mirror of
https://github.com/QuantumPackage/qp2.git
synced 2025-01-21 17:12:01 +01:00
TC SPRING CLEANING: BEGINNING
This commit is contained in:
parent
a607f84c34
commit
c50018e8bd
@ -123,7 +123,7 @@ subroutine give_integrals_3_body_bi_ort_spin( n, sigma_n, l, sigma_l, k, sigma_k
|
||||
endif
|
||||
|
||||
return
|
||||
end subroutine give_integrals_3_body_bi_ort_spin
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -132,6 +132,7 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
|
||||
double precision, allocatable :: A(:,:,:,:), b(:), A_tmp(:,:,:,:)
|
||||
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
|
||||
double precision, allocatable :: u1e_tmp(:), tmp(:,:,:)
|
||||
double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
|
||||
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:)
|
||||
|
||||
|
||||
@ -176,26 +177,27 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
|
||||
! --- --- ---
|
||||
! get A
|
||||
|
||||
allocate(tmp(n_points_final_grid,ao_num,ao_num))
|
||||
allocate(tmp1(n_points_final_grid,ao_num,ao_num), tmp2(n_points_final_grid,ao_num,ao_num))
|
||||
allocate(A(ao_num,ao_num,ao_num,ao_num))
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, ipoint) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp(ipoint,i,j) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
tmp1(ipoint,i,j) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
tmp2(ipoint,i,j) = aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid &
|
||||
call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, tmp1(1,1,1), n_points_final_grid, tmp2(1,1,1), n_points_final_grid &
|
||||
, 0.d0, A(1,1,1,1), ao_num*ao_num)
|
||||
|
||||
allocate(A_tmp(ao_num,ao_num,ao_num,ao_num))
|
||||
@ -207,13 +209,13 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
|
||||
allocate(b(ao_num*ao_num))
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
u1e_tmp(ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * u1e_tmp(ipoint)
|
||||
u1e_tmp(ipoint) = u1e_tmp(ipoint)
|
||||
enddo
|
||||
|
||||
call dgemv("T", n_points_final_grid, ao_num*ao_num, 1.d0, tmp(1,1,1), n_points_final_grid, u1e_tmp(1), 1, 0.d0, b(1), 1)
|
||||
call dgemv("T", n_points_final_grid, ao_num*ao_num, 1.d0, tmp1(1,1,1), n_points_final_grid, u1e_tmp(1), 1, 0.d0, b(1), 1)
|
||||
|
||||
deallocate(u1e_tmp)
|
||||
deallocate(tmp)
|
||||
deallocate(tmp1, tmp2)
|
||||
|
||||
! --- --- ---
|
||||
! solve Ax = b
|
||||
|
@ -179,7 +179,7 @@ double precision function num_v_ij_erf_rk_cst_mu_env(i, j, ipoint)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
r12 = dsqrt( dx * dx + dy * dy + dz * dz )
|
||||
r12 = dsqrt(dx*dx + dy*dy + dz*dz)
|
||||
if(r12 .lt. 1d-10) cycle
|
||||
|
||||
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12
|
||||
@ -228,7 +228,7 @@ subroutine num_x_v_ij_erf_rk_cst_mu_env(i, j, ipoint, integ)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
r12 = dsqrt( dx * dx + dy * dy + dz * dz )
|
||||
r12 = dsqrt(dx*dx + dy*dy + dz*dz)
|
||||
if(r12 .lt. 1d-10) cycle
|
||||
|
||||
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12
|
||||
@ -530,7 +530,7 @@ subroutine num_int2_u_grad1u_total_env2(i, j, ipoint, integ)
|
||||
dx = r1(1) - r2(1)
|
||||
dy = r1(2) - r2(2)
|
||||
dz = r1(3) - r2(3)
|
||||
r12 = dsqrt( dx * dx + dy * dy + dz * dz )
|
||||
r12 = dsqrt(dx*dx + dy*dy + dz*dz)
|
||||
if(r12 .lt. 1d-10) cycle
|
||||
|
||||
tmp0 = env_nucl(r2)
|
||||
|
@ -63,12 +63,10 @@
|
||||
do i_pass = 1, n_pass
|
||||
ii = (i_pass-1)*n_blocks + 1
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i_blocks, ipoint) &
|
||||
!$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, &
|
||||
!$OMP final_grid_points, tmp_grad1_u12, &
|
||||
!$OMP tmp_grad1_u12_squared)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i_blocks, ipoint) &
|
||||
!$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12, tmp_grad1_u12_squared)
|
||||
!$OMP DO
|
||||
do i_blocks = 1, n_blocks
|
||||
ipoint = ii - 1 + i_blocks ! r1
|
||||
@ -99,12 +97,10 @@
|
||||
|
||||
ii = n_pass*n_blocks + 1
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i_rest, ipoint) &
|
||||
!$OMP SHARED (n_rest, n_points_extra_final_grid, ii, &
|
||||
!$OMP final_grid_points, tmp_grad1_u12, &
|
||||
!$OMP tmp_grad1_u12_squared)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i_rest, ipoint) &
|
||||
!$OMP SHARED (n_rest, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12, tmp_grad1_u12_squared)
|
||||
!$OMP DO
|
||||
do i_rest = 1, n_rest
|
||||
ipoint = ii - 1 + i_rest ! r1
|
||||
|
@ -1125,6 +1125,7 @@ subroutine test_fit_coef_A1()
|
||||
double precision :: accu, norm, diff
|
||||
double precision, allocatable :: A1(:,:)
|
||||
double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:)
|
||||
double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
|
||||
|
||||
! ---
|
||||
|
||||
@ -1165,16 +1166,17 @@ subroutine test_fit_coef_A1()
|
||||
|
||||
call wall_time(t1)
|
||||
|
||||
allocate(tmp(ao_num,ao_num,n_points_final_grid))
|
||||
allocate(tmp1(ao_num,ao_num,n_points_final_grid), tmp2(ao_num,ao_num,n_points_final_grid))
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, ipoint) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp(i,j,ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
tmp1(i,j,ipoint) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
tmp2(i,j,ipoint) = aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
@ -1184,9 +1186,9 @@ subroutine test_fit_coef_A1()
|
||||
allocate(A2(ao_num,ao_num,ao_num,ao_num))
|
||||
|
||||
call dgemm( "N", "T", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, tmp(1,1,1), ao_num*ao_num, tmp(1,1,1), ao_num*ao_num &
|
||||
, tmp1(1,1,1), ao_num*ao_num, tmp2(1,1,1), ao_num*ao_num &
|
||||
, 0.d0, A2(1,1,1,1), ao_num*ao_num)
|
||||
deallocate(tmp)
|
||||
deallocate(tmp1, tmp2)
|
||||
|
||||
call wall_time(t2)
|
||||
print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
|
||||
@ -1238,6 +1240,7 @@ subroutine test_fit_coef_inv()
|
||||
double precision, allocatable :: A1(:,:), A1_inv(:,:), A1_tmp(:,:)
|
||||
double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:), A2_inv(:,:,:,:)
|
||||
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A2_tmp(:,:,:,:)
|
||||
double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
|
||||
|
||||
cutoff_svd = 5d-8
|
||||
|
||||
@ -1286,16 +1289,17 @@ subroutine test_fit_coef_inv()
|
||||
|
||||
call wall_time(t1)
|
||||
|
||||
allocate(tmp(n_points_final_grid,ao_num,ao_num))
|
||||
allocate(tmp1(n_points_final_grid,ao_num,ao_num), tmp2(n_points_final_grid,ao_num,ao_num))
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, ipoint) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
|
||||
!$OMP DO COLLAPSE(2)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do ipoint = 1, n_points_final_grid
|
||||
tmp(ipoint,i,j) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
tmp1(ipoint,i,j) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
tmp2(ipoint,i,j) = aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
@ -1304,11 +1308,11 @@ subroutine test_fit_coef_inv()
|
||||
|
||||
allocate(A2(ao_num,ao_num,ao_num,ao_num))
|
||||
|
||||
call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid &
|
||||
call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, tmp1(1,1,1), n_points_final_grid, tmp2(1,1,1), n_points_final_grid &
|
||||
, 0.d0, A2(1,1,1,1), ao_num*ao_num)
|
||||
|
||||
deallocate(tmp)
|
||||
deallocate(tmp1, tmp2)
|
||||
|
||||
call wall_time(t2)
|
||||
print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -273,60 +273,6 @@ end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine lapack_diag_non_sym_right(n, A, WR, WI, VR)
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n
|
||||
double precision, intent(in) :: A(n,n)
|
||||
double precision, intent(out) :: WR(n), WI(n), VR(n,n)
|
||||
|
||||
integer :: i, lda, ldvl, ldvr, LWORK, INFO
|
||||
double precision, allocatable :: Atmp(:,:), WORK(:), VL(:,:)
|
||||
|
||||
lda = n
|
||||
ldvl = 1
|
||||
ldvr = n
|
||||
|
||||
allocate( Atmp(n,n), VL(1,1) )
|
||||
Atmp(1:n,1:n) = A(1:n,1:n)
|
||||
|
||||
allocate(WORK(1))
|
||||
LWORK = -1
|
||||
call dgeev('N', 'V', n, Atmp, lda, WR, WI, VL, ldvl, VR, ldvr, WORK, LWORK, INFO)
|
||||
if(INFO.gt.0)then
|
||||
print*,'dgeev failed !!',INFO
|
||||
stop
|
||||
endif
|
||||
|
||||
LWORK = max(int(WORK(1)), 1) ! this is the optimal size of WORK
|
||||
deallocate(WORK)
|
||||
|
||||
allocate(WORK(LWORK))
|
||||
|
||||
! Actual diagonalization
|
||||
call dgeev('N', 'V', n, Atmp, lda, WR, WI, VL, ldvl, VR, ldvr, WORK, LWORK, INFO)
|
||||
if(INFO.ne.0) then
|
||||
print*,'dgeev failed !!', INFO
|
||||
stop
|
||||
endif
|
||||
|
||||
deallocate(Atmp, WORK, VL)
|
||||
|
||||
! print *, ' JOBL = F'
|
||||
! print *, ' eigenvalues'
|
||||
! do i = 1, n
|
||||
! write(*, '(1000(F16.10,X))') WR(i), WI(i)
|
||||
! enddo
|
||||
! print *, ' right eigenvect'
|
||||
! do i = 1, n
|
||||
! write(*, '(1000(F16.10,X))') VR(:,i)
|
||||
! enddo
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine non_hrmt_real_diag(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
||||
|
||||
BEGIN_DOC
|
||||
@ -1780,70 +1726,6 @@ end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine check_weighted_biorthog(n, m, W, Vl, Vr, thr_d, thr_nd, accu_d, accu_nd, S, stop_ifnot)
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n, m
|
||||
double precision, intent(in) :: Vl(n,m), Vr(n,m), W(n,n)
|
||||
double precision, intent(in) :: thr_d, thr_nd
|
||||
logical, intent(in) :: stop_ifnot
|
||||
double precision, intent(out) :: accu_d, accu_nd, S(m,m)
|
||||
|
||||
integer :: i, j
|
||||
double precision, allocatable :: SS(:,:), tmp(:,:)
|
||||
|
||||
print *, ' check weighted bi-orthogonality'
|
||||
|
||||
! ---
|
||||
|
||||
allocate(tmp(m,n))
|
||||
call dgemm( 'T', 'N', m, n, n, 1.d0 &
|
||||
, Vl, size(Vl, 1), W, size(W, 1) &
|
||||
, 0.d0, tmp, size(tmp, 1) )
|
||||
call dgemm( 'N', 'N', m, m, n, 1.d0 &
|
||||
, tmp, size(tmp, 1), Vr, size(Vr, 1) &
|
||||
, 0.d0, S, size(S, 1) )
|
||||
deallocate(tmp)
|
||||
|
||||
!print *, ' overlap matrix:'
|
||||
!do i = 1, m
|
||||
! write(*,'(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
accu_d = 0.d0
|
||||
accu_nd = 0.d0
|
||||
do i = 1, m
|
||||
do j = 1, m
|
||||
if(i==j) then
|
||||
accu_d = accu_d + dabs(S(i,i))
|
||||
else
|
||||
accu_nd = accu_nd + S(j,i) * S(j,i)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
accu_nd = dsqrt(accu_nd)
|
||||
|
||||
print *, ' accu_nd = ', accu_nd
|
||||
print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m)
|
||||
|
||||
! ---
|
||||
|
||||
if( stop_ifnot .and. ((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d) ) then
|
||||
print *, ' non bi-orthogonal vectors !'
|
||||
print *, ' accu_nd = ', accu_nd
|
||||
print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m)
|
||||
!print *, ' overlap matrix:'
|
||||
!do i = 1, m
|
||||
! write(*,'(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
stop
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ifnot)
|
||||
|
||||
implicit none
|
||||
|
@ -1,670 +0,0 @@
|
||||
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, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) 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, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) 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, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) 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, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) 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, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) 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, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) 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, 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
|
||||
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, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) 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, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) 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
|
||||
double precision :: 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) )
|
||||
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, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) 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, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print*,'accu_nd = ',accu_nd
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) 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, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) 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, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) 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
|
||||
|
||||
|
@ -183,11 +183,3 @@ BEGIN_PROVIDER [ double precision, x_W_ij_erf_rk, ( n_points_final_grid,3,mo_num
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, sqrt_weight_at_r, (n_points_final_grid)]
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
do ipoint = 1, n_points_final_grid
|
||||
sqrt_weight_at_r(ipoint) = dsqrt(final_weight_at_r_vector(ipoint))
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -9,3 +9,14 @@ interface: ezfio
|
||||
doc: Coefficients for the right wave function
|
||||
type: double precision
|
||||
size: (determinants.n_det,determinants.n_states)
|
||||
|
||||
[tc_gs_energy]
|
||||
type: Threshold
|
||||
doc: TC GS Energy
|
||||
interface: ezfio
|
||||
|
||||
[tc_gs_var]
|
||||
type: Threshold
|
||||
doc: TC GS VAR
|
||||
interface: ezfio
|
||||
|
||||
|
@ -6,18 +6,9 @@ program print_tc_energy
|
||||
|
||||
implicit none
|
||||
|
||||
print *, 'Hello world'
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
my_n_pt_r_grid = tc_grid1_r
|
||||
my_n_pt_a_grid = tc_grid1_a
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
|
||||
PROVIDE j2e_type
|
||||
PROVIDE j1e_type
|
||||
PROVIDE env_type
|
||||
@ -26,6 +17,27 @@ program print_tc_energy
|
||||
print *, ' j1e_type = ', j1e_type
|
||||
print *, ' env_type = ', env_type
|
||||
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
my_n_pt_r_grid = tc_grid1_r
|
||||
my_n_pt_a_grid = tc_grid1_a
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
call write_int(6, my_n_pt_r_grid, 'radial external grid over')
|
||||
call write_int(6, my_n_pt_a_grid, 'angular external grid over')
|
||||
|
||||
if(tc_integ_type .eq. "numeric") then
|
||||
my_extra_grid_becke = .True.
|
||||
PROVIDE tc_grid2_a tc_grid2_r
|
||||
my_n_pt_r_extra_grid = tc_grid2_r
|
||||
my_n_pt_a_extra_grid = tc_grid2_a
|
||||
touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
|
||||
|
||||
call write_int(6, my_n_pt_r_extra_grid, 'radial internal grid over')
|
||||
call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
|
||||
endif
|
||||
|
||||
call write_tc_energy()
|
||||
|
||||
end
|
||||
|
@ -6,7 +6,8 @@ program print_tc_var
|
||||
|
||||
implicit none
|
||||
|
||||
print *, 'Hello world'
|
||||
print *, ' TC VAR is available only for HF REF WF'
|
||||
print *, ' DO NOT FORGET TO RUN A CISD CALCULATION BEF'
|
||||
|
||||
my_grid_becke = .True.
|
||||
PROVIDE tc_grid1_a tc_grid1_r
|
||||
@ -17,7 +18,7 @@ program print_tc_var
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
call write_tc_var()
|
||||
call write_tc_gs_var_HF()
|
||||
|
||||
end
|
||||
|
||||
|
@ -38,9 +38,9 @@ subroutine main()
|
||||
call ezfio_has_cisd_energy(exists)
|
||||
if(.not.exists) then
|
||||
|
||||
call ezfio_has_tc_scf_bitc_energy(exists)
|
||||
call ezfio_has_tc_scf_tcscf_energy(exists)
|
||||
if(exists) then
|
||||
call ezfio_get_tc_scf_bitc_energy(e_ref)
|
||||
call ezfio_get_tc_scf_tcscf_energy(e_ref)
|
||||
endif
|
||||
|
||||
else
|
||||
@ -59,7 +59,7 @@ subroutine main()
|
||||
|
||||
close(iunit)
|
||||
|
||||
end subroutine main
|
||||
end
|
||||
|
||||
! --
|
||||
|
||||
@ -89,7 +89,7 @@ subroutine write_lr_spindeterminants()
|
||||
call ezfio_set_spindeterminants_psi_left_coef_matrix_values(buffer)
|
||||
deallocate(buffer)
|
||||
|
||||
end subroutine write_lr_spindeterminants
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -2,12 +2,67 @@
|
||||
subroutine write_tc_energy()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k
|
||||
double precision :: hmono, htwoe, hthree, htot
|
||||
double precision :: E_TC, O_TC
|
||||
double precision :: E_1e, E_2e, E_3e
|
||||
integer :: i, j, k
|
||||
double precision :: hmono, htwoe, hthree, htot
|
||||
double precision :: E_TC, O_TC
|
||||
double precision :: E_1e, E_2e, E_3e
|
||||
double precision, allocatable :: E_TC_tmp(:), E_1e_tmp(:), E_2e_tmp(:), E_3e_tmp(:)
|
||||
|
||||
do k = 1, n_states
|
||||
! GS
|
||||
! ---
|
||||
|
||||
allocate(E_TC_tmp(N_det), E_1e_tmp(N_det), E_2e_tmp(N_det), E_3e_tmp(N_det))
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE(i, j, hmono, htwoe, hthree, htot) &
|
||||
!$OMP SHARED(N_det, psi_det, N_int, psi_l_coef_bi_ortho, psi_r_coef_bi_ortho, &
|
||||
!$OMP E_TC_tmp, E_1e_tmp, E_2e_tmp, E_3e_tmp)
|
||||
!$OMP DO
|
||||
do i = 1, N_det
|
||||
E_TC_tmp(i) = 0.d0
|
||||
E_1e_tmp(i) = 0.d0
|
||||
E_2e_tmp(i) = 0.d0
|
||||
E_3e_tmp(i) = 0.d0
|
||||
do j = 1, N_det
|
||||
call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
|
||||
E_TC_tmp(i) = E_TC_tmp(i) + |