module functionals
  use constants, only : dp, zero, one, two, eps, three, fpi, four, third
  implicit none


  integer             :: mfxcx=1, mfxcc=1, mgcx=0, mgcc=0
  real(dp), parameter :: f76 = 7.0_dp/6.0_dp,  f43 = FOUR * THIRD
  real(dp), parameter :: pi34 = THREE/FPI,  alpha = TWO/THREE

contains
  subroutine xc(rho,ex,ec,vx,vc)

    !==--------------------------------------------------------------==
    !==  lda exchange and correlation functionals (in Hartree a.u.)  ==
    !==                                                              ==
    !==  exchange  :  slater alpha                                   ==
    !==  correlation : ceperley & alder (perdew-zunger parameters)   ==
    !==                vosko, wilk & nusair                          ==
    !==                lee, yang & parr                              ==
    !==                perdew & wang                                 ==
    !==                wigner                                        ==
    !==                hedin & lundqvist                             ==
    !==                ortiz & ballone (perdew-zunger formula)       ==
    !==                ortiz & ballone (perdew-wang formula)         ==
    !==                gunnarsson & lundqvist                        ==
    !==--------------------------------------------------------------==

    use utilities, only : error

    real(dp), intent(in)  :: rho
    real(dp), intent(out) :: ex,ec,vx,vc
    integer               :: iflag
    real(dp)              :: rs

    if(rho <= EPS) then
       ec = ZERO
       vc = ZERO
       ex = ZERO
       vx = ZERO
    else 

       ! exchange
       select case (mfxcx)
       case (0)
          ex=ZERO
          vx=ZERO
       case (1)
          call slaterx(rho,ex,vx)
       case default
          call error('xc','invalid value of mfxcx',1)
       end select

       ! correlation: many different functionals are foreseen
       ! only two (perdew-zunger and wigner) actually implemented

       select case (mfxcc)
       case (0)
          ec=ZERO
          vc=ZERO
       case (1)                  ! Perdew-Zunger
          rs=(pi34/rho)**third
          if(rs < ONE) then
             iflag=1
          else
             iflag=2
          end if

          call pz(rs,ec,vc,iflag)
       case (2:5)                ! Wigner 
          call wigner(rho,ec,vc)
       case default
          call error('xc','invalid value of mfxcc',2)
       end select

    end if

    return
  end subroutine xc

  subroutine slaterx(rho,ex,vx)

    real(dp), intent(in) :: rho
    real(dp), intent(out):: ex, vx
    real(dp), parameter  :: f1 = -1.10783814957303361_dp ! -9/8*(3/pi)**(1/3)
    real(dp)             :: rs

    rs = rho**third
    ex = f1*alpha*rs
    vx = f43*f1*alpha*rs

    return
  end subroutine slaterx

!==--------------------------------------------------------------==
!==  j.p. perdew and alex zunger prb 23, 5048 (1981)             ==
!==--------------------------------------------------------------==

  subroutine pz(rs,epz,vpz,iflg)
    use utilities, only : error
 
    real(dp), intent(in)  :: rs
    real(dp), intent(out) :: epz, vpz
    integer, intent(in)   :: iflg

    real(dp), parameter :: a   = 0.0311_dp, b   =-0.048_dp, &
                           c   = 0.0020_dp, d   =-0.0116_dp,&
                           b1  = 1.0529_dp, b2  = 0.3334_dp, &
                           gc  =-0.1423_dp

    real(dp)            :: xln, rs1, rs2, ox,dox

    epz = ZERO
    vpz = ZERO

    select case (iflg)
    case (1) ! high-density formula
       xln=log(rs)
       epz=a*xln+b+c*rs*xln+d*rs
       vpz=a*xln + (b-a/THREE)+TWO/THREE*c*rs*xln+(TWO*d-c)/THREE*rs
    case (2) ! interpolation formula
        rs1 = sqrt(rs)
        rs2 = rs
        ox  = ONE + b1*rs1 + b2*rs2
        dox = ONE + f76*b1*rs1 + f43*b2*rs2
        epz = gc/ox
        vpz = epz*dox/ox
    case default 
       call error('pz','invalid flag',1)
    end select

    return
  end subroutine pz

  subroutine wigner(rho,fxc,exc)

    real(dp), intent(in)  :: rho
    real(dp), intent(out) :: fxc,exc
    real(dp)              :: x

    if(rho > EPS) then
       x=rho**THIRD
       fxc=-x*((0.943656+8.8963*x)/(1.0+12.57*x)**2)
       exc=-0.738*x*(0.959/(1.0+12.57*x))
    else
       fxc = ZERO
       exc = ZERO
    end if

    return
  end subroutine wigner
end module functionals
