mirror of
https://github.com/LCPQ/quantum_package
synced 2024-10-18 22:11:53 +02:00
Merge branch 'master' of github.com:scemama/quantum_package
This commit is contained in:
commit
7769ea536c
@ -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
|
||||
#################
|
||||
|
@ -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()
|
||||
|
@ -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
76
plugins/All_singles/all_1h_1p_singles.irp.f
Normal 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
4
plugins/DFT_Utils/EZFIO.cfg
Normal file
@ -0,0 +1,4 @@
|
||||
[energy]
|
||||
type: double precision
|
||||
doc: Calculated energy
|
||||
interface: ezfio
|
1
plugins/DFT_Utils/NEEDED_CHILDREN_MODULES
Normal file
1
plugins/DFT_Utils/NEEDED_CHILDREN_MODULES
Normal file
@ -0,0 +1 @@
|
||||
Determinants
|
165
plugins/DFT_Utils/grid_density.irp.f
Normal file
165
plugins/DFT_Utils/grid_density.irp.f
Normal 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
54
plugins/DFT_Utils/integration_3d.irp.f
Normal 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
109
plugins/DFT_Utils/integration_radial.irp.f
Normal 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
219
plugins/DFT_Utils/routines_roland.irp.f
Normal 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
24
plugins/DFT_Utils/test_integration_3d_density.irp.f
Normal 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
|
@ -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
889
plugins/FOBOCI/SC2_1h1p.irp.f
Normal 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
|
||||
|
@ -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))
|
||||
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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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_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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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,23 +47,22 @@ 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
|
||||
if(is_ok)then
|
||||
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)
|
||||
@ -80,52 +81,11 @@ subroutine FOBOCI_lmct_mlct_old_thr
|
||||
! 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
|
||||
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,11 +140,10 @@ 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
|
||||
if(is_ok)then
|
||||
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
|
||||
@ -190,12 +151,22 @@ subroutine FOBOCI_lmct_mlct_old_thr
|
||||
dressing_matrix(k,l) = hkl
|
||||
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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
||||
|
@ -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()
|
||||
|
@ -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'
|
||||
|
@ -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
7
plugins/MRPT_Utils/EZFIO.cfg
Normal 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
187
plugins/MRPT_Utils/H_apply.irp.f
Normal 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
43
plugins/MRPT_Utils/MRPT_Utils.main.irp.f
Normal 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
1
plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES
Normal file
@ -0,0 +1 @@
|
||||
Determinants Selectors_full Generators_full Davidson
|
13
plugins/MRPT_Utils/README.rst
Normal file
13
plugins/MRPT_Utils/README.rst
Normal 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
1114
plugins/MRPT_Utils/energies_cas.irp.f
Normal file
File diff suppressed because it is too large
Load Diff
708
plugins/MRPT_Utils/excitations_cas.irp.f
Normal file
708
plugins/MRPT_Utils/excitations_cas.irp.f
Normal 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
|
||||
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
|
||||
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
210
plugins/MRPT_Utils/fock_like_operators.irp.f
Normal 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
186
plugins/MRPT_Utils/mrpt_dress.irp.f
Normal 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
369
plugins/MRPT_Utils/mrpt_utils.irp.f
Normal 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
958
plugins/MRPT_Utils/new_way.irp.f
Normal 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
796
plugins/MRPT_Utils/new_way_second_order_coef.irp.f
Normal 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
51
plugins/MRPT_Utils/print_1h2p.irp.f
Normal 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
484
plugins/MRPT_Utils/psi_active_prov.irp.f
Normal 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
757
plugins/MRPT_Utils/second_order_new.irp.f
Normal 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 .eqv. .False. )then ! condition not to double count
|
||||
if(cycle_same_spin_first_order .eqv. .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 .eqv. .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 .eqv. .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 .eqv. .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 .eqv. .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 .eqv. .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 .eqv. .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 .eqv. .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
283
plugins/MRPT_Utils/second_order_new_2p.irp.f
Normal 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
36
plugins/MRPT_Utils/utils_bitmask.irp.f
Normal 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
|
@ -17,3 +17,4 @@ doc: The selection process stops when the energy ratio variational/(variational+
|
||||
is equal to var_pt2_ratio
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 0.75
|
||||
|
||||
|
@ -1 +1 @@
|
||||
Properties Hartree_Fock Davidson
|
||||
Determinants Properties Hartree_Fock Davidson MRPT_Utils
|
||||
|
@ -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
67
plugins/Perturbation/pt2_new.irp.f
Normal 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
|
||||
|
@ -3,3 +3,10 @@ type: double precision
|
||||
doc: z point on which the integrated delta rho is calculated
|
||||
interface: ezfio,provider,ocaml
|
||||
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
|
||||
|
||||
|
@ -1 +1 @@
|
||||
Determinants
|
||||
Determinants Davidson
|
||||
|
@ -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
35
plugins/Properties/give_mos_at_r.irp.f
Normal 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
|
||||
|
@ -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
|
||||
@ -117,6 +122,11 @@ END_PROVIDER
|
||||
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
|
||||
|
||||
BEGIN_PROVIDER [double precision, iso_hcc_mhz, (nucl_num)]
|
||||
@ -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
45
plugins/Properties/iunit_two_bod.irp.f
Normal 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
|
||||
|
@ -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
36
plugins/Properties/print_spin_density.irp.f
Normal 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
11
plugins/Properties/provide_deltarho.irp.f
Normal 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
105
plugins/Properties/test_two_body_dm.irp.f
Normal 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
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -1 +1 @@
|
||||
MO_Basis
|
||||
MO_Basis Integrals_Bielec Bitmask
|
||||
|
@ -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
|
||||
|
||||
|
||||
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
|
||||
!
|
||||
! 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 !
|
||||
!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
|
||||
! 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 !
|
||||
|
||||
!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
110
plugins/loc_cele/loc_exchange_int.irp.f
Normal 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
45
plugins/loc_cele/loc_exchange_int_act.irp.f
Normal 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
45
plugins/loc_cele/loc_exchange_int_inact.irp.f
Normal 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
47
plugins/loc_cele/loc_exchange_int_virt.irp.f
Normal 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
|
@ -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
|
||||
"""
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)]
|
||||
@ -538,3 +646,18 @@ END_PROVIDER
|
||||
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
|
||||
|
||||
|
@ -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>
|
||||
|
@ -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
16
src/Davidson/diagonalize_restart_and_save_all_states.irp.f
Normal 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
25
src/Davidson/diagonalize_restart_and_save_lowest_state.irp.f
Normal 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
26
src/Davidson/diagonalize_restart_and_save_one_state.irp.f
Normal 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
176
src/Davidson/print_H_matrix_restart.irp.f
Normal 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
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
154
src/Determinants/mono_excitations.irp.f
Normal 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
|
||||
|
@ -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
11
src/Determinants/print_bitmask.irp.f
Normal 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
36
src/Determinants/print_holes_particles.irp.f
Normal 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
71
src/Determinants/print_wf.irp.f
Normal 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
50
src/Determinants/save_only_singles.irp.f
Normal 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
|
@ -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
|
||||
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
|
||||
|
@ -1,18 +1,11 @@
|
||||
program cisd
|
||||
program s2_eig_restart
|
||||
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
|
||||
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
619
src/Determinants/two_body_dm_map.irp.f
Normal 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
|
@ -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
|
||||
|
||||
|
||||
|
@ -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 ]
|
||||
|
@ -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
22
src/Integrals_Bielec/integrals_3_index.irp.f
Normal 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
|
@ -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
|
||||
|
File diff suppressed because it is too large
Load Diff
20
src/MO_Basis/mo_permutation.irp.f
Normal file
20
src/MO_Basis/mo_permutation.irp.f
Normal 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
|
53
src/MO_Basis/print_aos.irp.f
Normal file
53
src/MO_Basis/print_aos.irp.f
Normal file
@ -0,0 +1,53 @@
|
||||
program pouet
|
||||
implicit none
|
||||
integer :: i,j,k
|
||||
double precision :: r(3)
|
||||
double precision, allocatable :: aos_array(:),mos_array(:),ao_ortho_array(:)
|
||||
allocate(aos_array(ao_num),mos_array(mo_tot_num), ao_ortho_array(ao_num))
|
||||
integer :: nx,ny
|
||||
double precision :: interval_x
|
||||
double precision :: xmin,xmax
|
||||
double precision :: dx
|
||||
|
||||
double precision :: interval_y
|
||||
double precision :: ymin,ymax
|
||||
double precision :: dy
|
||||
|
||||
double precision :: val_max
|
||||
|
||||
!do i = 1, ao_num
|
||||
! write(41,'(100(F16.10,X))'),ao_ortho_canonical_overlap(i,:)
|
||||
!enddo
|
||||
|
||||
!stop
|
||||
|
||||
|
||||
xmin = nucl_coord(1,1)-6.d0
|
||||
xmax = nucl_coord(2,1)+6.d0
|
||||
interval_x = xmax - xmin
|
||||
!interval_x = nucl_dist(1,3)
|
||||
nx = 500
|
||||
dx = interval_x/dble(nx)
|
||||
!dx = dabs(interval_x)/dble(nx) * 1.d0/sqrt(2.d0)
|
||||
|
||||
r = 0.d0
|
||||
r(3) = xmin
|
||||
!r(2) = nucl_coord(1,2)
|
||||
!r(3) = nucl_coord(1,3)
|
||||
!r(1) = nucl_coord(2,1)
|
||||
!r(2) = 1.D0
|
||||
!r(3) = nucl_coord(2,3)
|
||||
double precision :: dr(3)
|
||||
!dr = 0.d0
|
||||
!dr(1) = -dx
|
||||
!dr(3) = dx
|
||||
do j = 1, nx+1
|
||||
call give_all_mos_at_r(r,mos_array)
|
||||
write(37,'(100(F16.10,X))') r(3),mos_array(1)*mos_array(1) , mos_array(2)*mos_array(2), mos_array(1)*mos_array(2)
|
||||
write(38,'(100(F16.10,X))') r(3),mos_array(1), mos_array(2), mos_array(1)*mos_array(2)
|
||||
! write(38,'(100(F16.10,X))') r(3),mos_array(10), mos_array(2) - 0.029916d0 * mos_array(10),mos_array(2) + 0.029916d0 * mos_array(10)
|
||||
r(3) += dx
|
||||
! r += dr
|
||||
enddo
|
||||
deallocate(aos_array,mos_array, ao_ortho_array)
|
||||
end
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user