!===============================================================================
!
! cg_ritz.F90 - program to calculate eigenmode by cg
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2008 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_evec

  type type_evec_hermit_half
     REAL    :: eval
     P_SPINCOL_OVERINDEXED :: x
  end type type_evec_hermit_half

  type type_evec_hermit
     REAL    :: eval
     P_SPINCOL_OVERINDEXED :: xe
     P_SPINCOL_OVERINDEXED :: xo
  end type type_evec_hermit

  integer, save :: neig
  type(type_evec_hermit     ),dimension(:),pointer,save :: evech1
  type(type_evec_hermit_half),dimension(:),pointer,save :: evech2

end

!!!-------------------------------------------------------------------------------
!!subroutine cg_ritz_cont1(id, n, evecs, iter, action)
!!  use module_evec
!!  use module_field
!!  use module_vol
!!  implicit none
!!
!!  integer, intent(in)  :: id, n, action  ![action 0:1 = min:max]
!!  integer, intent(out) :: iter
!!  type(type_evec_hermit),intent(out) :: evecs(n)
!!  integer :: i, ierr, niter,j
!!  REAL :: norm
!!
!!  DEBUG2S("Start: cg_ritz_cont1")
!!  iter = 0
!!  do i = 1, n
!!     !$omp parallel do
!!     do j = 1, size_sc_field
!!        evecs(i)%xe(j) = dble(  mod(j,2)             )
!!        evecs(i)%xo(j) = dble(  mod(j,2)             )
!!     enddo
!!     call orthogonalize_sc(i-1, evecs, evecs(i)%xe, evecs(i)%xo)
!!     call normalize_sc(evecs(i)%xe, evecs(i)%xo, norm)
!!     call cg_ritz(id, niter, evecs(i)%eval, evecs(i)%xe, evecs(i)%xo, evecs, i-1, action)
!!     iter = iter + niter
!!  enddo
!!  DEBUG2S("End: cg_ritz_cont1")
!!end
!!
!-------------------------------------------------------------------------------
subroutine cg_ritz_cont2(ftype, id, n, evecs, iter, action)
  use module_evec
  use module_field
  use module_vol
  implicit none

  integer, intent(in)  :: ftype, id, n, action  ![action 0:1 = min:max]
  integer, intent(out) :: iter
  type(type_evec_hermit_half),intent(out) :: evecs(n)
  integer :: i, ierr, niter,j
  REAL :: norm

  DEBUG2S("Start: cg_ritz_cont2")
  iter = 0
  do i = 1, n
     !$omp parallel do
     do j = 1, size_sc_field
        evecs(i)%x(j) = dble(  mod(j,2)             )
     enddo
     call orthogonalize_sc_half(i-1, evecs, evecs(i)%x)
     call normalize_sc_half(evecs(i)%x, norm)
     call cg_ritz_half(ftype, id, niter, evecs(i)%eval, evecs(i)%x, evecs, i-1, action)
     iter = iter + niter
  enddo
  DEBUG2S("End: cg_ritz_cont2")
end

!!!-------------------------------------------------------------------------------
!!subroutine cg_ritz(id, iter, mu, xe, xo, evecs, n, action)
!!  use module_evec
!!  use module_cg
!!  use module_function_decl
!!  use module_p_interface
!!  use module_vol
!!  implicit none
!!
!!  integer, intent(in)  :: action, id, n  ![action 0:1 = min:max]
!!  integer, intent(out) :: iter
!!  REAL,    intent(out) :: mu
!!  SPINCOL_OVERINDEXED, intent(inout) :: xe, xo
!!  type(type_evec_hermit),intent(in) :: evecs(n)
!!
!!  P_SPINCOL_OVERINDEXED,save :: ye, yo  ! y = Ax
!!  P_SPINCOL_OVERINDEXED,save :: ge, go  ! g = Ax - mu x
!!  P_SPINCOL_OVERINDEXED,save :: pe, po  ! search direction
!!  P_SPINCOL_OVERINDEXED,save :: ze, zo  ! z = Ap
!!
!!  REAL                    :: beta, pp, pap, rtr, rtrold, xp
!!  REAL                    :: costheta, sintheta
!!  integer                 :: i, niter, ierr, j
!!  character(72)           :: msg
!!
!!  TIMING_START(timing_bin_cg_ritz)
!!
!!  ALLOCATE_SC_OVERINDEXED(ye)
!!  ALLOCATE_SC_OVERINDEXED(ze)
!!  ALLOCATE_SC_OVERINDEXED(ge)
!!  ALLOCATE_SC_OVERINDEXED(pe)
!!  ALLOCATE_SC_OVERINDEXED(yo)
!!  ALLOCATE_SC_OVERINDEXED(zo)
!!  ALLOCATE_SC_OVERINDEXED(go)
!!  ALLOCATE_SC_OVERINDEXED(po)
!!
!!  call unprec_wdagw(ye, yo, xe, xo, id)
!!
!!  call orthogonalize_sc(n, evecs, ye, yo)
!!
!!  mu = sc_dot(xe, ye) + sc_dot(xo, yo) ;  mu = global_sum(mu)
!!
!!  rtr = ZERO
!!  !$omp parallel do reduction(+: rtr)
!!  do i = 1, size_sc_field
!!     ge(i) = ye(i)    - mu * xe(i)
!!     go(i) = yo(i)    - mu * xo(i)
!!     pe(i) = ge(i)
!!     po(i) = go(i)
!!     rtr  = rtr + ge(i)**2 + go(i)**2
!!  enddo
!!  rtr = global_sum(rtr)
!!
!!  do niter = 1, cg_ritz_para%maxiter
!!     if (rtr <= cg_ritz_para%rest_mc) goto 9999
!!
!!     call orthogonalize_sc(n, evecs, pe, po)
!!     pp =  sc_norm2(pe) + sc_norm2(po) ; pp = global_sum(pp)
!!     call unprec_wdagw(ze, zo, pe, po, id)
!!     call orthogonalize_sc(n, evecs, ze, zo)
!!
!!     pap = sc_dot(pe, ze) + sc_dot(po, zo); pap = global_sum(pap)
!!
!!     call min_ritz_func(mu, costheta, sintheta, rtr, pap, pp, action)
!!     call sc_axpby(xe, pe, costheta, sintheta)  ! x = costheta * x + sintheta * p
!!     call sc_axpby(xo, po, costheta, sintheta)  ! x = costheta * x + sintheta * p
!!     call sc_axpby(ye, ze, costheta, sintheta)  ! y = costheta * y + sintheta * z
!!     call sc_axpby(yo, zo, costheta, sintheta)  ! y = costheta * y + sintheta * z
!!
!!     rtrold = rtr
!!     rtr = ZERO
!!     !$omp parallel do reduction(+: rtr)
!!     do i = 1, size_sc_field
!!        ge(i) = ye(i)    - mu * xe(i)
!!        go(i) = yo(i)    - mu * xo(i)
!!        rtr  = rtr + ge(i)**2 + go(i)**2
!!     enddo
!!     rtr = global_sum(rtr)
!!
!!     beta = costheta * rtr / rtrold
!!     xp = sc_dot(xe, pe) + sc_dot(xo, po); xp = global_sum(xp)
!!
!!     !$omp parallel do
!!     do i = 1, size_sc_field
!!        pe(i) = ge(i) + beta * ( pe(i) -  xp * xe(i) )
!!        po(i) = go(i) + beta * ( po(i) -  xp * xo(i) )
!!     enddo
!!
!!  enddo
!!
!!  niter = niter - 1
!!
!!  if (cg_ritz_para%log /= 2) then
!!     if(my_pe()==0)write(UREC, *) "cg_ritz(): no convergence; rtr = ", rtr 
!!     write(msg, *) "cg_ritz(): no convergence; rtr = ", rtr 
!!     call die(msg)
!!  endif
!!
!!9999 continue
!!!=================================================
!!!!  if (cg_ritz_para%check /= 0) call check_cg_ritz(id, niter, mu, x)
!!
!!  call update_cg_stat(cg_ritz_stat, niter, 0)
!!
!!  iter = niter
!!
!!  TIMING_STOP(timing_bin_cg_ritz)
!!
!!end
!!
!-------------------------------------------------------------------------------
subroutine cg_ritz_half(ftype, id, iter, mu, x, evecs, n, action)
  use module_evec
  use module_cg
  use module_function_decl
  use module_p_interface
  use module_vol
  implicit none

  integer, intent(in)  :: action, ftype, id, n  ![action 0:1 = min:max]
  integer, intent(out) :: iter
  REAL,    intent(out) :: mu
  SPINCOL_OVERINDEXED, intent(inout) :: x
  type(type_evec_hermit_half),intent(in) :: evecs(n)

  P_SPINCOL_OVERINDEXED,save :: y  ! y = Ax
  P_SPINCOL_OVERINDEXED,save :: g  ! g = Ax - mu x
  P_SPINCOL_OVERINDEXED,save :: p  ! search direction
  P_SPINCOL_OVERINDEXED,save :: z  ! z = Ap

  REAL                    :: beta, pp, pap, rtr, rtrold, xp
  REAL                    :: costheta, sintheta
  integer                 :: i, niter, ierr, j
  character(72)           :: msg

  DEBUG2S("Start: cg_ritz_half")
  TIMING_START(timing_bin_cg_ritz)

  ALLOCATE_SC_OVERINDEXED(y)
  ALLOCATE_SC_OVERINDEXED(z)
  ALLOCATE_SC_OVERINDEXED(g)
  ALLOCATE_SC_OVERINDEXED(p)

  if (ftype == EO_NORMAL .or. ftype == EO_RATIONAL ) then
     call wdagw(y, x, id)
#ifdef BQCD_DDHMC
  elseif (ftype == DD_NORMAL .or. ftype == DD_RATIONAL) then
     call wtdagwt_all_dd(y, x, id)
  elseif (ftype == HH_NORMAL .or. ftype == HH_RATIONAL) then
     call unprec_hdagh(y, x, id)
#endif
  else
     call stderr2_int("cg_ritz_half called with fermionic type: ", 1, ftype)
     call die("cg_ritz_half can not treat this fermionic type")
  endif

  call orthogonalize_sc_half(n, evecs, y)
  mu = sc_dot(x, y) ;  mu = global_sum(mu)
  rtr = ZERO
  !$omp parallel do reduction(+: rtr)
  do i = 1, size_sc_field
     g(i) = y(i)    - mu * x(i)
     p(i) = g(i)
     rtr  = rtr + g(i)**2
  enddo
  rtr = global_sum(rtr)
  do niter = 1, cg_ritz_para%maxiter
     if (rtr <= cg_ritz_para%rest_mc) goto 9999

     call orthogonalize_sc_half(n, evecs, p)
     pp =  sc_norm2(p) ; pp = global_sum(pp)

  if (ftype == EO_NORMAL .or. ftype == EO_RATIONAL ) then
     call wdagw(z, p, id)
#ifdef BQCD_DDHMC
  elseif (ftype == DD_NORMAL .or. ftype == DD_RATIONAL) then
     call wtdagwt_all_dd(z, p, id)
  elseif (ftype == HH_NORMAL .or. ftype == HH_RATIONAL) then
     call unprec_hdagh(z, p, id)
#endif
  else
     call stderr2_int("cg_ritz_half called with fermionic type: ", 1, ftype)
     call die("cg_ritz_half can not treat this fermionic type")
  endif

     call orthogonalize_sc_half(n, evecs, z)
     pap = sc_dot(p, z) ; pap = global_sum(pap)
     call min_ritz_func(mu, costheta, sintheta, rtr, pap, pp, action)
     call sc_axpby(x, p, costheta, sintheta)  ! x = costheta * x + sintheta * p
     call sc_axpby(y, z, costheta, sintheta)  ! y = costheta * y + sintheta * z

     rtrold = rtr
     rtr = ZERO
     !$omp parallel do reduction(+: rtr)
     do i = 1, size_sc_field
        g(i) = y(i)    - mu * x(i)
        rtr  = rtr + g(i)**2
     enddo
     rtr = global_sum(rtr)

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


     beta = costheta * rtr / rtrold
     xp = sc_dot(x, p) ; xp = global_sum(xp)

     !$omp parallel do
     do i = 1, size_sc_field
        p(i) = g(i) + beta * ( p(i) -  xp * x(i) )
     enddo

  enddo

  niter = niter - 1

  if (cg_ritz_para%log /= 2) then
     if(my_pe()==0)write(UREC, *) "cg_ritz(): no convergence; rtr = ", rtr 
     write(msg, *) "cg_ritz(): no convergence; rtr = ", rtr 
     call die(msg)
  endif

9999 continue
!=================================================
  if (cg_ritz_para%check /= 0) call check_cg_ritz(ftype, id, niter, mu, x)

  call update_cg_stat(cg_ritz_stat, niter, 0)

  iter = niter

  TIMING_STOP(timing_bin_cg_ritz)
  DEBUG2S("End: cg_ritz_half")
end

!-------------------------------------------------------------------------------
subroutine check_cg_ritz(ftype, id, niter, mu, x)
  use      module_function_decl
  use      module_p_interface
  use      module_vol
  implicit none
  integer, intent(in) :: ftype, id, niter
  REAL,    intent(in) :: mu
  REAL :: res
  integer, save :: count = 0

  SPINCOL_OVERINDEXED, intent(in) :: x
  P_SPINCOL_OVERINDEXED,save :: tmp

  ALLOCATE_SC_OVERINDEXED(tmp)

  if(my_pe()==0 .and. count == 0) write(UREC,400)"T%cg_ritz",  &
     " niter","mu", " sum^Vol|mux-Ax|^2"

  if (ftype == EO_NORMAL .or. ftype == EO_RATIONAL ) then
     call wdagw(tmp, x, id)
#ifdef BQCD_DDHMC
  elseif (ftype == DD_NORMAL .or. ftype == DD_RATIONAL) then
     call wtdagwt_all_dd(tmp, x, id)
  elseif (ftype == HH_NORMAL .or. ftype == HH_RATIONAL) then
     call unprec_hdagh(tmp, x, id)
#endif
  else
     call stderr2_int("cg_ritz_half called with fermionic type: ", 1, ftype)
     call die("cg_ritz_half can not treat this fermionic type")
  endif

  tmp = tmp - mu * x
  res = sc_norm2(tmp); res = global_sum(res)

  if(my_pe()==0)  write(UREC,410)" %cg_ritz",  niter, mu, res

  count = 1

400 format (1x,a9, a6,1x,2a18)
410 format (1x,a9 ,i6,1x,2es18.6)

end

!-------------------------------------------------------------------------------
subroutine min_ritz_func(mu, &
                         costheta, &
                         sintheta, &
                         rtr, pap, pp, action)

  implicit none
  REAL,    intent(inout) :: mu
  REAL,    intent(out) :: costheta, sintheta
  integer, intent(in) :: action
  REAL,    intent(in) :: rtr, pap, pp
  REAL :: s1, s2, s3, a, cosd, sind

  s1 = HALF * (mu + pap / pp)
  s2 = HALF * (mu - pap / pp)
  s3 = rtr / sqrt(pp)
  a = sqrt ( s2**2 + s3**2 )
  cosd = s2 / a
  sind = s3 / a

  if ( action == 0 ) then
  !------------------------- min
       if (cosd > ZERO) then
          sintheta = - sqrt( HALF + HALF * cosd)
          costheta = - HALF * sind / sintheta
       else
          costheta =   sqrt( HALF - HALF * cosd)
          sintheta = - HALF * sind / costheta
       endif
       mu = s1 - a
  else
  !------------------------- max        need to check  !!!!!!
       if (cosd > ZERO) then
          costheta =   sqrt( HALF + HALF * cosd)
          sintheta =   HALF * sind / costheta
       else
          sintheta = - sqrt( HALF - HALF * cosd)
          costheta =   HALF * sind / sintheta
       endif
       mu = s1 + a
  endif

  sintheta = sintheta / sqrt(pp)

end

!-------------------------------------------------------------------------------
subroutine normalize_sc(inout1, inout2, norm)
  use      module_vol
  use      module_function_decl
  implicit none
  SPINCOL_OVERINDEXED, intent(inout) :: inout1, inout2
  REAL, intent(out) :: norm
  REAL :: tmp

  tmp = sc_norm2(inout1) + sc_norm2(inout2)
  tmp = global_sum(tmp)
  norm = sqrt(tmp)
  tmp = ONE / norm
  call sc_scale(inout1, tmp)
  call sc_scale(inout2, tmp)

end

!-------------------------------------------------------------------------------
subroutine normalize_sc_half(inout, norm)
  use      module_vol
  use      module_function_decl
  implicit none
  SPINCOL_OVERINDEXED, intent(inout) :: inout
  REAL, intent(out) :: norm
  REAL :: tmp

  tmp = sc_norm2(inout) 
  tmp = global_sum(tmp)
  norm = sqrt(tmp)
  tmp = ONE / norm
  call sc_scale(inout, tmp)

end

!-------------------------------------------------------------------------------
subroutine orthogonalize_sc(n, evecs, inoute, inouto)
  use module_vol
  use module_evec
  use module_function_decl
  implicit none

  type(type_evec_hermit),intent(in) :: evecs(n)
  SPINCOL_OVERINDEXED, intent(inout) :: inoute, inouto
  integer, intent(in) :: n
  COMPLEX :: xx, xxe, xxo
  integer :: i

  do i = 1, n
    xxe=sc_cdotc(evecs(i)%xe, inoute)
    xxo=sc_cdotc(evecs(i)%xo, inouto)
    call global_sum_vec(2, xxe)
    call global_sum_vec(2, xxo)
    xx = xxe + xxo
    call sc_caxpy(inoute, evecs(i)%xe, -xx)
    call sc_caxpy(inouto, evecs(i)%xo, -xx)
  enddo

end

!-------------------------------------------------------------------------------
subroutine orthogonalize_sc_half(n, evecs, inout)
  use module_vol
  use module_evec
  use module_function_decl
  implicit none

  type(type_evec_hermit_half),intent(in) :: evecs(n)
  SPINCOL_OVERINDEXED, intent(inout) :: inout
  integer, intent(in) :: n
  COMPLEX :: xx(n)
  integer :: i

  do i = 1, n
    xx(i)=sc_cdotc(evecs(i)%x, inout)
    call global_sum_vec(2, xx(i))
    call sc_caxpy(inout, evecs(i)%x, -xx(i))
  enddo

end

!-------------------------------------------------------------------------------
subroutine check_orthonormal_sc(n, evecs)
  use module_evec
  use module_function_decl
  implicit none

  type(type_evec_hermit_half),intent(in) :: evecs(n)
  integer, intent(in) :: n
  COMPLEX :: xx
  REAL :: res
  integer :: i, j

  res = ZERO

  do i = 1, n
     do j = 1, n
        xx = sc_cdotc(evecs(i)%x, evecs(j)%x)
        call global_sum_vec(2, xx)
        if (i==j)then
           res = res + ( real(xx) - ONE )**2
           res = res + (aimag(xx) )**2
        else
           res = res + ( real(xx) )**2
           res = res + (aimag(xx) )**2
        endif
     enddo
  enddo
  
  write(0,*)"ck_orthonormal_sc: ","n=",n,"sumdif=",res

end

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