!===============================================================================
!
! dsf_hhh.F90
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2009-2010 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 dsf_mtdagmt_hh(p, step, a, b, mid)
  use module_vol
  use module_dd
  implicit none

  GENERATOR_FIELD, intent(inout) :: p
  REAL,            intent(in)    :: step
!!  COMPLEX, dimension (4,3,ld%lat%volh, 0:ld%lat%num_ip-1,0:1),intent(in) :: a,b
  COMPLEX, dimension (4,3,ld%lat%volh, gd%lat%volh,0:1),intent(in) :: a,b
  integer,         intent(in)    :: mid

  COMPLEX, allocatable :: w(:, :, :, :, :)
  COMPLEX, allocatable :: w1(:, :, :, :, :)
  COMPLEX, allocatable :: w2(:, :, :, :, :)
  integer :: ierr

  allocate(w(NCOL, NCOL, volh_tot, EVEN:ODD, DIM), STAT = ierr)
  if (ierr /= 0) then
     call stderr2_int("allocation failed", 1, ierr)
     call die("dsf: allocation failed w")
  endif
  allocate(w1(NCOL, NCOL, volh_tot, EVEN:ODD, DIM), STAT = ierr)
  if (ierr /= 0) then
     call stderr2_int("allocation failed", 1, ierr)
     call die("dsf: allocation failed w1")
  endif
  allocate(w2(NCOL, NCOL, volh_tot, EVEN:ODD, DIM), STAT = ierr)
  if (ierr /= 0) then
     call stderr2_int("allocation failed", 1, ierr)
     call die("dsf: allocation failed w2")
  endif

  w  = ZERO
  w1 = ZERO
  w2 = ZERO
  call dsf_sum_hh(w, w1, w2,  step, a, b, mid)
  call dsf_w2gen(p, w, w1, w2, mid)

  deallocate(w,  STAT = ierr)
  if (ierr /= 0) then
     call stderr2_int("deallocation failed", 1, ierr)
     call die("dsf: deallocation failed w")
  endif
  deallocate(w1, STAT = ierr)
  if (ierr /= 0) then
     call stderr2_int("deallocation failed", 1, ierr)
     call die("dsf: deallocation failed w1")
  endif
  deallocate(w2, STAT = ierr)
  if (ierr /= 0) then
     call stderr2_int("deallocation failed", 1, ierr)
     call die("dsf: deallocation failed w2")
  endif
end

!-------------------------------------------------------------------------------
!
!  right most arg. : 0=d(D_EE), 1=d(D_OO)
!  dsf_unprec_dd(w, w1, w2,  step, a, b, id, 1)
!
!  d(D_EO) and d(D_OE) contribute both E and O domain so, this routine does not 
!  have right most arg.
!  dsf_unprec_bb(w, w1, w2,  step, a, b, id)
!
!-------------------------------------------------------------------------------
subroutine dsf_sum_hh(w, w1, w2, step, ina, inb, id)
  use module_vol
  use module_dd
  implicit none

  GAUGE_FIELD,     intent(inout) :: w, w1, w2
  REAL,            intent(in)    :: step
  COMPLEX, dimension (4,3,ld%lat%volh, gd%lat%volh,0:1):: ina, inb
  COMPLEX, dimension (4,3,ld%lat%volh, 0:ld%lat%num_ip-1,0:1):: a,b,bt,tmp,bbt,at
  integer,intent(in) :: id

!!  TIMING2_START(timing2_bin_dsf_sum)
  DEBUG2S("Start: dsf_sum_hh")

  a=0
  b=0
  call ddsc_undcmp(a(1,1,1,0,0), ina(1,1,1,1,0), 0)
  call ddsc_undcmp(a(1,1,1,0,1), ina(1,1,1,1,1), 0)
  call ddsc_undcmp(b(1,1,1,0,0), inb(1,1,1,1,0), 0)
  call ddsc_undcmp(b(1,1,1,0,1), inb(1,1,1,1,1), 0)


  !
  !  need to calulate
  !
  !1.  (Dd_EE^-1)b, d(D_EE)  (D_EE^-1 D_EO D_OO^-1 D_OE)a
  !2.  (Dd_EE^-1)b, d(D_EO)  (             D_OO^-1 D_OE)a
  !
  !3.  (Dd_OO^-1 Dd_OE Dd_EE^-1)b, d(D_OO)(D_OO^-1 D_OE)a
  !4.  (Dd_OO^-1 Dd_OE Dd_EE^-1)b, d(D_OE)              a

  !! 
  !! calculate bt=Dd_EE^-1 b
  !!
  call inv_unprec_mdag_dd( bt,  b, id, 0,.false.)

  !!
  !! calculate bbt=Dd_OO^-1 Dd_OE Dd_EE^-1 b
  !!
  call     unprec_mdag_bb(tmp, bt, id, 1)
  call inv_unprec_mdag_dd(bbt,tmp, id, 1,.false.)

  !!
  !! calculate 4.
  !!
  call dsf_unprec_bb(w, w1, w2, -step, a, bbt, id)

  !! 
  !! calculate 3. and
  !! a = D_OO^-1 D_OE a
  !!
  call     unprec_mmul_bb(tmp, a, id, 1)
  call inv_unprec_mmul_dd(at,tmp, id, 1,.false.)
  !!                                           here 1 meas derivation at ODD domain
  call dsf_unprec_dd(w, w1, w2,  step, at, bbt, id, 1)


  !!
  !! calculate 2. and
  !!
  call dsf_unprec_bb(w, w1, w2, -step, at,bt, id)

  !!
  !! calculate 1.
  !!
  call     unprec_mmul_bb(tmp,  at, id, 0)
  call inv_unprec_mmul_dd( at, tmp, id, 0,.false.)
  call dsf_unprec_dd(w, w1, w2,  step,  at,bt, id, 0)

  DEBUG2S("End: dsf_sum_hh")
!!  TIMING2_STOP(timing2_bin_dsf_sum)
end

!-------------------------------------------------------------------------------
!
!  right most arg. : 0=d(D_EE), 1=d(D_OO)
!  dsf_unprec_dd(w, w1, w2,  step, a, b, id, 1)
!
!  d(D_EO) and d(D_OE) contribute both E and O domain so, this routine does not 
!  have right most arg.
!  dsf_unprec_bb(w, w1, w2,  step, a, b, id)
!
!-------------------------------------------------------------------------------
subroutine dsf_sum_hh2(w, w1, w2, step, ina, inb, id)
  use module_vol
  use module_dd
  implicit none

  GAUGE_FIELD,     intent(inout) :: w, w1, w2
  REAL,            intent(in)    :: step
  COMPLEX, dimension (4,3,ld%lat%volh, gd%lat%volh,0:1):: ina, inb
  COMPLEX, dimension (4,3,ld%lat%volh, 0:ld%lat%num_ip-1,0:1):: a,b,bt,tmp,bbt,at
  integer,intent(in) :: id

!!  TIMING2_START(timing2_bin_dsf_sum)
  DEBUG2S("Start: dsf_sum_hh")

  a=0
  b=0
  call ddsc_undcmp(a(1,1,1,0,0), ina(1,1,1,1,0), 0)
  call ddsc_undcmp(a(1,1,1,0,1), ina(1,1,1,1,1), 0)
  call ddsc_undcmp(b(1,1,1,0,0), inb(1,1,1,1,0), 0)
  call ddsc_undcmp(b(1,1,1,0,1), inb(1,1,1,1,1), 0)


  !
  !  need to calulate
  !
  !1.  (Dd_EE^-1)b, d(D_EE)  (D_EE^-1 D_EO D_OO^-1 D_OE)a
  !2.  (Dd_EE^-1)b, d(D_EO)  (             D_OO^-1 D_OE)a
  !
  !3.  (Dd_OO^-1 Dd_OE Dd_EE^-1)b, d(D_OO)(D_OO^-1 D_OE)a
  !4.  (Dd_OO^-1 Dd_OE Dd_EE^-1)b, d(D_OE)              a

  !! 
  !! calculate bt=Dd_EE^-1 b
  !!
  call inv_unprec_mdag_dd( bt,  b, id, 0,.false.)

  !!
  !! calculate bbt=Dd_OO^-1 Dd_OE Dd_EE^-1 b
  !!
  call     unprec_mdag_bb(tmp, bt, id, 1)
  call inv_unprec_mdag_dd(bbt,tmp, id, 1,.false.)

  !!
  !! calculate 4.
  !!
  call dsf_unprec_bb(w, w1, w2, -step, a, bbt, id)

  !! 
  !! calculate 3. and
  !! a = D_OO^-1 D_OE a
  !!
  call     unprec_mmul_bb(tmp, a, id, 1)
  call inv_unprec_mmul_dd(at,tmp, id, 1,.false.)
  !!                                           here 1 meas derivation at ODD domain
  call dsf_unprec_dd(w, w1, w2,  step, at, bbt, id, 1)


  !!
  !! calculate 2. and
  !!
  call dsf_unprec_bb(w, w1, w2, -step, at,bt, id)

  !!
  !! calculate 1.
  !!
  call     unprec_mmul_bb(tmp,  at, id, 0)
  call inv_unprec_mmul_dd( at, tmp, id, 0,.false.)
  call dsf_unprec_dd(w, w1, w2,  step,  at,bt, id, 0)

  DEBUG2S("End: dsf_sum_hh")
!!  TIMING2_STOP(timing2_bin_dsf_sum)
end

!-------------------------------------------------------------------------------
subroutine dsf_unprec_dd(w, w1, w2, step, a, b, id, dm)
  use module_dd
  use module_action
  use module_field
  use module_function_decl
  use module_usc_dd
  use module_vol
  implicit none

  GAUGE_FIELD, intent(inout) :: w, w1, w2
  REAL,        intent(in)    :: step
  COMPLEX, dimension (4,3,ld%lat%volh, 0:ld%lat%num_ip-1,0:1):: a,b, tmp,tmp1
  integer,intent(in) :: id, dm
  REAL :: s, s1
  integer :: ip

  s  = -step*TWO* action%mtilde(id)%kappa
  s1 = -step*TWO*(action%mtilde(id)%cswkappa / EIGHT)*action%mtilde(id)%kappa
  tmp = b
  if (s1 /= ZERO) then
     do ip = 0,ld%lat%num_ip-1
     if (eo_dm(ip) == dm) then
     call clover_mult_ao(clover_dd(action%mtilde(id)%cid,ip)%i(1,1,EVEN),tmp(1,1,1,ip,EVEN),ld%lat%volh)
     call clover_mult_ao(clover_dd(action%mtilde(id)%cid,ip)%i(1,1,ODD ),tmp(1,1,1,ip,ODD ),ld%lat%volh)
     endif
     enddo
  endif
  call dsf_xyztfb_dd_w(w, gauge(2)%u(1,1,1,0,1), s, &
                       a(1,1,1,0,0), tmp(1,1,1,0,0), &
                       a(1,1,1,0,1), tmp(1,1,1,0,1), EVEN, dm)
  if (s1 /= ZERO) then
     do ip = 0,ld%lat%num_ip-1
     if (eo_dm(ip) == dm) then
        call d_dd(ODD, EVEN, tmp1(1,1,1,ip,ODD ), a(1,1,1,ip,EVEN), ip)
        call d_dd(EVEN, ODD, tmp1(1,1,1,ip,EVEN), a(1,1,1,ip,ODD ), ip)
        call clover_mult_ao(clover_dd(action%mtilde(id)%cid,ip)%i(1,1,EVEN),tmp1(1,1,1,ip,EVEN),ld%lat%volh)
        call clover_mult_ao(clover_dd(action%mtilde(id)%cid,ip)%i(1,1,ODD ),tmp1(1,1,1,ip,ODD ),ld%lat%volh)
     endif
     enddo
        call clover_bsa_dd_w(w1, s1, tmp(1,1,1,0,0), tmp1(1,1,1,0,0),EVEN ,dm)
        call clover_bsa_dd_w(w2, s1, tmp(1,1,1,0,1), tmp1(1,1,1,0,1),ODD  ,dm)
  endif
end

!-------------------------------------------------------------------------------
subroutine dsf_unprec_bb(w, w1, w2, step, a, b, id)
  use module_dd
  use module_action
  use module_field
  use module_function_decl
  use module_usc_dd
  use module_vol
  implicit none

  GAUGE_FIELD, intent(inout) :: w, w1, w2
  REAL,        intent(in)    :: step
  COMPLEX, dimension (4,3,ld%lat%volh, 0:ld%lat%num_ip-1,0:1):: a,b, tmp,tmp1
  COMPLEX, dimension (4,3,ld%lat%volh, gd%lat%volh):: ttt
  integer,intent(in) :: id
  REAL :: s, s1
  integer :: ip

  s  = -step*TWO* action%mtilde(id)%kappa
  s1 = -step*TWO*(action%mtilde(id)%cswkappa / EIGHT)*action%mtilde(id)%kappa
  tmp = b
  if (s1 /= ZERO) then
     do ip = 0,ld%lat%num_ip-1
     call clover_mult_ao(clover_dd(action%mtilde(id)%cid,ip)%i(1,1,EVEN),tmp(1,1,1,ip,EVEN),ld%lat%volh)
     call clover_mult_ao(clover_dd(action%mtilde(id)%cid,ip)%i(1,1,ODD ),tmp(1,1,1,ip,ODD ),ld%lat%volh)
     enddo
  endif
  call dsf_xyztfb_bb_w(w, gauge(2)%u(1,1,1,0,1), s, &
                       a(1,1,1,0,0), tmp(1,1,1,0,0), &
                       a(1,1,1,0,1), tmp(1,1,1,0,1), EVEN, 2)
  if (s1 /= ZERO) then
!     do ip = 0,ld%lat%num_ip-1
!        call ddsc_dcmp(ttt,a(1,1,1,0,EVEN), 1-eo_dm(ip))
!        call d_eo(ODD, EVEN, tmp1(1,1,1,ip,ODD ), ttt, ip)
!        call ddsc_dcmp(ttt,a(1,1,1,0,ODD ), 1-eo_dm(ip))
!        call d_eo(EVEN, ODD, tmp1(1,1,1,ip,EVEN), ttt, ip)
!        call clover_mult_ao(clover_dd(action%mtilde(id)%cid,ip)%i(1,1,EVEN),tmp1(1,1,1,ip,EVEN),ld%lat%volh)
!        call clover_mult_ao(clover_dd(action%mtilde(id)%cid,ip)%i(1,1,ODD ),tmp1(1,1,1,ip,ODD ),ld%lat%volh)
!     enddo


     do ip = 0,ld%lat%num_ip-1
        if (eo_dm(ip)==0 )then
        call ddsc_dcmp(ttt,a(1,1,1,0,EVEN), 1-eo_dm(ip))
        call d_eo(ODD, EVEN, tmp1(1,1,1,ip,ODD ), ttt, ip)
        call ddsc_dcmp(ttt,a(1,1,1,0,ODD ), 1-eo_dm(ip))
        call d_eo(EVEN, ODD, tmp1(1,1,1,ip,EVEN), ttt, ip)
        call clover_mult_ao(clover_dd(action%mtilde(id)%cid,ip)%i(1,1,EVEN),tmp1(1,1,1,ip,EVEN),ld%lat%volh)
        call clover_mult_ao(clover_dd(action%mtilde(id)%cid,ip)%i(1,1,ODD ),tmp1(1,1,1,ip,ODD ),ld%lat%volh)
        endif
     enddo
     do ip = 0,ld%lat%num_ip-1
        if (eo_dm(ip)==1 )then
        call ddsc_dcmp(ttt,a(1,1,1,0,EVEN), 1-eo_dm(ip))
        call d_eo(ODD, EVEN, tmp1(1,1,1,ip,ODD ), ttt, ip)
        call ddsc_dcmp(ttt,a(1,1,1,0,ODD ), 1-eo_dm(ip))
        call d_eo(EVEN, ODD, tmp1(1,1,1,ip,EVEN), ttt, ip)
        call clover_mult_ao(clover_dd(action%mtilde(id)%cid,ip)%i(1,1,EVEN),tmp1(1,1,1,ip,EVEN),ld%lat%volh)
        call clover_mult_ao(clover_dd(action%mtilde(id)%cid,ip)%i(1,1,ODD ),tmp1(1,1,1,ip,ODD ),ld%lat%volh)
        endif
     enddo
     call clover_bsa_dd_w(w1, s1, tmp(1,1,1,0,0), tmp1(1,1,1,0,0),EVEN ,2)
     call clover_bsa_dd_w(w2, s1, tmp(1,1,1,0,1), tmp1(1,1,1,0,1),ODD  ,2)
  endif
end

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