!===============================================================================
!
! correlations.F90 - correlation 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"
# include "gamma.h"

!-------------------------------------------------------------------------------
module hadron_corr
  implicit none
  integer, save :: n_mom=1
  type quark_prop
     COMPLEX, dimension(:,:,:,:,:,:), pointer :: g
  end type

  type(quark_prop), dimension(:),pointer,save :: qprop

end

!-------------------------------------------------------------------------------
subroutine correlations(traj)
  use module_field
  use module_action
  use module_input
  use hadron_corr
  use module_vol
  use module_switches
  implicit none
  integer, intent(in)  :: traj
  integer :: fid, mid, src_at(4)

  if (.not. switches%measure_correlations) return
  call gamma_init()
  fid = input%hmc_mpf_mass
  mid = action%fermi(fid)%mid1

  allocate(qprop(1))
  allocate(qprop(1)%g(4,4,3,3,volh, EVEN:ODD))
  qprop(1)%g=ZERO

  src_at = (/1, 1, 1, 1/)
  call get_qprop(qprop(1), mid, LOCAL_SOURCE, src_at)

!! call print_qprop_src(qprop(1), (/1,1,1,1/))
!! call print_qprop_src(qprop(1), (/2,1,1,1/))
!! call print_qprop_src(qprop(1), (/1,2,1,1/))
!! call print_qprop_src(qprop(1), (/1,1,2,1/))
!! call print_qprop_src(qprop(1), (/1,1,1,2/))
!! call print_qprop_src(qprop(1), (/0,1,1,1/))
!! call print_qprop_src(qprop(1), (/1,0,1,1/))
!! call print_qprop_src(qprop(1), (/1,1,0,1/))
!! call print_qprop_src(qprop(1), (/1,1,1,0/))
!!stop

  call meson(qprop(1), qprop(1))
  call baryon(qprop(1),qprop(1),qprop(1))
end

!-------------------------------------------------------------------------------
subroutine meson(qprop0, qprop1)                ! full meason prop
  use gamma
  use hadron_corr
  use module_lattice
  use module_function_decl
  implicit none
  type(quark_prop), intent(in) :: qprop0, qprop1
  COMPLEX, dimension(DIM, DIM, DIM, DIM, n_mom, 0:lt-1) :: meason_corr
  integer :: is1, is2, is3, is4, ic1, ic2, ix,iy,iz,it, j(4), coord(4), ii, eo, imom, igop1, igop2
  COMPLEX :: ctmp, c_local(n_mom), pexp_fac_c, m_corr(0:lt-1,n_mom), g1(4,4), g2(4,4)
  integer, external :: e_o, std_xyzt2i

  pexp_fac_c=ONE
  call pe2coord(my_pe(), coord)

  meason_corr = 0

  do is1 = 1, 4
  do is2 = 1, 4
  do is3 = 1, 4
  do is4 = 1, 4
     do it = 0, nt-1
        c_local(:) = 0
        do iz = 0, nz-1
        do iy = 0, ny-1
        do ix = 0, nx-1
           ctmp = 0
           j  = (/ix, iy, iz, it/)
           ii = std_xyzt2i(j)
           eo = e_o(j)
           do ic1 = 1, 3
           do ic2 = 1, 3
              ctmp = ctmp + qprop0%g(is1,is2,ic1,ic2,ii,eo) &
                    * conjg(qprop1%g(is4,is3,ic1,ic2,ii,eo))
           enddo
           enddo
           do imom = 1, n_mom
!!              c_local(imom) = c_local(imom) + pexp_fac_c(imom,ix,iy,iz) * ctmp
              c_local(imom) = c_local(imom) + pexp_fac_c * ctmp
           enddo
        enddo
        enddo
        enddo
        meason_corr(is1,is2,is3,is4,1:n_mom, it + nt*coord(4) ) = c_local(1:n_mom)
     enddo
  enddo ! is4
  enddo ! is3
  enddo ! is2
  enddo ! is1



  call global_sum_vec(256*n_mom*lt *2, meason_corr)

!!  do igop1 = 1, ngop
!!  do igop2 = 1, ngop
  do igop1 = 5, 5
  do igop2 = 5, 5
     call spin_mul(g1, gamma_op(G5)%c, gamma_op(igop1)%c) ! gop1 = gamma5 * gop1
     call spin_mul(g2, gamma_op(igop2)%c, gamma_op(G5)%c) ! gop2 = gop2 * gamma5
     do imom = 1, n_mom
     do it = 0, lt - 1
        ctmp=0
        do is1 = 1, 4
        do is2 = 1, 4
        do is3 = 1, 4
        do is4 = 1, 4
           if (g1(is4, is1) /= 0 .and. g2(is2, is3) /= 0) then
               ctmp= ctmp + g1(is4, is1) * g2(is2, is3) * meason_corr(is1,is2,is3,is4, imom, it)
           endif
        enddo
        enddo
        enddo
        enddo
        m_corr(it, imom) = ctmp
     enddo
     enddo
     write(*,*)igop1, igop2
     do it = 0, lt-1
        write(*,*)m_corr(it, 1)
     enddo
  enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine baryon(qp1, qp2, qp3)                ! full baryon prop
  use gamma
  use hadron_corr
  use module_lattice
  use module_function_decl
  implicit none
  type(quark_prop), intent(in) :: qp1, qp2, qp3
  COMPLEX, dimension(n_mom, 0:lt-1) :: baryon_corr
  integer :: ix,iy,iz,it, j(4), coord(4), ii, eo, imom, c1, c2
  COMPLEX :: ctmp, s_local(n_mom,0:nt-1), pexp_fac_c, b_corr(0:lt-1,n_mom)
  COMPLEX, dimension(4,4,3,3) :: g_aap, g_bbp, g_ccp, tmp1, tmp2, tmp3
  COMPLEX, dimension(4,4) :: tt0
  integer, external :: e_o, std_xyzt2i
  COMPLEX, external :: tracespin2

  pexp_fac_c=ONE
  call pe2coord(my_pe(), coord)

  baryon_corr = 0

  do it = 0, nt-1
     do iz = 0, nz-1
     do iy = 0, ny-1
     do ix = 0, nx-1

        j  = (/ix, iy, iz, it/)
        ii = std_xyzt2i(j)
        eo = e_o(j)
        g_aap = qp1%g(:,:,:,:,ii,eo)
        g_bbp = qp2%g(:,:,:,:,ii,eo)
        g_ccp = qp3%g(:,:,:,:,ii,eo)

        do c1=1, NCOL
        do c2=1, NCOL
           call spin_mul( tmp1(1,1,c1,c2), g_bbp(1,1,c1,c2), gamma_op(G31)%c)
           call spin_mul( tmp2(1,1,c1,c2), gamma_op(G31)%c, g_bbp(1,1,c1,c2))
        enddo
        enddo
        call contraction13(tmp3, tmp1, tmp2)

        call tracecol1(tt0 , g_aap, tmp3)
        ctmp = tracespin2(gamma_op(POL)%c,tt0)
        call tracecol2(tt0 , g_aap, tmp3)
        ctmp = ctmp + tracespin2(gamma_op(POL)%c,tt0)

        do imom = 1, n_mom
!!!           s_local(imom,it) = s_local(imom,it) + ctmp * epsi_epsip * pexp_fac_c(imom,ix,iy,iz)
           s_local(imom,it) = s_local(imom,it) + ctmp * pexp_fac_c
        enddo
     enddo
     enddo
     enddo
     baryon_corr(:,it+nt*coord(4)) = s_local(:,it) 
  enddo

  call global_sum_vec(n_mom*lt *2, baryon_corr)

  do imom = 1, n_mom
  do it = 0, lt - 1
     b_corr(it, imom) = baryon_corr(imom,it)
  enddo
  enddo

  write(*,*)"Baryon"
  do it = 0, lt-1
     write(*,*)b_corr(it, 1)
  enddo
end

!-------------------------------------------------------------------------------
!!subroutine baryon(qp1, qp2, qp3)                ! full baryon prop
!!  use gamma
!!  use hadron_corr
!!  use module_lattice
!!  use module_function_decl
!!  implicit none
!!  type(quark_prop), intent(in) :: qp1, qp2, qp3
!!  COMPLEX, dimension(DIM, DIM, n_mom, 0:lt-1) :: baryon_corr
!!  integer :: is1, is2, is3, is4, ic1, ic2, ix,iy,iz,it, j(4), coord(4), ii, eo, imom, epsi_l, epsi_lp, a, b,c ,ap,bp,cp,  epsi, epsi_epsip
!!  COMPLEX :: ctmp, s_local(4,4,n_mom,0:nt-1), pexp_fac_c, b_corr(0:lt-1,n_mom)
!!  COMPLEX, dimension(4,4) :: g_aap, g_bbp, g_ccp, g_bbpccp, g_aapbbpccp, tmp
!!  integer, external :: e_o, std_xyzt2i
!!  COMPLEX, external :: spintr
!!  COMPLEX, external :: tracespin2
!!  pexp_fac_c=ONE
!!  call pe2coord(my_pe(), coord)
!!
!!  baryon_corr = 0
!!
!!  do it = 0, nt-1
!!     do epsi_l = 0, 1
!!        do a = 1, NCOL
!!           b    = mod(a+epsi_l  , NCOL) + 1
!!           c    = mod(a-epsi_l+1, NCOL) + 1
!!           epsi = (1-2*epsi_l)
!!           do epsi_lp = 0, 1
!!              do ap = 1, NCOL
!!                 bp         = mod(ap+epsi_lp  , NCOL) + 1
!!                 cp         = mod(ap-epsi_lp+1, NCOL) + 1
!!                 epsi_epsip = epsi*(1-2*epsi_lp)
!!
!!                 do iz = 0, nz-1
!!                 do iy = 0, ny-1
!!                 do ix = 0, nx-1
!!
!!                    j  = (/ix, iy, iz, it/)
!!                    ii = std_xyzt2i(j)
!!                    eo = e_o(j)
!!                    g_aap = qp1%g(:,:,a,ap,ii,eo)
!!                    g_bbp = qp2%g(:,:,b,bp,ii,eo)
!!                    g_ccp = qp3%g(:,:,c,cp,ii,eo)
!!                    call g31xg31t(tmp, g_bbp)
!!                    call spin_mul(g_bbpccp, tmp, g_ccp)
!!                    call spin_mul(g_aapbbpccp, g_aap, g_bbpccp)
!!                    tmp = spintr(g_bbpccp) * g_aap + g_aapbbpccp
!!
!!                    do imom = 1, n_mom
!!!!!                       s_local(:,:,imom,it) = s_local(:,:,imom,it) + tmp * epsi_epsip * pexp_fac_c(imom,ix,iy,iz)
!!                       s_local(:,:,imom,it) = s_local(:,:,imom,it) + tmp * epsi_epsip * pexp_fac_c
!!                    enddo
!!
!!
!!                 enddo
!!                 enddo
!!                 enddo
!!              enddo
!!           enddo
!!        enddo
!!     enddo
!!     baryon_corr(:,:,:,it+nt*coord(4)) = s_local(:,:,:,it) 
!!  enddo
!!
!!  call global_sum_vec(16*n_mom*lt *2, baryon_corr)
!!
!!  do imom = 1, n_mom
!!  do it = 0, lt - 1
!!!!     b_corr(it, imom) = spintr(baryon_corr(1,1,imom,it))
!!     b_corr(it, imom) = tracespin2(gamma_op(UNP)%c, baryon_corr(1,1,imom,it))
!!  enddo
!!  enddo
!!  write(*,*)"Baryon"
!!  do it = 0, lt-1
!!     write(*,*)b_corr(it, 1)
!!  enddo
!!
!!
!!end

!-------------------------------------------------------------------------------
subroutine get_qprop(qprop0, mid, source_type, src_at)
  use hadron_corr
  use module_vol
  implicit none
  type(quark_prop), intent(out) :: qprop0
  integer, intent(in)  :: mid, source_type, src_at(4)
  SPINCOL_FIELD :: inp_e, inp_o, out_e, out_o
  integer :: is, ic

  call init_quark(mid)
  call make_source_local(inp_e, inp_o, src_at)
  call make_quark_source(qprop0%g(1,1,1,1,1,0), qprop0%g(1,1,1,1,1,1), inp_e, inp_o)

  do ic = 1, 3
  do is = 1, 4
     call get_quark_source(inp_e, inp_o, qprop0%g(1,1,1,1,1,0), qprop0%g(1,1,1,1,1,1), is, ic)
     call solve(out_e, out_o, inp_e, inp_o, mid)
     call put_quark_source(qprop0%g(1,1,1,1,1,0), qprop0%g(1,1,1,1,1,1), out_e, out_o, is, ic)
  enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine contraction13(qout, q1, q2)
  implicit none
  COMPLEX, dimension(4,4,3,3) :: qout, q1, q2
  integer :: i, j, k, ip, jp, kp, ieps, jeps, eps1, eps2
  integer :: a, b, c

  qout=ZERO
  do ieps = 0, 1
     do i = 1, NCOL
        j = mod(i + ieps  , NCOL) + 1
        k = mod(i - ieps+1, NCOL) + 1
        eps1 = (1-2*ieps)
        do jeps = 0, 1
           do ip = 1, NCOL
              jp = mod(ip + jeps  , NCOL) + 1
              kp = mod(ip - jeps+1, NCOL) + 1
              eps2 = (1-2*jeps)

              do a =1, DIM
              do b =1, DIM
              do c =1, DIM
                 qout(a,b,kp,k) = qout(a,b,kp,k) &
                         + eps1 * eps2 * q1(c,a,i,ip) * q2(c,b,j,jp)
              enddo
              enddo
              enddo
           enddo
        enddo
     enddo
  enddo
end

!-------------------------------------------------------------------------------
subroutine tracecol1(qout, q1, q2) ! traceColor (q1 * traceSpin(q2))
  implicit none
  COMPLEX, dimension(4,4) :: qout
  COMPLEX, dimension(4,4,3,3) :: q1, q2
  COMPLEX :: tmp
  integer :: i, j

  qout=ZERO
  do i = 1, NCOL
  do j = 1, NCOL
     tmp = q2(1,1,j,i)+q2(2,2,j,i)+q2(3,3,j,i)+q2(4,4,j,i)
     qout(:,:) = qout(:,:) + q1(:,:,i,j) * tmp
  enddo
  enddo
end

!-------------------------------------------------------------------------------
subroutine tracecol2(qout, q1, q2) ! traceColor (q1 * q2)
  implicit none
  COMPLEX, dimension(4,4) :: qout
  COMPLEX, dimension(4,4,3,3) :: q1, q2
  integer :: i, j

  qout=ZERO
  do i = 1, NCOL
  do j = 1, NCOL
     qout(:,:) = qout(:,:) + q1(:,:,i,j) * q2(:,:,j,i)
  enddo
  enddo
end

!-------------------------------------------------------------------------------
COMPLEX function tracespin2(q1, q2) ! traceSpin (q1 * q2)
  implicit none
  COMPLEX, dimension(4,4) :: q1, q2
  COMPLEX :: tmp
  integer :: i, j

  tmp=ZERO
  do i = 1, DIM
  do j = 1, DIM
     tmp = tmp + q1(i,j) * q2(j,i)
  enddo
  enddo
  tracespin2 = tmp
end

!===============================================================================
!===============================================================================
!
! copy form old version vector12.F90
!
!-------------------------------------------------------------------------------
!
! 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"

!-------------------------------------------------------------------------------
subroutine global_sum_vector12(sc,in_e,in_o)

  use module_function_decl
  use module_vol
  implicit none
  COMPLEX, dimension(DIM,NCOL), intent(out) :: sc
  SPINCOL_FIELD, intent(in) :: in_e, in_o
  COMPLEX :: tmp
  REAL :: re, im
  integer :: i, mu, c

  do c = 1, 3
     do mu = 1, 4
        tmp = ZERO
        !$omp parallel do reduction(+: tmp)
        do i = 1, volh
           tmp = tmp + in_e(mu,c,i)
        enddo
        !$omp parallel do reduction(+: tmp)
        do i = 1, volh
           tmp = tmp + in_o(mu,c,i)
        enddo
        re = global_sum(dble(tmp))
        im = global_sum(dimag(tmp))
        sc(mu,c) = cmplx( re, im, kind = RKIND)
     enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine write_vector12_0000_sum(in_e,in_o,name)

  use module_function_decl
  use module_vol
  implicit none
  SPINCOL_FIELD, intent(in) :: in_e, in_o
  character( len = 6), intent(in) :: name

  COMPLEX, dimension(DIM,NCOL) :: sc
  character( len = 10) :: name1, name2

  call global_sum_vector12(sc, in_e, in_o)

  write(name1,10)name,"0000"
  write(name2,10)name,"_sum"

  call write_vector12(0, in_e(1,1,1), name1)
  call write_vector12(0, sc, name2)

10 format (2a)

end

!-------------------------------------------------------------------------------
subroutine write_vector12(pe,sc,name)

  use module_function_decl
  implicit none
  COMPLEX, dimension(DIM,NCOL), intent(in) :: sc
  integer, intent(in) :: pe
  character( len = 10) :: name
  integer :: mu, c


  if (my_pe() == pe) then
     do c = 1, 3
        do mu = 1, 4
           write(*,100)"%%%",name,& 
           my_pe(),mu,c,dble(sc(mu,c)),dimag(sc(mu,c))
        enddo
     enddo
  endif

100 format (1x, 2a, 3i3, 2ES17.7)

end

!-------------------------------------------------------------------------------
!
! program to print quark propagator
!
!-------------------------------------------------------------------------------
subroutine print_qprop_src(qprop0, src_at) !! print qprop at src for color = 1
  use hadron_corr
  use module_lattice
  use module_function_decl
  implicit none
  type(quark_prop), intent(in) :: qprop0
  integer, intent(in)  :: src_at(4)
  integer :: ix, iy, iz, it, coord(4), j(4), i, eo, is, is_column,i8
  REAL :: tmp(8)
  integer, external :: std_xyzt2i, e_o

  write(0,111)"Print qporp at ",src_at

  call pe2coord(my_pe(), coord)
  it = src_at(4) - nt*coord(4)
  iz = src_at(3) - nz*coord(3)
  iy = src_at(2) - ny*coord(2)
  ix = src_at(1) - nx*coord(1)
  if ( 0<=it .and. it < nt .and. &
       0<=iz .and. iz < nz .and. &
       0<=iy .and. iy < ny .and. &
       0<=ix .and. ix < nx) then
     j = (/ix, iy, iz, it/)
     i = std_xyzt2i(j)
     eo= e_o(j)
     do is=1,4
     do is_column=1,4
        tmp(1 + 2*(is_column-1) ) = Re(qprop0%g(is,is_column,1,1,  i, eo))
        tmp(2 + 2*(is_column-1) ) = Im(qprop0%g(is,is_column,1,1,  i, eo))
     enddo
     write(0,123) ( tmp(i8), i8=1,8 )
     enddo
  endif
  111 format (a, "(", 3(i2,","),i2,")"  )
  123 format ( 4(2x,'(',e11.3,',',e11.3,')'   ) )
end

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