LCPQ
/
quantum_package
mirror of https://github.com/LCPQ/quantum_package
10
0
Fork 0
Code Issues Releases Wiki Activity

Merge with Dr. Giner

This commit is contained in:
Anthony Scemama 2016-11-02 21:46:12 +01:00
parent 1a6caf66b5 d13853691a
commit a3e2292b8e
108 changed files with 15145 additions and 1017 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
config/ifort.cfg
View File

@ -38,7 +38,7 @@ FCFLAGS : -xSSE4.2 -O2 -ip -ftz -g
#################
#
[PROFILE]
FC : -p -g -traceback
FC : -p -g
FCFLAGS : -xSSE4.2 -O2 -ip -ftz
# Debugging flags
@ -53,7 +53,6 @@ FCFLAGS : -xSSE4.2 -O2 -ip -ftz
[DEBUG]
FC : -g -traceback
FCFLAGS : -xSSE2 -C -fpe0
IRPF90_FLAGS : --openmp
# OpenMP flags
#################

7
plugins/All_singles/H_apply.irp.f
View File

@ -8,6 +8,13 @@ s.unset_skip()
s.filter_only_1h1p()
print s
s = H_apply("just_1h_1p_singles",do_double_exc=False)
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()
s.filter_only_1h1p()
print s
s = H_apply("just_mono",do_double_exc=False)
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()

2
plugins/All_singles/all_1h_1p.irp.f
View File

@ -49,7 +49,7 @@ subroutine routine
endif
call save_wavefunction
if(n_det_before == N_det)then
selection_criterion = selection_criterion * 0.5d0
selection_criterion_factor = selection_criterion_factor * 0.5d0
endif
enddo

76
plugins/All_singles/all_1h_1p_singles.irp.f Normal file
View File

@ -0,0 +1,76 @@
program restart_more_singles
BEGIN_DOC
! Generates and select single and double excitations of type 1h-1p
! on the top of a given restart wave function of type CAS
END_DOC
read_wf = .true.
touch read_wf
print*,'ref_bitmask_energy = ',ref_bitmask_energy
call routine
end
subroutine routine
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:)
integer :: N_st, degree
integer :: n_det_before
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
i = 0
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
pt2=-1.d0
E_before = ref_bitmask_energy
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
n_det_before = N_det
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_just_1h_1p_singles(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
E_before = CI_energy
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
enddo
endif
call save_wavefunction
if(n_det_before == N_det)then
selection_criterion_factor = selection_criterion_factor * 0.5d0
endif
enddo
threshold_davidson = 1.d-10
soft_touch threshold_davidson davidson_criterion
call diagonalize_CI
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1))
enddo
endif
call ezfio_set_all_singles_energy(CI_energy)
call save_wavefunction
deallocate(pt2,norm_pert)
end

4
plugins/DFT_Utils/EZFIO.cfg Normal file
View File

@ -0,0 +1,4 @@
[energy]
type: double precision
doc: Calculated energy
interface: ezfio

1
plugins/DFT_Utils/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Determinants

165
plugins/DFT_Utils/grid_density.irp.f Normal file
View File

@ -0,0 +1,165 @@
BEGIN_PROVIDER [integer, n_points_angular_grid]
implicit none
n_points_angular_grid = 50
END_PROVIDER
BEGIN_PROVIDER [integer, n_points_radial_grid]
implicit none
n_points_radial_grid = 10000
END_PROVIDER
BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_angular_grid,3) ]
&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_angular_grid)]
implicit none
BEGIN_DOC
! weights and grid points for the integration on the angular variables on
! the unit sphere centered on (0,0,0)
! According to the LEBEDEV scheme
END_DOC
call cal_quad(n_points_angular_grid, angular_quadrature_points,weights_angular_points)
include 'constants.include.F'
integer :: i
double precision :: accu
double precision :: degre_rad
!degre_rad = 180.d0/pi
!accu = 0.d0
!do i = 1, n_points_integration_angular_lebedev
! accu += weights_angular_integration_lebedev(i)
! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 2.d0 * pi
! angular_quadrature_points(i,1) = dcos ( degre_rad * theta_angular_integration_lebedev(i)) &
! * dsin ( degre_rad * phi_angular_integration_lebedev(i))
! angular_quadrature_points(i,2) = dsin ( degre_rad * theta_angular_integration_lebedev(i)) &
! * dsin ( degre_rad * phi_angular_integration_lebedev(i))
! angular_quadrature_points(i,3) = dcos ( degre_rad * phi_angular_integration_lebedev(i))
!enddo
!print*,'ANGULAR'
!print*,''
!print*,'accu = ',accu
!ASSERT( dabs(accu - 1.D0) < 1.d-10)
END_PROVIDER
BEGIN_PROVIDER [integer , m_knowles]
implicit none
BEGIN_DOC
! value of the "m" parameter in the equation (7) of the paper of Knowles (JCP, 104, 1996)
END_DOC
m_knowles = 3
END_PROVIDER
BEGIN_PROVIDER [double precision, grid_points_radial, (n_points_radial_grid)]
&BEGIN_PROVIDER [double precision, dr_radial_integral]
implicit none
BEGIN_DOC
! points in [0,1] to map the radial integral [0,\infty]
END_DOC
dr_radial_integral = 1.d0/dble(n_points_radial_grid-1)
integer :: i
do i = 1, n_points_radial_grid-1
grid_points_radial(i) = (i-1) * dr_radial_integral
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid,n_points_radial_grid,nucl_num)]
BEGIN_DOC
! points for integration over space
END_DOC
implicit none
integer :: i,j,k
double precision :: dr,x_ref,y_ref,z_ref
double precision :: knowles_function
do i = 1, nucl_num
x_ref = nucl_coord(i,1)
y_ref = nucl_coord(i,2)
z_ref = nucl_coord(i,3)
do j = 1, n_points_radial_grid-1
double precision :: x,r
x = grid_points_radial(j) ! x value for the mapping of the [0, +\infty] to [0,1]
r = knowles_function(alpha_knowles(int(nucl_charge(i))),m_knowles,x) ! value of the radial coordinate for the integration
do k = 1, n_points_angular_grid ! explicit values of the grid points centered around each atom
grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r
grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r
grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
BEGIN_DOC
! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988)
! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension
! and the points are labelled by the other dimensions
END_DOC
implicit none
integer :: i,j,k,l,m
double precision :: r(3)
double precision :: accu,cell_function_becke
double precision :: tmp_array(nucl_num)
! run over all points in space
do j = 1, nucl_num ! that are referred to each atom
do k = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom
do l = 1, n_points_angular_grid ! for each angular point attached to the "jth" atom
r(1) = grid_points_per_atom(1,l,k,j)
r(2) = grid_points_per_atom(2,l,k,j)
r(3) = grid_points_per_atom(3,l,k,j)
accu = 0.d0
do i = 1, nucl_num ! For each of these points in space, ou need to evaluate the P_n(r)
! function defined for each atom "i" by equation (13) and (21) with k == 3
tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
! Then you compute the summ the P_n(r) function for each of the "r" points
accu += tmp_array(i)
enddo
accu = 1.d0/accu
weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu
! print*,weight_functions_at_grid_points(l,k,j)
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
implicit none
integer :: i,j,k,l,m
double precision :: contrib
double precision :: r(3)
double precision :: aos_array(ao_num),mos_array(mo_tot_num)
do j = 1, nucl_num
do k = 1, n_points_radial_grid -1
do l = 1, n_points_angular_grid
one_body_dm_mo_alpha_at_grid_points(l,k,j) = 0.d0
one_body_dm_mo_beta_at_grid_points(l,k,j) = 0.d0
r(1) = grid_points_per_atom(1,l,k,j)
r(2) = grid_points_per_atom(2,l,k,j)
r(3) = grid_points_per_atom(3,l,k,j)
! call give_all_aos_at_r(r,aos_array)
! do i = 1, ao_num
! do m = 1, ao_num
! contrib = aos_array(i) * aos_array(m)
! one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_ao_alpha(i,m) * contrib
! one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_ao_beta(i,m) * contrib
! enddo
! enddo
call give_all_mos_at_r(r,mos_array)
do i = 1, mo_tot_num
do m = 1, mo_tot_num
contrib = mos_array(i) * mos_array(m)
one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_mo_alpha(i,m) * contrib
one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_mo_beta(i,m) * contrib
enddo
enddo
enddo
enddo
enddo
END_PROVIDER

54
plugins/DFT_Utils/integration_3d.irp.f Normal file
View File

@ -0,0 +1,54 @@
double precision function step_function_becke(x)
implicit none
double precision, intent(in) :: x
double precision :: f_function_becke
integer :: i,n_max_becke
!if(x.lt.-1.d0)then
! step_function_becke = 0.d0
!else if (x .gt.1)then
! step_function_becke = 0.d0
!else
step_function_becke = f_function_becke(x)
!!n_max_becke = 1
do i = 1, 4
step_function_becke = f_function_becke(step_function_becke)
enddo
step_function_becke = 0.5d0*(1.d0 - step_function_becke)
!endif
end
double precision function f_function_becke(x)
implicit none
double precision, intent(in) :: x
f_function_becke = 1.5d0 * x - 0.5d0 * x*x*x
end
double precision function cell_function_becke(r,atom_number)
implicit none
double precision, intent(in) :: r(3)
integer, intent(in) :: atom_number
BEGIN_DOC
! atom_number :: atom on which the cell function of Becke (1988, JCP,88(4))
! r(1:3) :: x,y,z coordinantes of the current point
END_DOC
double precision :: mu_ij,nu_ij
double precision :: distance_i,distance_j,step_function_becke
integer :: j
distance_i = (r(1) - nucl_coord_transp(1,atom_number) ) * (r(1) - nucl_coord_transp(1,atom_number))
distance_i += (r(2) - nucl_coord_transp(2,atom_number) ) * (r(2) - nucl_coord_transp(2,atom_number))
distance_i += (r(3) - nucl_coord_transp(3,atom_number) ) * (r(3) - nucl_coord_transp(3,atom_number))
distance_i = dsqrt(distance_i)
cell_function_becke = 1.d0
do j = 1, nucl_num
if(j==atom_number)cycle
distance_j = (r(1) - nucl_coord_transp(1,j) ) * (r(1) - nucl_coord_transp(1,j))
distance_j+= (r(2) - nucl_coord_transp(2,j) ) * (r(2) - nucl_coord_transp(2,j))
distance_j+= (r(3) - nucl_coord_transp(3,j) ) * (r(3) - nucl_coord_transp(3,j))
distance_j = dsqrt(distance_j)
mu_ij = (distance_i - distance_j)/nucl_dist(atom_number,j)
nu_ij = mu_ij + slater_bragg_type_inter_distance_ua(atom_number,j) * (1.d0 - mu_ij*mu_ij)
cell_function_becke *= step_function_becke(nu_ij)
enddo
end

109
plugins/DFT_Utils/integration_radial.irp.f Normal file
View File

@ -0,0 +1,109 @@
BEGIN_PROVIDER [ double precision, integral_density_alpha_knowles_becke_per_atom, (nucl_num)]
&BEGIN_PROVIDER [ double precision, integral_density_beta_knowles_becke_per_atom, (nucl_num)]
implicit none
double precision :: accu
integer :: i,j,k,l
double precision :: x
double precision :: integrand(n_points_angular_grid), weights(n_points_angular_grid)
double precision :: f_average_angular_alpha,f_average_angular_beta
double precision :: derivative_knowles_function,knowles_function
! Run over all nuclei in order to perform the Voronoi partition
! according ot equation (6) of the paper of Becke (JCP, (88), 1988)
! Here the m index is referred to the w_m(r) weight functions of equation (22)
! Run over all points of integrations : there are
! n_points_radial_grid (i) * n_points_angular_grid (k)
do j = 1, nucl_num
integral_density_alpha_knowles_becke_per_atom(j) = 0.d0
integral_density_beta_knowles_becke_per_atom(j) = 0.d0
do i = 1, n_points_radial_grid-1
! Angular integration over the solid angle Omega for a FIXED angular coordinate "r"
f_average_angular_alpha = 0.d0
f_average_angular_beta = 0.d0
do k = 1, n_points_angular_grid
f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j)
f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j)
enddo
!
x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
double precision :: contrib_integration
! print*,m_knowles
contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) &
*knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2
integral_density_alpha_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_alpha
integral_density_beta_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_beta
enddo
integral_density_alpha_knowles_becke_per_atom(j) *= dr_radial_integral
integral_density_beta_knowles_becke_per_atom(j) *= dr_radial_integral
enddo
END_PROVIDER
double precision function knowles_function(alpha,m,x)
implicit none
BEGIN_DOC
! function proposed by Knowles (JCP, 104, 1996) for distributing the radial points :
! the Log "m" function ( equation (7) in the paper )
END_DOC
double precision, intent(in) :: alpha,x
integer, intent(in) :: m
knowles_function = -alpha * dlog(1.d0-x**m)
end
double precision function derivative_knowles_function(alpha,m,x)
implicit none
BEGIN_DOC
! derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points
END_DOC
double precision, intent(in) :: alpha,x
integer, intent(in) :: m
derivative_knowles_function = alpha * dble(m) * x**(m-1) / (1.d0 - x**m)
end
BEGIN_PROVIDER [double precision, alpha_knowles, (100)]
implicit none
integer :: i
BEGIN_DOC
! recommended values for the alpha parameters according to the paper of Knowles (JCP, 104, 1996)
! as a function of the nuclear charge
END_DOC
! H-He
alpha_knowles(1) = 5.d0
alpha_knowles(2) = 5.d0
! Li-Be
alpha_knowles(3) = 7.d0
alpha_knowles(4) = 7.d0
! B-Ne
do i = 5, 10
alpha_knowles(i) = 5.d0
enddo
! Na-Mg
do i = 11, 12
alpha_knowles(i) = 7.d0
enddo
! Al-Ar
do i = 13, 18
alpha_knowles(i) = 5.d0
enddo
! K-Ca
do i = 19, 20
alpha_knowles(i) = 7.d0
enddo
! Sc-Zn
do i = 21, 30
alpha_knowles(i) = 5.d0
enddo
! Ga-Kr
do i = 31, 36
alpha_knowles(i) = 7.d0
enddo
END_PROVIDER

219
plugins/DFT_Utils/routines_roland.irp.f Normal file
View File

@ -0,0 +1,219 @@
subroutine cal_quad(n_quad, quad, weight)
! --------------------------------------------------------------------------------
!
! Arguments : subroutine cal_quad
! Description: evaluates quadrature points an weights
!
! Authors : B. Lévy, P. Pernot
! Date : 15 Nov 2000
! --------------------------------------------------------------------------------
implicit none
integer, intent(in) :: n_quad
double precision, intent(out) :: weight(n_quad)
double precision, intent(out) :: quad(n_quad,3)
! local:
double precision, parameter :: zero=0.d0, one= 1.d0
double precision, parameter :: p=0.707106781186547462d0
double precision, parameter :: q=0.577350269189625842d0
double precision, parameter :: r=0.301511344577763629d0
double precision, parameter :: s=0.904534033733290888d0
double precision, parameter :: fourpi= 12.5663706143591725d0
double precision, parameter :: a6=0.166666666666666657d0
double precision, parameter :: a18=0.333333333333333329d-01
double precision, parameter :: b18=0.666666666666666657d-01
double precision, parameter :: a26=0.476190476190476164d-01
double precision, parameter :: b26=0.380952380952380987d-01
double precision, parameter :: c26=0.321428571428571397d-01
double precision, parameter :: a50=0.126984126984126984d-01
double precision, parameter :: b50=0.225749559082892431d-01
double precision, parameter :: c50=0.210937500000000014d-01
double precision, parameter :: d50=0.201733355379188697d-01
double precision :: apt(3,6),bpt(3,12),cpt(3,8),dpt(3,24)
double precision :: awght,bwght,cwght,dwght
double precision :: s1, s2, s3
integer :: idim, ipt, i1, i2, i3, is1, is2, is3
integer :: iquad
! begin:
! l_here ='cal_quad'
! call enter (l_here,3)
! verifications:
! message = 'in '//trim(l_here)//', number of dimensions='//&
! trim(encode(dimensions_nb))//', must be 3'
! call ensure(message, dimensions_nb .eq. 3 )
! message = 'in '//trim(l_here)//', invalid number of quadrature points ='&
! //trim(encode(n_quad))
! call ensure(message,(n_quad-2)*(n_quad-6)*(n_quad-18)*(n_quad-26)*(n_quad-50) .eq. 0)
! initialize weights
awght = zero
bwght = zero
cwght = zero
dwght = zero
! type A points : (+/-1,0,0)
awght=a6*fourpi
ipt= 1
apt=0.
do idim = 1, 3
apt(idim,ipt)=one
ipt=ipt+1
apt(idim,ipt)=-one
ipt=ipt+1
enddo
! type B points : (+/-p,+/-p,0) with p= 1/sqrt(2)
if(n_quad.gt.6) then
awght=a18*fourpi
bwght=b18*fourpi
s1=p
s2=p
ipt= 1
bpt=0.
do idim = 1, 3
i1=idim+1
if(i1.gt.3) i1=i1-3
i2=idim+2
if(i2.gt.3) i2=i2-3
do is1= 1,2
do is2= 1,2
bpt(i1,ipt)=s1
bpt(i2,ipt)=s2
s2=-s2
ipt=ipt+1
enddo
s1=-s1
enddo
enddo
endif
! type C points : (+/-q,+/-q,+/-q) with q= 1/sqrt(3)
if(n_quad.gt.18) then
awght=a26*fourpi
bwght=b26*fourpi
cwght=c26*fourpi
s1=q
s2=q
s3=q
ipt= 1
cpt=0.
do is1= 1,2
do is2= 1,2
do is3= 1,2
cpt(1,ipt)=s1
cpt(2,ipt)=s2
cpt(3,ipt)=s3
s3=-s3
ipt=ipt+1
enddo
s2=-s2
enddo
s1=-s1
enddo
endif
! type D points : (+/-r,+/-r,+/-s)
if(n_quad.gt.26) then
awght=a50*fourpi
bwght=b50*fourpi
cwght=c50*fourpi
dwght=d50*fourpi
ipt= 1
dpt=0.
do i1= 1, 3
s1=s
s2=r
s3=r
i2=i1+1
if(i2.gt.3) i2=i2-3
i3=i1+2
if(i3.gt.3) i3=i3-3
do is1= 1,2
do is2= 1,2
do is3= 1,2
dpt(i1,ipt)=s1
dpt(i2,ipt)=s2
dpt(i3,ipt)=s3
s3=-s3
ipt=ipt+1
enddo
s2=-s2
enddo
s1=-s1
enddo
enddo
endif
! fill the points and weights tables
iquad= 1
do ipt= 1, 6
do idim = 1, 3
quad(iquad,idim)=apt(idim,ipt)
enddo
weight(iquad)=awght
iquad=iquad+1
enddo
if(n_quad.gt.6) then
do ipt= 1,12
do idim = 1, 3
quad(iquad,idim)=bpt(idim,ipt)
enddo
weight(iquad)=bwght
iquad=iquad+1
enddo
endif
if(n_quad.gt.18) then
do ipt= 1,8
do idim = 1, 3
quad(iquad,idim)=cpt(idim,ipt)
enddo
weight(iquad)=cwght
iquad=iquad+1
enddo
endif
if(n_quad.gt.26) then
do ipt= 1,24
do idim = 1, 3
quad(iquad,idim)=dpt(idim,ipt)
enddo
weight(iquad)=dwght
iquad=iquad+1
enddo
endif
! if (debug) then
! write(6,*)
! write(6,'(1X,a)') trim(l_here)//'-d : '//&
! '------------------------------------------------------'
! write(6,'(1X,a)') trim(l_here)//'-d : '//' I Weight Quad_points'
! write(6,'(1X,a)') trim(l_here)//'-d : '//&
! '----- ---------- -----------------------------------'
! do iquad= 1, n_quad
! write(6,'(1X,A,i5,4e12.3)') trim(l_here)//'-d : ',&
! iquad,weight(iquad),quad(iquad,1:3)
! enddo
! write(6,'(1X,a)') trim(l_here)//'-d : '//&
! '------------------------------------------------------'
! write(6,*)
! endif
! call exit (l_here,3)
end subroutine cal_quad

24
plugins/DFT_Utils/test_integration_3d_density.irp.f Normal file
View File

@ -0,0 +1,24 @@
program pouet
print*,'coucou'
read_wf = .True.
touch read_wf
print*,'m_knowles = ',m_knowles
call routine
end
subroutine routine
implicit none
integer :: i
double precision :: accu(2)
accu = 0.d0
do i = 1, nucl_num
accu(1) += integral_density_alpha_knowles_becke_per_atom(i)
accu(2) += integral_density_beta_knowles_becke_per_atom(i)
enddo
print*,'accu(1) = ',accu(1)
print*,'Nalpha = ',elec_alpha_num
print*,'accu(2) = ',accu(2)
print*,'Nalpha = ',elec_beta_num
end

13
plugins/FOBOCI/EZFIO.cfg
View File

@ -19,10 +19,15 @@ default: 0.00001
[do_it_perturbative]
type: logical
doc: if true, you do the FOBOCI calculation perturbatively
doc: if true, when a given 1h or 1p determinant is not selected because of its perturbation estimate, then if its coefficient is lower than threshold_perturbative, it is acounted in the FOBOCI differential density matrices
interface: ezfio,provider,ocaml
default: .False.
[threshold_perturbative]
type: double precision
doc: when do_it_perturbative is True, threshold_perturbative select if a given determinant ia selected or not for beign taken into account in the FOBO-SCF treatment. In practive, if the coefficient is larger then threshold_perturbative it means that it not selected as the perturbation should not be too importan. A value of 0.01 is in general OK.
interface: ezfio,provider,ocaml
default: 0.001
[speed_up_convergence_foboscf]
type: logical
@ -49,3 +54,9 @@ doc: if true, you do all 2p type excitation on the LMCT
interface: ezfio,provider,ocaml
default: .True.
[selected_fobo_ci]
type: logical
doc: if true, for each CI step you will run a CIPSI calculation that stops at pt2_max
interface: ezfio,provider,ocaml
default: .False.

889
plugins/FOBOCI/SC2_1h1p.irp.f Normal file
View File

@ -0,0 +1,889 @@
subroutine dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
use bitmasks
implicit none
BEGIN_DOC
! CISD+SC2 method :: take off all the disconnected terms of a ROHF+1h1p (selected or not)
!
! dets_in : bitmasks corresponding to determinants
!
! u_in : guess coefficients on the various states. Overwritten
! on exit
!
! dim_in : leftmost dimension of u_in
!
! sze : Number of determinants
!
! N_st : Number of eigenstates
!
! Initial guess vectors are not necessarily orthonormal
END_DOC
integer, intent(in) :: dim_in, sze, N_st, Nint
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(inout) :: u_in(dim_in,N_st)
double precision, intent(out) :: diag_H_elements(dim_in)
double precision, intent(in) :: convergence
integer :: i,j,k,l
integer :: n_singles
integer :: index_singles(sze),hole_particles_singles(sze,3)
integer :: n_doubles
integer :: index_doubles(sze),hole_particles_doubles(sze,2)
integer :: index_hf
double precision :: e_corr_singles(mo_tot_num,2)
double precision :: e_corr_doubles(mo_tot_num)
double precision :: e_corr_singles_total(2)
double precision :: e_corr_doubles_1h1p
integer :: exc(0:2,2,2),degree
integer :: h1,h2,p1,p2,s1,s2
integer :: other_spin(2)
double precision :: phase
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i_ok
double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral
double precision :: hij,c_ref,contrib
integer :: iorb
other_spin(1) = 2
other_spin(2) = 1
n_singles = 0
n_doubles = 0
do i = 1,sze
call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
call i_H_j(dets_in(1,1,i),dets_in(1,1,i),N_int,hij)
diag_H_elements(i) = hij
if(degree == 0)then
index_hf = i
else if (degree == 1)then
n_singles +=1
index_singles(n_singles) = i
! h1 = inactive orbital of the hole
hole_particles_singles(n_singles,1) = h1
! p1 = virtual orbital of the particle
hole_particles_singles(n_singles,2) = p1
! s1 = spin of the electron excited
hole_particles_singles(n_singles,3) = s1
else if (degree == 2)then
n_doubles +=1
index_doubles(n_doubles) = i
! h1 = inactive orbital of the hole (beta of course)
hole_particles_doubles(n_doubles,1) = h1
! p1 = virtual orbital of the particle (alpha of course)
hole_particles_doubles(n_doubles,2) = p2
else
print*,'PB !! found out other thing than a single or double'
print*,'stopping ..'
stop
endif
enddo
e_corr_singles = 0.d0
e_corr_doubles = 0.d0
e_corr_singles_total = 0.d0
e_corr_doubles_1h1p = 0.d0
c_ref = 1.d0/u_in(index_hf,1)
print*,'c_ref = ',c_ref
do i = 1,sze
call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
call i_H_j(ref_bitmask,dets_in(1,1,i),N_int,hij)
contrib = hij * u_in(i,1) * c_ref
if (degree == 1)then
e_corr_singles(h1,s1) += contrib
e_corr_singles(p1,s1) += contrib
e_corr_singles_total(s1)+= contrib
else if (degree == 2)then
e_corr_doubles_1h1p += contrib
e_corr_doubles(h1) += contrib
e_corr_doubles(p2) += contrib
endif
enddo
print*,'e_corr_singles alpha = ',e_corr_singles_total(1)
print*,'e_corr_singles beta = ',e_corr_singles_total(2)
print*,'e_corr_doubles_1h1p = ',e_corr_doubles_1h1p
! repeat all the correlation energy on the singles
do i = 1,n_singles
! you can repeat all the correlation energy of the single excitation of the other spin
diag_H_elements(index_singles(i)) += e_corr_singles_total(other_spin(hole_particles_singles(i,3)))
! you can repeat all the correlation energy of the single excitation of the same spin
do j = 1, n_inact_orb
iorb = list_inact(j)
! except the one of the hole
if(iorb == hole_particles_singles(i,1))cycle
! ispin = hole_particles_singles(i,3)
diag_H_elements(index_singles(i)) += e_corr_singles(iorb,hole_particles_singles(i,3))
enddo
! also exclude all the energy coming from the virtual orbital
diag_H_elements(index_singles(i)) -= e_corr_singles(hole_particles_singles(i,2),hole_particles_singles(i,3))
! If it is a single excitation alpha, you can repeat :
! +) all the double excitation 1h1p, appart the part involving the virtual orbital "r"
! If it is a single excitation alpha, you can repeat :
! +) all the double excitation 1h1p, appart the part involving the inactive orbital "i"
diag_H_elements(index_singles(i)) += e_corr_doubles_1h1p
if(hole_particles_singles(i,3) == 1)then ! alpha single excitation
diag_H_elements(index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,2))
else ! beta single exctitation
diag_H_elements(index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,1))
endif
enddo
! repeat all the correlation energy on the doubles
! as all the doubles involve the active space, you cannot repeat any of them one on another
do i = 1, n_doubles
! on a given double, you can repeat all the correlation energy of the singles alpha
do j = 1, n_inact_orb
iorb = list_inact(j)
! ispin = hole_particles_singles(i,3)
diag_H_elements(index_doubles(i)) += e_corr_singles(iorb,1)
enddo
! except the part involving the virtual orbital "hole_particles_doubles(i,2)"
diag_H_elements(index_doubles(i)) -= e_corr_singles(hole_particles_doubles(i,2),1)
! on a given double, you can repeat all the correlation energy of the singles beta
do j = 1, n_inact_orb
iorb = list_inact(j)
! except the one of the hole
if(iorb == hole_particles_doubles(i,1))cycle
! ispin = hole_particles_singles(i,3)
diag_H_elements(index_doubles(i)) += e_corr_singles(iorb,2)
enddo
enddo
! Taking into account the connected part of the 2h2p on the HF determinant
! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma}
! diag_H_elements(index_hf) += total_corr_e_2h2p
return
c_ref = c_ref * c_ref
print*,'diag_H_elements(index_hf) = ',diag_H_elements(index_hf)
do i = 1, n_singles
! start on the single excitation "|i>"
h1 = hole_particles_singles(i,1)
p1 = hole_particles_singles(i,2)
do j = 1, n_singles
do k = 1, N_int
key_tmp(k,1) = dets_in(k,1,index_singles(i))
key_tmp(k,2) = dets_in(k,2,index_singles(i))
enddo
h2 = hole_particles_singles(j,1)
p2 = hole_particles_singles(j,2)
call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok)
! apply the excitation operator from the single excitation "|j>"
if(i_ok .ne. 1)cycle
double precision :: phase_ref_other_single,diag_H_mat_elem,hijj,contrib_e2,coef_1
call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_single_double,N_int)
call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_ref_other_single,N_int)
call i_H_j(ref_bitmask,key_tmp,N_int,hij)
diag_H_elements(index_hf) += u_in(index_singles(i),1) * u_in(index_singles(j),1) * c_ref * hij &
* phase_single_double * phase_ref_other_single
enddo
enddo
print*,'diag_H_elements(index_hf) = ',diag_H_elements(index_hf)
end
subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
use bitmasks
implicit none
BEGIN_DOC
! CISD+SC2 method :: take off all the disconnected terms of a ROHF+1h1p (selected or not)
!
! dets_in : bitmasks corresponding to determinants
!
! u_in : guess coefficients on the various states. Overwritten
! on exit
!
! dim_in : leftmost dimension of u_in
!
! sze : Number of determinants
!
! N_st : Number of eigenstates
!
! Initial guess vectors are not necessarily orthonormal
END_DOC
integer, intent(in) :: dim_in, sze, N_st, Nint
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(inout) :: u_in(dim_in,N_st)
double precision, intent(out) :: diag_H_elements(dim_in)
double precision, intent(in) :: convergence
integer :: i,j,k,l
integer :: r,s,i0,j0,r0,s0
integer :: n_singles
integer :: index_singles(sze),hole_particles_singles(sze,3)
integer :: n_doubles
integer :: index_doubles(sze),hole_particles_doubles(sze,2)
integer :: index_hf
double precision :: e_corr_singles(mo_tot_num,2)
double precision :: e_corr_doubles(mo_tot_num)
double precision :: e_corr_singles_total(2)
double precision :: e_corr_doubles_1h1p
integer :: exc(0:2,2,2),degree
integer :: h1,h2,p1,p2,s1,s2
integer :: other_spin(2)
double precision :: phase
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i_ok
double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral
double precision :: hij,c_ref,contrib
integer :: iorb
other_spin(1) = 2
other_spin(2) = 1
n_singles = 0
n_doubles = 0
do i = 1,sze
call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
call i_H_j(dets_in(1,1,i),dets_in(1,1,i),N_int,hij)
diag_H_elements(i) = hij
if(degree == 0)then
index_hf = i
else if (degree == 1)then
n_singles +=1
index_singles(n_singles) = i
! h1 = inactive orbital of the hole
hole_particles_singles(n_singles,1) = h1
! p1 = virtual orbital of the particle
hole_particles_singles(n_singles,2) = p1
! s1 = spin of the electron excited
hole_particles_singles(n_singles,3) = s1
else if (degree == 2)then
n_doubles +=1
index_doubles(n_doubles) = i
! h1 = inactive orbital of the hole (beta of course)
hole_particles_doubles(n_doubles,1) = h1
! p1 = virtual orbital of the particle (alpha of course)
hole_particles_doubles(n_doubles,2) = p2
else
print*,'PB !! found out other thing than a single or double'
print*,'stopping ..'
stop
endif
enddo
double precision :: delta_e
double precision :: coef_ijrs
diag_H_elements = 0.d0
do i0 = 1, n_core_inact_orb
i= list_core_inact(i0)
do j0 = i0+1, n_core_inact_orb
j = list_core_inact(j0)
print*, i,j
do r0 = 1, n_virt_orb
r = list_virt(r0)
do s0 = r0+1, n_virt_orb
s = list_virt(s0)
!!! alpha (i-->r) / beta (j-->s)
s1 = 1
s2 = 2
key_tmp = ref_bitmask
call do_mono_excitation(key_tmp,i,r,s1,i_ok)
if(i_ok .ne.1)then
print*, 'pb !!'
stop
endif
call do_mono_excitation(key_tmp,j,s,s2,i_ok)
if(i_ok .ne.1)then
print*, 'pb !!'
stop
endif
call i_H_j(ref_bitmask, key_tmp, N_int,hij)
delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s)
coef_ijrs = hij/delta_e
do k = 1, n_singles
l = index_singles(k)
call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij)
diag_H_elements(l) += coef_ijrs * hij
enddo
!if(i>j.and.r>s)then
!! alpha (i-->r) / alpha (j-->s)
s1 = 1
s2 = 1
key_tmp = ref_bitmask
call do_mono_excitation(key_tmp,i,r,s1,i_ok)
if(i_ok .ne.1)then
print*, 'pb !!'
stop
endif
call do_mono_excitation(key_tmp,j,s,s2,i_ok)
if(i_ok .ne.1)then
print*, 'pb !!'
stop
endif
call i_H_j(ref_bitmask, key_tmp, N_int,hij)
delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s)
coef_ijrs = hij/delta_e
do k = 1, n_singles
l = index_singles(k)
call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij)
diag_H_elements(l) += coef_ijrs * hij
enddo
!! beta (i-->r) / beta (j-->s)
s1 = 2
s2 = 2
key_tmp = ref_bitmask
call do_mono_excitation(key_tmp,i,r,s1,i_ok)
if(i_ok .ne.1)then
print*, 'pb !!'
stop
endif
call do_mono_excitation(key_tmp,j,s,s2,i_ok)
if(i_ok .ne.1)then
print*, 'pb !!'
stop
endif
call i_H_j(ref_bitmask, key_tmp, N_int,hij)
delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s)
coef_ijrs = hij/delta_e
do k = 1, n_singles
l = index_singles(k)
call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij)
diag_H_elements(l) += coef_ijrs * hij
enddo
!endif
enddo
enddo
enddo
enddo
c_ref = 1.d0/u_in(index_hf,1)
do k = 1, n_singles
l = index_singles(k)
diag_H_elements(0) -= diag_H_elements(l)
enddo
! do k = 1, n_doubles
! l = index_doubles(k)
! diag_H_elements(0) += diag_H_elements(l)
! enddo
end
subroutine dressing_1h1p_full(dets_in,u_in,H_matrix,dim_in,sze,N_st,Nint,convergence)
use bitmasks
implicit none
BEGIN_DOC
! CISD+SC2 method :: take off all the disconnected terms of a ROHF+1h1p (selected or not)
!
! dets_in : bitmasks corresponding to determinants
!
! u_in : guess coefficients on the various states. Overwritten
! on exit
!
! dim_in : leftmost dimension of u_in
!
! sze : Number of determinants
!
! N_st : Number of eigenstates
!
! Initial guess vectors are not necessarily orthonormal
END_DOC
integer, intent(in) :: dim_in, sze, N_st, Nint
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(in) :: u_in(dim_in,N_st)
double precision, intent(inout) :: H_matrix(sze,sze)
double precision, intent(in) :: convergence
integer :: i,j,k,l
integer :: n_singles
integer :: index_singles(sze),hole_particles_singles(sze,3)
integer :: n_doubles
integer :: index_doubles(sze),hole_particles_doubles(sze,2)
integer :: index_hf
double precision :: e_corr_singles(mo_tot_num,2)
double precision :: e_corr_doubles(mo_tot_num)
double precision :: e_corr_singles_total(2)
double precision :: e_corr_doubles_1h1p
integer :: exc(0:2,2,2),degree
integer :: h1,h2,p1,p2,s1,s2
integer :: other_spin(2)
double precision :: phase
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i_ok
double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral
double precision :: hij,c_ref,contrib
integer :: iorb
other_spin(1) = 2
other_spin(2) = 1
n_singles = 0
n_doubles = 0
do i = 1,sze
call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
if(degree == 0)then
index_hf = i
else if (degree == 1)then
n_singles +=1
index_singles(n_singles) = i
! h1 = inactive orbital of the hole
hole_particles_singles(n_singles,1) = h1
! p1 = virtual orbital of the particle
hole_particles_singles(n_singles,2) = p1
! s1 = spin of the electron excited
hole_particles_singles(n_singles,3) = s1
else if (degree == 2)then
n_doubles +=1
index_doubles(n_doubles) = i
! h1 = inactive orbital of the hole (beta of course)
hole_particles_doubles(n_doubles,1) = h1
! p1 = virtual orbital of the particle (alpha of course)
hole_particles_doubles(n_doubles,2) = p2
else
print*,'PB !! found out other thing than a single or double'
print*,'stopping ..'
stop
endif
enddo
double precision, allocatable :: dressing_H_mat_elem(:)
allocate(dressing_H_mat_elem(N_det))
logical :: lmct
dressing_H_mat_elem = 0.d0
call dress_diag_elem_2h2p(dressing_H_mat_elem,N_det)
lmct = .False.
call dress_diag_elem_2h1p(dressing_H_mat_elem,N_det,lmct,1000)
lmct = .true.
call dress_diag_elem_1h2p(dressing_H_mat_elem,N_det,lmct,1000)
do i = 1, N_det
H_matrix(i,i) += dressing_H_mat_elem(i)
enddo
e_corr_singles = 0.d0
e_corr_doubles = 0.d0
e_corr_singles_total = 0.d0
e_corr_doubles_1h1p = 0.d0
c_ref = 1.d0/u_in(index_hf,1)
print*,'c_ref = ',c_ref
do i = 1,sze
call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
call i_H_j(ref_bitmask,dets_in(1,1,i),N_int,hij)
contrib = hij * u_in(i,1) * c_ref
if (degree == 1)then
e_corr_singles(h1,s1) += contrib
e_corr_singles(p1,s1) += contrib
e_corr_singles_total(s1)+= contrib
else if (degree == 2)then
e_corr_doubles_1h1p += contrib
e_corr_doubles(h1) += contrib
e_corr_doubles(p2) += contrib
endif
enddo
print*,'e_corr_singles alpha = ',e_corr_singles_total(1)
print*,'e_corr_singles beta = ',e_corr_singles_total(2)
print*,'e_corr_doubles_1h1p = ',e_corr_doubles_1h1p
! repeat all the correlation energy on the singles
! do i = 1,n_singles
! ! you can repeat all the correlation energy of the single excitation of the other spin
! H_matrix(index_singles(i),index_singles(i)) += e_corr_singles_total(other_spin(hole_particles_singles(i,3)))
! ! you can repeat all the correlation energy of the single excitation of the same spin
! do j = 1, n_inact_orb
! iorb = list_inact(j)
! ! except the one of the hole
! if(iorb == hole_particles_singles(i,1))cycle
! ! ispin = hole_particles_singles(i,3)
! H_matrix(index_singles(i),index_singles(i)) += e_corr_singles(iorb,hole_particles_singles(i,3))
! enddo
! ! also exclude all the energy coming from the virtual orbital
! H_matrix(index_singles(i),index_singles(i)) -= e_corr_singles(hole_particles_singles(i,2),hole_particles_singles(i,3))
!
! ! If it is a single excitation alpha, you can repeat :
! ! +) all the double excitation 1h1p, appart the part involving the virtual orbital "r"
! ! If it is a single excitation alpha, you can repeat :
! ! +) all the double excitation 1h1p, appart the part involving the inactive orbital "i"
! H_matrix(index_singles(i),index_singles(i)) += e_corr_doubles_1h1p
! if(hole_particles_singles(i,3) == 1)then ! alpha single excitation
! H_matrix(index_singles(i),index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,2))
! else ! beta single exctitation
! H_matrix(index_singles(i),index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,1))
! endif
! enddo
! ! repeat all the correlation energy on the doubles
! ! as all the doubles involve the active space, you cannot repeat any of them one on another
! do i = 1, n_doubles
! ! on a given double, you can repeat all the correlation energy of the singles alpha
! do j = 1, n_inact_orb
! iorb = list_inact(j)
! ! ispin = hole_particles_singles(i,3)
! H_matrix(index_doubles(i),index_doubles(i)) += e_corr_singles(iorb,1)
! enddo
! ! except the part involving the virtual orbital "hole_particles_doubles(i,2)"
! H_matrix(index_doubles(i),index_doubles(i)) -= e_corr_singles(hole_particles_doubles(i,2),1)
! ! on a given double, you can repeat all the correlation energy of the singles beta
! do j = 1, n_inact_orb
! iorb = list_inact(j)
! ! except the one of the hole
! if(iorb == hole_particles_doubles(i,1))cycle
! ! ispin = hole_particles_singles(i,3)
! H_matrix(index_doubles(i),index_doubles(i)) += e_corr_singles(iorb,2)
! enddo
! enddo
! Taking into account the connected part of the 2h2p on the HF determinant
! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma}
! H_matrix(index_hf) += total_corr_e_2h2p
print*,'H_matrix(index_hf,index_hf) = ',H_matrix(index_hf,index_hf)
do i = 1, n_singles
! start on the single excitation "|i>"
h1 = hole_particles_singles(i,1)
p1 = hole_particles_singles(i,2)
print*,'i = ',i
do j = i+1, n_singles
do k = 1, N_int
key_tmp(k,1) = dets_in(k,1,index_singles(i))
key_tmp(k,2) = dets_in(k,2,index_singles(i))
enddo
h2 = hole_particles_singles(j,1)
p2 = hole_particles_singles(j,2)
call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok)
! apply the excitation operator from the single excitation "|j>"
if(i_ok .ne. 1)cycle
double precision :: H_array(sze),diag_H_mat_elem,hjj
do k = 1, sze
call get_excitation_degree(dets_in(1,1,k),key_tmp,degree,N_int)
H_array(k) = 0.d0
if(degree > 2)cycle
call i_H_j(dets_in(1,1,k),key_tmp,N_int,hij)
H_array(k) = hij
enddo
hjj = 1.d0/(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
! contrib_e2 = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * hij * hij))
do l = 2, sze
! pause
H_matrix(l,l) += H_array(l) * H_array(l) * hjj
! H_matrix(1,l) += H_array(1) * H_array(l) * hjj
! H_matrix(l,1) += H_array(1) * H_array(l) * hjj
enddo
enddo
enddo
print*,'H_matrix(index_hf,index_hf) = ',H_matrix(index_hf,index_hf)
end
subroutine SC2_1h1p_full(dets_in,u_in,energies,H_matrix,dim_in,sze,N_st,Nint,convergence)
use bitmasks
implicit none
BEGIN_DOC
! CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not)
!
! dets_in : bitmasks corresponding to determinants
!
! u_in : guess coefficients on the various states. Overwritten
! on exit
!
! dim_in : leftmost dimension of u_in
!
! sze : Number of determinants
!
! N_st : Number of eigenstates
!
! Initial guess vectors are not necessarily orthonormal
END_DOC
integer, intent(in) :: dim_in, sze, N_st, Nint
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(inout) :: u_in(dim_in,N_st)
double precision, intent(out) :: energies(N_st)
double precision, intent(out) :: H_matrix(sze,sze)
double precision, intent(in) :: convergence
integer :: i,j,iter
print*,'sze = ',sze
H_matrix = 0.d0
do iter = 1, 1
! if(sze<=N_det_max_jacobi)then
double precision, allocatable :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:)
allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze))
H_matrix_tmp = 0.d0
call dressing_1h1p_full(dets_in,u_in,H_matrix_tmp,dim_in,sze,N_st,Nint,convergence)
do j=1,sze
do i=1,sze
H_matrix_tmp(i,j) += H_matrix_all_dets(i,j)
enddo
enddo
print*,'passed the dressing'
call lapack_diag(eigenvalues,eigenvectors, &
H_matrix_tmp,size(H_matrix_all_dets,1),sze)
do j=1,min(N_states_diag,sze)
do i=1,sze
u_in(i,j) = eigenvectors(i,j)
enddo
energies(j) = eigenvalues(j)
enddo
deallocate (H_matrix_tmp, eigenvalues, eigenvectors)
! else
! call davidson_diag_hjj(dets_in,u_in,diag_H_elements,energies,dim_in,sze,N_st,Nint,output_determinants)
! endif
print*,'E = ',energies(1) + nuclear_repulsion
enddo
end
subroutine SC2_1h1p(dets_in,u_in,energies,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
use bitmasks
implicit none
BEGIN_DOC
! CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not)
!
! dets_in : bitmasks corresponding to determinants
!
! u_in : guess coefficients on the various states. Overwritten
! on exit
!
! dim_in : leftmost dimension of u_in
!
! sze : Number of determinants
!
! N_st : Number of eigenstates
!
! Initial guess vectors are not necessarily orthonormal
END_DOC
integer, intent(in) :: dim_in, sze, N_st, Nint
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(inout) :: u_in(dim_in,N_st)
double precision, intent(out) :: energies(N_st)
double precision, intent(out) :: diag_H_elements(dim_in)
double precision :: extra_diag_H_elements(dim_in)
double precision, intent(in) :: convergence
integer :: i,j,iter
DIAG_H_ELEMENTS = 0.d0
do iter = 1, 1
! call dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
call dressing_1h1p_by_2h2p(dets_in,u_in,extra_diag_H_elements,dim_in,sze,N_st,Nint,convergence)
! if(sze<=N_det_max_jacobi)then
double precision, allocatable :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:)
allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze))
do j=1,sze
do i=1,sze
H_matrix_tmp(i,j) = H_matrix_all_dets(i,j)
enddo
enddo
H_matrix_tmp(1,1) += extra_diag_H_elements(1)
do i = 2,sze
H_matrix_tmp(1,i) += extra_diag_H_elements(i)
H_matrix_tmp(i,1) += extra_diag_H_elements(i)
enddo
!do i = 1,sze
! H_matrix_tmp(i,i) = diag_H_elements(i)
!enddo
call lapack_diag(eigenvalues,eigenvectors, &
H_matrix_tmp,size(H_matrix_all_dets,1),sze)
do j=1,min(N_states_diag,sze)
do i=1,sze
u_in(i,j) = eigenvectors(i,j)
enddo
energies(j) = eigenvalues(j)
enddo
deallocate (H_matrix_tmp, eigenvalues, eigenvectors)
! else
! call davidson_diag_hjj(dets_in,u_in,diag_H_elements,energies,dim_in,sze,N_st,Nint,output_determinants)
! endif
print*,'E = ',energies(1) + nuclear_repulsion
enddo
end
subroutine density_matrix_1h1p(dets_in,u_in,density_matrix_alpha,density_matrix_beta,norm,dim_in,sze,N_st,Nint)
use bitmasks
implicit none
BEGIN_DOC
! CISD+SC2 method :: take off all the disconnected terms of a ROHF+1h1p (selected or not)
!
! dets_in : bitmasks corresponding to determinants
!
! u_in : guess coefficients on the various states. Overwritten
! on exit
!
! dim_in : leftmost dimension of u_in
!
! sze : Number of determinants
!
! N_st : Number of eigenstates
!
! Initial guess vectors are not necessarily orthonormal
END_DOC
integer, intent(in) :: dim_in, sze, N_st, Nint
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(inout) :: u_in(dim_in,N_st)
double precision, intent(inout) :: density_matrix_alpha(mo_tot_num_align,mo_tot_num)
double precision, intent(inout) :: density_matrix_beta(mo_tot_num_align,mo_tot_num)
double precision, intent(inout) :: norm
integer :: i,j,k,l
integer :: n_singles
integer :: index_singles(sze),hole_particles_singles(sze,3)
integer :: n_doubles
integer :: index_doubles(sze),hole_particles_doubles(sze,2)
integer :: index_hf
integer :: exc(0:2,2,2),degree
integer :: h1,h2,p1,p2,s1,s2
integer :: other_spin(2)
double precision :: phase
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i_ok
double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral
double precision :: hij,c_ref,contrib
integer :: iorb
other_spin(1) = 2
other_spin(2) = 1
n_singles = 0
n_doubles = 0
norm = 0.d0
do i = 1,sze
call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
norm += u_in(i,1)* u_in(i,1)
if(degree == 0)then
index_hf = i
c_ref = 1.d0/psi_coef(i,1)
else if (degree == 1)then
n_singles +=1
index_singles(n_singles) = i
! h1 = inactive orbital of the hole
hole_particles_singles(n_singles,1) = h1
! p1 = virtual orbital of the particle
hole_particles_singles(n_singles,2) = p1
! s1 = spin of the electron excited
hole_particles_singles(n_singles,3) = s1
else if (degree == 2)then
n_doubles +=1
index_doubles(n_doubles) = i
! h1 = inactive orbital of the hole (beta of course)
hole_particles_doubles(n_doubles,1) = h1
! p1 = virtual orbital of the particle (alpha of course)
hole_particles_doubles(n_doubles,2) = p2
else
print*,'PB !! found out other thing than a single or double'
print*,'stopping ..'
stop
endif
enddo
print*,'norm = ',norm
! Taking into account the connected part of the 2h2p on the HF determinant
! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma}
do i = 1, n_singles
! start on the single excitation "|i>"
h1 = hole_particles_singles(i,1)
p1 = hole_particles_singles(i,2)
do j = 1, n_singles
do k = 1, N_int
key_tmp(k,1) = dets_in(k,1,index_singles(i))
key_tmp(k,2) = dets_in(k,2,index_singles(i))
enddo
h2 = hole_particles_singles(j,1)
p2 = hole_particles_singles(j,2)
call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok)
! apply the excitation operator from the single excitation "|j>"
if(i_ok .ne. 1)cycle
double precision :: coef_ijrs,phase_other_single_ref
integer :: occ(N_int*bit_kind_size,2),n_occ(2)
call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_single_double,N_int)
call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int)
call get_excitation(key_tmp,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int)
coef_ijrs = u_in(index_singles(i),1) * u_in(index_singles(j),1) * c_ref * c_ref &
* phase_single_double * phase_other_single_ref
call bitstring_to_list_ab(key_tmp, occ, n_occ, N_int)
do k=1,elec_alpha_num
l = occ(k,1)
density_matrix_alpha(l,l) += coef_ijrs*coef_ijrs
enddo
do k=1,elec_beta_num
l = occ(k,1)
density_matrix_beta(l,l) += coef_ijrs*coef_ijrs
enddo
norm += coef_ijrs* coef_ijrs
if(hole_particles_singles(j,3) == 1)then ! single alpha
density_matrix_alpha(h2,p2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref
density_matrix_alpha(p2,h2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref
else
density_matrix_beta(h2,p2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref
density_matrix_beta(p2,h2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref
endif
enddo
enddo
do i = 1, n_doubles
! start on the double excitation "|i>"
h1 = hole_particles_doubles(i,1)
p1 = hole_particles_doubles(i,2)
do j = 1, n_singles
do k = 1, N_int
key_tmp(k,1) = dets_in(k,1,index_doubles(i))
key_tmp(k,2) = dets_in(k,2,index_doubles(i))
enddo
h2 = hole_particles_singles(j,1)
p2 = hole_particles_singles(j,2)
call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok)
! apply the excitation operator from the single excitation "|j>"
if(i_ok .ne. 1)cycle
double precision :: coef_ijrs_kv,phase_double_triple
call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_double_triple,N_int)
call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int)
call get_excitation(key_tmp,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int)
coef_ijrs_kv = u_in(index_doubles(i),1) * u_in(index_singles(j),1) * c_ref * c_ref &
* phase_double_triple * phase_other_single_ref
call bitstring_to_list_ab(key_tmp, occ, n_occ, N_int)
do k=1,elec_alpha_num
l = occ(k,1)
density_matrix_alpha(l,l) += coef_ijrs_kv*coef_ijrs_kv
enddo
do k=1,elec_beta_num
l = occ(k,1)
density_matrix_beta(l,l) += coef_ijrs_kv*coef_ijrs_kv
enddo
norm += coef_ijrs_kv* coef_ijrs_kv
if(hole_particles_singles(j,3) == 1)then ! single alpha
density_matrix_alpha(h2,p2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref
density_matrix_alpha(p2,h2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref
else
density_matrix_beta(h2,p2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref
density_matrix_beta(p2,h2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref
endif
enddo
enddo
print*,'norm = ',norm
norm = 1.d0/norm
do i = 1, mo_tot_num
do j = 1, mo_tot_num
density_matrix_alpha(i,j) *= norm
density_matrix_beta(i,j) *= norm
enddo
enddo
coef_ijrs = 0.d0
do i = 1, mo_tot_num
coef_ijrs += density_matrix_beta(i,i) + density_matrix_beta(i,i)
enddo
print*,'accu = ',coef_ijrs
end

25
plugins/FOBOCI/all_singles.irp.f
View File

@ -1,13 +1,25 @@
subroutine all_single
subroutine all_single(e_pt2)
implicit none
double precision, intent(in) :: e_pt2
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
double precision,allocatable :: E_before(:)
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
selection_criterion = 0.d0
soft_touch selection_criterion
if(.not.selected_fobo_ci)then
selection_criterion = 0.d0
soft_touch selection_criterion
else
selection_criterion = 0.1d0
selection_criterion_factor = 0.01d0
selection_criterion_min = selection_criterion
soft_touch selection_criterion
endif
print*, 'e_pt2 = ',e_pt2
pt2_max = 0.15d0 * e_pt2
soft_touch pt2_max
print*, 'pt2_max = ',pt2_max
threshold_davidson = 1.d-9
soft_touch threshold_davidson davidson_criterion
i = 0
@ -17,6 +29,8 @@ subroutine all_single
print*,'pt2_max = ',pt2_max
print*,'N_det_generators = ',N_det_generators
pt2=-1.d0
print*, 'ref_bitmask_energy =',ref_bitmask_energy
print*, 'CI_expectation_value =',psi_energy(1)
E_before = ref_bitmask_energy
print*,'Initial Step '
@ -29,7 +43,7 @@ subroutine all_single
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
n_det_max = 100000
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > dabs(pt2_max))
i += 1
print*,'-----------------------'
print*,'i = ',i
@ -39,6 +53,8 @@ subroutine all_single
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
print*,'pt2_max = ',pt2_max
print*, maxval(abs(pt2(1:N_st))) > dabs(pt2_max)
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
@ -53,7 +69,6 @@ subroutine all_single
endif
E_before = CI_energy
!!!!!!!!!!!!!!!!!!!!!!!!!!! DOING ONLY ONE ITERATION OF SELECTION AS THE SELECTION CRITERION IS SET TO ZERO
exit
enddo
! threshold_davidson = 1.d-8
! soft_touch threshold_davidson davidson_criterion

40
plugins/FOBOCI/corr_energy_2h2p.irp.f
View File

@ -15,7 +15,7 @@
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i,j,k,l
integer :: i_hole,j_hole,k_part,l_part
double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib
double precision :: diag_H_mat_elem
integer :: i_ok,ispin
! Alpha - Beta correlation energy
@ -46,7 +46,7 @@
if(i_ok .ne.1)cycle
delta_e = (ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
contrib = hij*hij/delta_e
total_corr_e_2h2p += contrib
! Single orbital contribution
@ -81,8 +81,8 @@
k_part = list_virt(k)
do l = k+1,n_virt_orb
l_part = list_virt(l)
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
key_tmp = ref_bitmask
ispin = 1
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
@ -114,8 +114,8 @@
k_part = list_virt(k)
do l = k+1,n_virt_orb
l_part = list_virt(l)
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
key_tmp = ref_bitmask
ispin = 2
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
@ -161,7 +161,7 @@ END_PROVIDER
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i,j,k,l
integer :: i_hole,j_hole,k_part,l_part
double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib
double precision :: diag_H_mat_elem
integer :: i_ok,ispin
! Alpha - Beta correlation energy
@ -191,7 +191,7 @@ END_PROVIDER
if(i_ok .ne.1)cycle
delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
total_corr_e_2h1p += contrib
corr_energy_2h1p_ab_bb_per_2_orb(i_hole,j_hole) += contrib
@ -211,8 +211,8 @@ END_PROVIDER
k_part = list_act(k)
do l = 1,n_virt_orb
l_part = list_virt(l)
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
key_tmp = ref_bitmask
ispin = 1
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
@ -241,8 +241,8 @@ END_PROVIDER
k_part = list_act(k)
do l = 1,n_virt_orb
l_part = list_virt(l)
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
key_tmp = ref_bitmask
ispin = 2
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
@ -276,7 +276,7 @@ END_PROVIDER
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i,j,k,l
integer :: i_hole,j_hole,k_part,l_part
double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib
double precision :: diag_H_mat_elem
integer :: i_ok,ispin
! Alpha - Beta correlation energy
@ -302,7 +302,7 @@ END_PROVIDER
if(i_ok .ne.1)cycle
delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
total_corr_e_1h2p += contrib
@ -324,8 +324,8 @@ END_PROVIDER
k_part = list_act(k)
do l = i+1,n_virt_orb
l_part = list_virt(l)
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
key_tmp = ref_bitmask
ispin = 1
@ -356,8 +356,8 @@ END_PROVIDER
k_part = list_act(k)
do l = i+1,n_virt_orb
l_part = list_virt(l)
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
key_tmp = ref_bitmask
ispin = 2
@ -388,7 +388,7 @@ END_PROVIDER
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i,j,k,l
integer :: i_hole,j_hole,k_part,l_part
double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib
double precision :: diag_H_mat_elem
integer :: i_ok,ispin
! Alpha - Beta correlation energy
@ -412,7 +412,7 @@ END_PROVIDER
if(i_ok .ne.1)cycle
delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
total_corr_e_1h1p_spin_flip += contrib

4
plugins/FOBOCI/create_1h_or_1p.irp.f
View File

@ -68,7 +68,9 @@ subroutine create_restart_and_1h(i_hole)
SOFT_TOUCH N_det psi_det psi_coef
logical :: found_duplicates
if(n_act_orb.gt.1)then
call remove_duplicates_in_psi_det(found_duplicates)
endif
end
subroutine create_restart_and_1p(i_particle)
@ -213,6 +215,8 @@ subroutine create_restart_1h_1p(i_hole,i_part)
SOFT_TOUCH N_det psi_det psi_coef
logical :: found_duplicates
if(n_act_orb.gt.1)then
call remove_duplicates_in_psi_det(found_duplicates)
endif
end

8
plugins/FOBOCI/diag_fock_inactiv_virt.irp.f
View File

@ -38,7 +38,7 @@ end
subroutine diag_inactive_virt_new_and_update_mos
implicit none
integer :: i,j,i_inact,j_inact,i_virt,j_virt,k,k_act
double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral_schwartz
double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral
character*(64) :: label
tmp = 0.d0
do i = 1, mo_tot_num
@ -52,8 +52,8 @@ subroutine diag_inactive_virt_new_and_update_mos
accu =0.d0
do k = 1, n_act_orb
k_act = list_act(k)
accu += get_mo_bielec_integral_schwartz(i_inact,k_act,j_inact,k_act,mo_integrals_map)
accu -= get_mo_bielec_integral_schwartz(i_inact,k_act,k_act,j_inact,mo_integrals_map)
accu += get_mo_bielec_integral(i_inact,k_act,j_inact,k_act,mo_integrals_map)
accu -= get_mo_bielec_integral(i_inact,k_act,k_act,j_inact,mo_integrals_map)
enddo
tmp(i_inact,j_inact) = Fock_matrix_mo(i_inact,j_inact) + accu
tmp(j_inact,i_inact) = Fock_matrix_mo(j_inact,i_inact) + accu
@ -67,7 +67,7 @@ subroutine diag_inactive_virt_new_and_update_mos
accu =0.d0
do k = 1, n_act_orb
k_act = list_act(k)
accu += get_mo_bielec_integral_schwartz(i_virt,k_act,j_virt,k_act,mo_integrals_map)
accu += get_mo_bielec_integral(i_virt,k_act,j_virt,k_act,mo_integrals_map)
enddo
tmp(i_virt,j_virt) = Fock_matrix_mo(i_virt,j_virt) - accu
tmp(j_virt,i_virt) = Fock_matrix_mo(j_virt,i_virt) - accu

183
plugins/FOBOCI/dress_simple.irp.f
View File

@ -58,24 +58,7 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen
call i_h_j(det_buffer(1,1,i),det_buffer(1,1,i),Nint,haa)
f = 1.d0/(E_ref-haa)
! if(second_order_h)then
lambda_i = f
! else
! ! You write the new Hamiltonian matrix
! do k = 1, Ndet_generators
! H_matrix_tmp(k,Ndet_generators+1) = H_array(k)
! H_matrix_tmp(Ndet_generators+1,k) = H_array(k)
! enddo
! H_matrix_tmp(Ndet_generators+1,Ndet_generators+1) = haa
! ! Then diagonalize it
! call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,Ndet_generators+1,Ndet_generators+1)
! ! Then you extract the effective denominator
! accu = 0.d0
! do k = 1, Ndet_generators
! accu += eigenvectors(k,1) * H_array(k)
! enddo
! lambda_i = eigenvectors(Ndet_generators+1,1)/accu
! endif
do k=1,idx(0)
contrib = H_array(idx(k)) * H_array(idx(k)) * lambda_i
delta_ij_generators_(idx(k), idx(k)) += contrib
@ -89,20 +72,21 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen
end
subroutine is_a_good_candidate(threshold,is_ok,verbose)
subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
use bitmasks
implicit none
double precision, intent(in) :: threshold
logical, intent(out) :: is_ok
double precision, intent(out):: e_pt2
logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative
logical, intent(in) :: verbose
integer :: l,k,m
double precision,allocatable :: dressed_H_matrix(:,:)
double precision,allocatable :: psi_coef_diagonalized_tmp(:,:)
double precision, allocatable :: psi_coef_diagonalized_tmp(:,:)
integer(bit_kind), allocatable :: psi_det_generators_input(:,:,:)
double precision :: hij
allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators))
allocate(psi_coef_diagonalized_tmp(N_det_generators,N_states))
allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators),psi_coef_diagonalized_tmp(N_det_generators,N_states))
dressed_H_matrix = 0.d0
do k = 1, N_det_generators
do l = 1, N_int
@ -111,9 +95,20 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose)
enddo
enddo
!call H_apply_dressed_pert(dressed_H_matrix,N_det_generators,psi_det_generators_input)
call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose)
if(do_it_perturbative)then
if(is_ok)then
call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop,is_ok_perturbative)
!do m = 1, N_states
! do k = 1, N_det_generators
! do l = 1, N_int
! psi_selectors(l,1,k) = psi_det_generators_input(l,1,k)
! psi_selectors(l,2,k) = psi_det_generators_input(l,2,k)
! enddo
! psi_selectors_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
! enddo
!enddo
!soft_touch psi_selectors psi_selectors_coef
!if(do_it_perturbative)then
print*, 'is_ok_perturbative',is_ok_perturbative
if(is_ok.or.is_ok_perturbative)then
N_det = N_det_generators
do m = 1, N_states
do k = 1, N_det_generators
@ -122,11 +117,19 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose)
psi_det(l,2,k) = psi_det_generators_input(l,2,k)
enddo
psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
print*, 'psi_coef(k,m)',psi_coef(k,m)
enddo
enddo
soft_touch psi_det psi_coef N_det
e_pt2 = 0.d0
do m =1, N_det_generators
do l = 1, N_det_generators
call i_h_j(psi_det_generators_input(1,1,m),psi_det_generators_input(1,1,l),N_int,hij) ! Fill the zeroth order H matrix
e_pt2 += (dressed_H_matrix(m,l) - hij)* psi_coef_diagonalized_tmp(m,1)* psi_coef_diagonalized_tmp(l,1)
enddo
enddo
touch psi_coef psi_det N_det
endif
endif
!endif
deallocate(psi_det_generators_input,dressed_H_matrix,psi_coef_diagonalized_tmp)
@ -135,14 +138,14 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose)
end
subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose)
subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop,is_ok_perturbative)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators)
integer, intent(in) :: Ndet_generators
double precision, intent(in) :: threshold
logical, intent(in) :: verbose
logical, intent(out) :: is_ok
logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative
double precision, intent(out) :: psi_coef_diagonalized_tmp(Ndet_generators,N_states)
double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators)
@ -151,6 +154,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij
double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average
logical :: is_a_ref_det(Ndet_generators)
exit_loop = .False.
is_a_ref_det = .False.
do i = 1, N_det_generators
@ -191,6 +195,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then
if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then
is_ok = .False.
exit_loop = .True.
return
endif
endif
@ -278,9 +283,11 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
do k = 1, N_states
accu = 0.d0
do j =1, Ndet_generators
print*,'',eigvectors(j,i) , psi_coef_ref(j,k)
accu += eigvectors(j,i) * psi_coef_ref(j,k)
enddo
if(dabs(accu).ge.0.8d0)then
print*,'accu = ',accu
if(dabs(accu).ge.0.72d0)then
i_good_state(0) +=1
i_good_state(i_good_state(0)) = i
endif
@ -321,10 +328,124 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
exit
endif
enddo
if(.not.is_ok)then
is_ok_perturbative = .True.
do i = 1, Ndet_generators
if(is_a_ref_det(i))cycle
do k = 1, N_states
print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative
if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold_perturbative)then
is_ok_perturbative = .False.
exit
endif
enddo
if(.not.is_ok_perturbative)then
exit
endif
enddo
endif
if(verbose)then
print*,'is_ok = ',is_ok
print*,'is_ok = ',is_ok
print*,'is_ok_perturbative = ',is_ok_perturbative
endif
end
subroutine fill_H_apply_buffer_no_selection_first_order_coef(n_selected,det_buffer,Nint,iproc)
use bitmasks
implicit none
BEGIN_DOC
! Fill the H_apply buffer with determiants for CISD
END_DOC
integer, intent(in) :: n_selected, Nint, iproc
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
integer :: i,j,k
integer :: new_size
PROVIDE H_apply_buffer_allocated
call omp_set_lock(H_apply_buffer_lock(1,iproc))
new_size = H_apply_buffer(iproc)%N_det + n_selected
if (new_size > H_apply_buffer(iproc)%sze) then
call resize_h_apply_buffer(max(2*H_apply_buffer(iproc)%sze,new_size),iproc)
endif
do i=1,H_apply_buffer(iproc)%N_det
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num)
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num)
enddo
do i=1,n_selected
do j=1,N_int
H_apply_buffer(iproc)%det(j,1,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,1,i)
H_apply_buffer(iproc)%det(j,2,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,2,i)
enddo
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i+H_apply_buffer(iproc)%N_det)) )== elec_alpha_num)
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num)
enddo
double precision :: i_H_psi_array(N_states),h,diag_H_mat_elem_fock,delta_e
do i=1,N_selected
call i_H_psi(det_buffer(1,1,i),psi_selectors,psi_selectors_coef,N_int,N_det_selectors,psi_selectors_size,N_states,i_H_psi_array)
call i_H_j(det_buffer(1,1,i),det_buffer(1,1,i),N_int,h)
do j=1,N_states
delta_e = -1.d0 /(h - psi_energy(j))
H_apply_buffer(iproc)%coef(i+H_apply_buffer(iproc)%N_det,j) = i_H_psi_array(j) * delta_e
enddo
enddo
H_apply_buffer(iproc)%N_det = new_size
do i=1,H_apply_buffer(iproc)%N_det
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num)
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num)
enddo
call omp_unset_lock(H_apply_buffer_lock(1,iproc))
end
subroutine make_s2_eigenfunction_first_order
implicit none
integer :: i,j,k
integer :: smax, s
integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:)
integer :: N_det_new
integer, parameter :: bufsze = 1000
logical, external :: is_in_wavefunction
allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) )
smax = 1
N_det_new = 0
do i=1,N_occ_pattern
call occ_pattern_to_dets_size(psi_occ_pattern(1,1,i),s,elec_alpha_num,N_int)
s += 1
if (s > smax) then
deallocate(d)
allocate ( d(N_int,2,s) )
smax = s
endif
call occ_pattern_to_dets(psi_occ_pattern(1,1,i),d,s,elec_alpha_num,N_int)
do j=1,s
if (.not. is_in_wavefunction(d(1,1,j), N_int) ) then
N_det_new += 1
do k=1,N_int
det_buffer(k,1,N_det_new) = d(k,1,j)
det_buffer(k,2,N_det_new) = d(k,2,j)
enddo
if (N_det_new == bufsze) then
call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0)
N_det_new = 0
endif
endif
enddo
enddo
if (N_det_new > 0) then
call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0)
call copy_H_apply_buffer_to_wf
SOFT_TOUCH N_det psi_coef psi_det
endif
deallocate(d,det_buffer)
call write_int(output_determinants,N_det_new, 'Added deteminants for S^2')
end

14
plugins/FOBOCI/fobo_scf.irp.f
View File

@ -1,8 +1,13 @@
program foboscf
implicit none
call run_prepare
!if(disk_access_ao_integrals == "None" .or. disk_access_ao_integrals == "Read" )then
! disk_access_ao_integrals = "Write"
! touch disk_access_ao_integrals
!endif
!print*, 'disk_access_ao_integrals',disk_access_ao_integrals
no_oa_or_av_opt = .True.
touch no_oa_or_av_opt
call run_prepare
call routine_fobo_scf
call save_mos
@ -10,8 +15,8 @@ end
subroutine run_prepare
implicit none
no_oa_or_av_opt = .False.
touch no_oa_or_av_opt
! no_oa_or_av_opt = .False.
! touch no_oa_or_av_opt
call damping_SCF
call diag_inactive_virt_and_update_mos
end
@ -27,6 +32,7 @@ subroutine routine_fobo_scf
print*,'*******************************************************************************'
print*,'*******************************************************************************'
print*,'FOBO-SCF Iteration ',i
print*, 'ao_bielec_integrals_in_map = ',ao_bielec_integrals_in_map
print*,'*******************************************************************************'
print*,'*******************************************************************************'
if(speed_up_convergence_foboscf)then
@ -46,7 +52,7 @@ subroutine routine_fobo_scf
soft_touch threshold_lmct threshold_mlct
endif
endif
call FOBOCI_lmct_mlct_old_thr
call FOBOCI_lmct_mlct_old_thr(i)
call save_osoci_natural_mos
call damping_SCF
call diag_inactive_virt_and_update_mos

466
plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f
View File

@ -1,7 +1,8 @@
subroutine FOBOCI_lmct_mlct_old_thr
subroutine FOBOCI_lmct_mlct_old_thr(iter)
use bitmasks
implicit none
integer, intent(in) :: iter
integer :: i,j,k,l
integer(bit_kind),allocatable :: unpaired_bitmask(:,:)
integer, allocatable :: occ(:,:)
@ -10,7 +11,7 @@ subroutine FOBOCI_lmct_mlct_old_thr
logical :: test_sym
double precision :: thr,hij
double precision, allocatable :: dressing_matrix(:,:)
logical :: verbose,is_ok
logical :: verbose,is_ok,is_ok_perturbative
verbose = .True.
thr = 1.d-12
allocate(unpaired_bitmask(N_int,2))
@ -38,6 +39,7 @@ subroutine FOBOCI_lmct_mlct_old_thr
integer(bit_kind) , allocatable :: psi_singles(:,:,:)
logical :: lmct
double precision, allocatable :: psi_singles_coef(:,:)
logical :: exit_loop
allocate( zero_bitmask(N_int,2) )
do i = 1, n_inact_orb
lmct = .True.
@ -45,87 +47,45 @@ subroutine FOBOCI_lmct_mlct_old_thr
i_hole_osoci = list_inact(i)
print*,'--------------------------'
! First set the current generators to the one of restart
call set_generators_to_generators_restart
call set_psi_det_to_generators
call check_symetry(i_hole_osoci,thr,test_sym)
if(.not.test_sym)cycle
call set_generators_to_generators_restart
call set_psi_det_to_generators
print*,'i_hole_osoci = ',i_hole_osoci
call create_restart_and_1h(i_hole_osoci)
call set_generators_to_psi_det
print*,'Passed set generators'
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call is_a_good_candidate(threshold_lmct,is_ok,verbose)
double precision :: e_pt2
call is_a_good_candidate(threshold_lmct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
print*,'is_ok = ',is_ok
if(.not.is_ok)cycle
allocate(dressing_matrix(N_det_generators,N_det_generators))
dressing_matrix = 0.d0
if(.not.do_it_perturbative)then
do k = 1, N_det_generators
do l = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
dressing_matrix(k,l) = hkl
if(is_ok)then
allocate(dressing_matrix(N_det_generators,N_det_generators))
dressing_matrix = 0.d0
do k = 1, N_det_generators
do l = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
dressing_matrix(k,l) = hkl
enddo
enddo
enddo
hkl = dressing_matrix(1,1)
do k = 1, N_det_generators
dressing_matrix(k,k) = dressing_matrix(k,k) - hkl
enddo
print*,'Naked matrix'
do k = 1, N_det_generators
write(*,'(100(F12.5,X))')dressing_matrix(k,:)
enddo
! Do all the single excitations on top of the CAS and 1h determinants
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call all_single
! if(dressing_2h2p)then
! call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_hole_osoci,lmct)
! endif
! ! Change the mask of the holes and particles to perform all the
! ! double excitations that starts from the active space in order
! ! to introduce the Coulomb hole in the active space
! ! These are the 1h2p excitations that have the i_hole_osoci hole in common
! ! and the 2p if there is more than one electron in the active space
! do k = 1, N_int
! zero_bitmask(k,1) = 0_bit_kind
! zero_bitmask(k,2) = 0_bit_kind
! enddo
! ! hole is possible only in the orbital i_hole_osoci
! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int)
! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int)
! ! and in the active space
! do k = 1, n_act_orb
! call set_bit_to_integer(list_act(k),zero_bitmask(1,1),N_int)
! call set_bit_to_integer(list_act(k),zero_bitmask(1,2),N_int)
! enddo
! call set_bitmask_hole_as_input(zero_bitmask)
! call set_bitmask_particl_as_input(reunion_of_bitmask)
! call all_1h2p
! call diagonalize_CI_SC2
! call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
! ! Change the mask of the holes and particles to perform all the
! ! double excitations that from the orbital i_hole_osoci
! do k = 1, N_int
! zero_bitmask(k,1) = 0_bit_kind
! zero_bitmask(k,2) = 0_bit_kind
! enddo
! ! hole is possible only in the orbital i_hole_osoci
! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int)
! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int)
! call set_bitmask_hole_as_input(zero_bitmask)
! call set_bitmask_particl_as_input(reunion_of_bitmask)
! call set_psi_det_to_generators
! call all_2h2p
! call diagonalize_CI_SC2
hkl = dressing_matrix(1,1)
do k = 1, N_det_generators
dressing_matrix(k,k) = dressing_matrix(k,k) - hkl
enddo
print*,'Naked matrix'
do k = 1, N_det_generators
write(*,'(100(F12.5,X))')dressing_matrix(k,:)
enddo
! Do all the single excitations on top of the CAS and 1h determinants
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call all_single(e_pt2)
call make_s2_eigenfunction_first_order
threshold_davidson = 1.d-6
soft_touch threshold_davidson davidson_criterion
call diagonalize_ci
double precision :: hkl
call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
hkl = dressing_matrix(1,1)
@ -136,7 +96,10 @@ subroutine FOBOCI_lmct_mlct_old_thr
do k = 1, N_det_generators
write(*,'(100(F12.5,X))')dressing_matrix(k,:)
enddo
! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
deallocate(dressing_matrix)
else
if(.not.do_it_perturbative)cycle
if(.not. is_ok_perturbative)cycle
endif
call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci)
@ -145,7 +108,6 @@ subroutine FOBOCI_lmct_mlct_old_thr
norm_total(k) += norm_tmp(k)
enddo
call update_density_matrix_osoci
deallocate(dressing_matrix)
enddo
if(.True.)then
@ -159,10 +121,10 @@ subroutine FOBOCI_lmct_mlct_old_thr
print*,'--------------------------'
! First set the current generators to the one of restart
call set_generators_to_generators_restart
call set_psi_det_to_generators
call check_symetry(i_particl_osoci,thr,test_sym)
if(.not.test_sym)cycle
call set_generators_to_generators_restart
call set_psi_det_to_generators
print*,'i_particl_osoci= ',i_particl_osoci
! Initialize the bitmask to the restart ones
call initialize_bitmask_to_restart_ones
@ -178,24 +140,33 @@ subroutine FOBOCI_lmct_mlct_old_thr
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
!! ! so all the mono excitation on the new generators
call is_a_good_candidate(threshold_mlct,is_ok,verbose)
call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
print*,'is_ok = ',is_ok
if(.not.is_ok)cycle
allocate(dressing_matrix(N_det_generators,N_det_generators))
if(.not.do_it_perturbative)then
dressing_matrix = 0.d0
do k = 1, N_det_generators
do l = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
dressing_matrix(k,l) = hkl
if(is_ok)then
allocate(dressing_matrix(N_det_generators,N_det_generators))
dressing_matrix = 0.d0
do k = 1, N_det_generators
do l = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
dressing_matrix(k,l) = hkl
enddo
enddo
enddo
! call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix)
! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
call all_single
! if(dressing_2h2p)then
! call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_particl_osoci,lmct)
! endif
call all_single(e_pt2)
call make_s2_eigenfunction_first_order
threshold_davidson = 1.d-6
soft_touch threshold_davidson davidson_criterion
call diagonalize_ci
deallocate(dressing_matrix)
else
if(exit_loop)then
call set_generators_to_generators_restart
call set_psi_det_to_generators
exit
else
if(.not.do_it_perturbative)cycle
if(.not. is_ok_perturbative)cycle
endif
endif
call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
do k = 1, N_states
@ -203,7 +174,6 @@ subroutine FOBOCI_lmct_mlct_old_thr
norm_total(k) += norm_tmp(k)
enddo
call update_density_matrix_osoci
deallocate(dressing_matrix)
enddo
endif
@ -230,7 +200,7 @@ subroutine FOBOCI_mlct_old
double precision :: norm_tmp,norm_total
logical :: test_sym
double precision :: thr
logical :: verbose,is_ok
logical :: verbose,is_ok,exit_loop
verbose = .False.
thr = 1.d-12
allocate(unpaired_bitmask(N_int,2))
@ -270,7 +240,7 @@ subroutine FOBOCI_mlct_old
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
! ! so all the mono excitation on the new generators
call is_a_good_candidate(threshold_mlct,is_ok,verbose)
call is_a_good_candidate(threshold_mlct,is_ok,verbose,exit_loop)
print*,'is_ok = ',is_ok
is_ok =.True.
if(.not.is_ok)cycle
@ -304,7 +274,7 @@ subroutine FOBOCI_lmct_old
double precision :: norm_tmp,norm_total
logical :: test_sym
double precision :: thr
logical :: verbose,is_ok
logical :: verbose,is_ok,exit_loop
verbose = .False.
thr = 1.d-12
allocate(unpaired_bitmask(N_int,2))
@ -342,7 +312,7 @@ subroutine FOBOCI_lmct_old
call set_generators_to_psi_det
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call is_a_good_candidate(threshold_lmct,is_ok,verbose)
call is_a_good_candidate(threshold_lmct,is_ok,verbose,exit_loop)
print*,'is_ok = ',is_ok
if(.not.is_ok)cycle
! ! so all the mono excitation on the new generators
@ -365,3 +335,303 @@ subroutine FOBOCI_lmct_old
enddo
print*,'accu = ',accu
end
subroutine FOBOCI_lmct_mlct_old_thr_restart(iter)
use bitmasks
implicit none
integer, intent(in) :: iter
integer :: i,j,k,l
integer(bit_kind),allocatable :: unpaired_bitmask(:,:)
integer, allocatable :: occ(:,:)
integer :: n_occ_alpha, n_occ_beta
double precision :: norm_tmp(N_states),norm_total(N_states)
logical :: test_sym
double precision :: thr,hij
double precision, allocatable :: dressing_matrix(:,:)
logical :: verbose,is_ok,is_ok_perturbative
verbose = .True.
thr = 1.d-12
allocate(unpaired_bitmask(N_int,2))
allocate (occ(N_int*bit_kind_size,2))
do i = 1, N_int
unpaired_bitmask(i,1) = unpaired_alpha_electrons(i)
unpaired_bitmask(i,2) = unpaired_alpha_electrons(i)
enddo
norm_total = 0.d0
call initialize_density_matrix_osoci
call bitstring_to_list(inact_bitmask(1,1), occ(1,1), n_occ_beta, N_int)
print*,''
print*,''
print*,'mulliken spin population analysis'
accu =0.d0
do i = 1, nucl_num
accu += mulliken_spin_densities(i)
print*,i,nucl_charge(i),mulliken_spin_densities(i)
enddo
print*,''
print*,''
print*,'DOING FIRST LMCT !!'
print*,'Threshold_lmct = ',threshold_lmct
integer(bit_kind) , allocatable :: zero_bitmask(:,:)
integer(bit_kind) , allocatable :: psi_singles(:,:,:)
logical :: lmct
double precision, allocatable :: psi_singles_coef(:,:)
logical :: exit_loop
allocate( zero_bitmask(N_int,2) )
if(iter.ne.1)then
do i = 1, n_inact_orb
lmct = .True.
integer :: i_hole_osoci
i_hole_osoci = list_inact(i)
print*,'--------------------------'
! First set the current generators to the one of restart
call check_symetry(i_hole_osoci,thr,test_sym)
if(.not.test_sym)cycle
call set_generators_to_generators_restart
call set_psi_det_to_generators
print*,'i_hole_osoci = ',i_hole_osoci
call create_restart_and_1h(i_hole_osoci)
call set_generators_to_psi_det
print*,'Passed set generators'
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
double precision :: e_pt2
call is_a_good_candidate(threshold_lmct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
print*,'is_ok = ',is_ok
if(is_ok)then
allocate(dressing_matrix(N_det_generators,N_det_generators))
dressing_matrix = 0.d0
do k = 1, N_det_generators
do l = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
dressing_matrix(k,l) = hkl
enddo
enddo
hkl = dressing_matrix(1,1)
do k = 1, N_det_generators
dressing_matrix(k,k) = dressing_matrix(k,k) - hkl
enddo
print*,'Naked matrix'
do k = 1, N_det_generators
write(*,'(100(F12.5,X))')dressing_matrix(k,:)
enddo
! Do all the single excitations on top of the CAS and 1h determinants
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call all_single(e_pt2)
call make_s2_eigenfunction_first_order
threshold_davidson = 1.d-6
soft_touch threshold_davidson davidson_criterion
call diagonalize_ci
double precision :: hkl
call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
hkl = dressing_matrix(1,1)
do k = 1, N_det_generators
dressing_matrix(k,k) = dressing_matrix(k,k) - hkl
enddo
print*,'Dressed matrix'
do k = 1, N_det_generators
write(*,'(100(F12.5,X))')dressing_matrix(k,:)
enddo
deallocate(dressing_matrix)
else
if(.not.do_it_perturbative)cycle
if(.not. is_ok_perturbative)cycle
endif
call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci)
do k = 1, N_states
print*,'norm_tmp = ',norm_tmp(k)
norm_total(k) += norm_tmp(k)
enddo
call update_density_matrix_osoci
enddo
else
double precision :: array_dm(mo_tot_num)
call read_dm_from_lmct(array_dm)
call update_density_matrix_beta_osoci_read(array_dm)
endif
if(iter.ne.1)then
if(.True.)then
print*,''
print*,'DOING THEN THE MLCT !!'
print*,'Threshold_mlct = ',threshold_mlct
lmct = .False.
do i = 1, n_virt_orb
integer :: i_particl_osoci
i_particl_osoci = list_virt(i)
print*,'--------------------------'
! First set the current generators to the one of restart
call check_symetry(i_particl_osoci,thr,test_sym)
if(.not.test_sym)cycle
call set_generators_to_generators_restart
call set_psi_det_to_generators
print*,'i_particl_osoci= ',i_particl_osoci
! Initialize the bitmask to the restart ones
call initialize_bitmask_to_restart_ones
! Impose that only the hole i_hole_osoci can be done
call modify_bitmasks_for_particl(i_particl_osoci)
call print_generators_bitmasks_holes
! Impose that only the active part can be reached
call set_bitmask_hole_as_input(unpaired_bitmask)
!!! call all_single_h_core
call create_restart_and_1p(i_particl_osoci)
!!! ! Update the generators
call set_generators_to_psi_det
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
!!! ! so all the mono excitation on the new generators
call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
print*,'is_ok = ',is_ok
if(is_ok)then
allocate(dressing_matrix(N_det_generators,N_det_generators))
dressing_matrix = 0.d0
do k = 1, N_det_generators
do l = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
dressing_matrix(k,l) = hkl
enddo
enddo
call all_single(e_pt2)
call make_s2_eigenfunction_first_order
threshold_davidson = 1.d-6
soft_touch threshold_davidson davidson_criterion
call diagonalize_ci
deallocate(dressing_matrix)
else
if(exit_loop)then
call set_generators_to_generators_restart
call set_psi_det_to_generators
exit
else
if(.not.do_it_perturbative)cycle
if(.not. is_ok_perturbative)cycle
endif
endif
call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
do k = 1, N_states
print*,'norm_tmp = ',norm_tmp(k)
norm_total(k) += norm_tmp(k)
enddo
call update_density_matrix_osoci
enddo
endif
else
integer :: norb
call read_dm_from_mlct(array_dm,norb)
call update_density_matrix_alpha_osoci_read(array_dm)
do i = norb+1, n_virt_orb
i_particl_osoci = list_virt(i)
print*,'--------------------------'
! First set the current generators to the one of restart
call check_symetry(i_particl_osoci,thr,test_sym)
if(.not.test_sym)cycle
call set_generators_to_generators_restart
call set_psi_det_to_generators
print*,'i_particl_osoci= ',i_particl_osoci
! Initialize the bitmask to the restart ones
call initialize_bitmask_to_restart_ones
! Impose that only the hole i_hole_osoci can be done
call modify_bitmasks_for_particl(i_particl_osoci)
call print_generators_bitmasks_holes
! Impose that only the active part can be reached
call set_bitmask_hole_as_input(unpaired_bitmask)
!!! call all_single_h_core
call create_restart_and_1p(i_particl_osoci)
!!! ! Update the generators
call set_generators_to_psi_det
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
!!! ! so all the mono excitation on the new generators
call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
print*,'is_ok = ',is_ok
if(is_ok)then
allocate(dressing_matrix(N_det_generators,N_det_generators))
dressing_matrix = 0.d0
do k = 1, N_det_generators
do l = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
dressing_matrix(k,l) = hkl
enddo
enddo
call all_single(e_pt2)
call make_s2_eigenfunction_first_order
threshold_davidson = 1.d-6
soft_touch threshold_davidson davidson_criterion
call diagonalize_ci
deallocate(dressing_matrix)
else
if(exit_loop)then
call set_generators_to_generators_restart
call set_psi_det_to_generators
exit
else
if(.not.do_it_perturbative)cycle
if(.not. is_ok_perturbative)cycle
endif
endif
call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
do k = 1, N_states
print*,'norm_tmp = ',norm_tmp(k)
norm_total(k) += norm_tmp(k)
enddo
call update_density_matrix_osoci
enddo
endif
print*,'norm_total = ',norm_total
norm_total = norm_generators_restart
norm_total = 1.d0/norm_total
! call rescale_density_matrix_osoci(norm_total)
double precision :: accu
accu = 0.d0
do i = 1, mo_tot_num
accu += one_body_dm_mo_alpha_osoci(i,i) + one_body_dm_mo_beta_osoci(i,i)
enddo
print*,'accu = ',accu
end
subroutine read_dm_from_lmct(array)
implicit none
integer :: i,iunit ,getUnitAndOpen
double precision :: stuff
double precision, intent(out) :: array(mo_tot_num)
character*(128) :: input
input=trim("fort.33")
iunit= getUnitAndOpen(input,'r')
print*, iunit
array = 0.d0
do i = 1, n_inact_orb
read(iunit,*) stuff
print*, list_inact(i),stuff
array(list_inact(i)) = stuff
enddo
end
subroutine read_dm_from_mlct(array,norb)
implicit none
integer :: i,iunit ,getUnitAndOpen
double precision :: stuff
double precision, intent(out) :: array(mo_tot_num)
character*(128) :: input
input=trim("fort.35")
iunit= getUnitAndOpen(input,'r')
integer,intent(out) :: norb
read(iunit,*)norb
print*, iunit
input=trim("fort.34")
iunit= getUnitAndOpen(input,'r')
array = 0.d0
print*, 'norb = ',norb
do i = 1, norb
read(iunit,*) stuff
print*, list_virt(i),stuff
array(list_virt(i)) = stuff
enddo
end

2
plugins/FOBOCI/generators_restart_save.irp.f
View File

@ -9,6 +9,7 @@ BEGIN_PROVIDER [ integer, N_det_generators_restart ]
integer :: i
integer, save :: ifirst = 0
double precision :: norm
print*, ' Providing N_det_generators_restart'
if(ifirst == 0)then
call ezfio_get_determinants_n_det(N_det_generators_restart)
ifirst = 1
@ -30,6 +31,7 @@ END_PROVIDER
integer :: i, k
integer, save :: ifirst = 0
double precision, allocatable :: psi_coef_read(:,:)
print*, ' Providing psi_det_generators_restart'
if(ifirst == 0)then
call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart)
do k = 1, N_int

82
plugins/FOBOCI/hcc_1h1p.irp.f
View File

@ -1,82 +0,0 @@
program test_sc2
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
double precision, allocatable :: energies(:),diag_H_elements(:)
double precision, allocatable :: H_matrix(:,:)
allocate(energies(N_states),diag_H_elements(N_det))
call diagonalize_CI
call test_hcc
call test_mulliken
allocate(H_matrix(N_det,N_det))
stop 'SC2_1h1p_full is not in the git!'
! call SC2_1h1p_full(psi_det,psi_coef,energies, &
! H_matrix,size(psi_coef,1),N_det,N_states_diag,N_int,threshold_convergence_SC2)
deallocate(H_matrix)
integer :: i,j
double precision :: accu,coef_hf
! coef_hf = 1.d0/psi_coef(1,1)
! do i = 1, N_det
! psi_coef(i,1) *= coef_hf
! enddo
touch psi_coef
call pouet
end
subroutine pouet
implicit none
double precision :: accu,coef_hf
! provide one_body_dm_mo_alpha one_body_dm_mo_beta
! call density_matrix_1h1p(psi_det,psi_coef,one_body_dm_mo_alpha,one_body_dm_mo_beta,accu,size(psi_coef,1),N_det,N_states_diag,N_int)
! touch one_body_dm_mo_alpha one_body_dm_mo_beta
call test_hcc
call test_mulliken
! call save_wavefunction
end
subroutine test_hcc
implicit none
double precision :: accu
integer :: i,j
print*,'Z AU GAUSS MHZ cm^-1'
do i = 1, nucl_num
write(*,'(I2,X,F3.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i)
enddo
end
subroutine test_mulliken
double precision :: accu
integer :: i
integer :: j
accu= 0.d0
do i = 1, nucl_num
print*,i,nucl_charge(i),mulliken_spin_densities(i)
accu += mulliken_spin_densities(i)
enddo
print*,'Sum of Mulliken SD = ',accu
!print*,'AO SPIN POPULATIONS'
accu = 0.d0
!do i = 1, ao_num
! accu += spin_gross_orbital_product(i)
! write(*,'(X,I3,X,A4,X,I2,X,A4,X,F10.7)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),trim(l_to_charater(ao_l(i))),spin_gross_orbital_product(i)
!enddo
!print*,'sum = ',accu
!accu = 0.d0
!print*,'Angular momentum analysis'
!do i = 0, ao_l_max
! accu += spin_population_angular_momentum(i)
! print*,' ',trim(l_to_charater(i)),spin_population_angular_momentum(i)
!print*,'sum = ',accu
!enddo
end

58
plugins/FOBOCI/routines_foboci.irp.f
View File

@ -212,12 +212,50 @@ subroutine update_density_matrix_osoci
integer :: iorb,jorb
do i = 1, mo_tot_num
do j = 1, mo_tot_num
one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
enddo
enddo
end
subroutine update_density_matrix_beta_osoci_read(array)
implicit none
BEGIN_DOC
! one_body_dm_mo_alpha_osoci += Delta rho alpha
! one_body_dm_mo_beta_osoci += Delta rho beta
END_DOC
integer :: i,j
integer :: iorb,jorb
double precision :: array(mo_tot_num)
do i = 1, mo_tot_num
j = list_act(1)
one_body_dm_mo_beta_osoci(i,j) += array(i)
one_body_dm_mo_beta_osoci(j,i) += array(i)
one_body_dm_mo_beta_osoci(i,i) += array(i) * array(i)
enddo
end
subroutine update_density_matrix_alpha_osoci_read(array)
implicit none
BEGIN_DOC
! one_body_dm_mo_alpha_osoci += Delta rho alpha
! one_body_dm_mo_beta_osoci += Delta rho beta
END_DOC
integer :: i,j
integer :: iorb,jorb
double precision :: array(mo_tot_num)
do i = 1, mo_tot_num
j = list_act(1)
one_body_dm_mo_alpha_osoci(i,j) += array(i)
one_body_dm_mo_alpha_osoci(j,i) += array(i)
one_body_dm_mo_alpha_osoci(i,i) += array(i) * array(i)
enddo
end
@ -387,14 +425,14 @@ subroutine save_osoci_natural_mos
print*,'ACTIVE ORBITAL ',iorb
do j = 1, n_inact_orb
jorb = list_inact(j)
if(dabs(tmp(iorb,jorb)).gt.threshold_lmct)then
if(dabs(tmp(iorb,jorb)).gt.0.0001d0)then
print*,'INACTIVE '
print*,'DM ',iorb,jorb,(tmp(iorb,jorb))
endif
enddo
do j = 1, n_virt_orb
jorb = list_virt(j)
if(dabs(tmp(iorb,jorb)).gt.threshold_mlct)then
if(dabs(tmp(iorb,jorb)).gt.0.0001d0)then
print*,'VIRT '
print*,'DM ',iorb,jorb,(tmp(iorb,jorb))
endif
@ -412,6 +450,10 @@ subroutine save_osoci_natural_mos
label = "Natural"
call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1)
!if(disk_access_ao_integrals == "None" .or. disk_access_ao_integrals == "Write" )then
! disk_access_ao_integrals = "Read"
! touch disk_access_ao_integrals
!endif
!soft_touch mo_coef
deallocate(tmp,occ)
@ -588,14 +630,14 @@ end
integer :: i
double precision :: accu_tot,accu_sd
print*,'touched the one_body_dm_mo_beta'
one_body_dm_mo_alpha = one_body_dm_mo_alpha_osoci
one_body_dm_mo_beta = one_body_dm_mo_beta_osoci
one_body_dm_mo_alpha_average = one_body_dm_mo_alpha_osoci
one_body_dm_mo_beta_average = one_body_dm_mo_beta_osoci
touch one_body_dm_mo_alpha one_body_dm_mo_beta
accu_tot = 0.d0
accu_sd = 0.d0
do i = 1, mo_tot_num
accu_tot += one_body_dm_mo_alpha(i,i) + one_body_dm_mo_beta(i,i)
accu_sd += one_body_dm_mo_alpha(i,i) - one_body_dm_mo_beta(i,i)
accu_tot += one_body_dm_mo_alpha_average(i,i) + one_body_dm_mo_beta_average(i,i)
accu_sd += one_body_dm_mo_alpha_average(i,i) - one_body_dm_mo_beta_average(i,i)
enddo
print*,'accu_tot = ',accu_tot
print*,'accu_sdt = ',accu_sd

12
plugins/Full_CI/EZFIO.cfg
View File

@ -8,3 +8,15 @@ type: double precision
doc: Calculated FCI energy + PT2
interface: ezfio
[threshold_generators_pt2]
type: Threshold
doc: Thresholds on generators (fraction of the norm) for final PT2 calculation
interface: ezfio,provider,ocaml
default: 0.999
[threshold_selectors_pt2]
type: Threshold
doc: Thresholds on selectors (fraction of the norm) for final PT2 calculation
interface: ezfio,provider,ocaml
default: 1.

13
plugins/Full_CI/H_apply.irp.f
View File

@ -7,16 +7,17 @@ s.set_selection_pt2("epstein_nesbet_2x2")
#s.unset_openmp()
print s
#s = H_apply("FCI_PT2")
#s.set_perturbation("epstein_nesbet_2x2")
#s.unset_openmp()
#print s
s = H_apply_zmq("FCI_PT2")
s = H_apply("FCI_PT2")
s.set_perturbation("epstein_nesbet_2x2")
s.unset_openmp()
print s
s = H_apply("FCI_PT2_new")
s.set_perturbation("decontracted")
s.unset_openmp()
print s
s = H_apply("FCI_no_skip")
s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip()

5
plugins/Full_CI/full_ci.irp.f
View File

@ -92,8 +92,9 @@ program full_ci
call diagonalize_CI
if(do_pt2_end)then
print*,'Last iteration only to compute the PT2'
threshold_selectors = 1.d0
threshold_generators = 0.999d0
threshold_generators = threshold_generators_pt2
threshold_selectors = threshold_selectors_pt2
SOFT_TOUCH threshold_generators threshold_selectors
call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag, N_st)
print *, 'Final step'

6
plugins/Full_CI/full_ci_no_skip.irp.f
View File

@ -73,9 +73,11 @@ program full_ci
call diagonalize_CI
if(do_pt2_end)then
print*,'Last iteration only to compute the PT2'
threshold_generators = threshold_generators_pt2
threshold_selectors = threshold_selectors_pt2
SOFT_TOUCH threshold_generators threshold_selectors
! print*,'The thres'
threshold_selectors = 1.d0
threshold_generators = 0.999d0
call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag, N_st)
print *, 'Final step'

7
plugins/MRPT_Utils/EZFIO.cfg Normal file
View File

@ -0,0 +1,7 @@
[do_third_order_1h1p]
type: logical
doc: If true, compute the third order contribution for the 1h1p
interface: ezfio,provider,ocaml
default: True

187
plugins/MRPT_Utils/H_apply.irp.f Normal file
View File

@ -0,0 +1,187 @@
use bitmasks
BEGIN_SHELL [ /usr/bin/env python ]
from generate_h_apply import *
s = H_apply("mrpt")
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
s.data["params_post"] += ", delta_ij_, Ndet"
s.data["params_main"] += "delta_ij_, Ndet"
s.data["decls_main"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["finalization"] = ""
s.data["copy_buffer"] = ""
s.data["generate_psi_guess"] = ""
s.data["size_max"] = "3072"
print s
s = H_apply("mrpt_1h")
s.filter_only_1h()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
s.data["params_post"] += ", delta_ij_, Ndet"
s.data["params_main"] += "delta_ij_, Ndet"
s.data["decls_main"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["finalization"] = ""
s.data["copy_buffer"] = ""
s.data["generate_psi_guess"] = ""
s.data["size_max"] = "3072"
print s
s = H_apply("mrpt_1p")
s.filter_only_1p()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
s.data["params_post"] += ", delta_ij_, Ndet"
s.data["params_main"] += "delta_ij_, Ndet"
s.data["decls_main"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["finalization"] = ""
s.data["copy_buffer"] = ""
s.data["generate_psi_guess"] = ""
s.data["size_max"] = "3072"
print s
s = H_apply("mrpt_1h1p")
s.filter_only_1h1p()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
s.data["params_post"] += ", delta_ij_, Ndet"
s.data["params_main"] += "delta_ij_, Ndet"
s.data["decls_main"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["finalization"] = ""
s.data["copy_buffer"] = ""
s.data["generate_psi_guess"] = ""
s.data["size_max"] = "3072"
print s
s = H_apply("mrpt_2p")
s.filter_only_2p()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
s.data["params_post"] += ", delta_ij_, Ndet"
s.data["params_main"] += "delta_ij_, Ndet"
s.data["decls_main"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["finalization"] = ""
s.data["copy_buffer"] = ""
s.data["generate_psi_guess"] = ""
s.data["size_max"] = "3072"
print s
s = H_apply("mrpt_2h")
s.filter_only_2h()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
s.data["params_post"] += ", delta_ij_, Ndet"
s.data["params_main"] += "delta_ij_, Ndet"
s.data["decls_main"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["finalization"] = ""
s.data["copy_buffer"] = ""
s.data["generate_psi_guess"] = ""
s.data["size_max"] = "3072"
print s
s = H_apply("mrpt_1h2p")
s.filter_only_1h2p()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
s.data["params_post"] += ", delta_ij_, Ndet"
s.data["params_main"] += "delta_ij_, Ndet"
s.data["decls_main"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["finalization"] = ""
s.data["copy_buffer"] = ""
s.data["generate_psi_guess"] = ""
s.data["size_max"] = "3072"
print s
s = H_apply("mrpt_2h1p")
s.filter_only_2h1p()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
s.data["params_post"] += ", delta_ij_, Ndet"
s.data["params_main"] += "delta_ij_, Ndet"
s.data["decls_main"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["finalization"] = ""
s.data["copy_buffer"] = ""
s.data["generate_psi_guess"] = ""
s.data["size_max"] = "3072"
print s
s = H_apply("mrpt_2h2p")
s.filter_only_2h2p()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
s.data["params_post"] += ", delta_ij_, Ndet"
s.data["params_main"] += "delta_ij_, Ndet"
s.data["decls_main"] += """
integer, intent(in) :: Ndet
double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
"""
s.data["finalization"] = ""
s.data["copy_buffer"] = ""
s.data["generate_psi_guess"] = ""
s.data["size_max"] = "3072"
print s
END_SHELL

43
plugins/MRPT_Utils/MRPT_Utils.main.irp.f Normal file
View File

@ -0,0 +1,43 @@
program MRPT_Utils
implicit none
read_wf = .True.
touch read_wf
! call routine
! call routine_2
call routine_3
end
subroutine routine_3
implicit none
!provide fock_virt_total_spin_trace
provide delta_ij
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
print *, 'PT2 = ', second_order_pt_new(1)
print *, 'E = ', CI_energy(1)
print *, 'E+PT2 = ', CI_energy(1)+second_order_pt_new(1)
print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******'
print *, 'E dressed= ', CI_dressed_pt2_new_energy(1)
end
subroutine routine_2
implicit none
integer :: i
do i = 1, n_core_inact_orb
print*,fock_core_inactive_total(i,1,1),fock_core_inactive(i)
enddo
double precision :: accu
accu = 0.d0
do i = 1, n_act_orb
integer :: j_act_orb
j_act_orb = list_act(i)
accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb,1)
print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb,1),one_body_dm_mo_beta(j_act_orb,j_act_orb,1)
enddo
print*,'accu = ',accu
end

1
plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Determinants Selectors_full Generators_full Davidson

13
plugins/MRPT_Utils/README.rst Normal file
View File

@ -0,0 +1,13 @@
==========
MRPT_Utils
==========
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.

1114
plugins/MRPT_Utils/energies_cas.irp.f Normal file
View File

File diff suppressed because it is too large Load Diff

708
plugins/MRPT_Utils/excitations_cas.irp.f Normal file
View File

@ -0,0 +1,708 @@
subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, &
norm_out,psi_in_out,psi_in_out_coef, ndet,dim_psi_in,dim_psi_coef,N_states_in)
use bitmasks
implicit none
integer, intent(in) :: orb, hole_particle,spin_exc,N_states_in,ndet,dim_psi_in,dim_psi_coef
double precision, intent(out) :: norm_out(N_states_in)
integer(bit_kind), intent(inout) :: psi_in_out(N_int,2,dim_psi_in)
double precision, intent(inout) :: psi_in_out_coef(dim_psi_coef,N_states_in)
BEGIN_DOC
! apply a contracted excitation to psi_in_out whose coefficients
! are psi_in_out_coef
! hole_particle = 1 ===> creation of an electron in psi_in_out
! = -1 ===> annhilation of an electron in psi_in_out
! orb ===> is the index of orbital where you want wether to create or
! annhilate an electron
! spin_exc ===> is the spin of the electron (1 == alpha) (2 == beta)
! the wave function gets out normalized to unity
!
! norm_out is the sum of the squared of the coefficients
! on which the excitation has been possible
END_DOC
integer :: elec_num_tab_local(2)
integer :: i,j,accu_elec,k
integer :: det_tmp(N_int), det_tmp_bis(N_int)
double precision :: phase
double precision :: norm_factor
elec_num_tab_local = 0
do i = 1, ndet
if( psi_in_out_coef (i,1) .ne. 0.d0)then
do j = 1, N_int
elec_num_tab_local(1) += popcnt(psi_in_out(j,1,i))
elec_num_tab_local(2) += popcnt(psi_in_out(j,2,i))
enddo
exit
endif
enddo
if(hole_particle == 1)then
do i = 1, ndet
call set_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int)
accu_elec = 0
do j = 1, N_int
accu_elec += popcnt(psi_in_out(j,spin_exc,i))
enddo
if(accu_elec .ne. elec_num_tab_local(spin_exc)+1)then
do j = 1, N_int
psi_in_out(j,1,i) = 0_bit_kind
psi_in_out(j,2,i) = 0_bit_kind
enddo
do j = 1, N_states_in
psi_in_out_coef(i,j) = 0.d0
enddo
endif
phase = 1.d0
do k = 1, orb
do j = 1, N_int
det_tmp(j) = 0_bit_kind
enddo
call set_bit_to_integer(k,det_tmp,N_int)
accu_elec = 0
do j = 1, N_int
det_tmp_bis(j) = iand(det_tmp(j),(psi_in_out(j,spin_exc,i)))
accu_elec += popcnt(det_tmp_bis(j))
enddo
if(accu_elec == 1)then
phase = phase * -1.d0
endif
enddo
do j = 1, N_states_in
psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * phase
enddo
enddo
else if (hole_particle == -1)then
do i = 1, ndet
call clear_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int)
accu_elec = 0
do j = 1, N_int
accu_elec += popcnt(psi_in_out(j,spin_exc,i))
enddo
if(accu_elec .ne. elec_num_tab_local(spin_exc)-1)then
do j = 1, N_int
psi_in_out(j,1,i) = 0_bit_kind
psi_in_out(j,2,i) = 0_bit_kind
enddo
do j = 1, N_states_in
psi_in_out_coef(i,j) = 0.d0
enddo
endif
phase = 1.d0
do k = 1, orb-1
do j = 1, N_int
det_tmp(j) = 0_bit_kind
enddo
call set_bit_to_integer(k,det_tmp,N_int)
accu_elec = 0
do j = 1, N_int
det_tmp_bis(j) = iand(det_tmp(j),(psi_in_out(j,spin_exc,i)))
accu_elec += popcnt(det_tmp_bis(j))
enddo
if(accu_elec == 1)then
phase = phase * -1.d0
endif
enddo
do j = 1, N_states_in
psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * phase
enddo
enddo
endif
norm_out = 0.d0
do j = 1, N_states_in
do i = 1, ndet
norm_out(j) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j)
enddo
if(norm_out(j).le.1.d-10)then
norm_factor = 0.d0
else
norm_factor = 1.d0/(dsqrt(norm_out(j)))
endif
do i = 1, ndet
psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm_factor
enddo
enddo
end
double precision function diag_H_mat_elem_no_elec_check(det_in,Nint)
implicit none
BEGIN_DOC
! Computes <i|H|i>
END_DOC
integer,intent(in) :: Nint
integer(bit_kind),intent(in) :: det_in(Nint,2)
integer :: i, j, iorb, jorb
integer :: occ(Nint*bit_kind_size,2)
integer :: elec_num_tab_local(2)
double precision :: core_act
double precision :: alpha_alpha
double precision :: alpha_beta
double precision :: beta_beta
double precision :: mono_elec
core_act = 0.d0
alpha_alpha = 0.d0
alpha_beta = 0.d0
beta_beta = 0.d0
mono_elec = 0.d0
diag_H_mat_elem_no_elec_check = 0.d0
call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int)
call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int)
! alpha - alpha
! print*, 'elec_num_tab_local(1)',elec_num_tab_local(1)
! print*, 'elec_num_tab_local(2)',elec_num_tab_local(2)
do i = 1, elec_num_tab_local(1)
iorb = occ(i,1)
diag_H_mat_elem_no_elec_check += mo_mono_elec_integral(iorb,iorb)
mono_elec += mo_mono_elec_integral(iorb,iorb)
do j = i+1, elec_num_tab_local(1)
jorb = occ(j,1)
diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj_anti(jorb,iorb)
alpha_alpha += mo_bielec_integral_jj_anti(jorb,iorb)
enddo
enddo
! beta - beta
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
diag_H_mat_elem_no_elec_check += mo_mono_elec_integral(iorb,iorb)
mono_elec += mo_mono_elec_integral(iorb,iorb)
do j = i+1, elec_num_tab_local(2)
jorb = occ(j,2)
diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj_anti(jorb,iorb)
beta_beta += mo_bielec_integral_jj_anti(jorb,iorb)
enddo
enddo
! alpha - beta
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
do j = 1, elec_num_tab_local(1)
jorb = occ(j,1)
diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj(jorb,iorb)
alpha_beta += mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
! alpha - core-act
do i = 1, elec_num_tab_local(1)
iorb = occ(i,1)
do j = 1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb)
core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb)
enddo
enddo
! beta - core-act
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
do j = 1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb)
core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb)
enddo
enddo
! print*,'core_act = ',core_act
! print*,'alpha_alpha = ',alpha_alpha
! print*,'alpha_beta = ',alpha_beta
! print*,'beta_beta = ',beta_beta
! print*,'mono_elec = ',mono_elec
! do i = 1, n_core_inact_orb
! iorb = list_core_inact(i)
! diag_H_mat_elem_no_elec_check += 2.d0 * fock_core_inactive_total_spin_trace(iorb,1)
! enddo
!!!!!!!!!!!!
return
!!!!!!!!!!!!
! alpha - alpha
do i = 1, n_core_inact_orb
iorb = list_core_inact(i)
diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb)
do j = i+1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb)
enddo
enddo
do i = 1, n_core_inact_orb
iorb = list_core_inact(i)
diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb)
do j = i+1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb)
enddo
enddo
do i = 1, n_core_inact_orb
iorb = list_core_inact(i)
do j = 1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
end
subroutine i_H_j_dyall(key_i,key_j,Nint,hij)
use bitmasks
implicit none
BEGIN_DOC
! Returns <i|H|j> where i and j are determinants
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hij
integer :: exc(0:2,2,2)
integer :: degree
double precision :: get_mo_bielec_integral
integer :: m,n,p,q
integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem_no_elec_check, phase,phase_2
integer :: n_occ_ab(2)
logical :: has_mipi(Nint*bit_kind_size)
double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size)
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
hij = 0.d0
!DIR$ FORCEINLINE
call get_excitation_degree(key_i,key_j,degree,Nint)
select case (degree)
case (2)
call get_double_excitation(key_i,key_j,exc,phase,Nint)
if (exc(0,1,1) == 1) then
! Mono alpha, mono beta
hij = phase*get_mo_bielec_integral( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map)
else if (exc(0,1,1) == 2) then
! Double alpha
hij = phase*(get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map) - &
get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(2,2,1), &
exc(1,2,1) ,mo_integrals_map) )
else if (exc(0,1,2) == 2) then
! Double beta
hij = phase*(get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map) - &
get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(2,2,2), &
exc(1,2,2) ,mo_integrals_map) )
endif
case (1)
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
!DIR$ FORCEINLINE
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
has_mipi = .False.
if (exc(0,1,1) == 1) then
! Mono alpha
m = exc(1,1,1)
p = exc(1,2,1)
do k = 1, n_occ_ab(1)
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, n_occ_ab(2)
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, n_occ_ab(1)
hij = hij + mipi(occ(k,1)) - miip(occ(k,1))
enddo
do k = 1, n_occ_ab(2)
hij = hij + mipi(occ(k,2))
enddo
else
! Mono beta
m = exc(1,1,2)
p = exc(1,2,2)
do k = 1, n_occ_ab(2)
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, n_occ_ab(1)
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, n_occ_ab(1)
hij = hij + mipi(occ(k,1))
enddo
do k = 1, n_occ_ab(2)
hij = hij + mipi(occ(k,2)) - miip(occ(k,2))
enddo
endif
hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) )
case (0)
hij = diag_H_mat_elem_no_elec_check(key_i,Nint)
end select
end
subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target)
use bitmasks
implicit none
integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target
integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in)
double precision, intent(in) :: psi_in_coef(dim_psi_coef,N_states_in)
double precision, intent(out) :: energies(N_states_in)
integer :: i,j
double precision :: hij,accu
energies = 0.d0
accu = 0.d0
double precision, allocatable :: psi_coef_tmp(:)
allocate(psi_coef_tmp(ndet))
do i = 1, ndet
psi_coef_tmp(i) = psi_in_coef(i,state_target)
enddo
double precision :: hij_bis
do i = 1, ndet
if(psi_coef_tmp(i)==0.d0)cycle
do j = 1, ndet
if(psi_coef_tmp(j)==0.d0)cycle
call i_H_j_dyall(psi_in(1,1,i),psi_in(1,1,j),N_int,hij)
accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij
enddo
enddo
energies(state_target) = accu
deallocate(psi_coef_tmp)
end
double precision function coulomb_value_no_check(det_in,Nint)
implicit none
BEGIN_DOC
! Computes <i|H|i>
END_DOC
integer,intent(in) :: Nint
integer(bit_kind),intent(in) :: det_in(Nint,2)
integer :: i, j, iorb, jorb
integer :: occ(Nint*bit_kind_size,2)
integer :: elec_num_tab_local(2)
double precision :: core_act
double precision :: alpha_alpha
double precision :: alpha_beta
double precision :: beta_beta
double precision :: mono_elec
core_act = 0.d0
alpha_alpha = 0.d0
alpha_beta = 0.d0
beta_beta = 0.d0
mono_elec = 0.d0
coulomb_value_no_check = 0.d0
call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int)
call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int)
! alpha - alpha
do i = 1, elec_num_tab_local(1)
iorb = occ(i,1)
do j = i+1, elec_num_tab_local(1)
jorb = occ(j,1)
coulomb_value_no_check += mo_bielec_integral_jj_anti(jorb,iorb)
alpha_alpha += mo_bielec_integral_jj_anti(jorb,iorb)
enddo
enddo
! beta - beta
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
do j = i+1, elec_num_tab_local(2)
jorb = occ(j,2)
coulomb_value_no_check += mo_bielec_integral_jj_anti(jorb,iorb)
beta_beta += mo_bielec_integral_jj_anti(jorb,iorb)
enddo
enddo
! alpha - beta
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
do j = 1, elec_num_tab_local(1)
jorb = occ(j,1)
coulomb_value_no_check += mo_bielec_integral_jj(jorb,iorb)
alpha_beta += mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
end
subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij)
use bitmasks
implicit none
BEGIN_DOC
! Returns <i|H|j> where i and j are determinants
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hij
integer :: exc(0:2,2,2)
integer :: degree
double precision :: get_mo_bielec_integral
integer :: m,n,p,q
integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem_no_elec_check_no_exchange, phase,phase_2
integer :: n_occ_ab(2)
logical :: has_mipi(Nint*bit_kind_size)
double precision :: mipi(Nint*bit_kind_size)
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
hij = 0.d0
!DIR$ FORCEINLINE
call get_excitation_degree(key_i,key_j,degree,Nint)
select case (degree)
case (2)
call get_double_excitation(key_i,key_j,exc,phase,Nint)
if (exc(0,1,1) == 1) then
! Mono alpha, mono beta
if(exc(1,1,1) == exc(1,2,2) .and. exc(1,2,1) == exc(1,1,2))then
hij = 0.d0
else
hij = phase*get_mo_bielec_integral( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map)
endif
else if (exc(0,1,1) == 2) then
! Double alpha
hij = phase*get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map)
else if (exc(0,1,2) == 2) then
! Double beta
hij = phase*get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map)
endif
case (1)
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
!DIR$ FORCEINLINE
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
has_mipi = .False.
if (exc(0,1,1) == 1) then
! Mono alpha
m = exc(1,1,1)
p = exc(1,2,1)
do k = 1, n_occ_ab(1)
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, n_occ_ab(2)
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, n_occ_ab(1)
hij = hij + mipi(occ(k,1))
enddo
do k = 1, n_occ_ab(2)
hij = hij + mipi(occ(k,2))
enddo
else
! Mono beta
m = exc(1,1,2)
p = exc(1,2,2)
do k = 1, n_occ_ab(2)
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, n_occ_ab(1)
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, n_occ_ab(1)
hij = hij + mipi(occ(k,1))
enddo
do k = 1, n_occ_ab(2)
hij = hij + mipi(occ(k,2))
enddo
endif
hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) )
case (0)
hij = diag_H_mat_elem_no_elec_check_no_exchange(key_i,Nint)
end select
end
double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint)
implicit none
BEGIN_DOC
! Computes <i|H|i>
END_DOC
integer,intent(in) :: Nint
integer(bit_kind),intent(in) :: det_in(Nint,2)
integer :: i, j, iorb, jorb
integer :: occ(Nint*bit_kind_size,2)
integer :: elec_num_tab_local(2)
double precision :: core_act_exchange(2)
core_act_exchange = 0.d0
diag_H_mat_elem_no_elec_check_no_exchange = 0.d0
call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int)
call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int)
! alpha - alpha
do i = 1, elec_num_tab_local(1)
iorb = occ(i,1)
diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb)
do j = i+1, elec_num_tab_local(1)
jorb = occ(j,1)
diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
! beta - beta
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb)
do j = i+1, elec_num_tab_local(2)
jorb = occ(j,2)
diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
! alpha - beta
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
do j = 1, elec_num_tab_local(1)
jorb = occ(j,1)
diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
! alpha - core-act
do i = 1, elec_num_tab_local(1)
iorb = occ(i,1)
do j = 1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb)
core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb)
enddo
enddo
! beta - core-act
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
do j = 1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb)
core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb)
enddo
enddo
end
subroutine u0_H_dyall_u0_no_exchange(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target)
use bitmasks
implicit none
integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target
integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in)
double precision, intent(in) :: psi_in_coef(dim_psi_coef,N_states_in)
double precision, intent(out) :: energies(N_states_in)
integer :: i,j
double precision :: hij,accu
energies = 0.d0
accu = 0.d0
double precision, allocatable :: psi_coef_tmp(:)
allocate(psi_coef_tmp(ndet))
do i = 1, ndet
psi_coef_tmp(i) = psi_in_coef(i,state_target)
enddo
double precision :: hij_bis
do i = 1, ndet
if(psi_coef_tmp(i)==0.d0)cycle
do j = 1, ndet
if(psi_coef_tmp(j)==0.d0)cycle
call i_H_j_dyall_no_exchange(psi_in(1,1,i),psi_in(1,1,j),N_int,hij)
accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij
enddo
enddo
energies(state_target) = accu
deallocate(psi_coef_tmp)
end

210
plugins/MRPT_Utils/fock_like_operators.irp.f Normal file
View File

@ -0,0 +1,210 @@
BEGIN_PROVIDER [double precision, fock_core_inactive, (mo_tot_num)]
BEGIN_DOC
! inactive part of the fock operator with contributions only from the inactive
END_DOC
implicit none
integer :: i,j
double precision :: accu
integer :: j_inact_core_orb,i_inact_core_orb
do i = 1, n_core_inact_orb
accu = 0.d0
i_inact_core_orb = list_core_inact(i)
do j = 1, n_core_inact_orb
j_inact_core_orb = list_core_inact(j)
accu += 2.d0 * mo_bielec_integral_jj(i_inact_core_orb,j_inact_core_orb) &
- mo_bielec_integral_jj_exchange(i_inact_core_orb,j_inact_core_orb)
enddo
fock_core_inactive(i_inact_core_orb) = accu + mo_mono_elec_integral(i_inact_core_orb,i_inact_core_orb)
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, fock_virt_from_core_inact, (mo_tot_num)]
BEGIN_DOC
! fock operator for the virtuals that comes from the doubly occupied orbitals
END_DOC
implicit none
integer :: i,j
double precision :: accu
integer :: j_inact_core_orb,i_virt_orb
do i = 1, n_virt_orb
accu = 0.d0
i_virt_orb = list_virt(i)
do j = 1, n_core_inact_orb
! do j = 1, elec_alpha_num
! j_inact_core_orb = j
j_inact_core_orb = list_core_inact(j)
accu += 2.d0 * mo_bielec_integral_jj(i_virt_orb,j_inact_core_orb) &
- mo_bielec_integral_jj_exchange(i_virt_orb,j_inact_core_orb)
enddo
fock_virt_from_core_inact(i_virt_orb) = accu
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, fock_core_inactive_from_act, (mo_tot_num,2,N_states)]
BEGIN_DOC
! inactive part of the fock operator with contributions only from the active
END_DOC
implicit none
integer :: i,j,k
double precision :: accu_coulomb,accu_exchange(2)
double precision :: na,nb,ntot
double precision :: coulomb, exchange
double precision :: get_mo_bielec_integral
integer :: j_act_orb,k_act_orb,i_inact_core_orb
integer :: i_state
do i_state = 1,N_states
do i = 1, n_core_inact_orb
accu_coulomb = 0.d0
accu_exchange = 0.d0
i_inact_core_orb = list_core_inact(i)
do j = 1, n_act_orb
j_act_orb = list_act(j)
na = one_body_dm_mo_alpha(j_act_orb,j_act_orb,i_state)
nb = one_body_dm_mo_beta(j_act_orb,j_act_orb,i_state)
ntot = na + nb
coulomb = mo_bielec_integral_jj(i_inact_core_orb,j_act_orb)
exchange = mo_bielec_integral_jj_exchange(i_inact_core_orb,j_act_orb)
accu_coulomb += ntot * coulomb
accu_exchange(1) += na * exchange
accu_exchange(2) += nb * exchange
do k = j+1, n_act_orb
k_act_orb = list_act(k)
na = one_body_dm_mo_alpha(j_act_orb,k_act_orb,i_state)
nb = one_body_dm_mo_beta(j_act_orb,k_act_orb,i_state)
ntot = na + nb
coulomb = get_mo_bielec_integral(j_act_orb,i_inact_core_orb,k_act_orb,i_inact_core_orb,mo_integrals_map)
exchange = get_mo_bielec_integral(j_act_orb,k_act_orb,i_inact_core_orb,i_inact_core_orb,mo_integrals_map)
accu_coulomb += 2.d0 * ntot * coulomb
accu_exchange(1) += 2.d0 * na * exchange
accu_exchange(2) += 2.d0 * nb * exchange
enddo
enddo
fock_core_inactive_from_act(i_inact_core_orb,1,i_state) = accu_coulomb - accu_exchange(1)
fock_core_inactive_from_act(i_inact_core_orb,2,i_state) = accu_coulomb - accu_exchange(2)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, fock_virt_from_act, (mo_tot_num,2,N_states)]
BEGIN_DOC
! virtual part of the fock operator with contributions only from the active
END_DOC
implicit none
integer :: i,j,k
double precision :: accu_coulomb,accu_exchange(2)
double precision :: na,nb,ntot
double precision :: coulomb, exchange
double precision :: get_mo_bielec_integral
integer :: j_act_orb,i_virt_orb,k_act_orb
integer :: i_state
! TODO : inverse loop of i_state
do i_state = 1, N_states
do i = 1, n_virt_orb
accu_coulomb = 0.d0
accu_exchange = 0.d0
i_virt_orb = list_virt(i)
do j = 1, n_act_orb
j_act_orb = list_act(j)
na = one_body_dm_mo_alpha(j_act_orb,j_act_orb,i_state)
nb = one_body_dm_mo_beta(j_act_orb,j_act_orb,i_state)
ntot = na + nb
coulomb = mo_bielec_integral_jj(i_virt_orb,j_act_orb)
exchange = mo_bielec_integral_jj_exchange(i_virt_orb,j_act_orb)
accu_coulomb += ntot * coulomb
accu_exchange(1) += na * exchange
accu_exchange(2) += nb * exchange
do k = j+1, n_act_orb
k_act_orb = list_act(k)
na = one_body_dm_mo_alpha(j_act_orb,k_act_orb,i_state)
nb = one_body_dm_mo_beta(j_act_orb,k_act_orb,i_state)
ntot = na + nb
coulomb = get_mo_bielec_integral(j_act_orb,i_virt_orb,k_act_orb,i_virt_orb,mo_integrals_map)
exchange = get_mo_bielec_integral(j_act_orb,k_act_orb,i_virt_orb,i_virt_orb,mo_integrals_map)
accu_coulomb += 2.d0 * ntot * coulomb
accu_exchange(1) += 2.d0 * na * exchange
accu_exchange(2) += 2.d0 * nb * exchange
enddo
enddo
fock_virt_from_act(i_virt_orb,1,i_state) = accu_coulomb - accu_exchange(1)
fock_virt_from_act(i_virt_orb,2,i_state) = accu_coulomb - accu_exchange(2)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, fock_core_inactive_total, (mo_tot_num,2,N_states)]
&BEGIN_PROVIDER [double precision, fock_core_inactive_total_spin_trace, (mo_tot_num,N_states)]
BEGIN_DOC
! inactive part of the fock operator
END_DOC
implicit none
integer :: i
integer :: i_inact_core_orb
integer :: i_state
do i_state = 1, N_states
do i = 1, n_core_inact_orb
i_inact_core_orb = list_core_inact(i)
fock_core_inactive_total(i_inact_core_orb,1,i_state) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,1,i_state)
fock_core_inactive_total(i_inact_core_orb,2,i_state) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,2,i_state)
fock_core_inactive_total_spin_trace(i_inact_core_orb,i_state) = 0.5d0 * (fock_core_inactive_total(i_inact_core_orb,1,i_state) + fock_core_inactive_total(i_inact_core_orb,2,i_state))
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, fock_virt_total, (mo_tot_num,2,N_states)]
&BEGIN_PROVIDER [double precision, fock_virt_total_spin_trace, (mo_tot_num,N_states)]
BEGIN_DOC
! inactive part of the fock operator
END_DOC
implicit none
integer :: i
integer :: i_virt_orb
integer :: i_state
do i_state = 1, N_states
do i = 1, n_virt_orb
i_virt_orb= list_virt(i)
fock_virt_total(i_virt_orb,1,i_state) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,1,i_state)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb)
fock_virt_total(i_virt_orb,2,i_state) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,2,i_state)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb)
fock_virt_total_spin_trace(i_virt_orb,i_state) = 0.5d0 * ( fock_virt_total(i_virt_orb,1,i_state) + fock_virt_total(i_virt_orb,2,i_state) )
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, fock_operator_active_from_core_inact, (mo_tot_num,mo_tot_num)]
BEGIN_DOC
! active part of the fock operator with contributions only from the inactive
END_DOC
implicit none
integer :: i,j,k,k_inact_core_orb
integer :: iorb,jorb
double precision :: accu
double precision :: get_mo_bielec_integral,coulomb, exchange
PROVIDE mo_bielec_integrals_in_map
fock_operator_active_from_core_inact = 0.d0
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
accu = 0.d0
do k = 1, n_core_inact_orb
k_inact_core_orb = list_core_inact(k)
coulomb = get_mo_bielec_integral(k_inact_core_orb,iorb,k_inact_core_orb,jorb,mo_integrals_map)
exchange = get_mo_bielec_integral(k_inact_core_orb,jorb,iorb,k_inact_core_orb,mo_integrals_map)
accu += 2.d0 * coulomb - exchange
enddo
fock_operator_active_from_core_inact(iorb,jorb) = accu
enddo
enddo
END_PROVIDER

186
plugins/MRPT_Utils/mrpt_dress.irp.f Normal file
View File

@ -0,0 +1,186 @@
use omp_lib
use bitmasks
BEGIN_PROVIDER [ integer(omp_lock_kind), psi_ref_bis_lock, (psi_det_size) ]
implicit none
BEGIN_DOC
! Locks on ref determinants to fill delta_ij
END_DOC
integer :: i
do i=1,psi_det_size
call omp_init_lock( psi_ref_bis_lock(i) )
enddo
END_PROVIDER
subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,iproc,key_mask)
use bitmasks
implicit none
integer, intent(in) :: i_generator,n_selected, Nint, iproc
integer, intent(in) :: Ndet
integer(bit_kind),intent(in) :: key_mask(Nint, 2)
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
double precision, intent(inout) :: delta_ij_(Ndet,Ndet,*)
integer :: i,j,k,l
integer :: idx_alpha(0:psi_det_size)
integer :: degree_alpha(psi_det_size)
logical :: fullMatch
double precision :: delta_e_inv_array(psi_det_size,N_states)
double precision :: hij_array(psi_det_size)
integer(bit_kind) :: tq(Nint,2,n_selected)
integer :: N_tq
double precision :: hialpha,hij
integer :: i_state, i_alpha
integer(bit_kind),allocatable :: miniList(:,:,:)
integer,allocatable :: idx_miniList(:)
integer :: N_miniList, leng
double precision :: delta_e(N_states),hij_tmp
integer :: index_i,index_j
double precision :: phase_array(N_det),phase
integer :: exc(0:2,2,2),degree
leng = max(N_det_generators, N_det)
allocate(miniList(Nint, 2, leng), idx_miniList(leng))
!create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint)
call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint)
if(fullMatch) then
return
end if
call find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
if(N_tq > 0) then
call create_minilist(key_mask, psi_det, miniList, idx_miniList, N_det, N_minilist, Nint)
end if
do i_alpha=1,N_tq
call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
do j=1,idx_alpha(0)
idx_alpha(j) = idx_miniList(idx_alpha(j))
enddo
! double precision :: ihpsi0,coef_pert
! ihpsi0 = 0.d0
! coef_pert = 0.d0
phase_array =0.d0
do i = 1,idx_alpha(0)
index_i = idx_alpha(i)
call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha)
double precision :: coef_array(N_states)
do i_state = 1, N_states
coef_array(i_state) = psi_coef(index_i,i_state)
enddo
call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e)
hij_array(index_i) = hialpha
call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int)
! phase_array(index_i) = phase
do i_state = 1,N_states
delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state)
enddo
enddo
do i=1,idx_alpha(0)
index_i = idx_alpha(i)
hij_tmp = hij_array(index_i)
call omp_set_lock( psi_ref_bis_lock(index_i) )
do j = 1, idx_alpha(0)
index_j = idx_alpha(j)
! call get_excitation(psi_det(1,1,index_i),psi_det(1,1,index_i),exc,degree,phase,N_int)
! if(index_j.ne.index_i)then
! if(phase_array(index_j) * phase_array(index_i) .ne. phase)then
! print*, phase_array(index_j) , phase_array(index_i) ,phase
! call debug_det(psi_det(1,1,index_i),N_int)
! call debug_det(psi_det(1,1,index_j),N_int)
! call debug_det(tq(1,1,i_alpha),N_int)
! stop
! endif
! endif
do i_state=1,N_states
! standard dressing first order
delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state)
enddo
enddo
call omp_unset_lock( psi_ref_bis_lock(index_i))
enddo
enddo
deallocate(miniList, idx_miniList)
end
BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ]
gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators)
gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators)
call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int)
call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int)
END_PROVIDER
subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList)
use bitmasks
implicit none
integer, intent(in) :: i_generator,n_selected, Nint
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
integer :: i,j,k,m
logical :: is_in_wavefunction
integer :: degree(psi_det_size)
integer :: idx(0:psi_det_size)
logical :: good
integer(bit_kind), intent(out) :: tq(Nint,2,n_selected)
integer, intent(out) :: N_tq
integer :: nt,ni
logical, external :: is_connected_to
integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators)
integer,intent(in) :: N_miniList
N_tq = 0
i_loop : do i=1,N_selected
if(is_connected_to(det_buffer(1,1,i), miniList, Nint, N_miniList)) then
cycle
end if
if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then
N_tq += 1
do k=1,N_int
tq(k,1,N_tq) = det_buffer(k,1,i)
tq(k,2,N_tq) = det_buffer(k,2,i)
enddo
endif
enddo i_loop
end

369
plugins/MRPT_Utils/mrpt_utils.irp.f Normal file
View File

@ -0,0 +1,369 @@
BEGIN_PROVIDER [ double precision, delta_ij, (N_det,N_det,N_states) ]
&BEGIN_PROVIDER [ double precision, second_order_pt_new, (N_states) ]
&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h, (N_states) ]
&BEGIN_PROVIDER [ double precision, second_order_pt_new_1p, (N_states) ]
&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h1p, (N_states) ]
&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h, (N_states) ]
&BEGIN_PROVIDER [ double precision, second_order_pt_new_2p, (N_states) ]
&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h2p, (N_states) ]
&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h1p, (N_states) ]
&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h2p, (N_states) ]
implicit none
BEGIN_DOC
! Dressing matrix in N_det basis
END_DOC
integer :: i,j,m
integer :: i_state
double precision :: accu(N_states)
double precision, allocatable :: delta_ij_tmp(:,:,:)
delta_ij = 0.d0
allocate (delta_ij_tmp(N_det,N_det,N_states))
! 1h
delta_ij_tmp = 0.d0
call H_apply_mrpt_1h(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_1h(i_state) = accu(i_state)
enddo
print*, '1h = ',accu
! 1p
delta_ij_tmp = 0.d0
call H_apply_mrpt_1p(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_1p(i_state) = accu(i_state)
enddo
print*, '1p = ',accu
! 1h1p
delta_ij_tmp = 0.d0
call H_apply_mrpt_1h1p(delta_ij_tmp,N_det)
double precision :: e_corr_from_1h1p_singles(N_states)
!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles)
!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_1h1p(i_state) = accu(i_state)
enddo
print*, '1h1p = ',accu
! 1h1p third order
if(do_third_order_1h1p)then
delta_ij_tmp = 0.d0
call give_1h1p_sec_order_singles_contrib(delta_ij_tmp)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_1h1p(i_state) = accu(i_state)
enddo
print*, '1h1p(3)',accu
endif
! 2h
delta_ij_tmp = 0.d0
call H_apply_mrpt_2h(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_2h(i_state) = accu(i_state)
enddo
print*, '2h = ',accu
! 2p
delta_ij_tmp = 0.d0
call H_apply_mrpt_2p(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_2p(i_state) = accu(i_state)
enddo
print*, '2p = ',accu
! 1h2p
delta_ij_tmp = 0.d0
!call give_1h2p_contrib(delta_ij_tmp)
call H_apply_mrpt_1h2p(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_1h2p(i_state) = accu(i_state)
enddo
print*, '1h2p = ',accu
! 2h1p
delta_ij_tmp = 0.d0
!call give_2h1p_contrib(delta_ij_tmp)
call H_apply_mrpt_2h1p(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_2h1p(i_state) = accu(i_state)
enddo
print*, '2h1p = ',accu
! 2h2p
!delta_ij_tmp = 0.d0
!call H_apply_mrpt_2h2p(delta_ij_tmp,N_det)
!accu = 0.d0
!do i_state = 1, N_states
!do i = 1, N_det
! do j = 1, N_det
! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
! enddo
!enddo
!second_order_pt_new_2h2p(i_state) = accu(i_state)
!enddo
!print*, '2h2p = ',accu
double precision :: contrib_2h2p(N_states)
call give_2h2p(contrib_2h2p)
do i_state = 1, N_states
do i = 1, N_det
delta_ij(i,i,i_state) += contrib_2h2p(i_state)
enddo
second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state)
enddo
print*, '2h2p = ',contrib_2h2p(1)
! total
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
! write(*,'(1000(F16.10,x))')delta_ij(i,:,:)
do j = i_state, N_det
accu(i_state) += delta_ij(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
enddo
enddo
second_order_pt_new(i_state) = accu(i_state)
print*, 'total= ',accu(i_state)
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new, (N_det,N_det,N_states)]
implicit none
integer :: i,j,i_state
do i_state = 1, N_states
do i = 1,N_det
do j = 1,N_det
Hmatrix_dressed_pt2_new(j,i,i_state) = H_matrix_all_dets(j,i) + delta_ij(j,i,i_state)
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new_symmetrized, (N_det,N_det,N_states)]
implicit none
integer :: i,j,i_state
do i_state = 1, N_states
do i = 1,N_det
do j = i,N_det
Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) = H_matrix_all_dets(j,i) &
+ 0.5d0 * ( delta_ij(j,i,i_state) + delta_ij(i,j,i_state) )
Hmatrix_dressed_pt2_new_symmetrized(i,j,i_state) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state)
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag) ]
BEGIN_DOC
! Eigenvectors/values of the CI matrix
END_DOC
implicit none
double precision :: ovrlp,u_dot_v
integer :: i_good_state
integer, allocatable :: index_good_state_array(:)
logical, allocatable :: good_state_array(:)
double precision, allocatable :: s2_values_tmp(:)
integer :: i_other_state
double precision, allocatable :: eigenvectors(:,:), eigenvalues(:)
integer :: i_state
double precision :: s2,e_0
integer :: i,j,k
double precision, allocatable :: s2_eigvalues(:)
double precision, allocatable :: e_array(:)
integer, allocatable :: iorder(:)
! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors
do j=1,min(N_states_diag,N_det)
do i=1,N_det
CI_dressed_pt2_new_eigenvectors(i,j) = psi_coef(i,j)
enddo
enddo
do j=N_det+1,N_states_diag
do i=1,N_det
CI_dressed_pt2_new_eigenvectors(i,j) = 0.d0
enddo
enddo
if (diag_algorithm == "Davidson") then
print*, 'Davidson not yet implemented for the dressing ... '
stop
else if (diag_algorithm == "Lapack") then
allocate (eigenvectors(size(H_matrix_all_dets,1),N_det))
allocate (eigenvalues(N_det))
call lapack_diag(eigenvalues,eigenvectors, &
Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det,N_det)
CI_electronic_dressed_pt2_new_energy(:) = 0.d0
if (s2_eig) then
i_state = 0
allocate (s2_eigvalues(N_det))
allocate(index_good_state_array(N_det),good_state_array(N_det))
good_state_array = .False.
do j=1,N_det
call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2)
s2_eigvalues(j) = s2
! Select at least n_states states with S^2 values closed to "expected_s2"
if(dabs(s2-expected_s2).le.0.3d0)then
i_state +=1
index_good_state_array(i_state) = j
good_state_array(j) = .True.
endif
if(i_state.eq.N_states) then
exit
endif
enddo
if(i_state .ne.0)then
! Fill the first "i_state" states that have a correct S^2 value
do j = 1, i_state
do i=1,N_det
CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j))
enddo
CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(index_good_state_array(j))
CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j))
enddo
i_other_state = 0
do j = 1, N_det
if(good_state_array(j))cycle
i_other_state +=1
if(i_state+i_other_state.gt.n_states_diag)then
exit
endif
call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2)
do i=1,N_det
CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j)
enddo
CI_electronic_dressed_pt2_new_energy(i_state+i_other_state) = eigenvalues(j)
CI_dressed_pt2_new_eigenvectors_s2(i_state+i_other_state) = s2
enddo
deallocate(index_good_state_array,good_state_array)
else
print*,''
print*,'!!!!!!!! WARNING !!!!!!!!!'
print*,' Within the ',N_det,'determinants selected'
print*,' and the ',N_states_diag,'states requested'
print*,' We did not find any state with S^2 values close to ',expected_s2
print*,' We will then set the first N_states eigenvectors of the H matrix'
print*,' as the CI_dressed_pt2_new_eigenvectors'
print*,' You should consider more states and maybe ask for diagonalize_s2 to be .True. or just enlarge the CI space'
print*,''
do j=1,min(N_states_diag,N_det)
do i=1,N_det
CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j)
enddo
CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j)
CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(j)
enddo
endif
deallocate(s2_eigvalues)
else
! Select the "N_states_diag" states of lowest energy
do j=1,min(N_det,N_states_diag)
call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2)
do i=1,N_det
CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j)
enddo
CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j)
CI_dressed_pt2_new_eigenvectors_s2(j) = s2
enddo
endif
deallocate(eigenvectors,eigenvalues)
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ]
implicit none
BEGIN_DOC
! N_states lowest eigenvalues of the CI matrix
END_DOC
integer :: j
character*(8) :: st
call write_time(output_determinants)
do j=1,N_states_diag
CI_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion
write(st,'(I4)') j
call write_double(output_determinants,CI_dressed_pt2_new_energy(j),'Energy of state '//trim(st))
call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st))
enddo
END_PROVIDER

958
plugins/MRPT_Utils/new_way.irp.f Normal file
View File

@ -0,0 +1,958 @@
subroutine give_2h1p_contrib(matrix_2h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb
integer :: ispin,jspin
integer :: idet,jdet
integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2)
double precision :: perturb_dets_phase(n_act_orb,2,2)
double precision :: perturb_dets_hij(n_act_orb,2,2)
double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states)
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
!matrix_2h1p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do j = 1, n_inact_orb ! Second inactive
jorb = list_inact(j)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
! take all the integral you will need for i,j,r fixed
do a = 1, n_act_orb
aorb = list_act(a)
active_int(a,1) = get_mo_bielec_integral(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct
active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange
enddo
integer :: degree(N_det)
integer :: idx(0:N_det)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,3)
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a)
if(ispin == jspin .and. iorb.le.jorb)cycle ! condition not to double count
do a = 1, n_act_orb ! First active
aorb = list_act(a)
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
! Do the excitation inactive -- > active
call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin
call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
accu_elec= 0
do inint = 1, N_int
accu_elec+= popcnt(det_tmp(inint,jspin))
enddo
if(accu_elec .ne. elec_num_tab_local(jspin))then
perturb_dets_phase(a,jspin,ispin) = 0.0
perturb_dets_hij(a,jspin,ispin) = 0.d0
do istate = 1, N_states
coef_perturb_from_idet(a,jspin,ispin,istate) = 0.d0
enddo
cycle
endif
do inint = 1, N_int
perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1)
perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
perturb_dets_phase(a,jspin,ispin) = phase
do istate = 1, N_states
delta_e(a,jspin,istate) = one_creat(a,jspin,istate) &
- fock_virt_total_spin_trace(rorb,istate) &
+ fock_core_inactive_total_spin_trace(iorb,istate) &
+ fock_core_inactive_total_spin_trace(jorb,istate)
enddo
if(ispin == jspin)then
perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,2) - active_int(a,1) )
else
perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1)
endif
!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet
!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin)
do istate = 1, N_states
coef_perturb_from_idet(a,jspin,ispin,istate) = perturb_dets_hij(a,jspin,ispin) / delta_e(a,jspin,istate)
enddo
enddo
enddo
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS
!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a_{b} a^{\dagger}_a | Idet>
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_a
index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,1,1)) !!! a_{b}
index_orb_act_mono(idx(jdet),3) = 1
else
! Mono beta
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_a
index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,1,2)) !!! a_{b}
index_orb_act_mono(idx(jdet),3) = 2
endif
else
index_orb_act_mono(idx(jdet),1) = -1
endif
enddo
integer :: kspin
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator
! are connected by the presence of the perturbers determinants |det_tmp>
aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb}
borb = index_orb_act_mono(idx(jdet),2) ! a_{borb}
kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation
! the determinants Idet and Jdet interact throw the following operator
! | Jdet > = a_{borb,kspin} a^{\dagger}_{aorb, kspin} | Idet >
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{i} (ispin)
if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet >
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin)
enddo
double precision :: hja
! you determine the interaction between the excited determinant and the other parent | Jdet >
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet >
! hja = < det_tmp | H | Jdet >
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
if(kspin == ispin)then
hja = phase * (active_int(borb,2) - active_int(borb,1) )
else
hja = phase * active_int(borb,1)
endif
do istate = 1, N_states
matrix_2h1p(idx(jdet),idet,istate) += hja * coef_perturb_from_idet(aorb,kspin,ispin,istate)
enddo
enddo ! ispin
else
! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations
!
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet >
do ispin = 1, 2
do kspin = 1, 2
if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count
do a = 1, n_act_orb ! First active
do istate = 1, N_states
matrix_2h1p(idet,idet,istate) += coef_perturb_from_idet(a,kspin,ispin,istate) * perturb_dets_hij(a,kspin,ispin)
enddo
enddo
enddo
enddo
endif
enddo
enddo
enddo
enddo
enddo
end
subroutine give_1h2p_contrib(matrix_1h2p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*)
integer :: i,v,r,a,b
integer :: iorb, vorb, rorb, aorb, borb
integer :: ispin,jspin
integer :: idet,jdet
integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2)
double precision :: perturb_dets_phase(n_act_orb,2,2)
double precision :: perturb_dets_hij(n_act_orb,2,2)
double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states)
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
!matrix_1h2p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do v = 1, n_virt_orb ! First virtual
vorb = list_virt(v)
do r = 1, n_virt_orb ! Second virtual
rorb = list_virt(r)
! take all the integral you will need for i,j,r fixed
do a = 1, n_act_orb
aorb = list_act(a)
active_int(a,1) = get_mo_bielec_integral(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct
active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange
enddo
integer :: degree(N_det)
integer :: idx(0:N_det)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,3)
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb)
do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb)
do a = 1, n_act_orb ! First active
aorb = list_act(a)
if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
! Do the excitation active -- > virtual
call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin
call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
accu_elec= 0
do inint = 1, N_int
accu_elec+= popcnt(det_tmp(inint,jspin))
enddo
if(accu_elec .ne. elec_num_tab_local(jspin))then
perturb_dets_phase(a,jspin,ispin) = 0.0
perturb_dets_hij(a,jspin,ispin) = 0.d0
do istate = 1, N_states
coef_perturb_from_idet(a,jspin,ispin,istate) = 0.d0
enddo
cycle
endif
do inint = 1, N_int
perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1)
perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2)
enddo
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,a,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
perturb_dets_phase(a,jspin,ispin) = phase
do istate = 1, N_states
delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) &
- fock_virt_total_spin_trace(rorb,istate) &
- fock_virt_total_spin_trace(vorb,istate) &
+ fock_core_inactive_total_spin_trace(iorb,istate)
enddo
if(ispin == jspin)then
perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) )
else
perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1)
endif
!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet
!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin)
do istate = 1, N_states
coef_perturb_from_idet(a,jspin,ispin,istate) = perturb_dets_hij(a,jspin,ispin) / delta_e(a,jspin,istate)
enddo
enddo
enddo
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS
!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a^{\dagger}_b a_{a} | Idet>
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a
index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b}
index_orb_act_mono(idx(jdet),3) = 1
else
! Mono beta
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,2)) !!! a_a
index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b}
index_orb_act_mono(idx(jdet),3) = 2
endif
else
index_orb_act_mono(idx(jdet),1) = -1
endif
enddo
integer :: kspin
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator
! are connected by the presence of the perturbers determinants |det_tmp>
aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb}
borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb}
kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation
! the determinants Idet and Jdet interact throw the following operator
! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet >
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{i} (ispin)
if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet >
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin)
enddo
double precision :: hja
! you determine the interaction between the excited determinant and the other parent | Jdet >
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{borb,kspin} a_{iorb,ispin} | Jdet >
! hja = < det_tmp | H | Jdet >
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
if(kspin == ispin)then
hja = phase * (active_int(borb,1) - active_int(borb,2) )
else
hja = phase * active_int(borb,1)
endif
do istate = 1, N_states
matrix_1h2p(idx(jdet),idet,istate) += hja * coef_perturb_from_idet(aorb,kspin,ispin,istate)
enddo
enddo ! ispin
else
! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations
!
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet >
do ispin = 1, 2
do kspin = 1, 2
do a = 1, n_act_orb ! First active
aorb = list_act(a)
if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count
do istate = 1, N_states
matrix_1h2p(idet,idet,istate) += coef_perturb_from_idet(a,kspin,ispin,istate) * perturb_dets_hij(a,kspin,ispin)
enddo
enddo
enddo
enddo
endif
enddo
enddo
enddo
enddo
enddo
end
subroutine give_1h1p_contrib(matrix_1h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb
integer :: ispin,jspin
integer :: idet,jdet
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: istate
double precision :: hja,delta_e_inact_virt(N_states)
integer :: kspin,degree_scalar
!matrix_1h1p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
do j = 1, N_states
delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) &
- fock_virt_total_spin_trace(rorb,j)
enddo
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations
do jdet = 1, idx(0)
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
double precision :: himono,delta_e(N_states),coef_mono(N_states)
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono)
do state_target = 1, N_states
! delta_e(state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target)
delta_e(state_target) = one_anhil_one_creat_inact_virt_bis(i,r,idet,state_target)
coef_mono(state_target) = himono / delta_e(state_target)
enddo
if(idx(jdet).ne.idet)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
aorb = (exc(1,2,1)) !!! a^{\dagger}_a
borb = (exc(1,1,1)) !!! a_{b}
jspin = 1
else
! Mono beta
aorb = (exc(1,2,2)) !!! a^{\dagger}_a
borb = (exc(1,1,2)) !!! a_{b}
jspin = 2
endif
call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int)
if(degree_scalar .ne. 2)then
print*, 'pb !!!'
print*, degree_scalar
call debug_det(psi_det(1,1,idx(jdet)),N_int)
call debug_det(det_tmp,N_int)
stop
endif
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
if(ispin == jspin )then
hij = -get_mo_bielec_integral(iorb,aorb,rorb,borb,mo_integrals_map) &
+ get_mo_bielec_integral(iorb,aorb,borb,rorb,mo_integrals_map)
else
hij = get_mo_bielec_integral(iorb,borb,rorb,aorb,mo_integrals_map)
endif
hij = hij * phase
double precision :: hij_test
integer :: state_target
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test)
if(dabs(hij - hij_test).gt.1.d-10)then
print*, 'ahah pb !!'
print*, 'hij .ne. hij_test'
print*, hij,hij_test
call debug_det(psi_det(1,1,idx(jdet)),N_int)
call debug_det(det_tmp,N_int)
print*, ispin, jspin
print*,iorb,borb,rorb,aorb
print*, phase
call i_H_j_verbose(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test)
stop
endif
do state_target = 1, N_states
matrix_1h1p(idx(jdet),idet,state_target) += hij* coef_mono(state_target)
enddo
else
do state_target = 1, N_states
matrix_1h1p(idet,idet,state_target) += himono * coef_mono(state_target)
enddo
endif
enddo
enddo
enddo
enddo
enddo
end
subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb,s,sorb
integer :: ispin,jspin
integer :: idet,jdet
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2),det_tmp_bis(N_int,2)
integer(bit_kind) :: det_pert(N_int,2,n_inact_orb,n_virt_orb,2)
double precision :: coef_det_pert(n_inact_orb,n_virt_orb,2,N_states,2)
double precision :: delta_e_det_pert(n_inact_orb,n_virt_orb,2,N_states)
double precision :: hij_det_pert(n_inact_orb,n_virt_orb,2,N_states)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: istate
double precision :: hja,delta_e_inact_virt(N_states)
integer :: kspin,degree_scalar
!matrix_1h1p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
double precision :: himono,delta_e(N_states),coef_mono(N_states)
integer :: state_target
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do state_target = 1, N_states
coef_det_pert(i,r,ispin,state_target,1) = 0.d0
coef_det_pert(i,r,ispin,state_target,2) = 0.d0
enddo
do j = 1, N_states
delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) &
- fock_virt_total_spin_trace(rorb,j)
enddo
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono)
do inint = 1, N_int
det_pert(inint,1,i,r,ispin) = det_tmp(inint,1)
det_pert(inint,2,i,r,ispin) = det_tmp(inint,2)
enddo
do state_target = 1, N_states
delta_e_det_pert(i,r,ispin,state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target)
coef_det_pert(i,r,ispin,state_target,1) = himono / delta_e_det_pert(i,r,ispin,state_target)
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations
enddo ! ispin
enddo ! rorb
enddo ! iorb
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do inint = 1, N_int
det_tmp(inint,1) = det_pert(inint,1,i,r,ispin)
det_tmp(inint,2) = det_pert(inint,2,i,r,ispin)
enddo
do j = 1, n_inact_orb ! First inactive
jorb = list_inact(j)
do s = 1, n_virt_orb ! First virtual
sorb = list_virt(s)
do jspin = 1, 2 ! spin of the couple a-a^dagger (i,r)
if(i==j.and.r==s.and.ispin==jspin)cycle
do inint = 1, N_int
det_tmp_bis(inint,1) = det_pert(inint,1,j,s,jspin)
det_tmp_bis(inint,2) = det_pert(inint,2,j,s,jspin)
enddo
call i_H_j(det_tmp_bis,det_tmp,N_int,himono)
do state_target = 1, N_states
coef_det_pert(i,r,ispin,state_target,2) += &
coef_det_pert(j,s,jspin,state_target,1) * himono / delta_e_det_pert(i,r,ispin,state_target)
enddo
enddo
enddo
enddo
enddo ! ispin
enddo ! rorb
enddo ! iorb
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do state_target = 1, N_states
coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2)
enddo
do inint = 1, N_int
det_tmp(inint,1) = det_pert(inint,1,i,r,ispin)
det_tmp(inint,2) = det_pert(inint,2,i,r,ispin)
enddo
do jdet = 1, idx(0)
!
if(idx(jdet).ne.idet)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
aorb = (exc(1,2,1)) !!! a^{\dagger}_a
borb = (exc(1,1,1)) !!! a_{b}
jspin = 1
else
aorb = (exc(1,2,2)) !!! a^{\dagger}_a
borb = (exc(1,1,2)) !!! a_{b}
jspin = 2
endif
call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int)
if(degree_scalar .ne. 2)then
print*, 'pb !!!'
print*, degree_scalar
call debug_det(psi_det(1,1,idx(jdet)),N_int)
call debug_det(det_tmp,N_int)
stop
endif
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
double precision :: hij_test
hij_test = 0.d0
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test)
do state_target = 1, N_states
matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2)
enddo
else
hij_test = 0.d0
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij_test)
do state_target = 1, N_states
matrix_1h1p(idet,idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2)
enddo
endif
enddo
enddo
enddo
enddo
enddo ! idet
end
subroutine give_1p_sec_order_singles_contrib(matrix_1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1p(N_det,N_det,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb,s,sorb
integer :: ispin,jspin
integer :: idet,jdet
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2),det_tmp_bis(N_int,2)
integer(bit_kind) :: det_pert(N_int,2,n_act_orb,n_virt_orb,2)
double precision :: coef_det_pert(n_act_orb,n_virt_orb,2,N_states,2)
double precision :: delta_e_det_pert(n_act_orb,n_virt_orb,2,N_states)
double precision :: hij_det_pert(n_act_orb,n_virt_orb,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: hij,phase
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: istate
double precision :: hja,delta_e_act_virt(N_states)
integer :: kspin,degree_scalar
!matrix_1p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
double precision :: himono,delta_e(N_states),coef_mono(N_states)
integer :: state_target
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
do i = 1, n_act_orb ! First active
iorb = list_act(i)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do state_target = 1, N_states
coef_det_pert(i,r,ispin,state_target,1) = 0.d0
coef_det_pert(i,r,ispin,state_target,2) = 0.d0
enddo
do j = 1, N_states
delta_e_act_virt(j) = - fock_virt_total_spin_trace(rorb,j)
enddo
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation active -- > virtual
call do_mono_excitation(det_tmp,iorb,rorb,ispin,i_ok)
integer :: i_ok
if(i_ok .ne.1)then
do state_target = 1, N_states
coef_det_pert(i,r,ispin,state_target,1) = -1.d+10
coef_det_pert(i,r,ispin,state_target,2) = -1.d+10
hij_det_pert(i,r,ispin) = 0.d0
enddo
do inint = 1, N_int
det_pert(inint,1,i,r,ispin) = 0_bit_kind
det_pert(inint,2,i,r,ispin) = 0_bit_kind
enddo
cycle
endif
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono)
do inint = 1, N_int
det_pert(inint,1,i,r,ispin) = det_tmp(inint,1)
det_pert(inint,2,i,r,ispin) = det_tmp(inint,2)
enddo
do state_target = 1, N_states
delta_e_det_pert(i,r,ispin,state_target) = one_creat_virt(i,r,state_target) + delta_e_act_virt(state_target)
coef_det_pert(i,r,ispin,state_target,1) = himono / delta_e_det_pert(i,r,ispin,state_target)
hij_det_pert(i,r,ispin) = himono
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations
enddo ! ispin
enddo ! rorb
enddo ! iorb
! do i = 1, n_act_orb ! First active
! do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
! if(coef_det_pert(i,1,ispin,1,1) == -1.d+10)cycle
! iorb = list_act(i)
! do r = 1, n_virt_orb ! First virtual
! rorb = list_virt(r)
! do inint = 1, N_int
! det_tmp(inint,1) = det_pert(inint,1,i,r,ispin)
! det_tmp(inint,2) = det_pert(inint,2,i,r,ispin)
! enddo
! do j = 1, n_act_orb ! First active
! do jspin = 1, 2 ! spin of the couple a-a^dagger (i,r)
! if(coef_det_pert(j,1,jspin,1,1) == -1.d+10)cycle
! jorb = list_act(j)
! do s = 1, n_virt_orb ! First virtual
! sorb = list_virt(s)
! if(i==j.and.r==s.and.ispin==jspin)cycle
! do inint = 1, N_int
! det_tmp_bis(inint,1) = det_pert(inint,1,j,s,jspin)
! det_tmp_bis(inint,2) = det_pert(inint,2,j,s,jspin)
! enddo
! call i_H_j(det_tmp_bis,det_tmp,N_int,himono)
! do state_target = 1, N_states
! coef_det_pert(i,r,ispin,state_target,2) += &
! coef_det_pert(j,s,jspin,state_target,1) * himono / delta_e_det_pert(i,r,ispin,state_target)
! enddo
! enddo
! enddo
! enddo
! enddo ! ispin
! enddo ! rorb
! enddo ! iorb
do i = 1, n_act_orb ! First active
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
if(coef_det_pert(i,1,ispin,1,1) == -1.d+10)cycle
iorb = list_act(i)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
! do state_target = 1, N_states
! coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2)
! enddo
do inint = 1, N_int
det_tmp(inint,1) = det_pert(inint,1,i,r,ispin)
det_tmp(inint,2) = det_pert(inint,2,i,r,ispin)
enddo
do jdet = 1,N_det
double precision :: coef_array(N_states),hij_test
call i_H_j(det_tmp,psi_det(1,1,jdet),N_int,himono)
call get_delta_e_dyall(psi_det(1,1,jdet),det_tmp,coef_array,hij_test,delta_e)
do state_target = 1, N_states
! matrix_1p(idet,jdet,state_target) += himono * coef_det_pert(i,r,ispin,state_target,1)
matrix_1p(idet,jdet,state_target) += himono * hij_det_pert(i,r,ispin) / delta_e(state_target)
enddo
enddo
enddo
enddo
enddo
enddo ! idet
end
subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb
integer :: ispin,jspin
integer :: idet,jdet
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: istate
double precision :: hja,delta_e_inact_virt(N_states)
integer(bit_kind) :: pert_det(N_int,2,n_act_orb,n_act_orb,2)
double precision :: pert_det_coef(n_act_orb,n_act_orb,2,N_states)
integer :: kspin,degree_scalar
integer :: other_spin(2)
other_spin(1) = 2
other_spin(2) = 1
double precision :: hidouble,delta_e(N_states)
!matrix_1h1p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
do j = 1, N_states
delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) &
- fock_virt_total_spin_trace(rorb,j)
enddo
do idet = 1, N_det
call get_excitation_degree_vector_double_alpha_beta(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations
do ispin = 1, 2
jspin = other_spin(ispin)
do a = 1, n_act_orb
aorb = list_act(a)
do b = 1, n_act_orb
borb = list_act(b)
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation (i-->a)(ispin) + (b-->r)(other_spin(ispin))
integer :: i_ok,corb,dorb
call do_mono_excitation(det_tmp,iorb,aorb,ispin,i_ok)
if(i_ok .ne. 1)then
do state_target = 1, N_states
pert_det_coef(a,b,ispin,state_target) = -100000.d0
enddo
do inint = 1, N_int
pert_det(inint,1,a,b,ispin) = 0_bit_kind
pert_det(inint,2,a,b,ispin) = 0_bit_kind
enddo
cycle
endif
call do_mono_excitation(det_tmp,borb,rorb,jspin,i_ok)
if(i_ok .ne. 1)then
do state_target = 1, N_states
pert_det_coef(a,b,ispin,state_target) = -100000.d0
enddo
do inint = 1, N_int
pert_det(inint,1,a,b,ispin) = 0_bit_kind
pert_det(inint,2,a,b,ispin) = 0_bit_kind
enddo
cycle
endif
do inint = 1, N_int
pert_det(inint,1,a,b,ispin) = det_tmp(inint,1)
pert_det(inint,2,a,b,ispin) = det_tmp(inint,2)
enddo
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hidouble)
do state_target = 1, N_states
delta_e(state_target) = one_anhil_one_creat(a,b,ispin,jspin,state_target) + delta_e_inact_virt(state_target)
pert_det_coef(a,b,ispin,state_target) = hidouble / delta_e(state_target)
matrix_1h1p(idet,idet,state_target) += hidouble * pert_det_coef(a,b,ispin,state_target)
enddo
enddo
enddo
enddo
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
integer :: c,d,state_target
integer(bit_kind) :: det_tmp_bis(N_int,2)
! excitation from I --> J
! (a->c) (alpha) + (b->d) (beta)
aorb = exc(1,1,1)
corb = exc(1,2,1)
c = list_act_reverse(corb)
borb = exc(1,1,2)
dorb = exc(1,2,2)
d = list_act_reverse(dorb)
ispin = 1
jspin = 2
do inint = 1, N_int
det_tmp(inint,1) = pert_det(inint,1,c,d,1)
det_tmp(inint,2) = pert_det(inint,2,c,d,1)
det_tmp_bis(inint,1) = pert_det(inint,1,c,d,2)
det_tmp_bis(inint,2) = pert_det(inint,2,c,d,2)
enddo
double precision :: hjdouble_1,hjdouble_2
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1)
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2)
do state_target = 1, N_states
matrix_1h1p(idx(jdet),idet,state_target) += (pert_det_coef(c,d,1,state_target) * hjdouble_1 + pert_det_coef(c,d,2,state_target) * hjdouble_2 )
enddo
endif
enddo
enddo
enddo
enddo
end

796
plugins/MRPT_Utils/new_way_second_order_coef.irp.f Normal file
View File

@ -0,0 +1,796 @@
subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb
integer :: ispin,jspin
integer :: idet,jdet
integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2)
double precision :: perturb_dets_phase(n_act_orb,2,2)
double precision :: perturb_dets_hij(n_act_orb,2,2)
double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states,3)
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer(bit_kind) :: det_tmp_j(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
integer :: index_orb_act_mono(N_det,6)
!matrix_2h1p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do j = 1, n_inact_orb ! Second inactive
jorb = list_inact(j)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
! take all the integral you will need for i,j,r fixed
do a = 1, n_act_orb
aorb = list_act(a)
active_int(a,1) = get_mo_bielec_integral(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct
active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange
perturb_dets_phase(a,1,1) = -1000.d0
perturb_dets_phase(a,1,2) = -1000.d0
perturb_dets_phase(a,2,2) = -1000.d0
perturb_dets_phase(a,2,1) = -1000.d0
enddo
integer :: degree(N_det)
integer :: idx(0:N_det)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
do idet = 1, N_det
call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
! if(idet == 81)then
! call get_excitation_degree_vector_mono_or_exchange_verbose(psi_det(1,1,1),psi_det(1,1,idet),degree,N_int,N_det,idx)
! endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a)
if(ispin == jspin .and. iorb.le.jorb)cycle ! condition not to double count
do a = 1, n_act_orb ! First active
aorb = list_act(a)
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
! Do the excitation inactive -- > active
call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin
call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
accu_elec= 0
do inint = 1, N_int
accu_elec+= popcnt(det_tmp(inint,jspin))
enddo
if(accu_elec .ne. elec_num_tab_local(jspin))then
perturb_dets_phase(a,jspin,ispin) = -1000.d0
perturb_dets_hij(a,jspin,ispin) = 0.d0
do istate = 1, N_states
coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0
coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0
enddo
cycle
endif
do inint = 1, N_int
perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1)
perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
perturb_dets_phase(a,jspin,ispin) = phase
do istate = 1, N_states
delta_e(a,jspin,istate) = one_creat(a,jspin,istate) &
- fock_virt_total_spin_trace(rorb,istate) &
+ fock_core_inactive_total_spin_trace(iorb,istate) &
+ fock_core_inactive_total_spin_trace(jorb,istate)
enddo
if(ispin == jspin)then
perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,2) - active_int(a,1) )
else
perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1)
endif
!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet
!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin)
do istate = 1, N_states
coef_perturb_from_idet(a,jspin,ispin,istate,1) = perturb_dets_hij(a,jspin,ispin) / delta_e(a,jspin,istate)
enddo
enddo
enddo
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS
!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a^{\dagger}_b a_{a} | Idet>
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | K_{ab} | Idet>
integer :: i_hole,i_part
double precision :: hij_test
double precision :: fock_operator_local(n_act_orb,n_act_orb,2)
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
if(degree(jdet)==1)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
i_hole = list_act_reverse(exc(1,1,1)) !!! a_a
i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b}
kspin = 1 !!! kspin
index_orb_act_mono(idx(jdet),1) = i_hole
index_orb_act_mono(idx(jdet),2) = i_part
index_orb_act_mono(idx(jdet),3) = kspin
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
else
! Mono beta
i_hole = list_act_reverse(exc(1,1,2)) !!! a_a
i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b}
kspin = 2 !!! kspin
index_orb_act_mono(idx(jdet),1) = i_hole
index_orb_act_mono(idx(jdet),2) = i_part
index_orb_act_mono(idx(jdet),3) = kspin
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
endif
else if(degree(jdet)==2)then
call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
! Mono alpha
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a
index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b}
index_orb_act_mono(idx(jdet),3) = 1
! Mono beta
index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a
index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b}
index_orb_act_mono(idx(jdet),6) = 2
endif
else
index_orb_act_mono(idx(jdet),1) = -1
endif
enddo
integer :: kspin
integer :: corb,i_ok
integer(bit_kind) :: det_tmp_bis(N_int,2)
double precision :: hib , hab , hja
double precision :: delta_e_ab(N_states)
double precision :: hib_test,hja_test,hab_test
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS
if(degree(jdet) == 1)then
! ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator
! ! are connected by the presence of the perturbers determinants |det_tmp>
aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb}
borb = index_orb_act_mono(idx(jdet),2) ! a_{borb}
kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{i} (ispin)
! ! the determinants Idet and Jdet interact throw the following operator
! ! | Jdet > = a_{borb,kspin} a^{\dagger}_{aorb, kspin} | Idet >
do jspin = 1, 2
if (jspin .ne. kspin)then
do corb = 1, n_act_orb
if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle
! ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{corb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet >
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
enddo
! ! < idet | H | det_tmp > = phase * (ir|cv)
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
if(ispin == jspin)then
hib= phase * (active_int(corb,1) - active_int(corb,2))
else
hib= phase * active_int(corb,1)
endif
! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp >
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok)
if(i_ok .ne. 1)cycle
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
! < det_tmp | H | det_tmp_bis > = F_{aorb,borb}
hab = (fock_operator_local(aorb,borb,kspin) ) * phase
if(isnan(hab))then
print*, '1'
stop
endif
! < jdet | H | det_tmp_bis > = phase * (ir|cv)
call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int)
if(ispin == jspin)then
hja= phase * (active_int(corb,1) - active_int(corb,2))
else
hja= phase * (active_int(corb,1))
endif
do istate = 1, N_states
delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate)
matrix_2h1p(idx(jdet),idet,istate) = matrix_2h1p(idx(jdet),idet,istate) + &
hib / delta_e(corb,jspin,istate) * hab / delta_e_ab(istate) * hja
! ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp )
! ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis)
! ! < det_tmp_bis | H | Jdet >
enddo
enddo ! corb
else
if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count
do corb = 1, n_act_orb
if(corb == aorb .or. corb == borb) cycle
if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle
! ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{corb,jspin} a_{iorb,ispin} | Idet >
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
enddo
! < idet | H | det_tmp > = phase * ( (ir|cv) - (iv|cr) )
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
if(ispin == jspin)then
hib= phase * (active_int(corb,1) - active_int(corb,2))
else
hib= phase * active_int(corb,1)
endif
! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp >
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok)
if(i_ok .ne. 1)cycle
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
! ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb}
hab = fock_operator_local(aorb,borb,kspin) * phase
if(isnan(hab))then
print*, '2'
stop
endif
! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) )
call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int)
if(ispin == jspin)then
hja= phase * (active_int(corb,1) - active_int(corb,2))
else
hja= phase * (active_int(corb,1))
endif
do istate = 1, N_states
delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate)
matrix_2h1p(idx(jdet),idet,istate) = matrix_2h1p(idx(jdet),idet,istate) + &
hib / delta_e(corb,jspin,istate) * hab / delta_e_ab(istate) * hja
! ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp )
! ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis)
! ! < det_tmp_bis | H | Jdet >
enddo
enddo ! corb
endif
enddo
enddo
!
else !! Double excitation operators
!
if (index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then !! spin exchange
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{i} (ispin)
!!! ! first combination of spin :: | det_tmp > = a^{\dagger}_{aorb,beta} | Idet >
jspin = 2
aorb = index_orb_act_mono(idx(jdet),1) ! hole of the alpha electron
borb = index_orb_act_mono(idx(jdet),2) ! particle of the alpha electron
if(perturb_dets_phase(aorb,jspin,ispin).le.-100d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin)
enddo
! | det_tmp > = a^{\dagger}_{aorb,beta} | Idet >
call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int)
if(ispin == jspin)then
hib= phase * (active_int(aorb,1) - active_int(aorb,2))
else
hib= phase * (active_int(aorb,1))
endif
if(hib .ne. perturb_dets_hij(aorb,jspin,ispin))then
print*, 'pb !!'
print*, 'hib .ne. perturb_dets_hij(aorb,jspin,ispin)'
stop
endif
enddo !! ispin
else if(index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),4))then !! closed shell double excitation
else
call get_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,degree_scalar,phase,N_int)
integer :: h1,h2,p1,p2,s1,s2 , degree_scalar
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
print*, h1,p1,h2,p2,s1,s2
call debug_det(psi_det(1,1,idet),N_int)
call debug_det(psi_det(1,1,idx(jdet)),N_int)
print*, idet,idx(jdet)
print*, 'pb !!!!!!!!!!!!!'
call get_excitation_degree_vector_mono_or_exchange_verbose(psi_det(1,1,1),psi_det(1,1,idet),degree,N_int,N_det,idx)
stop
endif
endif
else
!! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations
!!
!! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet >
!!do ispin = 1, 2
!! do kspin = 1, 2
!! if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count
!! do a = 1, n_act_orb ! First active
!! do istate = 1, N_states
!! matrix_2h1p(idet,idet,istate) += coef_perturb_from_idet(a,kspin,ispin,istate,2) * perturb_dets_hij(a,kspin,ispin)
!! enddo
!! enddo
!! enddo
!!enddo
!
endif
enddo
enddo
enddo
enddo
enddo
end
subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*)
integer :: i,v,r,a,b,c
integer :: iorb, vorb, rorb, aorb, borb,corb
integer :: ispin,jspin
integer :: idet,jdet
integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2)
double precision :: perturb_dets_phase(n_act_orb,2,2)
double precision :: perturb_dets_hij(n_act_orb,2,2)
double precision :: perturb_dets_hpsi0(n_act_orb,2,2,N_states)
double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states,2)
logical :: already_generated(n_act_orb,2,2)
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer(bit_kind) :: det_tmp_j(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
double precision :: accu_contrib
integer :: degree(N_det)
integer :: idx(0:N_det)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,6)
double precision :: delta_e_inactive_virt(N_states)
integer :: kspin
double precision :: delta_e_ja(N_states)
double precision :: hja
double precision :: contrib_hij
double precision :: fock_operator_local(n_act_orb,n_act_orb,2)
double precision :: fock_operator_from_core(n_act_orb,n_act_orb)
double precision :: fock_operator_from_virt(n_act_orb,n_act_orb)
double precision :: fock_operator_from_act(n_act_orb,n_act_orb,n_act_orb,2)
accu_contrib = 0.d0
!matrix_1h2p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do v = 1, n_virt_orb ! First virtual
vorb = list_virt(v)
do r = 1, n_virt_orb ! Second virtual
rorb = list_virt(r)
! take all the integral you will need for i,j,r fixed
do a = 1, n_act_orb
aorb = list_act(a)
active_int(a,1) = get_mo_bielec_integral(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct
active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange
perturb_dets_phase(a,1,1) = -1000.d0
perturb_dets_phase(a,1,2) = -1000.d0
perturb_dets_phase(a,2,2) = -1000.d0
perturb_dets_phase(a,2,1) = -1000.d0
already_generated(a,1,1) = .False.
already_generated(a,1,2) = .False.
already_generated(a,2,2) = .False.
already_generated(a,2,1) = .False.
enddo
do istate = 1, N_states
delta_e_inactive_virt(istate) = &
- fock_virt_total_spin_trace(rorb,istate) &
- fock_virt_total_spin_trace(vorb,istate) &
+ fock_core_inactive_total_spin_trace(iorb,istate)
enddo
do idet = 1, N_det
call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb)
do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb)
do a = 1, n_act_orb ! First active
aorb = list_act(a)
do istate = 1, N_states
perturb_dets_hpsi0(a,jspin,ispin,istate) = 0.d0
coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0
coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0
enddo
if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
! Do the excitation active -- > virtual
call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin
call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
accu_elec= 0
do inint = 1, N_int
accu_elec+= popcnt(det_tmp(inint,jspin))
enddo
if(accu_elec .ne. elec_num_tab_local(jspin))then
perturb_dets_phase(a,jspin,ispin) = -1000.0d0
perturb_dets_hij(a,jspin,ispin) = 0.d0
do istate = 1, N_states
coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0
coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0
enddo
cycle
endif
do inint = 1, N_int
perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1)
perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2)
enddo
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,a,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
perturb_dets_phase(a,jspin,ispin) = phase
do istate = 1, N_states
delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) + delta_e_inactive_virt(istate)
enddo
if(ispin == jspin)then
perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) )
else
perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1)
endif
enddo
enddo
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS
!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a^{\dagger}_b a_{a} | Idet>
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | K_{ab} | Idet>
integer :: i_hole,i_part
double precision :: hij_test
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
if(degree(jdet)==1)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
i_hole = list_act_reverse(exc(1,1,1)) !!! a_a
i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b}
kspin = 1 !!! kspin
index_orb_act_mono(idx(jdet),1) = i_hole
index_orb_act_mono(idx(jdet),2) = i_part
index_orb_act_mono(idx(jdet),3) = kspin
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
else
! Mono beta
i_hole = list_act_reverse(exc(1,1,2)) !!! a_a
i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b}
kspin = 2 !!! kspin
index_orb_act_mono(idx(jdet),1) = i_hole
index_orb_act_mono(idx(jdet),2) = i_part
index_orb_act_mono(idx(jdet),3) = kspin
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
endif
else if(degree(jdet)==2)then
call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
! Mono alpha
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a
index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b}
index_orb_act_mono(idx(jdet),3) = 1
! Mono beta
index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a
index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b}
index_orb_act_mono(idx(jdet),6) = 2
endif
else
index_orb_act_mono(idx(jdet),1) = -1
endif
enddo
integer ::dorb,i_ok
integer(bit_kind) :: det_tmp_bis(N_int,2)
double precision :: hib , hab
double precision :: delta_e_ab(N_states)
double precision :: hib_test,hja_test,hab_test
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS
if(degree(jdet) == 1)then
! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator
! are connected by the presence of the perturbers determinants |det_tmp>
aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb}
borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb}
kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation
! the determinants Idet and Jdet interact throw the following operator
! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet >
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{i} (ispin)
if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count
do jspin = 1, 2
if (jspin .ne. kspin)then
do corb = 1, n_act_orb
if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{corb,kspin} a_{iorb,ispin} | Idet >
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
enddo
! < idet | H | det_tmp > = phase * (ir|cv)
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
if(ispin == jspin)then
hib= phase * (active_int(corb,1) - active_int(corb,2))
else
hib= phase * active_int(corb,1)
endif
! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp >
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok)
if(i_ok .ne. 1)cycle
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
! < det_tmp | H | det_tmp_bis > = F_{aorb,borb}
hab = (fock_operator_local(aorb,borb,kspin) ) * phase
! < jdet | H | det_tmp_bis > = phase * (ir|cv)
call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int)
if(ispin == jspin)then
hja= phase * (active_int(corb,1) - active_int(corb,2))
else
hja= phase * (active_int(corb,1))
endif
do istate = 1, N_states
delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate)
matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + &
hib / delta_e(corb,jspin,istate) * hab / delta_e_ab(istate) * hja
! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp )
! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis)
! < det_tmp_bis | H | Jdet >
enddo
enddo ! corb
else
do corb = 1, n_act_orb
if(corb == aorb .or. corb == borb) cycle
if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{corb,jspin} a_{iorb,ispin} | Idet >
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
enddo
! < idet | H | det_tmp > = phase * ( (ir|cv) - (iv|cr) )
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
if(ispin == jspin)then
hib= phase * (active_int(corb,1) - active_int(corb,2))
else
hib= phase * active_int(corb,1)
endif
! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp >
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok)
if(i_ok .ne. 1)cycle
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
! ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb}
hab = fock_operator_local(aorb,borb,kspin) * phase
! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) )
call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int)
if(ispin == jspin)then
hja= phase * (active_int(corb,1) - active_int(corb,2))
else
hja= phase * (active_int(corb,1))
endif
do istate = 1, N_states
delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate)
matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + &
hib / delta_e(corb,jspin,istate) * hab / delta_e_ab(istate) * hja
! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp )
! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis)
! < det_tmp_bis | H | Jdet >
enddo
enddo ! corb
endif
enddo ! jspin
enddo ! ispin
else
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of double excitations !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! a^{\dagger}_r a_{i} (ispin)
aorb = index_orb_act_mono(idx(jdet),4) ! hole of a beta electron
borb = index_orb_act_mono(idx(jdet),5) ! propagation of the hole :: mono excitation of alpha spin
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{i} (ispin)
! ! first combination of spin :: | det_tmp > = a_{aorb,beta} | Idet >
jspin = 2
if(perturb_dets_phase(aorb,jspin,ispin).le.-100d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin)
enddo
call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int)
if(ispin == jspin)then
hib= phase * (active_int(borb,1) - active_int(borb,2))
else
hib= phase * (active_int(borb,1))
endif
if( index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then
call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),1,i_ok)
if(i_ok .ne. 1)then
call debug_det(psi_det(1,1,idet),N_int)
call debug_det(psi_det(1,1,idx(jdet)),N_int)
print*, aorb, borb
call debug_det(det_tmp,N_int)
stop
endif
else
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),1,i_ok)
endif
if(i_ok .ne. 1)cycle
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
! < det_tmp | H | det_tmp_bis > = F_{aorb,borb}
if (aorb == borb)then
print*, 'iahaha'
stop
endif
hab = fock_operator_local(aorb,borb,1) * phase
call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int)
if(ispin == jspin)then
hja= phase * (active_int(borb,1) - active_int(borb,2))
else
hja= phase * (active_int(borb,1))
endif
do istate = 1, N_states
delta_e_ab(istate) = delta_e(aorb,jspin,istate) + one_anhil_one_creat(borb,aorb,1,1,istate)
matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + &
hib / delta_e(aorb,jspin,istate) * hab / delta_e_ab(istate) * hja
! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp )
! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis)
! < det_tmp_bis | H | Jdet >
enddo !! istate
! ! second combination of spin :: | det_tmp > = a_{aorb,alpha} | Idet >
jspin = 1
if(perturb_dets_phase(aorb,jspin,ispin).le.-100d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin)
enddo
call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int)
if(ispin == jspin)then
hib= phase * (active_int(borb,1) - active_int(borb,2))
else
hib= phase * (active_int(borb,1))
endif
if( index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then
call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),2,i_ok)
if(i_ok .ne. 1)then
call debug_det(psi_det(1,1,idet),N_int)
call debug_det(psi_det(1,1,idx(jdet)),N_int)
print*, aorb, borb
call debug_det(det_tmp,N_int)
stop
endif
else
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),2,i_ok)
endif
if(i_ok .ne. 1)cycle
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
! < det_tmp | H | det_tmp_bis > = F_{aorb,borb}
hab = fock_operator_local(aorb,borb,2) * phase
call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int)
if(ispin == jspin)then
hja= phase * (active_int(borb,1) - active_int(borb,2))
else
hja= phase * (active_int(borb,1))
endif
do istate = 1, N_states
delta_e_ab(istate) = delta_e(aorb,jspin,istate) + one_anhil_one_creat(borb,aorb,1,1,istate)
matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + &
hib / delta_e(aorb,jspin,istate) * hab / delta_e_ab(istate) * hja
! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp )
! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis)
! < det_tmp_bis | H | Jdet >
enddo !! istate
enddo !! ispin
endif !! en of test if jdet is a single or a double excitation of type K_ab
else !! jdet is idet
! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations
!
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet >
do ispin = 1, 2
do kspin = 1, 2
do a = 1, n_act_orb ! First active
if( perturb_dets_phase(a,kspin,ispin) .le. -10.d0)cycle
if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count
contrib_hij = perturb_dets_hij(a,kspin,ispin) * perturb_dets_hij(a,kspin,ispin)
do istate = 1, N_states
! matrix_1h2p(idet,idet,istate) += contrib_hij * delta_e(a,kspin,istate)
! perturb_dets_hpsi0(a,kspin,ispin,istate) += psi_coef(idet,istate) * perturb_dets_hij(a,kspin,ispin)
! coef_perturb_from_idet(a,kspin,ispin,istate,1) += psi_coef(idet,istate) &
! * perturb_dets_hij(a,kspin,ispin) * delta_e(a,kspin,istate)
enddo
enddo
enddo
enddo
endif
enddo !! jdet
enddo
enddo
enddo
enddo
end

51
plugins/MRPT_Utils/print_1h2p.irp.f Normal file
View File

@ -0,0 +1,51 @@
program print_1h2p
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
double precision,allocatable :: matrix_1h2p(:,:,:)
allocate (matrix_1h2p(N_det,N_det,N_states))
integer :: i,j,istate
do i = 1, N_det
do j = 1, N_det
do istate = 1, N_states
matrix_1h2p(i,j,istate) = 0.d0
enddo
enddo
enddo
if(.False.)then
call give_1h2p_contrib(matrix_1h2p)
double precision :: accu
accu = 0.d0
do i = 1, N_det
do j = 1, N_det
accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1)
enddo
enddo
print*, 'second order ', accu
endif
if(.True.)then
do i = 1, N_det
do j = 1, N_det
do istate = 1, N_states
matrix_1h2p(i,j,istate) = 0.d0
enddo
enddo
enddo
call give_1h2p_new(matrix_1h2p)
accu = 0.d0
do i = 1, N_det
do j = 1, N_det
accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1)
enddo
enddo
endif
print*, 'third order ', accu
deallocate (matrix_1h2p)
end

484
plugins/MRPT_Utils/psi_active_prov.irp.f Normal file
View File

@ -0,0 +1,484 @@
use bitmasks
BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)]
BEGIN_DOC
! active part of psi
END_DOC
implicit none
use bitmasks
integer :: i,j,k,l
provide cas_bitmask
!print*, 'psi_active '
do i = 1, N_det
do j = 1, N_int
psi_active(j,1,i) = iand(psi_det(j,1,i),cas_bitmask(j,1,1))
psi_active(j,2,i) = iand(psi_det(j,2,i),cas_bitmask(j,1,1))
enddo
enddo
END_PROVIDER
subroutine give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin,n_particles_spin,n_holes,n_particles,&
holes_active_list,particles_active_list)
implicit none
use bitmasks
integer(bit_kind),intent(in) :: det_1(N_int,2)
integer(bit_kind),intent(in ) :: det_2(N_int,2)
integer, intent(out) :: n_holes_spin(2),n_particles_spin(2)
integer, intent(out) :: n_holes,n_particles
integer, intent(out) :: holes_active_list(2 * n_act_orb,2)
integer, intent(out) :: particles_active_list(2 * n_act_orb,2)
integer :: i
integer(bit_kind) :: holes(N_int,2)
integer(bit_kind) :: particles(N_int,2)
integer(bit_kind) :: det_tmp_2(N_int,2),det_tmp_1(N_int,2)
BEGIN_DOC
! returns the holes and particles operators WITHIN THE ACTIVE SPACE
! that connect det_1 and det_2. By definition, the holes/particles
! are such that one starts from det_1 and goes to det_2
!
! n_holes is the total number of holes
! n_particles is the total number of particles
! n_holes_spin is the number of number of holes per spin (1=alpha, 2=beta)
! n_particles_spin is the number of number of particles per spin (1=alpha, 2=beta)
! holes_active_list is the index of the holes per spin, that ranges from 1 to n_act_orb
! particles_active_list is the index of the particles per spin, that ranges from 1 to n_act_orb
END_DOC
call give_active_part_determinant(det_1,det_tmp_1)
call give_active_part_determinant(det_2,det_tmp_2)
do i = 1, N_int
holes(i,1) = iand(det_tmp_1(i,1),xor(det_tmp_1(i,1),det_tmp_2(i,1)))
holes(i,2) = iand(det_tmp_1(i,2),xor(det_tmp_1(i,2),det_tmp_2(i,2)))
particles(i,1) = iand(det_tmp_2(i,1),xor(det_tmp_1(i,1),det_tmp_2(i,1)))
particles(i,2) = iand(det_tmp_2(i,2),xor(det_tmp_1(i,2),det_tmp_2(i,2)))
enddo
integer :: holes_list(N_int*bit_kind_size,2)
holes_list = 0
call bitstring_to_list(holes(1,1), holes_list(1,1), n_holes_spin(1), N_int)
call bitstring_to_list(holes(1,2), holes_list(1,2), n_holes_spin(2), N_int)
n_holes = 0
do i = 1, n_holes_spin(1)
n_holes +=1
holes_active_list(i,1) = list_act_reverse(holes_list(i,1))
enddo
do i = 1, n_holes_spin(2)
n_holes +=1
holes_active_list(i,2) = list_act_reverse(holes_list(i,2))
enddo
integer :: particles_list(N_int*bit_kind_size,2)
particles_list = 0
call bitstring_to_list(particles(1,1), particles_list(1,1), n_particles_spin(1), N_int)
call bitstring_to_list(particles(1,2), particles_list(1,2), n_particles_spin(2), N_int)
n_particles = 0
do i = 1, n_particles_spin(1)
n_particles += 1
particles_active_list(i,1) = list_act_reverse(particles_list(i,1))
enddo
do i = 1, n_particles_spin(2)
n_particles += 1
particles_active_list(i,2) = list_act_reverse(particles_list(i,2))
enddo
end
subroutine give_holes_in_inactive_space(det_1,n_holes_spin,n_holes,holes_list)
BEGIN_DOC
! returns the holes operators WITHIN THE INACTIVE SPACE
! that has lead to det_1.
!
! n_holes is the total number of holes
! n_holes_spin is the number of number of holes per spin (1=alpha, 2=beta)
! holes_inactive_list is the index of the holes per spin, that ranges from 1 to mo_tot_num
END_DOC
implicit none
use bitmasks
integer(bit_kind),intent(in) :: det_1(N_int,2)
integer, intent(out) :: n_holes_spin(2)
integer, intent(out) :: n_holes
integer, intent(out) :: holes_list(N_int*bit_kind_size,2)
integer :: i
integer(bit_kind) :: holes(N_int,2)
integer(bit_kind) :: det_tmp_1(N_int,2)
call give_core_inactive_part_determinant(det_1,det_tmp_1)
do i = 1, N_int
holes(i,1) = iand(reunion_of_core_inact_bitmask(i,1),xor(det_tmp_1(i,1),reunion_of_core_inact_bitmask(i,1)))
holes(i,2) = iand(reunion_of_core_inact_bitmask(i,2),xor(det_tmp_1(i,2),reunion_of_core_inact_bitmask(i,2)))
enddo
holes_list = 0
call bitstring_to_list(holes(1,1), holes_list(1,1), n_holes_spin(1), N_int)
call bitstring_to_list(holes(1,2), holes_list(1,2), n_holes_spin(2), N_int)
n_holes = n_holes_spin(1) + n_holes_spin(2)
end
subroutine give_particles_in_virt_space(det_1,n_particles_spin,n_particles,particles_list)
BEGIN_DOC
! returns the holes operators WITHIN THE VIRTUAL SPACE
! that has lead to det_1.
!
! n_particles is the total number of particles
! n_particles_spin is the number of number of particles per spin (1=alpha, 2=beta)
! particles_inactive_list is the index of the particles per spin, that ranges from 1 to mo_tot_num
END_DOC
implicit none
use bitmasks
integer(bit_kind),intent(in) :: det_1(N_int,2)
integer, intent(out) :: n_particles_spin(2)
integer, intent(out) :: n_particles
integer, intent(out) :: particles_list(N_int*bit_kind_size,2)
integer :: i
integer(bit_kind) :: det_tmp_1(N_int,2)
integer(bit_kind) :: particles(N_int,2)
call give_virt_part_determinant(det_1,det_tmp_1)
do i = 1, N_int
particles(i,1) = iand(virt_bitmask(i,1),det_tmp_1(i,1))
particles(i,2) = iand(virt_bitmask(i,2),det_tmp_1(i,2))
enddo
particles_list = 0
call bitstring_to_list(particles(1,1), particles_list(1,1), n_particles_spin(1), N_int)
call bitstring_to_list(particles(1,2), particles_list(1,2), n_particles_spin(2), N_int)
n_particles = n_particles_spin(1) + n_particles_spin(2)
end
subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
BEGIN_DOC
! routine that returns the delta_e with the Moller Plesset and Dyall operators
!
! with det_1 being a determinant from the cas, and det_2 being a perturber
!
! Delta_e(det_1,det_2) = sum (hole) epsilon(hole) + sum(part) espilon(part) + delta_e(act)
!
! where hole is necessary in the inactive, part necessary in the virtuals
!
! and delta_e(act) is obtained from the contracted application of the excitation
!
! operator in the active space that lead from det_1 to det_2
END_DOC
implicit none
use bitmasks
double precision, intent(out) :: delta_e_final(N_states)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
double precision, intent(in) :: coef_array(N_states),hij
integer :: i,j,k,l
integer :: i_state
integer :: n_holes_spin(2)
integer :: n_holes
integer :: holes_list(N_int*bit_kind_size,2)
double precision :: delta_e_inactive(N_states)
integer :: i_hole_inact
call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list)
delta_e_inactive = 0.d0
do i = 1, n_holes_spin(1)
i_hole_inact = holes_list(i,1)
do i_state = 1, N_states
delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact,i_state)
enddo
enddo
do i = 1, n_holes_spin(2)
i_hole_inact = holes_list(i,2)
do i_state = 1, N_states
delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state)
enddo
enddo
double precision :: delta_e_virt(N_states)
integer :: i_part_virt
integer :: n_particles_spin(2)
integer :: n_particles
integer :: particles_list(N_int*bit_kind_size,2)
call give_particles_in_virt_space(det_2,n_particles_spin,n_particles,particles_list)
delta_e_virt = 0.d0
do i = 1, n_particles_spin(1)
i_part_virt = particles_list(i,1)
do i_state = 1, N_states
delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state)
enddo
enddo
do i = 1, n_particles_spin(2)
i_part_virt = particles_list(i,2)
do i_state = 1, N_states
delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state)
enddo
enddo
integer :: n_holes_spin_act(2),n_particles_spin_act(2)
integer :: n_holes_act,n_particles_act
integer :: holes_active_list(2*n_act_orb,2)
integer :: holes_active_list_spin_traced(4*n_act_orb)
integer :: particles_active_list(2*n_act_orb,2)
integer :: particles_active_list_spin_traced(4*n_act_orb)
double precision :: delta_e_act(N_states)
delta_e_act = 0.d0
call give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin_act,n_particles_spin_act, &
n_holes_act,n_particles_act,holes_active_list,particles_active_list)
integer :: icount,icountbis
integer :: hole_list_practical(2,elec_num_tab(1)+elec_num_tab(2)), particle_list_practical(2,elec_num_tab(1)+elec_num_tab(2))
icount = 0
icountbis = 0
do i = 1, n_holes_spin_act(1)
icount += 1
icountbis += 1
hole_list_practical(1,icountbis) = 1
hole_list_practical(2,icountbis) = holes_active_list(i,1)
holes_active_list_spin_traced(icount) = holes_active_list(i,1)
enddo
do i = 1, n_holes_spin_act(2)
icount += 1
icountbis += 1
hole_list_practical(1,icountbis) = 2
hole_list_practical(2,icountbis) = holes_active_list(i,2)
holes_active_list_spin_traced(icount) = holes_active_list(i,2)
enddo
if(icount .ne. n_holes_act) then
print*,''
print*, icount, n_holes_act
print * , 'pb in holes_active_list_spin_traced !!'
stop
endif
icount = 0
icountbis = 0
do i = 1, n_particles_spin_act(1)
icount += 1
icountbis += 1
particle_list_practical(1,icountbis) = 1
particle_list_practical(2,icountbis) = particles_active_list(i,1)
particles_active_list_spin_traced(icount) = particles_active_list(i,1)
enddo
do i = 1, n_particles_spin_act(2)
icount += 1
icountbis += 1
particle_list_practical(1,icountbis) = 2
particle_list_practical(2,icountbis) = particles_active_list(i,2)
particles_active_list_spin_traced(icount) = particles_active_list(i,2)
enddo
if(icount .ne. n_particles_act) then
print*, icount, n_particles_act
print * , 'pb in particles_active_list_spin_traced !!'
stop
endif
integer :: i_hole_act, j_hole_act, k_hole_act
integer :: i_particle_act, j_particle_act, k_particle_act
integer :: ispin,jspin,kspin
if (n_holes_act == 0 .and. n_particles_act == 1) then
ispin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
! call get_excitation_degree(det_1,det_2,degree,N_int)
! if(degree == 1)then
! call get_excitation(det_1,det_2,exc,degree,phase,N_int)
! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
! i_hole = list_inact_reverse(h1)
! i_part = list_act_reverse(p1)
! do i_state = 1, N_states
! delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state)
! enddo
! else if (degree == 2)then
do i_state = 1, N_states
delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state)
enddo
! endif
else if (n_holes_act == 1 .and. n_particles_act == 0) then
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
! call get_excitation_degree(det_1,det_2,degree,N_int)
! if(degree == 1)then
! call get_excitation(det_1,det_2,exc,degree,phase,N_int)
! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
! i_hole = list_act_reverse(h1)
! i_part = list_virt_reverse(p1)
! do i_state = 1, N_states
! if(isnan(one_creat_virt(i_hole,i_part,i_state)))then
! print*, i_hole,i_part,i_state
! call debug_det(det_1,N_int)
! call debug_det(det_2,N_int)
! stop
! endif
! delta_e_act(i_state) += one_creat_virt(i_hole,i_part,i_state)
! enddo
! else if (degree == 2)then
do i_state = 1, N_states
delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state)
enddo
! endif
else if (n_holes_act == 1 .and. n_particles_act == 1) then
! i_hole_act = holes_active_list_spin_traced(1)
! i_particle_act = particles_active_list_spin_traced(1)
! delta_e_act += one_anhil_one_creat_spin_trace(i_hole_act,i_particle_act)
! first hole
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
! first particle
jspin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
do i_state = 1, N_states
delta_e_act(i_state) += one_anhil_one_creat(i_particle_act,i_hole_act,jspin,ispin,i_state)
enddo
else if (n_holes_act == 2 .and. n_particles_act == 0) then
! i_hole_act = holes_active_list_spin_traced(1)
! j_hole_act = holes_active_list_spin_traced(1)
! delta_e_act += two_anhil_spin_trace(i_hole_act,j_hole_act)
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
jspin = hole_list_practical(1,2)
j_hole_act = hole_list_practical(2,2)
do i_state = 1, N_states
delta_e_act(i_state) += two_anhil(i_hole_act,j_hole_act,ispin,jspin,i_state)
enddo
else if (n_holes_act == 0 .and. n_particles_act == 2) then
! i_particle_act = particles_active_list_spin_traced(1)
! j_particle_act = particles_active_list_spin_traced(2)
! delta_e_act += two_creat_spin_trace(i_particle_act,j_particle_act)
ispin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
jspin = particle_list_practical(1,2)
j_particle_act = particle_list_practical(2,2)
do i_state = 1, N_states
delta_e_act(i_state) += two_creat(i_particle_act,j_particle_act,ispin,jspin,i_state)
enddo
else if (n_holes_act == 2 .and. n_particles_act == 1) then
! i_hole_act = holes_active_list_spin_traced(1)
! j_hole_act = holes_active_list_spin_traced(2)
! i_particle_act = particles_active_list_spin_traced(1)
! print*, 'i_hole_act,j_hole_act,i_particle_act'
! print*, i_hole_act,j_hole_act,i_particle_act
! print*, two_anhil_one_creat_spin_trace(i_hole_act,j_hole_act,i_particle_act)
! delta_e_act += two_anhil_one_creat_spin_trace(i_hole_act,j_hole_act,i_particle_act)
! first hole
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
! second hole
jspin = hole_list_practical(1,2)
j_hole_act = hole_list_practical(2,2)
! first particle
kspin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
do i_state = 1, N_states
delta_e_act(i_state) += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin,i_state)
enddo
else if (n_holes_act == 1 .and. n_particles_act == 2) then
! i_hole_act = holes_active_list_spin_traced(1)
! i_particle_act = particles_active_list_spin_traced(1)
! j_particle_act = particles_active_list_spin_traced(2)
! delta_e_act += two_creat_one_anhil_spin_trace(i_hole_act,i_particle_act,j_particle_act)
! first hole
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
! first particle
jspin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
! second particle
kspin = particle_list_practical(1,2)
j_particle_act = particle_list_practical(2,2)
do i_state = 1, N_states
delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state)
enddo
else if (n_holes_act == 3 .and. n_particles_act == 0) then
! i_hole_act = holes_active_list_spin_traced(1)
! j_hole_act = holes_active_list_spin_traced(2)
! k_hole_act = holes_active_list_spin_traced(3)
! delta_e_act += three_anhil_spin_trace(i_hole_act,j_hole_act,k_hole_act)
! first hole
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
! second hole
jspin = hole_list_practical(1,2)
j_hole_act = hole_list_practical(2,2)
! third hole
kspin = hole_list_practical(1,3)
k_hole_act = hole_list_practical(2,3)
do i_state = 1, N_states
delta_e_act(i_state) += three_anhil(i_hole_act,j_hole_act,k_hole_act,ispin,jspin,kspin,i_state)
enddo
else if (n_holes_act == 0 .and. n_particles_act == 3) then
! i_particle_act = particles_active_list_spin_traced(1)
! j_particle_act = particles_active_list_spin_traced(2)
! k_particle_act = particles_active_list_spin_traced(3)
! delta_e_act += three_creat_spin_trace(i_particle_act,j_particle_act,k_particle_act)
! first particle
ispin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
! second particle
jspin = particle_list_practical(1,2)
j_particle_act = particle_list_practical(2,2)
! second particle
kspin = particle_list_practical(1,3)
k_particle_act = particle_list_practical(2,3)
do i_state = 1, N_states
delta_e_act(i_state) += three_creat(i_particle_act,j_particle_act,k_particle_act,ispin,jspin,kspin,i_state)
enddo
else if (n_holes_act .eq. 0 .and. n_particles_act .eq.0)then
integer :: degree
integer(bit_kind) :: det_1_active(N_int,2)
integer :: h1,h2,p1,p2,s1,s2
integer :: exc(0:2,2,2)
integer :: i_hole, i_part
double precision :: phase
call get_excitation_degree(det_1,det_2,degree,N_int)
if(degree == 1)then
call get_excitation(det_1,det_2,exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
i_hole = list_inact_reverse(h1)
i_part = list_virt_reverse(p1)
do i_state = 1, N_states
! delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state)
enddo
endif
else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then
delta_e_act = -10000000.d0
endif
!print*, 'one_anhil_spin_trace'
!print*, one_anhil_spin_trace(1), one_anhil_spin_trace(2)
do i_state = 1, n_states
delta_e_final(i_state) = delta_e_act(i_state) + delta_e_inactive(i_state) - delta_e_virt(i_state)
enddo
end

757
plugins/MRPT_Utils/second_order_new.irp.f Normal file
View File

@ -0,0 +1,757 @@
subroutine give_1h2p_new(matrix_1h2p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*)
integer :: i,v,r,a,b,c
integer :: iorb, vorb, rorb, aorb, borb,corb
integer :: ispin,jspin
integer :: idet,jdet
integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2)
double precision :: perturb_dets_phase(n_act_orb,2,2)
double precision :: perturb_dets_hij(n_act_orb,2,2)
double precision :: perturb_dets_hpsi0(n_act_orb,2,2,N_states)
logical :: already_generated(n_act_orb,2,2)
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer(bit_kind) :: det_tmp_j(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
double precision :: accu_contrib(N_states)
integer :: degree(N_det)
integer :: idx(0:N_det)
double precision :: delta_e(n_act_orb,2,N_states)
double precision :: delta_e_inv(n_act_orb,2,N_states)
double precision :: delta_e_inactive_virt(N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,6)
integer :: kspin
double precision :: delta_e_ja(N_states)
double precision :: hja
double precision :: contrib_hij
double precision :: fock_operator_local(n_act_orb,n_act_orb,2)
double precision :: hij_test
integer ::i_ok
integer(bit_kind) :: det_tmp_bis(N_int,2)
double precision :: hib , hab
double precision :: delta_e_ab(N_states)
double precision :: hib_test,hja_test,hab_test
integer :: i_hole,i_part
double precision :: hia,hjb
integer :: other_spin(2)
other_spin(1) = 2
other_spin(2) = 1
accu_contrib = 0.d0
!matrix_1h2p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do v = 1, n_virt_orb ! First virtual
vorb = list_virt(v)
do r = 1, n_virt_orb ! Second virtual
rorb = list_virt(r)
! take all the integral you will need for i,j,r fixed
do a = 1, n_act_orb
aorb = list_act(a)
active_int(a,1) = get_mo_bielec_integral(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct
active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange
perturb_dets_phase(a,1,1) = -1000.d0
perturb_dets_phase(a,1,2) = -1000.d0
perturb_dets_phase(a,2,2) = -1000.d0
perturb_dets_phase(a,2,1) = -1000.d0
enddo
do istate = 1, N_states
delta_e_inactive_virt(istate) = &
- fock_virt_total_spin_trace(rorb,istate) &
- fock_virt_total_spin_trace(vorb,istate) &
+ fock_core_inactive_total_spin_trace(iorb,istate)
enddo
do idet = 1, N_det
call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb)
do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb)
do a = 1, n_act_orb ! First active
aorb = list_act(a)
do istate = 1, N_states
perturb_dets_hpsi0(a,jspin,ispin,istate) = 0.d0
enddo
if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
! Do the excitation active -- > virtual
call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin
call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
accu_elec= 0
do inint = 1, N_int
accu_elec+= popcnt(det_tmp(inint,jspin))
enddo
if(accu_elec .ne. elec_num_tab_local(jspin))then
perturb_dets_phase(a,jspin,ispin) = -1000.0d0
perturb_dets_hij(a,jspin,ispin) = 0.d0
cycle
endif
do inint = 1, N_int
perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1)
perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
perturb_dets_phase(a,jspin,ispin) = phase
do istate = 1, N_states
delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) + delta_e_inactive_virt(istate)
delta_e_inv(a,jspin,istate) = 1.d0 / delta_e(a,jspin,istate)
enddo
if(ispin == jspin)then
perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) )
else
perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1)
endif
enddo
enddo
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS
!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a^{\dagger}_b a_{a} | Idet>
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | K_{ab} | Idet>
do jdet = 1, idx(0)
if(degree(jdet)==1)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
i_hole = list_act_reverse(exc(1,1,1)) !!! a_a
i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b}
kspin = 1 !!! kspin
index_orb_act_mono(idx(jdet),1) = i_hole
index_orb_act_mono(idx(jdet),2) = i_part
index_orb_act_mono(idx(jdet),3) = kspin
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
else
! Mono beta
i_hole = list_act_reverse(exc(1,1,2)) !!! a_a
i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b}
kspin = 2 !!! kspin
index_orb_act_mono(idx(jdet),1) = i_hole
index_orb_act_mono(idx(jdet),2) = i_part
index_orb_act_mono(idx(jdet),3) = kspin
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
endif
else if(degree(jdet)==2)then
call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
! Mono alpha
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a ALPHA
index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} ALPHA
index_orb_act_mono(idx(jdet),3) = 1
! Mono beta
index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a BETA
index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} BETA
index_orb_act_mono(idx(jdet),6) = 2
endif
enddo
do jdet = 1, idx(0)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS
if(degree(jdet) == 1)then
! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator
! are connected by the presence of the perturbers determinants |det_tmp>
aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb}
borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb}
kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation
! the determinants Idet and Jdet interact throw the following operator
! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet >
accu_contrib = 0.d0
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{i} (ispin)
! if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count
logical :: cycle_same_spin_first_order
cycle_same_spin_first_order = .False.
if(ispin == kspin .and. vorb.le.rorb)then
cycle_same_spin_first_order = .True.
endif
! if(ispin .ne. kspin .and. cycle_same_spin_first_order == .False. )then ! condition not to double count
if(cycle_same_spin_first_order == .False. )then ! condition not to double count
! FIRST ORDER CONTRIBUTION
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet >
if(perturb_dets_phase(aorb,kspin,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
if(kspin == ispin)then
hia = phase * (active_int(aorb,1) - active_int(aorb,2) )
else
hia = phase * active_int(aorb,1)
endif
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
if(kspin == ispin)then
hja = phase * (active_int(borb,1) - active_int(borb,2) )
else
hja = phase * active_int(borb,1)
endif
contrib_hij = hja * hia
do istate = 1, N_states
accu_contrib(istate) += contrib_hij * delta_e_inv(aorb,kspin,istate)
enddo
endif
!!!! SECOND ORDER CONTRIBTIONS
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,jspin} a_{corb,jspin} a_{iorb,ispin} | Idet >
do jspin = 1, 2
logical :: cycle_same_spin_second_order
cycle_same_spin_second_order = .False.
if(ispin == jspin .and. vorb.le.rorb)then
cycle_same_spin_second_order = .True.
endif
if(cycle_same_spin_second_order == .False.)then
do corb = 1, n_act_orb
if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
enddo
! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet >
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok)
if(i_ok .ne. 1)cycle
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
hia = perturb_dets_hij(corb,jspin,ispin)
hab = fock_operator_local(aorb,borb,kspin) * phase
if(dabs(hia).le.1.d-12)cycle
if(dabs(hab).le.1.d-12)cycle
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
if(jspin == ispin)then
hjb = phase * (active_int(corb,1) - active_int(corb,2) )
else
hjb = phase * active_int(corb,1)
endif
if(dabs(hjb).le.1.d-12)cycle
do istate = 1, N_states
accu_contrib(istate)+=hia * delta_e_inv(corb,jspin,istate) & ! | Idet > --> | det_tmp >
! | det_tmp > --> | det_tmp_bis >
*hab / (delta_e(corb,jspin,istate) + one_anhil_one_creat(aorb,borb,kspin,kspin,istate)) &
*hjb
enddo
enddo
endif
enddo
enddo ! ispin
do istate = 1, N_states
matrix_1h2p(idet,idx(jdet),istate) += accu_contrib(istate)
enddo
else if (degree(jdet) == 2)then
! CASE OF THE DOUBLE EXCITATIONS, ONLY THIRD ORDER EFFECTS
accu_contrib = 0.d0
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{i} (ispin)
! if it is standard exchange case, the hole ALPHA == the part. BETA
if (index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then
aorb = index_orb_act_mono(idx(jdet),1) !! the HOLE of the ALPHA electron
borb = index_orb_act_mono(idx(jdet),4) !! the HOLE of the BETA electron
! first case :: | det_tmp > == a_{borb,\beta} | Idet >
cycle_same_spin_second_order = .False.
if(ispin == 2 .and. vorb.le.rorb)then
cycle_same_spin_second_order = .True.
endif
if(cycle_same_spin_second_order == .False.)then ! condition not to double count
if(perturb_dets_phase(borb,2,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,borb,2,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,borb,2,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,borb,2,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,borb,2,ispin)
enddo
hia = perturb_dets_hij(borb,2,ispin)
if(dabs(hia).le.1.d-12)cycle
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),1,i_ok)
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
hab = fock_operator_local(aorb,borb,1) * phase
if(dabs(hab).le.1.d-12)cycle
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
if(ispin == 2)then
hjb = phase * (active_int(aorb,1) - active_int(aorb,2) )
else if (ispin == 1)then
hjb = phase * active_int(aorb,1)
endif
if(dabs(hjb).le.1.d-12)cycle
do istate = 1, N_states
accu_contrib(istate) += hia * delta_e_inv(borb,2,istate) & ! | Idet > --> | det_tmp >
! | det_tmp > --> | det_tmp_bis >
* hab / (delta_e(borb,2,istate) + one_anhil_one_creat(aorb,borb,1,1,istate)) &
* hjb
enddo
endif
! second case :: | det_tmp > == a_{aorb,\alpha} | Idet >
cycle_same_spin_second_order = .False.
if(ispin == 1 .and. vorb.le.rorb)then
cycle_same_spin_second_order = .True.
endif
if(cycle_same_spin_second_order == .False.)then ! condition not to double count
if(perturb_dets_phase(aorb,1,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,1,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,1,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,1,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,1,ispin)
enddo
hia = perturb_dets_hij(aorb,1,ispin)
if(dabs(hia).le.1.d-12)cycle
call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),2,i_ok)
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
hab = fock_operator_local(aorb,borb,2) * phase
if(dabs(hab).le.1.d-12)cycle
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
if(ispin == 1)then
hjb = phase * (active_int(borb,1) - active_int(borb,2) )
else if (ispin == 2)then
hjb = phase * active_int(borb,1)
endif
if(dabs(hjb).le.1.d-12)cycle
do istate = 1, N_states
accu_contrib(istate) += hia * delta_e_inv(aorb,1,istate) & ! | Idet > --> | det_tmp >
! | det_tmp > --> | det_tmp_bis >
* hab / (delta_e(aorb,1,istate) + one_anhil_one_creat(borb,aorb,2,2,istate)) &
* hjb
enddo
endif
! if it is a closed shell double excitation, the hole ALPHA == the hole BETA
else if (index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),4))then
aorb = index_orb_act_mono(idx(jdet),1) !! the HOLE of the ALPHA electron
borb = index_orb_act_mono(idx(jdet),2) !! the PART of the ALPHA electron
! first case :: | det_tmp > == a_{aorb,\beta} | Idet >
cycle_same_spin_second_order = .False.
if(ispin == 2 .and. vorb.le.rorb)then
cycle_same_spin_second_order = .True.
endif
if(cycle_same_spin_second_order == .False.)then ! condition not to double count
if(perturb_dets_phase(aorb,2,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,2,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,2,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,2,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,2,ispin)
enddo
hia = perturb_dets_hij(aorb,2,ispin)
if(dabs(hia).le.1.d-12)cycle
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),1,i_ok)
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
hab = fock_operator_local(aorb,borb,1) * phase
if(dabs(hab).le.1.d-12)cycle
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
if(ispin == 2)then
hjb = phase * (active_int(borb,1) - active_int(borb,2) )
else if (ispin == 1)then
hjb = phase * active_int(borb,1)
endif
if(dabs(hjb).le.1.d-12)cycle
do istate = 1, N_states
accu_contrib(istate) += hia * delta_e_inv(aorb,2,istate) & ! | Idet > --> | det_tmp >
! | det_tmp > --> | det_tmp_bis >
* hab / (delta_e(aorb,2,istate) + one_anhil_one_creat(aorb,borb,1,1,istate)) &
* hjb
enddo
endif
! second case :: | det_tmp > == a_{aorb,\alpha} | Idet >
cycle_same_spin_second_order = .False.
if(ispin == 1 .and. vorb.le.rorb)then
cycle_same_spin_second_order = .True.
endif
if(cycle_same_spin_second_order == .False.)then ! condition not to double count
if(perturb_dets_phase(aorb,1,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,1,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,1,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,1,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,1,ispin)
enddo
hia = perturb_dets_hij(aorb,1,ispin)
if(dabs(hia).le.1.d-12)cycle
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),2,i_ok)
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
hab = fock_operator_local(aorb,borb,2) * phase
if(dabs(hab).le.1.d-12)cycle
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
if(ispin == 1)then
hjb = phase * (active_int(borb,1) - active_int(borb,2) )
else if (ispin == 2)then
hjb = phase * active_int(borb,1)
endif
if(dabs(hjb).le.1.d-12)cycle
do istate = 1, N_states
accu_contrib(istate) += hia * delta_e_inv(aorb,1,istate) & ! | Idet > --> | det_tmp >
! | det_tmp > --> | det_tmp_bis >
* hab / (delta_e(aorb,1,istate) + one_anhil_one_creat(aorb,borb,2,2,istate)) &
* hjb
enddo
endif
else
! one should not fall in this case ...
call debug_det(psi_det(1,1,i),N_int)
call debug_det(psi_det(1,1,idx(jdet)),N_int)
call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
call decode_exc(exc,2,h1,p1,h2,p2,s1,s2)
integer :: h1, p1, h2, p2, s1, s2
print*, h1, p1, h2, p2, s1, s2
print*, 'pb !!! it is a double but not an exchange case ....'
stop
endif
enddo ! ispin
do istate = 1, N_states
matrix_1h2p(idet,idx(jdet),istate) += accu_contrib(istate)
enddo
else if (degree(jdet) == 0)then
! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations
!
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet >
accu_contrib = 0.d0
do ispin = 1, 2
do kspin = 1, 2
do a = 1, n_act_orb ! First active
if( perturb_dets_phase(a,kspin,ispin) .le. -10.d0)cycle
if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count
contrib_hij = perturb_dets_hij(a,kspin,ispin) * perturb_dets_hij(a,kspin,ispin)
do istate = 1, N_states
accu_contrib(istate) += contrib_hij * delta_e_inv(a,kspin,istate)
enddo
enddo
enddo
enddo
do istate = 1, N_states
matrix_1h2p(idet,idet,istate) += accu_contrib(istate)
enddo
endif
enddo !! jdet
enddo
enddo
enddo
enddo
end
subroutine give_2h1p_new(matrix_2h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb
integer :: ispin,jspin
integer :: idet,jdet
integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2)
double precision :: perturb_dets_phase(n_act_orb,2,2)
double precision :: perturb_dets_hij(n_act_orb,2,2)
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
integer :: i_hole,i_part
double precision :: delta_e_inv(n_act_orb,2,N_states)
double precision :: fock_operator_local(n_act_orb,n_act_orb,2)
double precision :: delta_e_inactive_virt(N_states)
integer :: degree(N_det)
integer :: idx(0:N_det)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,3)
integer :: kspin
double precision :: hij_test
double precision :: accu_contrib(N_states)
double precision :: contrib_hij
double precision :: hja
integer :: corb,i_ok
integer(bit_kind) :: det_tmp_bis(N_int,2)
double precision :: hia,hjb,hab
!matrix_2h1p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do j = 1, n_inact_orb ! Second inactive
jorb = list_inact(j)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
! take all the integral you will need for i,j,r fixed
do a = 1, n_act_orb
aorb = list_act(a)
active_int(a,1) = get_mo_bielec_integral(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct
active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange
perturb_dets_phase(a,1,1) = -1000.d0
perturb_dets_phase(a,1,2) = -1000.d0
perturb_dets_phase(a,2,2) = -1000.d0
perturb_dets_phase(a,2,1) = -1000.d0
enddo
do istate = 1, N_states
delta_e_inactive_virt(istate) = &
- fock_virt_total_spin_trace(rorb,istate) &
+ fock_core_inactive_total_spin_trace(iorb,istate) &
+ fock_core_inactive_total_spin_trace(jorb,istate)
enddo
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a)
if(ispin == jspin .and. iorb.le.jorb)cycle ! condition not to double count
do a = 1, n_act_orb ! First active
aorb = list_act(a)
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
! Do the excitation inactive -- > active
call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin
call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
accu_elec= 0
do inint = 1, N_int
accu_elec+= popcnt(det_tmp(inint,jspin))
enddo
if(accu_elec .ne. elec_num_tab_local(jspin))then
perturb_dets_phase(a,jspin,ispin) = -1000.0d0
perturb_dets_hij(a,jspin,ispin) = 0.d0
cycle
endif
do inint = 1, N_int
perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1)
perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
perturb_dets_phase(a,jspin,ispin) = phase
do istate = 1, N_states
delta_e(a,jspin,istate) = one_creat(a,jspin,istate) + delta_e_inactive_virt(istate)
delta_e_inv(a,jspin,istate) = 1.d0 / delta_e(a,jspin,istate)
enddo
if(ispin == jspin)then
perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) )
else
perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1)
endif
!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet
!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin)
enddo
enddo
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS
!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a_{b} a^{\dagger}_a | Idet>
do jdet = 1, idx(0)
if(degree(jdet)==1)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
i_part = list_act_reverse(exc(1,2,1)) ! a^{\dagger}_{aorb}
i_hole = list_act_reverse(exc(1,1,1)) ! a_{borb}
kspin = 1
index_orb_act_mono(idx(jdet),1) = i_part !!! a^{\dagger}_a
index_orb_act_mono(idx(jdet),2) = i_hole !!! a_{b}
index_orb_act_mono(idx(jdet),3) = 1
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
else
! Mono beta
i_part = list_act_reverse(exc(1,2,2))
i_hole = list_act_reverse(exc(1,1,2))
kspin = 2
index_orb_act_mono(idx(jdet),1) = i_part !!! a^{\dagger}_a
index_orb_act_mono(idx(jdet),2) = i_hole !!! a_{b}
index_orb_act_mono(idx(jdet),3) = 2
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
endif
endif
enddo
do jdet = 1, idx(0)
! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator
! are connected by the presence of the perturbers determinants |det_tmp>
if(degree(jdet) == 1)then
aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb}
borb = index_orb_act_mono(idx(jdet),2) ! a_{borb}
kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation
! the determinants Idet and Jdet interact throw the following operator
! | Jdet > = a_{borb,kspin} a^{\dagger}_{aorb, kspin} | Idet >
accu_contrib = 0.d0
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{i} (ispin)
! if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count
logical :: cycle_same_spin_first_order
cycle_same_spin_first_order = .False.
if(ispin == kspin .and. iorb.le.jorb)then
cycle_same_spin_first_order = .True.
endif
if(ispin .ne. kspin .or. cycle_same_spin_first_order == .False. )then! condition not to double count
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet >
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin)
enddo
! you determine the interaction between the excited determinant and the other parent | Jdet >
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet >
! hja = < det_tmp | H | Jdet >
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
if(kspin == ispin)then
hja = phase * (active_int(borb,1) - active_int(borb,2) )
else
hja = phase * active_int(borb,1)
endif
!! if(dabs(hja).le.1.d-10)cycle
do istate = 1, N_states
accu_contrib(istate) += hja * perturb_dets_hij(aorb,kspin,ispin) * delta_e_inv(aorb,kspin,istate)
enddo
endif
logical :: cycle_same_spin_second_order
!!!! SECOND ORDER CONTRIBUTIONS
!!!! SECOND ORDER CONTRIBTIONS
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{corb,jspin} a_{jorb,jspin} a_{iorb,ispin} | Idet >
do jspin = 1, 2
cycle_same_spin_second_order = .False.
if(ispin == jspin .and. iorb.le.jorb)then
cycle_same_spin_second_order = .True.
endif
if(ispin .ne. jspin .or. cycle_same_spin_second_order == .False. )then! condition not to double count
do corb = 1, n_act_orb
if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
enddo
! | det_tmp_bis > = a^{\dagger}_{aorb,kspin} a_{borb,kspin} a_{iorb,kspin} | Idet >
call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),kspin,i_ok)
if(i_ok .ne. 1)cycle
hia = perturb_dets_hij(corb,jspin,ispin)
if(dabs(hia).le.1.d-10)cycle
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
hab = fock_operator_local(borb,aorb,kspin) * phase
if(dabs(hab).le.1.d-10)cycle
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
if(jspin == ispin)then
hjb = phase * (active_int(corb,1) - active_int(corb,2) )
else
hjb = phase * active_int(corb,1)
endif
if(dabs(hjb).le.1.d-10)cycle
do istate = 1, N_states
accu_contrib(istate)+=hia * delta_e_inv(corb,jspin,istate) & ! | Idet > --> | det_tmp >
! | det_tmp > --> | det_tmp_bis >
*hab / (delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate)) &
*hjb
enddo
enddo ! jspin
endif
enddo
enddo ! ispin
do istate = 1, N_states
matrix_2h1p(idx(jdet),idet,istate) += accu_contrib(istate)
enddo
else if (degree(jdet) == 0 )then
! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations
!
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet >
accu_contrib = 0.d0
do ispin = 1, 2
do kspin = 1, 2
if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count
do a = 1, n_act_orb ! First active
contrib_hij = perturb_dets_hij(a,kspin,ispin) * perturb_dets_hij(a,kspin,ispin)
if(dabs(contrib_hij).le.1.d-10)cycle
do istate = 1, N_states
accu_contrib(istate) += contrib_hij * delta_e_inv(a,kspin,istate)
enddo
enddo
enddo
enddo
do istate =1, N_states
matrix_2h1p(idet,idet,istate) += accu_contrib(istate)
enddo
endif
enddo
enddo
enddo
enddo
enddo
end

283
plugins/MRPT_Utils/second_order_new_2p.irp.f Normal file
View File

@ -0,0 +1,283 @@
subroutine give_2p_new(matrix_2p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_2p(N_det,N_det,*)
integer :: i,v,r,a,b,c
integer :: iorb, vorb, rorb, aorb, borb,corb
integer :: ispin,jspin
integer :: idet,jdet
integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,n_act_orb,2,2)
double precision :: perturb_dets_phase(n_act_orb,n_act_orb,2,2)
double precision :: perturb_dets_hij(n_act_orb,n_act_orb,2,2)
double precision :: perturb_dets_hpsi0(n_act_orb,n_act_orb,2,2,N_states)
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer(bit_kind) :: det_tmp_j(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,n_act_orb,2)
double precision :: hij,phase
double precision :: accu_contrib(N_states)
integer :: degree(N_det)
integer :: idx(0:N_det)
double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states)
double precision :: delta_e_inv(n_act_orb,n_act_orb,2,2,N_states)
double precision :: delta_e_inactive_virt(N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,6)
integer :: kspin
double precision :: delta_e_ja(N_states)
double precision :: hja
double precision :: contrib_hij
double precision :: fock_operator_local(n_act_orb,n_act_orb,2)
double precision :: hij_test
integer ::i_ok
integer(bit_kind) :: det_tmp_bis(N_int,2)
double precision :: hib , hab
double precision :: delta_e_ab(N_states)
double precision :: hib_test,hja_test,hab_test
integer :: i_hole,i_part
double precision :: hia,hjb
integer :: other_spin(2)
other_spin(1) = 2
other_spin(2) = 1
accu_contrib = 0.d0
!matrix_2p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do v = 1, n_virt_orb ! First virtual
vorb = list_virt(v)
do r = 1, n_virt_orb ! Second virtual
rorb = list_virt(r)
! take all the integral you will need for r,v fixed
do a = 1, n_act_orb
aorb = list_act(a)
do b = 1, n_act_orb
borb = list_act(b)
active_int(a,b,1) = get_mo_bielec_integral(aorb,borb,rorb,vorb,mo_integrals_map) ! direct ( a--> r | b--> v )
active_int(a,b,2) = get_mo_bielec_integral(aorb,borb,vorb,rorb,mo_integrals_map) ! exchange ( b--> r | a--> v )
perturb_dets_phase(a,b,1,1) = -1000.d0
perturb_dets_phase(a,b,1,2) = -1000.d0
perturb_dets_phase(a,b,2,2) = -1000.d0
perturb_dets_phase(a,b,2,1) = -1000.d0
perturb_dets_phase(b,a,1,1) = -1000.d0
perturb_dets_phase(b,a,1,2) = -1000.d0
perturb_dets_phase(b,a,2,2) = -1000.d0
perturb_dets_phase(b,a,2,1) = -1000.d0
enddo
enddo
do istate = 1, N_states
delta_e_inactive_virt(istate) = &
- fock_virt_total_spin_trace(rorb,istate) &
- fock_virt_total_spin_trace(vorb,istate)
enddo
do idet = 1, N_det
! call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
call get_excitation_degree_vector(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
do ispin = 1, 2 ! spin of the couple a-a^dagger (aorb,rorb)
do jspin = 1, 2 ! spin of the couple a-a^dagger (borb,vorb)
do b = 1, n_act_orb ! First active
borb = list_act(b)
do a = 1, n_act_orb ! First active
aorb = list_act(a)
! if(ispin == 2.and. jspin ==1)then
! perturb_dets_phase(a,b,ispin,jspin) = -1000.0d0
! perturb_dets_hij(a,b,ispin,jspin) = 0.d0
! cycle ! condition not to double count
! endif
if(ispin == jspin .and. vorb.le.rorb)then
perturb_dets_phase(a,b,ispin,jspin) = -1000.0d0
perturb_dets_hij(a,b,ispin,jspin) = 0.d0
cycle ! condition not to double count
endif
if(ispin == jspin .and. aorb.le.borb) then
perturb_dets_phase(a,b,ispin,jspin) = -1000.0d0
perturb_dets_hij(a,b,ispin,jspin) = 0.d0
cycle ! condition not to double count
endif
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation (aorb,ispin) --> (rorb,ispin)
call clear_bit_to_integer(aorb,det_tmp(1,ispin),N_int) ! hole in "aorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
! Do the excitation (borb,jspin) --> (vorb,jspin)
call clear_bit_to_integer(borb,det_tmp(1,jspin),N_int) ! hole in "borb" of spin Jspin
call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
accu_elec= 0
do inint = 1, N_int
accu_elec+= popcnt(det_tmp(inint,1)) + popcnt(det_tmp(inint,2))
enddo
if(accu_elec .ne. elec_num_tab_local(2)+elec_num_tab_local(1))then
perturb_dets_phase(a,b,ispin,jspin) = -1000.0d0
perturb_dets_hij(a,b,ispin,jspin) = 0.d0
cycle
endif
do inint = 1, N_int
perturb_dets(inint,1,a,b,ispin,jspin) = det_tmp(inint,1)
perturb_dets(inint,2,a,b,ispin,jspin) = det_tmp(inint,2)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
perturb_dets_phase(a,b,ispin,jspin) = phase
do istate = 1, N_states
delta_e(a,b,ispin,jspin,istate) = two_anhil(a,b,ispin,jspin,istate) + delta_e_inactive_virt(istate)
delta_e_inv(a,b,ispin,jspin,istate) = 1.d0 / delta_e(a,b,ispin,jspin,istate)
enddo
if(ispin == jspin)then
perturb_dets_hij(a,b,ispin,jspin) = phase * (active_int(a,b,2) - active_int(a,b,1) )
else
perturb_dets_hij(a,b,ispin,jspin) = phase * active_int(a,b,1)
endif
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij)
if(hij.ne.perturb_dets_hij(a,b,ispin,jspin))then
print*, active_int(a,b,1) , active_int(b,a,1)
double precision :: hmono,hdouble
call i_H_j_verbose(psi_det(1,1,idet),det_tmp,N_int,hij,hmono,hdouble)
print*, 'pb !! hij.ne.perturb_dets_hij(a,b,ispin,jspin)'
print*, ispin,jspin
print*, aorb,rorb,borb,vorb
print*, hij,perturb_dets_hij(a,b,ispin,jspin)
call debug_det(psi_det(1,1,idet),N_int)
call debug_det(det_tmp,N_int)
stop
endif
enddo ! b
enddo ! a
enddo ! jspin
enddo ! ispin
!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS
!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a^{\dagger}_b a_{a} | Idet>
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | K_{ab} | Idet>
do jdet = 1, idx(0)
if(degree(jdet)==1)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
i_hole = list_act_reverse(exc(1,1,1)) !!! a_a
i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b}
kspin = 1 !!! kspin
index_orb_act_mono(idx(jdet),1) = i_hole
index_orb_act_mono(idx(jdet),2) = i_part
index_orb_act_mono(idx(jdet),3) = kspin
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
else
! Mono beta
i_hole = list_act_reverse(exc(1,1,2)) !!! a_a
i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b}
kspin = 2 !!! kspin
index_orb_act_mono(idx(jdet),1) = i_hole
index_orb_act_mono(idx(jdet),2) = i_part
index_orb_act_mono(idx(jdet),3) = kspin
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
endif
else if(degree(jdet)==2)then
call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a ALPHA
index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} ALPHA
index_orb_act_mono(idx(jdet),3) = 1
! Mono beta
index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a BETA
index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} BETA
index_orb_act_mono(idx(jdet),6) = 2
else if (exc(0,1,1) == 2) then
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a ALPHA
index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} ALPHA
index_orb_act_mono(idx(jdet),3) = 1
index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(2,1,1)) !!! a_c ALPHA
index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(2,2,1)) !!! a^{\dagger}_{d} ALPHA
index_orb_act_mono(idx(jdet),6) = 1
else if (exc(0,1,2) == 2) then
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,2)) !!! a_a BETA
index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(2,1,2)) !!! a^{\dagger}_{b} BETA
index_orb_act_mono(idx(jdet),3) = 2
index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,2,2)) !!! a_c BETA
index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(2,2,2)) !!! a^{\dagger}_{d} BETA
index_orb_act_mono(idx(jdet),6) = 2
endif
endif
enddo
! do jdet = 1, idx(0)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS
! if(degree(jdet) == 1)then
! ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator
! ! are connected by the presence of the perturbers determinants |det_tmp>
! aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb}
! borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb}
! kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation
! ! the determinants Idet and Jdet interact throw the following operator
! ! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet >
! accu_contrib = 0.d0
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{a} (ispin)
!!!! SECOND ORDER CONTRIBTIONS
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,jspin} a_{corb,jspin} a_{iorb,ispin} | Idet >
do jspin = 1, 2
if(ispin == 2 .and. jspin ==1)cycle
do b = 1, n_act_orb
do a = 1, n_act_orb
logical :: cycle_same_spin_second_order(2)
cycle_same_spin_second_order(1) = .False.
cycle_same_spin_second_order(2) = .False.
if(perturb_dets_phase(a,b,ispin,jspin).le.-10d0)cycle
if(ispin == jspin .and. vorb.le.rorb)then
cycle_same_spin_second_order(1) = .True.
endif
if(ispin == jspin .and. aorb.le.borb)then
cycle_same_spin_second_order(2) = .True.
endif
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,a,b,ispin,jspin)
det_tmp(inint,2) = perturb_dets(inint,2,a,b,ispin,jspin)
enddo
do jdet = 1, idx(0)
! if(idx(jdet).gt.idet)cycle
do istate = 1, N_states
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij)
matrix_2p(idx(jdet),idet,istate) += hij * perturb_dets_hij(a,b,ispin,jspin) * delta_e_inv(a,b,ispin,jspin,istate)
enddo
enddo ! jdet
enddo ! b
enddo ! a
enddo ! jspin
enddo ! ispin
! else if (degree(jdet) == 0)then
!
! endif
! enddo !! jdet
enddo
enddo
enddo
end

36
plugins/MRPT_Utils/utils_bitmask.irp.f Normal file
View File

@ -0,0 +1,36 @@
subroutine give_active_part_determinant(det_in,det_out)
implicit none
use bitmasks
integer(bit_kind),intent(in) :: det_in(N_int,2)
integer(bit_kind),intent(out) :: det_out(N_int,2)
integer :: i
do i = 1,N_int
det_out(i,1) = iand(det_in(i,1),cas_bitmask(i,1,1))
det_out(i,2) = iand(det_in(i,2),cas_bitmask(i,1,1))
enddo
end
subroutine give_core_inactive_part_determinant(det_in,det_out)
implicit none
use bitmasks
integer(bit_kind),intent(in) :: det_in(N_int,2)
integer(bit_kind),intent(out) :: det_out(N_int,2)
integer :: i
do i = 1,N_int
det_out(i,1) = iand(det_in(i,1),reunion_of_core_inact_bitmask(i,1))
det_out(i,2) = iand(det_in(i,2),reunion_of_core_inact_bitmask(i,1))
enddo
end
subroutine give_virt_part_determinant(det_in,det_out)
implicit none
use bitmasks
integer(bit_kind),intent(in) :: det_in(N_int,2)
integer(bit_kind),intent(out) :: det_out(N_int,2)
integer :: i
do i = 1,N_int
det_out(i,1) = iand(det_in(i,1),virt_bitmask(i,1))
det_out(i,2) = iand(det_in(i,2),virt_bitmask(i,1))
enddo
end

3
plugins/Perturbation/EZFIO.cfg
View File

@ -16,4 +16,5 @@ type: Normalized_float
doc: The selection process stops when the energy ratio variational/(variational+PT2)
is equal to var_pt2_ratio
interface: ezfio,provider,ocaml
default: 0.75
default: 0.75

2
plugins/Perturbation/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Properties Hartree_Fock Davidson
Determinants Properties Hartree_Fock Davidson MRPT_Utils

111
plugins/Perturbation/pt2_equations.irp.f
View File

@ -45,6 +45,37 @@ subroutine pt2_epstein_nesbet ($arguments)
end
subroutine pt2_decontracted ($arguments)
use bitmasks
implicit none
$declarations
BEGIN_DOC
END_DOC
integer :: i,j
double precision :: diag_H_mat_elem_fock, h
double precision :: i_H_psi_array(N_st)
double precision :: coef_pert
PROVIDE selection_criterion
ASSERT (Nint == N_int)
ASSERT (Nint > 0)
!call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array)
call i_H_psi_pert_new_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array,coef_pert)
H_pert_diag = 0.d0
c_pert(1) = coef_pert
e_2_pert(1) = coef_pert * i_H_psi_array(1)
! print*,coef_pert,i_H_psi_array(1)
end
subroutine pt2_epstein_nesbet_2x2 ($arguments)
use bitmasks
implicit none
@ -67,8 +98,8 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments)
ASSERT (Nint == N_int)
ASSERT (Nint > 0)
!call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array)
call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array)
call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array)
!call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array)
h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint)
do i =1,N_st
@ -85,6 +116,75 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments)
c_pert(i) = 0.d0
endif
H_pert_diag(i) = h*c_pert(i)*c_pert(i)
! print*, 'N_det,N_det_selectors = ',N_det,N_det_selectors
! print*, 'threshold_selectors',threshold_selectors
! print*, delta_e,i_H_psi_array(1)
! double precision :: hij,accu
! accu = 0.d0
! do j = 1, N_det
! call i_H_j(det_pert,psi_selectors(1,1,j),N_int,hij)
! print*, 'psi_selectors_coef(j,1 = ',psi_selectors_coef(j,1),psi_coef(j,1)
! call debug_det(psi_det(1,1,i),N_int)
! call debug_det(psi_selectors(1,1,i),N_int)
! accu += psi_selectors_coef(j,1) * hij
! enddo
! print*, 'accu,ihpsi0',accu,i_H_psi_array(1)
! stop
else
e_2_pert(i) = 0.d0
c_pert(i) = 0.d0
H_pert_diag(i) = 0.d0
endif
enddo
! if( e_2_pert(1) .ne. 0.d0)then
! print*,' e_2_pert(1) ', e_2_pert(1)
! endif
end
subroutine pt2_epstein_nesbet_2x2_no_ci_diag($arguments)
use bitmasks
implicit none
$declarations
BEGIN_DOC
! compute the Epstein-Nesbet 2x2 diagonalization coefficient and energetic contribution
!
! for the various N_st states.
!
! e_2_pert(i) = 0.5 * (( <det_pert|H|det_pert> - E(i) ) - sqrt( ( <det_pert|H|det_pert> - E(i)) ^2 + 4 <psi(i)|H|det_pert>^2 )
!
! c_pert(i) = e_2_pert(i)/ <psi(i)|H|det_pert>
!
END_DOC
integer :: i,j
double precision :: diag_H_mat_elem_fock,delta_e, h
double precision :: i_H_psi_array(N_st)
ASSERT (Nint == N_int)
ASSERT (Nint > 0)
PROVIDE psi_energy
call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array)
!call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array)
h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint)
do i =1,N_st
if (i_H_psi_array(i) /= 0.d0) then
delta_e = h - psi_energy(i)
if (delta_e > 0.d0) then
e_2_pert(i) = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * i_H_psi_array(i) * i_H_psi_array(i)))
else
e_2_pert(i) = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * i_H_psi_array(i) * i_H_psi_array(i)))
endif
if (dabs(i_H_psi_array(i)) > 1.d-6) then
c_pert(i) = e_2_pert(i)/i_H_psi_array(i)
else
c_pert(i) = 0.d0
endif
H_pert_diag(i) = h*c_pert(i)*c_pert(i)
else
e_2_pert(i) = 0.d0
c_pert(i) = 0.d0
@ -94,6 +194,8 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments)
end
subroutine pt2_moller_plesset ($arguments)
use bitmasks
implicit none
@ -144,6 +246,11 @@ subroutine pt2_moller_plesset ($arguments)
endif
do i =1,N_st
H_pert_diag(i) = h
! if(dabs(i_H_psi_array(i)).gt.1.d-8)then
! print*, i_H_psi_array(i)
! call debug_det(det_pert,N_int)
! print*, h1,p1,h2,p2,s1,s2
! endif
c_pert(i) = i_H_psi_array(i) *delta_e
e_2_pert(i) = c_pert(i) * i_H_psi_array(i)
enddo

67
plugins/Perturbation/pt2_new.irp.f Normal file
View File

@ -0,0 +1,67 @@
subroutine i_H_psi_pert_new_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,coef_pert)
use bitmasks
implicit none
integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate,idx_key(Ndet), N_minilist
integer(bit_kind), intent(in) :: keys(Nint,2,Ndet)
integer(bit_kind), intent(in) :: key(Nint,2)
double precision, intent(in) :: coef(Ndet_max,Nstate)
double precision, intent(out) :: i_H_psi_array(Nstate)
double precision, intent(out) :: coef_pert
integer :: idx(0:Ndet)
integer :: i, ii,j, i_in_key, i_in_coef
double precision :: phase
integer :: exc(0:2,2,2)
double precision :: hij
double precision :: delta_e_final
double precision :: hjj
BEGIN_DOC
! Computes <i|H|Psi> = \sum_J c_J <i|H|J>.
!
! Uses filter_connected_i_H_psi0 to get all the |J> to which |i>
! is connected. The |J> are searched in short pre-computed lists.
END_DOC
ASSERT (Nint > 0)
ASSERT (N_int == Nint)
ASSERT (Nstate > 0)
ASSERT (Ndet > 0)
ASSERT (Ndet_max >= Ndet)
i_H_psi_array = 0.d0
coef_pert = 0.d0
call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx)
if (Nstate == 1) then
do ii=1,idx(0)
i_in_key = idx(ii)
i_in_coef = idx_key(idx(ii))
!DIR$ FORCEINLINE
call i_H_j(keys(1,1,i_in_key),key,Nint,hij)
i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij
call get_delta_e_dyall(keys(1,1,i_in_key),key,delta_e_final)
coef_pert += coef(i_in_coef,1)*hij / delta_e_final
enddo
if (coef_pert * i_H_psi_array(1) > 0.d0)then
print*, coef_pert * i_H_psi_array(1)
endif
else
do ii=1,idx(0)
i_in_key = idx(ii)
i_in_coef = idx_key(idx(ii))
!DIR$ FORCEINLINE
call i_H_j(keys(1,1,i_in_key),key,Nint,hij)
i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij
do j = 1, Nstate
i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij
enddo
enddo
endif
end

9
plugins/Properties/EZFIO.cfg
View File

@ -2,4 +2,11 @@
type: double precision
doc: z point on which the integrated delta rho is calculated
interface: ezfio,provider,ocaml
default: 3.9
default: 3.9
[threshld_two_bod_dm]
type: double precision
doc: threshold for the values of the alpha/beta two body dm evaluation
interface: ezfio,provider,ocaml
default: 0.000001

2
plugins/Properties/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Determinants
Determinants Davidson

6
plugins/Properties/delta_rho.irp.f
View File

@ -3,9 +3,9 @@
&BEGIN_PROVIDER [double precision, z_max]
&BEGIN_PROVIDER [double precision, delta_z]
implicit none
z_min = -20.d0
z_max = 20.d0
delta_z = 0.1d0
z_min = 0.d0
z_max = 10.d0
delta_z = 0.005d0
N_z_pts = (z_max - z_min)/delta_z
print*,'N_z_pts = ',N_z_pts

35
plugins/Properties/give_mos_at_r.irp.f Normal file
View File

@ -0,0 +1,35 @@
subroutine give_all_act_mos_at_r(r,mos_array)
implicit none
double precision, intent(in) :: r(3)
double precision, intent(out) :: mos_array(n_act_orb)
double precision :: aos_array(ao_num),accu
integer :: i,j,iorb
!print*,'n_act_orb = ',n_act_orb
call give_all_aos_at_r(r,aos_array)
do i = 1, n_act_orb
iorb = list_act(i)
accu = 0.d0
do j = 1, ao_num
accu += mo_coef(j,iorb) * aos_array(j)
enddo
mos_array(i) = accu
enddo
end
subroutine give_all_core_mos_at_r(r,mos_array)
implicit none
double precision, intent(in) :: r(3)
double precision, intent(out) :: mos_array(n_core_orb)
double precision :: aos_array(ao_num),accu
integer :: i,j,iorb
call give_all_aos_at_r(r,aos_array)
do i = 1, n_core_orb
iorb = list_core(i)
accu = 0.d0
do j = 1, ao_num
accu += mo_coef(j,iorb) * aos_array(j)
enddo
mos_array(i) = accu
enddo
end

12
plugins/Properties/hyperfine_constants.irp.f
View File

@ -102,6 +102,11 @@ END_PROVIDER
conversion_factor_gauss_hcc(3) = 619.9027742370165d0
conversion_factor_cm_1_hcc(3) = 579.4924475562677d0
! boron
conversion_factor_mhz_hcc(5) = 1434.3655101868d0
conversion_factor_gauss_hcc(5) = 511.817264334d0
conversion_factor_cm_1_hcc(5) = 478.4528336953d0
! carbon
conversion_factor_mhz_hcc(6) = 1124.18303629792945d0
conversion_factor_gauss_hcc(6) = 401.136570647523058d0
@ -116,6 +121,11 @@ END_PROVIDER
conversion_factor_mhz_hcc(8) = -606.1958551736545d0
conversion_factor_gauss_hcc(8) = -216.30574771560407d0
conversion_factor_cm_1_hcc(8) = -202.20517197179822d0
! Phosphore
conversion_factor_mhz_hcc(15) = 1811.0967763744873d0
conversion_factor_gauss_hcc(15) = 646.2445276897648d0
conversion_factor_cm_1_hcc(15) = 604.1170297381395d0
END_PROVIDER
@ -141,7 +151,7 @@ subroutine print_hcc
integer :: i,j
print*,'Z AU GAUSS MHZ cm^-1'
do i = 1, nucl_num
write(*,'(I2,X,F3.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i)
write(*,'(I2,X,F4.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i)
enddo
end

45
plugins/Properties/iunit_two_bod.irp.f Normal file
View File

@ -0,0 +1,45 @@
BEGIN_PROVIDER [integer, i_unit_x_two_body_dm_ab]
implicit none
integer :: getUnitAndOpen
character*(128) :: file_name
file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_x')
i_unit_x_two_body_dm_ab = getUnitAndOpen(file_name,'w')
END_PROVIDER
BEGIN_PROVIDER [integer, i_unit_y_two_body_dm_ab]
implicit none
integer :: getUnitAndOpen
character*(128) :: file_name
file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_y')
i_unit_y_two_body_dm_ab = getUnitAndOpen(file_name,'w')
END_PROVIDER
BEGIN_PROVIDER [integer, i_unit_z_two_body_extra_diag_dm_ab]
implicit none
integer :: getUnitAndOpen
character*(128) :: file_name
file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_extra_diag')
i_unit_z_two_body_extra_diag_dm_ab = getUnitAndOpen(file_name,'w')
END_PROVIDER
BEGIN_PROVIDER [integer, i_unit_z_two_body_diag_dm_ab]
implicit none
integer :: getUnitAndOpen
character*(128) :: file_name
file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_diag')
i_unit_z_two_body_diag_dm_ab = getUnitAndOpen(file_name,'w')
END_PROVIDER
BEGIN_PROVIDER [integer, i_unit_z_two_body_total_dm_ab]
implicit none
integer :: getUnitAndOpen
character*(128) :: file_name
file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_total')
i_unit_z_two_body_total_dm_ab = getUnitAndOpen(file_name,'w')
END_PROVIDER

15
plugins/Properties/mulliken.irp.f
View File

@ -14,13 +14,16 @@ BEGIN_PROVIDER [double precision, spin_population, (ao_num_align,ao_num)]
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, spin_population_angular_momentum, (0:ao_l_max)]
BEGIN_PROVIDER [double precision, spin_population_angular_momentum, (0:ao_l_max)]
&BEGIN_PROVIDER [double precision, spin_population_angular_momentum_per_atom, (0:ao_l_max,nucl_num)]
implicit none
integer :: i
double precision :: accu
spin_population_angular_momentum = 0.d0
spin_population_angular_momentum_per_atom = 0.d0
do i = 1, ao_num
spin_population_angular_momentum(ao_l(i)) += spin_gross_orbital_product(i)
spin_population_angular_momentum_per_atom(ao_l(i),ao_nucl(i)) += spin_gross_orbital_product(i)
enddo
END_PROVIDER
@ -133,6 +136,16 @@ subroutine print_mulliken_sd
print*,' ',trim(l_to_charater(i)),spin_population_angular_momentum(i)
print*,'sum = ',accu
enddo
print*,'Angular momentum analysis per atom'
print*,'Angular momentum analysis'
do j = 1,nucl_num
accu = 0.d0
do i = 0, ao_l_max
accu += spin_population_angular_momentum_per_atom(i,j)
write(*,'(XX,I3,XX,A4,X,A4,X,F10.7)')j,trim(element_name(int(nucl_charge(j)))),trim(l_to_charater(i)),spin_population_angular_momentum_per_atom(i,j)
print*,'sum = ',accu
enddo
enddo
end

36
plugins/Properties/print_spin_density.irp.f Normal file
View File

@ -0,0 +1,36 @@
program print_sd
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
integer :: i,j,k
double precision :: z
double precision :: r(3),accu,accu_alpha,accu_beta,tmp
double precision, allocatable :: aos_array(:)
allocate(aos_array(ao_num))
r = 0.d0
r(1) = z_min
do i = 1, N_z_pts
call give_all_aos_at_r(r,aos_array)
accu = 0.d0
accu_alpha = 0.d0
accu_beta = 0.d0
do j = 1, ao_num
do k = 1, ao_num
tmp = aos_array(k) * aos_array(j)
accu += one_body_spin_density_ao(k,j) * tmp
accu_alpha += one_body_dm_ao_alpha(k,j) * tmp
accu_beta += one_body_dm_ao_beta(k,j) * tmp
enddo
enddo
r(1) += delta_z
write(33,'(100(f16.10,X))')r(1),accu,accu_alpha,accu_beta
enddo
end

11
plugins/Properties/provide_deltarho.irp.f Normal file
View File

@ -0,0 +1,11 @@
program pouet
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
provide integrated_delta_rho_all_points
end

105
plugins/Properties/test_two_body_dm.irp.f Normal file
View File

@ -0,0 +1,105 @@
program test_two_bod
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
integer :: i,j,k,l
integer :: h1,p1,h2,p2,s1,s2
double precision :: accu,get_two_body_dm_ab_map_element,get_mo_bielec_integral
accu = 0.d0
! Diag part of the core two body dm
do i = 1, n_core_orb
h1 = list_core(i)
do j = 1, n_core_orb
h2 = list_core(j)
accu += two_body_dm_ab_diag_core(j,i) * mo_bielec_integral_jj(h1,h2)
enddo
enddo
! Diag part of the active two body dm
do i = 1, n_act_orb
h1 = list_act(i)
do j = 1, n_act_orb
h2 = list_act(j)
accu += two_body_dm_ab_diag_act(j,i) * mo_bielec_integral_jj(h1,h2)
enddo
enddo
! Diag part of the active <-> core two body dm
do i = 1, n_act_orb
h1 = list_act(i)
do j = 1, n_core_orb
h2 = list_core(j)
accu += two_body_dm_diag_core_act(j,i) * mo_bielec_integral_jj(h1,h2)
enddo
enddo
print*,'BI ELECTRONIC = ',accu
double precision :: accu_extra_diag
accu_extra_diag = 0.d0
! purely active part of the two body dm
do l = 1, n_act_orb ! p2
p2 = list_act(l)
do k = 1, n_act_orb ! h2
h2 = list_act(k)
do j = 1, n_act_orb ! p1
p1 = list_act(j)
do i = 1,n_act_orb ! h1
h1 = list_act(i)
accu_extra_diag += two_body_dm_ab_big_array_act(i,j,k,l) * get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map)
enddo
enddo
enddo
enddo
! core <-> active part of the two body dm
do l = 1, n_act_orb ! p1
p1 = list_act(l)
do k = 1, n_act_orb ! h1
h1 = list_act(k)
do i = 1,n_core_orb ! h2
h2 = list_core(i)
accu_extra_diag += two_body_dm_ab_big_array_core_act(i,k,l) * get_mo_bielec_integral(h1,h2,p1,h2,mo_integrals_map)
enddo
enddo
enddo
print*,'extra_diag = ',accu_extra_diag
double precision :: average_mono
call get_average(mo_mono_elec_integral,one_body_dm_mo,average_mono)
print*,'BI ELECTRONIC = ',accu+accu_extra_diag
print*,'MONO ELECTRONIC = ',average_mono
print*,'Total elec = ',accu+average_mono + accu_extra_diag
print*,'Total = ',accu+average_mono+nuclear_repulsion +accu_extra_diag
double precision :: e_0,hij
call u_0_H_u_0(e_0,psi_coef,n_det,psi_det,N_int)
print*,'<Psi| H |Psi> = ',e_0 + nuclear_repulsion
integer :: degree
integer :: exc(0:2,2,2)
double precision :: phase
integer :: n_elements
n_elements = 0
accu = 0.d0
do i = 1, N_det
do j = i+1, N_det
call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int)
if(degree.gt.2)cycle
! if(degree.ne.1)cycle
call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
if(s1.eq.s2)cycle
n_elements += 1
call i_H_j(psi_det(1,1,i),psi_det(1,1,j),N_int,hij)
accu += 2.d0 * hij * psi_coef(i,1) * psi_coef(j,1)
enddo
enddo
print*,'n_elements = ',n_elements
print*,'<Psi| extra diag ',accu
print*,'dm ',accu_extra_diag
end

2
plugins/Selectors_full/e_corr_selectors.irp.f
View File

@ -56,7 +56,7 @@ END_PROVIDER
i_H_HF_per_selectors(i) = hij
E_corr_per_selectors(i) = psi_selectors_coef(i,1) * hij
E_corr_double_only += E_corr_per_selectors(i)
E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int))
! E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int))
elseif(exc_degree_per_selectors(i) == 0)then
coef_hf_selector = psi_selectors_coef(i,1)
E_corr_per_selectors(i) = -1000.d0

2
plugins/Selectors_full/selectors.irp.f
View File

@ -20,7 +20,7 @@ BEGIN_PROVIDER [ integer, N_det_selectors]
do i=1,N_det
norm = norm + psi_average_norm_contrib_sorted(i)
if (norm > threshold_selectors) then
N_det_selectors = i-1
N_det_selectors = i
exit
endif
enddo

1
plugins/Selectors_no_sorted/selectors.irp.f
View File

@ -40,6 +40,7 @@ END_PROVIDER
do k=1,N_states
do i=1,N_det_selectors
psi_selectors_coef(i,k) = psi_coef(i,k)
! print*, 'psi_selectors_coef(i,k) == ',psi_selectors_coef(i,k)
enddo
enddo
END_PROVIDER

2
plugins/loc_cele/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
MO_Basis
MO_Basis Integrals_Bielec Bitmask

312
plugins/loc_cele/loc_cele.irp.f
View File

@ -92,7 +92,7 @@
nrot(1) = 64 ! number of orbitals to be localized
nrot(1) = 2 ! number of orbitals to be localized
integer :: index_rot(1000,1)
@ -101,261 +101,73 @@
cmoref = 0.d0
irot = 0
! H2 molecule for the mixed localization
do i=1,64
irot(i,1) = i+2
enddo
irot(1,1) = 11
irot(2,1) = 12
cmoref(15,1,1) = 1.d0 !
cmoref(14,2,1) = 1.d0 !
do i=1,17
cmoref(i+1,i,1)=1.d0
enddo
cmoref(19,19-1,1)=1.d0
cmoref(20,19-1,1)=-1.d0
cmoref(19,20-1,1)=-1.d0
cmoref(20,20-1,1)=-1.d0
cmoref(21,20-1,1)=2.d0
cmoref(22,21-1,1)=1.d0
cmoref(23,22-1,1)=1.d0
cmoref(24,23-1,1)=1.d0
! ESATRIENE with 3 bonding and anti bonding orbitals
! First bonding orbital for esa
! cmoref(7,1,1) = 1.d0 !
! cmoref(26,1,1) = 1.d0 !
! Second bonding orbital for esa
! cmoref(45,2,1) = 1.d0 !
! cmoref(64,2,1) = 1.d0 !
! Third bonding orbital for esa
! cmoref(83,3,1) = 1.d0 !
! cmoref(102,3,1) = 1.d0 !
! First anti bonding orbital for esa
! cmoref(7,4,1) = 1.d0 !
! cmoref(26,4,1) = -1.d0 !
! Second anti bonding orbital for esa
! cmoref(45,5,1) = 1.d0 !
! cmoref(64,5,1) = -1.d0 !
! Third anti bonding orbital for esa
! cmoref(83,6,1) = 1.d0 !
! cmoref(102,6,1) = -1.d0 !
! ESATRIENE with 2 bonding and anti bonding orbitals
! AND 2 radical orbitals
! First radical orbital
! cmoref(7,1,1) = 1.d0 !
! First bonding orbital
! cmoref(26,2,1) = 1.d0 !
! cmoref(45,2,1) = 1.d0 !
! Second bonding orbital
! cmoref(64,3,1) = 1.d0 !
! cmoref(83,3,1) = 1.d0 !
! Second radical orbital for esa
! cmoref(102,4,1) = 1.d0 !
! First anti bonding orbital for esa
! cmoref(26,5,1) = 1.d0 !
! cmoref(45,5,1) =-1.d0 !
! Second anti bonding orbital for esa
! cmoref(64,6,1) = 1.d0 !
! cmoref(83,6,1) =-1.d0 !
! ESATRIENE with 1 central bonding and anti bonding orbitals
! AND 4 radical orbitals
! First radical orbital
cmoref(7,1,1) = 1.d0 !
! Second radical orbital
cmoref(26,2,1) = 1.d0 !
! First bonding orbital
cmoref(45,3,1) = 1.d0 !
cmoref(64,3,1) = 1.d0 !
! Third radical orbital for esa
cmoref(83,4,1) = 1.d0 !
! Fourth radical orbital for esa
cmoref(102,5,1) = 1.d0 !
! First anti bonding orbital
cmoref(45,6,1) = 1.d0 !
cmoref(64,6,1) =-1.d0 !
cmoref(25,24-1,1)=1.d0
cmoref(26,24-1,1)=-1.d0
cmoref(25,25-1,1)=-1.d0
cmoref(26,25-1,1)=-1.d0
cmoref(27,25-1,1)=2.d0
cmoref(28,26-1,1)=1.d0
cmoref(29,27-1,1)=1.d0
cmoref(30,28-1,1)=1.d0
cmoref(31,29-1,1)=1.d0
cmoref(32,29-1,1)=-1.d0
cmoref(31,30-1,1)=-1.d0
cmoref(32,30-1,1)=-1.d0
cmoref(33,30-1,1)=2.d0
cmoref(34,31-1,1)=1.d0
cmoref(35,32-1,1)=1.d0
cmoref(36,33-1,1)=1.d0
do i=33,49
cmoref(i+5,i,1)= 1.d0
enddo
cmoref(55,52-2,1)=1.d0
cmoref(56,52-2,1)=-1.d0
cmoref(55,53-2,1)=-1.d0
cmoref(56,53-2,1)=-1.d0
cmoref(57,53-2,1)=2.d0
cmoref(58,54-2,1)=1.d0
cmoref(59,55-2,1)=1.d0
cmoref(60,56-2,1)=1.d0
cmoref(61,57-2,1)=1.d0
cmoref(62,57-2,1)=-1.d0
cmoref(61,58-2,1)=-1.d0
cmoref(62,58-2,1)=-1.d0
cmoref(63,58-2,1)=2.d0
cmoref(64,59-2,1)=1.d0
cmoref(65,60-2,1)=1.d0
cmoref(66,61-2,1)=1.d0
cmoref(67,62-2,1)=1.d0
cmoref(68,62-2,1)=-1.d0
cmoref(67,63-2,1)=-1.d0
cmoref(68,63-2,1)=-1.d0
cmoref(69,63-2,1)=2.d0
cmoref(70,64-2,1)=1.d0
cmoref(71,65-2,1)=1.d0
cmoref(72,66-2,1)=1.d0
! H2 molecule
! do i=1,66
! irot(i,1) = i
! enddo
!
! do i=1,18
! cmoref(i,i,1)=1.d0
! enddo
! cmoref(19,19,1)=1.d0
! cmoref(20,19,1)=-1.d0
! cmoref(19,20,1)=-1.d0
! cmoref(20,20,1)=-1.d0
! cmoref(21,20,1)=2.d0
! cmoref(22,21,1)=1.d0
! cmoref(23,22,1)=1.d0
! cmoref(24,23,1)=1.d0
!
!
! cmoref(25,24,1)=1.d0
! cmoref(26,24,1)=-1.d0
! cmoref(25,25,1)=-1.d0
! cmoref(26,25,1)=-1.d0
! cmoref(27,25,1)=2.d0
! cmoref(28,26,1)=1.d0
! cmoref(29,27,1)=1.d0
! cmoref(30,28,1)=1.d0
!
! cmoref(31,29,1)=1.d0
! cmoref(32,29,1)=-1.d0
! cmoref(31,30,1)=-1.d0
! cmoref(32,30,1)=-1.d0
! cmoref(33,30,1)=2.d0
! cmoref(34,31,1)=1.d0
! cmoref(35,32,1)=1.d0
! cmoref(36,33,1)=1.d0
!
! do i=34,51
! cmoref(i+3,i,1)= 1.d0
! enddo
!
! cmoref(55,52,1)=1.d0
! cmoref(56,52,1)=-1.d0
! cmoref(55,53,1)=-1.d0
! cmoref(56,53,1)=-1.d0
! cmoref(57,53,1)=2.d0
! cmoref(58,54,1)=1.d0
! cmoref(59,55,1)=1.d0
! cmoref(60,56,1)=1.d0
!
! cmoref(61,57,1)=1.d0
! cmoref(62,57,1)=-1.d0
! cmoref(61,58,1)=-1.d0
! cmoref(62,58,1)=-1.d0
! cmoref(63,58,1)=2.d0
! cmoref(64,59,1)=1.d0
! cmoref(65,60,1)=1.d0
! cmoref(66,61,1)=1.d0
!
! cmoref(67,62,1)=1.d0
! cmoref(68,62,1)=-1.d0
! cmoref(67,63,1)=-1.d0
! cmoref(68,63,1)=-1.d0
! cmoref(69,63,1)=2.d0
! cmoref(70,64,1)=1.d0
! cmoref(71,65,1)=1.d0
! cmoref(72,66,1)=1.d0
! H atom
! do i=1,33
! irot(i,1) = i
! enddo
!
! do i=1,18
! cmoref(i,i,1)=1.d0
! enddo
! cmoref(19,19,1)=1.d0
! cmoref(20,19,1)=-1.d0
! cmoref(19,20,1)=-1.d0
! cmoref(20,20,1)=-1.d0
! cmoref(21,20,1)=2.d0
! cmoref(22,21,1)=1.d0
! cmoref(23,22,1)=1.d0
! cmoref(24,23,1)=1.d0
! cmoref(25,24,1)=1.d0
! cmoref(26,24,1)=-1.d0
! cmoref(25,25,1)=-1.d0
! cmoref(26,25,1)=-1.d0
! cmoref(27,25,1)=2.d0
! cmoref(28,26,1)=1.d0
! cmoref(29,27,1)=1.d0
! cmoref(30,28,1)=1.d0
!
! cmoref(31,29,1)=1.d0
! cmoref(32,29,1)=-1.d0
! cmoref(31,30,1)=-1.d0
! cmoref(32,30,1)=-1.d0
! cmoref(33,30,1)=2.d0
! cmoref(34,31,1)=1.d0
! cmoref(35,32,1)=1.d0
! cmoref(36,33,1)=1.d0
! Definition of the index of the MO to be rotated
! irot(2,1) = 21 ! the first mo to be rotated is the 21 th MO
! irot(3,1) = 22 ! etc....
! irot(4,1) = 23 !
! irot(5,1) = 24 !
! irot(6,1) = 25 !
!N2
! irot(1,1) = 5
! irot(2,1) = 6
! irot(3,1) = 7
! irot(4,1) = 8
! irot(5,1) = 9
! irot(6,1) = 10
!
! cmoref(5,1,1) = 1.d0 !
! cmoref(6,2,1) = 1.d0 !
! cmoref(7,3,1) = 1.d0 !
! cmoref(40,4,1) = 1.d0 !
! cmoref(41,5,1) = 1.d0 !
! cmoref(42,6,1) = 1.d0 !
!END N2
!HEXATRIENE
! irot(1,1) = 20
! irot(2,1) = 21
! irot(3,1) = 22
! irot(4,1) = 23
! irot(5,1) = 24
! irot(6,1) = 25
!
! cmoref(7,1,1) = 1.d0 !
! cmoref(26,1,1) = 1.d0 !
! cmoref(45,2,1) = 1.d0 !
! cmoref(64,2,1) = 1.d0 !
! cmoref(83,3,1) = 1.d0 !
! cmoref(102,3,1) = 1.d0 !
! cmoref(7,4,1) = 1.d0 !
! cmoref(26,4,1) = -1.d0 !
! cmoref(45,5,1) = 1.d0 !
! cmoref(64,5,1) = -1.d0 !
! cmoref(83,6,1) = 1.d0 !
! cmoref(102,6,1) = -1.d0 !
!END HEXATRIENE
!!!!H2 H2 CAS
! irot(1,1) = 1
! irot(2,1) = 2
!
! cmoref(1,1,1) = 1.d0
! cmoref(37,2,1) = 1.d0
!END H2
!!!! LOCALIZATION ON THE BASIS FUNCTIONS
! do i = 1, nrot(1)
! irot(i,1) = i
! cmoref(i,i,1) = 1.d0
! enddo
!END BASISLOC
! do i = 1, nrot(1)
! irot(i,1) = 4+i
! enddo
do i = 1, nrot(1)
print*,'irot(i,1) = ',irot(i,1)
enddo
! pause
! you define the guess vectors that you want
! the new MO to be close to
! cmore(i,j,1) = < AO_i | guess_vector_MO(j) >
! i goes from 1 to ao_num
! j goes from 1 to nrot(1)
! Here you must go to the GAMESS output file
! where the AOs are listed and explicited
! From the basis of this knowledge you can build your
! own guess vectors for the MOs
! The new MOs are provided in output
! in the same order than the guess MOs
! do i = 1, nrot(1)
! j = 5+(i-1)*15
! cmoref(j,i,1) = 0.2d0
! cmoref(j+3,i,1) = 0.12d0
! print*,'j = ',j
! enddo
! pause

110
plugins/loc_cele/loc_exchange_int.irp.f Normal file
View File

@ -0,0 +1,110 @@
program loc_int
implicit none
integer :: i,j,k,l,iorb,jorb
double precision :: exchange_int(mo_tot_num)
integer :: iorder(mo_tot_num)
integer :: indices(mo_tot_num,2)
logical :: list_core_inact_check(mo_tot_num)
integer :: n_rot
indices = 0
list_core_inact_check = .True.
n_rot = 0
do i = 1, n_core_inact_orb
iorb = list_core_inact(i)
exchange_int = 0.d0
iorder = 0
print*,''
if(list_core_inact_check(iorb) == .False.)cycle
do j = i+1, n_core_inact_orb
jorb = list_core_inact(j)
iorder(jorb) = jorb
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
enddo
n_rot += 1
call dsort(exchange_int,iorder,mo_tot_num)
indices(n_rot,1) = iorb
indices(n_rot,2) = iorder(1)
list_core_inact_check(iorder(1)) = .False.
print*,indices(n_rot,1),indices(n_rot,2)
print*,''
print*,''
enddo
print*,'****************************'
print*,'-+++++++++++++++++++++++++'
do i = 1, n_rot
iorb = indices(i,1)
jorb = indices(i,2)
print*,iorb,jorb
call mix_mo_jk(iorb,jorb)
enddo
indices = 0
list_core_inact_check = .True.
n_rot = 0
do i = 1, n_act_orb
iorb = list_act(i)
exchange_int = 0.d0
iorder = 0
print*,''
if(list_core_inact_check(iorb) == .False.)cycle
do j = i+1, n_act_orb
jorb = list_act(j)
iorder(jorb) = jorb
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
enddo
n_rot += 1
call dsort(exchange_int,iorder,mo_tot_num)
indices(n_rot,1) = iorb
indices(n_rot,2) = iorder(1)
list_core_inact_check(iorder(1)) = .False.
print*,indices(n_rot,1),indices(n_rot,2)
print*,''
print*,''
enddo
print*,'****************************'
print*,'-+++++++++++++++++++++++++'
do i = 1, n_rot
iorb = indices(i,1)
jorb = indices(i,2)
print*,iorb,jorb
call mix_mo_jk(iorb,jorb)
enddo
indices = 0
list_core_inact_check = .True.
n_rot = 0
do i = 1, n_virt_orb
iorb = list_virt(i)
exchange_int = 0.d0
iorder = 0
print*,''
if(list_core_inact_check(iorb) == .False.)cycle
do j = i+1, n_virt_orb
jorb = list_virt(j)
iorder(jorb) = jorb
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
enddo
n_rot += 1
call dsort(exchange_int,iorder,mo_tot_num)
indices(n_rot,1) = iorb
indices(n_rot,2) = iorder(1)
list_core_inact_check(iorder(1)) = .False.
print*,indices(n_rot,1),indices(n_rot,2)
print*,''
print*,''
enddo
print*,'****************************'
print*,'-+++++++++++++++++++++++++'
do i = 1, n_rot
iorb = indices(i,1)
jorb = indices(i,2)
print*,iorb,jorb
call mix_mo_jk(iorb,jorb)
enddo
call save_mos
end

45
plugins/loc_cele/loc_exchange_int_act.irp.f Normal file
View File

@ -0,0 +1,45 @@
program loc_int
implicit none
integer :: i,j,k,l,iorb,jorb
double precision :: exchange_int(mo_tot_num)
integer :: iorder(mo_tot_num)
integer :: indices(mo_tot_num,2)
logical :: list_core_inact_check(mo_tot_num)
integer :: n_rot
indices = 0
list_core_inact_check = .True.
n_rot = 0
do i = 1, n_act_orb
iorb = list_act(i)
exchange_int = 0.d0
iorder = 0
print*,''
if(list_core_inact_check(iorb) == .False.)cycle
do j = i+1, n_act_orb
jorb = list_act(j)
iorder(jorb) = jorb
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
enddo
n_rot += 1
call dsort(exchange_int,iorder,mo_tot_num)
indices(n_rot,1) = iorb
indices(n_rot,2) = iorder(1)
list_core_inact_check(iorder(1)) = .False.
print*,indices(n_rot,1),indices(n_rot,2)
print*,''
print*,''
enddo
print*,'****************************'
print*,'-+++++++++++++++++++++++++'
do i = 1, n_rot
iorb = indices(i,1)
jorb = indices(i,2)
print*,iorb,jorb
call mix_mo_jk(iorb,jorb)
enddo
call save_mos
end

45
plugins/loc_cele/loc_exchange_int_inact.irp.f Normal file
View File

@ -0,0 +1,45 @@
program loc_int
implicit none
integer :: i,j,k,l,iorb,jorb
double precision :: exchange_int(mo_tot_num)
integer :: iorder(mo_tot_num)
integer :: indices(mo_tot_num,2)
logical :: list_core_inact_check(mo_tot_num)
integer :: n_rot
indices = 0
list_core_inact_check = .True.
n_rot = 0
do i = 1, n_core_inact_orb
iorb = list_core_inact(i)
exchange_int = 0.d0
iorder = 0
print*,''
if(list_core_inact_check(iorb) == .False.)cycle
do j = i+1, n_core_inact_orb
jorb = list_core_inact(j)
iorder(jorb) = jorb
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
enddo
n_rot += 1
call dsort(exchange_int,iorder,mo_tot_num)
indices(n_rot,1) = iorb
indices(n_rot,2) = iorder(1)
list_core_inact_check(iorder(1)) = .False.
print*,indices(n_rot,1),indices(n_rot,2)
print*,''
print*,''
enddo
print*,'****************************'
print*,'-+++++++++++++++++++++++++'
do i = 1, n_rot
iorb = indices(i,1)
jorb = indices(i,2)
print*,iorb,jorb
call mix_mo_jk(iorb,jorb)
enddo
call save_mos
end

47
plugins/loc_cele/loc_exchange_int_virt.irp.f Normal file
View File

@ -0,0 +1,47 @@
program loc_int
implicit none
integer :: i,j,k,l,iorb,jorb
double precision :: exchange_int(mo_tot_num)
integer :: iorder(mo_tot_num)
integer :: indices(mo_tot_num,2)
logical :: list_core_inact_check(mo_tot_num)
integer :: n_rot
indices = 0
list_core_inact_check = .True.
n_rot = 0
do i = 1, n_virt_orb
iorb = list_virt(i)
exchange_int = 0.d0
iorder = 0
print*,''
if(list_core_inact_check(iorb) == .False.)cycle
do j = i+1, n_virt_orb
jorb = list_virt(j)
iorder(jorb) = jorb
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
enddo
n_rot += 1
call dsort(exchange_int,iorder,mo_tot_num)
indices(n_rot,1) = iorb
indices(n_rot,2) = iorder(1)
list_core_inact_check(iorder(1)) = .False.
print*,indices(n_rot,1),indices(n_rot,2)
print*,''
print*,''
enddo
print*,'****************************'
print*,'-+++++++++++++++++++++++++'
do i = 1, n_rot
iorb = indices(i,1)
jorb = indices(i,2)
print*,iorb,jorb
call mix_mo_jk(iorb,jorb)
enddo
call save_mos
end

55
scripts/generate_h_apply.py
View File

@ -18,6 +18,14 @@ filter1h
filter1p
only_2p_single
only_2p_double
only_2h_single
only_2h_double
only_1h_single
only_1h_double
only_1p_single
only_1p_double
only_2h1p_single
only_2h1p_double
filter_only_1h1p_single
filter_only_1h1p_double
filter_only_1h2p_single
@ -198,14 +206,55 @@ class H_apply(object):
if (is_a_1p(hole)) cycle
"""
def filter_only_2h(self):
self["only_2h_single"] = """
! ! DIR$ FORCEINLINE
if (is_a_2h(hole).eqv. .False.) cycle
"""
self["only_2h_double"] = """
! ! DIR$ FORCEINLINE
if ( is_a_2h(key).eqv. .False. )cycle
"""
def filter_only_1h(self):
self["only_1h_single"] = """
! ! DIR$ FORCEINLINE
if (is_a_1h(hole) .eqv. .False.) cycle
"""
self["only_1h_double"] = """
! ! DIR$ FORCEINLINE
if (is_a_1h(key) .eqv. .False.) cycle
"""
def filter_only_1p(self):
self["only_1p_single"] = """
! ! DIR$ FORCEINLINE
if ( is_a_1p(hole) .eqv. .False.) cycle
"""
self["only_1p_double"] = """
! ! DIR$ FORCEINLINE
if ( is_a_1p(key) .eqv. .False.) cycle
"""
def filter_only_2h1p(self):
self["only_2h1p_single"] = """
! ! DIR$ FORCEINLINE
if ( is_a_2h1p(hole) .eqv. .False.) cycle
"""
self["only_2h1p_double"] = """
! ! DIR$ FORCEINLINE
if (is_a_2h1p(key) .eqv. .False.) cycle
"""
def filter_only_2p(self):
self["only_2p_single"] = """
! ! DIR$ FORCEINLINE
if (.not. is_a_2p(hole)) cycle
if (is_a_2p(hole).eqv. .False.) cycle
"""
self["only_2p_double"] = """
! ! DIR$ FORCEINLINE
if (.not. is_a_2p(key)) cycle
if (is_a_2p(key).eqv. .False.) cycle
"""
@ -224,7 +273,7 @@ class H_apply(object):
! ! DIR$ FORCEINLINE
if (is_a_two_holes_two_particles(hole).eqv..False.) cycle
"""
self["filter_only_1h1p_double"] = """
self["filter_only_2h2p_double"] = """
! ! DIR$ FORCEINLINE
if (is_a_two_holes_two_particles(key).eqv..False.) cycle
"""

18
src/AO_Basis/aos.irp.f
View File

@ -17,7 +17,7 @@ END_PROVIDER
call ezfio_get_ao_basis_ao_prim_num_max(ao_prim_num_max)
integer :: align_double
ao_prim_num_max_align = align_double(ao_prim_num_max)
END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_normalized, (ao_num_align,ao_prim_num_max) ]
&BEGIN_PROVIDER [ double precision, ao_coef_normalization_factor, (ao_num) ]
@ -145,6 +145,7 @@ END_PROVIDER
BEGIN_PROVIDER [ integer, ao_l, (ao_num) ]
&BEGIN_PROVIDER [ integer, ao_l_max ]
&BEGIN_PROVIDER [ character*(128), ao_l_char, (ao_num) ]
implicit none
BEGIN_DOC
! ao_l = l value of the AO: a+b+c in x^a y^b z^c
@ -152,6 +153,7 @@ END_PROVIDER
integer :: i
do i=1,ao_num
ao_l(i) = ao_power(i,1) + ao_power(i,2) + ao_power(i,3)
ao_l_char(i) = l_to_charater(ao_l(i))
enddo
ao_l_max = maxval(ao_l)
END_PROVIDER
@ -179,20 +181,6 @@ integer function ao_power_index(nx,ny,nz)
ao_power_index = ((l-nx)*(l-nx+1))/2 + nz + 1
end
BEGIN_PROVIDER [ integer, ao_l, (ao_num) ]
&BEGIN_PROVIDER [ integer, ao_l_max ]
&BEGIN_PROVIDER [ character*(128), ao_l_char, (ao_num) ]
implicit none
BEGIN_DOC
! ao_l = l value of the AO: a+b+c in x^a y^b z^c
END_DOC
integer :: i
do i=1,ao_num
ao_l(i) = ao_power(i,1) + ao_power(i,2) + ao_power(i,3)
ao_l_char(i) = l_to_charater(ao_l(i))
enddo
ao_l_max = maxval(ao_l)
END_PROVIDER
BEGIN_PROVIDER [ character*(128), l_to_charater, (0:4)]
BEGIN_DOC

360
src/Bitmask/bitmask_cas_routines.irp.f
View File

@ -1,107 +1,113 @@
use bitmasks
integer function number_of_holes(key_in)
! function that returns the number of holes in the inact space
BEGIN_DOC
! Function that returns the number of holes in the inact space
END_DOC
implicit none
integer(bit_kind), intent(in) :: key_in(N_int,2)
integer :: i
number_of_holes = 0
if(N_int == 1)then
number_of_holes = number_of_holes &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )
else if(N_int == 2)then
number_of_holes = number_of_holes &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )
else if(N_int == 3)then
number_of_holes = number_of_holes &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )&
+ popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )&
+ popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )
else if(N_int == 4)then
number_of_holes = number_of_holes &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )&
+ popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )&
+ popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )&
+ popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )&
+ popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )
else if(N_int == 5)then
number_of_holes = number_of_holes &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )&
+ popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )&
+ popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )&
+ popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )&
+ popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )&
+ popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )&
+ popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )
else if(N_int == 6)then
number_of_holes = number_of_holes &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )&
+ popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )&
+ popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )&
+ popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )&
+ popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )&
+ popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )&
+ popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )&
+ popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )&
+ popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) )
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) )
else if(N_int == 7)then
number_of_holes = number_of_holes &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )&
+ popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )&
+ popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )&
+ popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )&
+ popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )&
+ popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )&
+ popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )&
+ popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )&
+ popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) )&
+ popcnt( xor( iand(inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), inact_bitmask(7,1)) )&
+ popcnt( xor( iand(inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), inact_bitmask(7,2)) )
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), reunion_of_core_inact_bitmask(7,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), reunion_of_core_inact_bitmask(7,2)) )
else if(N_int == 8)then
number_of_holes = number_of_holes &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )&
+ popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )&
+ popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )&
+ popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )&
+ popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )&
+ popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )&
+ popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )&
+ popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )&
+ popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) )&
+ popcnt( xor( iand(inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), inact_bitmask(8,1)) )&
+ popcnt( xor( iand(inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), inact_bitmask(8,2)) )
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), reunion_of_core_inact_bitmask(8,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), reunion_of_core_inact_bitmask(8,2)) )
else
do i = 1, N_int
number_of_holes = number_of_holes &
+ popcnt( xor( iand(inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), inact_bitmask(i,1)) )&
+ popcnt( xor( iand(inact_bitmask(i,2), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1)))), inact_bitmask(i,2)) )
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) )
enddo
endif
end
integer function number_of_particles(key_in)
BEGIN_DOC
! function that returns the number of particles in the virtual space
END_DOC
implicit none
integer(bit_kind), intent(in) :: key_in(N_int,2)
integer :: i
@ -204,11 +210,13 @@ integer function number_of_particles(key_in)
end
logical function is_a_two_holes_two_particles(key_in)
BEGIN_DOC
! logical function that returns True if the determinant 'key_in'
! belongs to the 2h-2p excitation class of the DDCI space
! this is calculated using the CAS_bitmask that defines the active
! orbital space, the inact_bitmasl that defines the inactive oribital space
! and the virt_bitmask that defines the virtual orbital space
END_DOC
implicit none
integer(bit_kind), intent(in) :: key_in(N_int,2)
integer :: i,i_diff
@ -221,163 +229,163 @@ logical function is_a_two_holes_two_particles(key_in)
i_diff = 0
if(N_int == 1)then
i_diff = i_diff &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) &
+ popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) &
+ popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) )
else if(N_int == 2)then
i_diff = i_diff &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) &
+ popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) &
+ popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) &
+ popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) &
+ popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) )
else if(N_int == 3)then
i_diff = i_diff &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) &
+ popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) &
+ popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) &
+ popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) &
+ popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) &
+ popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) &
+ popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) &
+ popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) &
+ popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) )
else if(N_int == 4)then
i_diff = i_diff &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) &
+ popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) &
+ popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) &
+ popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) &
+ popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) &
+ popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) &
+ popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) &
+ popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) &
+ popcnt( iand( iand( xor(key_in(4,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) &
+ popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) &
+ popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) &
+ popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) &
+ popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) )
else if(N_int == 5)then
i_diff = i_diff &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) &
+ popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) &
+ popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) &
+ popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) &
+ popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) &
+ popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) &
+ popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) &
+ popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) &
+ popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) &
+ popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) &
+ popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) &
+ popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) &
+ popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) &
+ popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) ) &
+ popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) &
+ popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) &
+ popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) )
else if(N_int == 6)then
i_diff = i_diff &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) &
+ popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) &
+ popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) &
+ popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) &
+ popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) &
+ popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) &
+ popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) &
+ popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) &
+ popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) &
+ popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) &
+ popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) &
+ popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) &
+ popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) &
+ popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) ) &
+ popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) &
+ popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) &
+ popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) &
+ popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) ) &
+ popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) ) &
+ popcnt( iand( iand( xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1))), virt_bitmask(6,1) ), virt_bitmask(6,1)) ) &
+ popcnt( iand( iand( xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1))), virt_bitmask(6,2) ), virt_bitmask(6,2)) )
else if(N_int == 7)then
i_diff = i_diff &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) &
+ popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) &
+ popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) &
+ popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) &
+ popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) &
+ popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) &
+ popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) &
+ popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) &
+ popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) &
+ popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) &
+ popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) &
+ popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) &
+ popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) &
+ popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) ) &
+ popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) &
+ popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) &
+ popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) &
+ popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) ) &
+ popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) ) &
+ popcnt( iand( iand( xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1))), virt_bitmask(6,1) ), virt_bitmask(6,1)) ) &
+ popcnt( iand( iand( xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1))), virt_bitmask(6,2) ), virt_bitmask(6,2)) ) &
+ popcnt( xor( iand(inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), inact_bitmask(7,1)) ) &
+ popcnt( xor( iand(inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), inact_bitmask(7,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), reunion_of_core_inact_bitmask(7,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), reunion_of_core_inact_bitmask(7,2)) ) &
+ popcnt( iand( iand( xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1))), virt_bitmask(7,1) ), virt_bitmask(7,1)) ) &
+ popcnt( iand( iand( xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1))), virt_bitmask(7,2) ), virt_bitmask(7,2)) )
else if(N_int == 8)then
i_diff = i_diff &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) &
+ popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) &
+ popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
+ popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) &
+ popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) &
+ popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) &
+ popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) &
+ popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) &
+ popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) &
+ popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) &
+ popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) &
+ popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) &
+ popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) &
+ popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) &
+ popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) ) &
+ popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) &
+ popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) &
+ popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) &
+ popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) ) &
+ popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) ) &
+ popcnt( iand( iand( xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1))), virt_bitmask(6,1) ), virt_bitmask(6,1)) ) &
+ popcnt( iand( iand( xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1))), virt_bitmask(6,2) ), virt_bitmask(6,2)) ) &
+ popcnt( xor( iand(inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), inact_bitmask(7,1)) ) &
+ popcnt( xor( iand(inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), inact_bitmask(7,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), reunion_of_core_inact_bitmask(7,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), reunion_of_core_inact_bitmask(7,2)) ) &
+ popcnt( iand( iand( xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1))), virt_bitmask(7,1) ), virt_bitmask(7,1)) ) &
+ popcnt( iand( iand( xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1))), virt_bitmask(7,2) ), virt_bitmask(7,2)) ) &
+ popcnt( xor( iand(inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), inact_bitmask(8,1)) ) &
+ popcnt( xor( iand(inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), inact_bitmask(8,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), reunion_of_core_inact_bitmask(8,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), reunion_of_core_inact_bitmask(8,2)) ) &
+ popcnt( iand( iand( xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1))), virt_bitmask(8,1) ), virt_bitmask(8,1)) ) &
+ popcnt( iand( iand( xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1))), virt_bitmask(8,2) ), virt_bitmask(8,2)) )
@ -385,8 +393,8 @@ logical function is_a_two_holes_two_particles(key_in)
do i = 1, N_int
i_diff = i_diff &
+ popcnt( xor( iand(inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), inact_bitmask(i,1)) ) &
+ popcnt( xor( iand(inact_bitmask(i,2), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1)))), inact_bitmask(i,2)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) ) &
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(i,2), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1)))), reunion_of_core_inact_bitmask(i,2)) ) &
+ popcnt( iand( iand( xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1))), virt_bitmask(i,1) ), virt_bitmask(i,1)) ) &
+ popcnt( iand( iand( xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1))), virt_bitmask(i,2) ), virt_bitmask(i,2)) )
enddo
@ -398,7 +406,9 @@ logical function is_a_two_holes_two_particles(key_in)
integer function number_of_holes_verbose(key_in)
BEGIN_DOC
! function that returns the number of holes in the inact space
END_DOC
implicit none
integer(bit_kind), intent(in) :: key_in(N_int,2)
integer :: i
@ -410,23 +420,25 @@ integer function number_of_holes_verbose(key_in)
key_tmp(1,1) = xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))
key_tmp(1,2) = xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,1,1)))
call debug_det(key_tmp,N_int)
key_tmp(1,1) = iand(key_tmp(1,1),inact_bitmask(1,1))
key_tmp(1,2) = iand(key_tmp(1,2),inact_bitmask(1,2))
key_tmp(1,1) = iand(key_tmp(1,1),reunion_of_core_inact_bitmask(1,1))
key_tmp(1,2) = iand(key_tmp(1,2),reunion_of_core_inact_bitmask(1,2))
call debug_det(key_tmp,N_int)
key_tmp(1,1) = xor(key_tmp(1,1),inact_bitmask(1,1))
key_tmp(1,2) = xor(key_tmp(1,2),inact_bitmask(1,2))
key_tmp(1,1) = xor(key_tmp(1,1),reunion_of_core_inact_bitmask(1,1))
key_tmp(1,2) = xor(key_tmp(1,2),reunion_of_core_inact_bitmask(1,2))
call debug_det(key_tmp,N_int)
! number_of_holes_verbose = number_of_holes_verbose + popcnt(key_tmp(1,1)) &
! + popcnt(key_tmp(1,2))
number_of_holes_verbose = number_of_holes_verbose &
+ popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&
+ popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&
+ popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )
print*,'----------------------'
end
integer function number_of_particles_verbose(key_in)
BEGIN_DOC
! function that returns the number of particles in the inact space
END_DOC
implicit none
integer(bit_kind), intent(in) :: key_in(N_int,2)
integer :: i
@ -473,6 +485,17 @@ logical function is_a_1h2p(key_in)
end
logical function is_a_2h1p(key_in)
implicit none
integer(bit_kind), intent(in) :: key_in(N_int,2)
integer :: number_of_particles, number_of_holes
is_a_2h1p = .False.
if(number_of_holes(key_in).eq.2 .and. number_of_particles(key_in).eq.1)then
is_a_2h1p = .True.
endif
end
logical function is_a_1h(key_in)
implicit none
integer(bit_kind), intent(in) :: key_in(N_int,2)
@ -506,3 +529,34 @@ logical function is_a_2p(key_in)
end
logical function is_a_2h(key_in)
implicit none
integer(bit_kind), intent(in) :: key_in(N_int,2)
integer :: number_of_particles, number_of_holes
is_a_2h = .False.
if(number_of_holes(key_in).eq.2 .and. number_of_particles(key_in).eq.0)then
is_a_2h = .True.
endif
end
logical function is_i_in_virtual(i)
implicit none
integer,intent(in) :: i
integer(bit_kind) :: key(N_int)
integer :: k,j
integer :: accu
is_i_in_virtual = .False.
key= 0_bit_kind
k = ishft(i-1,-bit_kind_shift)+1
j = i-ishft(k-1,bit_kind_shift)-1
key(k) = ibset(key(k),j)
accu = 0
do k = 1, N_int
accu += popcnt(iand(key(k),virt_bitmask(k,1)))
enddo
if(accu .ne. 0)then
is_i_in_virtual = .True.
endif
end

137
src/Bitmask/bitmasks.irp.f
View File

@ -37,6 +37,30 @@ BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ]
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), core_inact_act_bitmask_4, (N_int,4) ]
implicit none
integer :: i
do i=1,N_int
core_inact_act_bitmask_4(i,1) = reunion_of_core_inact_act_bitmask(i,1)
core_inact_act_bitmask_4(i,2) = reunion_of_core_inact_act_bitmask(i,1)
core_inact_act_bitmask_4(i,3) = reunion_of_core_inact_act_bitmask(i,1)
core_inact_act_bitmask_4(i,4) = reunion_of_core_inact_act_bitmask(i,1)
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask_4, (N_int,4) ]
implicit none
integer :: i
do i=1,N_int
virt_bitmask_4(i,1) = virt_bitmask(i,1)
virt_bitmask_4(i,2) = virt_bitmask(i,1)
virt_bitmask_4(i,3) = virt_bitmask(i,1)
virt_bitmask_4(i,4) = virt_bitmask(i,1)
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), HF_bitmask, (N_int,2)]
implicit none
@ -369,11 +393,19 @@ END_PROVIDER
BEGIN_PROVIDER [ integer, list_inact, (n_inact_orb)]
&BEGIN_PROVIDER [ integer, list_virt, (n_virt_orb)]
&BEGIN_PROVIDER [ integer, list_inact_reverse, (mo_tot_num)]
&BEGIN_PROVIDER [ integer, list_virt_reverse, (mo_tot_num)]
BEGIN_DOC
! list_inact : List of the inactive orbitals which are supposed to be doubly excited
! in post CAS methods
! list_virt : List of vritual orbitals which are supposed to be recieve electrons
! in post CAS methods
! list_inact_reverse : reverse list of inactive orbitals
! list_inact_reverse(i) = 0 ::> not an inactive
! list_inact_reverse(i) = k ::> IS the kth inactive
! list_virt_reverse : reverse list of virtual orbitals
! list_virt_reverse(i) = 0 ::> not an virtual
! list_virt_reverse(i) = k ::> IS the kth virtual
END_DOC
implicit none
integer :: occ_inact(N_int*bit_kind_size)
@ -381,25 +413,58 @@ END_PROVIDER
occ_inact = 0
call bitstring_to_list(inact_bitmask(1,1), occ_inact(1), itest, N_int)
ASSERT(itest==n_inact_orb)
list_inact_reverse = 0
do i = 1, n_inact_orb
list_inact(i) = occ_inact(i)
list_inact_reverse(occ_inact(i)) = i
enddo
occ_inact = 0
call bitstring_to_list(virt_bitmask(1,1), occ_inact(1), itest, N_int)
ASSERT(itest==n_virt_orb)
list_virt_reverse = 0
do i = 1, n_virt_orb
list_virt(i) = occ_inact(i)
list_virt_reverse(occ_inact(i)) = i
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, list_core_inact, (n_core_inact_orb)]
&BEGIN_PROVIDER [ integer, list_core_inact_reverse, (mo_tot_num)]
implicit none
integer :: occ_inact(N_int*bit_kind_size)
integer :: itest,i
occ_inact = 0
call bitstring_to_list(reunion_of_core_inact_bitmask(1,1), occ_inact(1), itest, N_int)
list_core_inact_reverse = 0
do i = 1, n_core_inact_orb
list_core_inact(i) = occ_inact(i)
list_core_inact_reverse(occ_inact(i)) = i
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, n_core_inact_orb ]
implicit none
integer :: i
n_core_inact_orb = 0
do i = 1, N_int
n_core_inact_orb += popcnt(reunion_of_core_inact_bitmask(i,1))
enddo
ENd_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)]
implicit none
BEGIN_DOC
! Reunion of the inactive, active and virtual bitmasks
! Reunion of the core and inactive and virtual bitmasks
END_DOC
integer :: i,j
integer :: i
do i = 1, N_int
reunion_of_core_inact_bitmask(i,1) = ior(core_bitmask(i,1),inact_bitmask(i,1))
reunion_of_core_inact_bitmask(i,2) = ior(core_bitmask(i,2),inact_bitmask(i,2))
@ -407,6 +472,36 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask, (N_int,2)]
&BEGIN_PROVIDER [ integer, n_core_inact_act_orb ]
implicit none
BEGIN_DOC
! Reunion of the core, inactive and active bitmasks
END_DOC
integer :: i,j
n_core_inact_act_orb = 0
do i = 1, N_int
reunion_of_core_inact_act_bitmask(i,1) = ior(reunion_of_core_inact_bitmask(i,1),cas_bitmask(i,1,1))
reunion_of_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),cas_bitmask(i,1,1))
n_core_inact_act_orb +=popcnt(reunion_of_core_inact_act_bitmask(i,1))
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, list_core_inact_act, (n_core_inact_act_orb)]
&BEGIN_PROVIDER [ integer, list_core_inact_act_reverse, (mo_tot_num)]
implicit none
integer :: occ_inact(N_int*bit_kind_size)
integer :: itest,i
occ_inact = 0
call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), occ_inact(1), itest, N_int)
list_inact_reverse = 0
do i = 1, n_core_inact_act_orb
list_core_inact_act(i) = occ_inact(i)
list_core_inact_act_reverse(occ_inact(i)) = i
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask, (N_int,2)]
@ -423,6 +518,7 @@ END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), inact_virt_bitmask, (N_int,2)]
&BEGIN_PROVIDER [ integer(bit_kind), core_inact_virt_bitmask, (N_int,2)]
implicit none
BEGIN_DOC
! Reunion of the inactive and virtual bitmasks
@ -431,10 +527,13 @@ END_PROVIDER
do i = 1, N_int
inact_virt_bitmask(i,1) = ior(inact_bitmask(i,1),virt_bitmask(i,1))
inact_virt_bitmask(i,2) = ior(inact_bitmask(i,2),virt_bitmask(i,2))
core_inact_virt_bitmask(i,1) = ior(core_bitmask(i,1),inact_virt_bitmask(i,1))
core_inact_virt_bitmask(i,2) = ior(core_bitmask(i,2),inact_virt_bitmask(i,2))
enddo
END_PROVIDER
BEGIN_PROVIDER [integer, list_core, (n_core_orb)]
&BEGIN_PROVIDER [integer, list_core_reverse, (mo_tot_num)]
BEGIN_DOC
! List of the core orbitals that are never excited in post CAS method
END_DOC
@ -444,8 +543,10 @@ END_PROVIDER
occ_core = 0
call bitstring_to_list(core_bitmask(1,1), occ_core(1), itest, N_int)
ASSERT(itest==n_core_orb)
list_core_reverse = 0
do i = 1, n_core_orb
list_core(i) = occ_core(i)
list_core_reverse(occ_core(i)) = i
enddo
END_PROVIDER
@ -458,8 +559,8 @@ END_PROVIDER
integer :: i,j
n_core_orb = 0
do i = 1, N_int
core_bitmask(i,1) = xor(closed_shell_ref_bitmask(i,1),reunion_of_cas_inact_bitmask(i,1))
core_bitmask(i,2) = xor(closed_shell_ref_bitmask(i,2),reunion_of_cas_inact_bitmask(i,2))
core_bitmask(i,1) = xor(full_ijkl_bitmask(i),ior(reunion_of_cas_inact_bitmask(i,1),virt_bitmask(i,1)))
core_bitmask(i,2) = xor(full_ijkl_bitmask(i),ior(reunion_of_cas_inact_bitmask(i,2),virt_bitmask(i,1)))
n_core_orb += popcnt(core_bitmask(i,1))
enddo
print*,'n_core_orb = ',n_core_orb
@ -497,11 +598,17 @@ BEGIN_PROVIDER [ integer, n_act_orb]
do i = 1, N_int
n_act_orb += popcnt(cas_bitmask(i,1,1))
enddo
print*,'n_act_orb = ',n_act_orb
END_PROVIDER
BEGIN_PROVIDER [integer, list_act, (n_act_orb)]
BEGIN_PROVIDER [integer, list_act, (n_act_orb)]
&BEGIN_PROVIDER [integer, list_act_reverse, (mo_tot_num)]
BEGIN_DOC
! list of active orbitals
! list_act(i) = index of the ith active orbital
!
! list_act_reverse : reverse list of active orbitals
! list_act_reverse(i) = 0 ::> not an active
! list_act_reverse(i) = k ::> IS the kth active orbital
END_DOC
implicit none
integer :: occ_act(N_int*bit_kind_size)
@ -509,10 +616,11 @@ BEGIN_PROVIDER [integer, list_act, (n_act_orb)]
occ_act = 0
call bitstring_to_list(cas_bitmask(1,1,1), occ_act(1), itest, N_int)
ASSERT(itest==n_act_orb)
list_act_reverse = 0
do i = 1, n_act_orb
list_act(i) = occ_act(i)
list_act_reverse(occ_act(i)) = i
enddo
END_PROVIDER
BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)]
@ -537,4 +645,19 @@ END_PROVIDER
enddo
END_PROVIDER
BEGIN_PROVIDER [integer, n_core_orb_allocate]
implicit none
n_core_orb_allocate = max(n_core_orb,1)
END_PROVIDER
BEGIN_PROVIDER [integer, n_inact_orb_allocate]
implicit none
n_inact_orb_allocate = max(n_inact_orb,1)
END_PROVIDER
BEGIN_PROVIDER [integer, n_virt_orb_allocate]
implicit none
n_virt_orb_allocate = max(n_virt_orb,1)
END_PROVIDER

16
src/Davidson/diagonalization.irp.f
View File

@ -324,8 +324,17 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia
double precision :: cpu, wall
include 'constants.include.F'
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, y, h, lambda
if(store_full_H_mat) then
stop 'TODO : put S^2 in stor_full_H_mat'
endif
if(store_full_H_mat.and.sze.le.n_det_max_stored)then
provide H_matrix_all_dets
endif
PROVIDE nuclear_repulsion
call write_time(iunit)
@ -418,6 +427,13 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia
! -----------------------------------------
call H_u_0_nstates(W(1,1,iter),U(1,1,iter),H_jj,sze,dets_in,Nint,N_st_diag,sze_8)
! do k=1,N_st
! if(store_full_H_mat.and.sze.le.n_det_max_stored)then
! call H_u_0_stored(W(1,k,iter),U(1,k,iter),H_matrix_all_dets,sze)
! else
! call H_u_0(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint)
! endif
! enddo
! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>

86
src/Davidson/diagonalize_CI_mono.irp.f
View File

@ -1,86 +0,0 @@
BEGIN_PROVIDER [ double precision, CI_electronic_energy_mono, (N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_eigenvectors_mono, (N_det,N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2_mono, (N_states_diag) ]
implicit none
BEGIN_DOC
! Eigenvectors/values of the CI matrix
END_DOC
integer :: i,j
do j=1,N_states_diag
do i=1,N_det
CI_eigenvectors_mono(i,j) = psi_coef(i,j)
enddo
enddo
if (diag_algorithm == "Davidson") then
call davidson_diag(psi_det,CI_eigenvectors_mono,CI_electronic_energy, &
size(CI_eigenvectors_mono,1),N_det,N_states,N_states_diag,N_int,output_determinants)
else if (diag_algorithm == "Lapack") then
double precision, allocatable :: eigenvectors(:,:), eigenvalues(:)
allocate (eigenvectors(size(H_matrix_all_dets,1),N_det))
allocate (eigenvalues(N_det))
call lapack_diag(eigenvalues,eigenvectors, &
H_matrix_all_dets,size(H_matrix_all_dets,1),N_det)
CI_electronic_energy_mono(:) = 0.d0
do i=1,N_det
CI_eigenvectors_mono(i,1) = eigenvectors(i,1)
enddo
integer :: i_state
double precision :: s2
i_state = 0
if (s2_eig) then
do j=1,N_det
call get_s2_u0(psi_det,eigenvectors(1,j),N_det,s2,N_det)
if(dabs(s2-expected_s2).le.0.3d0)then
print*,'j = ',j
print*,'e = ',eigenvalues(j)
print*,'c = ',dabs(eigenvectors(1,j))
if(dabs(eigenvectors(1,j)).gt.0.9d0)then
i_state += 1
do i=1,N_det
CI_eigenvectors_mono(i,i_state) = eigenvectors(i,j)
enddo
CI_electronic_energy_mono(i_state) = eigenvalues(j)
CI_eigenvectors_s2_mono(i_state) = s2
endif
endif
if (i_state.ge.N_states_diag) then
exit
endif
enddo
else
do j=1,N_states_diag
call get_s2_u0(psi_det,eigenvectors(1,j),N_det,s2,N_det)
if(dabs(eigenvectors(1,j)).gt.0.9d0)then
i_state += 1
do i=1,N_det
CI_eigenvectors_mono(i,i_state) = eigenvectors(i,j)
enddo
CI_electronic_energy_mono(i_state) = eigenvalues(j)
CI_eigenvectors_s2_mono(i_state) = s2
endif
enddo
endif
deallocate(eigenvectors,eigenvalues)
endif
END_PROVIDER
subroutine diagonalize_CI_mono
implicit none
BEGIN_DOC
! Replace the coefficients of the CI states by the coefficients of the
! eigenstates of the CI matrix
END_DOC
integer :: i,j
do j=1,N_states_diag
do i=1,N_det
psi_coef(i,j) = CI_eigenvectors_mono(i,j)
enddo
enddo
SOFT_TOUCH psi_coef CI_electronic_energy_mono CI_eigenvectors_mono CI_eigenvectors_s2_mono
end

16
src/Davidson/diagonalize_restart_and_save_all_states.irp.f Normal file
View File

@ -0,0 +1,16 @@
program diag_and_save
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
call diagonalize_CI
print*,'N_det = ',N_det
call save_wavefunction_general(N_det,N_states_diag,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted)
end

25
src/Davidson/diagonalize_restart_and_save_lowest_state.irp.f Normal file
View File

@ -0,0 +1,25 @@
program diag_and_save
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
print*,'N_det = ',N_det
call diagonalize_CI
integer :: igood_state
igood_state=1
double precision, allocatable :: psi_coef_tmp(:)
allocate(psi_coef_tmp(n_det))
integer :: i
do i = 1, N_det
psi_coef_tmp(i) = psi_coef(i,igood_state)
enddo
call save_wavefunction_general(N_det,1,psi_det,n_det,psi_coef_tmp)
deallocate(psi_coef_tmp)
end

26
src/Davidson/diagonalize_restart_and_save_one_state.irp.f Normal file
View File

@ -0,0 +1,26 @@
program diag_and_save
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
print*,'N_det = ',N_det
call diagonalize_CI
write(*,*)'Which state would you like to save ?'
integer :: igood_state
read(5,*)igood_state
double precision, allocatable :: psi_coef_tmp(:)
allocate(psi_coef_tmp(n_det))
integer :: i
do i = 1, N_det
psi_coef_tmp(i) = psi_coef(i,igood_state)
enddo
call save_wavefunction_general(N_det,1,psi_det,n_det,psi_coef_tmp)
deallocate(psi_coef_tmp)
end

176
src/Davidson/print_H_matrix_restart.irp.f Normal file
View File

@ -0,0 +1,176 @@
program print_H_matrix_restart
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
use bitmasks
implicit none
integer :: i,j
integer, allocatable :: H_matrix_degree(:,:)
double precision, allocatable :: H_matrix_phase(:,:)
integer :: degree
integer(bit_kind), allocatable :: keys_tmp(:,:,:)
allocate(keys_tmp(N_int,2,N_det))
do i = 1, N_det
print*,''
call debug_det(psi_det(1,1,i),N_int)
do j = 1, N_int
keys_tmp(j,1,i) = psi_det(j,1,i)
keys_tmp(j,2,i) = psi_det(j,2,i)
enddo
enddo
if(N_det.ge.10000)then
print*,'Warning !!!'
print*,'Number of determinants is ',N_det
print*,'It means that the H matrix will be enormous !'
print*,'stoppping ..'
stop
endif
print*,''
print*,'Determinants '
do i = 1, N_det
enddo
allocate(H_matrix_degree(N_det,N_det),H_matrix_phase(N_det,N_det))
integer :: exc(0:2,2,2)
double precision :: phase
do i = 1, N_det
do j = i, N_det
call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int)
H_matrix_degree(i,j) = degree
H_matrix_degree(j,i) = degree
phase = 0.d0
if(degree==1.or.degree==2)then
call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int)
endif
H_matrix_phase(i,j) = phase
H_matrix_phase(j,i) = phase
enddo
enddo
print*,'H matrix '
double precision :: ref_h_matrix,s2
ref_h_matrix = H_matrix_all_dets(1,1)
print*,'HF like determinant energy = ',ref_bitmask_energy+nuclear_repulsion
print*,'Ref element of H_matrix = ',ref_h_matrix+nuclear_repulsion
print*,'Printing the H matrix ...'
print*,''
print*,''
!do i = 1, N_det
! H_matrix_all_dets(i,i) -= ref_h_matrix
!enddo
do i = 1, N_det
H_matrix_all_dets(i,i) += nuclear_repulsion
enddo
!do i = 5,N_det
! H_matrix_all_dets(i,3) = 0.d0
! H_matrix_all_dets(3,i) = 0.d0
! H_matrix_all_dets(i,4) = 0.d0
! H_matrix_all_dets(4,i) = 0.d0
!enddo
do i = 1, N_det
write(*,'(I3,X,A3,1000(F16.7))')i,' | ',H_matrix_all_dets(i,:)
enddo
print*,''
print*,''
print*,''
print*,'Printing the degree of excitations within the H matrix'
print*,''
print*,''
do i = 1, N_det
write(*,'(I3,X,A3,X,1000(I1,X))')i,' | ',H_matrix_degree(i,:)
enddo
print*,''
print*,''
print*,'Printing the phase of the Hamiltonian matrix elements '
print*,''
print*,''
do i = 1, N_det
write(*,'(I3,X,A3,X,1000(F3.0,X))')i,' | ',H_matrix_phase(i,:)
enddo
print*,''
double precision, allocatable :: eigenvectors(:,:), eigenvalues(:)
double precision, allocatable :: s2_eigvalues(:)
allocate (eigenvectors(size(H_matrix_all_dets,1),N_det))
allocate (eigenvalues(N_det),s2_eigvalues(N_det))
call lapack_diag(eigenvalues,eigenvectors, &
H_matrix_all_dets,size(H_matrix_all_dets,1),N_det)
print*,'Two first eigenvectors '
call u_0_S2_u_0(s2_eigvalues,eigenvectors,n_det,keys_tmp,N_int,N_det,size(eigenvectors,1))
do j =1, N_states
print*,'s2 = ',s2_eigvalues(j)
print*,'e = ',eigenvalues(j)
print*,'coefs : '
do i = 1, N_det
print*,'i = ',i,eigenvectors(i,j)
enddo
if(j>1)then
print*,'Delta E(H) = ',eigenvalues(1) - eigenvalues(j)
print*,'Delta E(eV) = ',(eigenvalues(1) - eigenvalues(j))*27.2114d0
endif
enddo
double precision :: get_mo_bielec_integral,k_a_iv,k_b_iv
integer :: h1,p1,h2,p2
h1 = 10
p1 = 16
h2 = 14
p2 = 14
!h1 = 1
!p1 = 4
!h2 = 2
!p2 = 2
k_a_iv = get_mo_bielec_integral(h1,h2,p2,p1,mo_integrals_map)
h2 = 15
p2 = 15
k_b_iv = get_mo_bielec_integral(h1,h2,p2,p1,mo_integrals_map)
print*,'k_a_iv = ',k_a_iv
print*,'k_b_iv = ',k_b_iv
double precision :: k_av,k_bv,k_ai,k_bi
h1 = 16
p1 = 14
h2 = 14
p2 = 16
k_av = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map)
h1 = 16
p1 = 15
h2 = 15
p2 = 16
k_bv = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map)
h1 = 10
p1 = 14
h2 = 14
p2 = 10
k_ai = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map)
h1 = 10
p1 = 15
h2 = 15
p2 = 10
k_bi = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map)
print*,'k_av, k_bv = ',k_av,k_bv
print*,'k_ai, k_bi = ',k_ai,k_bi
double precision :: k_iv
h1 = 10
p1 = 16
h2 = 16
p2 = 10
k_iv = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map)
print*,'k_iv = ',k_iv
end

13
src/Determinants/EZFIO.cfg
View File

@ -106,3 +106,16 @@ interface: ezfio,provider,ocaml
doc: Energy that should be obtained when truncating the wave function (optional)
type: Energy
default: 0.
[store_full_H_mat]
type: logical
doc: If True, the Davidson diagonalization is performed by storing the full H matrix up to n_det_max_stored. Be careful, it can cost a lot of memory but can also save a lot of CPU time
interface: ezfio,provider,ocaml
default: False
[n_det_max_stored]
type: Det_number_max
doc: Maximum number of determinants for which the full H matrix is stored. Be careful, the memory requested scales as 10*n_det_max_stored**2. For instance, 90000 determinants represent a matrix of size 60 Gb.
interface: ezfio,provider,ocaml
default: 90000

16
src/Determinants/H_apply.irp.f
View File

@ -214,13 +214,8 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
duplicate(i) = .False.
enddo
found_duplicates = .False.
i=0
j=0
do while (i<N_det-1)
i = max(i+1,j)
do i=1,N_det-1
if (duplicate(i)) then
found_duplicates = .True.
cycle
endif
j = i+1
@ -244,6 +239,14 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
enddo
enddo
found_duplicates = .False.
do i=1,N_det
if (duplicate(i)) then
found_duplicates = .True.
exit
endif
enddo
if (found_duplicates) then
call write_bool(output_determinants,found_duplicates,'Found duplicate determinants')
k=0
@ -303,7 +306,6 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc)
call omp_unset_lock(H_apply_buffer_lock(1,iproc))
end
subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,i_generator,N_st,task_id)
use f77_zmq
implicit none

16
src/Determinants/H_apply.template.f
View File

@ -181,6 +181,8 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
logical :: is_a_1h
logical :: is_a_1p
logical :: is_a_2p
logical :: is_a_2h1p
logical :: is_a_2h
logical :: b_cycle
check_double_excitation = .True.
iproc = iproc_in
@ -312,6 +314,10 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
$filter_only_1h2p_double
$filter_only_2h2p_double
$only_2p_double
$only_2h_double
$only_1h_double
$only_1p_double
$only_2h1p_double
key_idx += 1
do k=1,N_int
keys_out(k,1,key_idx) = key(k,1)
@ -363,6 +369,10 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
$filter_only_1h2p_double
$filter_only_2h2p_double
$only_2p_double
$only_2h_double
$only_1h_double
$only_1p_double
$only_2h1p_double
key_idx += 1
do k=1,N_int
keys_out(k,1,key_idx) = key(k,1)
@ -429,6 +439,8 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato
integer(bit_kind) :: key_mask(N_int, 2)
logical :: check_double_excitation
logical :: is_a_2h1p
logical :: is_a_2h
logical :: is_a_1h1p
logical :: is_a_1h2p
logical :: is_a_1h
@ -504,6 +516,10 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato
$filterparticle
hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a)
$only_2p_single
$only_2h_single
$only_1h_single
$only_1p_single
$only_2h1p_single
$filter1h
$filter1p
$filter2p

2
src/Determinants/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Integrals_Monoelec Integrals_Bielec
Integrals_Monoelec Integrals_Bielec

81
src/Determinants/create_excitations.irp.f
View File

@ -31,10 +31,78 @@ subroutine do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok)
n_elec_tmp += popcnt(key_in(i,1)) + popcnt(key_in(i,2))
enddo
if(n_elec_tmp .ne. elec_num)then
!print*, n_elec_tmp,elec_num
!call debug_det(key_in,N_int)
i_ok = -1
endif
end
subroutine do_spin_flip(key_in,i_flip,ispin,i_ok)
implicit none
BEGIN_DOC
! flip the spin ispin in the orbital i_flip
! on key_in
! ispin = 1 == alpha
! ispin = 2 == beta
! i_ok = 1 == the flip is possible
! i_ok = -1 == the flip is not possible
END_DOC
integer, intent(in) :: i_flip,ispin
integer(bit_kind), intent(inout) :: key_in(N_int,2)
integer, intent(out) :: i_ok
integer :: k,j,i
integer(bit_kind) :: key_tmp(N_int,2)
i_ok = -1
key_tmp = 0_bit_kind
k = ishft(i_flip-1,-bit_kind_shift)+1
j = i_flip-ishft(k-1,bit_kind_shift)-1
key_tmp(k,1) = ibset(key_tmp(k,1),j)
integer :: other_spin(2)
other_spin(1) = 2
other_spin(2) = 1
if(popcnt(iand(key_tmp(k,1),key_in(k,ispin))) == 1 .and. popcnt(iand(key_tmp(k,1),key_in(k,other_spin(ispin)))) == 0 )then
! There is a spin "ispin" in the orbital i_flip AND There is no electron of opposit spin in the same orbital "i_flip"
key_in(k,ispin) = ibclr(key_in(k,ispin),j) ! destroy the electron ispin in the orbital i_flip
key_in(k,other_spin(ispin)) = ibset(key_in(k,other_spin(ispin)),j) ! create an electron of spin other_spin in the same orbital
i_ok = 1
else
return
endif
end
logical function is_spin_flip_possible(key_in,i_flip,ispin)
implicit none
BEGIN_DOC
! returns .True. if the spin-flip of spin ispin in the orbital i_flip is possible
! on key_in
END_DOC
integer, intent(in) :: i_flip,ispin
integer(bit_kind), intent(in) :: key_in(N_int,2)
integer :: k,j,i
integer(bit_kind) :: key_tmp(N_int,2)
is_spin_flip_possible = .False.
key_tmp = 0_bit_kind
k = ishft(i_flip-1,-bit_kind_shift)+1
j = i_flip-ishft(k-1,bit_kind_shift)-1
key_tmp(k,1) = ibset(key_tmp(k,1),j)
integer :: other_spin(2)
other_spin(1) = 2
other_spin(2) = 1
if(popcnt(iand(key_tmp(k,1),key_in(k,ispin))) == 1 .and. popcnt(iand(key_tmp(k,1),key_in(k,other_spin(ispin)))) == 0 )then
! There is a spin "ispin" in the orbital i_flip AND There is no electron of opposit spin in the same orbital "i_flip"
is_spin_flip_possible = .True.
return
else
return
endif
end
subroutine set_bit_to_integer(i_physical,key,Nint)
use bitmasks
implicit none
@ -45,3 +113,16 @@ subroutine set_bit_to_integer(i_physical,key,Nint)
j = i_physical-ishft(k-1,bit_kind_shift)-1
key(k) = ibset(key(k),j)
end
subroutine clear_bit_to_integer(i_physical,key,Nint)
use bitmasks
implicit none
integer, intent(in) :: i_physical,Nint
integer(bit_kind), intent(inout) :: key(Nint)
integer :: k,j,i
k = ishft(i_physical-1,-bit_kind_shift)+1
j = i_physical-ishft(k-1,bit_kind_shift)-1
key(k) = ibclr(key(k),j)
end

69
src/Determinants/density_matrix.irp.f
View File

@ -1,5 +1,22 @@
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num) ]
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_average, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_average, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix for each state
END_DOC
integer :: i
one_body_dm_mo_alpha_average = 0.d0
one_body_dm_mo_beta_average = 0.d0
do i = 1,N_states
one_body_dm_mo_alpha_average(:,:) += one_body_dm_mo_alpha(:,:,i) * state_average_weight(i)
one_body_dm_mo_beta_average(:,:) += one_body_dm_mo_beta(:,:,i) * state_average_weight(i)
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num,N_states) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num,N_states) ]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix for each state
@ -11,36 +28,31 @@
double precision :: phase
integer :: h1,h2,p1,p2,s1,s2, degree
integer :: exc(0:2,2,2),n_occ(2)
double precision, allocatable :: tmp_a(:,:), tmp_b(:,:)
double precision, allocatable :: tmp_a(:,:,:), tmp_b(:,:,:)
if(only_single_double_dm)then
print*,'ONLY DOUBLE DM'
one_body_dm_mo_alpha = one_body_single_double_dm_mo_alpha
one_body_dm_mo_beta = one_body_single_double_dm_mo_beta
else
one_body_dm_mo_alpha = 0.d0
one_body_dm_mo_beta = 0.d0
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, &
!$OMP tmp_a, tmp_b, n_occ)&
!$OMP SHARED(psi_det,psi_coef,N_int,N_states,state_average_weight,elec_alpha_num,&
!$OMP SHARED(psi_det,psi_coef,N_int,N_states,elec_alpha_num,&
!$OMP elec_beta_num,one_body_dm_mo_alpha,one_body_dm_mo_beta,N_det,mo_tot_num_align,&
!$OMP mo_tot_num)
allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) )
allocate(tmp_a(mo_tot_num_align,mo_tot_num,N_states), tmp_b(mo_tot_num_align,mo_tot_num,N_states) )
tmp_a = 0.d0
tmp_b = 0.d0
!$OMP DO SCHEDULE(dynamic)
do k=1,N_det
call bitstring_to_list_ab(psi_det(1,1,k), occ, n_occ, N_int)
do m=1,N_states
ck = psi_coef(k,m)*psi_coef(k,m) * state_average_weight(m)
ck = psi_coef(k,m)*psi_coef(k,m)
do l=1,elec_alpha_num
j = occ(l,1)
tmp_a(j,j) += ck
tmp_a(j,j,m) += ck
enddo
do l=1,elec_beta_num
j = occ(l,2)
tmp_b(j,j) += ck
tmp_b(j,j,m) += ck
enddo
enddo
do l=1,k-1
@ -51,28 +63,27 @@
call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
do m=1,N_states
ckl = psi_coef(k,m) * psi_coef(l,m) * phase * state_average_weight(m)
ckl = psi_coef(k,m) * psi_coef(l,m) * phase
if (s1==1) then
tmp_a(h1,p1) += ckl
tmp_a(p1,h1) += ckl
tmp_a(h1,p1,m) += ckl
tmp_a(p1,h1,m) += ckl
else
tmp_b(h1,p1) += ckl
tmp_b(p1,h1) += ckl
tmp_b(h1,p1,m) += ckl
tmp_b(p1,h1,m) += ckl
endif
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
one_body_dm_mo_alpha = one_body_dm_mo_alpha + tmp_a
one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:)
!$OMP END CRITICAL
!$OMP CRITICAL
one_body_dm_mo_beta = one_body_dm_mo_beta + tmp_b
one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:)
!$OMP END CRITICAL
deallocate(tmp_a,tmp_b)
!$OMP END PARALLEL
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ]
@ -163,7 +174,7 @@ BEGIN_PROVIDER [ double precision, one_body_dm_mo, (mo_tot_num_align,mo_tot_num)
BEGIN_DOC
! One-body density matrix
END_DOC
one_body_dm_mo = one_body_dm_mo_alpha + one_body_dm_mo_beta
one_body_dm_mo = one_body_dm_mo_alpha_average + one_body_dm_mo_beta_average
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_body_spin_density_mo, (mo_tot_num_align,mo_tot_num) ]
@ -171,7 +182,7 @@ BEGIN_PROVIDER [ double precision, one_body_spin_density_mo, (mo_tot_num_align,m
BEGIN_DOC
! rho(alpha) - rho(beta)
END_DOC
one_body_spin_density_mo = one_body_dm_mo_alpha - one_body_dm_mo_beta
one_body_spin_density_mo = one_body_dm_mo_alpha_average - one_body_dm_mo_beta_average
END_PROVIDER
subroutine set_natural_mos
@ -238,17 +249,19 @@ END_PROVIDER
END_DOC
implicit none
integer :: i,j,k,l
double precision :: dm_mo
double precision :: mo_alpha,mo_beta
one_body_spin_density_ao = 0.d0
one_body_dm_ao_alpha = 0.d0
one_body_dm_ao_beta = 0.d0
do k = 1, ao_num
do l = 1, ao_num
do i = 1, mo_tot_num
do j = 1, mo_tot_num
dm_mo = one_body_dm_mo_alpha(j,i)
mo_alpha = one_body_dm_mo_alpha_average(j,i)
mo_beta = one_body_dm_mo_beta_average(j,i)
! if(dabs(dm_mo).le.1.d-10)cycle
one_body_dm_ao_alpha(l,k) += mo_coef(k,i) * mo_coef(l,j) * dm_mo
one_body_dm_ao_beta(l,k) += mo_coef(k,i) * mo_coef(l,j) * dm_mo
one_body_dm_ao_alpha(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_alpha
one_body_dm_ao_beta(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_beta
enddo
enddo

27
src/Determinants/diagonalize_restart_and_save_two_states.irp.f Normal file
View File

@ -0,0 +1,27 @@
program diag_and_save
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
integer :: igood_state_1,igood_state_2
double precision, allocatable :: psi_coef_tmp(:,:)
integer :: i
print*,'N_det = ',N_det
!call diagonalize_CI
write(*,*)'Which couple of states would you like to save ?'
read(5,*)igood_state_1,igood_state_2
allocate(psi_coef_tmp(n_det,2))
do i = 1, N_det
psi_coef_tmp(i,1) = psi_coef(i,igood_state_1)
psi_coef_tmp(i,2) = psi_coef(i,igood_state_2)
enddo
call save_wavefunction_general(N_det,2,psi_det,n_det,psi_coef_tmp)
deallocate(psi_coef_tmp)
end

154
src/Determinants/mono_excitations.irp.f Normal file
View File

@ -0,0 +1,154 @@
use bitmasks
BEGIN_PROVIDER [integer(bit_kind), ref_closed_shell_bitmask, (N_int,2)]
implicit none
integer :: i,i0
integer :: n_occ_ab(2)
integer :: occ(N_int*bit_kind_size,2)
call bitstring_to_list_ab(ref_bitmask, occ, n_occ_ab, N_int)
! do the closed shell determinant
do i = 1, N_int
ref_closed_shell_bitmask(i,1) = ref_bitmask(i,1)
ref_closed_shell_bitmask(i,2) = ref_bitmask(i,2)
enddo
do i0 = elec_beta_num+1, elec_alpha_num
i=occ(i0,1)
call clear_bit_to_integer(i,ref_closed_shell_bitmask(1,1),N_int)
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_tot_num_align, mo_tot_num) ]
implicit none
integer :: i0,j0,i,j,k0,k
integer :: n_occ_ab(2)
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab_virt(2)
integer :: occ_virt(N_int*bit_kind_size,2)
integer(bit_kind) :: key_test(N_int)
integer(bit_kind) :: key_virt(N_int,2)
call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int)
do i = 1, N_int
key_virt(i,1) = full_ijkl_bitmask(i)
key_virt(i,2) = full_ijkl_bitmask(i)
key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask(i,1))
key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask(i,2))
enddo
double precision :: array_coulomb(mo_tot_num),array_exchange(mo_tot_num)
call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
! docc ---> virt mono excitations
do i0 = 1, n_occ_ab(1)
i=occ(i0,1)
do j0 = 1, n_occ_ab_virt(1)
j = occ_virt(j0,1)
call get_mo_bielec_integrals_coulomb_ii(i,j,mo_tot_num,array_coulomb,mo_integrals_map)
call get_mo_bielec_integrals_exch_ii(i,j,mo_tot_num,array_exchange,mo_integrals_map)
double precision :: accu
accu = 0.d0
do k0 = 1, n_occ_ab(1)
k = occ(k0,1)
accu += 2.d0 * array_coulomb(k) - array_exchange(k)
enddo
fock_operator_closed_shell_ref_bitmask(i,j) = accu + mo_mono_elec_integral(i,j)
fock_operator_closed_shell_ref_bitmask(j,i) = accu + mo_mono_elec_integral(i,j)
enddo
enddo
! virt ---> virt mono excitations
do i0 = 1, n_occ_ab_virt(1)
i=occ_virt(i0,1)
do j0 = 1, n_occ_ab_virt(1)
j = occ_virt(j0,1)
call get_mo_bielec_integrals_coulomb_ii(i,j,mo_tot_num,array_coulomb,mo_integrals_map)
call get_mo_bielec_integrals_exch_ii(i,j,mo_tot_num,array_exchange,mo_integrals_map)
accu = 0.d0
do k0 = 1, n_occ_ab(1)
k = occ(k0,1)
accu += 2.d0 * array_coulomb(k) - array_exchange(k)
enddo
fock_operator_closed_shell_ref_bitmask(i,j) = accu+ mo_mono_elec_integral(i,j)
fock_operator_closed_shell_ref_bitmask(j,i) = accu+ mo_mono_elec_integral(i,j)
enddo
enddo
! docc ---> docc mono excitations
do i0 = 1, n_occ_ab(1)
i=occ(i0,1)
do j0 = 1, n_occ_ab(1)
j = occ(j0,1)
call get_mo_bielec_integrals_coulomb_ii(i,j,mo_tot_num,array_coulomb,mo_integrals_map)
call get_mo_bielec_integrals_exch_ii(i,j,mo_tot_num,array_exchange,mo_integrals_map)
accu = 0.d0
do k0 = 1, n_occ_ab(1)
k = occ(k0,1)
accu += 2.d0 * array_coulomb(k) - array_exchange(k)
enddo
fock_operator_closed_shell_ref_bitmask(i,j) = accu+ mo_mono_elec_integral(i,j)
fock_operator_closed_shell_ref_bitmask(j,i) = accu+ mo_mono_elec_integral(i,j)
enddo
enddo
END_PROVIDER
subroutine get_mono_excitation_from_fock(det_1,det_2,h,p,spin,phase,hij)
use bitmasks
implicit none
integer,intent(in) :: h,p,spin
double precision, intent(in) :: phase
integer(bit_kind), intent(in) :: det_1(N_int,2), det_2(N_int,2)
double precision, intent(out) :: hij
integer(bit_kind) :: differences(N_int,2)
integer(bit_kind) :: hole(N_int,2)
integer(bit_kind) :: partcl(N_int,2)
integer :: occ_hole(N_int*bit_kind_size,2)
integer :: occ_partcl(N_int*bit_kind_size,2)
integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
integer :: i0,i
do i = 1, N_int
differences(i,1) = xor(det_1(i,1),ref_closed_shell_bitmask(i,1))
differences(i,2) = xor(det_1(i,2),ref_closed_shell_bitmask(i,2))
hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
partcl(i,1) = iand(differences(i,1),det_1(i,1))
partcl(i,2) = iand(differences(i,2),det_1(i,2))
enddo
call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
hij = fock_operator_closed_shell_ref_bitmask(h,p)
! holes :: direct terms
do i0 = 1, n_occ_ab_hole(1)
i = occ_hole(i0,1)
hij -= big_array_coulomb_integrals(i,h,p) ! get_mo_bielec_integral_schwartz(h,i,p,i,mo_integrals_map)
enddo
do i0 = 1, n_occ_ab_hole(2)
i = occ_hole(i0,2)
hij -= big_array_coulomb_integrals(i,h,p) !get_mo_bielec_integral_schwartz(h,i,p,i,mo_integrals_map)
enddo
! holes :: exchange terms
do i0 = 1, n_occ_ab_hole(spin)
i = occ_hole(i0,spin)
hij += big_array_exchange_integrals(i,h,p) ! get_mo_bielec_integral_schwartz(h,i,i,p,mo_integrals_map)
enddo
! particles :: direct terms
do i0 = 1, n_occ_ab_partcl(1)
i = occ_partcl(i0,1)
hij += big_array_coulomb_integrals(i,h,p)!get_mo_bielec_integral_schwartz(h,i,p,i,mo_integrals_map)
enddo
do i0 = 1, n_occ_ab_partcl(2)
i = occ_partcl(i0,2)
hij += big_array_coulomb_integrals(i,h,p) !get_mo_bielec_integral_schwartz(h,i,p,i,mo_integrals_map)
enddo
! particles :: exchange terms
do i0 = 1, n_occ_ab_partcl(spin)
i = occ_partcl(i0,spin)
hij -= big_array_exchange_integrals(i,h,p)!get_mo_bielec_integral_schwartz(h,i,i,p,mo_integrals_map)
enddo
hij = hij * phase
end

43
src/Determinants/occ_pattern.irp.f
View File

@ -256,27 +256,6 @@ subroutine make_s2_eigenfunction
integer :: N_det_new
integer, parameter :: bufsze = 1000
logical, external :: is_in_wavefunction
return
! !TODO DEBUG
! do i=1,N_det
! do j=i+1,N_det
! s = 0
! do k=1,N_int
! if((psi_det(k,1,j) /= psi_det(k,1,i)).or. &
! (psi_det(k,2,j) /= psi_det(k,2,i))) then
! s=1
! exit
! endif
! enddo
! if ( s == 0 ) then
! print *, 'Error0: det ', j, 'already in wf'
! call debug_det(psi_det(1,1,j),N_int)
! stop
! endif
! enddo
! enddo
! !TODO DEBUG
allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) )
smax = 1
@ -308,33 +287,15 @@ subroutine make_s2_eigenfunction
if (N_det_new > 0) then
call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,0)
! call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0)
call copy_H_apply_buffer_to_wf
SOFT_TOUCH N_det psi_coef psi_det
endif
deallocate(d,det_buffer)
! !TODO DEBUG
! do i=1,N_det
! do j=i+1,N_det
! s = 0
! do k=1,N_int
! if((psi_det(k,1,j) /= psi_det(k,1,i)).or. &
! (psi_det(k,2,j) /= psi_det(k,2,i))) then
! s=1
! exit
! endif
! enddo
! if ( s == 0 ) then
! print *, 'Error : det ', j, 'already in wf at ', i
! call debug_det(psi_det(1,1,j),N_int)
! stop
! endif
! enddo
! enddo
! !TODO DEBUG
call write_int(output_determinants,N_det_new, 'Added determinants for S^2')
end

11
src/Determinants/print_bitmask.irp.f Normal file
View File

@ -0,0 +1,11 @@
program print_bitmask
implicit none
print*,'core'
call debug_det(core_bitmask,N_int)
print*,'inact'
call debug_det(inact_bitmask,N_int)
print*,'virt'
call debug_det(virt_bitmask,N_int)
end

36
src/Determinants/print_holes_particles.irp.f Normal file
View File

@ -0,0 +1,36 @@
program pouet
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
integer :: i,j,number_of_holes,number_of_particles
integer :: n_h,n_p
do i = 1, N_det
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
if(n_h == 0 .and. n_p == 0)then
print*,'CAS'
else if(n_h == 1 .and. n_p ==0)then
print*,'1h'
else if(n_h == 0 .and. n_p ==1)then
print*,'1p'
else if(n_h == 1 .and. n_p ==1)then
print*,'1h1p'
else if(n_h == 2 .and. n_p ==1)then
print*,'2h1p'
else if(n_h == 1 .and. n_p ==2)then
print*,'1h2p'
else
print*,'PB !! '
call debug_det(psi_det(1,1,i), N_int)
stop
endif
enddo
end

71
src/Determinants/print_wf.irp.f Normal file
View File

@ -0,0 +1,71 @@
program printwf
implicit none
read_wf = .True.
touch read_wf
print*,'ref_bitmask_energy = ',ref_bitmask_energy
call routine
end
subroutine routine
implicit none
integer :: i
integer :: degree
double precision :: hij
integer :: exc(0:2,2,2)
double precision :: phase
integer :: h1,p1,h2,p2,s1,s2
double precision :: get_mo_bielec_integral
double precision :: norm_mono_a,norm_mono_b
norm_mono_a = 0.d0
norm_mono_b = 0.d0
do i = 1, min(500,N_det)
print*,''
print*,'i = ',i
call debug_det(psi_det(1,1,i),N_int)
call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,1),degree,N_int)
print*,'degree = ',degree
if(degree == 0)then
print*,'Reference determinant '
else
call i_H_j(psi_det(1,1,i),psi_det(1,1,1),N_int,hij)
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)
print*,'phase = ',phase
if(degree == 1)then
print*,'s1',s1
print*,'h1,p1 = ',h1,p1
if(s1 == 1)then
norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1))
else
norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1))
endif
print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,list_act(1),list_act(1),p1,mo_integrals_map)
double precision :: hmono,hdouble
call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble)
print*,'hmono = ',hmono
print*,'hdouble = ',hdouble
print*,'hmono+hdouble = ',hmono+hdouble
print*,'hij = ',hij
else
print*,'s1',s1
print*,'h1,p1 = ',h1,p1
print*,'s2',s2
print*,'h2,p2 = ',h2,p2
print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map)
endif
print*,'<Ref| H |D_I> = ',hij
endif
print*,'amplitude = ',psi_coef(i,1)/psi_coef(1,1)
enddo
print*,''
print*,''
print*,''
print*,'mono alpha = ',norm_mono_a
print*,'mono beta = ',norm_mono_b
end

50
src/Determinants/save_only_singles.irp.f Normal file
View File

@ -0,0 +1,50 @@
program save_only_singles
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
integer :: i,j,k,l
use bitmasks
integer :: n_det_restart,degree
integer(bit_kind),allocatable :: psi_det_tmp(:,:,:)
double precision ,allocatable :: psi_coef_tmp(:,:),accu(:)
integer, allocatable :: index_restart(:)
allocate(index_restart(N_det))
N_det_restart = 0
do i = 1, N_det
call get_excitation_degree(psi_det(1,1,1),psi_det(1,1,i),degree,N_int)
if(degree == 0 .or. degree==1)then
N_det_restart +=1
index_restart(N_det_restart) = i
cycle
endif
enddo
allocate (psi_det_tmp(N_int,2,N_det_restart),psi_coef_tmp(N_det_restart,N_states),accu(N_states))
accu = 0.d0
do i = 1, N_det_restart
do j = 1, N_int
psi_det_tmp(j,1,i) = psi_det(j,1,index_restart(i))
psi_det_tmp(j,2,i) = psi_det(j,2,index_restart(i))
enddo
do j = 1,N_states
psi_coef_tmp(i,j) = psi_coef(index_restart(i),j)
accu(j) += psi_coef_tmp(i,j) * psi_coef_tmp(i,j)
enddo
enddo
do j = 1, N_states
accu(j) = 1.d0/dsqrt(accu(j))
enddo
do j = 1,N_states
do i = 1, N_det_restart
psi_coef_tmp(i,j) = psi_coef_tmp(i,j) * accu(j)
enddo
enddo
call save_wavefunction_general(N_det_restart,N_states,psi_det_tmp,N_det_restart,psi_coef_tmp)
deallocate (psi_det_tmp,psi_coef_tmp,accu,index_restart)
end

621
src/Determinants/slater_rules.irp.f
View File

@ -495,8 +495,6 @@ end
subroutine i_H_j(key_i,key_j,Nint,hij)
use bitmasks
implicit none
@ -527,16 +525,23 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
hij = 0.d0
!DIR$ FORCEINLINE
call get_excitation_degree(key_i,key_j,degree,Nint)
integer :: spin
select case (degree)
case (2)
call get_double_excitation(key_i,key_j,exc,phase,Nint)
if (exc(0,1,1) == 1) then
! Mono alpha, mono beta
hij = phase*get_mo_bielec_integral( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map)
if(exc(1,1,1) == exc(1,2,2) )then
hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1))
else if (exc(1,2,1) ==exc(1,1,2))then
hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2))
else
hij = phase*get_mo_bielec_integral( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map)
endif
else if (exc(0,1,1) == 2) then
! Double alpha
hij = phase*(get_mo_bielec_integral( &
@ -570,27 +575,14 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
! Mono alpha
m = exc(1,1,1)
p = exc(1,2,1)
do k = 1, elec_alpha_num
hij = hij + mo_bielec_integral_mipi_anti(occ(k,1),m,p)
enddo
do k = 1, elec_beta_num
hij = hij + mo_bielec_integral_mipi(occ(k,2),m,p)
enddo
spin = 1
else
! Mono beta
m = exc(1,1,2)
p = exc(1,2,2)
do k = 1, elec_alpha_num
hij = hij + mo_bielec_integral_mipi(occ(k,1),m,p)
enddo
do k = 1, elec_beta_num
hij = hij + mo_bielec_integral_mipi_anti(occ(k,2),m,p)
enddo
spin = 2
endif
hij = phase*(hij + mo_mono_elec_integral(m,p))
call get_mono_excitation_from_fock(key_i,key_j,p,m,spin,phase,hij)
case (0)
hij = diag_H_mat_elem(key_i,Nint)
@ -617,6 +609,8 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem
integer :: n_occ_ab(2)
logical :: has_mipi(Nint*bit_kind_size)
double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size)
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
ASSERT (Nint > 0)
@ -668,27 +662,59 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
!DIR$ FORCEINLINE
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
has_mipi = .False.
if (exc(0,1,1) == 1) then
! Mono alpha
m = exc(1,1,1)
p = exc(1,2,1)
do k = 1, elec_alpha_num
hij = hij + mo_bielec_integral_mipi_anti(occ(k,1),m,p)
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_beta_num
hij = hij + mo_bielec_integral_mipi(occ(k,2),m,p)
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_alpha_num
hij = hij + mipi(occ(k,1)) - miip(occ(k,1))
enddo
do k = 1, elec_beta_num
hij = hij + mipi(occ(k,2))
enddo
else
! Mono beta
m = exc(1,1,2)
p = exc(1,2,2)
do k = 1, elec_beta_num
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_alpha_num
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_alpha_num
hij = hij + mo_bielec_integral_mipi(occ(k,1),m,p)
hij = hij + mipi(occ(k,1))
enddo
do k = 1, elec_beta_num
hij = hij + mo_bielec_integral_mipi_anti(occ(k,2),m,p)
hij = hij + mipi(occ(k,2)) - miip(occ(k,2))
enddo
endif
@ -719,6 +745,8 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem, phase,phase_2
integer :: n_occ_ab(2)
logical :: has_mipi(Nint*bit_kind_size)
double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size)
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
ASSERT (Nint > 0)
@ -743,8 +771,11 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map)
print*, 'hij verbose ',hij * phase
print*, 'phase verbose',phase
else if (exc(0,1,1) == 2) then
! Double alpha
print*,'phase hij = ',phase
hij = phase*(get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
@ -755,8 +786,31 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
exc(2,1,1), &
exc(2,2,1), &
exc(1,2,1) ,mo_integrals_map) )
print*,get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map)
print*,get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(2,2,1), &
exc(1,2,1) ,mo_integrals_map)
else if (exc(0,1,2) == 2) then
! Double beta
print*,'phase hij = ',phase
print*, get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map )
print*, get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(2,2,2), &
exc(1,2,2) ,mo_integrals_map)
hij = phase*(get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
@ -772,26 +826,59 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
!DIR$ FORCEINLINE
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
has_mipi = .False.
if (exc(0,1,1) == 1) then
! Mono alpha
m = exc(1,1,1)
p = exc(1,2,1)
do k = 1, elec_alpha_num
hdouble = hdouble + mo_bielec_integral_mipi_anti(occ(k,1),m,p)
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_beta_num
hdouble = hdouble + mo_bielec_integral_mipi(occ(k,2),m,p)
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_alpha_num
hdouble = hdouble + mipi(occ(k,1)) - miip(occ(k,1))
enddo
do k = 1, elec_beta_num
hdouble = hdouble + mipi(occ(k,2))
enddo
else
! Mono beta
m = exc(1,1,2)
p = exc(1,2,2)
do k = 1, elec_beta_num
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_alpha_num
hdouble = hdouble + mo_bielec_integral_mipi(occ(k,1),m,p)
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_alpha_num
hdouble = hdouble + mipi(occ(k,1))
enddo
do k = 1, elec_beta_num
hdouble = hdouble + mo_bielec_integral_mipi_anti(occ(k,2),m,p)
hdouble = hdouble + mipi(occ(k,2)) - miip(occ(k,2))
enddo
endif
@ -802,8 +889,6 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
hij = diag_H_mat_elem(key_i,Nint)
end select
end
subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullList, N_miniList, Nint)
use bitmasks
implicit none
@ -1047,6 +1132,7 @@ subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,
end
subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_interaction,interactions)
use bitmasks
implicit none
@ -1195,6 +1281,433 @@ subroutine i_H_psi_SC2_verbose(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_a
print*,'------'
end
subroutine get_excitation_degree_vector_mono(key1,key2,degree,Nint,sze,idx)
use bitmasks
implicit none
BEGIN_DOC
! Applies get_excitation_degree to an array of determinants and return only the mono excitations
END_DOC
integer, intent(in) :: Nint, sze
integer(bit_kind), intent(in) :: key1(Nint,2,sze)
integer(bit_kind), intent(in) :: key2(Nint,2)
integer, intent(out) :: degree(sze)
integer, intent(out) :: idx(0:sze)
integer :: i,l,d,m
ASSERT (Nint > 0)
ASSERT (sze > 0)
l=1
if (Nint==1) then
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2)))
if (d > 2) then
cycle
else
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
endif
enddo
else if (Nint==2) then
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2))) + &
popcnt(xor( key1(2,1,i), key2(2,1))) + &
popcnt(xor( key1(2,2,i), key2(2,2)))
if (d > 2) then
cycle
else
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
endif
enddo
else if (Nint==3) then
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2))) + &
popcnt(xor( key1(2,1,i), key2(2,1))) + &
popcnt(xor( key1(2,2,i), key2(2,2))) + &
popcnt(xor( key1(3,1,i), key2(3,1))) + &
popcnt(xor( key1(3,2,i), key2(3,2)))
if (d > 2) then
cycle
else
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
endif
enddo
else
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = 0
!DIR$ LOOP COUNT MIN(4)
do m=1,Nint
d = d + popcnt(xor( key1(m,1,i), key2(m,1))) &
+ popcnt(xor( key1(m,2,i), key2(m,2)))
enddo
if (d > 2) then
cycle
else
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
endif
enddo
endif
idx(0) = l-1
end
subroutine get_excitation_degree_vector_mono_or_exchange(key1,key2,degree,Nint,sze,idx)
use bitmasks
implicit none
BEGIN_DOC
! Applies get_excitation_degree to an array of determinants and return only the mono excitations
! and the connections through exchange integrals
END_DOC
integer, intent(in) :: Nint, sze
integer(bit_kind), intent(in) :: key1(Nint,2,sze)
integer(bit_kind), intent(in) :: key2(Nint,2)
integer, intent(out) :: degree(sze)
integer, intent(out) :: idx(0:sze)
integer(bit_kind) :: key_tmp(Nint,2)
integer :: i,l,d,m
integer :: exchange_1,exchange_2
ASSERT (Nint > 0)
ASSERT (sze > 0)
l=1
if (Nint==1) then
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2)))
key_tmp(1,1) = xor(key1(1,1,i),key2(1,1))
key_tmp(1,2) = xor(key1(1,2,i),key2(1,2))
if(popcnt(key_tmp(1,1)) .gt.3 .or. popcnt(key_tmp(1,2)) .gt.3 )cycle !! no double excitations of same spin
if (d > 4)cycle
if (d ==4)then
if(popcnt(xor(key_tmp(1,1),key_tmp(1,2))) == 0)then
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
else
cycle
endif
! pause
else
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
endif
enddo
else
print*, 'get_excitation_degree_vector_mono_or_exchange not yet implemented for N_int > 1 ...'
stop
endif
idx(0) = l-1
end
subroutine get_excitation_degree_vector_double_alpha_beta(key1,key2,degree,Nint,sze,idx)
use bitmasks
implicit none
BEGIN_DOC
! Applies get_excitation_degree to an array of determinants and return only the mono excitations
! and the connections through exchange integrals
END_DOC
integer, intent(in) :: Nint, sze
integer(bit_kind), intent(in) :: key1(Nint,2,sze)
integer(bit_kind), intent(in) :: key2(Nint,2)
integer, intent(out) :: degree(sze)
integer, intent(out) :: idx(0:sze)
integer(bit_kind) :: key_tmp(Nint,2)
integer :: i,l,d,m
integer :: degree_alpha, degree_beta
ASSERT (Nint > 0)
ASSERT (sze > 0)
l=1
if (Nint==1) then
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2)))
if (d .ne.4)cycle
key_tmp(1,1) = xor(key1(1,1,i),key2(1,1))
key_tmp(1,2) = xor(key1(1,2,i),key2(1,2))
degree_alpha = popcnt(key_tmp(1,1))
degree_beta = popcnt(key_tmp(1,2))
if(degree_alpha .gt.3 .or. degree_beta .gt.3 )cycle !! no double excitations of same spin
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
enddo
else if (Nint==2) then
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2))) + &
popcnt(xor( key1(2,1,i), key2(2,1))) + &
popcnt(xor( key1(2,2,i), key2(2,2)))
if (d .ne.4)cycle
key_tmp(1,1) = xor(key1(1,1,i),key2(1,1))
key_tmp(1,2) = xor(key1(1,2,i),key2(1,2))
key_tmp(2,1) = xor(key1(2,1,i),key2(2,1))
key_tmp(2,2) = xor(key1(2,2,i),key2(2,2))
degree_alpha = popcnt(key_tmp(1,1)) + popcnt(key_tmp(2,1))
degree_beta = popcnt(key_tmp(1,2)) + popcnt(key_tmp(2,2))
if(degree_alpha .gt.3 .or. degree_beta .gt.3 )cycle !! no double excitations of same spin
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
enddo
else if (Nint==3) then
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2))) + &
popcnt(xor( key1(2,1,i), key2(2,1))) + &
popcnt(xor( key1(2,2,i), key2(2,2))) + &
popcnt(xor( key1(3,1,i), key2(3,1))) + &
popcnt(xor( key1(3,2,i), key2(3,2)))
if (d .ne.4)cycle
key_tmp(1,1) = xor(key1(1,1,i),key2(1,1))
key_tmp(1,2) = xor(key1(1,2,i),key2(1,2))
key_tmp(2,1) = xor(key1(2,1,i),key2(2,1))
key_tmp(2,2) = xor(key1(2,2,i),key2(2,2))
key_tmp(3,1) = xor(key1(3,1,i),key2(3,1))
key_tmp(3,2) = xor(key1(3,2,i),key2(3,2))
degree_alpha = popcnt(key_tmp(1,1)) + popcnt(key_tmp(2,1)) + popcnt(key_tmp(3,1))
degree_beta = popcnt(key_tmp(1,2)) + popcnt(key_tmp(2,2)) + popcnt(key_tmp(3,2))
if(degree_alpha .gt.3 .or. degree_beta .gt.3 )cycle !! no double excitations of same spin
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
enddo
else
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = 0
!DIR$ LOOP COUNT MIN(4)
do m=1,Nint
d = d + popcnt(xor( key1(m,1,i), key2(m,1))) &
+ popcnt(xor( key1(m,2,i), key2(m,2)))
key_tmp(m,1) = xor(key1(m,1,i),key2(m,1))
key_tmp(m,2) = xor(key1(m,2,i),key2(m,2))
degree_alpha = popcnt(key_tmp(m,1))
degree_beta = popcnt(key_tmp(m,2))
enddo
if(degree_alpha .gt.3 .or. degree_beta .gt.3 )cycle !! no double excitations of same spin
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
enddo
endif
idx(0) = l-1
end
subroutine get_excitation_degree_vector_mono_or_exchange_verbose(key1,key2,degree,Nint,sze,idx)
use bitmasks
implicit none
BEGIN_DOC
! Applies get_excitation_degree to an array of determinants and return only the mono excitations
! and the connections through exchange integrals
END_DOC
integer, intent(in) :: Nint, sze
integer(bit_kind), intent(in) :: key1(Nint,2,sze)
integer(bit_kind), intent(in) :: key2(Nint,2)
integer, intent(out) :: degree(sze)
integer, intent(out) :: idx(0:sze)
integer :: i,l,d,m
integer :: exchange_1,exchange_2
ASSERT (Nint > 0)
ASSERT (sze > 0)
l=1
if (Nint==1) then
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2)))
exchange_1 = popcnt(xor(ior(key1(1,1,i),key1(1,2,i)),ior(key2(1,1),key2(1,2))))
exchange_2 = popcnt(ior(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2))))
if(i==99)then
integer(bit_kind) :: key_test(N_int,2)
key_test(1,2) = 0_bit_kind
call debug_det(key2,N_int)
key_test(1,1) = ior(key2(1,1),key2(1,2))
call debug_det(key_test,N_int)
key_test(1,1) = ior(key1(1,1,i),key1(1,2,i))
call debug_det(key1(1,1,i),N_int)
call debug_det(key_test,N_int)
key_test(1,1) = xor(ior(key1(1,1,i),key1(1,2,i)),ior(key2(1,1),key2(1,2)))
call debug_det(key_test,N_int)
print*, exchange_1 , exchange_2
stop
endif
if (d > 4)cycle
if (d ==4)then
if(exchange_1 .eq. 0 ) then
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
else
cycle
endif
! pause
else
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
endif
enddo
else if (Nint==2) then
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2))) + &
popcnt(xor( key1(2,1,i), key2(2,1))) + &
popcnt(xor( key1(2,2,i), key2(2,2)))
exchange_1 = popcnt(xor(iand(key1(1,1,i),key1(1,2,i)),iand(key2(1,2),key2(1,2)))) + &
popcnt(xor(iand(key1(2,1,i),key1(2,2,i)),iand(key2(2,2),key2(2,2))))
exchange_2 = popcnt(iand(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + &
popcnt(iand(xor(key1(2,1,i),key2(2,1)),xor(key1(2,2,i),key2(2,2))))
if (d > 4)cycle
if (d ==4)then
if(exchange_1 .eq. 0 ) then
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
else
cycle
endif
! pause
else
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
endif
enddo
else if (Nint==3) then
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2))) + &
popcnt(xor( key1(2,1,i), key2(2,1))) + &
popcnt(xor( key1(2,2,i), key2(2,2))) + &
popcnt(xor( key1(3,1,i), key2(3,1))) + &
popcnt(xor( key1(3,2,i), key2(3,2)))
exchange_1 = popcnt(xor(iand(key1(1,1,i),key1(1,2,i)),iand(key2(1,1),key2(1,2)))) + &
popcnt(xor(iand(key1(2,1,i),key1(2,2,i)),iand(key2(2,1),key2(2,2)))) + &
popcnt(xor(iand(key1(3,1,i),key1(3,2,i)),iand(key2(3,1),key2(3,2))))
exchange_2 = popcnt(iand(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + &
popcnt(iand(xor(key1(2,1,i),key2(2,1)),xor(key1(2,2,i),key2(2,2)))) + &
popcnt(iand(xor(key1(3,1,i),key2(3,1)),xor(key1(3,2,i),key2(3,2))))
if (d > 4)cycle
if (d ==4)then
if(exchange_1 .eq. 0 ) then
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
else
cycle
endif
! pause
else
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
endif
enddo
else
!DIR$ LOOP COUNT (1000)
do i=1,sze
d = 0
exchange_1 = 0
!DIR$ LOOP COUNT MIN(4)
do m=1,Nint
d = d + popcnt(xor( key1(m,1,i), key2(m,1))) &
+ popcnt(xor( key1(m,2,i), key2(m,2)))
exchange_1 = popcnt(xor(iand(key1(m,1,i),key1(m,2,i)),iand(key2(m,1),key2(m,2))))
exchange_2 = popcnt(iand(xor(key1(m,1,i),key2(m,1)),xor(key1(m,2,i),key2(m,2))))
enddo
if (d > 4)cycle
if (d ==4)then
if(exchange_1 .eq. 0 ) then
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
else
cycle
endif
! pause
else
degree(l) = ishft(d,-1)
idx(l) = i
l = l+1
endif
enddo
endif
idx(0) = l-1
end
subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx)
@ -1639,3 +2152,43 @@ subroutine get_phase(key1,key2,phase,Nint)
call get_excitation(key1, key2, exc, degree, phase, Nint)
end
subroutine H_u_0_stored(v_0,u_0,hmatrix,sze)
use bitmasks
implicit none
BEGIN_DOC
! Computes v_0 = H|u_0>
!
! n : number of determinants
!
! uses the big_matrix_stored array
END_DOC
integer, intent(in) :: sze
double precision, intent(in) :: hmatrix(sze,sze)
double precision, intent(out) :: v_0(sze)
double precision, intent(in) :: u_0(sze)
v_0 = 0.d0
call matrix_vector_product(u_0,v_0,hmatrix,sze,sze)
end
subroutine u_0_H_u_0_stored(e_0,u_0,hmatrix,sze)
use bitmasks
implicit none
BEGIN_DOC
! Computes e_0 = <u_0|H|u_0>
!
! n : number of determinants
!
! uses the big_matrix_stored array
END_DOC
integer, intent(in) :: sze
double precision, intent(in) :: hmatrix(sze,sze)
double precision, intent(out) :: e_0
double precision, intent(in) :: u_0(sze)
double precision :: v_0(sze)
double precision :: u_dot_v
e_0 = 0.d0
v_0 = 0.d0
call matrix_vector_product(u_0,v_0,hmatrix,sze,sze)
e_0 = u_dot_v(v_0,u_0,sze)
end

23
src/Determinants/truncate_wf.irp.f
View File

@ -1,18 +1,11 @@
program cisd
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
N_det=10000
do i=1,N_det
do k=1,N_int
psi_det(k,1,i) = psi_det_sorted(k,1,i)
psi_det(k,2,i) = psi_det_sorted(k,2,i)
enddo
psi_coef(i,:) = psi_coef_sorted(i,:)
enddo
program s2_eig_restart
implicit none
read_wf = .True.
call routine
end
subroutine routine
implicit none
call make_s2_eigenfunction
TOUCH psi_det psi_coef psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted N_det
call save_wavefunction
end

619
src/Determinants/two_body_dm_map.irp.f Normal file
View File

@ -0,0 +1,619 @@
use map_module
BEGIN_PROVIDER [ type(map_type), two_body_dm_ab_map ]
implicit none
BEGIN_DOC
! Map of the two body density matrix elements for the alpha/beta elements
END_DOC
integer(key_kind) :: key_max
integer(map_size_kind) :: sze
use map_module
call bielec_integrals_index(mo_tot_num,mo_tot_num,mo_tot_num,mo_tot_num,key_max)
sze = key_max
call map_init(two_body_dm_ab_map,sze)
print*, 'two_body_dm_ab_map initialized'
END_PROVIDER
subroutine insert_into_two_body_dm_ab_map(n_product,buffer_i, buffer_values, thr)
use map_module
implicit none
BEGIN_DOC
! Create new entry into two_body_dm_ab_map, or accumulate in an existing entry
END_DOC
integer, intent(in) :: n_product
integer(key_kind), intent(inout) :: buffer_i(n_product)
real(integral_kind), intent(inout) :: buffer_values(n_product)
real(integral_kind), intent(in) :: thr
call map_update(two_body_dm_ab_map, buffer_i, buffer_values, n_product, thr)
end
double precision function get_two_body_dm_ab_map_element(i,j,k,l,map)
use map_module
implicit none
BEGIN_DOC
! Returns one value of the wo body density matrix \rho_{ijkl}^{\alpha \beta} defined as :
! \rho_{ijkl}^{\alpha \beta } = <\Psi|a^{\dagger}_{i\alpha} a^{\dagger}_{j\beta} a_{k\beta} a_{l\alpha}|\Psi>
END_DOC
PROVIDE two_body_dm_ab_map
integer, intent(in) :: i,j,k,l
integer(key_kind) :: idx
type(map_type), intent(inout) :: map
real(integral_kind) :: tmp
PROVIDE two_body_dm_in_map
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(two_body_dm_ab_map,idx,tmp)
get_two_body_dm_ab_map_element = dble(tmp)
end
subroutine get_get_two_body_dm_ab_map_elements(j,k,l,sze,out_val,map)
use map_module
implicit none
BEGIN_DOC
! Returns multiple elements of the \rho_{ijkl}^{\alpha \beta }, all
! i for j,k,l fixed.
END_DOC
integer, intent(in) :: j,k,l, sze
double precision, intent(out) :: out_val(sze)
type(map_type), intent(inout) :: map
integer :: i
integer(key_kind) :: hash(sze)
real(integral_kind) :: tmp_val(sze)
PROVIDE two_body_dm_in_map
do i=1,sze
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,hash(i))
enddo
if (key_kind == 8) then
call map_get_many(two_body_dm_ab_map, hash, out_val, sze)
else
call map_get_many(two_body_dm_ab_map, hash, tmp_val, sze)
! Conversion to double precision
do i=1,sze
out_val(i) = dble(tmp_val(i))
enddo
endif
end
BEGIN_PROVIDER [ logical, two_body_dm_in_map ]
implicit none
BEGIN_DOC
! If True, the map of the two body density matrix alpha/beta is provided
END_DOC
two_body_dm_in_map = .True.
call add_values_to_two_body_dm_map(full_ijkl_bitmask_4)
END_PROVIDER
subroutine add_values_to_two_body_dm_map(mask_ijkl)
use bitmasks
use map_module
implicit none
BEGIN_DOC
! Adds values to the map of two_body_dm according to some bitmask
END_DOC
integer(bit_kind), intent(in) :: mask_ijkl(N_int,4)
integer :: degree
PROVIDE mo_coef psi_coef psi_det
integer :: exc(0:2,2,2)
integer :: h1,h2,p1,p2,s1,s2
double precision :: phase
double precision :: contrib
integer(key_kind),allocatable :: buffer_i(:)
double precision ,allocatable :: buffer_value(:)
integer :: size_buffer
integer :: n_elements
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,k,l,m
size_buffer = min(mo_tot_num*mo_tot_num*mo_tot_num,16000000)
allocate(buffer_i(size_buffer),buffer_value(size_buffer))
n_elements = 0
do i = 1, N_det ! i == |I>
call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int)
do j = i+1, N_det ! j == <J|
call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int)
if(degree>2)cycle
call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************
if(s1==s2)cycle ! Only the alpha/beta two body density matrix
! <J| a^{\dagger}_{p1 s1} a^{\dagger}_{p2 s2} a_{h2 s2} a_{h1 s1} |I> * c_I * c_J
if(h1>p1)cycle
if(h2>p2)cycle
! if(s1.ne.1)cycle
n_elements += 1
contrib = psi_coef(i,1) * psi_coef(j,1) * phase
buffer_value(n_elements) = contrib
!DEC$ FORCEINLINE
! call mo_bielec_integrals_index(h1,p1,h2,p2,buffer_i(n_elements))
call mo_bielec_integrals_index(h1,h2,p1,p2,buffer_i(n_elements))
! if (n_elements == size_buffer) then
! call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,&
! real(mo_integrals_threshold,integral_kind))
! n_elements = 0
! endif
else ! case of the SINGLE EXCITATIONS ***************************************************
cycle
! if(s1==1)then ! Mono alpha :
! do k = 1, elec_beta_num
! m = occ(k,2)
! n_elements += 1
! buffer_value(n_elements) = contrib
! ! <J| a^{\dagger}_{p1 \alpha} \hat{n}_{m \beta} a_{h1 \alpha} |I> * c_I * c_J
! call mo_bielec_integrals_index(h1,m,p1,m,buffer_i(n_elements))
! if (n_elements == size_buffer) then
! call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,&
! real(mo_integrals_threshold,integral_kind))
! n_elements = 0
! endif
! enddo
! else ! Mono Beta :
! do k = 1, elec_alpha_num
! m = occ(k,1)
! n_elements += 1
! buffer_value(n_elements) = contrib
! ! <J| a^{\dagger}_{p1 \beta} \hat{n}_{m \alpha} a_{h1 \beta} |I> * c_I * c_J
! call mo_bielec_integrals_index(h1,m,p1,m,buffer_i(n_elements))
! if (n_elements == size_buffer) then
! call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,&
! real(mo_integrals_threshold,integral_kind))
! n_elements = 0
! endif
! enddo
! endif
endif
enddo
enddo
print*,'n_elements = ',n_elements
call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,&
real(mo_integrals_threshold,integral_kind))
call map_unique(two_body_dm_ab_map)
deallocate(buffer_i,buffer_value)
end
BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_act, (n_act_orb, n_act_orb)]
&BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_inact, (n_inact_orb_allocate, n_inact_orb_allocate)]
&BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_core, (n_core_orb_allocate, n_core_orb_allocate)]
&BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_all, (mo_tot_num, mo_tot_num)]
&BEGIN_PROVIDER [double precision, two_body_dm_diag_core_a_act_b, (n_core_orb_allocate,n_act_orb)]
&BEGIN_PROVIDER [double precision, two_body_dm_diag_core_b_act_a, (n_core_orb_allocate,n_act_orb)]
&BEGIN_PROVIDER [double precision, two_body_dm_diag_core_act, (n_core_orb_allocate,n_act_orb)]
implicit none
use bitmasks
integer :: i,j,k,l,m
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: occ_act(N_int*bit_kind_size,2)
integer :: n_occ_ab_act(2)
integer :: occ_core(N_int*bit_kind_size,2)
integer :: n_occ_ab_core(2)
double precision :: contrib
BEGIN_DOC
! two_body_dm_ab_diag_all(k,m) = <\Psi | n_(k\alpha) n_(m\beta) | \Psi>
! two_body_dm_ab_diag_act(k,m) is restricted to the active orbitals :
! orbital k = list_act(k)
! two_body_dm_ab_diag_inact(k,m) is restricted to the inactive orbitals :
! orbital k = list_inact(k)
! two_body_dm_ab_diag_core(k,m) is restricted to the core orbitals :
! orbital k = list_core(k)
! two_body_dm_ab_diag_core_b_act_a(k,m) represents the core beta <-> active alpha part of the two body dm
! orbital k = list_core(k)
! orbital m = list_act(m)
! two_body_dm_ab_diag_core_a_act_b(k,m) represents the core alpha <-> active beta part of the two body dm
! orbital k = list_core(k)
! orbital m = list_act(m)
! two_body_dm_ab_diag_core_act(k,m) represents the core<->active part of the diagonal two body dm
! when we traced on the spin
! orbital k = list_core(k)
! orbital m = list_act(m)
END_DOC
integer(bit_kind) :: key_tmp_core(N_int,2)
integer(bit_kind) :: key_tmp_act(N_int,2)
two_body_dm_ab_diag_all = 0.d0
two_body_dm_ab_diag_act = 0.d0
two_body_dm_ab_diag_core = 0.d0
two_body_dm_ab_diag_inact = 0.d0
two_body_dm_diag_core_a_act_b = 0.d0
two_body_dm_diag_core_b_act_a = 0.d0
two_body_dm_diag_core_act = 0.d0
do i = 1, N_det ! i == |I>
! Full diagonal part of the two body dm
contrib = psi_coef(i,1)**2
call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int)
do j = 1, elec_beta_num
k = occ(j,2)
do l = 1, elec_alpha_num
m = occ(l,1)
two_body_dm_ab_diag_all(k,m) += 0.5d0 * contrib
two_body_dm_ab_diag_all(m,k) += 0.5d0 * contrib
enddo
enddo
! ACTIVE PART of the diagonal part of the two body dm
do j = 1, N_int
key_tmp_act(j,1) = psi_det(j,1,i)
key_tmp_act(j,2) = psi_det(j,2,i)
enddo
do j = 1, N_int
key_tmp_act(j,1) = iand(key_tmp_act(j,1),cas_bitmask(j,1,1))
key_tmp_act(j,2) = iand(key_tmp_act(j,2),cas_bitmask(j,1,1))
enddo
call bitstring_to_list_ab(key_tmp_act, occ_act, n_occ_ab_act, N_int)
do j = 1,n_occ_ab_act(2)
k = list_act_reverse(occ_act(j,2))
do l = 1, n_occ_ab_act(1)
m = list_act_reverse(occ_act(l,1))
two_body_dm_ab_diag_act(k,m) += 0.5d0 * contrib
two_body_dm_ab_diag_act(m,k) += 0.5d0 * contrib
enddo
enddo
! CORE PART of the diagonal part of the two body dm
do j = 1, N_int
key_tmp_core(j,1) = psi_det(j,1,i)
key_tmp_core(j,2) = psi_det(j,2,i)
enddo
do j = 1, N_int
key_tmp_core(j,1) = iand(key_tmp_core(j,1),core_bitmask(j,1))
key_tmp_core(j,2) = iand(key_tmp_core(j,2),core_bitmask(j,1))
enddo
call bitstring_to_list_ab(key_tmp_core, occ_core, n_occ_ab_core, N_int)
do j = 1,n_occ_ab_core(2)
k = list_core_reverse(occ_core(j,2))
do l = 1, n_occ_ab_core(1)
m = list_core_reverse(occ_core(l,1))
two_body_dm_ab_diag_core(k,m) += 0.5d0 * contrib
two_body_dm_ab_diag_core(m,k) += 0.5d0 * contrib
enddo
enddo
! ACT<->CORE PART
! alpha electron in active space
do j = 1,n_occ_ab_act(1)
k = list_act_reverse(occ_act(j,1))
! beta electron in core space
do l = 1, n_occ_ab_core(2)
m = list_core_reverse(occ_core(l,2))
! The fact that you have 1 * contrib and not 0.5 * contrib
! takes into account the following symmetry :
! 0.5 * <n_k n_m> + 0.5 * <n_m n_k>
two_body_dm_diag_core_b_act_a(m,k) += contrib
enddo
enddo
! beta electron in active space
do j = 1,n_occ_ab_act(2)
k = list_act_reverse(occ_act(j,2))
! alpha electron in core space
do l = 1, n_occ_ab_core(1)
m = list_core_reverse(occ_core(l,1))
! The fact that you have 1 * contrib and not 0.5 * contrib
! takes into account the following symmetry :
! 0.5 * <n_k n_m> + 0.5 * <n_m n_k>
two_body_dm_diag_core_a_act_b(m,k) += contrib
enddo
enddo
enddo
do j = 1, n_core_orb
do l = 1, n_act_orb
two_body_dm_diag_core_act(j,l) = two_body_dm_diag_core_b_act_a(j,l) + two_body_dm_diag_core_a_act_b(j,l)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
&BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_core_act, (n_core_orb_allocate,n_act_orb,n_act_orb)]
implicit none
use bitmasks
integer :: i,j,k,l,m
integer :: degree
PROVIDE mo_coef psi_coef psi_det
integer :: exc(0:2,2,2)
integer :: h1,h2,p1,p2,s1,s2
double precision :: phase
double precision :: contrib
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: occ_core(N_int*bit_kind_size,2)
integer :: n_occ_ab_core(2)
integer(bit_kind) :: key_tmp_i(N_int,2)
integer(bit_kind) :: key_tmp_i_core(N_int,2)
integer(bit_kind) :: key_tmp_j(N_int,2)
two_body_dm_ab_big_array_act = 0.d0
two_body_dm_ab_big_array_core_act = 0.d0
BEGIN_DOC
! two_body_dm_ab_big_array_act = Purely active part of the two body density matrix
! two_body_dm_ab_big_array_act_core takes only into account the single excitation
! within the active space that adds terms in the act <-> core two body dm
! two_body_dm_ab_big_array_act_core(i,j,k) = < a^\dagger_i n_k a_j >
! with i,j in the ACTIVE SPACE
! with k in the CORE SPACE
!
! The alpha-beta extra diagonal energy FOR WF DEFINED AS AN APPROXIMATION OF A CAS can be computed thanks to
! sum_{h1,p1,h2,p2} two_body_dm_ab_big_array_act(h1,p1,h2,p2) * (h1p1|h2p2)
! + sum_{h1,p1,h2,p2} two_body_dm_ab_big_array_core_act(h1,p1,h2,p2) * (h1p1|h2p2)
END_DOC
do i = 1, N_det ! i == |I>
! active part of psi_det(i)
do j = 1, N_int
key_tmp_i(j,1) = psi_det(j,1,i)
key_tmp_i(j,2) = psi_det(j,2,i)
key_tmp_i_core(j,1) = psi_det(j,1,i)
key_tmp_i_core(j,2) = psi_det(j,2,i)
enddo
do j = 1, N_int
key_tmp_i(j,1) = iand(key_tmp_i(j,1),cas_bitmask(j,1,1))
key_tmp_i(j,2) = iand(key_tmp_i(j,2),cas_bitmask(j,1,1))
enddo
do j = 1, N_int
key_tmp_i_core(j,1) = iand(key_tmp_i_core(j,1),core_bitmask(j,1))
key_tmp_i_core(j,2) = iand(key_tmp_i_core(j,2),core_bitmask(j,1))
enddo
call bitstring_to_list_ab(key_tmp_i_core, occ_core, n_occ_ab_core, N_int)
call bitstring_to_list_ab(key_tmp_i, occ, n_occ_ab, N_int)
do j = i+1, N_det ! j == <J|
! active part of psi_det(j)
do k = 1, N_int
key_tmp_j(k,1) = psi_det(k,1,j)
key_tmp_j(k,2) = psi_det(k,2,j)
enddo
do k = 1, N_int
key_tmp_j(k,1) = iand(key_tmp_j(k,1),cas_bitmask(k,1,1))
key_tmp_j(k,2) = iand(key_tmp_j(k,2),cas_bitmask(k,1,1))
enddo
! control if the two determinants are connected by
! at most a double excitation WITHIN THE ACTIVE SPACE
call get_excitation_degree(key_tmp_i,key_tmp_j,degree,N_int)
if(degree>2)cycle
! if it is the case, then compute the hamiltonian matrix element with the proper phase
call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
contrib = 0.5d0 * psi_coef(i,1) * psi_coef(j,1) * phase
if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************
if(s1==s2)cycle ! Only the alpha/beta two body density matrix
! <J| a^{\dagger}_{p1 s1} a^{\dagger}_{p2 s2} a_{h2 s2} a_{h1 s1} |I> * c_I * c_J
h1 = list_act_reverse(h1)
h2 = list_act_reverse(h2)
p1 = list_act_reverse(p1)
p2 = list_act_reverse(p2)
call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2)
else if(degree==1)then! case of the SINGLE EXCITATIONS ***************************************************
print*,'h1 = ',h1
h1 = list_act_reverse(h1)
print*,'h1 = ',h1
print*,'p1 = ',p1
p1 = list_act_reverse(p1)
print*,'p1 = ',p1
if(s1==1)then ! Mono alpha :
! purely active part of the extra diagonal two body dm
do k = 1, n_occ_ab(2)
m = list_act_reverse(occ(k,2))
! <J| a^{\dagger}_{p1 \alpha} \hat{n}_{m \beta} a_{h1 \alpha} |I> * c_I * c_J
call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m)
enddo
! core <-> active part of the extra diagonal two body dm
do k = 1, n_occ_ab_core(2)
m = list_core_reverse(occ_core(k,2))
! <J| a^{\dagger}_{p1 \alpha} \hat{n}_{m \beta} a_{h1 \alpha} |I> * c_I * c_J
two_body_dm_ab_big_array_core_act(m,h1,p1) += 2.d0 * contrib
two_body_dm_ab_big_array_core_act(m,p1,h1) += 2.d0 * contrib
enddo
else ! Mono Beta :
! purely active part of the extra diagonal two body dm
do k = 1, n_occ_ab(1)
m = list_act_reverse(occ(k,1))
! <J| a^{\dagger}_{p1 \beta} \hat{n}_{m \alpha} a_{h1 \beta} |I> * c_I * c_J
call insert_into_two_body_dm_big_array(two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m)
enddo
! core <-> active part of the extra diagonal two body dm
do k = 1, n_occ_ab_core(1)
m = list_core_reverse(occ_core(k,1))
! <J| a^{\dagger}_{p1 \alpha} \hat{n}_{m \beta} a_{h1 \alpha} |I> * c_I * c_J
two_body_dm_ab_big_array_core_act(m,h1,p1) += 2.d0 * contrib
two_body_dm_ab_big_array_core_act(m,p1,h1) += 2.d0 * contrib
enddo
endif
endif
enddo
enddo
print*,'Big array for density matrix provided !'
END_PROVIDER
subroutine insert_into_two_body_dm_big_array(big_array,dim1,dim2,dim3,dim4,contrib,h1,p1,h2,p2)
implicit none
integer, intent(in) :: h1,p1,h2,p2
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4)
double precision :: contrib
! Two spin symmetry
big_array(h1,p1,h2,p2) += contrib
big_array(h2,p2,h1,p1) += contrib
! Hermicity : hole-particle symmetry
big_array(p1,h1,p2,h2) += contrib
big_array(p2,h2,p1,h1) += contrib
end
double precision function compute_extra_diag_two_body_dm_ab(r1,r2)
implicit none
BEGIN_DOC
! compute the extra diagonal contribution to the alpha/bet two body density at r1, r2
END_DOC
double precision :: r1(3), r2(3)
double precision :: compute_extra_diag_two_body_dm_ab_act,compute_extra_diag_two_body_dm_ab_core_act
compute_extra_diag_two_body_dm_ab = compute_extra_diag_two_body_dm_ab_act(r1,r2)+compute_extra_diag_two_body_dm_ab_core_act(r1,r2)
end
double precision function compute_extra_diag_two_body_dm_ab_act(r1,r2)
implicit none
BEGIN_DOC
! compute the extra diagonal contribution to the two body density at r1, r2
! involving ONLY THE ACTIVE PART, which means that the four index of the excitations
! involved in the two body density matrix are ACTIVE
END_DOC
PROVIDE n_act_orb
double precision, intent(in) :: r1(3),r2(3)
integer :: i,j,k,l
double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb)
double precision :: contrib
double precision :: contrib_tmp
!print*,'n_act_orb = ',n_act_orb
compute_extra_diag_two_body_dm_ab_act = 0.d0
call give_all_act_mos_at_r(r1,mos_array_r1)
call give_all_act_mos_at_r(r2,mos_array_r2)
do l = 1, n_act_orb ! p2
do k = 1, n_act_orb ! h2
do j = 1, n_act_orb ! p1
do i = 1,n_act_orb ! h1
contrib_tmp = mos_array_r1(i) * mos_array_r1(j) * mos_array_r2(k) * mos_array_r2(l)
compute_extra_diag_two_body_dm_ab_act += two_body_dm_ab_big_array_act(i,j,k,l) * contrib_tmp
enddo
enddo
enddo
enddo
end
double precision function compute_extra_diag_two_body_dm_ab_core_act(r1,r2)
implicit none
BEGIN_DOC
! compute the extra diagonal contribution to the two body density at r1, r2
! involving ONLY THE ACTIVE PART, which means that the four index of the excitations
! involved in the two body density matrix are ACTIVE
END_DOC
double precision, intent(in) :: r1(3),r2(3)
integer :: i,j,k,l
double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb)
double precision :: mos_array_core_r1(n_core_orb),mos_array_core_r2(n_core_orb)
double precision :: contrib_core_1,contrib_core_2
double precision :: contrib_act_1,contrib_act_2
double precision :: contrib_tmp
compute_extra_diag_two_body_dm_ab_core_act = 0.d0
call give_all_act_mos_at_r(r1,mos_array_act_r1)
call give_all_act_mos_at_r(r2,mos_array_act_r2)
call give_all_core_mos_at_r(r1,mos_array_core_r1)
call give_all_core_mos_at_r(r2,mos_array_core_r2)
do i = 1, n_act_orb ! h1
do j = 1, n_act_orb ! p1
contrib_act_1 = mos_array_act_r1(i) * mos_array_act_r1(j)
contrib_act_2 = mos_array_act_r2(i) * mos_array_act_r2(j)
do k = 1,n_core_orb ! h2
contrib_core_1 = mos_array_core_r1(k) * mos_array_core_r1(k)
contrib_core_2 = mos_array_core_r2(k) * mos_array_core_r2(k)
contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_core_2 + contrib_act_2 * contrib_core_1)
compute_extra_diag_two_body_dm_ab_core_act += two_body_dm_ab_big_array_core_act(k,i,j) * contrib_tmp
enddo
enddo
enddo
end
double precision function compute_diag_two_body_dm_ab_core(r1,r2)
implicit none
double precision :: r1(3),r2(3)
integer :: i,j,k,l
double precision :: mos_array_r1(n_core_orb_allocate),mos_array_r2(n_core_orb_allocate)
double precision :: contrib,contrib_tmp
compute_diag_two_body_dm_ab_core = 0.d0
call give_all_core_mos_at_r(r1,mos_array_r1)
call give_all_core_mos_at_r(r2,mos_array_r2)
do l = 1, n_core_orb !
contrib = mos_array_r2(l)*mos_array_r2(l)
! if(dabs(contrib).lt.threshld_two_bod_dm)cycle
do k = 1, n_core_orb !
contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k)
! if(dabs(contrib).lt.threshld_two_bod_dm)cycle
compute_diag_two_body_dm_ab_core += two_body_dm_ab_diag_core(k,l) * contrib_tmp
enddo
enddo
end
double precision function compute_diag_two_body_dm_ab_act(r1,r2)
implicit none
double precision :: r1(3),r2(3)
integer :: i,j,k,l
double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb)
double precision :: contrib,contrib_tmp
compute_diag_two_body_dm_ab_act = 0.d0
call give_all_act_mos_at_r(r1,mos_array_r1)
call give_all_act_mos_at_r(r2,mos_array_r2)
do l = 1, n_act_orb !
contrib = mos_array_r2(l)*mos_array_r2(l)
! if(dabs(contrib).lt.threshld_two_bod_dm)cycle
do k = 1, n_act_orb !
contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k)
! if(dabs(contrib).lt.threshld_two_bod_dm)cycle
compute_diag_two_body_dm_ab_act += two_body_dm_ab_diag_act(k,l) * contrib_tmp
enddo
enddo
end
double precision function compute_diag_two_body_dm_ab_core_act(r1,r2)
implicit none
double precision :: r1(3),r2(3)
integer :: i,j,k,l
double precision :: mos_array_core_r1(n_core_orb_allocate),mos_array_core_r2(n_core_orb_allocate)
double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb)
double precision :: contrib_core_1,contrib_core_2
double precision :: contrib_act_1,contrib_act_2
double precision :: contrib_tmp
compute_diag_two_body_dm_ab_core_act = 0.d0
call give_all_act_mos_at_r(r1,mos_array_act_r1)
call give_all_act_mos_at_r(r2,mos_array_act_r2)
call give_all_core_mos_at_r(r1,mos_array_core_r1)
call give_all_core_mos_at_r(r2,mos_array_core_r2)
! if(dabs(contrib).lt.threshld_two_bod_dm)cycle
do k = 1, n_act_orb !
contrib_act_1 = mos_array_act_r1(k) * mos_array_act_r1(k)
contrib_act_2 = mos_array_act_r2(k) * mos_array_act_r2(k)
contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_act_2 + contrib_act_2 * contrib_act_1)
! if(dabs(contrib).lt.threshld_two_bod_dm)cycle
do l = 1, n_core_orb !
contrib_core_1 = mos_array_core_r1(l) * mos_array_core_r1(l)
contrib_core_2 = mos_array_core_r2(l) * mos_array_core_r2(l)
compute_diag_two_body_dm_ab_core_act += two_body_dm_diag_core_act(l,k) * contrib_tmp
enddo
enddo
end
double precision function compute_diag_two_body_dm_ab(r1,r2)
implicit none
double precision,intent(in) :: r1(3),r2(3)
double precision :: compute_diag_two_body_dm_ab_act,compute_diag_two_body_dm_ab_core
double precision :: compute_diag_two_body_dm_ab_core_act
compute_diag_two_body_dm_ab = compute_diag_two_body_dm_ab_act(r1,r2)+compute_diag_two_body_dm_ab_core(r1,r2) &
+ compute_diag_two_body_dm_ab_core_act(r1,r2)
end

9
src/Determinants/utils.irp.f
View File

@ -1,15 +1,17 @@
BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ]
use bitmasks
implicit none
BEGIN_DOC
! H matrix on the basis of the slater determinants defined by psi_det
END_DOC
integer :: i,j
integer :: i,j,k
double precision :: hij
integer :: degree(N_det),idx(0:N_det)
call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij)
!$OMP PARALLEL DO SCHEDULE(GUIDED) PRIVATE(i,j,hij) &
!$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hij,degree,idx,k) &
!$OMP SHARED (N_det, psi_det, N_int,H_matrix_all_dets)
do i =1,N_det
do j =i,N_det
do j = i, N_det
call i_H_j(psi_det(1,1,i),psi_det(1,1,j),N_int,hij)
H_matrix_all_dets(i,j) = hij
H_matrix_all_dets(j,i) = hij
@ -18,3 +20,4 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ]
!$OMP END PARALLEL DO
END_PROVIDER

21
src/Integrals_Bielec/EZFIO.cfg
View File

@ -5,6 +5,27 @@ interface: ezfio,provider,ocaml
default: False
ezfio_name: direct
[no_vvvv_integrals]
type: logical
doc: If True, computes all integrals except for the integrals having 4 virtual index
interface: ezfio,provider,ocaml
default: False
ezfio_name: no_vvvv_integrals
[no_ivvv_integrals]
type: logical
doc: Can be switched on only if no_vvvv_integrals is True, then do not computes the integrals having 3 virtual index and 1 belonging to the core inactive active orbitals
interface: ezfio,provider,ocaml
default: False
ezfio_name: no_ivvv_integrals
[no_vvv_integrals]
type: logical
doc: Can be switched on only if no_vvvv_integrals is True, then do not computes the integrals having 3 virtual orbitals
interface: ezfio,provider,ocaml
default: False
ezfio_name: no_vvv_integrals
[disk_access_mo_integrals]
type: Disk_access
doc: Read/Write MO integrals from/to disk [ Write | Read | None ]

2
src/Integrals_Bielec/ao_bi_integrals.irp.f
View File

@ -350,6 +350,8 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ]
integral = ao_bielec_integral(1,1,1,1)
real :: map_mb
print*, 'read_ao_integrals',read_ao_integrals
print*, 'disk_access_ao_integrals',disk_access_ao_integrals
if (read_ao_integrals) then
print*,'Reading the AO integrals'
call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)

22
src/Integrals_Bielec/integrals_3_index.irp.f Normal file
View File

@ -0,0 +1,22 @@
BEGIN_PROVIDER [double precision, big_array_coulomb_integrals, (mo_tot_num_align,mo_tot_num, mo_tot_num)]
&BEGIN_PROVIDER [double precision, big_array_exchange_integrals,(mo_tot_num_align,mo_tot_num, mo_tot_num)]
implicit none
integer :: i,j,k,l
double precision :: get_mo_bielec_integral
double precision :: integral
do k = 1, mo_tot_num
do i = 1, mo_tot_num
do j = 1, mo_tot_num
l = j
integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
big_array_coulomb_integrals(j,i,k) = integral
l = j
integral = get_mo_bielec_integral(i,j,l,k,mo_integrals_map)
big_array_exchange_integrals(j,i,k) = integral
enddo
enddo
enddo
END_PROVIDER

87
src/Integrals_Bielec/map_integrals.irp.f
View File

@ -402,25 +402,6 @@ double precision function get_mo_bielec_integral(i,j,k,l,map)
endif
end
double precision function get_mo_bielec_integral_schwartz(i,j,k,l,map)
use map_module
implicit none
BEGIN_DOC
! Returns one integral <ij|kl> in the MO basis
END_DOC
integer, intent(in) :: i,j,k,l
type(map_type), intent(inout) :: map
double precision, external :: get_mo_bielec_integral
PROVIDE mo_bielec_integrals_in_map mo_integrals_cache
if (mo_bielec_integral_schwartz(i,k)*mo_bielec_integral_schwartz(j,l) > mo_integrals_threshold) then
!DIR$ FORCEINLINE
get_mo_bielec_integral_schwartz = get_mo_bielec_integral(i,j,k,l,map)
else
get_mo_bielec_integral_schwartz = 0.d0
endif
end
double precision function mo_bielec_integral(i,j,k,l)
implicit none
@ -431,6 +412,7 @@ double precision function mo_bielec_integral(i,j,k,l)
double precision :: get_mo_bielec_integral
PROVIDE mo_bielec_integrals_in_map mo_integrals_cache
!DIR$ FORCEINLINE
PROVIDE mo_bielec_integrals_in_map
mo_bielec_integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
return
end
@ -520,6 +502,73 @@ subroutine get_mo_bielec_integrals_ij(k,l,sze,out_array,map)
deallocate(pairs,hash,iorder,tmp_val)
end
subroutine get_mo_bielec_integrals_coulomb_ii(k,l,sze,out_val,map)
use map_module
implicit none
BEGIN_DOC
! Returns multiple integrals <ki|li>
! k(1)i(2) 1/r12 l(1)i(2) :: out_val(i1)
! for k,l fixed.
END_DOC
integer, intent(in) :: k,l, sze
double precision, intent(out) :: out_val(sze)
type(map_type), intent(inout) :: map
integer :: i
integer(key_kind) :: hash(sze)
real(integral_kind) :: tmp_val(sze)
PROVIDE mo_bielec_integrals_in_map
integer :: kk
do i=1,sze
!DIR$ FORCEINLINE
call bielec_integrals_index(k,i,l,i,hash(i))
enddo
if (key_kind == 8) then
call map_get_many(map, hash, out_val, sze)
else
call map_get_many(map, hash, tmp_val, sze)
! Conversion to double precision
do i=1,sze
out_val(i) = dble(tmp_val(i))
enddo
endif
end
subroutine get_mo_bielec_integrals_exch_ii(k,l,sze,out_val,map)
use map_module
implicit none
BEGIN_DOC
! Returns multiple integrals <ki|il>
! k(1)i(2) 1/r12 i(1)l(2) :: out_val(i1)
! for k,l fixed.
END_DOC
integer, intent(in) :: k,l, sze
double precision, intent(out) :: out_val(sze)
type(map_type), intent(inout) :: map
integer :: i
integer(key_kind) :: hash(sze)
real(integral_kind) :: tmp_val(sze)
PROVIDE mo_bielec_integrals_in_map
integer :: kk
do i=1,sze
!DIR$ FORCEINLINE
call bielec_integrals_index(k,i,i,l,hash(i))
enddo
if (key_kind == 8) then
call map_get_many(map, hash, out_val, sze)
else
call map_get_many(map, hash, tmp_val, sze)
! Conversion to double precision
do i=1,sze
out_val(i) = dble(tmp_val(i))
enddo
endif
end
integer*8 function get_mo_map_size()
implicit none
BEGIN_DOC

1002
src/Integrals_Bielec/mo_bi_integrals.irp.f
View File

File diff suppressed because it is too large Load Diff

20
src/MO_Basis/mo_permutation.irp.f Normal file
View File

@ -0,0 +1,20 @@
program permut_mos
implicit none
integer :: mo1,mo2
integer :: i,j,k,l
double precision :: mo_coef_tmp(ao_num_align,2)
print*,'Which MOs would you like to change ?'
read(5,*)mo1,mo2
print*,''
do i= 1,ao_num
mo_coef_tmp(i,1) = mo_coef(i,mo1)
mo_coef_tmp(i,2) = mo_coef(i,mo2)
enddo
do i = 1,ao_num
mo_coef(i,mo1) = mo_coef_tmp(i,2)
mo_coef(i,mo2) = mo_coef_tmp(i,1)
enddo
touch mo_coef
call save_mos
end

Some files were not shown because too many files have changed in this diff Show More