!===============================================================================
!
! cg_def.F90 - mixed precision cg
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 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 cg_def(x, b, id, ip, iter, res) 
  use module_function_decl
  use module_check_solution
  use module_dd_evec
  use module_action
  use module_mre2
  use mre2_get_interface  
  use module_cg
  use vec
  implicit none
  type(type_mre2), save :: solutions

  complex(8), dimension(12*ld%lat%volh),         intent(inout):: x
  complex(8), dimension(12*ld%lat%volh), target, intent(in)   :: b
  integer, intent(out):: iter
  integer, intent(in) :: id, ip
  REAL,    intent(in) :: res

  complex(8),pointer :: tmp(:)
  complex(8),target  :: r(size(x)),p(size(b)),pb(size(b)),aap(size(b))
  REAL    :: rtr, rtr0, bb, paap, ak, bk
  integer :: niter,iter4
  complex(8), external :: ddsc_cdotc
  external :: wtmul_dd, mtmul_dd

  if (.not. dd_evec) return

!-------------------------------------------------------------------------------
  DEBUG2S("Start: cg_def")

  call precon_p(pb, b, ip)
  tmp=>pb
  bb = vec_norm2_c8(tmp)

  call precon_a(r, x, id, ip)
  niter = 1

  r = pb - r
  p = r

  tmp=>r
  rtr=vec_norm2_c8(tmp)
  if (stop_condition(rtr, res, bb)) goto 9999
  rtr0=rtr

  do niter = 1,  cg_para%maxiter

     call precon_a(aap, p, id, ip)
     paap = ddsc_cdotc(aap, p)

     ak = rtr0 / paap
     x = x + ak * p
     r = r - ak * aap
     tmp=>r
     rtr=vec_norm2_c8(tmp)
     if (stop_condition(rtr, res, bb)) goto 9999

#ifdef DEBUG2
     if(my_pe()==0.and.mod(niter,100)==0)write(0,*)niter,"defrtr",rtr
#endif

     bk = rtr / rtr0
     rtr0 = rtr
     p = r + bk * p
  enddo

write(0,*)"not conv cg_def"
stop

9999 continue

  call precon_b(x, b, id, ip) 

!!!!!! check
!  if(my_pe()==0)write(0,*)"check cg_def: solver rtr", rtr
!  call mtdagmt_dd(r, x, id, ip)
!  r=r-b
!  tmp=>r
!  rtr=vec_norm2_c8(tmp)
!  if(my_pe()==0)write(0,*)"check cg_def: actual rtr", rtr

  iter = niter
  call update_cg_stat(dd_stat, iter, 0)
  DEBUG2S("End: cg_def")
end

!-------------------------------------------------------------------------------
subroutine precon_a(out, in, id, ip) 
  use module_dd
  implicit none
  complex(8), dimension(12*ld%lat%volh):: in, out, tmp
  integer :: id, ip

  call mtdagmt_dd(tmp, in, id, ip)
  call precon_p(out, tmp, ip)
end

!-------------------------------------------------------------------------------
subroutine precon_b(x, b, id, ip) 
  use module_dd_evec
  implicit none
  complex(8), dimension(12*ld%lat%volh):: x, b, tmp
  integer :: id, ip, i,j
  complex(8) :: fac(defeig)

  call precon_q(tmp, x , id, ip)

  fac=ZERO
  do i = 1, defeig
  do j = 1, 12*ld%lat%volh
     fac(i) = fac(i) + conjg(evecdd(ip,1)%x(j,i)) * b(j)
  enddo
  fac(i)=fac(i)/evecdd(ip,1)%eval(i)
  enddo

  do j = 1, 12*ld%lat%volh
  x(j) = tmp(j) + fac(1) * evecdd(ip,1)%x(j,1)
  enddo

  do i = 2, defeig
  do j = 1, 12*ld%lat%volh
  x(j) = x(j) + fac(i) * evecdd(ip,1)%x(j,i)
  enddo
  enddo
end

!-------------------------------------------------------------------------------
subroutine precon_p(out, in, ip) 
  use module_dd_evec
  implicit none
  complex(8), dimension(12*ld%lat%volh):: in, out
  integer :: i, j, ip
  complex(8) :: fac(defeig)

  fac=ZERO
  do i = 1, defeig
  do j = 1, 12*ld%lat%volh
     fac(i) = fac(i) + conjg(evecdd(ip,1)%x(j,i)) * in(j)
  enddo
  enddo

  do j = 1, 12*ld%lat%volh
  out(j) = in(j) - fac(1) * evecdd(ip,1)%x(j,1)
  enddo

  do i = 2, defeig
  do j = 1, 12*ld%lat%volh
  out(j) = out(j) - fac(i) * evecdd(ip,1)%x(j,i)
  enddo
  enddo

end
!-------------------------------------------------------------------------------
subroutine precon_q(out, in, id, ip) 
  use module_dd_evec
  implicit none
  complex(8), dimension(12*ld%lat%volh):: in, out, tmp
  integer :: i, j, ip, id
  complex(8) :: fac(defeig)

  call mtdagmt_dd(tmp, in, id, ip)

  fac=ZERO
  do i = 1, defeig
  do j = 1, 12*ld%lat%volh
     fac(i) = fac(i) + conjg(evecdd(ip,1)%x(j,i)) * tmp(j)
  enddo
  fac(i)=fac(i)/evecdd(ip,1)%eval(i)
  enddo

  do j = 1, 12*ld%lat%volh
  out(j) = in(j) - fac(1) * evecdd(ip,1)%x(j,1)
  enddo

  do i = 2, defeig
  do j = 1, 12*ld%lat%volh
  out(j) = out(j) - fac(i) * evecdd(ip,1)%x(j,i)
  enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine precon2_a(out, in, id, ip) 
  use module_dd
  implicit none
  complex(8), dimension(12*ld%lat%volh):: in, out, tmp
  integer :: id, ip

  call mtdagmt_dd(tmp, in, id, ip)
  call precon2_p(out, tmp, ip)
end

!-------------------------------------------------------------------------------
subroutine precon2_b(x, b, id, ip) 
  use module_dd_evec
  implicit none
  complex(8), dimension(12*ld%lat%volh):: x, b, tmp
  integer :: id, ip, i,j
  complex(8) :: fac(defeig)

  call mtdagmt_dd(tmp, x, id, ip)
  tmp=b-tmp

  fac=ZERO
  do i = 1, defeig
  do j = 1, 12*ld%lat%volh
     fac(i) = fac(i) + conjg(evecdd(ip,1)%ax(j,i)) * tmp(j)
  enddo
!  fac(i)=fac(i)/evecdd(ip,1)%eval(i)
  enddo

  do j = 1, 12*ld%lat%volh
  x(j) = x(j) + fac(1) * evecdd(ip,1)%x(j,1)
  enddo

  do i = 2, defeig
  do j = 1, 12*ld%lat%volh
  x(j) = x(j) + fac(i) * evecdd(ip,1)%x(j,i)
  enddo
  enddo

!!  fac=ZERO
!!  do i = 1, defeig
!!  do j = 1, 12*ld%lat%volh
!!     fac(i) = fac(i) + conjg(evecdd(ip,1)%ax(j,i)) * b(j)
!!  enddo
!!!  fac(i)=fac(i)/evecdd(ip,1)%eval(i)
!!  enddo
!!
!!  do j = 1, 12*ld%lat%volh
!!  x(j) = tmp(j) + fac(1) * evecdd(ip,1)%x(j,1)
!!  enddo
!!
!!  do i = 2, defeig
!!  do j = 1, 12*ld%lat%volh
!!  x(j) = x(j) + fac(i) * evecdd(ip,1)%x(j,i)
!!  enddo
!!  enddo
end

!-------------------------------------------------------------------------------
subroutine precon2_p(out, in, ip) 
  use module_dd_evec
  implicit none
  complex(8), dimension(12*ld%lat%volh):: in, out
  integer :: i, j, ip
  complex(8) :: fac(defeig)

  fac=ZERO
  do i = 1, defeig
  do j = 1, 12*ld%lat%volh
     fac(i) = fac(i) + conjg(evecdd(ip,1)%ax(j,i)) * in(j)
  enddo
  enddo

  do j = 1, 12*ld%lat%volh
  out(j) = in(j) - fac(1) * evecdd(ip,1)%ax(j,1)
  enddo

  do i = 2, defeig
  do j = 1, 12*ld%lat%volh
  out(j) = out(j) - fac(i) * evecdd(ip,1)%ax(j,i)
  enddo
  enddo

end
!-------------------------------------------------------------------------------
subroutine precon2_q(out, in, id, ip) 
  use module_dd_evec
  implicit none
  complex(8), dimension(12*ld%lat%volh):: in, out, tmp
  integer :: i, j, ip, id
  complex(8) :: fac(defeig)

  call mtdagmt_dd(tmp, in, id, ip)

  fac=ZERO
  do i = 1, defeig
  do j = 1, 12*ld%lat%volh
     fac(i) = fac(i) + conjg(evecdd(ip,1)%ax(j,i)) * tmp(j)
  enddo
!  fac(i)=fac(i)/evecdd(ip,1)%eval(i)
  enddo

  do j = 1, 12*ld%lat%volh
  out(j) = in(j) - fac(1) * evecdd(ip,1)%x(j,1)
  enddo

  do i = 2, defeig
  do j = 1, 12*ld%lat%volh
  out(j) = out(j) - fac(i) * evecdd(ip,1)%x(j,i)
  enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine cg_def_r4(x, b, id, ip, iter, res) 
  use module_function_decl
  use module_check_solution
  use module_dd_evec
  use module_action
  use module_cg
  use vec
  implicit none


  complex(4), dimension(12*ld%lat%volh),         intent(inout):: x
  complex(4), dimension(12*ld%lat%volh), target, intent(in)   :: b
  integer, intent(out):: iter
  integer, intent(in) :: id, ip
  REAL,    intent(in) :: res

  complex(4),pointer :: tmp(:)
  complex(4),target  :: r(size(x)),p(size(b)),pb(size(b)),aap(size(b))
  REAL    :: rtr, rtr0, bb, paap, ak, bk
  integer :: niter,iter4
  complex(4), external :: ddsc_cdotc_r4

  if (.not. dd_evec) return

!-------------------------------------------------------------------------------
  DEBUG2S("Start: cg_def_r4")

  call precon_p_r4(pb, b, ip)
  tmp=>pb
  bb = vec_norm2_c4(tmp)

  call precon_a_r4(r, x, id, ip)
  niter = 1

  r = pb - r
  p = r

  tmp=>r
  rtr=vec_norm2_c4(tmp)
  if (stop_condition(rtr, res, bb)) goto 9999
  rtr0=rtr

!write(0,*)"rtr,bb",rtr,bb

  do niter = 1, cg_para%maxiter

     call precon_a_r4(aap, p, id, ip)
     paap = ddsc_cdotc_r4(aap, p)

!write(0,*)"paap",paap

     ak = rtr0 / paap
     x = x + ak * p
     r = r - ak * aap
     tmp=>r
     rtr=vec_norm2_c4(tmp)
     if (stop_condition(rtr, res, bb)) goto 9999
!write(0,*)"rtr",rtr
#ifdef DEBUG2
     if(my_pe()==0.and.mod(niter,100)==0)write(0,*)niter,"defrtr",rtr
#endif

     bk = rtr / rtr0
     rtr0 = rtr
     p = r + bk * p
  enddo

write(0,*)"not conv cg_def_r4"
stop

9999 continue

  call precon_b_r4(x, b, id, ip) 

! check
!  call mtdagmt_dd(r, x, id, ip)
!  r=r-b
!  tmp=>r
!  rtr=vec_norm2_c8(tmp)
!  write(0,*)"check cg_def", rtr
!stop

  iter = niter
  DEBUG2S("End: cg_def_r4")
end

!-------------------------------------------------------------------------------
subroutine precon_a_r4(out, in, id, ip) 
  use module_dd
  implicit none
  complex(4), dimension(12*ld%lat%volh):: in, out, tmp
  integer :: id, ip

  call mtdagmt_dd_r4(tmp, in, id, ip)
  call precon_p_r4(out, tmp, ip)
end

!-------------------------------------------------------------------------------
subroutine precon_b_r4(x, b, id, ip) 
  use module_dd_evec
  implicit none
  complex(4), dimension(12*ld%lat%volh):: x, b, tmp
  integer :: id, ip, i,j
  complex(4) :: fac(defeig)

  call precon_q_r4(tmp, x , id, ip)

  fac=ZERO
  do i = 1, defeig
  do j = 1, 12*ld%lat%volh
     fac(i) = fac(i) + conjg(evecdd_r4(ip,1)%x(j,i)) * b(j)
  enddo
  fac(i)=fac(i)/evecdd_r4(ip,1)%eval(i)
  enddo

  do j = 1, 12*ld%lat%volh
  x(j) = tmp(j) + fac(1) * evecdd_r4(ip,1)%x(j,1)
  enddo

  do i = 2, defeig
  do j = 1, 12*ld%lat%volh
  x(j) = x(j) + fac(i) * evecdd_r4(ip,1)%x(j,i)
  enddo
  enddo
end

!-------------------------------------------------------------------------------
subroutine precon_p_r4(out, in, ip) 
  use module_dd_evec
  implicit none
  complex(4), dimension(12*ld%lat%volh):: in, out
  integer :: i, j, ip
  complex(4) :: fac(defeig)

  fac=ZERO
  do i = 1, defeig
  do j = 1, 12*ld%lat%volh
     fac(i) = fac(i) + conjg(evecdd_r4(ip,1)%x(j,i)) * in(j)
  enddo
  enddo

  do j = 1, 12*ld%lat%volh
  out(j) = in(j) - fac(1) * evecdd_r4(ip,1)%x(j,1)
  enddo

  do i = 2, defeig
  do j = 1, 12*ld%lat%volh
  out(j) = out(j) - fac(i) * evecdd_r4(ip,1)%x(j,i)
  enddo
  enddo

end
!-------------------------------------------------------------------------------
subroutine precon_q_r4(out, in, id, ip) 
  use module_dd_evec
  implicit none
  complex(4), dimension(12*ld%lat%volh):: in, out, tmp
  integer :: i, j, ip, id
  complex(4) :: fac(defeig)

  call mtdagmt_dd_r4(tmp, in, id, ip)

  fac=ZERO
  do i = 1, defeig
  do j = 1, 12*ld%lat%volh
     fac(i) = fac(i) + conjg(evecdd_r4(ip,1)%x(j,i)) * tmp(j)
  enddo
  fac(i)=fac(i)/evecdd_r4(ip,1)%eval(i)
  enddo

  do j = 1, 12*ld%lat%volh
  out(j) = in(j) - fac(1) * evecdd_r4(ip,1)%x(j,1)
  enddo

  do i = 2, defeig
  do j = 1, 12*ld%lat%volh
  out(j) = out(j) - fac(i) * evecdd_r4(ip,1)%x(j,i)
  enddo
  enddo

end
!===============================================================================
