!===============================================================================
!
! mre.F90 - Chronological Inverter by Minimal Residual Extrapolation
!           hep-lat/9509012
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2003 Hinnerk Stueben
!               2009 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"

#ifdef PRECISION_R16
# define vec_norm2_c8  vec_norm2_c16
# define vec_cdotc_c8  vec_cdotc_c16
# define vec_dot_c8  vec_dot_c16
#endif


!-------------------------------------------------------------------------------
subroutine mre_put(basis, sc_field, reset)  ! add a solution

  use module_mre
  use module_p_interface
  use module_vol
  implicit none

  type(type_mre), intent(inout) :: basis
  SPINCOL_FIELD,  intent(in)    :: sc_field
  integer,        intent(in)    :: reset

  P_SPINCOL_FIELD               :: tmp
  integer                       :: i

  if (mre_n_vec == 0) then
     return
  endif

  call mre_allocate(basis)

  if (reset /= 0) then
     basis%rank = 0
     return
  endif

  tmp => basis%vec(mre_n_vec)%sc

  do i = mre_n_vec, 2, -1
     basis%vec(i)%sc => basis%vec(i - 1)%sc
  enddo

  basis%vec(1)%sc => tmp
  call sc_copy(basis%vec(1)%sc, sc_field)

  if (basis%rank < mre_n_vec) basis%rank = basis%rank + 1

end

!-------------------------------------------------------------------------------
!!subroutine mre_get(basis, matrix_mult, trial, phi, para, conf)
!!
!!  ! get trial solution
!!
!!  use typedef_hmc
!!  use module_function_decl
!!  use module_mre
!!  use module_vol
!!  implicit none
!!
!!  type(type_mre), intent(inout) :: basis
!!  external                      :: matrix_mult
!!  SPINCOL_FIELD,  intent(out)   :: trial
!!  SPINCOL_FIELD,  intent(in)    :: phi
!!  type(hmc_para), intent(in)    :: para
!!  type(hmc_conf), intent(in)    :: conf
!!
!!  type(type_mre), save          :: mv  ! "Matrix * v"
!!  COMPLEX, target               :: g(mre_n_vec, mre_n_vec + 1)
!!  COMPLEX, pointer              :: b(:)
!!  integer                       :: size_g
!!  integer                       :: i
!!  integer                       :: j
!!  integer                       :: s
!!  integer                       :: c
!!  integer                       :: rest
!!
!!  if (mre_n_vec == 0 .or. .not. associated(basis%vec) .or. basis%rank == 0) then
!!     call sc_copy(trial, phi)
!!     return
!!  endif
!!
!!  if (basis%rank == 1) then
!!     call sc_copy(trial, basis%vec(1)%sc)
!!     return
!!  endif
!!
!!  size_g = mre_n_vec * (mre_n_vec + 1) * SIZE_COMPLEX
!!
!!  b => g(:, mre_n_vec + 1)  ! storage arrangement for global sum
!!                            ! => one global sum for everything
!!
!!  call mre_allocate(mv)
!!  call mre_gram_schmidt(basis)
!!  
!!  do i = 1, basis%rank
!!     b(i) = sc_cdotc(basis%vec(i)%sc, phi)
!!     call matrix_mult(mv%vec(i)%sc, basis%vec(i)%sc, para, conf)
!!  enddo
!!
!!  do i = 1, basis%rank
!!     g(i, i) = sc_norm2(mv%vec(i)%sc)
!!     do j = i + 1, basis%rank
!!        g(i, j) = sc_cdotc(mv%vec(i)%sc, mv%vec(j)%sc)
!!        g(j, i) = conjg(g(i, j))
!!     enddo
!!  enddo
!!
!!  call global_sum_vec(size_g, g)
!!
!!  call mre_gauss_jordan(g, b, basis%rank, mre_n_vec)
!!
!!  ! calculation of "trial" with doubled data re-use:
!!
!!  call sc_cax2(trial, basis%vec(1)%sc, b(1), basis%vec(2)%sc, b(2))
!!
!!  rest = mod(basis%rank, 2)
!!
!!  do j = 3, basis%rank - rest, 2
!!     call sc_caxpy2(trial, basis%vec(j)%sc,   b(j), &
!!                           basis%vec(j+1)%sc, b(j+1))
!!  enddo
!!
!!  if (rest == 1) then
!!     j = basis%rank
!!     call sc_caxpy(trial, basis%vec(j)%sc, b(j))
!!  endif
!!
!!end
!!
!-------------------------------------------------------------------------------
subroutine mre_allocate(basis)

  use module_mre
  use module_p_interface
  use module_vol
  implicit none

  type(type_mre), intent(inout) :: basis
  integer                       :: i

  if (.not. associated(basis%vec)) then
     allocate(basis%vec(mre_n_vec))
     do i = 1, mre_n_vec
        nullify(basis%vec(i)%sc)  
        call allocate_sc_field(basis%vec(i)%sc)
     enddo
     basis%rank = 0
  endif

end

!-------------------------------------------------------------------------------
subroutine mre_gram_schmidt(basis)

  ! Golub and van Loon, Matrix Computations (3rd ed.), p. 232

  use module_function_decl
  use module_mre
  use module_vol
  implicit none

  type(type_mre), intent(inout) :: basis

  integer :: k, j
  REAL    :: r_kk, r_kj

  do k = 1, basis%rank
      r_kk = sc_norm2(basis%vec(k)%sc)
      r_kk = global_sum(r_kk)
      r_kk = ONE / sqrt(r_kk)
      call sc_scale(basis%vec(k)%sc, r_kk)
      do j = k + 1, basis%rank
         r_kj = sc_dot(basis%vec(k)%sc, basis%vec(j)%sc)
         r_kj = global_sum(r_kj)
         call sc_axpy(basis%vec(j)%sc, basis%vec(k)%sc, -r_kj)
      enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine mre_gauss_jordan(a, b, n, np)

  ! Numerical Recipes in Fortran (2nd ed.), p. 30
  ! inv(a) i.e. a is not unscrambled

  implicit none

  integer, intent(in)    :: n, np
  COMPLEX, intent(inout) :: a(np,np), b(np)

  integer :: ipiv(n)
  integer :: i, j, k, l, ll
  integer :: irow, icol

  REAL    :: big, tmp
  COMPLEX :: dum
  COMPLEX :: pivinv

  ipiv = 0

  do i = 1, n

     big = ZERO
     do j = 1, n
        if (ipiv(j) /= 1) then
           do k = 1, n
              if (ipiv(k) == 0) then
                 tmp = abs(a(j, k))
                 if (tmp >= big) then
                    big = tmp
                    irow = j
                    icol = k
                 endif
              else if (ipiv(k) > 1) then
                 call die("mre_gauss_jordan(): singular matrix 1")
              endif
           enddo
        endif
     enddo

     ipiv(icol) = ipiv(icol) + 1

     if (irow /= icol) then
        do l = 1, n
           dum = a(irow, l)
           a(irow, l) = a(icol, l)
           a(icol, l) = dum
        enddo
        dum = b(irow)
        b(irow) = b(icol)
        b(icol) = dum
     endif

     if (a(icol, icol) == ZERO ) then
        call die("mre_gauss_jordan(): singular matrix 2")
     endif

     pivinv = ONE / a(icol, icol)
     !!a(icol, icol) = ONE  !! only needed for inv(a)

     do  l = 1, n
        a(icol, l) = a(icol, l) * pivinv
     enddo

     b(icol) = b(icol) * pivinv

     do ll = 1, n
        if (ll /= icol) then
           dum = a(ll, icol)
           a(ll, icol) = ZERO
           do l = 1, n
              a(ll, l) = a(ll, l) - a(icol, l) * dum
           enddo
           b(ll) = b(ll) - b(icol) * dum
        endif
     enddo

  enddo

end

!===============================================================================
!===============================================================================
!
! mre2
!
! no need to change mre_gauss_jordan
!                   mre_gauss_jordan_r4 need?
!
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
subroutine mre2_get(matrix, basis, trial, phi, id, ip)
  ! get trial solution
  use module_function_decl
  use module_mre2
  use module_vol
  use vec
  implicit none

  type(type_mre2),  intent(inout) :: basis
  COMPLEX,       intent(out)      :: trial(:)
  COMPLEX,target,intent(in)       :: phi(:)
  COMPLEX,pointer                 :: tmp(:)
  integer,          intent(in) :: id
  integer,optional, intent(in) :: ip
  external :: matrix

  type(type_mre2),save          :: mv  ! "Matrix * v"
  COMPLEX, target               :: g(mre2_n_vec, mre2_n_vec + 1)
  COMPLEX, pointer              :: b(:)
  integer                       :: i, j, rest, size_g

  if (mre2_n_vec == 0 .or. .not. associated(basis%vec) .or. basis%rank == 0) then
     trial = phi ; return
  endif

  if (basis%rank == 1) then
     trial = basis%vec(1)%x ; return
  endif

  size_g = mre2_n_vec * (mre2_n_vec + 1) * SIZE_COMPLEX
  b => g(:, mre2_n_vec + 1)  ! storage arrangement for global sum
                             ! => one global sum for everything
  call mre2_allocate(mv, size(trial))
  call mre2_gram_schmidt(basis)
  do i = 1, basis%rank
     tmp => phi
     b(i) = vec_cdotc_c8(basis%vec(i)%x, tmp)
     if (present(ip)) then
        call matrix(mv%vec(i)%x, basis%vec(i)%x, id, ip)
     else
        call matrix(mv%vec(i)%x, basis%vec(i)%x, id)
     endif
  enddo
  do i = 1, basis%rank
     g(i, i) = vec_norm2_c8(mv%vec(i)%x)
     do j = i + 1, basis%rank
        g(i, j) = vec_cdotc_c8(mv%vec(i)%x, mv%vec(j)%x)
        g(j, i) = conjg(g(i, j))
     enddo
  enddo
  call global_sum_vec(size_g, g)
  call mre_gauss_jordan(g, b, basis%rank, mre2_n_vec)

  trial = b(1)*basis%vec(1)%x + b(2)*basis%vec(2)%x
  rest = mod(basis%rank, 2)
  do j = 3, basis%rank - rest, 2
     trial = trial + b(j)*basis%vec(j)%x + b(j+1)*basis%vec(j+1)%x
  enddo
  if (rest == 1) then
     j = basis%rank
     trial = trial + b(j)*basis%vec(j)%x
  endif


!  do j = 2, basis%rank
!     trial = trial + b(j)*basis%vec(j)%x
!  enddo
!  call mre2_deallocate(mv)

  do i = 1, mre2_n_vec
     deallocate(mv%vec(i)%x)
     nullify(mv%vec(i)%x)
  enddo
  deallocate(mv%vec)
  nullify(mv%vec)
end

!-------------------------------------------------------------------------------
! for complex(RKIND)
!-------------------------------------------------------------------------------
subroutine mre2_put(basis, field, reset, vec_size)  ! add a solution
  use module_mre2
  implicit none

  type(type_mre2), intent(inout) :: basis
  integer,        intent(in)     :: reset, vec_size
  COMPLEX,        intent(in)     :: field(vec_size)
  COMPLEX,pointer                :: tmp(:)
  integer                        :: i

  if (mre2_n_vec == 0) return
  call mre2_allocate(basis, vec_size)

  if (reset /= 0) then
     basis%rank = 0 ; return
  endif

  tmp => basis%vec(mre2_n_vec)%x
  do i = mre2_n_vec, 2, -1
     basis%vec(i)%x => basis%vec(i - 1)%x
  enddo

  basis%vec(1)%x => tmp
  basis%vec(1)%x = field
  if (basis%rank < mre2_n_vec) basis%rank = basis%rank + 1
end

!-------------------------------------------------------------------------------
subroutine mre2_allocate(basis, vec_size)
  use module_mre2
  implicit none
  type(type_mre2), intent(inout) :: basis
  integer :: i, vec_size

  if (.not. associated(basis%vec)) then
     allocate(basis%vec(mre2_n_vec))
     do i = 1, mre2_n_vec
        nullify(basis%vec(i)%x)  
        allocate(basis%vec(i)%x(vec_size))
        basis%vec(i)%x = ZERO
     enddo
     basis%rank = 0
  endif
end
!-------------------------------------------------------------------------------
subroutine mre2_gram_schmidt(basis)
  ! Golub and van Loon, Matrix Computations (3rd ed.), p. 232
  use module_function_decl
  use module_mre2
  use vec
  implicit none
  type(type_mre2), intent(inout) :: basis
  integer :: k, j
  REAL    :: r_kk, r_kj

  do k = 1, basis%rank
      r_kk = vec_norm2_c8(basis%vec(k)%x)
      r_kk = global_sum(r_kk)
      r_kk = ONE / sqrt(r_kk)
      basis%vec(k)%x = basis%vec(k)%x * r_kk
      do j = k + 1, basis%rank
         r_kj = vec_dot_c8(basis%vec(k)%x, basis%vec(j)%x)
         r_kj = global_sum(r_kj)
         basis%vec(j)%x = basis%vec(j)%x  -r_kj * basis%vec(k)%x
      enddo
  enddo
end
!===============================================================================
