!===============================================================================
!
! schr_pcac.F90 - pcac for SF
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2011 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 schr_pcac(job,traj)
  use module_action
  use module_input
  use module_hadspec
  use module_vol
  use module_switches
  use module_lattice
  use module_function_decl
  implicit none
  integer, intent(in)  :: job, traj
  integer :: mid, it
  REAL, dimension(lt) :: fa0, fp0, fa1, fp1
  logical, save :: fileopen = .false.
  character(len = 15) :: filename

  if (.not. switches%boundary_sf) return
  DEBUG2S("Start: schr_pcac")

  call gamma_init()

  call save_mtil_clov()
  call set_vq_mtil_clov(input%measure_schrpcac_kappa, input%measure_schrpcac_csw, &
                        input%measure_schrpcac_lambda, input%measure_schrpcac_em_charge)

  mid=1
  if (my_pe()==0)write(0,102)"schr_pcac%mtilde","ID", "cid", "did", "kappa", "cswk","rho","h","lambda","b", "em_charge"
  if (my_pe()==0)write(0,103)"schr_pcac%mtilde", 1, action%mtilde(1)%cid, action%mtilde(1)%did, &
  action%mtilde(1)%kappa, action%mtilde(1)%cswkappa, action%mtilde(1)%rho, action%mtilde(1)%h, &
  action%mtilde(1)%lambda, action%mtilde(1)%b, action%mtilde(1)%em_charge
  102 format (1x,a16,3a4,a9  ,a18   ,a9  ,a9  ,a9  ,a20   ,a10  )
  103 format (1x,a16,3i4,f9.6,f18.10,f9.6,f9.6,f9.6,f20.15,f10.4)



  allocate(qprop(1))
  allocate(qprop(1)%g(4,4,3,3,volh, EVEN:ODD))
  call get_qprop_schrpcac(qprop(1), mid, 0) ; call fafp(qprop(1), fa0, fp0)
  call get_qprop_schrpcac(qprop(1), mid, 1) ; call fafp(qprop(1), fa1, fp1)
  if (.not. fileopen) then
     if (len(trim(input%measure_schrpcac_file)) > 0) then
        if (my_pe()==0) open(60, file = trim(input%measure_schrpcac_file), action = "write")
     else
        write(filename, "(a, i6.6)" ) "fAfPhist.", job
        if (my_pe()==0) open(60, file = trim(filename), action = "write")
     endif
     fileopen = .true.
  endif

  if (my_pe()==0) then
  do it = 1, lt-1
     write(60,'(I6,I3,4E24.16)')traj, it+1,-fa0(   it+1), fp0(   it+1), fa1(lt-it+1), fp1(lt-it+1)
  enddo
  endif
  deallocate(qprop)

  call set_back_mtil_clov()

  DEBUG2S("End: schr_pcac")
end

!-------------------------------------------------------------------------------
subroutine fafp(qprop0, fa, fp)
  use gamma
  use module_hadspec
  use module_lattice
  use module_function_decl
  implicit none
  type(type_qprop), intent(in) :: qprop0
  REAL, intent(out) :: fa(0:lt-1), fp(0:lt-1)
  integer :: is0, is1, is2, ic1, ic2, ix,iy,iz,it, j(4), coord(4), ii, eo
  COMPLEX :: ctmpa, ctmpp, zgm
  integer, external :: e_o, std_xyzt2i

  call pe2coord(my_pe(), coord)
  fa = ZERO
  fp = ZERO

  do it = 0, nt-1
     ctmpa = ZERO
     ctmpp = ZERO
     do is1 = 1, 4
        is0 =igamma(is1,4)
        zgm =zgamma(is1,4)
     do is2 = 1, 4
        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)
           do ic1 = 1, 3
           do ic2 = 1, 3
              ctmpa = ctmpa + zgm * qprop0%g(is0,is2,ic1,ic2,ii,eo) &
                    *         conjg(qprop0%g(is1,is2,ic1,ic2,ii,eo))
              ctmpp = ctmpp +       qprop0%g(is1,is2,ic1,ic2,ii,eo) &
                    *         conjg(qprop0%g(is1,is2,ic1,ic2,ii,eo))
           enddo
           enddo
        enddo
        enddo
        enddo
     enddo ! is2
     enddo ! is1
     fa( it + nt*coord(4) ) = ctmpa
     fp( it + nt*coord(4) ) = ctmpp
  enddo

  call global_sum_vec(lt, fa)
  call global_sum_vec(lt, fp)
  fa=fa/dble(2*lx*ly*lz)
  fp=fp/dble(2*lx*ly*lz)

end

!-------------------------------------------------------------------------------
subroutine get_qprop_schrpcac(qprop0, mid, prime)
  use module_hadspec
  use module_vol
  implicit none
  type(type_qprop), intent(out) :: qprop0
  integer, intent(in)  :: mid, prime
  SPINCOL_FIELD :: inp_e, inp_o, out_e, out_o
  integer :: is, ic

  DEBUG2S("Start: get_qprop_schrpcac")
  call init_quark(mid)
  do ic = 1, 3
  do is = 1, 4
     call make_source_schrpcac(inp_e, inp_o, is, ic, prime)
     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
  DEBUG2S("End: get_qprop_schrpcac")
end

!-------------------------------------------------------------------------------
subroutine make_source_schrpcac(even, odd, is, ic, prime)
  use module_vol
  use module_field
  use module_stout_field
  implicit none
  integer, intent(in) :: is,ic,prime
  SPINCOL_FIELD, intent(out) :: even, odd

  if (gauge(2)%sid == 0) then
     call make_source_schrpcac_u(even, odd, is, ic, prime, gauge(1)%u)
  else
     call make_source_schrpcac_u(even, odd, is, ic, prime, stout(1)%iter(stout(1)%n)%u)
  endif

end

!-------------------------------------------------------------------------------
subroutine make_source_schrpcac_u(even, odd, is, ic, prime, u)
  use module_lattice
  use module_vol
  use module_function_decl
  use module_nn
  implicit none
  integer :: coord(4), j(4)
  integer :: it,iz,iy,ix,ii,jj,eo,src_t
  integer, intent(in) :: is,ic,prime
  SPINCOL_FIELD, intent(out) :: even, odd
  GAUGE_FIELD, intent(in) :: u
  integer, external :: std_xyzt2i, e_o

  DEBUG2S("Start: make_source_schrpcac_u")

  call pe2coord(my_pe(), coord)
  even = ZERO
  odd  = ZERO
  select case (prime)
     case (0) ! for [\psi(x)\zeta(y)]
        if (is == 3 .or. is == 4) return
        src_t = 1
        it = src_t - nt*coord(4)
        if ( 0<=it .and. it < nt) then
           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)
              jj = nn(ii, eo, 4, BWD)
              if (eo == EVEN) then
                 even(is,:,ii) = dconjg(u(ic, :, jj, 1-eo, 4))
              else
                  odd(is,:,ii) = dconjg(u(ic, :, jj, 1-eo, 4))
              endif
           enddo
           enddo
           enddo
        endif
     case (1) ! for [\psi(x)\zeta'(y)]  !!!'
        if (is == 1 .or. is == 2) return
        src_t = lt - 1
        it = src_t - nt*coord(4)
        if ( 0<=it .and. it < nt) then
           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)
              if (eo == EVEN) then
                 even(is,:,ii) = u(:, ic, ii, eo, 4)
              else
                  odd(is,:,ii) = u(:, ic, ii, eo, 4)
              endif
           enddo
           enddo
           enddo
        endif
     case default
        call die("make_source_schrpcac_u: Invalid prime")
  end select

  DEBUG2S("End: make_source_schrpcac_u")
end

!===============================================================================
! for checking
!-------------------------------------------------------------------------------
subroutine read_phmc_sf_config()
  use module_vol
  use module_field
  implicit none
  integer :: ix, iy, iz, it, ieo, imu, j(4), itb, jmu(4) , ee, jj, ic,jc
  integer :: ntx, nty, ntz, ntt
  integer :: ndx, ndy, ndz, ndt
  COMPLEX, dimension(3,3,0:4,4,4,4,4) :: ue, uo
  REAL :: plq, tmp
  GAUGE_FIELD ::u
  REAL, external :: sg
  integer, external :: std_xyzt2i, e_o

  write(*,*)"read_phmc_sf_config: start"

  open(40,file="config.x0y0z0",status='unknown',form='unformatted')
  write(*,*)"read_phmc_config: open config.x0y0z0"

  read(40)ue, uo
  write(*,*)"read_phmc_config: have read config.x0y0z0"

  jmu(1)=4
  jmu(2)=3
  jmu(3)=2
  jmu(4)=1

  do imu = 1,4
  do it=1,8
     itb=it/2
  do iz=1,4
  do iy=1,4
  do ix=1,4
     ieo=mod(ix + iy + iz + it, 2)
     j=(/ ix-1 , iy-1, iz-1, it-1/)
     jj=std_xyzt2i(j)
     ee=e_o(j)
     if (ieo == 0) u(:,:, jj ,ee, imu ) = ue(:,:,itb,iz,iy,ix,imu)
     if (ieo == 1) u(:,:, jj ,ee, imu ) = uo(:,:,itb,iz,iy,ix,imu)
  enddo
  enddo
  enddo
  enddo
  enddo

  gauge(1)%u=u

  call xbound_g_field(gauge(1)%u)
  call d_g_init(gauge(1)%u)
  call conf_check(gauge(1)%u)

  !!call conf_hot(gauge(1)%u)
  tmp=sg(gauge(1)%u)
  write(*,*)"plaq value calculated by bqcd", ONE - tmp / (SIX * volume)
!!  call flush(6)
end

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