!===============================================================================
!
!  dd_solver.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"

!-------------------------------------------------------------------------------
!
! Naive way, was used to check that subroutines work correctly
!
!-------------------------------------------------------------------------------
subroutine dd_solve(mid, zeta_e, zeta_o, eta_e, eta_o)
  use module_field
  use module_action
  use module_function_decl
  use module_p_interface
  use module_vol
  use module_dd
  implicit none

  SPINCOL_FIELD :: eta_e, eta_o, zeta_e, zeta_o
  P_SPINCOL_FIELD, save :: te, to
  integer :: mid, i, col, mu,iter
  
  COMPLEX, dimension(4,NCOL,ld%lat%volh,0:ld%lat%num_ip-1,EVEN:ODD):: &
                     ddsc, ddsc_tmp, ddsc_tmp1, ddsc_tmp2
  COMPLEX, dimension(4,NCOL,ld%lat%volh,gd%lat%volh,EVEN:ODD):: &
                     hddsc, hddsc_tmp
  REAL::res

  if(.not. ddable) return

  ddsc=0
  ddsc_tmp=0
  ddsc_tmp1=0
  ddsc_tmp2=0

  ALLOCATE_SC_FIELD(te)
  ALLOCATE_SC_FIELD(to)

  te=eta_e
  to=eta_o
  if (action%mtilde(mid)%cswkappa /= ZERO) then
     call clover_mult_ao(clover(action%mtilde(mid)%cid)%cfield%i(1,1,se), te, volh)
     call clover_mult_ao(clover(action%mtilde(mid)%cid)%cfield%i(1,1,so), to, volh)
  endif
  call sc2ddsc(ddsc, te, to)

  !
  ! ddsc_tmpE = DEE^-1 ddscE
  ! ddsc_tmpO = DOO^-1 ddscO
  !
  call inv_unprec_mmul_dd( ddsc_tmp, ddsc, mid, 2,.false.) ! ok
  !
  ! ddsc_tmp2E = DEE^-1 DEO ddsc_tmpO
  !
  call     unprec_mmul_bb( ddsc_tmp1, ddsc_tmp,  mid, 0)
  call inv_unprec_mmul_dd( ddsc_tmp2, ddsc_tmp1, mid, 0,.false.)
  !
  ! ddsc_tmpE = ddsc_tmp - dsc_tmp2
  !           = DEE^-1 ddscE - DEE^-1 DEO ddsc_tmpO
  !           = DEE^-1 ddscE - DEE^-1 DEO DOO^-1 ddscO
  ! ddsc_tmpO = DOO^-1 ddscO
  !
  call ddsc_sub_eo(ddsc_tmp, ddsc_tmp2, 0)
  !
  ! ddscE = \hatDEE^-1 ddsc_tmpE
  ! ddscO = ddsc_tmpO
  !


  call ddsc_dcmp(hddsc(1,1,1,1,0),ddsc_tmp(1,1,1,0,0),EVEN)
  call ddsc_dcmp(hddsc(1,1,1,1,1),ddsc_tmp(1,1,1,0,1),EVEN)

  call unprec_hdag(hddsc_tmp, hddsc, mid)
  call cg_hh_outer(hddsc, hddsc_tmp, mid, 0, CG_MC)                  ! ok

  call ddsc_undcmp(ddsc(1,1,1,0,0),hddsc(1,1,1,1,0),EVEN)
  call ddsc_undcmp(ddsc(1,1,1,0,1),hddsc(1,1,1,1,1),EVEN)

  call ddsc_copy_eo(ddsc,ddsc_tmp, 1)                          !!!! need
  !
  ! ddsc_tmp2O = DOO^-1 DOE ddscE
  !
  call     unprec_mmul_bb( ddsc_tmp1, ddsc,      mid, 1)
  call inv_unprec_mmul_dd( ddsc_tmp2, ddsc_tmp1, mid, 1, .false.)

  call ddsc_sub_eo(ddsc, ddsc_tmp2, 1)
  call ddsc2sc(zeta_e, zeta_o, ddsc)

end

!-------------------------------------------------------------------------------
!
! SAP+GCR wrapper
!
!-------------------------------------------------------------------------------
subroutine dd_solve2(mid, xe, xo, be, bo, restflag)
  use module_vol
  use module_dd
  use module_usc_dd
  use module_action
  implicit none
  SPINCOL_OVERINDEXED :: xe, xo, be, bo
  integer, intent(in) :: mid, restflag
  COMPLEX, dimension(4,3,ld%lat%volh,0:ld%lat%num_ip-1,0:1):: ddb, ddx
  integer :: ip
  SECONDS :: time0, sekunden, time

time0=sekunden()

  if(.not. ddable) return
  call sc2ddsc(ddb, be, bo)
  call sc2ddsc(ddx, xe, xo)

  if (action%mtilde(mid)%cswkappa /= ZERO) then
  do ip = 0, ld%lat%num_ip-1
     call clover_mult_ao(clover_dd(action%mtilde(mid)%cid,ip)%i(1,1,se), ddb(1,1,1,ip,se), ld%lat%volh)
     call clover_mult_ao(clover_dd(action%mtilde(mid)%cid,ip)%i(1,1,so), ddb(1,1,1,ip,so), ld%lat%volh)
  enddo
  endif

  call invd_sapgcr(ddx, ddb, mid, 0, restflag)
  call ddsc2sc(xe, xo, ddx)

  time=sekunden()-time0
  write(0,*)"time for dd_solver2",time

!stop

end

!-------------------------------------------------------------------------------
!
! DFL+SAP+GCR
!
!-------------------------------------------------------------------------------
subroutine invd_sapgcr(out, in, mid, dag, restflag)
  use module_field
  use module_action
  use module_function_decl
  use module_cg
  use module_vol
  use module_dd
  use module_input
  implicit none
  integer, intent(in) :: mid, dag, restflag
  !
  !         ordering 4,3,ld%lat%volh,0:ld%lat%num_ip-1,0:1
  !
  COMPLEX, dimension(12*ld%lat%volh*ld%lat%num_ip*2):: in, out, tmp, pin
  COMPLEX, dimension(12*ld%lat%volh*ld%lat%num_ip*2):: ddr, ddb, ddx
  COMPLEX, dimension(12*ld%lat%volh*ld%lat%num_ip*2,input%solver_defsapgcr_nkv):: ddp,dds
  integer :: i, l, k, cid, ip
  REAL::res, bk, bb, rtr, rtr0
  COMPLEX :: alk, ck 
  REAL, external :: ddsc_norm2_eo
  COMPLEX,external :: ddsc_cdotc_eo
  REAL :: kappac

  if(.not. ddable) return
  call get_cg_res(res, restflag)
  msap=.true.

  call projectl(ddb,in)
  call project(pin,in)

  bb = ddsc_norm2_eo(ddb, 2)
  call global_sum_vec(1, bb)

  ddx=ddb

!!  call unprec_d(ddr, ddx, mid, dag)
  call unprec_d(tmp, ddx, mid, dag)
  call projectl(ddr,tmp)

  ddr = ddb - ddr

  rtr = ddsc_norm2_eo(ddr, 2)
  call global_sum_vec(1, rtr)

  if (stop_condition(rtr, res, bb)) goto 9999
  rtr0=rtr

  do i=1,50
  do k = 1, input%solver_defsapgcr_nkv
     call sap_op(dds(:,k), ddr, mid, dag)

     ! D_apply
!     call unprec_d(ddp(:,k), dds(:,k), mid, dag)
     call unprec_d(tmp, dds(:,k), mid, dag)
     call projectl(ddp(:,k),tmp)

     do l = 1, k-1
        ! alk=(xk,xl)
        alk = ddsc_cdotc_eo(ddp(:,k),ddp(:,l),2) ; call global_sum_vec(2, alk)
        ddp(:,k) = ddp(:,k) - alk * ddp(:,l)
        dds(:,k) = dds(:,k) - alk * dds(:,l)
     enddo

     bk = ddsc_norm2_eo(ddp(:,k), 2) ; call global_sum_vec(1, bk)
     bk=ONE/sqrt(bk)
     ddp(:,k) = ddp(:,k) * bk
     dds(:,k) = dds(:,k) * bk

     ck = ddsc_cdotc_eo(ddr,ddp(:,k),2) ; call global_sum_vec(2, ck)
     ddx(:) = ddx(:) + ck * dds(:,k)
     ddr(:) = ddr(:) - ck * ddp(:,k)

     rtr = ddsc_norm2_eo(ddr, 2)
     call global_sum_vec(1, rtr)
     if (stop_condition(rtr, res, bb)) goto 9999
!!     write(0,*)"gcrin",k,sqrt(rtr/bb)
  enddo
!     call unprec_d(ddr, ddx, mid, dag)
     call unprec_d(tmp, ddx, mid, dag)
     call projectl(ddr,tmp)
     ddr = ddb - ddr
     rtr = ddsc_norm2_eo(ddr, 2)
     call global_sum_vec(1, rtr)
     if(my_pe()==0)write(0,*)"gcrout",i,rtr,sqrt(rtr/bb)
     if (stop_condition(rtr, res, bb)) goto 9999
  enddo

  9999 msap=.false.
!out=ddx

!!write(0,*)"original ddx",ddx(1)
  call projectr(out,ddx)
!!write(0,*)"projectr x ddx",out(1)
!!  ddx=out
!!  call projectr(out,ddx)
!!write(0,*)"projectr x projectr x ddx",out(1)

  out=out +pin
  

end

!-------------------------------------------------------------------------------
subroutine invh(out, in, mid, restflag)
  use module_dd
  integer, intent(in) :: mid, restflag
  COMPLEX, dimension(4,3,ld%lat%volh,gd%lat%volh,0:1) :: out, in
  COMPLEX, dimension(4,3,ld%lat%volh,0:ld%lat%num_ip-1,0:1):: tmp, ddb, ddx

  ddb=0
  call ddsc_undcmp(ddb(1,1,1,0,0), in(1,1,1,1,0), EVEN)
  call ddsc_undcmp(ddb(1,1,1,0,1), in(1,1,1,1,1), EVEN)

  call unprec_mmul_bb(tmp, ddb, mid,1)
  call invd_sapgcr(ddx, tmp, mid, 0, restflag)
  ddx = ddb - ddx

  call ddsc_dcmp(out(1,1,1,1,0),ddx(1,1,1,0,0),EVEN)
  call ddsc_dcmp(out(1,1,1,1,1),ddx(1,1,1,0,1),EVEN)

end

!-------------------------------------------------------------------------------
subroutine invhdag(out, in, mid, restflag)
  use module_dd
  use module_usc_dd
  use module_action
  integer, intent(in) :: mid, restflag
  COMPLEX, dimension(4,3,ld%lat%volh, gd%lat%volh,0:1) :: out, in
  COMPLEX, dimension(4,3,ld%lat%volh,0:ld%lat%num_ip-1,0:1):: tmp, ddb, ddx
  integer :: ip

  ddb=ZERO
  call ddsc_undcmp(ddb(1,1,1,0,0), in(1,1,1,1,0), EVEN)
  call ddsc_undcmp(ddb(1,1,1,0,1), in(1,1,1,1,1), EVEN)

  call invd_sapgcr(tmp, ddb, mid, 1, restflag)
  call unprec_mdag_dd(ddx, tmp, mid)

  call ddsc_dcmp(out(1,1,1,1,0),ddx(1,1,1,0,0),EVEN)
  call ddsc_dcmp(out(1,1,1,1,1),ddx(1,1,1,0,1),EVEN)

end

!-------------------------------------------------------------------------------
subroutine sap_op(out, in, mid, dag)
  use module_dd
  use module_input
  implicit none
  integer :: mid, dag, i
  complex(8), dimension(4,3,ld%lat%volh,0:ld%lat%num_ip-1,0:1), intent(in) :: in
  complex(8), dimension(4,3,ld%lat%volh,0:ld%lat%num_ip-1,0:1), intent(out):: out
  complex(4), dimension(4,3,ld%lat%volh,0:ld%lat%num_ip-1,0:1):: &
                     x, tmp, a,out4
  if(.not. ddable) return

  a=in ;  x=in
  do i = 1, input%solver_defsapgcr_nsp
     call sap_k0_r4(out4, a, mid, dag)
     call unprec_d_r4(tmp, out4, mid, dag)
     a = a - tmp + x
!     x = x + a
!     a = x
  enddo
  call sap_k0_r4(out4, a, mid, dag)
  out=out4

end

!-------------------------------------------------------------------------------
subroutine sap_op2(out, in, mid, dag)
  use module_dd
  use module_input
  implicit none
  integer :: mid, dag, i
  complex(8), dimension(4,3,ld%lat%volh,0:ld%lat%num_ip-1,0:1), intent(in) :: in
  complex(8), dimension(4,3,ld%lat%volh,0:ld%lat%num_ip-1,0:1), intent(out):: out
  complex(4), dimension(4,3,ld%lat%volh,0:ld%lat%num_ip-1,0:1):: &
                     x, tmp, a,out4
  if(.not. ddable) return

  a=in ;  x=in; out4=0
  do i = 1, input%solver_defsapgcr_nsp
     call sap_k2_r4(out4, x, mid, dag)
  enddo
  out=out4

end

!-------------------------------------------------------------------------------
subroutine sap_k0_r4(out, in, mid, dag)
  use module_dd
  implicit none
  integer, intent(in) :: mid, dag
  
  complex(4), dimension(4,NCOL,ld%lat%volh,0:ld%lat%num_ip-1,EVEN:ODD):: in, out, tmp

  if(.not. ddable) return
  if (dag==0) then
     call inv_unprec_mmul_dd_r4(out,   in, mid, 0,.false.) ! Dee^-1 in, in
     call     unprec_mmul_bb_r4(tmp,  out, mid, 1) ! Dee^-1 in, DoeDee^-1 in
     call ddsc_sub2_eo_r4(tmp, in, 1)
     call ddsc_copy_eo_r4(tmp,out, 0)
     call inv_unprec_mmul_dd_r4(out,  tmp, mid, 1,.false.)
   else
     call inv_unprec_mdag_dd_r4(out,   in, mid, 0,.false.) ! Dee^-1 in, in
     call     unprec_mdag_bb_r4(tmp,  out, mid, 1) ! Dee^-1 in, DoeDee^-1 in
     call ddsc_sub2_eo_r4(tmp, in, 1)
     call ddsc_copy_eo_r4(tmp,out, 0)
     call inv_unprec_mdag_dd_r4(out,  tmp, mid, 1,.false.)
   endif
end

!-------------------------------------------------------------------------------
subroutine sap_k2_r4(out, in, mid, dag)
  use module_dd
  implicit none
  integer, intent(in) :: mid, dag
  
  complex(4), dimension(4,NCOL,ld%lat%volh,0:ld%lat%num_ip-1,EVEN:ODD):: in, out, tmp, tmp2

  if(.not. ddable) return
!  call unprec_d_r4(tmp, out, mid, dag)
!  tmp=in-tmp
!  call inv_unprec_mmul_dd_r4(tmp2,   tmp, mid, 2,.false.)
!  out=in+tmp2
  call inv_unprec_mmul_dd_r4(out,   in, mid, 2,.false.)

end

!-------------------------------------------------------------------------------
subroutine unprec_d(out, in, mid, dag)
  use module_dd
  implicit none
  integer, intent(in) :: mid, dag
  
  complex(8), dimension(4,NCOL,ld%lat%volh,0:ld%lat%num_ip-1,EVEN:ODD):: in, out
  complex(8), dimension(4,NCOL,ld%lat%volh,0:ld%lat%num_ip-1,EVEN:ODD):: tmp

  if(.not. ddable) return
  if (dag==0) then
     call unprec_mmul_dd( out, in, mid)
     call unprec_mmul_bb( tmp, in, mid, 1)
     call ddsc_add_eo(out, tmp, 1)
     call unprec_mmul_bb( tmp, in, mid, 0)
     call ddsc_add_eo(out, tmp, 0)
  else
     call unprec_mdag_dd( out, in, mid)
     call unprec_mdag_bb( tmp, in, mid, 1)
     call ddsc_add_eo(out, tmp, 1)
     call unprec_mdag_bb( tmp, in, mid, 0)
     call ddsc_add_eo(out, tmp, 0)
  endif
end

!-------------------------------------------------------------------------------
subroutine unprec_d_r4(out, in, mid, dag)
  use module_dd
  implicit none
  integer, intent(in) :: mid, dag
  
  complex(4), dimension(4,NCOL,ld%lat%volh,0:ld%lat%num_ip-1,EVEN:ODD):: in, out
  complex(4), dimension(4,NCOL,ld%lat%volh,0:ld%lat%num_ip-1,EVEN:ODD):: tmp

  if(.not. ddable) return
  if (dag==0) then
     call unprec_mmul_dd_r4( out, in, mid)
     call unprec_mmul_bb_r4( tmp, in, mid, 1)
     call ddsc_add_eo_r4(out, tmp, 1)
     call unprec_mmul_bb_r4( tmp, in, mid, 0)
     call ddsc_add_eo_r4(out, tmp, 0)
   else
     call unprec_mdag_dd_r4( out, in, mid)
     call unprec_mdag_bb_r4( tmp, in, mid, 1)
     call ddsc_add_eo_r4(out, tmp, 1)
     call unprec_mdag_bb_r4( tmp, in, mid, 0)
     call ddsc_add_eo_r4(out, tmp, 0)
   endif
end

!-------------------------------------------------------------------------------
!
! SSOR+GCR for block inversion
!
!-------------------------------------------------------------------------------
subroutine invd_ssorgcr(ddx, ddb, mid, ip, dag, restflag)
  use module_field
  use module_action
  use module_function_decl
  use module_cg
  use module_vol
  use module_dd
  use vec
  implicit none
  integer, parameter :: ngcr = 10
  integer, intent(in) :: mid, ip, dag, restflag
  !
  !         ordering 4,3,ld%lat%volh,0:1
  !
  COMPLEX, dimension(12*ld%lat%volh*2),intent(inout):: ddx
  COMPLEX, dimension(12*ld%lat%volh*2),target       :: ddb
  COMPLEX, dimension(12*ld%lat%volh*2),target       :: ddr

  COMPLEX, dimension(12*ld%lat%volh*2,ngcr), target :: ddp,dds
  complex(8),pointer :: tmp(:), tmp1(:)

  integer :: i, l, k
  REAL::res, bk, bb, rtr, rtr0
  COMPLEX :: alk, ck 

  if(.not. ddable) return
  call get_cg_res(res, restflag)
!-----------------------------------------------------------

  tmp=>ddb
  bb = vec_norm2_c8(tmp)

  ddx=ddb
  call unprec_mmul_d(ddr, ddx, mid, ip, dag)
  ddr = ddb - ddr

  tmp=>ddr
  rtr = vec_norm2_c8(tmp)

  if (stop_condition(rtr, res, bb)) goto 9999
  rtr0=rtr

  do i=1,20
  do k = 1, ngcr
     call ssor_op(dds(:,k), ddr, mid, ip, dag)
     ! D_apply
     call unprec_mmul_d(ddp(:,k), dds(:,k), mid, ip, dag)
     do l = 1, k-1
        ! alk=(xk,xl)
        tmp=>ddp(:,k)
        tmp1=>ddp(:,l)

        alk = vec_cdotc_c8(tmp,tmp1)
        ddp(:,k) = ddp(:,k) - alk * ddp(:,l)
        dds(:,k) = dds(:,k) - alk * dds(:,l)
     enddo
     tmp=>ddp(:,k)
     bk = vec_norm2_c8(tmp)
     bk=ONE/sqrt(bk)
     ddp(:,k) = ddp(:,k) * bk
     dds(:,k) = dds(:,k) * bk
     tmp=>ddr
     tmp1=>ddp(:,k)
     ck = vec_cdotc_c8(tmp,tmp1)
     ddx(:) = ddx(:) + ck * dds(:,k)
     ddr(:) = ddr(:) - ck * ddp(:,k)
     tmp=>ddr
     rtr = vec_norm2_c8(tmp)
     if (stop_condition(rtr, res, bb)) goto 9999
  enddo
     call unprec_mmul_d(ddr, ddx, mid, ip, dag)
     ddr = ddb - ddr
     tmp=>ddr
     rtr = vec_norm2_c8(tmp)
     if (stop_condition(rtr, res, bb)) goto 9999
  enddo
  if(my_pe()==0)write(0,*)"ssorgcr did not converge",i,rtr
  stop

  9999 continue
  call update_cg_stat(dd_stat, i*(ngcr+1)+k, 0)
end

!-------------------------------------------------------------------------------
subroutine unprec_mmul_d(out, in, id, ip, dag)
  use module_dd
  use module_action
  implicit none
  COMPLEX, dimension (NDIRAC,NCOL, ld%lat%volh, 0:1) :: in
  COMPLEX, dimension (NDIRAC,NCOL, ld%lat%volh, 0:1) :: out
  integer,intent(in) :: id, ip, dag
  DEBUG2S("Start: unprec_mmul_d")

  if (dag==0) then
  call mmul_dd(out(1,1,1,se), in(1,1,1,so), so ,id, ip)
  call mmul_dd(out(1,1,1,so), in(1,1,1,se), se ,id, ip)
  else
  call mdag_dd(out(1,1,1,se), in(1,1,1,so), so ,id, ip)
  call mdag_dd(out(1,1,1,so), in(1,1,1,se), se ,id, ip)
  endif
  out=out+in
  DEBUG2S("End: unprec_mmul_dd")
end

!-------------------------------------------------------------------------------
subroutine ssor_op(out, in, mid, ip, dag)
  use module_dd
  use module_cg
  implicit none
  integer :: mid, dag, i, ip
  complex(8), dimension(4,3,ld%lat%volh,0:1), intent(in) :: in
  complex(8), dimension(4,3,ld%lat%volh,0:1), intent(out):: out
  complex(4), dimension(4,3,ld%lat%volh,0:1):: &
                     x, tmp, a,out4

  x=in
  call ssor_lu(a, x, 0, mid, ip, dag)
  x=a
  do i = 1, 4
     call ssor_dd(tmp, a, mid, ip, dag)
     a = a - tmp
     x = x + a
  enddo
  call ssor_lu(out4, x, 1, mid, ip, dag)
  out=out4
  call update_cg_stat(dd_stat, 0, 7)
end

!-------------------------------------------------------------------------------
subroutine ssor_op_r4(out, in, mid, ip, dag)
  use module_dd
  use module_cg
  implicit none
  integer :: mid, dag, i, ip
  complex(4), dimension(4,3,ld%lat%volh,0:1), intent(in) :: in
  complex(4), dimension(4,3,ld%lat%volh,0:1), intent(out):: out
  complex(4), dimension(4,3,ld%lat%volh,0:1):: &
                     x, tmp, a,out4

  x=in
  call ssor_lu(a, x, 0, mid, ip, dag)
  x=a
  do i = 1, 2
     call ssor_dd(tmp, a, mid, ip, dag)
     a = a - tmp
     x = x + a
  enddo
  call ssor_lu(out, x, 1, mid, ip, dag)
  call update_cg_stat(dd_stat, 0, 4)
end

!-------------------------------------------------------------------------------
subroutine ssor_dd(out, in, mid, ip, dag)
  use module_dd
  implicit none
  integer :: mid, dag, ip
  complex(4), dimension(4,3,ld%lat%volh,0:1), intent(in) :: in
  complex(4), dimension(4,3,ld%lat%volh,0:1), intent(out):: out
  complex(4), dimension(4,3,ld%lat%volh,0:1) :: tmp,tmp1
  real(4) :: omega, fac1, fac2

  omega=1.2
  fac2=1/omega
  fac1=1 - 2/omega

  call ssor_lu(tmp , in, 1, mid, ip, dag)
  call ssor_lu(tmp1, in, 0, mid, ip, dag)
  tmp1=tmp
  call ssor_lu(out,tmp, 0, mid, ip, dag)
  out = fac1 * out  + fac2 * tmp1 
end
!-------------------------------------------------------------------------------
subroutine ssor_lu(out, in, eo, mid, ip, dag)
  use module_usc_dd
  use module_dd
  use module_action
  implicit none
  integer :: eo, mid, dag, i, ip
  complex(4), dimension(4,3,ld%lat%volh,0:1), intent(in) :: in
  complex(4), dimension(4,3,ld%lat%volh,0:1), intent(out):: out
  complex(4), dimension(4,3,ld%lat%volh) :: tmp

  if(dag==0) then
     out(:,:,:,eo)=in(:,:,:,eo)
     call d_dd_r4(1-eo, eo, out(1,1,1,1-eo), in(1,1,1,eo), ip)
     if (action%mtilde(mid)%cid /=0)then
        call clover_mult_ao_r4(clover_dd_r4(action%mtilde(mid)%cid,ip)%i(1,1, 1-eo), out(1,1,1,1-eo), ld%lat%volh)
     endif
     out(:,:,:,1-eo) = in(:,:,:,1-eo) + action%mtilde(mid)%kappa * 1.2 * out(:,:,:,1-eo)
  else
     out(:,:,:,eo)=in(:,:,:,eo)
     tmp(:,:,:)=in(:,:,:,eo)
     if (action%mtilde(mid)%cid /=0)then
        call clover_mult_ao_r4(clover_dd_r4(action%mtilde(mid)%cid,ip)%i(1,1, eo), tmp, ld%lat%volh)
     endif
     call d_dag_dd_r4(1-eo , eo, out(:,:,:,1-eo), tmp, ip)
  endif
  out(:,:,:,1-eo) = in(:,:,:,1-eo) + action%mtilde(mid)%kappa * 1.2 * out(:,:,:,1-eo)
end


!-------------------------------------------------------------------------------
subroutine test_mmul_mdag(mid)
  use module_field
  use module_action
  use module_function_decl
  use module_p_interface
  use module_vol
  use module_dd
  use module_usc_dd
  implicit none

  P_SPINCOL_FIELD, save :: eta_e, eta_o, zeta_e, zeta_o, te,to
  integer :: mid
  integer :: i, mu, col
  
  COMPLEX, dimension(4,NCOL,ld%lat%volh,0:ld%lat%num_ip-1,EVEN:ODD):: &
                     ddsc, ddsc_tmp,ddsc_tmp1,ddsc_tmp2

  COMPLEX, dimension(4,NCOL,ld%lat%volh,gd%lat%volh,EVEN:ODD):: &
                     hddsc, hddsc_tmp

  COMPLEX :: ctmp(10)

  if(.not. ddable) return

  call test_deflation()


  DEBUG2S("Start: test_mmul_mdag")

  ALLOCATE_SC_FIELD(te)
  ALLOCATE_SC_FIELD(to)
  ALLOCATE_SC_FIELD(eta_e)
  ALLOCATE_SC_FIELD(eta_o)
  ALLOCATE_SC_FIELD(zeta_e)
  ALLOCATE_SC_FIELD(zeta_o)

  call make_source(eta_e, eta_o, FULL_SOURCE)
  call sc2ddsc(ddsc, eta_e, eta_o)

  if (my_pe()==0)  write(0,*)"!!!!!!!!!!! Check mmul and mdag "
!---------------------------------------------------mul
  if (my_pe()==0)  write(0,*)"difference mmul"
!!  call unprec_mmul(te, to, eta_e, eta_o, mid) removed
  call unprec_mmul_dd( ddsc_tmp, ddsc, mid)
  call unprec_mmul_bb( ddsc_tmp1,ddsc, mid, 1)
  call unprec_mmul_bb( ddsc_tmp2,ddsc, mid, 0)
  call ddsc_add_eo(ddsc_tmp, ddsc_tmp1, 1)
  call ddsc_add_eo(ddsc_tmp, ddsc_tmp2, 0)
  call ddsc2sc(zeta_e, zeta_o, ddsc_tmp)
  call check_ddsc(te, to, zeta_e, zeta_o)
!---------------------------------------------------dag
  if (my_pe()==0)  write(0,*)"difference mdag"
!!  call unprec_mdag(te, to, eta_e, eta_o, mid) removed
  call unprec_mdag_dd(  ddsc_tmp,ddsc, mid)
  call unprec_mdag_bb( ddsc_tmp1,ddsc, mid, 1)   ! Mboe
  call unprec_mdag_bb( ddsc_tmp2,ddsc, mid, 0)   ! Mbeo
  call ddsc_add_eo(ddsc_tmp, ddsc_tmp1, 1)
  call ddsc_add_eo(ddsc_tmp, ddsc_tmp2, 0)
  call ddsc2sc(zeta_e, zeta_o, ddsc_tmp)
  call check_ddsc(te, to, zeta_e, zeta_o)
!--------------------------------------------------- Hermitian

  call unprec_mmul_dd( ddsc_tmp1, ddsc,      mid)
  call unprec_mdag_dd( ddsc_tmp2, ddsc_tmp1, mid)

  call ddsc2sc(zeta_e, zeta_o, ddsc_tmp2)

  ctmp(1) = sc_cdotc(zeta_e,eta_e) + sc_cdotc(zeta_o,eta_o)
  call global_sum_vec(2, ctmp(1))
  if (my_pe()==0)write(0,210)"check hermicity: mdag_dd mmul_dd   ","(",ctmp(1),")"

  call unprec_mmul_bb( ddsc_tmp1, ddsc,      mid,0)
  call unprec_mdag_bb( ddsc_tmp2, ddsc_tmp1, mid,1)
  call ddsc2sc(zeta_e, zeta_o, ddsc_tmp2)
  ctmp(1) = sc_cdotc(zeta_e,eta_e) + sc_cdotc(zeta_o,eta_o)
  call global_sum_vec(2, ctmp(1))
  if (my_pe()==0)write(0,210)"check hermicity: mdag_bb1 mmul_bb0 ","(",ctmp(1),")"

  call unprec_mmul_bb( ddsc_tmp1, ddsc,      mid,1)
  call unprec_mdag_bb( ddsc_tmp2, ddsc_tmp1, mid,0)
  call ddsc2sc(zeta_e, zeta_o, ddsc_tmp2)
  ctmp(1) = sc_cdotc(zeta_e,eta_e) + sc_cdotc(zeta_o,eta_o)
  call global_sum_vec(2, ctmp(1))
  if (my_pe()==0)write(0,210)"check hermicity: mdag_bb0 mmul_bb1 ","(",ctmp(1),")"

  call unprec_mmul_bb( ddsc_tmp1, ddsc,      mid,0)
  call unprec_mdag_bb( ddsc_tmp2, ddsc_tmp1, mid,0)
  call ddsc2sc(zeta_e, zeta_o, ddsc_tmp2)
  ctmp(1) = sc_cdotc(zeta_e,eta_e) + sc_cdotc(zeta_o,eta_o)
  call global_sum_vec(2, ctmp(1))
  if (my_pe()==0)write(0,210)"check hermicity: mdag_bb0 mmul_bb0 ","(",ctmp(1),")"

  call unprec_mmul_bb( ddsc_tmp1, ddsc,      mid,1)
  call unprec_mdag_bb( ddsc_tmp2, ddsc_tmp1, mid,1)
  call ddsc2sc(zeta_e, zeta_o, ddsc_tmp2)
  ctmp(1) = sc_cdotc(zeta_e,eta_e) + sc_cdotc(zeta_o,eta_o)
  call global_sum_vec(2, ctmp(1))
  if (my_pe()==0)write(0,210)"check hermicity: mdag_bb1 mmul_bb1 ","(",ctmp(1),")"

  call ddsc_dcmp(hddsc(1,1,1,1,0),ddsc(1,1,1,0,0),EVEN)
  call ddsc_dcmp(hddsc(1,1,1,1,1),ddsc(1,1,1,0,1),EVEN)
  call unprec_hdagh( hddsc_tmp, hddsc,      mid)
  call ddsc_undcmp(ddsc_tmp1(1,1,1,0,0),hddsc_tmp(1,1,1,1,0),EVEN)
  call ddsc_undcmp(ddsc_tmp1(1,1,1,0,1),hddsc_tmp(1,1,1,1,1),EVEN)
  call ddsc_copy_eo(ddsc_tmp1, ddsc, ODD)

  call ddsc2sc(zeta_e, zeta_o, ddsc_tmp1)
  ctmp(1) = sc_cdotc(zeta_e,eta_e) + sc_cdotc(zeta_o,eta_o)
  call global_sum_vec(2, ctmp(1))
  if (my_pe()==0)  write(0,210)"check hermicity: unprec_hdagh      ","(",ctmp(1),")"



!--------------------------------------------------- inv
!  if (my_pe()==0)  write(0,*)"check inv unprec_hmul"
!  call ddsc_dcmp(hddsc(1,1,1,1,0),ddsc(1,1,1,0,0),EVEN)
!  call ddsc_dcmp(hddsc(1,1,1,1,1),ddsc(1,1,1,0,1),EVEN)
!  write(0,*)hddsc(1,1,1,1,0),"ori"
!  write(0,*)hddsc(2,1,1,1,0),"ori"
!  write(0,*)hddsc(3,1,1,1,0),"ori"
!  write(0,*)hddsc(4,1,1,1,0),"ori"
!  call invh(hddsc_tmp,hddsc,mid,CG_MC)
!  hddsc=hddsc_tmp
!  call unprec_hmul( hddsc_tmp, hddsc,      mid)
!  write(0,*)hddsc_tmp(1,1,1,1,0),"h invh"
!  write(0,*)hddsc_tmp(2,1,1,1,0),"h invh"
!  write(0,*)hddsc_tmp(3,1,1,1,0),"h invh"
!  write(0,*)hddsc_tmp(4,1,1,1,0),"h invh"

!stop
!  if (my_pe()==0)  write(0,*)"check inv unprec_hdag"
!  call ddsc_dcmp(hddsc(1,1,1,1,0),ddsc(1,1,1,0,0),EVEN)
!  call ddsc_dcmp(hddsc(1,1,1,1,1),ddsc(1,1,1,0,1),EVEN)
!  write(0,*)hddsc(1,1,1,1,0),"ori"
!  call invhdag(hddsc_tmp, hddsc, mid, CG_MC)
!  hddsc=hddsc_tmp
!  call unprec_hdag( hddsc_tmp, hddsc,      mid)
!  write(0,*)hddsc_tmp(1,1,1,1,0),"hdag invhdag"

!stop

  DEBUG2S("End: test_mmul_mdag")
210 format (a,a1,2d20.10,a1)
end

!-------------------------------------------------------------------------------
subroutine check_ddsc(in2_e, in2_o, in1_e, in1_o)
  use module_vol
  use module_function_decl
  implicit none
  SPINCOL_FIELD :: in2_e, in2_o, in1_e, in1_o
  integer :: i, mu, col, count


  count = 0
  
  do i = 1,volh
  do col=1,3
  do mu=1,4
     if (abs(in2_e(mu,col,i)- in1_e(mu,col,i)) > 0.00001) then
        write(0,212)"dd e",i,col,mu, &
        "(",in2_e(mu,col,i)- in1_e(mu,col,i),")", &
        "(",in2_e(mu,col,i),                 ")", &
        "(",in1_e(mu,col,i),                 ")"
        count = count + 1
     endif
     if (abs(in2_o(mu,col,i)- in1_o(mu,col,i)) > 0.00001) then
        write(0,212)"dd o",i,col,mu, &
        "(",in2_o(mu,col,i)- in1_o(mu,col,i),")", &
        "(",in2_o(mu,col,i),                 ")", &
        "(",in1_o(mu,col,i),                 ")"
        count = count + 1
     endif
  enddo
  enddo
  enddo

  if (count == 0 .and. my_pe()==0) write(0,*)"check_ddsc : OK"

212 format (a4, 3i5, 3(a1,2f10.5,a1))

end

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