program test_fgsl
!------------------------------------------------------------------------------
! Testing the Fortran interface to GSL
!------------------------------------------------------------------------------
  use fgsl
  use tmod
  implicit none
! 
  integer(fgsl_size_t), parameter :: nmax = 10, lda = 4, nfmax=19, ntmax=120
  integer, parameter :: num_tests=1000, itmax_root = 50
  real(fgsl_double), parameter :: eps = 1.0d-10
  real(fgsl_double), parameter :: eps2 = 1.0d-5, eps3 = 1.0d-3
  type(fgsl_function) :: stdfunc
  type(fgsl_function_fdf) :: stdfunc_fdf
  type(fgsl_error_handler_t) :: std
  type(fgsl_interp_accel) :: acc
  type(fgsl_interp) :: interp
  type(fgsl_spline) :: spline
  type(fgsl_poly_complex_workspace) :: wk
  type(fgsl_sf_result) :: sfres
  type(fgsl_vector) :: cvec, fvec, xvec, yvec, wvec, step
  type(fgsl_matrix) :: fmat, cov
!
  type(fgsl_permutation) :: p1, p2
  type(fgsl_integration_workspace) :: integ_wk
  type(fgsl_rng) :: rng
  type(fgsl_rng_type) :: rng_type
  type(fgsl_ntuple) :: ntuple
  type(fgsl_histogram) :: hist
  type(fgsl_siman_params_t) :: siman_params
  type(fgsl_odeiv_step) :: ode_step
  type(fgsl_odeiv_control) :: ode_ctrl
  type(fgsl_odeiv_evolve) :: ode_evlv
  type(fgsl_odeiv_system) :: ode_system
  type(fgsl_root_fsolver) :: root_fslv
  type(fgsl_root_fdfsolver) :: root_fdfslv
  type(fgsl_multiroot_fsolver) :: mroot_fslv
  type(fgsl_multiroot_function) :: mroot_f
  type(fgsl_multiroot_fdfsolver) :: mroot_fdfslv
  type(fgsl_multiroot_function_fdf) :: mroot_fdf
  type(fgsl_multimin_fminimizer) :: mmin_fmin
  type(fgsl_multimin_function) :: mmin_f
  type(fgsl_multimin_fdfminimizer) :: mmin_fdfmin
  type(fgsl_multimin_function_fdf) :: mmin_fdf
  type(fgsl_min_fminimizer) :: min_fslv
  type(fgsl_multifit_linear_workspace) :: lfit_ws
  type(fgsl_multifit_function_fdf) :: nlfit_fdf
  type(fgsl_multifit_fdfsolver) :: nlfit_slv
!
  type(fgsl_file) :: tfile
  character(kind=fgsl_char,len=fgsl_strmax) :: ieee_str1, ieee_str2
!
  type(data), target :: fitdata
!
  type(c_ptr) :: ptr, par_ptr
  integer :: i, j, nok
  integer(fgsl_int) :: status
  integer(fgsl_size_t) :: index, ivals(nmax), nsrt, istr, nrt
  integer(fgsl_size_t), pointer :: p_data(:)
  integer(fgsl_long) :: iarr(nmax),iarrdest(nmax)
  character(kind=fgsl_char, len=fgsl_strmax) :: name
  real(fgsl_double), dimension(nmax), target :: xa
  real(fgsl_double), dimension(nmax) :: ya, d, d2, di
  real(fgsl_double), dimension(lda, nmax), target :: a2d
  real(fgsl_double), dimension(3, nfmax), target :: xmf
  real(fgsl_double), dimension(3, ntmax) :: cmfstore
  real(fgsl_double), dimension(nfmax), target :: ymf, wmf
  real(fgsl_double), dimension(3), target :: cmf
  real(fgsl_double), dimension(3,3), target :: covmf
  real(fgsl_double), dimension(lda, nmax) :: b
  real(fgsl_double), pointer :: xptr(:), fptr(:), fmptr(:,:)
  real(c_double) :: y(2), dydt(2)
  real(c_double), target :: fpar(3), sarr(nmax), sarrdest(nmax)
  real(c_double), target :: xx, xv(3), stepv(2)
  real(fgsl_double) :: ra, rda, rd2a, ri, dmx, vmx, t, t1, h, xlo, xhi, &
        result, abserr, c0, c1, cov00, cov01, cov10, cov11, chisq
  complex(fgsl_double) :: z0, z1, z2, z(nmax)
  real(fgsl_float) :: ts
  logical :: test_ok, ok(num_tests)
!
  std = fgsl_set_error_handler_off()
  ok = .true.
  test_ok = .true.
  nok = 1
! NOTE: call of fdf_min routines gives float invalid/underflow
! the following attempts to suppress this
! (export GSL_IEEE_MODE="mask-invalid,mask-underflow,mask-denormalized")
! Need to check how to handle this in a better way
! (NAG aborts, g95 doesn't, bug in GSL????)
  call fgsl_ieee_env_setup()
!
! Polynomials
!
  d(1:2) = (/1.0_fgsl_double, 2.0_fgsl_double/)
  rda = fgsl_poly_eval(d, 2, 2.0_fgsl_double)
!  write(6, *) 'rda = ',rda, '(5?)'
  if (abs(rda - 5.0d0) > eps) test_ok = .false.
  
  call testres_toggle('fgsl_poly_eval',test_ok,ok,nok)
!
  xa(1:3) =  (/1.0_fgsl_double, 2.0_fgsl_double, 3.0_fgsl_double/)
  ya(1:3) =  (/1.0_fgsl_double, 8.0_fgsl_double, 3.0_fgsl_double/)
  status = fgsl_poly_dd_init(d2, xa, ya, 3_fgsl_size_t)
  rda = fgsl_poly_dd_eval(d2, xa, 3_fgsl_size_t, 2.0_fgsl_double)
!  write(6, *) 'rda = ',rda, '(8?)'
  if (abs(rda - 8.0d0) > eps .or. status /= fgsl_success) test_ok = .false.
  call testres_toggle('fgsl_poly_dd_init',test_ok,ok,nok)
!
  status = fgsl_poly_dd_taylor(di, 0.0_fgsl_double, d2, xa, 3_fgsl_size_t, d) 
  rda = di(1) + 2.0d0 * di(2) + 4.0d0 * di(3)
!  write(6, *) 'rda = ',rda, '(8?)'
  if (abs(rda - 8.0d0) > eps .or. status /= fgsl_success) test_ok = .false.
  call testres_toggle('fgsl_poly_dd_taylor',test_ok,ok,nok)
!
  status = fgsl_poly_solve_quadratic(1.0_fgsl_double, -3.0_fgsl_double, &
       2.0_fgsl_double, ra, ri)
!  write(6, *) 'ra = ',ra, '(1?); ri = ',ri, '(2?); status = ', status
  if (abs(ra - 1.0d0) > eps .or. abs(ri - 2.0d0) > eps .or. &
       status /= 2) test_ok = .false.
  call testres_toggle('fgsl_poly_solve_quadratic',test_ok,ok,nok)
!
  status = fgsl_poly_complex_solve_quadratic(1.0_fgsl_double,0.0_fgsl_double, &
       1.0_fgsl_double, z0, z1)
  if ( abs(z0 + (0.0d0,1.0d0)) > eps .or. abs(z1 - (0.0d0,1.0d0)) > eps &
       .or. status /= 2) test_ok = .false.
  call testres_toggle('fgsl_poly_complex_solve_quadratic',test_ok,ok,nok)
!
  status = fgsl_poly_solve_cubic(-6.0_fgsl_double,11.0_fgsl_double, &
       -6.0_fgsl_double, ra, ri, dmx)
 ! write(6, *) 'ra = ',ra, '(1?); ri = ',ri, '(2?); dmx = ',dmx, &
 !      '(3?); status = ', status
  if (abs(ra - 1.0d0) > eps .or. abs(ri - 2.0d0) > eps .or. &
       abs(dmx - 3.0d0) > eps .or. status /= 3) test_ok = .false.
  call testres_toggle('fgsl_poly_solve_cubic',test_ok,ok,nok)
!
  status = fgsl_poly_complex_solve_cubic(0.0_fgsl_double,0.0_fgsl_double, &
       -1.0_fgsl_double, z0, z1, z2)
  if ( abs(z0 - cos(2.0d0*m_pi/3.0d0) + (0.0d0,1.0d0)*sin(2.0d0*m_pi/3.0d0)) > eps &
       .or. abs(z2 - 1.0d0) > eps .or. abs(z1 - cos(2.0d0*m_pi/3.0d0) - &
       (0.0d0,1.0d0)*sin(2.0d0*m_pi/3.0d0)) > eps .or. status /= 3) test_ok = .false.
  call testres_toggle('fgsl_poly_complex_solve_cubic',test_ok,ok,nok)
!
  wk = fgsl_poly_complex_workspace_alloc(4_fgsl_size_t)
  status = -1
  xa(1:4) =  (/-1.0_fgsl_double, 0.0_fgsl_double, 0.0_fgsl_double, 1.0_fgsl_double/)
  if (.not. fgsl_well_defined(wk)) then
     test_ok=.false.
  else
     status = fgsl_poly_complex_solve(xa, 4_fgsl_size_t, wk, z)
  end if
!  write(6, *) 'complex roots z: ',z(1:3)
  if  ( abs(z(2) - cos(2.0d0*m_pi/3.0d0) + (0.0d0,1.0d0)*sin(2.0d0*m_pi/3.0d0)) > eps &
       .or. abs(z(3) - 1.0d0) > eps .or. abs(z(1) - cos(2.0d0*m_pi/3.0d0) - &
       (0.0d0,1.0d0)*sin(2.0d0*m_pi/3.0d0)) > eps .or. status /= fgsl_success) test_ok = .false.
  call fgsl_poly_complex_workspace_free(wk)
  call testres_toggle('fgsl_poly_complex_solve',test_ok,ok,nok)
!
! Special Functions
!
  ra = fgsl_sf_airy_ai(0.0_fgsl_double, fgsl_prec_double) 
  if (abs(ra - 0.35502805d0) > 1.0d-7) test_ok = .false.
  call testres_toggle('fgsl_sf_airy_ai',test_ok,ok,nok)
  status = fgsl_sf_airy_ai_e(0.0_fgsl_double, fgsl_prec_double, sfres)
  if (status /= fgsl_success .or. &
       abs(sfres%val - 0.3550280538878172d0) > sfres%err) test_ok = .false.
!  write(6, *) 'val/err was ',sfres
  call testres_toggle('fgsl_sf_airy_ai_e',test_ok,ok,nok)
  ra = fgsl_sf_airy_bi(0.0_fgsl_double, fgsl_prec_double) 
  if (abs(ra - 0.61492663d0) > 1.0d-7) test_ok = .false.
  call testres_toggle('fgsl_sf_airy_bi',test_ok,ok,nok)
  status = fgsl_sf_airy_bi_e(0.0_fgsl_double, fgsl_prec_double, sfres)
  if (status /= fgsl_success .or. &
       abs(sfres%val - 0.6149266274460007d0) > sfres%err) test_ok = .false.
!  write(6, *) 'val/err was ',sfres
  call testres_toggle('fgsl_sf_airy_bi_e',test_ok,ok,nok)
  status = fgsl_sf_airy_bi_e(0.0_fgsl_double, fgsl_prec_single, sfres)
  if (status /= fgsl_success .or. &
       abs(sfres%val - 0.6149266274460007d0) > sfres%err) test_ok = .false.
!  write(6, *) 'val/err was ',sfres
  call testres_toggle('fgsl_sf_airy_bi_e (single)',test_ok,ok,nok)
  status = fgsl_sf_airy_bi_e(0.0_fgsl_double, fgsl_prec_approx, sfres)
  if (status /= fgsl_success .or. &
       abs(sfres%val - 0.6149266274460007d0) > sfres%err) test_ok = .false.
!  write(6, *) 'val/err was ',sfres
  call testres_toggle('fgsl_sf_airy_bi_e (approx)',test_ok,ok,nok)
! FIXME  here many tests are missing still
  ra = fgsl_sf_bessel_jc0(1.0_fgsl_double) 
  if (abs(ra - 0.765197686557967d0) > eps) test_ok = .false.
  call testres_toggle('fgsl_sf_bessel_jc0',test_ok,ok,nok)
  ra = fgsl_sf_bessel_jc1(1.0_fgsl_double) 
  if (abs(ra - 0.4400505857d0) > eps) test_ok = .false.
  call testres_toggle('fgsl_sf_bessel_jc1',test_ok,ok,nok)
  ra = fgsl_sf_bessel_yc0(1.0_fgsl_double) 
  if (abs(ra - 0.0882569642d0) > eps) test_ok = .false.
  call testres_toggle('fgsl_sf_bessel_yc0',test_ok,ok,nok)
  ra = fgsl_sf_bessel_js0(1.0_fgsl_double) 
  if (abs(ra - 0.84147098d0) > 1.0d-7) test_ok = .false.
  call testres_toggle('fgsl_sf_bessel_js0',test_ok,ok,nok)
  ra = fgsl_sf_bessel_js1(1.0_fgsl_double) 
  if (abs(ra - 0.30116868) > 1.0d-7) test_ok = .false.
  call testres_toggle('fgsl_sf_bessel_js1',test_ok,ok,nok)
  ra = fgsl_sf_bessel_js2(1.0_fgsl_double) 
  if (abs(ra - 0.062035052d0) > 1.0d-7) test_ok = .false.
  call testres_toggle('fgsl_sf_bessel_js2',test_ok,ok,nok)
  ra = fgsl_sf_bessel_ys0(1.0_fgsl_double) 
  if (abs(ra + 0.54030231d0) > 1.0d-7) test_ok = .false.
  call testres_toggle('fgsl_sf_bessel_ys0',test_ok,ok,nok)
! elliptic functions
  ra = fgsl_sf_ellint_kcomp(0.5_fgsl_double, fgsl_prec_double) 
!  write(6, *) 'ra = ', ra
  if (abs(ra - 1.685750354812596d0) > eps) test_ok = .false.
  call testres_toggle('fgsl_sf_ellint_kcomp',test_ok,ok,nok)
  ra = fgsl_sf_ellint_ecomp(0.5_fgsl_double, fgsl_prec_double) 
!  write(6, *) 'ra = ', ra
  if (abs(ra - 1.46746220933d0) > eps) test_ok = .false.
  call testres_toggle('fgsl_sf_ellint_ecomp',test_ok,ok,nok)
  ra = fgsl_sf_ellint_f(m_pi/2,0.5_fgsl_double, fgsl_prec_double) 
!  write(6, *) 'ra = ', ra
  if (abs(ra - 1.685750354812596d0) > eps) test_ok = .false.
  call testres_toggle('fgsl_sf_ellint_f',test_ok,ok,nok)
  ra = fgsl_sf_ellint_e(m_pi/2, 0.5_fgsl_double, fgsl_prec_double) 
!  write(6, *) 'ra = ', ra
  if (abs(ra - 1.46746220933d0) > eps) test_ok = .false.
  call testres_toggle('fgsl_sf_ellint_e',test_ok,ok,nok)
  ra = fgsl_sf_ellint_p(m_pi/2, dsqrt(0.75d0), -0.5_fgsl_double, fgsl_prec_double) 
!  write(6, *) 'ra = ', ra
  if (abs(ra - 3.234773471249465d0) > eps) test_ok = .false.
  call testres_toggle('fgsl_sf_ellint_e',test_ok,ok,nok)
!
! Array processing
!
! vector
  do i=1,nmax
     xa(i) = dble(i)
  end do
  fvec = fgsl_vector_init(1.0_fgsl_double)
  status = fgsl_vector_align(xa,nmax,fvec,3_fgsl_size_t,1_fgsl_size_t,&
       2_fgsl_size_t)
!  write(6, *) 'Status: ',status,fgsl_success
  if (status /= fgsl_success) test_ok = .false.
  ya(1:3) = fvec
!  write(6, *) 'ya: ',ya(1:3)
  if (abs(ya(1)-2.0_fgsl_double) > eps .or. abs(ya(2)-4.0_fgsl_double) > eps .or. &
       abs(ya(3)-6.0_fgsl_double) > eps)  test_ok = .false.
  status = fgsl_vector_align(fptr,fvec)
  if (abs(fptr(1)-2.0_fgsl_double) > eps .or. abs(fptr(2)-4.0_fgsl_double) > eps .or. &
       abs(fptr(3)-6.0_fgsl_double) > eps .or. size(fptr) /= 3)  test_ok = .false.
  call fgsl_vector_free(fvec)
  call testres_toggle('fgsl_vector',test_ok,ok,nok)
! matrix
  do j=1,6
     do i=1,3
        a2d(i, j) = 10*j+i
     end  do
  end do
  fmat = fgsl_matrix_init(1.0_fgsl_double)
  status = fgsl_matrix_align(a2d, lda, 3_fgsl_size_t,6_fgsl_size_t,fmat)
  if (status /= fgsl_success) test_ok = .false.
  b(1:3,1:6) = fmat
  dmx = 0.0_fgsl_double
  do j=1,6
     do i=1,3
!        write(6, *) 'i, j, a, b: ', i, j, a2d(i, j), b(i, j)
        dmx = dmx + abs(b(i, j) - dble(10*j+i))
!        write(6, *) 'dmx : ', dmx
     end  do
  end do
  if (dmx > eps)  test_ok = .false.
  status = fgsl_matrix_align(fmptr,fmat)
  if (size(fmptr,1) /= 3 .or. size(fmptr,2) /= 6) test_ok = .false.
  dmx = 0.0_fgsl_double
  do j=1,6
     do i=1,3
        dmx = dmx + abs(fmptr(i, j) - dble(10*j+i))
     end  do
  end do
  if (dmx > eps)  test_ok = .false.
  call fgsl_matrix_free(fmat)
  call testres_toggle('fgsl_matrix',test_ok,ok,nok)
!
! Interpolation
!   not all interpolation types are checked since interface is invariant
!
  do i=1,nmax
     xa(i) = dble(i-1)
     ya(i) = dble(i-1)**3.0_fgsl_double
     d(i) =  3.0_fgsl_double * dble(i-1)**2.0_fgsl_double
     d2(i) =  6.0_fgsl_double * dble(i-1)
     di(i) =  1/4.0_fgsl_double * dble(i-1)**4.0_fgsl_double
  end do
! this only needed once
  acc = fgsl_interp_accel_alloc()
! cspline
  interp = fgsl_interp_alloc(fgsl_interp_cspline,nmax)
  name = fgsl_interp_name(interp)
!  write(6, *) name
  status = fgsl_interp_init(interp,xa,ya,nmax)
  dmx = 0.0d0
  do i=2,nmax
     ra = fgsl_interp_eval(interp, xa, ya, xa(i), acc)
     rda = fgsl_interp_eval_deriv(interp, xa, ya, xa(i), acc)
     rd2a = fgsl_interp_eval_deriv2(interp, xa, ya, xa(i), acc)
!     write(6, fmt='(3(1pd20.13,1x))') ra, rda, rd2a
!     write(6, fmt='(3(1pd20.13,1x))') ya(i),d(i),d2(i)
     dmx = max(dmx, abs(ra - ya(i)))
  end do
  call fgsl_interp_free(interp)
! write(6, *) 'Name is: ',trim(name)
  if (dmx > eps .or. trim(name) /= 'cspline') test_ok = .false.
  call testres_toggle('fgsl_interp',test_ok,ok,nok)
! cspline high-level interface
  spline = fgsl_spline_alloc(fgsl_interp_cspline,nmax)
  name = fgsl_spline_name(spline)
!  write(6, *) name
  status = fgsl_spline_init(spline,xa,ya,nmax)
  dmx = 0.0d0
  do i=2,nmax
     ra = fgsl_spline_eval(spline, xa(i), acc)
     rda = fgsl_spline_eval_deriv(spline, xa(i), acc)
     rd2a = fgsl_spline_eval_deriv2(spline, xa(i), acc)
     ri = fgsl_spline_eval_integ(spline, 0.0_fgsl_double, xa(i), acc)
!     write(6, fmt='(3(1pd20.13,1x))') ra, rda, rd2a
!     write(6, fmt='(3(1pd20.13,1x))') ya(i),d(i),d2(i)
     dmx = max(dmx, abs(ra - ya(i)))
  end do
  call fgsl_spline_free(spline)
  if (dmx > eps .or. trim(name) /= 'cspline') test_ok = .false.
  call testres_toggle('fgsl_spline',test_ok,ok,nok)
! polynomial
  interp = fgsl_interp_alloc(fgsl_interp_polynomial,4_fgsl_size_t)
  name = fgsl_interp_name(interp)
!  write(6, *) name
  status = fgsl_interp_init(interp,xa,ya,4_fgsl_size_t)
  dmx = 0.0d0
  do i=2,nmax
     ra = fgsl_interp_eval(interp, xa, ya, xa(i), acc)
     rda = fgsl_interp_eval_deriv(interp, xa, ya, xa(i), acc)
     rd2a = fgsl_interp_eval_deriv2(interp, xa, ya, xa(i), acc)
     ri = fgsl_interp_eval_integ(interp, xa, ya, 0.0_fgsl_double, xa(i), acc)
!     write(6, fmt='(4(1pd20.13,1x))') ra, rda, rd2a, ri
!     write(6, fmt='(4(1pd20.13,1x))') ya(i),d(i),d2(i), di(i)
     dmx = max(dmx, abs(ra - ya(i)))
     dmx = max(dmx, abs(rda - d(i)))
     dmx = max(dmx, abs(rd2a - d2(i)))
     dmx = max(dmx, abs(ri - di(i)))
  end do
  call fgsl_interp_free(interp)
  if (dmx > eps .or. trim(name) /= 'polynomial') test_ok = .false.
  call testres_toggle('fgsl_interp-2',test_ok,ok,nok)
! acc routines
  index = fgsl_interp_bsearch(xa, 1.5_fgsl_double,1_fgsl_size_t,nmax)
!  write(6, *) 'bsearch: index is ', index
  if (index /= 2)  test_ok = .false.
  call testres_toggle('fgsl_interp_bsearch',test_ok,ok,nok)
  index = fgsl_interp_accel_find(acc, xa, nmax, 1.5_fgsl_double)
!  write(6, *) 'find: index is ', index
  if (index /= 2)  test_ok = .false.
  call testres_toggle('fgsl_interp_accel_find',test_ok,ok,nok)
! cleanup
  call fgsl_interp_accel_free(acc)
!
! Permutations and combinations
!
  if (fgsl_well_defined(p1)) test_ok = .false.
  p1 = fgsl_permutation_alloc(4_fgsl_size_t)
  p2 = fgsl_permutation_alloc(4_fgsl_size_t)
  if (.not. (fgsl_well_defined(p1) .and. fgsl_well_defined(p2))) test_ok = .false.
  call fgsl_permutation_init(p1)
  call fgsl_permutation_init(p2)
  status = fgsl_permutation_swap(p1, 1_fgsl_size_t, 3_fgsl_size_t)
  index = fgsl_permutation_get(p1,1_fgsl_size_t)
  if (index /= 3) test_ok = .false.
  index = fgsl_permutation_get(p1,3_fgsl_size_t)
  if (index /= 1) test_ok = .false.
  status = fgsl_permutation_valid(p1)
  if (status /= fgsl_success) test_ok = .false.
  index = fgsl_permutation_size(p1)
  if (index /= 4) test_ok = .false.
!  write(6, *) 'Index = ',index
  p_data => fgsl_permutation_data(p1)
!  write(6, *) 'Size p_data is',size(p_data),associated(p_data)
  if (p_data(1) /= 0 .or. p_data(2) /= 3 .or. &
       p_data(3) /= 2 .or. p_data(4) /= 1) test_ok = .false.
  call testres_toggle('fgsl_permutation',test_ok,ok,nok)
!  write(6, *) 'permutations done'
  call fgsl_permutation_free(p1)
  call fgsl_permutation_free(p2)
!
! numerical quadrature
!
  xx = 1.0D0
  ptr = c_loc(xx)
  stdfunc = fgsl_function_init(integrate_fun1, ptr)
  integ_wk = fgsl_integration_workspace_alloc(1000_fgsl_size_t)
  status = fgsl_integration_qags(stdfunc, 0.0_fgsl_double, 1.0_fgsl_double, &
       0.0_fgsl_double, 1.0e-7_fgsl_double, 1000_fgsl_size_t, integ_wk, ra, rda); 
  if (status /= fgsl_success) test_ok = .false.
!  write(6, *) 'Integration result and error: ', ra, rda
  if (abs(ra + 4.0d0) > eps) test_ok = .false.
  call fgsl_function_free(stdfunc)
  call fgsl_integration_workspace_free(integ_wk)
  call testres_toggle('fgsl_integration',test_ok,ok,nok)
!
! histograms
!
  hist = fgsl_histogram_alloc(ntmax)
  if (fgsl_well_defined(hist)) then
     status = fgsl_histogram_set_ranges_uniform(hist, 0.0_fgsl_double, 3.6_fgsl_double)
     if (status /= fgsl_success) test_ok = .false.
     t = 0.1_fgsl_double
     do i=1, ntmax
        ra = sqrt(t)
        status = fgsl_histogram_increment(hist, ra)
        if (status /= fgsl_success) then
           test_ok = .false.
           exit
        end if
        t = t + 0.1_fgsl_double
     end do
  else
     test_ok = .false.
  end if
  tfile = fgsl_open('hist.dat','w+')
  status = fgsl_histogram_fprintf(tfile,hist,'%16.8f ','%16.8f ')
  status = fgsl_close(tfile)
  open(20, file='hist.dat',form='FORMATTED',status='OLD')
  do i=1, 115
     read(20, fmt=*) cmf
!     write(6, '(3(1PD15.8,1X))') cmf
  end do
  if (abs(cmf(1) - 3.42_fgsl_double) > eps .or. &
       abs(cmf(2) - 3.45_fgsl_double) > eps .or. &
       abs(cmf(3) - 3.0_fgsl_double) > eps) test_ok = .false.
!  close(20, status='DELETE')
  call fgsl_histogram_free(hist)
  call testres_toggle('fgsl_histogram',test_ok,ok,nok)
!
! Ntuples
!
  ptr = c_loc(cmf)
  ntuple = fgsl_ntuple_create('test.dat',ptr,24_fgsl_size_t)
  if (.not. fgsl_well_defined(ntuple)) test_ok = .false.
  rng = fgsl_rng_alloc(fgsl_rng_default)
  do i=1, ntmax
     cmf(1) = fgsl_ran_ugaussian(rng)
     cmf(2) = fgsl_ran_ugaussian(rng)
     cmf(3) = fgsl_ran_ugaussian(rng)
     cmfstore(1:3,i) = cmf
!     write(6, *) cmf
     status = fgsl_ntuple_write(ntuple)
     if (status /= fgsl_success) test_ok = .false.
  end do
  status = fgsl_ntuple_close(ntuple)
  if (status /= fgsl_success) test_ok = .false.
  ntuple = fgsl_ntuple_open('test.dat',ptr,24_fgsl_size_t)
  if (fgsl_well_defined(ntuple)) then
     do i=1, ntmax
        status = fgsl_ntuple_read(ntuple)
        dmx = abs(cmf(1)-cmfstore(1,i)) + &
             abs(cmf(2)-cmfstore(2,i)) + &
             abs(cmf(3)-cmfstore(3,i))
        if (dmx > eps) test_ok = .false.
     end do
     status = fgsl_ntuple_close(ntuple)
     if (status /= fgsl_success) test_ok = .false.
  else
     test_ok = .false.
  end if
  open(20,file='test.dat',form='FORMATTED',status='OLD')
  close(20,status='DELETE')
! FIXME test further ntuple stuff 
  call fgsl_rng_free(rng)
  call testres_toggle('fgsl_ntuple',test_ok,ok,nok)
!
! Sorting
!
  nsrt = 5
  istr = 1
  sarr(1:nsrt) = (/2.0_fgsl_double, 2.2_fgsl_double, -2.0_fgsl_double, -4.0_fgsl_double, &
       5.2_fgsl_double/)
  ptr = c_loc(sarr)
! FIXME fgsl_sizeof missing
  call fgsl_heapsort(ptr, nsrt, 8_fgsl_size_t, compare_double)
  if (sarr(1) /= -4.0_fgsl_double .or. sarr(2) /= -2.0_fgsl_double .or. &
       sarr(3) /= 2.0_fgsl_double .or. sarr(4) /= 2.2_fgsl_double .or. &
       sarr(5) /= 5.2_fgsl_double) test_ok = .false.
!  write(6, *) 'sarr = ',sarr(1:nsrt)
  sarr(1:nsrt) = (/2.0_fgsl_double, 2.2_fgsl_double, -2.0_fgsl_double, -4.0_fgsl_double, &
       5.2_fgsl_double/)
  status = fgsl_heapsort_index(ivals, ptr, nsrt, 8_fgsl_size_t, compare_double)
  if (ivals(1) /= 3 .or. ivals(2) /= 2 .or. ivals(3) /= 0 .or. ivals(4) /= 1 .or. &
       ivals(5) /= 4 .or. status /= fgsl_success) test_ok = .false.
  call testres_toggle('fgsl_heapsort',test_ok,ok,nok)
  nsrt = 3
  istr = 2
  sarr(1:6) = (/2.0_fgsl_double, 0.2_fgsl_double, -2.0_fgsl_double, 0.2_fgsl_double, &
       0.2_fgsl_double, 3.3_fgsl_double/)
  call fgsl_sort(sarr, istr, nsrt)
  if (sarr(1) /= -2.0_fgsl_double .or. sarr(2) /= 0.2_fgsl_double .or. &
       sarr(3) /= 0.2_fgsl_double .or. sarr(4) /= 0.2_fgsl_double .or. &
       sarr(5) /= 2.0_fgsl_double .or. sarr(6) /= 3.3_fgsl_double) test_ok = .false.
  nsrt = 5
  istr = 1
  sarr(1:nsrt) = (/2.0_fgsl_double, 2.2_fgsl_double, -2.0_fgsl_double, -4.0_fgsl_double, &
       5.2_fgsl_double/)
  call fgsl_sort_index(ivals,sarr, istr, nsrt)
  if (ivals(1) /= 3 .or. ivals(2) /= 2 .or. ivals(3) /= 0 .or. ivals(4) /= 1 .or. &
       ivals(5) /= 4 .or. status /= fgsl_success) test_ok = .false.
  status = fgsl_sort_smallest(sarrdest, 2_fgsl_size_t, sarr, istr, nsrt)
  if (sarrdest(1) /= -4.0_fgsl_double .or. sarrdest(2) /= -2.0_fgsl_double .or. &
       status /= fgsl_success) test_ok = .false. 
  status = fgsl_sort_smallest_index(ivals, 2_fgsl_size_t, sarr, istr, nsrt)
  if (ivals(1) /= 3 .or. ivals(2) /= 2 .or. status /= fgsl_success) test_ok = .false.
  status = fgsl_sort_largest(sarrdest, 2_fgsl_size_t, sarr, istr, nsrt)
  if (sarrdest(1) /= 5.2_fgsl_double .or. sarrdest(2) /= 2.2_fgsl_double .or. &
       status /= fgsl_success) test_ok = .false. 
  status = fgsl_sort_largest_index(ivals, 2_fgsl_size_t, sarr, istr, nsrt)
  if (ivals(1) /= 4 .or. ivals(2) /= 1 .or. status /= fgsl_success) test_ok = .false.
!
  nsrt = 3
  istr = 2
  iarr(1:6) = (/2_fgsl_long, 0_fgsl_long, -2_fgsl_long, 0_fgsl_long, &
       0_fgsl_long, 3_fgsl_long/)
  call fgsl_sort(iarr, istr, nsrt)
  if (iarr(1) /= -2_fgsl_long .or. iarr(2) /= 0_fgsl_long .or. &
       iarr(3) /= 0_fgsl_long .or. iarr(4) /= 0_fgsl_long .or. &
       iarr(5) /= 2_fgsl_long .or. iarr(6) /= 3_fgsl_long) test_ok = .false.
!  write(6, *) 'iarr is ', iarr(1:6)
  nsrt = 5
  istr = 1
  iarr(1:nsrt) = (/1_fgsl_long, 2_fgsl_long, -2_fgsl_long, -4_fgsl_long, &
       5_fgsl_long/)
  call fgsl_sort_index(ivals,iarr, istr, nsrt)
  if (ivals(1) /= 3 .or. ivals(2) /= 2 .or. ivals(3) /= 0 .or. ivals(4) /= 1 .or. &
       ivals(5) /= 4 .or. status /= fgsl_success) test_ok = .false.
  status = fgsl_sort_smallest(iarrdest, 2_fgsl_size_t, iarr, istr, nsrt)
  if (iarrdest(1) /= -4_fgsl_long .or. iarrdest(2) /= -2_fgsl_long .or. &
       status /= fgsl_success) test_ok = .false. 
  status = fgsl_sort_smallest_index(ivals, 2_fgsl_size_t, iarr, istr, nsrt)
  if (ivals(1) /= 3 .or. ivals(2) /= 2 .or. status /= fgsl_success) test_ok = .false.
  status = fgsl_sort_largest(iarrdest, 2_fgsl_size_t, iarr, istr, nsrt)
  if (iarrdest(1) /= 5_fgsl_long .or. iarrdest(2) /= 2_fgsl_long .or. &
       status /= fgsl_success) test_ok = .false. 
  status = fgsl_sort_largest_index(ivals, 2_fgsl_size_t, iarr, istr, nsrt)
  if (ivals(1) /= 4 .or. ivals(2) /= 1 .or. status /= fgsl_success) test_ok = .false.
  call testres_toggle('fgsl_sort',test_ok,ok,nok)
!
! Simulated Annealing
!
!  rng_type = fgsl_rng_env_setup()
  rng = fgsl_rng_alloc(fgsl_rng_default)
  xx = 15.5_fgsl_double
  ptr = c_loc(xx)
  call fgsl_siman_params_init(siman_params, 200, 10, 10.0_fgsl_double, &
       1.0_fgsl_double, 0.002_fgsl_double, 1.005_fgsl_double, 2.0e-6_fgsl_double) 
!  call fgsl_siman_solve(rng, ptr, e1, s1, m1, pp1, &
  call fgsl_siman_solve(rng, ptr, e1, s1, m1, &
       element_size=8_fgsl_size_t, params=siman_params)
!  write(6, *) xx
  if (abs(xx-1.3633498) > eps2) test_ok = .false.
  call fgsl_siman_params_free(siman_params)
  call fgsl_rng_free(rng)
  call testres_toggle('fgsl_siman',test_ok,ok,nok)
!
! Ordinary Differential Equations 
!
!  ode_step = fgsl_odeiv_step_alloc(fgsl_odeiv_step_rk8pd,2_fgsl_size_t)
! Note: bsimp uses the jacobian and gives consistency indicated below
  ode_step = fgsl_odeiv_step_alloc(fgsl_odeiv_step_bsimp,2_fgsl_size_t)
  name = fgsl_odeiv_step_name(ode_step)
!  write(6, *) 'ode_step_alloc of type ',trim(name),' done'
! FIXME: well_defined checks missing
  ode_ctrl = fgsl_odeiv_control_y_new(1.0e-6_fgsl_double, 0.0_fgsl_double)
  ode_evlv = fgsl_odeiv_evolve_alloc(2_fgsl_size_t)
  xx = 10.0e0_c_double
  ptr = c_loc(xx)
  ode_system = fgsl_odeiv_system_init(func_ode, 2_c_size_t, ptr, jac)
!
  t = 0.0_fgsl_double; t1 = 100.0_fgsl_double
  h = 1.0e-6_fgsl_double; y = (/1.0_c_double, 0.0_c_double /)
  do while (t < t1) 
     status = fgsl_odeiv_evolve_apply(ode_evlv, ode_ctrl, ode_step, ode_system, & 
          t, t1, h, y)
     if (status /= fgsl_success) exit
!     write(6,fmt='(3E15.8,1X)') t, y(1), y(2)
  end do
  call fgsl_odeiv_evolve_free (ode_evlv)
  call fgsl_odeiv_control_free (ode_ctrl)
  call fgsl_odeiv_step_free (ode_step)
  call fgsl_odeiv_system_free(ode_system)
  if (status /= fgsl_success .or. abs(y(1) + 1.758888) > 1.0e-5 .or. &
       abs(y(2) - 0.083643595) > 1.0e-6) test_ok = .false.
  call testres_toggle('fgsl_ode',test_ok,ok,nok)
!
! Numerical differentiation
!
  fpar = (/1.5_fgsl_double, 0.0_fgsl_double, 0.0_fgsl_double/)
  ptr = c_loc(fpar)
  stdfunc = fgsl_function_init(power, ptr)
  status = fgsl_deriv_central(stdfunc, 2.0_fgsl_double, eps2, result, abserr)
  if (status /= fgsl_success .or. abs(result - 1.5d0*sqrt(2.0d0)) > abserr) then
     test_ok = .false.
  end if
  status = fgsl_deriv_forward(stdfunc, 2.0_fgsl_double, eps2, result, abserr)
  if (status /= fgsl_success .or. abs(result - 1.5d0*sqrt(2.0d0)) > abserr) then
     test_ok = .false.
  end if
  status = fgsl_deriv_backward(stdfunc, 2.0_fgsl_double, eps2, result, abserr)
  if (status /= fgsl_success .or. abs(result - 1.5d0*sqrt(2.0d0)) > abserr) then
     test_ok = .false.
  end if
!  write(6, *) result, abserr, 1.5d0*sqrt(2.0d0)
  call fgsl_function_free(stdfunc)
  call testres_toggle('fgsl_deriv',test_ok,ok,nok)
!
! One dimensional root finding
!
  fpar = (/1.0_fgsl_double, 0.0_fgsl_double, -5.0_fgsl_double/)
  ptr = c_loc(fpar)
!
  root_fslv = fgsl_root_fsolver_alloc(fgsl_root_fsolver_brent)
  if (fgsl_well_defined(root_fslv)) then
     stdfunc = fgsl_function_init(quadratic, ptr)
     status = fgsl_root_fsolver_set(root_fslv, stdfunc, 0.0_fgsl_double, &
          5.0_fgsl_double)
     name = fgsl_root_fsolver_name (root_fslv)
     if (trim(name) /= 'brent') test_ok = .false.
     i = 0
     do
        i = i + 1
        status = fgsl_root_fsolver_iterate(root_fslv)
        if (status /= fgsl_success .or. i > itmax_root) then
           test_ok = .false.
           exit
        end if
        ra = fgsl_root_fsolver_root(root_fslv)
        xlo = fgsl_root_fsolver_x_lower(root_fslv)
        xhi = fgsl_root_fsolver_x_upper(root_fslv)
        status = fgsl_root_test_interval (xlo, xhi, 0.0_fgsl_double, eps2)
        if (status == fgsl_success) exit
     end do
  else
     test_ok = .false.
  end if
  if (abs(ra - sqrt(5.0_fgsl_double)) > eps2) test_ok = .false.
  call fgsl_root_fsolver_free(root_fslv)
  call fgsl_function_free(stdfunc)
  call testres_toggle('fgsl_roots',test_ok,ok,nok)
!
  root_fdfslv = fgsl_root_fdfsolver_alloc(fgsl_root_fdfsolver_newton)
  if (fgsl_well_defined(root_fdfslv)) then
     stdfunc_fdf = fgsl_function_fdf_init(quadratic, quadratic_deriv, &
          quadratic_fdf, ptr)
     status = fgsl_root_fdfsolver_set(root_fdfslv, stdfunc_fdf, &
          5.0_fgsl_double)
     name = fgsl_root_fdfsolver_name (root_fdfslv)
     if (trim(name) /= 'newton') test_ok = .false.
     i = 0
     ra = 0
     do
        i = i + 1
        status = fgsl_root_fdfsolver_iterate(root_fdfslv)
        if (status /= fgsl_success .or. i > itmax_root) then
           test_ok = .false.
           exit
        end if
        ri = ra
        ra = fgsl_root_fdfsolver_root(root_fdfslv)
        status = fgsl_root_test_delta (ra, ri, 0.0_fgsl_double, eps2)
        if (status == fgsl_success) exit
     end do
  else
     test_ok = .false.
  end if
  if (abs(ra - sqrt(5.0_fgsl_double)) > eps2) test_ok = .false.
!  write(6, *) ra, sqrt(5.0d0), i
  call fgsl_root_fdfsolver_free(root_fdfslv)
  call fgsl_function_fdf_free(stdfunc_fdf)
  call testres_toggle('fgsl_roots_fdf',test_ok,ok,nok)
!
! One-dimensional minimization
!
  min_fslv = fgsl_min_fminimizer_alloc(fgsl_min_fminimizer_brent)
  if (fgsl_well_defined(min_fslv)) then
     stdfunc = fgsl_function_init(cosp1, ptr)
     status = fgsl_min_fminimizer_set(min_fslv, stdfunc, 3.0_fgsl_double, 0.0_fgsl_double, &
          6.0_fgsl_double)
     name = fgsl_min_fminimizer_name(min_fslv)
     if (trim(name) /= 'brent') test_ok = .false.
     i = 0
     do
        i = i + 1
        status = fgsl_min_fminimizer_iterate(min_fslv)
        if (status /= fgsl_success .or. i > itmax_root) then
           test_ok = .false.
           exit
        end if
        ra = fgsl_min_fminimizer_x_minimum(min_fslv)
        xlo = fgsl_min_fminimizer_x_lower(min_fslv)
        xhi = fgsl_min_fminimizer_x_upper(min_fslv)
        status = fgsl_min_test_interval (xlo, xhi, eps2, 0.0_fgsl_double)
        if (status == fgsl_success) exit
     end do
  else
     test_ok = .false.
  end if
  if (abs(ra - m_pi) > eps2) test_ok = .false.
  call fgsl_min_fminimizer_free(min_fslv)
  call fgsl_function_free(stdfunc)
  call testres_toggle('fgsl_min',test_ok,ok,nok)
!
! Multi-root
!
! fsolver
  nrt = 2
  mroot_fslv = fgsl_multiroot_fsolver_alloc(fgsl_multiroot_fsolver_hybrids,nrt)
  name = fgsl_multiroot_fsolver_name(mroot_fslv)
  if (trim(name) /= "hybrids") test_ok = .false.
! initialize function object
  fpar(1:2) = (/1.0_fgsl_double, 10.0_fgsl_double/)
  ptr = c_loc(fpar)
  mroot_f = fgsl_multiroot_function_init(rosenbrock_f,nrt,ptr)
!
  xv(1:2) = (/-10.0_fgsl_double, -5.0_fgsl_double/)
  xvec = fgsl_vector_init(1.0_fgsl_double)
  status = fgsl_vector_align(xv,nrt,xvec,nrt,0_fgsl_size_t,1_fgsl_size_t)
!  ya(1:2) = xvec
!  write(6, *) 'status = ', status, ' vec: ',ya(1:2)
  if (status /= fgsl_success) test_ok = .false.
  status = fgsl_multiroot_fsolver_set(mroot_fslv, mroot_f, xvec)
  call fgsl_vector_free(xvec)
!  write(6, *) 'status = ', status
  if (status /= fgsl_success) test_ok = .false.
  fvec = fgsl_multiroot_fsolver_f(mroot_fslv)
  status = fgsl_vector_align(fptr, fvec)
  xvec = fgsl_multiroot_fsolver_root(mroot_fslv)
  status = fgsl_vector_align(xptr, xvec)
  if (fgsl_well_defined(mroot_fslv)) then
     i = 0
!     write(6,'('' It.              X                     F(X) '')')
     do
!        write(6, '(1x,i2,1x,2(1f12.5),1x,2(1f12.5))') i, xptr(1:2), fptr(1:2)
        i = i + 1
        status = fgsl_multiroot_fsolver_iterate(mroot_fslv);
        if (status /= fgsl_success .or. i > itmax_root) then
           test_ok = .false.
           exit
        end if
        status = fgsl_multiroot_test_residual(fvec, 1.0E-7_fgsl_double)
        if (status == fgsl_success) then 
!           write(6, '(1x,i2,1x,2(1f12.5),1x,2(1f12.5))') i, xptr(1:2), fptr(1:2)
           exit
        end if
     end do
  end if
  call fgsl_multiroot_fsolver_free(mroot_fslv)
  call fgsl_multiroot_function_free(mroot_f)
  call testres_toggle('fgsl_f_multiroot',test_ok,ok,nok)
! fdfsolver
  nrt = 2
  mroot_fdfslv = fgsl_multiroot_fdfsolver_alloc(fgsl_multiroot_fdfsolver_gnewton,nrt)
  name = fgsl_multiroot_fdfsolver_name(mroot_fdfslv)
  if (trim(name) /= "gnewton") test_ok = .false.
! initialize function object
  fpar(1:2) = (/1.0_fgsl_double, 10.0_fgsl_double/)
  ptr = c_loc(fpar)
  mroot_fdf = fgsl_multiroot_function_fdf_init(rosenbrock_f,rosenbrock_df, &
       rosenbrock_fdf,nrt,ptr)
!
  xv(1:2) = (/-10.0_fgsl_double, -5.0_fgsl_double/)
  xvec = fgsl_vector_init(1.0_fgsl_double)
  status = fgsl_vector_align(xv,nrt,xvec,nrt,0_fgsl_size_t,1_fgsl_size_t)
!  ya(1:2) = xvec
!  write(6, *) 'status = ', status, ' vec: ',ya(1:2)
  if (status /= fgsl_success) test_ok = .false.
  status = fgsl_multiroot_fdfsolver_set(mroot_fdfslv, mroot_fdf, xvec)
  call fgsl_vector_free(xvec)
!  write(6, *) 'status = ', status
  if (status /= fgsl_success) test_ok = .false.
  fvec = fgsl_multiroot_fdfsolver_f(mroot_fdfslv)
  status = fgsl_vector_align(fptr, fvec)
  xvec = fgsl_multiroot_fdfsolver_root(mroot_fdfslv)
  status = fgsl_vector_align(xptr, xvec)
  if (fgsl_well_defined(mroot_fdfslv)) then
     i = 0
!     write(6,'('' It.              X                     F(X) '')')
     do
!        write(6, '(1x,i2,1x,2(1f12.5),1x,2(1f12.5))') i, xptr(1:2), fptr(1:2)
        i = i + 1
        status = fgsl_multiroot_fdfsolver_iterate(mroot_fdfslv);
        if (status /= fgsl_success .or. i > itmax_root) then
           test_ok = .false.
           exit
        end if
        status = fgsl_multiroot_test_residual(fvec, 1.0E-7_fgsl_double)
        if (status == fgsl_success) then 
!           write(6, '(1x,i2,1x,2(1f12.5),1x,2(1f12.5))') i, xptr(1:2), fptr(1:2)
           exit
        end if
     end do
  end if
  call fgsl_multiroot_fdfsolver_free(mroot_fdfslv)
  call fgsl_multiroot_function_fdf_free(mroot_fdf)
  call testres_toggle('fgsl_fdf_multiroot',test_ok,ok,nok)
!
! Multi-minimizer
!
! fminimizer
  nrt = 2
  mmin_fmin = fgsl_multimin_fminimizer_alloc(fgsl_multimin_fminimizer_nmsimplex,nrt)
  name = fgsl_multimin_fminimizer_name(mmin_fmin)
  if (trim(name) /= "nmsimplex") test_ok = .false.
! initialize function object
  fpar(1:2) = (/1.0_fgsl_double, 2.0_fgsl_double/)
  ptr = c_loc(fpar)
  mmin_f = fgsl_multimin_function_init(paraboloid_f,nrt,ptr)
!
  xv(1:2) = (/5.0_fgsl_double, 7.0_fgsl_double/)
  xvec = fgsl_vector_init(1.0_fgsl_double)
  status = fgsl_vector_align(xv,nrt,xvec,nrt,0_fgsl_size_t,1_fgsl_size_t)
  stepv(1:2) = (/1.0_fgsl_double, 1.0_fgsl_double/)
  step = fgsl_vector_init(1.0_fgsl_double)
  status = fgsl_vector_align(stepv,nrt,step,nrt,0_fgsl_size_t,1_fgsl_size_t)
!  ya(1:2) = xvec
!  write(6, *) 'status = ', status, ' vec: ',ya(1:2)
  if (status /= fgsl_success) test_ok = .false.
  status = fgsl_multimin_fminimizer_set(mmin_fmin, mmin_f, xvec, step)
  call fgsl_vector_free(xvec)
  call fgsl_vector_free(step)
! FIXME: vector_free may not be necessary. Check memory leak without call.
!  write(6, *) 'status = ', status
  if (status /= fgsl_success) test_ok = .false.
  xvec = fgsl_multimin_fminimizer_x(mmin_fmin)
  status = fgsl_vector_align(xptr, xvec)
  if (fgsl_well_defined(mmin_fmin)) then
     i = 0
!     write(6,'('' It.              X                     f(X) '')')
     do
!        write(6, '(1x,i2,1x,2(1f12.5),1x,2(1f12.5))') i, xptr(1:2), &
!              fgsl_multimin_fminimizer_minimum(mmin_fmin)
        i = i + 1
        status = fgsl_multimin_fminimizer_iterate(mmin_fmin);
        if (status /= fgsl_success .or. i > itmax_root) then
           test_ok = .false.
           exit
        end if
        dmx = fgsl_multimin_fminimizer_size(mmin_fmin);
        status = fgsl_multimin_test_size(dmx, eps3)
!        write(6, *) 'status, dmx: ', status, dmx
        if (status == fgsl_success) then 
!           write(6, '(1x,i2,1x,2(1f12.5),1x,2(1f12.5))') i, xptr(1:2), &
!                 fgsl_multimin_fminimizer_minimum(mmin_fmin)
           exit
        end if
     end do
  end if
  call fgsl_multimin_fminimizer_free(mmin_fmin)
  call fgsl_multimin_function_free(mmin_f)
  call testres_toggle('fgsl_f_multimin',test_ok,ok,nok)
! fdfminimizer
  nrt = 2
  mmin_fdfmin = fgsl_multimin_fdfminimizer_alloc(fgsl_multimin_fdfminimizer_conjugate_fr,nrt)
  name = fgsl_multimin_fdfminimizer_name(mmin_fdfmin)
  if (trim(name) /= "conjugate_fr") test_ok = .false.
! initialize function object
  fpar(1:2) = (/1.0_fgsl_double, 2.0_fgsl_double/)
  ptr = c_loc(fpar)
  mmin_fdf = fgsl_multimin_function_fdf_init(paraboloid_f,paraboloid_df, paraboloid_fdf,nrt,ptr)
!
  xv(1:2) = (/5.0_fgsl_double, 7.0_fgsl_double/)
  xvec = fgsl_vector_init(1.0_fgsl_double)
  status = fgsl_vector_align(xv,nrt,xvec,nrt,0_fgsl_size_t,1_fgsl_size_t)
!  ya(1:2) = xvec
!  write(6, *) 'status = ', status, ' vec: ',ya(1:2)
  if (status /= fgsl_success) test_ok = .false.
  status = fgsl_multimin_fdfminimizer_set(mmin_fdfmin, mmin_fdf, xvec, 0.01_fgsl_double, eps3)
  call fgsl_vector_free(xvec)
! FIXME: vector_free may not be necessary. Check memory leak without call.
!  write(6, *) 'status = ', status
  if (status /= fgsl_success) test_ok = .false.
  xvec = fgsl_multimin_fdfminimizer_x(mmin_fdfmin)
  status = fgsl_vector_align(xptr, xvec)
  if (fgsl_well_defined(mmin_fdfmin)) then
     i = 0
!     write(6,'('' It.              X                     f(X) '')')
     do
!        write(6, '(1x,i2,1x,2(1f12.5),1x,2(1f12.5))') i, xptr(1:2), &
!              fgsl_multimin_fdfminimizer_minimum(mmin_fdfmin)
        i = i + 1
        status = fgsl_multimin_fdfminimizer_iterate(mmin_fdfmin)
! FIXME: last iteration produces invalid floating point operation. 
! g95 does not check flags, NAG requires -ieee=full to run through.
! try IEEE utilities?
        if (status /= fgsl_success .or. i > itmax_root) then
           test_ok = .false.
           exit
        end if
        fvec = fgsl_multimin_fdfminimizer_gradient(mmin_fdfmin)
        status = fgsl_multimin_test_gradient(fvec, eps3)
        if (status == fgsl_success) then 
!           write(6, '(1x,i2,1x,2(1f12.5),1x,2(1f12.5))') i, xptr(1:2), &
!                 fgsl_multimin_fminimizer_minimum(mmin_fmin)
           exit
        end if
     end do
  else
     test_ok = .false.
  end if
  call fgsl_multimin_fdfminimizer_free(mmin_fdfmin)
  call fgsl_multimin_function_fdf_free(mmin_fdf)
  call testres_toggle('fgsl_fdf_multimin',test_ok,ok,nok)
!
! Fitting
!
  d(1:4) = (/ 1970_fgsl_double, 1980_fgsl_double, 1990_fgsl_double, &
       2000_fgsl_double /)
  ya(1:4) = (/12_fgsl_double, 11_fgsl_double, 14_fgsl_double, &
       13_fgsl_double /)
  xa(1:4) = (/ 0.1_fgsl_double,  0.2_fgsl_double,  0.3_fgsl_double, &
       0.4_fgsl_double /)
  nrt = 4
  istr = 1
  status = fgsl_fit_wlinear (d, istr, xa, istr, ya, istr, nrt, &
       c0, c1, cov00, cov01, cov11, chisq)
  if (status /= fgsl_success) test_ok = .false.
!  write(6, *) 'Fit function: ',c0,' + ',c1,' * X'
!  write(6, *) 'Covariance Matrix (lower triangle): ',cov00,cov01,cov11
!  write(6, *) 'ChiSq: ',chisq
!  write(6, *) 'eps2: ',eps2
  if (abs(chisq-0.8_fgsl_double) > eps2 .or. abs(c0 + 106.6_fgsl_double) > eps2 &
       .or. abs(c1 - 0.06) > eps2 .or. abs(cov00 - 39602._fgsl_double) > eps2 .or. &
       abs(cov01 + 19.9_fgsl_double) > eps2 .or. &
       abs(cov11 - 0.01_fgsl_double) > eps2) test_ok = .false.
  call testres_toggle('fgsl_fit',test_ok,ok,nok)
!
  rng_type = fgsl_rng_env_setup()
  rng = fgsl_rng_alloc(fgsl_rng_default)
  t = 0.1_fgsl_double
  do i=1,nfmax
     xmf(1, i) = 1.0_fgsl_double
     xmf(2, i) = t
     xmf(3, i) = t*t
     ra = exp(t)
     ri = 0.1 * ra
     ymf(i) = ra + fgsl_ran_gaussian(rng, ri)
     wmf(i) = 1.0_fgsl_double/(ri*ri)
!     write(6, fmt='(3(1PD17.8,1X))') t, ymf(i), ri
     t = t + 0.1_fgsl_double
  end do
  lfit_ws = fgsl_multifit_linear_alloc(nfmax, 3_fgsl_size_t)
  if (fgsl_well_defined(lfit_ws)) then
     yvec = fgsl_vector_init(1.0_fgsl_double)
     wvec = fgsl_vector_init(1.0_fgsl_double)
     fmat = fgsl_matrix_init(1.0_fgsl_double)
     cvec = fgsl_vector_init(1.0_fgsl_double)
     cov = fgsl_matrix_init(1.0_fgsl_double)
     status = fgsl_vector_align(ymf,nfmax,yvec,nfmax,0_fgsl_size_t,1_fgsl_size_t)
     status = fgsl_vector_align(wmf,nfmax,wvec,nfmax,0_fgsl_size_t,1_fgsl_size_t)
     status = fgsl_matrix_align(xmf, 3_fgsl_size_t, 3_fgsl_size_t,nfmax,fmat)
     status = fgsl_vector_align(cmf,3_fgsl_size_t,cvec,3_fgsl_size_t,0_fgsl_size_t, &
          1_fgsl_size_t)
     status = fgsl_matrix_align(covmf, 3_fgsl_size_t, 3_fgsl_size_t,3_fgsl_size_t,cov)
     status = fgsl_multifit_wlinear (fmat, wvec, yvec, cvec, cov, chisq, lfit_ws)
     if (status /= fgsl_success) test_ok = .false.
     if (abs(cmf(1) - 1.1824632501803487_fgsl_double) > eps .or. &
          abs(cmf(2) - 0.1845715862795292_fgsl_double) > eps .or. &
          abs(cmf(3) - 1.3031038162033384_fgsl_double) > eps)  test_ok = .false.
     if (abs(covmf(1,1) - 1.25611919D-02) > eps2 .or. &
          abs(covmf(2,1) + 3.64387341D-02) > eps2 .or. &
          abs(covmf(3,1) - 1.94389116D-02) > eps2 .or. &
          abs(covmf(2,2) - 1.42339296D-01) > eps2 .or. &
          abs(covmf(3,2) + 8.48762160D-02) > eps2 .or. &
          abs(covmf(3,3) - 5.60243141D-02) > eps2)  test_ok = .false.
!     write(6, *) 'Fit: ',cmf
!     write(6, *) 'Cov: '
!     write(6,  fmt='(3(1PD17.8,1X))') covmf(1,1:3)
!     write(6,  fmt='(3(1PD17.8,1X))') covmf(2,1:3)
!     write(6,  fmt='(3(1PD17.8,1X))') covmf(3,1:3)
  else
     test_ok = .false.
  end if

  call fgsl_rng_free(rng)
  call fgsl_vector_free(cvec)
  call fgsl_vector_free(yvec)
  call fgsl_vector_free(wvec)
  call fgsl_matrix_free(fmat)
  call fgsl_matrix_free(cov)
  if (fgsl_well_defined(lfit_ws)) then
     call fgsl_multifit_linear_free(lfit_ws)
  end if
  call testres_toggle('fgsl_fit_multi',test_ok,ok,nok)
!
! Nonlinear fitting
!
  rng = fgsl_rng_alloc(fgsl_rng_default)
  fitdata%n = nmax
  allocate(fitdata%y(nmax),fitdata%sigma(nmax))
  do i=1, nmax
     fitdata%y(i) = 1.0_fgsl_double + 5.0_fgsl_double * exp(-0.1_fgsl_double*dble(i-1)) + &
          fgsl_ran_gaussian(rng, 0.1_fgsl_double)
     fitdata%sigma(i) = 0.1_fgsl_double
  end do
  ptr = c_loc(fitdata)
  nrt = 3_fgsl_size_t
  nlfit_fdf = fgsl_multifit_function_fdf_init(expb_f, expb_df, expb_fdf, nmax, nrt, ptr)
  nlfit_slv = fgsl_multifit_fdfsolver_alloc(fgsl_multifit_fdfsolver_lmsder, nmax, nrt)
  xv(1:3) = (/1.0_fgsl_double, 0.0_fgsl_double, 0.0_fgsl_double/)
  xvec = fgsl_vector_init(1.0_fgsl_double)
  status = fgsl_vector_align(xv,nrt,xvec,nrt,0_fgsl_size_t,1_fgsl_size_t)
  if (fgsl_well_defined(nlfit_slv)) then
     status = fgsl_multifit_fdfsolver_set(nlfit_slv, nlfit_fdf, xvec)
     if (status /= fgsl_success) then
        test_ok = .false.
     else
        i = 0
        do
           i = i + 1
           status = fgsl_multifit_fdfsolver_iterate(nlfit_slv)
           if (status /= fgsl_success .or. i > itmax_root) then
              test_ok = .false.
              exit
           end if
           status = fgsl_multifit_test_delta(fgsl_multifit_fdfsolver_dx(nlfit_slv), &
                fgsl_multifit_fdfsolver_position(nlfit_slv), eps2, eps2)
           if (status == fgsl_success) then 
              exit
           end if
        end do
     end if
  else
     test_ok = .false.
  end if
!  deallocate(fitdata%y,fitdata%sigma)
  call fgsl_vector_free(xvec)
  call fgsl_multifit_fdfsolver_free(nlfit_slv)
  call fgsl_multifit_function_fdf_free(nlfit_fdf)
  call fgsl_rng_free(rng)
  call testres_toggle('fgsl_nl_fit',test_ok,ok,nok)
!
! IEEE utils
!
  tfile = fgsl_open(fgsl_char_'ieee.dat',fgsl_char_'w+')
  if (fgsl_well_defined(tfile)) then
     t = 1.0_fgsl_double/3.0_fgsl_double
     call fgsl_ieee_fprintf(tfile, t)
     ts = 1.0_fgsl_float/3.0_fgsl_float
     call fgsl_ieee_fprintf(tfile, ts)
     status = fgsl_close(tfile)
     if (status /= 0) test_ok = .false.
     open(unit=20, file='ieee.dat',form='FORMATTED',status='OLD')
     read(20, fmt=*) ieee_str1, ieee_str2
!     write(6, *) 'ieee_str = ',trim(ieee_str1),' ',trim(ieee_str2)
     if (trim(ieee_str1) /= &
          '1.0101010101010101010101010101010101010101010101010101*2^-2') test_ok = .false. 
     if (trim(ieee_str2) /= &
          '1.01010101010101010101011*2^-2') test_ok = .false. 
     close(20,status='DELETE')
  else
     status = fgsl_close(tfile)
     test_ok = .false.
  end if
  call testres_toggle('fgsl_ieee',test_ok,ok,nok)
!
! Done
!
  if (all(ok)) then
     write(6, *) 'OK: All tests passed'
  else
     write(6, *) 'FAIL: Some or all tests failed'
  end if
end program test_fgsl
