!===============================================================================
!
! module_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"

!-------------------------------------------------------------------------------
module multi_lr_solver

  type :: lr_krylov
     REAL :: shift, tol
     integer :: iter, frdo
     REAL, dimension(:), pointer :: res
  end type lr_krylov

  type :: bsco_field
     COMPLEX, dimension(:,:), pointer :: v
  end type bsco_field

  type(bsco_field), dimension(:), pointer, save :: xx
  type(bsco_field), dimension(:), pointer, save :: pp

  type(lr_krylov), dimension(:), pointer, save :: lrkv
  integer, save :: nl, nr
  integer, save :: mnl=0
  integer, save :: mnr=0


  COMPLEX, parameter :: zone = (ONE, ZERO)
  COMPLEX, parameter :: zzero= (ZERO, ZERO)

contains

  subroutine set_multi_lr_solver(num_lhs, num_rhs, shift, tol)
    use module_vol
    implicit none
    integer :: num_lhs, num_rhs, i
    REAL, dimension(num_lhs) :: shift, tol

    nl = num_lhs
    nr = num_rhs

    if (nl > mnl .or. nr > mnr) then
       mnl = max(nl, mnl)
       mnr = max(nr, mnr)
       nullify(lrkv, xx, pp)
       allocate(lrkv(mnl), xx(mnl), pp(mnl))
       do i = 1, mnl
          allocate(lrkv(i)%res(mnr))
          allocate(xx(i)%v(12*volh_tot, mnr))
          allocate(pp(i)%v(12*volh_tot, mnr))
       enddo
    endif

    do i = 1, nl
       lrkv(i)%shift =  shift(i)
       lrkv(i)%tol   =  tol(i)
       lrkv(i)%iter  =  0
       lrkv(i)%frdo  =  0
       lrkv(i)%res(:)=  ONE
    enddo
  end subroutine set_multi_lr_solver

  subroutine get_residuals(res, sxi)
    implicit none
    integer :: i
    REAL, dimension(nr) :: res
    COMPLEX , dimension(nr, nr) :: sxi, tmp
#ifdef LAPACK
    call zgemm('C','N', nr, nr, nr, zone, sxi,  nr, sxi, nr, zzero, tmp, nr)
#else
    call die("multi_lr_solver needs LAPACK")
#endif
    do i = 1, nr
       res(i) = tmp(i,i)
    enddo

  end subroutine

end

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