!
!  Robust minimization functions
!
!  Copyright © 2011 - 2018 F.Hroch (hroch@physics.muni.cz)
!
!  This file is part of OakLeaf.
!
!  OakLeaf is free software: you can redistribute it and/or modify
!  it under the terms of the GNU Lesser General Public License as published by
!  the Free Software Foundation, either version 3 of the License, or
!  (at your option) any later version.
!
!  OakLeaf is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU Lesser General Public License for more details.
!
!  You should have received a copy of the GNU Lesser General Public License
!  along with OakLeaf.  If not, see <http://www.gnu.org/licenses/>.
!

module rfun

  implicit none

  ! M-estimator functions
  ! Hogg in Launer, Wilkinson: Robustness in Statistics

  ! default precision of real numbers
  integer, parameter, private :: kind = selected_real_kind(15)

  ! parameters of robust functions
  real(kind),parameter,private :: a = 1.349_kind
  real(kind),parameter,private :: a2 = a**2 / 2.0_kind
  real(kind),parameter,private :: c = 6.0_kind
  real(kind),parameter,private :: c2 = c**2 / 2.0_kind

  ! parameters for entropy determination (see test/eparam.f08)
  real(kind),parameter,public :: ehuber = 2.0045
  real(kind),parameter,public :: etukey = 2.1227

  public :: huber, dhuber, ihuber, tukey, dtukey, itukey, tukeys

contains

  !--------------------------------------------------------------
  !
  ! Robust functions
  !

  ! Huber

  elemental pure function huber(x)

    real(kind) :: huber
    real(kind), intent(in) :: x

    huber = max(-a,min(a,x))
!    if( abs(x) < a )then
!       huber = x
!    else
!       huber = sign(a,x)
!    endif

  end function huber


  elemental pure function dhuber(x)

    real(kind) :: dhuber
    real(kind), intent(in) :: x

    if( abs(x) <= a )then
       dhuber = 1.0_kind
    else
       dhuber = 0.0_kind
    endif

  end function dhuber

  elemental pure function ihuber(x)

    real(kind) :: ihuber
    real(kind), intent(in) :: x

    if( abs(x) < a ) then
       ihuber = x**2 / 2.0_kind
    else
       ihuber = a*abs(x) - a2
    end if

  end function ihuber


  ! Tukey

  elemental pure function tukey(x)

    real(kind) :: tukey
    real(kind), intent(in) :: x

    if( abs(x) < c )then
       tukey = x*(1.0_kind - (x/c)**2)**2
    else
       tukey = 0.0_kind
    endif

  end function tukey

  elemental pure function dtukey(x)

    real(kind) :: dTukey
    real(kind), intent(in) :: x
    real(kind) :: t

    if( abs(x) < c )then
       t = (x/c)**2
       dtukey = 1.0_kind + t*(5.0_kind*t - 6.0_kind)
    else
       dtukey = 0.0_kind
    endif

  end function dTukey

  elemental pure function iTukey(x)

    real(kind) :: itukey
    real(kind), intent(in) :: x
    real(kind) :: t

    if( abs(x) < c )then
       t = (x/c)**2
       iTukey = c2*t*(1.0_kind + t*(t/3.0_kind - 1.0_kind))
    else
       iTukey = 0.0_kind
    endif

  end function iTukey

  elemental pure subroutine tukeys(x,tukey,dtukey,itukey)

    real(kind), intent(in) :: x
    real(kind), intent(out) :: tukey,dtukey
    real(kind), intent(out), optional :: itukey
    real(kind) :: t
    logical :: l

    l = present(itukey)

    if( abs(x) < c )then
       t = (x/c)**2
       tukey = x*(1.0_kind - t)**2
       dtukey = 1.0_kind + t*(5.0_kind*t - 6.0_kind)
       if(l) iTukey = c2*t*(1.0_kind + t*(t/3.0_kind - 1.0_kind))
    else
       tukey = 0.0_kind
       dtukey = 0.0_kind
       if(l) iTukey = 0.0_kind
    endif

  end subroutine tukeys

end module rfun
