mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-11-07 14:03:37 +01:00
compiling after some cleaning
This commit is contained in:
eginer
parent
b749796d93
commit
366afb2933
1
plugins/local/old_delta_tc_qmc/NEED
Normal file
1
plugins/local/old_delta_tc_qmc/NEED
Normal file
@ -0,0 +1 @@
|
|||||||
|
|
||||||
4
plugins/local/old_delta_tc_qmc/README.rst
Normal file
4
plugins/local/old_delta_tc_qmc/README.rst
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
================
|
||||||
|
old_delta_tc_qmc
|
||||||
|
================
|
||||||
|
|
||||||
7
plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f
Normal file
7
plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f
Normal file
@ -0,0 +1,7 @@
|
|||||||
|
program old_delta_tc_qmc
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! TODO : Put the documentation of the program here
|
||||||
|
END_DOC
|
||||||
|
print *, 'Hello world'
|
||||||
|
end
|
||||||
198
plugins/local/slater_tc/h_mat_triple.irp.f
Normal file
198
plugins/local/slater_tc/h_mat_triple.irp.f
Normal file
@ -0,0 +1,198 @@
|
|||||||
|
subroutine H_tc_s2_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze)
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
|
||||||
|
!
|
||||||
|
! Assumes that the determinants are in psi_det
|
||||||
|
!
|
||||||
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
double precision, intent(in) :: u_0(sze,N_st)
|
||||||
|
double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
|
||||||
|
call H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze)
|
||||||
|
integer :: i,j,degree,ist
|
||||||
|
double precision :: hmono, htwoe, hthree, htot
|
||||||
|
do i = 1, N_det
|
||||||
|
do j = 1, N_det
|
||||||
|
call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int)
|
||||||
|
if(degree .ne. 3)cycle
|
||||||
|
call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,i), psi_det(1,1,j), hmono, htwoe, hthree, htot)
|
||||||
|
do ist = 1, N_st
|
||||||
|
v_0(i,ist) += htot * u_0(j,ist)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine H_tc_s2_u_0_with_pure_three_omp(v_0, s_0, u_0, N_st, sze)
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
|
||||||
|
!
|
||||||
|
! Assumes that the determinants are in psi_det
|
||||||
|
!
|
||||||
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
double precision, intent(in) :: u_0(sze,N_st)
|
||||||
|
double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
|
||||||
|
call H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze)
|
||||||
|
integer :: i,j,degree,ist
|
||||||
|
double precision :: hmono, htwoe, hthree, htot
|
||||||
|
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
|
||||||
|
!$OMP SHARED(N_st, N_det, N_int, psi_det, u_0, v_0) &
|
||||||
|
!$OMP PRIVATE(ist, i, j, degree, hmono, htwoe, hthree,htot)
|
||||||
|
do i = 1, N_det
|
||||||
|
do j = 1, N_det
|
||||||
|
call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int)
|
||||||
|
if(degree .ne. 3)cycle
|
||||||
|
call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,i), psi_det(1,1,j), hmono, htwoe, hthree, htot)
|
||||||
|
do ist = 1, N_st
|
||||||
|
v_0(i,ist) += htot * u_0(j,ist)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END PARALLEL DO
|
||||||
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
subroutine H_tc_s2_dagger_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze)
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes $v_0 = (H^TC)^dagger | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
|
||||||
|
!
|
||||||
|
! Assumes that the determinants are in psi_det
|
||||||
|
!
|
||||||
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
double precision, intent(in) :: u_0(sze,N_st)
|
||||||
|
double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
|
||||||
|
call H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze)
|
||||||
|
integer :: i,j,degree,ist
|
||||||
|
double precision :: hmono, htwoe, hthree, htot
|
||||||
|
do i = 1, N_det
|
||||||
|
do j = 1, N_det
|
||||||
|
call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int)
|
||||||
|
if(degree .ne. 3)cycle
|
||||||
|
call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,j), psi_det(1,1,i), hmono, htwoe, hthree, htot)
|
||||||
|
do ist = 1, N_st
|
||||||
|
v_0(i,ist) += htot * u_0(j,ist)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine H_tc_s2_dagger_u_0_with_pure_three_omp(v_0, s_0, u_0, N_st, sze)
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes $v_0 = (H^TC)^dagger | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
|
||||||
|
!
|
||||||
|
! Assumes that the determinants are in psi_det
|
||||||
|
!
|
||||||
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
double precision, intent(in) :: u_0(sze,N_st)
|
||||||
|
double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
|
||||||
|
call H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze)
|
||||||
|
integer :: i,j,degree,ist
|
||||||
|
double precision :: hmono, htwoe, hthree, htot
|
||||||
|
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
|
||||||
|
!$OMP SHARED(N_st, N_det, N_int, psi_det, u_0, v_0) &
|
||||||
|
!$OMP PRIVATE(ist, i, j, degree, hmono, htwoe, hthree,htot)
|
||||||
|
do i = 1, N_det
|
||||||
|
do j = 1, N_det
|
||||||
|
call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int)
|
||||||
|
if(degree .ne. 3)cycle
|
||||||
|
call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,j), psi_det(1,1,i), hmono, htwoe, hthree, htot)
|
||||||
|
do ist = 1, N_st
|
||||||
|
v_0(i,ist) += htot * u_0(j,ist)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END PARALLEL DO
|
||||||
|
end
|
||||||
|
|
||||||
|
! ---
|
||||||
|
subroutine triple_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! <key_j | H_tilde | key_i> for triple excitation
|
||||||
|
!!
|
||||||
|
!! WARNING !!
|
||||||
|
!
|
||||||
|
! Genuine triple excitations of the same spin are not yet implemented
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer(bit_kind), intent(in) :: key_j(N_int,2),key_i(N_int,2)
|
||||||
|
integer, intent(in) :: Nint
|
||||||
|
double precision, intent(out) :: hmono, htwoe, hthree, htot
|
||||||
|
integer :: degree
|
||||||
|
integer :: h1, p1, h2, p2, s1, s2, h3, p3, s3
|
||||||
|
integer :: holes_array(100,2),particles_array(100,2),degree_array(2)
|
||||||
|
double precision :: phase,sym_3_e_int_from_6_idx_tensor
|
||||||
|
|
||||||
|
hmono = 0.d0
|
||||||
|
htwoe = 0.d0
|
||||||
|
hthree = 0.d0
|
||||||
|
htot = 0.d0
|
||||||
|
call get_excitation_general(key_j, key_i, Nint,degree_array,holes_array, particles_array,phase)
|
||||||
|
degree = degree_array(1) + degree_array(2)
|
||||||
|
if(degree .ne. 3)return
|
||||||
|
if(degree_array(1)==3.or.degree_array(2)==3)then
|
||||||
|
if(degree_array(1) == 3)then
|
||||||
|
h1 = holes_array(1,1)
|
||||||
|
h2 = holes_array(2,1)
|
||||||
|
h3 = holes_array(3,1)
|
||||||
|
p1 = particles_array(1,1)
|
||||||
|
p2 = particles_array(2,1)
|
||||||
|
p3 = particles_array(3,1)
|
||||||
|
else
|
||||||
|
h1 = holes_array(1,2)
|
||||||
|
h2 = holes_array(2,2)
|
||||||
|
h3 = holes_array(3,2)
|
||||||
|
p1 = particles_array(1,2)
|
||||||
|
p2 = particles_array(2,2)
|
||||||
|
p3 = particles_array(3,2)
|
||||||
|
endif
|
||||||
|
hthree = sym_3_e_int_from_6_idx_tensor(p3, p2, p1, h3, h2, h1)
|
||||||
|
else
|
||||||
|
if(degree_array(1) == 2.and.degree_array(2) == 1)then ! double alpha + single beta
|
||||||
|
h1 = holes_array(1,1)
|
||||||
|
h2 = holes_array(2,1)
|
||||||
|
h3 = holes_array(1,2)
|
||||||
|
p1 = particles_array(1,1)
|
||||||
|
p2 = particles_array(2,1)
|
||||||
|
p3 = particles_array(1,2)
|
||||||
|
else if(degree_array(2) == 2 .and. degree_array(1) == 1)then ! double beta + single alpha
|
||||||
|
h1 = holes_array(1,2)
|
||||||
|
h2 = holes_array(2,2)
|
||||||
|
h3 = holes_array(1,1)
|
||||||
|
p1 = particles_array(1,2)
|
||||||
|
p2 = particles_array(2,2)
|
||||||
|
p3 = particles_array(1,1)
|
||||||
|
else
|
||||||
|
print*,'PB !!'
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
hthree = three_body_ints_bi_ort(p3,p2,p1,h3,h2,h1) - three_body_ints_bi_ort(p3,p2,p1,h3,h1,h2)
|
||||||
|
endif
|
||||||
|
hthree *= phase
|
||||||
|
htot = hthree
|
||||||
|
end
|
||||||
|
|
||||||
@ -1,193 +0,0 @@
|
|||||||
subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase)
|
|
||||||
use bitmasks
|
|
||||||
BEGIN_DOC
|
|
||||||
! returns the array, for each spin, of holes/particles between key_i and key_j
|
|
||||||
!
|
|
||||||
! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j>
|
|
||||||
END_DOC
|
|
||||||
include 'utils/constants.include.F'
|
|
||||||
implicit none
|
|
||||||
integer, intent(in) :: Nint
|
|
||||||
integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
|
|
||||||
integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2)
|
|
||||||
double precision, intent(out) :: phase
|
|
||||||
integer :: ispin,k,i,pos
|
|
||||||
integer(bit_kind) :: key_hole, key_particle
|
|
||||||
integer(bit_kind) :: xorvec(N_int_max,2)
|
|
||||||
holes_array = -1
|
|
||||||
particles_array = -1
|
|
||||||
degree_array = 0
|
|
||||||
do i = 1, N_int
|
|
||||||
xorvec(i,1) = xor( key_i(i,1), key_j(i,1))
|
|
||||||
xorvec(i,2) = xor( key_i(i,2), key_j(i,2))
|
|
||||||
degree_array(1) += popcnt(xorvec(i,1))
|
|
||||||
degree_array(2) += popcnt(xorvec(i,2))
|
|
||||||
enddo
|
|
||||||
degree_array(1) = shiftr(degree_array(1),1)
|
|
||||||
degree_array(2) = shiftr(degree_array(2),1)
|
|
||||||
|
|
||||||
do ispin = 1, 2
|
|
||||||
k = 1
|
|
||||||
!!! GETTING THE HOLES
|
|
||||||
do i = 1, N_int
|
|
||||||
key_hole = iand(xorvec(i,ispin),key_i(i,ispin))
|
|
||||||
do while(key_hole .ne.0_bit_kind)
|
|
||||||
pos = trailz(key_hole)
|
|
||||||
holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
|
|
||||||
key_hole = ibclr(key_hole,pos)
|
|
||||||
k += 1
|
|
||||||
if(k .gt.100)then
|
|
||||||
print*,'WARNING in get_excitation_general'
|
|
||||||
print*,'More than a 100-th excitation for spin ',ispin
|
|
||||||
print*,'stoping ...'
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
do ispin = 1, 2
|
|
||||||
k = 1
|
|
||||||
!!! GETTING THE PARTICLES
|
|
||||||
do i = 1, N_int
|
|
||||||
key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
|
|
||||||
do while(key_particle .ne.0_bit_kind)
|
|
||||||
pos = trailz(key_particle)
|
|
||||||
particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
|
|
||||||
key_particle = ibclr(key_particle,pos)
|
|
||||||
k += 1
|
|
||||||
if(k .gt.100)then
|
|
||||||
print*,'WARNING in get_excitation_general '
|
|
||||||
print*,'More than a 100-th excitation for spin ',ispin
|
|
||||||
print*,'stoping ...'
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
integer :: h,p, i_ok
|
|
||||||
integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
|
|
||||||
integer :: exc(0:2,2,2)
|
|
||||||
double precision :: phase_tmp
|
|
||||||
allocate(det_i(Nint,2),det_ip(N_int,2))
|
|
||||||
det_i = key_i
|
|
||||||
phase = 1.d0
|
|
||||||
do ispin = 1, 2
|
|
||||||
do i = 1, degree_array(ispin)
|
|
||||||
h = holes_array(i,ispin)
|
|
||||||
p = particles_array(i,ispin)
|
|
||||||
det_ip = det_i
|
|
||||||
call do_single_excitation(det_ip,h,p,ispin,i_ok)
|
|
||||||
if(i_ok == -1)then
|
|
||||||
print*,'excitation was not possible '
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
|
|
||||||
phase *= phase_tmp
|
|
||||||
det_i = det_ip
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
subroutine get_holes_general(key_i, key_j,Nint, holes_array)
|
|
||||||
use bitmasks
|
|
||||||
BEGIN_DOC
|
|
||||||
! returns the array, per spin, of holes between key_i and key_j
|
|
||||||
!
|
|
||||||
! with the following convention: a_{hole}|key_i> --> |key_j>
|
|
||||||
END_DOC
|
|
||||||
implicit none
|
|
||||||
integer, intent(in) :: Nint
|
|
||||||
integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
|
|
||||||
integer, intent(out) :: holes_array(100,2)
|
|
||||||
integer(bit_kind) :: key_hole
|
|
||||||
integer :: ispin,k,i,pos
|
|
||||||
holes_array = -1
|
|
||||||
do ispin = 1, 2
|
|
||||||
k = 1
|
|
||||||
do i = 1, N_int
|
|
||||||
key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin))
|
|
||||||
do while(key_hole .ne.0_bit_kind)
|
|
||||||
pos = trailz(key_hole)
|
|
||||||
holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
|
|
||||||
key_hole = ibclr(key_hole,pos)
|
|
||||||
k += 1
|
|
||||||
if(k .gt.100)then
|
|
||||||
print*,'WARNING in get_holes_general'
|
|
||||||
print*,'More than a 100-th excitation for spin ',ispin
|
|
||||||
print*,'stoping ...'
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
end
|
|
||||||
|
|
||||||
subroutine get_particles_general(key_i, key_j,Nint,particles_array)
|
|
||||||
use bitmasks
|
|
||||||
BEGIN_DOC
|
|
||||||
! returns the array, per spin, of particles between key_i and key_j
|
|
||||||
!
|
|
||||||
! with the following convention: a^dagger_{particle}|key_i> --> |key_j>
|
|
||||||
END_DOC
|
|
||||||
implicit none
|
|
||||||
integer, intent(in) :: Nint
|
|
||||||
integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
|
|
||||||
integer, intent(out) :: particles_array(100,2)
|
|
||||||
integer(bit_kind) :: key_particle
|
|
||||||
integer :: ispin,k,i,pos
|
|
||||||
particles_array = -1
|
|
||||||
do ispin = 1, 2
|
|
||||||
k = 1
|
|
||||||
do i = 1, N_int
|
|
||||||
key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
|
|
||||||
do while(key_particle .ne.0_bit_kind)
|
|
||||||
pos = trailz(key_particle)
|
|
||||||
particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
|
|
||||||
key_particle = ibclr(key_particle,pos)
|
|
||||||
k += 1
|
|
||||||
if(k .gt.100)then
|
|
||||||
print*,'WARNING in get_holes_general'
|
|
||||||
print*,'More than a 100-th excitation for spin ',ispin
|
|
||||||
print*,'Those are the two determinants'
|
|
||||||
call debug_det(key_i, N_int)
|
|
||||||
call debug_det(key_j, N_int)
|
|
||||||
print*,'stoping ...'
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
end
|
|
||||||
|
|
||||||
subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase)
|
|
||||||
implicit none
|
|
||||||
integer, intent(in) :: degree(2), Nint
|
|
||||||
integer(bit_kind), intent(in) :: key_i(Nint,2)
|
|
||||||
integer, intent(in) :: holes_array(100,2),particles_array(100,2)
|
|
||||||
double precision, intent(out) :: phase
|
|
||||||
integer :: i,ispin,h,p, i_ok
|
|
||||||
integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
|
|
||||||
integer :: exc(0:2,2,2)
|
|
||||||
double precision :: phase_tmp
|
|
||||||
allocate(det_i(Nint,2),det_ip(N_int,2))
|
|
||||||
det_i = key_i
|
|
||||||
phase = 1.d0
|
|
||||||
do ispin = 1, 2
|
|
||||||
do i = 1, degree(ispin)
|
|
||||||
h = holes_array(i,ispin)
|
|
||||||
p = particles_array(i,ispin)
|
|
||||||
det_ip = det_i
|
|
||||||
call do_single_excitation(det_ip,h,p,ispin,i_ok)
|
|
||||||
if(i_ok == -1)then
|
|
||||||
print*,'excitation was not possible '
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
|
|
||||||
phase *= phase_tmp
|
|
||||||
det_i = det_ip
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
@ -1,129 +0,0 @@
|
|||||||
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
|
|
||||||
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
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_slow(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_slow(psi_det(1,1,i), psi_det(1,1,1), N_int, hi0)
|
|
||||||
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,1), psi_det(1,1,i), N_int, h0i)
|
|
||||||
call htilde_mu_mat_bi_ortho_tot_slow(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
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -1,36 +0,0 @@
|
|||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
program tc_cisd_sc2
|
|
||||||
|
|
||||||
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 test
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
subroutine test()
|
|
||||||
implicit none
|
|
||||||
! double precision, allocatable :: dressing_dets(:),e_corr_dets(:)
|
|
||||||
! allocate(dressing_dets(N_det),e_corr_dets(N_det))
|
|
||||||
! e_corr_dets = 0.d0
|
|
||||||
! call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets)
|
|
||||||
provide eigval_tc_cisd_sc2_bi_ortho
|
|
||||||
end
|
|
||||||
@ -1,145 +0,0 @@
|
|||||||
BEGIN_PROVIDER [ double precision, reigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)]
|
|
||||||
&BEGIN_PROVIDER [ double precision, leigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)]
|
|
||||||
&BEGIN_PROVIDER [ double precision, eigval_tc_cisd_sc2_bi_ortho, (N_states)]
|
|
||||||
implicit none
|
|
||||||
integer :: it,n_real,degree,i,istate
|
|
||||||
double precision :: e_before, e_current,thr, hmono,htwoe,hthree,accu
|
|
||||||
double precision, allocatable :: e_corr_dets(:),h0j(:), h_sc2(:,:), dressing_dets(:)
|
|
||||||
double precision, allocatable :: leigvec_tc_bi_orth_tmp(:,:),reigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:)
|
|
||||||
allocate(leigvec_tc_bi_orth_tmp(N_det,N_det),reigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det))
|
|
||||||
allocate(e_corr_dets(N_det),h0j(N_det),h_sc2(N_det,N_det),dressing_dets(N_det))
|
|
||||||
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),eigval_tmp(N_states))
|
|
||||||
dressing_dets = 0.d0
|
|
||||||
do i = 1, N_det
|
|
||||||
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
|
|
||||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
|
||||||
if(degree == 1 .or. degree == 2)then
|
|
||||||
call htilde_mu_mat_opt_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i))
|
|
||||||
endif
|
|
||||||
enddo
|
|
||||||
reigvec_tc_bi_orth_tmp = 0.d0
|
|
||||||
do i = 1, N_det
|
|
||||||
reigvec_tc_bi_orth_tmp(i,1) = psi_r_coef_bi_ortho(i,1)
|
|
||||||
enddo
|
|
||||||
vec_tmp = 0.d0
|
|
||||||
do istate = 1, N_states
|
|
||||||
vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate)
|
|
||||||
enddo
|
|
||||||
do istate = N_states+1, n_states_diag
|
|
||||||
vec_tmp(istate,istate) = 1.d0
|
|
||||||
enddo
|
|
||||||
print*,'Diagonalizing the TC CISD '
|
|
||||||
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow)
|
|
||||||
do i = 1, N_det
|
|
||||||
e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
|
|
||||||
enddo
|
|
||||||
E_before = eigval_tmp(1)
|
|
||||||
print*,'Starting from ',E_before
|
|
||||||
|
|
||||||
e_current = 10.d0
|
|
||||||
thr = 1.d-5
|
|
||||||
it = 0
|
|
||||||
dressing_dets = 0.d0
|
|
||||||
double precision, allocatable :: H_jj(:),vec_tmp(:,:),eigval_tmp(:)
|
|
||||||
external htc_bi_ortho_calc_tdav_slow
|
|
||||||
external htcdag_bi_ortho_calc_tdav_slow
|
|
||||||
logical :: converged
|
|
||||||
do while (dabs(E_before-E_current).gt.thr)
|
|
||||||
it += 1
|
|
||||||
E_before = E_current
|
|
||||||
! h_sc2 = htilde_matrix_elmt_bi_ortho
|
|
||||||
call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets)
|
|
||||||
do i = 1, N_det
|
|
||||||
! print*,'dressing_dets(i) = ',dressing_dets(i)
|
|
||||||
h_sc2(i,i) += dressing_dets(i)
|
|
||||||
enddo
|
|
||||||
print*,'********************'
|
|
||||||
print*,'iteration ',it
|
|
||||||
! call non_hrmt_real_diag(N_det,h_sc2,&
|
|
||||||
! leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,&
|
|
||||||
! n_real,eigval_right_tmp)
|
|
||||||
! print*,'eigval_right_tmp(1)',eigval_right_tmp(1)
|
|
||||||
vec_tmp = 0.d0
|
|
||||||
do istate = 1, N_states
|
|
||||||
vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate)
|
|
||||||
enddo
|
|
||||||
do istate = N_states+1, n_states_diag
|
|
||||||
vec_tmp(istate,istate) = 1.d0
|
|
||||||
enddo
|
|
||||||
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow)
|
|
||||||
print*,'outside Davidson'
|
|
||||||
print*,'eigval_tmp(1) = ',eigval_tmp(1)
|
|
||||||
do i = 1, N_det
|
|
||||||
reigvec_tc_bi_orth_tmp(i,1) = vec_tmp(i,1)
|
|
||||||
e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
|
|
||||||
enddo
|
|
||||||
! E_current = eigval_right_tmp(1)
|
|
||||||
E_current = eigval_tmp(1)
|
|
||||||
print*,'it, E(SC)^2 = ',it,E_current
|
|
||||||
enddo
|
|
||||||
eigval_tc_cisd_sc2_bi_ortho(1:N_states) = eigval_right_tmp(1:N_states)
|
|
||||||
reigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = reigvec_tc_bi_orth_tmp(1:N_det,1:N_states)
|
|
||||||
leigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = leigvec_tc_bi_orth_tmp(1:N_det,1:N_states)
|
|
||||||
|
|
||||||
END_PROVIDER
|
|
||||||
|
|
||||||
subroutine get_cisd_sc2_dressing(dets,e_corr_dets,ndet,dressing_dets)
|
|
||||||
implicit none
|
|
||||||
use bitmasks
|
|
||||||
integer, intent(in) :: ndet
|
|
||||||
integer(bit_kind), intent(in) :: dets(N_int,2,ndet)
|
|
||||||
double precision, intent(in) :: e_corr_dets(ndet)
|
|
||||||
double precision, intent(out) :: dressing_dets(ndet)
|
|
||||||
integer, allocatable :: degree(:),hole(:,:),part(:,:),spin(:,:)
|
|
||||||
integer(bit_kind), allocatable :: hole_part(:,:,:)
|
|
||||||
integer :: i,j,k, exc(0:2,2,2),h1,p1,h2,p2,s1,s2
|
|
||||||
integer(bit_kind) :: xorvec(2,N_int)
|
|
||||||
|
|
||||||
double precision :: phase
|
|
||||||
dressing_dets = 0.d0
|
|
||||||
allocate(degree(ndet),hole(2,ndet),part(2,ndet), spin(2,ndet),hole_part(N_int,2,ndet))
|
|
||||||
do i = 2, ndet
|
|
||||||
call get_excitation_degree(HF_bitmask,dets(1,1,i),degree(i),N_int)
|
|
||||||
do j = 1, N_int
|
|
||||||
hole_part(j,1,i) = xor( HF_bitmask(j,1), dets(j,1,i))
|
|
||||||
hole_part(j,2,i) = xor( HF_bitmask(j,2), dets(j,2,i))
|
|
||||||
enddo
|
|
||||||
if(degree(i) == 1)then
|
|
||||||
call get_single_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int)
|
|
||||||
else if(degree(i) == 2)then
|
|
||||||
call get_double_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int)
|
|
||||||
endif
|
|
||||||
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
|
||||||
hole(1,i) = h1
|
|
||||||
hole(2,i) = h2
|
|
||||||
part(1,i) = p1
|
|
||||||
part(2,i) = p2
|
|
||||||
spin(1,i) = s1
|
|
||||||
spin(2,i) = s2
|
|
||||||
enddo
|
|
||||||
|
|
||||||
integer :: same
|
|
||||||
if(elec_alpha_num+elec_beta_num<3)return
|
|
||||||
do i = 2, ndet
|
|
||||||
do j = i+1, ndet
|
|
||||||
same = 0
|
|
||||||
if(degree(i) == degree(j) .and. degree(i)==1)cycle
|
|
||||||
do k = 1, N_int
|
|
||||||
xorvec(k,1) = iand(hole_part(k,1,i),hole_part(k,1,j))
|
|
||||||
xorvec(k,2) = iand(hole_part(k,2,i),hole_part(k,2,j))
|
|
||||||
same += popcnt(xorvec(k,1)) + popcnt(xorvec(k,2))
|
|
||||||
enddo
|
|
||||||
! print*,'i,j',i,j
|
|
||||||
! call debug_det(dets(1,1,i),N_int)
|
|
||||||
! call debug_det(hole_part(1,1,i),N_int)
|
|
||||||
! call debug_det(dets(1,1,j),N_int)
|
|
||||||
! call debug_det(hole_part(1,1,j),N_int)
|
|
||||||
! print*,'same = ',same
|
|
||||||
if(same.eq.0)then
|
|
||||||
dressing_dets(i) += e_corr_dets(j)
|
|
||||||
dressing_dets(j) += e_corr_dets(i)
|
|
||||||
endif
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
|
|
||||||
end
|
|
||||||
@ -1,170 +0,0 @@
|
|||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
program test_tc
|
|
||||||
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
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 routine_h_triple_left
|
|
||||||
call routine_h_triple_right
|
|
||||||
! call routine_test_s2_davidson
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
subroutine routine_h_triple_right
|
|
||||||
implicit none
|
|
||||||
logical :: do_right
|
|
||||||
integer :: sze ,i, N_st, j
|
|
||||||
double precision :: sij, accu_e, accu_s, accu_e_0, accu_s_0
|
|
||||||
double precision, allocatable :: v_0_ref(:,:),u_0(:,:),s_0_ref(:,:)
|
|
||||||
double precision, allocatable :: v_0_new(:,:),s_0_new(:,:)
|
|
||||||
sze = N_det
|
|
||||||
N_st = 1
|
|
||||||
allocate(v_0_ref(N_det,1),u_0(N_det,1),s_0_ref(N_det,1),s_0_new(N_det,1),v_0_new(N_det,1))
|
|
||||||
print*,'Checking first the Right '
|
|
||||||
do i = 1, sze
|
|
||||||
u_0(i,1) = psi_r_coef_bi_ortho(i,1)
|
|
||||||
enddo
|
|
||||||
double precision :: wall0,wall1
|
|
||||||
call wall_time(wall0)
|
|
||||||
call H_tc_s2_u_0_with_pure_three_omp(v_0_ref,s_0_ref, u_0,N_st,sze)
|
|
||||||
call wall_time(wall1)
|
|
||||||
print*,'time for omp',wall1 - wall0
|
|
||||||
call wall_time(wall0)
|
|
||||||
call H_tc_s2_u_0_with_pure_three(v_0_new, s_0_new, u_0, N_st, sze)
|
|
||||||
call wall_time(wall1)
|
|
||||||
print*,'time serial ',wall1 - wall0
|
|
||||||
accu_e = 0.d0
|
|
||||||
accu_s = 0.d0
|
|
||||||
do i = 1, sze
|
|
||||||
accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1))
|
|
||||||
accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1))
|
|
||||||
enddo
|
|
||||||
print*,'accu_e = ',accu_e
|
|
||||||
print*,'accu_s = ',accu_s
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
subroutine routine_h_triple_left
|
|
||||||
implicit none
|
|
||||||
logical :: do_right
|
|
||||||
integer :: sze ,i, N_st, j
|
|
||||||
double precision :: sij, accu_e, accu_s, accu_e_0, accu_s_0
|
|
||||||
double precision, allocatable :: v_0_ref(:,:),u_0(:,:),s_0_ref(:,:)
|
|
||||||
double precision, allocatable :: v_0_new(:,:),s_0_new(:,:)
|
|
||||||
sze = N_det
|
|
||||||
N_st = 1
|
|
||||||
allocate(v_0_ref(N_det,1),u_0(N_det,1),s_0_ref(N_det,1),s_0_new(N_det,1),v_0_new(N_det,1))
|
|
||||||
print*,'Checking the Left '
|
|
||||||
do i = 1, sze
|
|
||||||
u_0(i,1) = psi_l_coef_bi_ortho(i,1)
|
|
||||||
enddo
|
|
||||||
double precision :: wall0,wall1
|
|
||||||
call wall_time(wall0)
|
|
||||||
call H_tc_s2_dagger_u_0_with_pure_three_omp(v_0_ref,s_0_ref, u_0,N_st,sze)
|
|
||||||
call wall_time(wall1)
|
|
||||||
print*,'time for omp',wall1 - wall0
|
|
||||||
call wall_time(wall0)
|
|
||||||
call H_tc_s2_dagger_u_0_with_pure_three(v_0_new, s_0_new, u_0, N_st, sze)
|
|
||||||
call wall_time(wall1)
|
|
||||||
print*,'time serial ',wall1 - wall0
|
|
||||||
accu_e = 0.d0
|
|
||||||
accu_s = 0.d0
|
|
||||||
do i = 1, sze
|
|
||||||
accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1))
|
|
||||||
accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1))
|
|
||||||
enddo
|
|
||||||
print*,'accu_e = ',accu_e
|
|
||||||
print*,'accu_s = ',accu_s
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
|
|
||||||
subroutine routine_test_s2_davidson
|
|
||||||
implicit none
|
|
||||||
double precision, allocatable :: H_jj(:),vec_tmp(:,:), energies(:) , s2(:)
|
|
||||||
integer :: i,istate
|
|
||||||
logical :: converged
|
|
||||||
external H_tc_s2_dagger_u_0_opt
|
|
||||||
external H_tc_s2_u_0_opt
|
|
||||||
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),energies(n_states_diag), s2(n_states_diag))
|
|
||||||
do i = 1, N_det
|
|
||||||
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
|
|
||||||
enddo
|
|
||||||
! Preparing the left-eigenvector
|
|
||||||
print*,'Computing the left-eigenvector '
|
|
||||||
vec_tmp = 0.d0
|
|
||||||
do istate = 1, N_states
|
|
||||||
vec_tmp(1:N_det,istate) = psi_l_coef_bi_ortho(1:N_det,istate)
|
|
||||||
enddo
|
|
||||||
do istate = N_states+1, n_states_diag
|
|
||||||
vec_tmp(istate,istate) = 1.d0
|
|
||||||
enddo
|
|
||||||
do istate = 1, N_states
|
|
||||||
leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
|
|
||||||
enddo
|
|
||||||
integer :: n_it_max
|
|
||||||
n_it_max = 1
|
|
||||||
call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2, energies, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_dagger_u_0_opt)
|
|
||||||
double precision, allocatable :: v_0_new(:,:),s_0_new(:,:)
|
|
||||||
integer :: sze,N_st
|
|
||||||
logical :: do_right
|
|
||||||
sze = N_det
|
|
||||||
N_st = 1
|
|
||||||
do_right = .False.
|
|
||||||
allocate(s_0_new(N_det,1),v_0_new(N_det,1))
|
|
||||||
call H_tc_s2_u_0_nstates_openmp(v_0_new,s_0_new,vec_tmp,N_st,sze, do_right)
|
|
||||||
double precision :: accu_e_0, accu_s_0
|
|
||||||
accu_e_0 = 0.d0
|
|
||||||
accu_s_0 = 0.d0
|
|
||||||
do i = 1, sze
|
|
||||||
accu_e_0 += v_0_new(i,1) * vec_tmp(i,1)
|
|
||||||
accu_s_0 += s_0_new(i,1) * vec_tmp(i,1)
|
|
||||||
enddo
|
|
||||||
print*,'energies = ',energies
|
|
||||||
print*,'s2 = ',s2
|
|
||||||
print*,'accu_e_0',accu_e_0
|
|
||||||
print*,'accu_s_0',accu_s_0
|
|
||||||
|
|
||||||
! Preparing the right-eigenvector
|
|
||||||
print*,'Computing the right-eigenvector '
|
|
||||||
vec_tmp = 0.d0
|
|
||||||
do istate = 1, N_states
|
|
||||||
vec_tmp(1:N_det,istate) = psi_r_coef_bi_ortho(1:N_det,istate)
|
|
||||||
enddo
|
|
||||||
do istate = N_states+1, n_states_diag
|
|
||||||
vec_tmp(istate,istate) = 1.d0
|
|
||||||
enddo
|
|
||||||
do istate = 1, N_states
|
|
||||||
leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
|
|
||||||
enddo
|
|
||||||
n_it_max = 1
|
|
||||||
call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2, energies, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_u_0_opt)
|
|
||||||
sze = N_det
|
|
||||||
N_st = 1
|
|
||||||
do_right = .True.
|
|
||||||
v_0_new = 0.d0
|
|
||||||
s_0_new = 0.d0
|
|
||||||
call H_tc_s2_u_0_nstates_openmp(v_0_new,s_0_new,vec_tmp,N_st,sze, do_right)
|
|
||||||
accu_e_0 = 0.d0
|
|
||||||
accu_s_0 = 0.d0
|
|
||||||
do i = 1, sze
|
|
||||||
accu_e_0 += v_0_new(i,1) * vec_tmp(i,1)
|
|
||||||
accu_s_0 += s_0_new(i,1) * vec_tmp(i,1)
|
|
||||||
enddo
|
|
||||||
print*,'energies = ',energies
|
|
||||||
print*,'s2 = ',s2
|
|
||||||
print*,'accu_e_0',accu_e_0
|
|
||||||
print*,'accu_s_0',accu_s_0
|
|
||||||
|
|
||||||
end
|
|
||||||
Loading…
Reference in New Issue
Block a user