!!  Create a 1-d hydrostatic, atmosphere with an isothermal region
!!  (T_star) representing the NS, a hyperbolic tangent rise to a
!!  peak temperature (T_base) representing the base of an accreted
!!  layer, an isoentropic profile down to a lower temperature (T_lo),
!!  and then isothermal. This can serve as an initial model for a
!!  nova or XRB.
!!
!!  The temperature profile is:
!!
!!         ^
!!         |
!!  T_base +        /\
!!         |       /  \
!!         |      /  . \
!!  T_star +-----+      \
!!         |     .   .   \
!!         |              \
!!         |     .   .     \
!!  T_lo   +                +-----------
!!         |     .   .
!!         +-----+---+---------------> r
!!         |      \  /
!!         |      delta
!!         |< H_star>|
!!
!!  We take dens_base, the density at the base of the isentropic layer
!!  as input.  The composition is "ash" in the lower isothermal region
!!  and "fuel" in the isentropic and upper isothermal regions.  In the
!!  linear transition region, we linearly interpolate the composition.
!!
!!  The fuel and ash compositions are specified by the fuel?_name,
!!  fuel?_frac and ash?_name, ash?_frac parameters (name of the species
!!  and mass fraction).  Where ? = 1,2,3.
!!
!!  The model is placed into HSE by the following differencing:
!!
!!   (1/dr) [ <P>_i - <P>_{i-1} ] = (1/2) [ <rho>_i + <rho>_{i-1} ] g
!!
!!  This will be iterated over in tandem with the EOS call,
!!  P(i-1) = P_eos(rho(i-1), T(i-1), X(i-1)
!!

program init_1d_tanh

  use bl_types
  use bl_constants_module
  use bl_error_module
  use eos_module, only: eos_input_rt, eos, eos_init
  use eos_type_module, only: eos_t
  !use extern_probin_module, only: use_eos_coulomb
  use network, only : nspec, network_species_index, spec_names, network_init
  use fundamental_constants_module, only: Gconst

  implicit none

  integer :: i, n

  character(len=128) :: params_file

  real (kind=dp_t) :: T_base, T_star, T_lo
  real (kind=dp_t) :: dens_base
  real (kind=dp_t) :: H_star, delta

  real (kind=dp_t) :: slope_T, slope_xn(nspec)

  real (kind=dp_t) :: pres_base, entropy_base
  real (kind=dp_t), DIMENSION(nspec) :: xn_base, xn_star

  real (kind=dp_t), allocatable :: xzn_hse(:), xznl_hse(:), xznr_hse(:)
  real (kind=dp_t), allocatable :: model_hse(:,:)

  real :: A, B

  integer ::nx

  integer :: lun1, lun2

  ! define convenient indices for the scalars
  integer, parameter :: nvar = 3 + nspec
  integer, parameter :: idens = 1, &
                        itemp = 2, &
                        ipres = 3, &
                        ispec = 4

  ! we'll get the composition from the network module
  ! we allow for 3 different species separately in the fuel and ash
  integer :: ifuel1, ifuel2, ifuel3, ifuel4, ifuel5, ifuel6, ifuel7
  integer :: iash1, iash2, iash3, iash4
  character (len=32) :: fuel1_name, fuel2_name, fuel3_name, fuel4_name
  character (len=32) :: fuel5_name, fuel6_name, fuel7_name
  character (len=32) ::  ash1_name,  ash2_name,  ash3_name, ash4_name
  real (kind=dp_t) :: fuel1_frac, fuel2_frac, fuel3_frac, fuel4_frac
  real (kind=dp_t) :: fuel5_frac, fuel6_frac, fuel7_frac
  real (kind=dp_t) ::  ash1_frac,  ash2_frac,  ash3_frac, ash4_frac
  logical :: species_defined

  real (kind=dp_t) :: xmin, xmax, dCoord

  real (kind=dp_t) :: dens_zone, temp_zone, pres_zone, entropy
  real (kind=dp_t) :: dpd, dpt, dsd, dst

  real (kind=dp_t) :: p_want, drho, dtemp, delx

  real (kind=dp_t) :: g_zone, g_const, M_enclosed
  logical :: do_invsq_grav

  real (kind=dp_t), parameter :: TOL = 1.e-10

  integer, parameter :: MAX_ITER = 250

  integer :: iter

  logical :: converged_hse, fluff

  real (kind=dp_t), dimension(nspec) :: xn

  real (kind=dp_t) :: low_density_cutoff, smallx

  integer :: index_base

  logical :: isentropic

  character (len=256) :: outfile, outfile2
  character (len=8) :: num
  character (len=32) :: deltastr, dxstr
  character (len=32) :: num_to_unitstring

  real (kind=dp_t) :: max_hse_error, dpdr, rhog

  character (len=128) :: model_prefix

  integer :: narg

  logical :: index_base_from_temp

  type (eos_t) :: eos_state

  namelist /params/ nx, dens_base, T_star, T_base, T_lo, H_star, delta, &
                    fuel1_name, fuel2_name, fuel3_name, fuel4_name, &
                    fuel5_name, fuel6_name, fuel7_name, &
                    ash1_name, ash2_name, ash3_name, ash4_name, &
                    fuel1_frac, fuel2_frac, fuel3_frac, fuel4_frac, &
                    fuel5_frac, fuel6_frac, fuel7_frac, &
                    ash1_frac, ash2_frac, ash3_frac, ash4_frac, &
                    xmin, xmax, g_const, do_invsq_grav, M_enclosed, &
                    low_density_cutoff, model_prefix, index_base_from_temp

  ! determine if we specified a runtime parameters file or use the default
  narg = command_argument_count()

  if (narg == 0) then
     params_file = "_params"
  else
     call get_command_argument(1, value = params_file)
  endif

  ! define defaults for the parameters for this model
  nx = 640

  dens_base = 2.d6

  T_star = 1.d8
  T_base = 5.d8
  T_lo   = 5.e7

  H_star = 500.d0
  delta  = 25.d0

  fuel1_name = "helium-4"
  fuel2_name = ""
  fuel3_name = ""
  fuel4_name = ""
  fuel5_name = ""
  fuel6_name = ""
  fuel7_name = ""

  ash1_name  = "iron-56"
  ash2_name  = ""
  ash3_name  = ""
  ash4_name  = ""

  fuel1_frac = ONE
  fuel2_frac = ZERO
  fuel3_frac = ZERO
  fuel4_frac = ZERO
  fuel5_frac = ZERO
  fuel6_frac = ZERO
  fuel7_frac = ZERO

  ash1_frac = ONE
  ash2_frac = ZERO
  ash3_frac = ZERO
  ash4_frac = ZERO

  xmin = 0.0_dp_t
  xmax = 2.e3_dp_t

  model_prefix = "model"

  index_base_from_temp = .false.

  ! if do_invsq_grav = .false. we will use g_const for the
  ! gravitational acceleration.  Otherwise, we will compute gravity
  ! from M_enclosed and the distance from the origin
  M_enclosed = 2.d33
  g_const = -2.450d14
  do_invsq_grav = .false.

  low_density_cutoff = 1.d-4

  smallx = 1.d-10

  ! this comes in via extern_probin_module -- override the default
  ! here if we want
  !use_eos_coulomb = .true.

  ! initialize the EOS and network
  call eos_init()
  call network_init()

  ! check the namelist for any changed parameters
  open(unit=11, file=params_file, status="old", action="read")
  read(unit=11, nml=params)
  close(unit=11)

  ! get the species indices
  species_defined = .true.
  ifuel1 = network_species_index(trim(fuel1_name))
  if (ifuel1 < 0) species_defined = .false.

  if (fuel2_name /= "") then
     ifuel2 = network_species_index(trim(fuel2_name))
     if (ifuel2 < 0) species_defined = .false.
  endif

  if (fuel3_name /= "") then
     ifuel3 = network_species_index(trim(fuel3_name))
     if (ifuel3 < 0) species_defined = .false.
  endif

  if (fuel4_name /= "") then
     ifuel4 = network_species_index(trim(fuel4_name))
     if (ifuel4 < 0) species_defined = .false.
  endif

  if (fuel5_name /= "") then
     ifuel5 = network_species_index(trim(fuel5_name))
     if (ifuel5 < 0) species_defined = .false.
  endif

  if (fuel6_name /= "") then
     ifuel6 = network_species_index(trim(fuel6_name))
     if (ifuel6 < 0) species_defined = .false.
  endif

  if (fuel7_name /= "") then
     ifuel7 = network_species_index(trim(fuel7_name))
     if (ifuel7 < 0) species_defined = .false.
  endif

  iash1 = network_species_index(trim(ash1_name))
  if (iash1 < 0) species_defined = .false.

  if (ash2_name /= "") then
     iash2 = network_species_index(trim(ash2_name))
     if (iash2 < 0) species_defined = .false.
  endif

  if (ash3_name /= "") then
     iash3 = network_species_index(trim(ash3_name))
     if (iash3 < 0) species_defined = .false.
  endif

  if (ash4_name /= "") then
     iash4 = network_species_index(trim(ash4_name))
     if (iash4 < 0) species_defined = .false.
  endif

  if (.not. species_defined) then
     print *, ifuel1, ifuel2, ifuel3, ifuel4, ifuel5, ifuel6, ifuel7
     print *, iash1, iash2, iash3, iash4
     call bl_error("ERROR: species not defined")
  endif

  ! set the composition of the underlying star
  xn_star(:) = smallx
  xn_star(iash1) = ash1_frac
  if (ash2_name /= "") xn_star(iash2) = ash2_frac
  if (ash3_name /= "") xn_star(iash3) = ash3_frac
  if (ash4_name /= "") xn_star(iash4) = ash4_frac

  ! and the composition of the accreted layer
  xn_base(:) = smallx
  xn_base(ifuel1) = fuel1_frac
  if (fuel2_name /= "") xn_base(ifuel2) = fuel2_frac
  if (fuel3_name /= "") xn_base(ifuel3) = fuel3_frac
  if (fuel4_name /= "") xn_base(ifuel4) = fuel4_frac
  if (fuel5_name /= "") xn_base(ifuel5) = fuel5_frac
  if (fuel6_name /= "") xn_base(ifuel6) = fuel6_frac
  if (fuel7_name /= "") xn_base(ifuel7) = fuel7_frac

  ! check if they sum to 1
  if (abs(sum(xn_star) - ONE) > nspec*smallx) then
     call bl_error("ERROR: ash mass fractions don't sum to 1")
  endif

  if (abs(sum(xn_base) - ONE) > nspec*smallx) then
     call bl_error("ERROR: fuel mass fractions don't sum to 1")
  endif

!-----------------------------------------------------------------------------
! Create a 1-d uniform grid that is identical to the mesh that we are
! mapping onto, and then we want to force it into HSE on that mesh.
!-----------------------------------------------------------------------------

  ! allocate storage
  allocate(xzn_hse(nx))
  allocate(xznl_hse(nx))
  allocate(xznr_hse(nx))
  allocate(model_hse(nx,nvar))

  ! compute the coordinates of the new gridded function
  dCoord = (xmax - xmin) / dble(nx)

  do i = 1, nx
     xznl_hse(i) = xmin + (dble(i) - ONE)*dCoord
     xzn_hse(i)  = xmin + (dble(i) - HALF)*dCoord
     xznr_hse(i) = xmin + (dble(i))*dCoord
  enddo

  ! find the index of the base height
  index_base = -1
  do i = 1, nx
     if (xzn_hse(i) >= xmin + H_star + delta) then
        index_base = i+1
        exit
     endif
  enddo

  if (index_base == -1) then
     print *, 'ERROR: base_height not found on grid'
     call bl_error('ERROR: invalid base_height')
  endif

!-----------------------------------------------------------------------------
! put the model onto our new uniform grid
!-----------------------------------------------------------------------------

  fluff = .false.

  ! determine the conditions at the base
  eos_state%T     = T_base
  eos_state%rho   = dens_base
  eos_state%xn(:) = xn_base(:)

  call eos(eos_input_rt, eos_state)

  ! store the conditions at the base -- we'll use the entropy later
  ! to constrain the isentropic layer
  pres_base = eos_state%p
  entropy_base = eos_state%s

  print *, 'entropy_base = ', entropy_base
  print *, 'pres_base = ', pres_base

  ! set an initial temperature profile and composition
  do i = 1, nx

     !hyperbolic tangent transition:
     model_hse(i,ispec:ispec-1+nspec) = xn_star(1:nspec) + &
          HALF*(xn_base(1:nspec) - xn_star(1:nspec))* &
          (ONE + tanh((xzn_hse(i) - (xmin + H_star - delta) + delta)/delta))

     model_hse(i,itemp) = T_star + HALF*(T_base - T_star)* &
          (ONE + tanh((xzn_hse(i) - (xmin + H_star - delta) + delta)/delta))

     ! the density and pressure will be determined via HSE,
     ! for now, set them to the base conditions
     model_hse(i,idens) = dens_base
     model_hse(i,ipres) = pres_base

  enddo

  if (index_base_from_temp) then
     ! find the index of the base height -- look at the temperature for this
     index_base = -1
     do i = 1, nx
        !if (xzn_hse(i) >= xmin + H_star + delta) then
        if (model_hse(i,itemp) > 0.9995*T_base) then
           index_base = i+1
           exit
        endif
     enddo

     if (index_base == -1) then
        print *, 'ERROR: base_height not found on grid'
        call bl_error('ERROR: invalid base_height')
     endif
  endif

  print *, 'index_base = ', index_base

  ! make the base thermodynamics consistent for this base point -- that is
  ! what we will integrate from!
  eos_state%rho = model_hse(index_base,idens)
  eos_state%T = model_hse(index_base,itemp)
  eos_state%xn(:) = model_hse(index_base,ispec:ispec-1+nspec)

  call eos(eos_input_rt, eos_state)

  model_hse(index_base,ipres) = eos_state%p

!-----------------------------------------------------------------------------
! HSE + entropy solve
!-----------------------------------------------------------------------------

! the HSE state will be done putting creating an isentropic state until
! the temperature goes below T_lo -- then we will do isothermal.
! also, once the density goes below low_density_cutoff, we stop HSE

  isentropic = .true.

  !---------------------------------------------------------------------------
  ! integrate up
  !---------------------------------------------------------------------------
  do i = index_base+1, nx

     delx = xzn_hse(i) - xzn_hse(i-1)

     ! compute the gravitation acceleration at the lower edge
     if (do_invsq_grav) then
        g_zone = -Gconst*M_enclosed/xznl_hse(i)**2
     else
        g_zone = g_const
     endif

     ! we've already set initial guesses for density, temperature, and
     ! composition
     dens_zone = model_hse(i,idens)
     temp_zone = model_hse(i,itemp)
     xn(:) = model_hse(i,ispec:nvar)

     !-----------------------------------------------------------------------
     ! iteration loop
     !-----------------------------------------------------------------------

     ! start off the Newton loop by saying that the zone has not converged
     converged_hse = .FALSE.

     if (.not. fluff) then

        do iter = 1, MAX_ITER

           if (isentropic) then

              ! get the pressure we want from the HSE equation, just the
              ! zone below the current.  Note, we are using an average of
              ! the density of the two zones as an approximation of the
              ! interface value -- this means that we need to iterate for
              ! find the density and pressure that are consistent

              ! furthermore, we need to get the entropy that we need,
              ! which will come from adjusting the temperature in
              ! addition to the density.

              ! HSE differencing
              p_want = model_hse(i-1,ipres) + &
                   delx*0.5*(dens_zone + model_hse(i-1,idens))*g_zone

              ! now we have two functions to zero:
              !   A = p_want - p(rho,T)
              !   B = entropy_base - s(rho,T)
              ! We use a two dimensional Taylor expansion and find the deltas
              ! for both density and temperature

              ! now we know the pressure and the entropy that we want, so we
              ! need to find the temperature and density through a two
              ! dimensional root find

              ! (t, rho) -> (p, s)
              eos_state%T     = temp_zone
              eos_state%rho   = dens_zone
              eos_state%xn(:) = xn(:)

              call eos(eos_input_rt, eos_state)

              entropy = eos_state%s
              pres_zone = eos_state%p

              dpt = eos_state%dpdt
              dpd = eos_state%dpdr
              dst = eos_state%dsdt
              dsd = eos_state%dsdr

              A = p_want - pres_zone
              B = entropy_base - entropy

              dtemp = ((dsd/(dpd-0.5*delx*g_zone))*A - B)/ &
                   (dsd*dpt/(dpd -0.5*delx*g_zone) - dst)

              drho = (A - dpt*dtemp)/(dpd - 0.5*delx*g_zone)

              dens_zone = max(0.9_dp_t*dens_zone, &
                   min(dens_zone + drho, 1.1_dp_t*dens_zone))

              temp_zone = max(0.9_dp_t*temp_zone, &
                   min(temp_zone + dtemp, 1.1_dp_t*temp_zone))

              ! check if the density falls below our minimum cut-off --
              ! if so, floor it
              if (dens_zone < low_density_cutoff) then

                 dens_zone = low_density_cutoff
                 temp_zone = T_lo
                 converged_hse = .TRUE.
                 fluff = .TRUE.
                 exit

              endif

              ! if (A < TOL .and. B < ETOL) then
              if (abs(drho) < TOL*dens_zone .and. &
                  abs(dtemp) < TOL*temp_zone) then
                 converged_hse = .TRUE.
                 exit
              endif

           else

              ! do isothermal
              p_want = model_hse(i-1,ipres) + &
                   delx*0.5*(dens_zone + model_hse(i-1,idens))*g_zone

              temp_zone = T_lo

              ! (t, rho) -> (p)
              eos_state%T   = temp_zone
              eos_state%rho = dens_zone
              eos_state%xn(:) = xn(:)

              call eos(eos_input_rt, eos_state)

              entropy = eos_state%s
              pres_zone = eos_state%p

              dpd = eos_state%dpdr

              drho = (p_want - pres_zone)/(dpd - 0.5*delx*g_zone)

              dens_zone = max(0.9*dens_zone, &
                   min(dens_zone + drho, 1.1*dens_zone))

              if (abs(drho) < TOL*dens_zone) then
                 converged_hse = .TRUE.
                 exit
              endif

              if (dens_zone < low_density_cutoff) then

                 dens_zone = low_density_cutoff
                 temp_zone = T_lo
                 converged_hse = .TRUE.
                 fluff = .TRUE.
                 exit

              endif

           endif

           if (temp_zone < T_lo) then
              temp_zone = T_lo
              isentropic = .false.
           endif

        enddo

        if (.NOT. converged_hse) then

           print *, 'Error zone', i, ' did not converge in init_1d'
           print *, 'integrate up'
           print *, dens_zone, temp_zone
           print *, p_want, entropy_base, entropy
           print *, drho, dtemp
           call bl_error('Error: HSE non-convergence')

        endif

     else
        dens_zone = low_density_cutoff
        temp_zone = T_lo
     endif

     ! call the EOS one more time for this zone and then go on to the next
     ! (t, rho) -> (p)
     eos_state%T     = temp_zone
     eos_state%rho   = dens_zone
     eos_state%xn(:) = xn(:)

     call eos(eos_input_rt, eos_state)

     pres_zone = eos_state%p

     ! update the thermodynamics in this zone
     model_hse(i,idens) = dens_zone
     model_hse(i,itemp) = temp_zone
     model_hse(i,ipres) = pres_zone

     ! to make this process converge faster, set the density in the
     ! next zone to the density in this zone
     ! model_hse(i+1,idens) = dens_zone

  enddo

  !---------------------------------------------------------------------------
  ! integrate down -- using the temperature profile defined above
  !---------------------------------------------------------------------------
  do i = index_base-1, 1, -1

     delx = xzn_hse(i+1) - xzn_hse(i)

     ! compute the gravitation acceleration at the upper edge
     if (do_invsq_grav) then
        g_zone = -Gconst*M_enclosed/xznr_hse(i)**2
     else
        g_zone = g_const
     endif

     ! we already set the temperature and composition profiles
     temp_zone = model_hse(i,itemp)
     xn(:) = model_hse(i,ispec:nvar)

     ! use our previous initial guess for density
     dens_zone = model_hse(i+1,idens)

     !-----------------------------------------------------------------------
     ! iteration loop
     !-----------------------------------------------------------------------

     ! start off the Newton loop by saying that the zone has not converged
     converged_hse = .FALSE.

     do iter = 1, MAX_ITER

        ! get the pressure we want from the HSE equation, just the
        ! zone below the current.  Note, we are using an average of
        ! the density of the two zones as an approximation of the
        ! interface value -- this means that we need to iterate for
        ! find the density and pressure that are consistent

        ! HSE differencing
        p_want = model_hse(i+1,ipres) - &
             delx*0.5*(dens_zone + model_hse(i+1,idens))*g_zone

        ! we will take the temperature already defined in model_hse
        ! so we only need to zero:
        !   A = p_want - p(rho)

        ! (t, rho) -> (p)
        eos_state%T     = temp_zone
        eos_state%rho   = dens_zone
        eos_state%xn(:) = xn(:)

        call eos(eos_input_rt, eos_state)

        pres_zone = eos_state%p

        dpd = eos_state%dpdr

        A = p_want - pres_zone

        drho = A/(dpd + 0.5*delx*g_zone)

        dens_zone = max(0.9_dp_t*dens_zone, &
             min(dens_zone + drho, 1.1_dp_t*dens_zone))

        if (abs(drho) < TOL*dens_zone) then
           converged_hse = .TRUE.
           exit
        endif

     enddo

     if (.NOT. converged_hse) then

        print *, 'Error zone', i, ' did not converge in init_1d'
        print *, 'integrate down'
        print *, dens_zone, temp_zone
        print *, p_want
        print *, drho
        call bl_error('Error: HSE non-convergence')

     endif

     ! call the EOS one more time for this zone and then go on to the next
     ! (t, rho) -> (p)
     eos_state%T     = temp_zone
     eos_state%rho   = dens_zone
     eos_state%xn(:) = xn(:)

     call eos(eos_input_rt, eos_state)

     pres_zone = eos_state%p

     ! update the thermodynamics in this zone
     model_hse(i,idens) = dens_zone
     model_hse(i,itemp) = temp_zone
     model_hse(i,ipres) = pres_zone

  enddo

  write(num,'(i8)') nx

  deltastr = num_to_unitstring(delta)
  dxstr = num_to_unitstring(dCoord)

  outfile = trim(model_prefix) // ".hse." // "tanh.delta_" // trim(adjustl(deltastr)) // ".dx_" // trim(adjustl(dxstr))
  outfile2 = trim(outfile) // ".extras"

  open (newunit=lun1, file=outfile, status="unknown")
  open (newunit=lun2, file=outfile2, status="unknown")

  write (lun1,1001) "# npts = ", nx
  write (lun1,1001) "# num of variables = ", nvar
  write (lun1,1002) "# density"
  write (lun1,1002) "# temperature"
  write (lun1,1002) "# pressure"

  do n = 1, nspec
     write (lun1, 1003) "# ", spec_names(n)
  enddo

1000 format (1x, 100(g26.16, 1x))
1001 format (a, i5)
1002 format (a)
1003 format (a,a)

  do i = 1, nx

     write (lun1,1000) xzn_hse(i), model_hse(i,idens), model_hse(i,itemp), model_hse(i,ipres), &
          (model_hse(i,ispec-1+n), n=1,nspec)

  enddo

  ! some metadata
  write (lun1, 1002) "# generated by toy_atm"
  write (lun1, 1003) "# inputs file", params_file

  write (lun2,1001), "# npts = ", nx
  write (lun2,1001), "# num of variables = ", 2
  write (lun2,1002), "# entropy"
  write (lun2,1002), "# c_s"

  ! test: bulk EOS call -- Maestro will do this once we are mapped, so make
  ! sure that we are in HSE with updated thermodynamics
  do i = 1, nx
     eos_state%rho = model_hse(i,idens)
     eos_state%T = model_hse(i,itemp)
     eos_state%xn(:) = model_hse(i,ispec:ispec-1+nspec)

     call eos(eos_input_rt, eos_state)

     model_hse(i,ipres) = eos_state%p

     write (lun2,1000), xzn_hse(i), eos_state%s, eos_state%cs
  enddo

  ! compute the maximum HSE error
  max_hse_error = -1.d30

  do i = 2, nx-1

     ! compute the gravitation acceleration at the lower edge
     if (do_invsq_grav) then
        g_zone = -Gconst*M_enclosed/xznl_hse(i)**2
     else
        g_zone = g_const
     endif

     dpdr = (model_hse(i,ipres) - model_hse(i-1,ipres))/delx
     rhog = HALF*(model_hse(i,idens) + model_hse(i-1,idens))*g_zone

     if (dpdr /= ZERO .and. model_hse(i+1,idens) > low_density_cutoff) then
        max_hse_error = max(max_hse_error, abs(dpdr - rhog)/abs(dpdr))
     endif

  enddo

  print *, 'maximum HSE error = ', max_hse_error
  print *, ' '

  close (unit=lun1)
  close (unit=lun2)

end program init_1d_tanh

function num_to_unitstring(value)

  use bl_types
  implicit none

  real (kind=dp_t) :: value
  character (len=32) :: num_to_unitstring
  character (len=16) :: temp

  if (value > 1.d5) then

     ! work in km
     write(temp,'(f6.3)') value/1.d5
     num_to_unitstring = trim(temp) // "km"
  else

     ! work in cm
     if (value > 1.d3) then
        write(temp,'(f8.3)') value
        num_to_unitstring = trim(temp) // "cm"

     else
        write(temp,'(f6.3)') value
        num_to_unitstring = trim(temp) // "cm"
     endif

  endif

  return
end function num_to_unitstring


!--------------------------------------------------------------------------------------------------
! MODULE: NPIMod
!
!> @brief Subroutines for the norm-preserving interpolation (NPI) method of Meek and Levine.
!> @details
!! NPI is an overlap based method for interpolating wave functions and time-derivative couplings
!! (TDCs) during a nuclear time step in nonadiabatic dynamics calculations.
!! The method is based on the interpolation of the wave functions from those at the beginning of
!! the time step to those at the end using a time-dependent transformation matrix:
!! \f[
!! \ket{\psi_j(t)} = \vb{U}(t) \ket{\psi_j(t_0)}
!! \f]
!! where the elements of \f$ \vb{U}(t) \f$ are:
!! \f[
!! U_{jj}(t) = \cos(\frac{\cos^{-1}W_{jj}}{\Delta t} (t - t_0))
!! \f]
!! and
!! \f[
!! U_{jk}(t) = \sin(\frac{\sin^{-1}W_{jk}}{\Delta t} (t - t_0)).
!! \f]
!! The resulting TDCs are:
!! \f[
!! \braket{\psi_k(t)}{\pdv{\psi_j(t)}{t}} =
!! \mel{\psi_k(t_0)}{\vb{U}^\dagger(t)\pdv{t}\vb{U(t)}}{\psi_j(t_0)}
!! \f]
!!
!! These TDCs can be analytically integrated over a given time step \f$ t_0 \f$ to \f$ t_0 +
!! \Delta t \f$ (\ref npi_tdc_integrated subroutine). This is done in the original article and the
!! value is used as a constant during the time step.
!!
!! Original article: DOI: 10.1021/jz5009449
!
!> @note The main input_mod for the NPI method is the overlap matrix containing the overlaps between
!! the electronic state wave functions at \f$ t_0 \f$ and at \f$ t_0 + \Delta t \f$. It is assumed
!! that the phases of the two sets of wave functions are matched, meaning that the change from
!! \f$ \qty{\ket{\psi_i(t_0)}} \f$ to \f$ \qty{\ket{\psi_i(t_0 + \Delta t)}} \f$ is (approximately)
!! a rotation.
!--------------------------------------------------------------------------------------------------
module npi_mod
    use global_defs
    implicit none

    private
    public :: npi_tdc_integrated

contains

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: NPI_TDC_Integrated
    !
    ! DESCRIPTION:
    !> @brief Average value of the TDC over a time interval \p dt.
    !> @details
    !! Returns the analytic solution of the integral:
    !! \f[
    !! \eval{\braket{\psi_k(t)}{\pdv{\psi_j(t)}{t}}}_{t_0+\Delta t/2} =
    !! \frac{\int_{t_0}^{t_0+\Delta t}
    !!       {\mel{\psi_k(t_0)}{\vb{U}^\dagger(t)\pdv{t}\vb{U(t)}}{\psi_j(t_0)} dt}}{\Delta t}
    !! \f]
    !!
    !! Equations are taken from the Supporting Information of the
    !! article.
    !! Variable names are chosen to match those in the article. The compile time parameter \p thr
    !! can be used to change the value at which the equations are replaced by their limits as the
    !! denominators approach zero.
    !----------------------------------------------------------------------------------------------
    subroutine npi_tdc_integrated(dt, ww, tdc)
        real(dp), intent(in) :: dt !< Time step.
        real(dp), intent(in) :: ww(:, :) !< Wave function overlap matrix.
        real(dp), intent(out) :: tdc(:, :) !< Approximate time derivative coupling at t0+dt/2.
        real(dp), parameter :: thr = 0.00000001_dp !< Denominator threshod below which values are
                                                   !! replaced by their limits.
        real(dp) :: w(size(ww, 1), size(ww, 2)) !< Temporary w array.
        real(dp) :: acs(size(ww, 1), size(ww, 2)) !< ArcCos of w array elements.
        real(dp) :: ass(size(ww, 1), size(ww, 2)) !< ArcSin of w array elements.
        real(dp) :: a, b, c, d, e !< Temporary values.
        real(dp) :: denom, wlj, wlk, aslj, aslk !< Temporary values.
        integer :: k, j, n

        w = ww
        where (abs(w)>1.0_dp) w=int(w)
        acs = acos(w)
        ass = asin(w)
        n = size(w, 1)

        do k = 1, n
            do j = 1, n
                if (j == k) then
                    tdc(k, j) = 0.0_dp
                    cycle
                end if
                a = -1.0_dp !< Limit for a.
                b = 1.0_dp !< Limit for b.
                c = 1.0_dp !< Limit for c.
                d = 1.0_dp !< Limit for d.
                denom = acs(j, j) - ass(j, k)
                if (abs(denom) > thr) a = -sin(denom) / denom
                denom = acs(j, j) + ass(j, k)
                if (abs(denom) > thr) b = sin(denom) / denom
                denom = acs(k, k) - ass(k, j)
                if (abs(denom) > thr) c = sin(denom) / denom
                denom = acs(k, k) + ass(k, j)
                if (abs(denom) > thr) d = sin(denom) / denom

                e = 0.0_dp !< Limit for e when wlj = 0.
                if (n > 2) then
                    wlj = sqrt(1 - w(j, j)**2 - w(k, j)**2)
                    if (wlj > thr) then
                        wlk = - (w(j, k) * w(j, j) + w(k, k) * w(k, j)) / wlj
                        aslj = asin(wlj)
                        aslk = asin(wlk)
                        denom = aslj**2 - aslk**2
                        if (abs(denom) > thr) then
                            e = 2 * aslj * ( wlj * wlk * aslj +                                    &
                            &   (sqrt((1 - wlj**2) * (1 - wlk**2)) - 1) * aslk) / denom
                        else
                            e = wlj**2 !< Limit for e when denom = 0.
                        end if
                    end if
                end if
                ! Integrated expression for the NPI TDC.
                tdc(k, j) = (acs(j, j) * (a + b) + ass(k, j) * (c + d) + e) * 0.5_dp / dt
            end do
        end do
    end subroutine npi_tdc_integrated

end module npi_mod


module basis_change
  !  This module will contain all the procedures to do a change of basis.
  !
  !  globals is another modules that has the global variables and derived
  !  types defined.
  !
  !  There are three subroutines defined indes this module.  "compute_factors"
  !   computes some factors used in determining the transformation matrix,
  !  "compute_delta" actutally computes the general transformation matrix,
  !   and "change_basis" changes the basis of a wave function.
  !
  !  The global variable delta is the transformation matrix
  use precision
  use globals
  use operators

  implicit none
  complex(cdp), dimension(:,:), allocatable, private :: delta
contains
  subroutine compute_delta(b1,b2)

    !  This computes the transformation matrix delta between two basis
    !
    !  b1 is the basis to change from
    !  b2 is the basis to change to
    !  facd and faccd are two factors that are summed over to get delta
    !  i is the variable used to loop over basis b2
    !  j is the variable used to loop over basis b1
    !  l is a loop variable
    !  minij contains the minimum of i,j at various stages in the program
    !  d is the difference between the two basis
    !  cd is the conjugate of d
    !  fac a tempory variable
    !  dcd is d*cd

    type(basis), intent(in) :: b1, b2
    complex(cdp), dimension(:,:), allocatable :: facd, faccd
    integer(idp) :: i,j,l,minij
    complex(cdp) :: cd, d
    real(fdp) :: fac, dcd
    if (allocated(delta)) then
       deallocate(delta)
    end if
    allocate(facd(0:b2%n,0:b2%n), faccd(0:b1%n,0:b1%n), delta(0:b2%n,0:b1%n))
    delta=cmplx(0)
    facd=cmplx(0)
    faccd=cmplx(0)
    d=b1%alpha - b2%alpha
    cd=conjg(d)
    dcd=real(d*cd)
    !
    !  Sets up facd and faccd for iterative computation
    !

    do i=0,b2%n
       facd(i,i)=cmplx(1)
    end do
    do j=0,b1%n
       faccd(j,j)=cmplx(1)
    end do
    !
    !  Computes (iteratively) facd and faccd
    !
    do i=1,b2%n
       do l=i-1,0,-1
          facd(i,l)=sqrt(dble(l+1))/dble(i-l)*d*facd(i,l+1)
       end do
    end do
    do j=1,b1%n
       do l=j-1,0,-1
          faccd(j,l)=-sqrt(dble(l+1))/dble(j-l)*cd*faccd(j,l+1)

       end do
    end do

    !
    !  Computes delta from facd and faccd
    !

    do i = 0,b2%n
       do j = 0,b1%n
          minij=min(i,j)
          do l = 0,minij-1,2
             fac=1-(i-l)*(j-l)/(dcd*(l+1))
             delta(i,j)=delta(i,j) + facd(i,l)*faccd(j,l)*fac
          end do
          if ((minij/2)*2 == minij) then
             delta(i,j)=delta(i,j) + facd(i,minij)*faccd(j,minij)
          end if
       end do
    end do
    deallocate(facd, faccd)

  end subroutine compute_delta
  subroutine change_basis(y1,y2)
    !  This subroutine changes the wave function y1 to y2, depending on
    !  the basis these wave functions are defined in.
    type(wave_fn), intent(in) :: y1
    type(wave_fn), intent(inout) :: y2
    call compute_delta(y1%in_basis,y2%in_basis)

    y2%co_eff = matmul(delta,y1%co_eff)

    y2%co_eff = y2%co_eff / normalisation(y2)

  end subroutine change_basis
end module basis_change


module model_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

contains

  subroutine get_model_size(ymin, ymax, dy, lo, hi)

    use amrex_fort_module, only : rt => amrex_real
    real(rt)        , intent(in) :: ymin, ymax, dy
    integer, intent(out) :: lo, hi

    integer :: npts

    ! number of points in the domain
    npts = (ymax - ymin)/dy + 1

    ! we'll do some ghost cells, for the boundary conditions
    ! by design, the base of the model will be at zone 0
    lo = -4
    hi = npts + 4

  end subroutine get_model_size

  subroutine get_model(ymin, ymax, dy, &
                       pres_base, dens_base, do_isentropic, &
                       xn_model, &
                       r_model, rho_model, T_model, e_model, p_model, &
                       lo, hi)

    use eos_module, only : eos
    use eos_type_module, only : eos_t, eos_input_rp
    use network, only : nspec
    use meth_params_module, only: const_grav

    use amrex_fort_module, only : rt => amrex_real
    integer, intent(in) :: lo, hi
    real(rt)        , intent(in) :: ymin, ymax, dy
    real(rt)        , intent(in) :: pres_base, dens_base
    logical,          intent(in) :: do_isentropic
    real(rt)        , intent(in) :: xn_model(nspec)

    real(rt)        , intent(out) ::   r_model(lo:hi)
    real(rt)        , intent(out) :: rho_model(lo:hi)
    real(rt)        , intent(out) ::   T_model(lo:hi)
    real(rt)        , intent(out) ::   e_model(lo:hi)
    real(rt)        , intent(out) ::   p_model(lo:hi)

    real(rt)         :: H, gamma_const

    integer :: j

    type (eos_t) :: eos_state

    ! compute the pressure scale height (for an isothermal, ideal-gas
    ! atmosphere)
    H = pres_base / dens_base / abs(const_grav)

    ! create the constant if we are isentropic
    eos_state % rho = dens_base
    eos_state % p = pres_base
    eos_state % xn(:) = xn_model(:)

    ! initial guess
    eos_state % T = 1000.0e0_rt

    call eos(eos_input_rp, eos_state)

    gamma_const = pres_base/(dens_base * eos_state % e) + 1.0e0_rt

    rho_model(0) = dens_base
    p_model(0) = pres_base

    r_model(0) = ymin + 0.5e0_rt*dy

    ! integrate up from the base
    do j = 1, hi

       r_model(j) = ymin + (dble(j)+0.5e0_rt)*dy

       if (do_isentropic) then
          rho_model(j) = dens_base*(const_grav*dens_base*(gamma_const - 1.0)* &
               (r_model(j)-r_model(0))/ &
               (gamma_const*pres_base) + 1.e0_rt)**(1.e0_rt/(gamma_const - 1.e0_rt))
       else
          rho_model(j) = dens_base * exp(-(r_model(j)-r_model(0))/H)
       endif

       p_model(j) = p_model(j-1) - &
             dy * 0.5e0_rt * (rho_model(j)+rho_model(j-1)) * abs(const_grav)

    enddo

    ! integrate down from the base
    do j = -1, lo, -1

       r_model(j) = ymin + (dble(j)+0.5e0_rt)*dy

       if (do_isentropic) then
          rho_model(j) = dens_base*(const_grav*dens_base*(gamma_const - 1.0)* &
               (r_model(j)-r_model(0))/ &
             (gamma_const*pres_base) + 1.e0_rt)**(1.e0_rt/(gamma_const - 1.e0_rt))
       else
          rho_model(j) = dens_base * exp(-(r_model(j)-r_model(0))/H)
       endif

       p_model(j) = p_model(j+1) + &
             dy * 0.5e0_rt * (rho_model(j)+rho_model(j+1)) * abs(const_grav)

    enddo

    ! thermodynamics
    do j = lo, hi
       eos_state % rho = rho_model(j)
       eos_state % p = p_model(j)
       eos_state % xn(:) = xn_model(:)

       ! initial guess
       eos_state % T = 1000.0e0_rt

       call eos(eos_input_rp, eos_state)

       e_model(j) = eos_state % e
       T_model(j) = eos_state % T
    end do

  end subroutine get_model

end module model_module


C     NOTE: this all function is an old bunch of.. don't touch it
      function gasdev(iseed)
C         Returns a normally distributed deviate with zero mean and unit
C         variance
          implicit none

          external ran
          real ran

          save

          integer :: iseed,
     &               iset
          real :: v1,
     &            v2,
     &            r,
     &            fac,
     &            gset,
     &            gasdev

          data iset/0/
          if (iset == 0) then
  1           v1 = 2.0 * (ran(iseed)) - 1.0
              v2 = 2.0 * (ran(iseed)) - 1.0
              r = v1 * v1 + v2 * v2
              if (r >= 1.0 .or. r == 0.0) then
                  goto 1
              end if
              fac = sqrt(-2.0e0 * log(r) / r)
              gset = v1 * fac
              gasdev = v2 * fac
              iset = 1
          else
              gasdev = gset
              iset = 0
          end if
      end function


! =====================================================================
! subroutine USHOR
!
! This subroutine constructs an approximate ground state
! wavefunction for the simple harmonic oscillator ring.
! ---------------------------------------------------------------------
      subroutine USHOR(nRP,nR,nP,r0,kR,R,P,U)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: r0
      double precision :: kR
      double precision :: R(nR)
      double precision :: P(nP)
      double complex :: U(nRP)

      integer :: i
      integer :: j
      integer :: k
      double precision :: pi
      double complex :: a
      double complex :: b

      pi = 3.14159265358979323846d0
      a = dcmplx((kR/pi)**(0.25d0),0.0d0)

      k = 0
      do j = 1, nP
         do i = 1, nR
            k = k + 1
            b = dcmplx(-0.5d0*kR*(R(i)-r0)**2,0.0d0)
            U(k) = a*cdexp(b)
         enddo
      enddo

      return
      end
! =====================================================================


      SUBROUTINE FLEG(X,PL,NL)
      DIMENSION PL(NL)
      PL(1)=1.
      PL(2)=X
      IF(NL.GT.2) THEN
        TWOX=2.*X
        F2=X
        D=1.
        DO 11 J=3,NL
          F1=D
          F2=F2+TWOX
          D=D+1.
          PL(J)=(F2*PL(J-1)-F1*PL(J-2))/D
11      CONTINUE
      ENDIF
      RETURN
      END


!******************************************************************************
!*
!*                     ROUTINES FOR LEAST-SQUARE METHODS
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 06/2014.
  !
  ! 3) DESCRIPTION: contains various methods performing chi2 minimization
  !                 for general multi-dimensional non-linear functions.
  !==========================================================================

MODULE chi2_minimization

  USE utilities, ONLY:
  IMPLICIT NONE
  PRIVATE

  PUBLIC :: chi2min_LM

CONTAINS

  !==========================================================================
  ! CALL CHI2MIN_LM (funcresidual,Nobs,par,tol,resid,status,verbose, &
  !                  limited,limits,fixed,itied,chi2,chi2red,parerr,covar,Niter,
  !                  step,relstep,twoside)
  !
  !   Modified Levenberg-Marquardt chi2 minimization routine. Greatly based
  ! on MINPACK's function LMDIF1 and dependencies, painfully converted from F77,
  ! and subsequently, but still painfully, partly vectorized. The Jacobian is
  ! computed using finite difference approximation. Finally, I implemented
  ! several functionalities of C. Markwardt's IDL MPFIT (limiting, fixing
  ! parameters).
  !   Npar is the number of parameters par. Nobs is the number of observations.
  ! PAR[Npar] is the parameter array. RESID[Nobs] is the result of the function.
  ! TOL is the termination tolerance. FUNCRESIDUAL is the function to be called.
  !   FUNCRESIDUAL is a function returning the weighted residuals between the
  ! model and the observations. It should have the following interface:
  !    INTERFACE
  !      FUNCTION funcresidual (par,Nobs)
  !        USE utilities, ONLY: DP
  !        IMPLICIT NONE
  !        INTEGER, INTENT(IN) :: Nobs
  !        REAL(DP), DIMENSION(:), INTENT(IN) :: par
  !        REAL(DP), DIMENSION(Nobs) :: funcresidual
  !      END FUNCTION funcresidual
  !    END INTERFACE
  ! STATUS is an integer output variable. If the user has terminated execution,
  ! STATUS is set to the (negative) value of iflag. Otherwise, status is set as
  ! follows:
  !         status = 0: improper input parameters.
  !         status = 1: algorithm estimates that the relative error
  !                     in the sum of squares is at most tol.
  !         status = 2: algorithm estimates that the relative error
  !                     between par and the solution is at most tol.
  !         status = 3: conditions for status = 1 and status = 2 both hold.
  !         status = 4: resid is orthogonal to the columns of the
  !                     jacobian to machine precision.
  !         status = 5: number of calls to funcresidual has reached or
  !                     exceeded 200*(n+1).
  !         status = 6: tol is too small. No further reduction in
  !                     the sum of squares is possible.
  !         status = 7: tol is too small. No further improvement in
  !                     the approximate solution par is possible.
  !==========================================================================

  SUBROUTINE chi2min_LM (funcresidual,Nobs,par,tol,resid,status,verbose, &
                         limited,limits,fixed,itied,parname,chi2,chi2red, &
                         parerr,covar,Niter,step,relstep,twoside,Nitermax)

    USE utilities, ONLY: DP, trimlr, pring, strike, verbatim
    USE inout, ONLY: lenpar
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: Nobs
    REAL(DP), DIMENSION(:), INTENT(INOUT) :: par
    INTEGER, INTENT(OUT), OPTIONAL :: status
    INTEGER, INTENT(OUT), OPTIONAL :: Niter
    INTEGER, DIMENSION(SIZE(par)), INTENT(IN), OPTIONAL :: itied
    REAL(DP), INTENT(IN), OPTIONAL :: tol
    REAL(DP), INTENT(OUT), OPTIONAL :: chi2, chi2red
    REAL(DP), DIMENSION(Nobs), INTENT(OUT), OPTIONAL :: resid
    REAL(DP), DIMENSION(SIZE(par),2), INTENT(IN), OPTIONAL :: limits
    REAL(DP), DIMENSION(SIZE(par)), INTENT(OUT), OPTIONAL :: parerr
    REAL(DP), DIMENSION(SIZE(par),SIZE(par)), INTENT(OUT), OPTIONAL :: covar
    LOGICAL, INTENT(IN), OPTIONAL :: verbose
    LOGICAL, DIMENSION(SIZE(par),2), INTENT(IN), OPTIONAL :: limited
    LOGICAL, DIMENSION(SIZE(par)), INTENT(IN), OPTIONAL :: fixed
    CHARACTER(*), DIMENSION(SIZE(par)), INTENT(IN), OPTIONAL :: parname
    REAL(DP), DIMENSION(SIZE(par)), INTENT(IN), OPTIONAL :: step
    LOGICAL, DIMENSION(SIZE(par)), INTENT(IN), OPTIONAL :: relstep, twoside
    INTEGER, INTENT(IN), OPTIONAL :: Nitermax
    INTERFACE
      FUNCTION funcresidual (par,Nobs)
        USE utilities, ONLY: DP
        IMPLICIT NONE
        INTEGER, INTENT(IN) :: Nobs
        REAL(DP), DIMENSION(:), INTENT(IN) :: par
        REAL(DP), DIMENSION(Nobs) :: funcresidual
      END FUNCTION funcresidual
    END INTERFACE

    REAL(DP), PARAMETER :: factor = 1.E2_DP
    REAL(DP), PARAMETER :: tol0 = 1.E-10_DP
    REAL(DP), PARAMETER :: tolR = 1.E-14_DP
    LOGICAL, PARAMETER :: fastnorm = .False.

    INTEGER :: i, maxfev, mode, Nfev, Npar, Nparfree, info, iter
    INTEGER, DIMENSION(:), ALLOCATABLE :: ifree, ipvt
    INTEGER, DIMENSION(SIZE(par)) :: jtied
    REAL(DP) :: tol1, restol, gtol, partol
    REAL(DP), DIMENSION(Nobs) :: resid0
    REAL(DP), DIMENSION(SIZE(par),2) :: limpar
    REAL(DP), DIMENSION(:), ALLOCATABLE :: parfree, diag, diffstep
    REAL(DP), DIMENSION(:,:), ALLOCATABLE :: limitsfree, fjac, covarfree
    LOGICAL, DIMENSION(SIZE(par),2) :: limbool
    LOGICAL, DIMENSION(SIZE(par)) :: fix
    LOGICAL, DIMENSION(:), ALLOCATABLE :: reldiffstep, difftwoside
    LOGICAL, DIMENSION(:,:), ALLOCATABLE :: limitedfree
    LOGICAL :: printing
    CHARACTER(lenpar), DIMENSION(SIZE(par)) :: parnam

    !------------------------------------------------------------------------
    !                             Preparation
    !------------------------------------------------------------------------

    ! General parameters
    !-------------------
    Npar = SIZE(par(:))   ! Number of model parameters

    ! Fitter settings
    IF (.NOT. PRESENT(Nitermax)) THEN
      maxfev = 200 * (Npar + 1)     ! Maximum number of function evaluation
    ELSE
      maxfev = Nitermax * (Npar + 1)
    END IF
    tol1 = tol0
    IF (PRESENT(tol)) tol1 = tol  ! General tolerance
    restol = tol1     ! Tolerance on the residual
    partol = tol1     ! Tolerance on the parameter
    gtol = 0._DP      ! Tolerance on cos between residuals and jacobian
    mode = 1          ! 1 => internal scaling of parameters

    ! Options
    printing = verbatim            ! Compute function for printing
    IF (PRESENT(verbose)) printing = verbose

    ! Parameter name
    IF (PRESENT(parname)) THEN
      parnam(:) = parname(:)
    ELSE
      DO i=1,Npar
        parnam(i) = "Par "//TRIMLR(PRING(i))
      END DO
    END IF

    ! Parameter constraints
    !----------------------
    ! Tied parameters
    IF (PRESENT(itied)) THEN
      IF (SIZE(itied) /= Npar) CALL STRIKE("CHI2MIN_LM","Wrong size for ITIED")
      jtied(:) = itied(:)

      ! Make sure that the parameter has been computed before tying its value:
      ! the index of the tied parameter should be larger than the index of the
      ! parameter it is tied to.
      DO i=1,Npar
        IF (jtied(i) > 0) THEN
          IF (jtied(i) >= i) THEN
            jtied(jtied(i)) = i
            jtied(i) = 0
          ENDIF
        END IF
      END DO
    ELSE
      jtied(:) = 0
    END IF

    ! Fixed parameters
    fix(:) = .False.
    IF (PRESENT(fixed)) fix(:) = fixed(:)
    Nparfree = COUNT((.NOT. fix(:)) .AND. (jtied(:) <= 0))
    IF (Nobs < Nparfree) &
      CALL STRIKE ("CHI2MIN_LM","Not enough free parameters")
    ALLOCATE (parfree(Nparfree),ifree(Nparfree))
    parfree(:) = PACK(par(:),(.NOT. fix(:)) .AND. (jtied(:) <= 0))
    ifree(:) = PACK([(i,i=1,Npar)],(.NOT. fix(:)) .AND. (jtied(:) <= 0))

    ! Parameter limits
    limbool(:,:) = .False.
    IF (PRESENT(limited)) limbool(:,:) = limited(:,:)
    limpar(:,:) = 0._DP
    IF (PRESENT(limits)) limpar(:,:) = limits(:,:)

    ! Check consistency of limits and parameters
    IF (ANY(limbool(:,:))) THEN
      DO i=1,Npar
        IF (limbool(i,1) .AND. limbool(i,2)) THEN
          IF (limpar(i,1) > limpar(i,2)) &
            CALL STRIKE("CHI2MIN_LM","Limits of parameter "//TRIMLR(PRING(i)) &
                                   //" are inconsistent")
        END IF
        IF (limbool(i,1)) THEN
          IF (par(i) < limpar(i,1)) &
            CALL STRIKE ("CHI2MIN_LM","Parameter "//TRIMLR(PRING(i)) &
                                    //" is lower than its limit")
        END IF
        IF (limbool(i,2)) THEN
          IF (par(i) > limpar(i,2)) &
            CALL STRIKE ("CHI2MIN_LM","Parameter "//TRIMLR(PRING(i)) &
                                    //" is larger than its limit")
        END IF
      END DO
    END IF

    ! Effective limits on free parameters
    ALLOCATE (limitedfree(Nparfree,2),limitsfree(Nparfree,2))
    DO i=1,2
      limitedfree(:,i) = PACK(limbool(:,i),(.NOT. fix(:)) .AND. (jtied(:) <= 0))
      limitsfree(:,i) = PACK(limpar(:,i),(.NOT. fix(:)) .AND. (jtied(:) <= 0))
    END DO

    ! Optional scaling
    ALLOCATE(diag(Nparfree))
    diag(:) = 0._DP

    ! Optional stepsize for the Jacobian
    ALLOCATE (diffstep(Nparfree),reldiffstep(Nparfree))
    IF (PRESENT(step) .AND. PRESENT(relstep)) THEN
      diffstep(:) = PACK(step(:),(.NOT. fix(:)) .AND. (jtied(:) <= 0))
      reldiffstep(:) = PACK(relstep(:),(.NOT. fix(:)) .AND. (jtied(:) <= 0))
    ELSE
      diffstep(:) = 0._DP
      reldiffstep(:) = .True.
    END IF
    ALLOCATE (difftwoside(Nparfree))
    IF (PRESENT(twoside)) &
      difftwoside(:) = PACK(twoside(:),(.NOT. fix(:)) .AND. (jtied(:) <= 0))

    !------------------------------------------------------------------------
    !                        Actual System Solution
    !------------------------------------------------------------------------

    ! LMDIF
    ALLOCATE (fjac(Nobs,Nparfree),ipvt(Nparfree))
    CALL LMDIF(funcresidual,Nobs,Npar,Nparfree,par,parfree,ifree,jtied,resid0, &
               restol,partol,gtol,maxfev,diffstep,reldiffstep,difftwoside, &
               diag,mode,factor,printing,info,Nfev,fastnorm,limitedfree, &
               limitsfree,parnam,ipvt,fjac,Iter)

    ! Set (very carefully) the covariance matrix
    IF (PRESENT(covar)) covar(:,:) = 0._DP
    IF (PRESENT(parerr)) parerr(:) = 0._DP
    IF (info > 0 .AND. (PRESENT(covar) .OR. PRESENT(parerr))) THEN

      ! Covariance matrix for free parameters
      ALLOCATE (covarfree(Nparfree,Nparfree))
      covarfree(:,:) = COVARMAT(fjac(:,:),Nobs,Nparfree,ipvt(:),tolR)

      ! Fill in actual covariance matrix, accounting for fixed parameters
      IF (PRESENT(covar)) THEN
        FORALL (i=1:Nparfree) covar(ifree(:),ifree(i)) = covarfree(:,i)
        DO i=1,Npar
          IF (jtied(i) > 0) THEN
            covar(i,:) = covar(jtied(i),:)
            covar(:,i) = covar(:,jtied(i))
          END IF
        END DO
      END IF

      ! Comput errors in parameters
      IF (PRESENT(parerr)) THEN
        FORALL (i=1:Nparfree) parerr(ifree(i)) = SQRT(covarfree(i,i))
        DO i=1,Npar
          IF (jtied(i) > 0) parerr(i) = parerr(jtied(i))
        END DO
      END IF

      ! Free memory space
      DEALLOCATE (covarfree)

    END IF

    ! Output status
    IF (info == 8) info = 4
    IF (printing) THEN
      PRINT*, "Status = "//TRIMLR(PRING(info))
      SELECT CASE (info)
        CASE (0)
          PRINT*, "Termination of CHI2MIN_LM: improper input parameters!"
        CASE (1)
          PRINT*, "Termination of CHI2MIN_LM: " &
                //"the relative error in the residuals is at most TOL."
        CASE (2)
          PRINT*, "Termination of CHI2MIN_LM: " &
                //"the relative error between the parameters and the " &
                //"solution is at most TOL."
        CASE (3)
          PRINT*, "Termination of CHI2MIN_LM: " &
                //"the relative errors in both the parameters and the " &
                //"residuals are at most TOL."
        CASE (4)
          PRINT*, "Termination of CHI2MIN_LM: " &
                //"the residuals are orthogonal to the columns of the " &
                //"jacobian to machine precision."
        CASE (5)
          PRINT*, "Termination of CHI2MIN_LM: " &
                //"number of calls to the function has reached or " &
                //"exceeded the maximum number."
        CASE (6)
          PRINT*, "Termination of CHI2MIN_LM: " &
                //"TOL is too small. No further reduction in the sum of " &
                //"squares is possible."
        CASE (7)
          PRINT*, "Termination of CHI2MIN_LM: " &
                //"TOL is too small. No further improvement in the " &
                //"approximate solution par is possible."
        CASE DEFAULT
          PRINT*, "Termination of CHI2MIN_LM: improper termination!"
      END SELECT
    END IF

    ! Optional ouput
    IF (PRESENT(status)) status = info
    IF (PRESENT(resid)) resid = resid0
    IF (PRESENT(chi2)) chi2 = SUM(resid0(:)**2)
    IF (PRESENT(chi2red)) chi2red = SUM(resid0(:)**2) / (Nobs-Nparfree)
    IF (PRESENT(Niter)) Niter = Iter

    ! Free memory space
    DEALLOCATE (ifree,ipvt,parfree,diag,limitsfree,fjac,reldiffstep, &
                difftwoside,limitedfree)

    !------------------------------------------------------------------------

  END SUBROUTINE chi2min_LM

  !--------------------------------------------------------------------------
  !   General Levenberg-Marquardt subroutine called by CHI2MIN_LM.
  !--------------------------------------------------------------------------

  SUBROUTINE lmdif (funcresidual,Nobs,Npar,Nparfree,par,parfree,ifree,itied, &
                    resid,restol,partol,gtol,maxfev,step,relstep,twoside,diag, &
                    mode,factor,printing,info,Nfev,fastnorm,limited,limits, &
                    parname,ipvt,fjac,Iter)

    USE utilities, ONLY: DP, epsDP, trimlr, pring
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: Nobs, Npar, Nparfree, maxfev
    INTEGER, INTENT(INOUT) :: mode
    INTEGER, INTENT(OUT) :: info, Nfev, Iter
    INTEGER, DIMENSION(Nparfree), INTENT(IN) :: ifree
    INTEGER, DIMENSION(Npar), INTENT(IN) :: itied
    INTEGER, DIMENSION(Nparfree), INTENT(OUT) :: ipvt
    REAL(DP), INTENT(IN) :: restol, partol, gtol, factor
    REAL(DP), DIMENSION(Nparfree), INTENT(IN) :: step
    REAL(DP), DIMENSION(Npar), INTENT(INOUT) :: par
    REAL(DP), DIMENSION(Nparfree), INTENT(INOUT) :: parfree, diag
    REAL(DP), DIMENSION(Nobs), INTENT(INOUT) :: resid
    REAL(DP), DIMENSION(Nparfree,2), INTENT(IN) :: limits
    REAL(DP), DIMENSION(Nobs,Nparfree), INTENT(OUT) :: fjac
    LOGICAL, DIMENSION(Nparfree,2), INTENT(IN) :: limited
    LOGICAL, DIMENSION(Nparfree), INTENT(IN) :: relstep, twoside
    LOGICAL, INTENT(IN) :: printing, fastnorm
    CHARACTER(*), DIMENSION(Npar), INTENT(IN) :: parname
    INTERFACE
      FUNCTION funcresidual (par,Nobs)
        USE utilities, ONLY: DP
        IMPLICIT NONE
        INTEGER, INTENT(IN) :: Nobs
        REAL(DP), DIMENSION(:), INTENT(IN) :: par
        REAL(DP), DIMENSION(Nobs) :: funcresidual
      END FUNCTION funcresidual
    END INTERFACE

    INTEGER :: i, iflag, j, l
    REAL(DP) :: actred, delta, dirder, fnorm, fnorm1, gnorm, alpha
    REAL(DP) :: parLM, pnorm, prered, ratio, temp, temp1, temp2, parnorm
    REAL(DP), DIMENSION(Npar) :: wa2par
    REAL(DP), DIMENSION(Nparfree) :: ulim1, llim1, qtf, wa1, wa2, wa3
    REAL(DP), DIMENSION(Nobs) :: wa4
    LOGICAL :: getout
    LOGICAL, DIMENSION(Nparfree) :: dwa1, limsup, liminf

    !------------------------------------------------------------------------

    info = 0
    iflag = 0
    Nfev = 0
    delta = 0._DP
    getout = .False.

    ! Check the input parameters for errors
    IF (Nparfree > 0 .AND. Nobs >= Nparfree &
        .AND. restol >= 0._DP .AND. partol >= 0._DP .AND. gtol >= 0._DP &
        .AND. maxfev > 0 .AND. factor > 0._DP) THEN

      IF (mode == 2) THEN
        IF (ANY(diag(:) <= 0._DP)) getout = .True.
      END IF

      ! Evaluate the function at the starting point and calculate its norm
      iflag = 1
      WHERE (itied(:) > 0) par(:) = par(itied(:))
      resid(:) = FUNCRESIDUAL(par(:),Nobs)
      Nfev = 1
      IF (iflag < 0) getout = .True.
      fnorm = ENORM(resid(:),fastnorm)

      ! Initialize levenberg-marquardt parameter and iteration counter
      parLM = 0._DP
      iter = 1
      parnorm = 1._DP

      ! Beginning of the outer loop
      outerloop: DO
        IF (getout) EXIT

        ! Calculate the jacobian matrix
        iflag = 2
        CALL FDJAC2(funcresidual,Nobs,Npar,Nparfree,par,parfree,ifree,itied, &
                    resid,fjac,iflag,step,relstep,twoside,wa4,limited(1,:), &
                    limited(:,2),limits(1,:),limits(:,2))

        Nfev = Nfev + Nparfree
        IF (iflag < 0) EXIT

        ! Limits
        liminf(:) = ( limited(:,1) .AND. parfree(:) == limits(:,1) )
        limsup(:) = ( limited(:,2) .AND. parfree(:) == limits(:,2) )

        ! Total derivative of sum wrt lower/upper pegged parameters
        ! Note: SUM(resid*fjac(:,i)) is d(CHI^2)/dpar(i)
        IF (ANY(limited(:,1))) THEN
          DO i=1,Nparfree
            IF (liminf(i)) THEN
              IF (SUM(resid(:) * fjac(:,i)) > 0._DP) fjac(:,i) = 0._DP
            END IF
          END DO
        END IF
        IF (ANY(limited(:,2))) THEN
          DO i=1,Nparfree
            IF (limsup(i)) THEN
              IF (SUM(resid(:) * fjac(:,i)) < 0._DP) fjac(:,i) = 0._DP
            END IF
          END DO
        END IF

        ! Print iterates
        IF (printing) CALL PRINTPAR(iter,Nobs,Npar,Nparfree,par,resid, &
                                    limited,limits,parname,ifree,itied)

        ! Compute the QR factorization of the jacobian
        CALL QRFAC(Nobs,Nparfree,fjac,.True.,ipvt,Nparfree,wa1,wa2,wa3,fastnorm)

        ! On the first iteration and if mode is 1, scale according
        ! to the norms of the columns of the initial jacobian
        IF (iter == 1) THEN
          IF (mode /= 2) diag(:) = MERGE(wa2(:),1._DP,wa2(:) /= 0._DP)

          ! On the first iteration, calculate the norm of the scaled par
          ! and initialize the step bound delta
          wa3(:) = diag(:) * parfree(:)
          parnorm = ENORM(wa3(:),fastnorm)
          delta = factor * parnorm
          IF (delta == 0._DP) delta = factor
        END IF

        ! Form (Q transpose)*resid and store the first n components in qtf
        wa4(:) = resid(:)
        DO j=1,Nparfree
          IF (fjac(j,j) /= 0._DP) THEN
            temp = - SUM(fjac(j:Nobs,j)*wa4(j:Nobs)) / fjac(j,j)
            wa4(j:Nobs) = wa4(j:Nobs) + fjac(j:Nobs,j)*temp
          END IF
          fjac(j,j) = wa1(j)
          qtf(j) = wa4(j)
        END DO

        ! Compute the norm of the scaled gradient
        gnorm = 0._DP
        IF (fnorm /= 0._DP) THEN
          DO j=1,Nparfree
            l = ipvt(j)
            IF (wa2(l) /= 0._DP) &
              gnorm = MAX(gnorm,ABS(SUM(fjac(1:j,j)*qtf(1:j)/fnorm)/wa2(l)))
          END DO
        END IF

        ! Test for convergence of the gradient norm
        IF (gnorm <= gtol) info = 4
        IF (info /= 0) EXIT

        ! Rescale if necessary
        IF (mode /= 2) THEN
          DO j=1,Nparfree
            diag(j) = MAX(diag(j),wa2(j))
          END DO
        END IF

        ! Beginning of the inner loop
        innerloop: DO

          ! Determine the Levenberg-Marquardt parameter
          CALL LMPAR(Nparfree,fjac,Nobs,ipvt,diag,qtf,delta,parLM, &
                     wa1,wa2,wa3,wa4,fastnorm)

          ! Store the direction p and par + p. Calculate the norm of p
          wa1(:) = - wa1(:)
          IF (ANY(limited(:,:))) THEN

            ! Respect the limits. If a step were to go out of bounds, then
            ! we should take a step in the same direction but shorter distance.
            ! The step should take us right to the limit in that case.
            alpha = 1._DP

            ! Do not allow any steps out of bounds
            WHERE (liminf(:)) wa1(:) = MERGE(wa1(:),0._DP,wa1(:) > 0._DP)
            WHERE (limsup(:)) wa1(:) = MERGE(wa1(:),0._DP,wa1(:) < 0._DP)
            dwa1(:) = ( ABS(wa1(:)) > epsDP )
            alpha = MIN( alpha, &
                         MINVAL( (limits(:,1)-parfree(:))/wa1(:), &
                                 MASK=(dwa1(:) .AND. limited(:,1) &
                                      .AND. parfree(:)+wa1(:) < limits(:,1)) ) )
            alpha = MIN( alpha, &
                         MINVAL( (limits(:,2)-parfree(:))/wa1(:), &
                                 MASK=(dwa1(:) .AND. limited(:,2) &
                                      .AND. parfree(:)+wa1(:) > limits(:,2)) ) )

            ! Scale the resulting vector
            wa1(:) = wa1(:) * alpha
            wa2(:) = parfree(:) + wa1(:)

            ! Adjust the final output values. If the step put us exactly
            ! on a boundary, make sure we peg it there.
            ! Handles case of: nonzero*LIM +/- zero*LIM
            ulim1(:) = limits(:,2) * ( 1._DP - SIGN(1._DP,limits(:,2))*epsDP ) &
                     - MERGE(1._DP,0._DP,limits(:,2) == 0._DP) * epsDP
            llim1(:) = limits(:,1) * ( 1._DP + SIGN(1._DP,limits(:,1))*epsDP ) &
                     + MERGE(1._DP,0._DP,limits(:,1) == 0._DP) * epsDP
            wa2(:) = MERGE( limits(:,2), wa2(:), &
                            limited(:,2) .AND. wa2(:) >= ulim1(:) )
            wa2(:) = MERGE( limits(:,1), wa2(:), &
                            limited(:,1) .AND. wa2(:) <= llim1(:) )

          ELSE

            ! No parameter limits, so just move to new position WA2
            alpha = 1._DP
            wa2(:) = parfree(:) + wa1(:)

          END IF
          wa3(:) = diag(:) * wa1(:)
          pnorm = ENORM(wa3(:),fastnorm)

          ! On the first iteration, adjust the initial step bound
          IF (iter == 1) delta = MIN(delta,pnorm)

          ! Evaluate the function at par + p and calculate its norm
          iflag = 1
          wa2par(:) = par(:)
          wa2par(ifree(:)) = wa2(:)
          WHERE (itied(:) > 0) wa2par(:) = wa2par(itied(:))
          wa4(:) = FUNCRESIDUAL(wa2par(:),Nobs)
          Nfev = Nfev + 1
          IF (iflag < 0) THEN
            getout = .True.
            EXIT
          END IF
          fnorm1 = ENORM(wa4(:),fastnorm)

          ! Compute the scaled actual reduction
          actred = - 1._DP
          IF (0.1_DP*fnorm1 < fnorm) actred = 1._DP - (fnorm1/fnorm)**2

          ! Compute the scaled predicted reduction and the scaled directional
          ! derivative
          DO j=1,Nparfree
            wa3(j) = 0._DP
            wa3(1:j) = wa3(1:j) + fjac(1:j,j)*wa1(ipvt(j))
          END DO

          ! Remember, alpha is the fraction of the full LM step actually taken
          temp1 = ENORM(alpha*wa3(:),fastnorm) / fnorm
          temp2 = SQRT(alpha*parLM) * pnorm / fnorm
          prered = temp1**2 + temp2**2/0.5_DP
          dirder = - (temp1**2 + temp2**2)

          ! Compute the ratio of the actual to the predicted reduction
          ratio = 0._DP
          IF (prered /= 0._DP) ratio = actred / prered

          ! Update the step bound
          IF (ratio <= 0.25_DP) THEN
            IF (actred >= 0._DP) temp = 0.5_DP
            IF (actred < 0._DP) &
              temp = 0.5_DP * dirder / (dirder + 0.5_DP*actred)
            IF (0.1_DP*fnorm1 >= fnorm .OR. temp < 0.1_DP) temp = 0.1_DP
            delta = temp * MIN(delta,pnorm/0.1_DP)
            parLM = parLM / temp
          ELSE
            IF (parLM == 0._DP .OR. ratio >= 0.75_DP) THEN
              delta = pnorm / 0.5_DP
              parLM = 0.5_DP * parLM
            END IF
          END IF

          ! Test for successful iteration
          IF (ratio >= 1.E-4_DP) THEN

            ! Successful iteration. Update par, resid, and their norms
            parfree(:) = wa2(:)
            par(ifree(:)) = parfree(:)
            WHERE (itied(:) > 0) par(:) = par(itied(:))
            wa2(:) = diag(:) * parfree(:)
            resid(:) = wa4(:)
            parnorm = ENORM(wa2(:),fastnorm)
            fnorm = fnorm1
            iter = iter + 1

          END IF

          ! Tests for convergence
          IF (ABS(actred) <= restol .AND. prered <= restol &
              .AND. 0.5_DP*ratio <= 1._DP) info = 1
          IF (delta <= partol*parnorm) info = 2
          IF (ABS(actred) <= restol .AND. prered <= restol &
              .AND. 0.5_DP*ratio <= 1._DP .AND. info == 2) info = 3
          IF (info /= 0) THEN
            getout = .True.
            EXIT
          END IF

          ! Tests for termination and stringent tolerances
          IF (Nfev >= maxfev) info = 5
          IF (ABS(actred) <= epsDP .AND. prered <= epsDP &
              .AND. 0.5_DP*ratio <= 1._DP) info = 6
          IF (delta <= epsDP*parnorm) info = 7
          IF (gnorm <= epsDP) info = 8
          IF (info /= 0) THEN
            getout = .True.
            EXIT
          END IF

          ! End of the inner loop. Repeat if iteration unsuccessful
          IF (ratio >= 1.E-4_DP) EXIT

       END DO innerloop

      END DO outerloop

    END IF

    ! Termination, either normal or user imposed
    IF (iflag < 0) info = iflag
    WHERE (itied(:) > 0) par(:) = par(itied(:))
    resid(:) = FUNCRESIDUAL(par(:),Nobs)
    IF (printing) CALL PRINTPAR(iter,Nobs,Npar,Nparfree,par,resid, &
                                limited,limits,parname,ifree,itied)
    RETURN

    !------------------------------------------------------------------------

  END SUBROUTINE lmdif

  !--------------------------------------------------------------------------

  SUBROUTINE printpar (iter,Nobs,Npar,Nparfree,par,resid,limited,limits, &
                       parname,ifree,itied)

    USE utilities, ONLY: DP, trimlr, pring
    USE inout, ONLY: lenpar
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: iter, Nobs, Npar, Nparfree
    INTEGER, DIMENSION(Nparfree), INTENT(IN) :: ifree
    INTEGER, DIMENSION(Npar), INTENT(IN) :: itied
    REAL(DP), DIMENSION(Npar), INTENT(IN) :: par
    REAL(DP), DIMENSION(Nobs), INTENT(IN) :: resid
    REAL(DP), DIMENSION(Nparfree,2), INTENT(IN) :: limits
    LOGICAL, DIMENSION(Nparfree,2), INTENT(IN) :: limited
    CHARACTER(*), DIMENSION(Npar), INTENT(IN) :: parname

    INTEGER, PARAMETER :: Ndec = 6

    INTEGER :: i, j
    CHARACTER(lenpar) :: parstr
    CHARACTER(lenpar*2) :: infostr

    !------------------------------------------------------------------------

    PRINT*, "  Iter "//TRIMLR(PRING(Iter))//" of CHI2MIN_LM" &
          //"       N(d.o.f.) = "//TRIMLR(PRING(Nobs-Nparfree)) &
          //"       chi2/N(d.o.f.) = " &
          //TRIMLR(PRING(SUM(resid(:)**2)/(Nobs-Nparfree),NDEC=Ndec))
    j = 1
    DO i=1,Npar
      IF (ALL(ifree(:) /= i)) THEN
        IF (itied(i) <= 0) THEN
          infostr = "fixed"
        ELSE
          infostr = "tied to "//TRIMLR(parname(itied(i)))
        END IF
      ELSE
        IF (.NOT. limited(j,1) .AND. .NOT. limited(j,2)) THEN
          infostr = "free"
        ELSE IF (limited(j,1) .AND. .NOT. limited(j,2)) THEN
          infostr = "> "//TRIMLR(PRING(limits(j,1),NDEC=Ndec))
        ELSE IF (.NOT. limited(j,1) .AND. limited(j,2)) THEN
          infostr = "< "//TRIMLR(PRING(limits(j,2),NDEC=Ndec))
        ELSE IF (limited(j,1) .AND. limited(j,2)) THEN
          infostr = "> "//TRIMLR(PRING(limits(j,1),NDEC=Ndec))//" & < " &
                  //TRIMLR(PRING(limits(j,2),NDEC=Ndec))
        END IF
        j = j + 1
      END IF
      parstr = TRIMLR(PRING(par(i),NDEC=Ndec))
      PRINT*, ADJUSTR(parname(i))//"  =  "//ADJUSTL(parstr)//ADJUSTL(infostr)
    END DO

    !------------------------------------------------------------------------

  END SUBROUTINE printpar

  !--------------------------------------------------------------------------
  !   Function calculating the Euclidian norm of a vector. It is computed by
  ! accumulating the sum of squares in three different sums. The sums of
  ! squares for the small and large components are scaled so that no overflows
  ! occur. Non-destructive underflows are permitted. Underflows and overflows
  ! do not occur in the computation of the unscaled sum of squares for the
  ! intermediate components. The definitions of small, intermediate and large
  ! components depend on two constants, rdwarf and rgiant. The main
  ! restrictions on these constants are that rdwarf**2 not underflow and
  ! rgiant**2 not overflow. The constants given here are suitable for every
  ! known computer.
  !--------------------------------------------------------------------------

  FUNCTION enorm (parfree,fastnorm)

    USE utilities, ONLY: DP, tinyDP, hugeDP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: parfree
    LOGICAL, INTENT(IN) :: fastnorm
    REAL(DP) :: enorm

    INTEGER :: i, Nparfree
    REAL(DP) :: agiant, adwarf, s1, s2, s3, parabs, par1max, par3max
    REAL(DP) :: rdwarf, rgiant

    !------------------------------------------------------------------------

    fastorslow: IF (fastnorm) THEN

      ! Fast but risky normalization
      !-----------------------------
      enorm = SQRT(SUM(parfree(:)**2))

    ELSE

      ! Numerically robust, but slower normalization
      !---------------------------------------------
      Nparfree = SIZE(parfree(:))
      rdwarf = SQRT(tinyDP) * 10._DP
      rgiant = SQRT(hugeDP) * 0.1_DP
      s1 = 0._DP
      s2 = 0._DP
      s3 = 0._DP
      par1max = 0._DP
      par3max = 0._DP
      agiant = rgiant / Nparfree
      adwarf = rdwarf * Nparfree
      DO i=1,Nparfree
        parabs = ABS(parfree(i))
        IF (parabs <= adwarf .OR. parabs >= agiant) THEN
          IF (parabs > adwarf) THEN

            ! Sum for large components
            IF (parabs > par1max) THEN
              s1 = 1._DP + s1*(par1max/parabs)**2
              par1max = parabs
            ELSE
              s1 = s1 + (parabs/par1max)**2
            END IF

          ELSE

            ! Sum for small components
            IF (parabs > par3max) THEN
              s3 = 1._DP + s3*(par3max/parabs)**2
              par3max = parabs
            ELSE
              IF (parabs /= 0._DP) s3 = s3 + (parabs/par3max)**2
            END IF

          END IF

        ELSE

          ! Sum for intermediate components
          s2 = s2 + parabs**2

        END IF
      END DO

      ! Calculation of norm
      IF (s1 /= 0._DP) THEN
        enorm = par1max * SQRT( s1 + (s2/par1max) / par1max )
      ELSE
        IF (s2 /= 0._DP) THEN
          IF (s2 >= par3max) &
            enorm = SQRT( s2 * (1._DP+(par3max/s2)*(par3max*s3)) )
          IF (s2 < par3max) &
            enorm = SQRT( par3max * ((s2/par3max)+(par3max*s3)) )
        ELSE
          enorm = par3max * SQRT(s3)
        END IF
      END IF

    END IF fastorslow

    RETURN

    !------------------------------------------------------------------------

  END FUNCTION enorm

  !--------------------------------------------------------------------------
  !   Computes a forward-difference approximation to the m by n jacobian
  ! matrix associated with a specified problem of m functions in n variables.
  !--------------------------------------------------------------------------

  SUBROUTINE fdjac2 (funcresidual,Nobs,Npar,Nparfree,par,parfree,ifree,itied, &
                     resid,fjac,iflag,step,relstep,twoside,wa,downlimited, &
                     uplimited,downlimit,uplimit)

    USE utilities, ONLY: DP, epsDP
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: Nobs, Nparfree, Npar
    INTEGER, INTENT(INOUT) :: iflag
    INTEGER, DIMENSION(Nparfree), INTENT(IN) :: ifree
    INTEGER, DIMENSION(Npar), INTENT(IN) :: itied
    REAL(DP), DIMENSION(Nparfree), INTENT(IN) :: step
    REAL(DP), DIMENSION(Npar), INTENT(INOUT) :: par
    REAL(DP), DIMENSION(Nparfree), INTENT(INOUT) :: parfree
    REAL(DP), DIMENSION(Nobs), INTENT(IN) :: resid
    REAL(DP), DIMENSION(Nobs,Nparfree), INTENT(OUT) :: fjac
    REAL(DP), DIMENSION(Nobs), INTENT(INOUT) :: wa
    REAL(DP), DIMENSION(Nparfree), INTENT(IN) :: downlimit, uplimit
    LOGICAL, DIMENSION(Nparfree), INTENT(IN) :: downlimited, uplimited
    LOGICAL, DIMENSION(Nparfree), INTENT(IN) :: relstep, twoside
    INTERFACE
      FUNCTION funcresidual (par,Nobs)
        USE utilities, ONLY: DP
        IMPLICIT NONE
        INTEGER, INTENT(IN) :: Nobs
        REAL(DP), DIMENSION(:), INTENT(IN) :: par
        REAL(DP), DIMENSION(Nobs) :: funcresidual
      END FUNCTION funcresidual
    END INTERFACE

    INTEGER :: j
    REAL(DP) :: eps, h, temp
    REAL(DP), DIMENSION(Nobs) :: wainf
    LOGICAL :: twosided

    !------------------------------------------------------------------------

    DO j=1,Nparfree
      twosided = twoside(j)

      ! Step size
      temp = parfree(j)
      eps = MAX(step(j),SQRT(epsDP))
      IF (relstep(j)) THEN
        h = eps * ABS(temp)
        IF (h == 0._DP) h = eps
      ELSE
        h = eps
      END IF

      ! Adjust the limits
      IF (uplimited(j)) THEN
        IF (parfree(j) + h > uplimit(j)) THEN
          h = - h
          twosided = .False.
        END IF
      END IF
      IF (twosided) THEN
        IF (downlimited(j)) THEN
          IF (parfree(j) - h < downlimit(j)) twosided = .False.
        END IF
      END IF

      ! Compute the finite difference
      parfree(j) = temp + h
      par(ifree(j)) = parfree(j)
      WHERE (itied(:) > 0) par(:) = par(itied(:))
      wa(:) = FUNCRESIDUAL(par(:),Nobs)
      IF (iflag >= 0) THEN
        IF (twosided) THEN
          parfree(j) = temp - h
          par(ifree(j)) = parfree(j)
          WHERE (itied(:) > 0) par(:) = par(itied(:))
          wainf(:) = FUNCRESIDUAL(par(:),Nobs)
          fjac(:,j) = (wa(:) - wainf(:)) / (2._DP*h)
        ELSE
          fjac(:,j) = (wa(:) - resid(:)) / h
        END IF
        parfree(j) = temp
        par(ifree(j)) = parfree(j)
        WHERE (itied(:) > 0) par(:) = par(itied(:))
      ELSE
        EXIT
      END IF
    END DO

    RETURN

    !------------------------------------------------------------------------

  END SUBROUTINE fdjac2

  !--------------------------------------------------------------------------
  !   This subroutine uses householder transformations with column pivoting
  ! (optional) to compute a QR factorization of the m by n matrix A. That is,
  ! qrfac determines an orthogonal matrix Q, a permutation matrix P, and an
  ! upper trapezoidal matrix R with diagonal elements of nonincreasing
  ! magnitude, such that A*P = Q*R. The householder transformation for
  ! column k, k = 1,2,...,min(m,n), is of the form:
  !                         t
  !         i - (1/u(k))*u*u
  ! where u has zeros in the first k-1 positions. The form of this
  ! transformation and the method of pivoting first appeared in the
  ! corresponding linpack subroutine.
  !--------------------------------------------------------------------------

  SUBROUTINE qrfac (Nobs,Nparfree,A,pivot,ipvt,lipvt,rdiag,acnorm,wa,fastnorm)

    USE utilities, ONLY: DP, epsDP
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: Nobs, Nparfree, lipvt
    INTEGER, DIMENSION(lipvt), INTENT(OUT) :: ipvt
    LOGICAL, INTENT(IN) :: pivot, fastnorm
    REAL(DP), DIMENSION(Nobs,Nparfree), INTENT(INOUT) :: A
    REAL(DP), DIMENSION(Nparfree), INTENT(OUT) :: rdiag, acnorm
    REAL(DP), DIMENSION(Nparfree), INTENT(INOUT) :: wa

    INTEGER :: i, j, jp1, k, kmax, minmn
    REAL(DP) :: ajnorm, temp

    !------------------------------------------------------------------------

    ! Compute the initial column norms and initialize several arrays
    DO j=1,Nparfree
      acnorm(j) = ENORM(A(:,j),fastnorm)
    END DO
    rdiag(:) = acnorm(:)
    wa(:) = rdiag(:)
    IF (pivot) ipvt(:) = [(j,j=1,Nparfree)]

    ! Reduce A to R with householder transformations
    minmn = MIN(Nobs,Nparfree)
    DO j=1,minmn

      IF (pivot) THEN
        ! Bring the column of largest norm into the pivot position
        kmax = MAXLOC(rdiag(j:Nparfree),DIM=1) + j - 1
        IF (kmax /= j) THEN
          DO i=1,Nobs
            temp = A(i,j)
            A(i,j) = A(i,kmax)
            A(i,kmax) = temp
          END DO
          rdiag(kmax) = rdiag(j)
          wa(kmax) = wa(j)
          k = ipvt(j)
          ipvt(j) = ipvt(kmax)
          ipvt(kmax) = k
        END IF
      END IF

      ! Compute the householder transformation to reduce the j-th column of a
      ! to a multiple of the j-th unit vector
      ajnorm = ENORM(A(j:Nobs,j),fastnorm)
      IF (ajnorm /= 0._DP) THEN
        IF (A(j,j) < 0._DP) ajnorm = - ajnorm
        A(j:Nobs,j) = A(j:Nobs,j) / ajnorm
        A(j,j) = A(j,j) + 1._DP

        ! Apply the transformation to the remaining columns and update the norms
        jp1 = j + 1
        IF (Nparfree >= jp1) THEN
          DO k=jp1,Nparfree
            temp = SUM(A(j:Nobs,j)*A(j:Nobs,k)) / A(j,j)
            A(j:Nobs,k) = A(j:Nobs,k) - temp * A(j:Nobs,j)
            IF (pivot .AND. rdiag(k) /= 0._DP) THEN
              temp = A(j,k) / rdiag(k)
              rdiag(k) = rdiag(k) * SQRT(MAX(0._DP,1._DP-temp**2))
              IF (5.E-2_DP*(rdiag(k)/wa(k))**2 <= epsDP) THEN
                rdiag(k) = ENORM(A(jp1:Nobs,k),fastnorm)
                wa(k) = rdiag(k)
              END IF
            END IF
          END DO
        END IF
      END IF
      rdiag(j) = - ajnorm

    END DO

    RETURN

    !------------------------------------------------------------------------

  END SUBROUTINE qrfac

  !--------------------------------------------------------------------------
  !   Given an m by n matrix A, an n by n nonsingular diagonal matrix d, an
  ! m-vector b, and A positive number delta, the problem is to determine a
  ! value for the parameter parLM such that if par solves the system:
  !         A*par = b ,     sqrt(parLM)*d*par = 0 ,
  ! in the least squares sense, and dparnorm is the euclidean norm of d*par,
  ! then either parLM is zero and:
  !         (dparnorm-delta) <= 0.1*delta ,
  ! or parLM is positive and:
  !         abs(dparnorm-delta) <= 0.1*delta .
  ! This subroutine completes the solution of the problem if it is provided
  ! with the necessary information from the QR factorization, with column
  ! pivoting, of A. That is, if A*P = Q*R, where P is a permutation matrix, Q
  ! has orthogonal columns, and R is an upper triangular matrix with diagonal
  ! elements of nonincreasing magnitude, then lmpar expects the full upper
  ! triangle of R, the permutation matrix P, and the first n components of
  ! (Q transpose)*b. On output lmpar also provides an upper triangular matrix
  ! S such that:
  !          t   t                   t
  !         P *(A *A + parLM*d*d)*P = S *S .
  ! S is employed within lmpar and may be of separate interest.
  ! Only a few iterations are generally needed for convergence of the
  ! algorithm. If, however, the limit of 10 iterations is reached, then the
  ! output parLM will contain the best value obtained so far.
  !--------------------------------------------------------------------------

  SUBROUTINE lmpar (Nparfree,R,Nobs,ipvt,diag,qtb,delta,parLM, &
                    parfree,sdiag,wa1,wa2,fastnorm)

    USE utilities, ONLY: DP, tinyDP
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: Nparfree, Nobs
    INTEGER, DIMENSION(Nparfree), INTENT(IN) :: ipvt
    REAL(DP), INTENT(IN) :: delta
    REAL(DP), INTENT(INOUT) :: parLM
    REAL(DP), DIMENSION(Nobs,Nparfree), INTENT(INOUT) :: R
    REAL(DP), DIMENSION(Nparfree), INTENT(IN) :: diag, qtb
    REAL(DP), DIMENSION(Nparfree), INTENT(INOUT) :: parfree, sdiag
    REAL(DP), DIMENSION(Nparfree), INTENT(INOUT) :: wa1, wa2
    LOGICAL, INTENT(IN) :: fastnorm

    INTEGER :: iter, j, jm1, jp1, k, Nsing
    REAL(DP) :: dparnorm, fp, gnorm, parc, parl, paru, temp

    !------------------------------------------------------------------------

    ! Compute and store in par the gauss-newton direction. If the
    ! jacobian is rank-deficient, obtain a least squares solution.
    wa1(:) = qtb(:)
    Nsing = MINVAL(PACK([(j-1,j=1,Nparfree)],[(R(j,j),j=1,Nparfree)] == 0._DP, &
                        SPREAD(Nparfree,1,Nparfree)))
    IF (Nsing < Nparfree) wa1(Nsing+1:Nparfree) = 0._DP
    IF (Nsing >= 1) THEN
      DO k=1,Nsing
        j = Nsing - k + 1
        wa1(j) = wa1(j) / R(j,j)
        temp = wa1(j)
        jm1 = j - 1
        IF (jm1 >= 1) wa1(1:jm1) = wa1(1:jm1) - R(1:jm1,j) * temp
      END DO
    END IF
    parfree(ipvt(:)) = wa1(:)

    ! Initialize the iteration counter. Evaluate the function at the origin,
    ! and test for acceptance of the gauss-newton direction.
    iter = 0
    wa2(:) = diag(:) * parfree(:)
    dparnorm = ENORM(wa2(:),fastnorm)
    fp = dparnorm - delta
    IF (fp > 0.1_DP*delta) THEN

      ! If the jacobian is not rank deficient, the Newton step provides a
      ! lower bound, parl, for the zero of the function. Otherwise set this
      ! bound to zero.
      parl = 0._DP
      IF (Nsing >= Nparfree) THEN
        wa1(:) = diag(ipvt(:)) * wa2(ipvt(:)) / dparnorm
        wa1(1) = wa1(1) / R(1,1)
        DO j=2,Nparfree
          jm1 = j - 1
          wa1(j) = (wa1(j) - SUM(R(1:jm1,j)*wa1(1:jm1)) ) / R(j,j)
        END DO
        temp = ENORM(wa1(:),fastnorm)
        parl = ( (fp/delta) / temp ) / temp
      END IF

      ! Calculate an upper bound, paru, for the zero of the function.
      FORALL (j=1:Nparfree) wa1(j) = SUM(R(1:j,j)*qtb(1:j)) / diag(ipvt(j))
      gnorm = ENORM(wa1(:),fastnorm)
      paru = gnorm / delta
      IF (paru == 0._DP) paru = tinyDP / MIN(delta,0.1_DP)

      ! If the input parLM lies outside of the interval (parl,paru),
      ! set parLM to the closer endpoint.
      parLM = MAX(parLM,parl)
      parLM = MIN(parLM,paru)
      IF (parLM == 0._DP) parLM = gnorm / dparnorm

      ! Beginning of an iteration
      iteration: DO
         iter = iter + 1

         ! Evaluate the function at the current value of parLM
         IF (parLM == 0._DP) parLM = MAX(tinyDP,1.E-3_DP*paru)
         wa1(:) = SQRT(parLM) * diag(:)
         CALL QRSOLV(Nparfree,r,Nobs,ipvt,wa1,qtb,parfree,sdiag,wa2)
         wa2(:) = diag(:) * parfree(:)
         dparnorm = ENORM(wa2(:),fastnorm)
         temp = fp
         fp = dparnorm - delta

         ! If the function is small enough, accept the current value of parLM.
         ! Also test for the exceptional cases where parl is zero or the
         ! number of iterations has reached 10.
         IF (ABS(fp) <= 0.1_DP*delta .OR. parl == 0._DP .AND. fp <= temp &
             .AND. temp < 0._DP .OR. iter == 10) EXIT

         ! Compute the newton correction
         wa1(:) = diag(ipvt(:)) * wa2(ipvt(:)) / dparnorm
         DO j=1,Nparfree-1
           wa1(j) = wa1(j) / sdiag(j)
           jp1 = j + 1
           wa1(jp1:Nparfree) = wa1(jp1:Nparfree) - R(jp1:Nparfree,j) * wa1(j)
         END DO
         wa1(Nparfree) = wa1(Nparfree) / sdiag(Nparfree)
         temp = ENORM(wa1(:),fastnorm)
         parc = ( (fp/delta) / temp ) / temp

         ! Depending on the sign of the function, update parl or paru
         IF (fp > 0._DP) parl = MAX(parl,parLM)
         IF (fp < 0._DP) paru = MIN(paru,parLM)

         ! Compute an improved estimate for
         parLM = MAX(parl,parLM+parc)

      END DO iteration

    END IF

    ! Termination
    IF (iter == 0) parLM = 0._DP

    RETURN

    !------------------------------------------------------------------------

  END SUBROUTINE lmpar

  !--------------------------------------------------------------------------
  !   Given an m by n matrix A, an n by n diagonal matrix D, and an m-vector b,
  ! the problem is to determine an par which solves the system:
  !         A*par = b ,     D*par = 0 ,
  ! in the least squares sense. This subroutine completes the solution of the
  ! problem if it is provided with the necessary information from the QR
  ! factorization, with column pivoting, of A. That is, if A*P = Q*R, where P
  ! is a permutation matrix, Q has orthogonal columns, and R is an upper
  ! triangular matrix with diagonal elements of nonincreasing magnitude, then
  ! qrsolv expects the full upper triangle of R, the permutation matrix P, and
  ! the first n components of (Q transpose)*b. the system
  !   A*par = b, D*par = 0, is then equivalent to:
  !                t       t
  !         R*z = Q *b ,  P *D*P*z = 0 ,
  ! where par = P*z. If this system does not have full rank, then a least
  ! squares solution is obtained. On output qrsolv also provides an upper
  ! triangular matrix s such that:
  !          t   t               t
  !         P *(A *A + D*D)*P = S *S .
  ! S is computed within qrsolv and may be of separate interest.
  !--------------------------------------------------------------------------

  SUBROUTINE qrsolv (Nparfree,r,Nobs,ipvt,diag,qtb,parfree, &
                     sdiag,wa)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: Nparfree, Nobs
    INTEGER, DIMENSION(Nparfree), INTENT(IN) :: ipvt
    REAL(DP), DIMENSION(Nobs,Nparfree), INTENT(INOUT) :: R
    REAL(DP), DIMENSION(Nparfree), INTENT(IN) :: diag, qtb
    REAL(DP), DIMENSION(Nparfree), INTENT(INOUT) :: parfree, sdiag
    REAL(DP), DIMENSION(Nparfree), INTENT(INOUT) :: wa

    INTEGER :: j, jp1, k, kp1, l, Nsing
    REAL(DP) :: cosine, cotan, qtbpj, sine, tang, temp
    REAL(DP), DIMENSION(Nparfree) :: tempvec

    !------------------------------------------------------------------------

    ! Copy R and (Q transpose)*b to preserve input and initialize S. In
    ! particular, save the diagonal elements of R in par.
    DO j=1,Nparfree
      R(j:Nparfree,j) = R(j,j:Nparfree)
      parfree(j) = R(j,j)
    END DO
    wa(:) = qtb(:)

    ! Eliminate the diagonal matrix D using a givens rotation
    DO j=1,Nparfree

      ! Prepare the row of D to be eliminated, locating the diagonal element
      ! using P from the QR factorization
      l = ipvt(j)
      IF (diag(l) /= 0._DP) THEN

        sdiag(j:Nparfree) = 0._DP
        sdiag(j) = diag(l)

        ! The transformations to eliminate the row of D modify only a single
        ! element of (Q transpose)*b beyond the first n, which is initially
        ! zero
        qtbpj = 0._DP
        DO k=j,Nparfree

          ! Determine a givens rotation which eliminates the appropriate
          ! element in the current row of D
          IF (sdiag(k) /= 0._DP) THEN

            IF (ABS(R(k,k)) < ABS(sdiag(k))) THEN
              cotan = R(k,k) / sdiag(k)
              sine = 0.5_DP / SQRT(0.25_DP+0.25_DP*cotan**2)
              cosine = sine * cotan
            ELSE
              tang = sdiag(k) / R(k,k)
              cosine = 0.5_DP / SQRT(0.25_DP+0.25_DP*tang**2)
              sine = cosine * tang
            END IF

            ! Compute the modified diagonal element of R and the modified
            ! element of ((Q transpose)*b,0)
            R(k,k) = cosine * R(k,k) + sine * sdiag(k)
            temp = cosine * wa(k) + sine * qtbpj
            qtbpj = - sine * wa(k) + cosine * qtbpj
            wa(k) = temp

            ! Accumulate the tranformation in the row of S
            kp1 = k + 1
            IF (Nparfree >= kp1) THEN
              tempvec(kp1:Nparfree) = cosine*R(kp1:Nparfree,k) &
                                    + sine*sdiag(kp1:Nparfree)
              sdiag(kp1:Nparfree) = - sine*R(kp1:Nparfree,k) &
                                    + cosine*sdiag(kp1:Nparfree)
              R(kp1:Nparfree,k) = tempvec(kp1:Nparfree)
            END IF
          END IF

        END DO

      END IF

      ! Store the diagonal element of S and restore the corresponding diagonal
      ! element of R
      sdiag(j) = R(j,j)
      R(j,j) = parfree(j)

    END DO

    ! Solve the triangular system for z. If the system is singular, then obtain
    ! a least squares solution
    Nsing = MINVAL(PACK([(j-1,j=1,Nparfree)],sdiag(:) == 0._DP, &
                   SPREAD(Nparfree,1,Nparfree)))
    IF (Nsing < Nparfree) wa(Nsing+1:Nparfree) = 0._DP
    IF (Nsing >= 1) THEN
      DO k=1,Nsing
        j = Nsing - k + 1
        jp1 = j + 1
        wa(j) = (wa(j) &
                - MERGE(SUM(R(jp1:Nsing,j)*wa(jp1:Nsing)),0._DP,Nsing >= jp1)) &
              / sdiag(j)
      END DO
    END IF

    ! Permute the components of z back to components of par
    parfree(ipvt(:)) = wa(:)

    RETURN

    !------------------------------------------------------------------------

  END SUBROUTINE qrsolv

  !--------------------------------------------------------------------------
  !   Given an m by n matrix A, the problem is to determine the covariance
  ! matrix corresponding to A, defined as:
  !          t
  ! inverse(A *A) .
  ! This subroutine completes the solution of the problem if it is provided
  ! with the necessary information from the QR factorization, with column
  ! pivoting, of A. that is, if
  ! A*P = Q*R, where P is a permutation matrix, Q has orthogonal columns, and
  ! R is an upper triangular matrix with diagonal elements of nonincreasing
  ! magnitude, then covar expects the full upper triangle of R and the
  ! permutation matrix P. The covariance matrix is then computed as:
  !  t          t
  ! P *inverse(R *R)*P .
  ! If A is nearly rank deficient, it may be desirable to compute the
  ! covariance matrix corresponding to the linearly independent columns of A.
  ! To define the numerical rank of A, covar uses the tolerance tol. If l is
  ! the largest integer such that:
  ! abs(R(l,l)) .gt. tol*abs(R(1,1)) ,
  ! then covar computes the covariance matrix corresponding to the first l
  ! columns of R. For k greater than l, column c and row ipvt(k) of the
  ! covariance matrix are set to zero.
  !--------------------------------------------------------------------------

  FUNCTION covarmat (R,Nobs,Nparfree,ipvt,tol)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: Nobs, Nparfree
    INTEGER, DIMENSION(Nparfree), INTENT(IN) :: ipvt
    REAL(DP), DIMENSION(Nobs,Nparfree), INTENT(IN) :: R
    REAL(DP), INTENT(IN) :: tol
    REAL(DP), DIMENSION(Nparfree,Nparfree) :: covarmat

    INTEGER :: i, ii, j, jj, k, km1, l
    LOGICAL :: sing
    REAL(DP) :: temp, tolr
    REAL(DP), DIMENSION(Nparfree) :: wa
    REAL(DP), DIMENSION(Nobs,Nparfree) :: cov

    !------------------------------------------------------------------------

    cov(:,:) = R(:,:)

    ! Form the inverse of r in the full upper triangle of r
    tolr = tol * ABS(cov(1,1))
    l = 0
    DO k=1,Nparfree
      IF (ABS(cov(k,k)) <= tolr) EXIT
      cov(k,k) = 1._DP / cov(k,k)
      km1 = k - 1
      IF (km1 >= 1) THEN
        DO j=1,km1
          temp = cov(k,k) * cov(j,k)
          cov(j,k) = 0._DP
          cov(1:j,k) = cov(1:j,k) - temp * cov(1:j,j)
        END DO
      END IF
      l = k
    END DO

    ! Form the full upper triangle of the inverse of (R transpose)*R in the
    ! full upper triangle of R
    IF (l >= 1) THEN
      DO k=1,l
        km1 = k - 1
        IF (km1 >= 1) THEN
          DO j=1,km1
            temp = cov(j,k)
            cov(1:j,j) = cov(1:j,j) + temp * cov(1:j,k)
          END DO
        END IF
        temp = cov(k,k)
        cov(1:k,k) = temp * cov(1:k,k)
      END DO
    END IF

    ! Form the full lower triangle of the covariance matrix in the strict
    ! lower triangle of R and in wa
    DO j=1,Nparfree
      jj = ipvt(j)
      sing = (j > l)
      DO i=1,j
        IF (sing) cov(i,j) = 0._DP
        ii = ipvt(i)
        IF (ii > jj) cov(ii,jj) = cov(i,j)
        IF (ii < jj) cov(jj,ii) = cov(i,j)
      END DO
      wa(jj) = cov(j,j)
    END DO

    ! Symmetrize the covariance matrix in R
    DO j=1,Nparfree
      cov(1:j,j) = cov(j,1:j)
      cov(j,j) = wa(j)
    END DO
    covarmat(:,:) = cov(1:Nparfree,1:Nparfree)

    RETURN

    !------------------------------------------------------------------------

  END FUNCTION covarmat

END MODULE chi2_minimization


!*==slas2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLAS2 computes singular values of a 2-by-2 triangular matrix.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLAS2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX )
!
!       .. Scalar Arguments ..
!       REAL               F, G, H, SSMAX, SSMIN
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLAS2  computes the singular values of the 2-by-2 matrix
!>    [  F   G  ]
!>    [  0   H  ].
!> On return, SSMIN is the smaller singular value and SSMAX is the
!> larger singular value.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] F
!> \verbatim
!>          F is REAL
!>          The (1,1) element of the 2-by-2 matrix.
!> \endverbatim
!>
!> \param[in] G
!> \verbatim
!>          G is REAL
!>          The (1,2) element of the 2-by-2 matrix.
!> \endverbatim
!>
!> \param[in] H
!> \verbatim
!>          H is REAL
!>          The (2,2) element of the 2-by-2 matrix.
!> \endverbatim
!>
!> \param[out] SSMIN
!> \verbatim
!>          SSMIN is REAL
!>          The smaller singular value.
!> \endverbatim
!>
!> \param[out] SSMAX
!> \verbatim
!>          SSMAX is REAL
!>          The larger singular value.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup OTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Barring over/underflow, all output quantities are correct to within
!>  a few units in the last place (ulps), even in the absence of a guard
!>  digit in addition/subtraction.
!>
!>  In IEEE arithmetic, the code works correctly if one matrix element is
!>  infinite.
!>
!>  Overflow will not occur unless the largest singular value itself
!>  overflows, or is within a few ulps of overflow. (On machines with
!>  partial overflow, like the Cray, overflow may occur if the largest
!>  singular value is within a factor of 2 of overflow.)
!>
!>  Underflow is harmless if underflow is gradual. Otherwise, results
!>  may correspond to a matrix modified by perturbations of size near
!>  the underflow threshold.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE SLAS2(F,G,H,Ssmin,Ssmax)
      IMPLICIT NONE
!*--SLAS2111
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      REAL F , G , H , Ssmax , Ssmin
!     ..
!
!  ====================================================================
!
!     .. Parameters ..
      REAL ZERO
      PARAMETER (ZERO=0.0E0)
      REAL ONE
      PARAMETER (ONE=1.0E0)
      REAL TWO
      PARAMETER (TWO=2.0E0)
!     ..
!     .. Local Scalars ..
      REAL as , at , au , c , fa , fhmn , fhmx , ga , ha
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , MIN , SQRT
!     ..
!     .. Executable Statements ..
!
      fa = ABS(F)
      ga = ABS(G)
      ha = ABS(H)
      fhmn = MIN(fa,ha)
      fhmx = MAX(fa,ha)
      IF ( fhmn==ZERO ) THEN
         Ssmin = ZERO
         IF ( fhmx==ZERO ) THEN
            Ssmax = ga
         ELSE
            Ssmax = MAX(fhmx,ga)                                        &
     &              *SQRT(ONE+(MIN(fhmx,ga)/MAX(fhmx,ga))**2)
         ENDIF
      ELSEIF ( ga<fhmx ) THEN
         as = ONE + fhmn/fhmx
         at = (fhmx-fhmn)/fhmx
         au = (ga/fhmx)**2
         c = TWO/(SQRT(as*as+au)+SQRT(at*at+au))
         Ssmin = fhmn*c
         Ssmax = fhmx/c
      ELSE
         au = fhmx/ga
         IF ( au==ZERO ) THEN
!
!              Avoid possible harmful underflow if exponent range
!              asymmetric (true SSMIN may not underflow even if
!              AU underflows)
!
            Ssmin = (fhmn*fhmx)/ga
            Ssmax = ga
         ELSE
            as = ONE + fhmn/fhmx
            at = (fhmx-fhmn)/fhmx
            c = ONE/(SQRT(ONE+(as*au)**2)+SQRT(ONE+(at*au)**2))
            Ssmin = (fhmn*c)*au
            Ssmin = Ssmin + Ssmin
            Ssmax = ga/(c+c)
         ENDIF
      ENDIF
!
!     End of SLAS2
!
      END SUBROUTINE SLAS2


        parameter(nz=80,nlevels=3)

	implicit double precision (a-h,o-z)

        dimension s(nz),t(nz),p(nz),gamma(nz),dgl(nz),dgh(nz)
	dimension glevels(nlevels),sns(nlevels),tns(nlevels),pns(nlevels)
	dimension dsns(nlevels),dtns(nlevels),dpns(nlevels)

	data glevels/26.8,27.9,28.1/

ccc
ccc             an example of labelling data
ccc

        open(10,file='example.dat',status='old')

        read(10,*) along,alat,n
        do k = 1,n
          read(10,*) s(k),t(k),p(k)
        end do

ccc
ccc		label
ccc

        call gamma_n(s,t,p,n,along,alat,gamma,dgl,dgh)

        print *, '\nlocation'
	print *
        write(6,'(2f12.4,i8)') along,alat

        print *, '\nlabels'
	print *
        do k = 1,n
          write(6,'(f8.2,3f12.6)') p(k),gamma(k),dgl(k),dgh(k)
        end do

ccc
ccc		fit some surfaces
ccc

	call neutral_surfaces(s,t,p,gamma,n,glevels,nlevels,
     &					sns,tns,pns,dsns,dtns,dpns)

	print *, '\nsurfaces'
        print *

	do k = 1,nlevels
	  print '(f8.2,2f12.6,f14.6,f6.1)',
     &				glevels(k),sns(k),tns(k),pns(k),dpns(k)
	end do

	print *

        end


module brillouin
    use double
    use environment
contains
    function BrilSum(env, sumFunc)
        ! uses Kahan summation algorithm to improve accuracy
        implicit none
        type(Environ), intent(in) :: env
        interface
            function sumFunc(env, k)
                use double
                use environment
                implicit none
                type(Environ), intent(in) :: env
                real(kind=DP), intent(in) :: k(1:3)
                real(kind=DP) :: sumFunc
            end function sumFunc
        end interface
        real(kind=DP) :: BrilSum, start, finish, step, k(1:3), y, t, c
        integer :: nx, ny, nz
        start = -ACos(-1.0_DP) ! start = -pi
        finish = -start
        step = (finish - start) / env%zoneLength
        BrilSum = 0.0_DP
        c = 0.0_DP
        k = start
        xLoop: do nx=1, env%zoneLength
            yLoop: do ny=1, env%zoneLength
                zLoop: do nz=1, env%zoneLength
                    y = sumFunc(env, k) - c
                    t = BrilSum + y
                    c = (t - BrilSum) - y
                    BrilSum = t
                    k(3) = k(3) + step
                end do zLoop
                k(2) = k(2) + step
                k(3) = start
            end do yLoop
            k(1) = k(1) + step
            k(2) = start
        end do xLoop
    end function BrilSum
end module brillouin