mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-12-22 20:34:58 +01:00
added tc_progs
This commit is contained in:
eginer
parent
366afb2933
commit
17ae4d8fe2
@ -892,8 +892,8 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
|||||||
psi_h_alpha = 0.d0
|
psi_h_alpha = 0.d0
|
||||||
alpha_h_psi = 0.d0
|
alpha_h_psi = 0.d0
|
||||||
do iii = 1, N_det_selectors
|
do iii = 1, N_det_selectors
|
||||||
call htilde_mu_mat_bi_ortho_tot_slow(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
|
call htilde_mu_mat_opt_bi_ortho_tot(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
|
||||||
call htilde_mu_mat_bi_ortho_tot_slow(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
|
call htilde_mu_mat_opt_bi_ortho_tot(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
|
||||||
call get_excitation_degree(psi_selectors(1,1,iii), det,degree,N_int)
|
call get_excitation_degree(psi_selectors(1,1,iii), det,degree,N_int)
|
||||||
if(degree == 0)then
|
if(degree == 0)then
|
||||||
print*,'problem !!!'
|
print*,'problem !!!'
|
||||||
|
|||||||
@ -1,64 +0,0 @@
|
|||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
program test_natorb
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
call routine()
|
|
||||||
! call test()
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
subroutine routine()
|
|
||||||
|
|
||||||
implicit none
|
|
||||||
double precision, allocatable :: fock_diag(:),eigval(:),leigvec(:,:),reigvec(:,:),mat_ref(:,:)
|
|
||||||
allocate(eigval(mo_num),leigvec(mo_num,mo_num),reigvec(mo_num,mo_num),fock_diag(mo_num),mat_ref(mo_num, mo_num))
|
|
||||||
double precision, allocatable :: eigval_ref(:),leigvec_ref(:,:),reigvec_ref(:,:)
|
|
||||||
allocate(eigval_ref(mo_num),leigvec_ref(mo_num,mo_num),reigvec_ref(mo_num,mo_num))
|
|
||||||
|
|
||||||
double precision :: thr_deg
|
|
||||||
integer :: i,n_real,j
|
|
||||||
print*,'fock_matrix'
|
|
||||||
do i = 1, mo_num
|
|
||||||
fock_diag(i) = Fock_matrix_mo(i,i)
|
|
||||||
print*,i,fock_diag(i)
|
|
||||||
enddo
|
|
||||||
thr_deg = 1.d-6
|
|
||||||
mat_ref = -one_e_dm_mo
|
|
||||||
print*,'diagonalization by block'
|
|
||||||
call diag_mat_per_fock_degen(fock_diag,mat_ref,mo_num,thr_deg,leigvec,reigvec,eigval)
|
|
||||||
call non_hrmt_bieig( mo_num, mat_ref&
|
|
||||||
, leigvec_ref, reigvec_ref&
|
|
||||||
, n_real, eigval_ref)
|
|
||||||
print*,'TEST ***********************************'
|
|
||||||
double precision :: accu_l, accu_r
|
|
||||||
do i = 1, mo_num
|
|
||||||
accu_l = 0.d0
|
|
||||||
accu_r = 0.d0
|
|
||||||
do j = 1, mo_num
|
|
||||||
accu_r += reigvec_ref(j,i) * reigvec(j,i)
|
|
||||||
accu_l += leigvec_ref(j,i) * leigvec(j,i)
|
|
||||||
enddo
|
|
||||||
print*,i
|
|
||||||
write(*,'(I3,X,100(F16.10,X))')i,eigval(i),eigval_ref(i),accu_l,accu_r
|
|
||||||
enddo
|
|
||||||
end
|
|
||||||
@ -1,173 +0,0 @@
|
|||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
program test_normal_order
|
|
||||||
|
|
||||||
BEGIN_DOC
|
|
||||||
! TODO : Put the documentation of the program here
|
|
||||||
END_DOC
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
call provide_all_three_ints_bi_ortho()
|
|
||||||
call test()
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
subroutine test
|
|
||||||
implicit none
|
|
||||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
|
||||||
integer :: h1,h2,p1,p2,s1,s2,i_ok,degree,Ne(2)
|
|
||||||
integer :: exc(0:2,2,2)
|
|
||||||
integer(bit_kind), allocatable :: det_i(:,:)
|
|
||||||
double precision :: hmono,htwoe,hthree,htilde_ij,accu,phase,normal,hthree_tmp
|
|
||||||
integer, allocatable :: occ(:,:)
|
|
||||||
allocate( occ(N_int*bit_kind_size,2) )
|
|
||||||
call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int)
|
|
||||||
allocate(det_i(N_int,2))
|
|
||||||
s1 = 1
|
|
||||||
s2 = 2
|
|
||||||
accu = 0.d0
|
|
||||||
do h1 = 1, elec_beta_num
|
|
||||||
do p1 = elec_alpha_num+1, mo_num
|
|
||||||
do h2 = 1, elec_beta_num
|
|
||||||
do p2 = elec_beta_num+1, mo_num
|
|
||||||
hthree = 0.d0
|
|
||||||
|
|
||||||
det_i = ref_bitmask
|
|
||||||
s1 = 1
|
|
||||||
s2 = 2
|
|
||||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
|
||||||
if(i_ok.ne.1)cycle
|
|
||||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
|
||||||
if(i_ok.ne.1)cycle
|
|
||||||
call htilde_mu_mat_opt_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij)
|
|
||||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
|
||||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
|
||||||
hthree_tmp *= phase
|
|
||||||
hthree += 0.5d0 * hthree_tmp
|
|
||||||
det_i = ref_bitmask
|
|
||||||
s1 = 2
|
|
||||||
s2 = 1
|
|
||||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
|
||||||
if(i_ok.ne.1)cycle
|
|
||||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
|
||||||
if(i_ok.ne.1)cycle
|
|
||||||
call htilde_mu_mat_opt_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij)
|
|
||||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
|
||||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
|
||||||
hthree_tmp *= phase
|
|
||||||
hthree += 0.5d0 * hthree_tmp
|
|
||||||
|
|
||||||
|
|
||||||
! normal = normal_two_body_bi_orth_ab(p2,h2,p1,h1)
|
|
||||||
call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, normal)
|
|
||||||
if(dabs(hthree).lt.1.d-10)cycle
|
|
||||||
if(dabs(hthree-normal).gt.1.d-10)then
|
|
||||||
! print*,pp2,pp1,hh2,hh1
|
|
||||||
print*,p2,p1,h2,h1
|
|
||||||
print*,hthree,normal,dabs(hthree-normal)
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
! call three_comp_two_e_elem(det_i,h1,h2,p1,p2,s1,s2,normal)
|
|
||||||
! normal = eff_2_e_from_3_e_ab(p2,p1,h2,h1)
|
|
||||||
accu += dabs(hthree-normal)
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
print*,'accu opposite spin = ',accu
|
|
||||||
stop
|
|
||||||
|
|
||||||
! p2=6
|
|
||||||
! p1=5
|
|
||||||
! h2=2
|
|
||||||
! h1=1
|
|
||||||
|
|
||||||
s1 = 1
|
|
||||||
s2 = 1
|
|
||||||
accu = 0.d0
|
|
||||||
do h1 = 1, elec_alpha_num
|
|
||||||
do p1 = elec_alpha_num+1, mo_num
|
|
||||||
do p2 = p1+1, mo_num
|
|
||||||
do h2 = h1+1, elec_alpha_num
|
|
||||||
det_i = ref_bitmask
|
|
||||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
|
||||||
if(i_ok.ne.1)cycle
|
|
||||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
|
||||||
if(i_ok.ne.1)cycle
|
|
||||||
call htilde_mu_mat_opt_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
|
||||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
|
||||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
|
||||||
integer :: hh1, pp1, hh2, pp2, ss1, ss2
|
|
||||||
call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
|
|
||||||
hthree *= phase
|
|
||||||
normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
|
|
||||||
! normal = eff_2_e_from_3_e_aa(p2,p1,h2,h1)
|
|
||||||
if(dabs(hthree).lt.1.d-10)cycle
|
|
||||||
if(dabs(hthree-normal).gt.1.d-10)then
|
|
||||||
print*,pp2,pp1,hh2,hh1
|
|
||||||
print*,p2,p1,h2,h1
|
|
||||||
print*,hthree,normal,dabs(hthree-normal)
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
! print*,hthree,normal,dabs(hthree-normal)
|
|
||||||
accu += dabs(hthree-normal)
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
print*,'accu same spin alpha = ',accu
|
|
||||||
|
|
||||||
|
|
||||||
s1 = 2
|
|
||||||
s2 = 2
|
|
||||||
accu = 0.d0
|
|
||||||
do h1 = 1, elec_beta_num
|
|
||||||
do p1 = elec_beta_num+1, mo_num
|
|
||||||
do p2 = p1+1, mo_num
|
|
||||||
do h2 = h1+1, elec_beta_num
|
|
||||||
det_i = ref_bitmask
|
|
||||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
|
||||||
if(i_ok.ne.1)cycle
|
|
||||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
|
||||||
if(i_ok.ne.1)cycle
|
|
||||||
call htilde_mu_mat_opt_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
|
||||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
|
||||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
|
||||||
call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
|
|
||||||
hthree *= phase
|
|
||||||
! normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
|
|
||||||
normal = eff_2_e_from_3_e_bb(p2,p1,h2,h1)
|
|
||||||
if(dabs(hthree).lt.1.d-10)cycle
|
|
||||||
if(dabs(hthree-normal).gt.1.d-10)then
|
|
||||||
print*,pp2,pp1,hh2,hh1
|
|
||||||
print*,p2,p1,h2,h1
|
|
||||||
print*,hthree,normal,dabs(hthree-normal)
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
! print*,hthree,normal,dabs(hthree-normal)
|
|
||||||
accu += dabs(hthree-normal)
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
print*,'accu same spin beta = ',accu
|
|
||||||
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
|
|
||||||
@ -1,171 +0,0 @@
|
|||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
program test_tc_fock
|
|
||||||
|
|
||||||
BEGIN_DOC
|
|
||||||
! TODO : Put the documentation of the program here
|
|
||||||
END_DOC
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
!call routine_1
|
|
||||||
!call routine_2
|
|
||||||
! call routine_3()
|
|
||||||
|
|
||||||
call routine_tot
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
subroutine routine_3()
|
|
||||||
|
|
||||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
|
||||||
|
|
||||||
implicit none
|
|
||||||
integer :: i, a, i_ok, s1
|
|
||||||
double precision :: hmono, htwoe, hthree, htilde_ij
|
|
||||||
double precision :: err_ai, err_tot, ref, new
|
|
||||||
integer(bit_kind), allocatable :: det_i(:,:)
|
|
||||||
|
|
||||||
allocate(det_i(N_int,2))
|
|
||||||
|
|
||||||
err_tot = 0.d0
|
|
||||||
|
|
||||||
do s1 = 1, 2
|
|
||||||
|
|
||||||
det_i = ref_bitmask
|
|
||||||
call debug_det(det_i, N_int)
|
|
||||||
print*, ' HF det'
|
|
||||||
call debug_det(det_i, N_int)
|
|
||||||
|
|
||||||
do i = 1, elec_num_tab(s1)
|
|
||||||
do a = elec_num_tab(s1)+1, mo_num ! virtual
|
|
||||||
|
|
||||||
det_i = ref_bitmask
|
|
||||||
call do_single_excitation(det_i, i, a, s1, i_ok)
|
|
||||||
if(i_ok == -1) then
|
|
||||||
print*, 'PB !!'
|
|
||||||
print*, i, a
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
print*, ' excited det'
|
|
||||||
call debug_det(det_i, N_int)
|
|
||||||
|
|
||||||
call htilde_mu_mat_opt_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
|
|
||||||
if(dabs(hthree).lt.1.d-10)cycle
|
|
||||||
ref = hthree
|
|
||||||
if(s1 == 1)then
|
|
||||||
new = fock_a_tot_3e_bi_orth(a,i)
|
|
||||||
else if(s1 == 2)then
|
|
||||||
new = fock_b_tot_3e_bi_orth(a,i)
|
|
||||||
endif
|
|
||||||
err_ai = dabs(dabs(ref) - dabs(new))
|
|
||||||
if(err_ai .gt. 1d-7) then
|
|
||||||
print*,'s1 = ',s1
|
|
||||||
print*, ' warning on', i, a
|
|
||||||
print*, ref,new,err_ai
|
|
||||||
endif
|
|
||||||
print*, ref,new,err_ai
|
|
||||||
err_tot += err_ai
|
|
||||||
|
|
||||||
write(22, *) htilde_ij
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
|
|
||||||
print *, ' err_tot = ', err_tot
|
|
||||||
|
|
||||||
deallocate(det_i)
|
|
||||||
|
|
||||||
end subroutine routine_3
|
|
||||||
|
|
||||||
! ---
|
|
||||||
subroutine routine_tot()
|
|
||||||
|
|
||||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
|
||||||
|
|
||||||
implicit none
|
|
||||||
integer :: i, a, i_ok, s1,other_spin(2)
|
|
||||||
double precision :: hmono, htwoe, hthree, htilde_ij
|
|
||||||
double precision :: err_ai, err_tot, ref, new
|
|
||||||
integer(bit_kind), allocatable :: det_i(:,:)
|
|
||||||
|
|
||||||
allocate(det_i(N_int,2))
|
|
||||||
other_spin(1) = 2
|
|
||||||
other_spin(2) = 1
|
|
||||||
|
|
||||||
err_tot = 0.d0
|
|
||||||
|
|
||||||
! do s1 = 1, 2
|
|
||||||
s1 = 2
|
|
||||||
det_i = ref_bitmask
|
|
||||||
call debug_det(det_i, N_int)
|
|
||||||
print*, ' HF det'
|
|
||||||
call debug_det(det_i, N_int)
|
|
||||||
|
|
||||||
! do i = 1, elec_num_tab(s1)
|
|
||||||
! do a = elec_num_tab(s1)+1, mo_num ! virtual
|
|
||||||
do i = 1, elec_beta_num
|
|
||||||
do a = elec_beta_num+1, mo_num! virtual
|
|
||||||
print*,i,a
|
|
||||||
|
|
||||||
det_i = ref_bitmask
|
|
||||||
call do_single_excitation(det_i, i, a, s1, i_ok)
|
|
||||||
if(i_ok == -1) then
|
|
||||||
print*, 'PB !!'
|
|
||||||
print*, i, a
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
|
|
||||||
call htilde_mu_mat_opt_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
|
|
||||||
print*,htilde_ij
|
|
||||||
! if(dabs(htilde_ij).lt.1.d-10)cycle
|
|
||||||
print*, ' excited det'
|
|
||||||
call debug_det(det_i, N_int)
|
|
||||||
|
|
||||||
if(s1 == 1)then
|
|
||||||
new = Fock_matrix_tc_mo_alpha(a,i)
|
|
||||||
else
|
|
||||||
new = Fock_matrix_tc_mo_beta(a,i)
|
|
||||||
endif
|
|
||||||
ref = htilde_ij
|
|
||||||
! if(s1 == 1)then
|
|
||||||
! new = fock_a_tot_3e_bi_orth(a,i)
|
|
||||||
! else if(s1 == 2)then
|
|
||||||
! new = fock_b_tot_3e_bi_orth(a,i)
|
|
||||||
! endif
|
|
||||||
err_ai = dabs(dabs(ref) - dabs(new))
|
|
||||||
if(err_ai .gt. 1d-7) then
|
|
||||||
print*,'---------'
|
|
||||||
print*,'s1 = ',s1
|
|
||||||
print*, ' warning on', i, a
|
|
||||||
print*, ref,new,err_ai
|
|
||||||
print*,hmono, htwoe, hthree
|
|
||||||
print*,'---------'
|
|
||||||
endif
|
|
||||||
print*, ref,new,err_ai
|
|
||||||
err_tot += err_ai
|
|
||||||
|
|
||||||
write(22, *) htilde_ij
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
! enddo
|
|
||||||
|
|
||||||
print *, ' err_tot = ', err_tot
|
|
||||||
|
|
||||||
deallocate(det_i)
|
|
||||||
|
|
||||||
end subroutine routine_3
|
|
||||||
1
plugins/local/tc_progs/NEED
Normal file
1
plugins/local/tc_progs/NEED
Normal file
@ -0,0 +1 @@
|
|||||||
|
tc_bi_ortho
|
||||||
Loading…
Reference in New Issue
Block a user