!===============================================================================
!
! schr_boundary.F90  ---  a boundary condition for Schroedinger function
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2007 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"

#ifdef QPACE
# undef PI
# define PI    STRCAT(3.1415926535897932384626_, RKIND)
#endif

!-------------------------------------------------------------------------------
subroutine schr_boundary_gauge(u)

  use module_schr_bc
  use module_lattice
  use module_vol
  use module_nn
  use module_function_decl
  implicit none

  GAUGE_FIELD, intent(inout) :: u
  integer :: mu, nu, count, i, eo, c1, c2, mu1
  REAL :: phi0(3), phi1(3), dl(3)
  COMPLEX :: bound, bd1(3,3), bd2(3,3)

  phi0(1)=-PI/SIX
  phi0(2)= ZERO
  phi0(3)=-(phi0(1)+phi0(2))
  phi1(1)=-5.0_8*PI/SIX
  phi1(2)= 2.0_8*PI/SIX
  phi1(3)=-(phi1(1)+phi1(2))

  dl(1)=dble(lx)
  dl(2)=dble(ly)
  dl(3)=dble(lz)
  do c1 =1, 3
  do mu =1, 3
     bd1(c1,mu) = cmplx(dcos(phi0(c1)/dl(mu)), dsin(phi0(c1)/dl(mu)),kind=RKIND)
     bd2(c1,mu) = cmplx(dcos(phi1(c1)/dl(mu)), dsin(phi1(c1)/dl(mu)),kind=RKIND)
  enddo
  enddo

  do eo = EVEN,ODD
     !
     ! put 0 for links at t = -1
     !
     do mu = 1, 4
        do count = 1, bc_len_bb(eo)
           i = bc_list_bb(count, eo)
           u(:, :, i, eo, mu) = ZERO
        enddo
     enddo
     !
     ! put Schr bound for (1,2,3)-dir links at t = 0
     !
     do mu = 1, 3
        do count = 1, bc_len_b_all(eo)
           i = bc_list_b_all(count, eo)
           u(:, :, i, eo, mu) = ZERO
           do c1 = 1, NCOL
              u(c1, c1, i, eo, mu) = bd1(c1,mu)
           enddo
        enddo
     enddo
     !
     ! put Schr bound for (1,2,3)-dir links at t = T+1
     !
     do mu = 1, 3
        do count = 1, bc_len_tp(eo)
           i = bc_list_tp(count, eo)
           u(:, :, i, eo, mu) = ZERO
           do c1 = 1, NCOL
              u(c1, c1, i, eo, mu) = bd2(c1,mu)
           enddo
        enddo
     enddo
     !
     ! put 0 for 4-dir links at t = T+1
     !
     do count = 1, bc_len_tp(eo)
        i = bc_list_tp(count, eo)
        u(:, :, i, eo, 4) = ZERO
     enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine schr_boundary_zero3(u) ! put 0 out of boundary
  use module_schr_bc
  use module_vol
  implicit none
  GAUGE_FIELD, intent(inout) :: u
  integer :: mu, count, i, eo

  do eo = EVEN,ODD
     !
     ! put 0 for spacial links at t = 0
     !
     do count = 1, bc_len_b_all(eo)
        i = bc_list_b_all(count, eo)
        u(:, :, i, eo, 1:3) = ZERO
     enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine schr_boundary_zero4(u) ! put 0 out of boundary
  use module_schr_bc
  use module_vol
  implicit none
  GAUGE_FIELD, intent(inout) :: u
  integer :: mu, count, i, eo

  do eo = EVEN,ODD
     !
     ! put 0 for links at t = -1
     !
     do count = 1, bc_len_bb(eo)
        i = bc_list_bb(count, eo)
        u(:, :, i, eo, 1:4) = ZERO
     enddo
     !
     ! put 0 for links at t = T+1
     !
     do count = 1, bc_len_tp(eo)
        i = bc_list_tp(count, eo)
        u(:, :, i, eo, 1:4) = ZERO
     enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine schr_boundary_p(p)
  use module_schr_bc
  use module_vol
  implicit none
  GENERATOR_FIELD, intent(inout) :: p
  integer :: eo, i, count

  !
  ! put 0 for (1,2,3)-dir links at t = 0
  !
  do eo = EVEN,ODD
     do count = 1, bc_len_b(eo)
        i = bc_list_b(count, eo)
        p(:, i, eo, 1:3) = ZERO
     enddo
  enddo

end

!-------------------------------------------------------------------------------
REAL function s_plaq_sfdiff(u)  ! returns S_g only diff by SF
  use module_schr_weight
  use module_schr_bc
  use module_lattice
  use module_nn
  use module_vol
  implicit none

  GAUGE_FIELD :: u
  REAL :: p
  SU3 :: uuu
  integer :: i, e, o, mu, nu, j1, j2, count
  REAL, external :: Re_Tr_uu, global_sum

  DEBUG2S("Start: s_plaq_sfdiff")

  p = ZERO
  do mu = 1, DIM
     do nu = mu + 1, DIM
        if (mu /= 4 .and. nu /= 4) cycle
        do e = EVEN, ODD
           o = EVEN + ODD - e
           !$omp parallel do reduction(+: p) private(i, j1, j2, uuu)
           do count = 1, bc_len_b(e)
              i = bc_list_b(count, e)
              j1 = nn(i, e, mu, FWD)
              j2 = nn(i, e, nu, FWD)
              call udd_imp(uuu, u(1, 1, j1, o, nu), &
                             u(1, 1, j2, o, mu), &
                             u(1, 1, i, e, nu))
              p = p + (ONE - Re_Tr_uu(uuu, u(1, 1, i, e, mu))/THREE ) * ( cpt -ONE )
           enddo

           !$omp parallel do reduction(+: p) private(i, j1, j2, uuu)
           do count = 1, bc_len_t(e)
              i = bc_list_t(count, e)
              j1 = nn(i, e, mu, FWD)
              j2 = nn(i, e, nu, FWD)
              call udd_imp(uuu, u(1, 1, j1, o, nu), &
                             u(1, 1, j2, o, mu), &
                             u(1, 1, i, e, nu))
              p = p + (ONE - Re_Tr_uu(uuu, u(1, 1, i, e, mu))/THREE ) * ( cpt -ONE )
           enddo
        enddo
     enddo
  enddo

  s_plaq_sfdiff = global_sum(p)
!!  call sf_classical_action()
  DEBUG2S("End: s_plaq_sfdiff")

end

!-------------------------------------------------------------------------------
subroutine dsg_sfdiff(p, u, plaq, step)
  use module_schr_weight
  use module_schr_bc
  use module_field
  use module_action_type
  use module_vol
  use module_nn
  implicit none

  GENERATOR_FIELD, intent(inout) :: p
  GAUGE_FIELD, intent(in)        :: u
  type(type_plaq), intent(in)    :: plaq
  REAL,            intent(in)    :: step
  REAL                           :: s
  SU3                            :: uuu, w
  integer                        :: mu, nu, e, o, i, j1, j2, count

  s = - step * plaq%beta / THREE * ( cpt - ONE )

  if (s == ZERO) return

  DEBUG2S("Start: dsg_sfdiff")

  do mu = 1, 3
     do e = EVEN, ODD
        o = EVEN + ODD - e

        !$omp parallel do private(i, j1, j2, uuu, w)
        do count = 1, bc_len_1(e)
           i = bc_list_1(count, e)
           j1 = nn(i,  e, 4,  BWD)
           j2 = nn(j1, o, mu, FWD)
           call ddu_imp(uuu, u(1, 1,j2, e, 4), &
                             u(1, 1,j1, o, mu), &
                             u(1, 1,j1, o, 4))
           call uu(w, u(1, 1, i, e, mu), uuu)
           call im_tr_j(p(1, i, e, mu), w, s)
        enddo

        !$omp parallel do private(i, j1, j2, uuu, w)
        do count = 1, bc_len_t(e)
           i = bc_list_t(count, e)
           j1 = nn(i, e, mu, FWD)
           j2 = nn(i, e, 4,  FWD)
           call udd_imp(uuu, u(1, 1, j1, o, 4), &
                             u(1, 1, j2, o, mu), &
                             u(1, 1, i,  e, 4))
           call uu(w, u(1, 1, i, e, mu), uuu)
           call im_tr_j(p(1, i, e, mu), w, s)
        enddo
     enddo
  enddo

  do e = EVEN, ODD
     !$omp parallel do private(i, j1, j2, uuu, w)
     do count = 1, bc_len_b(e)
        i = bc_list_b(count, e)
        call staple(uuu, u, i, e, 4)
        call uu(w, u(1, 1, i, e, 4), uuu)
        call im_tr_j(p(1, i, e, 4), w, s)
     enddo

     !$omp parallel do private(i, j1, j2, uuu, w)
     do count = 1, bc_len_t(e)
        i = bc_list_t(count, e)
        call staple(uuu, u, i, e, 4)
        call uu(w, u(1, 1, i, e, 4), uuu)
        call im_tr_j(p(1, i, e, 4), w, s)
     enddo
  enddo

  DEBUG2S("End: dsg_sfdiff")
end

!-------------------------------------------------------------------------------
REAL function s_rect_sfdiff(u)  ! returns S_g only diff by SF
  use module_schr_weight
  use module_schr_bc
  use module_lattice
  use module_nn
  use module_vol
  use module_switches
  implicit none

  GAUGE_FIELD :: u, w1, w2
  REAL :: p
  SU3 :: uuu
  integer :: i, e, o, mu, nu, j1, j2, count
  REAL, external :: Re_Tr_uu, global_sum

  DEBUG2S("Start: s_rect_sfdiff")

  p = ZERO
  do mu = 1, 3
     call r_staple(w1, u(1,1,1,0,1), mu)
     if (switches%boundary_sf) call schr_boundary_zero4(w1)

     do e = EVEN, ODD
        o = EVEN + ODD - e

        !$omp parallel do reduction(+: p) private(i, j1, j2, uuu)
        do count = 1, bc_len_b(e)
           i = bc_list_b(count, e)
           j1 = nn(i , e, mu, FWD)
           j2 = nn(i , e, 4,  FWD)
           uuu = ZERO
           call uddp(uuu, w1(1, 1, j1, o, 4), &
                           u(1, 1, j2, o, mu), &
                           u(1, 1, i , e, 4))
           p = p + (ONE - Re_Tr_uu(uuu, u(1, 1, i, e, mu))/THREE ) * ( crt - ONE )
        enddo

        !$omp parallel do reduction(+: p) private(i, j1, j2, uuu)
        do count = 1, bc_len_t(e)
           i = bc_list_t(count, e)
           j1 = nn(i , e, mu, FWD)
           j2 = nn(i , e, 4,  FWD)
           uuu = ZERO
           call uddp(uuu, w1(1, 1, j1, o, 4), &
                           u(1, 1, j2, o, mu), &
                           u(1, 1, i , e, 4))
           p = p + (ONE - Re_Tr_uu(uuu, u(1, 1, i, e, mu))/THREE ) * ( crt - ONE )
        enddo

     enddo
  enddo

  !! 3*lx*ly*lz subtruction for rectangle sticking out of t=T
  s_rect_sfdiff = global_sum(p) - dble(3*lx*ly*lz)

  DEBUG2S("End: s_rect_sfdiff")
end

!-------------------------------------------------------------------------------
subroutine dsig_sfdiff(p, u, impg, step)
  use module_schr_weight
  use module_schr_bc
  use module_field
  use module_action_type
  use module_vol
  use module_nn
  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                           :: s
  SU3                            :: uuu, w
  integer                        :: mu, nu, e, o, i, j1, j2, count
  COMPLEX, allocatable :: w1(:, :, :, :, :)
  COMPLEX, allocatable :: w2(:, :, :, :, :)

  s = -step * impg%beta1 / THREE * ( crt - ONE )

  if (s == ZERO) return

  DEBUG2S("Start: dsig_sfdiff")
  allocate(w1(NCOL, NCOL, volh_tot, EVEN:ODD, DIM))
  allocate(w2(NCOL, NCOL, volh_tot, EVEN:ODD, DIM))

  !
  ! right staple
  !


  do mu = 1, 3
  call r_staple(w1, u(1,1,1,0,1), mu)
  if (switches%boundary_sf) call schr_boundary_zero4(w1)
     do e = EVEN, ODD
        o = EVEN + ODD - e

        !  4==>---x      t=1
        !  |      |
        !  x------mu     t=0

        !$omp parallel do private(i, j1, j2, uuu, w)
        do count = 1, bc_len_1(e)
           i = bc_list_1(count, e)
           j1 = nn(i,  e, 4,  BWD)
           j2 = nn(j1, o, mu, FWD)
           call ddu_imp(uuu,         w1(1, 1,j2, e, 4), &
                             u(1, 1,j1, o, mu), &
                             u(1, 1,j1, o, 4))
           call uu(w, u(1, 1, i, e, mu), uuu)
           call im_tr_j(p(1, i, e, mu), w, s)
        enddo

        !  4------x     t=T
        !  |      |
        !  x==>---mu    t=T-1

        !$omp parallel do private(i, j1, j2, uuu, w)
        do count = 1, bc_len_t(e)
           i = bc_list_t(count, e)
           j1 = nn(i, e, mu, FWD)
           j2 = nn(i, e, 4,  FWD)
           call udd_imp(uuu,         w1(1, 1, j1, o, 4), &
                             u(1, 1, j2, o, mu), &
                             u(1, 1, i,  e, 4))
           call uu(w, u(1, 1, i, e, mu), uuu)
           call im_tr_j(p(1, i, e, mu), w, s)
        enddo
     enddo
  enddo

  !
  ! left stable
  !


  do mu = 1, 3
  call l_staple(w1, u(1,1,1,0,1), mu)
  if (switches%boundary_sf) call schr_boundary_zero4(w1)
     do e = EVEN, ODD
        o = EVEN + ODD - e

        !  4---==>x      t=1
        !  |      |
        !  x------mu     t=0

        !$omp parallel do private(i, j1, j2, uuu, w)
        do count = 1, bc_len_1(e)
           i = bc_list_1(count, e)
           j1 = nn(i,  e, 4,  BWD)
           j2 = nn(j1, o, mu, FWD)
           call ddu_imp(uuu, u(1, 1,j2, e, 4), &
                             u(1, 1,j1, o, mu), &
                                     w1(1, 1,j1, o, 4))
           call uu(w, u(1, 1, i, e, mu), uuu)
           call im_tr_j(p(1, i, e, mu), w, s)
        enddo

        !  4------x      t=T
        !  |      |
        !  x---==>mu     t=T-1

        !$omp parallel do private(i, j1, j2, uuu, w)
        do count = 1, bc_len_t(e)
           i = bc_list_t(count, e)
           j1 = nn(i, e, mu, FWD)
           j2 = nn(i, e, 4,  FWD)
           call udd_imp(uuu, u(1, 1, j1, o, 4), &
                             u(1, 1, j2, o, mu), &
                                     w1(1, 1, i,  e, 4))
           call uu(w, u(1, 1, i, e, mu), uuu)
           call im_tr_j(p(1, i, e, mu), w, s)
        enddo
     enddo

  enddo

  call u_staple(w1, u(1,1,1,0,1), 4)
  call d_staple(w2, u(1,1,1,0,1), 4)
  if (switches%boundary_sf) call schr_boundary_zero4(w1)
  if (switches%boundary_sf) call schr_boundary_zero4(w2)

  do e = EVEN, ODD
     !$omp parallel do private(i, uuu, w)
     do count = 1, bc_len_b(e)
        i = bc_list_b(count, e)
        call staple_ud(uuu, u, w1, w2, i, e, 4)
        call uu(w, u(1, 1, i, e, 4), uuu)
        call im_tr_j(p(1, i, e, 4), w, s)
     enddo

     !$omp parallel do private(i, uuu, w)
     do count = 1, bc_len_t(e)
        i = bc_list_t(count, e)
        call staple_ud(uuu, u, w1, w2, i, e, 4)
        call uu(w, u(1, 1, i, e, 4), uuu)
        call im_tr_j(p(1, i, e, 4), w, s)
     enddo
  enddo

  deallocate(w1,w2)
  DEBUG2S("End: dsig_sfdiff")
end

!-------------------------------------------------------------------------------
subroutine schrfunc_cswkappa(fac)
  use module_schr_bc
  use module_vol
  REAL, intent(inout) :: fac(EVEN:ODD, volh)
  integer :: eo, i, count

  do eo = EVEN,ODD
     do count = 1, bc_len_b(eo)
        i = bc_list_b(count, eo)
        fac(eo, i) = ZERO
     enddo
  enddo

end

!-------------------------------------------------------------------------------

!!
!! below must be correct
!!
!!!-------------------------------------------------------------------------------
!!subroutine sf_classical_action()
!!  use module_action
!!  use module_lattice
!!  REAL :: lt3, lt6, sin1, sin2, w, lll, ca
!!
!!  w = 1.5_8
!!  lll=lx*ly*lz
!!  lt3=PI/dble(3*lt*lx)
!!  lt6=PI/dble(6*lt*lx)
!!
!!  sin0=sin(    lt3)**2 + TWO * sin(lt6)**2
!!  sin1=sin(TWO*lt3)**2 + TWO * sin(lt3)**2
!!
!!  ca = c0*sin0*lt + c1*sin1*(2*lt -3 + 2*w)
!!
!!write(0,*)"sf_classical_action",ca * lll * 12 / g2
!!call flush(0)
!!
!!end
!!
!===============================================================================
