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

  type type_eigenmodes
     logical          :: initial, fresh
     complex(8), pointer :: eval(:)
     complex(8), pointer :: x(:,:)
  end type type_eigenmodes

  integer, save :: defeig, m
  type(type_eigenmodes),dimension(:),pointer,save :: emode


end module module_gcrodr

!-------------------------------------------------------------------------------
subroutine init_gcrodr()
  use module_input
  use module_gcrodr
  use module_vol
  use module_action
  use module_function_decl
  implicit none
  integer, save:: count=0
  integer :: i

  if (count==1) return

  DEBUG2S("Start: init_gcrodr")

  allocate(emode(size(action%mtilde)))
       m=input%solver_gcrodr_numarstep
  defeig=input%solver_gcrodr_numdefvec
  do i=1, size(action%mtilde)
     emode(i)%initial=.true.
     allocate(emode(i)%x(12*volh_tot,defeig))
     allocate(emode(i)%eval(defeig))
  enddo
  count=1
  if (my_pe()==0) write(0,*)"GCRODR(", defeig, ",", m, ")"

  DEBUG2S("End: init_gcrodr")
end

!-------------------------------------------------------------------------------
subroutine gcrodr(x, b, id, iter, res)
  use module_function_decl
  use module_check_solution
  use module_cg
  use module_vol
  use module_gcrodr
  use module_action
  implicit none
  complex(8),intent(inout):: x(12*volh_tot)
  complex(8),intent(in) :: b(12*volh_tot)
  integer, intent(in) :: id
  integer, intent(out) :: iter
  real(8), intent(in) :: res

  complex(8) :: r(12*volh_tot), v(12*volh_tot,m+1), vtmp(12*volh_tot,defeig+1)
  complex(8) :: cc(12*volh_tot,defeig), uu(12*volh_tot,defeig)

  integer :: i, j, k, niter, lwork, info
  integer, save :: itert=0
  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, ctmp2(defeig)
  complex(8)::work(m*2)
  complex(8) :: zpone, zmone

  zpone = dcmplx( ONE,ZERO)
  zmone = dcmplx(-ONE,ZERO)
  lwork=m*2


#ifdef LAPACK

  DEBUG2S("Start: gcrodr")

  if (m<=defeig) call die("GCRODR impossible m<nev")
  if (0==defeig) call die("GCRODR inev=0")

  bb = sc_norm2(b) ; call global_sum_vec(1, bb)
  call wdagw(r, x, id)  ; iter=1 ; itert=itert+1
  r = b - r
  rtr=sc_norm2(r) ; call global_sum_vec(1, rtr)
  niter =1


  if (my_pe()==0 )write(0,*)"GCRODR kappa:", action%mtilde(id)%kappa
  if (my_pe()==0 )write(0,*)"GCRODR res:",itert,iter, rtr
  if (stop_condition(rtr, res, bb)) goto 9999

if (.not. emode(id)%initial) then
   ! when rtr /=rtr_real, this does not work
   !if (emode(id)%fresh) then
   !   do i=1,defeig
   !      uu(:,i)=emode(id)%x(:,i)
   !      cc(:,i)=emode(id)%ax(:,i)
   !   enddo
   !else
      do i=1,defeig
         call wdagw(cc(1,i), emode(id)%x(1,i), id) ; iter=iter+1 ; itert=itert+1
      enddo
!! for check QR
!      do i=1,defeig
!         call sc_copy(vtmp(1,i), cc(1,i))
!      enddo
      
      call gram_schmidt2(cc, r_qr, 12*volh_tot, 12*volh, defeig, .true.)

!! check QR
!      do i=1,defeig
!         vtmp(1:12*volh,defeig+1)=ZERO
!         do j=1,defeig
!            if (r_qr(j,i)/=ZERO)then
!               vtmp(1:12*volh,defeig+1)=vtmp(1:12*volh,defeig+1)+ cc(1:12*volh,j) * r_qr(j,i)
!            endif
!         enddo
!         vtmp(1:12*volh,defeig+1)=vtmp(1:12*volh,defeig+1) - vtmp(1:12*volh,i)
!         rtr=sc_norm2(vtmp(1,defeig+1)); call global_sum_vec(1, rtr)
!         if (my_pe()==0)write(0,*)"QR res: ",i,rtr
!      enddo



      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(1:12*volh,i)=uu(1:12*volh,i)+ emode(id)%x(1:12*volh,j) * r_qr(j,i)
            endif
         enddo
      enddo
   !endif

   do i=1,defeig
      ctmp2(i)=sc_cdotc(cc(1,i), r) 
   enddo
   call global_sum_vec(2*defeig, ctmp2)

   do i=1,defeig
      x(1:12*volh)=x(1:12*volh)+uu(1:12*volh,i)*ctmp2(i)
      r(1:12*volh)=r(1:12*volh)-cc(1:12*volh,i)*ctmp2(i)
   enddo
   rtr=sc_norm2(r) ; call global_sum_vec(1, rtr)

!!  do i=1,defeig
!!     call sc_copy(emode(id)%x(1,i), uu(1,i)) ! \til{Y}
!!  enddo   
!  call wdagw(vtmp(1,1), x, id)  ; iter = iter +1
!  vtmp(:,1)=vtmp(:,1)-b
!  rtr_real=sc_norm2(vtmp(1,1)) ; call global_sum_vec(1, rtr_real)
!!  if (max(rtr_real, rtr) > 1.01_8* min(rtr_real,rtr) ) then
!     write(0,*)rtr,rtr_real
!!     stop
!!  endif

else

  v(1:12*volh,1)=r(1:12*volh)
  call normalize_sc_half(v(1,1), beta)
  h=ZERO

  do j = 1, m                           !!!!! gmres(m)
     call wdagw(v(1,j+1), v(1,j), id) ; iter = iter +1 ; itert=itert+1
     do i = 1, j
        h(i,j) = sc_cdotc(v(1,i), v(1,j+1)) ; call global_sum_vec(2, h(i,j))
        v(1:12*volh,j+1) = v(1:12*volh,j+1) - h(i,j) * v(1:12*volh,i)
     enddo
     call normalize_sc_half(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(1:12*volh) = x(1:12*volh) + v(1:12*volh,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(1:12*volh) = v(1:12*volh,1) * yy(1)
  do i = 2, m+1
     r(1:12*volh) = r(1:12*volh) + v(1:12*volh,i) * yy(i)
  enddo
  rtr=sc_norm2(r)  ; call global_sum_vec(1, rtr)

!  call wdagw(vtmp(1,1), x, id)
!  vtmp(:,1)=vtmp(:,1)-b
!  rtr_real=sc_norm2(vtmp(1,1)) ; call global_sum_vec(1, rtr_real)
!  write(0,*)rtr,rtr_real

  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
  do i=1,defeig
     call sc_copy(emode(id)%x(1,i),vtmp(1,i))
  enddo

  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(1:12*volh,i)=cc(1:12*volh,i)+ v(1:12*volh,j) * qr(j,i)
     enddo
  enddo

  do i=1,defeig
     do j=1,defeig
        if (r_qr(j,i)/=ZERO)then
           uu(1:12*volh,i)=uu(1:12*volh,i)+ emode(id)%x(1:12*volh,j) * r_qr(j,i)
        endif
     enddo
  enddo

!  !! check U and C
!  do i =1, defeig
!     call wdagw(vtmp(1,1), uu(1,i), id)
!     vtmp(:,1)=vtmp(:,1)-cc(:,i)
!     rtr_real=sc_norm2(vtmp(1,1)) ; call global_sum_vec(1, rtr_real)
!     if (my_pe()==0)write(0,*)"|Au-c|",i,rtr_real
!  enddo

endif

if (my_pe()==0 )write(0,*)"GCRODR res:",itert, iter, rtr
if (stop_condition(rtr, res, bb)) goto 9999

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

  DEBUG2S("gcrodr 101")

  j=defeig
  v(1:12*volh,j+1) = r(1:12*volh)
  call normalize_sc_half(v(1,j+1), tmp)
  do j = defeig+1, m
     call wdagw(vtmp(1,1), v(1,j), id)  ; iter = iter +1 ; itert=itert+1
     do i = 1, defeig
        h(i,j) = sc_cdotc(cc(1,i), vtmp(1,1)) ; call global_sum_vec(2, h(i,j))
     enddo
     call projecton_imvv(v(1,j+1), vtmp(1,1), cc, 12*volh_tot, 12*volh, defeig, .true.)
     do i = 1, defeig
        ctmp = sc_cdotc(cc(1,i), v(1,j+1)) ; call global_sum_vec(2, ctmp)
        v(1:12*volh,j+1) = v(1:12*volh,j+1) - ctmp * cc(1:12*volh,i)
     enddo
     do i = defeig+1, j
        h(i,j) = sc_cdotc(v(1,i), v(1,j+1)) ; call global_sum_vec(2, h(i,j))
        v(1:12*volh,j+1) = v(1:12*volh,j+1) - h(i,j) * v(1:12*volh,i)
     enddo
     call normalize_sc_half(v(1,j+1), tmp)
     h(j+1,j)=tmp
  enddo

  DEBUG2S("gcrodr 102")


  do i = 1, defeig
     g(i)=sc_cdotc(cc(1,i), r)
  enddo
  do i = defeig+1, m+1
     g(i)=sc_cdotc(v(1,i), r)
  enddo
  call global_sum_vec(2*(m+1), g)

  DEBUG2S("gcrodr 103")

  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)

  DEBUG2S("gcrodr 104")

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

  DEBUG2S("gcrodr 105")

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

  DEBUG2S("gcrodr 106")

  do i = 1, defeig
     r(1:12*volh) = r(1:12*volh) - cc(1:12*volh,i) * yy(i)
  enddo
  do i = defeig+1, m+1
     r(1:12*volh) = r(1:12*volh) -  v(1:12*volh,i) * yy(i)
  enddo
  rtr=sc_norm2(r) ; call global_sum_vec(1, rtr)

  DEBUG2S("gcrodr 107")

  call wdagw(vtmp(1,1), x, id)  ; iter = iter +1 ; itert=itert+1
  vtmp(:,1)=vtmp(:,1)-b
  rtr_real=sc_norm2(vtmp(1,1)) ; call global_sum_vec(1, rtr_real)
  if (max(rtr_real, rtr) > 1.01_8* min(rtr_real,rtr) ) then
     if (my_pe()==0)write(0,*)"GCRODR inconsistent res!!!"
     if (my_pe()==0)write(0,*)"GCRODR rtr, rtt_real",rtr,rtr_real
     if (stop_condition(rtr_real, res, bb)) then
        if (my_pe()==0)write(0,*) &
        "GCRODR rtt_real satisfies stopping condition, finilize without error"
        goto 9999
     endif
     stop
  endif

  DEBUG2S("gcrodr 108")

htmp=ZERO
do i=1,defeig
   do j=1,m
      htmp(i,j)=sc_cdotc(cc(1,i),v(1,j))
   enddo
enddo
do i=defeig+1,m+1
   do j=1,m
      htmp(i,j)=sc_cdotc(v(1,i),v(1,j))
   enddo
enddo
call global_sum_vec(2*m*(m+1), htmp)

  DEBUG2S("gcrodr 109")


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

  DEBUG2S("gcrodr 110")


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

  DEBUG2S("gcrodr 111")

  call zgeneigen(eval, evec, gg, ff, m, defeig)
  p(1:m,1:defeig)=evec(1:m,1:defeig)

  if (my_pe()==0 .and. mod(niter,10)==0) then
     do j=1,defeig
        write(0,*)"GCRODR eval",itert, iter,j,eval(j)
     enddo
  endif

  do i=1,defeig
     call sc_zero(emode(id)%x(1,i))
     do j=1,m
        emode(id)%x(1:12*volh,i) = emode(id)%x(1:12*volh,i) + v(1:12*volh,j) * p(j,i)
     enddo
  enddo

  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

  DEBUG2S("gcrodr 114")


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

  DEBUG2S("gcrodr 115")

  do i=1,defeig
     uu(1:12*volh,i)=ZERO
     do j=1,defeig
        if (r_qr(j,i)/=ZERO)then
           uu(1:12*volh,i)=uu(1:12*volh,i)+ emode(id)%x(1:12*volh,j) * r_qr(j,i)
        endif
     enddo
  enddo

  DEBUG2S("gcrodr 116")

  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

  DEBUG2S("gcrodr 117")

  if (my_pe()==0 .and. mod(niter,1+ int(50/m) )==0 )write(0,*)"GCRODR res:",itert, iter, rtr
  if (stop_condition(rtr, res, bb)) goto 9999


enddo

  DEBUG2S("gcrodr 201")

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

  if (my_pe()==0 )write(0,*)"GCRODR res:",itert, iter, rtr
  DEBUG2S("gcrodr 300")

! must be changed
  do i=1,defeig
     call sc_copy(emode(id)%x(1,i), uu(1,i)) ! \til{Y}
  enddo
  emode(id)%fresh=.true.
  emode(id)%initial=.false.


  DEBUG2S("gcrodr 301")

  call update_cg_stat(cg_stat, iter, 0) !! must be changed

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

  DEBUG2S("End: init_gcrodr")
end

!-------------------------------------------------------------------------------
subroutine projecton_imvv(out, in, v, lenall, len, k, global) ! out=(I - V_k V_k^H) in
  implicit none
  complex(8), dimension(lenall)  :: in, out
  complex(8), dimension(lenall,k):: v
  integer :: i, j, k, len, lenall
  logical :: global
  complex(8) :: fac

  out(1:len) = in(1:len)
  do i = 1, k
     fac=ZERO
     do j = 1, len
        fac = fac + conjg(v(j,i)) * in(j)
     enddo
     if (global) call global_sum_vec(2, fac)
     out(1:len) = out(1:len) - fac * v(1:len,i)
  enddo

end

!-------------------------------------------------------------------------------
subroutine zhritz(eval, evec, h, beta, m, n) ! return 'SM' harmonic ritz pairs 
  implicit none                              ! by given h and beta
  integer, intent(in) :: m, n
  real(8), intent(in) :: beta
  complex(8),intent(in):: h(m,m)
  complex(8),intent(out) :: eval(n),evec(m,n)

  real(8) :: abnrm, rconde(m), rcondv(m), rwork(2*m), scale(m), ttt(m)
  complex (8) :: vl(m,m), vr(m,m), hm(m,m), em(m)
  complex(8),allocatable :: work(:)
  integer :: lwork, info, ilo,ihi, ipiv(m), i,j

#ifdef LAPACK

  scale=ONE

  em=ZERO ;  em(m)=ONE
  do i=1,m;  do j=1,m
     hm(i,j)=conjg(h(j,i))
  enddo;  enddo

  call zgesv(m, 1, hm, m, ipiv, em, m, info)
  if(info/=0)write(0,*)"zgesv failed at zhritz err", info
  if(info/=0)call  die("zgesv failed at zhritz")

  hm=h
  do i=1,m
     hm(i,m)=hm(i,m)+em(ipiv(i)) * beta**2
  enddo

  allocate(work(10)) !! dummy allocation
  lwork=-1
  call zgeevx("N", "N", "V", "N", m, hm, m, em, vl, m, vr, m, &
              ilo, ihi, scale, abnrm, rconde, rcondv, &
              work, lwork, rwork, info)
  if(info/=0)write(0,*)"zgeevx failed at zhritz err", info
  if(info/=0)call  die("zgeevx failed at zhritz")
  lwork=int(real(work(1)))
  deallocate(work)
  allocate(work(lwork))
  call zgeevx("N", "N", "V", "N", m, hm, m, em, vl, m, vr, m, &
              ilo, ihi, scale, abnrm, rconde, rcondv, &
              work, lwork, rwork, info)
  if(info/=0)write(0,*)"zgeevx failed at zhritz err", info
  if(info/=0)call  die("zgeevx failed at zhritz")
  deallocate(work)

  do i=1,m
     ttt(i)=(Re(em(i)))**2 + (Im(em(i)))**2
  enddo
  call sortd(ttt,ipiv,m)

  do i=1,n
     eval(i)=em(ipiv(i))
     evec(1:m,i)=vr(1:m,ipiv(i))
  enddo

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

end

!-------------------------------------------------------------------------------
subroutine zgeneigen(eval, evec, g, f, m, n) ! return 'SM' ritz pairs 
  implicit none                              ! of G_mm v = e F_mm v
  integer, intent(in) :: m, n
  complex(8),intent(in):: g(m,m), f(m,m)
  complex(8),intent(out) :: eval(n),evec(m,n)

  real(8) :: rwork(8*m), ttt(m)
  complex (8) :: gtmp(m,m), ftmp(m,m), ev(m), vl(m,m), vr(m,m), aaa(m), bbb(m)
  complex(8),allocatable :: work(:)
  integer :: lwork, info, ipiv(m), i,j

#ifdef LAPACK

  gtmp=g
  ftmp=f

  allocate(work(10)) !! dummy allocation
  lwork=-1
  call ZGGEV( "N", "V", m, gtmp, m, ftmp, m, aaa, bbb, &
               VL, m, VR, m, WORK, LWORK, RWORK, INFO )
  if(info/=0)write(0,*)"zggev failed at zgeneigen err", info
  if(info/=0)call  die("zggev failed at zgeneigen")

  lwork=int(real(work(1)))
  deallocate(work)
  allocate(work(lwork))

  call ZGGEV( "N", "V", m, gtmp, m, ftmp, m, aaa, bbb, &
               VL, m, VR, m, WORK, LWORK, RWORK, INFO )
  if(info/=0)write(0,*)"zggev failed at zgeneigen err", info
  if(info/=0)call  die("zggev failed at zgeneigen")
  deallocate(work)

  ev=aaa/bbb
  do i=1,m
     ttt(i)=(Re(ev(i)))**2 + (Im(ev(i)))**2
  enddo
  call sortd(ttt,ipiv,m)
  do i=1, n
     eval(i)=ev(ipiv(i))
     evec(1:m,i)=vr(1:m,ipiv(i))
  enddo

!!  write(0,*)info, aaa,bbb
!!  do j=1,m
!!     call matvecmult(g, vl(1:m,1), vr(1:m,j) ,m)   
!!     do i=1,m
!!        write(0,*)"jban g",j,vl(i,1)
!!     enddo
!!     call matvecmult(f, vl(1:m,1), vr(1:m,j) ,m)
!!     do i=1,m
!!        write(0,*)"jban f",j,vl(i,1)*aaa(j)/bbb(j)
!!     enddo
!!  enddo
!!  stop

#else
  call die("zgeneigen needs LAPACK")
#endif
end

!-------------------------------------------------------------------------------
subroutine zqr(q, r, m, n)
  implicit none
  integer, intent(in)     :: m,n
  complex(8),intent(inout):: q(m,n)
  complex(8),intent(out)  :: r(n,n)
  integer :: lwork, info, i, j, k
  complex(8):: tau(n), qr(m,n)
  complex(8),allocatable::work(:)

#ifdef LAPACK

!  write(0,*)"zqr: initial A",q

  allocate(work(10)) !! dummy allocation
  lwork=-1
  call ZGEQRF( m, n, q, m, tau, WORK, LWORK, INFO )
  if (info/=0)write(0,*)"ZGEQRF-1 failed at zqr err",info
  if (info/=0)call  die("ZGEQRF-1 failed at zqr")
  lwork=int(real(work(1)))
  deallocate(work)
  allocate(work(lwork))
  call ZGEQRF( m, n, q, m, tau, WORK, LWORK, INFO )
  if (info/=0)write(0,*)"ZGEQRF failed at zqr err",info
  if (info/=0)call  die("ZGEQRF failed at zqr")

  r=ZERO
  do i=1,n
     r(i,i)=q(i,i)
     do j=i+1,n
        r(i,j)=q(i,j)
     enddo
  enddo

  lwork=-1
  call ZUNGQR( m, n, n, q, m, tau, WORK, LWORK, INFO )
  if (info/=0)write(0,*)"ZUNGQR-1 failed at zqr err",info
  if (info/=0)call  die("ZUNGQR-1 failed at zqr")
  lwork=int(real(work(1)))
  deallocate(work)
  allocate(work(lwork))
  call ZUNGQR( m, n, n, q, m, tau, WORK, LWORK, INFO )
  if (info/=0)write(0,*)"ZUNGQR failed at zqr err",info
  if (info/=0)call  die("ZUNGQR failed at zqr")

!!  call gram_schmidt(q, r, m, n, .false.)

!  qr=ZERO
!  do i=1,m
!  do j=1,n
!     do k=1,n
!        qr(i,j)=qr(i,j)+q(i,k)*r(k,j)
!     enddo
!  enddo
!  enddo
!  write(0,*)"zqr: result qr",qr


  deallocate(work)

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

end
