!===============================================================================
!
! dirac_matrix.F90
!
! make Dirac operator as matrix form,
! matrix shape for parallel computing is (12, volume/NPE, 12, volume)
!
!-------------------------------------------------------------------------------
!
! 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"

!-------------------------------------------------------------------------------
module module_dirac_matrix
  implicit none
  COMPLEX,dimension(4,4),save :: proj_1_p_gamma1, proj_1_m_gamma1
  COMPLEX,dimension(4,4),save :: proj_1_p_gamma2, proj_1_m_gamma2
  COMPLEX,dimension(4,4),save :: proj_1_p_gamma3, proj_1_m_gamma3
  COMPLEX,dimension(4,4),save :: proj_1_p_gammac, proj_1_m_gammac
  COMPLEX,dimension(4,4),save :: proj_1_p_gamman, proj_1_m_gamman

  integer, pointer, save :: ieo2_around_i(:,:,:)
  integer, pointer, save :: ieo2_around_is(:,:,:)
  integer, pointer, save :: ieo2_around_it(:,:,:)

  integer, pointer, save :: ieo2_around_it_nspace(:,:)
  integer, pointer, save :: ieo2_around_it_space(:,:,:)

end module

!-------------------------------------------------------------------------------
subroutine checkmat(id)
  use module_field
  use module_action
  use module_vol
  implicit none
  integer, intent(in) :: id
  SPINCOL_FIELD :: eta_e, eta_o, zeta_e, zeta_o
  COMPLEX,allocatable :: zeta(:), eta(:), zeta1(:), mat(:,:)
  COMPLEX :: fac1, fac2

  call stderr2("Now check mat-vec mult with chemical potential")

  fac1 = exp(cmplx( chemi, chemi_i))
  fac2 = exp(cmplx(-chemi,-chemi_i))

  allocate(zeta(12*vol), zeta1(12*vol), eta(12*vol), mat(12*vol, 12*volume))

  call make_source(eta_e, eta_o, RANDOM_SOURCE)
  call sceo2sc(eta, eta_e, eta_o)
  !
  ! result multiplied by using d
  !
!  call d(se, so, zeta_e, eta_o, gauge(2)%u(1,1,1,0,1))
!  call sc_xpby(zeta_e, eta_e, - action%mtilde(id)%kappa)
!  call d(so, se, zeta_o, eta_e, gauge(2)%u(1,1,1,0,1))
!  call sc_xpby(zeta_o, eta_o, - action%mtilde(id)%kappa)
!  call clover_mult_a(zeta_e, clover(action%mtilde(id)%cid)%a(1,1,se), eta_e, volh)
!  call clover_mult_a(zeta_o, clover(action%mtilde(id)%cid)%a(1,1,so), eta_o, volh)


  call unprec_wmul(zeta_e, zeta_o, eta_e, eta_o, id)

  call sceo2sc(zeta, zeta_e, zeta_o)
  call make_dirac_op(mat, id, fac1, fac2)
  call matvec_mul(mat, zeta1, eta, 12*vol, 12*volume)
  call compare_sc(zeta, zeta1, 24*vol)

  deallocate(zeta, zeta1, eta, mat)
!!  call comm_finalize()
!!  call die("stop")
end

!-------------------------------------------------------------------------------
# define CLOVER_AS_COMPLEX_ARRAY
# include "clover.h"
subroutine clover_put_4d(mat, eo, a, offset)
  use module_dirac_matrix
  use module_vol
  implicit none
  COMPLEX, dimension(18, 2, *) :: a
  COMPLEX:: mat(3,4,vol,3,4,volume), cl1(6,6), cl2(6,6), clp(6,6), clm(6,6)
  integer :: c1, s1, c2, s2, ii, i, eo, sc1, sc2, offset, jj

  call init_dirac_matrix()
  !$omp parallel do private (ii, jj, clp, clm, cl1, cl2, sc1, sc2, s1, s2, c1, c2)
  do i=1, volh
     ii=ieo2_around_i(i,eo,0)
     jj=ii + offset
# undef J
# define J 1
     cl1(1,1) =A11 ; cl1(1,2) =A12 ; cl1(1,3) =A13 ; cl1(1,4) =A14 ; cl1(1,5) =A15 ; cl1(1,6) =A16
     cl1(2,1) =A21 ; cl1(2,2) =A22 ; cl1(2,3) =A23 ; cl1(2,4) =A24 ; cl1(2,5) =A25 ; cl1(2,6) =A26
     cl1(3,1) =A31 ; cl1(3,2) =A32 ; cl1(3,3) =A33 ; cl1(3,4) =A34 ; cl1(3,5) =A35 ; cl1(3,6) =A36
     cl1(4,1) =A41 ; cl1(4,2) =A42 ; cl1(4,3) =A43 ; cl1(4,4) =A44 ; cl1(4,5) =A45 ; cl1(4,6) =A46
     cl1(5,1) =A51 ; cl1(5,2) =A52 ; cl1(5,3) =A53 ; cl1(5,4) =A54 ; cl1(5,5) =A55 ; cl1(5,6) =A56
     cl1(6,1) =A61 ; cl1(6,2) =A62 ; cl1(6,3) =A63 ; cl1(6,4) =A64 ; cl1(6,5) =A65 ; cl1(6,6) =A66
# undef J
# define J 2
     cl2(1,1) =A11 ; cl2(1,2) =A12 ; cl2(1,3) =A13 ; cl2(1,4) =A14 ; cl2(1,5) =A15 ; cl2(1,6) =A16
     cl2(2,1) =A21 ; cl2(2,2) =A22 ; cl2(2,3) =A23 ; cl2(2,4) =A24 ; cl2(2,5) =A25 ; cl2(2,6) =A26
     cl2(3,1) =A31 ; cl2(3,2) =A32 ; cl2(3,3) =A33 ; cl2(3,4) =A34 ; cl2(3,5) =A35 ; cl2(3,6) =A36
     cl2(4,1) =A41 ; cl2(4,2) =A42 ; cl2(4,3) =A43 ; cl2(4,4) =A44 ; cl2(4,5) =A45 ; cl2(4,6) =A46
     cl2(5,1) =A51 ; cl2(5,2) =A52 ; cl2(5,3) =A53 ; cl2(5,4) =A54 ; cl2(5,5) =A55 ; cl2(5,6) =A56
     cl2(6,1) =A61 ; cl2(6,2) =A62 ; cl2(6,3) =A63 ; cl2(6,4) =A64 ; cl2(6,5) =A65 ; cl2(6,6) =A66

     clp=cl1+cl2
     clm=cl1-cl2
     do s1=1,2;   do s2=1,2
     do c1=1,3;   do c2=1,3
        sc1=(s1-1)*3+c1
        sc2=(s2-1)*3+c2
        mat(c1,s1  ,ii,c2,s2  ,jj)=clp(sc1,sc2)
        mat(c1,s1+2,ii,c2,s2+2,jj)=clp(sc1,sc2)
        mat(c1,s1  ,ii,c2,s2+2,jj)=clm(sc1,sc2)
        mat(c1,s1+2,ii,c2,s2  ,jj)=clm(sc1,sc2)
     enddo; enddo
     enddo; enddo
  enddo

end

!-------------------------------------------------------------------------------
# define CLOVER_AS_COMPLEX_ARRAY
# include "clover.h"
subroutine clover_put_4d_sc12(mat, i, eo, a, offset)
  use module_dirac_matrix
  use module_vol
  implicit none
  COMPLEX, dimension(18, 2, *) :: a
  COMPLEX:: mat(3,4,3,4,volume), cl1(6,6), cl2(6,6), clp(6,6), clm(6,6)
  integer :: c1, s1, c2, s2, ii, i, eo, sc1, sc2, offset, jj

  call init_dirac_matrix()

     ii=ieo2_around_i(i,eo,0)
     jj=ii + offset
# undef J
# define J 1
     cl1(1,1) =A11 ; cl1(1,2) =A12 ; cl1(1,3) =A13 ; cl1(1,4) =A14 ; cl1(1,5) =A15 ; cl1(1,6) =A16
     cl1(2,1) =A21 ; cl1(2,2) =A22 ; cl1(2,3) =A23 ; cl1(2,4) =A24 ; cl1(2,5) =A25 ; cl1(2,6) =A26
     cl1(3,1) =A31 ; cl1(3,2) =A32 ; cl1(3,3) =A33 ; cl1(3,4) =A34 ; cl1(3,5) =A35 ; cl1(3,6) =A36
     cl1(4,1) =A41 ; cl1(4,2) =A42 ; cl1(4,3) =A43 ; cl1(4,4) =A44 ; cl1(4,5) =A45 ; cl1(4,6) =A46
     cl1(5,1) =A51 ; cl1(5,2) =A52 ; cl1(5,3) =A53 ; cl1(5,4) =A54 ; cl1(5,5) =A55 ; cl1(5,6) =A56
     cl1(6,1) =A61 ; cl1(6,2) =A62 ; cl1(6,3) =A63 ; cl1(6,4) =A64 ; cl1(6,5) =A65 ; cl1(6,6) =A66
# undef J
# define J 2
     cl2(1,1) =A11 ; cl2(1,2) =A12 ; cl2(1,3) =A13 ; cl2(1,4) =A14 ; cl2(1,5) =A15 ; cl2(1,6) =A16
     cl2(2,1) =A21 ; cl2(2,2) =A22 ; cl2(2,3) =A23 ; cl2(2,4) =A24 ; cl2(2,5) =A25 ; cl2(2,6) =A26
     cl2(3,1) =A31 ; cl2(3,2) =A32 ; cl2(3,3) =A33 ; cl2(3,4) =A34 ; cl2(3,5) =A35 ; cl2(3,6) =A36
     cl2(4,1) =A41 ; cl2(4,2) =A42 ; cl2(4,3) =A43 ; cl2(4,4) =A44 ; cl2(4,5) =A45 ; cl2(4,6) =A46
     cl2(5,1) =A51 ; cl2(5,2) =A52 ; cl2(5,3) =A53 ; cl2(5,4) =A54 ; cl2(5,5) =A55 ; cl2(5,6) =A56
     cl2(6,1) =A61 ; cl2(6,2) =A62 ; cl2(6,3) =A63 ; cl2(6,4) =A64 ; cl2(6,5) =A65 ; cl2(6,6) =A66

     clp=cl1+cl2
     clm=cl1-cl2
     do s1=1,2;   do s2=1,2
     do c1=1,3;   do c2=1,3
        sc1=(s1-1)*3+c1
        sc2=(s2-1)*3+c2
        mat(c1,s1  ,c2,s2  ,jj)=clp(sc1,sc2)
        mat(c1,s1+2,c2,s2+2,jj)=clp(sc1,sc2)
        mat(c1,s1  ,c2,s2+2,jj)=clm(sc1,sc2)
        mat(c1,s1+2,c2,s2  ,jj)=clm(sc1,sc2)
     enddo; enddo
     enddo; enddo

end

!-------------------------------------------------------------------------------
subroutine clover_put(mat, eo, it, a, offset)
  use module_dirac_matrix
  use module_vol
  use module_lattice
  implicit none
  COMPLEX, dimension(18, 2, *) :: a
  COMPLEX:: mat(3,4,nx*ny*nz,3,4,lx*ly*lz), cl1(6,6), cl2(6,6), clp(6,6), clm(6,6)
  integer :: c1, s1, c2, s2, is, it, i, ii, eo, sc1, sc2, jj, offset

  !$omp parallel do private (i, is, jj, clp, clm, cl1, cl2, sc1, sc2, s1, s2, c1, c2)
  do ii=1, volh/lt
     i = ieo2_around_it_space(ii,eo,it)
     is=ieo2_around_is(i,eo,0)
     jj=is + offset
# undef J
# define J 1
     cl1(1,1) =A11 ; cl1(1,2) =A12 ; cl1(1,3) =A13 ; cl1(1,4) =A14 ; cl1(1,5) =A15 ; cl1(1,6) =A16
     cl1(2,1) =A21 ; cl1(2,2) =A22 ; cl1(2,3) =A23 ; cl1(2,4) =A24 ; cl1(2,5) =A25 ; cl1(2,6) =A26
     cl1(3,1) =A31 ; cl1(3,2) =A32 ; cl1(3,3) =A33 ; cl1(3,4) =A34 ; cl1(3,5) =A35 ; cl1(3,6) =A36
     cl1(4,1) =A41 ; cl1(4,2) =A42 ; cl1(4,3) =A43 ; cl1(4,4) =A44 ; cl1(4,5) =A45 ; cl1(4,6) =A46
     cl1(5,1) =A51 ; cl1(5,2) =A52 ; cl1(5,3) =A53 ; cl1(5,4) =A54 ; cl1(5,5) =A55 ; cl1(5,6) =A56
     cl1(6,1) =A61 ; cl1(6,2) =A62 ; cl1(6,3) =A63 ; cl1(6,4) =A64 ; cl1(6,5) =A65 ; cl1(6,6) =A66
# undef J
# define J 2
     cl2(1,1) =A11 ; cl2(1,2) =A12 ; cl2(1,3) =A13 ; cl2(1,4) =A14 ; cl2(1,5) =A15 ; cl2(1,6) =A16
     cl2(2,1) =A21 ; cl2(2,2) =A22 ; cl2(2,3) =A23 ; cl2(2,4) =A24 ; cl2(2,5) =A25 ; cl2(2,6) =A26
     cl2(3,1) =A31 ; cl2(3,2) =A32 ; cl2(3,3) =A33 ; cl2(3,4) =A34 ; cl2(3,5) =A35 ; cl2(3,6) =A36
     cl2(4,1) =A41 ; cl2(4,2) =A42 ; cl2(4,3) =A43 ; cl2(4,4) =A44 ; cl2(4,5) =A45 ; cl2(4,6) =A46
     cl2(5,1) =A51 ; cl2(5,2) =A52 ; cl2(5,3) =A53 ; cl2(5,4) =A54 ; cl2(5,5) =A55 ; cl2(5,6) =A56
     cl2(6,1) =A61 ; cl2(6,2) =A62 ; cl2(6,3) =A63 ; cl2(6,4) =A64 ; cl2(6,5) =A65 ; cl2(6,6) =A66

     clp=cl1+cl2
     clm=cl1-cl2
     do s1=1,2;   do s2=1,2
     do c1=1,3;   do c2=1,3
        sc1=(s1-1)*3+c1
        sc2=(s2-1)*3+c2
        mat(c1,s1  ,is,c2,s2  ,jj)=clp(sc1,sc2)
        mat(c1,s1+2,is,c2,s2+2,jj)=clp(sc1,sc2)
        mat(c1,s1  ,is,c2,s2+2,jj)=clm(sc1,sc2)
        mat(c1,s1+2,is,c2,s2  ,jj)=clm(sc1,sc2)
     enddo; enddo
     enddo; enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine one_put(mat, m, n, offset)
  implicit none
  integer, intent(in) :: m, n, offset
  COMPLEX,intent(inout) :: mat(12,m,12,n)
  integer :: i

  !$omp parallel do
  do i = 1, m
     mat( 1, i, 1, i + offset )=ONE
     mat( 2, i, 2, i + offset )=ONE
     mat( 3, i, 3, i + offset )=ONE
     mat( 4, i, 4, i + offset )=ONE
     mat( 5, i, 5, i + offset )=ONE
     mat( 6, i, 6, i + offset )=ONE
     mat( 7, i, 7, i + offset )=ONE
     mat( 8, i, 8, i + offset )=ONE
     mat( 9, i, 9, i + offset )=ONE
     mat(10, i,10, i + offset )=ONE
     mat(11, i,11, i + offset )=ONE
     mat(12, i,12, i + offset )=ONE
  enddo
end

!-------------------------------------------------------------------------------
subroutine hop_put_4d(mat, gp, gm, i, eo, dir, ii, kappa, fac1, fac2)
  use module_nn
  use module_vol
  use module_dirac_matrix
  use module_field
  implicit none
  integer, intent(in) :: i, eo, dir, ii
  COMPLEX, intent(in) :: gp(4,4), gm(4,4)
  COMPLEX, intent(inout) :: mat(3,4,vol,3,4,volume)
  REAL, intent(in) :: kappa
  COMPLEX, intent(in) :: fac1, fac2
  integer :: s1, s2, col1, col2, jm, jj, jb

  jm=nn(i, eo, dir, BWD)
  jj=ieo2_around_i(i,eo,1 + 2*(dir-1) )
  jb=ieo2_around_i(i,eo,2 + 2*(dir-1) )

  do s1 = 1, 4
  do s2 = 1, 4
     if ( gp(s1, s2) /=0 ) then
        do col1 = 1, 3
        do col2 = 1, 3
           mat(col1,s1,ii,col2,s2,jj)=mat(col1,s1,ii,col2,s2,jj) &
          -kappa*      gauge(2)%u(col1,col2, i,   eo,dir) *gp(s1,s2)*fac1
        enddo
        enddo
     endif
     if ( gm(s1, s2) /=0 ) then
        do col1 = 1, 3
        do col2 = 1, 3
           mat(col1,s1,ii,col2,s2,jb)=mat(col1,s1,ii,col2,s2,jb) &
          -kappa*conjg(gauge(2)%u(col2,col1, jm,1-eo,dir))*gm(s1,s2)*fac2
        enddo
        enddo
     endif
  enddo
  enddo
end

!-------------------------------------------------------------------------------
subroutine hop_put_4d_sc12(mat, gp, gm, i, eo, dir, kappa, fac1, fac2)
  use module_nn
  use module_vol
  use module_dirac_matrix
  use module_field
  implicit none
  integer, intent(in) :: i, eo, dir
  COMPLEX, intent(in) :: gp(4,4), gm(4,4)
  COMPLEX, intent(inout) :: mat(3,4,3,4,volume)
  REAL, intent(in) :: kappa
  COMPLEX, intent(in) :: fac1, fac2
  integer :: s1, s2, col1, col2, jm, jj, jb

  jm=nn(i, eo, dir, BWD)
  jj=ieo2_around_i(i,eo,1 + 2*(dir-1) )
  jb=ieo2_around_i(i,eo,2 + 2*(dir-1) )

  do s1 = 1, 4
  do s2 = 1, 4
     if ( gp(s1, s2) /=0 ) then
        do col1 = 1, 3
        do col2 = 1, 3
           mat(col1,s1,col2,s2,jj)=mat(col1,s1,col2,s2,jj) &
          -kappa*      gauge(2)%u(col1,col2, i,   eo,dir) *gp(s1,s2)*fac1
        enddo
        enddo
     endif
     if ( gm(s1, s2) /=0 ) then
        do col1 = 1, 3
        do col2 = 1, 3
           mat(col1,s1,col2,s2,jb)=mat(col1,s1,col2,s2,jb) &
          -kappa*conjg(gauge(2)%u(col2,col1, jm,1-eo,dir))*gm(s1,s2)*fac2
        enddo
        enddo
     endif
  enddo
  enddo
end

!-------------------------------------------------------------------------------
subroutine hop_put_space(mat, gp, gm, i, eo, dir, is, kappa)
  use module_nn
  use module_lattice
  use module_dirac_matrix
  use module_field
  implicit none
  integer, intent(in) :: i, eo, dir, is
  COMPLEX, intent(in) :: gp(4,4), gm(4,4)
  COMPLEX, intent(inout) :: mat(3,4,nx*ny*nz,3,4,lx*ly*lz)
  REAL, intent(in) :: kappa
  integer :: s1, s2, col1, col2, jm, jj, jb

  jm=nn(i, eo, dir, BWD)
  jj=ieo2_around_is(i,eo,1 + 2*(dir-1) )
  jb=ieo2_around_is(i,eo,2 + 2*(dir-1) )

  do s1 = 1, 4
  do s2 = 1, 4
     if ( gp(s1, s2) /=0 ) then
        do col1 = 1, 3
        do col2 = 1, 3
           mat(col1,s1,is,col2,s2,jj)=mat(col1,s1,is,col2,s2,jj) &
          -kappa*      gauge(2)%u(col1,col2, i,   eo,dir) *gp(s1,s2)
        enddo
        enddo
     endif
     if ( gm(s1, s2) /=0 ) then
        do col1 = 1, 3
        do col2 = 1, 3
           mat(col1,s1,is,col2,s2,jb)=mat(col1,s1,is,col2,s2,jb) &
          -kappa*conjg(gauge(2)%u(col2,col1, jm,1-eo,dir))*gm(s1,s2)
        enddo
        enddo
     endif
  enddo
  enddo
end

!-------------------------------------------------------------------------------
subroutine hop_put_tforw(mat, kappa, it)
  use module_nn
  use module_vol
  use module_lattice
  use module_dirac_matrix
  use module_field
  implicit none
  integer, intent(in) :: it 
  COMPLEX, intent(inout) :: mat(3,4,nx*ny*nz,3,4,lx*ly*lz)
  REAL, intent(in) :: kappa
  integer :: s1, s2, col1, col2, i, ii, is, jj, eo

  DEBUG2S("Start: hop_put_tforw")
  call init_dirac_matrix()
  mat=ZERO
  do eo = EVEN, ODD
  do ii = 1, volh/lt
     i = ieo2_around_it_space(ii,eo,it)
     is=ieo2_around_is(i,eo,0)
     jj=ieo2_around_is(i,eo,7)
     do s1 = 1, 4
     do s2 = 1, 4
        if ( proj_1_m_gamman(s1, s2) /=0 ) then
           do col1 = 1, 3
           do col2 = 1, 3
              mat(col1,s1,is,col2,s2,jj)=mat(col1,s1,is,col2,s2,jj) &
             -kappa*      gauge(2)%u(col1,col2, i,   eo,4) *proj_1_m_gamman(s1,s2)
           enddo
           enddo
        endif
     enddo
     enddo
  enddo
  enddo
  DEBUG2S("End: hop_put_tforw")
end

!-------------------------------------------------------------------------------
subroutine hop_put_tback(mat, kappa, it)
  use module_nn
  use module_vol
  use module_lattice
  use module_dirac_matrix
  use module_field
  implicit none
  integer, intent(in) :: it
  COMPLEX, intent(inout) :: mat(3,4,nx*ny*nz,3,4,lx*ly*lz)
  REAL, intent(in) :: kappa
  integer :: s1, s2, col1, col2, jm, jj, jb, ii, is, i, eo

  DEBUG2S("Start: hop_put_tback")
  call init_dirac_matrix()
  mat=ZERO
  do eo = EVEN, ODD
  do ii = 1, volh/lt
     i = ieo2_around_it_space(ii,eo,it)
     jm=nn(i, eo, 4, BWD)
     is=ieo2_around_is(i,eo,0)
     jb=ieo2_around_is(i,eo,8)
     do s1 = 1, 4
     do s2 = 1, 4
        if ( proj_1_p_gamman(s1, s2) /=0 ) then
           do col1 = 1, 3
           do col2 = 1, 3
              mat(col1,s1,is,col2,s2,jb)=mat(col1,s1,is,col2,s2,jb) &
             -kappa*conjg(gauge(2)%u(col2,col1, jm,1-eo,4))*proj_1_p_gamman(s1,s2)
           enddo
           enddo
        endif
     enddo
     enddo
  enddo
  enddo
  DEBUG2S("End: hop_put_tback")
end

!-------------------------------------------------------------------------------
subroutine make_dirac_op(mat, id, fac1, fac2) ! for one node
  use module_dirac_matrix
  use module_vol
  use module_field
  use module_action
  use module_function_decl
  implicit none
  integer, intent(in) :: id
  COMPLEX, intent(in) :: fac1, fac2
  COMPLEX,intent(out) :: mat(3,4,vol,3,4,volume)
  REAL :: kappa
  integer :: ii, i, eo, offset
  COMPLEX, parameter :: zone = cmplx(1,0)

  DEBUG2S("Start: make_dirac_op")
  call init_dirac_matrix()
  kappa=action%mtilde(id)%kappa
  mat=ZERO
  offset =  my_pe()*vol
  if (action%mtilde(id)%cswkappa == 0) then
     call one_put(mat, vol, volume, offset)
  else
     call clover_put_4d(mat, EVEN, clover(action%mtilde(id)%cid)%cfield%a(1,1,se), offset)
     call clover_put_4d(mat, ODD,  clover(action%mtilde(id)%cid)%cfield%a(1,1,so), offset)
  endif

  if (kappa /= 0) then
     !$omp parallel do private (i, ii)
     do eo=EVEN, ODD
     do i=1, volh
        ii=ieo2_around_i(i,eo,0)
        call hop_put_4d(mat, proj_1_p_gamma1, proj_1_m_gamma1, i, eo, 1, ii, kappa,zone,zone) ! x-dir
        call hop_put_4d(mat, proj_1_p_gamma2, proj_1_m_gamma2, i, eo, 2, ii, kappa,zone,zone) ! y-dir
        call hop_put_4d(mat, proj_1_p_gamma3, proj_1_m_gamma3, i, eo, 3, ii, kappa,zone,zone) ! z-dir
        call hop_put_4d(mat, proj_1_m_gamman, proj_1_p_gamman, i, eo, 4, ii, kappa,fac1,fac2) ! t-dir
     enddo
     enddo
  endif
  DEBUG2S("End: make_dirac_op")
end

!-------------------------------------------------------------------------------
subroutine make_dirac_op_3d(mat3,matt, id)
  use module_lattice
  use module_action
  implicit none
  integer, intent(in) :: id
  REAL :: kappa
  COMPLEX:: mat3(3,4,nx*ny*nz,3,4,lx*ly*lz,lt)
  COMPLEX:: matt(3,4,nx*ny*nz,3,4,lx*ly*lz,2*lt)
  integer :: it

  DEBUG2S("Start: make_dirac_op_3d")
  kappa=action%mtilde(id)%kappa
  do it = 1, lt
     call make_dirac_op_space(mat3(:,:,:,:,:,:,it), id, it)
     call hop_put_tforw(matt(:,:,:,:,:,:,it   ), kappa, it)
     call hop_put_tback(matt(:,:,:,:,:,:,it+lt), kappa, it)
  enddo
  DEBUG2S("End: make_dirac_op_3d")
end

!-------------------------------------------------------------------------------
subroutine make_dirac_op_space(mat3, id, it)
  use module_dirac_matrix
  use module_lattice
  use module_vol
  use module_nn
  use module_field
  use module_action
  use module_function_decl
  implicit none
  integer, intent(in) :: id, it
  REAL :: kappa
  COMPLEX:: mat3(3,4,nx*ny*nz,3,4,lx*ly*lz)
  integer :: ic, is, i, jc, js, j, eo, offset, ii

  DEBUG2S("Start: make_dirac_op_space")
  call init_dirac_matrix()
  kappa=action%mtilde(id)%kappa
  offset =  my_pe()*vol/nt

  !$omp parallel do private (j, js, jc, i, is, ic)
  do j = 1, lx*ly*lz
  do js = 1, 4
  do jc = 1, 3
  do i = 1, nx*ny*nz
  do is = 1, 4
  do ic = 1, 3
     mat3(ic,is,i,jc,js,j)=ZERO
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo


  if (action%mtilde(id)%cswkappa == 0) then
     call one_put(mat3, vol/nt, volume/nt, offset)
  else
     call clover_put(mat3, EVEN, it, clover(action%mtilde(id)%cid)%cfield%a(1,1,se), offset)
     call clover_put(mat3, ODD,  it, clover(action%mtilde(id)%cid)%cfield%a(1,1,so), offset)
  endif
  if (kappa /= 0) then
     !$omp parallel do private (eo, ii, i, is)
     do eo=EVEN, ODD
     do ii=1, volh/lt
        i =ieo2_around_it_space(ii,eo,it)
        is=ieo2_around_is(i,eo,0)
        call hop_put_space(mat3, proj_1_p_gamma1, proj_1_m_gamma1, i, eo, 1, is, kappa) ! x-dir
        call hop_put_space(mat3, proj_1_p_gamma2, proj_1_m_gamma2, i, eo, 2, is, kappa) ! y-dir
        call hop_put_space(mat3, proj_1_p_gamma3, proj_1_m_gamma3, i, eo, 3, is, kappa) ! z-dir
     enddo
     enddo
  endif
  DEBUG2S("End: make_dirac_op_space")
end

!-------------------------------------------------------------------------------
subroutine make_hdirac_op_space(hmat, id, it)
  use module_dirac_matrix
  use module_lattice
  use module_vol
  use module_nn
  use module_field
  use module_action
  implicit none
  integer, intent(in) :: id, it
  REAL :: kappa
  COMPLEX:: mat3(3,4,nx*ny*nz,3,4,lx*ly*lz), hmat(6,nx*ny*nz,6,lx*ly*lz,  2,2)
  integer :: ic, jc, i, j

  call make_dirac_op_space(mat3, id, it)

  !$omp parallel do private (j, jc, i, ic)
  do j = 1, lx*ly*lz
  do jc = 1, 3
  do i = 1, nx*ny*nz
  do ic = 1, 3
     hmat(ic+0, i, jc+0, j, 2, 1) = mat3(ic, 1, i, jc, 1, j)
     hmat(ic+3, i, jc+0, j, 2, 1) = mat3(ic, 2, i, jc, 1, j)
     hmat(ic+0, i, jc+0, j, 1, 1) = mat3(ic, 3, i, jc, 1, j)
     hmat(ic+3, i, jc+0, j, 1, 1) = mat3(ic, 4, i, jc, 1, j)
     hmat(ic+0, i, jc+3, j, 2, 1) = mat3(ic, 1, i, jc, 2, j)
     hmat(ic+3, i, jc+3, j, 2, 1) = mat3(ic, 2, i, jc, 2, j)
     hmat(ic+0, i, jc+3, j, 1, 1) = mat3(ic, 3, i, jc, 2, j)
     hmat(ic+3, i, jc+3, j, 1, 1) = mat3(ic, 4, i, jc, 2, j)
     hmat(ic+0, i, jc+0, j, 2, 2) = mat3(ic, 1, i, jc, 3, j)
     hmat(ic+3, i, jc+0, j, 2, 2) = mat3(ic, 2, i, jc, 3, j)
     hmat(ic+0, i, jc+0, j, 1, 2) = mat3(ic, 3, i, jc, 3, j)
     hmat(ic+3, i, jc+0, j, 1, 2) = mat3(ic, 4, i, jc, 3, j)
     hmat(ic+0, i, jc+3, j, 2, 2) = mat3(ic, 1, i, jc, 4, j)
     hmat(ic+3, i, jc+3, j, 2, 2) = mat3(ic, 2, i, jc, 4, j)
     hmat(ic+0, i, jc+3, j, 1, 2) = mat3(ic, 3, i, jc, 4, j)
     hmat(ic+3, i, jc+3, j, 1, 2) = mat3(ic, 4, i, jc, 4, j)
  enddo
  enddo
  enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine hhop_put_tforw(mat, kappa, it)
  use module_nn
  use module_vol
  use module_lattice
  use module_dirac_matrix
  use module_field
  implicit none
  integer, intent(in) :: it 
  COMPLEX, intent(inout) :: mat(3,2,nx*ny*nz, 3,2,lx*ly*lz)
  REAL, intent(in) :: kappa
  COMPLEX :: tmp(3,4,nx*ny*nz,3,4,lx*ly*lz)
  integer :: j, jc, i, ic

  call hop_put_tforw(tmp, kappa, it)

  !$omp parallel do private (j, jc, i, ic)
  do j = 1, lx*ly*lz
  do jc = 1, 3
  do i = 1, nx*ny*nz
  do ic = 1, 3
     mat(ic, 1, i, jc, 1, j) = tmp(ic, 3, i, jc, 3, j)
     mat(ic, 2, i, jc, 1, j) = tmp(ic, 4, i, jc, 3, j)
     mat(ic, 1, i, jc, 2, j) = tmp(ic, 3, i, jc, 4, j)
     mat(ic, 2, i, jc, 2, j) = tmp(ic, 4, i, jc, 4, j)
  enddo
  enddo
  enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine init_dirac_matrix()
  use module_dirac_matrix
  use module_lattice
  use module_vol
  implicit none
  integer :: i, eo, ll(4), dir, it

  if (.not. associated(ieo2_around_i)) then
  allocate(ieo2_around_i(volh,0:1, 0:8))
  allocate(ieo2_around_is(volh,0:1, 0:8))
  allocate(ieo2_around_it(volh,0:1, 0:8))

  allocate(ieo2_around_it_nspace(0:1, lt))
  allocate(ieo2_around_it_space(volh/lt, 0:1, lt))

  proj_1_m_gamma1=0
  proj_1_p_gamma1=0
  proj_1_m_gamma2=0
  proj_1_p_gamma2=0
  proj_1_m_gamma3=0
  proj_1_p_gamma3=0
  proj_1_m_gammac=0
  proj_1_p_gammac=0
  proj_1_m_gamman=0
  proj_1_p_gamman=0

  do i=1,4
  proj_1_m_gamma1(i,i)=ONE
  proj_1_p_gamma1(i,i)=ONE
  proj_1_m_gamma2(i,i)=ONE
  proj_1_p_gamma2(i,i)=ONE
  proj_1_m_gamma3(i,i)=ONE
  proj_1_p_gamma3(i,i)=ONE
  proj_1_m_gammac(i,i)=ONE
  proj_1_p_gammac(i,i)=ONE
  enddo

  proj_1_m_gamman(3,3)=TWO
  proj_1_m_gamman(4,4)=TWO
  proj_1_p_gamman(1,1)=TWO
  proj_1_p_gamman(2,2)=TWO

  proj_1_m_gamma1(1,4)=cmplx(ZERO,ONE)
  proj_1_m_gamma1(2,3)=cmplx(ZERO,ONE)
  proj_1_m_gamma1(3,2)=cmplx(ZERO,-ONE)
  proj_1_m_gamma1(4,1)=cmplx(ZERO,-ONE)
  proj_1_p_gamma1(1,4)=cmplx(ZERO,-ONE)
  proj_1_p_gamma1(2,3)=cmplx(ZERO,-ONE)
  proj_1_p_gamma1(3,2)=cmplx(ZERO,ONE)
  proj_1_p_gamma1(4,1)=cmplx(ZERO,ONE)

  proj_1_m_gamma2(1,4)= ONE
  proj_1_m_gamma2(2,3)=-ONE
  proj_1_m_gamma2(3,2)=-ONE
  proj_1_m_gamma2(4,1)= ONE
  proj_1_p_gamma2(1,4)=-ONE
  proj_1_p_gamma2(2,3)= ONE
  proj_1_p_gamma2(3,2)= ONE
  proj_1_p_gamma2(4,1)=-ONE

  proj_1_m_gamma3(1,3)=cmplx(ZERO, ONE)
  proj_1_m_gamma3(2,4)=cmplx(ZERO,-ONE)
  proj_1_m_gamma3(3,1)=cmplx(ZERO,-ONE)
  proj_1_m_gamma3(4,2)=cmplx(ZERO, ONE)
  proj_1_p_gamma3(1,3)=cmplx(ZERO,-ONE)
  proj_1_p_gamma3(2,4)=cmplx(ZERO, ONE)
  proj_1_p_gamma3(3,1)=cmplx(ZERO, ONE)
  proj_1_p_gamma3(4,2)=cmplx(ZERO,-ONE)

  proj_1_m_gammac(1,3)=-ONE
  proj_1_m_gammac(2,4)=-ONE
  proj_1_m_gammac(3,1)= ONE
  proj_1_m_gammac(4,2)= ONE
  proj_1_p_gammac(1,3)= ONE
  proj_1_p_gammac(2,4)= ONE
  proj_1_p_gammac(3,1)=-ONE
  proj_1_p_gammac(4,2)=-ONE


  do eo=EVEN, ODD
  do i=1, volh
     call i2xyzt(i,     eo, ll)
     ieo2_around_i(i,eo,0)= 1 + ll(1) + ll(2)*nx + ll(3)*nx*ny + ll(4)*nx*ny*nz
     ieo2_around_is(i,eo,0)= 1 + ll(1) + ll(2)*nx + ll(3)*nx*ny
     ieo2_around_it(i,eo,0)= 1 + ll(4)

     call ieo_offset_global(i, eo, 1, FWD, ieo2_around_i(i,eo,1), ieo2_around_is(i,eo,1), ieo2_around_it(i,eo,1))
     call ieo_offset_global(i, eo, 1, BWD, ieo2_around_i(i,eo,2), ieo2_around_is(i,eo,2), ieo2_around_it(i,eo,2))
     call ieo_offset_global(i, eo, 2, FWD, ieo2_around_i(i,eo,3), ieo2_around_is(i,eo,3), ieo2_around_it(i,eo,3))
     call ieo_offset_global(i, eo, 2, BWD, ieo2_around_i(i,eo,4), ieo2_around_is(i,eo,4), ieo2_around_it(i,eo,4))
     call ieo_offset_global(i, eo, 3, FWD, ieo2_around_i(i,eo,5), ieo2_around_is(i,eo,5), ieo2_around_it(i,eo,5))
     call ieo_offset_global(i, eo, 3, BWD, ieo2_around_i(i,eo,6), ieo2_around_is(i,eo,6), ieo2_around_it(i,eo,6))
     call ieo_offset_global(i, eo, 4, FWD, ieo2_around_i(i,eo,7), ieo2_around_is(i,eo,7), ieo2_around_it(i,eo,7))
     call ieo_offset_global(i, eo, 4, BWD, ieo2_around_i(i,eo,8), ieo2_around_is(i,eo,8), ieo2_around_it(i,eo,8))
  enddo
  enddo


!!!!!!!!!!!!!!!!!!!
  ieo2_around_it_nspace=0
  do eo=EVEN, ODD
  do i=1, volh
     it=ieo2_around_it(i,eo,0)
     ieo2_around_it_nspace(eo,it) = ieo2_around_it_nspace(eo,it) + 1
     ieo2_around_it_space(ieo2_around_it_nspace(eo,it),eo,it) = i
  enddo
  enddo

  endif


end

!-------------------------------------------------------------------------------
subroutine ieo_offset_global(i, eo , dir, fb, i4, i3, it)
  use module_function_decl
  use module_lattice
  use module_nnpe
  use module_nn
  use module_vol
  implicit none
  integer, intent(in) :: i, eo, dir, fb
  integer, intent(out):: i4, i3, it
  integer :: j, ll(4), pe(4), ip
  integer, save :: nxy, nxyz, count=0

  if (count==0) then
     nxy = nx * ny
     nxyz= nxy * nz
     count=-1
  endif

  pe = 0
  j = nn(i, eo, dir, fb)
  call i2xyzt(j, 1-eo, ll)

  if ( j > volh ) then
     if ( ll(dir) == -1 ) then
        pe(dir) = -1
        ll(dir) = n(dir)-1
     elseif( ll(dir) == n(dir) ) then
        pe(dir) = 1
        ll(dir) = 0
     endif
  endif

  ip=nnpe( pe(1), pe(2), pe(3), pe(4))

  it = 1 + ll(4)
  i3 = 1 + ll(1) + ll(2) * nx + ll(3) * nxy
  i4 = i3+ ll(4) * nxyz

  i3 = i3 + ip * nxyz
  i4 = i4 + ip * vol

end

!-------------------------------------------------------------------------------
subroutine compare_sc(in1, in2, size)
  use module_function_decl
  implicit none
  integer :: i, size
  REAL :: in1(size), in2(size), res, tmp

  res=0
  do i=1, size
     tmp=(in1(i)-in2(i))**2
     res=res+tmp
     if (tmp > 0.00001)write(*,'(1x,i3,i5,3(f15.10))')my_pe(), i, tmp,in1(i),in2(i)
  enddo
  res=global_sum(res)
  call stderr2_real("vector difference",1,res)

end

!-------------------------------------------------------------------------------
subroutine sceo2sc(out, in_e, in_o)
  use module_lattice
  use module_vol
  implicit none
  integer :: id, ix, iy, iz, it, i, ii, j(4), spin, col

  SPINCOL_FIELD :: in_e, in_o
  COMPLEX       :: out(3,4,vol)
  integer, external :: std_xyzt2i, e_o

  i=0
  do it=0,nt-1
  do iz=0,nz-1
  do iy=0,ny-1
  do ix=0,nx-1
     i=i+1
     j = (/ix, iy, iz, it/)
     ii = std_xyzt2i(j)
     if (e_o(j) == EVEN) then
        do col=1, 3
        do spin=1, 4
           out(col,spin,i)=in_e(spin,col,ii)
        enddo
        enddo
     else
        do col=1, 3
        do spin=1, 4
           out(col,spin,i)=in_o(spin,col,ii)
        enddo
        enddo
     endif
  enddo
  enddo
  enddo
  enddo

end

!===============================================================================
! for checking
!-------------------------------------------------------------------------------
module phmc_read
  integer, save :: ipeo=0
 
  type su3_obj 
     complex(8) :: u(3,3) 
  end type

  type gsf_eo_wg_obj
     type(su3_obj) :: s(0:2,0:5,0:5,0:5)
     integer :: ieo,idummy(3)
  end type

  type gvf_eo_wg_obj
     type(gsf_eo_wg_obj)  :: mu(4)
     integer :: ieo,idummy(3)
  end type

  type gvf_wg_obj
     type(gvf_eo_wg_obj)  :: eo(0:1)
  end type

end

!-------------------------------------------------------------------------------
subroutine read_phmc_config()
  use phmc_read
  use module_vol
  use module_field
  implicit none
  type(gvf_wg_obj) :: phmc_u
  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
  REAL :: plq, tmp
  GAUGE_FIELD ::u
  REAL, external :: sg
  integer, external :: std_xyzt2i, e_o

  write(*,*)"read_phmc_config: start"

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

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

  read(40)NTX,NTY,NTZ,NTT
  read(40)NDX,NDY,NDZ
  read(40)plq

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


  do imu = 1,4
  do it=1,4
     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)
     u(:,:, jj ,ee, imu )=phmc_u%eo(ieo)%mu(imu)%s(itb,iz,iy,ix)%u
  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)

end

!-------------------------------------------------------------------------------
subroutine qcd_matrix_dump(id)
  use module_dirac_matrix
  use module_field
  use module_action
  use module_vol
  use module_lattice
  use module_function_decl
  implicit none
  integer, intent(in) :: id
  COMPLEX,allocatable :: mat(:,:)
  REAL :: kappa
  COMPLEX :: fac1, fac2
  COMPLEX, parameter :: zone = cmplx(1,0)

  integer :: nnz, i, j, rows, cols, x, y, z, t, ii, eo, offset
  character rep*10
  character field*7
  character symm*19
  integer, external :: std_xyzt2i, e_o


  call stderr2("Matrix dumping")

  rep =  'coordinate'
  field = 'complex'
  symm = 'general'
  rows = 12*vol
  cols = 12*volume

  if ( action%mtilde(id)%cid == 0 ) then
     nnz = rows * 40 ! wilson
  else
     nnz = rows * 51 ! clover
  endif

  kappa=action%mtilde(id)%kappa
  fac1 = exp(cmplx( chemi, chemi_i))
  fac2 = exp(cmplx(-chemi,-chemi_i))

  allocate(mat(12, 12*volume))
!!  call make_dirac_op(mat, id, fac1, fac2)


  open(80, file='qcd.test.mtx')

  write(80,fmt=5)rep,' ',field,' ',symm
5 format('%%MatrixMarket matrix ',11A,1A,8A,1A,20A)


  write(80,fmt=*) rows,cols,nnz


  do t = 0, NT - 1
  do z = 0, NZ - 1
  do y = 0, NY - 1
  do x = 0, NX - 1

     i = std_xyzt2i((/x, y, z, t/))
     eo = e_o((/x, y, z, t/))

     mat=ZERO
     offset =  my_pe()*vol
     if (action%mtilde(id)%cswkappa == 0) then
        call one_put(mat, vol, volume, offset)
     else
        call clover_put_4d_sc12(mat, i, eo, clover(action%mtilde(id)%cid)%cfield%a(1,1,eo), offset)
     endif

     if (kappa /= 0) then
        call hop_put_4d_sc12(mat, proj_1_p_gamma1, proj_1_m_gamma1, i, eo, 1, kappa,zone,zone) ! x-dir
        call hop_put_4d_sc12(mat, proj_1_p_gamma2, proj_1_m_gamma2, i, eo, 2, kappa,zone,zone) ! y-dir
        call hop_put_4d_sc12(mat, proj_1_p_gamma3, proj_1_m_gamma3, i, eo, 3, kappa,zone,zone) ! z-dir
        call hop_put_4d_sc12(mat, proj_1_m_gamman, proj_1_p_gamman, i, eo, 4, kappa,fac1,fac2) ! t-dir
     endif

     ii=ieo2_around_i(i,eo,0)
     do i = 1, 12
     do j = 1, cols
        if ( mat(i,j) /= ZERO ) then
           write(80,fmt=*) i+12*(ii-1), j, real( mat(i,j) ), aimag( mat(i,j) )
        endif
     enddo
     enddo
!write(*,*)mat(1,1)
!stop

  enddo
  enddo
  enddo
  enddo

  deallocate(mat)
end

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