!===============================================================================
!
! multi_lr_solver.F90 - multi LR solver  ( A + a(i) ) x(i,j) = b(j)
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2012 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 mbcg_test()
  use module_cg
  use module_vol
  use module_rhmc
  use multi_lr_solver
  use module_input
  implicit none
  integer :: n, nrhs, id
  REAL, allocatable:: b(:,:), tol(:)
  REAL :: tol0
  integer :: i, iters
  external :: wdagw_r8

  if (input%test_multi_shift_block_cg == 0 .and. &
      input%test_multi_shift_block_cg_qr == 0) return

  nl = ratapp(0)%shift
  nr = max(input%test_multi_shift_block_cg, input%test_multi_shift_block_cg_qr)
  id = 1

  allocate(tol(nl))
  allocate(b(24*volh_tot, nr))

  do i = 1, nr
     call ran_gauss_volh(NDIRAC * NCOL, b(1,i), HALF, EVEN)
  enddo

  !
  ! tolerance setting
  !
  call get_cg_res(tol0, 0)
  tol = tol0
  if (associated(relax)) tol(1:size(relax)) = tol0 * relax(1:size(relax))

  call set_multi_lr_solver(nl, nr, ratapp(0)%bbar, tol)
  if (input%test_multi_shift_block_cg /= 0)  call multi_shift_blockcg(wdagw_r8, id, b, iters)
  if (input%test_multi_shift_block_cg_qr /= 0)  call multi_shift_blockcg_qr(wdagw_r8, id, b, iters)

stop
end

!-------------------------------------------------------------------------------
subroutine check_multi_lr_solver(matrix, id, b)
  use multi_lr_solver
  use module_vol
  use module_function_decl
  implicit none
  COMPLEX,dimension(12*volh_tot, nr) :: b
  integer,intent(in):: id
  COMPLEX, dimension(12*volh_tot) :: r
  integer, save :: count=0
  integer :: i, il, ir
  REAL ::tmp, rtr(nr), rmin, rmax, rave

  if(my_pe()==0 .and. count==0) then
     write(UREC,400)"T%shift(  )",  " niter"," sum^Vol|b-Mx|^2", "min", "max"
     count=1
  endif

  do il = 1, nl
     if ( lrkv(il)%frdo == 1) cycle
     rave = ZERO
     rmax = -99999
     rmin =  99999
     do ir = 1, nr
        call matrix(r, xx(il)%v(1,ir), id)
        tmp = ZERO
        !$omp parallel do reduction(+: tmp)
        do i = 1, 12*volh
          r(i) = r(i) + lrkv(il)%shift * xx(il)%v(i,ir) - b(i,ir)
          tmp = tmp + real(r(i))**2 + aimag(r(i))**2
        enddo
        rtr(ir) = global_sum(tmp)
        rave = rave + rtr(ir)
        rmax = max(rmax, rtr(ir))
        rmin = min(rmin, rtr(ir))
     enddo
     if(my_pe()==0)  write(UREC,410) "%shift(",il,")", lrkv(il)%iter, rave/nr, rmin, rmax
  enddo
  400 format (1x,a11,      a6,1x,3(a16))
  410 format (2x,a7 ,i2,a1,i6,1x,3(es16.6))
end

!!!===============================================================================
!-------------------------------------------------------------------------------
subroutine matinvmul_local(out, in, n) ! out = in^-1 out
  implicit none
  COMPLEX, dimension(n, n) :: out, in, tmp
  integer :: ipiv(n), i, n
#ifdef LAPACK
  tmp = in
  call ZGESV( n, n, tmp, n, ipiv, out, n, i )
#else
  call die("multi_lr_solver needs LAPACK")
#endif
end

!-------------------------------------------------------------------------------
subroutine matinv_local(inout, n)
  implicit none
  COMPLEX, dimension(n, n) :: inout, unit
  integer :: ipiv(n), i, n, info
#ifdef LAPACK
  unit = ZERO
  do i = 1, n
     unit(i, i) = ONE
  enddo

  call ZGESV( n, n, inout, n, ipiv, unit, n, info )
  inout = unit
#else
  call die("multi_lr_solver needs LAPACK")
#endif
end

!-------------------------------------------------------------------------------
subroutine get_matinv_local(out, in, n)
  implicit none
  COMPLEX, dimension(n, n) :: out, in, tmp
  integer :: ipiv(n), i, n, info
#ifdef LAPACK
  out = ZERO
  do i = 1, n
     out(i, i) = ONE
  enddo

  tmp = in
  call ZGESV( n, n, tmp, n, ipiv, out, n, info )
#else
  call die("multi_lr_solver needs LAPACK")
#endif
end

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