!===============================================================================
!
! multi_shift_cg_mix.F90 - cg multi shift solver  ( A + a(i) ) x(i) = b
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2006-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"

!-------------------------------------------------------------------------------
subroutine multi_shift_cg_mix(b, id, n, frdo, shift, iter, iter_sh, res) 
  use module_field
  use module_cg
  use module_function_decl
  use module_p_interface
  use module_vol
  use module_mre
  implicit none
  SPINCOL_OVERINDEXED,           intent(in)  :: b
  integer,                       intent(out) :: iter, iter_sh(n)
  integer,                       intent(in)  :: frdo(n), n, id
  REAL,                          intent(in)  :: shift(n)
  REAL,                          intent(in)  :: res

  type(type_mre), save :: solutions

  P_SPINCOL_OVERINDEXED,save :: r, p, aap
  real(4), dimension(SIZE_COMPLEX*NDIRAC*NCOL*volh_tot) :: r4, p4


  REAL       :: ak, ako, bko, bk, rtr, rtrold, paap, as, z0, z1
  REAL       :: bb, interval, rtr0, rp, rpold
  REAL       :: z(2,n), bs(n)
  integer    :: i, niter, n_min, n_con(n), iter4, iter4_tot
  character(72)           :: msg


call die("not correct")


  TIMING2_START(timing2_bin_cgm)

  ALLOCATE_SC_OVERINDEXED(r)
  ALLOCATE_SC_OVERINDEXED(p)
  ALLOCATE_SC_OVERINDEXED(aap)

  n_min = n
  do i = 1, n
     n_con(i) = frdo(i)
     if (frdo(i) == 0) n_min = min(n_min,i)
  enddo

  ako=ONE
  bko=ZERO
  z =ONE

  bb = sc_norm2(b);bb = global_sum(bb)
  DEBUG2R("norm(b)=   ",  sqrt(bb)/2/action%mtilde(id)%kappa)
  DEBUG2R("rsd    =   ",  dble(res)**2*bb/(2*action%mtilde(id)%kappa)**2)

  call sc_copy(r,b)
  rtrold = sc_norm2(r);rtrold = global_sum(rtrold)

  rtr0=rtrold
  if (criterion == 0) then 
     if ( rtr0 <= res) goto 9999
     interval = (res/rtr0)**(1.0_8/dble(outer_steps))
  endif
  if (criterion == 1) then
     if (rtr0 <= res*res*bb ) goto 9999
     interval = res**(1.0_8/dble(outer_steps))
  endif

  iter4_tot = 0
  !----------------------------------------
  !  preconditioning
  !--
  call mre_get2(solutions, p, r, id)
  !$omp parallel do
  do i = 1, size_sc_field
     r4(i) = r(i)
     p4(i) = r(i)
  enddo
  if (criterion == 0) then
     call cg_inner(p4, r4, id, iter4, real(rtr0*interval**niter , kind=4))
  else
     call cg_inner(p4, r4, id, iter4, real(interval , kind=4))
  endif
  iter4_tot = iter4_tot + iter4
  !$omp parallel do
  do i = 1, size_sc_field
     p(i) = p4(i)
  enddo
  call mre_put(solutions, p, 0)
  rpold = sc_dot(r, p) ; rpold = global_sum(rpold)
  !----------------------------------------

  do i=1,n
     call sc_copy(sco(2,i)%sco,r)
     call sc_zero(sco(1,i)%sco)
  enddo
!----------------------------------------
  do niter = 1, cg_para%maxiter
     call wdagw(aap, sco(2,n_min)%sco, id)
     call sc_axpy(aap, sco(2,n_min)%sco, shift(n_min))
     paap = sc_dot(sco(2,n_min)%sco, aap) ; paap = global_sum(paap)

     ak= - rpold / paap
!!     ak= - rtrold / paap


     call sc_axpy(r, aap, ak)
     rtr = sc_norm2(r);rtr = global_sum(rtr)

     do i = 1, n
        if ( n_con(i) == 0) then
           z0 = z(1,i)
           z1 = z(2,i)
           bs(i)=ak*ako/(ak*bko*(ONE-z1/z0)+ako*(ONE-(shift(i)-shift(n_min))*ak))
           call sc_axpy(sco(1,i)%sco, sco(2,i)%sco, -bs(i))
           cgm_iterations_total_sh = cgm_iterations_total_sh + 1
           iter_sh(i)= niter
           z0 = z(2,i)*bs(i)/ak
           if (criterion == 0 .and. rtr*z0**2 <= res        ) n_con(i)=1
           if (criterion == 1 .and. rtr*z0**2 <= res*res*bb ) n_con(i)=1
        endif
     enddo

     z0 = z(2,n_min)*bs(n_min)/ak
     if ( criterion == 0 .and. rtr*z0**2 <= res        ) goto 9999
     if ( criterion == 0 .and. rtr*z0**2 <= res*res*bb ) goto 9999

write(0,*)rtr*z0**2

     !----------------------------------------
     !  preconditioning
     !--
     call mre_get2(solutions, p, r, id)
     !$omp parallel do
     do i = 1, size_sc_field
        r4(i) = r(i)
        p4(i) = p(i)
     enddo
     if (criterion == 0) then
        call cg_inner(p4, r4, id, iter4, real(rtr0*interval**niter , kind=4))
     else
        call cg_inner(p4, r4, id, iter4, real(interval , kind=4))
     endif
     iter4_tot = iter4_tot + iter4
     !$omp parallel do
     do i = 1, size_sc_field
        p(i) = p4(i)
     enddo
     call mre_put(solutions, p, 0)
     rp = sc_dot(r, p) ; rp = global_sum(rp)
     !----------------------------------------
     bk = rp / rpold
     rpold   = rp
     call sc_xpby(sco(2,n_min)%sco, p, bk)

!     bk = rtr / rtrold
!     rtrold   = rtr
!     call sc_xpby(sco(2,n_min)%sco, r, bk)

     do i = 1, n
        if ( n_con(i) == 0) then
           z0 = bs(i)/ak
           z1 = z(2,i)*z0
           as  = bk * (z0)**2 
           if (i /= n_min) call sc_axpby(sco(2, i)%sco, p, as, z1/ (ONE-(shift(i)-shift(n_min))*ak))
!!           if (i /= n_min) call sc_axpby(sco(2, i)%sco, r, as, z1)
           z(1,i) =z(2,i)
           z(2,i) =z1
        endif
     enddo

     ako=ak
     bko=bk
  enddo
!----------------------------------------
  niter = niter - 1

  if (cg_para%log /= 2) then
     if(my_pe()==0)write(UREC, *) "cgm(): no convergence; rtr = ", rtr 
     if(my_pe()==0)write(UREC, *) "b    = ",b(1)
     if(my_pe()==0)write(UREC, *) "r    = ",r(1)
     if(my_pe()==0)write(UREC, *) "aa   = ",sco(1,1)%sco(1)
     if(my_pe()==0)write(UREC, *) "pm   = ",sco(2,1)%sco(1)
     if(my_pe()==0)write(UREC, *) "alpha= ",ak
     if(my_pe()==0)write(UREC, *) "beta = ",bk
     write(msg, *) "cgm(): no convergence; rtr = ", rtr 
     call die(msg)
  endif

9999 continue

  call mre_put(solutions, p, 1)




!=================================================
!  if (cg_para%check /= 0) then
     if(my_pe()==0)  write(UREC,400)"T%shift(  )",  " niter"," sum^Vol|b-Mx|^2"
400 format (1x,a11,      a6,1x,a16)
410 format (2x,a7 ,i2,a1,i6,1x,es16.6)
     do i=1,n
        if ( frdo(i) == 1) goto 100        !------------------------------------------------ GOTO
        call wdagw(aap, sco(1, i)%sco, id)
        call sc_axpy(aap, sco(1,i)%sco, shift(i))
        r(1:2*4*3*volh) = aap(1:2*4*3*volh) - b(1:2*4*3*volh)
        rtr = sc_norm2(r);rtr = global_sum(rtr)
       if(my_pe()==0)  write(UREC,410) "%shift(",i,")", iter_sh(i),    rtr
100 continue
     enddo
!  endif

  cgm_stat%ncall = cgm_stat%ncall + 1
  cgm_stat%niter = niter
  cgm_stat%niter_max = max(cgm_stat%niter_max, niter)
  cgm_stat%niter_tot = cgm_stat%niter_tot + niter
  cgm_iterations_total    = cgm_iterations_total    + niter

  iter = niter

  TIMING2_STOP(timing2_bin_cgm)
stop
end

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