Skip to content

Commit

Permalink
Merge pull request #13 from QuantumPackage/dev-stable-tc-scf
Browse files Browse the repository at this point in the history
Dev stable tc scf
  • Loading branch information
AbdAmmar committed May 6, 2023
2 parents 868d5a1 + 24ec7f4 commit 17566b8
Show file tree
Hide file tree
Showing 10 changed files with 197 additions and 56 deletions.
31 changes: 7 additions & 24 deletions src/cipsi_tc_bi_ortho/pt2.irp.f
@@ -1,4 +1,4 @@
subroutine pt2_tc_bi_ortho
subroutine tc_pt2
use selection_types
implicit none
BEGIN_DOC
Expand All @@ -15,7 +15,7 @@ subroutine pt2_tc_bi_ortho
double precision, external :: memory_of_double
double precision :: correlation_energy_ratio,E_denom,E_tc,norm
double precision, allocatable :: ept2(:), pt1(:),extrap_energy(:)
PROVIDE H_apply_buffer_allocated distributed_davidson mo_two_e_integrals_in_map
PROVIDE H_apply_buffer_allocated distributed_davidson

print*,'Diagonal elements of the Fock matrix '
do i = 1, mo_num
Expand Down Expand Up @@ -44,24 +44,14 @@ subroutine pt2_tc_bi_ortho
pt2_data % overlap= 0.d0
pt2_data % variance = huge(1.e0)

if (s2_eig) then
call make_s2_eigenfunction
endif
!!!! WARNING !!!! SEEMS TO BE PROBLEM WTH make_s2_eigenfunction !!!! THE DETERMINANTS CAN APPEAR TWICE IN THE WFT DURING SELECTION
! if (s2_eig) then
! call make_s2_eigenfunction
! endif
print_pt2 = .False.
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
! call routine_save_right

if (N_det > N_det_max) then
psi_det(1:N_int,1:2,1:N_det) = psi_det_generators(1:N_int,1:2,1:N_det)
psi_coef(1:N_det,1:N_states) = psi_coef_sorted_tc_gen(1:N_det,1:N_states)
N_det = N_det_max
soft_touch N_det psi_det psi_coef
if (s2_eig) then
call make_s2_eigenfunction
endif
print_pt2 = .False.
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
endif

allocate(ept2(1000),pt1(1000),extrap_energy(100))

Expand All @@ -71,18 +61,11 @@ subroutine pt2_tc_bi_ortho
! soft_touch thresh_it_dav

print_pt2 = .True.
to_select = int(sqrt(dble(N_states))*dble(N_det)*selection_factor)
to_select = max(N_states_diag, to_select)

E_denom = E_tc ! TC Energy of the current wave function
call pt2_dealloc(pt2_data)
call pt2_dealloc(pt2_data_err)
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection

N_iter += 1

call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)

end
Expand Down
31 changes: 31 additions & 0 deletions src/fci_tc_bi/pt2_tc.irp.f
@@ -0,0 +1,31 @@
program tc_pt2_prog
implicit none
my_grid_becke = .True.
my_n_pt_r_grid = 30
my_n_pt_a_grid = 50
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
pruning = -1.d0
touch pruning
! pt2_relative_error = 0.01d0
! touch pt2_relative_error
call run_pt2_tc

end


subroutine run_pt2_tc

implicit none

PROVIDE psi_det psi_coef mo_bi_ortho_tc_two_e mo_bi_ortho_tc_one_e
if(elec_alpha_num+elec_beta_num.ge.3)then
if(three_body_h_tc)then
call provide_all_three_ints_bi_ortho
endif
endif
! ---

call tc_pt2


end
12 changes: 3 additions & 9 deletions src/kohn_sham/print_mos.irp.f
Expand Up @@ -3,28 +3,22 @@ program print_mos
integer :: i,nx
double precision :: r(3), xmax, dx, accu
double precision, allocatable :: mos_array(:)
double precision:: alpha,envelop
double precision:: alpha,envelop,dm_a,dm_b
allocate(mos_array(mo_num))
xmax = 5.d0
nx = 1000
dx=xmax/dble(nx)
r = 0.d0
alpha = 0.5d0
do i = 1, nx
call dm_dft_alpha_beta_at_r(r,dm_a,dm_b)
call give_all_mos_at_r(r,mos_array)
accu = mos_array(3)**2+mos_array(4)**2+mos_array(5)**2
accu = dsqrt(accu)
envelop = (1.d0 - dexp(-alpha * r(3)**2))
write(33,'(100(F16.10,X))')r(3), mos_array(1), mos_array(2), accu, envelop
write(33,'(100(F16.10,X))')r(3), mos_array(1), mos_array(2), accu, dm_a+dm_b, envelop
r(3) += dx
enddo

end

double precision function f_mu(x)
implicit none
double precision, intent(in) :: x



end
7 changes: 6 additions & 1 deletion src/tc_bi_ortho/e_corr_bi_ortho.irp.f
Expand Up @@ -45,6 +45,9 @@
&BEGIN_PROVIDER [ double precision, e_corr_bi_orth_proj ]
&BEGIN_PROVIDER [ double precision, e_corr_single_bi_orth ]
&BEGIN_PROVIDER [ double precision, e_corr_double_bi_orth ]
&BEGIN_PROVIDER [ double precision, e_corr_bi_orth_proj_abs ]
&BEGIN_PROVIDER [ double precision, e_corr_single_bi_orth_abs ]
&BEGIN_PROVIDER [ double precision, e_corr_double_bi_orth_abs ]
implicit none
integer :: i,degree
double precision :: hmono,htwoe,hthree,htilde_ij
Expand All @@ -57,13 +60,15 @@
call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
if(degree == 1)then
e_corr_single_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
e_corr_single_bi_orth_abs += dabs(reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1))
else if(degree == 2)then
e_corr_double_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
! print*,'coef_wf , e_cor',reigvec_tc_bi_orth(i,1)/reigvec_tc_bi_orth(1,1), reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
e_corr_double_bi_orth_abs += dabs(reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1))
endif
enddo
e_corr_bi_orth_proj = e_corr_single_bi_orth + e_corr_double_bi_orth
e_corr_bi_orth = eigval_right_tc_bi_orth(1) - e_tilde_bi_orth_00
e_corr_bi_orth_proj_abs = e_corr_single_bi_orth_abs + e_corr_double_bi_orth_abs
END_PROVIDER

BEGIN_PROVIDER [ double precision, e_tc_left_right ]
Expand Down
125 changes: 125 additions & 0 deletions src/tc_bi_ortho/pt2_tc_cisd.irp.f
@@ -0,0 +1,125 @@
program pt2_tc_cisd

BEGIN_DOC
!
! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together
! with the energy. Saves the left-right wave functions at the end.
!
END_DOC

my_grid_becke = .True.
my_n_pt_r_grid = 30
my_n_pt_a_grid = 50
read_wf = .True.
touch read_wf
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid

print*, ' nb of states = ', N_states
print*, ' nb of det = ', N_det
call routine_diag()

call routine
end

subroutine routine
implicit none
integer :: i,h1,p1,h2,p2,s1,s2,degree
double precision :: h0i,hi0,e00,ei,delta_e
double precision :: norm,e_corr,coef,e_corr_pos,e_corr_neg,e_corr_abs

integer :: exc(0:2,2,2)
double precision :: phase
double precision :: eh1,ep1,eh2,ep2

norm = 0.d0
e_corr = 0.d0
e_corr_abs = 0.d0
e_corr_pos = 0.d0
e_corr_neg = 0.d0
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,1), psi_det(1,1,1), N_int, e00)
do i = 2, N_det
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,1), N_int, hi0)
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,1), psi_det(1,1,i), N_int, h0i)
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, ei)
call get_excitation_degree(psi_det(1,1,1), psi_det(1,1,i),degree,N_int)
call get_excitation(psi_det(1,1,1), psi_det(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
eh1 = Fock_matrix_tc_diag_mo_tot(h1)
ep1 = Fock_matrix_tc_diag_mo_tot(p1)
delta_e = eh1 - ep1
if (degree==2)then
eh2 = Fock_matrix_tc_diag_mo_tot(h2)
ep2 = Fock_matrix_tc_diag_mo_tot(p2)
delta_e += eh2 - ep2
endif
! delta_e = e00 - ei
coef = hi0/delta_e
norm += coef*coef
e_corr = coef* h0i
if(e_corr.lt.0.d0)then
e_corr_neg += e_corr
elseif(e_corr.gt.0.d0)then
e_corr_pos += e_corr
endif
e_corr_abs += dabs(e_corr)
enddo
print*,'e_corr_abs = ',e_corr_abs
print*,'e_corr_pos = ',e_corr_pos
print*,'e_corr_neg = ',e_corr_neg
print*,'norm = ',dsqrt(norm)

end

subroutine routine_diag()

implicit none
integer :: i, j, k
double precision :: dE

! provide eigval_right_tc_bi_orth
! provide overlap_bi_ortho
! provide htilde_matrix_elmt_bi_ortho

if(N_states .eq. 1) then

print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1)
print*,'e_tc_left_right = ',e_tc_left_right
print*,'e_tilde_bi_orth_00 = ',e_tilde_bi_orth_00
print*,'e_pt2_tc_bi_orth = ',e_pt2_tc_bi_orth
print*,'e_pt2_tc_bi_orth_single = ',e_pt2_tc_bi_orth_single
print*,'e_pt2_tc_bi_orth_double = ',e_pt2_tc_bi_orth_double
print*,'***'
print*,'e_corr_bi_orth = ',e_corr_bi_orth
print*,'e_corr_bi_orth_proj = ',e_corr_bi_orth_proj
print*,'e_corr_bi_orth_proj_abs = ',e_corr_bi_orth_proj_abs
print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth
print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth
print*,'e_corr_single_bi_orth_abs = ',e_corr_single_bi_orth_abs
print*,'e_corr_double_bi_orth_abs = ',e_corr_double_bi_orth_abs
print*,'Left/right eigenvectors'
do i = 1,N_det
write(*,'(I5,X,(100(F12.7,X)))')i,leigvec_tc_bi_orth(i,1),reigvec_tc_bi_orth(i,1),leigvec_tc_bi_orth(i,1)*reigvec_tc_bi_orth(i,1)
enddo

else

print*,'eigval_right_tc_bi_orth : '
do i = 1, N_states
print*, i, eigval_right_tc_bi_orth(i)
enddo

print*,''
print*,'******************************************************'
print*,'TC Excitation energies (au) (eV)'
do i = 2, N_states
dE = eigval_right_tc_bi_orth(i) - eigval_right_tc_bi_orth(1)
print*, i, dE, dE/0.0367502d0
enddo
print*,''

endif

end



4 changes: 2 additions & 2 deletions src/tc_bi_ortho/slater_tc_opt_diag.irp.f
Expand Up @@ -156,7 +156,7 @@ subroutine ac_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
htwoe = htwoe + mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
enddo

if(three_body_h_tc)then
if(three_body_h_tc.and.elec_num.gt.2)then
!!!!! 3-e part
!! same-spin/same-spin
do j = 1, na
Expand Down Expand Up @@ -243,7 +243,7 @@ subroutine a_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
enddo

if(three_body_h_tc)then
if(three_body_h_tc.and.elec_num.gt.2)then
!!!!! 3-e part
!! same-spin/same-spin
do j = 1, na
Expand Down
14 changes: 7 additions & 7 deletions src/tc_bi_ortho/slater_tc_opt_double.irp.f
Expand Up @@ -41,15 +41,15 @@ subroutine double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe,
if(s1.ne.s2)then
! opposite spin two-body
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
if(three_body_h_tc)then
if(three_body_h_tc.and.elec_num.gt.2)then
if(.not.double_normal_ord)then
if(degree_i>degree_j)then
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
else
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
endif
elseif(double_normal_ord.and.elec_num+elec_num.gt.2)then
htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ???
elseif(double_normal_ord.and.elec_num.gt.2)then
htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)
endif
endif
else
Expand All @@ -58,16 +58,16 @@ subroutine double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe,
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
! exchange terms
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
if(three_body_h_tc)then
if(three_body_h_tc.and.elec_num.gt.2)then
if(.not.double_normal_ord)then
if(degree_i>degree_j)then
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
else
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
endif
elseif(double_normal_ord.and.elec_num+elec_num.gt.2)then
htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ???
htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ???
elseif(double_normal_ord.and.elec_num.gt.2)then
htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)
htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)
endif
endif
endif
Expand Down
2 changes: 1 addition & 1 deletion src/tc_bi_ortho/slater_tc_opt_single.irp.f
Expand Up @@ -106,7 +106,7 @@ subroutine get_single_excitation_from_fock_tc(key_i,key_j,h,p,spin,phase,hmono,h
htwoe -= buffer_x(i)
enddo
hthree = 0.d0
if (three_body_h_tc)then
if (three_body_h_tc.and.elec_num.gt.2)then
call three_comp_fock_elem(key_i,h,p,spin,hthree)
endif

Expand Down
25 changes: 14 additions & 11 deletions src/tc_bi_ortho/tc_bi_ortho.irp.f
Expand Up @@ -48,17 +48,20 @@ subroutine routine_diag()

if(N_states .eq. 1) then

print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1)
print*,'e_tc_left_right = ',e_tc_left_right
print*,'e_tilde_bi_orth_00 = ',e_tilde_bi_orth_00
print*,'e_pt2_tc_bi_orth = ',e_pt2_tc_bi_orth
print*,'e_pt2_tc_bi_orth_single = ',e_pt2_tc_bi_orth_single
print*,'e_pt2_tc_bi_orth_double = ',e_pt2_tc_bi_orth_double
print*,'***'
print*,'e_corr_bi_orth = ',e_corr_bi_orth
print*,'e_corr_bi_orth_proj = ',e_corr_bi_orth_proj
print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth
print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth
print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1)
print*,'e_tc_left_right = ',e_tc_left_right
print*,'e_tilde_bi_orth_00 = ',e_tilde_bi_orth_00
print*,'e_pt2_tc_bi_orth = ',e_pt2_tc_bi_orth
print*,'e_pt2_tc_bi_orth_single = ',e_pt2_tc_bi_orth_single
print*,'e_pt2_tc_bi_orth_double = ',e_pt2_tc_bi_orth_double
print*,'***'
print*,'e_corr_bi_orth = ',e_corr_bi_orth
print*,'e_corr_bi_orth_proj = ',e_corr_bi_orth_proj
print*,'e_corr_bi_orth_proj_abs = ',e_corr_bi_orth_proj_abs
print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth
print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth
print*,'e_corr_single_bi_orth_abs = ',e_corr_single_bi_orth_abs
print*,'e_corr_double_bi_orth_abs = ',e_corr_double_bi_orth_abs
print*,'Left/right eigenvectors'
do i = 1,N_det
write(*,'(I5,X,(100(F12.7,X)))')i,leigvec_tc_bi_orth(i,1),reigvec_tc_bi_orth(i,1),leigvec_tc_bi_orth(i,1)*reigvec_tc_bi_orth(i,1)
Expand Down

0 comments on commit 17566b8

Please sign in to comment.