subroutine VFiteration()
  use Globals
  use Utils

  implicit none

  integer, parameter :: maxIter = 20000, showError = 500
  real(8), parameter :: tolerance = 1.0d-4
  integer :: iter, ind_a, ind_z, ind_q, ind_g, ind_b

  real(8) :: error_N_vf, error_U_vf, error_W_vf, error_J_vf, error_V_vf, error_N_pf, error_U_pf, error_W_pf, error_vf, error_pf

  real(8), dimension(gp_a,gp_z) :: new_N_vf, new_N_pf, exp_N
  real(8), dimension(gp_a,gp_z,0:1) :: exp_U
  real(8), dimension(gp_a,gp_z,gp_q) :: new_W_vf, new_W_pf, exp_W
  real(8), dimension(gp_a,gp_z,gp_gamma,0:1) :: new_U_vf, new_J_vf, new_U_pf
  real(8), dimension(gp_a,gp_z,gp_q,gp_gamma,0:1) :: new_V_vf

  ! Guess a value for global value functions
  call random_number(N_vf) ! Assign random numbers to N_vf
  call random_number(U_vf)
  call random_number(W_vf)
  call ValueFunctions(N_vf,U_vf,W_vf,J_vf,V_vf)

  ! Initialise new value functions
  new_N_vf = 0.d0
  new_U_vf = 0.d0
  new_W_vf = 0.d0
  new_J_vf = 0.d0
  new_V_vf = 0.d0

  ! Initialise global policy functions
  N_pf = 0.d0
  U_pf = 0.d0
  W_pf = 0.d0

  ! Initialise new policy functions
  new_N_pf = 1.d0
  new_U_pf = 1.d0
  new_W_pf = 1.d0

  ! Value function iteration
  do iter = 1, maxIter
    ! Compute expected values
    call ExpectedValues(exp_N, exp_U, exp_W)

    ! Iterate over all states TODAY
    do ind_a = 1, gp_a
    do ind_z = 1, gp_z
      call value_N(ind_a, exp_N(:,ind_z), new_N_pf(ind_a,ind_z), new_N_vf(ind_a,ind_z))

      do ind_q = 1, gp_q
        call value_W(ind_a, ind_z, ind_q, exp_W(:,ind_z,ind_q), &
                    new_W_pf(ind_a,ind_z,ind_q), new_W_vf(ind_a,ind_z,ind_q))
      end do

      do ind_b = 0,1
        do ind_g = 1, gp_gamma
          call value_U(ind_a, ind_z, ind_g, ind_b, exp_U(:,ind_z,ind_b), &
                      new_U_pf(ind_a,ind_z,ind_g,ind_b), new_U_vf(ind_a,ind_z,ind_g,ind_b))
        end do
      end do
    end do
    end do

    ! Compute new J and new V
    call ValueFunctions(new_N_vf,new_U_vf,new_W_vf,new_J_vf,new_V_vf)

    ! Compute errors
    error_N_vf = maxval(abs(new_N_vf-N_vf))
    error_U_vf = maxval(abs(new_U_vf-U_vf))
    error_W_vf = maxval(abs(new_W_vf-W_vf))
    error_J_vf = maxval(abs(new_J_vf-J_vf))
    error_V_vf = maxval(abs(new_V_vf-V_vf))
    error_vf = max(error_N_vf, error_U_vf, error_W_vf, error_J_vf, error_V_vf)

    error_N_pf = maxval(abs(new_N_pf-N_pf))
    error_U_pf = maxval(abs(new_U_pf-U_pf))
    error_W_pf = maxval(abs(new_W_pf-W_pf))
    error_pf = max(error_N_pf, error_U_pf, error_W_pf)

    ! Update value functions and decision rules
    N_vf = new_N_vf
    U_vf = new_U_vf
    W_vf = new_W_vf
    J_vf = new_J_vf
    V_vf = new_V_vf

    N_pf = new_N_pf
    U_pf = new_U_pf
    W_pf = new_W_pf

    if ((error_vf.lt.tolerance).and.(error_pf.lt.tolerance)) then
      print *, "Value function iteration finished at iteration:", iter
      print *, ""
      exit
    elseif (mod(iter,showError).eq.0) then
      print *, "Current value function iteration errors, at iteration:", iter
      print *, "Error for N is:", error_N_vf
      print *, "Error for U is:", error_U_vf
      print *, "Error for W is:", error_W_vf
      print *, "Error for J is:", error_J_vf
      print *, "Error for V is:", error_V_vf
      print *, "Error for N's policy function is:", error_N_pf
      print *, "Error for U's policy function is:", error_U_pf
      print *, "Error for W's policy function is:", error_W_pf
      print *, ""
    end if
  end do

end subroutine VFiteration

!===== EXPECTED VALUES ============================================================================
subroutine ExpectedValues(exp_N, exp_U, exp_W)
  ! Computes auxiliary vector to store the expected value for each level of assets tomorrow
  use Globals
  implicit none
  integer :: ind_z, ind_q, ind_b, ind_ap, ind_zp, ind_qp, ind_gp, ind_bp
  real(8) :: prob_N, prob_U, prob_W
  real(8), dimension(gp_a,gp_z), intent(out) :: exp_N
  real(8), dimension(gp_a,gp_z,0:1), intent(out) :: exp_U
  real(8), dimension(gp_a,gp_z,gp_q), intent(out) :: exp_W

  ! Initialise arrays to 0
  exp_N = 0.d0
  exp_U = 0.d0
  exp_W = 0.d0

  ! Iterate over values of z TODAY
  do ind_z = 1, gp_z
    ! Iterate over all values of assets, z, q, and gammas tomorrow
    do ind_ap = 1, gp_a
    do ind_zp = 1, gp_z
    do ind_qp = 1, gp_q
    do ind_gp = 1, gp_gamma
      prob_N = z_trans(ind_z,ind_zp)*q_trans(ind_qp)*gamma_trans(ind_gp)
      exp_N(ind_ap,ind_z) = exp_N(ind_ap,ind_z) + prob_N*(&
                      (lambda_n*V_vf(ind_ap,ind_zp,ind_qp,ind_gp,0)) + &
                      ((1.d0-lambda_n)*J_vf(ind_ap,ind_zp,ind_gp,0)))

      ! Iterate over values of match quality TODAY
      prob_W = prob_N
      do ind_q = 1, gp_q
        exp_W(ind_ap,ind_z,ind_q) = exp_W(ind_ap,ind_z,ind_q) + prob_W*(&
                        ((1.d0-sigma-lambda_e)*V_vf(ind_ap,ind_zp,ind_q,ind_gp,0)) + &
                        (lambda_e*V_vf(ind_ap,ind_zp,max(ind_q,ind_qp),ind_gp,0)) + &
                        (sigma*(1.d0-lambda_u)*J_vf(ind_ap,ind_zp,ind_gp,1)) + &
                        (sigma*lambda_u*V_vf(ind_ap,ind_zp,ind_qp,ind_gp,1)))
      end do

      ! Iterate over values of UI TODAY and TOMORROW
      do ind_b = 0, 1
      do ind_bp = 0, 1
        prob_U = prob_W*IB_trans(ind_b,ind_bp)
        exp_U(ind_ap,ind_z,ind_b) = exp_U(ind_ap,ind_z,ind_b) + prob_U*(&
                        (lambda_u*V_vf(ind_ap,ind_zp,ind_qp,ind_gp,ind_bp)) + &
                        ((1.d0-lambda_u)*J_vf(ind_ap,ind_zp,ind_gp,ind_bp)))
      end do
      end do
    end do
    end do
    end do
    end do
  end do
end subroutine ExpectedValues

!===== OLF ========================================================================================
subroutine value_N(ind_a, aux_exp, pf, vf)
  use Globals
  use Utils
  implicit none

  integer, intent(in) :: ind_a
  real(8) :: aux_max_a, income
  real(8), dimension(gp_a), intent(in) :: aux_exp
  real(8), intent(out) :: pf, vf

  ! Compute income
  income = (1.d0+int_rate)*a_values(ind_a) + T

  ! Compute upper bound for assets
  aux_max_a = min(max_a-tiny, max(min_a, income))

  ! Find level of assets that maximised Bellman Equation
  call golden_method(valor_N, min_a, aux_max_a, pf, vf)

CONTAINS
  real(8) function valor_N(ap)
    implicit none
    real(8), intent(in) :: ap
    real(8) :: aux_inter, cons

    ! Compute interpolated value for tomorrow
    aux_inter = my_inter(a_values, aux_exp, gp_a, ap)

    ! Compute consumption
    cons = income - ap

    valor_N = u(cons) + beta*aux_inter
  end function valor_N
end subroutine value_N

!===== EMPLOYED ===================================================================================
subroutine value_W(ind_a, ind_z, ind_q, aux_exp, pf, vf)
  use Globals
  use Utils
  implicit none

  integer, intent(in) :: ind_a, ind_z, ind_q
  real(8) :: aux_max_a, income
  real(8), dimension(gp_a), intent(in) :: aux_exp
  real(8), intent(out) :: pf, vf

  ! Compute income
  income = (1.d0+int_rate)*a_values(ind_a) + T + (1.d0-tau)*wage*z_values(ind_z)*q_values(ind_q)

  ! Compute upper bound for assets
  aux_max_a = min(max_a-tiny, max(min_a, income))

  ! Find level of assets that maximised Bellman Equation
  call golden_method(valor_W, min_a, aux_max_a, pf, vf)

CONTAINS
  real(8) function valor_W(ap)
    implicit none
    real(8), intent(in) :: ap
    real(8) :: aux_inter, cons

    ! Compute interpolated value for tomorrow
    aux_inter = my_inter(a_values, aux_exp, gp_a, ap)

    ! Compute consumption
    cons = income - ap

    valor_W = u(cons) - alpha + beta*aux_inter
  end function valor_W
end subroutine value_W

!===== EMPLOYED ===================================================================================
subroutine value_U(ind_a, ind_z, ind_g, ind_b, aux_exp, pf, vf)
  use Globals
  use Utils
  implicit none

  integer, intent(in) :: ind_a, ind_z, ind_g, ind_b
  real(8) :: aux_max_a, income
  real(8), dimension(gp_a), intent(in) :: aux_exp
  real(8), intent(out) :: pf, vf

  ! Compute income
  income = (1.d0+int_rate)*a_values(ind_a) + T + (1.d0-tau)*real(ind_b)*benefits(z_values(ind_z))

  ! Compute upper bound for assets
  aux_max_a = min(max_a-tiny, max(min_a, income))

  ! Find level of assets that maximised Bellman Equation
  call golden_method(valor_U, min_a, aux_max_a, pf, vf)

CONTAINS
  real(8) function valor_U(ap)
    implicit none
    real(8), intent(in) :: ap
    real(8) :: aux_inter, cons

    ! Compute interpolated value for tomorrow
    aux_inter = my_inter(a_values, aux_exp, gp_a, ap)

    ! Compute consumption
    cons = income - ap

    valor_U = u(cons) - gamma_values(ind_g) + beta*aux_inter
  end function valor_U
end subroutine value_U


      program DRDCHI
c>> 2001-05-25 DRDCDCHI Krogh Minor change for making .f90 version.
c>> 1996-06-17 DRDCDCHI Krogh  Minor format change for C conversion.
c>> 1996-05-28 DRDCDCHI Krogh  Changed Fortran 90 code.
c>> 1994-10-19 DRDCDCHI Krogh  Changes to use M77CON
c>> 1994-07-06 DRDCDCHI WVS set up for chgtyp
c
c     Evaluate the Probability Integral Q(chi-square,nu) of the Chi-
c     Square distribution by using DCDCHI.
c
c--D replaces "?": DR?CHI, DR?CDCHI, ?cdchi
      double precision CHISQ, NU, P, Q(4)
      integer IERR, J
c
10    format ('     Probability Integral Q(chi**2 | nu)'/
     1 '    CHI**2        NU = 1',13x,'2',13x,'3',13x,'4')
20    format (1p,5g14.7)
      chisq = 0.5d0
      print 10
30    if (chisq .le. 6) then
         do 40 j = 1, 4
            nu = j
            call dcdchi (chisq, nu, p, q(j), ierr)
40       continue
         print 20, chisq, q
         chisq = chisq + 0.5d0
         go to 30
      end if
      stop
      end


    function getnoise(a,nxo,nyo,fwhm)

! Estimate sky noise by iterative subtraction of smoothed background.

    implicit real (a-h,o-z)
    implicit integer (i,n)
    real(4),allocatable :: as(:,:),ac(:,:),atrim(:,:),wt(:,:),kern(:,:)
    logical(4),allocatable :: mask(:,:)
    real(4) a(nxo,nyo)
    logical converged

    isubsample = max(nint(fwhm/40.), 1)
    nx = nxo/isubsample
    ny = nyo/isubsample
    allocate (as(nx,ny))
    allocate (ac(nx,ny))
    allocate (atrim(nx,ny))
    allocate (wt(nx,ny))
    allocate (mask(nx,ny))

    if (isubsample==1) then
        as = a
    else
        do j = 1,ny
        do i = 1,nx
            as(i,j) = a(isubsample*i, isubsample*j)
        enddo
        enddo
    endif

! Construct Gaussian smoothing kernel.
    fwhms = fwhm/isubsample
    ik = nint(0.75*fwhms)
    nk = 2*ik+1
    allocate (kern(nk,nk))
    aln2 = log(2.)
    do j = 1,nk
    do i = 1,nk
        kern(i,j) = exp(-4.*(aln2/fwhms**2)*((i-ik-1)**2 + (j-ik-1)**2))
    enddo
    enddo
    kern = kern/sum(kern)

    wt = 1.
    where(as==0.) wt = 0.
    atrim = as*wt

! Begin iterative smoothing.
    converged = .false.
    sigprev = 1.e35
    maxit = 100
    tol = 0.001
    it = 0
    do while (.not.converged .and. it<maxit)
        it = it+1
        call convol(atrim,kern,ac,nx,ny,nk)
        sigma = sqrt(sum(wt*(atrim-ac)**2)/sum(wt))
        mask = .false.
        where(atrim-ac > 3.*sigma) mask = .true.
        where(mask) atrim = ac
        where(mask) wt = 0.
        if (abs(sigma-sigprev)/sigma < tol) converged = .true.
        sigprev = sigma
    enddo

    deallocate(as)
    deallocate(ac)
    deallocate(atrim)
    deallocate(wt)
    deallocate(mask)
    deallocate(kern)
    getnoise = sigma
    return

    end function getnoise


!> Unit tests for the m_gayberne module.
module gayberne_pfunit
  use m_gayberne
  use pfunit
  use num_kind
  implicit none

  !> The relative tolerance for reals to be comparable.
  !! @see ftnunit documentation. Two values v1 and v2 are considered
  !! equal if abs( v1 - v2 ) < margin * (abs(v1)+abs(v2)) / 2
  real(dp), parameter :: margin = 1.e-9_dp

  real(dp), dimension(3), parameter :: ex = (/1._dp, 0._dp, 0._dp/), &
       ey = (/0._dp, 1._dp, 0._dp/), ez = (/0._dp, 0._dp, 1._dp/)

contains

  subroutine test_zero_at_cross_contact
    real(dp) :: kappa_sigma = 4.4_dp
    real(dp) :: kappa_epsilon = 20._dp
    real(dp) :: mu = 1.235_dp
    real(dp) :: nu = 1.6546_dp
    real(dp) :: sigma_0 = 1.234_dp
    real(dp) :: epsilon_0 = 1.2798_dp
    real(dp), dimension(3) :: ui = (/1._dp, 0._dp, 0._dp/)
    real(dp), dimension(3) :: uj = (/0._dp, 1._dp, 0._dp/)
    real(dp), dimension(3) :: rij
    real(dp) :: e_gb
    logical :: overlap
    type(gayberne) :: gb
    rij = (/0.0_dp, 0.0_dp, sigma_0/)
    gb = gayberne(kappa_sigma, kappa_epsilon, mu, nu, sigma_0, epsilon_0)
    call gb%potential(ui, uj, rij, e_gb, overlap)
    call assertEqual(0._dp, real(e_gb, dp), margin, &
         'Zero at cross contact')
    call AssertFalse(overlap, 'Overlap is false')
    !  call assertEqual(0._dp, potential(ui, uj, rij))
  end subroutine test_zero_at_cross_contact

  subroutine test_kappa_sigma_defined
    real(dp) :: kappa_sigma = 4.4_dp
    real(dp) :: kappa_epsilon = 20._dp
    real(dp) :: mu = 5.235_dp
    real(dp) :: nu = 3.6546_dp
    real(dp) :: sigma_0 = 1.234_dp
    real(dp) :: epsilon_0 = 1.2798_dp
    real(dp), dimension(3) :: ui = (/1._dp, 0._dp, 0._dp/)
    real(dp), dimension(3) :: uj
    real(dp), dimension(3) :: urij_ee
    real(dp), dimension(3) :: urij_ss = (/0._dp, 1._dp, 0._dp/)
    type(gayberne) :: gb
    uj = ui
    urij_ee = ui
    gb = gayberne(kappa_sigma, kappa_epsilon, mu, nu, sigma_0, epsilon_0)
    call assertEqual(kappa_sigma, &
         gb%sigma(ui, uj, urij_ee) / gb%sigma(ui, uj, urij_ss), margin, &
         "kappasigma defined correctly")
  end subroutine test_kappa_sigma_defined

  subroutine test_kappa_epsilon_defined
    real(dp) :: kappa_sigma = 4.4_dp
    real(dp) :: kappa_epsilon = 20._dp
    real(dp) :: mu = 6.235_dp
    real(dp) :: nu = 23.6546_dp
    real(dp) :: sigma_0 = 1.234_dp
    real(dp) :: epsilon_0 = 1.2798_dp
    real(dp), dimension(3) :: ui = (/1._dp, 0._dp, 0._dp/)
    real(dp), dimension(3) :: uj
    real(dp), dimension(3) :: urij_ee
    real(dp), dimension(3) :: urij_ss = (/0._dp, 1._dp, 0._dp/)
    type(gayberne) :: gb
    uj = ui
    urij_ee = ui
    gb = gayberne(kappa_sigma, kappa_epsilon, mu, nu, sigma_0, epsilon_0)
    call assertEqual(kappa_epsilon, &
         gb%epsilon(ui, uj, urij_ss) / gb%epsilon(ui, uj, urij_ee), &
         margin, "kappaepsilon defined correctly.")
  end subroutine test_kappa_epsilon_defined

  subroutine test_reduces_to_lennard_jones
    real(dp) :: sigma_0 = 3.435_dp
    real(dp) :: epsilon_0 = 234.234_dp
    real(dp) :: lj_potential
    real(dp) :: lj_6
    real(dp), dimension(3) :: rij
    real(dp), dimension(3) :: ui = (/1._dp, 0._dp, 0._dp/)
    real(dp), dimension(3) :: uj = (/0._dp, 1._dp, 0._dp/)
    real(dp) :: r_absolute
    real(dp) :: e_gb
    logical :: overlap
    type(gayberne) :: gb
    r_absolute = sigma_0 + 1._dp
    rij = (/-r_absolute, 0._dp, 0._dp/)
    lj_6 = (sigma_0 / r_absolute)**6
    lj_potential = 4._dp * epsilon_0 * lj_6 * (lj_6 - 1._dp)
    gb = gayberne(1._dp, 1._dp, 6.234_dp, 2.84687_dp, sigma_0, epsilon_0)
    call gb%potential(ui, uj, rij, e_gb, overlap)
    call assertEqual(lj_potential, e_gb, margin, &
         "Reduces to Lennard-Jones.")
    call AssertFalse(overlap, "Overlap is false.")
  end subroutine test_reduces_to_lennard_jones

  subroutine test_force_zeros
    use num_kind, only: dp
    real(dp), parameter :: mu = 1.5_dp, nu=1.3_dp
    real(dp), parameter :: sigma0 = 1.2_dp, epsilon0 = 0.9_dp
    real(dp), parameter :: kappasigma = 4.4_dp, kappaepsilon=20._dp
    real(dp) :: deriv(3), chisigma
    type(gayberne) :: gb
    gb = gayberne(kappasigma, kappaepsilon, mu, nu, sigma0, epsilon0)
    !! side-by-side:
    deriv = gb%force(ez, ez, ex * sigma0 * 2 ** (1._dp/6))
    call assertEqual(0._dp, deriv(1), margin, "Side-by-side derivative zero.")
    !! cross configuration:
    deriv = gb%force(ez, ey, ex * sigma0 * 2 ** (1._dp/6))
    call assertEqual(0._dp, deriv(1), margin, &
         "Cross configuration derivative zero.")
    !! T configuration:
    chisigma = (kappasigma * kappasigma - 1._dp) / &
         (kappasigma * kappasigma + 1._dp)
    deriv = gb%force(ez, ex, ex * sigma0 * &
         (2 ** (1._dp/6) - 1._dp/sqrt(1 - chisigma) + 1))
    call assertEqual(0._dp, deriv(1), margin, &
         "Cross configuration derivative zero.")
    !! End to end:
    deriv = gb%force(ez, ez, ez * sigma0 * &
         (2 ** (1._dp/6) - kappasigma + 1))
    call assertEqual(0._dp, deriv(1), margin, &
         "Cross configuration derivative zero.")
  end subroutine test_force_zeros

  subroutine test_small_separation
    intrinsic huge
    intrinsic tiny
    real(dp) :: kappa_sigma = 4.4_dp
    real(dp) :: kappa_epsilon = 20._dp
    real(dp) :: mu = 1._dp
    real(dp) :: nu = 1._dp
    real(dp) :: sigma_0 = 1._dp
    real(dp) :: epsilon_0 = 1._dp
    real(dp), dimension(3) :: rij
    real(dp), dimension(3) :: ui = (/1._dp, 0._dp, 0._dp/)
    real(dp), dimension(3) :: uj
    real(dp) :: r_absolute
    real(dp) :: e_gb
    logical :: overlap
    real(dp) :: small_number
    real(dp) :: hard_core = 0.6_dp
    type(gayberne) :: gb
    small_number = 1.e-9_dp
    r_absolute = hard_core - small_number
    gb = gayberne(kappa_sigma, kappa_epsilon, mu, nu, sigma_0, epsilon_0)
    uj = ui
    rij = (/0.0_dp, r_absolute, 0.0_dp/)
    call gb%potential(ui, uj, rij, e_gb, overlap)
    call AssertTrue(overlap, "Overlap at small separation.")
  end subroutine test_small_separation

  subroutine test_normalop
    real(dp) :: kappa_sigma = 4.4_dp
    real(dp) :: kappa_epsilon = 20._dp
    real(dp) :: mu = 1._dp
    real(dp) :: nu = 1._dp
    real(dp) :: sigma_0 = 1._dp
    real(dp) :: epsilon_0 = 1._dp
    real(dp), dimension(3) :: rij = (/1._dp, 1._dp, 0._dp/)
    real(dp), dimension(3) :: ui = (/0._dp, 0._dp, 1._dp/)
    real(dp) :: e_gb
    real(dp) :: expected
    logical :: overlap
    real(dp) :: khi
    type(gayberne) :: gb
    gb = gayberne(kappa_sigma, kappa_epsilon, mu, nu, sigma_0, epsilon_0)
    call gb%potential(ui, ui, rij, e_gb, overlap)
    expected = 4._dp * (dot_product(rij, rij)**(-6) - &
         dot_product(rij, rij)**(-3))
    khi = (kappa_sigma**2 - 1._dp)/(kappa_sigma**2 + 1._dp)
    expected = expected/sqrt(1._dp - khi**2)
    !write(*, *) 'expected = ', expected
    call assertEqual(expected, e_gb, margin, &
         "Normal operation.")
  end subroutine test_normalop

  subroutine test_forcevsfinitedifference
    real(dp), parameter :: kappa_sigma = 4.4
    real(dp), parameter :: kappa_epsilon = 20.
    real(dp), parameter :: mu = 1.
    real(dp), parameter :: nu = 1.
    real(dp), parameter :: sigma_0 = 1.
    real(dp), parameter :: epsilon_0 = 1.
    logical :: overlap
    real(dp), dimension(3), parameter :: r0 = ex * (kappa_sigma - 1.) * 2. / 3.
    real(dp), parameter :: dr = 1e-6
    !real(dp), dimension(3), parameter :: r1 = r0 + ex * dr
    real(dp), dimension(3) :: r1
    real(dp), dimension(3), parameter :: uj = (/sqrt(2.)**(-1), 0., &
         sqrt(2.)**(-1)/)
    real(dp) :: force(3), energy1, energy0
    real(dp),dimension(3) :: gradient
    type(gayberne) :: gb
    real(dp), parameter :: evecs(3, 3) = &
         reshape([1, 0, 0, 0, 1, 0, 0, 0, 1], [3, 3])
    integer :: i
    gb = gayberne(kappa_sigma, kappa_epsilon, mu, nu, sigma_0, epsilon_0)

    do i = 1, 3
       call gb%potential(ez, uj, r0, energy0, overlap)
       r1 = r0 + evecs(:, i) * dr
       call gb%potential(ez, uj, r1, energy1, overlap)
       force = gb%force(ez, uj, r0 + 0.5 * dr * evecs(:, i))
       call assertEqual(-(energy1 - energy0) / dr, force(i), margin, &
            "Force not comparable to finite difference approximation.")
       gradient= g_potential(gb, ez, uj, r0 + 0.5 * dr * evecs(:, i))
       call assertEqual(gradient(i), (energy1 - energy0) / dr, margin, &
            "New force comparable to finite difference approximation.")
    end do
end subroutine

end module


PROGRAM timer_test
IMPLICIT NONE
  INTEGER(KIND=8) :: begin_timer, end_timer
  INTEGER :: i
  REAL :: x

  CALL SYSTEM_CLOCK(begin_timer)
  DO i = 1, 100000000
    x = SQRT(REAL(i**2 - 1))
  END DO
  CALL SYSTEM_CLOCK(end_timer)
  WRITE(*, '(F14.6)') REAL(end_timer - begin_timer) / 100000000.
END PROGRAM timer_test


! Array related routines (Integration, Interpolation, etc.)
!
! ------------------------------------------------------------------------------
! Copyright (c) 2009-13, Thomas P. Robitaille
!
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
!  * Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
!  * Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ------------------------------------------------------------------------------

module lib_array

  implicit none
  save

  private

  integer,parameter :: idp = selected_int_kind(13)
  integer,parameter :: sp = selected_real_kind(p=6,r=37)
  integer,parameter :: dp = selected_real_kind(p=15,r=307)

  public :: is_nan
  interface is_nan
     module procedure is_nan_int
     module procedure is_nan_int8
     module procedure is_nan_sp
     module procedure is_nan_dp
  end interface is_nan

  public :: linspace
  interface linspace
     module procedure linspace_sp
     module procedure linspace_dp
  end interface linspace

  public :: logspace
  interface logspace
     module procedure logspace_sp
     module procedure logspace_dp
  end interface logspace

  public :: integral
  interface integral
     module procedure integral_sp
     module procedure integral_dp
     module procedure integral_subset_sp
     module procedure integral_subset_dp
  end interface integral

  public :: cumulative_integral
  interface cumulative_integral
     module procedure cumulative_integral_sp
     module procedure cumulative_integral_dp
     ! module procedure cumulative_integral_subset_sp
     ! module procedure cumulative_integral_subset_dp
  end interface cumulative_integral

  public :: integral_linlog
  interface integral_linlog
     module procedure integral_linlog_sp
     module procedure integral_linlog_dp
     module procedure integral_linlog_subset_sp
     module procedure integral_linlog_subset_dp
  end interface integral_linlog

  public :: cumulative_integral_linlog
  interface cumulative_integral_linlog
     module procedure cumulative_integral_linlog_sp
     module procedure cumulative_integral_linlog_dp
     ! module procedure cumulative_integral_linlog_subset_sp
     ! module procedure cumulative_integral_linlog_subset_dp
  end interface cumulative_integral_linlog

  public :: integral_loglin
  interface integral_loglin
     module procedure integral_loglin_sp
     module procedure integral_loglin_dp
     module procedure integral_loglin_subset_sp
     module procedure integral_loglin_subset_dp
  end interface integral_loglin

  public :: cumulative_integral_loglin
  interface cumulative_integral_loglin
     module procedure cumulative_integral_loglin_sp
     module procedure cumulative_integral_loglin_dp
     ! module procedure cumulative_integral_loglin_subset_sp
     ! module procedure cumulative_integral_loglin_subset_dp
  end interface cumulative_integral_loglin

  public :: integral_loglog
  interface integral_loglog
     module procedure integral_loglog_sp
     module procedure integral_loglog_dp
     module procedure integral_loglog_subset_sp
     module procedure integral_loglog_subset_dp
  end interface integral_loglog

  public :: cumulative_integral_loglog
  interface cumulative_integral_loglog
     module procedure cumulative_integral_loglog_sp
     module procedure cumulative_integral_loglog_dp
     ! module procedure cumulative_integral_loglog_subset_sp
     ! module procedure cumulative_integral_loglog_subset_dp
  end interface cumulative_integral_loglog

  public :: locate
  interface locate
     module procedure locate_sp
     module procedure locate_dp
  end interface locate

  public :: interp1d
  interface interp1d
     module procedure interp1d_sp
     module procedure interp1d_dp
     module procedure interp1d_array_sp
     module procedure interp1d_array_dp
  end interface interp1d

  public :: interp1d_linlog
  interface interp1d_linlog
     module procedure interp1d_linlog_sp
     module procedure interp1d_linlog_dp
     module procedure interp1d_array_linlog_sp
     module procedure interp1d_array_linlog_dp
  end interface interp1d_linlog

  public :: interp1d_loglin
  interface interp1d_loglin
     module procedure interp1d_loglin_sp
     module procedure interp1d_loglin_dp
     module procedure interp1d_array_loglin_sp
     module procedure interp1d_array_loglin_dp
  end interface interp1d_loglin

  public :: interp1d_loglog
  interface interp1d_loglog
     module procedure interp1d_loglog_sp
     module procedure interp1d_loglog_dp
     module procedure interp1d_array_loglog_sp
     module procedure interp1d_array_loglog_dp
  end interface interp1d_loglog

  public :: rebin
  interface rebin
     module procedure rebin_sp
     module procedure rebin_dp
  end interface rebin

  public :: rebin_linlog
  interface rebin_linlog
     module procedure rebin_linlog_sp
     module procedure rebin_linlog_dp
  end interface rebin_linlog

  public :: rebin_loglin
  interface rebin_loglin
     module procedure rebin_loglin_sp
     module procedure rebin_loglin_dp
  end interface rebin_loglin

  public :: rebin_loglog
  interface rebin_loglog
     module procedure rebin_loglog_sp
     module procedure rebin_loglog_dp
  end interface rebin_loglog

  public :: interp2d
  interface interp2d
     module procedure interp2d_sp
     module procedure interp2d_dp
  end interface interp2d

  public :: histogram1d
  interface histogram1d
     module procedure histogram1d_sp
     module procedure histogram1d_dp
  end interface histogram1d

  public :: histogram2d
  interface histogram2d
     module procedure histogram2d_sp
     module procedure histogram2d_dp
  end interface histogram2d

  public :: ipos
  interface ipos
     module procedure ipos_sp
     module procedure ipos_dp
  end interface ipos

  public :: xval
  interface xval
     module procedure xval_sp
     module procedure xval_dp
  end interface xval

  public :: quicksort
  interface quicksort
     module procedure quicksort_sp
     module procedure quicksort_all_sp
     module procedure quicksort_dp
     module procedure quicksort_all_dp
  end interface quicksort

  public :: quicksort_index
  interface quicksort_index
     module procedure quicksort_index_sp
     module procedure quicksort_index_all_sp
     module procedure quicksort_index_dp
     module procedure quicksort_index_all_dp
  end interface quicksort_index

  public :: test_quicksort_sp
  public :: test_quicksort_dp

  public :: int
  interface int
     module procedure logical2int
  end interface int

contains

  elemental integer function logical2int(a) result(b)
    implicit none
    logical,intent(in) :: a
    if(a) then
       b = 1
    else
       b = 0
    end if
  end function logical2int

  !!@FOR real(sp):sp real(dp):dp integer:int integer(idp):int8

  logical elemental function is_nan_<T>(value) result(nan)
    ! x != x does not work with pgfortran
    @T,intent(in) :: value
    nan = .not. (value > -1 .or. value < 1)
  end function is_nan_<T>

  !!@END FOR

  !!@FOR real(sp):sp real(dp):dp

  subroutine linspace_<T>(xmin,xmax,x)
    implicit none
    @T,intent(in) :: xmin,xmax
    @T,intent(out) :: x(:)
    integer :: i,n
    n = size(x)
    if (n == 1) then
       if(xmin /= xmax) then
          write(0,'("ERROR: Cannot call linspace with n=1 and xmin /= xmax")')
          stop
       else
          x = xmin
       end if
    else
       do i=1,n
          x(i) = (xmax-xmin) * real(i-1,<T>) / real(n-1,<T>) + xmin
       end do
    end if
  end subroutine linspace_<T>

  subroutine logspace_<T>(xmin,xmax,x)
    implicit none
    @T,intent(in) :: xmin,xmax
    @T,intent(out) :: x(:)
    if (size(x) == 1 .and. xmin /= xmax) then
       write(0,'("ERROR: Cannot call logspace with n=1 and xmin /= xmax")')
       stop
    end if
    call linspace(log10(xmin),log10(xmax),x)
    x = 10._<T>**x
  end subroutine logspace_<T>

  real(<T>) function integral_<T>(x,y)
    ! Total integral of a function
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    integral_<T> = integral_general_<T>(x, y, trapezium_<T>)
  end function integral_<T>

  real(<T>) function integral_subset_<T>(x,y,x1,x2)
    ! Integral of a function between two limits
    implicit none
    real(<T>),intent(in) :: x(:),y(:),x1,x2
    integral_subset_<T> = integral_general_subset_<T>(x, y, x1, x2, interp1d_<T>, trapezium_<T>)
  end function integral_subset_<T>

  real(<T>) function integral_linlog_<T>(x,y)
    ! Total integral of a function
    ! (uses linlog interpolation)
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    integral_linlog_<T> = integral_general_<T>(x, y, trapezium_linlog_<T>)
  end function integral_linlog_<T>

  real(<T>) function integral_linlog_subset_<T>(x,y,x1,x2)
    ! Integral of a function between two limits
    ! (uses linlog interpolation)
    implicit none
    real(<T>),intent(in) :: x(:),y(:),x1,x2
    integral_linlog_subset_<T> = integral_general_subset_<T>(x, y, x1, x2, interp1d_linlog_<T>, trapezium_linlog_<T>)
  end function integral_linlog_subset_<T>

  real(<T>) function integral_loglin_<T>(x,y)
    ! Total integral of a function
    ! (uses loglin interpolation)
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    integral_loglin_<T> = integral_general_<T>(x, y, trapezium_loglin_<T>)
  end function integral_loglin_<T>

  real(<T>) function integral_loglin_subset_<T>(x,y,x1,x2)
    ! Integral of a function between two limits
    ! (uses loglin interpolation)
    implicit none
    real(<T>),intent(in) :: x(:),y(:),x1,x2
    integral_loglin_subset_<T> = integral_general_subset_<T>(x, y, x1, x2, interp1d_loglin_<T>, trapezium_loglin_<T>)
  end function integral_loglin_subset_<T>

  real(<T>) function integral_loglog_<T>(x,y)
    ! Total integral of a function
    ! (uses log10 interpolation)
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    integral_loglog_<T> = integral_general_<T>(x, y, trapezium_loglog_<T>)
  end function integral_loglog_<T>

  real(<T>) function integral_loglog_subset_<T>(x,y,x1,x2)
    ! Integral of a function between two limits
    ! (uses log10 interpolation)
    implicit none
    real(<T>),intent(in) :: x(:),y(:),x1,x2
    integral_loglog_subset_<T> = integral_general_subset_<T>(x, y, x1, x2, interp1d_loglog_<T>, trapezium_loglog_<T>)
  end function integral_loglog_subset_<T>

  function cumulative_integral_<T>(x,y)
    ! Total cumulative_integral of a function
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    real(<T>), dimension(size(y)) :: cumulative_integral_<T>
    cumulative_integral_<T> = cumulative_integral_general_<T>(x, y, trapezium_<T>)
  end function cumulative_integral_<T>

  function cumulative_integral_linlog_<T>(x,y)
    ! Total cumulative_integral of a function
    ! (uses linlog interpolation)
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    real(<T>), dimension(size(y)) :: cumulative_integral_linlog_<T>
    cumulative_integral_linlog_<T> = cumulative_integral_general_<T>(x, y, trapezium_linlog_<T>)
  end function cumulative_integral_linlog_<T>

  function cumulative_integral_loglin_<T>(x,y)
    ! Total cumulative_integral of a function
    ! (uses loglin interpolation)
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    real(<T>), dimension(size(y)) :: cumulative_integral_loglin_<T>
    cumulative_integral_loglin_<T> = cumulative_integral_general_<T>(x, y, trapezium_loglin_<T>)
  end function cumulative_integral_loglin_<T>

  function cumulative_integral_loglog_<T>(x,y)
    ! Total cumulative_integral of a function
    ! (uses log10 interpolation)
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    real(<T>), dimension(size(y)) :: cumulative_integral_loglog_<T>
    cumulative_integral_loglog_<T> = cumulative_integral_general_<T>(x, y, trapezium_loglog_<T>)
  end function cumulative_integral_loglog_<T>

  real(<T>) function integral_general_<T>(x,y,f_chunk) result(sum)
    ! Total integral of a function
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    integer :: j
    interface
       real(<T>) function f_chunk(x1,y1,x2,y2)
         import :: <T>
         implicit none
         real(<T>),intent(in) :: x1,y1,x2,y2
       end function f_chunk
    end interface
    sum = 0._<T>
    do j=1,size(x)-1
       sum=sum+f_chunk(x(j),y(j),x(j+1),y(j+1))
    end do
  end function integral_general_<T>

  function cumulative_integral_general_<T>(x,y,f_chunk) result(c)
    ! Total integral of a function
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    integer :: j
    interface
       real(<T>) function f_chunk(x1,y1,x2,y2)
         import :: <T>
         implicit none
         real(<T>),intent(in) :: x1,y1,x2,y2
       end function f_chunk
    end interface
    real(<T>), dimension(size(y)) :: c
    c(1) = 0._<T>
    do j=1,size(x)-1
       c(j+1)=c(j)+f_chunk(x(j),y(j),x(j+1),y(j+1))
    end do
  end function cumulative_integral_general_<T>

  real(<T>) function integral_general_subset_<T>(x,y,x1,x2,f_interp,f_chunk) result(sum)
    ! Integral of a function between two limits

    implicit none

    real(<T>),intent(in) :: x(:),y(:),x1,x2
    integer :: i1,i2
    real(<T>) :: f1,f2
    integer :: n

    interface
       real(<T>) function f_interp(x, y, xval,bounds_error,fill_value)
         import :: <T>
         implicit none
         real(<T>),dimension(:),intent(in) :: x,y
         real(<T>),intent(in) :: xval
         logical,intent(in),optional :: bounds_error
         real(<T>),intent(in),optional :: fill_value
       end function f_interp
       real(<T>) function f_chunk(x1,y1,x2,y2)
         import :: <T>
         implicit none
         real(<T>),intent(in) :: x1,y1,x2,y2
       end function f_chunk
    end interface

    n = size(x)

    if(x1.gt.x(n).or.x2.lt.x(1)) then
       sum = 0._<T>
       return
    end if

    if(x1.gt.x(1)) then
       i1 = locate(x,x1)
       f1 = f_interp(x,y,x1)
    else
       i1 = 0
       f1 = 0._<T>
    end if

    if(x2.lt.x(n)) then
       i2 = locate(x,x2)
       f2 = f_interp(x,y,x2)
    else
       i2 = n
       f2 = 0._<T>
    end if

    if(i2.gt.i1) then

       ! Add main part
       if(i2 > i1+1) then
          sum = integral_general_<T>(x(i1+1:i2), y(i1+1:i2), f_chunk)
       else
          sum = 0._<T>
       end if

       ! Add extremities
       sum = sum + f_chunk(x1,f1,x(i1+1),y(i1+1))
       sum = sum + f_chunk(x(i2),y(i2),x2,f2)

    else

       sum = f_chunk(x1,f1,x2,f2)

    end if

  end function integral_general_subset_<T>

  real(<T>) function trapezium_<T>(x1,y1,x2,y2)
    implicit none
    real(<T>),intent(in) :: x1,y1,x2,y2
    trapezium_<T> = 0.5_<T>*(y1+y2)*(x2-x1)
  end function trapezium_<T>

  real(<T>) function trapezium_loglin_<T>(x1,y1,x2,y2)
    implicit none
    real(<T>),intent(in) :: x1,y1,x2,y2
    real(<T>) :: a,b
    if(x1==x2) then
       trapezium_loglin_<T> = 0._<T>
    else
       a = (y1-y2) / log10(x1/x2)
       b = y1 - a * log10(x1)
       trapezium_loglin_<T> = a*(x2*log10(x2) - x1*log10(x1)) &
            &                     + (b-a/log(10._<T>)) * (x2 - x1)
    end if
  end function trapezium_loglin_<T>

  real(<T>) function trapezium_linlog_<T>(x1,y1,x2,y2)
    implicit none
    real(<T>),intent(in) :: x1,y1,x2,y2
    real(<T>) :: dx
    if(x1==x2) then
       trapezium_linlog_<T> = 0._<T>
    else if(y1==y2) then
       trapezium_linlog_<T> = y1*(x2-x1)
    else
       dx = x2 - x1
       trapezium_linlog_<T> = (y2-y1)*(x2-x1)/log(10._<T>)/log10(y2/y1)
    end if
  end function trapezium_linlog_<T>

  real(<T>) function trapezium_loglog_<T>(x1,y1,x2,y2)
    implicit none
    real(<T>),intent(in) :: x1,y1,x2,y2
    real(<T>) :: b
    if(x1==x2) then
       trapezium_loglog_<T> = 0._<T>
    else if(y1==0..or.y2==0.) then
       trapezium_loglog_<T> = 0._<T>
    else
       b = log10(y1/y2) / log10(x1/x2)
       if(abs(b+1._dp) < 1e-10) then
          trapezium_loglog_<T> = x1 * y1 * log(x2/x1)
       else
          trapezium_loglog_<T> = y1 * (x2*(x2/x1)**b-x1) / (b+1)
       end if
    end if
  end function trapezium_loglog_<T>

  real(<T>) function interp1d_single_<T>(x1,y1,x2,y2,xval) result(yval)
    real(<T>),intent(in) :: x1,y1,x2,y2,xval
    real(<T>) :: frac
    frac = ( xval - x1 ) / ( x2 - x1 )
    yval = y1 + frac * ( y2 - y1 )
  end function interp1d_single_<T>

  real(<T>) function interp1d_single_linlog_<T>(x1,y1,x2,y2,xval) result(yval)
    real(<T>),intent(in) :: x1,y1,x2,y2,xval
    real(<T>) :: frac
    if(y1==0..or.y2==0.) then
       yval = 0._<T>
    else
       frac = ( xval - x1 ) / ( x2 - x1 )
       yval = 10._<T>**(log10(y1) + frac * ( log10(y2) - log10(y1) ))
    end if
  end function interp1d_single_linlog_<T>

  real(<T>) function interp1d_single_loglin_<T>(x1,y1,x2,y2,xval) result(yval)
    real(<T>),intent(in) :: x1,y1,x2,y2,xval
    real(<T>) :: frac
    frac = ( log10(xval) - log10(x1) ) / ( log10(x2) - log10(x1) )
    yval = y1 + frac * ( y2 - y1 )
  end function interp1d_single_loglin_<T>

  real(<T>) function interp1d_single_loglog_<T>(x1,y1,x2,y2,xval) result(yval)
    real(<T>),intent(in) :: x1,y1,x2,y2,xval
    real(<T>) :: frac
    if(y1==0..or.y2==0.) then
       yval = 0._<T>
    else
       frac = ( log10(xval) - log10(x1) ) / ( log10(x2) - log10(x1) )
       yval = 10._<T>**(log10(y1) + frac * ( log10(y2) - log10(y1) ))
    end if
  end function interp1d_single_loglog_<T>

  real(<T>) function interp1d_<T>(x,y,xval,bounds_error,fill_value) result(yval)
    implicit none
    real(<T>),dimension(:),intent(in) :: x,y
    real(<T>),intent(in) :: xval
    logical,intent(in),optional :: bounds_error
    real(<T>),intent(in),optional :: fill_value
    yval = interp1d_general_<T>(x,y,xval,interp1d_single_<T>,bounds_error,fill_value)
  end function interp1d_<T>

  function interp1d_array_<T>(x,y,xval,bounds_error,fill_value)
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    real(<T>),intent(in) :: xval(:)
    logical,intent(in),optional :: bounds_error
    real(<T>),intent(in),optional :: fill_value
    real(<T>) :: interp1d_array_<T>(size(xval))
    integer :: i
    do i=1,size(xval)
       interp1d_array_<T>(i) = interp1d_<T>(x,y,xval(i),bounds_error,fill_value)
    end do
  end function interp1d_array_<T>

  real(<T>) function interp1d_linlog_<T>(x,y,xval,bounds_error,fill_value) result(yval)
    implicit none
    real(<T>),dimension(:),intent(in) :: x,y
    real(<T>),intent(in) :: xval
    logical,intent(in),optional :: bounds_error
    real(<T>),intent(in),optional :: fill_value
    yval = interp1d_general_<T>(x,y,xval,interp1d_single_linlog_<T>,bounds_error,fill_value)
  end function interp1d_linlog_<T>

  function interp1d_array_linlog_<T>(x,y,xval,bounds_error,fill_value)
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    real(<T>),intent(in) :: xval(:)
    logical,intent(in),optional :: bounds_error
    real(<T>),intent(in),optional :: fill_value
    real(<T>) :: interp1d_array_linlog_<T>(size(xval))
    integer :: i
    do i=1,size(xval)
       interp1d_array_linlog_<T>(i) = interp1d_linlog_<T>(x,y,xval(i),bounds_error,fill_value)
    end do
  end function interp1d_array_linlog_<T>

  real(<T>) function interp1d_loglin_<T>(x,y,xval,bounds_error,fill_value) result(yval)
    implicit none
    real(<T>),dimension(:),intent(in) :: x,y
    real(<T>),intent(in) :: xval
    logical,intent(in),optional :: bounds_error
    real(<T>),intent(in),optional :: fill_value
    yval = interp1d_general_<T>(x,y,xval,interp1d_single_loglin_<T>,bounds_error,fill_value)
  end function interp1d_loglin_<T>

  function interp1d_array_loglin_<T>(x,y,xval,bounds_error,fill_value)
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    real(<T>),intent(in) :: xval(:)
    logical,intent(in),optional :: bounds_error
    real(<T>),intent(in),optional :: fill_value
    real(<T>) :: interp1d_array_loglin_<T>(size(xval))
    integer :: i
    do i=1,size(xval)
       interp1d_array_loglin_<T>(i) = interp1d_loglin_<T>(x,y,xval(i),bounds_error,fill_value)
    end do
  end function interp1d_array_loglin_<T>

  real(<T>) function interp1d_loglog_<T>(x,y,xval,bounds_error,fill_value) result(yval)
    implicit none
    real(<T>),dimension(:),intent(in) :: x,y
    real(<T>),intent(in) :: xval
    logical,intent(in),optional :: bounds_error
    real(<T>),intent(in),optional :: fill_value
    yval = interp1d_general_<T>(x,y,xval,interp1d_single_loglog_<T>,bounds_error,fill_value)
  end function interp1d_loglog_<T>

  function interp1d_array_loglog_<T>(x,y,xval,bounds_error,fill_value)
    implicit none
    real(<T>),intent(in) :: x(:),y(:)
    real(<T>),intent(in) :: xval(:)
    logical,intent(in),optional :: bounds_error
    real(<T>),intent(in),optional :: fill_value
    real(<T>) :: interp1d_array_loglog_<T>(size(xval))
    integer :: i
    do i=1,size(xval)
       interp1d_array_loglog_<T>(i) = interp1d_loglog_<T>(x,y,xval(i),bounds_error,fill_value)
    end do
  end function interp1d_array_loglog_<T>

  real(<T>) function interp1d_general_<T>(x,y,xval,f_single,bounds_error,fill_value) result(yval)

    implicit none

    integer :: n
    ! the size of the array

    real(<T>),dimension(:),intent(in) :: x,y
    ! the x and y arrays

    real(<T>),intent(in) :: xval
    ! the value at which to interpolate y

    interface
       real(<T>) function f_single(x1,y1,x2,y2,xval)
         import :: <T>
         implicit none
         real(<T>),intent(in) :: x1,y1,x2,y2,xval
       end function f_single
    end interface

    logical,intent(in),optional :: bounds_error
    ! whether to raise an out of bounds error

    real(<T>),intent(in),optional :: fill_value
    ! value for out of bounds if bounds_error is .false.

    integer :: ipos
    ! position of x value in x array

    logical :: bounds_error_tmp
    real(<T>) :: fill_value_tmp

    if(present(bounds_error)) then
       bounds_error_tmp = bounds_error
    else
       bounds_error_tmp = .true.
    end if

    if(.not.bounds_error_tmp) then
       if(present(fill_value)) then
          fill_value_tmp = fill_value
       else
          fill_value_tmp = 0._<T>
       end if
    end if

    n = size(x)

    ipos = locate(x,xval)

    ! --- First some error checking --- !

    if(ipos == -1) then
       if(bounds_error_tmp) then
          write(0,'("ERROR: Interpolation out of bounds : ",ES11.4," in [",ES11.4,":",ES11.4,"]")') xval,x(1),x(n)
          stop
       else
          yval = fill_value_tmp
          return
       end if
    end if

    if( ipos < n .and. ipos > 0) then
       yval = f_single(x(ipos), y(ipos), x(ipos+1), y(ipos+1), xval)
    else if(ipos == n) then
       yval = y(n)
    else if(ipos == 0) then
       yval = y(1)
    else
       write(0,'("ERROR: Unexpected value of ipos : ",I0)') ipos
       stop
    end if

  end function interp1d_general_<T>

  function interp2d_<T>(x,y,array,x0,y0,bounds_error,fill_value) result(value)
    ! Bilinar interpolation of array = f(x,y) at (x0,y0)

    implicit none

    real(<T>),intent(in) :: x(:),y(:),array(:,:),x0,y0

    logical,intent(in),optional :: bounds_error
    ! whether to raise an out of bounds error

    real(<T>),intent(in),optional :: fill_value
    ! value for out of bounds if bounds_error is .false.

    real(<T>) :: value,norm
    integer :: i1,i2,j1,j2

    logical :: bounds_error_tmp
    real(<T>) :: fill_value_tmp

    if(present(bounds_error)) then
       bounds_error_tmp = bounds_error
    else
       bounds_error_tmp = .true.
    end if

    if(.not.bounds_error_tmp) then
       if(present(fill_value)) then
          fill_value_tmp = fill_value
       else
          fill_value_tmp = 0._<T>
       end if
    end if

    if(size(x).ne.size(array,1)) stop "x does not match array"
    if(size(y).ne.size(array,2)) stop "y does not match array"

    i1 = locate(x,x0) ; i2 = i1 + 1
    j1 = locate(y,y0) ; j2 = j1 + 1

    if(i1==-1) then
       if(bounds_error_tmp) then
          write(0,'("ERROR: Interpolation out of bounds : ",ES11.4," in [",ES11.4,":",ES11.4,"]")') x0,x(1),x(size(x))
          stop
       else
          value = fill_value_tmp
          return
       end if
    end if

    if(j1==-1) then
       if(bounds_error_tmp) then
          write(0,'("ERROR: Interpolation out of bounds : ",ES11.4," in [",ES11.4,":",ES11.4,"]")') y0,y(1),y(size(y))
          stop
       else
          value = fill_value_tmp
          return
       end if
    end if

    norm = 1._<T> / (x(i2) - x(i1)) / (y(j2)-y(j1))

    value =   array(i1,j1) * (x(i2)-x0) * (y(j2)-y0) * norm &
         &       + array(i2,j1) * (x0-x(i1)) * (y(j2)-y0) * norm &
         &       + array(i1,j2) * (x(i2)-x0) * (y0-y(j1)) * norm &
         &       + array(i2,j2) * (x0-x(i1)) * (y0-y(j1)) * norm

  end function interp2d_<T>

  real(<T>) function average_lin_<T>(a,b)
    implicit none
    real(<T>),intent(in) :: a,b
    average_lin_<T> = 0.5_<T> * (a + b)
  end function average_lin_<T>

  real(<T>) function average_log_<T>(a,b)
    implicit none
    real(<T>),intent(in) :: a,b
    average_log_<T> = sqrt(a*b)
  end function average_log_<T>

  subroutine rebin_<T>(x, y, xx, yy)
    real(<T>),intent(in) :: x(:), y(:), xx(:)
    real(<T>),intent(out) :: yy(:)
    call rebin_general_<T>(x, y, xx, yy, average_lin_<T>, integral_subset_<T>)
  end subroutine rebin_<T>

  subroutine rebin_linlog_<T>(x, y, xx, yy)
    real(<T>),intent(in) :: x(:), y(:), xx(:)
    real(<T>),intent(out) :: yy(:)
    call rebin_general_<T>(x, y, xx, yy, average_lin_<T>, integral_linlog_subset_<T>)
  end subroutine rebin_linlog_<T>

  subroutine rebin_loglin_<T>(x, y, xx, yy)
    real(<T>),intent(in) :: x(:), y(:), xx(:)
    real(<T>),intent(out) :: yy(:)
    call rebin_general_<T>(x, y, xx, yy, average_log_<T>, integral_loglin_subset_<T>)
  end subroutine rebin_loglin_<T>

  subroutine rebin_loglog_<T>(x, y, xx, yy)
    real(<T>),intent(in) :: x(:), y(:), xx(:)
    real(<T>),intent(out) :: yy(:)
    call rebin_general_<T>(x, y, xx, yy, average_log_<T>, integral_loglog_subset_<T>)
  end subroutine rebin_loglog_<T>

  subroutine rebin_general_<T>(x, y, xx, yy, f_average, f_integral)
    implicit none
    real(<T>),intent(in) :: x(:), y(:), xx(:)
    real(<T>),intent(out) :: yy(:)
    integer :: i
    real(<T>) :: xmin, xmax
    interface
       real(<T>) function f_average(a,b)
         import :: <T>
         implicit none
         real(<T>),intent(in) :: a,b
       end function f_average
       real(<T>) function f_integral(x,y,x1,x2)
         import :: <T>
         implicit none
         real(<T>),intent(in) :: x(:),y(:),x1,x2
       end function f_integral
    end interface
    do i=1,size(xx)
       if(i==1) then
          xmin = xx(1)
       else
          xmin = f_average(xx(i-1), xx(i))
       end if
       if(i==size(xx)) then
          xmax = xx(size(xx))
       else
          xmax = f_average(xx(i), xx(i+1))
       end if
       yy(i) = f_integral(x, y, xmin, xmax) / (xmax - xmin)
    end do
  end subroutine rebin_general_<T>

  integer function locate_<T>(xx,x)
    ! Locate a value in a sorted array

    implicit none
    real(<T>), dimension(:), intent(in) :: xx
    real(<T>), intent(in) :: x
    integer :: n,jl,jm,ju
    logical :: ascnd
    n=size(xx)
    ascnd = (xx(n) >= xx(1))
    jl=0
    ju=n+1
    do
       if (ju-jl <= 1) exit
       jm=(ju+jl)/2
       if (ascnd .eqv. (x >= xx(jm))) then
          jl=jm
       else
          ju=jm
       end if
    end do

    if (x == xx(1)) then
       locate_<T> = 1
    else if (x == xx(n)) then
       locate_<T> = n-1
    else if(ascnd.and. (x > xx(n) .or. x < xx(1))) then
       locate_<T> = -1
    else if(.not.ascnd.and. (x < xx(n) .or. x > xx(1))) then
       locate_<T> = -1
    else
       locate_<T> = jl
    end if

  end function locate_<T>

  integer function ipos_<T>(xmin,xmax,x,nbin)
    ! Find bin a value falls in for a regular histogram

    implicit none

    real(<T>),intent(in) :: xmin,xmax
    ! range of values

    real(<T>),intent(in) :: x
    ! the value to bin

    integer,intent(in) :: nbin
    ! number of bins

    real(<T>) :: frac

    if(xmax > xmin) then

       if(x < xmin) then
          ipos_<T> = 0
       else if(x > xmax) then
          ipos_<T> = nbin+1
       else if(x < xmax) then
          frac=(x-xmin)/(xmax-xmin)
          ipos_<T>=int(frac*real(nbin, <T>))+1
       else  ! x == xmax
          ipos_<T> = nbin
       end if

    else

       if(x < xmax) then
          ipos_<T> = 0
       else if(x > xmin) then
          ipos_<T> = nbin+1
       else if(x < xmin) then
          frac=(x-xmin)/(xmax-xmin)
          ipos_<T>=int(frac*real(nbin, <T>))+1
       else  ! x == xmin
          ipos_<T> = nbin
       end if

    end if

  end function ipos_<T>

  real(<T>) function xval_<T>(xmin,xmax,i,nbin)
    ! Find central value of a bin for a regular histogram

    implicit none

    real(<T>),intent(in) :: xmin,xmax
    ! range of values

    integer,intent(in) :: i
    ! the bin number

    integer,intent(in) :: nbin
    ! number of bins

    real(<T>) :: frac

    frac=(real(i-1)+0.5)/real(nbin)

    xval_<T>=frac*(xmax-xmin)+xmin

  end function xval_<T>

  subroutine histogram1d_<T>(array,xmin,xmax,nbin,hist_x,hist_y,mask,weights)
    ! Bin 1D array of values into 1D regular histogram

    implicit none

    real(<T>),dimension(:),intent(in) :: array
    real(<T>),dimension(:),intent(in),optional :: weights
    ! the array of values to bin

    real(<T>),intent(in) :: xmin,xmax
    ! the range of the histogram

    integer,intent(in) :: nbin
    ! number of bins

    real(<T>),dimension(nbin),intent(out) :: hist_x,hist_y
    ! the histogram

    integer :: i,ibin
    ! binning variables

    logical,optional,intent(in) :: mask(:)
    logical,allocatable:: keep(:)

    allocate(keep(size(array)))

    if(present(mask)) then
       keep = mask
    else
       keep = .true.
    end if

    hist_x=0._<T> ; hist_y=0._<T>

    do i=1,size(array)
       if(keep(i)) then
          ibin=ipos(xmin,xmax,array(i),nbin)
          if(ibin.ge.1.and.ibin.le.nbin) then
             if(present(weights)) then
                hist_y(ibin)=hist_y(ibin)+weights(i)
             else
                hist_y(ibin)=hist_y(ibin)+1._<T>
             end if
          end if
       end if
    end do

    do ibin=1,nbin
       hist_x(ibin)=xval(xmin,xmax,ibin,nbin)
    end do

    deallocate(keep)

  end subroutine histogram1d_<T>

  subroutine histogram2d_<T>(n,x,y,xmin,xmax,ymin,ymax,nx,ny,array,mask_in)
    ! Bin two 1D array of values into 2D regular grid

    implicit none

    integer,intent(in) :: n
    ! number of values to bin

    real(<T>),dimension(n),intent(in) :: x,y
    logical,dimension(n),intent(in),optional :: mask_in
    ! the array of values to bin

    real(<T>),intent(in) :: xmin,xmax,ymin,ymax
    ! the range of the histogram

    integer,intent(in) :: nx,ny
    ! number of bins

    real(<T>),dimension(nx,ny),intent(out) :: array
    ! the histogram

    integer :: i,ix,iy
    ! binning variables

    logical,dimension(n) :: mask

    if(present(mask_in)) then
       mask = mask_in
    else
       mask = .true.
    end if

    array = 0._<T>

    do i=1,n

       if(mask(i)) then

          ix=ipos(xmin,xmax,x(i),nx)
          iy=ipos(ymin,ymax,y(i),ny)

          if(ix.ge.1.and.ix.le.nx) then
             if(iy.ge.1.and.iy.le.ny) then
                array(ix,iy) = array(ix,iy) + 1.
             end if
          end if

       end if

    end do

  end subroutine histogram2d_<T>

  subroutine swap_<T>(array, i, j)
    implicit none
    real(<T>),intent(inout) :: array(:)
    integer,intent(in) :: i, j
    real(<T>) :: temp
    temp = array(j)
    array(j) = array(i)
    array(i) = temp
  end subroutine swap_<T>

  subroutine partition_<T>(array, left, right, pivot_index, store_index)
    implicit none
    real(<T>),intent(inout) :: array(:)
    integer,intent(in) :: left, right, pivot_index
    integer,intent(out) :: store_index
    real(<T>) :: pivot_value
    integer :: i
    pivot_value = array(pivot_index)
    call swap_<T>(array, pivot_index, right)
    store_index = left
    do i=left, right-1
       if(array(i) <= pivot_value) then
          call swap_<T>(array, i, store_index)
          store_index = store_index + 1
       end if
    end do
    call swap_<T>(array, store_index, right)
  end subroutine partition_<T>

  recursive subroutine quicksort_<T>(array, left, right)
    implicit none
    real(<T>),intent(inout) :: array(:)
    integer,intent(in) :: left, right
    integer :: pivot_index, new_pivot_index
    if(right > left) then
       pivot_index = left+(right-left)/2
       call partition_<T>(array, left, right, pivot_index, new_pivot_index)
       call quicksort_<T>(array, left, new_pivot_index - 1)
       call quicksort_<T>(array, new_pivot_index + 1, right)
    end if
  end subroutine quicksort_<T>

  recursive subroutine quicksort_all_<T>(array)
    implicit none
    real(<T>),intent(inout) :: array(:)
    call quicksort_<T>(array, 1, size(array))
  end subroutine quicksort_all_<T>

  subroutine swap_index_<T>(array, index, i, j)
    implicit none
    real(<T>),intent(inout) :: array(:)
    integer,intent(inout) :: index(:)
    integer,intent(in) :: i, j
    real(<T>) :: temp
    integer :: temp_i
    temp = array(j)
    temp_i = index(j)
    array(j) = array(i)
    index(j) = index(i)
    array(i) = temp
    index(i) = temp_i
  end subroutine swap_index_<T>

  subroutine partition_index_<T>(array, index, left, right, pivot_index, store_index)
    implicit none
    real(<T>),intent(inout) :: array(:)
    integer,intent(inout) :: index(:)
    integer,intent(in) :: left, right, pivot_index
    integer,intent(out) :: store_index
    real(<T>) :: pivot_value
    integer :: i
    pivot_value = array(pivot_index)
    call swap_index_<T>(array, index, pivot_index, right)
    store_index = left
    do i=left, right-1
       if(array(i) <= pivot_value) then
          call swap_index_<T>(array, index, i, store_index)
          store_index = store_index + 1
       end if
    end do
    call swap_index_<T>(array, index, store_index, right)
  end subroutine partition_index_<T>

  recursive subroutine quicksort_index_<T>(array, index, left, right)
    implicit none
    real(<T>),intent(inout) :: array(:)
    integer,intent(inout) :: index(:)
    integer,intent(in) :: left, right
    integer :: pivot_index, new_pivot_index
    if(right > left) then
       pivot_index = left+(right-left)/2
       call partition_index_<T>(array, index, left, right, pivot_index, new_pivot_index)
       call quicksort_index_<T>(array, index, left, new_pivot_index - 1)
       call quicksort_index_<T>(array, index, new_pivot_index + 1, right)
    end if
  end subroutine quicksort_index_<T>

  recursive subroutine quicksort_index_all_<T>(array, index)
    implicit none
    real(<T>),intent(inout) :: array(:)
    integer,intent(inout) :: index(:)
    call quicksort_index_<T>(array, index, 1, size(array))
  end subroutine quicksort_index_all_<T>

  subroutine check_sort_<T>(array)
    implicit none
    real(<T>),intent(inout) :: array(:)
    integer :: j
    do j=1,size(array)-1
       if(array(j+1) < array(j)) stop "Incorrectly sorted array"
    end do
  end subroutine check_sort_<T>

  subroutine test_quicksort_<T>()

    implicit none

    real(<T>),allocatable :: array1(:), array2(:)
    integer,allocatable :: index(:)
    integer :: j,i

    write(*,'(" Testing quicksort")')

    do j=1,20

       write(*,'("  - n=",I0)') 2**j

       allocate(array1(2**j))

       call random_number(array1)

       call quicksort(array1)

       call check_sort_<T>(array1)

       deallocate(array1)

    end do

    write(*,'(" Testing quicksort_index")')

    do j=1,20

       write(*,'("  - n=",I0)') 2**j

       allocate(array1(2**j), array2(2**j), index(2**j))

       call random_number(array1)
       array2 = array1
       forall(i=1:2**j) index(i) = i

       call quicksort_index(array1, index)

       call check_sort_<T>(array1)

       if(any(array2(index).ne.array1)) stop "Failure in quicksort_index"

       deallocate(array1, array2, index)

    end do

  end subroutine test_quicksort_<T>

  !!@END FOR

  subroutine invert_matrix(n,a,c)

    implicit none

    integer,intent(in) :: n
    ! size of the matrix

    real(dp),dimension(n,n),intent(in)  :: a
    real(dp),dimension(n,n),intent(out) :: c
    ! the input and output matrices

    real(dp),dimension(n,n) :: b

    integer :: i,j
    real(dp) :: scale

    ! a is the input matrix

    ! b is initially set to a

    b = a

    ! c is initially an identity matrix

    c = 0._dp
    forall(i=1:n) c(i,i) = 1._dp

    ! Go through each row, and sutract from all subsequent rows

    do i=1,n
       do j=i+1,n
          scale = -b(i,j)/b(i,i)
          b(:,j) = b(:,j)+scale*b(:,i)
          c(:,j) = c(:,j)+scale*c(:,i)
       end do
    end do

    do j=1,n-1
       do i=j+1,n
          scale = -b(i,j)/b(i,i)
          b(:,j) = b(:,j)+scale*b(:,i)
          c(:,j) = c(:,j)+scale*c(:,i)
       end do
    end do

    forall(i=1:n,j=1:n) c(i,j) = c(i,j)/b(j,j)
    forall(i=1:n,j=1:n) b(i,j) = b(i,j)/b(j,j)

  end subroutine invert_matrix

  subroutine print_matrix(a)

    implicit none

    integer :: nx,ny
    real(dp),dimension(:,:),intent(in) :: a

    integer :: i

    character(len=20) :: fmt

    nx = size(a,1)
    ny = size(a,2)

    write(fmt,'("(",I3.3,"(F9.5,1X))")') nx

    do i=1,ny
       write(*,fmt) a(:,i)
    end do

  end subroutine print_matrix

  subroutine bin_array(n,x,y,n_bin,xmin,xmax,x_bin,y_bin)

    implicit none

    integer,intent(in) :: n,n_bin
    real(dp),dimension(n),intent(in) :: x,y
    real(dp),dimension(n_bin),intent(out) :: x_bin,y_bin

    real(dp),dimension(n_bin) :: s,c

    real(dp) :: xmin,xmax

    integer :: i,ix

    s = 0.
    c = 0.

    do i=1,n

       ix = ipos(xmin,xmax,x(i),n_bin)

       if(ix.ge.1.and.ix.le.n_bin) then
          c(ix)  = c(ix) + 1.
          s(ix)  = s(ix) + y(i)
       end if

    end do

    do i=1,n_bin
       x_bin(i) = xval(xmin,xmax,i,n_bin)
    end do

    y_bin = s / c

  end subroutine bin_array

  subroutine smooth_2d(array,sigma)

    implicit none

    real,intent(inout) :: array(:,:)

    integer :: nx,ny
    real,allocatable :: array_orig(:,:),array_count(:,:)

    real,intent(in) :: sigma

    integer :: i,j,ii,jj,imin,imax,jmin,jmax,w

    real :: dx,dy,d

    nx = size(array,1)
    ny = size(array,2)

    allocate(array_orig(nx,ny),array_count(nx,ny))

    array_orig  = array
    array       = 0.
    array_count = 0.

    w = nint(sigma * 5._dp)

    do i=1,nx
       do j=1,ny

          imin = max( 1,i-w)
          imax = min(nx,i+w)
          jmin = max( 1,j-w)
          jmax = min(ny,j+w)

          do ii=imin,imax
             do jj=jmin,jmax

                dx = real(ii-i) / sigma
                dy = real(jj-j) / sigma

                d = dx*dx+dy*dy

                array(i,j) = array(i,j) + array_orig(ii,jj) * exp(-d/2._dp)
                array_count(i,j) = array_count(i,j) + exp(-d/2._dp)

             end do
          end do

       end do
    end do

    array = array / array_count

  end subroutine smooth_2d

end module lib_array


    subroutine phfunc2(xv,fph,dfph)
!   --------------------------------
!   This routine calculate pH for a solution at equilibrium with
!   soil PCO2. Used to estimate phosphorus weathering

    implicit none
    include 'combine_foam.inc'

    pr=0.

    fph=-xv*xv*xv+1.d-8*xv+2*ak1soil*ak2soil*betasoil*pco2soil+ &
        ak1soil*xv*betasoil*pco2soil
    dfph=-3.*xv*xv+1.d-8+ak1soil*xv*betasoil*pco2soil

    return
    end


      FUNCTION FSTRSE(VOID,BMECH1,BMECH2,BMECH3)
      REAL::FSTRSE,BMECH1,TMP,VOID,BMECH2,BMECH3,FSTRSELOG
C  ADDED STANDARD EXPONENTIAL FORM CONSTITUTIVE RELATIONSHIP
C CHANGE RECORD
C
C
C **  FSTRSE IS WATER SPECIFIC WEIGHT NORMALIZED EFFECTIVE STRESS
C
      IF(BMECH1.GT.0.0)THEN
        TMP=-(VOID-BMECH2)/BMECH3
        FSTRSE=BMECH1*EXP(TMP)
      ELSE
C
C        FSTRSELOG=-0.0147351*(VOID**3)+0.333957*(VOID**2)-3.28661*VOID
C
        FSTRSELOG=-0.0147351*(VOID**3)+0.311854*(VOID**2)-2.96371*VOID
     &      +7.34698
        FSTRSE=EXP(FSTRSELOG)
      END IF
      RETURN
      END


      program envelopef
      implicit none

      include "sacf.h"

!     Define the Maximum size of the data Array
      integer MAX
      parameter (MAX=4000)

!     Define the Data Array of size MAX
      real*4 :: ya(MAX), yb(MAX), yc(MAX)

!     Declare Variables used in the rsac1() subroutine
      real beg, delta
      integer na, nb, nc
      character*64 KNAME
      integer nerr

      integer sac_compare

!     Read in the first data file
      kname = 'convolvef_in1.sac'
      call rsac1(kname, ya, na, beg, delta, MAX, nerr)

      if(nerr .NE. 0) then
         write(*,*)'Error reading in file: ',kname
         call exit(-1)
      endif

!     Read in the second data file
      kname = 'convolvef_in2.sac'
      call rsac1(kname, yb, nb, beg, delta, MAX, nerr)

      if(nerr .NE. 0) then
         write(*,*)'Error reading in file: ',kname
         call exit(-1)
      endif

      nc = na + nb - 1
      call convolve(ya, na, yb, nb, yc, nc)

      if(sac_compare("convolvef_out_sac1.sac", yc, nc, 0.0, delta) .ne. 1) then
         write(*,*)'data does not match file'
      endif

      call wsac1("convolvef_out.sac", yc, nc, beg, delta, nerr);

      end program envelopef


c> \file setulb.f

c> \example driver1.f
c> This simple driver demonstrates how to call the L-BFGS-B code to
c> solve a sample problem (the extended Rosenbrock function
c> subject to bounds on the variables).
c> The dimension n of this problem is variable.
c> (Fortran-77 version)

c> \example driver1.f90
c> This simple driver demonstrates how to call the L-BFGS-B code to
c> solve a sample problem (the extended Rosenbrock function
c> subject to bounds on the variables).
c> The dimension n of this problem is variable.
c> (Fortran-90 version)

c> \example driver2.f
c> This driver shows how to replace the default stopping test
c> by other termination criteria. It also illustrates how to
c> print the values of several parameters during the course of
c> the iteration. The sample problem used here is the same as in
c> DRIVER1 (the extended Rosenbrock function with bounds on the variables).
c> (Fortran-77 version)

c> \example driver2.f90
c> This driver shows how to replace the default stopping test
c> by other termination criteria. It also illustrates how to
c> print the values of several parameters during the course of
c> the iteration. The sample problem used here is the same as in
c> DRIVER1 (the extended Rosenbrock function with bounds on the variables).
c> (Fortran-90 version)

c> \example driver3.f
c> This time-controlled driver shows that it is possible to terminate
c> a run by elapsed CPU time, and yet be able to print all desired
c> information. This driver also illustrates the use of two
c> stopping criteria that may be used in conjunction with a limit
c> on execution time. The sample problem used here is the same as in
c> driver1 and driver2 (the extended Rosenbrock function with bounds
c> on the variables).
c> (Fortran-77 version)

c> \example driver3.f90
c> This time-controlled driver shows that it is possible to terminate
c> a run by elapsed CPU time, and yet be able to print all desired
c> information. This driver also illustrates the use of two
c> stopping criteria that may be used in conjunction with a limit
c> on execution time. The sample problem used here is the same as in
c> driver1 and driver2 (the extended Rosenbrock function with bounds
c> on the variables).
c> (Fortran-90 version)

c> \brief This subroutine partitions the working arrays wa and iwa, and
c>        then uses the limited memory BFGS method to solve the bound
c>        constrained optimization problem by calling mainlb.
c>
c> This subroutine partitions the working arrays wa and iwa, and
c> then uses the limited memory BFGS method to solve the bound
c> constrained optimization problem by calling mainlb.
c> (The direct method will be used in the subspace minimization.)
c>
c> @param n On entry n is the dimension of the problem.

c>          On exit n is unchanged.
c>
c> @param m On entry m is the maximum number of variable metric corrections
c>             used to define the limited memory matrix.

c>          On exit m is unchanged.
c>
c> @param x On entry x is an approximation to the solution.

c>          On exit x is the current approximation.
c>
c> @param l On entry l is the lower bound on x.

c>          On exit l is unchanged.
c>
c> @param u On entry u is the upper bound on x.

c>          On exit u is unchanged.
c>
c> @param nbd On entry nbd represents the type of bounds imposed on the
c>               variables, and must be specified as follows:
c>               nbd(i)=

0 if x(i) is unbounded,

c>
1 if x(i) has only a lower bound,

c>
2 if x(i) has both lower and upper bounds, and

c>
3 if x(i) has only an upper bound.

c>            On exit nbd is unchanged.
c>
c> @param f On first entry f is unspecified.

c>          On final exit f is the value of the function at x.
c>
c> @param g On first entry g is unspecified.

c>          On final exit g is the value of the gradient at x.
c>
c> @param factr On entry factr >= 0 is specified by the user.  The iteration
c>                 will stop when

c>                 (f^k - f^{k+1})/max{|f^k|,|f^{k+1}|,1} <= factr*epsmch

c>                 where epsmch is the machine precision, which is automatically
c>                 generated by the code.

c>                 Typical values for factr:

c>
1.d+12 for low accuracy;

c>
1.d+7  for moderate accuracy;

c>
1.d+1 for extremely high accuracy.

c>              On exit factr is unchanged.
c>
c> @param pgtol On entry pgtol >= 0 is specified by the user.  The iteration
c>                 will stop when

c>                        max{|proj g_i | i = 1, ..., n} <= pgtol

c>                 where pg_i is the ith component of the projected gradient.

c>              On exit pgtol is unchanged.
c>
c> @param wa working array
c>
c> @param iwa working array
c>
c> @param task working string indicating
c>             the current job when entering and quitting this subroutine.
c>
c> @param iprint Must be set by the user.
c>               It controls the frequency and type of output generated:

c>
iprint<0    no output is generated;

c>
iprint=0    print only one line at the last iteration;

c>
0<iprint<99 print also f and |proj g| every iprint iterations;

c>
iprint=99   print details of every iteration except n-vectors;

c>
iprint=100  print also the changes of active set and final x;

c>
iprint>100  print details of every iteration including x and g;

c>               When iprint > 0, the file iterate.dat will be created to
c>                                summarize the iteration.
c>
c> @param csave working string
c>
c> @param lsave working array;
c>              On exit with 'task' = NEW_X, the following information is
c>                                                                    available:

c>
If lsave(1) = .true.  then  the initial X has been replaced by
c>                                                its projection in the feasible set;

c>
If lsave(2) = .true.  then  the problem is constrained;

c>
If lsave(3) = .true.  then  each variable has upper and lower
c>                                                bounds;

c>
c> @param isave working array;
c>              On exit with 'task' = NEW_X, the following information is
c>                                                                    available:

c>
isave(22) = the total number of intervals explored in the
c>                                    search of Cauchy points;

c>
isave(26) = the total number of skipped BFGS updates before
c>                                    the current iteration;

c>
isave(30) = the number of current iteration;

c>
isave(31) = the total number of BFGS updates prior the current
c>                                    iteration;

c>
isave(33) = the number of intervals explored in the search of
c>                                    Cauchy point in the current iteration;

c>
isave(34) = the total number of function and gradient
c>                                    evaluations;

c>
isave(36) = the number of function value or gradient
c>                                              evaluations in the current iteration;

c>
if isave(37) = 0  then the subspace argmin is within the box;

c>
if isave(37) = 1  then the subspace argmin is beyond the box;

c>
isave(38) = the number of free variables in the current
c>                                    iteration;

c>
isave(39) = the number of active constraints in the current
c>                                    iteration;

c>
n + 1 - isave(40) = the number of variables leaving the set of
c>                                        active constraints in the current iteration;

c>
isave(41) = the number of variables entering the set of active
c>                                    constraints in the current iteration.

c>
c> @param dsave working array;
c>              On exit with 'task' = NEW_X, the following information is
c>                                                                    available:

c>
dsave(1) = current 'theta' in the BFGS matrix;

c>
dsave(2) = f(x) in the previous iteration;

c>
dsave(3) = factr*epsmch;

c>
dsave(4) = 2-norm of the line search direction vector;

c>
dsave(5) = the machine precision epsmch generated by the code;

c>
dsave(7) = the accumulated time spent on searching for
c>                                                             Cauchy points;

c>
dsave(8) = the accumulated time spent on
c>                                                        subspace minimization;

c>
dsave(9) = the accumulated time spent on line search;

c>
dsave(11) = the slope of the line search function at
c>                                         the current point of line search;

c>
dsave(12) = the maximum relative step length imposed in
c>                                                                  line search;

c>
dsave(13) = the infinity norm of the projected gradient;

c>
dsave(14) = the relative step length in the line search;

c>
dsave(15) = the slope of the line search function at
c>                                        the starting point of the line search;

c>
dsave(16) = the square of the 2-norm of the line search
c>                                                             direction vector.

      subroutine setulb(n, m, x, l, u, nbd, f, g, factr, pgtol, wa, iwa,
     +                 task, iprint, csave, lsave, isave, dsave)

      character*60     task, csave
      logical          lsave(4)
      integer          n, m, iprint,
     +                 nbd(n), iwa(3*n), isave(44)
      double precision f, factr, pgtol, x(n), l(n), u(n), g(n),
c
c-jlm-jn
     +                 wa(2*m*n + 5*n + 11*m*m + 8*m), dsave(29)

c     ************
c
c     References:
c
c       [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited
c       memory algorithm for bound constrained optimization'',
c       SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208.
c
c       [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: a
c       limited memory FORTRAN code for solving bound constrained
c       optimization problems'', Tech. Report, NAM-11, EECS Department,
c       Northwestern University, 1994.
c
c       (Postscript files of these papers are available via anonymous
c        ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.)
c
c                           *  *  *
c
c     NEOS, November 1994. (Latest revision June 1996.)
c     Optimization Technology Center.
c     Argonne National Laboratory and Northwestern University.
c     Written by
c                        Ciyou Zhu
c     in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.
c
c
c     ************
c-jlm-jn
      integer   lws,lr,lz,lt,ld,lxp,lwa,
     +          lwy,lsy,lss,lwt,lwn,lsnd

      if (task .eq. 'START') then
         isave(1)  = m*n
         isave(2)  = m**2
         isave(3)  = 4*m**2
         isave(4)  = 1                      ! ws      m*n
         isave(5)  = isave(4)  + isave(1)   ! wy      m*n
         isave(6)  = isave(5)  + isave(1)   ! wsy     m**2
         isave(7)  = isave(6)  + isave(2)   ! wss     m**2
         isave(8)  = isave(7)  + isave(2)   ! wt      m**2
         isave(9)  = isave(8)  + isave(2)   ! wn      4*m**2
         isave(10) = isave(9)  + isave(3)   ! wsnd    4*m**2
         isave(11) = isave(10) + isave(3)   ! wz      n
         isave(12) = isave(11) + n          ! wr      n
         isave(13) = isave(12) + n          ! wd      n
         isave(14) = isave(13) + n          ! wt      n
         isave(15) = isave(14) + n          ! wxp     n
         isave(16) = isave(15) + n          ! wa      8*m
      endif
      lws  = isave(4)
      lwy  = isave(5)
      lsy  = isave(6)
      lss  = isave(7)
      lwt  = isave(8)
      lwn  = isave(9)
      lsnd = isave(10)
      lz   = isave(11)
      lr   = isave(12)
      ld   = isave(13)
      lt   = isave(14)
      lxp  = isave(15)
      lwa  = isave(16)

      call mainlb(n,m,x,l,u,nbd,f,g,factr,pgtol,
     +  wa(lws),wa(lwy),wa(lsy),wa(lss), wa(lwt),
     +  wa(lwn),wa(lsnd),wa(lz),wa(lr),wa(ld),wa(lt),wa(lxp),
     +  wa(lwa),
     +  iwa(1),iwa(n+1),iwa(2*n+1),task,iprint,
     +  csave,lsave,isave(22),dsave)

      return

      end


program uno
open (10, FILE='Ejer5A.dat', STATUS='UNKNOWN')
write(10,*) i,x1,x2,xm, abs(G)
close(10)
end program
subroutine eulerexp(func,xo,yo,a,b,n,y)
!dado la confincion inicial xo,yo, en el intervalo (a,b) se eligen n puntos y devuelve la funcion en esos puntos.
implicit none
REAL*8,ALLOCATABLE,DIMENSION(:)::y,x
integer*4::n,i
real*8::func,xo,yo,a,b,h
h=(b-a)/n
allocate(x(n+1),y(n))
do i=0,n
x(i)=xo+h*i
end do
y(1)=yo+func(xo,yo)*h
do i=1,n
y(i+1)=y(i)+func(x(i),y(i))*h
end do
return
end subroutine


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

! tests arithmetic if codegen

function aif(x, expect)
  integer :: x
  integer :: expect(3)
  integer :: res
  if(x) 5,15,25
5   res = expect(1)
    goto 35
15  res = expect(2)
    goto 35
25  res = expect(3)
35  aif = res
end function

program main
  integer, parameter :: val1=10
  integer, parameter :: val2=20
  integer, parameter :: val3=30
  integer :: res(3)
  integer :: expect(3) = (/10,20,30/)
  res(1) = aif(-1, expect)
  res(2) = aif(0, expect)
  res(3) = aif(1, expect)
  call check(res, expect, 3)
end program


subroutine beta(Nm,Nx,Ny,psi,beta_term)

implicit none
integer, intent(in) :: Nx,Ny,Nm
real(8), dimension(Nm,Nx,Ny), intent(in)  :: psi
real(8), dimension(Nm,Nx,Ny), intent(out) :: beta_term

integer :: i,j,m

beta_term(:,:,:) = 0.d0

do m=1,Nm
 do i=2,Nx-1
  do j=2,Ny-1

   beta_term(m,i,j) = psi(m,i+1,j)-psi(m,i-1,j)

  end do
 end do
end do
!write(*,*) beta_term

end


! Heat transport in 2D.
!
! A parallel version of the same serial code.  Run it with `-np 4`.  Compile and
! run:
!
!   $ mpifort -g -O0 -Wall -Wextra -Wpedantic -fcheck=all -fbacktrace heat_parallel.f90
!   $ mpirun -np 4 --oversubscribe ./a.out < in.txt
program heat_parallel
    use mpi_f08
    implicit none
    real, parameter :: alpha = 2.5e-4
    real, dimension(:, :), pointer :: prev_t, next_t, temp_t
    real :: diff_t, global_diff_t
    type(MPI_Comm) :: comm
    type(MPI_Status) :: status
    integer(kind=MPI_ADDRESS_KIND) :: lb, real_extent
    type(MPI_Datatype) :: a_col, a_row, a_tmp_row
    integer :: n_ranks, my_rank, root, north_rank, south_rank, west_rank, east_rank
    integer :: n_rows, n_cols, row, col, ib, ie, jb, je, rb, re, cb, ce
    integer :: s, i, time

    call MPI_Init()
    comm = MPI_COMM_WORLD
    call MPI_Comm_size(comm, n_ranks)
    call MPI_Comm_rank(comm, my_rank)

    root = 0

    ! Create a 2D topology.
    n_rows = 2
    n_cols = 2
    if (n_rows * n_cols /= n_ranks) then
        print "(a)", "Run this code with `-np 4`."
        call MPI_Abort(comm, MPI_ERR_TOPOLOGY)
    end if
    call get_coords(my_rank, n_rows, n_cols, row, col)

    ! Define neighbor ranks with non-periodic boundaries.
    north_rank = get_rank(row - 1, col,     n_rows, n_cols)
    south_rank = get_rank(row + 1, col,     n_rows, n_cols)
    west_rank  = get_rank(row,     col - 1, n_rows, n_cols)
    east_rank  = get_rank(row,     col + 1, n_rows, n_cols)

    ! Read in the array size and distribute it between processes.
    if (my_rank == root) read *, s
    call MPI_Bcast(s, 1, MPI_INTEGER, root, comm)

    ! Partition the global 2D array into a Cartisian product of two 1D array
    ! partitions for each of the two dimensions.
    call partition(row, n_rows, s, ib, ie)
    call partition(col, n_cols, s, jb, je)

    ! Create sub-arrays for the temperature grid.  Include two outer cells on
    ! both sides for ghost columns and rows.
    allocate(prev_t(ib - 1:ie + 1, jb - 1:je + 1))
    allocate(next_t(ib - 1:ie + 1, jb - 1:je + 1))

    ! One column covers the internal range, [ib:ie].
    call MPI_Type_contiguous(ie - ib + 1, MPI_REAL, a_col)
    call MPI_Type_commit(a_col)

    ! One row covers the internal range and two outer ghost cells, [jb-1:je+1].
    call MPI_Type_get_extent(MPI_REAL, lb, real_extent)
    call MPI_Type_vector(je - jb + 3, 1, ie - ib + 3, MPI_REAL, a_tmp_row)
    call MPI_Type_create_resized(a_tmp_row, lb, real_extent, a_row)
    call MPI_Type_commit(a_row)

    ! Read in the `prev_t` array at root and distribute it to other processes.
    call read_array()

    ! Synchronize rows.
    call MPI_Sendrecv(prev_t(ib,     jb - 1), 1, a_row, north_rank, 3, &
                      prev_t(ie + 1, jb - 1), 1, a_row, south_rank, 3, comm, status)
    call MPI_Sendrecv(prev_t(ie,     jb - 1), 1, a_row, south_rank, 4, &
                      prev_t(ib - 1, jb - 1), 1, a_row, north_rank, 4, comm, status)

    ! Copy boundary conditions to the next array.
    next_t(:, :) = prev_t(:, :)

    time = 0
    do
        next_t(ib:ie, jb:je) = &
            (1.0 - 4.0 * alpha) *     prev_t(ib    :ie,     jb    :je    ) &
                       + alpha  * (   prev_t(ib - 1:ie - 1, jb    :je    ) &
                                    + prev_t(ib + 1:ie + 1, jb    :je    ) &
                                    + prev_t(ib    :ie    , jb - 1:je - 1) &
                                    + prev_t(ib    :ie    , jb + 1:je + 1) )

        ! Synchronize columns.
        call MPI_Sendrecv(next_t(ib, jb    ), 1, a_col, west_rank, 1, &
                          next_t(ib, je + 1), 1, a_col, east_rank, 1, comm, status)
        call MPI_Sendrecv(next_t(ib, je    ), 1, a_col, east_rank, 2, &
                          next_t(ib, jb - 1), 1, a_col, west_rank, 2, comm, status)

        ! Synchronize rows.
        call MPI_Sendrecv(next_t(ib,     jb - 1), 1, a_row, north_rank, 3, &
                          next_t(ie + 1, jb - 1), 1, a_row, south_rank, 3, comm, status)
        call MPI_Sendrecv(next_t(ie,     jb - 1), 1, a_row, south_rank, 4, &
                          next_t(ib - 1, jb - 1), 1, a_row, north_rank, 4, comm, status)

        diff_t = maxval(abs(next_t(ib:ie, jb:je) - prev_t(ib:ie, jb:je)))
        call MPI_Allreduce(diff_t, global_diff_t, 1, MPI_REAL, MPI_MAX, comm)

        if (modulo(time, 10000) == 0) then
            if (my_rank == root) then
                print "(a, i0, a, es12.5)", "time = ", time, ", diff_t = ", global_diff_t
            end if
            ! Print the `prev_t` array by sending it to root.
            call print_array()
        end if
        if (global_diff_t < epsilon(0.0)) exit
        temp_t => prev_t; prev_t => next_t; next_t => temp_t
        time = time + 1
    end do
    if (my_rank == root) print "(a, i0)", "Final time is ", time

    deallocate(prev_t)
    deallocate(next_t)

    call MPI_Type_free(a_col)
    call MPI_Type_free(a_row)

    call MPI_Finalize()

contains

    !---------------------------------------------------------------------------
    ! Direct procedure: get the process rank from its coordinates in a 2D
    ! Cartesian topology.  The row and column numbers can be oustide the range
    ! of definition.  The Cartesian topology is column-major as in Fortran.  The
    ! boundaries are not periodic to avoid communicating utmost ghost cells to
    ! neighbors to keep the boundary conditions constant.
    integer function get_rank(row, col, n_rows, n_cols)
        integer, intent(in) :: row, col, n_rows, n_cols

        if (      0 <= col .and. col < n_cols &
            .and. 0 <= row .and. row < n_rows) then
                get_rank = row + col * n_rows
        else
            get_rank = MPI_PROC_NULL
        end if
        return
    end function get_rank
    !---------------------------------------------------------------------------
    ! Inverse procedure: get the row and column coordinates in a 2D Cartesian
    ! topology for the given process rank.  The process rank may be outside the
    ! range of definition but should preferably be not.  The Cartesian topology
    ! is column-major as in Fortran.
    subroutine get_coords(rank, n_rows, n_cols, row, col)
        integer, intent(in)    :: rank, n_rows, n_cols
        integer, intent(inout) :: row, col

        row = modulo(rank, n_rows)
        col = (rank - row) / n_rows
        if (0 <= col .and. col < n_cols) then
            return
        else
            print "(a, 2(i0, a))", "get_coords: rank ", rank, &
                " is outside the column range [0, ", n_cols, ")."
            call MPI_Abort(comm, MPI_ERR_TOPOLOGY)
        end if
    end subroutine get_coords
    !---------------------------------------------------------------------------
    subroutine partition(id, n_ids, size, b, e)
        integer, intent(in)    :: id, n_ids, size
        integer, intent(inout) :: b, e
        integer :: remainder, quotient

        remainder = modulo(size, n_ids)
        quotient  = (size - remainder) / n_ids
        b = 1 + quotient * (id    ) + min(remainder, id    )
        e =     quotient * (id + 1) + min(remainder, id + 1)
        return
    end subroutine partition
    !---------------------------------------------------------------------------
    ! Read in the global array and distribute to other processes row-by-row.
    subroutine read_array()
        if (my_rank == root) then
            block
                real, dimension(:), allocatable :: t_row
                integer :: dst
                allocate(t_row(0:s + 1))
                do row = 0, n_rows - 1
                    call partition(row, n_rows, s, rb, re)
                    rb = merge(rb - 1, rb, row == 0)
                    re = merge(re + 1, re, row == n_rows - 1)
                    do i = rb, re
                        read *, t_row(:)
                        do col = 0, n_cols - 1
                            call partition(col, n_cols, s, cb, ce)
                            dst = get_rank(row, col, n_rows, n_cols)
                            if (dst == root) then
                                prev_t(i, cb - 1:ce + 1) = t_row(cb - 1:ce + 1)
                            else
                                call MPI_Send(t_row(cb - 1), ce - cb + 3, MPI_REAL, dst, 0, comm)
                            end if
                        end do
                    end do
                end do
                deallocate(t_row)
            end block
        else
            rb = merge(ib - 1, ib, row == 0)
            re = merge(ie + 1, ie, row == n_rows - 1)
            do i = rb, re
                call MPI_Recv(prev_t(i, jb - 1), 1, a_row, root, 0, comm, status)
            end do
        end if
        return
    end subroutine read_array
    !---------------------------------------------------------------------------
    ! Homework:
    subroutine print_array()
        if (my_rank == root) then
            continue
        else
            continue
        end if
        return
    end subroutine print_array
    !---------------------------------------------------------------------------
end program heat_parallel


c==============================================================================
      subroutine calc_xyz(l, b, d, x, y, z)
c==============================================================================
c
c     calculates the cartesian xyz positions in the Galaxy
c     given galactic latitude and longitude and distance.
c                       DRL 30/1/92
c
c     Last Change 93/05/20 DRL @ JB Changed to sun at (-rsun,0,0)
c
      implicit none
c
c     passed down variables: in l & b in degrees d in kpc
c                           out x,y,z in kpc
c
      real l, b, d, x, y, z
c
c     local variables
c
      real cl, cb, sl, sb, lold, bold, rsun, rad
      parameter(rsun=8.5,rad=57.29577951)
      logical first
      data first/.true./
c
c     work out cos & sin if changed from last call
c
      if (l.ne.lold.or.b.ne.bold.or.first) then
        cl=cos(l/rad)
        sl=sin(l/rad)
        cb=cos(b/rad)
        sb=sin(b/rad)
        first=.false.
        lold=l
        bold=b
      endif
c
c     calculate (x,y,z)
c
c      x = d*cb*cl - rsun
c      y = d*cb*sl
c      z = d*sb

	x=d*cb*sl
	y=rsun-d*cb*cl
	z=d*sb

      end
c==============================================================================


!-------------------------------------------------------------------------------
! (C) Crown copyright Met Office. All rights reserved.
!     Refer to COPYRIGHT.txt of this distribution for details.
!-------------------------------------------------------------------------------
! Find a solution to the GPSRO inverse problem.
!-------------------------------------------------------------------------------

module ufo_gnssroonedvarcheck_setom1_mod

use kinds
use missing_values_mod
use ufo_roobserror_utils_mod, only: Rmatrix_type

private
public :: Ops_GPSRO_setOM1

contains

SUBROUTINE Ops_GPSRO_setOM1 (nobs,      &
                             zobs,      &
                             yobs,      &
                             Rmatrix,   &
                             OSigma,    &
                             OM1,       &
                             OM1_error)

USE ufo_utils_mod, ONLY: InvertMatrix

IMPLICIT NONE

! Subroutine arguments:
INTEGER, INTENT(IN)             :: nobs
REAL(kind_real), INTENT(IN)     :: zobs(:)
REAL(kind_real), INTENT(IN)     :: yobs(:)
TYPE (rmatrix_type), INTENT(IN) :: Rmatrix
REAL(kind_real), INTENT(OUT)    :: OSigma(:)
REAL(kind_real), INTENT(OUT)    :: OM1(:,:)
LOGICAL, INTENT(OUT)            :: OM1_error

! Local declarations:
CHARACTER(len=*), PARAMETER     :: RoutineName = "Ops_GPSRO_setOM1"
INTEGER                         :: n
INTEGER                         :: i
INTEGER                         :: ReturnCode
REAL(kind_real)                 :: frac_err
REAL(kind_real)                 :: omat(nobs,nobs)
REAL(kind_real), ALLOCATABLE    :: gradient(:)

IF (Rmatrix % satid <= 0) THEN
  ! Rmatrix has not been set up
  OM1_error = .TRUE.
  OSigma(:) = 1
  OM1(:,:) = 1
ELSE
  ALLOCATE (gradient(Rmatrix % num_heights - 1))

  DO i = 1, Rmatrix % num_heights - 1

    ! Calculate the gradient of fractional error with height

    gradient(i) = (Rmatrix % frac_err(i + 1) - Rmatrix % frac_err(i)) / &
                  (Rmatrix % height(i + 1) - Rmatrix % height(i))

  END DO

  OM1_error = .FALSE.

  ! Initialise covariance matrix

  omat(:,:) = 0.0

  ! Calculate the variance values

  DO n = 1, nobs

    i = 1

    DO

      IF (zobs(n) < Rmatrix % height(i + 1) .OR. &
          i + 1 >= Rmatrix % num_heights) THEN
        EXIT
      END IF

      i = i + 1

    END DO

    ! Fractional error

    frac_err = Rmatrix % frac_err(i) + &
               gradient(i) * (zobs(n) - Rmatrix % height(i))

    ! Standard deviation

    OSigma(n) = MAX (frac_err * yobs(n), Rmatrix % min_error)

    ! Variance

    omat(n,n) = OSigma(n) ** 2

  END DO

  ! Calculate the covariances

  DO n = 1,nobs

    DO i = n + 1,nobs

      omat(n,i) = SQRT (omat(n,n) * omat(i,i)) * &
                  EXP (-Rmatrix % clen * ABS (zobs(i) - zobs(n)))

      omat(i,n) = omat(n,i)

    END DO

  END DO

  ! Invert the matrix

  CALL InvertMatrix (nobs,   &
                     nobs,   &
                     omat,   &
                     ReturnCode)

  ! Set the inverse

  OM1(:,:) = omat(:,:)

  IF (ReturnCode /= 0) OM1_error = .TRUE.

  DEALLOCATE (gradient)
END IF

END SUBROUTINE Ops_GPSRO_setOM1

end module ufo_gnssroonedvarcheck_setom1_mod


module grasp_rciqed_qed_pyykkoe
    use, intrinsic :: iso_fortran_env, only: real64, dp => real64
    implicit none

contains

    !> Calculates `(k1, k2)` matrix element of the effective local QED self-energy
    !! potential [Pyykkö & Zhao, 2003].
    !!
    !! Returns the value of the matrix element for the specified orbital pair `(k1, k2)`.
    !!
    !! It is assumed that the self-energy correction is given by a simple central scalar
    !! potential \f$ V(r) = B \exp(-\beta r^2) \f$. Pyykkö & Zhao then parametrize and fit
    !! the \f$B\f$ and \f$\beta\f$ values for \f$Z\f$-dependecy:
    !!
    !! \f[
    !!     B = b_0 + b_1 \cdot Z + b_2 \cdot Z^2,
    !!     \quad
    !!     \beta = \beta_0 + \beta_1 \cdot Z + \beta_2 \cdot Z^2
    !! \f]
    !!
    !! The values for the parameters are listed in Table 2. of the reference.
    !!
    !! The code is based on the implementation in GRASP92 by Christian Thierfelder,
    !! Peter Schwerdtfeger and Lukáš Félix Pašteka.
    !!
    !! ### References
    !!
    !!   - [Pyykkö & Zhao, 2003] Pyykkö and Zhao, J.Phys.B 36, 1469 (2003)
    !!
    function qedse_pyykkoe(k1, k2)
        use def_C, only: Z
        use grid_C, only: N, R, RP
        use tatb_C, only: MTP, TA
        use wave_C, only: PF, QF
        use quad_I
        implicit none

        integer :: k1, k2
        real(real64) :: qedse_pyykkoe

        integer :: i
        real(real64) :: B, beta

        ! Values for the parametrization of B and beta, from [Pyykkö & Zhao, 2003]
        real(real64), parameter :: b0 = -48.6166_dp
        real(real64), parameter :: b1 =  1.53666_dp
        real(real64), parameter :: b2 =  0.0301129_dp
        real(real64), parameter :: beta0 = -12751.3_dp
        real(real64), parameter :: beta1 =  916.038_dp
        real(real64), parameter :: beta2 =  5.7797_dp

        ! B and beta values for the current Z value
        B = b0 + b1*Z + b2*(Z**2)
        beta = beta0 + beta1*Z + beta2*(Z**2)

        ! We'll integrate f(r) = V(r) |ψ(r)|^2 , where ψ(r) is the Dirac wavefunction
        ! for the Pyykkö & Zhao potential V(r). The calculated expectation value gets
        ! returned.
        do i = 1, N
            TA(i) = (PF(i,k1)*PF(i,k2) + QF(i,k1)*QF(i,k2)) * B * exp(-beta*(R(i)**2)) * RP(i)
        end do
        MTP = N
        call QUAD(qedse_pyykkoe)
    end

end module grasp_rciqed_qed_pyykkoe


      module MOD_INITVEL

      contains

      SUBROUTINE INITVEL(RMAX, TEFF, GLOG, RSTAR, XMASS)

C***  INITIALIZATION OF THE VELOCITY-FIELD PARAMETERS

      use MOD_REGULA

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER ( ONE = 1.D+0, TWO = 2.D+0 )

      COMMON/VELPAR/ VFINAL,VMIN,BETA,VPAR1,VPAR2,RCON,HSCALE
      COMMON/VELPA1/ RMA

C***  BOLTZMANN CONSTANT (ERG/DEG)
      DATA  BOLTZ/ 1.380622D-16  /
C***  ATOMIC MASS UNIT (GRAMM)
      DATA  AMU/ 1.660531D-24/

      RMA=RMAX

      IF (BETA.LE..0) THEN
            WRITE (6,'(A)') 'BETA OPTION INVALID'
            STOP 'ERROR'
            ENDIF

C***  CONVERSION OF VELOCITY-FIELD PARAMETERS (ANALYTIC LAW)
      Q=(VMIN/VFINAL)**(ONE/BETA)
      VPAR2=(ONE-Q)/(ONE-Q/RMAX)
      VPAR1=VMIN/(ONE-VPAR2)**BETA

C***  DETERMINATION OF THE SCALE HEIGHT (HYDROSTATIC EQ.)
C***  XMASS= MEAN MASS IN AMU ( 2. FOR HE II, 1.33 FOR HE III )
      HSCALE=BOLTZ*TEFF/XMASS/AMU/RSTAR/10.**GLOG

C***  ITERATIVE DETERMINATION OF THE CONNECTION POINT RCON
C***  BY REQUIRING A CONTINUOUS AND SMOOTH CONNECTION

      RCON=ONE
C***  BRANCH IF AT THE INNER BOUNDARY THE EXPONENTIAL LAW GRADIENT
C***  EXCEEDS ALREADY THE BETA-LAW GRADIENT
      IF (DELTAGR(ONE) .LT. .0) THEN
            WRITE (6,'(A)') 'INITVEL: NO HYDROSTATIC DOMAIN ENCOUNTERED'

            RETURN
            ENDIF

C***  LOWER GUESS FOR RCON
      RCON1=ONE
      WRITE (6,111) VPAR1,VPAR2,RCON,HSCALE
 176  RCONMIN=DMAX1(RCON1,VPAR2+1.D-10)
      IF (RCONMIN.GT.RMAX) THEN
         RCON=RMAX
         DEL=DELTAGR(RCON)
         WRITE (6,111) VPAR1,VPAR2,RCON,DEL
         RETURN
         ENDIF
      IF (DELTAGR(RCONMIN) .LT. .0) THEN

            RCON1=RCON1+HSCALE
            GOTO 176

            ENDIF

C***  UPPER GUESS FOR RCON
      RCONMAX=RCONMIN
    2 RCONMAX=RCONMAX+HSCALE
      IF (RCONMAX .GE. RMAX) THEN
            RCON=RMAX
            WRITE (6,*) 'INITVEL: NO BETA-LAW DOMAIN ENCOUNTERED'
            RCON=2.8D0
            DELVEL=DELTAGR(RCON)
            WRITE (6,111) VPAR1,VPAR2,RCON,DELVEL
            RETURN
            ENDIF

      IF (DELTAGR(RCONMAX) .GE. .0) GOTO 2
      RCONMIN=RCONMAX-HSCALE

    1 RCONOLD=RCON
      EPS=1.D-6
      CALL REGULA (DELTAGR,RCON,.0,RCONMIN,RCONMAX,EPS)
C***  RE-ADJUST THE BETA-LAW PARAMETERS SUCH THAT BOTH VELOCITIES AGREE
C***  AT THE CONNECTION POINT
      IF (ABS(RCON-RCONOLD) .GT. 1.D-5) GOTO 1

      WRITE (6,111) VPAR1,VPAR2,RCON,HSCALE
111   FORMAT (/,' INITVEL: VPAR1,VPAR2,RCON,HSCALE= ',/,4E12.5/)

      RETURN

      END subroutine

      FUNCTION DELTAGR(R)
C***  DIFFERENCE OF VELOCITY GRADIENTS FROM BOTH VELOCITY LAWS:
C***  THE BETA LAW (OUTER REGION) AND THE EXPONENTIAL LAW (INNER REGION)
C***  THIS ROUTINE SERVES FOR ESTIMATING THE CONNECTION POINT BETWEEN BOTH
C***  REGIONS AND IS CALLED FROM SUBROUTINE INITVEL, MAIN PROGRAM WRSTART

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER ( ONE = 1.D+0, TWO = 2.D+0 )

      COMMON/VELPAR/ VFINAL,VMIN,BETA,VPAR1,VPAR2,RCON,HSCALE
      COMMON/VELPA1/ RMA

C***  ASSUMING THAT R IS THE CONECTION RADIUS
      VCON=VMIN/R/R*EXP((ONE-ONE/R)/HSCALE)
      Q=(VCON/VFINAL)**(ONE/BETA)
      VPAR2=(ONE-Q)/(ONE/R - Q/RMA)
      VPAR1=VCON/(ONE-VPAR2/R)**BETA
      DELTAGR=VPAR1*VPAR2*BETA*(ONE-VPAR2/R)**(BETA-ONE)/R/R -
     -        VMIN/R/R*EXP((ONE-ONE/R)/HSCALE)*(ONE/R/R/HSCALE-TWO/R)
      RETURN

      END function

      end module


*     MB02GD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, NMAX, NLMAX
      PARAMETER        ( KMAX = 20, NMAX = 20, NLMAX = 20 )
      INTEGER          LDRB, LDT, LDWORK
      PARAMETER        ( LDRB = ( NLMAX + 1 )*KMAX, LDT = KMAX*NMAX,
     $                   LDWORK = ( NLMAX + 1 )*KMAX*KMAX +
     $                            ( 3 + NLMAX )*KMAX )
*     .. Local Scalars ..
      INTEGER          I, J, INFO, K, M, N, NL, SIZR
      CHARACTER        TRIU, TYPET
*     .. Local Arrays dimensioned for TYPET = 'R' ..
      DOUBLE PRECISION DWORK(LDWORK), RB(LDRB, NMAX*KMAX),
     $                 T(LDT, NMAX*KMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02GD
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) K, N, NL, TRIU
      TYPET = 'R'
      M = ( NL + 1 )*K
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE IF( NL.LE.0 .OR. NL.GT.NLMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) NL
      ELSE IF( K.LE.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) K
      ELSE
         READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K )
*        Compute the banded Cholesky factor.
         CALL MB02GD( TYPET, TRIU, K, N, NL, 0, N, T, LDT, RB, LDRB,
     $                DWORK, LDWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            IF ( LSAME( TRIU, 'T' ) ) THEN
               SIZR = NL*K + 1
            ELSE
               SIZR = ( NL + 1 )*K
            END IF
            DO 10  I = 1, SIZR
               WRITE ( NOUT, FMT = 99996 ) ( RB(I,J), J = 1, N*K )
   10       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02GD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02GD = ',I2)
99997 FORMAT (/' The upper Cholesky factor in banded storage format ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' NL is out of range.',/' NL = ',I5)
99993 FORMAT (/' K is out of range.',/' K = ',I5)
      END