!===============================================================================
!
! dsig.F90
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2006-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 dsig(p, u, impg, step)
  use module_field
  use module_action_type
  use module_vol
  use module_switches
  implicit none

  GENERATOR_FIELD, intent(inout) :: p
  GAUGE_FIELD, intent(in)        :: u
  type(type_impg), intent(in)    :: impg
  REAL,            intent(in)    :: step
  REAL                           :: s1, s2, s3
  SU3                            :: uuu, w
  integer                        :: mu, eo, i

  COMPLEX, allocatable :: w1(:, :, :, :, :)
  COMPLEX, allocatable :: w2(:, :, :, :, :)
  COMPLEX, allocatable :: w3(:, :, :, :, :)
  integer :: ierr


  if (impg%beta1 == ZERO) return
  if (step == ZERO) return

  TIMING_START(timing_bin_dsig)
  DEBUG2S("Start: dsig")

  allocate(w1(NCOL, NCOL, volh_tot, EVEN:ODD, DIM), STAT = ierr)
  allocate(w2(NCOL, NCOL, volh_tot, EVEN:ODD, DIM), STAT = ierr)
  allocate(w3(NCOL, NCOL, volh_tot, EVEN:ODD, DIM), STAT = ierr)

  call hmc_forces_old(p)
  s1 = -step * impg%beta1 / THREE
  s2 = -step * impg%beta2 / THREE
  s3 = -step * impg%beta3 / THREE

  do mu = 1, DIM
     call r_staple(w1, u(1,1,1,0,1), mu)
     if (switches%boundary_sf) call schr_boundary_zero4(w1)
     do eo = EVEN, ODD
        !$omp parallel do private(uuu, w)
        do i = 1, volh
           call staple_r_fat(uuu, u(1,1,1,0,1), w1, i, eo, mu)
           call uu(w, u(1, 1, i, eo, mu), uuu)
           call im_tr_j(p(1, i, eo, mu), w, s1)
        enddo
     enddo

     call u_staple(w1, u(1,1,1,0,1), mu)
     call d_staple(w2, u(1,1,1,0,1), mu)
     call l_staple(w3, u(1,1,1,0,1), mu)

     if (switches%boundary_sf) call schr_boundary_zero4(w1)
     if (switches%boundary_sf) call schr_boundary_zero4(w2)
     if (switches%boundary_sf) call schr_boundary_zero4(w3)

     do eo = EVEN, ODD
        !$omp parallel do private(uuu, w)
        do i = 1, volh
           call staple_udl(uuu, u(1,1,1,0,1), w1, w2, w3, i, eo, mu)
           call uu(w, u(1, 1, i, eo, mu), uuu)
           call im_tr_j(p(1, i, eo, mu), w, s1)
        enddo
     enddo

     if (s2 /= ZERO) call die("imp_action ERROR") ! chai
     if (s3 /= ZERO) call die("imp_action ERROR") ! para
  enddo

  if (switches%boundary_sf) call dsig_sfdiff(p, u, impg, step)
#ifdef BQCD_DDHMC
  call nonactive(p) !! for ddhmc
#endif
  call hmc_forces_new(p, step, impg%fid)


  deallocate(w1, STAT = ierr)
  deallocate(w2, STAT = ierr)

  DEBUG2S("End: dsig")
  TIMING_STOP(timing_bin_dsig)

end

!!!-------------------------------------------------------------------------------
!!subroutine dsig_old(p, impg, step)
!!  use module_field
!!  use module_action_type
!!  use module_vol
!!  use module_switches
!!  implicit none
!!
!!  GENERATOR_FIELD, intent(inout) :: p
!!  type(type_impg), intent(in)    :: impg
!!  REAL,            intent(in)    :: step
!!  REAL                           :: s1, s2, s3
!!  SU3                            :: uuu, w
!!  integer                        :: mu, eo, i
!!
!!!!  GAUGE_FIELD :: u_tmp1, u_tmp2
!!
!!  COMPLEX, allocatable :: w1(:, :, :, :, :)
!!  COMPLEX, allocatable :: w2(:, :, :, :, :)
!!  integer :: ierr
!!
!!
!!  if (impg%beta1 == ZERO) return
!!  if (step == ZERO) return
!!
!!  TIMING_START(timing_bin_dsig)
!!  DEBUG2S("Start: dsig")
!!
!!  allocate(w1(NCOL, NCOL, volh_tot, EVEN:ODD, DIM), STAT = ierr)
!!  if (ierr /= 0) then
!!     call stderr2_int("allocation failed", 1, ierr)
!!     call die("dsig: allocation failed w1")
!!  endif
!!  allocate(w2(NCOL, NCOL, volh_tot, EVEN:ODD, DIM), STAT = ierr)
!!  if (ierr /= 0) then
!!     call stderr2_int("allocation failed", 1, ierr)
!!     call die("dsig: allocation failed w2")
!!  endif
!!
!!  call hmc_forces_old(p)
!!  s1 = -step * impg%beta1 / THREE
!!  s2 = -step * impg%beta2 / THREE
!!  s3 = -step * impg%beta3 / THREE
!!
!!  do mu = 1, DIM
!!     call r_staple(w1, u(1,1,1,0,1), mu)
!!if (switches%boundary_sf) call schr_boundary_zero4(w1)
!!     do eo = EVEN, ODD
!!        !$omp parallel do private(uuu, w)
!!        do i = 1, volh
!!           call staple_r_fat(uuu, u(1,1,1,0,1), w1, i, eo, mu)
!!           call uu(w, u(1, 1, i, eo, mu), uuu)
!!           call im_tr_j(p(1, i, eo, mu), w, s1)
!!        enddo
!!     enddo
!!
!!     call ul_staple(w1, u(1,1,1,0,1), mu)
!!     call dl_staple(w2, u(1,1,1,0,1), mu)
!!
!!if (switches%boundary_sf) call schr_boundary_zero4(w1)
!!if (switches%boundary_sf) call schr_boundary_zero4(w2)
!!
!!     do eo = EVEN, ODD
!!        !$omp parallel do private(uuu, w)
!!        do i = 1, volh
!!           call staple_udl2(uuu, u(1,1,1,0,1), w1, w2, i, eo, mu)
!!           call uu(w, u(1, 1, i, eo, mu), uuu)
!!           call im_tr_j(p(1, i, eo, mu), w, s1)
!!        enddo
!!     enddo
!!
!!     if (s2 /= ZERO) call die("imp_action ERROR") ! chai
!!     if (s3 /= ZERO) call die("imp_action ERROR") ! para
!!  enddo
!!
!!  call nonactive(p) !! for ddhmc
!!
!!  call hmc_forces_new(p, step, impg%fid)
!!
!!
!!  deallocate(w1, STAT = ierr)
!!  if (ierr /= 0) then
!!     call stderr2_int("deallocation failed", 1, ierr)
!!     call die("dsig: deallocation failed w1")
!!  endif
!!  deallocate(w2, STAT = ierr)
!!  if (ierr /= 0) then
!!     call stderr2_int("deallocation failed", 1, ierr)
!!     call die("dsig: deallocation failed w2")
!!  endif
!!
!!  DEBUG2S("End: dsig")
!!  TIMING_STOP(timing_bin_dsig)
!!
!!end
!!
!===============================================================================
