!
!  robust ratio
!
!  Copyright © 2012 - 2017 F.Hroch (hroch@physics.muni.cz)
!
!  This file is part of Munipack.
!
!  Munipack is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation, either version 3 of the License, or
!  (at your option) any later version.
!
!  Munipack 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 General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with Munipack.  If not, see <http://www.gnu.org/licenses/>.

module robratio

  ! This module provides subroutines for estimation of a mean ratio
  !
  !     t =  pht / cts
  !
  ! including estimation of its scatter.
  !
  ! rcal should be called as:
  !
  !  call rcal(pht,dpht,cts,dcts,t,dt,verbose,reliable,poisson)
  !
  ! on input:
  !   pht - array of reference (from a catalogue) number of photons
  !   dpht - array of statistical errors of pht
  !   cts - array of observed number of photons
  !   dcts - array of statistical errors of cts
  !   verbose - print additional info
  !
  ! on output are estimated:
  !   t - robust ratio
  !   dt - its standard error
  !   reliable - indicates reliability of results (optional)
  !   poisson - indicates Poisson (.true.) or Normal (.false.)
  !             distribution used for determine of results (optional)
  !
  ! The given results  means that a true value T of the sample pht/cts can be,
  ! with 70% probability, found in interval
  !
  !         t - dt  <  T  <  t + dt
  !
  ! The estimate is performed as maximum of entropy of Poisson density
  ! for values of pht smaller than 'plimit' (666) or by robust estimate
  ! of parameters of Normal distribution. Both the estimates are robust.
  ! Poisson mean is estimated on minimum of free energy:
  ! https://en.wikipedia.org/wiki/Helmholtz_free_energy

  implicit none

  integer, parameter, private :: dbl = selected_real_kind(15)

  ! verbose, updated by calling rcal()
  logical, private :: verbose = .false.

  ! which method of estimate of the ratio will be used?
  integer, parameter, private :: method = 2

  ! debuging
  logical, parameter, private :: debug = .false.

  ! Hessians are computed by analytic or numerical way
  logical, parameter, private :: analytic = .true.

  integer, parameter, private :: maxit = precision(0.0_dbl)
  ! Number of iterations is limited by numerical precision.
  ! We belives, as optimists, that one order is reached by each iteration.
  ! But, the pesimist, inside us, says that the convergence can be slower.

  ! Tolerances in numerical precision of iterations
  real(dbl), parameter, private :: tol = 10*epsilon(1.0_dbl)

  ! Limit for use of Poisson statistics (Normal otherwise)
  integer, parameter, private :: plimit = 666

  ! Parameter for regularisation
  real(dbl), private :: reg

  ! working arrays
  real(dbl), dimension(:), allocatable, private :: cts,dcts,pht,dpht,res, &
       dcts2,dpht2
  real(dbl), private :: xctph, sigma, rmin, rmax

  private :: fundif, funder, loglikely, residuals, residuals2, difjac, &
       jacobian_analytic, rnewton, snoise, snoise1, rcal2, rcal1, rcal0, &
       pnoisemin, entropy, rinit, ratiomin, zmean, zfun, pmean, negfree, &
       rmean_graph, poisson_graph, snoise_graph, graph, nscale

  ! implemened both single and double precision
  interface rcal
     module procedure rcal_double, rcal_single
  end interface rcal

contains

  subroutine rcal_double(xpht,xdpht,xcts,xdcts,ctph,dctph,verb,xreliable, &
       xpoisson)

    use rfun
    use weightedmean
    use medians

    real(dbl), dimension(:), target, intent(in) :: xpht,xdpht,xcts,xdcts
    real(dbl), intent(in out) :: ctph,dctph
    logical, optional, intent(in) :: verb
    logical, optional, intent(out) :: xreliable, xpoisson

    integer :: ndat,n,i,nplus,nstep
    real(dbl) :: d,c,r,w,sig,t0,s0,regold,sigold
    logical :: reliable, poisson, convergent

    if( present(verb) ) verbose = verb

    reliable = .false.
    poisson = .false.

    ndat = size(xpht)

    if( ndat < 1 ) then                ! no data
       ctph = 1
       dctph = 0
       return
    endif

    if( ndat == 1 ) then               ! single point only
       ctph = xpht(1) / xcts(1)
       dctph = 1
       return
    endif

    ! data check
    if( .not. (all(xpht > 0) .and. all(xcts > 0) .and. all(xdpht > 0) .and. &
         all(xdcts > 0) ) ) &
         stop 'robratio.f08: rcal got invalid data (negative or zero counts).'
    if( size(cts) /= size(pht) ) stop 'robratio.f08: size(cts) /= size(pht)'
    if( size(dcts) /= size(dpht) ) stop 'robratio.f08: size(dcts) /= size(dpht)'
    if( size(cts) /= size(dcts) ) stop 'robratio.f08: size(cts) /= size(dcts)'
    if( size(pht) /= size(dpht) ) stop 'robratio.f08: size(pht) /= size(dpht)'

    allocate(pht(ndat),cts(ndat),dpht(ndat),dcts(ndat),res(ndat),&
         dpht2(ndat),dcts2(ndat))
    pht = xpht
    cts = xcts
    dpht = xdpht
    dcts = xdcts
!    dpht = sqrt(pht)
!    dcts = sqrt(cts)
    dpht2 = dpht**2
    dcts2 = dcts**2

    ! determine range for ratio
    rmin = minval(pht/cts)
    rmax = maxval(pht/cts)

    ! no regularisation
    reg = 0

    i = max(int(log10(real(ndat))) - 1,0)
    nstep = 10**i
    if( verbose .and. nstep > 1 ) write(*,'(a,i0,a)') &
         'Warning: printing only every ',nstep,'th datapoint.'

    ! initial estimate of ctph and spread, by absolute values
    call rinit(ctph,sig)
    call residuals(ctph,res)

    if( verbose ) then
       write(*,*) 'Data table: pht(i),dpht(i),cts(i),dcts(i), ratio, residuals'
       do i = 1,ndat,nstep
          r = pht(i) / cts(i)
          write(*,'(i3,1p,2(g15.5,g10.3),0pf11.3,f10.3)') &
               i,pht(i),dpht(i),cts(i),dcts(i),r,res(i)
       end do
       write(*,'(a50,1pg15.5,1x,0pg8.2)') &
            "Initial ctph, sig by min. of absolute deviations:",ctph,sig
    end if

    ! singular data
    if( abs(sig) < tol ) then
       if( verbose ) write(*,*) &
            '(!) Skipping robust estimation -- singular data.'
       dctph = 0
       reliable = .true.
       goto 666
    end if


    ! update sig by entropy
!    sig = snoise(ctph,sig)


    ! Solvers
    select case(method)

    case(0)
       ! maximum likelihood
       call rcal0(ctph,dctph,sig)

    case(1)
       ! Scale by entropy, ratio by maximum likelihood
       call rcal1(ctph,dctph,sig)

    case(2)
       ! Poisson (for low counts), Normal otherwise with var() ~= 1

!       call rcal3(ctph,dctph,sig,reliable,poisson)

       t0 = ctph
       s0 = sig

       sigold = -1
       do i = 0,666,10
          reg = i
          call rcal2(ctph,sig,reliable,poisson)
!          write(*,*) reg,ctph,sig
          if( sig < 1 ) exit
          sigold = sig
          regold = reg
       end do
       ! solve reg. parameter by linear interpolation to the condition sig=1
       if( sigold > 0 .and. abs(sig - sigold) > epsilon(sig) ) then
          reg = regold + (1 - sigold)*(reg - regold)/(sig - sigold)
          call rcal2(ctph,sig,reliable,poisson)
       end if

       if( verbose ) &
            write(*,'(a50,1pg15.3)') 'Regularisation parameter:',reg

       if( reliable ) then

          t0 = ctph
          s0 = sig

          call rnewton(ctph,dctph,sig,convergent)

          reliable = convergent .and. (rmin <= ctph .and. ctph <= rmax)

          if( verbose ) write(*,'(a50,1pg15.5,1x,0pg8.2,l3)') &
               'Robust mean by Newton with std.err.:',ctph,dctph,convergent
       end if

       if( .not. reliable ) then
          ctph = t0
          sig = s0
          dctph = sig * ctph * median(sqrt(ctph**2*dcts2 + dpht2)) / &
               (0.6745 * median((cts*ctph + pht)/2))
!          dctph = median(sig*sqrt(t**2*dcts**2 + dpht**2)) / 0.6745
       end if

    case default
       ! No default is here, initial estimates will be used
       continue

    end select

666 continue

    ! residual sum
    if( verbose ) then
       call residuals(ctph,res)
       write(*,*) '# photons, computed counts, rel.err, expected rel.err, res., huber, dhuber:'
       do i = 1,ndat,nstep
          c = ctph*cts(i)
          d = (pht(i) - c)/((pht(i) + c)/2)
          w = sqrt((dpht(i)/ctph)**2 + dcts(i)**2)/((cts(i) + pht(i)/ctph)/2.0)
          if( sig > 0 ) then
             r = res(i) / sig
          else
             r = 0
          end if
          write(*,'(i3,1p2g13.4,0p2f10.5,3f8.3)') &
               i,pht(i),c,d,w,r,huber(r),dhuber(r)
       enddo
       n = count(abs(res) < sig)
       nplus = count(res > 0)
       write(*,'(a,g0.5,a,1pg0.1,a,5x,a,g0.3)') &
            'ctph = ',ctph,' +- ',dctph,',','sig = ',sig
       write(*,'(a,i0,a,i0,a,f0.1,a)') &
            'Points within 1-sigma error interval: ', &
            n,'/',ndat,' (',100.*real(n)/real(ndat),'%)'
       write(*,'(a,i0,"/",f0.1,",   ",i0,"+-",f0.1)') &
            'Sign test (total/expected, +):  ',&
            ndat,ndat/2.0,nplus,sqrt(nplus*0.25)
       ! Test whatever the errors corresponds to values to prove
       ! Poisson's origin. It is quantity like
       ! https://en.wikipedia.org/wiki/Index_of_dispersion
       write(*,'(a,2(1x,g0.3,1x,a,:","))') 'Mean Poissonity (best=1): ',&
            sqrt(sum(dpht**2/pht)/ndat),'(reference)', &
            sqrt(sum(dcts**2/cts)/ndat),'(data)'
    end if

    deallocate(res,pht,cts,dpht,dcts,dpht2,dcts2)

    if( present(xreliable) ) xreliable = reliable
    if( present(xpoisson) ) xpoisson = poisson

  end subroutine rcal_double

  subroutine rcal_single(xpht,xdpht,xcts,xdcts,ctph,dctph,xverb,xreliable,&
       xpoisson)

    real, dimension(:), target, intent(in) :: xpht,xdpht,xcts,xdcts
    real, intent(in out) :: ctph,dctph
    logical, optional, intent(in) :: xverb
    logical, optional, intent(out) :: xreliable, xpoisson

    logical :: verb,reliable,poisson
    real(dbl) :: t,dt
    real(dbl), dimension(:), allocatable :: pht,dpht,cts,dcts
    integer :: n

    if( present(xverb) ) then
       verb = xverb
    else
       verb = .false.
    end if

    if( size(xcts) /= size(xpht) ) &
         stop 'robratio.f08, single: size(cts) /= size(pht)'
    if( size(xdcts) /= size(xdpht) ) &
         stop 'robratio.f08, single: size(dcts) /= size(dpht)'
    if( size(xcts) /= size(xdcts) ) &
         stop 'robratio.f08, single: size(cts) /= size(dcts)'
    if( size(xpht) /= size(xdpht) ) &
         stop 'robratio.f08, single: size(pht) /= size(dpht)'

    n = size(xpht)
    allocate(pht(n),dpht(n),cts(n),dcts(n))
    pht = xpht
    dpht = xdpht
    cts = xcts
    dcts = xdcts

    call rcal_double(pht,dpht,cts,dcts,t,dt,verb,reliable,poisson)
    ctph = real(t)
    dctph = real(dt)

    if( present(xreliable) ) xreliable = reliable
    if( present(xpoisson) ) xpoisson = poisson

    deallocate(pht,dpht,cts,dcts)

  end subroutine rcal_single



  subroutine residuals(t,r)

    real(dbl), intent(in) :: t
    real(dbl), dimension(:), intent(out) :: r
    real(dbl) :: t2

    t2 = t**2

!    r = (pht - t*cts) / sqrt(t**2*dcts**2 + dpht**2)
!    r = (pht - t*cts) / sqrt(t2*dcts2 + dpht2 +  (pht+t*cts)/2*  reg**2)
    r = (pht - t*cts) / sqrt(t2*dcts2 + dpht2 +  pht*  reg**2)
!    r = (pht - t*cts) / (dcts*sqrt(t) + dpht)

!    write(*,*) pht(1),cts(1),dcts2(1),dpht2(1),r(1),t,&
!         (pht(1)-t*cts(1))/sqrt(t2*dcts2(1)+dpht2(1)),t2,r(1)

  end subroutine residuals

  subroutine residuals2(t,r,ds)

    real(dbl), intent(in) :: t
    real(dbl), dimension(:), intent(out) :: r,ds
    real(dbl) :: t2

    t2 = t**2
    !    r = (pht - t*cts) / sqrt(t**2*dcts**2 + dpht**2)
!    ds = sqrt(t2*dcts2 + dpht2 + (pht+t*cts)/2* reg**2)
    ds = sqrt(t2*dcts2 + dpht2 + pht* reg**2)
    r =  (pht - t*cts) / ds
!    ds = dcts*sqrt(t) + dpht
!    r = (pht - t*cts) / ds

  end subroutine residuals2


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

  subroutine rcal2(ctph,sig,reliable,poisson)

    use rfun

    real(dbl), intent(in out) :: ctph, sig
    logical, intent(out) :: reliable,poisson

    integer :: n
    real(dbl) :: t,dt,s,s0,t0
    logical :: reli, treli, sreli

    n = size(pht)
    t = ctph
    s = sig

    if( maxval(pht) < plimit ) then
       poisson = .true.

       call pmean(ctph)
       dt = sig

       reliable = .true.
    else

       t0 = t
       s0 = s
       reliable = .false.

       call zmean(t,s,treli)
       call nscale(t,s,sreli)
       reli = treli .and. sreli
!       s = snoise(t,s)

       if( verbose ) write(*,'(a50,1pg15.5,1x,0pg8.2,1x,2l1)') &
            'Robust mean estimation, sig by entropy:',t,s,treli,sreli

       reliable = reli .and. (rmin <= t .and. t <= rmax)

       if( reliable ) then
          ctph = t
          sig = s
       else
          ctph = t0
          sig = s0
       end if

    end if

    if( debug ) then
       call snoise_graph(ctph,sig)
       call rmean_graph(ctph-3*sig,ctph+5*sig,sig)
       call poisson_graph
    end if

  end subroutine rcal2

!!$  subroutine rcal3(ctph,dctph,sig,reliable,poisson)
!!$
!!$    use rfun
!!$    use medians
!!$    use fmm
!!$
!!$    real(dbl), intent(in out) :: ctph, sig
!!$    real(dbl), intent(out) :: dctph
!!$    logical, intent(out) :: reliable,poisson
!!$    real(dbl), parameter :: tol = 1e-2
!!$    real(dbl), parameter :: regmin = 0
!!$    real(dbl), parameter :: regmax = 1e3
!!$
!!$    sigma = sig
!!$    xctph = ctph
!!$!    sig = fmin(regmin,regmax,sigfun,tol)
!!$    sig = zeroin(regmin,regmax,sigfun,tol)
!!$
!!$    ctph = xctph
!!$    call rcal2(ctph,dctph,sig,reliable,poisson)
!!$
!!$  end subroutine rcal3
!!$
!!$  function sigfun(r)
!!$
!!$    real(dbl) :: sigfun
!!$    real(dbl), intent(in) :: r
!!$    real(dbl) :: ctph,dctph, s
!!$    logical :: reliable,poisson
!!$
!!$    reg = r
!!$!    s = sig
!!$    call rcal2(xctph,dctph,sigma,reliable,poisson)
!!$    xctph = ctph
!!$    sigfun = sigma - 1
!!$
!!$  end function sigfun

  subroutine rcal1(ctph,dctph,sig)

    real(dbl), intent(in out) :: ctph, sig
    real(dbl), intent(out) :: dctph

    integer :: iter
    real(dbl) :: t,dt,s,t1
    logical :: convergent

    t = ctph
    s = sig
    t1 = huge(t)

    do iter = 1,maxit

       ! precision of mean improved with the updated scale
       call rnewton(t,dt,s,convergent)

       convergent = abs(t - t1) < tol .and. convergent
       if( convergent ) exit

       s = snoise(t,s)
       t1 = t
    end do

    if( convergent ) then
       ctph = t
       dctph = dt
       sig = s
    else
       dctph = -1
    end if

    if( .not. convergent .and. verbose ) &
         write(*,*) &
         "Warning: Likelihood and entropy iterations shows no convergence!"

    if( debug ) call snoise_graph(ctph,sig)

  end subroutine rcal1


  subroutine rnewton(t,dt,s,convergent)

    use rfun

    real(dbl), intent(in out) :: t
    real(dbl), intent(out) :: dt
    real(dbl), intent(in) :: s
    logical, intent(out) :: convergent

    integer :: n,iter
    real(dbl) :: xtol,d,f,df,f2
    real(dbl), dimension(:), allocatable :: r,psi,dpsi,ds,rs,ds2

    convergent = .false.

    if( .not. (s > 0) ) return

    n = size(pht)
    allocate(r(n),psi(n),dpsi(n),ds(n),rs(n),ds2(n))

    ! tolerance limit will depends on number of elements in sums
    ! because every element can include its rounding error...
    ! ... proportional to absolute value ...
    xtol = n*tol*abs(t)

    do iter = 1, maxit

       ! solution of f(t) = 0, where f(t) = sum(psi((n-t*c)/(s*ds))
       call residuals2(t,r,ds)
       rs = r / s
       ds2 = ds**2
       call tukeys(rs,psi)
       call dtukeys(rs,dpsi)

       f = t*sum((psi*r-1.0_dbl)*(dcts/ds)**2) + sum(psi*cts/ds)
       df = sum(dpsi*(cts/ds + r*t*dcts2/ds2)**2) &
            -sum(psi*(pht - 3*t*cts)*(dcts/ds)**2/ds) &
            +sum(psi*3*r*t**2*(dcts/ds)**4) &
            +sum((dcts/ds)**2) - 2*t**2*sum((dcts2/ds2)**2)

       if( abs(df) < epsilon(df) ) exit

       ! corrector for mean
       d = s * f / df

       ! update location
       t = t + d

       if( debug ) write(*,'(a,i2,1pg20.10,1p3g12.3)') &
            "mean, incr., f, f': ",iter,t,d,f,df

       convergent = abs(d) < xtol

       ! exit of iterations: the absolute errot must be at least |d| < tol
       if( convergent ) exit

    enddo

    f2 = sum(psi**2)  ! mean of psi**2
    df = df * s**2
!    write(*,*) f2,d,df
    if( convergent .and. df > 0 .and. f2 > 0 ) then
       dt = s*sqrt(f2/df**2*n/(n-1)) ! df is an element of Jacobian
    end if

    deallocate(r,psi,dpsi,ds,rs,ds2)

  end subroutine rnewton

  subroutine nscale(t,s,reli)

    use entropyscale

    real(dbl), intent(in) :: t
    real(dbl), intent(in out) :: s
    logical, intent(out) :: reli
    real(dbl), dimension(:), allocatable :: r
    integer :: n

    n = size(pht)
    allocate(r(n))
    call residuals(t,r)
    call escale(r,s,reli)
    deallocate(r)

  end subroutine nscale

  function snoise(t,s)

    use fmm

    real(dbl), intent(in) :: t,s
    real(dbl) :: snoise

    real(dbl), dimension(:), allocatable :: r
    real(dbl) :: stol,smin,smax
    integer :: n

    stol = 1e-3
    smin = max(s / 10, epsilon(s))
    smax = min(s * 10, (rmax - rmin)/2)

    n = size(pht)
    allocate(r(n))
    call residuals(t,r)
    smin = minval(abs(r))
    smax = maxval(abs(r))
    deallocate(r)
    xctph = t
    snoise = fmin(smin,smax,pnoisemin,stol)

  end function snoise

  function pnoisemin(s)

    real(dbl), intent(in) :: s
    real(dbl) :: pnoisemin

    pnoisemin = - entropy(xctph,s)

  end function pnoisemin

  function entropy(t,s)

    use rfun

    real(dbl), parameter :: expmax = log(huge(1.0_dbl)/2.1)

    real(dbl), intent(in) :: t,s
    real(dbl) :: entropy
    real(dbl), dimension(:), allocatable :: r,rho
    integer :: n

    n = size(pht)
    allocate(r(n),rho(n))

    call residuals(t,r)
    call ihubers(r/s,rho)
    entropy = sum(rho*exp(-2*rho),rho < expmax)
    deallocate(r,rho)

  end function entropy



  subroutine snoise1(t,sig)

    ! Estimate of maximum entropy by Newton's method
    ! While, I'd pin one's hopes on the method, it does not stands
    ! many common data (convergence is occurred only for ideal data). Perhaps,
    ! there are __numerical problems__ in evaluations of exponential functions.
    ! Or, it is bad idea to do derivate of its derivative.

    use rfun

    real(dbl), intent(in) :: t
    real(dbl), intent(in out) :: sig

    integer :: n,iter
    real(dbl) :: s,sum1,sum2,fs,dfs,d
    real(dbl), dimension(:), allocatable :: r,f,df,rho,erho
    logical :: convergent

    n = size(pht)
    allocate(r(n),rho(n),df(n),f(n),erho(n))

    s = sig
    convergent = .false.

    do iter = 1, maxit

       if( .not. (s > 0) ) exit

       call residuals(t,r)
       call ihubers(r/s,rho)
       call hubers(r/s,f)
       call dhubers(r/s,df)

!       rho = (r/s)**2/2
!       f = r/s
!       df = 1

       erho = exp(-2*rho)
       sum1 = sum(f*r*(1-2*rho)*erho)
       sum2 = sum(((1-2*rho)*(2*f**2-df) + 2*f**2)*r**2*erho)

       fs = -sum1 / s**2
       dfs = 2*sum1 / s**3 - sum2 / s**4

       ! Note. If we have good initial estimate, than sum1 (=fs) is near to zero
       ! and sum1 / sum2 * s**2 is numerically equivalent, but little bit
       ! faster, than fs/dfs. Their numerical difference is negligible.

       if( .not. (abs(dfs) > 0) ) exit

       ! Newton's step for scale
       d = fs / dfs
       s = s - d

       if( debug ) write(*,'(a,i3,4g15.5)') "scale,f,f',incr.",iter,s,d,fs,dfs

       ! exit immediately when required precision is reached
       convergent = abs(d) < 10*epsilon(sig)
       if( convergent ) exit

    end do

    deallocate(r,f,df,rho,erho)

    if( convergent ) sig = s

    if( debug ) call snoise_graph(t,s)

  end subroutine snoise1



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

  subroutine rcal0(ctph,dctph,sig)

    use rfun
    use minpacks
    use neldermead

    real(dbl), intent(in out) :: ctph,sig
    real(dbl), intent(out) :: dctph

    integer :: ndat,i,info,nprint,icount,numres,ifault,nwins
    real(dbl) :: c,s,log0,wsig,sum2,sum3,reqmin
    real(dbl),dimension(:), allocatable :: p,dp
    real(dbl),dimension(2,2) :: jac, hess
    real(dbl),dimension(2) :: u,u0,du

    if( verbose ) then
       nprint = 1
    else
       nprint = 0
    end if

    ndat = size(pht)

    ! winsorisation at x-sigma
    if( verbose ) write(*,'(a,f3.1,a)') 'Winsorisation at ',winscut, &
         " for pht, ctph*cts, dpht, residual in sigma, replacement: "
    nwins = 0
    call residuals(ctph,res)
    do i = 1,ndat
       if( abs(res(i)) > winscut ) then
          nwins = nwins + 1
          wsig = - sign(winscut,res(i))
          c = max(pht(i) + wsig*sqrt(dpht(i)**2+ctph**2*dcts(i)**2),0.0)
          if( verbose ) &
               write(*,'(i3,1p2g15.5,g12.2,1pg11.3,g15.5)') &
               i,pht(i),ctph*cts(i),dpht(i),res(i),c
          cts(i) = c / ctph
       end if
    end do

    ! locate proper solution
    ! Approximate location of -log(L), the function has one global minimum
    du(1) = 0.1*ctph
    du(2) = 0.1*sig
    u = (/ctph, sig/)
    u0 = u
    reqmin = epsilon(reqmin)
    call nelmin(loglikely,size(u),u0,u,log0,reqmin,du,1,10000,icount,numres,ifault)
    if( verbose ) write(*,'(a,2i6,3g15.5)') 'Log-likelihood solution: ',ifault,icount,u

    if( ifault /= 0 ) then
       if( verbose ) write(*,*) "Finished prematurely without likelihood convergence."
       goto 666
    endif


    s = u(2)
    ctph = u(1)
    dctph = s/sqrt(real(ndat))

    if( verbose ) write(*,'(a,2g10.5,i6)') &
         'ctph, s (winsorising and robust applied): ',ctph,s,nwins

    ! solution of psi( (pht(i) - ctph*cts(i)) / s*sqrt(..)
    if( verbose ) write(*,'(4(6x,a2,7x))') 't','s','f1','f2'
    if( analytic ) then
       call lmder2(funder,u,epsilon(u),nprint,info)
    else
       call lmdif2(fundif,u,epsilon(u),nprint,info)
    end if

    if( verbose ) then
       write(*,*) 'Analytic jacobian: ',analytic
       write(*,*) 'Minpack info:',info
    end if

    if( info /= 5 ) then

       ctph = u(1)
       s = u(2)
       sig = huber_sigcorr*sig

       call jacobian_analytic(u,jac)
       call qrinv(jac,hess)

       if( verbose ) then
          write(*,*) 'jac:',real(jac(1,:))
          write(*,*) 'jac:',real(jac(2,:))
          write(*,*) 'hess:',real(hess(1,:))
          write(*,*) 'hess:',real(hess(2,:))
       end if

       ! estimate errors
       if( hess(1,1) > 0 .and. ndat > 1 ) then
          allocate(p(ndat),dp(ndat))
          call residuals(ctph,res)
          call hubers(res/s,p)
          call dhubers(res/s,dp)
          sum2 = sum(dp)
          sum3 = sum(p**2)
          if( sum2 > 0 .and. sum3 > 0 ) then
             dctph = s*sig*ndat*sqrt(sum3/sum2/(ndat-1.0)*hess(1,1))
          end if
          deallocate(p,dp)
       else
          dctph = -1
       end if

    else

       if( verbose ) write(*,*) "Finished prematurely without convergence in gradient."

    end if

666 continue

  end subroutine rcal0



  subroutine fundif(m,np,p,fvec,iflag)

    use rfun

    integer, intent(in) :: m,np
    integer, intent(inout) :: iflag
    real(dbl), dimension(np), intent(in) :: p
    real(dbl), dimension(m), intent(out) :: fvec
    real(dbl), dimension(:), allocatable :: r,f,ds
    real(dbl), dimension(2,2) :: jac
    real(dbl), dimension(2) :: fv
    integer :: n
    real(dbl) :: t,s

    if( iflag == 0 ) then

       write(*,'(4g15.5)') p,fvec

       if( debug ) then
          n = 2
          call funder(2,2,p,fv,jac,2,n)
          write(*,*) ' jac:',jac(1,:)
          write(*,*) ' jac:',jac(2,:)

       end if
       return

    end if

    n = size(pht)
    allocate(r(n),f(n),ds(n))
    t = p(1)
    s = p(2)

!    ds = sqrt(t**2*dcts**2 + dpht**2)
    ds = sqrt(t**2*dcts2 + dpht2)
    r = (pht - t*cts)/ds
    r = r / s

    call hubers(r,f)
!    f = r

    fv(1) = sum(f*(cts*dpht2 + pht*t*dcts2)/ds**3) - s*t*sum(dcts2/ds**2)
!    fv(1) = sum(f*(cts*dpht**2 + pht*t*dcts**2)/ds**3) - s*t*sum(dcts**2/ds**2)
    fv(2) = sum(f*r) - n

    fvec = fv / s

    deallocate(r,f,ds)

  end subroutine fundif


  subroutine funder(m,np,p,fvec,fjac,ldfjac,iflag)

    use rfun

    integer, intent(in) :: m,np,ldfjac
    integer, intent(inout) :: iflag
    real(dbl), dimension(np), intent(in) :: p
    real(dbl), dimension(m), intent(out) :: fvec
    real(dbl), dimension(ldfjac,np), intent(out) :: fjac
    real(dbl), dimension(:), allocatable :: r,f,df,ds,ds2,cs,dd,d1s,d2s
    real(dbl), dimension(2,2) :: dfjac
    integer :: n
    real(dbl) :: t,s

    if( iflag == 0 ) then
       write(*,'(4g15.5)') p,fvec

       if( debug ) then
          write(*,*) ' jac:',fjac(1,:)
          write(*,*) ' jac:',fjac(2,:)

          call difjac(p(1),p(2),dfjac)
          write(*,*) 'djac:',dfjac(1,:)
          write(*,*) 'djac:',dfjac(2,:)

       end if

       return
    end if

    n = size(pht)
    allocate(r(n),f(n),ds(n),cs(n),ds2(n),df(n),dd(n),d1s(n),d2s(n))
    t = p(1)
    s = p(2)

!    ds2 = t**2*dcts**2 + dpht**2
    ds2 = t**2*dcts2 + dpht2
    ds = sqrt(ds2)
    r = (pht - t*cts)/(s*ds)

    call hubers(r,f)
!    f = r

    dd = pht - t*cts
    d1s = t*dcts**2/ds
    d2s = dcts**2*(ds - t*d1s)/ds2
    cs = cts*ds + dd*d1s

    if( iflag == 1 ) then

       fvec(1) = sum(f*cs/s/ds2) - sum(d1s/ds)
       fvec(2) = sum(f*dd/s**2/ds) - n/s

    else if( iflag == 2 ) then

       call dhubers(r,df)
!       df = 1

       fjac(1,1) = sum(df*(cs/s/ds2)**2) - &
            sum(f*(dd*(d2s*ds-2*d1s**2)-2*cts*ds*d1s)/s/ds**3) + &
            sum((d2s*ds - d1s**2)/ds**2)
       fjac(1,2) = sum(df*cs*dd/s**3/ds**3) + sum(f*cs/s**2/ds2)
       fjac(2,2) = sum(df*(dd/s**2/ds)**2) + sum(f*2*dd/s**3/ds) - n/s**2

       fjac(2,1) = fjac(1,2)
       fjac = - fjac

    end if

    deallocate(r,f,ds,cs,ds2,df,dd,d1s,d2s)

  end subroutine funder


  subroutine difjac(t,s,jac)

    real(dbl), intent(in) :: t,s
    real(dbl), dimension(:,:), intent(out) :: jac
    real(dbl), parameter :: d = 1e-4
    real(dbl), dimension(2) :: fv1,fv2
    integer :: iflag

    iflag = 1

    call fundif(2,2,(/t+d,s/),fv1,iflag)
    call fundif(2,2,(/t-d,s/),fv2,iflag)
    jac(1,:) = (fv1 - fv2)/(2*d)

    call fundif(2,2,(/t,s+d/),fv1,iflag)
    call fundif(2,2,(/t,s-d/),fv2,iflag)
    jac(2,:) = (fv1 - fv2)/(2*d)

  end subroutine difjac



  function loglikely(p)

    use rfun

    real(dbl), dimension(:), intent(in) :: p
    real(dbl) :: loglikely
    real(dbl), dimension(:), allocatable :: r,f,ds
    integer :: n
    real(dbl) :: t,s

    n = size(pht)
    t = p(1)
    s = p(2)

    if( s < epsilon(s) ) then
       loglikely = huge(loglikely)
       return
    end if

    allocate(r(n),f(n),ds(n))
!    ds = s * sqrt(t**2*dcts**2 + dpht**2)
    ds = s * sqrt(t**2*dcts2 + dpht2)
    r = (pht - t*cts)/ds

    call ihubers(r,f)
!    f = r**2/2
    loglikely = sum(f) + sum(log(ds))

    deallocate(r,f,ds)

  end function loglikely

  subroutine jacobian_analytic(p,fjac)

    use rfun

    real(dbl), dimension(:),intent(in) :: p
    real(dbl), dimension(:,:), intent(out) :: fjac
    real(dbl), dimension(:), allocatable :: r,rs,f,df,ds,ds2
    integer :: n
    real(dbl) :: t,s

    n = size(pht)
    allocate(r(n),rs(n),f(n),ds(n),ds2(n),df(n))
    t = p(1)
    s = p(2)

!    ds2 = t**2*dcts**2 + dpht**2
    ds2 = t**2*dcts2 + dpht2
    ds = sqrt(ds2)
    r = pht - t*cts
    rs = r /(s*ds)

    call hubers(rs,f)
    !    f = r
    call dhubers(rs,df)
    !       df = 1

    ! this is a very simple approximation only

    fjac(1,1) = sum(df) ! sum(df*cts**2)
    fjac(1,2) = 0 !sum(df*r*cts)/s + sum(f*cts*ds)
    fjac(2,1) = fjac(1,2)
    fjac(2,2) = n !sum(df*r**2/s**2) + n

    deallocate(r,rs,f,ds,ds2,df)

  end subroutine jacobian_analytic

  subroutine rinit(t,s)

    ! This is a the first estimation of ratio parameter.
    ! I'm in doubts to use Newton's method or fmin by Brent's
    ! method (Golden sections search on star and interpolation
    ! by parabola near minimum). Brent's method looks to be
    ! extraordinary robust... especially when absolute value
    ! is processed.

    use fmm
    use medians
    use qmeans

    real(dbl), intent(out) :: t,s
    integer :: n
    real(dbl) :: d,ds
!    real(dbl) :: rtol

!    rtol = 1e-5*max(1.0,rmax)
    !    t = fmin(rmin,rmax,ratiomin,rtol)


    n = size(pht)

    if( n > 30 ) then
       t = qmedian(pht/cts)
       ds = qmedian(sqrt(t**2*dcts2 + dpht2))
       s = qmedian(abs(pht - t*cts)) / (0.6745*ds)
    else if( n > 13 ) then
       t = median(pht/cts)
       ds = median(sqrt(t**2*dcts2 + dpht2))
       s = median(abs(pht - t*cts)) / (0.6745*ds)
    else if( n > 2 ) then
       call qmean(pht/cts,t,d)
       call qmean(sqrt(t**2*dcts2 + dpht2),ds,d)
       call qmean(abs(pht - t*cts),s,d)
       s = s / (0.6745*ds)
    else if( n > 0 ) then
       t = sum(pht/cts) / n
       ds = sum(sqrt(t**2*dcts2 + dpht2)) / n
       s = sum(abs(pht - t*cts)) / (n * ds)
    else
       t = 0
       s = 0
    end if



!    write(*,*) t,s,n

!    allocate(ds(n))
!    call residuals2(t,res,ds)
!    s = qmedian(abs(res)) / 0.6745
!    d = qmedian(ds)
!    deallocate(ds)

    ! Just for fun. All of estimates below gives the same result on standard data:
!     write (*,*) sqrt(sum(res**2)/n),median(abs(res))/0.6745,sum(abs(res))/n/0.8

  end subroutine rinit

  function ratiomin(t)

!    use medians

    real(dbl), intent(in) :: t
    real(dbl) :: ratiomin
    integer :: n

    n = size(pht)
    call residuals(t,res)
    ratiomin = sum(abs(res)) / (0.8*n)

    ! This function computes sum of absolute deviations. To have values
    ! of order of an unit, we're normalise the sum by data size. The
    ! factor 0.8 converts of its Laplace's dispersion to one corresponding
    ! to Normal distributions. It is important for estimate of dispersion.

  end function ratiomin


  subroutine zmean(t,s,reli)

    use fmm
    use medians

    ! This is a robust estimation of the ratio.

    real(dbl), intent(in out) :: t
    real(dbl), intent(in) :: s
    logical, intent(out) :: reli
    real(dbl) :: htol,d,tmin,tmax

!    htol = 1e-7*max(1.0,rmax)
    sigma = s

    d = 3.3 * qmedian(abs(pht/cts - t)) / 0.6745
    htol = 1e-5*d

    if( size(pht) > 13 ) then
       tmin = max(t - d,rmin)
       tmax = min(t + d,rmax)
    else
       tmin = rmin
       tmax = rmax
    end if
!    write(*,*) tmin,tmax,d,s,qmedian(sqrt(dpht**2 + t**2*dcts**2))
    t = zeroin(tmin,tmax,zfun,htol)

    d = 2*htol
    reli = rmin + d < t .and. t < rmax - d

    ! the realiable result is inside interval rmin .. rmax
    ! and not too close to the interval endpoints

  end subroutine zmean


  function zfun(t)

    use rfun

    real(dbl), intent(in) :: t
    real(dbl) :: zfun
    real(dbl), dimension(:), allocatable :: phi,ds
    integer :: n

    n = size(pht)
    allocate(phi(n),ds(n))
    call residuals2(t,res,ds)
    call tukeys(res/sigma,phi)

    zfun = (t*sum((phi*res - 1.0_dbl)*(dcts/ds)**2) + sum(phi*cts/ds))/sigma

    deallocate(phi,ds)

  end function zfun


  subroutine pmean(t)

    use fmm
!    use qmeans

    real(dbl), intent(out) :: t
!    real(dbl) :: tmin, tmax, d
!    real(dbl) :: d

!    call qmean(pht / cts,t,d)

!    tmin = rmin
!    tmax = rmax
    t = fmin(rmin,rmax,negfree,tol)

  end subroutine pmean


  function negfree(t)

    ! negative free energy

    real(dbl), intent(in) :: t
    real(dbl) :: negfree
    real(dbl), dimension(:), allocatable :: f

    allocate(f(size(pht)))

    ! The density for Poisson distribution is computed by the way:
    ! https://en.wikipedia.org/wiki/Poisson_distribution#Definition

    f = pht*log(t*cts) - t*cts - log_gamma(pht + 1)
    f = exp(f)
    negfree = - sum(f)
    deallocate(f)

  end function negfree


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

  subroutine poisson_graph

    integer, parameter :: nmax = 1000
    integer :: n
    real(dbl) :: t,dt
    real(dbl), dimension(:), allocatable :: f

    allocate(f(size(pht)))

    dt = (rmax - rmin) / nmax

    open(1,file='/tmp/f')
    do n = 1,nmax,2
       t = rmin + dt*n
       f = pht*log(t*cts) - t*cts - log_gamma(pht+1)
       write(1,*) t,sum(exp(f)),sum(f*exp(f))
    end do
    close(1)

    deallocate(f)

  end subroutine poisson_graph

  subroutine snoise_graph(t,sig)

    real(dbl), intent(in) :: t, sig

    integer :: i
    real(dbl) :: s

    open(1,file='/tmp/e')
    do i = 2,int(1000*sig),10
       s = i / 100.0
       write(1,*) s,entropy(t,s)
    end do
    close(1)

  end subroutine snoise_graph


  subroutine rmean_graph(t1,t2,s)

    use rfun

    real(dbl), intent(in) :: t1,t2,s
    real(dbl) :: t,dt
    real(dbl), dimension(:), allocatable :: r,rho
    integer :: i,n

    n = size(pht)
    allocate(r(n),rho(n))

    dt = (t2 - t1) / 1000

    open(1,file='/tmp/r')
    do i = 1,1000,10
       t = t1 + dt*i

       call residuals(t,r)
!       call ihubers(r/s,rho)
       call itukeys(r/s,rho)

       write(1,*) t,loglikely((/t,s/)),sum(rho),zfun(t)
    end do
    close(1)

    deallocate(r,rho)

  end subroutine rmean_graph


  ! an interface for plotting of functions in minimum (not used for calibration)
  subroutine graph(xpht,xdpht,xcts,xdcts,ctph,sig,type,fvec)

    real(dbl), dimension(:), target, intent(in) :: xpht,xdpht,xcts,xdcts
    real(dbl), intent(in) :: ctph,sig
    character(len=*), intent(in) :: type
    real(dbl), dimension(:) :: fvec
    integer :: iflag, ndat

    ndat = size(xpht)
    allocate(pht(ndat),cts(ndat),dpht(ndat),dcts(ndat))
    pht = xpht
    cts = xcts
    dpht = xdpht
    dcts = xdcts

    if( type == "grad" ) then
       iflag = 1
       call fundif(2,2,(/ctph,sig/),fvec,iflag)
    else if( type == "like" ) then
       fvec(1) = loglikely((/ctph,sig/))
    else
       fvec = 0
    end if

    deallocate(pht,cts,dpht,dcts)

  end subroutine graph


end module robratio
