!===============================================================================
!
! gcrodr_dd.F90 
!
! solves "matrix_mult * x = b" and returns number of iterations
!
! GCRO-DR Ref.:  Recycling krylov subspaces forsequences of linear systems  
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 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"

!-------------------------------------------------------------------------------
subroutine gcrodr_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
  complex(8),intent(inout):: x(12*ld%lat%volh)
  complex(8),intent(in) :: b(12*ld%lat%volh)
  integer, intent(in) :: id,ip,matrix, m
  integer, intent(out) :: iter
  real(8), intent(in) :: res

  complex(8) :: r(12*ld%lat%volh), v(12*ld%lat%volh,m+1), vtmp(12*ld%lat%volh,defeig+1)
  complex(8) :: cc(12*ld%lat%volh,defeig), uu(12*ld%lat%volh,defeig)
  complex(8), external :: ddsc_cdotc, veccdotc
  real(8), external :: ddsc_norm2

  integer :: mdm, i, j, k, niter, lwork, info
  real(8) :: beta, bb, tmp, rtr, rtr_real
  complex(8) :: h(m+1,m), g(m+1), yy(m+1),htmp(m+1,m),y(m)
  complex(8):: p(m+1,defeig+1), eval(defeig),evec(m,defeig), gg(m,m), ff(m,m)
  complex(8):: r_qr(defeig,defeig), qr(m+1,defeig), gtmp(m+1,1), ctmp
  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("gmresdr1 impossible m<nev")
  if (0==defeig) call die("gmresdr1 inev=0")
  bb = ddsc_norm2(b)
  x=b
  call muldd_aggre(r, x, id, ip, matrix)
  r = b - r

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

if (.not. evecdd(ip,mdm)%initial) then
   ! when rtr /=rtr_real, this does not work
   !if (evecdd(ip,mdm)%fresh) then
   !   do i=1,defeig
   !      uu(:,i)=evecdd(ip,mdm)%x(:,i)
   !      cc(:,i)=evecdd(ip,mdm)%ax(:,i)
   !   enddo
   !else
      do i=1,defeig
         call muldd_aggre(cc(1,i), evecdd(ip,mdm)%x(1,i), id, ip, matrix)
      enddo
   
      call zqr(cc,r_qr,12*ld%lat%volh,defeig)
      call ZTRTRI( "U", "N", defeig, r_qr, defeig, INFO )  !! R^-1
   
      uu=ZERO
      do i=1,defeig
         do j=1,defeig
            if (r_qr(j,i)/=ZERO)then
               uu(:,i)=uu(:,i)+ evecdd(ip,mdm)%x(:,j) * r_qr(j,i)
            endif
         enddo
      enddo
   !endif

   do i=1,defeig
      ctmp=ddsc_cdotc(cc(1,i), r)
      x(:)=x(:)+uu(:,i)*ctmp
      r(:)=r(:)-cc(:,i)*ctmp
   enddo

  rtr=ddsc_norm2(r)

!!  call muldd_aggre(vtmp(1,1), x, id, ip, matrix)
!!  vtmp(:,1)=b(:)-vtmp(:,1)
!!  rtr_real=ddsc_norm2(vtmp(1,1))
!!  write(0,*)rtr, rtr_real

else

  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

  htmp=h;  gtmp(:,1)=g
  call zgels("N", m+1, m, 1, htmp, m+1, gtmp, m+1, work,lwork, info)
  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)

#ifdef DEBUG2
  call muldd_aggre(vtmp(1,1), x, id, ip, matrix)
  vtmp(:,1)=b(:)-vtmp(:,1)
  rtr_real=ddsc_norm2(vtmp(1,1))
  write(0,*)rtr, rtr_real
#endif

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

  vtmp=ZERO
  do i=1,defeig
     do j=1,m
        vtmp(:,i) = vtmp(:,i) + v(:,j) * p(j,i)
     enddo
  enddo
  evecdd(ip,mdm)%x(1:12*ld%lat%volh,1:defeig)=vtmp(1:12*ld%lat%volh,1:defeig) ! \til{Y}

  qr=ZERO
  do i=1,m+1
     do j=1,defeig
        do k=1, m
           qr(i,j)=qr(i,j)+h(i,k)*p(k,j)
        enddo
     enddo
  enddo              !!! this is HmPk

  call zqr(qr,r_qr,m+1,defeig)
  call ZTRTRI( "U", "N", defeig, r_qr, defeig, INFO )  !! R^-1

  cc=ZERO
  uu=ZERO
  do i=1,defeig
     do j=1,m+1
        cc(:,i)=cc(:,i)+ v(:,j) * qr(j,i)
     enddo
  enddo
  do i=1,defeig
     do j=1,defeig
        if (r_qr(j,i)/=ZERO)then
           uu(:,i)=uu(:,i)+ evecdd(ip,mdm)%x(:,j) * r_qr(j,i)
        endif
     enddo
  enddo

endif

do niter = 1, cg_para%maxiter
   h=ZERO
   do i = 1, defeig
      call normalize_vecdd(uu(1,i), tmp)
      h(i,i)=ONE/tmp
      v(:,i)=uu(:,i)
   enddo

  j=defeig
  v(:,j+1) = r(:)
  call normalize_vecdd(v(1,j+1), tmp)

  do j = defeig+1, m
     call muldd_aggre(vtmp(1,1), v(1,j), id, ip, matrix)
     do i = 1, defeig
        h(i,j) = ddsc_cdotc(cc(1,i), vtmp(1,1))
     enddo
     call projecton_imvv(v(1,j+1), vtmp(1,1), cc, 12*ld%lat%volh, 12*ld%lat%volh, defeig, .false.)
     do i = 1, defeig
        ctmp = ddsc_cdotc(cc(1,i), v(1,j+1))
        v(:,j+1) = v(:,j+1) - ctmp * cc(:,i)
     enddo
     do i = defeig+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, defeig
     g(i)=ddsc_cdotc(cc(1,i), r)
  enddo
  do i = defeig+1, m+1
     g(i)=ddsc_cdotc(v(1,i), r)
  enddo


  htmp=h;  gtmp(:,1)=g
  call zgels("N", m+1, m, 1, htmp, m+1, gtmp, m+1, work,lwork, info)
  y(1:m)=gtmp(1:m,1)

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

  yy=ZERO
  do i = 1, m+1
     do j = 1, m
        yy(i) = yy(i) + h(i,j) * y(j)
     enddo
  enddo

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

#ifdef DEBUG2
  !! OK
  call muldd_aggre(vtmp(1,1), x, id, ip, matrix)
  vtmp(:,1)=b-vtmp(:,1)
  rtr_real=ddsc_norm2(vtmp(1,1))
  write(0,*)rtr, rtr_real

  if(abs(rtr-rtr_real) > min(rtr,rtr_real)*100.0_8 .and. &  
     stop_condition((max(rtr,rtr_real)), res, bb) ) 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
#endif

htmp=ZERO
do i=1,defeig
   do j=1,m
      htmp(i,j)=ddsc_cdotc(cc(1,i),v(1,j))
   enddo
enddo
do i=defeig+1,m+1
   do j=1,m
      htmp(i,j)=ddsc_cdotc(v(1,i),v(1,j))
   enddo
enddo

ff=ZERO
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)
  p(1:m,1:defeig)=evec(1:m,1:defeig)

  vtmp=ZERO
  do i=1,defeig
     do j=1,m
        vtmp(:,i) = vtmp(:,i) + v(:,j) * p(j,i)
     enddo
  enddo
  evecdd(ip,mdm)%x(1:12*ld%lat%volh,1:defeig)=vtmp(1:12*ld%lat%volh,1:defeig) ! \til{Y}

  qr=ZERO
  do i=1,m+1
     do j=1,defeig
        do k=1, m
           qr(i,j)=qr(i,j)+h(i,k)*p(k,j)
        enddo
     enddo
  enddo              !!! this is HmPk

  call zqr(qr,r_qr,m+1,defeig)
  call ZTRTRI( "U", "N", defeig, r_qr, defeig, INFO )  !! R^-1

  uu=ZERO
  do i=1,defeig
     do j=1,defeig
        if (r_qr(j,i)/=ZERO)then
           uu(:,i)=uu(:,i)+ evecdd(ip,mdm)%x(:,j) * r_qr(j,i)
        endif
     enddo
  enddo

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

  if (stop_condition(rtr, res, bb)) goto 9999
enddo

  niter = niter - 1
  if (cg_para%log /= 2) then
     write(0, *) "gcrodr_dd(): 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)=uu(1:12*ld%lat%volh,1:defeig) ! \til{Y}
  evecdd(ip,mdm)%ax(1:12*ld%lat%volh,1:defeig)=cc(1:12*ld%lat%volh,1:defeig)
  evecdd(ip,mdm)%fresh=.true.
  evecdd(ip,mdm)%initial=.false.

  call update_cg_stat(dd_stat, iter, 0)

!!  OK
!  call muldd_aggre(vtmp(1,1), uu(1,1), id, ip, matrix)
!  write(0,*)niter, vtmp(1,1), cc(1,1)
!  write(0,*)niter, vtmp(2,1), cc(2,1)
!  write(0,*)niter, vtmp(3,1), cc(3,1)
!  write(0,*)niter, vtmp(4,1), cc(4,1)
!  write(0,*)niter, vtmp(5,1), cc(5,1)
!  stop

#else
  call die("gcrodr_dd needs LAPCK")
#endif

end

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