!===============================================================================
!
! dsf-v3.F90  -  version u_flip
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2007-2008 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 dsf(p, p_qed, p_axion, step, a, b, mid)
  use module_vol
  implicit none

  GENERATOR_FIELD, intent(inout) :: p
  U1_GENERATOR_FIELD, intent(inout) :: p_qed
  AXION_MOMENTUM_FIELD, intent(inout) :: p_axion
  REAL,            intent(in)    :: step
  SPINCOL_FIELD,   intent(in)    :: a, b
  integer,         intent(in)    :: mid

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

  DEBUG2S("Start: dsf")

  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 xbound_sc_field(a)
!!  call xbound_sc_field(b)

  call dsf_sum(p_axion, w, w1, w2, step, a, b, mid)
  call dsf_w2gen(p, p_qed, w, w1, w2, mid)

  deallocate(w, w1, w2)

  !!call sc_zero_halo(a)
  !!call sc_zero_halo(b)
  DEBUG2S("End: dsf_sum")
end

!-------------------------------------------------------------------------------
subroutine dsf_sum(p_axion, w, w1, w2, step, a, b, id)
  use module_field
  use module_action
  use module_vol
  use module_p_interface
  implicit none

  AXION_MOMENTUM_FIELD, intent(inout) :: p_axion
  GAUGE_FIELD,     intent(inout) :: w, w1, w2
  REAL,            intent(in)    :: step
  SPINCOL_FIELD :: a, b
  integer,intent(in) :: id
  COMPLEX, allocatable :: at(:, :, :)
  COMPLEX, allocatable :: bt(:, :, :)
  COMPLEX, allocatable :: tmp(:, :, :)
  REAL                           :: s, s1, s2, s3, s4

  COMPLEX :: fac1, fac2
  COMPLEX, parameter :: zone= cmplx(1,0)
  fac1=exp(cmplx( chemi, chemi_i))
  fac2=exp(cmplx(-chemi,-chemi_i))


  TIMING_START(timing_bin_dsf_sum)
  DEBUG2S("Start: dsf_sum")

  allocate(tmp(NDIRAC, NCOL, volh_tot))
  allocate(at(NDIRAC, NCOL, volh_tot))
  allocate(bt(NDIRAC, NCOL, volh_tot))

  !!call sc_zero_halo(tmp)
  !!call sc_zero_halo(at)
  !!call sc_zero_halo(bt)

  at = ZERO
  bt = ZERO
  s = -step * TWO *   action%mtilde(id)%kappa**2 / (ONE + action%mtilde(id)%h**2)
  s1 = -step * TWO * (action%mtilde(id)%cswkappa / EIGHT)
  s2 = -step * TWO * (action%mtilde(id)%cswkappa / EIGHT) * action%mtilde(id)%kappa**2
  s3 =  step * TWO *finv_axion                              ! for axion
  s4 =  step * TWO *finv_axion * action%mtilde(id)%kappa**2 ! for axion
#ifdef OMTDTD
  call sc_copy(tmp, b)
  if (s1 /= ZERO) then
     call clover_dag_inv_mult(tmp, action%mtilde(id)%cid, se)   ! <- for non-Hermitian clover 
  endif
  call dsf_at_bt(at, bt, a, tmp, action%mtilde(id)%kappa, &
                               action%mtilde(id)%cswkappa, &
                               action%mtilde(id)%h, &
                               action%mtilde(id)%cid, &
                               se)
  call dsf_xyztfb_w(w, gauge(2)%u(1,1,1,0,1), s, a, tmp, at, bt, se)
  call clover_bsa_w(w2, s2, bt, at)
  call axion_force(p_axion, s4, bt, at, so)
  if (s1 /= ZERO) then
#ifdef FLIPSC
     call scfield_reorder_43_to_34(at)
#endif
     call sc_zero_halo(at)
     if (chemi /=0 .or. chemi_i/=0) call emuu4(gauge(2)%u, fac1, fac2, .false.)
     call d(se, so, bt, at, gauge(2)%u(1,1,1,0,1))
     if (chemi /=0 .or. chemi_i/=0) call emuu4(gauge(2)%u, zone, zone, .false.)
     call xbound_sc_field(at)
     call clover_inv_mult(bt, action%mtilde(id)%cid, se)
#ifdef FLIPSC
     call scfield_reorder_34_to_43(bt)
#endif
     call xbound_sc_field(bt)
  endif
  !                         b     a
  call clover_bsa_w(w1, s2, tmp,  bt )
  call axion_force(p_axion, s4, tmp, bt, se)
#else
  call dsf_at_bt(at, bt, a, b, action%mtilde(id)%kappa, &
                               action%mtilde(id)%cswkappa, &
                               action%mtilde(id)%h, &
                               action%mtilde(id)%cid, &
                               se)
  call dsf_xyztfb_w(w, gauge(2)%u(1,1,1,0,1), s, a, b, at, bt, se)
  call clover_bsa_w(w1, s1, b,  a )
  call clover_bsa_w(w2, s2, bt, at)
  call axion_force(p_axion, s3, b,   a, se)
  call axion_force(p_axion, s4, bt, at, so)
#endif

  !!call sc_zero_halo(a)
  !!call sc_zero_halo(b)

  deallocate(tmp, at, bt)

  DEBUG2S("End: dsf_sum")
  TIMING_STOP(timing_bin_dsf_sum)

end

!-------------------------------------------------------------------------------
subroutine dsf_w2gen(p, p_qed, w, w1, w2, mid)
  use module_field
  use module_switches
  use module_vol
  use module_action
  use module_stout_field
  implicit none

  GENERATOR_FIELD, intent(inout) :: p
  U1_GENERATOR_FIELD, intent(inout) :: p_qed
  GAUGE_FIELD,     intent(in)    :: w, w1, w2
  integer,intent(in)             :: mid
  COMPLEX, allocatable :: ww(:, :, :, :, :)
  integer, parameter :: stout_id = 1

  TIMING_START(timing_bin_dsf_w2gen)
  DEBUG2S("Start: dsf_w2gen")

  if (switches%qed) then
     call qed_gen_m_force(p_qed, w)  !! is called BEFORE derivative, because QED relates only hopping term 
     call qed_qcd_mult(w, a_qed_ptr, gauge(2)%em_charge)
  endif

  if (switches%clover) then
     if (gauge(3)%sid /=0 .and. gauge(2)%sid /=0) then
        call clover_d_add(w, stout(stout_id)%iter( stout(stout_id)%n )%u, w1, se)
        call clover_d_add(w, stout(stout_id)%iter( stout(stout_id)%n )%u, w2, so)
        call dstout(w, stout_id)
     elseif (gauge(3)%sid /=0 .and. gauge(2)%sid ==0) then
        allocate(ww(NCOL, NCOL, volh_tot, 0:1, DIM))
        ww = ZERO
        call clover_d_add(ww,stout(stout_id)%iter( stout(stout_id)%n )%u, w1, se)
        call clover_d_add(ww,stout(stout_id)%iter( stout(stout_id)%n )%u, w2, so)
        call dstout(ww, stout_id)
        call gauge_add(w,ww)
        deallocate(ww)
     elseif (gauge(3)%sid ==0 .and. gauge(2)%sid /=0) then
        allocate(ww(NCOL, NCOL, volh_tot, 0:1, DIM))
        ww = ZERO
        call clover_d_add(ww, gauge(1)%u, w1, se)
        call clover_d_add(ww, gauge(1)%u, w2, so)
        call dstout(w, stout_id)
        call gauge_add(w,ww)
        deallocate(ww)
     else
        call clover_d_add(w, gauge(1)%u, w1, se)
        call clover_d_add(w, gauge(1)%u, w2, so)
     endif
     call gen_m_force(p, w, gauge(1)%u)
  else
     if (gauge(2)%sid /=0) call dstout(w, stout_id)
     call gen_m_force(p, w, gauge(1)%u)
  endif
#ifdef BQCD_DDHMC
  call nonactive(p) !! for ddhmc
#endif
  DEBUG2S("End: dsf_w2gen")
  TIMING_STOP(timing_bin_dsf_w2gen)

end

!-------------------------------------------------------------------------------
!
! a  =                          (M^dagM)^(-1) phi
! b  =                        M (M^dagM)^(-1) phi
! at =C_oo^(    -1) D_oe        (M^dagM)^(-1) phi
! bt =C_oo^(dag,-1) D_oe^dag  M (M^dagM)^(-1) phi
!
!-------------------------------------------------------------------------------
subroutine dsf_at_bt(at, bt, a, b, k, ck, h, cid, e)
  use module_action
  use module_field
  use module_vol
  implicit none
  SPINCOL_FIELD,   intent(out)   :: at, bt
  SPINCOL_FIELD,   intent(inout) :: a, b
  REAL,            intent(in)    :: k, ck, h
  integer,         intent(in)    :: e, cid
  integer                        :: o

  COMPLEX :: fac1, fac2
  COMPLEX, parameter :: zone = cmplx(1,0)

  if (k == ZERO) return

  TIMING_START(timing_bin_dsf_at_bt)
  DEBUG2S("Start: dsf_at_bt")

  call sc_zero_halo(a)
  call sc_zero_halo(b)

  o = 1 - e

  fac1=exp(cmplx( chemi, chemi_i))
  fac2=exp(cmplx(-chemi,-chemi_i))
  if (chemi /=0 .or. chemi_i/=0) call emuu4(gauge(2)%u, fac1, fac2, .false.)
  call d(    o, e, at, a, gauge(2)%u(1,1,1,0,1))          ! A~ = Doe A
  if (chemi /=0 .or. chemi_i/=0) call emuu4(gauge(2)%u, zone, zone, .false.)

  fac1=exp(cmplx(-chemi, chemi_i))
  fac2=exp(cmplx( chemi,-chemi_i))
  if (chemi /=0 .or. chemi_i/=0) call emuu4(gauge(2)%u, fac1, fac2, .false.)
  call d_dag(o, e, bt, b, gauge(2)%u(1,1,1,0,1))          ! B~ = Deo+ B
  if (chemi /=0 .or. chemi_i/=0) call emuu4(gauge(2)%u, zone, zone, .false.)

  if (ck /= ZERO) then
     call clover_inv_mult(at, cid, o)    ! A~ = inv(Too) A~
     call clover_dag_inv_mult(bt, cid, o)! B~ = inv(Too) B~, for non-Hermitian clover
  else
     if (h /= ZERO) then
        call h_mult_b(-h, at, volh)                 ! A~ ~ inv(H) A~
        call h_mult_b( h, bt, volh)                 ! B~ ~ inv(H+) B~
     endif
  endif
  DEBUG2S("Start: dsf_at_bt: before xbound")
#ifdef FLIPSC
  call scfield_reorder_34_to_43(a)
  call scfield_reorder_34_to_43(b)
  call scfield_reorder_34_to_43(at)
  call scfield_reorder_34_to_43(bt)
#endif

  call xbound_sc_field(a)
  call xbound_sc_field(b)
  call xbound_sc_field(at)
  call xbound_sc_field(bt)

  DEBUG2S("End: dsf_at_bt")
  TIMING_STOP(timing_bin_dsf_at_bt)
end

!-------------------------------------------------------------------------------
subroutine dsf_xyztfb_w(w_add, u, s, a, b, at, bt, e)
  use module_p_interface
  use module_action
  use module_nn
  use module_vol
  implicit none

  GAUGE_FIELD,     intent(in)    :: u
  SPINCOL_FIELD,   intent(in)    :: a, at, b, bt
  REAL,            intent(in)    :: s
  integer,         intent(in)    :: e
  GAUGE_FIELD,     intent(inout) :: w_add
  COMPLEX, allocatable :: w(:, :, :, :, :)
  SU3     :: v
  integer :: i, eo, mu, o
  COMPLEX :: fac1, fac2

  if (s == ZERO) return

  TIMING_START(timing_bin_dsf_xyztfb_w)
  DEBUG2S("Start: dsf_xyztfb_w")

  fac1=exp(cmplx( chemi, chemi_i))
  fac2=exp(cmplx(-chemi,-chemi_i))

  allocate(w(NCOL, NCOL, volh_tot, EVEN:ODD, DIM))

  o = 1 - e

#ifdef GAMMA_NOTATION_CHROMA
  call dsf_f_dcmp_1_p_gamma1(w(1,1,1,e,1), b, at, nn(1,e,1,FWD))
  call dsf_f_dcmp_1_p_gamma1(w(1,1,1,o,1), bt, a, nn(1,o,1,FWD))
  call dsf_f_dcmp_1_m_gamma2(w(1,1,1,e,2), b, at, nn(1,e,2,FWD))
  call dsf_f_dcmp_1_m_gamma2(w(1,1,1,o,2), bt, a, nn(1,o,2,FWD))
  call dsf_f_dcmp_1_p_gamma3(w(1,1,1,e,3), b, at, nn(1,e,3,FWD))
  call dsf_f_dcmp_1_p_gamma3(w(1,1,1,o,3), bt, a, nn(1,o,3,FWD))
  call dsf_f_dcmp_1_m_gammac(w(1,1,1,e,4), b, at, nn(1,e,4,FWD))
  call dsf_f_dcmp_1_m_gammac(w(1,1,1,o,4), bt, a, nn(1,o,4,FWD))
#elif defined GAMMA_NOTATION_CHIRAL
  call dsf_f_dcmp_1_m_gamma1(w(1,1,1,e,1), b, at, nn(1,e,1,FWD))
  call dsf_f_dcmp_1_m_gamma1(w(1,1,1,o,1), bt, a, nn(1,o,1,FWD))
  call dsf_f_dcmp_1_m_gamma2(w(1,1,1,e,2), b, at, nn(1,e,2,FWD))
  call dsf_f_dcmp_1_m_gamma2(w(1,1,1,o,2), bt, a, nn(1,o,2,FWD))
  call dsf_f_dcmp_1_m_gamma3(w(1,1,1,e,3), b, at, nn(1,e,3,FWD))
  call dsf_f_dcmp_1_m_gamma3(w(1,1,1,o,3), bt, a, nn(1,o,3,FWD))
  call dsf_f_dcmp_1_m_gammac(w(1,1,1,e,4), b, at, nn(1,e,4,FWD))
  call dsf_f_dcmp_1_m_gammac(w(1,1,1,o,4), bt, a, nn(1,o,4,FWD))
#elif defined GAMMA_NOTATION_DDHMC
  call dsf_f_dcmp_1_m_gamma1(w(1,1,1,e,1), b, at, nn(1,e,1,FWD))
  call dsf_f_dcmp_1_m_gamma1(w(1,1,1,o,1), bt, a, nn(1,o,1,FWD))
  call dsf_f_dcmp_1_m_gamma2(w(1,1,1,e,2), b, at, nn(1,e,2,FWD))
  call dsf_f_dcmp_1_m_gamma2(w(1,1,1,o,2), bt, a, nn(1,o,2,FWD))
  call dsf_f_dcmp_1_m_gamma3(w(1,1,1,e,3), b, at, nn(1,e,3,FWD))
  call dsf_f_dcmp_1_m_gamma3(w(1,1,1,o,3), bt, a, nn(1,o,3,FWD))
  call dsf_f_dcmp_1_p_gammac(w(1,1,1,e,4), b, at, nn(1,e,4,FWD))
  call dsf_f_dcmp_1_p_gammac(w(1,1,1,o,4), bt, a, nn(1,o,4,FWD))
#elif defined GAMMA_NOTATION_BQCD
  call dsf_f_dcmp_1_p_gamma1(w(1,1,1,e,1), b, at, nn(1,e,1,FWD))
  call dsf_f_dcmp_1_p_gamma1(w(1,1,1,o,1), bt, a, nn(1,o,1,FWD))
  call dsf_f_dcmp_1_p_gamma2(w(1,1,1,e,2), b, at, nn(1,e,2,FWD))
  call dsf_f_dcmp_1_p_gamma2(w(1,1,1,o,2), bt, a, nn(1,o,2,FWD))
  call dsf_f_dcmp_1_p_gamma3(w(1,1,1,e,3), b, at, nn(1,e,3,FWD))
  call dsf_f_dcmp_1_p_gamma3(w(1,1,1,o,3), bt, a, nn(1,o,3,FWD))
  call dsf_f_dcmp_1_m_gamman(w(1,1,1,e,4), b, at, nn(1,e,4,FWD))
  call dsf_f_dcmp_1_m_gamman(w(1,1,1,o,4), bt, a, nn(1,o,4,FWD))
#endif

  call flip_bc(w)
  do mu = 1, 3
     do eo = EVEN, ODD
        !$omp parallel do
        do i = 1, volh
           call u_scale(w(1, 1, i, eo, mu), s)
           call u_add(w_add(1, 1, i, eo, mu), w(1, 1, i, eo, mu))
        enddo
     enddo
  enddo
  !$omp parallel do
  do i = 1, volh
     call u_scale_c(w(1, 1, i, e, 4), s*fac1)
     call u_add(w_add(1, 1, i, e, 4), w(1, 1, i, e, 4))
  enddo
  !$omp parallel do
  do i = 1, volh
     call u_scale_c(w(1, 1, i, o, 4), s*fac1)
     call u_add(w_add(1, 1, i, o, 4), w(1, 1, i, o, 4))
  enddo



#ifdef GAMMA_NOTATION_CHROMA
  call dsf_b_dcmp_1_m_gamma1(w(1,1,1,e,1), bt, a, nn(1,e,1,FWD))
  call dsf_b_dcmp_1_m_gamma1(w(1,1,1,o,1), b, at, nn(1,o,1,FWD))
  call dsf_b_dcmp_1_p_gamma2(w(1,1,1,e,2), bt, a, nn(1,e,2,FWD))
  call dsf_b_dcmp_1_p_gamma2(w(1,1,1,o,2), b, at, nn(1,o,2,FWD))
  call dsf_b_dcmp_1_m_gamma3(w(1,1,1,e,3), bt, a, nn(1,e,3,FWD))
  call dsf_b_dcmp_1_m_gamma3(w(1,1,1,o,3), b, at, nn(1,o,3,FWD))
  call dsf_b_dcmp_1_p_gammac(w(1,1,1,e,4), bt, a, nn(1,e,4,FWD))
  call dsf_b_dcmp_1_p_gammac(w(1,1,1,o,4), b, at, nn(1,o,4,FWD))
#elif defined GAMMA_NOTATION_CHIRAL
  call dsf_b_dcmp_1_p_gamma1(w(1,1,1,e,1), bt, a, nn(1,e,1,FWD))
  call dsf_b_dcmp_1_p_gamma1(w(1,1,1,o,1), b, at, nn(1,o,1,FWD))
  call dsf_b_dcmp_1_p_gamma2(w(1,1,1,e,2), bt, a, nn(1,e,2,FWD))
  call dsf_b_dcmp_1_p_gamma2(w(1,1,1,o,2), b, at, nn(1,o,2,FWD))
  call dsf_b_dcmp_1_p_gamma3(w(1,1,1,e,3), bt, a, nn(1,e,3,FWD))
  call dsf_b_dcmp_1_p_gamma3(w(1,1,1,o,3), b, at, nn(1,o,3,FWD))
  call dsf_b_dcmp_1_p_gammac(w(1,1,1,e,4), bt, a, nn(1,e,4,FWD))
  call dsf_b_dcmp_1_p_gammac(w(1,1,1,o,4), b, at, nn(1,o,4,FWD))
#elif defined GAMMA_NOTATION_DDHMC
  call dsf_b_dcmp_1_p_gamma1(w(1,1,1,e,1), bt, a, nn(1,e,1,FWD))
  call dsf_b_dcmp_1_p_gamma1(w(1,1,1,o,1), b, at, nn(1,o,1,FWD))
  call dsf_b_dcmp_1_p_gamma2(w(1,1,1,e,2), bt, a, nn(1,e,2,FWD))
  call dsf_b_dcmp_1_p_gamma2(w(1,1,1,o,2), b, at, nn(1,o,2,FWD))
  call dsf_b_dcmp_1_p_gamma3(w(1,1,1,e,3), bt, a, nn(1,e,3,FWD))
  call dsf_b_dcmp_1_p_gamma3(w(1,1,1,o,3), b, at, nn(1,o,3,FWD))
  call dsf_b_dcmp_1_m_gammac(w(1,1,1,e,4), bt, a, nn(1,e,4,FWD))
  call dsf_b_dcmp_1_m_gammac(w(1,1,1,o,4), b, at, nn(1,o,4,FWD))
#elif defined GAMMA_NOTATION_BQCD
  call dsf_b_dcmp_1_m_gamma1(w(1,1,1,e,1), bt, a, nn(1,e,1,FWD))
  call dsf_b_dcmp_1_m_gamma1(w(1,1,1,o,1), b, at, nn(1,o,1,FWD))
  call dsf_b_dcmp_1_m_gamma2(w(1,1,1,e,2), bt, a, nn(1,e,2,FWD))
  call dsf_b_dcmp_1_m_gamma2(w(1,1,1,o,2), b, at, nn(1,o,2,FWD))
  call dsf_b_dcmp_1_m_gamma3(w(1,1,1,e,3), bt, a, nn(1,e,3,FWD))
  call dsf_b_dcmp_1_m_gamma3(w(1,1,1,o,3), b, at, nn(1,o,3,FWD))
  call dsf_b_dcmp_1_p_gamman(w(1,1,1,e,4), bt, a, nn(1,e,4,FWD))
  call dsf_b_dcmp_1_p_gamman(w(1,1,1,o,4), b, at, nn(1,o,4,FWD))
#endif

  do mu = 1, DIM
     do eo = EVEN, ODD
        !$omp parallel do private(v)
        do i = 1, volh
           call uud(v, w(1, 1, i, eo, mu), u(1, 1, i, eo, mu))
           call udu(w(1, 1, i, eo, mu), u(1, 1, i, eo, mu), v)   !! to cancel later
        enddo
     enddo
  enddo

  call flip_bc(w)

  do mu = 1, 3
     do eo = EVEN, ODD
        !$omp parallel do
        do i = 1, volh
           call u_scale(w(1, 1, i, eo, mu), -s)
           call u_add(w_add(1, 1, i, eo, mu), w(1, 1, i, eo, mu))
        enddo
     enddo
  enddo
  !$omp parallel do
  do i = 1, volh
     call u_scale_c(w(1, 1, i, o, 4), -s*fac2)
     call u_add(w_add(1, 1, i, o, 4), w(1, 1, i, o, 4))
  enddo
  !$omp parallel do
  do i = 1, volh
     call u_scale_c(w(1, 1, i, e, 4), -s*fac2)
     call u_add(w_add(1, 1, i, e, 4), w(1, 1, i, e, 4))
  enddo



  deallocate(w)

  DEBUG2S("End: dsf_xyztfb_w")
  TIMING_STOP(timing_bin_dsf_xyztfb_w)

end

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