      SUBROUTINE perturbation_gaussian
      USE global
      IMPLICIT NONE
      REAL*8  ::X1(1,NXP4), X2(1,NXP4), XC
      INTEGER :: IC
!
!---------------------------------------------------------------------
!
      XC = aint(0.5*NX)+1      ! Center of the system lenght
!--------- HOT Electron density perturbation ------------------------------
      DO IC = 1, NXP4
         X1(1,IC)=(IC -XC)*DX/L0;  ! Argument of gaussion purturbation
         X2(1,IC)=(IC -XC)*DX/L0V;  ! Argument of gaussion purturbation
      END DO
!
         DO 121 IC = 1, NXP4
         NI(1,IC)  = NI0 + DN*NI0*exp(0-X1(1,IC)**2)
         NCE(1,IC) = NCE0 + DN*NCE0*exp(0-X1(1,IC)**2)
         NHE(1,IC) = NHE0 + DN*NHE0*exp(0-X1(1,IC)**2)

         VXI(1,IC)  = VXI0 + DNV*exp(0-X2(1,IC)**2)
         VXCE(1,IC) = VXCE0 + DNV*exp(0-X2(1,IC)**2)
         VXHE(1,IC) = VXHE0 + DNV*exp(0-X2(1,IC)**2)

         PI(1,IC)   = NI(1,IC)*TI
         PCE(1,IC)  = NCE(1,IC)*TCE
         PHE(1,IC)  = NHE(1,IC)*THE

  121    CONTINUE
! ---- Boundary condition -------

!
      NI(2,:)  = NI(1,:)
      NCE(2,:) = NCE(1,:)
      NHE(2,:) = NHE(1,:)

      PI(2,:)  = PI(1,:)
      PCE(2,:) = PCE(1,:)
      PHE(2,:) = PHE(1,:)

      VXI(2,:)  = VXI(1,:)
      VXCE(2,:) = VXCE(1,:)
      VXHE(2,:) = VXHE(1,:)

      CALL poisson_sol_E2(NI(2,:), NCE(2,:),NHE(2,:), EX(2,:))
      CALL poisson_sol_E2(NI(1,:), NCE(1,:), NHE(1,:), EX(1,:))
!
      END SUBROUTINE perturbation_gaussian


module neuralnet
    use netcdf
    implicit none
    type Dense
        integer :: input_size
        integer :: output_size
        real(kind=8), allocatable :: weights(:, :)
        real(kind=8), allocatable :: bias(:)
        character(len=10) :: activation
    end type Dense

contains

    function apply_dense(layer, input)
        ! Description: Pass a set of input data through a single dense layer and nonlinear activation function
        !
        ! Args:
        ! layer (input): a single Dense object
        ! input (input): a 2D array where the rows are different examples and
        !   the columns are different model inputs
        !
        ! Returns:
        ! The output of the dense layer as a 2D array with shape (number of inputs, number of neurons)
        type(Dense), intent(in) :: layer
        real(kind=8), dimension(:, :), intent(in) :: input
        real(kind=8), dimension(size(input, 1), layer%output_size) :: apply_dense
        integer :: i, j
        apply_dense = matmul(input, layer%weights)
        do i=1, size(input, 1)
            do j=1, size(layer%bias)
                apply_dense(i, j) = apply_dense(i, j) + layer%bias(j)
            end do
        end do
        apply_dense = apply_activation(apply_dense, layer%activation)
        return
    end function apply_dense

    function apply_activation(input, activation_type)
        ! Description: Apply a nonlinear activation function to a given array of input values.
        !
        ! Args:
        ! input: A 2D array
        ! activation_type: string describing which activation is being applied. If the activation
        !       type does not match any of the available options, the linear activation is applied.
        !       Currently supported activations are:
        !           relu
        !           elu
        !           selu
        !           sigmoid
        !           tanh
        !           softmax
        !           linear
        ! Returns:
        ! activation_type: Array of the same dimensions as input with the nonlinear activation applied.
        real(kind=8), dimension(:, :), intent(in) :: input
        character(len=10), intent(in) :: activation_type
        real(kind=8), dimension(size(input, 1)) :: softmax_sum
        real(kind=8), dimension(size(input, 1), size(input, 2)) :: apply_activation
        real(kind=8), parameter :: selu_alpha = 1.6732
        real(kind=8), parameter :: selu_lambda = 1.0507
        integer :: i, j
        select case (trim(activation_type))
            case ("relu")
                where(input < 0)
                    apply_activation = 0
                elsewhere
                    apply_activation = input
                endwhere
            case ("elu")
                where(input < 0)
                    apply_activation = exp(input) - 1
                elsewhere
                    apply_activation = input
                end where
            case ("selu")
                where(input < 0)
                    apply_activation = selu_lambda * ( selu_alpha * exp(input) - selu_alpha)
                elsewhere
                    apply_activation = selu_lambda * input
                end where
            case ("sigmoid")
                apply_activation = 1.0 / (1.0 + exp(-input))
            case ("tanh")
                apply_activation = tanh(input)
            case ("softmax")
                softmax_sum = sum(exp(input), dim=2)
                do i=1, size(input, 1)
                    do j=1, size(input, 2)
                        apply_activation(i, j) = exp(input(i, j)) / softmax_sum(i)
                    end do
                end do
            case ("linear")
                apply_activation = input
            case default
                apply_activation = input
        end select
        return
    end function apply_activation

    subroutine init_neuralnet(filename, neural_net_model)
        ! init_neuralnet
        ! Description: Loads dense neural network weights from a netCDF file and builds an array of
        ! Dense types from the weights and activations.
        !
        ! Args:
        ! filename (input): Full path to the netCDF file
        ! neural_net_model (output): array of Dense layers composing a densely connected neural network
        !
        character(len=*), intent(in) :: filename
        type(Dense), allocatable, intent(out) :: neural_net_model(:)
        integer :: ncid, num_layers_id, num_layers
        integer :: layer_names_var_id, i, layer_in_dimid, layer_out_dimid
        integer :: layer_in_dim, layer_out_dim
        integer :: layer_weight_var_id
        integer :: layer_bias_var_id
        character(len=8), allocatable :: layer_names(:)
        character(len=10) :: num_layers_dim_name = "num_layers"
        character(len=11) :: layer_name_var = "layer_names"
        character (len=11) :: layer_in_dim_name
        character (len=12) :: layer_out_dim_name
        real (kind=8), allocatable :: temp_weights(:, :)
        ! Open netCDF file
        call check(nf90_open(filename, nf90_nowrite, ncid))
        ! Get the number of layers in the neural network
        call check(nf90_inq_dimid(ncid, num_layers_dim_name, num_layers_id))
        call check(nf90_inquire_dimension(ncid, num_layers_id, &
                                          num_layers_dim_name, num_layers))
        call check(nf90_inq_varid(ncid, layer_name_var, layer_names_var_id))
        allocate(layer_names(num_layers))
        call check(nf90_get_var(ncid, layer_names_var_id, layer_names))
        print *, "load neural network " // filename
        allocate(neural_net_model(num_layers))
        ! Loop through each layer and load the weights, bias term, and activation function
        do i=1, num_layers
            layer_in_dim_name = trim(layer_names(i)) // "_in"
            layer_out_dim_name = trim(layer_names(i)) // "_out"
            layer_in_dimid = -1
            ! Get layer input and output dimensions
            call check(nf90_inq_dimid(ncid, trim(layer_in_dim_name), layer_in_dimid))
            call check(nf90_inquire_dimension(ncid, layer_in_dimid, layer_in_dim_name, layer_in_dim))
            call check(nf90_inq_dimid(ncid, trim(layer_out_dim_name), layer_out_dimid))
            call check(nf90_inquire_dimension(ncid, layer_out_dimid, layer_out_dim_name, layer_out_dim))
            call check(nf90_inq_varid(ncid, trim(layer_names(i)) // "_weights", &
                                      layer_weight_var_id))
            call check(nf90_inq_varid(ncid, trim(layer_names(i)) // "_bias", &
                                      layer_bias_var_id))
            neural_net_model(i)%input_size = layer_in_dim
            neural_net_model(i)%output_size = layer_out_dim
            ! Fortran loads 2D arrays in the opposite order from Python/C, so I
            ! first load the data into a temporary array and then apply the
            ! transpose operation to copy the weights into the Dense layer
            allocate(neural_net_model(i)%weights(layer_in_dim, layer_out_dim))
            allocate(temp_weights(layer_out_dim, layer_in_dim))
            call check(nf90_get_var(ncid, layer_weight_var_id, &
                                    temp_weights))
            neural_net_model(i)%weights = transpose(temp_weights)
            deallocate(temp_weights)
            ! Load the bias weights
            allocate(neural_net_model(i)%bias(layer_out_dim))
            call check(nf90_get_var(ncid, layer_bias_var_id, &
                                    neural_net_model(i)%bias))
            ! Get the name of the activation function, which is stored as an attribute of the weights variable
            call check(nf90_get_att(ncid, layer_weight_var_id, "activation", &
                                    neural_net_model(i)%activation))
        end do
        print *, "finished loading neural network " // filename
        call check(nf90_close(ncid))

    end subroutine init_neuralnet

    subroutine neuralnet_predict(neuralnet_model, input, prediction)
        ! neuralnet_predict
        ! Description: generate prediction from neural network model for an arbitrary set of input values
        !
        ! Args:
        ! neuralnet_model (input): Array of type(Dense) objects
        ! input (input): 2D array of input values. Each row is a separate instance and each column is a model input.
        ! prediction (output): The prediction of the neural network as a 2D array of dimension (examples, outputs)

        type(Dense), intent(in) :: neuralnet_model(:)
        real(kind=8), intent(in) :: input(:, :)
        real(kind=8), allocatable, intent(out) :: prediction(:, :)
        real(kind=8), allocatable :: hidden_in(:, :)
        real(kind=8), allocatable :: hidden_out(:, :)
        integer :: i
        allocate(hidden_in(size(input, 1), size(input, 2)))
        hidden_in = input
        do i=1, size(neuralnet_model, 1)
            allocate(hidden_out(size(input, 1), &
                                neuralnet_model(i)%output_size))
            hidden_out = apply_dense(neuralnet_model(i), hidden_in)
            deallocate(hidden_in)
            allocate(hidden_in(size(hidden_out, 1), size(hidden_out, 2)))
            hidden_in = hidden_out
            deallocate(hidden_out)
        end do
        allocate(prediction(size(hidden_in, 1), size(hidden_in, 2)))
        prediction = hidden_in
        deallocate(hidden_in)
    end subroutine neuralnet_predict

    subroutine check(status)
        ! Check for netCDF errors
        integer, intent ( in) :: status
        if(status /= nf90_noerr) then
          print *, trim(nf90_strerror(status))
          stop 2
        end if
    end subroutine check

    subroutine print_2d_array(input_array)
        ! Print 2D array in pretty format
        real(kind=8), intent(in) :: input_array(:, :)
        integer :: i, j
        do i=1, size(input_array, 1)
            do j=1, size(input_array, 2)
                write(*, fmt="(1x,a,f6.3)", advance="no") "", input_array(i, j)
            end do
            write(*, *)
        end do
    end subroutine print_2d_array
end module neuralnet


program ua_pic_3d

use mesh_fields_m
use poisson_3d_m
use output_m
use particles_m
use compute_rho_cic_m
use interpolation_cic_m

implicit none

type(mesh_t)       :: mesh
type(fields_3d_t)  :: f
type(poisson_3d_t) :: poisson
type(particles_t)  :: p

real(8), parameter :: delta = 3.d-3
real(8), parameter :: ep    = 0.5d0**10
real(8)            :: pi

integer               :: istep
integer               :: n, m
integer,    parameter :: nx = 64, ny = 64, nz = 4
integer(8), parameter :: nbpart = nx * ny * 100
real(8)               :: xmin(3), xmax(3)
real(8)               :: dx, dy, dz
real(8)               :: err_x, err_y, err_z
integer               :: Nmrc
integer               :: N0mrc
integer               :: Nmrcm
integer               :: nstep
real(8)               :: Bm(3), Ee(3)
real(8)               :: dt
real(8)               :: time
real(8)               :: tfinal
real(8)               :: alpha
real(8)               :: beta

pi = 4d0 * atan(1d0)

xmin = [00d0, 00d0, 00d0]
xmax = [18d0, 18d0, 01d0]

tfinal = pi

Nmrc   = 2**7
Nmrcm  = 2**7
N0mrc  = nint(tfinal/ep/(2d0*pi)/Nmrc)
nstep  = 1

if (N0mrc == 0 .or. N0mrc == 1) then
    dt    = ep*(2d0*pi)/Nmrc
    nstep = nint(tfinal/dt)
else
    alpha = 0.5d0*(1d0+1d0/N0mrc)*ep*N0mrc
    beta  = 0.5d0*(1d0-1d0/N0mrc)*ep*N0mrc
    dt    = (2d0*pi)/Nmrcm
endif

call init_mesh( mesh, xmin(1), xmax(1), nx, &
                      xmin(2), xmax(2), ny, &
                      xmin(3), xmax(3), nz )

dx = mesh%dx
dy = mesh%dy
dz = mesh%dz

call init_fields( f, mesh )

call init_poisson( poisson, mesh)

print*, " number of particles = ", nbpart

call init_particles_3d( p, nbpart, mesh )

call compute_rho_cic( f, p)

print*, sum(f%rho) * dx * dy * dz, nbpart * p%w

call solve_poisson( poisson, f)

call write_data( 1, f)

call interpolate_eb_cic( p, f)

time  = 0.0_8

print"(a,9g10.3)", ' N0 = ', N0mrc, nstep

if (N0mrc == 0 .or. N0mrc == 1) then

    do istep = 1, nstep !*** Loop over time

        call push_particles(p, 0.5d0*dt)

        call compute_rho_cic(f, p)

        call solve_poisson(poisson, f)

        call interpolate_eb_cic( p, f )

        do m = 1, p%nbpart

            Bm(1) = (p%x(2,m)-9.d0)*delta/sqrt(1d0 &
                  +((p%x(1,m)-9d0)**2+(p%x(2,m)-9.d0)**2)*delta**2)

            Bm(2) =-(p%x(1,m)-9.d0)*delta/sqrt(1d0 &
                +((p%x(1,m)-9d0)**2+(p%x(2,m)-9.d0)**2)*delta**2)

            Bm(3) = 1d0/sqrt(1d0+((p%x(1,m)-9d0)**2+(p%x(2,m)-9d0)**2)*delta**2)

            Ee = p%e(:,m)

            p%v(:,m) = cos(dt/ep) * p%v(:,m) &
                     + sin(dt/ep) * cross(p%v(:,m),Bm) &
                     + ep * sin(dt/ep) * Ee &
                     + (dt-ep*sin(dt/ep)) * &
                       (Bm(1) * Ee(1)+Bm(2)*Ee(2) &
                     + Bm(3) * Ee(3)) * Bm &
                     + (ep - ep*cos(dt/ep))*cross(Ee,Bm) &
                     + (1.d0-cos(dt/ep))*(Bm(1)*p%v(1,m) &
                     + Bm(2)*p%v(2,m)+Bm(3)*p%v(3,m))*Bm
        end do

        p%x = p%x + 0.5d0 * dt * p%v

        time = time + dt

    end do ! next time step

else

    do istep = 1, Nmrc

        do n=1,Nmrcm

            call push_particles(p, 0.5d0*dt*alpha)

            call compute_rho_cic(f, p)
            call solve_poisson(poisson, f)
            call interpolate_eb_cic( p, f )

            do m=1,p%nbpart

                Bm(1) = (p%x(2,m)-9d0)*delta/sqrt(1d0+((p%x(1,m)-9d0)**2 &
                       +(p%x(2,m)-9d0)**2)*delta**2)
                Bm(2) =-(p%x(1,m)-9d0)*delta/dsqrt(1d0+((p%x(1,m)-9.d0)**2 &
                       +(p%x(2,m)-9d0)**2)*delta**2)
                Bm(3) = 1d0/dsqrt(1d0+((p%x(1,m)-9d0)**2 &
                       +(p%x(2,m)-9d0)**2)*delta**2)

                Ee = p%e(:,m)

                p%v(:,m) = cos(dt)*p%v(:,m)+sin(dt)*cross(p%v(:,m),Bm) &
                          + alpha*sin(dt)*Ee &
                          + alpha*(dt-sin(dt)) &
                          * (Bm(1)*Ee(1)+Bm(2)*Ee(2)+Bm(3)*Ee(3))*Bm &
                          + alpha*(1d0-cos(dt))*cross(Ee,Bm) &
                          + (1d0-cos(dt))*(Bm(1)*p%v(1,m) &
                          +                Bm(2)*p%v(2,m) &
                          +                Bm(3)*p%v(3,m)) * Bm
            end do

            call push_particles(p, 0.5d0*dt*alpha)

        end do

        do n = 1, Nmrcm

            call push_particles(p, 0.5d0*dt*beta)

            call compute_rho_cic(f, p)
            call solve_poisson(poisson, f)
            call interpolate_eb_cic( p, f )

            do m=1,p%nbpart

                Bm(1) = (p%x(2,m)-9d0)*delta/sqrt(1d0+((p%x(m,1)-9d0)**2 &
                       +(p%x(2,m)-9d0)**2)*delta**2)

                Bm(2) =-(p%x(1,m)-9d0)*delta/sqrt(1d0+((p%x(m,1)-9d0)**2 &
                       +(p%x(2,m)-9d0)**2)*delta**2)

                Bm(3) = 1d0/sqrt(1d0+((p%x(1,m)-9d0)**2 &
                       +(p%x(2,m)-9d0)**2)*delta**2)

                Ee = p%e(:,m)

                p%v(:,m) =  cos( dt) * p%v(:,m) &
                          + sin(-dt) * cross(p%v(:,m),Bm) &
                          - beta * sin(-dt) * Ee &
                          - beta * (-dt-dsin(-dt)) &
                          * dot_product(Ee,Bm) * Bm &
                          - beta * (1d0-cos(dt)) * cross(Ee,Bm) &
                          + (1d0-cos(dt))*(Bm(1)*p%v(1,m) &
                          + Bm(2) * p%v(2,m) + Bm(3) * p%v(3,m))*Bm
            end do

            call push_particles(p, 0.5d0*dt*beta)

        end do

        time = time + N0mrc * (2d0*pi)

    end do

end if

contains

pure function cross(v,w) result(res)

    real(8), intent(in) :: v(3)
    real(8), intent(in) :: w(3)
    real(8)             :: res(3)

    res(1) = v(2) * w(3) - v(3) * w(2)
    res(2) = v(3) * w(1) - v(1) * w(3)
    res(3) = v(1) * w(2) - v(2) * w(1)

end function cross

subroutine push_particles( p, delta_t )

    type(particles_t)   :: p
    real(8), intent(in) :: delta_t

    integer :: m
    real(8) :: d(3)

    do m = 1, p%nbpart !periodic BC

        d = delta_t * p%v(:,m) - xmin(:)

        p%x(1,m) = xmin(1) + modulo(p%x(1,m) + d(1), xmax(1) - xmin(1))
        p%x(2,m) = xmin(2) + modulo(p%x(2,m) + d(2), xmax(2) - xmin(2))
        p%x(3,m) = xmin(3) + modulo(p%x(3,m) + d(3), xmax(3) - xmin(3))

    end do

end subroutine push_particles

end program ua_pic_3d


!============================================================
!   phi functions adapted to fortran90
!   from Rita Ribeiro package uba
!   http://www.dcc.fc.up.pt/~rpribeiro/uba/uba_0.7.5.tar.gz
!============================================================

subroutine rtophi(n, y, method, npts, lparms, phiParms, yPhi, ydPhi, yddPhi)
!----------------------------------------------------------------
! Subroutine rtophi is used for obtaining and evaluating the relevance&
! fphion for a set of points of the target variable provided.
!----------------------------------------------------------------
!                n :: input, integer, the nr of points in y.
!              y(n):: input, real values, the target values.
!           method :: input, integer, the method used for obtaining &
!                     the relevance (0:extremes, 1:range)
!             npts :: input, integer, the number of points in the &
!                     relevance matrix
!           lparms :: input, integer, the length of phiParms argument
! phiParms(lparms) :: input, real values, the information on phi, &
!                     i.e., the successive y, phi(y) phi'(y)
!          yPhi(n) :: input/output, real values, evaluation of phi(y)
!         ydPhi(n) :: input/output, real values, evaluation of phi'(y)
!        yddPhi(n) :: input/output, real values, evaluation of phi''(y)
!----------------------------------------------------------------
! Authors:: P.Branco, R.Ribeiro 2016.04.22.
!----------------------------------------------------------------
! Dependences:: subroutine phiInit, subroutine phiEval ----------
!----------------------------------------------------------------
! References:: Ribeiro, R., 2011. PhiRelevance-based regression
!              (Doctoral dissertation, PhD thesis,
!              Dep. Computer Science, Faculty of Sciences -
!              University of Porto).
!----------------------------------------------------------------
	implicit none
	! Arguments
	integer (kind=4), intent(in) :: n, lparms, method, npts
	real   (kind=8), intent (in) :: y(n)
	real   (kind=8), intent (in) :: phiParms(lparms)
	real(kind=8), intent (inout) :: yPhi(n)
	real(kind=8), intent (inout) :: ydPhi(n)
	real(kind=8), intent (inout) :: yddPhi(n)
	!Local Variables
	real   (kind=8) :: x(npts), a(npts), b(npts), c(npts), d(npts) !,&
!						y_phi, yd_phi, ydd_phi
	integer(kind=4) :: i

	x=0.0d0
	a=0.0d0
	b=0.0d0
	c=0.0d0
	d=0.0d0
	i=1

	call phiSplInit(lparms, phiParms, npts, x, a, b, c, d)

	call phiEval(n, y, method, npts, x, a, b, c, d, yPhi, ydPhi, yddPhi)

contains

subroutine phiEval(n, y, method, npts, x, a, b, c, d, yPhi, ydPhi, yddPhi)
	!Arguments
	integer(kind=4), intent(in) :: n, method, npts
	real   (kind=8), intent(in) :: y(n)
	real(kind=8), intent(inout) :: yPhi(n), ydPhi(n), yddPhi(n)
	real   (kind=8), intent(in) :: x(npts), a(npts), b(npts), c(npts), d(npts)

	!Local Variables
	integer(kind=4) :: i
	real   (kind=8) :: yval, yvald, yvaldd
	do i=1, n
		call phiSplValue(y(i), method, n, npts, x, a, b, c, d, yval, yvald, yvaldd)
		yPhi(i) = yval
		ydPhi(i) = yvald
		yddPhi(i) = yvaldd

	end do

end subroutine phiEval

subroutine phiSplInit(lparms, phiParms, npts, x, a, b, c, d)
	!Arguments
	integer (kind=4), intent(in) :: lparms, npts
	real    (kind=8), intent(in) :: phiParms(lparms)
	real (kind=8), intent(inout) :: x(npts), a(npts), b(npts), c(npts), d(npts)

	!Local Variables
	integer (kind=4) :: i, n
	real    (kind=8) :: newm(npts), y(npts), m(npts)

	do i=1, npts
		x(i) = phiParms(3 * i - 2)
		y(i) = phiParms(3 * i - 1)
		m(i) = phiParms(3 * i)
	end do

	newm=m
	call pchipSet(npts, x, y, m, newm, c, d)

	a=y
	b=newm

end subroutine phiSplInit

subroutine phiSplValue( y, method, n, npts, x, a, b, c, d, yval, yvald, yvaldd)
	!Arguments
	integer(kind=4), intent(in) :: method, n, npts
	real   (kind=8), intent(in) :: y, x(npts), a(npts), b(npts), c(npts), d(npts)
	real(kind=8), intent(inout) :: yval, yvald, yvaldd

	!Local Variables
	integer(kind=4) :: extrapol ! //linear

	extrapol = 0
	call pchipVal(npts, x, a, b, c, d, y, extrapol, yval, yvald, yvaldd)

end subroutine phiSplValue

!============================================================
!
!    pchip: Piecewice Cubic Hermite Interpolating Polynomial
!
!============================================================
subroutine pchipVal(npts, x, a, b, c, d, xval, extrapol, yval, yvald, yvaldd)
!----------------------------------------------------------------
! Subroutine pchipVal is used to evaluate the cubic polynomial.
! It finds, from the left, which is the interval that contains
! or is nearest to xval.
! Check for linear extrapolation.
! Use cubic Hermite polynomials, even for extrapolation.
!----------------------------------------------------------------
!    npts :: input, integer, nr of points in the reevance matrix
!  x(npts):: input, real values, pchip coeficients
! a(npts) :: input, real values, pchip coeficients
! b(npts) :: input, real values, pchip coeficients
! c(npts) :: input, real values, pchip coeficients
! d(npts) :: input, real values, pchip coeficients
!    xval :: input, real value, x value where the relevance function &
!            will be evaluated
!extrapol :: input, integer, used for linear extrapolation
!    yval :: input/output, real value, relevance value obtained in &
!            xval ( phi(xval) )
!   yvald :: input/output, real value, relevance derivative evaluated &
!            in xval ( phi'(xval) )
!  yvaldd :: input/output, real value, relevance second derivative &
!            in xval ( phi''(xval) )
!----------------------------------------------------------------
! Authors:: P.Branco, R.Ribeiro 2016.04.22.
!----------------------------------------------------------------
! Dependence:: subroutine findInterval.--------------------------
!----------------------------------------------------------------
! References:: Ribeiro, R., 2011. PhiRelevance-based regression
!              (Doctoral dissertation, PhD thesis,
!              Dep. Computer Science, Faculty of Sciences -
!              University of Porto).
!----------------------------------------------------------------
	implicit none
	!Arguments
	integer (kind=4), intent(in) :: npts, extrapol
	real    (kind=8), intent(in) :: x(npts), a(npts), b(npts), c(npts), d(npts), xval
	real (kind=8), intent(inout) :: yval, yvald, yvaldd

	!Local Variables
	integer(kind=4) :: i, rightmostClosed, allInside, mfl, left
	real   (kind=8) :: s

	i = 1
	left = 1
	rightmostClosed = 0
	allInside = 0
	mfl = 0
	s=0.0d0
	! result of findInterval in variable left
	call findInterval(x, npts, xval, rightmostClosed, allInside, i,&
						mfl, left)
	i = left

	!// if extrapol is linear
	if (extrapol == 0 .and. (i == 0 .or. i == npts))then
		if (i == 0) then
			i = i + 1
		end if
		yval = a(i) + b(i) * (xval - x(i))
		yvald = b(i)
		yvaldd = 0 ! // This is the case where ydd does not exist
		return
	end if

	s = xval -x(i)

	yval = a(i) + s * (b(i) + s * (c(i) + s * d(i)))
	yvald = b(i) + s * (2 * c(i) + s * (3 * d(i)))
	yvaldd = 2 * c(i) + s * 6 * d(i)

end subroutine pchipVal

!============================================================
!
!    pchip: Piecewice Cubic Hermite Interpolating Polynomial
!
!============================================================
subroutine pchipSet(npts, x, y, m, newm, c, d)
!----------------------------------------------------------------
! Subroutine pchip_set() is used for
!----------------------------------------------------------------
!       npts :: input, integer, the number of points in the
!               relevance matrix.
!    x(npts) :: input/output, real values,
!    y(npts) :: input/output, real values,
!    m(npts) :: input, real values, initial slopes.
! newm(npts) :: input/output, real values, adjusted slopes.
!    c(npts) :: input/output, real values, coeficients
!    d(npts) :: input/output, real values,
!----------------------------------------------------------------
! Authors:: P.Branco, R.Ribeiro 2016.04.22.
!----------------------------------------------------------------
! Dependence:: subroutine pchipSlopeMonoFC.----------------------
!----------------------------------------------------------------
! References:: Ribeiro, R., 2011. PhiRelevance-based regression
!              (Doctoral dissertation, PhD thesis,
!              Dep. Computer Science, Faculty of Sciences
!              University of Porto).
!----------------------------------------------------------------
	implicit none
	! Arguments
	integer(kind=4), intent(in) :: npts
	real(kind=8), intent(inout) :: x(npts), y(npts), newm(npts), c(npts), d(npts)
	real   (kind=8), intent(in) :: m(npts)

	! Local Variables
	integer(kind=4) :: i
	real   (kind=8) :: h(npts), delta(npts)

	do i=1, npts-1
		h(i) = x(i+1) - x(i)
		delta(i) = (y(i+1) - y(i))/ h(i)
	end do

	call pchipSlopeMonoFC(npts, newm, delta) ! adjusts newm values

	do i=1, npts-1
		c(i) = (3*delta(i) - 2 * newm(i) - newm(i+1)) / h(i)
		d(i) = (newm(i) - 2 * delta(i) + newm(i+1)) / (h(i) * h(i))
	end do

end subroutine pchipSet

subroutine pchipSlopeMonoFC(npts, newm, delta)
!----------------------------------------------------------------
! Subroutine pchipSlopeMonoFC obtains slopes for shape-preserving
! Hermite cubic polynomials. Modify the slopes  m_k := s'(x_k)
! using Fritsch & Carlson (1980)'s algorithm.
! Adapted
!----------------------------------------------------------------
!        npts :: input, integer, the number of points in the
!                relevance matrix.
! delta(npts) :: input, real values, pchip auxiliar coeficients.
!  newm(npts) :: input/output, real values, the slope adjusted values.
!----------------------------------------------------------------
! Authors:: P.Branco R.Ribeiro 2016.04.22.
!----------------------------------------------------------------
! Dependence:: none. --------------------------------------------
!----------------------------------------------------------------
! References:: Fritsch, F.N. and Carlson, R.E., 1980.
!              Monotone piecewise cubic interpolation.
!              SIAM Journal on Numerical Analysis, 17(2), pp.238-246.
!              and
!              Ribeiro, R., 2011. PhiRelevance-based regression
!              (Doctoral dissertation, PhD thesis,
!              Dep. Computer Science, Faculty of Sciences
!              University of Porto).
!----------------------------------------------------------------
	implicit none
	! Arguments
	integer(kind=4), intent(in) :: npts
	real   (kind=8), intent(in) :: delta(npts)
	real(kind=8), intent(inout) :: newm(npts)

	! Local Variables
	integer(kind=4) :: k, k1
	real   (kind=8) :: Sk, alpha, beta, a2b3, ab23, tauS

	do k=1,npts-1 ! modify both newm(i) and newm(i+1) if needed
		Sk = delta(k)
		k1 = k + 1

		if (abs(Sk) == 0) then
			newm(k) = 0.0d0
			newm(k1) = 0.0d0
		else
			alpha = newm(k) / Sk
			beta = newm(k1) / Sk
			if (abs(newm(k)) /= 0 .and. alpha < 0) then
				newm(k) = - newm(k)
				alpha = newm(k) / Sk
			end if

			if (abs(newm(k1)) /= 0 .and. beta < 0) then
				newm(k1) = -newm(k1)
				beta = newm(k1) / Sk
			end if

			a2b3 = 2 * alpha + beta - 3
			ab23 = alpha + 2 * beta - 3

			if (a2b3 > 0 .and. ab23 > 0 .and. &
				alpha * (a2b3 + ab23) < a2b3 * a2b3) then
				!we are outside the monotonocity region ==> fix slopes
				tauS = 3 * Sk / sqrt(alpha * alpha + beta * beta)
				newm(k) = tauS * alpha
				newm(k1) = tauS * beta
			end if
		end if
	end do

end subroutine pchipSlopeMonoFC

subroutine findInterval(xt, npts, x, rightmostClosed, allInside, ilo,&
						mflag, left)
!----------------------------------------------------------------
! Subroutine findInterval determines in which interval a case is.
! Adaptation of findInterval function in Applic.h in c to fortran 90
!----------------------------------------------------------------
!        xt(npts) :: input, real values, numeric vector of length n,&
!                    assumed to be nondecreasing
!            npts :: input, integer, length of xt
!               x :: input, real value, the point whose location with&
!                    respect to the sequence  xt  is to be determined.
! rightmostClosed :: input, integer, binary parameter setting if right&
!                    interval is closed
!       allInside :: input, integer, binary parameter setting is all &
!                    points should be inside the extremes
!             ilo :: input, integer, last iteration returned interval
!           mflag :: input/output, integer, flag for signalling if the&
!                    point is outside or outside the given points
!            left :: input/output, integer, the result obtained for the&
!                    interval index
!----------------------------------------------------------------
! Authors:: P.Branco 2016.04.22.
!----------------------------------------------------------------
! Dependences:: subroutine gotoL50, subroutine leftBoundary, subroutine&
!               rightBoundary.
!----------------------------------------------------------------
! References::
!----------------------------------------------------------------
	implicit none
	!Arguments
	integer    (kind=4), intent(in) :: npts, rightmostClosed, allInside
	integer (kind=4), intent(inout) :: mflag, left, ilo
	real       (kind=8), intent(in) :: xt(npts), x

	!Local Variables
	integer(kind=4) :: istep, ihi

	if (ilo <= 0) then
		if (x < xt(1)) then
			call leftBoundary(mflag, allInside, left)
			return
		end if
		ilo = 1
	end if

	ihi = ilo + 1

	if (ihi >= npts) then
		if (x >= xt(npts)) then
			call rightBoundary(xt, npts, x, mflag, allInside, &
								rightmostClosed, left)
			return
		end if
		if (npts <= 1) then
			call leftBoundary(mflag, allInside, left)
			return
		end if
		ilo = npts - 1
		ihi = npts
	end if

	if (x < xt(ihi)) then
		if (x >= xt(ilo)) then ! /* `lucky': same interval as last time */
			mflag = 0
			left = ilo
			return
		end if
		!/* **** now x < xt[ilo] .   decrease  ilo  to capture  x */
		istep = 1
		do while (ilo > 1)
			ihi = ilo
			ilo = ihi - istep
			if (x >= xt(ilo)) then
				call gotoL50(xt, npts, x, ilo, ihi, mflag, left)
				return
			end if
			istep = istep * 2
		end do
		ilo = 1
		if (x < xt(1)) then
			call leftBoundary(mflag, allInside, left)
			return
		end if

	else
		!/* **** now x >= xt[ihi] .  increase  ihi  to capture  x */
		istep = 1
		do while (ihi < npts)
			ilo = ihi
			ihi = ilo + istep
			if (ihi >= npts) then
				exit
			end if
			if (x < xt(ihi)) then
				call gotoL50(xt, npts, x, ilo, ihi, mflag, left)
				return
			end if
			istep = istep * 2
		end do

		if (x >= xt(npts)) then
			call rightBoundary(xt, npts, x, mflag, allInside, &
								rightmostClosed, left)
			return
		end if
		ihi = npts
	end if

	call gotoL50(xt, npts, x, ilo, ihi, mflag, left)

end subroutine findInterval

subroutine leftBoundary(mflag, allInside, left)
	implicit none
	!Arguments
	integer(kind=4), intent(inout) :: mflag, left
	integer   (kind=4), intent(in) :: allInside

	mflag = -1
	if (allInside == 1) then
		left = 1
	else
		left = 0
	end if
	return
end subroutine leftBoundary

subroutine rightBoundary(xt, npts, x, mflag, allInside, rightmostClosed, left)
	implicit none
	!Arguments
	integer   (kind=4), intent(in) :: npts, allInside, rightmostClosed
	integer(kind=4), intent(inout) :: mflag, left
	real      (kind=8), intent(in) :: xt(npts), x

	mflag = +1
	if (allInside == 1 .or. (rightmostClosed == 1 .and. x == xt(npts))) then
		left = npts-1
	else
		left = npts
	end if
	return
end subroutine rightBoundary

subroutine gotoL50(xt, npts, x, ilo, ihi, mflag, left)
	implicit none
	!Arguments
	integer   (kind=4), intent(in) :: npts
	integer(kind=4), intent(inout) :: mflag, left, ilo, ihi
	real      (kind=8), intent(in) :: xt(npts), x

	!Local Variables
	integer (kind=4) :: middle

    !* **** now xt[ilo] <= x < xt[ihi] . narrow the interval. */
	do
		middle = (ilo + ihi) / 2
		if (middle == ilo) then
			mflag = 0
			left = ilo
			return
		end if
		!/* note. it is assumed that middle = ilo in case ihi = ilo+1 . */
		if (x >= xt(middle)) then
			ilo = middle
		else
			ihi = middle
		end if
	end do
end subroutine gotoL50

end subroutine rtophi


      SUBROUTINE proma3(a,b,c,n1,n3,zeros)
!********************************************************************
!
!***this routine evaluates a matrix-vector product adding over a
!
!           a(i) = b(i,k) * c(k)    a = b * c
!
!********************************************************************
      IMPLICIT NONE

      INTEGER (kind=4),INTENT(IN) :: n1,n3
      REAL (kind=8),INTENT(IN) :: b(n1,n3), c(n3)
      REAL (kind=8),INTENT(OUT) :: a(n1)
      LOGICAL(kind=4),INTENT(IN) :: zeros

      IF (zeros) THEN
        a = MATMUL(b,c)
      ELSE
        a = a + MATMUL(b,c)
      END IF
      RETURN

      END SUBROUTINE proma3


module gpfunc
implicit none

type, abstract :: GP
  contains
  procedure(kern_elem), deferred, nopass :: kern
  procedure :: build_K_poly
end type GP

type, extends(GP) :: SqExpGP
  contains
  procedure, nopass :: kern => kern_sqexp_elem
end type SqExpGP

type Kernel
    procedure(abstract_kern), pointer, nopass :: kern
end type Kernel

type Kernel1D
    procedure(kern_1d), pointer, nopass :: kern
end type Kernel1D

type CompositeKernel
    type(Kernel1D), allocatable :: kernels(:)
end type CompositeKernel

abstract interface
    pure function kern_elem(ndim, xa, xb)
      integer, intent(in) :: ndim
      real(8), intent(in) :: xa(ndim), xb(ndim)
      real(8) :: kern_elem
    end function kern_elem

    subroutine abstract_kern(np, ndim, xa, xb, out)
        integer, intent(in) :: np, ndim
        real(8), intent(in) :: xa(np,ndim), xb(ndim)
        real(8), intent(out) :: out(np)
    end subroutine abstract_kern

    subroutine kern_1d(np, xa, xb, out)
        integer, intent(in) :: np
        real(8), intent(in) :: xa(np), xb
        real(8), intent(out) :: out(np)
    end subroutine kern_1d

end interface

contains

! Build kernel matrix polymorphism
subroutine build_K_poly(this, np, ndim, xa, xb, K)
  class(GP) :: this
  integer, intent(in)    :: np, ndim
  real(8), intent(in)    :: xa(ndim, np), xb(ndim, np) ! Points and hyperparams
  real(8), intent(inout) :: K(np, np)  ! Result matrix

  integer :: ka, kb

  !$omp parallel do
  do kb = 1, size(xb, 2)
    do ka = 1, size(xa, 2)
      K(ka, kb) = this%kern(ndim, xa(:, ka), xb(:, kb))
    end do
  end do

end subroutine build_K_poly

! Build kernel matrix
subroutine build_K(np, ndim, xa, xb, K, kern)
  integer, intent(in)    :: np, ndim
  real(8), intent(in)    :: xa(ndim, np), xb(ndim, np) ! Points and hyperparams
  real(8), intent(inout) :: K(np, np)  ! Result matrix
  external :: kern  ! Kernel function
  real(8) :: kern   ! Have to split these in two lines for f2py

  integer :: ka, kb

  !$omp parallel do
  do kb = 1, size(xb, 2)
    do ka = 1, size(xa, 2)
      K(ka, kb) = kern(ndim, xa(:, ka), xb(:, kb))
    end do
  end do

end subroutine build_K

subroutine build_K_sqexp(np, ndim, xa, xb, K)
  integer, intent(in)    :: np, ndim
  real(8), intent(in)    :: xa(np, ndim)
  real(8), intent(in)    :: xb(np, ndim)
  real(8), intent(inout) :: K(np, np)     ! Result matrix

  integer :: ka, kb

  !$omp parallel do
  do kb = 1, np
    !$omd simd
    do ka = 1, np
      K(ka, kb) = exp(-0.5d0*sum((xa(ka, :) - xb(kb, :))**2))
    end do
  end do
  !$omp end parallel do
end subroutine build_K_sqexp

subroutine build_K_sqexp_T(np, ndim, xa, xb, K)
  integer, intent(in)    :: np, ndim
  real(8), intent(in)    :: xa(ndim, np)
  real(8), intent(in)    :: xb(ndim, np)
  real(8), intent(inout) :: K(np, np)     ! Result matrix

  integer :: ka, kb

  !$omp parallel do
  do kb = 1, np
    !$omd simd
    do ka = 1, np
      K(ka, kb) = exp(-sum((xa(:, ka) - xb(:, kb))**2/2d0))
    end do
  end do
  !$omp end parallel do
end subroutine build_K_sqexp_T

subroutine build_ldKdl_sqexp(np, ndim, xa, xb, dim, dKdl)
  ! Returns matrix of l_d*dk/dl_d for dimension d
  integer, intent(in)    :: np, ndim
  real(8), intent(in)    :: xa(np, ndim)
  real(8), intent(in)    :: xb(np, ndim)
  integer, intent(in)    :: dim            ! Dimension towards to differentiate
  real(8), intent(inout) :: dKdl(np, np)   ! Derivative matrix

  real(8) :: xdiff(np, ndim)
  integer :: ka, kb

  do kb = 1, np
    do ka = 1, np
      dKdl(ka, kb) = -xdiff(ka, dim)*exp(-sum((xa(ka, :) - xb(kb, :))**2/2d0))
    end do
  end do
end subroutine build_ldKdl_sqexp

pure function kern_sqexp_elem(ndim, xa, xb)
    integer, intent(in) :: ndim
    real(8), intent(in) :: xa(ndim), xb(ndim)
    real(8) :: kern_sqexp_elem

    kern_sqexp_elem = exp(-0.5d0*sum((xa - xb)**2))

end function kern_sqexp_elem

subroutine kern_sqexp_vec(np, ndim, xa, xb, out)
    integer, intent(in) :: np, ndim
    real(8), intent(in) :: xa(np,ndim), xb(ndim)
    real(8), intent(out) :: out(np)

    integer :: ka

    !$omp simd
    do ka = 1, np
        out(ka) = exp(-sum((xa(ka, :) - xb)**2/2d0))
    end do

end subroutine kern_sqexp_vec

subroutine kern_sqexp_vec_T(np, ndim, xa, xb, out)
  integer, intent(in) :: np, ndim
  real(8), intent(in) :: xa(ndim, np), xb(ndim)
  real(8), intent(out) :: out(np)

  integer :: ka

  !$omp simd
  do ka = 1, np
      out(ka) = exp(-sum((xa(:, ka) - xb)**2/2d0))
  end do

end subroutine kern_sqexp_vec_T

! Build kernel matrix
subroutine build_K_vec(np, ndim, xa, xb, K, kern)
    integer, intent(in)    :: np, ndim
    real(8), intent(in)    :: xa(np, ndim), xb(np, ndim) ! Points and hyperparams
    real(8), intent(inout) :: K(np, np)  ! Result matrix
    external :: kern  ! Kernel function

    integer :: kb

    !$omp parallel do
    do kb = 1, np
        call kern(np, ndim, xa, xb(kb, :), K(:, kb))
    end do
    !$omp end parallel do

  end subroutine build_K_vec

! Build kernel matrix
subroutine build_K_vec_T(np, ndim, xa, xb, K, kern)
    integer, intent(in)    :: np, ndim
    real(8), intent(in)    :: xa(ndim, np), xb(ndim, np) ! Points and hyperparams
    real(8), intent(inout) :: K(np, np)  ! Result matrix
    external :: kern  ! Kernel function

    integer :: kb

    !$omp parallel do
    do kb = 1, np
        call kern(np, ndim, xa, xb(:, kb), K(:, kb))
    end do
    !$omp end parallel do

end subroutine build_K_vec_T

!-------------------------------------------------------------------------------
! Row-wise kernel with derived type and function pointer
subroutine build_K_der(np, ndim, xa, xb, K, kern)
    integer, intent(in)    :: np, ndim
    real(8), intent(in)    :: xa(np, ndim), xb(np, ndim) ! Points and hyperparams
    real(8), intent(inout) :: K(np, np)  ! Result matrix
    type(Kernel) :: kern  ! Kernel function container

    integer :: kb

    !$omp parallel do
    do kb = 1, np
        call kern%kern(np, ndim, xa, xb(kb, :), K(:, kb))
    end do
    !$omp end parallel do

end subroutine build_K_der

subroutine kern_sqexp_1D(np, xa, xb, out)
    integer, intent(in) :: np
    real(8), intent(in) :: xa(np), xb
    real(8), intent(out) :: out(np)

    out = exp(-(xa - xb)**2/2d0)

end subroutine kern_sqexp_1D

subroutine kern_one_1D(np, xa, xb, out)
  integer, intent(in) :: np
  real(8), intent(in) :: xa(np), xb
  real(8), intent(out) :: out(np)

  out = 1d0

end subroutine kern_one_1D

!-------------------------------------------------------------------------------
! Column-wise kernel with derived type and function pointer
subroutine build_K_prod(np, ndim, xa, xb, K, kerns)
    integer, intent(in)    :: np, ndim
    real(8), intent(in)    :: xa(np, ndim), xb(np, ndim) ! Points and hyperparams
    real(8), intent(inout) :: K(np, np)  ! Result matrix
    type(CompositeKernel) :: kerns  ! Kernel function container

    real(8) :: col(np)
    integer :: kb, kd

    K = 1d0

    !$omp parallel do private(col)
    do kd = 1, ndim
        do kb = 1, np
            call kerns%kernels(kd)%kern(np, xa(:, kd), xb(kb, kd), col)
            K(:, kb) = K(:, kb)*col
        end do
    end do
    !$omp end parallel do

end subroutine build_K_prod

subroutine kern_sqexp_vec2(nd, nx, x0, x1, out)
implicit none
INTEGER*4, intent(in) :: nd
INTEGER*4, intent(in) :: nx
REAL*8, intent(in), dimension(1:nd, 1:nx) :: x0
REAL*8, intent(in), dimension(1:nd, 1:nx) :: x1
REAL*8, intent(out), dimension(1:nd, 1:nx) :: out
INTEGER*4 :: kd
INTEGER*4 :: kx
do kx = 1, nx
   do kd = 1, nd
      out(kd, kx) = exp(-0.5d0*(-x0(kd, kx) + x1(kd, kx))**2)
   end do
end do
end subroutine

! Build kernel matrix
subroutine build_K_interface(np, ndim, xa, xb, K, kern)
  integer, intent(in)    :: np, ndim
  real(8), intent(in)    :: xa(ndim, np), xb(ndim, np) ! Points and hyperparams
  real(8), intent(inout) :: K(np, np)  ! Result matrix

  interface
    pure function kern(ndim, xa, xb)
      integer, intent(in) :: ndim
      real(8), intent(in) :: xa(ndim), xb(ndim)
      real(8) :: kern
    end function kern
  end interface

  integer :: ka, kb

  !$omp parallel do
  do kb = 1, size(xb, 2)
    do ka = 1, size(xa, 2)
      K(ka, kb) = kern(ndim, xa(:, ka), xb(:, kb))
    end do
  end do

end subroutine build_K_interface

end module gpfunc


module mod_common_subrs
  use mod_wrf_file
  implicit none
contains

  !-------------------------------------------------------------------------------
  ! This module contains some general subroutines which can be used both
  ! generalized omega equation and Zwack-okossi equation.
  !-------------------------------------------------------------------------------

  function calmul(psfc,lev,nlev) result (mulfact)
    !   Calculation of multiplication factors for the attenuation of
    !   below-ground forcings
    real,dimension(:,:),  intent(in) :: psfc
    real,dimension(:),    intent(in) :: lev
    integer,              intent(in) :: nlev
    real,dimension(:,:,:),allocatable :: mulfact
    real :: pm1
    integer :: i,j,k,nlon,nlat,factor
    nlon=size(psfc,1); nlat=size(psfc,2)
    allocate(mulfact(nlon,nlat,nlev))
    factor=2

    select case (factor)

    case (1) ! old version
       mulfact=1.
       do i=1,nlon
          do j=1,nlat
             do k=1,nlev-1
                if(psfc(i,j) .le. lev(k+1) )then
                   mulfact(i,j,k)=0.
                else
                   if(psfc(i,j).le.lev(k))then
                      mulfact(i,j,k)=(psfc(i,j)-lev(k+1))/(lev(k)-lev(k+1))
                      !mulfact(i,j,k)=0.
                   endif
                endif
             enddo
          enddo
       enddo

    case (2) ! new version with mass-centered cells
       mulfact=1.
       do i=1,nlon
          do j=1,nlat
             do k=1,nlev-1
                if(k==1)then
                   pm1=2*lev(1)-lev(2)
                else
                   pm1=lev(k-1)
                end if
                if (psfc(i,j) <= lev(k)-((lev(k)-lev(k+1))/2) )then
                   mulfact(i,j,k)=0.
                else if (psfc(i,j) > lev(k)-((lev(k)-lev(k+1))/2) .and. &
                     psfc(i,j) <= lev(k)+((pm1-lev(k))/2)) then
                   mulfact(i,j,k)=(psfc(i,j)-(lev(k+1)+(lev(k)-lev(k+1))/2))&
                        /((pm1-lev(k))/2+(lev(k)-lev(k+1))/2)
                else if (psfc(i,j) >= (2*lev(1)-lev(2))) then
                   mulfact(i,j,k) = 1 + (psfc(i,j)-((lev(1)+pm1)/2))/&
                        (pm1-lev(1))
                endif
             enddo
          enddo
       enddo

    end select
  end function calmul

  subroutine irrotationalWind(u,v,dx,dy,uKhi,vKhi)
    !   This subroutine calculates irrotational wind components (uKhi,vKhi) from
    !   velocity potential.
    use mod_poisson_DFT
    implicit none

    real,dimension(:,:,:),intent(in) :: u,v
    real,                 intent(in) :: dx,dy
    real,dimension(:,:,:),intent(out) :: uKhi,vKhi

    integer :: nlon,nlat,nlev,k
    double precision, dimension ( : ), allocatable ::  bd_0
    real,dimension(:,:,:),allocatable :: dudx,dvdy,khi,dkhidx,dkhidy

    nlon=size(u,1); nlat=size(u,2); nlev=size(u,3)
    allocate(khi(nlon,nlat,nlev))
    allocate(bd_0(nlon+1))

    !   Calculate the divergence of wind
    dudx = xder_cart(u,dx)
    dvdy = yder_cart(v,dy)

    !   Velocity potential is equal to inverse laplacian of divergence

    bd_0=0.0e0
    do k=1,nlev
       call poisson_solver_2D(dudx(:,:,k)+dvdy(:,:,k),dx,dy,khi(:,:,k),&
            bd_0,bd_0)
    enddo

    !   Derivatives of velocity potential
    dkhidx = xder_cart(khi,dx)
    dkhidy = yder_cart(khi,dy)

    !   Wind components are equal to derivatives
    uKhi=dkhidx
    vKhi=dkhidy

  end subroutine irrotationalWind

  function curl_cart ( u, v, dx, dy ) result ( zeta )
    real, dimension ( :, :, : ), intent ( in ) :: u, v
    real,                        intent ( in ) :: dx,dy
    real, dimension ( :, :, : ), allocatable :: zeta, du_dy, dv_dx

    allocate ( zeta ( size (u, 1 ), size ( u, 2 ), &
         size ( u, 3 ) ) )

    du_dy = yder_cart(u,dy)
    dv_dx = xder_cart(v,dx)
    zeta = dv_dx - du_dy

  end function curl_cart

  function pder(f,dp) result (dfdp)
    !   Estimation of pressure derivatives.
    !   One-sided derivatives are used at top and bottom levels
    !   Accuracy=1 means second-order accuracy
    !   Accuracy=2 fourth-order accuracy
    implicit none

    real,dimension(:,:,:),intent(in) :: f
    real,                 intent(in) :: dp
    real,dimension(:,:,:),allocatable :: dfdp
    real :: inv_dp
    integer :: nlon,nlat,nlev,accuracy,k

    nlon=size(f,1); nlat=size(f,2); nlev=size(f,3)
    allocate(dfdp(nlon,nlat,nlev))
    inv_dp = 1.0 / (2.*dp)
    accuracy=1
    select case (accuracy)

    case(1)
       dfdp(:,:,2:nlev-1)=f(:,:,3:nlev)-f(:,:,1:nlev-2)
       dfdp(:,:,2:nlev-1)=dfdp(:,:,2:nlev-1)*inv_dp

       dfdp(:,:,1)=(f(:,:,2)-f(:,:,1))/dp
       dfdp(:,:,nlev)=(f(:,:,nlev)-f(:,:,nlev-1))/dp
    case(2)
       do k=3,nlev-2
          dfdp(:,:,k)=f(:,:,k-2)-8.*f(:,:,k-1)+8.*f(:,:,k+1) &
               -f(:,:,k+2)
          dfdp(:,:,k)=dfdp(:,:,k)/(12.*dp)
       enddo
       dfdp(:,:,2)=(dfdp(:,:,3)-dfdp(:,:,1))/(2.*dp)
       dfdp(:,:,nlev-1)=(dfdp(:,:,nlev)-dfdp(:,:,nlev-2))/(2.*dp)
       dfdp(:,:,1)=(f(:,:,2)-f(:,:,1))/dp
       dfdp(:,:,nlev)=(f(:,:,nlev)-f(:,:,nlev-1))/dp

    end select

  end function pder

  function xder_cart(f,dx) result(dfdx)
    !   Calculation of x derivatives. Periodic domain in x assumed
    implicit none

    real,dimension(:,:,:),intent(in) :: f
    real,                 intent(in) :: dx
    real,dimension(:,:,:),allocatable  :: dfdx
    real :: inv_dx
    integer :: i,j,k,nlon,nlat,nlev,i1,i2,acc,i_1,i_2
    nlon=size(f,1); nlat=size(f,2); nlev=size(f,3)
    allocate(dfdx(nlon,nlat,nlev))
    acc=1
    inv_dx = 1.0 / (2.*dx)

    select case (acc)
    case (1)
       do k=1,nlev
          do j=1,nlat
             do i=1,nlon
                i1=max(i-1,1)
                i2=min(i+1,nlon)
                if(i1.eq.i)i1=nlon
                if(i2.eq.i)i2=1
                dfdx(i,j,k)=(f(i2,j,k)-f(i1,j,k))*inv_dx
             enddo
          enddo
       enddo
    case (2)
       do k=1,nlev
          do j=1,nlat
             do i=1,nlon
                i_2=i-2
                i_1=i-1
                i1=i+1
                i2=i+2
                if(i==2)i_2=nlon
                if(i==1)then
                   i_2=nlon-1
                   i_1=nlon
                end if
                if(i==nlon-1)i2=1
                if(i==nlon)then
                   i1=1
                   i2=2
                end if
                dfdx(i,j,k)=(f(i_2,j,k)-8*f(i_1,j,k)+8*f(i1,j,k)-f(i2,j,k))&
                     /(12*dx)
             enddo
          enddo
       enddo
    end select

  end function xder_cart

  function yder_cart(f,dy) result(dfdy)
    !   Calculation of y derivatives
    !   One-sided estimates are used at the southern and northern boundaries
    implicit none

    real,dimension(:,:,:),intent(in) :: f
    real,                 intent(in) :: dy
    real,dimension(:,:,:),allocatable  :: dfdy
    real :: inv_dy
    integer :: i,j,k,nlon,nlat,nlev,acc
    nlon=size(f,1); nlat=size(f,2); nlev=size(f,3)
    allocate(dfdy(nlon,nlat,nlev))
    inv_dy = 1.0 / (2.*dy)
    acc=1
    select case(acc)

    case(1)
       do k=1,nlev
          do j=2,nlat-1
             do i=1,nlon
                dfdy(i,j,k)=(f(i,j+1,k)-f(i,j-1,k))*inv_dy
             enddo
          enddo
       enddo
       dfdy(:,1,:)=(f(:,2,:)-f(:,1,:))/dy
       dfdy(:,nlat,:)=(f(:,nlat,:)-f(:,nlat-1,:))/dy

    case (2)
       do k=1,nlev
          do j=1,nlat
             do i=1,nlon
                if(j==2)then
                   dfdy(i,2,k)=(f(i,3,k)-f(i,1,k))/(2*dy)
                else if(j==1)then
                   dfdy(i,1,k)=(-f(i,3,k)+4*f(i,2,k)-3*f(i,1,k))/(2*dy)
                else if(j==nlat-1)then
                   dfdy(i,nlat-1,k)=(f(i,nlat,k)-f(i,nlat-2,k))/(2*dy)
                else if(j==nlat)then
                   dfdy(i,nlat,k)=(f(i,nlat-2,k)-4*f(i,nlat-1,k) &
                        +3*f(i,nlat,k))/(2*dy)
                else
                   dfdy(i,j,k)=(f(i,j-2,k)-8*f(i,j-1,k)+8*f(i,j+1,k)&
                        -f(i,j+2,k))/(12*dy)
                end if
             enddo
          enddo
       enddo
    end select

  end function yder_cart

  function advect_cart(u,v,f,dx,dy) result(adv)
    !   Computing u*dfdx + v*dfdy in cartesian coordinates
    implicit none

    real,dimension(:,:,:),intent(in) :: u,v,f
    real,                 intent(in) :: dx,dy
    real,dimension(:,:,:),allocatable :: dfdx,dfdy,adv
    allocate(adv(size(u,1),size(u,2),size(u,3)))

    dfdx = xder_cart(f,dx)
    dfdy = yder_cart(f,dy)

    adv=u*dfdx+v*dfdy

  end function advect_cart

  function define_sigma(t,lev) result(sigma)
    !   Calculatig sigma stability parameter in isobaric coordinates
    use mod_const
    implicit none

    real,dimension(:,:,:),intent(in) :: t
    real,dimension(:),    intent(in) :: lev
    real                             :: dlev
    real,dimension(:,:,:),allocatable :: sigma
    integer :: k,nlon,nlat,nlev
    real,dimension(:,:,:),allocatable :: theta,dThetaDp

    nlon=size(t,1); nlat=size(t,2); nlev=size(t,3)
    dlev=lev(2)-lev(1)
    allocate(theta(nlon,nlat,nlev),sigma(nlon,nlat,nlev))

    do k=1,nlev
       theta(:,:,k)=log(t(:,:,k))-(r/cp)*log(lev(k)/1e5)
    enddo
    dThetaDp=pder(theta,dlev)

    do k=1,nlev
       sigma(:,:,k)=-R*t(:,:,k)/lev(k)*dThetaDp(:,:,k)
    enddo

  end function define_sigma

  function define_sp(sigma,lev) result(sp)
    !   Calculating Sp stability parameter
    use mod_const
    implicit none

    real,dimension(:,:,:),intent(in) :: sigma
    real,dimension(:),intent(in) :: lev
    real,dimension(:,:,:),allocatable :: sp
    integer :: k

    allocate(sp(size(sigma,1),size(sigma,2),size(sigma,3)))

    do k=1,size(sigma,3)
       sp(:,:,k)=sigma(:,:,k)*lev(k)/r
    enddo

  end function define_sp

  function laplace_cart(f,dx,dy) result(lapl)
    !     Laplace operator in cartesian coordinates.
    !     The domain is assumed to be periodic in east-west-direction
    !     ** At the northern and southern boundaries, second y derivative
    !     is assumed to be zero
    implicit none

    real,dimension(:,:,:),intent(in) :: f
    real,                 intent(in) :: dx,dy
    real,dimension(:,:,:),allocatable :: lapl
    integer :: nlon,nlat,nlev,acc,i,j,k
    real :: inv_dx,inv_dy
    nlon=size(f,1)
    nlat=size(f,2)
    nlev=size(f,3)
    allocate(lapl(nlon,nlat,nlev))
    inv_dx = 1.0 / (dx * dx)
    inv_dy = 1.0 / (dy * dy)
    acc=1

    select case(acc)
    case(1)
       ! x-direction
       lapl ( 2 : nlon - 1, :, : ) = f( 1: nlon - 2, :, : ) + f ( 3: nlon, :, : ) &
            - 2 * f( 2 : nlon - 1, :, : )
       lapl ( 1, :, : )    = f( nlon, :, : ) + f ( 2, :, : ) &
            - 2 * f( 1, :, : )
       lapl ( nlon, :, : ) = f( nlon - 1, :, : ) + f ( 1, :, : ) &
            - 2 * f( nlon, :, : )
       lapl = lapl * inv_dx

       ! y-directon
       lapl ( :, 2 : nlat -1, : ) = lapl ( :, 2 : nlat -1, : ) &
            + ( f ( :, 1 : nlat -2, : ) + f ( :, 3 : nlat, :) &
            - 2 * f( :, 2 : nlat -1, : ) ) * inv_dy

    case(2)

       do j=1,nlat
          do k=1,nlev
             do i=1,nlon
                ! x-direction
                if(i==1)then
                   lapl(i,j,k)=(-(1/12)*f(nlon-1,j,k)+(4/3)*f(nlon,j,k)-(5/2)*f(i,j,k) &
                        +(4/3)*f(i+1,j,k)-(1/12)*f(i+2,j,k))/(dx*dx)
                else if(i==2)then
                   lapl(i,j,k)=(-(1/12)*f(nlon,j,k)+(4/3)*f(i-1,j,k)-(5/2)*f(i,j,k) &
                        +(4/3)*f(i+1,j,k)-(1/12)*f(i+2,j,k))/(dx*dx)
                else if(i==nlon-1)then
                   lapl(i,j,k)=(-(1/12)*f(i-2,j,k)+(4/3)*f(i-1,j,k)-(5/2)*f(i,j,k) &
                        +(4/3)*f(i+1,j,k)-(1/12)*f(1,j,k))/(dx*dx)
                else if(i==nlon)then
                   lapl(i,j,k)=(-(1/12)*f(i-2,j,k)+(4/3)*f(i-1,j,k)-(5/2)*f(i,j,k) &
                        +(4/3)*f(1,j,k)-(1/12)*f(2,j,k))/(dx*dx)
                else
                   lapl(i,j,k)=-(1/12)*f(i-2,j,k)+(4/3)*f(i-1,j,k)-(5/2)*f(i,j,k) &
                        +(4/3)*f(i+1,j,k)-(1/12)*f(i+2,j,k)
                   lapl(i,j,k)=lapl(i,j,k)/(dx*dx)
                end if
             enddo
          enddo
       enddo

       do i=1,nlon
          do k=1,nlev
             do j=2,nlat-1
                ! y-direction
                if(j==2)then
                   lapl(i,j,k)=lapl(i,j,k)+(f(i,j-1,k)+f(i,j+1,k)-2*f(i,j,k))&
                        /(dy*dy)
                else if(j==nlat-1)then
                   lapl(i,j,k)=lapl(i,j,k)+(f(i,j-1,k)+f(i,j+1,k)-2*f(i,j,k))&
                        /(dy*dy)
                else
                   lapl(i,j,k)=lapl(i,j,k)+(-(1/12)*f(i,j-2,k)+(4/3)*f(i,j-1,k) &
                        -(5/2)*f(i,j,k)+(4/3)*f(i,j+1,k)-(1/12)*f(i,j+2,k))/(dy*dy)
                end if
             enddo
          enddo
       enddo

    end select

  end function laplace_cart

end module mod_common_subrs


!------------------------------------------------------------------------------|
!..A 2-D FINITE VOLUME SOLVER FOR THE DIFFUSION EQUATION                       |
!                      ON UNSTRUCTURED GRIDS                                   |
!  Course: AE305                                                               |
!------------------------------------------------------------------------------|
Module vars
   integer :: ncell, nnode
   integer,parameter :: ntmax=100000, ntio=100
   integer,allocatable,dimension(:,:) :: node, neigh
   real,parameter ::  delq_allow = 1.E-7, pi = 4*ATAN(1.0)
   real,allocatable,dimension(:,:) :: xy, qgrad
   real,allocatable,dimension(:) :: qcell,qnode,qbc,area,unode,vnode
   real :: uinf, vinf, dt, alpha_deg = 0.0
 End module

  program FiniteVolume
   Use vars
 !..Read the input data and initialize the solution
     call INIT()
 !..Start the solution loop
     DO nt=1,ntmax
        call GRADIENT      !..Evaluate Q gradients for cells
        delq_max = 0.
        do n = 1,ncell     !..Sweep all the cells and solve for T^n+1
           delq     = -dt/area(n) * CellFLUX(n)
           qcell(n) = qcell(n) + delq
           delq_max = MAX(ABS(delq),delq_max)
        enddo
 !..Output the intermediate solutions
        if( MOD(nt,100) .eq. 0 ) print*, ' nt, Delq_max :',nt,delq_max
        if(delq_max .lt. delq_allow) exit
        !if( MOD(nt,ntio) .eq. 0 .and. nt .ne. ntmax ) call TECout(nt)
     ENDDO
     !call TECout(nt-1)       !..Output the final solution
     call QNODES()
     call PRESSURE()
   stop  'DONE'
  end

 !------------------------------------------------------------------------
  subroutine INIT()
   Use vars
   character :: fn*16
   logical   :: ok

 !..Read the grid data
   !  write(*,'(/(a))',advance='no')'  Enter the grid file name [circle.dat]: '
   !  read(*,'(a)') fn
   !  if( fn .eq. ' ') fn = 'circle.dat'
   !  inquire(FILE=fn,EXIST=ok)
   !  if( .not. ok ) then
   !      print*, '  ', fn, ' does not exist! \n\n'
   !      stop
   !  endif
   !  open(1,file=fn,form='formatted')
   open(1,file="circle.dat",form='formatted')
    read(1,*) ncell,nnode
    allocate( node(3,ncell),neigh(3,ncell),xy(2,nnode),area(ncell), &
              qcell(ncell),qnode(nnode),unode(nnode),vnode(nnode), &
              qbc(4),qgrad(2,ncell) )
    read(1,*) (no,(xy(i,n),i=1,2),n=1,nnode)
    read(1,*) (no,(node(i,n),i=1,3),(neigh(i,n),i=1,3),n=1,ncell)
    close(1)
    print*, ' # of cells :',ncell
    print*, ' # of nodes :',nnode

   !  write(*,'(/(a))',advance='no')'  Enter the time step : '
   !  read(*,*) dt
      dt = 0.001
 !..Compute cell areas
    do n = 1,ncell
       n1 = node(1,n)
       n2 = node(2,n)
       n3 = node(3,n)
       area(n) = 0.5*( (xy(1,n2)-xy(1,n1))*(xy(2,n3)-xy(2,n1)) &
                      -(xy(2,n2)-xy(2,n1))*(xy(1,n3)-xy(1,n1))  )
    enddo

    alpha = alpha_deg/180.*pi
    uinf  = COS(alpha)
    vinf  = SIN(alpha)

 !..Initialize the solution with free stream
     do n =1,ncell
           xc = (xy(1,node(1,n))+xy(1,node(2,n))+xy(1,node(3,n)))/3.
           yc = (xy(2,node(1,n))+xy(2,node(2,n))+xy(2,node(3,n)))/3.
           qcell(n) = xc*uinf + yc*vinf
     enddo
 !..Initialize the solution with 0
 !	qcell = 0.

    !call TECout(0)
    return
  end
  !-------------------------------------------------------------------
  subroutine PRESSURE()
   use vars
   real :: angle
   real,dimension(nnode) :: pres
   do n=1,nnode
      pres(n) = 1 - (unode(n)**2 + vnode(n)**2)
   enddo
   open(3,file='cp_team_31.dat',form='formatted')
   DO n = 1,ncell
      do ns = 1,3
         nn = node(ns,n)
         ne = neigh(ns,n)
       if(ne.eq.-2) then
         angle = pi - atan2(xy(2,nn),xy(1,nn))
         angle = angle * (180/pi)
         write(3,*) angle,pres(nn)
       endif
    enddo
   ENDDO
   close(3)
   return
  end
 !-------------------------------------------------------------------
 subroutine  GRADIENT()
   Use vars
   qgrad = 0.
   DO n = 1,ncell
      do ns = 1,3
         n1 = node(ns,n)
         ni2 = MOD(ns,3) + 1
         n2 = node(ni2,n)
         dx = xy(1,n2)-xy(1,n1)
         dy = xy(2,n2)-xy(2,n1)
         ne = neigh(ns,n)
         if(ne .gt. 0) then       !..real neighbor
          qface = 0.5*(qcell(n) + qcell(ne))
          qgrad(1,n) = qgrad(1,n) + (1/area(n)) * qface * dy
          qgrad(2,n) = qgrad(2,n) - (1/area(n)) * qface * dx
       elseif(ne.eq.-1) then     !..Outside boundary
           qgrad(1,n) = uinf
           qgrad(2,n) = vinf
           exit
       elseif(ne.eq.-2) then     !..Wall boundary
        qface = qcell(n)
        qgrad(1,n) = qgrad(1,n) + (1/area(n)) * qface * dy
        qgrad(2,n) = qgrad(2,n) - (1/area(n)) * qface * dx
       endif
    enddo
   ENDDO
   return
  end

 !------------------------------------------------------------------------
 function CellFLUX(n)
   Use vars

   Cellflux = 0.
   do ns = 1,3               !..Add the surface fluxes
      n1 = node(ns,n)
      ni2 = MOD(ns,3) + 1
      n2 = node(ni2,n)
      dx = xy(1,n2)-xy(1,n1)
      dy = xy(2,n2)-xy(2,n1)
 !..Apply proper BCs when computing the face fluxes
      ne = neigh(ns,n)
      if( ne .gt. 0 ) then        !..real neighbor...
       f = ( qgrad(1,n) + qgrad(1,ne) ) / 2.
       g = ( qgrad(2,n) + qgrad(2,ne) ) / 2.
       elseif(ne.eq.-1) then     !..Outside boundary
          f = uinf
          g = vinf
      elseif(ne.eq.-2) then     !..Wall boundary
          f = 0
          g = 0
      endif
      Cellflux = Cellflux - (f*dy - g*dx)
   enddo
   return
 end

 !-------------------------------------------------------------------
 subroutine  TECout(nstep) !..Output the solution/grid in TECPLOT format
   Use vars
   character :: fname*32, str*12, ext*6
    call QNODES()

 !..Set the output file name
    write(str,'(f9.6)') float(nstep)/1e6
    read(str,'(3x,a6)') ext
    fname = 'q-'//ext//'.tec'
    open(1,file=fname, form='formatted')
    write(1,100) nnode,ncell
    write(1,101) (xy(1,n),xy(2,n),qnode(n),unode(n),vnode(n),n=1,nnode)
    write(1,102) (node(1,n),node(2,n),node(3,n),n=1,ncell)
    close(1)
   100 format (' VARIABLES= "X", "Y", "Q", "U", "V"'/, &
               ' ZONE N=', I6,' E=', I6,' F=FEPOINT ',' ET=triangle'  )
   101 format (5(1x,e12.5))
   102 format (3(1x,i6))
   return
 end
 !-------------------------------------------------------------------
 subroutine  QNODES()     !..Evaluate averaged q_node values
   Use vars
   integer, dimension(:) :: npass(nnode)
    qnode = 0.
    unode = 0.
    vnode = 0.
    npass = 0.
 !..Find the contribution of cells to the node Q
    do n=1,ncell
    do nf=1,3
       nn = node(nf,n)
       qnode(nn)=qnode(nn)+qcell(n)
       unode(nn)=unode(nn)+qgrad(1,n)
       vnode(nn)=vnode(nn)+qgrad(2,n)
       npass(nn)=npass(nn)+1
    enddo
    enddo
 !..Average the total node Q with # of contributing cells
    do n=1,nnode
       qnode(n)=qnode(n)/npass(n)
       unode(n)=unode(n)/npass(n)
       vnode(n)=vnode(n)/npass(n)
    enddo
   return
 end
 !------------------------------END----------------------------------


    Program dpttrf_example

!     DPTTRF Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dpttrf
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: info, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: d(:), e(:)
!     .. Executable Statements ..
      Write (nout, *) 'DPTTRF Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (d(n), e(n-1))

!     Read the lower bidiagonal part of the tridiagonal matrix A from
!     data file

      Read (nin, *) d(1:n)
      Read (nin, *) e(1:n-1)

!     Factorize the tridiagonal matrix A

      Call dpttrf(n, d, e, info)

      If (info>0) Then
        Write (nout, 100) 'The leading minor of order ', info, &
          ' is not positive definite'
      End If

!     Print details of the factorization

      Write (nout, *) 'Details of factorization'
      Write (nout, *)
      Write (nout, *) ' The diagonal elements of D'
      Write (nout, 110) d(1:n)
      Write (nout, *)
      Write (nout, *) ' Subdiagonal elements of the Cholesky factor L'
      Write (nout, 110) e(1:n-1)

100   Format (1X, A, I3, A)
110   Format (1X, 8F9.4)
    End Program


subroutine continuous_betas_linear(npt, y, b0, b1)
    implicit none
    integer, intent(in)                      :: npt
    real(8), intent(in), dimension(npt)      :: y
    real(8), intent(inout), dimension(npt-1) :: b0, b1

    b0 = y(1:(npt-1))
    b1 = y(2:npt)-y(1:(npt-1))
end subroutine continuous_betas_linear

subroutine continuous_betas_quadratic(npt, x, y, b0, b1, b2)
    implicit none
    integer,intent(in)                      :: npt
    real(8),dimension(npt),intent(in)       :: x, y
    real(8),dimension(npt-1),intent(inout)  :: b0, b1, b2
    integer                                 :: i, m

    m         = (npt+1)/2 !position of the mode
    b0(m)     = y(m)
    b1(m)     = 0.0d0
    b2(m)     = y(m+1) - y(m)
    do i = m+1, npt-1
        b0(i) = y(i)
        b1(i) = ( b1(i-1) + 2.0d0 * b2(i-1) ) * (x(i+1)-x(i)) / (x(i)-x(i-1))
        b2(i) = y(i+1) - y(i) - b1(i)
    enddo
    do i = m-1, 1, -1
        b0(i) = y(i)
        b1(i) = 2.0d0 * (y(i+1) - y(i)) - b1(i+1) * (x(i+1)-x(i)) / (x(i+2)-x(i+1))
        b2(i) = y(i+1) - y(i) - b1(i)
    enddo
end subroutine continuous_betas_quadratic

subroutine continuous_betas_quadratic_old(npt, x, y, b0, b1, b2)
    implicit none
    integer,intent(in)                      :: npt
    real(8),dimension(npt),intent(in)       :: x, y
    real(8),dimension(npt-1),intent(inout)  :: b0, b1, b2
    integer                                 :: i
    real(8)                                 :: d

    b0(:) = y(1:(npt - 1))
    d = (x(3) - x(1)) / (x(2) - x(1))
    b1(1) = d / (d - 1) * (y(2) - y(3) / d ** 2 - y(1) * (1 - 1 / d ** 2))
    do i = 2, npt - 1
      b1(i) = (b1(i - 1) + 2 * (y(i) - y(i - 1) - b1(i - 1))) * &
        (x(i + 1) - x(i)) / (x(i) - x(i - 1))
    enddo
    b2(1:(npt - 1)) = y(2:npt) - y(1:(npt - 1)) - b1(1:(npt - 1))
end subroutine continuous_betas_quadratic_old

subroutine continuous_integrals_b2equal0(npt, beta0, beta1, xlow, xhigh, integrals)
    implicit none
    integer,intent(in)                      :: npt
    real(8),dimension(npt-1),intent(in)     :: beta0, beta1, xlow, xhigh
    real(8),dimension(npt-1),intent(out)    :: integrals

    integrals = exp(beta0) * (exp(beta1 * xhigh) - exp(beta1 * xlow) ) / beta1
end subroutine continuous_integrals_b2equal0

subroutine continuous_integrals(npt, beta0, beta1, beta2, xlow, xhigh, integrals)
    implicit none
    integer,intent(in)                      :: npt
    real(8),dimension(npt-1),intent(in)     :: beta0, beta1, beta2, xlow, xhigh
    real(8),dimension(npt-1),intent(out)    :: integrals
    real(8),dimension(npt-1)                :: imL, imU, dlt, sgB
    real(8),parameter                       :: pi = 3.141592653589793d0
    integer                                 :: i
    real(8)                                 :: erU, erL, twosqpi

    twosqpi = 2.0/sqrt(pi)
    sgB = sign(1.0d0, beta2)
    imL = -sgB * 0.5d0 * (2.0d0 * beta2 * xlow  + beta1) / sqrt(abs(beta2))
    imU = -sgB * 0.5d0 * (2.0d0 * beta2 * xhigh + beta1) / sqrt(abs(beta2))
    do i = 1, npt-1
        if (abs(beta2(i)) < 1d-16) then
          dlt(i) = 0d0
        else if (abs(beta1(i)/beta2(i)) < 100d0) then
            if(beta2(i) < 0.0d0) then
                call erfS(imL(i),erL)
                call erfS(imU(i),erU)
            else
                call erfiS(imL(i),erL)
                call erfiS(imU(i),erU)
            endif
            dlt(i) = erU - erL
        else
            if(beta2(i) < 0.0d0) then
                dlt(i) = exp(-imL(i))*twosqpi*(imU(i)-imL(i))* &
                    (1d0 - (imU(i)-imL(i))*imL(i))
            else if(beta2(i) > 0.0d0) then
                dlt(i) = exp(imL(i))*twosqpi*(imU(i)-imL(i))* &
                    (1d0 + (imU(i)-imL(i))*imL(i))
            else
              dlt(i) = 0d0
            endif
        endif
    enddo
    where (dlt == 0)
      integrals = 0
    elsewhere
      integrals = - 0.5d0 * sqrt(pi/abs(beta2)) * &
                exp( (4.0d0 * beta0 * beta2 - beta1**2)/(4.0d0 * beta2)) * dlt
    end where
end subroutine continuous_integrals

subroutine continuous_pdf(n, z, npt, x, dx, beta0, beta1, beta2, normct, dolog, pdf)
    implicit none
    integer,intent(in)                  :: n, npt
    logical, intent(in)                 :: dolog
    real(8),dimension(n),intent(in)     :: z
    real(8),dimension(npt),intent(in)   :: x
    real(8),dimension(npt-1),intent(in) :: dx, beta0, beta1, beta2
    real(8),intent(in)                  :: normct
    real(8),dimension(n),intent(inout)  :: pdf
    integer,dimension(n)                :: pos
    integer,dimension(1)                :: pvec
    real(8),dimension(n)                :: zscaled
    integer                             :: i
    real(8)                             :: b0, b1, b2

    if(dolog) then
        pdf = -50
    else
        pdf = 0
    endif
    do i = 1, n
        pvec   = minloc( abs(z(i) - x) )
        pos(i) = pvec(1)
    enddo
    where( x(pos) > z .and. pos > 1)
        pos = pos - 1
    end where
    where(pos < npt)
        zscaled = (z - x(pos)) / dx(pos)
    end where
    do i = 1, npt-1
        b0 = beta0(i)
        b1 = beta1(i)
        b2 = beta2(i)
        if(dolog) then
            where( pos == i )
                pdf = b0 + b1 * zscaled + b2 * zscaled**2 - log(normct)
            end where
        else
            where( pos == i )
                pdf = exp(b0 + b1 * zscaled + b2 * zscaled**2) / normct
            end where
        endif
    enddo

end subroutine continuous_pdf

subroutine continuous_cdf_quadratic(n, z, npt, x, dx, beta0, beta1, beta2, pcdf, normct, p)
    implicit none
    integer,intent(in)                  :: n, npt
    real(8),dimension(n),intent(in)     :: z
    real(8),dimension(npt),intent(in)   :: x
    real(8),dimension(npt-1),intent(in) :: dx, beta0, beta1, beta2, pcdf
    real(8),intent(in)                  :: normct
    real(8),dimension(n),intent(inout)  :: p
    real(8),parameter                   :: spi2 = sqrt(3.14159265359d0) / 2.0d0
    real(8),parameter                   :: a = 0.147d0
    integer,dimension(n)                :: pos
    real(8),dimension(n)                :: tU, imU, erU
    complex(8)                          :: uL, iL
    complex(8),dimension(n)             :: cU, iU
    real(8),dimension(npt)              :: lagged_pcdf
    integer,dimension(1)                :: pvec
    integer                             :: i
    real(8)                             :: b0, b1, b2, rd, xi, dxi
    real(8)                             :: imL, tL, erL, sb2, signb2, aux

    do i = 1, n
        pvec   = minloc( abs(z(i) - x) )
        pos(i) = pvec(1)
    enddo
    where (x(pos) > z .and. pos > 1)
        pos = pos - 1
    end where
    lagged_pcdf(1)     = 0.0d0
    lagged_pcdf(2:npt) = pcdf( 1:(npt-1) )
    do i = 1, npt-1
      b0 = beta0(i)
      b1 = beta1(i)
      b2 = beta2(i)
      rd = lagged_pcdf(i)
      xi = x(i)
      dxi = dx(i)
      sb2 = sqrt(abs(b2))
      signb2 = sign(1.0d0, b2)
      aux = -spi2 * dxi * exp( ( 4.0d0 * b0 * b2 - b1**2 )/(4.0d0 * b2) ) / &
        (sb2 * normct)
      imL = -signb2 * 0.5d0 * b1 / sb2
      if (abs(b2) < 1d-15) then
        where(pos == i)
          p = 0.0d0
        end where
      elseif (abs(b1/b2) < 100.0d0) then
          if( b2 < 0.0d0) then
              !local version of erf(imL) -> erL
              tL  = 1.0d0 / (1.0d0 + 0.327591100d0 * abs(imL))
              erL = sign(1.0d0 - &
                        (0.254829592d0 * tL - 0.284496736d0 * tL**2 + &
                        1.421413741d0 * tL**3 - &
                        1.453152027d0 * tL**4 + &
                        1.061405429d0 * tL**5) * exp(-imL**2), imL)
              where(pos == i)
                  !local version of erf(imU) -> erU
                  imU = -signb2 * (b2 * (z - xi) / dxi + 0.5d0 * b1) / sb2
                  tU  = 1.0d0 / (1.0d0 + 0.327591100d0 * abs(imU))
                  erU = sign(1.0d0 - &
                          (0.254829592d0 * tU - 0.284496736d0 * tU**2 + 1.421413741d0 * tU**3 - &
                          1.453152027d0 * tU**4 + 1.061405429d0 * tU**5) * exp(-imU**2), imU)
                  p   = rd + aux * (erU - erL)
              end where
          else
              !local version of erfi(imL) -> erL
              uL  = cmplx(0.0d0,abs(imL),KIND=8)
              iL  = 1.0d0 / (1.0d0 + 0.327591100d0 * uL )
              erL = sign(aimag(1.0d0 - &
                        (0.254829592d0 * iL - 0.284496736d0 * iL**2 + 1.421413741d0 * iL**3 - &
                        1.453152027d0 * iL**4 + 1.061405429d0 * iL**5) * exp(-uL**2) ), imL)
              where(pos == i)
                  !local version of erfi(imU) -> erU
                  imU = -signb2 * (b2 * (z - xi) / dxi + 0.5d0 * b1 ) / sb2
                  cU  = cmplx(0.0d0,abs(imU), KIND = 8)
                  iU  = 1.0d0 / (1.0d0 + 0.327591100d0 * cU )
                  erU = sign(aimag(1.0d0 - &
                        (0.254829592d0 * iU - 0.284496736d0 * iU**2 + 1.421413741d0 * iU**3 - &
                        1.453152027d0 * iU**4 + 1.061405429d0 * iU**5) * exp(-cU**2) ), imU)
                  p   = rd + aux * (erU - erL)
              end where
          endif
      elseif (b2 < 0.0d0) then
          where(pos == i)
              imU = -sb2 * (0.5d0 * b1 + b2 * (z - xi) / dxi) / sb2
              p   = rd + aux * exp(-imL**2)*(imU-imL)*( 1.0d0 - (imU-imL)*imL ) / spi2
          end where
      elseif (b2 > 0.0d0) then
          where(pos == i)
              imU = -sb2 * (0.5d0 * b1 + b2 * (z - xi) / dxi) / sb2
              p   = rd + aux * exp( imL**2)*(imU-imL)*( 1.0d0 + (imU-imL)*imL ) / spi2
          end where
      endif
    enddo
    where (pos >= npt)
        p = 1.0d0
    end where
end subroutine continuous_cdf_quadratic

subroutine continuous_cdf_linear(n, z, npt, x, dx, beta0, beta1, pcdf, normct, p)
    implicit none
    integer, intent(in)                     :: n, npt
    real(8), intent(in)                     :: normct
    real(8), intent(in), dimension(n)       :: z
    real(8), intent(in), dimension(npt)     :: x, dx
    real(8), intent(in), dimension(npt-1)   :: beta0, beta1, pcdf
    real(8), intent(inout), dimension(n)    :: p
    integer                                 :: i, pos(n), pvec(1)
    real(8)                                 :: rd, b0, b1, di, xi

    do i = 1, n
        pvec   = minloc( abs(z(i) - x) )
        pos(i) = pvec(1)
    enddo
    where( x(pos) > z )
        pos = pos - 1
    end where

    rd = 0.0d0
    do i=1,npt-1
        b0 = beta0(i)
        b1 = beta1(i)
        di = dx(i)
        xi = x(i)
        where( pos == i )
            p = rd + (di / normct) * &
                (exp(b0) / b1 ) * ( -1.0d0 + exp(b1 * &
                (z-xi) / di))
        end where
        rd = pcdf(i) !for next round
    enddo
    where( pos >= npt)
        p = 1.0d0
    end where
end subroutine continuous_cdf_linear

subroutine continuous_invcdf_quadratic(n, p, npt, x, dx, beta0, beta1, beta2, pcdf, normct, z)
    implicit none
    integer,intent(in)                  :: n, npt
    real(8),dimension(n),intent(in)     :: p
    real(8),dimension(npt),intent(in)   :: x
    real(8),dimension(npt-1),intent(in) :: dx, beta0, beta1, beta2, pcdf
    real(8),intent(in)                  :: normct
    real(8),dimension(n),intent(inout)  :: z
    real(8),parameter                   :: twosqpi  = 2.0d0 / sqrt(3.141592653589793d0)
    real(8),parameter                   :: spi2     = sqrt(3.141592653589793d0) / 2.0d0
    real(8),parameter                   :: twopi    = 2.0d0 / 3.141592653589793d0
    real(8),parameter                   :: inverfa  = 0.145d0
    real(8),parameter                   :: inverfia = 0.1382d0
    integer,dimension(n)                :: pos
    real(8),dimension(n)                :: xU, tU, imU
    complex(8)                          :: uL, iL
    complex(8),dimension(n)             :: cU
    real(8),dimension(npt)              :: lagged_pcdf
    integer,dimension(1)                :: pvec
    integer                             :: i, j
    real(8)                             :: b0, b1, b2, rd, xi
    real(8)                             :: dxi, imL, tL, erL, sb2, aux, signb2
    real(8)                             :: a, b, c, r1, r2, z1, z2

    do i = 1, n
        pvec   = minloc( abs(p(i) - pcdf) )
        pos(i) = pvec(1)
    enddo
    where( pcdf(pos) < p .and. pos < npt)
        pos = pos + 1
    end where
    lagged_pcdf(1)     = 0.0d0
    lagged_pcdf(2:npt) = pcdf( 1:(npt-1) )
    do i = 1, npt-1
        b0  = beta0(i)
        b1  = beta1(i)
        b2  = beta2(i)
        rd  = lagged_pcdf(i)
        xi  = x(i)
        dxi = dx(i)
        sb2 = sqrt(abs(b2))
        signb2 = sign(1.0d0, b2)
        aux = - twosqpi * sb2 * normct / (dxi * exp( (4.0d0 * b0 * b2 - b1**2) / (4.0d0 * b2) ) )
        imL = - signb2 * 0.5d0 * b1 / sb2
        if( abs(b1/b2) < 100.0d0 ) then
            if( b2 < 0.0d0) then
                !local version of erf(imL) -> erL
                tL  = 1.0d0 / (1.0d0 + 0.327591100d0 * abs(imL))
                erL = sign(1.0d0 - &
                        (0.254829592d0 * tL - 0.284496736d0 * tL**2 + 1.421413741d0 * tL**3 - &
                        1.453152027d0 * tL**4 + 1.061405429d0 * tL**5) * exp(-imL**2), imL)
                where(pos == i)
                    !vectors
                    xU  = aux * (p - rd) + erL
                    !local version of inv_erf(xU) -> imU
                    tU  = log(1.0d0 - xU**2)
                    imU = sign( sqrt( sqrt( (twopi/inverfa + 0.5d0 * tU)**2 - tU / inverfa) - &
                                (twopi/inverfa + 0.5d0 * tU) ), xU)
                    z   = xi + dxi * (sb2 * imU - 0.5d0 * b1) / b2
                end where
            else
                !local version of erfi(imL) -> erL
                uL  = cmplx(0.0d0,abs(imL),KIND=8)
                iL  = 1.0d0 / (1.0d0 + 0.327591100d0 * uL )
                erL = sign(aimag(1.0d0 - (0.254829592d0 * iL - 0.284496736d0 * iL**2 + &
                            1.421413741d0 * iL**3 - &
                            1.453152027d0 * iL**4 + 1.061405429d0 * iL**5) * exp(-uL**2) ), imL)
                where(pos == i)
                    xU  = aux * (p - rd) + erL
                    !local version of inv_erfi(xU) -> imU
                    cU  = log( 1.0d0 - cmplx(0.0d0, abs(xU),KIND=8)**2 )
                    imU = sign(aimag(sqrt(sqrt( &
                            (twopi/inverfia + 0.5d0 * cU)**2 - cU / inverfia) - &
                            (twopi/inverfia + 0.5d0 * cU) )), xU)
                    z   = xi + dxi * (sb2 * imU - 0.5d0 * b1) / b2
                end where
            end if
        else  if( b2 < 0.0d0 ) then
            a = imL
            b = -1.0d0 - 2.0d0 * imL**2
            do j=1,n
                if(pos(j) == i) then
                    c = imL**3 + imL + (p(j)-rd) * aux * spi2 / exp(-imL**2)
                    r1 = (-b - sqrt(b**2-4.0d0*a*c))/(2.0d0*a)
                    z1 = -r1/sb2 - 0.5d0*b1/b2
                    r2 = (-b + sqrt(b**2-4.0d0*a*c))/(2.0d0*a)
                    z2 = -r2/sb2 - 0.5d0*b1/b2
                    if( abs(z1 - 0.5d0) <= 0.5d0 ) then
                        z(j) = xi + dxi * z1
                    else
                        z(j) = xi + dxi * z2
                    endif
                endif
            enddo
        else
            a = imL
            b = 1.0d0 - 2.0d0 * imL**2
            do j=1,n
                if(pos(j) == i) then
                    c = imL**3 - imL - (p(j)-rd) * aux * spi2 / exp( imL**2)
                    r1 = (-b - sqrt(b**2-4.0d0*a*c))/(2.0d0*a)
                    z1 = -r1/sb2 - 0.5d0*b1/b2
                    r2 = (-b + sqrt(b**2-4.0d0*a*c))/(2.0d0*a)
                    z2 = -r2/sb2 - 0.5d0*b1/b2
                    if( abs(z1 - 0.5d0) <= 0.5d0 ) then
                        z(j) = xi + dxi * z1
                    else
                        z(j) = xi + dxi * z2
                    endif
                endif
            enddo
        endif
    enddo
end subroutine continuous_invcdf_quadratic

subroutine continuous_invcdf_quadratic_bkp(n, p, npt, x, dx, beta0, beta1, beta2, pcdf, normct, z)
    implicit none
    integer,intent(in)                  :: n, npt
    real(8),dimension(n),intent(in)     :: p
    real(8),dimension(npt),intent(in)   :: x
    real(8),dimension(npt-1),intent(in) :: dx, beta0, beta1, beta2, pcdf
    real(8),intent(in)                  :: normct
    real(8),dimension(n),intent(out)    :: z
    real(8),parameter                   :: twosqpi  = 2.0d0 / sqrt(3.141592653589793d0)
    real(8),parameter                   :: twopi    = 2.0d0 / 3.141592653589793d0
    real(8),parameter                   :: inverfa  = 0.145d0
    real(8),parameter                   :: inverfia = 0.1382d0
    integer,dimension(n)                :: pos
    real(8),dimension(n)                :: xU, tU, imU
    complex(8)                          :: uL, iL
    complex(8),dimension(n)             :: cU
    real(8),dimension(npt-1)            :: lagged_pcdf
    integer,dimension(1)                :: pvec
    integer                             :: i
    real(8)                             :: b0, b1, b2, rd, xi
    real(8)                             :: dxi, imL, tL, erL, sb2, aux

    do i = 1, n
        pvec   = minloc( abs(p(i) - pcdf) )
        pos(i) = pvec(1)
    enddo
    where( pcdf(pos) < p .and. pos < npt)
        pos = pos + 1
    end where
    lagged_pcdf(1) = 0.0d0
    lagged_pcdf(2:npt) = pcdf( 1:(npt-1) )
    do i = 1, npt-1
        b0  = beta0(i)
        b1  = beta1(i)
        b2  = beta2(i)
        rd  = lagged_pcdf(i)
        xi  = x(i)
        dxi = dx(i)
        sb2 = sqrt(abs(b2))
        imL = 0.5d0 * b1 / sb2
        if( b2 < 0.0d0) then
            !scalars
            aux = -sb2 * twosqpi * exp( (b1**2 - 4.0d0 * b0 * b2) / (4.0d0 * b2) ) * normct / dxi
            !local version of erf(imL) -> erL
            tL  = 1.0d0 / (1.0d0 + 0.327591100d0 * abs(imL))
            erL = sign(1.0d0 - &
                  (0.254829592d0 * tL - 0.284496736d0 * tL**2 + 1.421413741d0 * tL**3 - &
                  1.453152027d0 * tL**4 + 1.061405429d0 * tL**5) * exp(-imL**2), imL)
            where(pos == i)
                !vectors
                xU  = aux * (p - rd) + erL
                !local version of inv_erf(xU) -> imU
                tU  = log(1.0d0 - xU**2)
                imU = sign( sqrt( sqrt( (twopi/inverfa + 0.5d0 * tU)**2 - tU / inverfa) - &
                      (twopi/inverfa + 0.5d0 * tU) ), xU)
                z   = xi + dxi * (2.0d0 * sb2 * imU - b1) / ( 2.0d0 * b2 )
            end where
        else
            !scalars
            aux = sb2 * twosqpi * exp( (b1**2 - 4.0d0 * b0 * b2) / (4.0d0 * b2) ) * normct / dxi
            !local version of erfi(imL) -> erL
            uL  = cmplx(0.0d0,abs(imL),KIND=8)
            iL  = 1.0d0 / (1.0d0 + 0.327591100d0 * uL )
            erL = sign(aimag(1.0d0 - (0.254829592d0 * iL - 0.284496736d0 * iL**2 + 1.421413741d0 * iL**3 - &
                  1.453152027d0 * iL**4 + 1.061405429d0 * iL**5) * exp(-uL**2) ), imL)
            where(pos == i)
                xU  = aux * (p - rd) + erL
                !local version of inv_erfi(xU) -> imU
                cU  = log( 1.0d0 - cmplx(0.0d0, abs(xU),KIND=8)**2 )
                imU = sign(aimag(sqrt( sqrt((twopi/inverfia + 0.5d0 * cU)**2 - cU / inverfia) - &
                      (twopi/inverfia + 0.5d0 * cU) )), xU)
                z   = xi + dxi * (2.0d0 * sb2 * imU - b1) / ( 2.0d0 * b2 )
            end where
        end if
    enddo
end subroutine continuous_invcdf_quadratic_bkp

subroutine continuous_invcdf_linear(n, p, npt, x, dx, beta0, beta1, pcdf, normct, z)
    implicit none
    integer, intent(in)                     :: n, npt
    real(8), intent(in)                     :: normct
    real(8), intent(in), dimension(n)       :: p
    real(8), intent(in), dimension(npt)     :: x
    real(8), intent(in), dimension(npt-1)   :: dx, beta0, beta1, pcdf
    real(8), intent(inout), dimension(n)    :: z
    integer                                 :: i, pos(n), pvec(1)
    real(8)                                 :: rd, b0, b1, di, xi

    do i = 1, n
        pvec   = minloc( abs(p(i) - pcdf) )
        pos(i) = pvec(1)
    enddo
    where( pcdf(pos) > p .and. pos > 1 )
        pos = pos - 1
    end where

    rd = 0.0d0
    do i=1,npt-1
        b0 = beta0(i)
        b1 = beta1(i)
        di = dx(i)
        xi = x(i)
        where( pos == i )
            z = xi + di * log( (p-rd) * normct * b1 / &
                (di * exp(b0)) + 1.0d0 ) / b1
        end where
        rd = pcdf(i) !for the next round
    enddo
end subroutine continuous_invcdf_linear

! Subroutine erfV: computes the error function of a real number
! Arguments:
!    n   -- input, dimension of vector x
!    x   -- input, vector containing the n values to be evaluated
!    res -- output, vector containing erf(x)
! This is an approximate function, provided by
! Winitzki, Sergei (6 February 2008). "A handy approximation for the error function and its inverse"
! Wikipedia reference: http://en.wikipedia.org/wiki/Error_function
! Example:
! r <- .Fortran('erfF',n=as.integer(1),x=as.double(1), res=as.double(0)); r$res
! should provide 0.8427007, i.e., Erf[1]
subroutine erfV(n,x,res)
    implicit none
    integer,intent(in)                  :: n
    real(8),dimension(n),intent(in)     :: x
    real(8),dimension(n),intent(out)    :: res
    real(8),dimension(n)                :: t

    t   = 1.0d0 / (1.0d0 + 0.327591100d0 * abs(x))
    res = sign(1.0d0 - (0.254829592d0 * t - 0.284496736d0 * t**2 + 1.421413741d0 * t**3 - &
                        1.453152027d0 * t**4 + 1.061405429d0 * t**5) * exp(-x**2), x)
end subroutine erfV

subroutine erfS(x,res)
    implicit none
    real(8),intent(in)     :: x
    real(8),intent(out)    :: res
    real(8)                :: t

    t   = 1.0d0 / (1.0d0 + 0.327591100d0 * abs(x))
    res = sign(1.0d0 - (0.254829592d0 * t - 0.284496736d0 * t**2 + 1.421413741d0 * t**3 - &
                        1.453152027d0 * t**4 + 1.061405429d0 * t**5) * exp(-x**2), x)
end subroutine erfS

! Subroutine erfiV: computes the imaginary error function of a complex number
! with real part equal to zero and imaginary part equal to x
! Arguments:
!    n   -- input, dimension of vector x
!    x   -- input, vector containing the n values to be evaluated
!    res -- output, vector containing Im( erfi(x) )
! This is an approximate function, provided by
! Winitzki, Sergei (6 February 2008). "A handy approximation for the error function and its inverse"
! Wikipedia reference: http://en.wikipedia.org/wiki/Error_function
! Example:
! ri <- .Fortran('erfiF',n=as.integer(1),x=as.double(1), res=as.double(0)); ri$res
! should provide 1.651042, i.e., Erfi[1]
subroutine erfiV(n, x, res)
    implicit none
    integer,intent(in)                  :: n
    real(8),dimension(n),intent(in)     :: x
    real(8),dimension(n),intent(out)    :: res
    complex(8),dimension(n)             :: t, u

    u   = cmplx(0.0d0,abs(x),KIND=8)
    t   = 1.0d0 / (1.0d0 + 0.327591100d0 * u )
    res = sign(aimag(1.0d0 - (0.254829592d0 * t - 0.284496736d0 * t**2 + 1.421413741d0 * t**3 - &
                   1.453152027d0 * t**4 + 1.061405429d0 * t**5) * exp(-u**2) ), x)
end subroutine erfiV

subroutine erfiS(x, res)
    implicit none
    real(8),intent(in)     :: x
    real(8),intent(out)    :: res
    complex(8)             :: t, u

    u   = cmplx(0.0d0,abs(x),KIND=8)
    t   = 1.0d0 / (1.0d0 + 0.327591100d0 * u )
    res = sign(aimag(1.0d0 - (0.254829592d0 * t - 0.284496736d0 * t**2 + 1.421413741d0 * t**3 - &
                   1.453152027d0 * t**4 + 1.061405429d0 * t**5) * exp(-u**2) ), x)
end subroutine erfiS

! Subroutine inv_erfV: computes the inverse of the error function of a real number
! Arguments:
!    n   -- input, dimension of vector x
!    x   -- input, vector containing the n values to be evaluated
!    res -- output, vector containing erf^{-1}(x)
! This is an approximate function, provided by
! Winitzki, Sergei (6 February 2008). "A handy approximation for the error function and its inverse"
! Wikipedia reference: http://en.wikipedia.org/wiki/Error_function
! Example:
! ir <- .Fortran('inv_erfF',n=as.integer(1),x=as.double(0.8427008), res=as.double(0)); ir$res
! should provide 1, i.e., invErf[0.8427]
subroutine inv_erfV(n, x, res)
    implicit none
    integer,intent(in)                  :: n
    real(8),dimension(n),intent(in)     :: x
    real(8),dimension(n),intent(out)    :: res
    real(8),dimension(n)                :: t, q
    real(8),parameter                   :: a = 0.145d0
    real(8),parameter                   :: twopia = 2.0d0/(3.141592653589793d0*0.145d0)

    t   = log(1.0d0 - x**2)
    q   = twopia + 0.5d0 * t
    res = sign( sqrt( sqrt(q**2 - t / a) - q ), x)
end subroutine inv_erfV

subroutine inv_erfS(x, res)
    implicit none
    real(8),intent(in)     :: x
    real(8),intent(out)    :: res
    real(8)                :: t, q
    real(8),parameter      :: a = 0.145d0
    real(8),parameter      :: twopia = 2.0d0/(3.141592653589793d0*0.145d0)

    t   = log(1.0d0 - x**2)
    q   = twopia + 0.5d0 * t
    res = sign( sqrt( sqrt(q**2 - t / a) - q ), x)
end subroutine inv_erfS

! Subroutine inv_erfiV: computes the inverse of the imaginary error function of
! a complex number with imaginary part equal to zero and real part equal to x
! Arguments:
!    n   -- input, dimension of vector x
!    x   -- input, vector containing the n values to be evaluated
!    res -- output, vector containing erfi^{-1}(x)
! This is an approximate function, provided by
! Winitzki, Sergei (6 February 2008). "A handy approximation for the error function and its inverse"
! Wikipedia reference: http://en.wikipedia.org/wiki/Error_function
! Example:
! iri <- .Fortran('inv_erfiF',n=as.integer(1),x=as.double(1.650426), res=as.double(0)); iri$res
! should provide 1, i.e., erfi^{-1}(1.650426)
subroutine inv_erfiV(n, x, res)
    implicit none
    integer,intent(in)                  :: n
    real(8),dimension(n),intent(in)     :: x
    real(8),dimension(n),intent(out)    :: res
    complex(8),dimension(n)             :: t, q, u
    real(8), parameter                  :: a = 0.1382d0
    real(8),parameter                   :: itwopia = 2.0d0/(3.141592653589793d0 * a)

    u   = cmplx(0.0d0, abs(x),KIND=8)
    t   = log(1.0d0 - u**2)
    q   = itwopia + 0.5d0 * t
    res = sign(aimag(sqrt( sqrt(q**2 - t / a) - q )), x)
end subroutine inv_erfiV

subroutine inv_erfiS(x, res)
    implicit none
    real(8),intent(in)     :: x
    real(8),intent(out)    :: res
    complex(8)             :: t, q, u
    real(8),parameter      :: a = 0.1382d0
    real(8),parameter      :: itwopia = 2.0d0/(3.141592653589793d0 * a)

    u   = cmplx(0.0d0, abs(x),KIND=8)
    t   = log(1.0d0 - u**2)
    q   = itwopia + 0.5d0 * t
    res = sign(aimag(sqrt( sqrt(q**2 - t / a) - q )), x)
end subroutine inv_erfiS

!Subroutine slow_erf: computes the error function of a real number, using a slow but accurate algorithm
! Arguments:
!    n   -- input, dimension of vector x
!    x   -- input, vector containing the n values to be evaluated
!    res -- output, vector containing erf(x)
! Reference: Book "Computation of Special functions"
! Vectorized algorithm adapted from the Fortran scalar subroutines provided in
! http://jin.ece.illinois.edu/routines/routines.html
! Example:
! rs <- .Fortran('slow_erf',n=as.integer(1),x=as.double(1), res=as.double(0)); rs$res
! should provide 0.8427008, i.e., Erf[1]
subroutine slow_erf(n, x, res)
    implicit none
    integer,intent(in)                  :: n
    real(8),dimension(n),intent(in)     :: x
    real(8),dimension(n),intent(out)    :: res
    real(8),parameter                   :: eps = 1.0d-15
    real(8),parameter                   :: dpi = 1.0d0 / sqrt(3.141592653589793d0)
    real(8),dimension(n)                :: a0, sq, esq, er
    logical,dimension(n)                :: test1, test2
    integer                             :: i, k
    real(8)                             :: r, rs, mysq

    a0    = abs(x)
    test1 = (a0 < 3.5d0)
    test2 = (x  < 0.0d0)
    sq    = x * x
    esq   = exp(-sq)
    do i=1,n
        mysq = sq(i)
        if(test1(i)) then
            r  = x(i)
            rs = r
            do k = 1, 120
                r = r * mysq / ( k + 0.5d0 )
                rs = rs + r
                if( abs(r/rs) <= eps ) exit
            enddo
        else
            r  = 1.0d0 / x(i)
            rs = r
            do k = 1, 13
                r = -r * (k - 0.5d0) / mysq
                rs = rs + r
                if( abs(r/rs) <= eps ) exit
            enddo
        end if
        er(i) = rs
    enddo
    where(test1)
        res = 2.0d0 * dpi * esq * er
    elsewhere
        res = 1.0d0 - dpi * esq * er
        where(test2)
            res = -res
        end where
    end where
end subroutine

!Subroutine slow_erfi: computes the imaginary error function of a complex number,
!using a slow but accurate algorithm
! Arguments:
!    n   -- input, dimension of vector x
!    x   -- input, vector containing the n values to be evaluated
!    res -- output, vector containing erfi(x)
! Reference: Book "Computation of Special functions"
! Vectorized algorithm adapted from the Fortran scalar subroutines provided in
! http://jin.ece.illinois.edu/routines/routines.html
! Example:
! ris <- .Fortran('slow_erfi',n=as.integer(1),z=complex(imaginary=1),
!                 res=as.complex(0)); Im(ris$res)
! should provide 1.650426, i.e., Erfi[1]
subroutine slow_erfi(n, z, res)
    implicit none
    integer,intent(in)                  :: n
    complex(8),dimension(n),intent(in)  :: z
    complex(8),dimension(n),intent(out) :: res
    real(8),parameter                   :: eps = 1.0d-15
    real(8),parameter                   :: dpi = 1.0d0 / sqrt(3.141592653589793d0)
    real(8),dimension(n)                :: a0, esq
    complex(8),dimension(n)             :: er
    logical,dimension(n)                :: test1, test2
    complex(8),dimension(n)             :: z1, sq
    integer                             :: i, k
    complex(8)                          :: r, rs, mysq

    a0    = cdabs(z)
    test1 = (a0 <= 5.8d0)
    test2 = (real(z) < 0.0)
    where(test2)
        z1 = -z
    elsewhere
        z1 = z
    end where
    sq    = z1 * z1
    esq   = real(cdexp(-z*z))
    do i=1,n
        mysq = sq(i)
        if(test1(i)) then
            r  = z1(i)
            rs = r
            do k = 1, 120
                r  = r * mysq / (k + 0.5d0)
                rs = rs + r
                if(cdabs(r/rs) < eps) exit
            enddo
        else
            r  = 1.0d0 / z1(i)
            rs = r
            do k = 1, 13
                r  = -r * (k - 0.5d0) / mysq
                rs = rs + r
                if(cdabs(r/rs) < eps) exit
            enddo
        endif
        er(i) = rs
    enddo
    where(test1)
        res = 2.0d0 * dpi * esq * er
    elsewhere
        res = 1.0d0 - dpi * esq * er
    end where
    where(test2)
        res = -res
    end where
end subroutine

!* Wrapping subroutine, used to compute the Exponential Integral **************
subroutine expint(x, res)
    implicit none
    real(8), intent(in)    :: x
    real(8), intent(out)   :: res
    real(8)                :: r8_ei

    res = r8_ei(x)
end subroutine

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TESTING, remove when done
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine convolution_normal_continuous(n, xl, dxl, b0l, b1l, b2l, normct, m, v, x, y)
    implicit none
    integer,intent(in)                  :: n
    real(8),dimension(n),  intent(in)   :: xl
    real(8),dimension(n-1),intent(in)   :: dxl
    real(8),dimension(n-1),intent(in)   :: b0l, b1l, b2l
    real(8),intent(in)                  :: normct, m, v
    real(8),dimension(n),intent(out)    :: x, y
    real(8),dimension(n-1)              :: a0part, a1part, alpha0, alpha1, alpha2
    real(8),dimension(n-1)              :: xlow, xhigh, integrals
    integer                             :: i
    real(8)                             :: evaluation_point, c

    c      = - 0.5d0 * log( 2d0 * 3.141592653589793d0 * v) - log(normct)
    xlow   = xl(1:(n-1))
    xhigh  = xl(2:n)
    a0part = b0l - b1l * xlow/dxl + b2l * (xlow/dxl)**2 + c
    a1part = b1l/dxl - 2.0d0 * b2l * xlow / dxl**2
    alpha2 = -0.5d0 / v + b2l / dxl**2
    do i = 1, n
      evaluation_point = xl(i) - 3.5d0 + 7.0d0*dble(i-1)/dble(n-1)
      alpha0 = a0part - 0.5d0*(evaluation_point - m)**2/v
      alpha1 = a1part + (evaluation_point - m)/v
      call continuous_integrals(n-1, alpha0, alpha1, alpha2, xlow, xhigh, integrals)
      x(i) = evaluation_point
      y(i) = log(sum(integrals * dxl))
    enddo
end subroutine convolution_normal_continuous