mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-11-07 14:03:37 +01:00
added non_hermit_dav
This commit is contained in:
eginer
parent
4b715bfcd9
commit
7f653b9eee
1
src/non_hermit_dav/NEED
Normal file
1
src/non_hermit_dav/NEED
Normal file
@ -0,0 +1 @@
|
|||||||
|
utils
|
||||||
1088
src/non_hermit_dav/biorthog.irp.f
Normal file
1088
src/non_hermit_dav/biorthog.irp.f
Normal file
File diff suppressed because it is too large
Load Diff
56
src/non_hermit_dav/gram_schmit.irp.f
Normal file
56
src/non_hermit_dav/gram_schmit.irp.f
Normal file
@ -0,0 +1,56 @@
|
|||||||
|
subroutine bi_ortho_gram_schmidt(wi,vi,n,ni,wk,wk_schmidt)
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! you enter with a set of "ni" BI-ORTHONORMAL vectors of length "n"
|
||||||
|
!
|
||||||
|
! vi(j,i) = <j|vi>, wi(j,i) = <j|wi>, <vi|wj> = delta_{ij} S_ii, S_ii =<vi|wi>
|
||||||
|
!
|
||||||
|
! and a vector vk(j) = <j|vk>
|
||||||
|
!
|
||||||
|
! you go out with a vector vk_schmidt(j) = <j|vk_schmidt>
|
||||||
|
!
|
||||||
|
! which is Gram-Schmidt orthonormalized with respect to the "vi"
|
||||||
|
!
|
||||||
|
! <vi|wk_schmidt> = 0
|
||||||
|
!
|
||||||
|
! |wk_schmidt> = |wk> - \sum_{i=1}^ni (<vi|wk>/<vi|wi>) |wi>
|
||||||
|
!
|
||||||
|
! according to Eq. (5), (6) of Computers Structures, Vol 56, No. 4, pp 605-613, 1995
|
||||||
|
!
|
||||||
|
! https://doi.org/10.1016/0045-7949(94)00565-K
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: n,ni
|
||||||
|
double precision, intent(in) :: wi(n,ni),vi(n,ni),wk(n)
|
||||||
|
double precision, intent(out):: wk_schmidt(n)
|
||||||
|
double precision :: vi_wk,u_dot_v,tmp,u_dot_u
|
||||||
|
double precision, allocatable :: sii(:)
|
||||||
|
integer :: i,j
|
||||||
|
allocate( sii(ni) )
|
||||||
|
wk_schmidt = wk
|
||||||
|
do i = 1, ni
|
||||||
|
sii(i) = u_dot_v(vi(1,i),wi(1,i),n)
|
||||||
|
enddo
|
||||||
|
! do i = 1, n
|
||||||
|
! print*,i,'wk',wk(i)
|
||||||
|
! enddo
|
||||||
|
! print*,''
|
||||||
|
! print*,''
|
||||||
|
do i = 1, ni
|
||||||
|
! print*,'i',i
|
||||||
|
! Gram-Schmidt
|
||||||
|
vi_wk = u_dot_v(vi(1,i),wk,n)
|
||||||
|
vi_wk = vi_wk / sii(i)
|
||||||
|
! print*,''
|
||||||
|
do j = 1, n
|
||||||
|
! print*,j,vi_wk,wi(j,i)
|
||||||
|
wk_schmidt(j) -= vi_wk * wi(j,i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
tmp = u_dot_u(wk_schmidt,n)
|
||||||
|
tmp = 1.d0/dsqrt(tmp)
|
||||||
|
wk_schmidt = tmp * wk_schmidt
|
||||||
|
! do j = 1, n
|
||||||
|
! print*,j,'wk_scc',wk_schmidt(j)
|
||||||
|
! enddo
|
||||||
|
! pause
|
||||||
|
end
|
||||||
93
src/non_hermit_dav/htilde_mat.irp.f
Normal file
93
src/non_hermit_dav/htilde_mat.irp.f
Normal file
@ -0,0 +1,93 @@
|
|||||||
|
BEGIN_PROVIDER [ integer, n_mat]
|
||||||
|
implicit none
|
||||||
|
n_mat = 2
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, h_non_hermit, (n_mat, n_mat)]
|
||||||
|
&BEGIN_PROVIDER [ double precision, h_non_hermit_transp, (n_mat, n_mat)]
|
||||||
|
&BEGIN_PROVIDER [ double precision, reigvec_ht, (n_mat, n_mat)]
|
||||||
|
&BEGIN_PROVIDER [ double precision, leigvec_ht, (n_mat, n_mat)]
|
||||||
|
&BEGIN_PROVIDER [ double precision, eigval_ht, (n_mat)]
|
||||||
|
&BEGIN_PROVIDER [ integer, n_real_ht, (n_mat)]
|
||||||
|
implicit none
|
||||||
|
integer :: i,j
|
||||||
|
do i = 1, n_mat
|
||||||
|
read(33,*)h_non_hermit(i,1:n_mat)
|
||||||
|
enddo
|
||||||
|
print*,''
|
||||||
|
print*,'H_mat '
|
||||||
|
print*,''
|
||||||
|
do i = 1, n_mat
|
||||||
|
write(*,'(1000(F16.10,X))')h_non_hermit(i,:)
|
||||||
|
enddo
|
||||||
|
do i = 1, n_mat
|
||||||
|
do j = 1, n_mat
|
||||||
|
h_non_hermit_transp(j,i) = h_non_hermit(i,j)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
call non_hrmt_real_diag(n_mat,h_non_hermit,reigvec_ht,leigvec_ht,n_real_ht,eigval_ht)
|
||||||
|
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
subroutine hcalc_r_tmp(v,u,N_st,sze) ! v = H u
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Template of routine for the application of H
|
||||||
|
!
|
||||||
|
! Here, it is done with the Hamiltonian matrix
|
||||||
|
!
|
||||||
|
! on the set of determinants of psi_det
|
||||||
|
!
|
||||||
|
! Computes $v = H | u \rangle$
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
double precision, intent(in) :: u(sze,N_st)
|
||||||
|
double precision, intent(inout) :: v(sze,N_st)
|
||||||
|
integer :: i,j,istate
|
||||||
|
v = 0.d0
|
||||||
|
do istate = 1, N_st
|
||||||
|
do j = 1, sze
|
||||||
|
do i = 1, sze
|
||||||
|
v(i,istate) += h_non_hermit(i,j) * u(j,istate)
|
||||||
|
! print*,i,j,h_non_hermit(i,j),u(j,istate)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*,'HU'
|
||||||
|
do i = 1, sze
|
||||||
|
print*,v(i,1)
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine hcalc_l_tmp(v,u,N_st,sze) ! v = H^\dagger u
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Template of routine for the application of H
|
||||||
|
!
|
||||||
|
! Here, it is done with the Hamiltonian matrix
|
||||||
|
!
|
||||||
|
! on the set of determinants of psi_det
|
||||||
|
!
|
||||||
|
! Computes $v = H | u \rangle$
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
double precision, intent(in) :: u(sze,N_st)
|
||||||
|
double precision, intent(inout) :: v(sze,N_st)
|
||||||
|
integer :: i,j,istate
|
||||||
|
v = 0.d0
|
||||||
|
do istate = 1, N_st
|
||||||
|
do j = 1, sze
|
||||||
|
do i = 1, sze
|
||||||
|
v(i,istate) += h_non_hermit_transp(i,j) * u(j,istate)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*,'HU'
|
||||||
|
do i = 1, sze
|
||||||
|
print*,v(i,1)
|
||||||
|
enddo
|
||||||
|
end
|
||||||
2391
src/non_hermit_dav/lapack_diag_non_hermit.irp.f
Normal file
2391
src/non_hermit_dav/lapack_diag_non_hermit.irp.f
Normal file
File diff suppressed because it is too large
Load Diff
669
src/non_hermit_dav/new_routines.irp.f
Normal file
669
src/non_hermit_dav/new_routines.irp.f
Normal file
@ -0,0 +1,669 @@
|
|||||||
|
subroutine non_hrmt_diag_split_degen_bi_orthog(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
|
||||||
|
!
|
||||||
|
! of a non hermitian matrix A(n,n)
|
||||||
|
!
|
||||||
|
! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: n
|
||||||
|
double precision, intent(in) :: A(n,n)
|
||||||
|
integer, intent(out) :: n_real_eigv
|
||||||
|
double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
|
||||||
|
double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
|
||||||
|
|
||||||
|
integer :: i, j, n_degen,k , iteration
|
||||||
|
double precision :: shift_current
|
||||||
|
double precision :: r,thr,accu_d, accu_nd
|
||||||
|
integer, allocatable :: iorder_origin(:),iorder(:)
|
||||||
|
double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
|
||||||
|
double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
|
||||||
|
double precision, allocatable :: im_part(:),re_part(:)
|
||||||
|
double precision :: accu,thr_cut, thr_norm=1d0
|
||||||
|
|
||||||
|
|
||||||
|
thr_cut = 1.d-15
|
||||||
|
print*,'Computing the left/right eigenvectors ...'
|
||||||
|
print*,'Using the degeneracy splitting algorithm'
|
||||||
|
! initialization
|
||||||
|
shift_current = 1.d-15
|
||||||
|
iteration = 0
|
||||||
|
print*,'***** iteration = ',iteration
|
||||||
|
|
||||||
|
|
||||||
|
! pre-processing the matrix :: sorting by diagonal elements
|
||||||
|
allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
|
||||||
|
allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
|
||||||
|
! print*,'Aw'
|
||||||
|
do i = 1, n
|
||||||
|
iorder_origin(i) = i
|
||||||
|
diag_elem(i) = A(i,i)
|
||||||
|
! write(*,'(100(F16.10,X))')A(:,i)
|
||||||
|
enddo
|
||||||
|
call dsort(diag_elem, iorder_origin, n)
|
||||||
|
do i = 1, n
|
||||||
|
do j = 1, n
|
||||||
|
A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
|
||||||
|
allocate(im_part(n),iorder(n))
|
||||||
|
allocate( S(n,n) )
|
||||||
|
|
||||||
|
|
||||||
|
Aw = A_save
|
||||||
|
call cancel_small_elmts(aw,n,thr_cut)
|
||||||
|
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||||
|
do i = 1, n
|
||||||
|
im_part(i) = -dabs(WI(i))
|
||||||
|
iorder(i) = i
|
||||||
|
enddo
|
||||||
|
call dsort(im_part, iorder, n)
|
||||||
|
n_real_eigv = 0
|
||||||
|
do i = 1, n
|
||||||
|
if(dabs(WI(i)).lt.1.d-20)then
|
||||||
|
n_real_eigv += 1
|
||||||
|
else
|
||||||
|
! print*,'Found an imaginary component to eigenvalue'
|
||||||
|
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
if(n_real_eigv.ne.n)then
|
||||||
|
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||||
|
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||||
|
print*,'Splitting the degeneracies by ',shift_current
|
||||||
|
else
|
||||||
|
print*,'All eigenvalues are real !'
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
do while(n_real_eigv.ne.n)
|
||||||
|
iteration += 1
|
||||||
|
print*,'***** iteration = ',iteration
|
||||||
|
if(shift_current.gt.1.d-3)then
|
||||||
|
print*,'shift_current > 1.d-3 !!'
|
||||||
|
print*,'Your matrix intrinsically contains complex eigenvalues'
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
Aw = A_save
|
||||||
|
call cancel_small_elmts(Aw,n,thr_cut)
|
||||||
|
call split_matrix_degen(Aw,n,shift_current)
|
||||||
|
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||||
|
n_real_eigv = 0
|
||||||
|
do i = 1, n
|
||||||
|
if(dabs(WI(i)).lt.1.d-20)then
|
||||||
|
n_real_eigv+= 1
|
||||||
|
else
|
||||||
|
! print*,'Found an imaginary component to eigenvalue'
|
||||||
|
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
if(n_real_eigv.ne.n)then
|
||||||
|
do i = 1, n
|
||||||
|
im_part(i) = -dabs(WI(i))
|
||||||
|
iorder(i) = i
|
||||||
|
enddo
|
||||||
|
call dsort(im_part, iorder, n)
|
||||||
|
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||||
|
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||||
|
print*,'Splitting the degeneracies by ',shift_current
|
||||||
|
else
|
||||||
|
print*,'All eigenvalues are real !'
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
!!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
|
||||||
|
do i = 1, n
|
||||||
|
eigval(i) = WR(i)
|
||||||
|
iorder(i) = i
|
||||||
|
enddo
|
||||||
|
call dsort(eigval,iorder,n)
|
||||||
|
do i = 1, n
|
||||||
|
! print*,'eigval(i) = ',eigval(i)
|
||||||
|
reigvec_tmp(:,i) = VR(:,iorder(i))
|
||||||
|
leigvec_tmp(:,i) = Vl(:,iorder(i))
|
||||||
|
enddo
|
||||||
|
|
||||||
|
!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
|
||||||
|
! check bi-orthogonality
|
||||||
|
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, .false.)
|
||||||
|
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||||
|
if( accu_nd .lt. 1d-10 ) then
|
||||||
|
print *, ' bi-orthogonality: ok'
|
||||||
|
else
|
||||||
|
print *, ' '
|
||||||
|
print *, ' bi-orthogonality: not imposed yet'
|
||||||
|
print *, ' '
|
||||||
|
print *, ' '
|
||||||
|
print *, ' orthog between degen eigenvect'
|
||||||
|
print *, ' '
|
||||||
|
double precision, allocatable :: S_nh_inv_half(:,:)
|
||||||
|
allocate(S_nh_inv_half(n,n))
|
||||||
|
logical :: complex_root
|
||||||
|
deallocate(S_nh_inv_half)
|
||||||
|
call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp)
|
||||||
|
call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp)
|
||||||
|
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, .false.)
|
||||||
|
if( accu_nd .lt. 1d-10 ) then
|
||||||
|
print *, ' bi-orthogonality: ok'
|
||||||
|
else
|
||||||
|
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||||
|
call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S)
|
||||||
|
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, .false.)
|
||||||
|
if( accu_nd .lt. 1d-10 ) then
|
||||||
|
print *, ' bi-orthogonality: ok'
|
||||||
|
else
|
||||||
|
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||||
|
print*,'Must be a deep problem ...'
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
|
||||||
|
!! EIGENVECTORS SORTED AND BI-ORTHONORMAL
|
||||||
|
do i = 1, n
|
||||||
|
do j = 1, n
|
||||||
|
VR(iorder_origin(j),i) = reigvec_tmp(j,i)
|
||||||
|
VL(iorder_origin(j),i) = leigvec_tmp(j,i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
!! RECOMPUTING THE EIGENVALUES
|
||||||
|
eigval = 0.d0
|
||||||
|
do i = 1, n
|
||||||
|
iorder(i) = i
|
||||||
|
accu = 0.d0
|
||||||
|
do j = 1, n
|
||||||
|
accu += VL(j,i) * VR(j,i)
|
||||||
|
do k = 1, n
|
||||||
|
eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
eigval(i) *= 1.d0/accu
|
||||||
|
! print*,'eigval(i) = ',eigval(i)
|
||||||
|
enddo
|
||||||
|
!! RESORT JUST TO BE SURE
|
||||||
|
call dsort(eigval, iorder, n)
|
||||||
|
do i = 1, n
|
||||||
|
do j = 1, n
|
||||||
|
reigvec(j,i) = VR(j,iorder(i))
|
||||||
|
leigvec(j,i) = VL(j,iorder(i))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*,'Checking for final reigvec/leigvec'
|
||||||
|
shift_current = max(1.d-10,shift_current)
|
||||||
|
print*,'Thr for eigenvectors = ',shift_current
|
||||||
|
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
|
||||||
|
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, .false.)
|
||||||
|
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||||
|
|
||||||
|
if( accu_nd .lt. 1d-10 ) then
|
||||||
|
print *, ' bi-orthogonality: ok'
|
||||||
|
else
|
||||||
|
print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
|
||||||
|
print*,'Eigenvectors are not bi orthonormal ..'
|
||||||
|
print*,'accu_nd = ',accu_nd
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine non_hrmt_diag_split_degen_s_inv_half(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
|
||||||
|
!
|
||||||
|
! of a non hermitian matrix A(n,n)
|
||||||
|
!
|
||||||
|
! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: n
|
||||||
|
double precision, intent(in) :: A(n,n)
|
||||||
|
integer, intent(out) :: n_real_eigv
|
||||||
|
double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
|
||||||
|
double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
|
||||||
|
|
||||||
|
integer :: i, j, n_degen,k , iteration
|
||||||
|
double precision :: shift_current
|
||||||
|
double precision :: r,thr,accu_d, accu_nd
|
||||||
|
integer, allocatable :: iorder_origin(:),iorder(:)
|
||||||
|
double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
|
||||||
|
double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
|
||||||
|
double precision, allocatable :: im_part(:),re_part(:)
|
||||||
|
double precision :: accu,thr_cut, thr_norm=1.d0
|
||||||
|
double precision, allocatable :: S_nh_inv_half(:,:)
|
||||||
|
logical :: complex_root
|
||||||
|
|
||||||
|
|
||||||
|
thr_cut = 1.d-15
|
||||||
|
print*,'Computing the left/right eigenvectors ...'
|
||||||
|
print*,'Using the degeneracy splitting algorithm'
|
||||||
|
! initialization
|
||||||
|
shift_current = 1.d-15
|
||||||
|
iteration = 0
|
||||||
|
print*,'***** iteration = ',iteration
|
||||||
|
|
||||||
|
|
||||||
|
! pre-processing the matrix :: sorting by diagonal elements
|
||||||
|
allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
|
||||||
|
allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
|
||||||
|
! print*,'Aw'
|
||||||
|
do i = 1, n
|
||||||
|
iorder_origin(i) = i
|
||||||
|
diag_elem(i) = A(i,i)
|
||||||
|
! write(*,'(100(F16.10,X))')A(:,i)
|
||||||
|
enddo
|
||||||
|
call dsort(diag_elem, iorder_origin, n)
|
||||||
|
do i = 1, n
|
||||||
|
do j = 1, n
|
||||||
|
A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
|
||||||
|
allocate(im_part(n),iorder(n))
|
||||||
|
allocate( S(n,n) )
|
||||||
|
allocate(S_nh_inv_half(n,n))
|
||||||
|
|
||||||
|
|
||||||
|
Aw = A_save
|
||||||
|
call cancel_small_elmts(aw,n,thr_cut)
|
||||||
|
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||||
|
do i = 1, n
|
||||||
|
im_part(i) = -dabs(WI(i))
|
||||||
|
iorder(i) = i
|
||||||
|
enddo
|
||||||
|
call dsort(im_part, iorder, n)
|
||||||
|
n_real_eigv = 0
|
||||||
|
do i = 1, n
|
||||||
|
if(dabs(WI(i)).lt.1.d-20)then
|
||||||
|
n_real_eigv += 1
|
||||||
|
else
|
||||||
|
! print*,'Found an imaginary component to eigenvalue'
|
||||||
|
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
if(n_real_eigv.ne.n)then
|
||||||
|
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||||
|
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||||
|
print*,'Splitting the degeneracies by ',shift_current
|
||||||
|
else
|
||||||
|
print*,'All eigenvalues are real !'
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
do while(n_real_eigv.ne.n)
|
||||||
|
iteration += 1
|
||||||
|
print*,'***** iteration = ',iteration
|
||||||
|
if(shift_current.gt.1.d-3)then
|
||||||
|
print*,'shift_current > 1.d-3 !!'
|
||||||
|
print*,'Your matrix intrinsically contains complex eigenvalues'
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
Aw = A_save
|
||||||
|
! thr_cut = shift_current
|
||||||
|
call cancel_small_elmts(Aw,n,thr_cut)
|
||||||
|
call split_matrix_degen(Aw,n,shift_current)
|
||||||
|
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||||
|
n_real_eigv = 0
|
||||||
|
do i = 1, n
|
||||||
|
if(dabs(WI(i)).lt.1.d-20)then
|
||||||
|
n_real_eigv+= 1
|
||||||
|
else
|
||||||
|
! print*,'Found an imaginary component to eigenvalue'
|
||||||
|
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
if(n_real_eigv.ne.n)then
|
||||||
|
do i = 1, n
|
||||||
|
im_part(i) = -dabs(WI(i))
|
||||||
|
iorder(i) = i
|
||||||
|
enddo
|
||||||
|
call dsort(im_part, iorder, n)
|
||||||
|
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||||
|
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||||
|
print*,'Splitting the degeneracies by ',shift_current
|
||||||
|
else
|
||||||
|
print*,'All eigenvalues are real !'
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
!!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
|
||||||
|
do i = 1, n
|
||||||
|
eigval(i) = WR(i)
|
||||||
|
iorder(i) = i
|
||||||
|
enddo
|
||||||
|
call dsort(eigval,iorder,n)
|
||||||
|
do i = 1, n
|
||||||
|
! print*,'eigval(i) = ',eigval(i)
|
||||||
|
reigvec_tmp(:,i) = VR(:,iorder(i))
|
||||||
|
leigvec_tmp(:,i) = Vl(:,iorder(i))
|
||||||
|
enddo
|
||||||
|
|
||||||
|
!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
|
||||||
|
! check bi-orthogonality
|
||||||
|
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, .false.)
|
||||||
|
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||||
|
if( accu_nd .lt. 1d-10 ) then
|
||||||
|
print *, ' bi-orthogonality: ok'
|
||||||
|
else
|
||||||
|
print *, ' '
|
||||||
|
print *, ' bi-orthogonality: not imposed yet'
|
||||||
|
if(complex_root)then
|
||||||
|
print *, ' '
|
||||||
|
print *, ' '
|
||||||
|
print *, ' orthog between degen eigenvect'
|
||||||
|
print *, ' '
|
||||||
|
! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
|
||||||
|
call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp) ! orthogonalization of reigvec
|
||||||
|
call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp) ! orthogonalization of leigvec
|
||||||
|
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S)
|
||||||
|
|
||||||
|
if( accu_nd .lt. 1d-10 ) then
|
||||||
|
print *, ' bi-orthogonality: ok'
|
||||||
|
else
|
||||||
|
print*,'New vectors not bi-orthonormals at ', accu_nd
|
||||||
|
call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half, complex_root)
|
||||||
|
if(complex_root)then
|
||||||
|
call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp) ! bi-orthonormalization using QR
|
||||||
|
else
|
||||||
|
print*,'S^{-1/2} exists !!'
|
||||||
|
call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
else ! the matrix S^{-1/2} exists
|
||||||
|
print*,'S^{-1/2} exists !!'
|
||||||
|
call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
|
||||||
|
endif
|
||||||
|
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, .false.)
|
||||||
|
if( accu_nd .lt. 1d-10 ) then
|
||||||
|
print *, ' bi-orthogonality: ok'
|
||||||
|
else
|
||||||
|
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||||
|
print*,'Must be a deep problem ...'
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
|
||||||
|
!! EIGENVECTORS SORTED AND BI-ORTHONORMAL
|
||||||
|
do i = 1, n
|
||||||
|
do j = 1, n
|
||||||
|
VR(iorder_origin(j),i) = reigvec_tmp(j,i)
|
||||||
|
VL(iorder_origin(j),i) = leigvec_tmp(j,i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
!! RECOMPUTING THE EIGENVALUES
|
||||||
|
eigval = 0.d0
|
||||||
|
do i = 1, n
|
||||||
|
iorder(i) = i
|
||||||
|
accu = 0.d0
|
||||||
|
do j = 1, n
|
||||||
|
accu += VL(j,i) * VR(j,i)
|
||||||
|
do k = 1, n
|
||||||
|
eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
eigval(i) *= 1.d0/accu
|
||||||
|
! print*,'eigval(i) = ',eigval(i)
|
||||||
|
enddo
|
||||||
|
!! RESORT JUST TO BE SURE
|
||||||
|
call dsort(eigval, iorder, n)
|
||||||
|
do i = 1, n
|
||||||
|
do j = 1, n
|
||||||
|
reigvec(j,i) = VR(j,iorder(i))
|
||||||
|
leigvec(j,i) = VL(j,iorder(i))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*,'Checking for final reigvec/leigvec'
|
||||||
|
shift_current = max(1.d-10,shift_current)
|
||||||
|
print*,'Thr for eigenvectors = ',shift_current
|
||||||
|
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
|
||||||
|
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, .false.)
|
||||||
|
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||||
|
|
||||||
|
if( accu_nd .lt. 1d-10 ) then
|
||||||
|
print *, ' bi-orthogonality: ok'
|
||||||
|
else
|
||||||
|
print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
|
||||||
|
print*,'Eigenvectors are not bi orthonormal ..'
|
||||||
|
print*,'accu_nd = ',accu_nd
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine non_hrmt_fock_mat(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! routine returning the eigenvalues and left/right eigenvectors of the TC fock matrix
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: n
|
||||||
|
double precision, intent(in) :: A(n,n)
|
||||||
|
integer, intent(out) :: n_real_eigv
|
||||||
|
double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
|
||||||
|
double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
|
||||||
|
|
||||||
|
integer :: i, j, n_degen,k , iteration
|
||||||
|
double precision :: shift_current
|
||||||
|
double precision :: r,thr,accu_d, accu_nd
|
||||||
|
integer, allocatable :: iorder_origin(:),iorder(:)
|
||||||
|
double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
|
||||||
|
double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
|
||||||
|
double precision, allocatable :: im_part(:),re_part(:)
|
||||||
|
double precision :: accu,thr_cut
|
||||||
|
double precision, allocatable :: S_nh_inv_half(:,:)
|
||||||
|
logical :: complex_root
|
||||||
|
|
||||||
|
|
||||||
|
thr_cut = 1.d-15
|
||||||
|
print*,'Computing the left/right eigenvectors ...'
|
||||||
|
print*,'Using the degeneracy splitting algorithm'
|
||||||
|
! initialization
|
||||||
|
shift_current = 1.d-15
|
||||||
|
iteration = 0
|
||||||
|
print*,'***** iteration = ',iteration
|
||||||
|
|
||||||
|
|
||||||
|
! pre-processing the matrix :: sorting by diagonal elements
|
||||||
|
allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
|
||||||
|
allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
|
||||||
|
! print*,'Aw'
|
||||||
|
do i = 1, n
|
||||||
|
iorder_origin(i) = i
|
||||||
|
diag_elem(i) = A(i,i)
|
||||||
|
! write(*,'(100(F16.10,X))')A(:,i)
|
||||||
|
enddo
|
||||||
|
call dsort(diag_elem, iorder_origin, n)
|
||||||
|
do i = 1, n
|
||||||
|
do j = 1, n
|
||||||
|
A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
|
||||||
|
allocate(im_part(n),iorder(n))
|
||||||
|
allocate( S(n,n) )
|
||||||
|
allocate(S_nh_inv_half(n,n))
|
||||||
|
|
||||||
|
|
||||||
|
Aw = A_save
|
||||||
|
call cancel_small_elmts(aw,n,thr_cut)
|
||||||
|
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||||
|
do i = 1, n
|
||||||
|
im_part(i) = -dabs(WI(i))
|
||||||
|
iorder(i) = i
|
||||||
|
enddo
|
||||||
|
call dsort(im_part, iorder, n)
|
||||||
|
n_real_eigv = 0
|
||||||
|
do i = 1, n
|
||||||
|
if(dabs(WI(i)).lt.1.d-20)then
|
||||||
|
n_real_eigv += 1
|
||||||
|
else
|
||||||
|
! print*,'Found an imaginary component to eigenvalue'
|
||||||
|
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
if(n_real_eigv.ne.n)then
|
||||||
|
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||||
|
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||||
|
print*,'Splitting the degeneracies by ',shift_current
|
||||||
|
else
|
||||||
|
print*,'All eigenvalues are real !'
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
do while(n_real_eigv.ne.n)
|
||||||
|
iteration += 1
|
||||||
|
print*,'***** iteration = ',iteration
|
||||||
|
if(shift_current.gt.1.d-3)then
|
||||||
|
print*,'shift_current > 1.d-3 !!'
|
||||||
|
print*,'Your matrix intrinsically contains complex eigenvalues'
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
Aw = A_save
|
||||||
|
! thr_cut = shift_current
|
||||||
|
call cancel_small_elmts(Aw,n,thr_cut)
|
||||||
|
call split_matrix_degen(Aw,n,shift_current)
|
||||||
|
call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
|
||||||
|
n_real_eigv = 0
|
||||||
|
do i = 1, n
|
||||||
|
if(dabs(WI(i)).lt.1.d-20)then
|
||||||
|
n_real_eigv+= 1
|
||||||
|
else
|
||||||
|
! print*,'Found an imaginary component to eigenvalue'
|
||||||
|
! print*,'Re(i) + Im(i)',WR(i),WI(i)
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
if(n_real_eigv.ne.n)then
|
||||||
|
do i = 1, n
|
||||||
|
im_part(i) = -dabs(WI(i))
|
||||||
|
iorder(i) = i
|
||||||
|
enddo
|
||||||
|
call dsort(im_part, iorder, n)
|
||||||
|
shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
|
||||||
|
print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
|
||||||
|
print*,'Splitting the degeneracies by ',shift_current
|
||||||
|
else
|
||||||
|
print*,'All eigenvalues are real !'
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
!!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
|
||||||
|
do i = 1, n
|
||||||
|
eigval(i) = WR(i)
|
||||||
|
iorder(i) = i
|
||||||
|
enddo
|
||||||
|
call dsort(eigval,iorder,n)
|
||||||
|
do i = 1, n
|
||||||
|
! print*,'eigval(i) = ',eigval(i)
|
||||||
|
reigvec_tmp(:,i) = VR(:,iorder(i))
|
||||||
|
leigvec_tmp(:,i) = Vl(:,iorder(i))
|
||||||
|
enddo
|
||||||
|
|
||||||
|
!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
|
||||||
|
! check bi-orthogonality
|
||||||
|
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S)
|
||||||
|
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||||
|
if( accu_nd .lt. 1d-10 ) then
|
||||||
|
print *, ' bi-orthogonality: ok'
|
||||||
|
else
|
||||||
|
print *, ' '
|
||||||
|
print *, ' bi-orthogonality: not imposed yet'
|
||||||
|
print *, ' '
|
||||||
|
print *, ' '
|
||||||
|
print *, ' Using impose_unique_biorthog_degen_eigvec'
|
||||||
|
print *, ' '
|
||||||
|
! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
|
||||||
|
call impose_unique_biorthog_degen_eigvec(n, eigval, mo_coef, leigvec_tmp, reigvec_tmp)
|
||||||
|
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S)
|
||||||
|
print*,'accu_nd = ',accu_nd
|
||||||
|
if( accu_nd .lt. 1d-10 ) then
|
||||||
|
print *, ' bi-orthogonality: ok'
|
||||||
|
else
|
||||||
|
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||||
|
call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half,complex_root)
|
||||||
|
if(complex_root)then
|
||||||
|
print*,'S^{-1/2} does not exits, using QR bi-orthogonalization'
|
||||||
|
call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S) ! bi-orthonormalization using QR
|
||||||
|
else
|
||||||
|
print*,'S^{-1/2} exists !!'
|
||||||
|
call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S)
|
||||||
|
if( accu_nd .lt. 1d-10 ) then
|
||||||
|
print *, ' bi-orthogonality: ok'
|
||||||
|
else
|
||||||
|
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||||
|
print*,'Must be a deep problem ...'
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
|
||||||
|
!! EIGENVECTORS SORTED AND BI-ORTHONORMAL
|
||||||
|
do i = 1, n
|
||||||
|
do j = 1, n
|
||||||
|
VR(iorder_origin(j),i) = reigvec_tmp(j,i)
|
||||||
|
VL(iorder_origin(j),i) = leigvec_tmp(j,i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
!! RECOMPUTING THE EIGENVALUES
|
||||||
|
eigval = 0.d0
|
||||||
|
do i = 1, n
|
||||||
|
iorder(i) = i
|
||||||
|
accu = 0.d0
|
||||||
|
do j = 1, n
|
||||||
|
accu += VL(j,i) * VR(j,i)
|
||||||
|
do k = 1, n
|
||||||
|
eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
eigval(i) *= 1.d0/accu
|
||||||
|
! print*,'eigval(i) = ',eigval(i)
|
||||||
|
enddo
|
||||||
|
!! RESORT JUST TO BE SURE
|
||||||
|
call dsort(eigval, iorder, n)
|
||||||
|
do i = 1, n
|
||||||
|
do j = 1, n
|
||||||
|
reigvec(j,i) = VR(j,iorder(i))
|
||||||
|
leigvec(j,i) = VL(j,iorder(i))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*,'Checking for final reigvec/leigvec'
|
||||||
|
shift_current = max(1.d-10,shift_current)
|
||||||
|
print*,'Thr for eigenvectors = ',shift_current
|
||||||
|
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec,shift_current)
|
||||||
|
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S)
|
||||||
|
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||||
|
|
||||||
|
if( accu_nd .lt. 1d-10 ) then
|
||||||
|
print *, ' bi-orthogonality: ok'
|
||||||
|
else
|
||||||
|
print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
|
||||||
|
print*,'Eigenvectors are not bi orthonormal ..'
|
||||||
|
print*,'accu_nd = ',accu_nd
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
53
src/non_hermit_dav/project.irp.f
Normal file
53
src/non_hermit_dav/project.irp.f
Normal file
@ -0,0 +1,53 @@
|
|||||||
|
subroutine h_non_hermite(v,u,Hmat,a,N_st,sze)
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Template of routine for the application of H
|
||||||
|
!
|
||||||
|
! Here, it is done with the Hamiltonian matrix
|
||||||
|
!
|
||||||
|
! on the set of determinants of psi_det
|
||||||
|
!
|
||||||
|
! Computes $v = a * H | u \rangle$
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
double precision, intent(in) :: u(sze,N_st), Hmat(sze,sze), a
|
||||||
|
double precision, intent(inout) :: v(sze,N_st)
|
||||||
|
integer :: i,j,k
|
||||||
|
do k = 1, N_st
|
||||||
|
do j = 1, sze
|
||||||
|
do i = 1, sze
|
||||||
|
v(i,k) += a * u(j,k) * Hmat(i,j)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine exp_tau_H(u,v,hmat,tau,et,N_st,sze)
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! realises v = (1 - tau (H - et)) u
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
double precision, intent(in) :: hmat(sze,sze), u(sze,N_st), tau, et
|
||||||
|
double precision, intent(out):: v(sze,N_st)
|
||||||
|
double precision :: a
|
||||||
|
integer :: i,j
|
||||||
|
v = (1.d0 + tau * et) * u
|
||||||
|
a = -1.d0 * tau
|
||||||
|
call h_non_hermite(v,u,Hmat,a,N_st,sze)
|
||||||
|
end
|
||||||
|
|
||||||
|
double precision function project_phi0(u,Hmat0,N_st,sze)
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
double precision, intent(in) :: u(sze,N_st), Hmat0(sze)
|
||||||
|
integer :: j
|
||||||
|
project_phi0 = 0.d0
|
||||||
|
do j = 1, sze
|
||||||
|
project_phi0 += u(j,1) * Hmat0(j)
|
||||||
|
enddo
|
||||||
|
project_phi0 *= 1.d0 / u(1,1)
|
||||||
|
end
|
||||||
|
|
||||||
325
src/non_hermit_dav/utils.irp.f
Normal file
325
src/non_hermit_dav/utils.irp.f
Normal file
@ -0,0 +1,325 @@
|
|||||||
|
|
||||||
|
subroutine get_inv_half_svd(matrix, n, matrix_inv_half)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! :math:`X = S^{-1/2}` obtained by SVD
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: n
|
||||||
|
double precision, intent(in) :: matrix(n,n)
|
||||||
|
double precision, intent(out) :: matrix_inv_half(n,n)
|
||||||
|
|
||||||
|
integer :: num_linear_dependencies
|
||||||
|
integer :: LDA, LDC
|
||||||
|
integer :: info, i, j, k
|
||||||
|
double precision, parameter :: threshold = 1.d-6
|
||||||
|
double precision, allocatable :: U(:,:),Vt(:,:), D(:),matrix_half(:,:),D_half(:)
|
||||||
|
|
||||||
|
double precision :: accu_d,accu_nd
|
||||||
|
|
||||||
|
LDA = size(matrix, 1)
|
||||||
|
LDC = size(matrix_inv_half, 1)
|
||||||
|
if(LDA .ne. LDC) then
|
||||||
|
print*, ' LDA != LDC'
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
|
||||||
|
print*, ' n = ', n
|
||||||
|
print*, ' LDA = ', LDA
|
||||||
|
print*, ' LDC = ', LDC
|
||||||
|
|
||||||
|
double precision,allocatable :: WR(:),WI(:),VL(:,:),VR(:,:)
|
||||||
|
allocate(WR(n),WI(n),VL(n,n),VR(n,n))
|
||||||
|
call lapack_diag_non_sym(n,matrix,WR,WI,VL,VR)
|
||||||
|
do i = 1, n
|
||||||
|
print*,'WR,WI',WR(i),WI(i)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
allocate(U(LDC,n), Vt(LDA,n), D(n))
|
||||||
|
|
||||||
|
call svd(matrix, LDA, U, LDC, D, Vt, LDA, n, n)
|
||||||
|
double precision, allocatable :: tmp1(:,:),tmp2(:,:),D_mat(:,:)
|
||||||
|
allocate(tmp1(n,n),tmp2(n,n),D_mat(n,n),matrix_half(n,n),D_half(n))
|
||||||
|
D_mat = 0.d0
|
||||||
|
do i = 1,n
|
||||||
|
D_mat(i,i) = D(i)
|
||||||
|
enddo
|
||||||
|
! matrix = U D Vt
|
||||||
|
! tmp1 = U D
|
||||||
|
tmp1 = 0.d0
|
||||||
|
call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||||
|
, U, size(U, 1), D_mat, size(D_mat, 1) &
|
||||||
|
, 0.d0, tmp1, size(tmp1, 1) )
|
||||||
|
! tmp2 = tmp1 X Vt = matrix
|
||||||
|
tmp2 = 0.d0
|
||||||
|
call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||||
|
, tmp1, size(tmp1, 1), Vt, size(Vt, 1) &
|
||||||
|
, 0.d0, tmp2, size(tmp2, 1) )
|
||||||
|
print*,'Checking the recomposition of the matrix'
|
||||||
|
accu_nd = 0.d0
|
||||||
|
accu_d = 0.d0
|
||||||
|
do i = 1, n
|
||||||
|
accu_d += dabs(tmp2(i,i) - matrix(i,i))
|
||||||
|
do j = 1, n
|
||||||
|
if(i==j)cycle
|
||||||
|
accu_nd += dabs(tmp2(j,i) - matrix(j,i))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*,'accu_d =',accu_d
|
||||||
|
print*,'accu_nd =',accu_nd
|
||||||
|
print*,'passed the recomposition'
|
||||||
|
|
||||||
|
num_linear_dependencies = 0
|
||||||
|
do i = 1, n
|
||||||
|
if(abs(D(i)) <= threshold) then
|
||||||
|
D(i) = 0.d0
|
||||||
|
num_linear_dependencies += 1
|
||||||
|
else
|
||||||
|
ASSERT (D(i) > 0.d0)
|
||||||
|
D_half(i) = dsqrt(D(i))
|
||||||
|
D(i) = 1.d0 / dsqrt(D(i))
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
write(*,*) ' linear dependencies', num_linear_dependencies
|
||||||
|
|
||||||
|
matrix_inv_half = 0.d0
|
||||||
|
matrix_half = 0.d0
|
||||||
|
do k = 1, n
|
||||||
|
if(D(k) /= 0.d0) then
|
||||||
|
do j = 1, n
|
||||||
|
do i = 1, n
|
||||||
|
! matrix_inv_half(i,j) = matrix_inv_half(i,j) + U(i,k) * D(k) * Vt(k,j)
|
||||||
|
matrix_inv_half(i,j) = matrix_inv_half(i,j) + U(i,k) * D(k) * Vt(j,k)
|
||||||
|
matrix_half(i,j) = matrix_half(i,j) + U(i,k) * D_half(k) * Vt(j,k)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
print*,'testing S^1/2 * S^1/2= S'
|
||||||
|
! tmp1 = S^1/2 X S^1/2
|
||||||
|
tmp1 = 0.d0
|
||||||
|
call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||||
|
, matrix_half, size(matrix_half, 1), matrix_half, size(matrix_half, 1) &
|
||||||
|
, 0.d0, tmp1, size(tmp1, 1) )
|
||||||
|
accu_nd = 0.d0
|
||||||
|
accu_d = 0.d0
|
||||||
|
do i = 1, n
|
||||||
|
accu_d += dabs(tmp1(i,i) - matrix(i,i))
|
||||||
|
do j = 1, n
|
||||||
|
if(i==j)cycle
|
||||||
|
accu_nd += dabs(tmp1(j,i) - matrix(j,i))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*,'accu_d =',accu_d
|
||||||
|
print*,'accu_nd =',accu_nd
|
||||||
|
|
||||||
|
! print*,'S inv half'
|
||||||
|
! do i = 1, n
|
||||||
|
! write(*, '(1000(F16.10,X))') matrix_inv_half(i,:)
|
||||||
|
! enddo
|
||||||
|
|
||||||
|
double precision, allocatable :: pseudo_inverse(:,:),identity(:,:)
|
||||||
|
allocate( pseudo_inverse(n,n),identity(n,n))
|
||||||
|
call get_pseudo_inverse(matrix,n,n,n,pseudo_inverse,n,threshold)
|
||||||
|
|
||||||
|
! S^-1 X S = 1
|
||||||
|
! identity = 0.d0
|
||||||
|
! call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||||
|
! , matrix, size(matrix, 1), pseudo_inverse, size(pseudo_inverse, 1) &
|
||||||
|
! , 0.d0, identity, size(identity, 1) )
|
||||||
|
print*,'Checking S^-1/2 X S^-1/2 = S^-1 ?'
|
||||||
|
! S^-1/2 X S^-1/2 = S^-1 ?
|
||||||
|
tmp1 = 0.d0
|
||||||
|
call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||||
|
,matrix_inv_half, size(matrix_inv_half, 1), matrix_inv_half, size(matrix_inv_half, 1) &
|
||||||
|
, 0.d0, tmp1, size(tmp1, 1) )
|
||||||
|
accu_nd = 0.d0
|
||||||
|
accu_d = 0.d0
|
||||||
|
do i = 1, n
|
||||||
|
accu_d += dabs(1.d0 - pseudo_inverse(i,i))
|
||||||
|
do j = 1, n
|
||||||
|
if(i==j)cycle
|
||||||
|
accu_nd += dabs(tmp1(j,i) - pseudo_inverse(j,i))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*,'accu_d =',accu_d
|
||||||
|
print*,'accu_nd =',accu_nd
|
||||||
|
|
||||||
|
stop
|
||||||
|
!
|
||||||
|
! ! ( S^-1/2 x S ) x S^-1/2
|
||||||
|
! Stmp2 = 0.d0
|
||||||
|
! call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||||
|
! , Stmp, size(Stmp, 1), matrix_inv_half, size(matrix_inv_half, 1) &
|
||||||
|
! , 0.d0, Stmp2, size(Stmp2, 1) )
|
||||||
|
|
||||||
|
! S^-1/2 x ( S^-1/2 x S )
|
||||||
|
! Stmp2 = 0.d0
|
||||||
|
! call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||||
|
! , matrix_inv_half, size(matrix_inv_half, 1), Stmp, size(Stmp, 1) &
|
||||||
|
! , 0.d0, Stmp2, size(Stmp2, 1) )
|
||||||
|
|
||||||
|
! do i = 1, n
|
||||||
|
! do j = 1, n
|
||||||
|
! if(i==j) then
|
||||||
|
! accu_d += Stmp2(j,i)
|
||||||
|
! else
|
||||||
|
! accu_nd = accu_nd + Stmp2(j,i) * Stmp2(j,i)
|
||||||
|
! endif
|
||||||
|
! enddo
|
||||||
|
! enddo
|
||||||
|
! accu_nd = dsqrt(accu_nd)
|
||||||
|
! print*, ' after S^-1/2: sum of off-diag S elements = ', accu_nd
|
||||||
|
! print*, ' after S^-1/2: sum of diag S elements = ', accu_d
|
||||||
|
! do i = 1, n
|
||||||
|
! write(*,'(1000(F16.10,X))') Stmp2(i,:)
|
||||||
|
! enddo
|
||||||
|
|
||||||
|
!double precision :: thresh
|
||||||
|
!thresh = 1.d-10
|
||||||
|
!if( accu_nd.gt.thresh .or. dabs(accu_d-dble(n)).gt.thresh) then
|
||||||
|
! stop
|
||||||
|
!endif
|
||||||
|
|
||||||
|
end subroutine get_inv_half_svd
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine get_inv_half_nonsymmat_diago(matrix, n, matrix_inv_half, complex_root)
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! input: S = matrix
|
||||||
|
! output: S^{-1/2} = matrix_inv_half obtained by diagonalization
|
||||||
|
!
|
||||||
|
! S = VR D VL^T
|
||||||
|
! = VR D^{1/2} D^{1/2} VL^T
|
||||||
|
! = VR D^{1/2} VL^T VR D^{1/2} VL^T
|
||||||
|
! = S^{1/2} S^{1/2} with S = VR D^{1/2} VL^T
|
||||||
|
!
|
||||||
|
! == > S^{-1/2} = VR D^{-1/2} VL^T
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: n
|
||||||
|
double precision, intent(in) :: matrix(n,n)
|
||||||
|
logical, intent(out) :: complex_root
|
||||||
|
double precision, intent(out) :: matrix_inv_half(n,n)
|
||||||
|
|
||||||
|
integer :: i, j
|
||||||
|
double precision :: accu_d, accu_nd
|
||||||
|
double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:), S(:,:), S_diag(:)
|
||||||
|
double precision, allocatable :: tmp1(:,:), D_mat(:,:)
|
||||||
|
|
||||||
|
complex_root = .False.
|
||||||
|
|
||||||
|
matrix_inv_half = 0.D0
|
||||||
|
print*,'Computing S^{-1/2}'
|
||||||
|
|
||||||
|
allocate(WR(n), WI(n), VL(n,n), VR(n,n))
|
||||||
|
call lapack_diag_non_sym(n, matrix, WR, WI, VL, VR)
|
||||||
|
|
||||||
|
allocate(S(n,n))
|
||||||
|
call check_biorthog(n, n, VL, VR, accu_d, accu_nd, S)
|
||||||
|
print*,'accu_nd S^{-1/2}',accu_nd
|
||||||
|
if(accu_nd.gt.1.d-10) then
|
||||||
|
complex_root = .True. ! if vectors are not bi-orthogonal return
|
||||||
|
print*,'Eigenvectors of S are not bi-orthonormal, skipping S^{-1/2}'
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
|
||||||
|
allocate(S_diag(n))
|
||||||
|
do i = 1, n
|
||||||
|
S_diag(i) = 1.d0/dsqrt(S(i,i))
|
||||||
|
if(dabs(WI(i)).gt.1.d-20.or.WR(i).lt.0.d0)then ! check that eigenvalues are real and positive
|
||||||
|
complex_root = .True.
|
||||||
|
print*,'Eigenvalues of S have imaginary part '
|
||||||
|
print*,'WR(i),WI(i)',WR(i), WR(i)
|
||||||
|
print*,'Skipping S^{-1/2}'
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
deallocate(S)
|
||||||
|
|
||||||
|
if(complex_root) return
|
||||||
|
|
||||||
|
! normalization of vectors
|
||||||
|
do i = 1, n
|
||||||
|
if(S_diag(i).eq.1.d0) cycle
|
||||||
|
do j = 1,n
|
||||||
|
VL(j,i) *= S_diag(i)
|
||||||
|
VR(j,i) *= S_diag(i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
deallocate(S_diag)
|
||||||
|
|
||||||
|
allocate(tmp1(n,n), D_mat(n,n))
|
||||||
|
|
||||||
|
D_mat = 0.d0
|
||||||
|
do i = 1, n
|
||||||
|
D_mat(i,i) = 1.d0/dsqrt(WR(i))
|
||||||
|
enddo
|
||||||
|
deallocate(WR, WI)
|
||||||
|
|
||||||
|
! tmp1 = VR D^{-1/2}
|
||||||
|
tmp1 = 0.d0
|
||||||
|
call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||||
|
, VR, size(VR, 1), D_mat, size(D_mat, 1) &
|
||||||
|
, 0.d0, tmp1, size(tmp1, 1) )
|
||||||
|
deallocate(VR, D_mat)
|
||||||
|
|
||||||
|
! S^{-1/2} = tmp1 X VL^T
|
||||||
|
matrix_inv_half = 0.d0
|
||||||
|
call dgemm( 'N', 'T', n, n, n, 1.d0 &
|
||||||
|
, tmp1, size(tmp1, 1), VL, size(VL, 1) &
|
||||||
|
, 0.d0, matrix_inv_half, size(matrix_inv_half, 1) )
|
||||||
|
deallocate(tmp1, VL)
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine bi_ortho_s_inv_half(n,leigvec,reigvec,S_nh_inv_half)
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: n
|
||||||
|
double precision, intent(in) :: S_nh_inv_half(n,n)
|
||||||
|
double precision, intent(inout) :: leigvec(n,n),reigvec(n,n)
|
||||||
|
BEGIN_DOC
|
||||||
|
! bi-orthonormalization of left and right vectors
|
||||||
|
!
|
||||||
|
! S = VL^T VR
|
||||||
|
!
|
||||||
|
! S^{-1/2} S S^{-1/2} = 1 = S^{-1/2} VL^T VR S^{-1/2} = VL_new^T VR_new
|
||||||
|
!
|
||||||
|
! VL_new = VL (S^{-1/2})^T
|
||||||
|
!
|
||||||
|
! VR_new = VR S^{^{-1/2}}
|
||||||
|
END_DOC
|
||||||
|
double precision,allocatable :: vl_tmp(:,:),vr_tmp(:,:)
|
||||||
|
print*,'Bi-orthonormalization using S^{-1/2}'
|
||||||
|
allocate(vl_tmp(n,n),vr_tmp(n,n))
|
||||||
|
vl_tmp = leigvec
|
||||||
|
vr_tmp = reigvec
|
||||||
|
! VL_new = VL (S^{-1/2})^T
|
||||||
|
call dgemm( 'N', 'T', n, n, n, 1.d0 &
|
||||||
|
, vl_tmp, size(vl_tmp, 1), S_nh_inv_half, size(S_nh_inv_half, 1) &
|
||||||
|
, 0.d0, leigvec, size(leigvec, 1) )
|
||||||
|
! VR_new = VR S^{^{-1/2}}
|
||||||
|
call dgemm( 'N', 'N', n, n, n, 1.d0 &
|
||||||
|
, vr_tmp, size(vr_tmp, 1), S_nh_inv_half, size(S_nh_inv_half, 1) &
|
||||||
|
, 0.d0, reigvec, size(reigvec, 1) )
|
||||||
|
double precision :: accu_d, accu_nd
|
||||||
|
double precision,allocatable :: S(:,:)
|
||||||
|
allocate(S(n,n))
|
||||||
|
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S)
|
||||||
|
if(dabs(accu_d - n).gt.1.d-10 .or. accu_nd .gt.1.d-8 )then
|
||||||
|
print*,'Pb in bi_ortho_s_inv_half !!'
|
||||||
|
print*,'accu_d =',accu_d
|
||||||
|
print*,'accu_nd =',accu_nd
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
end
|
||||||
Loading…
Reference in New Issue
Block a user