!===============================================================================
!
! remez.F90 with FMLIB version 1.2
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2008-2011 Yoshifumi Nakamura
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
! BQCD 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.
!
! BQCD 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 BQCD.  If not, see <http://www.gnu.org/licenses/>.
!
!-------------------------------------------------------------------------------
module module_remez
  use fmzm
  type(fm), save :: spread, apstrt, apend, apwidt, pi, delta, norm
  type(fm), allocatable, save :: mm(:), xx(:), step(:), coef(:)
  type(fm), allocatable, save :: roots(:), poles(:) 
  integer, save :: n, d, neq
  integer, save :: power_num, power_den

end

!-------------------------------------------------------------------------------
subroutine remez(start, end, power_num, power_den, degree, prec, dr, dp, pm)
  use module_function_decl
  implicit none
  real(8), intent(in) :: start, end
  integer, intent(in) :: power_num, power_den, degree, prec, pm
  real(8), intent(out):: dr(0:degree,pm), dp(degree,pm)
  real(8) :: err 
  integer :: n,d, i, rrr
  integer, external :: remez_root

  if (.not.(pm == 1 .or. pm == 2)) call die("undefined procedure at remez")

  n=degree
  d=degree

  call remez_init(power_num,power_den,n,d,start,end,prec)
  call remez_allocate()
  rrr= remez_root(err)
  if (rrr==1) call die("Delta too small, try increasing precision")
  if (rrr==2) call die("remez_root : try increasing maxiter")

  if ( pm == 1) then  
     call getpfe(-1, dr(0,1), dp(1,1))
     if (my_pe()==0) then
        write(0,*)"generated new coeffs x^(-",power_num,"/",power_den,")"
        write(0,*)"range[", start,",", end,"]"
        write(0,*)err
        write(0,"(d25.17)")dr(0,1)
        do i = 1,n
           write(0,"(2d25.17)")dr(i,1),dp(i,1)
        enddo
     endif
  else
     call getpfe(-1, dr(0,1), dp(1,1))
     if (my_pe()==0) then
        write(0,*)"generated new coeffs x^(-",power_num,"/",power_den,")"
        write(0,*)"range[", start,",", end,"]"
        write(0,*)err
        write(0,"(d25.17)")dr(0,1)
        do i = 1,n
           write(0,"(2d25.17)")dr(i,1),dp(i,1)
        enddo
     endif
     call getpfe( 1, dr(0,2), dp(1,2))
     if (my_pe()==0) then
        write(0,*)"generated new coeffs x^(+",power_num,"/",power_den,")"
        write(0,*)"range[", start,",", end,"]"
        write(0,*)err
        write(0,"(d25.17)")dr(0,2)
        do i = 1,n
           write(0,"(2d25.17)")dr(i,2),dp(i,2)
        enddo
     endif
  endif

  call remez_deallocate()

end

!-------------------------------------------------------------------------------
subroutine remez_test()
  use module_function_decl
  implicit none
  real(8) :: start, end, err, dr(0:10), dp(10)
  integer :: power_num,power_den,n,d, prec, i, rrr
  integer, external :: remez_root

  start = 0.003_8
  end = 1
  power_num =1
  power_den =2
  prec=95

  do i = 41, 80
     n=i;d=n
10 continue
     call remez_init(power_num,power_den,n,d,start,end,prec)
     call remez_allocate()
     rrr= remez_root(err)
!!     if (rrr==1) call die("Delta too small, try increasing precision")
     if (rrr==1) then
        prec = prec + 1
        call remez_deallocate()
        go to 10
     endif
     if (rrr==2) call die("remez_root : try increasing maxiter")
     call remez_deallocate()
     if (my_pe()==0) write(*,*)" %remez",n, prec
  enddo
end

!-------------------------------------------------------------------------------
subroutine remez_init(pnum,pden,num,den,start,end,prec)
  use module_remez
  implicit none
  real(8) :: start, end
  integer :: prec, pnum,pden,num,den

  power_num = pnum
  power_den = pden
  n = num
  d = den
  neq = n + d + 1
  call fm_set(prec)
  apstrt = to_fm(start)
  apend = to_fm(end)

end
!-------------------------------------------------------------------------------
subroutine remez_allocate()
  use module_remez
  implicit none

  allocate(step(0:n+d+1))
  allocate(  mm(0:n+d+1))
  allocate(  xx(0:n+d+2))
  allocate(coef(n+d+1))
  allocate( roots(0:n-1) )
  allocate( poles(0:d-1) )
end

!-------------------------------------------------------------------------------
subroutine remez_deallocate()
  use module_remez
  implicit none

  deallocate(step)
  deallocate(  mm)
  deallocate(  xx)
  deallocate(coef)
  deallocate( roots)
  deallocate( poles)
end

!-------------------------------------------------------------------------------
integer function remez_root(err_dp)
  use module_function_decl
  use module_remez
  implicit none
  real(8), intent(out) :: err_dp
  integer :: iter
  real(8) :: tolerance
  type(fm) :: err

  tolerance = 1d-15

  call fm_pi(pi)
  spread = to_fm(1d37)
  iter = 0
  apwidt = apend - apstrt

  call initialguess()
  call stpini()

  do while (spread > tolerance) 
     if (mod(iter, 100) == 0 ) then
        if (my_pe()==0)write(0,*)iter, to_dp(spread), to_dp(delta)
     endif
     call equations(neq,n,d, xx(0:neq-1), coef)
     if (delta < tolerance) then
        remez_root = 1
        return
     endif
     call search(err)
     iter = iter + 1
     if (iter > 999999) then
        remez_root = 2
        return
     endif
  enddo
  err_dp = to_dp(err)
  if (my_pe()==0)write(0,*)"Converged at",iter,"iterations, error =",err_dp

  call root()
  remez_root = 0
end

!-------------------------------------------------------------------------------
subroutine initialguess()
  use module_remez
  implicit none
  type(fm) :: a, r, cc
  integer :: i

  a = to_fm(neq)

  mm(0) = apstrt
  do i = 1, neq-1
!!     call fmcos(pi*i/a, cc)
!!     cc=cos(pi*i/a)
!!     r = ( 1 - cos(pi*i/a) )/2
!!     call fmsqrt_r1(r)
     mm(i) = apstrt + sqrt( ( 1 - cos(pi*i/a) )/2 ) * apwidt
  enddo
  mm(neq) = apend

  a = to_fm(2.0 * neq)
  do i = 0, neq
!!     call fmcos(pi*(2*i+1)/a, cc)
!!     r = (1 - cc )/2
!!     call fmsqrt_r1(r)
     xx(i) = apstrt + sqrt( (1 - cos(pi*(2*i+1)/a) )/2 ) * apwidt
  enddo

end

!-------------------------------------------------------------------------------
subroutine stpini()
  use module_remez
  implicit none
  integer :: i

  xx(neq+1) = apend
  delta = to_fm(0.25)
  step(0) = xx(0) - apstrt
  do i = 1, neq-1
     step(i) = xx(i) - xx(i-1)
  enddo
  step(neq) = step(neq-1)

end

!-------------------------------------------------------------------------------
subroutine equations(nd1,n,d, xt, b)
  use fmzm
  implicit none
  type(fm), intent(out) :: b(nd1)
  type(fm), intent(in) :: xt(nd1)
  integer, intent(in) :: nd1, n, d
  type(fm) :: a(nd1,nd1), yt, z
  integer :: i, j

  do i = 1, nd1
     call target_func(xt(i), yt)
     z = to_fm(1)
     do j = 1, n+1
        a(i,j) = z
        z = z * xt(i)
     enddo
     z = to_fm(1)
     do j = 1, d
        a(i,n+1+j) = - yt * z
        z = z * xt(i)
     enddo
     b(i) = yt * z
  enddo

  call solve_fm(a,b,nd1)

end

!-------------------------------------------------------------------------------
subroutine target_func(x, y)
  use module_remez
  implicit none
  type(fm), intent(out) :: y
  type(fm), intent(in) :: x
  type(fm) :: pwr, f, df, dy, tmp1,tmp2

!!  pwr = to_fm(dble(power_num)/dble(power_den))
!!  call fmpwr(x,pwr,y)
  call fmrpwr(x, power_num, power_den, y)

end

!-------------------------------------------------------------------------------
subroutine solve_fm(a, b, n)
  use fmzm
  implicit none
  type(fm), intent(inout) :: a(n,n), b(n)
  integer, intent(in) :: n
  type(fm) :: big, tmp, dum, pivinv
  integer :: i,j,k,l,ll, irow, icol,  ipiv(n)

  ipiv = 0

  do i = 1, n
     big = to_fm(0)
     do j = 1, n
        if (ipiv(j) /= 1) then
           do k = 1, n
              if (ipiv(k) == 0) then
                 call fmabs(a(j, k), tmp)
                 if (tmp >= big) then
                    big = tmp
                    irow = j
                    icol = k
                 endif
              else if (ipiv(k) > 1) then
                 call die("solve_fm(): singular matrix 1")
              endif
           enddo
        endif
     enddo

     ipiv(icol) = ipiv(icol) + 1

     if (irow /= icol) then
        do l = 1, n
           dum = a(irow, l)
           a(irow, l) = a(icol, l)
           a(icol, l) = dum
        enddo
        dum = b(irow)
        b(irow) = b(icol)
        b(icol) = dum
     endif

     if (a(icol, icol) == 0 ) then
        call fm_prnt(a(icol, icol))
        call die("solve_fm(): singular matrix 2")
     endif

     pivinv = 1 / a(icol, icol)
     !!a(icol, icol) = ONE  !! only needed for inv(a)

     do  l = 1, n
        a(icol, l) = a(icol, l) * pivinv
     enddo

     b(icol) = b(icol) * pivinv

     do ll = 1, n
        if (ll /= icol) then
           dum = a(ll, icol)
           a(ll, icol) = to_fm(0)
           do l = 1, n
              a(ll, l) = a(ll, l) - a(icol, l) * dum
           enddo
           b(ll) = b(ll) - b(icol) * dum
        endif
     enddo

  enddo

end

!-------------------------------------------------------------------------------
! Search for error maxima and minima
subroutine search(ym)
  use module_remez
  implicit none
  integer :: i, j, meq, emsign, ensign, steps
  type(fm) :: a, q, xm, ym, xn, yn, xx0, xx1, eclose, farther
  type(fm), allocatable :: yy(:)

  meq = neq + 1
  allocate( yy(0:meq) )

  eclose = to_fm(1d30)
  farther = to_fm(0)

  j = 1
  xx0 = apstrt

  do i=0, meq -1
     steps = 0
     xx1 = xx(i)
     if (i==meq-1) xx1 = apend
     xm = mm(i)
     call geterr(ym,xm,emsign)
     q = step(i)
     xn = xm + q
     if (xn < xx0 .or. xn >= xx1) then
        q = -q
        xn = xm
        yn = ym
        ensign = emsign
     else
        call geterr(yn,xn,ensign)
        if (yn < ym) then
          q = -q
          xn = xm
          yn = ym
          ensign = emsign
        endif
     endif


     do while(yn >= ym)
        steps = steps + 1
        if (steps > 10) exit

        ym = yn
        xm = xn
        emsign = ensign
        a = xm + q
        if (a == xm .or. a <= xx0 .or. a >= xx1) exit
        xn = a
        call geterr(yn,xn,ensign)
     enddo

     mm(i) = xm                        !! Position of maximum
     yy(i) = ym                        !! Value of maximum

     if (eclose  > ym) eclose  = ym
     if (farther < ym) farther = ym

     xx0 = xx1                         !! Walk to next zero.
  enddo !! end of search loop

  q = (farther - eclose)                      !! Decrease step size if error spread increased
  if ( eclose /= to_fm(0) ) q = q / eclose           !! Relative error spread
  if (q >= spread) delta = delta * to_fm(0.5) !! Spread is increasing; decrease step size
  spread = q


  do i = 0, neq - 1
     q = yy(i+1)
     if (q /= 0 ) then
        q = yy(i) / q  - to_fm(1)
     else
        q = to_fm(0.0625)
     endif
     if (q > to_fm(0.25)) q = to_fm(0.25)
     q = q * ( mm(i+1) - mm(i) )
     step(i) = q * delta
  enddo

  step(neq) = step(neq-1)

  do i = 0, neq - 1
     xm = xx(i) - step(i)
     if ( xm <= apstrt ) cycle
     if ( xm >= apend  ) cycle
     if (xm <= mm(i)  ) xm = to_fm(0.5) * (mm(i)   + xx(i))
     if (xm >= mm(i+1)) xm = to_fm(0.5) * (mm(i+1) + xx(i))
     xx(i) = xm
  enddo

  deallocate(yy)

end

!-------------------------------------------------------------------------------
subroutine geterr(err,x,nsign)
  use fmzm
  implicit none
  integer :: nsign
  type(fm) :: err,x,f,app

  call target_func(x, f)
  call approx(x, app)
  err = app - f

  if (f /= to_fm(0)) err = err / f
  if (err < to_fm(0)) then
     nsign = -1
     err = -err
  else
     nsign = 1
  endif

end

!-------------------------------------------------------------------------------
subroutine approx(x,app)
  use module_remez
  implicit none
  type(fm) :: x,app, yn, yd
  integer :: i

  yn = coef(n+1)
  do i = n, 1, -1
     yn = x * yn  +  coef(i)
  enddo
  yd = x + coef(d+n+1)
  do i = d+n,n+2,-1
     yd = x * yd  +  coef(i)
  enddo

  app = yn/yd

end

!-------------------------------------------------------------------------------
subroutine root()
  use module_function_decl
  use module_remez
  implicit none
  type(fm) :: x,dx,upper,lower,tol
  type(fm) :: poly(0:neq)
  integer :: i,j 

  dx = 0.5
  upper=to_fm(1) ; lower=to_fm(-100000) ; tol = to_fm(1d-20)

  poly(0:neq)=to_fm(0)

  !! First find the numerator roots
  do i = 0, n
     poly(i) = coef(i+1)
  enddo

  do i = n-1, 0, -1
     call rtnewt(roots(i), poly, i+1, lower,upper,tol)
     if ( roots(i) == 0 ) write(0,*)i
     if ( roots(i) == 0 ) call die("Err: Failure to converge on root of num")
     poly(0) = -poly(0) / roots(i)
     do j = 1, i
        poly(j) = ( poly(j-1) - poly(j) ) / roots(i)
     enddo
  enddo

  !! Now find the denominator roots
  poly(d) = 1
  do i = 0, d-1
     poly(i) = coef(n+2+i)
  enddo
  do i = d-1, 0, -1
     call rtnewt(poles(i),poly,i+1,lower,upper,tol);
     if (poles(i) == 0.0) call die("Err: Failure to converge on rootof den")
     poly(0) = -poly(0)/poles(i)
     do j = 1, i
        poly(j) = ( poly(j-1) - poly(j) ) / poles(i);
     enddo
  enddo

  norm = coef(n+1)

#ifdef DEBUG2
  if (my_pe()==0)then
  write(0,*)"Normalisation constant is",to_dp(norm)
  do i = 0, n-1
     write(0,*)"root(",i,")=",to_dp(roots(i))
  enddo
  do i = 0, d-1
     write(0,*)"pole(",i,")=",to_dp(poles(i))
  enddo
  endif
#endif

end

!-------------------------------------------------------------------------------
subroutine rtnewt(out, poly, i, x1, x2, xacc)
  use module_remez
  implicit none
  type(fm) :: out, poly(0:neq), x1, x2, xacc, df, dx, f
  integer :: i, j, jmax, k

jmax=1000
  out = (x1+x2)/2
  do j=1, jmax
     f=poly(i)
     do k=i-1,0,-1
        f= f*out + poly(k)
     enddo

     df=to_fm(i)*poly(i)
     do k=i-1,1,-1
        df = df*out + to_fm(k)*poly(k)
     enddo
     dx = f/df
     out = out - dx
     if ((x1-out)*(out-x2) < 0) call die("Jumped out of brackets in rtnewt")
     if (abs(dx) < xacc) return
  enddo
  call warn("Maximum number of iterations exceeded in rtnewt")
  out = 0

end

!-------------------------------------------------------------------------------
subroutine getpfe(ss, dr, dp)
  use module_remez
  implicit none
  type(fm) :: r(0:n-1), p(0:d-1), tmp
  integer :: i, ss
  real(8) :: dr(0:n), dp(d)

  if (n /= d) call die("n should be equal to d ")
  if (.not. (ss == 1 .or. ss == -1)) call die("getpfe : unknown sign")

  if (ss == -1) then
     do i = 0, n-1
        p(i)=roots(i)
        r(i)=poles(i)
     enddo
     tmp = 1/norm
  else
     do i = 0, n-1
        r(i)=roots(i)
        p(i)=poles(i)
     enddo
     tmp = norm
  endif

  call pfe(n, d, r,p,tmp)

  do i = 1,n
     dr(i)= to_dp(r(i-1))
     dp(i)= to_dp(p(i-1))
  enddo
  dr(0)=to_dp(tmp)
end

!-------------------------------------------------------------------------------
subroutine pfe(n, d, res, poles, norm)
  use module_function_decl
  use fmzm
  implicit none
  integer, intent(in) :: n, d
  type(fm), intent(inout) :: res(0:n-1), poles(0:d-1), norm
  type(fm) :: numerator(0:n-1), denominator(0:d-1), temp
  integer :: i, j, small

! Initialization
  do i = 1, n-1
     numerator(i) = to_fm(0)
     denominator(i) = to_fm(0)
  enddo
  numerator(0) = to_fm(1)
  denominator(0) = to_fm(1)

  do j = 0, n-1
     do i = n-1, 0, -1
        numerator(i) = - numerator(i) * res(j)
        denominator(i) = - denominator(i) * poles(j)
        if (i>0) then
           numerator(i) = numerator(i) + numerator(i-1)
           denominator(i) = denominator(i) + denominator(i-1)
        endif
     enddo
  enddo

! Convert to proper fraction form.
! Fraction is now in the form 1 + n/d, where O(n)+1=O(d)

  do i = 0, n-1
     numerator(i) = numerator(i) - denominator(i)
  enddo

! Find the residues of the partial fraction expansion and absorb the
! coefficients.

  do i = 0, n-1
     res(i) = to_fm(0)
     do j = n-1, 0, -1
        res(i) = poles(i)*res(i)+numerator(j)
     enddo
     do j = n-1, 0, -1
        if (i/=j) res(i) = res(i) / (poles(i)-poles(j))
     enddo
     res(i) = res(i)*norm
  enddo

! res now holds the residues

  j = 0
  do i = 0, n-1
     poles(i) = -poles(i)
  enddo

! Move the ordering of the poles from smallest to largest
  do j = 0, n-1
     small = j
     do i = j+1, n-1
        if (poles(i) < poles(small)) small = i
     enddo
     if (small /= j) then
        temp = poles(small)
        poles(small) = poles(j)
        poles(j) = temp
        temp = res(small)
        res(small) = res(j)
        res(j) = temp

     endif
#ifdef DEBUG2
     if(my_pe()==0)write(0,*)"pfe : Residue = ", to_dp(res(j)), " Pole = ",to_dp(poles(j))
#endif
  enddo

end

!===============================================================================
