!===============================================================================
!
! gmres.F90 - solves "matrix_mult * x = b" and returns number of iterations
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2008-2010 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_gmres
  use typedef

  type(sco_field),dimension(:),pointer,save :: v

end

!-------------------------------------------------------------------------------
subroutine gmres(x, b, id, iter, res)
  use module_function_decl
  use module_check_solution
  use module_action
  use module_cg
  use module_vol
  use module_counter
  implicit none

  SPINCOL_OVERINDEXED,  intent(inout) :: x
  SPINCOL_OVERINDEXED,  intent(in)    :: b
  integer,              intent(out)   :: iter
  integer,              intent(in)    :: id
  DOUBLE,               intent(in)    :: res

  SPINCOL_OVERINDEXED :: r
  DOUBLE        :: bb, rtr, dtmp
  integer       :: i, niter
  character(72) :: msg

!
! needed for checking solution
!
  DOUBLE        :: norm(3)
  integer, save :: headline_check_written = 0
  character(*), parameter :: key_chk = "%cgChk"
  character(*), parameter :: fmt_chk_h = "(1x, 2a, a6, 4a20)"
  character(*), parameter :: fmt_chk_b = "(1x, a7, i6, 3e20.10, i20)"

!-------------------------------------------------------------------------------

  TIMING_START(timing_bin_cg)

  bb = 0.0_8
  !$omp parallel do reduction(+: bb) private(dtmp)
  do i = 1, size_sc_field
     dtmp = b(i)
     bb = bb + dtmp**2
  enddo
  call global_sum_vec(1, bb)

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

  do niter = 1, cg_para%maxiter
     call gmres_m(x, b, r, id, 10, rtr)
     if (stop_condition(rtr, res, bb)) goto 9999
  enddo

  niter = niter - 1

  if (cg_para%log /= 2) then
     write(msg, *) "cg(): no convergence; rtr = ", rtr 
     call die(msg)
  endif

9999 continue

  call update_cg_stat(gmres_stat, niter, 0)
  call update_cg_stat(cg_stat, niter, 0)

  iter = niter

  TIMING_STOP(timing_bin_cg)

  if (cg_para%check /= 0) then  ! check solution

     call check_solution(id, x, b, norm)

     if (headline_check_written == 0) then
        if (my_pe() == 0) then
           write(UREC, fmt_chk_h) &
               "T", key_chk, "traj", "rtr", "Rb", "Rx", "iterations"
        endif
        headline_check_written = 1
     endif
     
     if (my_pe() == 0) then
        write(UREC, fmt_chk_b) &
           key_chk, counter%traj, rtr, &
           norm(1)/norm(2), norm(1)/norm(3), iter
     endif

  endif

end

!-------------------------------------------------------------------------------
!!subroutine gmres_m(x, b, r, v, id, m, rtr)
  subroutine gmres_m(x, b, r, id, m, rtr)

  use module_gmres
  use module_p_interface
  use module_function_decl
  use module_vol
  implicit none

  SPINCOL_OVERINDEXED,  intent(inout) :: x
  SPINCOL_OVERINDEXED,  intent(in)    :: b
  SPINCOL_OVERINDEXED,  intent(out)   :: r
  integer,              intent(in)    :: m
  integer,              intent(in)    :: id
  REAL,                 intent(out)   :: rtr

  integer :: i, j, ierr
  REAL :: vv, beta, inv, r2
  REAL :: c,s,h1,h2,g1,g2
  REAL, allocatable :: h(:,:), g(:), y(:), q(:,:), yy(:),htmp(:,:)

  allocate(h(m+1,m))
  allocate(htmp(m+1,m))
  allocate(g(m+1))
  allocate(y(m))
  allocate(yy(m+1))

  if (.not. associated(v)) then
     allocate(v(m+1), STAT = ierr)
     if (ierr /= 0) then
        call stderr2_int("allocation failed", 1, ierr)
        call die("gmres: allocation failed x")
     endif
     do i = 1, m+1
        ALLOCATE_SC_OVERINDEXED(v(i)%sco)
     enddo
  endif

!-------------------------------------------------------------------------------

  call wdagw(v(1)%sco, x, id)
  vv = ZERO
  !$omp parallel do reduction(+: vv)
  do i = 1, size_sc_field
     v(1)%sco(i) = b(i) - v(1)%sco(i)
     vv = vv + v(1)%sco(i)**2
  enddo
  call global_sum_vec(1, vv)

  beta = sqrt(vv)
  inv = ONE/beta

  !$omp parallel do
  do i = 1, size_sc_field
     v(1)%sco(i) = v(1)%sco(i) * inv
  enddo

  h=ZERO
  g=ZERO
  g(1)=beta
  do j = 1, m
     call wdagw(v(j+1)%sco, v(j)%sco, id)
     do i = 1, j
        h(i,j) = sc_dot(v(j+1)%sco, v(i)%sco)
        h(i,j) = global_sum(h(i,j))
        call sc_axpy(v(j+1)%sco, v(i)%sco, -h(i,j))
     enddo
     call normalize_sc(v(j+1)%sco, h(j+1,j))
  enddo

htmp=h

  do i = 1, m
     r2 = ONE/sqrt(h(i,i)**2 + h(i+1,i)*h(i+1,i))
     c = h(i,  i)*r2
     s = h(i+1,i)*r2
     do j = i, m
        h1 = c*h(i,j) + s*h(i+1,j)
        h2 =-s*h(i,j) + c*h(i+1,j)
        h(i,  j) = h1
        h(i+1,j) = h2
     enddo
     g1 = c*g(i) + s*g(i+1)
     g2 =-s*g(i) + c*g(i+1)
     g(i)   = g1
     g(i+1) = g2
  enddo

  do i = m, 1, -1
     do j = i+1, m
        g(i) = g(i) - h(i,j) * y(j)
     enddo
     y(i) = g(i) / h(i,i)
  enddo

  do j = 1, m
     !$omp parallel do
     do i = 1, size_sc_field
        x(i) = x(i) + v(j)%sco(i) * y(j)
     enddo
  enddo

  yy=ZERO
  yy(1)=beta
  do i = 1, m+1
     do j = 1, m
        yy(i) = yy(i) - htmp(i,j) * y(j)
     enddo
  enddo

  !$omp parallel do
  do i = 1, size_sc_field
     r(i) = v(1)%sco(i) * yy(1)
  enddo
  do j = 2, m+1
     !$omp parallel do
     do i = 1, size_sc_field
        r(i) = r(i) + v(j)%sco(i) * yy(j)
     enddo
  enddo

  rtr = g(m+1)**2

  deallocate(h)
  deallocate(htmp)
  deallocate(g)
  deallocate(y)
  deallocate(yy)
end
#ifdef BQCD_DDHMC
!-------------------------------------------------------------------------------
subroutine gmres_dd(matrix, x, b, id, ip, iter, res, m)
  use module_check_solution
  use module_cg
  use module_dd
  implicit none
  integer, intent(out)   :: iter
  integer, intent(in)    :: id,ip,matrix, m
  DOUBLE,  intent(in)    :: res

  complex(8),intent(inout):: x(12*ld%lat%volh)
  complex(8),intent(in)   :: b(12*ld%lat%volh)
  complex(8) :: r(12*ld%lat%volh), v(12*ld%lat%volh,m+1), h(m+1,m), y(m), g(m+1)
  complex(8), external :: ddsc_cdotc
  real(8), external :: ddsc_norm2
  integer :: i, j, niter
  real(8) :: beta, bb, tmp, rtr

  bb = ddsc_norm2(b)
  do niter = 1, cg_para%maxiter
    call muldd_aggre(v(1,1), x, id, ip, matrix)
    v(:,1) = b(:) - v(:,1)
    rtr=ddsc_norm2(v(:,1))
    if (stop_condition(rtr, res, bb)) goto 9999
    call normalize_vecdd(v(1,1), beta)

    h=ZERO;g=ZERO;g(1)=beta
    do j = 1, m
       call muldd_aggre(v(1,j+1), v(1,j), id, ip, matrix)
       do i = 1, j
          h(i,j) = ddsc_cdotc(v(1,j+1), v(1,i))
          v(:,j+1) = v(:,j+1) - h(i,j) * v(:,i)
       enddo
       call normalize_vecdd(v(1,j+1), tmp)
       h(j+1,j)=tmp
    enddo

    call min_gmhy(y,h,g,m)
    do j = 1, m
       x(:) = x(:) + v(:,j) * y(j)
    enddo
  enddo

  niter = niter - 1
  if (cg_para%log /= 2) then
     write(0, *) "gmres_dd(): no convergence; rtr = ", rtr ; stop
  endif

  9999 continue

  if(matrix==MTDAGMT_DD) then
     iter=niter * (m   + 1)
  else
     iter=niter * (dble(m+1)/TWO)
  endif
  call update_cg_stat(dd_stat, iter, 0)

end

!-------------------------------------------------------------------------------
subroutine gmres_dd_r4(matrix, x, b, id, ip, iter, res, m)
  use module_check_solution
  use module_cg
  use module_dd
  implicit none
  integer, intent(out)   :: iter
  integer, intent(in)    :: id,ip,matrix, m
  DOUBLE,  intent(in)    :: res

  complex(4),intent(inout):: x(12*ld%lat%volh)
  complex(4),intent(in)   :: b(12*ld%lat%volh)
  complex(4) :: r(12*ld%lat%volh), v(12*ld%lat%volh,m+1)
  complex(4), external :: ddsc_cdotc_r4
  real(4), external :: ddsc_norm2_r4

  integer :: i, j, niter
  complex(4) :: h1,h2
  complex(4) :: h(m+1,m), g(m+1), y(m)
  complex(4) :: g1,g2,c
  real(4) :: vv, r2, beta, inv, s
  real(4)::bb, tmp, rtr
!-------------------------------------------------------------------------------

  bb = ddsc_norm2_r4(b)

  do niter = 1, cg_para%maxiter
    call muldd_aggre_r4(v(1,1), x, id, ip, matrix)
    v(:,1) = b(:) - v(:,1)
    rtr=ddsc_norm2_r4(v(1,1))
    if (stop_condition(dble(rtr), res, dble(bb))) goto 9999

    beta=ddsc_norm2_r4(v(1,1))
    beta=sqrt(beta)
    v(:,1)=v(:,1)/beta

    h=ZERO;  g=ZERO;  g(1)=beta
    do j = 1, m
       call muldd_aggre_r4(v(1,j+1), v(1,j), id, ip, matrix)
       do i = 1, j
          h(i,j) = ddsc_cdotc_r4(v(1,j+1), v(1,i))
          v(:,j+1) = v(:,j+1) - h(i,j) * v(:,i)
       enddo
       tmp=ddsc_norm2_r4(v(1,j+1))
       tmp=sqrt(tmp)
       v(:,j+1)=v(:,j+1)/tmp
       h(j+1,j)=tmp
    enddo

    do i = 1, m
       r2 = ONE/sqrt( conjg(h(i,i))*h(i,i) + real(h(i+1,i))**2 )
       c = h(i,  i)*r2
       s = h(i+1,i)*r2
       do j = i, m
          h1 = conjg(c)*h(i,j) + s*h(i+1,j)
          h2 =-      s *h(i,j) + c*h(i+1,j)
          h(i,  j) = h1
          h(i+1,j) = h2
       enddo
       g1 = conjg(c)*g(i) + s*g(i+1)
       g2 =-      s *g(i) + c*g(i+1)
       g(i)   = g1
       g(i+1) = g2
    enddo

    do i = m, 1, -1
       do j = i+1, m
          g(i) = g(i) - h(i,j) * y(j)
       enddo
       y(i) = g(i) / real(h(i,i))
    enddo

    do j = 1, m
       x(:) = x(:) + v(:,j) * y(j)
    enddo

  enddo

  niter = niter - 1
  if (cg_para%log /= 2) then
     write(0, *) "gmres_dd_r4(): no convergence; rtr = ", rtr ; stop
  endif

9999 continue

  if(matrix==MTDAGMT_DD) then
     iter=niter * (m   + 1)
  else
     iter=niter * (dble(m+1)/TWO)
  endif
  call update_cg_stat(dd_stat, 0, iter)
end

!-------------------------------------------------------------------------------
subroutine gmrespj_dd(matrix, x, b, id, ip, iter, res, m)
  use module_check_solution
  use module_cg
  use module_dd
  use module_dd_evec
  implicit none
  integer, intent(out)   :: iter
  integer, intent(in)    :: id,ip,matrix, m
  DOUBLE,  intent(in)    :: res
  complex(8),intent(inout):: x(12*ld%lat%volh)
  complex(8),intent(in)   :: b(12*ld%lat%volh)
  complex(8) :: r(12*ld%lat%volh), v(12*ld%lat%volh,m+1), vtmp(12*ld%lat%volh,defeig+1)
  complex(8), external :: ddsc_cdotc
  real(8), external :: ddsc_norm2
  integer :: i, j, k, niter, lwork, info, mdm
  real(8) :: vv, beta, inv, bb, tmp, rtr, ttt(m), rtr_real
  complex(8) :: h(m+1,m), g(m+1), yy(m+1), htmp(m+1,m),y(m), r_dummy(defeig,defeig)
  complex(8) :: eval(defeig),evec(m,defeig), gtmp(m+1,1), gg(m,m),ff(m,m)
  complex(8)::work(80)
  complex(8) :: zpone, zmone

  zpone = dcmplx( ONE,ZERO)
  zmone = dcmplx(-ONE,ZERO)
  lwork=80


#ifdef LAPACK
  if (m<=defeig) call die("gmresdr impossible m<nev")
  if (evecdd(ip,mdm)%initial) return

  mdm = 1
  if (matrix==MTDAG_DD) mdm = 2

  bb = ddsc_norm2(b)

do niter = 1, cg_para%maxiter

  call muldd_aggre(r, x, id, ip, matrix)
  r = b - r
  rtr=ddsc_norm2(r)
  if (stop_condition(rtr, res, bb)) goto 9999

  v(:,1)=r
  call normalize_vecdd(v(1,1), beta)

  h=ZERO
  do j = 1, m-defeig
     call muldd_aggre(v(1,j+1), v(1,j), id, ip, matrix)
     do i = 1, j
        h(i,j) = ddsc_cdotc(v(1,i), v(1,j+1))  !! must be this order
        v(:,j+1) = v(:,j+1) - h(i,j) * v(:,i)
     enddo
     call normalize_vecdd(v(1,j+1), tmp)
     h(j+1,j)=tmp
  enddo
  do j = m-defeig+1,m
     call muldd_aggre(v(1,j+1), evecdd(ip,mdm)%x(1,j-m+defeig), id, ip, matrix)
     do i = 1, j
        h(i,j) = ddsc_cdotc(v(1,i), v(1,j+1))  !! must be this order
        v(:,j+1) = v(:,j+1) - h(i,j) * v(:,i)
     enddo
     call normalize_vecdd(v(1,j+1), tmp)
     h(j+1,j)=tmp
  enddo
  g=ZERO;  g(1)=beta
  beta=h(m+1,m)           !!! NEW beta


  htmp=h;  gtmp(:,1)=g
  call zgels("N", m+1, m, 1, htmp, m+1, gtmp, m+1, work,lwork, info)
  if(info/=0)call die("zgels failed")
  y(1:m)=gtmp(1:m,1)
  do j = 1, m-defeig
     x(:) = x(:) + v(:,j) * y(j)
  enddo
  do j = m-defeig+1,m
     x(:) = x(:) + evecdd(ip,mdm)%x(:,j-m+defeig) * y(j)
  enddo


  gtmp(:,1)=g
  call zgemv("N", m+1, m, zmone, h, m+1, y, 1, zpone, gtmp, 1)
  yy(:)=gtmp(:,1)

  r(:) = v(:,1) * yy(1)
  do i = 2, m+1
     r(:) = r(:) + v(:,i) * yy(i)
  enddo
  rtr=ddsc_norm2(r)

  call muldd_aggre(r, x, id, ip, matrix)
  r=b-r
  rtr_real=ddsc_norm2(r)
  if(abs(rtr-rtr_real) > min(rtr,rtr_real)*100.0_8 .and. &
     max(rtr,rtr_real) > res ) then
    write(0,*)"ip,mid,matrix,rtr,rtrreal",ip,id,matrix,rtr,rtr_real
    call die(" difference rtr and rtr_real is bit at gmres_morgan")
  endif


ff=ZERO
htmp=ZERO
do i=1,m+1
   do j=1,m-defeig
      htmp(i,j)=ddsc_cdotc(v(1,i),v(1,j))
   enddo
   do j=m-defeig+1,m
      htmp(i,j)=ddsc_cdotc(v(1,i),evecdd(ip,mdm)%x(1,j-m+defeig))
   enddo
enddo

do i=1,m
do j=1,m
do k=1,m+1
   ff(i,j)=ff(i,j)+conjg(h(k,i))*htmp(k,j)
enddo
enddo
enddo

gg=ZERO
do i=1,m
do j=1,m
do k=1,m+1
   gg(i,j)=gg(i,j)+conjg(h(k,i))*h(k,j)
enddo
enddo
enddo

  call zgeneigen(eval, evec, gg, ff, m, defeig)

  vtmp=ZERO
  do i=1,defeig
     do j=1, m - defeig
        vtmp(:,i) = vtmp(:,i) + v(:,j) * evec(j,i)
     enddo
     do j=m - defeig+1, m
        vtmp(:,i) = vtmp(:,i) + evecdd(ip,mdm)%x(:,j-m+defeig) * evec(j,i)
     enddo
  enddo


  call gram_schmidt(vtmp, r_dummy, 12*ld%lat%volh, defeig, .false.)
  do i=1,defeig
     v(:,i)=vtmp(:,i)
  enddo
 

  !!!! check
  call gmresdr_eigcheck(matrix, v(1:12*ld%lat%volh,1:defeig), eval(1:defeig), defeig, id,ip)

  do i=1,defeig
     evecdd(ip,mdm)%x(:,i)=v(:,i)
  enddo
  if (stop_condition(rtr, res, bb)) goto 9999
enddo

  niter = niter - 1
  if (cg_para%log /= 2) then
     write(0, *) "gmres_dd_morgam(): no convergence; rtr = ", rtr ; stop
  endif

9999 continue

  if(matrix==MTDAGMT_DD) then
     iter=niter * (m   + 1) +1
  else
     iter=niter * (dble(m)/TWO + 1) +1
  endif
  evecdd(ip,mdm)%x(1:12*ld%lat%volh,1:defeig+1)=v(1:12*ld%lat%volh,1:defeig+1)
  evecdd(ip,mdm)%h(1:defeig+1,1:defeig)=h(1:defeig+1,1:defeig)
  evecdd(ip,mdm)%fresh=.true.
  evecdd(ip,mdm)%initial=.false.

  call update_cg_stat(dd_stat, iter, 0)
#else
  call die("gmres_morgan needs LAPACK")
#endif
end

!-------------------------------------------------------------------------------
subroutine gmresdr_dd(matrix, x, b, id, ip, iter, res, m)
  use module_check_solution
  use module_cg
  use module_dd
  use module_dd_evec
  implicit none
  integer, intent(out):: iter
  integer, intent(in) :: id,ip,matrix, m
  DOUBLE,  intent(in) :: res
  complex(8),intent(inout):: x(12*ld%lat%volh)
  complex(8),intent(in)   :: b(12*ld%lat%volh)
  complex(8) :: r(12*ld%lat%volh), v(12*ld%lat%volh,m+1), vtmp(12*ld%lat%volh,defeig+1)
  complex(8), external :: ddsc_cdotc, veccdotc
  real(8), external :: ddsc_norm2
  integer :: i, j, k, niter, lwork,info, mdm
  real(8) :: beta, inv, bb, tmp, rtr, rtr_real
  complex(8) :: h(m+1,m), g(m+1), yy(m+1),htmp(m+1,m),y(m), rr(defeig+1,defeig+1), r_dummy(defeig,defeig)
  complex(8) :: p(m+1,defeig+1), eval(defeig),evec(m,defeig), gtmp(m+1,1)
  complex(8)::work(80)
  complex(8) :: zpone, zmone

  zpone = dcmplx( ONE,ZERO)
  zmone = dcmplx(-ONE,ZERO)
  lwork=80

#ifdef LAPACK
  if (m<=defeig) call die("gmresdr impossible m<nev")

  mdm = 1
  if (matrix==MTDAG_DD) mdm = 2

  bb = ddsc_norm2(b)
  call muldd_aggre(r, x, id, ip, matrix)
  r = b - r
  rtr=ddsc_norm2(r)
  if (stop_condition(rtr, res, bb)) goto 9999


if(evecdd(ip,mdm)%initial)then
  v(:,1)=r
  call normalize_vecdd(v(1,1), beta)
  h=ZERO
  do j = 1, m                           !!!!! gmres(m)
     call muldd_aggre(v(1,j+1), v(1,j), id, ip, matrix)
     do i = 1, j
        h(i,j) = ddsc_cdotc(v(1,i), v(1,j+1))  !! must be this order
        v(:,j+1) = v(:,j+1) - h(i,j) * v(:,i)
     enddo
     call normalize_vecdd(v(1,j+1), tmp)
     h(j+1,j)=tmp
  enddo
  g=ZERO;  g(1)=beta
  beta=h(m+1,m)           !!! NEW beta
else
!! PROJECTION
!!
  do i=1,defeig
     g(i)=ddsc_cdotc(evecdd(ip,mdm)%x(1,i),r)! NEW g
  enddo
  htmp=ZERO; gtmp=ZERO
  htmp(1:defeig,1:defeig)=h(1:defeig,1:defeig-1)
  gtmp(1:defeig,1       )=g(1:defeig)

  call zgels("N", m+1, m, 1, htmp, m+1, gtmp, m+1, work,lwork, info)
  if(info/=0) call die("zgels failed")
  y(1:m)=gtmp(1:m,1)
  do j = 1, defeig
     x(:) = x(:) + evecdd(ip,mdm)%x(:,j) * y(j)
  enddo
  yy=ZERO
  do i=1,defeig+1
     do j=1,defeig
        yy(i)=yy(i)+h(i,j)*y(j)
     enddo
  enddo
  do i = 1, defeig+1
     r(:) = r(:) - evecdd(ip,mdm)%x(:,i) * yy(i)
  enddo
  rtr=ddsc_norm2(r)
  write(0,*)rtr
  call muldd_aggre(r, x, id, ip, matrix)
  r=b-r
  rtr=ddsc_norm2(r)
  write(0,*)rtr
  if (stop_condition(rtr, res, bb)) goto 9999
stop
endif


do niter = 1, cg_para%maxiter

  htmp=h;  gtmp(:,1)=g
  call zgels("N", m+1, m, 1, htmp, m+1, gtmp, m+1, work,lwork, info)
  if(info/=0) call die("zgels failed")

  y(1:m)=gtmp(1:m,1)
  do j = 1, m
     x(:) = x(:) + v(:,j) * y(j)
  enddo

  gtmp(:,1)=g
  call zgemv("N", m+1, m, zmone, h, m+1, y, 1, zpone, gtmp, 1)
  yy(:)=gtmp(:,1)

  r(:) = v(:,1) * yy(1)
  do i = 2, m+1
     r(:) = r(:) + v(:,i) * yy(i)
  enddo
  rtr=ddsc_norm2(r)

  call muldd_aggre(r, x, id, ip, matrix)
  r=b-r
  rtr_real=ddsc_norm2(r)

  if(abs(rtr-rtr_real) > min(rtr,rtr_real)*100.0_8 .and. &
     max(rtr,rtr_real) > res ) then
     write(0,*)"ip,mid,matrix,rtr,rtrreal",ip,id,matrix,rtr,rtr_real
     call die(" difference rtr and rtr_real is bit at gmres_dr")
  endif
  if (stop_condition(rtr, res, bb)) goto 9999

  call zhritz(eval, evec, h(1:m,1:m), beta, m, defeig)

  p(1:m,1:defeig)=evec(1:m,1:defeig)
  p(m+1,1:defeig)=dcmplx(ZERO,ZERO)
  call gram_schmidt(p, r_dummy, m+1, defeig, .false.)
  p(:,defeig+1)= yy(:)
  call gram_schmidt_last(p, m+1, defeig+1, .false.)


  !
  ! calculation of new H and V
  !
  htmp=ZERO
  do i=1,m+1
     do j=1,defeig
        do k=1, m
           htmp(i,j)=htmp(i,j)+h(i,k)*p(k,j)
        enddo
     enddo
  enddo

  h=ZERO
  do i=1,defeig+1
     do j=1,defeig
        do k=1, m+1
           h(i,j)=h(i,j)+conjg(p(k,i)) *htmp(k,j)
        enddo
     enddo
  enddo

  vtmp=ZERO
  do i=1,defeig+1
     do j=1,m+1
        vtmp(:,i) = vtmp(:,i) + v(:,j) * p(j,i)
     enddo
  enddo

  call gram_schmidt_last(vtmp, 12*ld%lat%volh, defeig+1, .false.)

  do i=1,defeig+1
     v(:,i)=vtmp(:,i)
  enddo

  !!!! check
!!  call gmresdr_eigcheck(matrix, v(1:12*ld%lat%volh,1:defeig), eval(1:defeig), defeig, id,ip)

  do j = defeig+1, m
     call muldd_aggre(v(1,j+1), v(1,j), id, ip, matrix)
     do i = 1, j
        h(i,j) = ddsc_cdotc(v(1,i), v(1,j+1))  !! must be this order
        v(:,j+1) = v(:,j+1) - h(i,j) * v(:,i)
     enddo
     call normalize_vecdd(v(1,j+1), tmp)
     h(j+1,j)=tmp
  enddo
  do i=1,m+1
     g(i)=ddsc_cdotc(v(1,i),r)! NEW g
  enddo
  beta=h(m+1,m)               ! NEW beta
  !! set beta, H and g done
enddo

  niter = niter - 1
  if (cg_para%log /= 2) then
     write(0, *) "gmresdr_dd(): no convergence; rtr = ", rtr ; stop
  endif

9999 continue

  if(matrix==MTDAGMT_DD) then
     iter=niter * m + m  + 1
  else
     iter=(dble(niter * m + m  + 1)*HALF)
  endif

  call update_cg_stat(dd_stat, iter, 0)

  evecdd(ip,mdm)%x(1:12*ld%lat%volh,1:defeig+1)=vtmp(1:12*ld%lat%volh,1:defeig+1)
  evecdd(ip,mdm)%h(1:defeig+1,1:defeig)=h(1:defeig+1,1:defeig)
  evecdd(ip,mdm)%fresh=.true.
  evecdd(ip,mdm)%initial=.false.

#else
  call die("gmres_dr needs LAPACK")
#endif

end

!===============================================================================
subroutine galerkinproj(x, b, r, v, h, n, id, ip, matrix)
  use module_dd_evec
  implicit none
  integer, intent(in) :: n, id, ip, matrix
  complex(8), dimension(12*ld%lat%volh):: x,b,r
  complex(8), dimension(12*ld%lat%volh,n):: v
  complex(8) :: h(n,n), g(n), htmp(n,n)
  integer :: i, ipiv(n), info
  complex(8), external :: ddsc_cdotc

#ifdef LAPACK
  do i = 1, n
     g(i)=ddsc_cdotc(v(1,i),r)
  enddo

  htmp=h

  call zgesv(n, 1, htmp, n, ipiv, g, n, info)
  if(info/=0)call die("zgesv failed")

  do i = 1, n
     x(:) = x(:) + v(:,i) * g(ipiv(i))
  enddo

  call muldd_aggre(r, x, id, ip, matrix)
  r=b-r
#else
  call die("galerkinproj needs LAPACK")
#endif

end

!===============================================================================
!-------------------------------------------------------------------------------
subroutine gmresdr_eigcheck(matrix, v, eval, n, id,ip)
  use module_function_decl
  use module_dd
  implicit none
  integer, intent(in) :: n, id,ip, matrix
  complex(8), dimension(12*ld%lat%volh,n):: v
  complex(8), dimension(12*ld%lat%volh):: r
  complex(8), dimension(n):: eval
  integer :: i, j
  real(8), external :: ddsc_norm2
  real(8) :: rtr

  rtr=ZERO
  do i=1, n
     call muldd_aggre(r, v(1,i), id, ip, matrix)
     r(:)=r(:)-v(:,i) * eval(i)
     rtr=rtr+ddsc_norm2(r)
  enddo
  if(my_pe()==0)write(0,*)"Sum||Ax-lambda x||^2 /n",rtr/n
end
!===============================================================================
#endif