module iromberg

  implicit none
  integer, parameter, private :: kind = selected_real_kind(15)

contains

  function romberg(f,a,b,tol,count,iflag)

    ! Rombergova metoda numerickeho vypoctu intergalu.
    !
    ! Znaceni:
    ! 2**MMAX = maximalni pocet vycisleni integrovane funkce F(X)
    ! Interval: <AINT,BINT>
    ! Absolutni presnost: EPS
    !
    ! iflag = 0 .. dosazena pozadovana presnost
    ! iflag = 1 .. nedosazena pozadovana presnost kvuli zaokrouhlovani
    ! iflag = 2 .. prekrocen maximalni pocet vycisleni funkce
    !

    interface
       function f(x)
         integer, parameter :: kind = selected_real_kind(15)
         real(kind) :: f
         real(kind), intent(in) :: x
       end function f
    end interface

    real(kind) :: romberg
    real(kind), intent(in) :: a,b
    real(kind), intent(in), optional :: tol
    integer, intent(in), optional :: count
    integer, intent(out), optional :: iflag

    integer :: mmax,i,j,k
    real(kind) :: x,s,g,h,err,d,dmin,y,epsmin
    real(kind), dimension(:), allocatable :: t
!    double precision :: f

    if( present(tol) ) then
       err = tol
    else
       err = 10*epsilon(1.0_kind)
    end if
    if( present(count) ) then
       mmax = count
    else
       mmax = 2 * nint(log((b - a) / err) / 0.6931)
    end if
!    write(*,*) err,mmax

    allocate(t(0:mmax))

!    external f

! Integracni meze
!      AINT = 0.0
!      BINT = -1.0
! Zadana chyba
!      EPS = 1E-13
!
    g = (b - a)/2.0
    h = g
    t(0) = g*(f(a) + f(b))
    k = 1
    dmin = 0.0_kind
!    hmin = 0.0_kind
    do j = 1, mmax
       y = t(0)
       x = a + g
       s = 0.0_kind
       do i = 0, k - 1
          s = s + f(x + h*i)
       enddo
       t(j) = t(j - 1)/2.0 + s * g
       s = 1.0_kind
       do i = j, 1, -1
          s = 4.0_kind*s
          t(i - 1) = (s*t(i) - t(i - 1))/(s - 1.0_kind)
       enddo
       d = abs(t(0) - y)
       if( j > 1 ) then
          if( d < tol )then
             ! Pozadovana presnost dosazena
             if( present(iflag) ) iflag = 0
             romberg = t(0)
             return
          endif
          if( d >= epsmin )then
             ! prenosti nedosahnuto kvuly zaokrouhlovani
             if( present(iflag) ) iflag = 1
             romberg = t(0)
             return
          endif
       endif
       k = 2*k
       h = g
       g = g / 2.0_kind
       epsmin = d
    enddo
    if( present(iflag) ) iflag = 2
    romberg = t(0)

  end function romberg

end module iromberg
