!===============================================================================
!
! fermi_action.F90  -  initialises phi and calculates actions
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2008-2010 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/>.
!
!-------------------------------------------------------------------------------
! Modified for PFHMC, Zolotarev ratapps, PF-RHMC and tRHMC
!
! Editor: Taylor Haar
! Last modified: 21/03/2017
!-------------------------------------------------------------------------------
# include "defs.h"

!-------------------------------------------------------------------------------
subroutine calc_fermi_action(init)
  use module_action
  use module_switches
  implicit none
  logical, intent(in) :: init
  integer :: i
  integer, save :: count = 0

  if (n_pfermi == 0) return
  DEBUG2S("Start: fermi_action")
  if (count == 0 .or. (.not. init)) call gene_new_coeff()
  count = 1

  do i = 1, n_pfermi
     select case(action%pfermi(i)%type)
     case(EO_NORMAL)
        if (action%pfermi(i)%polyid > 0) then
           call fermi_action_poly(action%pfermi(i), init)
        else
           call fermi_action_massprec(action%pfermi(i),init)
        endif
     case(EO_RATIONAL)
        if (init) then
           if (action%pfermi(i)%polyid > 0) then
              if (action%pfermi(i)%rid > 0) then
                 ! PF-RHMC correction term
                 if (switches%zolotarev .and. action%pfermi(i)%nth == 2) then
                    call fermi_action_rhmc_zolo(EO_RATIONAL, &
                         action%pfermi(i), init)
                 else
                    call fermi_action_rhmc_z(EO_RATIONAL, &
                         action%pfermi(i), init)
                 endif
              else
                 ! Polynomial filter term
                 call fermi_action_poly(action%pfermi(i), init)
              endif
           else
              if (switches%zolotarev .and. action%pfermi(i)%nth == 2) then
                 call fermi_action_rhmc_zolo(EO_RATIONAL, &
                      action%pfermi(i), init)
              else
                 call fermi_action_rhmc(EO_RATIONAL, action%pfermi(i),init)
              endif
           endif
        endif
     case default     ; call die("fermi_action: undefined fermi type")
     end select
  enddo
  DEBUG2S("End: fermi_action")
end

!-------------------------------------------------------------------------------
subroutine calc_fermi_action_rhmc()
  ! Calculate just the RHMC fermion action terms
  use module_action
  use module_switches
  implicit none
  integer :: i

  if (n_pfermi == 0) return
  call gene_new_coeff()
  do i = 1, n_pfermi
     if (action%pfermi(i)%rid >= 0) then
        select case(action%pfermi(i)%type)
        case(EO_RATIONAL)
           if (switches%zolotarev .and. action%pfermi(i)%nth == 2) then
              ! Use Zolotarev version
              call fermi_action_rhmc_zolo(EO_RATIONAL, &
                   action%pfermi(i), .false.)
           else if (action%pfermi(i)%polyid > 0) then
              ! PF-RHMC: Call the complex variety
              call fermi_action_rhmc_z(EO_RATIONAL, action%pfermi(i),.false.)
           else
              call fermi_action_rhmc(EO_RATIONAL, action%pfermi(i),.false.)
           endif
        case default     ; call die("fermi_action_rhmc: undefined fermi type")
        end select
     endif
  enddo
end

!-------------------------------------------------------------------------------
subroutine fermi_action_massprec(pf, init)
  use module_action
  use module_function_decl
  use module_vol
  implicit none
  type(type_pfermi) :: pf
  logical :: init
  COMPLEX, allocatable :: tmp1(:), tmp2(:)

  DEBUG2S("Start: fermi_action_massprec")

  allocate(tmp1(NDIRAC*NCOL*volh_tot))
  allocate(tmp2(NDIRAC*NCOL*volh_tot))

  if (init) then
     call random_sc_field(tmp1)
     pf%sf = dotprod(tmp1, tmp1, SIZE_SC_FIELD)
     call init_quark(pf%mid1)
     call wdag_r8(tmp2, tmp1, pf%mid1)
     if (pf%mid2 /= 0) then
        call init_quark(pf%mid2)
        call cg_outer(tmp1, tmp2, pf%mid2, 0, CG_MC)
        call wmul_r8(tmp2, tmp1, pf%mid2)
     endif
     call sc_copy(pf%mpf(1)%sc,tmp2)
  else
     if (pf%mid2 /= 0) then
        call init_quark(pf%mid2)
        call sc_copy(tmp1, pf%mpf(1)%sc)
        call wdag_r8(tmp2, tmp1, pf%mid2)
     else
        call sc_copy(tmp2, pf%mpf(1)%sc)
     endif
     !! tmp1=tmp2 is needed, since cg_outer has a preconditioning
     tmp1=tmp2
     call init_quark(pf%mid1)
     call cg_outer(tmp1, tmp2, pf%mid1, 0, CG_MC)
     call wmul_r8(tmp2, tmp1, pf%mid1)
     pf%sf = dotprod(tmp2, tmp2, SIZE_SC_FIELD)
  endif

  deallocate(tmp1, tmp2)
  DEBUG2S("End: fermi_action_massprec")
end

!------------------------------------------------------------------------------
subroutine fermi_action_poly(pf, init)
  ! Initialize the pseudofermion for a polynomial filtering term (init = .true.)
  ! or calculate the PF action term given the pseudofermion (init = .false.)

  use module_action
  use module_function_decl
  use module_p_interface
  use module_vol
  use module_poly
  implicit none

  type(type_pfermi) :: pf
  logical :: init
  COMPLEX, allocatable :: tmp1(:), tmp2(:)
  integer :: i, act_fermi_id

  DEBUG2S("Start: fermi_action_poly")

  allocate(tmp1(NDIRAC*NCOL*volh_tot))
  allocate(tmp2(NDIRAC*NCOL*volh_tot))

  call init_quark(pf%mid1)

  pf%sf = 0

  if (init) then
     ! Generate phi distributed according to exp(-S_poly)
     do i = 1, pf%npf
        ! First, generate tmp1 distributed like exp(-tmp1^t tmp1)
        call random_sc_field(tmp1)
        pf%sf = pf%sf + dotprod(tmp1, tmp1, SIZE_SC_FIELD)
        if (poly(pf%polyid)%type == P_CORRECTION) then
           ! S_poly = phi^t (PK)^-1 phi
           ! Assume P = Q*Q: then xi = (QM^dag)^-1 phi is Gaussian distributed
           ! Hence, we take phi = QM^dag xi
           call wdag_r8(tmp2, tmp1, pf%mid1)
           call poly_hmult(pf%mpf(i)%sc, tmp2, pf)
        else
           ! S_poly = phi^t P phi
           ! Assume P = Q*Q: then xi = Q phi is Gaussian distributed
           ! Hence, we take phi = Q^-1 xi

           ! We want to count the CG iters here as part of 'iter_SF' in the
           ! output, 'np=0', but inv_hpoly() uses 'np=pf%pid', which will
           ! count towards a force iteration counter.
           !
           ! To work around this, we temporarily change pf%pid to 0
           !
           ! It's a hack, but the alternative is not much nicer
           ! (= add an extra parameter that's only used here)

           act_fermi_id = pf%pid
           pf%pid = 0
           call inv_hpoly(pf%mpf(i)%sc, tmp1, pf, CG_MC)
           pf%pid = act_fermi_id
        endif
     enddo
  else
     ! Given phi, calculate S_poly
     do i = 1, pf%npf
        if (poly(pf%polyid)%type == P_CORRECTION) then
           ! S_poly = phi^t (PK)^-1 phi
           call inv_poly(tmp1, pf%mpf(i)%sc, pf, CG_MC)
           pf%sf = dotprod(pf%mpf(i)%sc, tmp1, SIZE_SC_FIELD)
        else
           ! S_poly = phi^t P phi
           call poly_mult(tmp1, pf%mpf(i)%sc, pf)
           pf%sf = dotprod(pf%mpf(i)%sc, tmp1, SIZE_SC_FIELD)
        endif
     enddo
  endif

  deallocate(tmp1, tmp2)
  DEBUG2S("End: fermi_action_poly")

end subroutine fermi_action_poly

!-------------------------------------------------------------------------------
subroutine fermi_action_rhmc(type, pf, init)
  use module_action
  use module_function_decl
  use module_vol
  use module_rhmc
  implicit none

  type(type_pfermi) :: pf
  logical :: init
  integer :: type
  integer :: mid, rid, i
  REAL :: factor, exponent
  COMPLEX, allocatable :: tmp(:)

  DEBUG2S("Start : fermi_action_rhmc")
  mid   = pf%mid1
  rid   = pf%rid
  factor= pf%factor

  allocate(tmp(NDIRAC*NCOL*volh_tot))

  call init_quark(mid)

  pf%sf = 0

  if (init) then
     exponent= - ratapp(rid)%exponents(2)
     do i = 1, pf%npf
        call random_sc_field(tmp)
        pf%sf = pf%sf + dotprod(tmp, tmp, SIZE_SC_FIELD)
        call rhmc_action(type, tmp, mid, ratapp(rid)%shift_exact, ratapp(rid)%abar_exact_p, ratapp(rid)%bbar_exact_p, factor, exponent)
        call sc_copy(pf%mpf(i)%sc, tmp)
     enddo
  else
     exponent=   ratapp(rid)%exponents(2)
     do i =1, pf%npf
        call sc_copy(tmp, pf%mpf(i)%sc)
        call rhmc_action(type, tmp, mid, ratapp(rid)%shift_exact, ratapp(rid)%abar_exact_m, ratapp(rid)%bbar_exact_m, factor, exponent)
        pf%sf = pf%sf + dotprod(tmp, tmp, SIZE_SC_FIELD)
     enddo
  endif

  deallocate(tmp)

  DEBUG2S("End: fermi_action_rhmc")

end

!-------------------------------------------------------------------------------
subroutine rhmc_action(type, inout, mid, n, a, b, factor, exponent)
  ! Multiply 'inout' in place by the rational approximation described
  ! by the other input parameters
  use module_vol
  use module_field
  implicit none

  SPINCOL_FIELD, intent(inout) :: inout
  integer,       intent(in)    :: mid, n, type
  REAL,          intent(in)    :: a(0:n), b(n), factor, exponent
  integer :: frdo(n), iters(n), i
  REAL :: fe(0:n), bof(n)

  fe(0)=factor**exponent * a(0)
  fe(1:n)=factor**exponent * a(1:n) / factor
  bof=b/factor
  frdo =0

  call mcg_outer(type, inout, mid, n, frdo, bof, iters, 0, CG_MC)
  call sc_scale(inout, fe(0))
  do i=1, n
     call sc_axpy(inout, sco(1,i)%sco(1), fe(i))
  enddo

end

!-------------------------------------------------------------------------------
subroutine random_sc_field(out)
  use module_vol
  implicit none
  SPINCOL_FIELD, intent(out) :: out

#ifdef NON_REALITY
  out=cmplx(dsqrt(0.3_8),dsqrt(0.2_8),kind=8)
#else
  call ran_gauss_volh(NDIRAC * NCOL, out, HALF, EVEN)
#endif

#ifdef FLIPSC
  call scfield_reorder_43_to_34(out)
#endif

end

#ifdef BQCD_DDHMC
!-------------------------------------------------------------------------------
subroutine random_sc_field_dd(out)
  use module_vol
  implicit none
  SPINCOL_FIELD, intent(out) :: out
  SPINCOL_FIELD :: tmp

#ifdef NON_REALITY
  tmp=cmplx(dsqrt(0.3_8),dsqrt(0.2_8),kind=8)
#else
  call ran_gauss_volh(NDIRAC * NCOL, tmp, HALF, EVEN)
#endif
  call sc_realorder(out,tmp)
end

!-------------------------------------------------------------------------------
subroutine random_sc_field_hh(out)
  use module_dd
  implicit none
  COMPLEX, dimension(4,3,ld%lat%volh,0:ld%lat%num_ip-1),intent(out) :: out
  COMPLEX, dimension(4,3,ld%lat%volh,0:ld%lat%num_ip-1) :: tmp
  COMPLEX, dimension(4,3,ld%lat%volh,0:ld%lat%num_ip-1,0:1) :: ddsc

#ifdef NON_REALITY
  out=cmplx(dsqrt(0.3_8),dsqrt(0.2_8),kind=8)
  tmp=cmplx(dsqrt(0.3_8),dsqrt(0.2_8),kind=8)
#else
  call ran_gauss_volh(NDIRAC * NCOL, out, HALF, EVEN)
  call ran_gauss_volh(NDIRAC * NCOL, tmp, HALF, ODD)
#endif

  call sc2ddsc(ddsc,out,tmp)
  call ddsc_dcmp(out(1,1,1,0              ),ddsc(1,1,1,0,0),0)
  call ddsc_dcmp(out(1,1,1,ld%lat%num_ip/2),ddsc(1,1,1,0,1),0)

end

#endif

!-------------------------------------------------------------------------------
subroutine fermi_action_rhmc_z(type, pf, init)
  ! Complex version for PF-RHMC with standard BQCD RHMC
  use module_action
  use module_function_decl
  use module_vol
  use module_rhmc
  implicit none

  type(type_pfermi) :: pf
  logical :: init
  integer :: type

  integer :: mid, rid, i
  REAL :: factor, exponent
  COMPLEX, allocatable :: tmp(:), tmp2(:)

  DEBUG2S("Start : fermi_action_rhmc_z")
  mid = pf%mid1
  rid = pf%rid
  factor = pf%factor

  allocate(tmp(NDIRAC*NCOL*volh_tot))
  allocate(tmp2(NDIRAC*NCOL*volh_tot))

  call init_quark(mid)

  pf%sf = 0

  if (init) then
     ! Initialize the pseudofermions at pf%mpf(i)%sc
     exponent = -ratapp(rid)%exponents(2)
     do i = 1, pf%npf
       call random_sc_field(tmp)
       pf%sf = pf%sf + dotprod(tmp, tmp, SIZE_SC_FIELD)
       call rhmc_action(type, tmp, mid, ratapp(rid)%shift_exact, &
            ratapp(rid)%abar_exact_p, ratapp(rid)%bbar_exact_p, &
            factor, exponent)
       if (pf%polyid > 0) then
          call poly_hmult(tmp2, tmp, pf)
       endif
       call sc_copy(pf%mpf(i)%sc, tmp2)
    enddo
  else
     ! Given the pseudofermions at pf%mpf(i)%sc, calculate Sf
     exponent = ratapp(rid)%exponents(2)
     do i = 1, pf%npf
        call sc_copy(tmp, pf%mpf(i)%sc)
        call rhmc_action(type, tmp, mid, ratapp(rid)%shift_exact, &
             ratapp(rid)%abar_exact_m, ratapp(rid)%bbar_exact_m, &
             factor, exponent)
        if (pf%polyid > 0) then
           call inv_hpoly(tmp2, tmp, pf, CG_MC)
        endif
        pf%sf = pf%sf + dotprod(tmp2, tmp2, SIZE_SC_FIELD)
     enddo
  endif

  deallocate(tmp, tmp2)

  DEBUG2S("End: fermi_action_rhmc_z")

end

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

subroutine half_rat(inout, mid, n, c_k, b_k, d_n, factor, exponent, conj)
  ! Mulitply inout in-place by half the rational function
  !
  ! inout -> S(K) inout, where R(K) = SdagS = d_n \prod(K + c_k)/\prod(K + b_k)
  ! Factorization here uses K = MdagM

  use module_vol
  use module_field
  use module_function_decl
  implicit none

  SPINCOL_FIELD, intent(inout) :: inout
  integer,       intent(in)    :: mid, n
  REAL,          intent(in)    :: c_k(n), b_k(n), d_n, factor, exponent
  integer, intent(in)          :: conj

  integer :: frdo(n), iters(n), i, j
  logical :: use_conj
  REAL :: fe
  COMPLEX :: residue, iscof(n), isbof(n)
  COMPLEX, allocatable :: tmp(:)

  external :: wdagg5_r8

  allocate(tmp(NDIRAC*NCOL*volh_tot))

  ! Perform required scaling such that the approximation range is centred
  ! over the latest eigenvalue range for K
  ! Explicitly half exponent here for half the rational approxmation
  fe = factor**(exponent/2)

  ! Determine whether we're calculating S*(K) or just S(K)
  !if (present(conj)) then
  use_conj = (conj >= 1)
  !else
  !   use_conj = .false.
  !endif

  ! Shifts required here are i * sqrt(b_k) and i * sqrt(c_k)
  ! 'iscof' = i * sqrt(c_k/factor), similarly for isbof
  if (use_conj) then
     iscof = cmplx(ZERO, -sqrt(c_k/factor))
     isbof = cmplx(ZERO, -sqrt(b_k/factor))
  else
     iscof = cmplx(ZERO, sqrt(c_k/factor))
     isbof = cmplx(ZERO, sqrt(b_k/factor))
  endif

  frdo = 0

  ! A real-shift rational polynomial R(K) = d_n prod(K + c_k)/prod(K + b_k)
  ! can be decomposed to R(K) = S*S, where
  !   S(K) = sqrt(d_n) prod(M + i sqrt(c_k))/prod(M + i sqrt(b_k))
  ! and K = M^dag M.
  !
  ! Calculating S(K) involves a multi-shift conjugate residual solver, as
  ! M is not positive-definite in general.

  if (use_conj) then
     call mcr_outer_mat(inout, wdagg5_r8, mid, n, frdo, isbof, iters, 0, CG_MC)
  else
     call mcr_outer_z(inout, mid, n, frdo, isbof, iters, 0, CG_MC)
  endif

  !! Construct S(K) from the poles [M + i sqrt(b_k)]^-1 phi via
  !+    S(K) = sqrt(d_n) (M + i sqrt(c_n)) * sum [res_k / (M + i sqrt(b_k))]
  !+ where res_k = residue of the remaining rational function
  !+ at z = - i sqrt(b_k)
  call sc_zero(inout)
  do i = 1, n
     residue = fe * sqrt(d_n)
     do j = 1, n
        if (j /= i) then
           residue = residue / (- isbof(i) + isbof(j))
        endif
        if (j < n) then
           residue = residue * (- isbof(i) + iscof(j))
        endif
     enddo
     call sc_caxpy(inout, sco(1,i)%sco(1), residue)
  enddo

  ! Perform mulitplication by (M + i sqrt(c_n))
  if (use_conj) then
     call wdagg5_r8(tmp, inout, mid)
  else
     call g5wmul_r8(tmp, inout, mid)
  endif
  call sc_cxpby(inout, tmp(1), iscof(n))

  deallocate(tmp)

end subroutine half_rat

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

subroutine rat_mult(inout, mid, n, c_k, b_k, d_n, factor, exponent)
  ! Mulitply inout in-place by the rational function
  !
  ! inout -> R(K) inout, where R(K) = d_n \prod(K + c_k)/\prod(K + b_k)

  use module_vol
  use module_field
  use module_function_decl
  implicit none

  SPINCOL_FIELD, intent(inout) :: inout
  integer,       intent(in)    :: mid, n
  REAL,          intent(in)    :: c_k(n), b_k(n), d_n, factor, exponent

  integer :: frdo(n), iters(n), i, j
  REAL :: fe
  COMPLEX :: residue, cof(n), bof(n)
  COMPLEX, allocatable :: tmp(:)

  allocate(tmp(NDIRAC*NCOL*volh_tot))

  ! Perform required scaling such that the approximation range is centred
  ! over the latest eigenvalue range for K
  fe = factor**exponent

  cof = c_k/factor
  bof = b_k/factor

  frdo = 0

  ! Calculate the poles required
  call mcg_outer_z(inout, mid, n, frdo, bof, iters, 0, CG_MC)

  !! Construct R(K) from the poles [K + b_k]^-1 phi via
  !+    S(K) = d_n (K + c_n) * sum [res_k / (K + b_k)]
  !+ where res_k = residue of the remaining rational function
  !+ at z = - b_k
  call sc_zero(inout)
  do i = 1, n
     residue = fe * d_n
     do j = 1, n
        if (j /= i) then
           residue = residue / (- bof(i) + bof(j))
        endif
        if (j < n) then
           residue = residue * (- bof(i) + cof(j))
        endif
     enddo
     call sc_caxpy(inout, sco(1,i)%sco(1), residue)
  enddo

  ! Perform mulitplication by (K + c_n)
  call wdagw_r8(tmp, inout, mid)
  call sc_cxpby(inout, tmp(1), cof(n))

  deallocate(tmp)

end subroutine rat_mult

!-------------------------------------------------------------------------------
subroutine fermi_action_rhmc_zolo(type, pf, init)
  ! Calculate fermion action for a Zolotarev rational approximation
  !
  ! Includes modifications for the truncated and polynomial correction
  ! cases.

  use module_action
  use module_function_decl
  use module_vol
  use module_rhmc_zolo
  use module_truncrat
  use module_input
  implicit none

  type(type_pfermi) :: pf
  logical :: init
  integer :: type

  integer :: mid, rid, i, nshifts
  integer :: i_large, i_small, n_low, n_high
  REAL :: factor, exponent, d_n
  COMPLEX, allocatable :: tmp(:), tmp2(:)

  DEBUG2S("Start : fermi_action_rhmc_zolo")
  mid = pf%mid1
  rid = pf%rid
  factor = pf%factor
  nshifts = ratapp_zolo(rid)%shift

  if (pf%truncid > 0) then
     n_low = truncrat(pf%truncid)%n_low
     n_high = truncrat(pf%truncid)%n_high
     ! Reverse indices so that an initial index of '1' == largest shift
     !
     ! For example, if (n_low, n_high) = (2, 6), then we want the 2nd to 6th
     ! largest shifts, which are at indices (nshifts - 1) to (nshifts - 5)

     i_large = nshifts - n_low + 1
     ! If n_high = 0, we want to include ALL smaller shifts -> i_small = 1
     i_small = modulo(nshifts - n_high, nshifts) + 1
  else
     ! No truncation => whole ratapp is included
     i_small = 1
     i_large = nshifts
  endif


  if (i_large < ZERO) then
     call die("fermi_action_rhmc_zolo(): # shifts < n_low")
  endif

  if (i_large == nshifts) then
      ! This term approximates 1/sqrt(K) as it has the largest shift:
      ! => include d_n and exponent
      d_n = ratapp_zolo(rid)%d_n
      exponent = ratapp_zolo(rid)%exponent
  else
      ! This is a correction term: no d_n, and exponent = 0
      d_n = ONE
      exponent = ZERO
  endif

  allocate(tmp(NDIRAC*NCOL*volh_tot))
  if (.not. init .and. pf%polyid > 0) then
     ! Need extra storage for this case
     allocate(tmp2(NDIRAC*NCOL*volh_tot))
  endif

  call init_quark(mid)

  pf%sf = 0

  if (init) then
     ! Generate appropriately distributed pseudofermions pf%mpf(i)%sc
     exponent = -exponent
     do i = 1, pf%npf
        call random_sc_field(tmp)
        pf%sf = pf%sf + dotprod(tmp, tmp, SIZE_SC_FIELD)

        ! tmp -> S(K)^-1 tmp
        !+ such that R(K) = S*S = d_n prod(K + c_k)/prod(K + b_k)
        ! The inverse is constructed by switching the c_k and b_k,
        ! and inverting the normalization constant:
        !  R^-1 = 1/d_n prod(K + b_k)/prod(K + c_k)

        call half_rat(tmp, mid, i_large-i_small+1, &
             ratapp_zolo(rid)%b_k(i_small:i_large), &
             ratapp_zolo(rid)%c_k(i_small:i_large), &
             ONE/d_n, factor, exponent, 0)

        ! Add in polynomial part if it exists
        if (pf%polyid > 0) then
           ! Sf = pt (P^-1(K) R(K)) p: include polynomial part
           call poly_hmult(pf%mpf(i)%sc, tmp, pf)
        else
           ! Sf = pt R(K) p
           call sc_copy(pf%mpf(i)%sc, tmp)
        endif

     enddo
  else
     ! Given pseudofermions pf%mpf(i)%sc, calculate the action S(K)
     do i = 1, pf%npf
        call sc_copy(tmp, pf%mpf(i)%sc)

        ! tmp -> S(K) tmp
        !+ such that R(K) = S*S = d_n prod(K + c_k)/prod(K + b_k)
        call half_rat(tmp, mid, i_large-i_small+1, &
             ratapp_zolo(rid)%c_k(i_small:i_large), &
             ratapp_zolo(rid)%b_k(i_small:i_large), &
             d_n, factor, exponent, 0)

        if (pf%polyid > 0) then
           ! Sf = pt (P^-1(K) R(K)) p: include polynomial part
           call inv_hpoly(tmp2, tmp, pf, CG_MC)
           pf%sf = pf%sf + dotprod(tmp2, tmp2, SIZE_SC_FIELD)
        else
           ! Sf = pt R(K) p
           pf%sf = pf%sf + dotprod(tmp, tmp, SIZE_SC_FIELD)
        endif
     enddo
  endif

  deallocate(tmp)
  if (.not. init .and. pf%polyid > 0) then
     deallocate(tmp2)
  endif

  DEBUG2S("End: fermi_action_rhmc_zolo")

end subroutine fermi_action_rhmc_zolo


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