!===============================================================================
!
! dsfr.F90  --  p(j,x,mu) := p(j,x,mu) - step * D_{x,mu,j} S_{fr}
!               for ration fractions
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2006-2012, 2017 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/>.
!
!-------------------------------------------------------------------------------
# include "defs.h"

!-------------------------------------------------------------------------------
subroutine dsfr(p, p_qed, p_axion, step, calc_sf, pf)
  use module_field
  use module_action
  use module_input
  use module_switches
  use module_vol
  use module_rhmc
  use module_hmc_forces
  implicit none

  GENERATOR_FIELD, intent(inout)    :: p
  U1_GENERATOR_FIELD, intent(inout) :: p_qed
  AXION_MOMENTUM_FIELD, intent(inout) :: p_axion
  integer, intent(in)               :: calc_sf
  REAL,    intent(in)               :: step
  type(type_pfermi)                 :: pf

  COMPLEX, dimension(:,:,:,:,:),allocatable :: w, w1, w2

  if (switches%quenched) return
  DEBUG2S("Start: dsfr")
  call hmc_forces_old(p)

  allocate(w( NCOL, NCOL, volh_tot, EVEN:ODD, DIM)); w=ZERO
  allocate(w1(NCOL, NCOL, volh_tot, EVEN:ODD, DIM)); w1=ZERO
  allocate(w2(NCOL, NCOL, volh_tot, EVEN:ODD, DIM)); w2=ZERO

  call dsf_fraction_sep(pf, step, w,w1,w2, p_axion)
  call dsf_w2gen(p, p_qed, w,w1,w2, pf%mid1)

  deallocate(w, w1, w2)

  call hmc_forces_new(p, step, pf%fid)
  DEBUG2S("End: dsfr")
end

!-------------------------------------------------------------------------------
subroutine dsf_fraction_sep(pf, step, w, w1, w2, p_axion)
  use module_action
  use module_vol
  use module_rhmc
  use module_field
  use module_input
  use multi_lr_solver
  implicit none

  type(type_pfermi) :: pf
  GAUGE_FIELD, intent(inout) :: w, w1, w2
  AXION_MOMENTUM_FIELD, intent(inout) :: p_axion
  REAL,        intent(in)    :: step
  integer :: frdo(ratapp(pf%rid)%shift)
  integer :: iters(ratapp(pf%rid)%shift), mid, rid, type, i, j

  REAL :: step_abar, factor, fe, bof(ratapp(pf%rid)%shift)
  REAL, allocatable :: tmp(:), phi(:,:)

  mid = pf%mid1
  rid = pf%rid
  type= pf%type
  call init_quark(mid)
  frdo =0

  factor=pf%factor
  fe    =factor**ratapp(rid)%exponents(1) / factor
  bof   =ratapp(rid)%bbar/factor

  allocate( tmp(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot))
  allocate( phi(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot, pf%npf))

  if (input%multi_shift_block_cg_qr==0) then
     do j = 1, pf%npf
     call sc_copy(phi(1,1),  pf%mpf(j)%sc)
     call mcg_outer(type, phi(1,1), mid, ratapp(rid)%shift, frdo, bof, iters, pf%pid, CG_MD)
     do i=1,ratapp(rid)%shift
        step_abar=step*ratapp(rid)%abar(i) * fe
        call wmul_r8(tmp, sco(1,i)%sco(1), mid)
        call dsf_sum(p_axion, w, w1, w2, step_abar, sco(1,i)%sco(1), tmp, mid)
     enddo
     enddo
  else
     do j = 1, pf%npf
        call sc_copy(phi(1, j), pf%mpf(j)%sc)
     enddo
     call mbcg_outer(type, mid, phi, ratapp(rid)%shift, pf%npf, frdo, bof, iters, pf%pid, CG_MD)
     do i = 1, ratapp(rid)%shift
        step_abar=step*ratapp(rid)%abar(i) * fe
        do j = 1, pf%npf
           call wmul_r8(tmp, xx(i)%v(1,j), mid)
           call dsf_sum(p_axion, w, w1, w2, step_abar, xx(i)%v(1,j), tmp, mid)
        enddo
     enddo
  endif

  deallocate(tmp, phi)

end

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