module tmod
  use fgsl
  use, intrinsic :: iso_c_binding
! some scaffolding for the testing
  implicit none
  logical, parameter, private :: debug = .false.
  interface
     subroutine pp1(xp) bind(c)
       import :: c_ptr
       type(c_ptr), value :: xp
     end subroutine pp1
  end interface
  type data 
     integer(fgsl_size_t) :: n
     real(fgsl_double), allocatable :: y(:), sigma(:)
  end type data
  character(kind=fgsl_char,len=fgsl_strmax) :: test_message
contains
  subroutine testres_toggle(whichtest,test_ok,ok,nok)
    character(len=*), intent(in) :: whichtest
    logical, intent(inout) :: test_ok
    logical, intent(inout) :: ok(:)
    integer, intent(inout) :: nok
    if (.not. test_ok) then
       write(6, *) 'FAIL: ', whichtest
    elseif (debug) then
       write(6, *) 'OK: ', whichtest
    end if
    ok(nok) = test_ok
    test_ok = .true.
    nok = nok + 1
  end subroutine testres_toggle
!
! error treatment test 
!
  subroutine mine_sr(reason, file, line, errno) bind(c)
    type(c_ptr), value :: reason, file
    integer(c_int), value :: line, errno
!
    test_message = fgsl_strerror(errno)
    write(6, *) 'Processed error in ',trim(fgsl_name(file)), ' at line ',line
    write(6, *) 'Reason was: ',trim(fgsl_name(reason))
  end subroutine mine_sr
!
! simulated annealing
!
  function e1(xp) bind(c)
    type(c_ptr), value :: xp
    real(fgsl_double) :: e1
!
    real(fgsl_double), pointer :: x
    call c_f_pointer(xp, x)
    e1 = exp(-(x-1.0_fgsl_double)**2.0_fgsl_double) * &
         sin(8.0_fgsl_double*x)
  end function e1
  function m1(xp, yp) bind(c)
    type(c_ptr), value :: xp, yp
    real(fgsl_double) :: m1
!
    real(fgsl_double), pointer :: x, y
    call c_f_pointer(xp, x)
    call c_f_pointer(yp, y)
    m1 = abs(x - y)
  end function m1
  subroutine s1(r, xp, step_size) bind(c)
    type(c_ptr), value :: r, xp
    real(fgsl_double), value :: step_size
!
    real(fgsl_double), pointer :: x
    real(fgsl_double) :: u
    type(fgsl_rng) :: gr
    call fgsl_obj_c_ptr(gr, r)
    call c_f_pointer(xp, x)
    u = fgsl_rng_uniform(gr)
    x = x + 2.0_fgsl_double * u * step_size - step_size
  end subroutine s1
!
! numerical quadrature
!
  function integrate_fun1(x, params) bind(c)
    real(c_double), value :: x
    type(c_ptr), value :: params
    real(c_double) :: integrate_fun1
!
    real(c_double), pointer :: alpha
    call c_f_pointer(params, alpha)
!    write(6, *) 'Alpha = ',alpha
    integrate_fun1 = log(alpha * x) / sqrt(x)
  end function integrate_fun1
! functions for ODE testing
  function func_ode(t, y, dydt, params) bind(c)
    real(c_double), value :: t
    real(c_double), dimension(*), intent(in) :: y
    real(c_double), dimension(*) :: dydt
    type(c_ptr), value :: params
    integer(c_int) :: func_ode
! 
    real(c_double), pointer :: mu
!
!    write(6, *) 'Starting func:'
    call c_f_pointer(params, mu)
!    write(6, *) 'y, mu:', y(1:2), mu
    dydt(1) = y(2)
    dydt(2) = -y(1) - mu*y(2)*(y(1)*y(1) - 1)
    func_ode = fgsl_success
  end function func_ode
  function jac(t, y, dfdy, dfdt, params) bind(c)
    real(c_double), value :: t
    real(c_double), dimension(*), intent(in) :: y
    real(c_double), dimension(*) :: dfdy
    real(c_double), dimension(*) :: dfdt
    type(c_ptr), value :: params
    integer(c_int) :: jac
! 
    real(c_double), pointer :: mu
!
!    write(6, *) 'Calling jac'
    call c_f_pointer(params, mu)
    dfdy(1) = 0.0_c_double
    dfdy(2) = 1.0_c_double
    dfdy(3) = -2.0_c_double*mu*y(1)*y(2) - 1.0_c_double
    dfdy(4) = -mu*(y(1)*y(1) - 1.0_c_double)
    dfdt(1:2) = 0.0_c_double
    jac = fgsl_success
  end function jac
! functions for sorting
  function compare_double(x, y) bind(c)
    type(c_ptr), value :: x, y
    integer(c_int) :: compare_double
!
    real(fgsl_double), pointer :: xp, yp
    call c_f_pointer(x, xp)
    call c_f_pointer(y, yp)
!    write(6, *) xp, yp
    if (xp > yp) then
       compare_double = 1_c_int
    else if (xp < yp) then
       compare_double = -1_c_int
    else
       compare_double = 0_c_int
    end if
  end function compare_double
! functions for root finding tests
  function quadratic(x, params) bind(c)
    real(c_double), value :: x
    type(c_ptr), value :: params
    real(c_double) :: quadratic
!
    real(fgsl_double), pointer :: p(:)
    call c_f_pointer(params, p, (/3/))
    quadratic = (p(1)*x + p(2))*x + p(3)
  end function quadratic
  function quadratic_deriv(x, params) bind(c)
    real(c_double), value :: x
    type(c_ptr), value :: params
    real(c_double) :: quadratic_deriv
!
    real(fgsl_double), pointer :: p(:)
    call c_f_pointer(params, p, (/3/))
    quadratic_deriv = 2.0_fgsl_double*p(1)*x + p(2) 
  end function quadratic_deriv
  subroutine quadratic_fdf(x, params, y, dy) bind(c)
    real(c_double), value :: x
    type(c_ptr), value :: params
    real(c_double), intent(out) :: y, dy
!
    real(fgsl_double), pointer :: p(:)
    call c_f_pointer(params, p, (/3/))
    y = (p(1)*x + p(2))*x + p(3)
    dy = 2.0_fgsl_double*p(1)*x + p(2)
  end subroutine quadratic_fdf
  function power(x, params) bind(c)
    real(c_double), value :: x
    type(c_ptr), value :: params
    real(c_double) :: power
!
    real(fgsl_double), pointer :: p
    call c_f_pointer(params, p)
    power = x ** p
  end function power
!
! for minimization test
!
  function cosp1(x, params) bind(c)
    real(c_double), value :: x
    type(c_ptr), value :: params
    real(c_double) :: cosp1
!   
    cosp1 = cos(x) + 1.0d0
  end function cosp1
!
! for multiroot-finding
!
  function rosenbrock_f(x, params, f) bind(c)
    type(c_ptr), value :: x, params, f
    integer(c_int) :: rosenbrock_f
!
    type(fgsl_vector) :: fx, ff
    real(fgsl_double), pointer :: par(:), xv(:), yv(:)
    integer(fgsl_int) :: status
    call fgsl_obj_c_ptr(fx, x)
    call fgsl_obj_c_ptr(ff, f)
    call c_f_pointer(params, par, (/ 2 /))
    status = fgsl_vector_align(xv, fx)
    status = fgsl_vector_align(yv, ff)
    yv(1) = par(1) * (1.0_fgsl_double - xv(1))
    yv(2) = par(2) * (xv(2) - xv(1)*xv(1))
    rosenbrock_f = fgsl_success
  end function rosenbrock_f
  function rosenbrock_df(x, params, df) bind(c)
    type(c_ptr), value :: x, params, df
    integer(c_int) :: rosenbrock_df
!
    type(fgsl_vector) :: fx
    type(fgsl_matrix) :: dff
    real(fgsl_double), pointer :: par(:), xv(:), yv(:,:)
    integer(fgsl_int) :: status
    call fgsl_obj_c_ptr(fx, x)
    call fgsl_obj_c_ptr(dff, df)
    call c_f_pointer(params, par, (/ 2 /))
    status = fgsl_vector_align(xv, fx)
    status = fgsl_matrix_align(yv, dff)
    yv(1:2,1:2) = reshape( source = (/ -par(1), 0.0_fgsl_double , &
         -2.0_fgsl_double*par(2)*xv(1), par(2)  /), &
         shape = (/ 2, 2 /))
    rosenbrock_df = fgsl_success
  end function rosenbrock_df
  function rosenbrock_fdf(x, params, f, df) bind(c)
    type(c_ptr), value :: x, params, f, df
    integer(c_int) :: rosenbrock_fdf
!
    integer(c_int) :: status
    status = rosenbrock_f(x, params, f)
    status = rosenbrock_df(x, params, df)
    rosenbrock_fdf = fgsl_success
  end function rosenbrock_fdf
!
! Multimin
!
  function paraboloid_f(v, p) bind(c)
    type(c_ptr), value :: v, p
    real(c_double) :: paraboloid_f
!
    type(fgsl_vector) :: vec
    real(fgsl_double), pointer :: par(:), pvec(:)
    integer(fgsl_int) :: status
    call fgsl_obj_c_ptr(vec, v)
    call c_f_pointer(p, par, (/ 2 /))
    status = fgsl_vector_align(pvec, vec)
    paraboloid_f = 10.0_fgsl_double * (pvec(1)-par(1))**2 + &
         20.0_fgsl_double * (pvec(2)-par(2))**2 + 30.0_fgsl_double
  end function paraboloid_f
  subroutine paraboloid_df(v, p, df) bind(c)
    type(c_ptr), value :: v, p, df
!
    type(fgsl_vector) :: vec, grad
    real(fgsl_double), pointer :: par(:), pvec(:), pdf(:)
    integer(fgsl_int) :: status
    call fgsl_obj_c_ptr(vec, v)
    call fgsl_obj_c_ptr(grad, df)
    call c_f_pointer(p, par, (/ 2 /))
    status = fgsl_vector_align(pvec, vec)
    status = fgsl_vector_align(pdf, grad)
    pdf(1) = 20.0_fgsl_double * (pvec(1)-par(1))
    pdf(2) = 40.0_fgsl_double * (pvec(2)-par(2))
  end subroutine paraboloid_df
  subroutine paraboloid_fdf(v, p, f, df) bind(c)
    type(c_ptr), value :: v, p, df
    real(c_double) :: f
    f = paraboloid_f(v, p)
    call paraboloid_df(v, p, df)
  end subroutine paraboloid_fdf
! Least squares fitting
  function expb_f(x, cdata, f) bind(c)
    type(c_ptr), value :: x, cdata, f
    integer(c_int) :: expb_f
!
    type(fgsl_vector) :: f_x, f_f
    type(data), pointer :: f_data
    integer(fgsl_size_t) :: i
    integer(fgsl_int) :: status
    real(fgsl_double) :: yy
    real(fgsl_double), pointer :: p_x(:), p_f(:)
!
    call fgsl_obj_c_ptr(f_x, x)
    call fgsl_obj_c_ptr(f_f, f)
    status = fgsl_vector_align(p_x, f_x)
    status = fgsl_vector_align(p_f, f_f)
    call c_f_pointer(cdata, f_data)
    do i=1,f_data%n
       yy = p_x(1) * exp(- p_x(2) * dble(i-1) ) + p_x(3)
       p_f(i) = (yy - f_data%y(i))/f_data%sigma(i)
    end do
    expb_f = fgsl_success
  end function expb_f
  function expb_df(x, cdata, j) bind(c)
    type(c_ptr), value :: x, cdata, j
    integer(c_int) :: expb_df
!
    type(fgsl_vector) :: f_x
    type(fgsl_matrix) :: f_j
    type(data), pointer :: f_data
    integer(fgsl_size_t) :: i
    integer(fgsl_int) :: status
    real(fgsl_double) :: yy
    real(fgsl_double), pointer :: p_x(:), p_j(:,:)
!
    call fgsl_obj_c_ptr(f_x, x)
    call fgsl_obj_c_ptr(f_j, j)
    status = fgsl_vector_align(p_x, f_x)
    status = fgsl_matrix_align(p_j, f_j)
    call c_f_pointer(cdata, f_data)
    do i=1,f_data%n
       yy = exp(- p_x(2) * dble(i-1) )
       p_j(1,i) = yy / f_data%sigma(i)
       p_j(2,i) = - dble(i-1) * p_x(1) * yy / f_data%sigma(i)
       p_j(3,i) = 1 / f_data%sigma(i)
    end do
    expb_df = fgsl_success
  end function expb_df
  function expb_fdf(x, cdata, f, j) bind(c)
    type(c_ptr), value :: x, cdata, f, j
    integer(c_int) :: expb_fdf
!
    integer(c_int) :: status
    status = expb_f(x, cdata, f)
    status = expb_df(x, cdata, j)
    expb_fdf = fgsl_success
  end function expb_fdf
end module tmod
