! subroutine solar
!subroutine solar(alat,along,iyear,imonth,iday,tt,solar_zen,sazi)
SUBROUTINE solar(alat,along,century,tt,solar_zen,sazi)
!   program used to calculate solar angle using NOAA method
!   it is more accurate and using julian day
!   the program is written by Fuqin Li in 2010

!   * Re-written as an indepentent subroutine by JS, Aug 2014

!   Inputs:
!       alat
!       along
!       century
!       tt

!   Outputs:
!       solar_zen
!       sazi

    use sys_variables, only : pi, d2r, r2d

    implicit none

    double precision, intent(in) :: alat, along
    double precision, intent(in) :: century, tt
    real, intent(out) :: solar_zen, sazi
    double precision geom_ss
    double precision sun_long, sun_anom, eccent, sun_eqc
    double precision sun_truelong, sun_trueanom
    double precision sun_rad, sun_app, ecliptic_mean
    double precision obliq_corr, sun_asc, sun_declin
    double precision vary, eq_time, suntime_true, hangle
    double precision solar_zen1, solar_ele1, atmo
    double precision solar_ele, sss, ss_time

    geom_ss = 280.46646d0+century*(36000.76983d0+century*0.0003032d0)
    sun_long = dmod(geom_ss,360d0)
    sun_anom = 357.52911d0+century*(35999.05029d0-0.0001537d0*century)
    eccent = 0.016708634d0-century*(0.000042037d0+0.0001537d0*century)

    sun_eqc = sin(sun_anom*d2r)*(1.914602d0-century*(0.004817d0+ &
      0.000014d0*century))+sin(2*sun_anom*d2r)*(0.019993d0-0.000101d0* &
      century)+sin(3*sun_anom*d2r)*0.000289d0

    sun_truelong = sun_long+sun_eqc
    sun_trueanom = sun_anom+sun_eqc

    sun_rad = (1.000001018d0*(1-eccent**2))/(1+eccent* &
      cos(sun_trueanom*d2r))

    sun_app = sun_truelong-0.00569d0-0.00478d0*sin(d2r*(125.04- &
      1937.136d0*century))

    ecliptic_mean = 23.0+(26.0+((21.448-century*(46.815+century* &
      (0.00059d0-century*0.001813d0))))/60.0)/60.0

    obliq_corr = ecliptic_mean+0.00256*cos((125.04-1934.136*century)* &
      d2r)

    sun_asc = r2d*(atan2(cos(sun_app*d2r),cos(obliq_corr*d2r)* &
      sin(sun_app*d2r)))

    sun_declin = r2d*(asin(sin(obliq_corr*d2r)*sin(sun_app*d2r)))
    vary = tan(obliq_corr/2.0*d2r)**2

    eq_time = 4*r2d*(vary*sin(2.0*sun_long*d2r)-2*eccent*sin(d2r* &
      sun_anom)+ 4*eccent*vary*sin(d2r*sun_anom)*cos(2*d2r*sun_long) &
      -0.5*vary**2* sin(4*d2r*sun_long)-1.25*eccent**2*sin(2*d2r* &
      sun_anom))

    ss_time = tt*60+eq_time+4*along*r2d
    suntime_true = dmod(ss_time,1440d0)

    if (suntime_true/4.0 .ge. 0) then
        hangle = suntime_true/4.0-180
    else
        hangle = suntime_true/4.0+180
    endif

    solar_zen1 = r2d*(acos(sin(alat)*sin(d2r*sun_declin)+ &
      cos(alat)*cos(d2r*sun_declin)*cos(d2r*hangle)))

    solar_ele1 = 90.0-solar_zen1

    if (solar_ele1 .gt. 85) atmo = 0

    if (solar_ele1 .gt. 5 .and. solar_ele1 .le.85) atmo = 58.1/tan( &
      solar_ele1*d2r)-0.07/(tan(solar_ele1*d2r)**3)+0.000086d0/ &
      (tan(solar_ele1*d2r)**5)

    if (solar_ele1 .gt. -0.575 .and. solar_ele1 .le.5) atmo = &
      1735.0+solar_ele1*(-518.2+solar_ele1*(103.4+solar_ele1*(-12.79+ &
      solar_ele1*0.711)))

    if (solar_ele1 .le. -0.575 ) atmo = -20.772/tan(solar_ele1*d2r)

    atmo = atmo/3600.0
    solar_ele = solar_ele1+atmo
    solar_zen = 90-solar_ele

    if (hangle .gt. 0) then
        sss = r2d*(acos(((sin(alat)*cos(d2r*solar_zen1))-sin(d2r* &
          sun_declin))/(cos(alat)*sin(d2r*solar_zen1))))+180.0
    else
        sss = 540.0-r2d*(acos(((sin(alat)*cos(d2r*solar_zen1))- &
          sin(d2r*sun_declin))/(cos(alat)*sin(d2r*solar_zen1))))
    endif

    sazi = dmod(sss,360d0)

    return

END SUBROUTINE solar


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief Jacobian calculation

module hecmw_Jacob341
contains

  subroutine hecmw_Jacob_341 ( hecMESH, iElem, DET, W, N, NX, NY, NZ)
    use hecmw_util
    implicit none

    type(hecmwST_local_mesh):: hecMESH
    integer(kind=kint)::       iElem
    real(kind=kreal)::         DET
    real(kind=kreal)::         W(4),N(4,4),NX(4,4),NY(4,4),NZ(4,4)

    integer(kind=kint):: i, ii, j, iLocal
    real(kind=kreal):: DUM
    real(kind=kreal):: XX(4), YY(4), ZZ(4)
    real(kind=kreal):: NR(4), NS(4), NT(4)
    real(kind=kreal):: Jacob(3,3), Jinv(3,3)
    real(kind=kreal),parameter:: alpha = 0.58541020, beta = 0.13819660

    !!
    !! ******** Set values of coordinates********
    !!
    do i = 1, 4
      ii = 4 - i
      iLocal = hecMESH%elem_node_item( 4*iElem -ii )
      XX(i) = hecMESH%node( iLocal*3 -2 )
      YY(i) = hecMESH%node( iLocal*3 -1 )
      ZZ(i) = hecMESH%node( iLocal*3    )
      W(i)  = 0.25D0
    end do

    !!
    !! ******** Set values to shape functions ********
    !!
    N(1,1) = alpha
    N(2,1) = beta
    N(3,1) = beta
    N(4,1) = beta

    N(1,2) = beta
    N(2,2) = alpha
    N(3,2) = beta
    N(4,2) = beta

    N(1,3) = beta
    N(2,3) = beta
    N(3,3) = alpha
    N(4,3) = beta

    N(1,4) = beta
    N(2,4) = beta
    N(3,4) = beta
    N(4,4) = alpha
    !!
    !! ******** Derivative of shape functions ********
    !!
    !! ----------- For R-Coordinate -------------
    NR(1) = 1.0
    NR(2) = 0.0
    NR(3) = 0.0
    NR(4) =-1.0
    !! ----------- For S-Coordinate -------------
    NS(1) = 0.0
    NS(2) = 1.0
    NS(3) = 0.0
    NS(4) =-1.0
    !! ----------- For T-Coordinate -------------
    NT(1) = 0.0
    NT(2) = 0.0
    NT(3) = 1.0
    NT(4) =-1.0
    !!
    !! ******** Jacobi matrix calculation********
    !!
    Jacob(1,1) = NR(1)*XX(1)+NR(2)*XX(2)+NR(3)*XX(3)+NR(4)*XX(4)
    Jacob(2,1) = NS(1)*XX(1)+NS(2)*XX(2)+NS(3)*XX(3)+NS(4)*XX(4)
    Jacob(3,1) = NT(1)*XX(1)+NT(2)*XX(2)+NT(3)*XX(3)+NT(4)*XX(4)
    Jacob(1,2) = NR(1)*YY(1)+NR(2)*YY(2)+NR(3)*YY(3)+NR(4)*YY(4)
    Jacob(2,2) = NS(1)*YY(1)+NS(2)*YY(2)+NS(3)*YY(3)+NS(4)*YY(4)
    Jacob(3,2) = NT(1)*YY(1)+NT(2)*YY(2)+NT(3)*YY(3)+NT(4)*YY(4)
    Jacob(1,3) = NR(1)*ZZ(1)+NR(2)*ZZ(2)+NR(3)*ZZ(3)+NR(4)*ZZ(4)
    Jacob(2,3) = NS(1)*ZZ(1)+NS(2)*ZZ(2)+NS(3)*ZZ(3)+NS(4)*ZZ(4)
    Jacob(3,3) = NT(1)*ZZ(1)+NT(2)*ZZ(2)+NT(3)*ZZ(3)+NT(4)*ZZ(4)

    DET = Jacob(1,1) * Jacob(2,2) * Jacob(3,3)   &
      &         + Jacob(1,2) * Jacob(2,3) * Jacob(3,1)   &
      &         + Jacob(1,3) * Jacob(2,1) * Jacob(3,2)   &
      &         - Jacob(1,3) * Jacob(2,2) * Jacob(3,1)   &
      &         - Jacob(1,2) * Jacob(2,1) * Jacob(3,3)   &
      &         - Jacob(1,1) * Jacob(2,3) * Jacob(3,2)
    !!
    !! ******** Inverse Jacobi matrix calculation ********
    !!
    DUM = 1.0 / DET
    Jinv(1,1) = DUM*(  Jacob(2,2)*Jacob(3,3) -Jacob(2,3)*Jacob(3,2) )
    Jinv(2,1) = DUM*( -Jacob(2,1)*Jacob(3,3) +Jacob(2,3)*Jacob(3,1) )
    Jinv(3,1) = DUM*(  Jacob(2,1)*Jacob(3,2) -Jacob(2,2)*Jacob(3,1) )
    Jinv(1,2) = DUM*( -Jacob(1,2)*Jacob(3,3) +Jacob(1,3)*Jacob(3,2) )
    Jinv(2,2) = DUM*(  Jacob(1,1)*Jacob(3,3) -Jacob(1,3)*Jacob(3,1) )
    Jinv(3,2) = DUM*( -Jacob(1,1)*Jacob(3,2) +Jacob(1,2)*Jacob(3,1) )
    Jinv(1,3) = DUM*(  Jacob(1,2)*Jacob(2,3) -Jacob(1,3)*Jacob(2,2) )
    Jinv(2,3) = DUM*( -Jacob(1,1)*Jacob(2,3) +Jacob(1,3)*Jacob(2,1) )
    Jinv(3,3) = DUM*(  Jacob(1,1)*Jacob(2,2) -Jacob(1,2)*Jacob(2,1) )

    do i = 1, 4
      do j = 1, 4

        NX(i,j) = Jinv(1,1)*NR(i) + Jinv(1,2)*NS(i) +Jinv(1,3)*NT(i)
        NY(i,j) = Jinv(2,1)*NR(i) + Jinv(2,2)*NS(i) +Jinv(2,3)*NT(i)
        NZ(i,j) = Jinv(3,1)*NR(i) + Jinv(3,2)*NS(i) +Jinv(3,3)*NT(i)

      end do
    end do

  end subroutine hecmw_Jacob_341

end module hecmw_Jacob341


Module hssw_structure
  Use hs_structure
  Use math_constants
  Use quadratures
  Implicit None
  Contains

    !Function that calculates the direct correlation function of a
    !Square Well System using Sharma-Sharma approximation Scheme and Verlet-Weiss
    !for the hard core part
    ! c(k,ϕ,λ)
    !wave-vector "k" for "k>=0"
    !density "ϕ" for "ϕ>0"
    !temperature "T" for "T>0"
    !square well range "λ>1"
    Function c_hssw_shvw_aux(phi,T,lambda,k) result(c_aux)
      Implicit None
      Real * 8, Intent(in) :: phi !Volume fraction value
      Real * 8, Intent(in) :: T !Temperature
      Real * 8, Intent(in) :: lambda !square well range
      Real * 8, Intent (in) :: k !Value of the wave vector
      Real * 8 :: c_aux
      Real * 8 :: k_func,ckdum,chs
      Real * 8 :: k2,lk,l5,l3
      chs = c_hs_vw(phi,k)
      k2 = k * k
      if (k > 0.075d0) then
        lk = lambda * k
        c_aux = ((cos(k) - lambda * cos(lk)) / k) + ((sin(lk) - sin(k)) / k2)
        c_aux = c_aux / k
      else
        l3 = lambda ** 3
        l5 = lambda ** 5
        c_aux = (1.d0/3.d0) * (l3 - 1.d0) - (1.d0/30.d0) * (l5 - 1.d0) * k2
      end if
      c_aux = 4.d0 * pi * c_aux / T
      return
    End Function

  !Function that calculates the direct correlation function of a Hard Sphere +
  !Square Well System using Sharma-Sharma approximation Scheme and Verlet-Weiss
  !for the hard core part
  ! c(k,ϕ,λ)
  !wave-vector "k" for "k>=0"
  !density "ϕ" for "ϕ>0"
  !temperature "T" for "T>0"
  !square well range "λ>1"
  Function c_hssw_shvw(phi,T,lambda,k) result(c)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent(in) :: T !Temperature
    Real * 8, Intent(in) :: lambda !square well range
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: c
    Real * 8 :: chs
    chs = c_hs_vw(phi,k)
    c = chs + c_hssw_shvw_aux(phi,T,lambda,k)
    return
  End Function

  !Function that calculates the inverse structure factor of a Hard Sphere +
  !Square Well System using Sharma-Sharma approximation Scheme and Verlet-Weiss
  ! 1/S(k,ϕ,λ)
  !wave-vector "k" for "k>=0"
  !density "ϕ" for "ϕ>0"
  !temperature "T" for "T>0"
  !square well range "λ>1"
  Function is_hssw_shvw(phi,T,lambda,k) result(is)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent(in) :: T !Temperature
    Real * 8, Intent(in) :: lambda !square well range
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: is,phi_vw, chs
    phi_vw = phi*(1.d0 - (phi / 16.d0))
    chs = c_hs_vw(phi,k)
    is = (phi_vw * chs) + (phi * c_hssw_shvw_aux(phi,T,lambda,k))
    is = 1.d0 - 6.d0 * is / pi
    return
  End Function

  !Function that calculates the structure factor of a Hard Sphere +
  !Square Well System using Sharma-Sharma approximation Scheme and Verlet-Weiss
  ! S(k,ϕ,λ)
  !wave-vector "k" for "k>=0"
  !density "ϕ" for "ϕ>0"
  !temperature "T" for "T>0"
  !square well range "λ>1"
  Function s_hssw_shvw(phi,T,lambda,k) result(s)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent(in) :: T !Temperature
    Real * 8, Intent(in) :: lambda !square well range
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: s
    s = 1.d0 / is_hssw_shvw(phi,T,lambda,k)
    return
  End Function

  !Function that calculates the spinodal temperature of a Hard sphere +
  !Square Well system using Sharma-Sharma approximation, it needs the information of:
  ! "phi" -> volume fraction of the system
  ! " lambda" -> length of the square well potential
  Function Ts_hssw_shvw(phi,lambda) result(T)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent(in) :: lambda  !length of the square well potential
    Real * 8 :: T
    T = 8.d0 * phi * (lambda ** 3 - 1) * s_hs_vw(phi,0.d0)
  End Function

  !Function that calculates the direct correlation function of a
  !Square Well System using Generalized Sharma-Sharma approximation Scheme and Verlet-Weiss
  !for the hard core part
  ! c(k,ϕ,λ)
  !wave-vector "k" for "k>=0"
  !density "ϕ" for "ϕ>0"
  !temperature "T" for "T>0"
  !square well range "λ>1"
  Function c_hssw_gsvw_aux(phi,T,lambda,k) result(c_aux)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent(in) :: T !Temperature
    Real * 8, Intent(in) :: lambda !square well range
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: c_aux
    Real * 8 :: k_func,ckdum,chs
    Real * 8 :: k2,lk,l5,l3
    k2 = k * k
    if (k > 0.075d0) then
      lk = lambda * k
      c_aux = ((cos(k) - lambda * cos(lk)) / k) + ((sin(lk) - sin(k))/k2)
      c_aux = c_aux / k
    else
      l3 = lambda ** 3
      l5 = lambda ** 5
      c_aux = (1.d0/3.d0) * (l3 - 1.d0) - (1.d0/30.d0) * (l5 - 1.d0) * k2
    end if
    c_aux = 4.d0 * pi * c_aux * ( exp(1.d0/T) - 1.d0)
    return
  End Function

  !Function that calculates the direct correlation function of a Hard Sphere +
  !Square Well System using Generalized Sharma-Sharma approximation Scheme and Verlet-Weiss
  !for the hard core part
  ! c(k,ϕ,λ)
  !wave-vector "k" for "k>=0"
  !density "ϕ" for "ϕ>0"
  !temperature "T" for "T>0"
  !square well range "λ>1"
  Function c_hssw_gsvw(phi,T,lambda,k) result(c)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent(in) :: T !Temperature
    Real * 8, Intent(in) :: lambda !square well range
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: c
    Real * 8 :: k_func,ckdum,chs
    Real * 8 :: k2,lk,l5,l3
    chs = c_hs_vw(phi,k)
    c = c_hs_vw(phi,k) + c_hssw_gsvw_aux(phi,T,lambda,k)
    return
  End Function

  !Function that calculates the inverse structure factor of a Hard Sphere +
  !Square Well System using Sharma-Sharma approximation Scheme and Verlet-Weiss
  ! 1/S(k,ϕ,λ)
  !wave-vector "k" for "k>=0"
  !density "ϕ" for "ϕ>0"
  !temperature "T" for "T>0"
  !square well range "λ>1"
  Function is_hssw_gsvw(phi,T,lambda,k) result(is)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent(in) :: T !Temperature
    Real * 8, Intent(in) :: lambda !square well range
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: is,phi_vw, chs
    phi_vw = phi*(1.d0 - (phi / 16.d0))
    chs = c_hs_vw(phi,k)
    is = (phi_vw * chs) + (phi *  c_hssw_gsvw_aux(phi,T,lambda,k))
    is = 1.d0 - 6.d0  * is / pi
    return
  End Function

  !Function that calculates the structure factor of a Hard Sphere +
  !Square Well System using Sharma-Sharma approximation Scheme and Verlet-Weiss
  ! S(k,ϕ,λ)
  !wave-vector "k" for "k>=0"
  !density "ϕ" for "ϕ>0"
  !temperature "T" for "T>0"
  !square well range "λ>1"
  Function s_hssw_gsvw(phi,T,lambda,k) result(s)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent(in) :: T !Temperature
    Real * 8, Intent(in) :: lambda !square well range
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: s
    s = 1.d0 / is_hssw_gsvw(phi,T,lambda,k)
    return
  End Function

  !Function that calculates the structure factor of a Hard Sphere +
  !Square Well System using Boltzmann approximation Scheme
  ! S(k,ϕ,λ)
  !wave-vector "k" for "k>=0"
  !density "ϕ" for "ϕ>0"
  !temperature "T" for "T>0"
  !square well range "λ>1"
  Function s_hssw_bolt(phi,T,lambda,k) result(s)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent(in) :: T !Temperature
    Real * 8, Intent(in) :: lambda !square well range
    Real * 8, Intent (in) :: k !Value of the wave vector
    Real * 8 :: s, x, lk, k3, l3
    k3=k * k * k
    x = exp(1.d0/T) - 1.d0
    lk = lambda * k
    s = 0.d0
    If (k > 0.075d0) Then
      s = sin(lk) - sin(k) + k * cos(k) - lk * cos(lk)
      s = s * x
      s = s + k * cos(k) - sin(k)
      s = s / k3
    Else
      l3 = lambda * lambda * lambda
      s = (x * (l3 - 1.d0) - 1.d0) / 3.d0
    End If
    s = 1.d0 + (24.d0 * phi * s )
    return
  End Function

  !Santos SW S(k)
  Function s_hssw_stos (phi,T,lambda,k) Result(s)
    Implicit None
    Integer :: i1
    Real * 8, Intent(in) :: phi, T, lambda, k
    Real * 8 :: s
    Real * 8 :: A0,A01,L1,L2,S1,S2,S3,sw_tau !F(t) Parameters
    Real * 8 :: alpha1,alpha2,alpha3,beta1,beta2,beta3,beta4,gamma0,gamma1,gamma2 !L2 Parameters
    Real * 8 :: Lam1,Lam2,Lam3,Lam4,Lam5,Lam6,tau1,tau2 !convenient dummies variables
    Complex * 16 :: Ftp,Ftm,Gtp,Gtm !F(t),F(-t),G(t),G(-t)
    Real * 8 :: Ftdum1,Ftdum2,Ftdum3
    real * 8 dum1,dum2,dum3
    Complex * 16 :: im
    Real * 8 dumeta
    dumeta=phi
    im=(0.d0,1.d0)
    !Allocate (Ftp(kpoints))
    !Allocate (Ftm(kpoints))
    !Allocate (Gtp(kpoints))
    !Allocate (Gtm(kpoints))
    Lam1=lambda
    Lam2=Lam1**2
    Lam3=Lam1**3
    Lam4=Lam1**4
    Lam5=Lam1**5
    Lam6=Lam1**6
    !A0
    A0=exp(1.d0/T)-1.d0
    !A0 prima
    A01=A0*((Lam1-1.d0)**2)
    !print*, "A01=",A01
    !square well tau
    sw_tau=1.d0/(12.d0*A0*Lam1*(Lam1-1.d0))
    tau1=1.d0/sw_tau
    !print*, "tau1=",tau1
    tau2=1.d0/(sw_tau**2)
    !print*, "tau2=",tau2
    !alpha 1
    alpha1=2.d0*A01*(2.d0+Lam1)+((1.d0+(4.d0*Lam1)+Lam2-3.d0*A01)*tau1/6.d0)
    !print*, "alpha1", alpha1
    !alpha2
    alpha2=3.d0+A01*(7.d0+2.d0*Lam1-3.d0*Lam2)-((7.d0+Lam1+16.d0*Lam2+A01*&
    &(23.d0+15.d0*Lam1+15.d0*Lam2+7.d0*Lam3))*tau1/12.d0)
    !print*, "alpha2", alpha2
    !alpha3
    alpha3=-2.d0-2.d0*A01*(1.d0+2.d0*Lam1+3.d0*Lam2)+((7.d0+Lam1-2.d0*Lam2+A01*&
    &(7.d0+15.d0*Lam1+21.d0*Lam2+11.d0*Lam3+6.d0*Lam4))*tau1/6.d0)
    !print*, "alpha3", alpha3
    !beta1
    beta1=-4.d0-4.d0*A01*(2.d0+Lam1)-(tau2/3.d0)+((5.d0+2.d0*Lam1-Lam2+3.d0*A01)*tau1/3.d0)
    !print*, "beta1", beta1
    !beta2
    beta2=6.d0+6.d0*A01*(3.d0+2.d0*Lam1+Lam2)+4.d0*(A01**2)*((2.d0+Lam1)**2)&
    &-((9.d0*(3.d0+Lam1)+A01*(59.d0+51.d0*Lam1+3.d0*Lam2-5.d0*Lam3)&
    &+12.d0*(A01**2)*(2.d0+Lam1))*tau1/6.d0)+((31.d0+8.d0*Lam1+18.d0*Lam2&
    &-4.d0*Lam3+Lam4+12.d0*A01*(5.d0+Lam1)+9.d0*(A01**2))*tau2/36.d0)
    !print*, "beta2", beta2
    !beta3
    beta3=-4.d0-12.d0*A01*(1.d0+Lam1+Lam2)-4.d0*(A01**2)*(2.d0+Lam1)*(1.d0&
    &+2.d0*Lam1+3.d0*Lam2)+((3.d0*(4.d0+Lam1+Lam2)+A01*(29.d0&
    &+36.d0*Lam1+30.d0*Lam2+7.d0*Lam3-3.d0*Lam4)+(A01**2)&
    &*(17.d0+43.d0*Lam1+30.d0*Lam2+Lam3-Lam4))*tau1/3.d0)-((29.d0+13.d0*Lam1&
    &+27.d0*Lam2+7.d0*Lam3-4.d0*Lam4+A01*(68.d0+80.d0*Lam1+80.d0*Lam2+16.d0*Lam3&
    &+7.d0*Lam4+Lam5)+3.d0*(A01**2)*(13.d0+13.d0*Lam1+Lam2-3.d0*Lam3))*tau2/36.d0)
    !print*, "beta3", beta3
    !beta4 BE WARE, MODIFIED FROM THE ARTICLE
    dum1=(1.d0+A01*(1.d0+2.d0*Lam1+3.d0*Lam2))**2
    dum2=2.d0*A01*(7.d0+15.d0*Lam1+15.d0*Lam2+5.d0*Lam3+6.d0*Lam4)
    dum3= A01*A01*(1.d0+2.d0*Lam1+3.d0*Lam2)*(7.d0+15.d0*Lam1+3.d0*Lam2-Lam3)
    dum2=7.d0+Lam1+4.d0*Lam2+dum2+dum3
    beta4=dum1-(dum2*tau1/6.d0)
    dum1=49.d0+38.d0*Lam1+9.d0*Lam2+8.d0*Lam3+16.d0*Lam4
    dum2=2.d0*A01*(49.d0+88.d0*Lam1+112.d0*Lam2+80.d0*Lam3+35.d0*Lam4-4.d0*Lam5)
    dum3=A01*A01*(49.d0+138.d0*Lam1+219.d0*Lam2+124.d0*Lam3+27.d0*Lam4+18.d0*Lam5+Lam6)
    dum1=dum1+dum2+dum3
    dum1=dum1*tau2/144.d0
    beta4=beta4+dum1
    !print*, "beta4",beta4
    !gamma0
    gamma0=1.d0+Lam1-(tau1/6.d0)
    !print*, "gamma0",gamma0
    !gamma1
    gamma1=2.d0*(1.d0+Lam1-Lam2)-((3.d0+Lam3)*tau1/6.d0)
    !print*, "gamma1",gamma1
    !gamma2
    gamma2=Lam1*(-4.d0*Lam1+((2.d0+3.d0*Lam1+Lam2+Lam3)*tau1/3.d0))
    !print*, "gamma2",gamma2
    !L2
    L2=-1.d0+(alpha1*dumeta)+(alpha2*dumeta**2)+(alpha3*dumeta**3)+((1.d0+2.d0*dumeta)*&
    &dsqrt(1.d0+(beta1*dumeta)+(beta2*dumeta**2)+(beta3*dumeta**3)+(beta4*dumeta**4)))
    L2=L2/(12.d0*dumeta*(gamma0+gamma1*dumeta+gamma2*dumeta**2))
    !print*, "L2",L2
    !L1
    L1=1.d0+0.5d0*dumeta+2.d0*dumeta*(1.d0+Lam1+Lam2)*L2-0.5d0*dumeta*A01*(3.d0+2.d0*Lam1+Lam2)
    L1=L1/(1.d0+2.d0*dumeta)
    !print*, "L1",L1
    !S1
    S1=(-1.5d0+2.d0*(1.d0+Lam1+Lam2)*L2-0.5d0*(3.d0+2.d0*Lam1+Lam2)*A01)!Care inconsistency
    S1=S1*(dumeta/(1.d0+2.d0*dumeta))
    !print*, "S1",S1
    !S2
    S2=(-1.d0+dumeta+2.d0*(1.d0-2.d0*dumeta*Lam1*(1.d0+Lam1))*L2-(1.d0-dumeta*((1.d0+Lam1)**2))*A01)
    S2=S2/(2.d0*(1.d0+2.d0*dumeta))
    !print*, "S2",S2
    !S3
    S3=(-(((1.d0-dumeta)**2)/(12.d0*dumeta))-(0.5d0*(Lam1+1.d0)-dumeta*Lam2)*L2)
    S3=S3+(4.d0+2.d0*Lam1-dumeta*(3.d0*Lam2+2.d0*Lam1+1.d0))*(A01/12.d0)
    S3=S3/(1.d0+2.d0*dumeta)
    !print*, "S3",S3
    !F(t)->F(ik)
    Ftdum1=L1+(L2/(Lam1-1.d0))-A0*(Lam1-1.d0)
    Ftdum2=L2/(Lam1-1.d0)
    Ftdum3=Lam1-1.d0
    !Do i1=1, kpoints
      !Ftp(i1)=CMPLX(1.d0+A0,0)+CMPLX(0.D0,Ftdum1*k(i1))-(CMPLX(A0,Ftdum2*k)*exp(CMPLX(0.d0,-Ftdum3*k)))
      !Ftp(i1)=-Ftp(i1)/CMPLX((1.d0-S2*(k**2)),(S1*k-S3*(k**3)))/(12.d0*eta)
      !Ftm(i1)=CMPLX(1.d0+A0,0)+CMPLX(0.D0,-Ftdum1*k)-(CMPLX(A0,-Ftdum2*k)*exp(CMPLX(0.d0,Ftdum3*k)))
      !Ftm(i1)=-Ftp(i1)/CMPLX(12.d0*eta*(1.d0-S2*(k**2)),-12.d0*eta*(S1*k-S3*(k**3)))
      Ftp=(1.d0+A0+Ftdum1*(im*k))-(A0+Ftdum2*(im*k))*exp(-Ftdum3*(im*k))
      Ftp=Ftp/(1.d0+(S1*(im*k))+(S2*(im*k)**2)+(S3*(im*k)**3))
      Ftp=-Ftp/(12.d0*dumeta)
      Ftm=(1.d0+A0+Ftdum1*(-im*k))-(A0+Ftdum2*(-im*k))*exp(-Ftdum3*(-im*k))
      Ftm=Ftm/(1.d0+(S1*(-im*k))+(S2*(-im*k)**2)+(S3*(-im*k)**3))
      Ftm=-Ftm/(12.d0*dumeta)
      !G(t)->G(ik)
      !Gtp(i1)=CMPLX(0.d0,k)*Ftp(i1)*exp(CMPLX(0.d0,-k))/(CMPLX(1.d0,0.d0)+12.d0*eta*Ftp(i1)*exp(CMPLX(0.d0,-k)))
      Gtp=(im*k)*Ftp*exp(-im*k)/(1.d0+12.d0*dumeta*Ftp*exp(-im*k))
      !G(-t)->G(-ik)
      !Gtm(i1)=CMPLX(0.d0,-k)*Ftm(i1)*exp(CMPLX(0.d0,k))/(CMPLX(1.d0,0.d0)+12.d0*eta*Ftm(i1)*exp(CMPLX(0.d0,k)))
      Gtm=(-im*k)*Ftm*exp(im*k)/(1.d0+12.d0*dumeta*Ftm*exp(im*k))

      s=Realpart((Gtp-Gtm)/(im*k))
      s=1.d0-(12.d0*dumeta*s)
      !s=Realpart(Gtm(i1))
    !End Do
  End Function

  !Function that calculates the spinodal temperature of a Hard sphere + Square Well
  !system using Sharma-Sharma approximation, it needs the information of:
  ! "phi" -> volume fraction of the system
  ! "lambda" -> length of the square well potential
  Function Ts_hssw_gsvw(phi,lambda) result(T)
    Implicit None
    Real * 8, Intent(in) :: phi !Volume fraction value
    Real * 8, Intent(in) :: lambda !length of the square well potential
    Real * 8 :: T
    Real * 8 :: Tshvw
    Tshvw = Ts_hssw_shvw(phi,lambda)
    T = 1.d0/log(1.d0 + (1.d0/Tshvw))
  End Function

  Function u_HSSW(r,lambda) result(u)
    Implicit None
    Real * 8, Intent(in) :: r,lambda
    Real * 8 :: u
    If ( 1.d0 <= r .and. r <= lambda) Then
      u = -1.d0
    Else
      u = 0.d0
    End If
  End Function

  Function gr_tail_hssw_gsvw(k_max,lambda,T,rho,r) result(g_tail)
    Implicit None
    Real * 8, Intent(in) :: k_max, lambda, T, rho, r !
    Real * 8 :: g_tail !
    Real * 8 :: dum1,dum2,dum3,dum4,phi,Ac1,Ac2,Ac3,As1,As2,Bc1,Bs1,A1,A2
    Real * 8 :: dumAplus,dumAminus,dumBplus,dumBminus,dumA,SiAp,SiAm,SiBp,SiBm,Sirk
    Real * 8 :: sp,sp2,sp3,sp4,sm,sm2,sm3,sm4,slp,slm
    Real * 8 :: si, ci
    phi = pi * rho / 6.d0
    phi = phi*(1.d0 - (phi / 16.d0))  !Verlet-Weiss correction
    dum1 = - ( ( 1.d0 + 2.d0 * phi ) ** 2 )
    dum2 = 6.d0 * phi * ( ( 1.d0 + ( phi / 2.d0 ) ) ** 2 )
    dum3 = - 0.5d0 * phi * ( ( 1.d0 + ( 2.d0 * phi ) ) ** 2 )
    dum4 = ( 1.d0 - phi )
    dum4 = dum4 ** 4
    dum1 = dum1 / dum4 !alpha
    dum2 = dum2 / dum4  !beta
    dum3 = dum3 / dum4  !delta
    Bs1 = exp(1.d0/T) - 1.d0
    Ac1 = Bs1 - dum1 - dum2 - dum3
    Ac2 = 2.d0 * dum2 + 12.d0 * dum3
    Ac3 = -24.d0 * dum3
    As1 = -Bs1 + dum1 + 2.d0 * dum2 + 4.d0 * dum3
    As2 = - 24.d0 * dum3
    A1 = -2 * dum2
    A2 = 24.d0 * dum3
    Bc1 = - lambda * Bs1
    sp = 1.d0 + r
    sp2 = sp * sp
    sp3 = sp2 * sp
    sp4 = sp2 * sp2
    sm = 1.d0 - r
    sm2 = sm * sm
    sm3 = sm2 * sm
    sm4 = sm2 * sm2
    slp = lambda + r
    slm = lambda - r
    dumAplus = Ac1 + (As1 * sp) - (Ac2 * sp2 / 2.d0) - (As2 * sp3 / 6.d0) + (Ac3 * sp4 / 24.d0)
    dumAminus = Ac1 + (As1 * sm) - (Ac2 * sm2 / 2.d0) - (As2 * sm3 / 6.d0) + (Ac3 * sm4 / 24.d0)
    dumBplus = Bc1 + (Bs1 * slp)
    dumBminus = Bc1 + (Bs1 * slm)
    dumA = (A2 *(r ** 4)/12.d0) - (A1*(r**2))
    call cisi(sp * k_max, ci, si)
    SiAp = (pi/2.d0) - si
    call cisi(slp * k_max, ci, si)
    SiBp = (pi/2.d0) - si
    !Conditional dependendt of r values
    SiAm = 0.d0
    SiBm = - pi / 2.d0
    !if (r == 0) SiAm =-pi/2.d0
    if (r > 1.d0) Then
      SiAm = -pi/2.d0
      if (r < lambda) SiBm = -SiBm
    End If
    call cisi(sm * k_max, ci, si)
    SiAm = SiAm - si
    call cisi(slm * k_max, ci, si)
    SiBm = SiBm - si
    !
    call cisi(r * k_max, ci, si )
    Sirk = (pi/2.d0) - si
    !g_tail = A * ( r8_si( ( 1.d0 + r) * k_max ) - r8_si( (1.d0 - r) * k_max ) )
    !g_tail = g_tail + (B * (r8_si( ( lambda - r ) * k_max ) -  r8_si( ( lambda + r ) * k_max ) ))
    !g_tail = - g_tail / (pi * r) !
    !if (r > 1 .and. r < lambda ) g_tail =  g_tail - (B / r)
    !if (r > 1) g_tail = g_tail + (A/r)
    g_tail = dumAplus * SiAp + dumBplus * SiBp - dumAminus * SiAm - dumBminus * SiBm + dumA * Sirk
    g_tail = g_tail / (pi*r)
    return
  End Function

  Function gr_tail_hssw_shvw(k_max,lambda,T,rho,r) result(g_tail)
    Implicit None
    Real * 8, Intent(in) :: k_max, lambda, T, rho, r !
    Real * 8 :: g_tail !
    Real * 8 :: dum1,dum2,dum3,dum4,phi,Ac1,Ac2,Ac3,As1,As2,Bc1,Bs1,A1,A2
    Real * 8 :: dumAplus,dumAminus,dumBplus,dumBminus,dumA,SiAp,SiAm,SiBp,SiBm,Sirk
    Real * 8 :: sp,sp2,sp3,sp4,sm,sm2,sm3,sm4,slp,slm
    Real * 8 :: si, ci
    phi = pi * rho / 6.d0
    phi = phi*(1.d0 - (phi / 16.d0))  !Verlet-Weiss correction
    dum1 = - ( ( 1.d0 + 2.d0 * phi ) ** 2 )
    dum2 = 6.d0 * phi * ( ( 1.d0 + ( phi / 2.d0 ) ) ** 2 )
    dum3 = - 0.5d0 * phi * ( ( 1.d0 + ( 2.d0 * phi ) ) ** 2 )
    dum4 = ( 1.d0 - phi )
    dum4 = dum4 ** 4
    dum1 = dum1 / dum4 !alpha
    dum2 = dum2 / dum4  !beta
    dum3 = dum3 / dum4  !delta
    Bs1 = 1.d0 / T
    Ac1 = Bs1 - dum1 - dum2 - dum3
    Ac2 = 2.d0 * dum2 + 12.d0 * dum3
    Ac3 = -24.d0 * dum3
    As1 = -Bs1 + dum1 + 2.d0 * dum2 + 4.d0 * dum3
    As2 = - 24.d0 * dum3
    A1 = -2 * dum2
    A2 = 24.d0 * dum3
    Bc1 = - lambda * Bs1
    sp = 1.d0 + r
    sp2 = sp * sp
    sp3 = sp2 * sp
    sp4 = sp2 * sp2
    sm = 1.d0 - r
    sm2 = sm * sm
    sm3 = sm2 * sm
    sm4 = sm2 * sm2
    slp = lambda + r
    slm = lambda - r
    dumAplus = Ac1 + (As1 * sp) - (Ac2 * sp2 / 2.d0) - (As2 * sp3 / 6.d0) + (Ac3 * sp4 / 24.d0)
    dumAminus = Ac1 + (As1 * sm) - (Ac2 * sm2 / 2.d0) - (As2 * sm3 / 6.d0) + (Ac3 * sm4 / 24.d0)
    dumBplus = Bc1 + (Bs1 * slp)
    dumBminus = Bc1 + (Bs1 * slm)
    dumA = (A2 *(r ** 4)/12.d0) - (A1*(r**2))
    call cisi(sp * k_max, ci, si)
    SiAp = (pi/2.d0) - si
    call cisi(slp * k_max, ci, si)
    SiBp = (pi/2.d0) - si
    !Conditional dependendt of r values
    SiAm = 0.d0
    SiBm = - pi / 2.d0
    !if (r == 0) SiAm =-pi/2.d0
    if (r > 1.d0) Then
      SiAm = -pi/2.d0
      if (r < lambda) SiBm = -SiBm
    End If
    call cisi(sm * k_max, ci, si)
    SiAm = SiAm - si
    call cisi(slm * k_max, ci, si)
    SiBm = SiBm - si
    !
    call cisi(r * k_max, ci, si )
    Sirk = (pi/2.d0) - si
    !g_tail = A * ( r8_si( ( 1.d0 + r) * k_max ) - r8_si( (1.d0 - r) * k_max ) )
    !g_tail = g_tail + (B * (r8_si( ( lambda - r ) * k_max ) -  r8_si( ( lambda + r ) * k_max ) ))
    !g_tail = - g_tail / (pi * r) !
    !if (r > 1 .and. r < lambda ) g_tail =  g_tail - (B / r)
    !if (r > 1) g_tail = g_tail + (A/r)
    g_tail = dumAplus * SiAp + dumBplus * SiBp - dumAminus * SiAm - dumBminus * SiBm + dumA * Sirk
    g_tail = g_tail / (pi*r)
    return
  End Function

  Function absc(h)
    Complex * 16, intent(in) :: h
    Real * 8 :: absc
    absc = abs(real(h)) + abs(aimag(h))
  End function

  Subroutine cisi(x,ci,si)
    Implicit None
    Real * 8, intent(in) :: x
    Real * 8, intent (out) :: ci,si
    Integer, parameter :: MAXIT = 100
    Real * 8, parameter :: EPS=6.d-8, FPMIN=1.d-30, TMIN=2.d0
    Integer :: i,k
    Real * 8 :: a,err,fact,sign,sum,sumc,sums,t,term,absc
    Complex * 16 :: h,b,c,d,del
    Logical :: odd, convergence
    absc(h) = abs(real(h))+abs(aimag(h))
    t = abs(x)
    if (t.eq.0.) then
      si = 0.d0
      ci = -1.d0/FPMIN
      return
    end if
    if (t .gt. TMIN) then
      b = cmplx(1.d0,t)
      c = 1.d0/FPMIN
      d = 1.d0/b
      h = d
      i = 2
      convergence = .False.
      do while (convergence .eqv. .False.)
        a = -(i-1)**2
        b = b+2.d0
        d = 1.d0/(a*d+b)
        c = b+a/c
        del = c*d
        h = h*del
        i = i + 1
        if ( (absc(del-1.d0) .lt. EPS) .or. ( i == MAXIT) ) convergence = .True.
      end do
  !      if () pause 'cf failed in cisi'
        if (i .ge. MAXIT) Print*, 'cf failed in cisi'
        h = cmplx(cos(t),-sin(t))*h
        ci = -real(h)
        si = pih+aimag(h)
        else
          if( t .lt. sqrt(FPMIN) )then
            sumc = 0.d0
            sums = t
          else
            sum  = 0.d0
            sums = 0.d0
            sumc = 0.d0
            sign = 1.d0
            fact = 1.d0
            odd  = .true.
            k = 1
            convergence = .False.
            do while (convergence .eqv. .False.)
              fact = fact * t / k
              term = fact / k
              sum  = sum + sign * term
              err  = term / abs(sum)
              if ( odd ) then
                sign = -sign
                sums = sum
                sum  = sumc
              else
                sumc = sum
                sum  = sums
              end if
              if( (err .lt. EPS) .or. (k == MAXIT) ) convergence = .True.
              odd = .not. odd
              k = k + 1
              end do
              !pause 'maxits exceeded in cisi'
            end if
            if (k .ge. MAXIT ) print*, 'maxits exceeded in cisi'
            si = sums
            ci = sumc+log(t)+EULER
          end if
          if( x .lt. 0.d0 ) si = -si
          return
  End Subroutine

  !This subroutine writes down the structure factor, the direct correlation function and the
	!inverse of the structure factor and the associated run file info
	Subroutine structure_writting_hssw(k,sk,kw,sys_cond,approx,quad,quadp_f,quadp_i,folder,id)
    Implicit None
		Real * 8, dimension(:), intent(in) :: k, sk, kw, sys_cond,quadp_f
		Integer, dimension(:) :: quadp_i
		Character(*), intent(in) :: folder, approx, quad
		Integer, intent(in) :: id
		Real * 8 :: phi, T, lambda
		Integer :: di_phi, i_T, di_T
		Integer, parameter :: di_phi_min=4, i_T_max = 3, di_T_min = 4, id_max=2
		Character (len=di_phi_min) :: phi_char
		Character (len=i_T_max+di_T_min+1) :: T_char
		Character (len=id_max) :: id_char
		Character (len=len(folder)+len(phi_char)+len(T_char)+len(id_char)+19) :: File_name
		Character (len=len(File_name)) :: info_File_name
		Integer :: i1
		!System conditions
		phi = sys_cond(1)
		T = sys_cond(2)
		lambda = sys_cond(3)
		!Calculating the associated integers for phi and T:
		i_T = int(T)
		di_T = int( (T- dble(i_T)) * (10.d0 ** di_T_min) )
		di_phi = int(phi * (10.d0 ** di_phi_min) )
		!Writting con character variables, formats have to be consistent with char lengths
		Write(phi_char,"(I4.4)") di_phi
		Write(T_char,"(I3.3,A1,I4.4)") i_T,"_",di_T
		Write(id_char,"(I2.2)") id
		File_name = folder//"S_phi_0_"//phi_char//"_T_"//T_char//"_id_"//id_char//".dat"
		info_File_name = folder//"S_phi_0_"//phi_char//"_T_"//T_char//"_id_"//id_char//".inf"
		Open(unit=100, file=File_name, status="Replace")
		Write (100,*) "# 						k 										S(k)											Weights"
		Do i1=1, size(k)
			Write(100,*) k(i1),sk,kw(i1)
		End Do
		Close(100)
		Open (unit=100, file=info_File_name, status="replace")
		Write(100,*) "###  Run Information for the file: "//File_name
		Write(100,*) "### System parameters ###"
		Write(100,*) "Volume Fraction phi = ", phi
		Write(100,*) "Temperature      T* = ", T
		Write(100,*) "Lambda              = ", lambda
		Write(100,*) "###############################"
		Write(100,*) "### Structure Approximation ###"
		Select case (approx)
			case ("SHVW")
				Write(100,*) "				Sharma-Sharma + Verlet Weiss (HSPY)"
			case ("GSVW")
				Write(100,*) "				Generalized Sharma-Sharma + Verlet Weiss (HSPY)"
			case Default
				Write(100,*) "				"//approx
		End Select
		Write(100,*) "###############################"
		Write(100,*) "### Quadratures ###"
		Select case (quad)
			case("CLCU")
				Write(100,*) "				Clenshaw-Curtis"
				Write(100,*) "quadrature number of points = ", quadp_i(1)
				Write(100,*) "quadrature minimum value    = ", quadp_f(1)
				Write(100,*) "quadrature maximum value    = ", quadp_f(2)
			case Default
				Write(100,*) "				"//quad
				Write(100,*) "quadrature number of points = ", quadp_i(1)
				Write(100,*) "quadrature minimum value    = ", quadp_f(1)
				Write(100,*) "quadrature maximum value    = ", quadp_f(2)
		End Select
		Write(100,*) "###############################"
		Write(100,*) "### Wave-Vectors ###"
		Write(100,*) "number of points     = ", size(k)
		Write(100,*) "k minimum value      = ", k(1)
		Write(100,*) "k maximum value      = ", k(size(k))
		Close(100)
	End Subroutine
  !This subroutine writes down the structure factor, the direct correlation function and the
	!inverse of the structure factor and the associated run file info
	Subroutine writting_hssw_p(sys_cond,approx,i_unit)
    Implicit None
		Real * 8, dimension(:), intent(in) :: sys_cond
		Integer :: i_unit
		Character(*), intent(in) :: approx
		Real * 8 :: phi, T, lambda
		Integer :: i1
		!System conditions
		phi = sys_cond(1)
		T = sys_cond(2)
		lambda = sys_cond(3)
		Write(i_unit,*) "### Hard Sphere + Square Well System parameters ###"
		Write(i_unit,*) "Volume Fraction phi = ", phi
		Write(i_unit,*) "Temperature      T* = ", T
		Write(i_unit,*) "Lambda              = ", lambda
		Write(i_unit,*) "###############################"
		Write(i_unit,*) "### Structure Approximation ###"
		Select case (approx)
			case ("SHVW")
				Write(i_unit,*) "				Sharma-Sharma + Verlet Weiss (HSPY)"
			case ("GSVW")
				Write(i_unit,*) "				Generalized Sharma-Sharma + Verlet Weiss (HSPY)"
			case Default
				Write(i_unit,*) "				"//approx
		End Select
    Write(i_unit,*) "###############################"
	End Subroutine

  !Pressure for the Hard Sphere Square Well system through compressibility of Sharma-Sharma
  Function P_HSSW_SH(T,phi,lambda) result(P)
    Implicit None
    Real * 8, intent(in) :: T, phi, lambda
    Real * 8 :: P
    P = 6.d0 * phi * T * (1.d0 + phi**2 - phi **3) / ( pi * (1.d0 - phi)**3 )
    P = P - (24.d0 * (lambda**3 - 1.d0) * phi ** 2 / pi)
  End Function

  !Pressure for the Hard Sphere Square Well system through compressibility of Generalized Sharma-Sharma
  Function P_HSSW_GSH(T,phi,lambda) result(P)
    Implicit None
    Real * 8, intent(in) :: T, phi, lambda
    Real * 8 :: P
    Real * 8 :: FT, phi2, phi3
    phi2 = phi  * phi
    phi3 = phi2 * phi
    FT = exp(1.d0/T) - 1.d0
    P = 6.d0 * phi * T * (1.d0 + phi + phi2 - phi3) / ( pi * (1.d0 - phi)**3 )
    P = P - (24.d0 * (lambda ** 3 - 1.d0) * phi2 * T * FT / pi)
  End Function

  Function P_HSSW_gr(T,rho,lambda,g,r) result(P)
    Implicit None
    Real * 8, intent(in) :: T, rho, lambda
    Real * 8, Dimension(:), intent(in) :: g,r
    Real * 8 :: P, glsm,glsp,gsp,rp,rd
    integer :: i1
    rp=0.d0
    do i1=1,size(r)
      rd=r(i1)
      if ( rp <= 1.d0 .and. rd > 1.d0) gsp=g(i1)
      if ( rp < lambda .and. rd >= lambda ) glsm = g(i1-1)
      if ( rp <= lambda .and. rd > lambda ) glsp = g(i1)
      rp=rd
    end do

    P = rho * T + (2.d0*pi/3.d0) * (rho**2 * T * gsp)
    P = P - (pi/3.d0) * rho **2 * lambda**3 * (glsp + glsm)
    return
  End Function

  Function phi_c_HSSW_SH() result(phi_c)
    Implicit None
    Real * 8 :: phi_lo, phi_up, phi_test, f_lo, f_up, f_test
    Real * 8 :: phi_c
    Real * 8 :: error
    Real * 8, parameter :: tol = 1.d-12
    Integer :: i1
    phi_lo = 5.d-2
    phi_up = 3.d-1
    f_lo = F_phic_aux(phi_lo)
    f_up = F_phic_aux(phi_up)
    error = (phi_up - phi_lo) / phi_up
    Do while (error > tol)
      phi_test = (phi_lo + phi_up) / 2.d0
      f_test = F_phic_aux(phi_test)
      If (f_test*f_up<0.d0) Then
        phi_lo = phi_test
        f_lo = f_test
      Else
        phi_up = phi_test
        f_up = f_test
      End If
      error = (phi_up - phi_lo) / phi_up
    End Do
    If (abs(f_up)>abs(f_lo)) Then
      phi_c = phi_lo
    Else
      phi_c = phi_up
    End If
  End Function

  Function T_c_HSSW_SH(lambda) result(T_c)
    Implicit None
    Real * 8, intent(in) :: lambda
    Real * 8 :: T_c
    Real * 8 :: phi_c
    Real * 8 :: FT, phi_c_m5, lambda3m
    phi_c = phi_c_HSSW_SH()
    phi_c_m5 = (1.d0 - phi_c) ** 5
    lambda3m = (lambda ** 3) -1.d0
    FT = (2.d0 + 5.d0 * phi_c - phi_c ** 2) / ( 2.d0 * phi_c_m5 * lambda3m )
    T_c = 1.d0 / FT
    Return
  End Function

  Function T_c_HSSW_GSH(lambda) result(T_c)
    Implicit None
    Real * 8, intent(in) :: lambda
    Real * 8 :: T_c
    Real * 8 :: phi_c
    Real * 8 :: FT, phi_c_m5, lambda3m
    phi_c = phi_c_HSSW_SH()
    phi_c_m5 = (1.d0 - phi_c) ** 5
    lambda3m = (lambda ** 3) - 1.d0
    FT = (2.d0 + 5.d0 * phi_c - phi_c ** 2) / ( 2.d0 * phi_c_m5 * lambda3m )
    T_c = 1.d0 / log(FT + 1.d0)
    Return
  End Function

  Function F_phic_aux(phi) Result(F)
    Implicit None
    Real * 8, intent(in) :: phi
    Real * 8 :: F
    Real * 8 :: phi5, phi4, phi3, phi2
    phi2 = phi  * phi
    phi3 = phi2 * phi
    phi4 = phi3 * phi
    phi5 = phi4 * phi
    F = -phi5 + 5.d0*phi4 -4.d0*phi3 -20.d0*phi2 -5.d0*phi + 1.d0
    Return
  End Function

  Subroutine Binodal_phis_HSSW_GSH(T,lambda,phi_l,phi_u)
    Implicit None
    Real * 8, intent(in) :: T, lambda
    Real * 8, intent(out) :: phi_l, phi_u
    Real * 8 :: phi_m, error, phi_s_l, phi_s_u
    Real * 8 :: phi_c, T_c,PB1,PB2, P_test, P_up, P_lo
    Real * 8 :: FT, A1, A2, Pdum
    Integer, parameter :: qnp = 2**10
    Real * 8, dimension(qnp) :: quad_p, quad_w
    Real * 8, dimension(qnp) :: phi_q1, phi_w1, integrand1, phi_q2, phi_w2, integrand2
    Integer :: i1
    Real * 8, parameter :: tol = 1.d-10
    call Clenshaw_Curtis_quadrature(qnp,quad_p,quad_w)
    Pdum = pi / (6.d0 * T)
    phi_c = phi_c_HSSW_SH()
    T_c = T_c_HSSW_GSH(lambda)
    FT= exp(1.d0/T) - 1.d0
    call roots_phi_s_P_aux(FT,lambda,phi_c,phi_s_l,phi_s_u)
    PB1 = P_HSSW_GSH(T,phi_s_l,lambda) * Pdum
    PB2 = P_HSSW_GSH(T,phi_s_u,lambda) * Pdum
    If (PB1 > PB2) Then
      P_up = PB1
      P_lo = PB2
      If (P_lo< 0.d0) P_lo = 0.d0
    Else
      P_up = PB2
      P_lo = PB1
      If (P_lo<0.d0) P_lo = 0.d0
    End If
    P_test = (P_up + P_lo) / 2.d0
    phi_l = Pressure_root_HSSW(FT,lambda,P_test,0.d0,phi_s_l)
    phi_m = Pressure_root_HSSW(FT,lambda,P_test,phi_s_l,phi_s_u)
    phi_u = Pressure_root_HSSW(FT,lambda,P_test,phi_s_u,1.d0)
    phi_q1 = quad_p
    phi_q2 = quad_p
    phi_w1 = quad_w
    phi_w2 = quad_w
    call rescale_OW(qnp,phi_q1,phi_w1,-1.d0,1.d0,phi_l,phi_m)
    call rescale_OW(qnp,phi_q2,phi_w2,-1.d0,1.d0,phi_m,phi_u)
    !Open (unit=10, file="integrand_test.dat", status="Replace")
    Do i1 = 1, qnp
      integrand1(i1) =  (P_HSSW_GSH(T,phi_q1(i1),lambda) * Pdum - P_test)/(phi_q1(i1)**2)
      integrand2(i1) =  (P_HSSW_GSH(T,phi_q2(i1),lambda) * Pdum - P_test)/(phi_q2(i1)**2)
      !Write(10,*) integrand1(i1),phi_q1(i1),integrand2(i1),phi_q2(i1)
    End Do
    !Close (10)
    !stop
    A1 = abs(sum(integrand1 * phi_w1))
    A2 = abs(sum(integrand2 * phi_w2))
    error = Abs(A1 - A2) / A1
    Do while (error > tol)
      If (A1 > A2) Then
        P_lo  = P_test
      Else
        P_up = P_test
      End If
      P_test = (P_up + P_lo) / 2.d0
      phi_l = Pressure_root_HSSW(FT,lambda,P_test,0.d0,phi_s_l)
      phi_m = Pressure_root_HSSW(FT,lambda,P_test,phi_s_l,phi_s_u)
      phi_u = Pressure_root_HSSW(FT,lambda,P_test,phi_s_u,1.d0)
      phi_q1 = quad_p
      phi_q2 = quad_p
      phi_w1 = quad_w
      phi_w2 = quad_w
      call rescale_OW(qnp,phi_q1,phi_w1,-1.d0,1.d0,phi_l,phi_m)
      call rescale_OW(qnp,phi_q2,phi_w2,-1.d0,1.d0,phi_m,phi_u)
      Do i1 = 1, qnp
        integrand1(i1) =  (P_HSSW_GSH(T,phi_q1(i1),lambda) * Pdum - P_test)/(phi_q1(i1)**2)
        integrand2(i1) =  (P_HSSW_GSH(T,phi_q2(i1),lambda) * Pdum - P_test)/(phi_q2(i1)**2)
      End Do
      A1 = abs(sum(integrand1 * phi_w1))
      A2 = abs(sum(integrand2 * phi_w2))
      error = Abs(A1 - A2) / A1
    End Do
    !Open (unit=10, file="integrand_test.dat", status="Replace")
    !Do i1 = 1, qnp
    !  Write(10,*) integrand1(i1),phi_q1(i1),integrand2(i1),phi_q2(i1)
    !End Do
    !Close (10)
    Print*, phi_l, phi_u, T
    Return
  End Subroutine

  Function Pressure_root_HSSW(FT,lambda,Pc,phi_Bl,phi_Bu) result(phi_root)
    Implicit None
    Real * 8, intent(in) :: FT, lambda, Pc
    Real * 8, intent(in) ::  phi_Bl, phi_Bu
    Real * 8 :: phi_lo, phi_up
    Real * 8 :: phi_root
    Real * 8 :: error, P_lo, P_up, phi_test, P_test
    Real * 8, parameter :: tol = 1.d-12
    phi_lo = phi_Bl
    phi_up = phi_Bu
    error = (phi_up - phi_lo) / phi_up
    P_lo = P_root_HSSW_aux(FT,lambda,Pc,phi_lo)
    P_up = P_root_HSSW_aux(FT,lambda,Pc,phi_up)
    Do while(error > tol)
      phi_test = (phi_lo + phi_up) / 2.d0
      P_test = P_root_HSSW_aux(FT,lambda,Pc,phi_test)
      If (P_test * P_lo < 0.d0) Then
        phi_up = phi_test
        P_up = P_test
      Else
        phi_lo = phi_test
        P_lo = P_test
      End If
      error = (phi_up - phi_lo) / phi_up
    End Do
    If (abs(P_lo)<abs(P_up)) Then
      phi_root = phi_lo
    Else
      phi_root = phi_up
    End If
  End Function

  Function P_root_HSSW_aux(FT,lambda,Pc,phi) result(P)
    Implicit None
    Real * 8, intent(in) :: FT, lambda, Pc,phi
    Real * 8 :: P
    Real * 8 :: phi2,phi3,phim3
    phi2 = phi * phi
    phi3 = phi2 * phi
    phim3 = (1.d0 - phi) ** 3
    P = (phi * (1.d0 + phi + phi2 - phi3) / phim3) - (4.d0 * (lambda ** 3 - 1.d0)* FT * phi2) - Pc
  End Function

  Subroutine roots_phi_s_P_aux(FT,lambda,phi_c,phi_l,phi_u)
    Implicit None
    Real * 8, intent(in) :: FT, lambda, phi_c
    Real * 8 :: phi_l,phi_u
    Real * 8 :: error
    Real * 8, parameter :: tol = 1.d-12
    Real * 8 :: phi_test, phi_lo, phi_up
    Real * 8 :: root_lo, root_up, root_test
    phi_lo = 0.d0
    phi_up = phi_c
    error = (phi_up - phi_lo) / phi_up
    root_lo = roots_phi_s_aux(FT,lambda,phi_lo)
    root_up = roots_phi_s_aux(FT,lambda,phi_up)
    Do while (error > tol)
      phi_test  = (phi_up + phi_lo) / 2.d0
      root_test = roots_phi_s_aux(FT,lambda,phi_test)
      If (root_test * root_lo < 0.d0) Then
        phi_up  = phi_test
        root_up = root_test
      Else
        phi_lo = phi_test
        root_lo = root_test
      End If
      error = (phi_up - phi_lo) / phi_up
    End Do
    If (abs(root_lo)<abs(root_up)) Then
      phi_l = phi_lo
    Else
      phi_l = phi_up
    End If
    phi_lo = phi_c
    phi_up = 1.d0
    error  = (phi_up - phi_lo) / phi_up
    root_lo = roots_phi_s_aux(FT,lambda,phi_lo)
    root_up = roots_phi_s_aux(FT,lambda,phi_up)
    Do while (error > tol)
      phi_test  = (phi_up + phi_lo) / 2.d0
      root_test = roots_phi_s_aux(FT,lambda,phi_test)
      If (root_test * root_lo < 0.d0) Then
        phi_up  = phi_test
        root_up = root_test
      Else
        phi_lo  = phi_test
        root_lo = root_test
      End If
      error = (phi_up - phi_lo) / phi_up
    End Do
    If (abs(root_lo)<abs(root_up)) Then
      phi_u = phi_lo
    Else
      phi_u = phi_up
    End If
    return
  End Subroutine

  Function roots_phi_s_aux(FT,lambda,phi) result(F)
    Implicit None
    Real * 8, intent(in) :: FT,lambda,phi
    Real * 8 :: F
    Real * 8 :: A
    Real * 8 :: phim4, phi2
    phi2 = phi * phi
    phim4 = (1.d0 - phi) ** 4
    A = -8.d0 * FT * (lambda ** 3 - 1.d0)
    F = A * phi * phim4 + 8.d0 * phi - 2.d0 * phi2 + phim4
  End Function

  !This subroutine writes down the radial distribution function, the coordination number
	! and the associated run file info
	Subroutine g_rel_writting_hssw(r,k,gr,coor_n_r,drp,drw,sys_cond,approx,quad_k,&
            & quad_dr,quadp_f,quadp_i,quadp_drf,quadp_dri,folder,id)
		Real * 8, dimension(:), intent(in) :: r, k, gr, coor_n_r,drp, drw, sys_cond,quadp_f,quadp_drf
		Integer, dimension(:) :: quadp_i, quadp_dri
		Character(*), intent(in) :: folder, approx, quad_k, quad_dr
		Integer, intent(in) :: id
		Real * 8 :: phi, T, lambda
		Integer :: di_phi, i_T, di_T
		Integer, parameter :: di_phi_min=4, i_T_max = 3, di_T_min = 4, id_max=2
		Character (len=di_phi_min) :: phi_char
		Character (len=i_T_max+di_T_min+1) :: T_char
		Character (len=id_max) :: id_char
		Character (len=len(folder)+len(phi_char)+len(T_char)+len(id_char)+19) :: File_name
		Character (len=len(File_name)) :: info_File_name
		Integer :: i1, i2
		!System conditions
		phi = sys_cond(1)
		T = sys_cond(2)
		lambda = sys_cond(3)
		!Calculating the associated integers for phi and T:
		i_T = int(T)
		di_T = int( (T- dble(i_T)) * (10.d0 ** di_T_min) )
		di_phi = int(phi * (10.d0 ** di_phi_min) )
		!Writting con character variables, formats have to be consistent with char lengths
		Write(phi_char,"(I4.4)") di_phi
		Write(T_char,"(I3.3,A1,I4.4)") i_T,"_",di_T
		Write(id_char,"(I2.2)") id
		File_name = folder//"g_phi_0_"//phi_char//"_T_"//T_char//"_id_"//id_char//".dat"
		info_File_name = folder//"g_phi_0_"//phi_char//"_T_"//T_char//"_id_"//id_char//".inf"
		Open(unit=100, file=File_name, status="Replace")
		Write (100,*) "# 			r							g(r)							#_coor(r)"
    Do i1=1, size(r)
      Write(100,*) r(i1),gr(i1),coor_n_r(i1)
		End Do
		Close(100)
		Open (unit=100, file=info_File_name, status="replace")
		Write(100,*) "###  Run Information for the file: "//File_name
		Write(100,*) "### System parameters ###"
		Write(100,*) "Volume Fraction phi = ", phi
		Write(100,*) "Temperature      T* = ", T
		Write(100,*) "Lambda              = ", lambda
		Write(100,*) "###############################"
		Write(100,*) "### Structure Approximation ###"
		Select case (approx)
			case ("SHVW")
				Write(100,*) "				Sharma-Sharma + Verlet Weiss (HSPY)"
			case ("GSVW")
				Write(100,*) "				Generalized Sharma-Sharma + Verlet Weiss (HSPY)"
			case Default
				Write(100,*) "				"//approx
		End Select
		Write(100,*) "###############################"
		Write(100,*) "### Structure Quadratures ###"
		Select case (quad_k)
			case("CLCU")
				Write(100,*) "				Clenshaw-Curtis"
				Write(100,*) "quadrature number of points = ", quadp_i(1)
				Write(100,*) "quadrature minimum value    = ", quadp_f(1)
				Write(100,*) "quadrature maximum value    = ", quadp_f(2)
			case Default
				Write(100,*) "				"//quad_k
				Write(100,*) "quadrature number of points = ", quadp_i(1)
				Write(100,*) "quadrature minimum value    = ", quadp_f(1)
				Write(100,*) "quadrature maximum value    = ", quadp_f(2)
		End Select
		Write(100,*) "###############################"
		Write(100,*) "### Wave-Vectors ###"
		Write(100,*) "number of points     = ", size(k)
		Write(100,*) "k minimum value      = ", k(1)
		Write(100,*) "k maximum value      = ", k(size(k))
    Write(100,*) "###############################"
		Write(100,*) "### Radial Distance ###"
		Write(100,*) "number of points     = ", size(k)
		Write(100,*) "r minimum value      = ", r(1)
		Write(100,*) "r maximum value      = ", r(size(r))
    Write(100,*) "###############################"
		Write(100,*) "### Differential Radial Distance Quadratures ###"
		Select case (quad_dr)
			case("CLCU")
				Write(100,*) "				Clenshaw-Curtis"
				Write(100,*) "quadrature number of points = ", quadp_dri(1)
				Write(100,*) "quadrature minimum value    = ", quadp_drf(1)
				Write(100,*) "quadrature maximum value    = ", quadp_drf(2)
			case Default
				Write(100,*) "				"//quad_dr
				Write(100,*) "quadrature number of points = ", quadp_i(1)
				Write(100,*) "quadrature minimum value    = ", quadp_f(1)
				Write(100,*) "quadrature maximum value    = ", quadp_f(2)
		End Select
    Write(100,*)"# 						r										Weight"
    Do i1 =1 , size(drp)
      Write(100,*) drp(i1), drw(i1)
    End Do
		Close(100)
	End Subroutine

  Function P0(k,a) Result(P)
    Implicit None
    Real * 8, intent(in) :: k,a
    Real * 8 :: P
    Real * 8 :: ka, k2, ka2, ka4
    ka = k*a
    k2 = k**2
    ka2 = ka * ka
    ka4 = ka2 * ka2
    If (ka < 0.075 ) Then
      If (k > 0.d0) Then
        P = ( -1.d0 / k2) + a*a* (0.5d0 - (ka2/24.d0))
      Else
        P = - 1.d20
      End If
    Else
      P = - cos(ka) / k2
    End If
    Return
  End function

  Function P1(k,a) Result(P)
    Implicit None
    Real * 8, intent(in) :: k,a
    Real * 8 :: P
    Real * 8 :: ka,k3, ka2,a2,a3
    ka = k*a
    k3 = k**3
    a2 = a*a
    ka2 = ka*ka
    If (ka < 0.075 ) Then
        a3=a2*a
        P = ( (10.d0 - ka2)/(30.d0) )
        P = P * a3
    Else
      P = ( sin(ka) - ka * cos(ka) ) / k3
    End If
    Return
  End function

  Function P2(k,a) Result(P)
    Implicit None
    Real * 8, intent(in) :: k,a
    Real * 8 :: P
    Real * 8 :: ka,k2,k4, ka2, a4
    ka = k*a
    k2 = k**2
    ka2 = ka * ka
    k4 = k2 * k2
    a4 = a**4
    If (ka < 0.075 ) Then
      P = (2.d0/k4) + a4*(0.25d0 - (1.d0 / 36.d0) * ka2)
    Else
      P = ( 2.d0*ka*sin(ka) +( 2.d0-ka2 )*cos(ka) ) / k4
    End If
    Return
  End function

  Function P4(k,a) Result(P)
    Implicit None
    Real * 8, intent(in) :: k,a
    Real * 8 :: P
    Real * 8 :: ka,ka2,ka4,k2,k4,k6,a6,a4
    ka = k*a
    ka2 = ka * ka
    ka4 = ka2 * ka2
    k2 = k*k
    k4 = k2 * k2
    k6 = k4 * k2
    ka2 = ka * ka
    a6 = a**6
    a4 = a**4
    If (ka < 0.075 ) Then
      P = (-24.d0/k6) + a6 * ( (1.d0/6.d0) - (1.d0/48.d0) * ka2 )
    Else
      P = ( (4.d0*ka*(ka2-6.d0))* sin(ka) - (ka4 - 12.d0*ka2 + 24.d0) * cos(ka) ) / k6
    End If
    Return
  End function
  !!!!!!!!!!!!!!!!!!Delta Ps functions

  Function DP0(k,a,b) Result(DP)
    Implicit None
    Real * 8, intent(in) :: k,a,b
    Real * 8 :: DP
    Real * 8 :: ka, k2, ka2, kb, kb2,a2,b2
    ka = k*a
    kb = k*b
    If (ka < 0.075d0 .And. kb < 0.075d0) Then
      a2 = a * a
      b2 = b * b
      ka2 = a2 * ka * ka
      kb2 = b2 * kb * kb
      DP = 0.5d0 * (a2-b2) - (ka2-kb2)/24.d0
    Else
      DP = P0(k,a) - P0(k,b)
    End If
    Return
  End function

  Function DP1(k,a,b) Result(DP)
    Implicit None
    Real * 8, intent(in) :: k,a,b
    Real * 8 :: DP
    DP = P1(k,a)-P1(k,b)
    Return
  End function

  Function DP2(k,a,b) Result(DP)
    Implicit None
    Real * 8, intent(in) :: k,a,b
    Real * 8 :: DP
    Real * 8 :: ka2, kb2, ka, kb, a4,b4,a2,b2, k2
    ka = k*a
    kb = k*b
    If (ka < 0.075 .And. kb < 0.075d0 ) Then
      a2=a*a
      b2=b*b
      a4 = a2 * a2
      b4 = b2 * b2
      k2 = k * k
      ka2 = a2*k2*a4
      kb2 = b2*k2*b4
      DP = (a4-b4)*0.25d0 - (ka2-kb2)*(1.d0/36.d0)
    Else
      DP = P2(k,a)-P2(k,b)
    End If
    Return
  End function

  Function DP4(k,a,b) Result(DP)
    Implicit None
    Real * 8, intent(in) :: k,a,b
    Real * 8 :: DP
    Real * 8 :: ka, kb
    Real * 8 :: a6, b6, ka2, kb2,a2,b2,k2
    ka = k*a
    kb = k*b
    If (ka < 0.075d0 .And. kb < 0.075d0 ) Then
      k2 = k * k
      a2 = a*a
      b2 = b*b
      a6 = a**6
      b6 = b**6
      ka2 = a2 * k2 * a6
      kb2 = b2 * k2 * b6
      DP = (a6-b6)* (1.d0/6.d0) - (ka2-kb2) * (1.d0/48.d0)
    Else
      DP = P4(k,a) - P4(k,b)
    End If
    Return
  End function

  Function c1_hssw(T,lambda,k) Result(c1k)
    Implicit None
    Real * 8, intent(in) :: T,lambda,k
    Real * 8 :: c1k
    Real * 8 :: x
    Real * 8 :: A,B,C
    Real * 8 :: A1, A2, A3
    Real * 8 :: B1, B2, B3, B4, B5
    Real * 8 :: C1, C2, C3, C4, C5
    Real * 8 :: LM1
    LM1 = lambda - 1
    x = exp(1.d0/T) - 1.d0
    If ( 1.d0 < lambda .and. lambda < 2.d0 ) Then
      A1 = 4.d0/3.d0
      A2 = -1.d0
      A3 = 1.d0/12.d0
      B1 = -2.d0
      B2 = 1.d0/6.d0
      B3 = 0.5d0 * (lambda**2 - 1.d0)
      B4 = - 4.d0 * ( lambda**3 - 1.d0 ) / 3.d0
      B5 = lambda **2 - 1
      C1 = B4
      C2 = -B5
      C3 = B2
      C4 = 2.d0 * B3 * B3
      C5 = C4
      A = - ( A1 * DP1(k,1.d0,0.d0) + A2 * DP2(k,1.d0,0.d0) + A3 * DP4(k,1.d0, 0.d0) )
      A = A + x * ( A1 * DP1(k,lambda,1.d0) + A2 * DP2(k,lambda,1.d0) + A3 * DP4(k,lambda,1.d0) )
      B = - ( B1 * DP2(k,LM1,0.d0) + B2 * DP4(k,LM1,0.d0) )
      B = B - ( B3 * DP0(k,1.d0,LM1) + B4 * DP1(k,1.d0,LM1) + B5 * DP2(k,1.d0,LM1) )
      B = B + x * ( B3 * DP0(k,1.d0,lambda) + B4 * DP1(k,1.d0,lambda) + B5 * DP2(k,1.d0,lambda) )
      C = - ( C1 * DP1(k,LM1,0.d0) + C2 * DP2(k,LM1,0.d0) + C3 * DP4(k,LM1,0.d0) )
      C = C - ( C4 * DP0(k,1.d0,LM1) )
      C = C + x * ( C4 * DP0(k,lambda,1.d0) )
    Else If ( 2.d0 .le. lambda .and. lambda < 3.d0) Then
    Else If ( 3.d0 .le. lambda ) Then
    Else
    End If
    c1k = A + (x*B) + (x*x*C)
    c1k = c1k * ( (2.d0 * pi) ** 2 )
    Return
  End Function

  Function dc1_hssw(T,lambda,k) Result(c1k)
    Implicit None
    Real * 8, intent(in) :: T,lambda,k
    Real * 8 :: c1k
    Real * 8 :: x,x2
    Real * 8 :: A,B,C
    Real * 8 :: A1, A2, A3
    Real * 8 :: B1, B2, B3, B4, B5
    Real * 8 :: C1, C2, C3, C4, C5
    Real * 8 :: LM1
    LM1 = lambda - 1
    x = exp(1.d0/T) - 1.d0
    x2 = x * x
    If ( 1.d0 < lambda .and. lambda < 2.d0 ) Then
      A1 = 4.d0/3.d0
      A2 = -1.d0
      A3 = 1.d0/12.d0
      B1 = -2.d0
      B2 = 1.d0/6.d0
      B3 = 0.5d0 * (lambda**2 - 1.d0)
      B4 = - 4.d0 * ( lambda**3 - 1.d0 ) / 3.d0
      B5 = lambda **2 - 1
      C1 = B4
      C2 = -B5
      C3 = B2
      C4 = 2.d0 * B3 * B3
      C5 = C4
      A =  x * ( A1 * DP1(k,lambda,1.d0) + A2 * DP2(k,lambda,1.d0) + A3 * DP4(k,lambda,1.d0) )
      B = - ( B1 * DP2(k,LM1,0.d0) + B2 * DP4(k,LM1,0.d0) )
      B = B - ( B3 * DP0(k,1.d0,LM1) + B4 * DP1(k,1.d0,LM1) + B5 * DP2(k,1.d0,LM1) )
      B = B + x * ( B3 * DP0(k,1.d0,lambda) + B4 * DP1(k,1.d0,lambda) + B5 * DP2(k,1.d0,lambda) )
      C = - ( C1 * DP1(k,LM1,0.d0) + C2 * DP2(k,LM1,0.d0) + C3 * DP4(k,LM1,0.d0) )
      C = C - ( C4 * DP0(k,1.d0,LM1) )
      C = C + x * ( C4 * DP0(k,lambda,1.d0) )
    Else If ( 2.d0 .le. lambda .and. lambda < 3.d0) Then
    Else If ( 3.d0 .le. lambda ) Then
    Else
    End If
    c1k = A + (x*B) + (x2*C)
    c1k = c1k * ( (2.d0 * pi) ** 2 )
    Return
  End Function

  Function dc0_hssw(T,lambda,k) Result(c0k)
    Implicit None
    Real * 8, intent(in) :: T,lambda,k
    Real * 8 :: c0k
    Real * 8 :: x
    Real * 8 :: A,B,C
    Real * 8 :: A1, A2, A3
    Real * 8 :: B1, B2, B3, B4
    Real * 8 :: C1, C2, C3, C4
    Real * 8 :: LM1
    x = exp(1.d0/T) - 1.d0
    !c0k = x * ( 4.d0 * pi ) * DP1(k,lambda,1.d0)
    c0k = ( 4.d0 * pi ) * DP1(k,lambda,1.d0) / T
    Return
  End Function

  Function c1_hs_py(k) Result (c1k)
    Implicit None
    Real * 8, intent(in) :: k
    Real * 8 :: c1k
    Real * 8 :: A1, A2, A3
    A1 =  4.d0 / 3.d0
    A2 = -1.d0
    A3 = 1.d0/12.d0
    c1k = - ( A1 * DP1(k,1.d0,0.d0) + A2 * DP2(k,1.d0,0.d0) + A3 * DP4(k,1.d0, 0.d0) )
    c1k = c1k * ( (2.d0 * pi) ** 2 )
    Return
  End Function

  Function ck_hssw_py_1_order(phi,T,lambda,k) Result(ck)
    Implicit None
    Real * 8, intent(in) :: phi,T,lambda,k
    Real * 8 :: ck
    Real * 8 :: rho
    rho = 6.d0 * phi / pi
    ck = c_hs_py(phi,k) + dc0_hssw(T,lambda,k) + rho * dc1_hssw(T,lambda,k)
  End Function

  Function ck_hssw_pyvw_1_order(phi,T,lambda,k) Result(ck)
    Implicit None
    Real * 8, intent(in) :: phi,T,lambda,k
    Real * 8 :: ck
    Real * 8 :: rho
    rho = 6.d0 * phi / pi
    ck = c_hs_vw(phi,k) + dc0_hssw(T,lambda,k) + rho * dc1_hssw(T,lambda,k)
  End Function

  Function isk_hssw_py_1_order(phi,T,lambda,k) Result(isk)
    Implicit None
    Real * 8, intent(in) :: phi,T,lambda,k
    Real * 8 :: isk
    Real * 8 :: rho
    rho = 6.d0 * phi / pi
    isk = 1.d0 - (rho * ck_hssw_py_1_order(phi,T,lambda,k) )
  End Function

  Function isk_hssw_pyvw_1_order(phi,T,lambda,k) Result(isk)
    Implicit None
    Real * 8, intent(in) :: phi,T,lambda,k
    Real * 8 :: isk
    Real * 8 :: rho, rho_vw
    Real * 8 :: phi_vw
    Real * 8 :: chs, csw
    phi_vw = phi*(1.d0 - (phi / 16.d0))
    rho = 6.d0 * phi / pi
    rho_vw = 6.d0 * phi_vw / pi
    chs = c_hs_vw(phi,k)
    csw = dc0_hssw(T,lambda,k) !+ rho * dc1_hssw(T,lambda,k)
    isk = 1.d0 - ( (rho_vw * chs) + (rho * csw) )
  End Function

  Function sk_hssw_py_1_order(phi,T,lambda,k) Result(sk)
    Implicit None
    Real * 8, intent(in) :: phi,T,lambda,k
    Real * 8 :: sk
    Real * 8 :: rho
    sk = 1.d0 / isk_hssw_py_1_order(phi,T,lambda,k)
  End Function

  Function sk_hssw_pyvw_1_order(phi,T,lambda,k) Result(sk)
    Implicit None
    Real * 8, intent(in) :: phi,T,lambda,k
    Real * 8 :: sk
    Real * 8 :: rho
    sk = 1.d0 / isk_hssw_pyvw_1_order(phi,T,lambda,k)
  End Function

  Function Ts_hssw_pyvw_1_order(phi,lambda) Result(Ts)
    Implicit None
    Real * 8, intent(in) :: phi, lambda
    Real * 8 :: Ts
    Real * 8 :: T_u, T_l, T_test, isk
    Logical :: convergence
    Real * 8, Parameter :: tol=1.d-7
    Real * 8 :: error

    !Finding Temperature Bounds:
    T_test = 1.d0
    isk = isk_hssw_pyvw_1_order(phi,T_test,lambda,0.d0)
    convergence = .False.
    If (isk > 0.d0) Then
      T_u = T_test
      Do while (convergence .eqv. .False.)
        T_test = T_test * 0.5d0
        isk = isk_hssw_pyvw_1_order(phi,T_test,lambda,0.d0)
        If (isk < 0.d0) Then
          T_l = T_test
          convergence = .True.
        Else
          T_u = T_test
        End If
      End Do
    Else
      T_l = T_test
      Do while (convergence .eqv. .False.)
        T_test = T_test * 2.d0
        isk = isk_hssw_pyvw_1_order(phi,T_test,lambda,0.d0)
        If (isk < 0.d0) Then
          T_l = T_test
        Else
          T_u = T_test
          convergence = .True.
        End If
      End Do
    End If
    !!!!!!!!!!!!!!!!!!!!
    !Reducing bounds to a given tolerance
    convergence = .False.
    Do while (convergence .eqv. .False.)
      T_test = (T_u + T_l) * 0.5d0
      isk = isk_hssw_pyvw_1_order(phi,T_test,lambda,0.d0)
      If (isk < 0.d0) Then
        T_l = T_test
      Else
        T_u = T_test
      End If
      error = (T_u - T_l ) / T_u
      If (error < tol) convergence = .True.
    End Do
    Ts = T_test
  End Function

End Module


module constants_m
    !! Various math constants.

use, intrinsic ::  iso_fortran_env, only: int32, int64, real64

implicit none

integer, parameter :: ip = int32
    !! Default integer precision
integer, parameter :: ip_long = int64
    !! Default long integer precision

integer, parameter :: rp = real64
    !! Default real precision

integer, parameter :: sizeof_char = 1
    !! Size of a char in bytes

integer, parameter :: sizeof_int  = 4
    !! Size of a default int in bytes

integer, parameter :: sizeof_long_int  = 8
    !! Size of a default long int in bytes

integer, parameter :: sizeof_real = 8
    !! Size of a default real in bytes

real (rp), parameter :: math_third = 0.333333333333333_rp

!>pi
real (rp), parameter :: math_pi = 3.1415926535897931_rp

!>pi divided by two
real (rp), parameter :: math_pi_2 = 1.5707963267948966_rp

!>pi divided by four
real (rp), parameter :: math_pi_4 = 0.78539816339744828_rp

!>reciprocal of pi
real (rp), parameter :: math_1_pi = 0.31830988618379069_rp

!>two times reciprocal of pi
real (rp), parameter :: math_2_pi = 0.63661977236758138_rp

!>two times the reciprocal of the square root of pi.
real (rp), parameter :: math_2_sqrtpi = 1.1283791670955126_rp

!>square root of two
real (rp), parameter :: math_sqrt2 = 1.4142135623730951_rp

!>cube root of two
real (rp), parameter :: math_cbrt2 = 1.2599210498948732_rp

!>sixth root of two
real (rp), parameter :: math_sxrt2 = 1.122462048309373_rp

!>reciprocal of the square root of two
real (rp), parameter :: math_sqrt1_2 = 0.70710678118654746_rp

!>square root of three
real (rp), parameter :: math_sqrt3 = 1.7320508075688772_rp

!>square root of M_E
real (rp), parameter :: math_sqrt_e = 1.6487212707001282_rp

!>square root of pi
real (rp), parameter :: math_sqrt_pi = 1.7724538509055159_rp

!>The base of natural logarithms
real (rp), parameter :: math_e = 2.7182818284590451_rp

!>The logarithm of M_E to base two
real (rp), parameter :: math_log2e = 1.4426950408889634_rp

!>The logarithm of M_E to base 10
real (rp), parameter :: math_log10e = 0.43429448190325182_rp

!>The natural logarithm of two
real (rp), parameter :: math_ln2 = 0.69314718055994529_rp

!>The natural logarithm of 10
real (rp), parameter :: math_ln10 = 2.3025850929940459_rp

end module constants_m


subroutine fermi(y, x, n)
  real*8, intent(out) :: y(n)
  real*8, intent(in)  :: x(n)
  integer,intent(in)  :: n
  do i=1,n
     y(i) = 1.d0/(exp(x(i))+1.d0)
  end do
end subroutine fermi

subroutine gauss(y, x, s, n)
  real*8, intent(out) :: y(n)
  real*8, intent(in)  :: x(n)
  real*8, intent(in)  :: s
  integer,intent(in)  :: n
  !
  real*8, parameter :: sr2pi = 2.506628274631d0
  do i=1,n
     y(i) = 1.d0/(s*sr2pi)*exp(-x(i)*x(i)/(2.d0*s*s))
  enddo
end subroutine gauss

subroutine cfermi(y, x, n)
  real*8, intent(out) :: y(n)
  real*8, intent(in)  :: x(n)
  integer,intent(in)  :: n
  do i=1,n
     if (x(i)>10.) then
        y(i) = 0.d0
     else if (x(i) < -10.d0) then
        y(i) = 1.d0
     else
        y(i) = 1.d0/(exp(x(i))+1.d0)
     endif
  end do
end subroutine cfermi
subroutine cgauss(y, x, s, n)
  real*8, intent(out) :: y(n)
  real*8, intent(in)  :: x(n)
  real*8, intent(in)  :: s
  integer,intent(in)  :: n
  !
  real*8, parameter :: sr2pi = 2.506628274631
  do i=1,n
     if ( abs(x(i))>10.d0*s) then
        y(i) = 0.d0
     else
        y(i) = 1.d0/(s*sr2pi)*exp(-x(i)*x(i)/(2*s*s))
     endif
  end do
end subroutine cgauss

subroutine fr_convolution(res, iom, enk, mwm, omega, womeg, nom)
  !  We are computing
  !       sigma(iom) = -1/beta \sum_{iOm} mwm[iOm]/(iom-eps+iOm)
  !   Because mwm[-iOm]=mwm[iOm] and at T=0, we can rewrite
  !       sigma(iom) = 1/pi Integrate[ mwm[Om]*(eps-iom)/((eps-iom)^2 + Om^2) , {Om,0,Infinity} ]
  !   Finally, we notice that
  !                         Integrate[ 1/((eps-iom)^2 + Om^2) , {Om,0,Infinity} ] = pi*sign(eps)/(2*(eps-iom))
  !   therefore
  !       sigma(iom) = (eps-iom)/pi Integrate[ (mwm[Om]-mwm[iom])/((eps-iom)^2 + Om^2) , {Om,0,Infinity} ] + mwm[iom] * sign(eps)/2
  !
  complex*16, intent(out) :: res
  integer,    intent(in)  :: iom, nom
  real*8,     intent(in)  :: enk
  real*8,     intent(in)  :: omega(nom), womeg(nom)
  complex*16, intent(in)  :: mwm(nom)
  !
  real(8),    parameter  :: pi = 3.14159265358979d0
  complex*16 :: eps_om, eps_om2, sc0
  integer    :: i

  eps_om = cmplx(enk, -omega(iom), 8)
  eps_om2 = eps_om * eps_om
  sc0 = 0.d0
  do i=1,nom
     if (i==iom) cycle
     sc0 = sc0 + (mwm(i)-mwm(iom)) * womeg(i) / (omega(i)**2 + eps_om2)
  enddo
  res = eps_om*sc0/pi
  if (abs(mwm(iom))>1e-16) then
     res = res + mwm(iom)/pi * atan(omega(nom)/eps_om) !0.5d0*pi*sign(1.d0, enk)
  endif
end subroutine fr_convolution

subroutine fr_convolution2(res, enk, mwm, mwm_iom, omega, omega_iom, womeg, nom)
  !  We are computing
  !       sigma(iom) = -1/beta \sum_{iOm} mwm[iOm]/(iom-eps+iOm)
  !   Because mwm[-iOm]=mwm[iOm] and at T=0, we can rewrite
  !       sigma(iom) = 1/pi Integrate[ mwm[Om]*(eps-iom)/((eps-iom)^2 + Om^2) , {Om,0,Infinity} ]
  !   Finally, we notice that
  !                         Integrate[ 1/((eps-iom)^2 + Om^2) , {Om,0,Infinity} ] = pi*sign(eps)/(2*(eps-iom))
  !   therefore
  !       sigma(iom) = (eps-iom)/pi Integrate[ (mwm[Om]-mwm[iom])/((eps-iom)^2 + Om^2) , {Om,0,Infinity} ] + mwm[iom] * sign(eps)/2
  !
  complex*16, intent(out) :: res
  complex*16, intent(in)  :: mwm_iom
  integer,    intent(in)  :: nom
  real*8,     intent(in)  :: enk
  real*8,     intent(in)  :: omega(nom), womeg(nom)
  real*8,     intent(in)  :: omega_iom
  complex*16, intent(in)  :: mwm(nom)
  !
  real(8),    parameter  :: pi = 3.14159265358979d0
  complex*16 :: eps_om, eps_om2, sc0
  integer    :: i

  eps_om = cmplx(enk, -omega_iom, 8)
  eps_om2 = eps_om * eps_om
  sc0 = 0.d0
  do i=1,nom
     !if (i==iom) cycle
     sc0 = sc0 + (mwm(i)-mwm_iom) * womeg(i) / (omega(i)**2 + eps_om2)
  enddo
  res = eps_om*sc0/pi
  if (abs(mwm_iom)>1e-16) then
     res = res + mwm_iom/pi * atan(omega(nom)/eps_om) !0.5d0*pi*sign(1.d0, enk)
  endif
end subroutine fr_convolution2

subroutine many_fr_convolutions(sC, enk, Ul, omega, womeg, nom, nl, nb2)
  implicit none
  integer,    intent(in) :: nom, nl, nb2
  complex*16, intent(out):: sC(nl,nb2,nom)
  complex*16, intent(in) :: Ul(nl,nom) ! nl=22,nom=32
  real*8,     intent(in) :: enk(nb2) ! nb2=44
  real*8,     intent(in) :: omega(nom), womeg(nom)
  !
  integer    :: il, ie2, iom
  do il=1,nl
     do iom=1,nom
        do ie2=1,nb2
           call fr_convolution2(sC(il,ie2,iom), enk(ie2), Ul(il,:), Ul(il,iom), omega, omega(iom), womeg, nom)
        enddo
     enddo
  enddo
end subroutine many_fr_convolutions

subroutine all_fr_convolutions(sc_p, enk, mwm, omega, womeg, nb1,nb2,nom)
  implicit none
  integer,    intent(in) :: nom, nb1, nb2
  complex*16, intent(out):: sc_p(nb1,nom)
  complex*16, intent(in) :: mwm(nom,nb1,nb2)
  real*8,     intent(in) :: enk(nb2)
  real*8,     intent(in) :: omega(nom), womeg(nom)
  !
  complex*16 :: sc, sc_sum
  integer    :: ie1, ie2, iom
  do ie1=1,nb1
     do iom=1,nom
        sc_sum = 0.d0
        do ie2=1,nb2
           call fr_convolution2(sc, enk(ie2), mwm(:,ie1,ie2), mwm(iom,ie1,ie2), omega, omega(iom), womeg, nom)
           sc_sum = sc_sum + sc
        enddo
        sc_p(ie1,iom) = sc_sum
     enddo
  enddo
end subroutine all_fr_convolutions

subroutine few_fr_convolutions(res, enk, mwm, mwm_iom, omega, omega_iom, womeg, nom, nb2)
  implicit none
  integer,    intent(in) :: nom, nb2
  complex*16, intent(out):: res
  complex*16, intent(in) :: mwm(nb2,nom), mwm_iom(nb2)
  real*8,     intent(in) :: enk(nb2)
  real*8,     intent(in) :: omega(nom), womeg(nom), omega_iom
  !
  integer    :: ie2
  complex*16 :: sc
  res = 0.d0
  do ie2=1,nb2
     call fr_convolution2(sc, enk(ie2), mwm(ie2,:), mwm_iom(ie2), omega, omega_iom, womeg, nom)
     res = res + sc
  enddo
end subroutine few_fr_convolutions


module tools_mod

    implicit none
    ! FFT parameters
    include "misc/fftw3.f90"
    ! Double Precision
    integer, parameter :: dp=kind(0.d0)
    ! Print Output Format
    character(len=*), parameter  :: FMT = "ES23.15E3"
    ! Mathematical Constants
    real(dp),    parameter :: PI    = 4.0_dp*datan(1.0_dp)
    complex(dp), parameter :: II    = complex(0.0_dp,1.0_dp)
    ! Clock variables
    integer     :: clock_rate, start_clock, end_clock
    real(dp)    :: cpu_time_start, cpu_time_end

    contains

    ! FFT routines
    include "functions/fft.f90"
    include "functions/ifft.f90"

    ! Anti-Alias routines
    include "subroutines/antialias.f90"
    include "subroutines/antialias2d.f90"

    ! Weights
    include "subroutines/weights.f90"
    include "subroutines/weights_z.f90"

    ! File Output routines
    include "subroutines/write_cmatrix.f90"
    include "subroutines/write_rmatrix.f90"
    include "subroutines/write_cvector.f90"
    include "subroutines/write_rvector.f90"

    ! File Input routines
    include "subroutines/read_rvector.f90"

    ! Console Output routines
    include "subroutines/print_cmatrix.f90"
    include "subroutines/print_rmatrix.f90"
    include "subroutines/print_imatrix.f90"
    include "subroutines/print_cvector.f90"
    include "subroutines/print_rvector.f90"
    include "subroutines/print_ivector.f90"

    ! Matlab-like routines
    include "subroutines/tictoc.f90"
    include "subroutines/meshgrid.f90"

    include "functions/isfinite.f90"
    include "functions/linspace.f90"
    include "functions/logspace.f90"
    include "functions/norm.f90"

    ! Additional
    include "functions/plinspace.f90"
    include "functions/fourierwavnum.f90"
    include "functions/relerror_r.f90"
    include "functions/relerror_c.f90"
    include "functions/chebpts.f90"
    include "functions/legpts.f90"

    ! Vector generation
    include "functions/constvec_i.f90"
    include "functions/constvec_r.f90"
    include "functions/constvec_z.f90"

    ! LAPACK & BLAS wrappers
    include "subroutines/ZLU.f90"
    include "subroutines/ZMM.f90"

    include "functions/ZLUS.f90"

end module tools_mod


c=======================================================================
c
c     subroutine KERNELD
c
c     Density Estimation by Non Parametric Gaussian Kernel method
c
c-----------------------------------------------------------------------
      SUBROUTINE kerneld ( n, m, x, y, z, info )
c-----------------------------------------------------------------------
c
c     INPUT :
c            n      : number of histogram points (n>1)           integer
c            m      : number of grid points      (m>0)           integer
c            x      : returns/histogram (n)                       double
c            y      : grid (m)                                    double
c
c     OUTPUT :
c            z      : Gaussian kernel estimation (m)              double
c            info   : diagnostic argument                        integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, m, info
      DOUBLE PRECISION x(*), y(*), z(*)
c
c     local variables
      INTEGER i, j
      DOUBLE PRECISION h, hh, stdx, coef, pi, tmp, sumz
      PARAMETER ( pi = 3.1415926535898 )
c
c     external subroutines
      EXTERNAL VOLAT
c
c     intrinsic functions
      INTRINSIC sqrt, exp
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
      DO i = 1,m
        z(i) = 0.0
      ENDDO
c
c     standard deviation (volatility) of x
      CALL VOLAT ( n, x, stdx, info )
      IF (info .LT. 0) RETURN
c
c     optimal choice of h for Gaussian kernel (cf. D. Bosq and al. p85)
      h = (1.059*stdx)/(n**0.2)
c
c     coefficient
      coef = 1./(SQRT(2.0*pi))
      hh   = 2.0*(h*h)
c
c     Gaussian kernel estimation at z
      sumz = 0.0
      DO i = 1,m
        tmp = 0.0
          DO j = 1,n
             tmp = tmp + coef * EXP((-(y(i)-x(j))**2)/(hh))
          ENDDO
          z(i) = tmp / (n*h)
      ENDDO
      RETURN
      END


!
!*******************************************************************************
!
subroutine tri_eig(nm,n,d,e,z,ierror)
!
!*******************************************************************************
!
!  Discussion:
!
!---  This subroutine is a rewrite and update of the eispack routine tql2
!---  Revised 31 August 2020 to remove obsolete FORTRAN and to make
!---  compatible with FORTRAN 90
!
!----------    Original EISPACK coments   --------------------------------
!
!     this subroutine is a translation of the algol procedure tql2,
!     num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and
!     wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).
!
!     this subroutine finds the eigenvalues and eigenvectors
!     of a symmetric tridiagonal matrix by the ql method.
!     the eigenvectors of a full symmetric matrix can also
!     be found if  tred2  has been used to reduce this
!     full matrix to tridiagonal form.
!
!     on input
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement.
!
!        n is the order of the matrix.
!
!        d contains the diagonal elements of the input matrix.
!
!        e contains the subdiagonal elements of the input matrix
!          in its last n-1 positions.  e(1) is arbitrary.
!
!        z contains the transformation matrix produced in the
!          reduction by  tred2, if performed.  if the eigenvectors
!          of the tridiagonal matrix are desired, z must contain
!          the identity matrix.
!
!      on output
!
!        d contains the eigenvalues in ascending order.  if an
!          error exit is made, the eigenvalues are correct but
!          unordered for indices 1,2,...,ierror-1.
!
!        e has been destroyed.
!
!        z contains orthonormal eigenvectors of the symmetric
!          tridiagonal (or full) matrix.  if an error exit is made,
!          z contains the eigenvectors associated with the stored
!          eigenvalues.
!
!        ierror is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!     calls pythag_90 for  dsqrt(a*a + b*b) .
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!--------------     End of original EISPACK comments   ------------------
!
!  Date:
!
!    31 August 2020
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   implicit none
   integer(kind=4), intent(in) :: nm, n
   real(kind=8), intent(out) :: d(n), e(n), z(nm,n)
   integer(kind=4), intent(out) :: ierror
!-----------------------------------------------------------------------------
   integer(kind=4) :: i, j, k, l, m, ii, l1, l2, mml
   real(kind=8) :: c, c2, c3, dl1, el1, f, g, h, p, r, s, s2, tst1, tst2
!
!-------------    External functions
!
   real(kind=8) :: pythag_90
!
!*******************************************************************************
!
   ierror = 0
   if(n == 1)return   !   Nothing to be done if n = 1
!
   do i = 2, n
      e(i-1) = e(i)
   end do
!
   f = 0.0d0
   tst1 = 0.0d0
   e(n) = 0.0d0
!
   do l = 1, n
      j = 0
      h = abs(d(l)) + abs(e(l))
      if(tst1 < h) tst1 = h
!---   Look for small sub-diagonal element
      do m = l, n
         tst2 = tst1 + abs(e(m))
         if (tst2 == tst1)exit
!         if(abs(tst2 - tst1) < 1.0d-30)exit
      end do
!---   An eigenvalue is found
      if(m == l)then
         d(l) = d(l) + f
         cycle
      end if
!---   Do up to 30 iterations
      do j = 1, 30
         l1 = l + 1
         l2 = l1 + 1
         g = d(l)
         p = (d(l1) - g)/(2.0d0*e(l))
         r = pythag_90(p,1.0d0)
         d(l) = e(l)/(p + sign(r,p))
         d(l1) = e(l)*(p + sign(r,p))
         dl1 = d(l1)
         h = g - d(l)
!
         if(l2 <= n)then
            do i = l2, n
               d(i) = d(i) - h
            end do
        end if
!
        f = f + h
!
!---   QL transformation
!
         p = d(m)
         c = 1.0d0
         c2 = c
         el1 = e(l1)
         s = 0.0d0
         mml = m - l
         do ii = 1, mml
            c3 = c2
            c2 = c
            s2 = s
            i = m - ii
            g = c*e(i)
            h = c*p
            r = pythag_90(p,e(i))
            e(i+1) = s*r
            s = e(i) / r
            c = p / r
            p = c*d(i) - s*g
            d(i+1) = h + s*(c*g + s*d(i))
!
!---   Form eigenvectors
!
            do k = 1, n
               h = z(k,i+1)
               z(k,i+1) = s*z(k,i) + c*h
               z(k,i) = c*z(k,i) - s*h
            end do
         end do
!
         p = -s*s2*c3*el1*e(l)/dl1
         e(l) = s*p
         d(l) = c*p
         tst2 = tst1 + abs(e(l))
         if(tst2 <= tst1)exit
      end do
!
!----   Too many iterations and failed to find eigenvalues
!----   return with error flag set
!
      if(j == 30)then
         ierror = 1
         return
      end if
      d(l) = d(l) + f
   end do
!
!---   Order eigenvalues and eigenvectors
!
   do ii = 2, n
      i = ii - 1
      k = i
      p = d(i)
!
      do j = ii, n
         if (d(j) < p)then
            k = j
            p = d(j)
         end if
      end do
!
      if(k == i) cycle
      d(k) = d(i)
      d(i) = p
      do j = 1, n
         p = z(j,i)
         z(j,i) = z(j,k)
         z(j,k) = p
      end do
   end do
   return
end subroutine tri_eig
!
!*******************************************************************************
!
real(kind=8) function pythag_90(a,b)
   implicit none
   real(kind=8), intent(in) :: a, b
!
!*******************************************************************************
!
!  Discussion:
!
!----   Conversion of EISPACK routine pythag to FORTRAN 90
!----   Removed outdated FORTRAN and updated to be compatible
!----   with FORTRAN 90
!
!
!--------------     Original EISPACK comments   ------------------
!
!     finds dsqrt(a**2+b**2) without overflow or destructive underflow
!
!--------------     End of original EISPACK comments   ------------------
!
!
!  Date:
!
!    31 August 2020
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   real(kind=8) :: p, r, s, t, u
   pythag_90 = 0.0d0
   p = max(abs(a),abs(b))
   if(abs(p - 0.0d0) < 1.0d-30) return
   r = (min(abs(a),abs(b))/p)**2
   t = 4.0d0 + r
   do while(abs(t - 4.0d0) >= 1.0d-30)
      s = r/t
      u = 1.0d0 + 2.0d0*s
      p = u*p
      r = (s/u)**2*r
      t = 4.0d0 + r
   end do
   pythag_90 = p
   return
end function pythag_90


c       this file contains the following user-callable routines:
c
c
c       routine iddp_aid computes the ID, to a specified precision,
c       of an arbitrary matrix. This routine is randomized.
c
c       routine idd_estrank estimates the numerical rank,
c       to a specified precision, of an arbitrary matrix.
c       This routine is randomized.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine iddp_aid(eps,m,n,a,work,krank,list,proj)
c
c       computes the ID of the matrix a, i.e., lists in list
c       the indices of krank columns of a such that
c
c       a(j,list(k))  =  a(j,list(k))
c
c       for all j = 1, ..., m; k = 1, ..., krank, and
c
c                        krank
c       a(j,list(k))  =  Sigma  a(j,list(l)) * proj(l,k-krank)       (*)
c                         l=1
c
c                     +  epsilon(j,k-krank)
c
c       for all j = 1, ..., m; k = krank+1, ..., n,
c
c       for some matrix epsilon dimensioned epsilon(m,n-krank)
c       such that the greatest singular value of epsilon
c       <= the greatest singular value of a * eps.
c
c       input:
c       eps -- precision to which the ID is to be computed
c       m -- first dimension of a
c       n -- second dimension of a
c       a -- matrix to be decomposed; the present routine does not
c            alter a
c       work -- initialization array that has been constructed
c               by routine idd_frmi
c
c       output:
c       krank -- numerical rank of a to precision eps
c       list -- indices of the columns in the ID
c       proj -- matrix of coefficients needed to interpolate
c               from the selected columns to the other columns
c               in the original matrix being ID'd;
c               proj doubles as a work array in the present routine, so
c               proj must be at least n*(2*n2+1)+n2+1 real*8 elements
c               long, where n2 is the greatest integer less than
c               or equal to m, such that n2 is a positive integer
c               power of two.
c
c       _N.B._: The algorithm used by this routine is randomized.
c               proj must be at least n*(2*n2+1)+n2+1 real*8 elements
c               long, where n2 is the greatest integer less than
c               or equal to m, such that n2 is a positive integer
c               power of two.
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,n,list(n),krank,kranki,n2
        real*8 eps,a(m,n),proj(*),work(17*m+70)
c
c
c       Allocate memory in proj.
c
        n2 = work(2)
c
c
c       Find the rank of a.
c
        call idd_estrank(eps,m,n,a,work,kranki,proj)
c
c
        if(kranki .eq. 0) call iddp_aid0(eps,m,n,a,krank,list,proj,
     1                                   proj(m*n+1))
c
        if(kranki .ne. 0) call iddp_aid1(eps,n2,n,kranki,proj,
     1                                   krank,list,proj(n2*n+1))
c
c
        return
        end
c
c
c
c
        subroutine iddp_aid0(eps,m,n,a,krank,list,proj,rnorms)
c
c       uses routine iddp_id to ID a without modifying its entries
c       (in contrast to the usual behavior of iddp_id).
c
c       input:
c       eps -- precision of the decomposition to be constructed
c       m -- first dimension of a
c       n -- second dimension of a
c
c       output:
c       krank -- numerical rank of the ID
c       list -- indices of the columns in the ID
c       proj -- matrix of coefficients needed to interpolate
c               from the selected columns to the other columns in a;
c               proj doubles as a work array in the present routine, so
c               must be at least m*n real*8 elements long
c
c       work:
c       rnorms -- must be at least n real*8 elements long
c
c       _N.B._: proj must be at least m*n real*8 elements long
c
        implicit none
        integer m,n,krank,list(n),j,k
        real*8 eps,a(m,n),proj(m,n),rnorms(n)
c
c
c       Copy a into proj.
c
        do k = 1,n
          do j = 1,m
            proj(j,k) = a(j,k)
          enddo ! j
        enddo ! k
c
c
c       ID proj.
c
        call iddp_id(eps,m,n,proj,krank,list,rnorms)
c
c
        return
        end
c
c
c
c
        subroutine iddp_aid1(eps,n2,n,kranki,proj,krank,list,rnorms)
c
c       IDs the uppermost kranki x n block of the n2 x n matrix
c       input as proj.
c
c       input:
c       eps -- precision of the decomposition to be constructed
c       n2 -- first dimension of proj as input
c       n -- second dimension of proj as input
c       kranki -- number of rows to extract from proj
c       proj -- matrix containing the kranki x n block to be ID'd
c
c       output:
c       proj -- matrix of coefficients needed to interpolate
c               from the selected columns to the other columns
c               in the original matrix being ID'd
c       krank -- numerical rank of the ID
c       list -- indices of the columns in the ID
c
c       work:
c       rnorms -- must be at least n real*8 elements long
c
        implicit none
        integer n,n2,kranki,krank,list(n),j,k
        real*8 eps,proj(n2*n),rnorms(n)
c
c
c       Move the uppermost kranki x n block of the n2 x n matrix proj
c       to the beginning of proj.
c
        do k = 1,n
          do j = 1,kranki
            proj(j+kranki*(k-1)) = proj(j+n2*(k-1))
          enddo ! j
        enddo ! k
c
c
c       ID proj.
c
        call iddp_id(eps,kranki,n,proj,krank,list,rnorms)
c
c
        return
        end
c
c
c
c
        subroutine idd_estrank(eps,m,n,a,w,krank,ra)
c
c       estimates the numerical rank krank of an m x n matrix a
c       to precision eps. This routine applies n2 random vectors
c       to a, obtaining ra, where n2 is the greatest integer
c       less than or equal to m such that n2 is a positive integer
c       power of two. krank is typically about 8 higher than
c       the actual numerical rank.
c
c       input:
c       eps -- precision defining the numerical rank
c       m -- first dimension of a
c       n -- second dimension of a
c       a -- matrix whose rank is to be estimated
c       w -- initialization array that has been constructed
c            by routine idd_frmi
c
c       output:
c       krank -- estimate of the numerical rank of a;
c                this routine returns krank = 0 when the actual
c                numerical rank is nearly full (that is,
c                greater than n - 8 or n2 - 8)
c       ra -- product of an n2 x m random matrix and the m x n matrix
c             a, where n2 is the greatest integer less than or equal
c             to m such that n2 is a positive integer power of two;
c             ra doubles as a work array in the present routine, and so
c             must be at least n*n2+(n+1)*(n2+1) real*8 elements long
c
c       _N.B._: ra must be at least n*n2+(n2+1)*(n+1) real*8
c               elements long for use in the present routine
c               (here, n2 is the greatest integer less than or equal
c               to m, such that n2 is a positive integer power of two).
c               This routine returns krank = 0 when the actual
c               numerical rank is nearly full.
c
        implicit none
        integer m,n,krank,n2,irat,lrat,iscal,lscal,ira,lra,lra2
        real*8 eps,a(m,n),ra(*),w(17*m+70)
c
c
c       Extract from the array w initialized by routine idd_frmi
c       the greatest integer less than or equal to m that is
c       a positive integer power of two.
c
        n2 = w(2)
c
c
c       Allocate memory in ra.
c
        lra = 0
c
        ira = lra+1
        lra2 = n2*n
        lra = lra+lra2
c
        irat = lra+1
        lrat = n*(n2+1)
        lra = lra+lrat
c
        iscal = lra+1
        lscal = n2+1
        lra = lra+lscal
c
        call idd_estrank0(eps,m,n,a,w,n2,krank,ra(ira),ra(irat),
     1                    ra(iscal))
c
c
        return
        end
c
c
c
c
        subroutine idd_estrank0(eps,m,n,a,w,n2,krank,ra,rat,scal)
c
c       routine idd_estrank serves as a memory wrapper
c       for the present routine. (Please see routine idd_estrank
c       for further documentation.)
c
        implicit none
        integer m,n,n2,krank,ifrescal,k,nulls
        real*8 a(m,n),ra(n2,n),scal(n2+1),eps,residual,
     1         w(17*m+70),rat(n,n2+1)
c
c
c       Apply the random matrix to every column of a, obtaining ra.
c
        do k = 1,n
          call idd_frm(m,n2,w,a(1,k),ra(1,k))
        enddo ! k
c
c
c       Transpose ra to obtain rat.
c
        call idd_atransposer(n2,n,ra,rat)
c
c
        krank = 0
        nulls = 0
c
c
c       Loop until nulls = 7, krank+nulls = n2, or krank+nulls = n.
c
 1000   continue
c
c
          if(krank .gt. 0) then
c
c           Apply the previous Householder transformations
c           to rat(:,krank+1).
c
            ifrescal = 0
c
            do k = 1,krank
              call idd_houseapp(n-k+1,rat(1,k),rat(k,krank+1),
     1                          ifrescal,scal(k),rat(k,krank+1))
            enddo ! k
c
          endif ! krank .gt. 0
c
c
c         Compute the Householder vector associated
c         with rat(krank+1:*,krank+1).
c
          call idd_house(n-krank,rat(krank+1,krank+1),
     1                   residual,rat(1,krank+1),scal(krank+1))
          residual = abs(residual)
c
c
          krank = krank+1
          if(residual .le. eps) nulls = nulls+1
c
c
        if(nulls .lt. 7 .and. krank+nulls .lt. n2
     1   .and. krank+nulls .lt. n)
     2   goto 1000
c
c
        if(nulls .lt. 7) krank = 0
c
c
        return
        end
c
c
c
c
        subroutine idd_atransposer(m,n,a,at)
c
c       transposes a to obtain at.
c
c       input:
c       m -- first dimension of a, and second dimension of at
c       n -- second dimension of a, and first dimension of at
c       a -- matrix to be transposed
c
c       output:
c       at -- transpose of a
c
        implicit none
        integer m,n,j,k
        real*8 a(m,n),at(n,m)
c
c
        do k = 1,n
          do j = 1,m
c
            at(k,j) = a(j,k)
c
          enddo ! j
        enddo ! k
c
c
        return
        end


!########################################################
!     PURPOSE  : Solve the Hubbard model using DMFT away from half-filling
! with modified itertive perturbation scheme (MPT)
!     AUTHORS  : Adriano Amaricci
!########################################################
MODULE COMMON
  USE GREENFUNX
  USE BROYDEN
  implicit none
  real(8)                :: xmu0,n,n0
  type(matsubara_gf)     :: sigma,fg,fg0,gamma
  complex(8),allocatable :: sold(:)
END MODULE COMMON

FUNCTION FUNCV(x)
  USE COMMON
  USE DMFT_IPT
  implicit none
  real(8),dimension(:),intent(in)  ::  x
  real(8),dimension(size(x))       ::  funcv
  real(8)                          :: zn0
  xmu0=x(1)
  !Hartree corrected WF is: \tilde{\calG0}^-1 = \calG0^-1 +xmu -xmu0 -U*n
  fg0%iw = one/(one/gamma%iw +xmu-xmu0-u*(n-0.5d0))
  call fftgf_iw2tau(fg0%iw,fg0%tau,beta)
  n0=-real(fg0%tau(L),8)
  funcv(1)=n-n0
  write(*,"(3(f13.9))")n,n0,xmu0
END FUNCTION FUNCV

program hmmpt_matsubara
  USE DMFT_IPT
  USE COMMON
  USE SQUARE_LATTICE
  USE TOOLS
  USE IOTOOLS
  implicit none
  integer    :: i,Lk
  real(8)    :: x(1),z
  logical    :: check
  complex(8) :: zeta
  logical :: converged

  real(8) :: nread,nerror,ndelta
  integer :: nindex=0

  real(8),allocatable,dimension(:) :: wt,epsik,wm

  call read_input("inputIPT.in")
  call parse_cmd_variable(nread,"NREAD",default=0.d0)
  call parse_cmd_variable(nerror,"NERROR",default=1.d-4)
  call parse_cmd_variable(ndelta,"NDELTA",default=0.1d0)

  call allocate_gf(fg,L)
  call allocate_gf(fg0,L)
  call allocate_gf(sigma,L)
  call allocate_gf(gamma,L)
  allocate(sold(size(sigma%iw)))

  !Build frequency array
  allocate(wm(L))
  wm = pi/beta*real(2*arange(1,L)-1,8)

  !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)

  n=0.5d0 ; sigma%iw= U*(n-0.5d0) ; xmu0=xmu
  iloop=0 ; converged=.false.
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)")"DMFT-loop",iloop
     do i=1,L
        zeta    = xi*wm(i) + xmu - sigma%iw(i)
        !fg%iw(i) = gfbethe(wm(i),zeta,D)
        fg%iw(i) = sum_overk_zeta(zeta,epsik,wt)
     enddo
     call fftgf_iw2tau(fg%iw,fg%tau,beta)
     n=-real(fg%tau(L))

     !Get the regular Weiss Field: \Gamma(w+xmu)
     gamma%iw= one/(one/fg%iw + sigma%iw)

     !Fix the xmu0 w/ condition n0=n
     x(1)=xmu
     call broydn(x,check)
     xmu0=x(1)
     sigma%iw = solve_mpt_matsubara(fg0%iw,n,n0,xmu0)
     sigma%iw = weigth*sigma%iw + (1.d0-weigth)*sold ; sold=sigma%iw
     converged=check_convergence(sigma%iw,eps_error,Nsuccess,Nloop)
     z=1.d0 - dimag(sigma%iw(1))/wm(1);z=1.d0/z
     call splot("nVSiloop.ipt",iloop,n,append=TT)
     call splot("zetaVSiloop.ipt",iloop,z,append=TT)
     if(nread/=0.d0)call search_mu(converged)
  enddo
  call close_file("nVSiloop.ipt")
  call close_file("zetaVSiloop.ipt")
  call splot("G_iw.ipt",wm,fg%iw,append=printf)
  call splot("G0_iw.ipt",wm,fg0%iw,append=printf)
  call splot("Sigma_iw.ipt",wm,sigma%iw,append=printf)
  call splot("n.z.u.xmu.ipt",n,z,u,xmu,append=printf)

contains

  subroutine search_mu(convergence)
    real(8)               :: naverage
    logical,intent(inout) :: convergence
    real(8)               :: ndelta1
    integer               :: nindex1
    naverage=2.d0*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,"| xmu=",xmu
    write(*,"(A,f15.12)")"dn=",abs(naverage-nread)
    print*,""
    if(abs(naverage-nread)>nerror)convergence=.false.
    call splot("muVSiter.ipt",iloop,xmu,abs(naverage-nread),append=.true.)
  end subroutine search_mu

end program hmmpt_matsubara


! CalAzimTraveltime:  forward calculate the anisotropic traveltime.
!   used in the Forward program and inversion program.

        SUBROUTINE CalAzimTraveltime(nx,ny,nz,maxvp,dall,GGc,GGs,Gc,Gs,fwdTaa)
        IMPLICIT NONE
! INPUT
        INTEGER,INTENT(IN):: dall,maxvp,nx,ny,nz
        REAL,INTENT(IN):: GGc(dall,maxvp),GGs(dall,maxvp)
        REAL,INTENT(IN):: Gc(nx-2,ny-2,nz-1),Gs(nx-2,ny-2,nz-1)
! OUTPUT
        REAL :: fwdTaa(dall), fwdTgc(dall),fwdTgs(dall)
! PARAMETER
         INTEGER jj,kk,ii,i
         INTEGER nvx,nvz
         REAL GsCol(maxvp),GcCol(maxvp)

        nvx=nx-2
        nvz=ny-2

        DO jj=1,ny-2
        DO kk=1,nx-2
              GcCol( (jj-1)*nvx+kk:(nz-2)*nvz*nvx+(jj-1)*nvx+kk:nvx*nvz)=Gc(kk,jj,1:nz-1)
              GsCol( (jj-1)*nvx+kk:(nz-2)*nvz*nvx+(jj-1)*nvx+kk:nvx*nvz)=Gs(kk,jj,1:nz-1)
        ENDDO
        ENDDO

        fwdTgc=MATMUL(GGc,GcCol)
        fwdTgs=MATMUL(GGs,GsCol)
        fwdTaa=0

        DO i=1,dall
                fwdTaa(i)=fwdTgs(i)+fwdTgc(i)
        ENDDO
        END SUBROUTINE