module gsw_mod_toolbox

use gsw_mod_kinds

implicit none

public :: gsw_add_barrier
public :: gsw_add_mean
public :: gsw_adiabatic_lapse_rate_from_ct
public :: gsw_adiabatic_lapse_rate_ice
public :: gsw_alpha
public :: gsw_alpha_on_beta
public :: gsw_alpha_wrt_t_exact
public :: gsw_alpha_wrt_t_ice
public :: gsw_beta_const_t_exact
public :: gsw_beta
public :: gsw_cabbeling
public :: gsw_c_from_sp
public :: gsw_chem_potential_water_ice
public :: gsw_chem_potential_water_t_exact
public :: gsw_cp_ice
public :: gsw_ct_first_derivatives
public :: gsw_ct_first_derivatives_wrt_t_exact
public :: gsw_ct_freezing_exact
public :: gsw_ct_freezing
public :: gsw_ct_freezing_first_derivatives
public :: gsw_ct_freezing_first_derivatives_poly
public :: gsw_ct_freezing_poly
public :: gsw_ct_from_enthalpy_exact
public :: gsw_ct_from_enthalpy
public :: gsw_ct_from_entropy
public :: gsw_ct_from_pt
public :: gsw_ct_from_rho
public :: gsw_ct_from_t
public :: gsw_ct_maxdensity
public :: gsw_ct_second_derivatives
public :: gsw_deltasa_atlas
public :: gsw_deltasa_from_sp
public :: gsw_dilution_coefficient_t_exact
public :: gsw_dynamic_enthalpy
public :: gsw_enthalpy_ct_exact
public :: gsw_enthalpy_diff
public :: gsw_enthalpy
public :: gsw_enthalpy_first_derivatives_ct_exact
public :: gsw_enthalpy_first_derivatives
public :: gsw_enthalpy_ice
public :: gsw_enthalpy_second_derivatives_ct_exact
public :: gsw_enthalpy_second_derivatives
public :: gsw_enthalpy_sso_0
public :: gsw_enthalpy_t_exact
public :: gsw_entropy_first_derivatives
public :: gsw_entropy_from_pt
public :: gsw_entropy_from_t
public :: gsw_entropy_ice
public :: gsw_entropy_part
public :: gsw_entropy_part_zerop
public :: gsw_entropy_second_derivatives
public :: gsw_fdelta
public :: gsw_frazil_properties
public :: gsw_frazil_properties_potential
public :: gsw_frazil_properties_potential_poly
public :: gsw_frazil_ratios_adiabatic
public :: gsw_frazil_ratios_adiabatic_poly
public :: gsw_geo_strf_dyn_height
public :: gsw_geo_strf_dyn_height_pc
public :: gsw_gibbs
public :: gsw_gibbs_ice
public :: gsw_gibbs_ice_part_t
public :: gsw_gibbs_ice_pt0
public :: gsw_gibbs_ice_pt0_pt0
public :: gsw_gibbs_pt0_pt0
public :: gsw_grav
public :: gsw_helmholtz_energy_ice
public :: gsw_hill_ratio_at_sp2
public :: gsw_ice_fraction_to_freeze_seawater
public :: gsw_internal_energy
public :: gsw_internal_energy_ice
public :: gsw_ipv_vs_fnsquared_ratio
public :: gsw_kappa_const_t_ice
public :: gsw_kappa
public :: gsw_kappa_ice
public :: gsw_kappa_t_exact
public :: gsw_latentheat_evap_ct
public :: gsw_latentheat_evap_t
public :: gsw_latentheat_melting
public :: gsw_linear_interp_sa_ct
public :: gsw_melting_ice_equilibrium_sa_ct_ratio
public :: gsw_melting_ice_equilibrium_sa_ct_ratio_poly
public :: gsw_melting_ice_into_seawater
public :: gsw_melting_ice_sa_ct_ratio
public :: gsw_melting_ice_sa_ct_ratio_poly
public :: gsw_melting_seaice_equilibrium_sa_ct_ratio
public :: gsw_melting_seaice_equilibrium_sa_ct_ratio_poly
public :: gsw_melting_seaice_into_seawater
public :: gsw_melting_seaice_sa_ct_ratio
public :: gsw_melting_seaice_sa_ct_ratio_poly
public :: gsw_nsquared
public :: gsw_pot_enthalpy_from_pt_ice
public :: gsw_pot_enthalpy_from_pt_ice_poly
public :: gsw_pot_enthalpy_ice_freezing
public :: gsw_pot_enthalpy_ice_freezing_first_derivatives
public :: gsw_pot_enthalpy_ice_freezing_first_derivatives_poly
public :: gsw_pot_enthalpy_ice_freezing_poly
public :: gsw_pot_rho_t_exact
public :: gsw_pressure_coefficient_ice
public :: gsw_pressure_freezing_ct
public :: gsw_pt0_cold_ice_poly
public :: gsw_pt0_from_t
public :: gsw_pt0_from_t_ice
public :: gsw_pt_first_derivatives
public :: gsw_pt_from_ct
public :: gsw_pt_from_entropy
public :: gsw_pt_from_pot_enthalpy_ice
public :: gsw_pt_from_pot_enthalpy_ice_poly_dh
public :: gsw_pt_from_pot_enthalpy_ice_poly
public :: gsw_pt_from_t
public :: gsw_pt_from_t_ice
public :: gsw_pt_second_derivatives
public :: gsw_rho_alpha_beta
public :: gsw_rho
public :: gsw_rho_first_derivatives
public :: gsw_rho_first_derivatives_wrt_enthalpy
public :: gsw_rho_ice
public :: gsw_rho_second_derivatives
public :: gsw_rho_second_derivatives_wrt_enthalpy
public :: gsw_rho_t_exact
public :: gsw_rr68_interp_sa_ct
public :: gsw_saar
public :: gsw_sa_freezing_estimate
public :: gsw_sa_freezing_from_ct
public :: gsw_sa_freezing_from_ct_poly
public :: gsw_sa_freezing_from_t
public :: gsw_sa_freezing_from_t_poly
public :: gsw_sa_from_rho
public :: gsw_sa_from_sp_baltic
public :: gsw_sa_from_sp
public :: gsw_sa_from_sstar
public :: gsw_sa_p_inrange
public :: gsw_seaice_fraction_to_freeze_seawater
public :: gsw_sigma0
public :: gsw_sigma1
public :: gsw_sigma2
public :: gsw_sigma3
public :: gsw_sigma4
public :: gsw_sound_speed
public :: gsw_sound_speed_ice
public :: gsw_sound_speed_t_exact
public :: gsw_specvol_alpha_beta
public :: gsw_specvol_anom_standard
public :: gsw_specvol
public :: gsw_specvol_first_derivatives
public :: gsw_specvol_first_derivatives_wrt_enthalpy
public :: gsw_specvol_ice
public :: gsw_specvol_second_derivatives
public :: gsw_specvol_second_derivatives_wrt_enthalpy
public :: gsw_specvol_sso_0
public :: gsw_specvol_t_exact
public :: gsw_sp_from_c
public :: gsw_sp_from_sa_baltic
public :: gsw_sp_from_sa
public :: gsw_sp_from_sk
public :: gsw_sp_from_sr
public :: gsw_sp_from_sstar
public :: gsw_spiciness0
public :: gsw_spiciness1
public :: gsw_spiciness2
public :: gsw_sr_from_sp
public :: gsw_sstar_from_sa
public :: gsw_sstar_from_sp
public :: gsw_t_deriv_chem_potential_water_t_exact
public :: gsw_t_freezing_exact
public :: gsw_t_freezing
public :: gsw_t_freezing_first_derivatives
public :: gsw_t_freezing_first_derivatives_poly
public :: gsw_t_freezing_poly
public :: gsw_t_from_ct
public :: gsw_t_from_pt0_ice
public :: gsw_thermobaric
public :: gsw_turner_rsubrho
public :: gsw_util_indx
public :: gsw_util_interp1q_int
public :: gsw_util_sort_real
public :: gsw_util_xinterp1
public :: gsw_z_from_p

interface

    pure subroutine gsw_add_barrier (input_data, long, lat, long_grid, &
                                  lat_grid, dlong_grid, dlat_grid, output_data)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: long, lat, long_grid, lat_grid, dlong_grid
    real (r8), intent(in) :: dlat_grid
    real (r8), intent(in), dimension(4) :: input_data
    real (r8), intent(out), dimension(4) :: output_data
    end subroutine gsw_add_barrier

    pure subroutine gsw_add_mean (data_in, data_out)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in), dimension(4) :: data_in
    real (r8), intent(out), dimension(4) :: data_out
    end subroutine gsw_add_mean

    elemental function gsw_adiabatic_lapse_rate_from_ct (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_adiabatic_lapse_rate_from_ct
    end function gsw_adiabatic_lapse_rate_from_ct

    elemental function gsw_adiabatic_lapse_rate_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_adiabatic_lapse_rate_ice
    end function gsw_adiabatic_lapse_rate_ice

    elemental function gsw_alpha (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_alpha
    end function gsw_alpha

    elemental function gsw_alpha_on_beta (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_alpha_on_beta
    end function gsw_alpha_on_beta

    elemental function gsw_alpha_wrt_t_exact (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_alpha_wrt_t_exact
    end function gsw_alpha_wrt_t_exact

    elemental function gsw_alpha_wrt_t_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_alpha_wrt_t_ice
    end function gsw_alpha_wrt_t_ice

    elemental function gsw_beta_const_t_exact (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_beta_const_t_exact
    end function gsw_beta_const_t_exact

    elemental function gsw_beta (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_beta
    end function gsw_beta

    elemental function gsw_cabbeling (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_cabbeling
    end function gsw_cabbeling

    elemental function gsw_c_from_sp (sp, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sp, t, p
    real (r8) :: gsw_c_from_sp
    end function gsw_c_from_sp

    elemental function gsw_chem_potential_water_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_chem_potential_water_ice
    end function gsw_chem_potential_water_ice

    elemental function gsw_chem_potential_water_t_exact (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_chem_potential_water_t_exact
    end function gsw_chem_potential_water_t_exact

    elemental function gsw_cp_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_cp_ice
    end function gsw_cp_ice

    elemental subroutine gsw_ct_first_derivatives (sa, pt, ct_sa, ct_pt)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, pt
    real (r8), intent(out), optional :: ct_sa, ct_pt
    end subroutine gsw_ct_first_derivatives

    elemental subroutine gsw_ct_first_derivatives_wrt_t_exact (sa, t, p, &
    				       ct_sa_wrt_t, ct_t_wrt_t, ct_p_wrt_t)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8), intent(out), optional :: ct_p_wrt_t, ct_sa_wrt_t, ct_t_wrt_t
    end subroutine gsw_ct_first_derivatives_wrt_t_exact

    elemental function gsw_ct_freezing_exact (sa, p, saturation_fraction)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, saturation_fraction
    real (r8) :: gsw_ct_freezing_exact
    end function gsw_ct_freezing_exact

    elemental function gsw_ct_freezing (sa, p, saturation_fraction, poly)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, saturation_fraction
    logical, intent(in), optional :: poly
    real (r8) :: gsw_ct_freezing
    end function gsw_ct_freezing

    elemental subroutine gsw_ct_freezing_first_derivatives (sa, p, &
                              saturation_fraction, ctfreezing_sa, ctfreezing_p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, saturation_fraction
    real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p
    end subroutine gsw_ct_freezing_first_derivatives

    elemental subroutine gsw_ct_freezing_first_derivatives_poly (sa, p, &
                              saturation_fraction, ctfreezing_sa, ctfreezing_p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, saturation_fraction
    real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p
    end subroutine gsw_ct_freezing_first_derivatives_poly

    elemental function gsw_ct_freezing_poly (sa, p, saturation_fraction)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, saturation_fraction
    real (r8) :: gsw_ct_freezing_poly
    end function gsw_ct_freezing_poly

    elemental function gsw_ct_from_enthalpy_exact (sa, h, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, h, p
    real (r8) :: gsw_ct_from_enthalpy_exact
    end function gsw_ct_from_enthalpy_exact

    elemental function gsw_ct_from_enthalpy (sa, h, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, h, p
    real (r8) :: gsw_ct_from_enthalpy
    end function gsw_ct_from_enthalpy

    elemental function gsw_ct_from_entropy (sa, entropy)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, entropy
    real (r8) :: gsw_ct_from_entropy
    end function gsw_ct_from_entropy

    elemental function gsw_ct_from_pt (sa, pt)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, pt
    real (r8) :: gsw_ct_from_pt
    end function gsw_ct_from_pt

    elemental subroutine gsw_ct_from_rho (rho, sa, p, ct, ct_multiple)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: rho, sa, p
    real (r8), intent(out) :: ct
    real (r8), intent(out), optional :: ct_multiple
    end subroutine gsw_ct_from_rho

    elemental function gsw_ct_from_t (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_ct_from_t
    end function gsw_ct_from_t

    elemental function gsw_ct_maxdensity (sa, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p
    real (r8) :: gsw_ct_maxdensity
    end function gsw_ct_maxdensity

    elemental subroutine gsw_ct_second_derivatives (sa, pt, ct_sa_sa, ct_sa_pt, &
                                                    ct_pt_pt)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, pt
    real (r8), intent(out), optional :: ct_sa_sa, ct_sa_pt, ct_pt_pt
    end subroutine gsw_ct_second_derivatives

    elemental function gsw_deltasa_atlas (p, long, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: p, long, lat
    real (r8) :: gsw_deltasa_atlas
    end function gsw_deltasa_atlas

    elemental function gsw_deltasa_from_sp (sp, p, long, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sp, p, long, lat
    real (r8) :: gsw_deltasa_from_sp
    end function gsw_deltasa_from_sp

    elemental function gsw_dilution_coefficient_t_exact (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_dilution_coefficient_t_exact
    end function gsw_dilution_coefficient_t_exact

    elemental function gsw_dynamic_enthalpy (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_dynamic_enthalpy
    end function gsw_dynamic_enthalpy

    elemental function gsw_enthalpy_ct_exact (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_enthalpy_ct_exact
    end function gsw_enthalpy_ct_exact

    elemental function gsw_enthalpy_diff (sa, ct, p_shallow, p_deep)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p_shallow, p_deep
    real (r8) :: gsw_enthalpy_diff
    end function gsw_enthalpy_diff

    elemental function gsw_enthalpy (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_enthalpy
    end function gsw_enthalpy

    elemental subroutine gsw_enthalpy_first_derivatives_ct_exact (sa, ct, p, &
                                                                  h_sa, h_ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8), intent(out), optional :: h_sa, h_ct
    end subroutine gsw_enthalpy_first_derivatives_ct_exact

    elemental subroutine gsw_enthalpy_first_derivatives (sa, ct, p, h_sa, h_ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8), intent(out), optional :: h_sa, h_ct
    end subroutine gsw_enthalpy_first_derivatives

    elemental function gsw_enthalpy_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_enthalpy_ice
    end function gsw_enthalpy_ice

    elemental subroutine gsw_enthalpy_second_derivatives_ct_exact (sa, ct, p, &
                                                     h_sa_sa, h_sa_ct, h_ct_ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct
    end subroutine gsw_enthalpy_second_derivatives_ct_exact

    elemental subroutine gsw_enthalpy_second_derivatives (sa, ct, p, h_sa_sa, &
                                                          h_sa_ct, h_ct_ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct
    end subroutine gsw_enthalpy_second_derivatives

    elemental function gsw_enthalpy_sso_0 (p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: p
    real (r8) :: gsw_enthalpy_sso_0
    end function gsw_enthalpy_sso_0

    elemental function gsw_enthalpy_t_exact (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_enthalpy_t_exact
    end function gsw_enthalpy_t_exact

    elemental subroutine gsw_entropy_first_derivatives (sa, ct, eta_sa, eta_ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8), intent(out), optional :: eta_sa, eta_ct
    end subroutine gsw_entropy_first_derivatives

    elemental function gsw_entropy_from_pt (sa, pt)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, pt
    real (r8) :: gsw_entropy_from_pt
    end function gsw_entropy_from_pt

    elemental function gsw_entropy_from_t (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_entropy_from_t
    end function gsw_entropy_from_t

    elemental function gsw_entropy_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_entropy_ice
    end function gsw_entropy_ice

    elemental function gsw_entropy_part (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_entropy_part
    end function gsw_entropy_part

    elemental function gsw_entropy_part_zerop (sa, pt0)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, pt0
    real (r8) :: gsw_entropy_part_zerop
    end function gsw_entropy_part_zerop

    elemental subroutine gsw_entropy_second_derivatives (sa, ct, eta_sa_sa, &
                                                         eta_sa_ct, eta_ct_ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8), intent(out), optional :: eta_sa_sa, eta_sa_ct, eta_ct_ct
    end subroutine gsw_entropy_second_derivatives

    elemental function gsw_fdelta (p, long, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: p, long, lat
    real (r8) :: gsw_fdelta
    end function gsw_fdelta

    elemental subroutine gsw_frazil_properties (sa_bulk, h_bulk, p, &
                                                sa_final, ct_final, w_ih_final)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa_bulk, h_bulk, p
    real (r8), intent(out) :: sa_final, ct_final, w_ih_final
    end subroutine gsw_frazil_properties

    elemental subroutine gsw_frazil_properties_potential (sa_bulk, h_pot_bulk,&
                                             p, sa_final, ct_final, w_ih_final)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa_bulk, h_pot_bulk, p
    real (r8), intent(out) :: sa_final, ct_final, w_ih_final
    end subroutine gsw_frazil_properties_potential

    elemental subroutine gsw_frazil_properties_potential_poly (sa_bulk, &
                                 h_pot_bulk, p, sa_final, ct_final, w_ih_final)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa_bulk, h_pot_bulk, p
    real (r8), intent(out) :: sa_final, ct_final, w_ih_final
    end subroutine gsw_frazil_properties_potential_poly

    elemental subroutine gsw_frazil_ratios_adiabatic (sa, p, w_ih, &
                                  dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, w_ih
    real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil
    end subroutine gsw_frazil_ratios_adiabatic

    elemental subroutine gsw_frazil_ratios_adiabatic_poly (sa, p, w_ih, &
                                  dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, w_ih
    real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil
    end subroutine gsw_frazil_ratios_adiabatic_poly

    pure function gsw_geo_strf_dyn_height (sa, ct, p, p_ref)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa(:), ct(:), p(:), p_ref
    real (r8) :: gsw_geo_strf_dyn_height(size(sa))
    end function gsw_geo_strf_dyn_height

    pure subroutine gsw_geo_strf_dyn_height_pc (sa, ct, delta_p, &
                                                geo_strf_dyn_height_pc, p_mid)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa(:), ct(:), delta_p(:)
    real (r8), intent(out) :: geo_strf_dyn_height_pc(:), p_mid(:)
    end subroutine gsw_geo_strf_dyn_height_pc

    elemental function gsw_gibbs (ns, nt, np, sa, t, p)
    use gsw_mod_kinds
    implicit none
    integer, intent(in) :: ns, nt, np
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_gibbs
    end function gsw_gibbs

    elemental function gsw_gibbs_ice (nt, np, t, p)
    use gsw_mod_kinds
    implicit none
    integer, intent(in) :: nt, np
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_gibbs_ice
    end function gsw_gibbs_ice

    elemental function gsw_gibbs_ice_part_t (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_gibbs_ice_part_t
    end function gsw_gibbs_ice_part_t

    elemental function gsw_gibbs_ice_pt0 (pt0)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: pt0
    real (r8) :: gsw_gibbs_ice_pt0
    end function gsw_gibbs_ice_pt0

    elemental function gsw_gibbs_ice_pt0_pt0 (pt0)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: pt0
    real (r8) :: gsw_gibbs_ice_pt0_pt0
    end function gsw_gibbs_ice_pt0_pt0

    elemental function gsw_gibbs_pt0_pt0 (sa, pt0)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, pt0
    real (r8) :: gsw_gibbs_pt0_pt0
    end function gsw_gibbs_pt0_pt0

    elemental function gsw_grav (lat, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: lat, p
    real (r8) :: gsw_grav
    end function gsw_grav

    elemental function gsw_helmholtz_energy_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_helmholtz_energy_ice
    end function gsw_helmholtz_energy_ice

    elemental function gsw_hill_ratio_at_sp2 (t)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t
    real (r8) :: gsw_hill_ratio_at_sp2
    end function gsw_hill_ratio_at_sp2

    elemental subroutine gsw_ice_fraction_to_freeze_seawater (sa, ct, p, &
                                              t_ih, sa_freeze, ct_freeze, w_ih)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p, t_ih
    real (r8), intent(out) :: sa_freeze, ct_freeze, w_ih
    end subroutine gsw_ice_fraction_to_freeze_seawater

    elemental function gsw_internal_energy (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_internal_energy
    end function gsw_internal_energy

    elemental function gsw_internal_energy_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_internal_energy_ice
    end function gsw_internal_energy_ice

    pure subroutine gsw_ipv_vs_fnsquared_ratio (sa, ct, p, p_ref, &
                                                ipv_vs_fnsquared_ratio, p_mid)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa(:), ct(:), p(:), p_ref
    real (r8), intent(out) :: ipv_vs_fnsquared_ratio(:), p_mid(:)
    end subroutine gsw_ipv_vs_fnsquared_ratio

    elemental function gsw_kappa_const_t_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_kappa_const_t_ice
    end function gsw_kappa_const_t_ice

    elemental function gsw_kappa (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_kappa
    end function gsw_kappa

    elemental function gsw_kappa_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_kappa_ice
    end function gsw_kappa_ice

    elemental function gsw_kappa_t_exact (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_kappa_t_exact
    end function gsw_kappa_t_exact

    elemental function gsw_latentheat_evap_ct (sa, ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8) :: gsw_latentheat_evap_ct
    end function gsw_latentheat_evap_ct

    elemental function gsw_latentheat_evap_t (sa, t)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t
    real (r8) :: gsw_latentheat_evap_t
    end function gsw_latentheat_evap_t

    elemental function gsw_latentheat_melting (sa, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p
    real (r8) :: gsw_latentheat_melting
    end function gsw_latentheat_melting

    pure subroutine gsw_linear_interp_sa_ct (sa, ct, p, p_i, sa_i, ct_i)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa(:), ct(:), p(:), p_i(:)
    real (r8), intent(out) :: sa_i(:), ct_i(:)
    end subroutine gsw_linear_interp_sa_ct

    elemental function gsw_melting_ice_equilibrium_sa_ct_ratio (sa, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p
    real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio
    end function gsw_melting_ice_equilibrium_sa_ct_ratio

    elemental function gsw_melting_ice_equilibrium_sa_ct_ratio_poly (sa, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p
    real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio_poly
    end function gsw_melting_ice_equilibrium_sa_ct_ratio_poly

    elemental subroutine gsw_melting_ice_into_seawater (sa, ct, p, w_ih, t_ih,&
                                                sa_final, ct_final, w_ih_final)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p, w_ih, t_ih
    real (r8), intent(out) :: sa_final, ct_final, w_ih_final
    end subroutine gsw_melting_ice_into_seawater

    elemental function gsw_melting_ice_sa_ct_ratio (sa, ct, p, t_ih)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p, t_ih
    real (r8) :: gsw_melting_ice_sa_ct_ratio
    end function gsw_melting_ice_sa_ct_ratio

    elemental function gsw_melting_ice_sa_ct_ratio_poly (sa, ct, p, t_ih)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p, t_ih
    real (r8) :: gsw_melting_ice_sa_ct_ratio_poly
    end function gsw_melting_ice_sa_ct_ratio_poly

    elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio (sa, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p
    real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio
    end function gsw_melting_seaice_equilibrium_sa_ct_ratio

    elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio_poly (sa, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p
    real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio_poly
    end function gsw_melting_seaice_equilibrium_sa_ct_ratio_poly

    elemental subroutine gsw_melting_seaice_into_seawater (sa, ct, p, &
                             w_seaice, sa_seaice, t_seaice, sa_final, ct_final)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p, w_seaice, sa_seaice, t_seaice
    real (r8), intent(out) :: sa_final, ct_final
    end subroutine gsw_melting_seaice_into_seawater

    elemental function gsw_melting_seaice_sa_ct_ratio (sa, ct, p, sa_seaice, &
                                                       t_seaice)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice
    real (r8) :: gsw_melting_seaice_sa_ct_ratio
    end function gsw_melting_seaice_sa_ct_ratio

    elemental function gsw_melting_seaice_sa_ct_ratio_poly (sa, ct, p, &
                                                           sa_seaice, t_seaice)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice
    real (r8) :: gsw_melting_seaice_sa_ct_ratio_poly
    end function gsw_melting_seaice_sa_ct_ratio_poly

    pure subroutine gsw_nsquared (sa, ct, p, lat, n2, p_mid)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa(:), ct(:), p(:), lat(:)
    real (r8), intent(out) :: n2(:), p_mid(:)
    end subroutine gsw_nsquared

    elemental function gsw_pot_enthalpy_from_pt_ice (pt0_ice)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: pt0_ice
    real (r8) :: gsw_pot_enthalpy_from_pt_ice
    end function gsw_pot_enthalpy_from_pt_ice

    elemental function gsw_pot_enthalpy_from_pt_ice_poly (pt0_ice)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: pt0_ice
    real (r8) :: gsw_pot_enthalpy_from_pt_ice_poly
    end function gsw_pot_enthalpy_from_pt_ice_poly

    elemental function gsw_pot_enthalpy_ice_freezing (sa, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p
    real (r8) :: gsw_pot_enthalpy_ice_freezing
    end function gsw_pot_enthalpy_ice_freezing

    elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives (sa, &
                  p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p
    real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa
    real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p
    end subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives

    elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly(&
             sa, p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p
    real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa
    real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p
    end subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly

    elemental function gsw_pot_enthalpy_ice_freezing_poly (sa, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p
    real (r8) :: gsw_pot_enthalpy_ice_freezing_poly
    end function gsw_pot_enthalpy_ice_freezing_poly

    elemental function gsw_pot_rho_t_exact (sa, t, p, p_ref)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p, p_ref
    real (r8) :: gsw_pot_rho_t_exact
    end function gsw_pot_rho_t_exact

    elemental function gsw_pressure_coefficient_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_pressure_coefficient_ice
    end function gsw_pressure_coefficient_ice

    elemental function gsw_pressure_freezing_ct (sa, ct, saturation_fraction)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, saturation_fraction
    real (r8) :: gsw_pressure_freezing_ct
    end function gsw_pressure_freezing_ct

    elemental function gsw_pt0_cold_ice_poly (pot_enthalpy_ice)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: pot_enthalpy_ice
    real (r8) :: gsw_pt0_cold_ice_poly
    end function gsw_pt0_cold_ice_poly

    elemental function gsw_pt0_from_t (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_pt0_from_t
    end function gsw_pt0_from_t

    elemental function gsw_pt0_from_t_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_pt0_from_t_ice
    end function gsw_pt0_from_t_ice

    elemental subroutine gsw_pt_first_derivatives (sa, ct, pt_sa, pt_ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8), intent(out), optional :: pt_sa, pt_ct
    end subroutine gsw_pt_first_derivatives

    elemental function gsw_pt_from_ct (sa, ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8) :: gsw_pt_from_ct
    end function gsw_pt_from_ct

    elemental function gsw_pt_from_entropy (sa, entropy)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, entropy
    real (r8) :: gsw_pt_from_entropy
    end function gsw_pt_from_entropy

    elemental function gsw_pt_from_pot_enthalpy_ice (pot_enthalpy_ice)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: pot_enthalpy_ice
    real (r8) :: gsw_pt_from_pot_enthalpy_ice
    end function gsw_pt_from_pot_enthalpy_ice

    elemental function gsw_pt_from_pot_enthalpy_ice_poly_dh (pot_enthalpy_ice)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: pot_enthalpy_ice
    real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly_dh
    end function gsw_pt_from_pot_enthalpy_ice_poly_dh

    elemental function gsw_pt_from_pot_enthalpy_ice_poly (pot_enthalpy_ice)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: pot_enthalpy_ice
    real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly
    end function gsw_pt_from_pot_enthalpy_ice_poly

    elemental function gsw_pt_from_t (sa, t, p, p_ref)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p, p_ref
    real (r8) :: gsw_pt_from_t
    end function gsw_pt_from_t

    elemental function gsw_pt_from_t_ice (t, p, p_ref)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p, p_ref
    real (r8) :: gsw_pt_from_t_ice
    end function gsw_pt_from_t_ice

    elemental subroutine gsw_pt_second_derivatives (sa, ct, pt_sa_sa, &
                                                    pt_sa_ct, pt_ct_ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8), intent(out), optional :: pt_sa_sa, pt_sa_ct, pt_ct_ct
    end subroutine gsw_pt_second_derivatives

    elemental subroutine gsw_rho_alpha_beta (sa, ct, p, rho, alpha, beta)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8), intent(out), optional :: rho, alpha, beta
    end subroutine gsw_rho_alpha_beta

    elemental function gsw_rho (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_rho
    end function gsw_rho

    elemental subroutine gsw_rho_first_derivatives (sa, ct, p, drho_dsa, &
                                                    drho_dct, drho_dp)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8), intent(out), optional :: drho_dsa, drho_dct, drho_dp
    end subroutine gsw_rho_first_derivatives

    elemental subroutine gsw_rho_first_derivatives_wrt_enthalpy (sa, ct, p, &
                                                                 rho_sa, rho_h)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8), intent(out), optional :: rho_sa, rho_h
    end subroutine gsw_rho_first_derivatives_wrt_enthalpy

    elemental function gsw_rho_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_rho_ice
    end function gsw_rho_ice

    elemental subroutine gsw_rho_second_derivatives (sa, ct, p, rho_sa_sa, &
                                      rho_sa_ct, rho_ct_ct, rho_sa_p, rho_ct_p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8), intent(out), optional :: rho_sa_sa, rho_sa_ct, rho_ct_ct
    real (r8), intent(out), optional :: rho_sa_p, rho_ct_p
    end subroutine gsw_rho_second_derivatives

    elemental subroutine gsw_rho_second_derivatives_wrt_enthalpy (sa, ct, p, &
                                                  rho_sa_sa, rho_sa_h, rho_h_h)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8), intent(out), optional :: rho_sa_sa, rho_sa_h, rho_h_h
    end subroutine gsw_rho_second_derivatives_wrt_enthalpy

    elemental function gsw_rho_t_exact (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_rho_t_exact
    end function gsw_rho_t_exact

    pure subroutine gsw_rr68_interp_sa_ct (sa, ct, p, p_i, sa_i, ct_i)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa(:), ct(:), p(:), p_i(:)
    real (r8), intent(out) :: sa_i(:), ct_i(:)
    end subroutine gsw_rr68_interp_sa_ct

    elemental function gsw_saar (p, long, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: p, long, lat
    real (r8) :: gsw_saar
    end function gsw_saar

    elemental function gsw_sa_freezing_estimate (p, saturation_fraction, ct, t)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: p, saturation_fraction
    real (r8), intent(in), optional :: ct, t
    real (r8) :: gsw_sa_freezing_estimate
    end function gsw_sa_freezing_estimate

    elemental function gsw_sa_freezing_from_ct (ct, p, saturation_fraction)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: ct, p, saturation_fraction
    real (r8) :: gsw_sa_freezing_from_ct
    end function gsw_sa_freezing_from_ct

    elemental function gsw_sa_freezing_from_ct_poly (ct, p, saturation_fraction)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: ct, p, saturation_fraction
    real (r8) :: gsw_sa_freezing_from_ct_poly
    end function gsw_sa_freezing_from_ct_poly

    elemental function gsw_sa_freezing_from_t (t, p, saturation_fraction)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p, saturation_fraction
    real (r8) :: gsw_sa_freezing_from_t
    end function gsw_sa_freezing_from_t

    elemental function gsw_sa_freezing_from_t_poly (t, p, saturation_fraction)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p, saturation_fraction
    real (r8) :: gsw_sa_freezing_from_t_poly
    end function gsw_sa_freezing_from_t_poly

    elemental function gsw_sa_from_rho (rho, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: rho, ct, p
    real (r8) :: gsw_sa_from_rho
    end function gsw_sa_from_rho

    elemental function gsw_sa_from_sp_baltic (sp, long, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sp, long, lat
    real (r8) :: gsw_sa_from_sp_baltic
    end function gsw_sa_from_sp_baltic

    elemental function gsw_sa_from_sp (sp, p, long, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sp, p, long, lat
    real (r8) :: gsw_sa_from_sp
    end function gsw_sa_from_sp

    elemental function gsw_sa_from_sstar (sstar, p, long, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sstar, p, long, lat
    real (r8) :: gsw_sa_from_sstar
    end function gsw_sa_from_sstar

    elemental function gsw_sa_p_inrange (sa, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p
    logical :: gsw_sa_p_inrange
    end function gsw_sa_p_inrange

    elemental subroutine gsw_seaice_fraction_to_freeze_seawater (sa, ct, p, &
                           sa_seaice, t_seaice, sa_freeze, ct_freeze, w_seaice)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice
    real (r8), intent(out) :: sa_freeze, ct_freeze, w_seaice
    end subroutine gsw_seaice_fraction_to_freeze_seawater

    elemental function gsw_sigma0 (sa, ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8) :: gsw_sigma0
    end function gsw_sigma0

    elemental function gsw_sigma1 (sa, ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8) :: gsw_sigma1
    end function gsw_sigma1

    elemental function gsw_sigma2 (sa, ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8) :: gsw_sigma2
    end function gsw_sigma2

    elemental function gsw_sigma3 (sa, ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8) :: gsw_sigma3
    end function gsw_sigma3

    elemental function gsw_sigma4 (sa, ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8) :: gsw_sigma4
    end function gsw_sigma4

    elemental function gsw_sound_speed (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_sound_speed
    end function gsw_sound_speed

    elemental function gsw_sound_speed_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_sound_speed_ice
    end function gsw_sound_speed_ice

    elemental function gsw_sound_speed_t_exact (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_sound_speed_t_exact
    end function gsw_sound_speed_t_exact

    elemental subroutine gsw_specvol_alpha_beta (sa, ct, p, specvol, alpha, &
                                                 beta)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8), intent(out), optional :: specvol, alpha, beta
    end subroutine gsw_specvol_alpha_beta

    elemental function gsw_specvol_anom_standard (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_specvol_anom_standard
    end function gsw_specvol_anom_standard

    elemental function gsw_specvol (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_specvol
    end function gsw_specvol

    elemental subroutine gsw_specvol_first_derivatives (sa, ct, p, v_sa, v_ct, &
                                                        v_p, iflag)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    integer, intent(in), optional :: iflag
    real (r8), intent(out), optional :: v_sa, v_ct, v_p
    end subroutine gsw_specvol_first_derivatives

    elemental subroutine gsw_specvol_first_derivatives_wrt_enthalpy (sa, ct, &
                                                           p, v_sa, v_h, iflag)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    integer, intent(in), optional :: iflag
    real (r8), intent(out), optional :: v_sa, v_h
    end subroutine gsw_specvol_first_derivatives_wrt_enthalpy

    elemental function gsw_specvol_ice (t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: t, p
    real (r8) :: gsw_specvol_ice
    end function gsw_specvol_ice

    elemental subroutine gsw_specvol_second_derivatives (sa, ct, p, v_sa_sa, &
                                       v_sa_ct, v_ct_ct, v_sa_p, v_ct_p, iflag)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    integer, intent(in), optional :: iflag
    real (r8), intent(out), optional :: v_sa_sa, v_sa_ct, v_ct_ct, v_sa_p, v_ct_p
    end subroutine gsw_specvol_second_derivatives

    elemental subroutine gsw_specvol_second_derivatives_wrt_enthalpy (sa, ct, &
                                              p, v_sa_sa, v_sa_h, v_h_h, iflag)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    integer, intent(in), optional :: iflag
    real (r8), intent(out), optional :: v_sa_sa, v_sa_h, v_h_h
    end subroutine gsw_specvol_second_derivatives_wrt_enthalpy

    elemental function gsw_specvol_sso_0 (p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: p
    real (r8) :: gsw_specvol_sso_0
    end function gsw_specvol_sso_0

    elemental function gsw_specvol_t_exact (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_specvol_t_exact
    end function gsw_specvol_t_exact

    elemental function gsw_sp_from_c (c, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: c, t, p
    real (r8) :: gsw_sp_from_c
    end function gsw_sp_from_c

    elemental function gsw_sp_from_sa_baltic (sa, long, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, long, lat
    real (r8) :: gsw_sp_from_sa_baltic
    end function gsw_sp_from_sa_baltic

    elemental function gsw_sp_from_sa (sa, p, long, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, long, lat
    real (r8) :: gsw_sp_from_sa
    end function gsw_sp_from_sa

    elemental function gsw_sp_from_sk (sk)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sk
    real (r8) :: gsw_sp_from_sk
    end function gsw_sp_from_sk

    elemental function gsw_sp_from_sr (sr)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sr
    real (r8) :: gsw_sp_from_sr
    end function gsw_sp_from_sr

    elemental function gsw_sp_from_sstar (sstar, p, long, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sstar, p, long, lat
    real (r8) :: gsw_sp_from_sstar
    end function gsw_sp_from_sstar

    elemental function gsw_spiciness0 (sa, ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8) :: gsw_spiciness0
    end function gsw_spiciness0

    elemental function gsw_spiciness1 (sa, ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8) :: gsw_spiciness1
    end function gsw_spiciness1

    elemental function gsw_spiciness2 (sa, ct)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct
    real (r8) :: gsw_spiciness2
    end function gsw_spiciness2

    elemental function gsw_sr_from_sp (sp)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sp
    real (r8) :: gsw_sr_from_sp
    end function gsw_sr_from_sp

    elemental function gsw_sstar_from_sa (sa, p, long, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, long, lat
    real (r8) :: gsw_sstar_from_sa
    end function gsw_sstar_from_sa

    elemental function gsw_sstar_from_sp (sp, p, long, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sp, p, long, lat
    real (r8) :: gsw_sstar_from_sp
    end function gsw_sstar_from_sp

    elemental function gsw_t_deriv_chem_potential_water_t_exact (sa, t, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, t, p
    real (r8) :: gsw_t_deriv_chem_potential_water_t_exact
    end function gsw_t_deriv_chem_potential_water_t_exact

    elemental function gsw_t_freezing_exact (sa, p, saturation_fraction)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, saturation_fraction
    real (r8) :: gsw_t_freezing_exact
    end function gsw_t_freezing_exact

    elemental function gsw_t_freezing (sa, p, saturation_fraction, poly)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, saturation_fraction
    logical, intent(in), optional :: poly
    real (r8) :: gsw_t_freezing
    end function gsw_t_freezing

    elemental subroutine gsw_t_freezing_first_derivatives (sa, p, &
                                saturation_fraction, tfreezing_sa, tfreezing_p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, saturation_fraction
    real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p
    end subroutine gsw_t_freezing_first_derivatives

    elemental subroutine gsw_t_freezing_first_derivatives_poly (sa, p, &
                                saturation_fraction, tfreezing_sa, tfreezing_p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p, saturation_fraction
    real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p
    end subroutine gsw_t_freezing_first_derivatives_poly

    elemental function gsw_t_freezing_poly (sa, p, saturation_fraction, polynomial)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, p
    real (r8), intent(in), optional :: saturation_fraction
    logical, intent(in), optional :: polynomial
    real (r8) :: gsw_t_freezing_poly
    end function gsw_t_freezing_poly

    elemental function gsw_t_from_ct (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_t_from_ct
    end function gsw_t_from_ct

    elemental function gsw_t_from_pt0_ice (pt0_ice, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: pt0_ice, p
    real (r8) :: gsw_t_from_pt0_ice
    end function gsw_t_from_pt0_ice

    elemental function gsw_thermobaric (sa, ct, p)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa, ct, p
    real (r8) :: gsw_thermobaric
    end function gsw_thermobaric

    pure subroutine gsw_turner_rsubrho (sa, ct, p, tu, rsubrho, p_mid)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: sa(:), ct(:), p(:)
    real (r8), intent(out) :: tu(:), rsubrho(:), p_mid(:)
    end subroutine gsw_turner_rsubrho

    pure subroutine gsw_util_indx (x, n, z, k)
    use gsw_mod_kinds
    integer, intent(in) :: n
    integer, intent(out) :: k
    real (r8), intent(in), dimension(n) :: x
    real (r8), intent(in) :: z
    end subroutine gsw_util_indx

    pure function gsw_util_interp1q_int (x, iy, x_i) result(y_i)
    use gsw_mod_kinds
    implicit none
    integer, intent(in) :: iy(:)
    real (r8), intent(in) :: x(:), x_i(:)
    real (r8) :: y_i(size(x_i))
    end function gsw_util_interp1q_int

    pure function gsw_util_sort_real (rarray) result(iarray)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: rarray(:)    ! Values to be sorted
    integer :: iarray(size(rarray))       ! Sorted ids
    end function gsw_util_sort_real

    pure function gsw_util_xinterp1 (x, y, n, x0)
    use gsw_mod_kinds
    implicit none
    integer, intent(in) :: n
    real (r8), intent(in) :: x0
    real (r8), dimension(n), intent(in) :: x, y
    real (r8) :: gsw_util_xinterp1
    end function gsw_util_xinterp1

    elemental function gsw_z_from_p (p, lat)
    use gsw_mod_kinds
    implicit none
    real (r8), intent(in) :: p, lat
    real (r8) :: gsw_z_from_p
    end function gsw_z_from_p

end interface

end module gsw_mod_toolbox


c=============================================================================c
      subroutine conformal( npts, s, xb, yb, cur )
c=============================================================================c
      parameter (zero=0.0d0,    pt5=0.5d0,    pt25=0.25d0,    one=1.0d0,
     &           onept5=1.5d0,  two=2.0d0,    twopt5=2.5d0,
     &           three=3.0d0,   pi=3.1415926535897932385d+0,  four=4.0,
     &           tol=1.0e-7)

      dimension s(npts), xb(npts), yb(npts), cur(npts)

      parameter ( mpts=2048 )
      dimension x(mpts), y(mpts), th(mpts), psi(mpts)
      dimension phi(mpts), eps(mpts), tmp(mpts)

      parameter ( nint = 800 )
      dimension aa(nint), bb(nint)
      complex   cc(nint), z, zeta, rk(nint), rh(nint), ra(nint)

      common /tmp1/ n, korder, xknot(mpts), bs(mpts), phip

      external integrand, RKQCR, BSITG
c=============================================================================c
      write(*,"(/,'Conformal is not tested, therefore skipping...')")
      return

      korder = 5
      n = npts
      if (n .gt. mpts) then
         write(*,"('ERROR:  Increase mpts in conformal ')")
         call exit(1)
      end if
c
c.... Map the airfoil to an approximate circle
c
      open(20,file='map.out')
      rn = one / cur(1)
c     a  = (one - pt5 * rn) * pt25
c     x0 = pt5 * rn + two * a
      a  = (one - rn) * pt25
      x0 = rn + two * a
      y0 = zero
      do i = 1, npts
         x(i) = -(xb(i) - x0)
         y(i) = yb(i) - y0
         p = one - (x(i)/(two*a))**2 - (y(i)/(two*a))**2
         th(i) = asin( sqrt( pt5*(p + sqrt(p**2 + (y(i)/a)**2)) ) )
         if (x(i) .lt. zero) th(i) = pi - th(i)
c.error  psi(i) = asinh( sqrt( pt5*(-p + sqrt(p**2 + (y(i)/a)**2)) ) )
         write(20,100) s(i), x(i), y(i), th(i), psi(i),
     &                 a*exp(psi(i))*cos(th(i)),
     &                 a*exp(psi(i))*sin(th(i))
      end do
      close(20)
c
c.... correct for finite precision
c
      th(1)  = zero
      th(n)  = pi
      psi(n) = zero
c
c.... initialize
c
      do i = 1, n
         eps(i) = zero
      end do

      do k = 1, nint-1
         aa(k) = log( abs( sin(pi*(two*k+one)/(four*nint)) /
     &                     sin(pi*(two*k-one)/(four*nint)) ) )
      end do
c
c.... compute the mapping to a circle
c
      niter = 1
      write(*,"('Enter niter ==> ',$)")
      read(*,*) niter
      do iter = 1, niter
         write(*,"('Interation = ',i4)") iter
         do i = 1, n
            phi(i) = th(i) + eps(i)
         end do
         call BSNAK(n, phi, korder, xknot)
         call BSINT(n, phi, psi, korder, xknot, bs )

         do i = 1, n
            phip   = phi(i)
            eps(i) = pi/nint * BSDER( 1, phip, korder, xknot, n, bs )
            do k = 1, nint-1

               phia = phip + k * pi / nint
               if (phia .ge. two*pi) phia = phia - two*pi

               phib = phip - k * pi / nint
               if (phib .le. zero) phib = phib + two*pi

               if (phia .ge. zero .and. phia .le. pi) then
                  psia = BSDER( 0, phia, korder, xknot, n, bs )
               else
                  phia = two * pi - phia
                  psia = BSDER( 0, phia, korder, xknot, n, bs )
               end if

               if (phib .ge. zero .and. phib .le. pi) then
                  psib = BSDER( 0, phib, korder, xknot, n, bs )
               else
                  phib = two * pi - phib
                  psib = BSDER( 0, phib, korder, xknot, n, bs )
               end if

               eps(i) = eps(i) + aa(k) * ( psia - psib )
            end do
            eps(i) = -one/pi * eps(i)
         end do
c
c.... enforce symmetry
c
         eps(1) = zero
         eps(n) = zero

      end do

      do i = 1, n
         phi(i) = th(i) + eps(i)
      end do
      call BSNAK(n, phi, korder, xknot)
      call BSINT(n, phi, psi, korder, xknot, bs )

      open(20,file='conf.out')
      do i = 1, n
         write(20,100) phi(i), th(i), psi(i), eps(i),
     &   BSDER( 0, phi(i), korder, xknot, n, bs ),
     &   BSDER( 1, phi(i), korder, xknot, n, bs )
      end do
      close(20)
c
c.... compute psi0
c
      psi0 = one/pi * BSITG( zero, pi, korder, xknot, n, bs )
      write(*,"('Psi0 = ',1pe14.7)") psi0
c
c.... check to make sure that they are congugate
c
      call BSNAK(n, phi, korder, xknot)
      call BSINT(n, phi, eps, korder, xknot, bs )

      do i = 1, n
         phip   = phi(i)
         psi(i) = pi/nint * BSDER( 1, phip, korder, xknot, n, bs )
         do k = 1, nint-1

            phia = phip + k * pi / nint
            if (phia .ge. two*pi) phia = phia - two*pi

            phib = phip - k * pi / nint
            if (phib .le. zero) phib = phib + two*pi

            if (phia .ge. zero .and. phia .le. pi) then
               epsa = BSDER( 0, phia, korder, xknot, n, bs )
            else
               phia = two * pi - phia
               epsa = -BSDER( 0, phia, korder, xknot, n, bs )
            end if

            if (phib .ge. zero .and. phib .le. pi) then
               epsb = BSDER( 0, phib, korder, xknot, n, bs )
            else
               phib = two * pi - phib
               epsb = -BSDER( 0, phib, korder, xknot, n, bs )
            end if

            psi(i) = psi(i) + aa(k) * ( epsa - epsb )
         end do
         psi(i) = one/pi * psi(i)
      end do

      open(20,file='check.out')
      do i = 1, n
         write(20,100) phi(i), th(i), psi(i), eps(i),
     &                 BSDER( 1, phi(i), korder, xknot, n, bs )
      end do
      close(20)
c
c.... compute the coefficients of the mapping
c.... (The b are zero due to symmetry)
c
      R = a * exp( psi0 )
      write(*,"('a = ',1pe13.7)") a
      write(*,"('R = ',1pe13.7)") R
      do k = 1, 10
         do i = 1, n
            tmp(i) =  psi(i) * cos( real(k) * phi(i) )
         end do
         call BSINT(n, phi, tmp, korder, xknot, bs )
         aa(k) = R**k * two / pi * BSITG( zero, pi, korder, xknot, n, bs )
         write(*,"('A(',i2,') = ',1pe14.7)") k, aa(k)
      end do

      do k = 1, 10
         bb(k) = zero
         cc(k) = cmplx(aa(k),bb(k))
      end do

      rk(1) = cc(1)
      rk(2) = 1.0 / 2.0 * ( rk(1) * cc(1) + 2.0 * cc(2) )
      rk(3) = 1.0 / 3.0 * ( rk(2) * cc(1) + 2.0 * rk(1) * cc(2) +
     &                      3.0 * cc(3) )
      rk(4) = 1.0 / 4.0 * ( rk(3) * cc(1) + 2.0 * rk(2) * cc(2) +
     &                      3.0 * rk(1) * cc(3) + 4.0 * rk(4) )
      rk(5) = 1.0 / 5.0 * ( rk(4) * cc(1) + 2.0 * rk(3) * cc(2) +
     &                      3.0 * rk(2) * cc(3) + 4.0 * rk(1) * cc(4) +
     &                      5.0 * cc(5) )
      rk(6) = 1.0 / 6.0 * ( rk(5) * cc(1) + 2.0 * rk(4) * cc(2) +
     &                      3.0 * rk(3) * cc(3) + 4.0 * rk(2) * cc(4) +
     &                      5.0 * rk(1) * cc(5) + 6.0 * cc(6) )

      rh(1) = -cc(1)
      rh(2) = 1.0 / 2.0 * ( rk(1) * (-cc(1)) + 2.0 * (-cc(2)) )
      rh(3) = 1.0 / 3.0 * ( rk(2) * (-cc(1)) + 2.0 * rk(1) * (-cc(2)) +
     &                      3.0 * (-cc(3)) )
      rh(4) = 1.0 / 4.0 * ( rk(3) * (-cc(1)) + 2.0 * rk(2) * (-cc(2)) +
     &                      3.0 * rk(1) * (-cc(3)) + 4.0 * rk(4) )
      rh(5) = 1.0 / 5.0 * ( rk(4) * (-cc(1)) + 2.0 * rk(3) * (-cc(2)) +
     &                      3.0 * rk(2) * (-cc(3)) + 4.0 * rk(1) * (-cc(4)) +
     &                      5.0 * (-cc(5)) )

      ra(1) = rk(2) + a**2
      ra(2) = rk(3) + a**2 * rh(1)
      ra(3) = rk(4) + a**2 * rh(2)
      ra(4) = rk(5) + a**2 * rh(3)
      ra(5) = rk(6) + a**2 * rh(4)

      open(20,file='body.new')
      do i = 1, n
         z = a * exp(psi0) * exp( cmplx(zero,one) * phi(i) )

         zeta = z + cc(1) + ra(1) / z + ra(2) / z**2 + ra(3) / z**3
     &        + ra(4) / z**4
c    &        + ra(5) / z**5

         write(20,100) real(zeta), aimag(zeta), real(z), aimag(z)
      end do
      close(20)

      return
 100  format(8(1pe13.6,1x))
      end

c=============================================================================c
      subroutine integrand( nvar, epsl, phil, depsdphi )
c=============================================================================c
      parameter (zero=0.0d0,    pt5=0.5d0,    pt25=0.25d0,    one=1.0d0,
     &           onept5=1.5d0,  two=2.0d0,    twopt5=2.5d0,
     &           three=3.0d0,   big=1.0e10,   pi=3.1415926535897932385d+0,
     &           tol=1.0e-7)

      parameter ( mpts=2048 )
      common /tmp1/ n, korder, xknot(mpts), bs(mpts), phip
c=============================================================================c

      dpsidphi = BSDER( 1, phil, korder, xknot, n, bs )

      depsdphi = one/pi * ( dpsidphi * log(abs(sin(pt5*(phil - phip)))) )

      return
      end


!########################################################
!     Program  : AHMIPT
!     TYPE     : Main program
!     PURPOSE  : Solve the Attractive Hubbard Model using IPT
!     AUTHORS  : Adriano Amaricci
!########################################################
program ahmmpt_matsubara_phase_2dsquare
  USE DMFT_IPT
  USE IOTOOLS
  USE RANDOM
  USE CHRONOBAR
  USE SQUARE_LATTICE
  implicit none
  integer                         :: i,ik,esp,Lk,M
  logical                         :: converged,check1,check2,check
  complex(8)                      :: zeta,cdet
  complex(8)                      :: delta,delta0
  real(8)                         :: n,n0,w
  real(8)                         :: sc_phase,sc_mod
  real(8)                         :: sc0_phase,sc0_mod

  !
  complex(8),allocatable          :: fg(:,:),fg0(:,:),sigma(:,:),calG(:,:)
  real(8),allocatable             :: fgt(:)
  complex(8),allocatable          :: fft(:)
  complex(8),allocatable          :: det(:),sold(:,:)
  !
  real(8),allocatable             :: wt(:),epsik(:),wm(:),tau(:)

  include "revision.inc"
  call version(revision)
  call read_input("inputIPT.in")

  allocate(wm(L),tau(0:L))
  wm(:)  = pi/beta*real(2*arange(1,L)-1,8)
  tau(0:)= linspace(0.d0,beta,L+1,mesh=dtau)

  !
  allocate(fg(2,L),fg0(2,L),calG(2,L))
  allocate(sigma(2,L),sold(2,L))
  allocate(det(L))
  allocate(fgt(0:L),fft(0:L))

  !build square lattice structure:
  Lk   = square_lattice_dimension(Nx)
  allocate(wt(Lk),epsik(Lk))
  wt   = square_lattice_structure(Lk,Nx)
  epsik= square_lattice_dispersion_array(Lk,ts)
  call get_initial_sigma

  iloop=0 ; converged=.false.
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)",advance="yes")"DMFT-loop",iloop

     call start_timer
     fg=zero
     do i=1,L
        zeta =  xi*wm(i) + xmu - sigma(1,i)
        do ik=1,Lk
           cdet = abs(zeta-epsik(ik))**2 + abs(sigma(2,i))**2
           fg(1,i)=fg(1,i) + wt(ik)*conjg(zeta-epsik(ik))/cdet
           fg(2,i)=fg(2,i) - wt(ik)*sigma(2,i)/cdet !inverse is transpose!!!
        enddo
     enddo

     call fftgf_iw2tau(fg(1,:),fgt(0:),beta)
     call fftff_iw2tau(fg(2,:),fft(0:),beta)
     n=-fgt(L) ; delta= -u*fft(L)

     !calcola calG0^-1, calF0^-1 (WFs)
     det      =  abs(fg(1,:))**2     + abs(fg(2,:))**2
     fg0(1,:) =  conjg(fg(1,:))/det  + sigma(1,:) + u*(n-0.5d0)
     fg0(2,:) =  fg(2,:)/det         + sigma(2,:) +  delta

     det       =  abs(fg0(1,:))**2   + abs(fg0(2,:))**2
     calG(1,:) =  conjg(fg0(1,:))/det
     calG(2,:) =  fg0(2,:)/det

     call fftgf_iw2tau(calG(1,:),fgt(0:),beta)
     call fftff_iw2tau(calG(2,:),fft(0:),beta)
     n0=-fgt(L) ; delta0= -u*fft(L)

     sc_mod=abs(delta)
     sc0_mod=abs(delta0)
     sc_phase=atan2(dimag(delta),real(delta,8))
     sc0_phase=atan2(dimag(delta0),real(delta,8))

     write(*,"(6(f16.12))",advance="no")n,n0,sc_mod,sc_phase,sc0_mod,sc0_phase

     sigma =  solve_mpt_sc_matsubara(calG,n,n0,delta,delta0)
     sigma =  weight*sigma + (1.d0-weight)*sold;sold=sigma

     !this is an idea of Massimo, check error as a single array.
     converged = check_convergence_scalar(sc_mod,eps=eps_error,N1=Nsuccess,N2=nloop)

     if(nread/=0.d0)call search_mu(converged)

     call splot("nVSiloop.ipt",iloop,n,n0,append=TT)
     call splot("deltaVSiloop.ipt",iloop,sc_mod,sc0_mod,append=TT)
     call splot("phaseVSiloop.ipt",iloop,sc_phase,sc0_phase,append=TT)

     ! This stays here for the time being, until the code is bomb proof
     call splot("G_iw.ipt",wm,fg(1,:),append=printf)
     call splot("F_iw.ipt",wm,fg(2,:),append=printf)
     call splot("G_tau.ipt",tau,fgt,append=printf)
     call splot("F_tau.ipt",tau,fft,append=printf)
     call splot("calG_iw.ipt",wm,calG(1,:),append=printf)
     call splot("calF_iw.ipt",wm,calG(2,:),append=printf)
     call splot("calG_tau.ipt",tau,fgt,append=printf)
     call splot("calF_tau.ipt",tau,fft,append=printf)
     call splot("Sigma_iw.ipt",wm,sigma(1,:),append=printf)
     call splot("Self_iw.ipt",wm,sigma(2,:),append=printf)
     call splot("observables.ipt",beta,xmu,u,n,n0,sc_mod,sc0_mod,sc_phase,sc0_phase,append=printf)
     call stop_timer
  enddo

  call close_file("nVSiloop.ipt")
  call close_file("deltaVSiloop.ipt")
  call close_file("phaseVSiloop.ipt")

  call splot("G_iw.last",wm,fg(1,:),append=FF)
  call splot("F_iw.last",wm,fg(2,:),append=FF)
  call splot("G_tau.last",tau,fgt,append=FF)
  call splot("F_tau.last",tau,fft,append=FF)
  call splot("calG_iw.last",wm,calG(1,:),append=FF)
  call splot("calF_iw.last",wm,calG(2,:),append=FF)
  call splot("Sigma_iw.last",wm,sigma(1,:),append=FF)
  call splot("Self_iw.last",wm,sigma(2,:),append=FF)
  call splot("observables.last",beta,xmu,u,n,n0,sc_mod,sc0_mod,sc_phase,sc0_phase,append=FF)

  !call get_sc_internal_energy

contains

  subroutine search_mu(convergence)
    integer, save         :: nindex
    integer               :: nindex1
    real(8)               :: naverage,ndelta1
    logical,intent(inout) :: convergence

    naverage=n
    nindex1=nindex
    ndelta1=ndelta
    if((naverage >= nread+nerror))then
       nindex=-1
    elseif(naverage <= nread-nerror)then
       nindex=1
    else
       nindex=0
    endif
    if(nindex1+nindex==0)then !avoid loop forth and back
       ndelta=ndelta1/2.d0    !decreasing the step
    else
       ndelta=ndelta1
    endif
    xmu=xmu+real(nindex,8)*ndelta

    write(*,"(A,f15.12,A,f15.12,A,f15.12,A,f15.12)")" n=",naverage,"/",nread,"| shift=",nindex*ndelta,"| mu=",xmu

    if(abs(naverage-nread)>nerror)convergence=.false.
    call splot("muVSiter.ipt",iloop,xmu,abs(naverage-nread),append=.true.)
  end subroutine search_mu

  subroutine get_initial_sigma()
    inquire(file="Sigma_iw.last",exist=check1)
    inquire(file="Self_iw.last",exist=check2)
    check=check1.AND.check2
    if(check)then
       write(*,*)"Reading Sigma in input:"
       call sread("Sigma_iw.last",wm,sigma(1,:))
       call sread("Self_iw.last",wm,sigma(2,:))
    else
       print*,"Using Hartree-Fock self-energy"
       print*,"===================================="
       call init_random_number
       call random_number(sc_phase)
       sc_phase=sc_phase*pi2
       n=0.5d0
       delta=abs(deltasc)*exp(xi*sc_phase)
       sigma(2,:)=-delta ; sigma(1,:)=zero
       sold=sigma
    endif
  end subroutine get_initial_sigma

end program ahmmpt_matsubara_phase_2dsquare


c=======================================================================
c
c     subroutine calepsvar
c
c     This function computes a level of calibration (espilon) defined by
c     a percentage of explained variance.
c
c-----------------------------------------------------------------------
      SUBROUTINE calepsvar ( n, cov, exvar, iwork, dwork,
     &                       epsilon, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       p     : number of variables (p>=1)                       integer
c       cov   : covariance matrix (p*p)                           double
c       exvar : percentage of explained variance, in ]0,1]        double
c
c     WORKSPACE
c       iwork : n                                                integer
c       dwork : 2*n*n + 17*n                                      double
c
c     OUTPUT
c       epsilon : sensitivity parameter                           double
c       info    : diagnostic argument                            integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info
      DOUBLE PRECISION cov(n, *), exvar, epsilon
c
c     workspace
      DOUBLE PRECISION dwork(*), iwork(*)
c
c     local variables
      INTEGER i, pisdp, pdsdp, pdsvd, pds
      DOUBLE PRECISION sum, psum, a
c
c-----------------------------------------------------------------------
c
c     initialisation
      info = 0
      epsilon = 0.0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      pisdp = 1
c     pisdp   : pointer for TESTSDP who needs (n)
c
c     Total size of iwork array ( n )
c
c     pointers for double precision work space  : dwork
c     ----------------------------------------------------------
      pdsdp = 1
c     pdsdp   : pointer for TESTSDP so (n*(2*n + 7)
      pdsvd = pdsdp + ( n*( 2*n + 7 ) )
c     pdsvd  : pointer for SVD so (9*n)
      pds   = pdsvd + ( 9*n )
c     pds    : pointer for eigenvalues so (n)
c
c     Total size of work array = ( n*(2*n + 17) )
c
c-----------------------------------------------------------------------
c
c     test if n >= 2
       IF (n .LT. 2) THEN
        info = -2
        RETURN
       ENDIF
c
c     covariance matrix SDP test
      CALL TESTSDP (n, cov, iwork(pisdp), dwork(pdsdp), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     singular value decomposition (svd) of cov. matrix
c     A = U * Diag(S) * VT
      CALL svd ( n, n, cov, dwork(pdsvd),
     &           dwork(pdsdp), dwork(pdsdp + (n*n)), dwork(pds), info)
c      CALL eigenvd (n, cov, dwork(pdsvd), dwork(pds), dwork(pdsdp),info)
c
c     sum of eigenvalues
      sum =0.0
      DO i = 1,n
        sum = sum + dwork(pds + i - 1)
      ENDDO
      a    = exvar*sum
      psum = dwork(pds)
c
c     test if lambda(max) > exvar*sum
c     the % variance is too small (risk overestimated)
      IF (psum .GT. a) THEN
        epsilon = psum
        info    =  1301
        RETURN
      ENDIF
c
c     compute optimal espsilon
      DO i = 2,n
        psum = psum + dwork(pds + i - 1)
        IF (psum .GT. a) THEN
            epsilon = dwork(pds + i - 1)
c           test % variance is too large
            IF (i .EQ. n) THEN
                info = 1302
            ENDIF
            RETURN
        ENDIF
      ENDDO
c
c     test % variance is too large
      IF (psum .LT. a) THEN
        epsilon = dwork(pds + n - 1)
        info = 1302
      ENDIF
c
      RETURN
      END


!>  This module implements the models, source terms, and equation set for
!!  computing an approximate wall-distance field using by solving a p-Poisson
!!  equation within the DG-Chimera framework.
!!
!!  OVERVIEW:
!!  ---------
!!  This approach extends prior work that used regular Poisson equations to compute
!!  an approximate wall distance field. The prior work using Poisson equations is published
!!  largely by Paul Tucker. The Poisson-based approach is not as accurate as some
!!  other approaches, but is easy to implement.
!!      Tucker, et al. "Transport Equation Based Wall Distance Computations Aimed at
!!                      Flows With Time-Dependent Geometry," NASA/TM-2003-212680
!!
!!  Tucker investigates some other methods based on Hamilton-Jacobi equations as well.
!!  Hamilton-Jacobi equations are not directly discretizable in a DG framework.
!!
!!  The approach taken here follows the work by Belyaev and Fayolle.
!!      Belyaev, et al. "On Variational and PDE-based Distance Function Approximations,"
!!                       COMPUTER GRAPHICS, Vol. 34, No. 8, 2015, pp. 104-118.
!!
!!  Belyaev, et al. extended the Poisson approach by using a p-Laplacian operator
!!  to create a p-Poisson equation. This has the property, that as 'p' goes to infinity,
!!  the solution of this equation satisfies the distance field. The benefit is that
!!  the approach is easy to implement, and can be made as accurate as one wants by
!!  increasing 'p' in the governing equation.
!!
!!
!!  EQUATIONS:
!!  ----------
!!
!!  Scalar equation:
!!      - working variable(u)
!!      - parameter(p)
!!
!!  div( |grad(u)|**(p-2) * grad(u) ) = 1
!!
!!
!!  Here, |grad(u)|**(p-2) is some norm of the gradient of 'u'. For the p-Laplacian it is:
!!
!!      |grad(u)|**(p-2) = (dudx**2  +  dudy**2  +  dudz**2)**(p-2/2)
!!
!!  This can be thought of as just a nonlinear diffusion coefficient in our original
!!  scalar diffusion equation:
!!      div( mu(u) * grad(u) ) = 1
!!
!!  To implement this, we can reuse the scalar diffusion operators that have already
!!  been implemented:
!!      - Scalar Diffusion Boundary Average Operator
!!      - Scalar Diffusion Volume Operator
!!      - Scalar Diffusion BC Operator
!!
!!  We need to implement the nonlinear diffusion coefficient model for mu(u):
!!      - Implement p-laplacian diffusion coefficient model. Used by
!!        scalar diffusion operators.
!!
!!  We need to implement the source term:
!!      - Implement new operator (S=1)
!!
!!
!!  In the end, we build a new equation set by composing the standard scalar
!!  diffusion operators with the p-laplacian model and a unit source term.
!!
!!
!----------------------------------------------------------------------------------------
module eqn_wall_distance
#include <messenger.h>
    use mod_constants,         only: ZERO, ONE, TWO, THREE
    use type_equation_set,     only: equation_set_t
    use type_equation_builder, only: equation_builder_t
    use type_chidg_worker,      only: chidg_worker_t
    use type_properties,        only: properties_t
    use type_operator,          only: operator_t
    use type_model,             only: model_t
    use mod_operators,          only: operator_factory
    use mod_models,             only: model_factory
    use DNAD_D
    use ieee_arithmetic
    implicit none

    !>  A builder for an approximate Wall Distance equation set based on a p-Poisson equation.
    !!
    !!  Build using the standard scalar diffusion operators:
    !!      Scalar Diffusion Boundary Average Operator
    !!      Scalar Diffusion Volume Operator
    !!      Scalar Diffusion BC Operator
    !!
    !!  Use the p-Laplace model implemented in this file:
    !!      p-Laplace
    !!
    !!  Use the Source term(S = 1.0) implemented in this file:
    !!      Wall Distance Source
    !!
    !!  @author Nathan A. Wukie
    !!  @date   11/16/2016
    !!
    !------------------------------------------------------------------------------------------
    type, extends(equation_builder_t), public :: wall_distance

    contains
        procedure   :: init
        procedure   :: build
    end type wall_distance
    !******************************************************************************************

    !>  A new diffusion coefficient model for the scalar equations. This facilitates
    !!  the implementation of a p-Laplace operator, which is like a normal
    !!  laplace operator, but with a nonlinear diffusion coefficient:
    !!
    !!      dif(mu * grad(u))
    !!
    !!  where
    !!
    !!      mu = (dudx**2 + dudy**2 + dudz**2)**((p-2)/2)
    !!
    !!  and 'p' is the p-Laplace parameter.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   9/30/2016
    !!
    !------------------------------------------------------------------------------------------
    type, extends(model_t), public :: p_laplace_model

    contains
        procedure   :: init    => init_model
        procedure   :: compute => compute_model
    end type p_laplace_model
    !******************************************************************************************

    !>  A source term in the p-Poisson equation for computing Wall Distance.
    !!
    !!  S = 1.0
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   8/19/2016
    !!
    !------------------------------------------------------------------------------------------
    type, extends(operator_t), public :: wall_distance_source_t

    contains
        procedure   :: init    => init_source
        procedure   :: compute => compute_source
    end type wall_distance_source_t
    !******************************************************************************************

    !>  Parameter 'p' in the p-Poisson equation
    !!
    !!   p=2 :: linear Poisson equation
    !!   p>2 :: nonlinear p-Poisson equation
    !!
    !!  Default: p=2
    !!
    !! Procedures:
    !!   set_p_poisson_parameter
    !!   get_p_poisson_parameter
    !!
    !------------------------------------------
    real(rk)    :: p           = 2._rk
    real(rk)    :: p_min       = 2._rk
    real(rk)    :: p_max       = 6._rk
    real(rk)    :: p_increment = 0.5_rk
    real(rk)    :: p_sub_rtol  = 1.e-2_rk
    integer(ik) :: p_sub_nmax  = 3
    real(rk)    :: zero_tol    = 1.e-12_rk
    logical     :: destruction = .false.

contains

    !---------------------------------------------------------------------------------------
    !
    !                   Scalar Diffusion Coefficient Model : p-Laplacian
    !
    !---------------------------------------------------------------------------------------

    !>  Initialize the model with a name and the model fields it is contributing to.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/5/2016
    !!
    !---------------------------------------------------------------------------------------
    subroutine init_model(self)
        class(p_laplace_model), intent(inout)   :: self

        call self%set_name('p-Laplace')
        call self%set_dependency('f(Grad(Q))')
        call self%add_model_field('Scalar Diffusion Coefficient')

    end subroutine init_model
    !***************************************************************************************

    !>  Compute a p-Laplace diffusion coefficient.
    !!
    !!  In the scalar diffusion equation:
    !!      dif(mu * grad(u)) = S
    !!
    !!  The p-Laplace equation is given by defining the diffusion coefficient as:
    !!      mu = (dudx**2 + dudy**2 + dudz**2)**((p-2)/2)
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/5/2016
    !!
    !--------------------------------------------------------------------------------------
    subroutine compute_model(self,worker)
        class(p_laplace_model),     intent(in)      :: self
        type(chidg_worker_t),       intent(inout)   :: worker

        type(AD_D), dimension(:),   allocatable :: &
            u, grad1_u, grad2_u, grad3_u, sumsqr, mu

        real(rk)    :: eps = 1.e-6_rk

        ! Interpolate solution to quadrature nodes
        u       = worker%get_field('u', 'value')
        grad1_u = worker%get_field('u', 'grad1')
        grad2_u = worker%get_field('u', 'grad2')
        grad3_u = worker%get_field('u', 'grad3')

        ! Square components of gradient and sum
        sumsqr = grad1_u*grad1_u  +  grad2_u*grad2_u  +  grad3_u*grad3_u

        ! Compute diffusion coefficient
        mu = (eps + sumsqr)**((p-TWO)/TWO)

        call worker%store_model_field('Scalar Diffusion Coefficient','value',mu)

    end subroutine compute_model
    !***************************************************************************************

    !-----------------------------------------------------------------------------------------
    !
    !                Methods implementing the Wall Distance Source term
    !
    !-----------------------------------------------------------------------------------------

    !>  Initialize Wall Distance source term.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   8/29/2016
    !!
    !-----------------------------------------------------------------------------------------
    subroutine init_source(self)
        class(wall_distance_source_t),   intent(inout)      :: self

        integer :: file_unit, msg
        logical :: file_exists
        namelist /distance/ p, p_max, p_increment, destruction, p_sub_rtol, p_sub_nmax, zero_tol

        ! Set operator name
        call self%set_name("Wall Distance Source")
        call self%set_operator_type("Volume Advective Source")
        call self%add_primary_field("u")

        inquire(file='distance.nml', exist=file_exists)
        if (file_exists) then
            open(newunit=file_unit,form='formatted',file='distance.nml')
            read(file_unit,nml=distance,iostat=msg)
            close(file_unit)
        end if

    end subroutine init_source
    !******************************************************************************************

    !>  Implement Wall Distance source term.
    !!
    !!  S = 1.0
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   8/19/2016
    !!
    !------------------------------------------------------------------------------------------
    subroutine compute_source(self,worker,prop)
        class(wall_distance_source_t),      intent(inout)   :: self
        type(chidg_worker_t),               intent(inout)   :: worker
        class(properties_t),                intent(inout)   :: prop

        type(AD_D), allocatable, dimension(:)   :: source

        ! Interpolate solution to quadrature nodes to initialize derivatives
        source = worker%get_field('u','value','element')
        source = ONE

        ! Integrate volume flux
        call worker%integrate_volume_source('u',source)

    end subroutine compute_source
    !*******************************************************************************************

    !-----------------------------------------------------------------------------------------
    !
    !                Methods implementing the Wall Distance equation builder.
    !
    !-----------------------------------------------------------------------------------------

    !>  Wall Distance builder initialization.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   8/30/2016
    !!
    !-----------------------------------------------------------------------------------------
    subroutine init(self)
        class(wall_distance),   intent(inout)  :: self

        call self%set_name('Wall Distance : p-Poisson')

    end subroutine init
    !*****************************************************************************************

    !>  Build a p-Poisson equation.
    !!
    !!  This substitutes the standard Laplace operator in the Poisson equation
    !!  with a p-Laplace operator, creating a p-Poisson equation.
    !!
    !!  A nice property of the p-Poisson equation is that as 'p' goes to infinity,
    !!  the solution approaches the distance field, satisfying the Eikonal equation.
    !!  This allows one to obtain approximate distance fields, selecting the fidelity
    !!  of the approximation that is required.
    !!
    !!  The practical implementation of this is to create a new nonlinear diffusion
    !!  coefficient model that will then be used in the regular scalar diffusion equation.
    !!  A source term is also implemented so that the equation is an approximation of the
    !!  distance field.
    !!
    !!
    !!  @author Nathan A. Wukie
    !!  @date   11/16/2016
    !!
    !-----------------------------------------------------------------------------------------
    function build(self,blueprint) result(wall_distance_eqn)
        class(wall_distance),   intent(in)  :: self
        character(*),           intent(in)  :: blueprint

        character(:),   allocatable     :: user_msg
        type(equation_set_t)            :: wall_distance_eqn
        type(p_laplace_model)           :: p_laplace
        type(wall_distance_source_t)    :: wall_distance_source

        ! Register p-Poisson model and wall distance source term
        call model_factory%register(p_laplace)
        call operator_factory%register(wall_distance_source)

        ! Set equationset name.
        call wall_distance_eqn%set_name("Wall Distance : p-Poisson")

        ! Add spatial operators
        select case (trim(blueprint))

            case('default')
                ! Add the operators for the standard scalar diffusion equation:
                !   div(mu*grad(u)) = 0
                call wall_distance_eqn%add_operator("Scalar Diffusion Boundary Average Operator")
                call wall_distance_eqn%add_operator("Scalar Diffusion Volume Operator")
                call wall_distance_eqn%add_operator("Scalar Diffusion BC Operator")

                ! Add a definition for mu
                call wall_distance_eqn%add_model('p-Laplace')

                ! Add a source term (S=1)
                call wall_distance_eqn%add_operator("Wall Distance Source")

            case default
                user_msg = "build_wall_distance: I didn't recognize the construction &
                            parameter that was passed to build the equation set."
                call chidg_signal_one(FATAL,user_msg, blueprint)

        end select

    end function build
    !*****************************************************************************************

    !>  Set the 'p' parameter in the p-Poisson equation.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   11/16/2016
    !!
    !-----------------------------------------------------------------------------------------
    subroutine set_p_poisson_parameter(p_in)
        real(rk),   intent(in)  :: p_in

        p = p_in

    end subroutine set_p_poisson_parameter
    !*****************************************************************************************

    !>  Get the 'p' parameter in the p-Poisson equation.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   11/16/2016
    !!
    !-----------------------------------------------------------------------------------------
    function get_p_poisson_parameter() result(p_out)
        real(rk)    :: p_out

        p_out = p

    end function get_p_poisson_parameter
    !*****************************************************************************************

end module eqn_wall_distance


      subroutine locate(vardp,layern,flyern,tpbtfg)
c
c     +++PURPOSE+++
c     This is a subroutines to locate the soil layer and finer soil layer number
c     of certain depth.
c     Each soil layer was divided into 10 thin layers for frost simulation.
c     In the tillage zone (top two 10cm thick soil layers) the fine layer thickness is 1 cm.
c     While in the untilled zone (20cm thick each layer) the fine layer thickness is 2cm.
c
c     Authors(s):  Shuhui Dun, WSU
c     Date: 02/22/2008
c     Verified by: Joan Wu, WSU
c
c     ----------------------------------------------
c
c     +++ARGUMENT DECLARATIONS+++
      integer layern,flyern,tpbtfg
      real vardp
c
c     +++ARGUMENT DEFINITIONS+++
c     layerN - soil layer number
c     flyerN - finer soil layer number
c     tpbtfg - a flag for  start point or ending point is required,
c              0 for starting point and 1 for ending point.
c     vardp  - depth variable
c
c     +++PARAMETERS+++
      include 'pmxtil.inc'
      include 'pmxtls.inc'
      include 'pmxpln.inc'
      include 'pmxhil.inc'
      include 'pmxnsl.inc'
c
c     +++COMMON BLOCKS+++
      include 'cflgfs.inc'
      include  'cwater.inc'
      include  'cstruc.inc'
c     fine layer for frost simulation
c
c     +++LOCAL VARIABLES+++
c
      real tmpvr1,tmpvr2,tmpvr3,fthick
c
c     + + + DATA INITIALIZATIONS + + +

c     convert depth from cm to mm
      tmpvr1 = vardp *1000

c
c     minimum depth is 10mm
      if (tmpvr1 .lt. 10.) then
           layerN = 1
           flyern = 1
           return
      endif
c
c     The top 2 layers (20cm) are each 10cm deep
      if (tmpvr1.lt.200) then
c     In the tillage layer soil layer depth is 10 cm.
           layern = int(tmpvr1/100.) + 1
           tmpvr2 = mod(tmpvr1,100.)
c          normally soil layer thickness will be 10cm, except
c          for last layer. nfine() should be set to less fine layers for the last
c          partial layer.
           fthick = (dg(layern,iplane)*1000)/nfine(layern)
           flyern = int(tmpvr2/fthick) + 1
           tmpvr3 = mod(tmpvr2,fthick)
      else
c     Below the tillage layer soil layer depth is 20cm
           layern = int(tmpvr1/200.) + 2
           tmpvr2 = mod(tmpvr1,200.)
c          normally soil layer thickness will be 20cm, except
c          for last layer. nfine() should be set to less fine layers for the last
c          partial layer.
           fthick = (dg(layern,iplane)*1000)/nfine(layern)
           flyern = int(tmpvr2/fthick) + 1
           tmpvr3 = mod(tmpvr2,fthick)
      endif
c
      if(tpbtfg.eq.1) then
c     Ending point is different than the starting point at soil layer division
          if (abs(tmpvr2).lt.1.0) then
             layern = layern - 1
             flyern = nfine(layern)
           elseif (abs(tmpvr3).lt.1.0) then
             flyern = flyern -1
           endif
      endif
c
      return
      end


Real Function pipik(srt)
  Real xarray(5), earray(5)
  Save
  Data xarray/0.001, 0.7, 1.5, 1.7, 2.0/
  Data earray/1., 1.2, 1.6, 2.0, 2.4/
  pmass = 0.9383
  pipik = 0.
  If (srt<=1.) Return
  If (srt>2.4) Then
    pipik = 2.0/2.
    Return
  End If
  If (srt<earray(1)) Then
    pipik = xarray(1)/2.
    Return
  End If
  Do ie = 1, 5
    If (earray(ie)==srt) Then
      pipik = xarray(ie)
      Goto 10
    Else If (earray(ie)>srt) Then
      ymin = alog(xarray(ie-1))
      ymax = alog(xarray(ie))
      xmin = alog(earray(ie-1))
      xmax = alog(earray(ie))
      pipik = exp(ymin+(alog(srt)-xmin)*(ymax-ymin)/(xmax-xmin))
      Goto 10
    End If
  End Do
  10 pipik = pipik/2.
  Continue
  Return
End Function pipik


!=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2011 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================

! This module contains a few 'generic' FFT routines, making the
! 2DECOMP&FFT library not dependent on any external libraries

module glassman

  use decomp_2d, only : mytype

  implicit none

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Following is a FFT implementation based on algorithm proposed by
  ! Glassman, a general FFT algorithm supporting arbitrary input length.
  !
  ! W. E. Ferguson, Jr., "A simple derivation of Glassman general-n fast
  ! Fourier transform," Comput. and Math. with Appls., vol. 8, no. 6, pp.
  ! 401-411, 1982.
  !
  ! Original implemtation online at http://www.jjj.de/fft/fftpage.html
  !
  ! Updated
  !  -  to handle double-precision as well
  !  -  unnecessary scaling code removed
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  SUBROUTINE SPCFFT(U,N,ISIGN,WORK)

    IMPLICIT NONE

    LOGICAL :: INU
    INTEGER :: A,B,C,N,I,ISIGN
    COMPLEX(mytype) :: U(*),WORK(*)

    A = 1
    B = N
    C = 1
    INU = .TRUE.

    DO WHILE ( B .GT. 1 )
       A = C * A
       C = 2
       DO WHILE ( MOD(B,C) .NE. 0 )
          C = C + 1
       END DO
       B = B / C
       IF ( INU ) THEN
          CALL SPCPFT (A,B,C,U,WORK,ISIGN)
       ELSE
          CALL SPCPFT (A,B,C,WORK,U,ISIGN)
       END IF
       INU = ( .NOT. INU )
    END DO

    IF ( .NOT. INU ) THEN
       DO I = 1, N
          U(I) = WORK(I)
       END DO
    END IF

    RETURN
  END SUBROUTINE SPCFFT

  SUBROUTINE SPCPFT( A, B, C, UIN, UOUT, ISIGN )

    IMPLICIT NONE

    INTEGER :: ISIGN,A,B,C,IA,IB,IC,JCR,JC

    DOUBLE PRECISION :: ANGLE

    COMPLEX(mytype) :: UIN(B,C,A),UOUT(B,A,C),DELTA,OMEGA,SUM

    ANGLE = 6.28318530717958_mytype / REAL( A * C, kind=mytype )
    OMEGA = CMPLX( 1.0, 0.0, kind=mytype )

    IF( ISIGN .EQ. 1 ) THEN
       DELTA = CMPLX( DCOS(ANGLE), DSIN(ANGLE), kind=mytype )
    ELSE
       DELTA = CMPLX( DCOS(ANGLE), -DSIN(ANGLE), kind=mytype )
    END IF

    DO IC = 1, C
       DO IA = 1, A
          DO IB = 1, B
             SUM = UIN( IB, C, IA )
             DO JCR = 2, C
                JC = C + 1 - JCR
                SUM = UIN( IB, JC, IA ) + OMEGA * SUM
             END DO
             UOUT( IB, IA, IC ) = SUM
          END DO
          OMEGA = DELTA * OMEGA
       END DO
    END DO

    RETURN
  END SUBROUTINE SPCPFT

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! A 3D real-to-complex routine implemented using the 1D FFT above
  !   Input:   nx*ny*nz real numbers
  !   Output:  (nx/2+1)*ny*nz complex numbers
  ! Just like big FFT libraries (such as FFTW) do
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine glassman_3d_r2c(in_r,nx,ny,nz,out_c)

    implicit none

    integer, intent(IN) :: nx,ny,nz
    real(mytype), dimension(nx,ny,nz) :: in_r
    complex(mytype), dimension(nx/2+1,ny,nz) :: out_c

    complex(mytype), allocatable, dimension(:) :: buf, scratch
    integer :: maxsize, i,j,k

    maxsize = max(nx, max(ny,nz))
    allocate(buf(maxsize))
    allocate(scratch(maxsize))

    ! ===== 1D FFTs in X =====
    do k=1,nz
       do j=1,ny
          ! Glassman's 1D FFT is c2c only,
          ! needing some pre- and post-processing for r2c
          ! pack real input in complex storage
          do i=1,nx
             buf(i) = cmplx(in_r(i,j,k),0._mytype, kind=mytype)
          end do
          call spcfft(buf,nx,-1,scratch)
          ! simply drop the redundant part of the complex output
          do i=1,nx/2+1
             out_c(i,j,k) = buf(i)
          end do
       end do
    end do

    ! ===== 1D FFTs in Y =====
    do k=1,nz
       do i=1,nx/2+1
          do j=1,ny
             buf(j) = out_c(i,j,k)
          end do
          call spcfft(buf,ny,-1,scratch)
          do j=1,ny
             out_c(i,j,k) = buf(j)
          end do
       end do
    end do

    ! ===== 1D FFTs in Z =====
    do j=1,ny
       do i=1,nx/2+1
          do k=1,nz
             buf(k) = out_c(i,j,k)
          end do
          call spcfft(buf,nz,-1,scratch)
          do k=1,nz
             out_c(i,j,k) = buf(k)
          end do
       end do
    end do

    deallocate(buf,scratch)

    return
  end subroutine glassman_3d_r2c

end module glassman