!===============================================================================
!
! sig.F90 - calculation of improved gauge action
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 1998-2005 Hinnerk Stueben
!               2006-2009 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"

!-------------------------------------------------------------------------------
module module_s_plaq
  interface
     REAL function s_plaq(u,plaq)
     REAL :: plaq(3)
     P_GAUGE_FIELD :: u
     end function s_plaq
  end interface
end

!-------------------------------------------------------------------------------
REAL function sig(s_p, plaq, rect)  ! returns S_g , s_plaq=sg(u)
  use module_field
  use module_action
  use module_s_plaq
  use module_switches
  implicit none

  REAL,intent(out) :: s_p, plaq(3), rect(3)
  REAL, external :: s_rect, s_plaq_sfdiff, s_rect_sfdiff
  REAL :: tmp

  s_p = s_plaq(gauge(1)%u, plaq)
  sig = action%plaq%beta * s_p

  if (switches%boundary_sf) sig = sig + action%plaq%beta * s_plaq_sfdiff(gauge(1)%u)
!!write(*,*)sig


  if (action%impg%beta1 /= ZERO) then
     tmp = s_rect(gauge(1)%u, rect)
     if (switches%boundary_sf) tmp = tmp + s_rect_sfdiff(gauge(1)%u)
     sig = sig + action%impg%beta1 * tmp
!!write(*,*) action%impg%beta1 * tmp
  else
     rect=0
  endif

!   if (action%impg%beta2 /= ZERO) sig = sig + action%impg%beta2 * s_chai2(gauge(1)%u)
!   if (action%impg%beta3 /= ZERO) sig = sig + action%impg%beta3 * s_para2(gauge(1)%u)

end

!-------------------------------------------------------------------------------
REAL function s_plaq(u, plaq)  ! returns S_g
  use module_lattice
  use module_nn
  use module_vol
  implicit none

!!  GAUGE_FIELD, intent(in) :: u
  P_GAUGE_FIELD :: u
  REAL, intent(out) :: plaq(3)
  REAL :: global_sum, p
  SU3 :: uuu
  integer :: i, e, o, mu, nu, j1, j2
  REAL, external :: Re_Tr_uu

  TIMING_START(timing_bin_plaq)

  plaq = 0

  do mu = 1, DIM
     do e = EVEN, ODD
        o = EVEN + ODD - e
        do nu = mu + 1, DIM
           p = ZERO
           !$omp parallel do reduction(+: p) private(j1, j2, uuu)
           do i = 1, VOLH

              !  (j2,o) --<--   x        nu
              !    |            |        
              !    v            ^         ^
              !    |            |         |
              !  (i,e)  -->-- (j1,o)      x-->  mu


              j1 = nn(i, e, mu, FWD)
              j2 = nn(i, e, nu, FWD)
              
              uuu = 0
              call uddp(uuu, u(1, 1, j1, o, nu), &
                             u(1, 1, j2, o, mu), &
                             u(1, 1, i, e, nu))

              p = p + Re_Tr_uu(uuu, u(1, 1, i, e, mu))
           enddo
           !$omp end parallel do

           if (gamma_index(mu) == 4 .or. gamma_index(nu) == 4) then
              plaq(3) = plaq(3) + p
           else
              plaq(2) = plaq(2) + p
           endif

        enddo
     enddo
  enddo

  plaq(3) = global_sum(plaq(3))
  plaq(2) = global_sum(plaq(2))
  plaq(1) = plaq(2) + plaq(3)

  s_plaq = SIX * dble(volume) - plaq(1) / THREE

  plaq(1) = plaq(1) / dble(18*volume)
  plaq(2) = plaq(2) / dble( 9*volume)
  plaq(3) = plaq(3) / dble( 9*volume)

  TIMING_STOP(timing_bin_plaq)

end

!-------------------------------------------------------------------------------
REAL function s_rect(u, rect)  ! returns S_rest
  use module_lattice
  use module_nn
  use module_vol
  use module_switches
  implicit none

  GAUGE_FIELD, intent(in) :: u
  REAL, intent(out) :: rect(3)
  REAL :: global_sum, p
  SU3 :: uuu
  integer :: i, e, o, mu, nu, j1, j2
  REAL, external :: Re_Tr_uu

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

  TIMING_START(timing_bin_rect)
  DEBUG2S("Start: s_rect")

  allocate(w1(NCOL, NCOL, volh_tot, EVEN:ODD, DIM), STAT = ierr)
  if (ierr /= 0) then
     call stderr2_int("allocation failed", 1, ierr)
     call die("s_rect: 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("s_rect: allocation failed w2")
  endif

  rect = 0

  do mu = 1, DIM
     do nu = mu + 1, DIM

        do e = EVEN, ODD
           o = EVEN + ODD - e
           !$omp parallel do private(j1, j2)
           do i = 1, VOLH
              !  (j2,o) --<--   x         nu
              !    |            |   
              !    v            ^         ^
              !    |            |         |
              !  (I,e)  -->-- (j1,o)      x-->  mu
              j1 = nn(i , e, mu, FWD)
              j2 = nn(i , e, nu, FWD)
              call uud_imp(w1(1, 1, i , e, nu), &
                                u(1, 1, i , e, mu), &
                                u(1, 1, j1, o, nu), &
                                u(1, 1, j2, o, mu))
              call uud_imp(w2(1, 1, i , e, mu), &
                                u(1, 1, i , e, nu), &
                                u(1, 1, j2, o, mu), &
                                u(1, 1, j1, o, nu))
           enddo
        enddo
#ifdef D500
        do e = EVEN, ODD
           call xbound_g(w1, e, nu)
           call xbound_g(w2, e, mu)
        enddo
if (switches%boundary_sf) call schr_boundary_zero4(w1)
if (switches%boundary_sf) call schr_boundary_zero4(w2)
#endif
        do e = EVEN, ODD
           o = EVEN + ODD - e
#ifndef D500
           call xbound_g_rect_ind(w1, o, nu, mu, FWD)
           call xbound_g_rect_ind(w2, o, mu, nu, FWD)
if (switches%boundary_sf) call schr_boundary_zero4(w1)
if (switches%boundary_sf) call schr_boundary_zero4(w2)
#endif
           p = ZERO
           !$omp parallel do reduction(+: p) private(j1, j2, uuu)
           do i = 1, VOLH
              !  (j2,o) <<<<<   x         nu
              !    |            A   
              !    v            A         ^
              !    |            A         |
              !  (I,e)  -->-- (j1,o)      x-->  mu
              j1 = nn(i , e, mu, FWD)
              j2 = nn(i , e, nu, FWD)
              uuu = ZERO
              call uddp(uuu, w1(1, 1, j1, o, nu), &
                                  u(1, 1, j2, o, mu), &
                                  u(1, 1, i , e, nu))
              call uddp(uuu,      u(1, 1, j1, o, nu), &
                             w2(1, 1, j2, o, mu), &
                                  u(1, 1, i , e, nu))

              p = p + Re_Tr_uu(uuu, u(1, 1, i, e, mu))
           enddo
           !$omp end parallel do

           if (gamma_index(mu) == 4 .or. gamma_index(nu) == 4) then
              rect(3) = rect(3) + p
           else
              rect(2) = rect(2) + p
           endif

        enddo
     enddo
  enddo

  rect(3)= global_sum(rect(3))
  rect(2)= global_sum(rect(2))
  rect(1)= rect(2) + rect(3)

  s_rect = (12.0_8 * volume) - rect(1) / THREE

  rect(1) = rect(1) / dble(36*volume)
  rect(2) = rect(2) / dble(18*volume)
  rect(3) = rect(3) / dble(18*volume)

  deallocate(w1, STAT = ierr)
  if (ierr /= 0) then
     call stderr2_int("deallocation failed", 1, ierr)
     call die("s_rect: deallocation failed w1")
  endif
  deallocate(w2, STAT = ierr)
  if (ierr /= 0) then
     call stderr2_int("deallocation failed", 1, ierr)
     call die("s_rect: deallocation failed w2")
  endif

  DEBUG2S("End: s_rect")
  TIMING_STOP(timing_bin_rect)

end

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