!===============================================================================
!
! staple_imp.F90 - calculates sum of staples for one link
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2006-2009 Yoshifumi Nakamura 
!               1998-2013 Hinnerk Stueben
!
! 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_staple
  interface
     subroutine staple_p(uuu, u, i, e, mu)
     SU3 :: uuu
     P_GAUGE_FIELD :: u
     integer :: i, e, mu
     end subroutine staple_p
  end interface
end

!-------------------------------------------------------------------------------
subroutine staple(uuu, u, i, e, mu)

!! was written by Hinnerk Stueben
!! modified by Y.N. (2008)

  use module_nn
  use module_vol
  implicit none
  SU3, intent(out) :: uuu
  GAUGE_FIELD, intent(in) :: u
  integer, intent(in) :: i, e, mu
  integer :: o, nu, j1, j2, j3, j4

  o = EVEN + ODD - e
  uuu = 0

  do nu = 1, DIM
     if (nu /= mu) then

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


        j1 = nn(i, e, mu, FWD)
        j2 = nn(i, e, nu, FWD)
        j3 = nn(i, e, nu, BWD)
        j4 = nn(j3,o, mu, FWD)

        if (j4 /= nn(j1, o, nu, BWD)) call die('staple(): j4 inconsistent')
        if (nn(j1, o, nu, FWD) /= nn(j2, o, mu, FWD)) &
           call die('staple(): j12 inconsistent')

        call uddp(uuu, u(1, 1, j1, o, nu), &
!        call uuu_fwd(uuu, u(1, 1, j1, o, nu), &
                       u(1, 1, j2, o, mu), &
                       u(1, 1, i, e, nu))

        call ddup(uuu, u(1, 1, j4, e, nu), &
!        call uuu_bwd(uuu, u(1, 1, j4, e, nu), &
                       u(1, 1, j3, o, mu), &
                       u(1, 1, j3, o, nu))
        
     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine staple_p(uuu, u, i, e, mu)

  use module_nn
  use module_vol
  implicit none
  SU3, intent(out) :: uuu
!!  GAUGE_FIELD, intent(in) :: u
  P_GAUGE_FIELD :: u
  integer, intent(in) :: i, e, mu
  integer :: o, nu, j1, j2, j3, j4

  o = EVEN + ODD - e
  uuu = 0

  do nu = 1, DIM
     if (nu /= mu) then

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


        j1 = nn(i, e, mu, FWD)
        j2 = nn(i, e, nu, FWD)
        j3 = nn(i, e, nu, BWD)
        j4 = nn(j3,o, mu, FWD)

        if (j4 /= nn(j1, o, nu, BWD)) call die('staple(): j4 inconsistent')
        if (nn(j1, o, nu, FWD) /= nn(j2, o, mu, FWD)) &
           call die('staple(): j12 inconsistent')

        call uddp(uuu, u(1, 1, j1, o, nu), &
!        call uuu_fwd(uuu, u(1, 1, j1, o, nu), &
                       u(1, 1, j2, o, mu), &
                       u(1, 1, i, e, nu))

        call ddup(uuu, u(1, 1, j4, e, nu), &
!        call uuu_bwd(uuu, u(1, 1, j4, e, nu), &
                       u(1, 1, j3, o, mu), &
                       u(1, 1, j3, o, nu))
        
     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine staple_r_fat(uuu, u, u_tmp1, i, e, mu)

  use module_nn
  use module_vol
  implicit none

  SU3, intent(out) :: uuu
  GAUGE_FIELD, intent(in) :: u, u_tmp1
  integer, intent(in) :: i, e, mu
  integer :: o, nu, j1, j2, j3, j4
!  SU3 :: tmp

  o = EVEN + ODD - e
  uuu = 0

  do nu = 1, DIM
     if (nu /= mu) then

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

        j1 = nn(i, e, mu, FWD)
        j2 = nn(i, e, nu, FWD)
        j3 = nn(i, e, nu, BWD)
        j4 = nn(j3,o, mu, FWD)

        call uddp(uuu, u_tmp1(1, 1, j1, o, nu), &
!        call uuu_fwd(uuu, u_tmp1(1, 1, j1, o, nu), &
                            u(1, 1, j2, o, mu), &
                            u(1, 1, i , e, nu))


!        call udu(tmp,  u(1, 1, j3, o, mu),  u(1, 1, j3, o, nu))
!        call dup(uuu, u_tmp1(1, 1, j4, e, nu), tmp)
!        call ddup(uuu, u_tmp1(1, 1, j4, e, nu), &
        call uuu_bwd(uuu, u_tmp1(1, 1, j4, e, nu), &
                            u(1, 1, j3, o, mu), &
                            u(1, 1, j3, o, nu))

     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine staple_ud(uuu, u, u_tmp1, u_tmp2, i, e, mu)

  use module_nn
  use module_vol
  implicit none

  SU3, intent(out) :: uuu
  GAUGE_FIELD, intent(in) :: u, u_tmp1, u_tmp2
  integer, intent(in) :: i, e, mu
  integer :: o, nu, j1, j2, j3, j4

  o = EVEN + ODD - e
  uuu = 0

  do nu = 1, DIM
     if (nu /= mu) then
        !  (j2,o) --<--   x        nu
        !    |            |
        !    v            ^         ^
        !    |            |         |
        !  (i,e)  -->-- (j1,o)      x-->  mu
        !    |            |
        !    ^            v
        !    |            |
        !  (j3,o) --<-- (j4,e)
        j1 = nn(i, e, mu, FWD)
        j2 = nn(i, e, nu, FWD)
        j3 = nn(i, e, nu, BWD)
        j4 = nn(j3,o, mu, FWD)
        call uddp(uuu,      u(1, 1, j1, o, nu), &
                       u_tmp1(1, 1, j2, o, nu), &
                            u(1, 1, i , e, nu))
        call ddup(uuu,      u(1, 1, j4, e, nu), &
                       u_tmp2(1, 1, j3, o, nu), &
                            u(1, 1, j3, o, nu))
     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine staple_udl(uuu, u, u_tmp1, u_tmp2, u_tmp3, i, e, mu)

  use module_nn
  use module_vol
  implicit none

  SU3, intent(out) :: uuu
  GAUGE_FIELD, intent(in) :: u, u_tmp1, u_tmp2, u_tmp3
  integer, intent(in) :: i, e, mu
  integer :: o, nu, j1, j2, j3, j4

  o = EVEN + ODD - e
  uuu = 0

  do nu = 1, DIM
     if (nu /= mu) then
        !  (j2,o) --<--   x        nu
        !    |            |
        !    v            ^         ^
        !    |            |         |
        !  (i,e)  -->-- (j1,o)      x-->  mu
        !    |            |
        !    ^            v
        !    |            |
        !  (j3,o) --<-- (j4,e)
        j1 = nn(i, e, mu, FWD)
        j2 = nn(i, e, nu, FWD)
        j3 = nn(i, e, nu, BWD)
        j4 = nn(j3,o, mu, FWD)
        call uddp(uuu,      u(1, 1, j1, o, nu), &
                       u_tmp1(1, 1, j2, o, nu), &
                            u(1, 1, i , e, nu))
        call ddup(uuu,      u(1, 1, j4, e, nu), &
                       u_tmp2(1, 1, j3, o, nu), &
                            u(1, 1, j3, o, nu))
        call uddp(uuu,      u(1, 1, j1, o, nu), &
                            u(1, 1, j2, o, mu), &
                       u_tmp3(1, 1, i , e, nu))
        call ddup(uuu,      u(1, 1, j4, e, nu), &
                            u(1, 1, j3, o, mu), &
                       u_tmp3(1, 1, j3, o, nu))
     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine staple_udl2(uuu, u, u_tmp1, u_tmp2, i, e, mu)

  use module_nn
  use module_vol
  implicit none

  SU3, intent(out) :: uuu
  GAUGE_FIELD, intent(in) :: u, u_tmp1, u_tmp2
  integer, intent(in) :: i, e, mu
  integer :: o, nu, j1, j2, j3, j4

  o = EVEN + ODD - e
  uuu = 0

  do nu = 1, DIM
     if (nu /= mu) then
        !  (j2,o) --<--   x        nu
        !    |            |
        !    v            ^         ^
        !    |            |         |
        !  (i,e)  -->-- (j1,o)      x-->  mu
        !    |            |
        !    ^            v
        !    |            |
        !  (j3,o) --<-- (j4,e)
        j1 = nn(i, e, mu, FWD)
        j2 = nn(i, e, nu, FWD)
        j3 = nn(i, e, nu, BWD)
        j4 = nn(j3,o, mu, FWD)
        call uup(uuu,      u(1, 1, j1, o, nu), &
                      u_tmp1(1, 1, j2, o, nu))
        call dup(uuu,      u(1, 1, j4, e, nu), &
                      u_tmp2(1, 1, j3, o, nu))
     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine r_fat(u_out, u, mu, c)

  use module_nn
  use module_vol
  implicit none

  GAUGE_FIELD, intent(out) :: u_out
  GAUGE_FIELD, intent(in) :: u
  integer, intent(in) :: mu
  REAL, intent(in) :: c

  integer :: i, e, o, nu, j1, j2

  do nu = 1, DIM
     if (nu /= mu) then
        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(u_out(1, 1, i , e, nu), &
                             u(1, 1, i , e, mu), &
                             u(1, 1, j1, o, nu), &
                             u(1, 1, j2, o, mu))
              call u_scale(u_out(1, 1, i , e, nu), c)
              call u_add(  u_out(1, 1, i , e, nu), u(1, 1, i, e, nu))
           enddo
        enddo
     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine r_staple(u_out, u, mu)

  use module_nn
  use module_vol
  implicit none

  GAUGE_FIELD, intent(out) :: u_out
  GAUGE_FIELD, intent(in) :: u
  integer, intent(in) :: mu

  integer :: i, e, o, nu, j1, j2

  do nu = 1, DIM
     if (nu /= mu) then
        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(u_out(1, 1, i , e, nu), &
                             u(1, 1, i , e, mu), &
                             u(1, 1, j1, o, nu), &
                             u(1, 1, j2, o, mu))
           enddo
           call xbound_g(u_out, e, nu)
        enddo
     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine u_staple(u_out, u, mu)

  use module_nn
  use module_vol
  implicit none

  GAUGE_FIELD, intent(out) :: u_out
  GAUGE_FIELD, intent(in) :: u
  integer, intent(in) :: mu

  integer :: i, e, o, nu, j1, j2

  do nu = 1, DIM
     if (nu /= mu) then
        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(u_out(1, 1, i , e, nu), &
                             u(1, 1, i , e, nu), &
                             u(1, 1, j2, o, mu), &
                             u(1, 1, j1, o, nu))
           enddo
           call xbound_g(u_out, e, nu)
        enddo
     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine d_staple(u_out, u, mu)

  use module_nn
  use module_vol
  implicit none

  GAUGE_FIELD, intent(out) :: u_out
  GAUGE_FIELD, intent(in) :: u
  integer, intent(in) :: mu

  integer :: i, e, o, nu, j1, j2

  do nu = 1, DIM
     if (nu /= mu) then
        do e = EVEN, ODD
           o = EVEN + ODD - e
           !$omp parallel do private(j1, j2)
           do i = 1, volh
              !  (i,e)  -->--   x
              !    |            |
              !    ^            v
              !    |            |
              !  (j1,o) --<-- (j2,e)
              j1 = nn(i, e, nu, BWD)
              j2 = nn(j1,o, mu, FWD)
              call duu_imp(u_out(1, 1, i , e, nu), &
                               u(1, 1, j1, o, nu), &
                               u(1, 1, j1, o, mu), &
                               u(1, 1, j2, e, nu))
           enddo
           call xbound_g(u_out, e, nu)
        enddo
     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine l_staple(u_out, u, mu)

  use module_nn
  use module_vol
  implicit none

  GAUGE_FIELD, intent(out) :: u_out
  GAUGE_FIELD, intent(in) :: u
  integer, intent(in) :: mu

  integer :: i, e, o, nu, j1, j2

  do nu = 1, DIM
     if (nu /= mu) then
        do e = EVEN, ODD
           o = EVEN + ODD - e
           !$omp parallel do private(j1, j2)
           do i = 1, volh
              !  (j2,e) -->--   x
              !    |            |
              !    ^            v
              !    |            |
              !  (j1,o) --<-- (i,e)
              j1 = nn(i, e, mu, BWD)
              j2 = nn(j1,o, nu, FWD)
              call duu_imp(u_out(1, 1, i , e, nu), &
                               u(1, 1, j1, o, mu), &
                               u(1, 1, j1, o, nu), &
                               u(1, 1, j2, e, mu))
           enddo
           call xbound_g(u_out, e, nu)
        enddo
     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine ul_staple(u_out, u, mu)

  use module_nn
  use module_vol
  implicit none

  GAUGE_FIELD, intent(out) :: u_out
  GAUGE_FIELD, intent(in) :: u
  integer, intent(in) :: mu

  integer :: i, e, o, nu, j1, j2, j3, j4, j5
  SU3 :: u_tmp1, u_tmp2

  do nu = 1, DIM
     if (nu /= mu) then
        do e = EVEN, ODD
           o = EVEN + ODD - e
           !$omp parallel do private(j1, j2, j3, j4, j5,u_tmp1,u_tmp2)
           do i = 1, volh
              !               (j2,o) -<---   x
              !                 |            |
              !                 v            ^
              !                 |            |
              !  (j3,o) --<-- (i,e) --<-- (j1,o)
              !    |            |
              !    v            v
              !    |            |
              !  (j5,e) -->-- (j4,o)
              j1 = nn(i, e, mu, FWD)
              j2 = nn(i, e, nu, FWD)
              j3 = nn(i, e, mu, BWD)
              j4 = nn(i, e, nu, BWD)
              j5 = nn(j3,o, nu, BWD)
              call udd_imp(u_tmp1, &
                               u(1, 1, j1, o, nu), &
                               u(1, 1, j2, o, mu), &
                               u(1, 1, i , e, nu))
              call uuu_imp(u_tmp2, &
                               u(1, 1, j5, e, nu), &
                               u(1, 1, j3, o, mu), &
                               u(1, 1, i , e, mu))
              call uud(u_out(1, 1, i , e, nu), u_tmp1, u(1, 1, j4, o, nu))
              call dup(u_out(1, 1, i , e, nu), u_tmp2, u(1, 1, j5, e, mu))
           enddo
#ifdef D500
           call xbound_g(u_out, e, nu)
#else
           call xbound_g_rect_ind(u_out, e, nu, nu, FWD)
#endif
        enddo
     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine dl_staple(u_out, u, mu)

  use module_nn
  use module_vol
  implicit none

  GAUGE_FIELD, intent(out) :: u_out
  GAUGE_FIELD, intent(in) :: u
  integer, intent(in) :: mu

  integer :: i, e, o, nu, j1, j2, j3, j4, j5
  SU3 :: u_tmp1, u_tmp2

  do nu = 1, DIM
     if (nu /= mu) then
        do e = EVEN, ODD
           o = EVEN + ODD - e
           !$omp parallel do private(j1, j2, j3, j4, j5,u_tmp1,u_tmp2)
           do i = 1, volh

              !  (j5,e) -->-- (j1,o)
              !    |            |
              !    ^            ^
              !    |            |
              !  (j3,o) --<-- (i,e) --<--    x
              !                 |            |
              !                 ^            v
              !                 |            |
              !               (j2,o) -<--- (j4,e)
              j1 = nn(i, e, nu, FWD)
              j2 = nn(i, e, nu, BWD)
              j3 = nn(i, e, mu, BWD)
              j4 = nn(j2,o, mu, FWD)
              j5 = nn(j3,o, nu, FWD)
              call ddu_imp(u_tmp1, &
                               u(1, 1, j4, e, nu), &
                               u(1, 1, j2, o, mu), &
                               u(1, 1, j2, o, nu))
              call ddu_imp(u_tmp2, &
                               u(1, 1, i , e, mu), &
                               u(1, 1, j3, o, mu), &
                               u(1, 1, j3, o, nu))
              call  uu(u_out(1, 1, i , e, nu), u_tmp1, u(1, 1, i , e, nu))
              call uup(u_out(1, 1, i , e, nu), u_tmp2, u(1, 1, j5, e, mu))
           enddo
#ifdef D500
           call xbound_g(u_out, e, nu)
#else
           call xbound_g_rect_ind(u_out, e, nu, nu, BWD)
#endif

        enddo
     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine staple_qed(aaa, a, i, e, mu)

  use module_nn
  use module_vol
  use module_switches
  implicit none
  REAL, intent(out) :: aaa
  U1_GENERATOR_FIELD, intent(in) :: a
  integer, intent(in) :: i, e, mu
  integer :: o, nu, j1, j2, j3, j4

  o = EVEN + ODD - e
  aaa = 0

  do nu = 1, DIM
     if (nu /= mu) then

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


        j1 = nn(i, e, mu, FWD)
        j2 = nn(i, e, nu, FWD)
        j3 = nn(i, e, nu, BWD)
        j4 = nn(j3,o, mu, FWD)


        aaa = aaa + a(j1, o, nu) - a(j2, o, mu) - a(i, e, nu) 
        aaa = aaa - a(j4, e, nu) - a(j3, o, mu) + a(j3, o, nu)
     endif
  enddo

end

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