LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-06-02 11:25:26 +02:00
Code Issues Releases Wiki Activity

minor changes in README.rst of many src files

Browse Source
This commit is contained in:
Emmanuel Giner 2018-12-26 16:45:57 +01:00
parent d292f00154
commit 3e54005d7e
53 changed files with 119 additions and 7596 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
scripts/module/module_handler.py
View File

@ -84,6 +84,7 @@ def get_dict_child(l_root_abs=None):
except IOError:
pass
else:
# print module_rel
if module_rel not in d_ref:
d_ref[module_rel] = l_children
else:

7
src/ao_one_e_integrals/README.rst
View File

@ -4,3 +4,10 @@ AO_one_e_integrals
All the one-electron integrals in the |AO| basis are here.
The most important providers for usual quantum-chemistry calculation are:
# `ao_kinetic_integral` which are the kinetic operator integrals on the |AO| basis (see :file:`kin_ao_ints.irp.f`)
# `ao_nucl_elec_integral` which are the nuclear-elctron operator integrals on the |AO| basis (see :file:`pot_ao_ints.irp.f`)
# `ao_mono_elec_integral` which are the the h_core operator integrals on the |AO| basis (see :file:`ao_mono_ints.irp.f`)
Note that you can find other interesting integrals related to the position operator in :file:`spread_dipole_ao.irp.f`.

2
src/ao_one_e_integrals/spread_dipole_ao.irp.f
View File

@ -222,9 +222,11 @@
subroutine overlap_bourrin_spread(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,lower_exp_val,dx,nx)
BEGIN_DOC
! Computes the following integral :
! int [-infty ; +infty] of [(x-A_center)^(power_A) * (x-B_center)^power_B * exp(-alpha(x-A_center)^2) * exp(-beta(x-B_center)^2) * x ]
! needed for the dipole and those things
END_DOC
implicit none
integer :: i,j,k,l
integer,intent(in) :: power_A,power_B

13
src/aux_quantities/README.rst
View File

@ -1,6 +1,13 @@
============
Data energy and density
============
==============
aux_quantities
==============
This module contains some global variables (such as densities and energies) which are stored in the EZFIO folder in a different place than determinants. This is used in practice to store density matrices which can be obtained from any methods, as long as they are stored in the same MO basis which is used for the calculations. In |RS-DFT| calculations, this can be done to perform damping on the density in order to speed up convergence.
The main providers of that module are:
# `data_one_body_alpha_dm_mo` and `data_one_body_beta_dm_mo` which are the one-body alpha and beta densities which are necessary read from the EZFIO folder.
Thanks to these providers you can use any density matrix that does not necessary corresponds to that of the current wave function.

9
src/becke_numerical_grid/README.rst
View File

@ -1,11 +1,18 @@
====================
Becke Numerical Grid
becke_numerical_grid
====================
This module contains all quantities needed to build the Becke's grid used in general for DFT integration. Note that it can be used for whatever integration in R^3 as long as the functions to be integrated are mostly concentrated near the atomic regions.
This grid is built as the reunion of a spherical grid around each atom. Each spherical grid contains a certain number of radial and angular points.
The main providers of that module are:
# :option:`becke_numerical_grid n_points_integration_angular` which is the number of angular integration points. WARNING: it obeys to specific rules so it cannot be any integer number. Some of the possible values are [ 50 | 74 | 266 | 590 | 1202 | 2030 | 5810 ] for instance. See :file:`angular.f` for more details.
# :option:`becke_numerical_grid n_points_radial_grid` which is the number of radial angular points. This can be any strictly positive integer. Nevertheless, a minimum of 50 is in general necessary.
# `final_grid_points` which are the (x,y,z) coordinates of the grid points.
# `final_weight_at_r_vector` which are the weights at each grid point
For a simple example of how to use the grid, see :file:`example.irp.f`.
The spherical integration uses Lebedev-Laikov grids, which was used from the code distributed through CCL (http://www.ccl.net/).

4
src/becke_numerical_grid/example.irp.f
View File

@ -35,7 +35,7 @@ subroutine example_becke_numerical_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_functions_at_final_grid_points(i)
weight = final_weight_at_r_vector(i)
double precision :: distance, f_r
! you compute the function to be integrated
distance = dsqrt( (r(1) - center(1))**2 + (r(2) - center(2))**2 + (r(3) - center(3))**2 )
@ -58,7 +58,7 @@ subroutine example_becke_numerical_grid
r(1) = grid_points_per_atom(1,k,j,i)
r(2) = grid_points_per_atom(2,k,j,i)
r(3) = grid_points_per_atom(3,k,j,i)
weight = final_weight_functions_at_grid_points(k,j,i)
weight = final_weight_at_r(k,j,i)
distance = dsqrt( (r(1) - center(1))**2 + (r(2) - center(2))**2 + (r(3) - center(3))**2 )
f_r = dexp(-alpha * distance)
integral_2 += f_r * weight

8
src/becke_numerical_grid/grid_becke.irp.f
View File

@ -123,7 +123,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,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)
@ -156,7 +156,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int
accu += tmp_array(i)
enddo
accu = 1.d0/accu
weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu
weight_at_r(l,k,j) = tmp_array(j) * accu
enddo
enddo
enddo
@ -164,7 +164,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int
END_PROVIDER
BEGIN_PROVIDER [double precision, final_weight_functions_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
BEGIN_PROVIDER [double precision, final_weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
BEGIN_DOC
! Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights.
END_DOC
@ -182,7 +182,7 @@ BEGIN_PROVIDER [double precision, final_weight_functions_at_grid_points, (n_poin
do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
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
final_weight_functions_at_grid_points(k,i,j) = weights_angular_points(k) * weight_functions_at_grid_points(k,i,j) * contrib_integration * dr_radial_integral
final_weight_at_r(k,i,j) = weights_angular_points(k) * weight_at_r(k,i,j) * contrib_integration * dr_radial_integral
enddo
enddo
enddo

6
src/becke_numerical_grid/grid_becke_vector.irp.f
View File

@ -24,14 +24,14 @@ BEGIN_PROVIDER [integer, n_points_final_grid]
END_PROVIDER
BEGIN_PROVIDER [double precision, final_grid_points, (3,n_points_final_grid)]
&BEGIN_PROVIDER [double precision, final_weight_functions_at_final_grid_points, (n_points_final_grid) ]
&BEGIN_PROVIDER [double precision, final_weight_at_r_vector, (n_points_final_grid) ]
&BEGIN_PROVIDER [integer, index_final_points, (3,n_points_final_grid) ]
&BEGIN_PROVIDER [integer, index_final_points_reverse, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
implicit none
BEGIN_DOC
! final_grid_points(1:3,j) = (/ x, y, z /) of the jth grid point
!
! final_weight_functions_at_final_grid_points(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
! final_weight_at_r_vector(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
!
! index_final_points(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
!
@ -52,7 +52,7 @@ END_PROVIDER
final_grid_points(1,i_count) = grid_points_per_atom(1,k,i,j)
final_grid_points(2,i_count) = grid_points_per_atom(2,k,i,j)
final_grid_points(3,i_count) = grid_points_per_atom(3,k,i,j)
final_weight_functions_at_final_grid_points(i_count) = final_weight_functions_at_grid_points(k,i,j)
final_weight_at_r_vector(i_count) = final_weight_at_r(k,i,j)
index_final_points(1,i_count) = k
index_final_points(2,i_count) = i
index_final_points(3,i_count) = j

3
src/davidson/README.rst
View File

@ -8,4 +8,7 @@ a dressing is used, the dressing column should be defined and the
:ref:`davidsondressed` module should be used. If no dressing is required,
the :ref:`davidson` module should be used, and it has a default zero dressing vector.
The important providers for that module are:
# `psi_energy` which is the expectation value over the wave function (`psi_det`, `psi_coef`) of the Hamiltonian, dressed or not. It uses the general subroutine `u_0_H_u_0`.
# `psi_energy_bielec` which is the expectation value over the wave function (`psi_det`, `psi_coef`) of the standard two-electrons coulomb operator. It uses the general routine `u_0_H_u_0_bielec`.

2
src/davidson/u0_h_u0.irp.f
View File

@ -1,7 +1,7 @@
BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ]
implicit none
BEGIN_DOC
! Energy of the current wave function
! Electronic energy of the current wave function
END_DOC
call u_0_H_u_0(psi_energy,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size)
integer :: i

16
src/determinants/README.rst
View File

@ -3,3 +3,19 @@ Determinants
============
Contains everything for the computation of the Hamiltonian matrix elements in the basis of orthogonal Slater determinants built on a restricted spin-orbitals basis.
The main providers for this module are:
# :option:`determinants n_states`: number of states to be computed
# `psi_det`: list of determinants in the wave function used in many routines/providers of the |QP|.
# `psi_coef`: list of coefficients, for all :option:`determinants n_states` states, and all determinants.
The main routines for this module are:
# `i_H_j`: computes the Hamiltonian matrix element between two arbitrary Slater determinants.
# `i_H_j_s2`: computes the Hamiltonian and (:math:`S^2`) matrix element between two arbitrary Slater determinants.
# `i_H_j_verbose`: returns the decomposition in terms of one- and two-body components of the Hamiltonian matrix elements between two arbitrary Slater determinants. Also return the fermionic phase factor.
# `i_H_psi`: computes the Hamiltonian matrix element between an arbitrary Slater determinant and a wave function composed of a sum of arbitrary Slater determinants.
For an example of how to use these routines and providers, take a look at :file:`example.irp.f`.

11
src/dft_keywords/README.rst
View File

@ -1,12 +1,13 @@
============
DFT Keywords
dft_keywords
============
This module contains the main keywords related to a DFT calculation or RS-DFT calculation, such as:
# :option:exchange_functional
# :option:correlation_functional
# :option:HF_exchange : only relevent for the :ref:`ks_scf` program
# :option:density_for_dft : mainly relevent for multi-determinant range separated DFT, see the plugins of eginer.
# :option:`dft_keywords exchange_functional`
# :option:`dft_keywords correlation_functional`
# :option:`dft_keywords HF_exchange` : only relevent for the :ref:`ks_scf` program
The keyword for the range separation parameter :math:`\mu` is the :option:`ao_two_e_erf_integrals mu_erf` keyword.
The keyword for the type of density used in RS-DFT calculation with a multi-configurational wave function is the :option:`density_for_dft density_for_dft` keyword.

134
src/dft_utils_in_r/dm_in_r.irp.f
View File

@ -103,8 +103,8 @@ end
enddo
end
BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ]
&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ]
BEGIN_PROVIDER [double precision, one_dm_alpha_in_r, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ]
&BEGIN_PROVIDER [double precision, one_dm_beta_in_r, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ]
implicit none
integer :: i,j,k,l,m,istate
double precision :: contrib
@ -114,8 +114,8 @@ end
do k = 1, n_points_radial_grid -1
do l = 1, n_points_integration_angular
do istate = 1, N_States
one_body_dm_mo_alpha_at_grid_points(l,k,j,istate) = 0.d0
one_body_dm_mo_beta_at_grid_points(l,k,j,istate) = 0.d0
one_dm_alpha_in_r(l,k,j,istate) = 0.d0
one_dm_beta_in_r(l,k,j,istate) = 0.d0
enddo
r(1) = grid_points_per_atom(1,l,k,j)
r(2) = grid_points_per_atom(2,l,k,j)
@ -124,8 +124,8 @@ end
double precision :: dm_a(N_states),dm_b(N_states)
call dm_dft_alpha_beta_at_r(r,dm_a,dm_b)
do istate=1,N_states
one_body_dm_mo_alpha_at_grid_points(l,k,j,istate) = dm_a(istate)
one_body_dm_mo_beta_at_grid_points(l,k,j,istate) = dm_b(istate)
one_dm_alpha_in_r(l,k,j,istate) = dm_a(istate)
one_dm_beta_in_r(l,k,j,istate) = dm_b(istate)
enddo
enddo
@ -161,15 +161,15 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [double precision, one_body_dm_alpha_and_grad_at_r, (4,n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_body_dm_beta_and_grad_at_r, (4,n_points_final_grid,N_states) ]
BEGIN_PROVIDER [double precision, one_dm_and_grad_alpha_in_r, (4,n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_dm_and_grad_beta_in_r, (4,n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_body_grad_2_dm_alpha_at_r, (n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_body_grad_2_dm_beta_at_r, (n_points_final_grid,N_states) ]
BEGIN_DOC
! one_body_dm_alpha_and_grad_at_r(1,i,i_state) = d\dx n_alpha(r_i,istate)
! one_body_dm_alpha_and_grad_at_r(2,i,i_state) = d\dy n_alpha(r_i,istate)
! one_body_dm_alpha_and_grad_at_r(3,i,i_state) = d\dz n_alpha(r_i,istate)
! one_body_dm_alpha_and_grad_at_r(4,i,i_state) = n_alpha(r_i,istate)
! one_dm_and_grad_alpha_in_r(1,i,i_state) = d\dx n_alpha(r_i,istate)
! one_dm_and_grad_alpha_in_r(2,i,i_state) = d\dy n_alpha(r_i,istate)
! one_dm_and_grad_alpha_in_r(3,i,i_state) = d\dz n_alpha(r_i,istate)
! one_dm_and_grad_alpha_in_r(4,i,i_state) = n_alpha(r_i,istate)
! one_body_grad_2_dm_alpha_at_r(i,istate) = d\dx n_alpha(r_i,istate)^2 + d\dy n_alpha(r_i,istate)^2 + d\dz n_alpha(r_i,istate)^2
! where r_i is the ith point of the grid and istate is the state number
END_DOC
@ -188,112 +188,18 @@ END_PROVIDER
r(3) = final_grid_points(3,i)
!!!! Works also with the ao basis
call density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, dm_a_grad, dm_b_grad, aos_array, grad_aos_array)
one_body_dm_alpha_and_grad_at_r(1,i,istate) = dm_a_grad(1,istate)
one_body_dm_alpha_and_grad_at_r(2,i,istate) = dm_a_grad(2,istate)
one_body_dm_alpha_and_grad_at_r(3,i,istate) = dm_a_grad(3,istate)
one_body_dm_alpha_and_grad_at_r(4,i,istate) = dm_a(istate)
one_dm_and_grad_alpha_in_r(1,i,istate) = dm_a_grad(1,istate)
one_dm_and_grad_alpha_in_r(2,i,istate) = dm_a_grad(2,istate)
one_dm_and_grad_alpha_in_r(3,i,istate) = dm_a_grad(3,istate)
one_dm_and_grad_alpha_in_r(4,i,istate) = dm_a(istate)
one_body_grad_2_dm_alpha_at_r(i,istate) = dm_a_grad(1,istate) * dm_a_grad(1,istate) + dm_a_grad(2,istate) * dm_a_grad(2,istate) + dm_a_grad(3,istate) * dm_a_grad(3,istate)
one_body_dm_beta_and_grad_at_r(1,i,istate) = dm_b_grad(1,istate)
one_body_dm_beta_and_grad_at_r(2,i,istate) = dm_b_grad(2,istate)
one_body_dm_beta_and_grad_at_r(3,i,istate) = dm_b_grad(3,istate)
one_body_dm_beta_and_grad_at_r(4,i,istate) = dm_b(istate)
one_dm_and_grad_beta_in_r(1,i,istate) = dm_b_grad(1,istate)
one_dm_and_grad_beta_in_r(2,i,istate) = dm_b_grad(2,istate)
one_dm_and_grad_beta_in_r(3,i,istate) = dm_b_grad(3,istate)
one_dm_and_grad_beta_in_r(4,i,istate) = dm_b(istate)
one_body_grad_2_dm_beta_at_r(i,istate) = dm_b_grad(1,istate) * dm_b_grad(1,istate) + dm_b_grad(2,istate) * dm_b_grad(2,istate) + dm_b_grad(3,istate) * dm_b_grad(3,istate)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_and_grad_at_grid_points, (4,n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ]
&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_and_grad_at_grid_points, (4,n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ]
BEGIN_DOC
! one_body_dm_mo_alpha_and_grad_at_grid_points(1,.....,i_state) = d\dx \rho_{\alpha}^{\istate}(r)
! one_body_dm_mo_alpha_and_grad_at_grid_points(2,.....,i_state) = d\dy \rho_{\alpha}^{\istate}(r)
! one_body_dm_mo_alpha_and_grad_at_grid_points(3,.....,i_state) = d\dz \rho_{\alpha}^{\istate}(r)
! one_body_dm_mo_alpha_and_grad_at_grid_points(4,.....,i_state) = \rho_{\alpha}^{\istate}(r)
END_DOC
implicit none
integer :: i,j,k,l,m,istate
double precision :: contrib
double precision :: r(3)
double precision :: aos_array(ao_num),grad_aos_array(3,ao_num)
do istate = 1, N_States
do j = 1, nucl_num
do k = 1, n_points_radial_grid -1
do l = 1, n_points_integration_angular
do m = 1, 4
one_body_dm_mo_alpha_and_grad_at_grid_points(m,l,k,j,istate) = 0.d0
one_body_dm_mo_beta_and_grad_at_grid_points(m,l,k,j,istate) = 0.d0
enddo
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)
!!!!! Works also with the ao basis
double precision :: dm_a(N_states),dm_b(N_states), dm_a_grad(3,N_states), dm_b_grad(3,N_states)
call density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, dm_a_grad, dm_b_grad, aos_array, grad_aos_array)
one_body_dm_mo_alpha_and_grad_at_grid_points(1,l,k,j,istate) = dm_a_grad(1,istate)
one_body_dm_mo_alpha_and_grad_at_grid_points(2,l,k,j,istate) = dm_a_grad(2,istate)
one_body_dm_mo_alpha_and_grad_at_grid_points(3,l,k,j,istate) = dm_a_grad(3,istate)
one_body_dm_mo_alpha_and_grad_at_grid_points(4,l,k,j,istate) = dm_a(istate)
one_body_dm_mo_beta_and_grad_at_grid_points(1,l,k,j,istate) = dm_b_grad(1,istate)
one_body_dm_mo_beta_and_grad_at_grid_points(2,l,k,j,istate) = dm_b_grad(2,istate)
one_body_dm_mo_beta_and_grad_at_grid_points(3,l,k,j,istate) = dm_b_grad(3,istate)
one_body_dm_mo_beta_and_grad_at_grid_points(4,l,k,j,istate) = dm_b(istate)
enddo
enddo
enddo
enddo
END_PROVIDER
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,istate
double precision :: x
double precision :: integrand(n_points_integration_angular), weights(n_points_integration_angular)
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_integration_angular (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 istate = 1, N_states
do k = 1, n_points_integration_angular
f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j,istate) * 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,istate) * weight_functions_at_grid_points(k,i,j)
enddo
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

12
src/dft_utils_one_e/e_xc.irp.f
View File

@ -19,7 +19,7 @@
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight=final_weight_functions_at_final_grid_points(i)
weight = final_weight_at_r_vector(i)
rhoa(istate) = one_body_dm_alpha_at_r(i,istate)
rhob(istate) = one_body_dm_beta_at_r(i,istate)
call ec_LDA(rhoa(istate),rhob(istate),e_c,vc_a,vc_b)
@ -58,11 +58,11 @@
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight=final_weight_functions_at_final_grid_points(i)
rho_a(istate) = one_body_dm_alpha_and_grad_at_r(4,i,istate)
rho_b(istate) = one_body_dm_beta_and_grad_at_r(4,i,istate)
grad_rho_a(1:3,istate) = one_body_dm_alpha_and_grad_at_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_body_dm_beta_and_grad_at_r(1:3,i,istate)
weight = final_weight_at_r_vector(i)
rho_a(istate) = one_dm_and_grad_alpha_in_r(4,i,istate)
rho_b(istate) = one_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3,istate) = one_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_dm_and_grad_beta_in_r(1:3,i,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0

12
src/dft_utils_one_e/pot_ao.irp.f
View File

@ -19,7 +19,7 @@
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight=final_weight_functions_at_final_grid_points(i)
weight = final_weight_at_r_vector(i)
rhoa(istate) = one_body_dm_alpha_at_r(i,istate)
rhob(istate) = one_body_dm_beta_at_r(i,istate)
call ec_LDA_sr(mu_local,rhoa(istate),rhob(istate),e_c,vc_a,vc_b)
@ -94,11 +94,11 @@
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight=final_weight_functions_at_final_grid_points(i)
rho_a(istate) = one_body_dm_alpha_and_grad_at_r(4,i,istate)
rho_b(istate) = one_body_dm_beta_and_grad_at_r(4,i,istate)
grad_rho_a(1:3,istate) = one_body_dm_alpha_and_grad_at_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_body_dm_beta_and_grad_at_r(1:3,i,istate)
weight = final_weight_at_r_vector(i)
rho_a(istate) = one_dm_and_grad_alpha_in_r(4,i,istate)
rho_b(istate) = one_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3,istate) = one_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_dm_and_grad_beta_in_r(1:3,i,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0

12
src/dft_utils_one_e/sr_exc.irp.f
View File

@ -19,7 +19,7 @@
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight=final_weight_functions_at_final_grid_points(i)
weight = final_weight_at_r_vector(i)
rhoa(istate) = one_body_dm_alpha_at_r(i,istate)
rhob(istate) = one_body_dm_beta_at_r(i,istate)
call ec_LDA_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_c,vc_a,vc_b)
@ -58,11 +58,11 @@
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight=final_weight_functions_at_final_grid_points(i)
rho_a(istate) = one_body_dm_alpha_and_grad_at_r(4,i,istate)
rho_b(istate) = one_body_dm_beta_and_grad_at_r(4,i,istate)
grad_rho_a(1:3,istate) = one_body_dm_alpha_and_grad_at_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_body_dm_beta_and_grad_at_r(1:3,i,istate)
weight = final_weight_at_r_vector(i)
rho_a(istate) = one_dm_and_grad_alpha_in_r(4,i,istate)
rho_b(istate) = one_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3,istate) = one_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_dm_and_grad_beta_in_r(1:3,i,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0

12
src/dft_utils_one_e/sr_pot_ao.irp.f
View File

@ -17,7 +17,7 @@
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight=final_weight_functions_at_final_grid_points(i)
weight=final_weight_at_r_vector(i)
rhoa(istate) = one_body_dm_alpha_at_r(i,istate)
rhob(istate) = one_body_dm_beta_at_r(i,istate)
call ec_LDA_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_c,sr_vc_a,sr_vc_b)
@ -92,11 +92,11 @@
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight=final_weight_functions_at_final_grid_points(i)
rho_a(istate) = one_body_dm_alpha_and_grad_at_r(4,i,istate)
rho_b(istate) = one_body_dm_beta_and_grad_at_r(4,i,istate)
grad_rho_a(1:3,istate) = one_body_dm_alpha_and_grad_at_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_body_dm_beta_and_grad_at_r(1:3,i,istate)
weight = final_weight_at_r_vector(i)
rho_a(istate) = one_dm_and_grad_alpha_in_r(4,i,istate)
rho_b(istate) = one_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3,istate) = one_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_dm_and_grad_beta_in_r(1:3,i,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0

1
src/dft_utils_two_body/.gitignore vendored
View File

@ -1 +0,0 @@
../../data/module_gitignore

2
src/dft_utils_two_body/INSTALL.cfg
View File

@ -1,2 +0,0 @@
[scripts]
qp_cipsi_rsh

3
src/dft_utils_two_body/NEED
View File

@ -1,3 +0,0 @@
dft_utils_one_e
determinants
davidson_undressed

44
src/dft_utils_two_body/mr_dft_energy.irp.f
View File

@ -1,44 +0,0 @@
BEGIN_PROVIDER [double precision, electronic_energy_mr_dft, (N_states)]
implicit none
BEGIN_DOC
! Energy for the multi determinantal DFT calculation
END_DOC
print*,'You are using a variational method which uses the wave function stored in the EZFIO folder'
electronic_energy_mr_dft = total_range_separated_electronic_energy
END_PROVIDER
subroutine print_variational_energy_dft
implicit none
print*,'/////////////////////////'
print*, '****************************************'
print*,'///////////////////'
print*, ' Regular range separated DFT energy '
write(*, '(A22,X,F32.10)') 'mu_erf = ',mu_erf
write(*, '(A22,X,F16.10)') 'TOTAL ENERGY = ',electronic_energy_mr_dft+nuclear_repulsion
print*, ''
print*, 'Component of the energy ....'
print*, ''
write(*, '(A22,X,F16.10)') 'nuclear_repulsion = ',nuclear_repulsion
write(*, '(A22,X,F16.10)') 'psi_energy_erf = ',psi_energy_erf
write(*, '(A22,X,F16.10)') 'psi_dft_energy_h_cor= ',psi_dft_energy_h_core
write(*, '(A22,X,F16.10)') 'short_range_Hartree = ',short_range_Hartree
write(*, '(A22,X,F16.10)') 'two_elec_energy = ',two_elec_energy_dft
write(*, '(A22,X,F16.10)') 'energy_x = ',energy_x
write(*, '(A22,X,F16.10)') 'energy_c = ',energy_c
write(*, '(A22,X,F16.10)') 'E_xc = ',energy_x + energy_c
write(*, '(A22,X,F16.10)') 'E_Hxc = ',energy_x + energy_c + short_range_Hartree
print*, ''
print*, '****************************************'
print*, ''
write(*, '(A22,X,F16.10)') 'Approx eigenvalue = ',electronic_energy_mr_dft+nuclear_repulsion + Trace_v_Hxc - (short_range_Hartree + energy_x + energy_c)
write(*, '(A22,X,F16.10)') 'Trace_v_xc = ',Trace_v_xc
write(*, '(A22,X,F16.10)') 'Trace_v_Hxc = ',Trace_v_Hxc
write(*, '(A22,X,F16.10)') '<Psi| H | Psi> = ',psi_energy
write(*, '(A22,X,F16.10)') 'psi_energy_bielec = ',psi_energy_bielec
write(*, '(A22,X,F16.10)') 'psi_energy_h_core = ',psi_energy_h_core
end

16
src/dft_utils_two_body/print_rsdft_variational_energy.irp.f
View File

@ -1,16 +0,0 @@
program DFT_Utils_two_body_main
implicit none
read_wf = .true.
touch read_wf
disk_access_mo_one_integrals = "None"
touch disk_access_mo_one_integrals
disk_access_mo_integrals = "None"
touch disk_access_mo_integrals
disk_access_ao_integrals = "None"
touch disk_access_ao_integrals
density_for_dft = "WFT"
touch density_for_dft
call print_variational_energy_dft
end

81
src/dft_utils_two_body/psi_energy_erf.irp.f
View File

@ -1,81 +0,0 @@
BEGIN_PROVIDER [ double precision, psi_energy_erf, (N_states) ]
use bitmasks
implicit none
BEGIN_DOC
! Computes e_0 = <Psi|W_{ee}^{lr}|Psi>/<Psi|Psi>
!
END_DOC
integer :: i
call u_0_H_u_0_erf(psi_energy_erf,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size)
do i=N_det+1,N_states
psi_energy_erf(i) = 0.d0
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_energy_h_core_and_sr_hartree, (N_states) ]
implicit none
BEGIN_DOC
! psi_energy_h_core = <Psi| h_{core} + v_{H}^{sr}|Psi>
END_DOC
psi_energy_h_core_and_sr_hartree = psi_energy_h_core + short_range_Hartree
END_PROVIDER
BEGIN_PROVIDER [ double precision, total_range_separated_electronic_energy, (N_states) ]
implicit none
BEGIN_DOC
! Total_range_separated_electronic_energy = <Psi| h_{core} |Psi> + (1/2) <Psi| v_{H}^{sr} |Psi> + <i|W_{ee}^{lr}|i> + E_{x} + E_{c}
END_DOC
total_range_separated_electronic_energy = psi_energy_h_core + short_range_Hartree + psi_energy_erf + energy_x + energy_c
END_PROVIDER
BEGIN_PROVIDER [ double precision, two_elec_energy_dft, (N_states) ]
implicit none
BEGIN_DOC
! two_elec_energy_dft = (1/2) <Psi| v_{H}^{sr} |Psi> + <Psi|W_{ee}^{lr}|Psi>
END_DOC
two_elec_energy_dft = short_range_Hartree + psi_energy_erf
END_PROVIDER
BEGIN_PROVIDER [ double precision, ref_bitmask_energy_erf ]
&BEGIN_PROVIDER [ double precision, bi_elec_ref_bitmask_energy_erf ]
use bitmasks
implicit none
BEGIN_DOC
! Energy with the LONG RANGE INTERACTION of the reference bitmask used in Slater rules
END_DOC
integer :: occ(N_int*bit_kind_size,2)
integer :: i,j
call bitstring_to_list(ref_bitmask(1,1), occ(1,1), i, N_int)
call bitstring_to_list(ref_bitmask(1,2), occ(1,2), i, N_int)
ref_bitmask_energy_erf = 0.d0
bi_elec_ref_bitmask_energy_erf = 0.d0
do j= 1, elec_alpha_num
do i = j+1, elec_alpha_num
bi_elec_ref_bitmask_energy_erf += mo_two_e_int_erf_jj_anti(occ(i,1),occ(j,1))
ref_bitmask_energy_erf += mo_two_e_int_erf_jj_anti(occ(i,1),occ(j,1))
enddo
enddo
do j= 1, elec_beta_num
do i = j+1, elec_beta_num
bi_elec_ref_bitmask_energy_erf += mo_two_e_int_erf_jj_anti(occ(i,2),occ(j,2))
ref_bitmask_energy_erf += mo_two_e_int_erf_jj_anti(occ(i,2),occ(j,2))
enddo
do i= 1, elec_alpha_num
bi_elec_ref_bitmask_energy_erf += mo_two_e_int_erf_jj(occ(i,1),occ(j,2))
ref_bitmask_energy_erf += mo_two_e_int_erf_jj(occ(i,1),occ(j,2))
enddo
enddo
END_PROVIDER

26
src/dft_utils_two_body/routines_save_integrals_dft.irp.f
View File

@ -1,26 +0,0 @@
subroutine save_one_e_effective_potential
implicit none
BEGIN_DOC
! used to save the effective_one_e_potential into the one-body integrals in the ezfio folder
! this effective_one_e_potential is computed with the current density
! and will couple the WFT with DFT for the next regular WFT calculation
END_DOC
call ezfio_set_mo_one_e_integrals_integral_nuclear(effective_one_e_potential_without_kin)
call ezfio_set_mo_one_e_integrals_integral_kinetic(mo_kinetic_integral)
print *, 'Effective DFT potential is written on disk on the mo_ne_integral integrals'
call ezfio_set_mo_one_e_integrals_disk_access_mo_one_integrals("Read")
end
subroutine write_all_integrals_for_mrdft
implicit none
BEGIN_DOC
! saves all integrals needed for RS-DFT-MRCI calculation: one-body effective potential and two-elec erf integrals
END_DOC
call save_one_e_effective_potential
call save_erf_bi_elec_integrals_mo
call save_erf_bi_elec_integrals_ao
end

226
src/dft_utils_two_body/slater_rules_erf.irp.f
View File

@ -1,226 +0,0 @@
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! THIS FILE CONTAINS EVERYTHING YOU NEED TO COMPUTE THE LONG RANGE PART OF THE INTERACTION
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine i_H_j_erf(key_i,key_j,Nint,hij)
use bitmasks
implicit none
BEGIN_DOC
! Returns <i|W_{ee}^{lr}|j> where i and j are determinants
! and the W_{ee}^{lr} is the long range two-body interaction
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_erf
integer :: m,n,p,q
integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem_erf, phase,phase_2
integer :: n_occ_ab(2)
PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_map int_erf_3_index_exc
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num)
ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num)
ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num)
ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
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 * int_erf_3_index_exc(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 * int_erf_3_index_exc(exc(1,2,1),exc(1,1,1),exc(1,2,2))
else
hij = phase*get_mo_bielec_integral_erf( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_erf_map)
endif
else if (exc(0,1,1) == 2) then
! Double alpha
hij = phase*(get_mo_bielec_integral_erf( &
exc(1,1,1), &
exc(2,1,1), &
exc(1,2,1), &
exc(2,2,1) ,mo_integrals_erf_map) - &
get_mo_bielec_integral_erf( &
exc(1,1,1), &
exc(2,1,1), &
exc(2,2,1), &
exc(1,2,1) ,mo_integrals_erf_map) )
else if (exc(0,1,2) == 2) then
! Double beta
hij = phase*(get_mo_bielec_integral_erf( &
exc(1,1,2), &
exc(2,1,2), &
exc(1,2,2), &
exc(2,2,2) ,mo_integrals_erf_map) - &
get_mo_bielec_integral_erf( &
exc(1,1,2), &
exc(2,1,2), &
exc(2,2,2), &
exc(1,2,2) ,mo_integrals_erf_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)
if (exc(0,1,1) == 1) then
! Mono alpha
m = exc(1,1,1)
p = exc(1,2,1)
spin = 1
do i = 1, n_occ_ab(1)
hij += -int_erf_3_index_exc(occ(i,1),m,p) + int_erf_3_index(occ(i,1),m,p)
enddo
do i = 1, n_occ_ab(2)
hij += int_erf_3_index(occ(i,2),m,p)
enddo
else
! Mono beta
m = exc(1,1,2)
p = exc(1,2,2)
spin = 2
do i = 1, n_occ_ab(2)
hij += -int_erf_3_index_exc(occ(i,2),m,p) + int_erf_3_index(occ(i,2),m,p)
enddo
do i = 1, n_occ_ab(1)
hij += int_erf_3_index(occ(i,1),m,p)
enddo
endif
hij = hij * phase
case (0)
hij = diag_H_mat_elem_erf(key_i,Nint)
end select
end
double precision function diag_H_mat_elem_erf(key_i,Nint)
BEGIN_DOC
! returns <i|W_{ee}^{lr}|i> where |i> is a determinant and
! W_{ee}^{lr} is the two body long-range interaction
END_DOC
implicit none
integer(bit_kind), intent(in) :: key_i(N_int,2)
integer, intent(in) :: Nint
integer :: i,j
integer :: occ(Nint*bit_kind_size,2)
integer :: n_occ_ab(2)
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
diag_H_mat_elem_erf = 0.d0
! alpha - alpha
do i = 1, n_occ_ab(1)
do j = i+1, n_occ_ab(1)
diag_H_mat_elem_erf += mo_two_e_int_erf_jj_anti(occ(i,1),occ(j,1))
enddo
enddo
! beta - beta
do i = 1, n_occ_ab(2)
do j = i+1, n_occ_ab(2)
diag_H_mat_elem_erf += mo_two_e_int_erf_jj_anti(occ(i,2),occ(j,2))
enddo
enddo
! alpha - beta
do i = 1, n_occ_ab(1)
do j = 1, n_occ_ab(2)
diag_H_mat_elem_erf += mo_two_e_int_erf_jj(occ(i,1),occ(j,2))
enddo
enddo
end
subroutine i_H_j_mono_spin_erf(key_i,key_j,Nint,spin,hij)
use bitmasks
implicit none
BEGIN_DOC
! Returns <i|H|j> where i and j are determinants differing by a single excitation
END_DOC
integer, intent(in) :: Nint, spin
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hij
integer :: exc(0:2,2)
double precision :: phase
PROVIDE int_erf_3_index_exc mo_bielec_integrals_erf_in_map
call i_H_j_erf(key_i,key_j,Nint,hij)
end
subroutine i_H_j_double_spin_erf(key_i,key_j,Nint,hij)
use bitmasks
implicit none
BEGIN_DOC
! Returns <i|H|j> where i and j are determinants differing by a same-spin double excitation
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint), key_j(Nint)
double precision, intent(out) :: hij
integer :: exc(0:2,2)
double precision :: phase
double precision, external :: get_mo_bielec_integral_erf
PROVIDE int_erf_3_index_exc mo_bielec_integrals_erf_in_map
call get_double_excitation_spin(key_i,key_j,exc,phase,Nint)
hij = phase*(get_mo_bielec_integral_erf( &
exc(1,1), &
exc(2,1), &
exc(1,2), &
exc(2,2), mo_integrals_erf_map) - &
get_mo_bielec_integral_erf( &
exc(1,1), &
exc(2,1), &
exc(2,2), &
exc(1,2), mo_integrals_erf_map) )
end
subroutine i_H_j_double_alpha_beta_erf(key_i,key_j,Nint,hij)
use bitmasks
implicit none
BEGIN_DOC
! Returns <i|H|j> where i and j are determinants differing by an opposite-spin double excitation
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)
double precision :: phase, phase2
double precision, external :: get_mo_bielec_integral_erf
PROVIDE int_erf_3_index_exc mo_bielec_integrals_erf_in_map
call get_mono_excitation_spin(key_i(1,1),key_j(1,1),exc(0,1,1),phase,Nint)
call get_mono_excitation_spin(key_i(1,2),key_j(1,2),exc(0,1,2),phase2,Nint)
phase = phase*phase2
if (exc(1,1,1) == exc(1,2,2)) then
hij = phase * int_erf_3_index_exc(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 * int_erf_3_index_exc(exc(1,2,1),exc(1,1,1),exc(1,2,2))
else
hij = phase*get_mo_bielec_integral_erf( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_erf_map)
endif
end

482
src/dft_utils_two_body/u0_w_erf_u0.irp.f
View File

@ -1,482 +0,0 @@
subroutine u_0_H_u_0_erf(e_0,u_0,n,keys_tmp,Nint,N_st,sze)
use bitmasks
implicit none
BEGIN_DOC
! Computes e_0 = <u_0|W_{ee}^{lr}|u_0>/<u_0|u_0>
!
! n : number of determinants
!
END_DOC
integer, intent(in) :: n,Nint, N_st, sze
double precision, intent(out) :: e_0(N_st)
double precision, intent(inout) :: u_0(sze,N_st)
integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n)
double precision, allocatable :: v_0(:,:), s_0(:,:), u_1(:,:)
double precision :: u_dot_u,u_dot_v,diag_H_mat_elem
integer :: i,j
allocate (v_0(sze,N_st),s_0(sze,N_st))
call H_S2_u_0_erf_nstates_openmp(v_0,s_0,u_0,N_st,sze)
double precision :: norm
do i=1,N_st
norm = u_dot_u(u_0(1,i),n)
if (norm /= 0.d0) then
e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n)
else
e_0(i) = 0.d0
endif
enddo
deallocate (s_0, v_0)
end
subroutine H_S2_u_0_erf_nstates_openmp(v_0,s_0,u_0,N_st,sze)
use bitmasks
implicit none
BEGIN_DOC
! Computes v_0 = H|u_0> and s_0 = S^2 |u_0>
!
! Assumes that the determinants are in psi_det
!
! istart, iend, ishift, istep are used in ZMQ parallelization.
END_DOC
integer, intent(in) :: N_st,sze
double precision, intent(inout) :: v_0(sze,N_st), s_0(sze,N_st), u_0(sze,N_st)
integer :: k
double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
allocate(u_t(N_st,N_det),v_t(N_st,N_det),s_t(N_st,N_det))
do k=1,N_st
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
enddo
v_t = 0.d0
s_t = 0.d0
call dtranspose( &
u_0, &
size(u_0, 1), &
u_t, &
size(u_t, 1), &
N_det, N_st)
call H_S2_u_0_erf_nstates_openmp_work(v_t,s_t,u_t,N_st,sze,1,N_det,0,1)
deallocate(u_t)
call dtranspose( &
v_t, &
size(v_t, 1), &
v_0, &
size(v_0, 1), &
N_st, N_det)
call dtranspose( &
s_t, &
size(s_t, 1), &
s_0, &
size(s_0, 1), &
N_st, N_det)
deallocate(v_t,s_t)
do k=1,N_st
call dset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
call dset_order(s_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
enddo
end
subroutine H_S2_u_0_erf_nstates_openmp_work(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
implicit none
BEGIN_DOC
! Computes v_0 = H|u_0> and s_0 = S^2 |u_0>
!
! Default should be 1,N_det,0,1
END_DOC
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
double precision, intent(in) :: u_t(N_st,N_det)
double precision, intent(out) :: v_t(N_st,sze), s_t(N_st,sze)
PROVIDE ref_bitmask_energy_erf N_int short_range_Hartree
select case (N_int)
case (1)
call H_S2_u_0_erf_nstates_openmp_work_1(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
case (2)
call H_S2_u_0_erf_nstates_openmp_work_2(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
case (3)
call H_S2_u_0_erf_nstates_openmp_work_3(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
case (4)
call H_S2_u_0_erf_nstates_openmp_work_4(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
case default
call H_S2_u_0_erf_nstates_openmp_work_N_int(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
end select
end
BEGIN_TEMPLATE
subroutine H_S2_u_0_erf_nstates_openmp_work_$N_int(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
implicit none
BEGIN_DOC
! Computes v_t = H|u_t> and s_t = S^2 |u_t>
!
! Default should be 1,N_det,0,1
END_DOC
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
double precision, intent(in) :: u_t(N_st,N_det)
double precision, intent(out) :: v_t(N_st,sze), s_t(N_st,sze)
double precision :: hij, sij
integer :: i,j,k,l
integer :: k_a, k_b, l_a, l_b, m_a, m_b
integer :: istate
integer :: krow, kcol, krow_b, kcol_b
integer :: lrow, lcol
integer :: mrow, mcol
integer(bit_kind) :: spindet($N_int)
integer(bit_kind) :: tmp_det($N_int,2)
integer(bit_kind) :: tmp_det2($N_int,2)
integer(bit_kind) :: tmp_det3($N_int,2)
integer(bit_kind), allocatable :: buffer(:,:)
integer :: n_doubles
integer, allocatable :: doubles(:)
integer, allocatable :: singles_a(:)
integer, allocatable :: singles_b(:)
integer, allocatable :: idx(:), idx0(:)
integer :: maxab, n_singles_a, n_singles_b, kcol_prev, nmax
integer*8 :: k8
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
allocate(idx0(maxab))
do i=1,maxab
idx0(i) = i
enddo
! Prepare the array of all alpha single excitations
! -------------------------------------------------
PROVIDE N_int nthreads_davidson
!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
!$OMP SHARED(psi_bilinear_matrix_rows, N_det, &
!$OMP psi_bilinear_matrix_columns, &
!$OMP psi_det_alpha_unique, psi_det_beta_unique, &
!$OMP n_det_alpha_unique, n_det_beta_unique, N_int, &
!$OMP psi_bilinear_matrix_transp_rows, &
!$OMP psi_bilinear_matrix_transp_columns, &
!$OMP psi_bilinear_matrix_transp_order, N_st, &
!$OMP psi_bilinear_matrix_order_transp_reverse, &
!$OMP psi_bilinear_matrix_columns_loc, &
!$OMP psi_bilinear_matrix_transp_rows_loc, &
!$OMP istart, iend, istep, irp_here, v_t, s_t, &
!$OMP ishift, idx0, u_t, maxab) &
!$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, &
!$OMP lcol, lrow, l_a, l_b, &
!$OMP buffer, doubles, n_doubles, &
!$OMP tmp_det2, hij, sij, idx, l, kcol_prev, &
!$OMP singles_a, n_singles_a, singles_b, &
!$OMP n_singles_b, k8)
! Alpha/Beta double excitations
! =============================
allocate( buffer($N_int,maxab), &
singles_a(maxab), &
singles_b(maxab), &
doubles(maxab), &
idx(maxab))
kcol_prev=-1
ASSERT (iend <= N_det)
ASSERT (istart > 0)
ASSERT (istep > 0)
!$OMP DO SCHEDULE(dynamic,64)
do k_a=istart+ishift,iend,istep
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
if (kcol /= kcol_prev) then
call get_all_spin_singles_$N_int( &
psi_det_beta_unique, idx0, &
tmp_det(1,2), N_det_beta_unique, &
singles_b, n_singles_b)
endif
kcol_prev = kcol
! Loop over singly excited beta columns
! -------------------------------------
do i=1,n_singles_b
lcol = singles_b(i)
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
l_a = psi_bilinear_matrix_columns_loc(lcol)
ASSERT (l_a <= N_det)
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
ASSERT (l_a <= N_det)
idx(j) = l_a
l_a = l_a+1
enddo
j = j-1
call get_all_spin_singles_$N_int( &
buffer, idx, tmp_det(1,1), j, &
singles_a, n_singles_a )
! Loop over alpha singles
! -----------------------
do k = 1,n_singles_a
l_a = singles_a(k)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
call i_H_j_double_alpha_beta_erf(tmp_det,tmp_det2,$N_int,hij)
call get_s2(tmp_det,tmp_det2,$N_int,sij)
do l=1,N_st
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a)
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP DO SCHEDULE(dynamic,64)
do k_a=istart+ishift,iend,istep
! Single and double alpha excitations
! ===================================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
! Initial determinant is at k_b in beta-major representation
! ----------------------------------------------------------------------
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
spindet(1:$N_int) = tmp_det(1:$N_int,1)
! Loop inside the beta column to gather all the connected alphas
lcol = psi_bilinear_matrix_columns(k_a)
l_a = psi_bilinear_matrix_columns_loc(lcol)
do i=1,N_det_alpha_unique
if (l_a > N_det) exit
lcol = psi_bilinear_matrix_columns(l_a)
if (lcol /= kcol) exit
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
idx(i) = l_a
l_a = l_a+1
enddo
i = i-1
call get_all_spin_singles_and_doubles_$N_int( &
buffer, idx, spindet, i, &
singles_a, doubles, n_singles_a, n_doubles )
! Compute Hij for all alpha singles
! ----------------------------------
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
do i=1,n_singles_a
l_a = singles_a(i)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
call i_H_j_mono_spin_erf( tmp_det, tmp_det2, $N_int, 1, hij)
do l=1,N_st
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
! single => sij = 0
enddo
enddo
! Compute Hij for all alpha doubles
! ----------------------------------
do i=1,n_doubles
l_a = doubles(i)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
call i_H_j_double_spin_erf( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij)
do l=1,N_st
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
! same spin => sij = 0
enddo
enddo
! Single and double beta excitations
! ==================================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
kcol = psi_bilinear_matrix_columns(k_a)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
spindet(1:$N_int) = tmp_det(1:$N_int,2)
! Initial determinant is at k_b in beta-major representation
! -----------------------------------------------------------------------
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
! Loop inside the alpha row to gather all the connected betas
lrow = psi_bilinear_matrix_transp_rows(k_b)
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
do i=1,N_det_beta_unique
if (l_b > N_det) exit
lrow = psi_bilinear_matrix_transp_rows(l_b)
if (lrow /= krow) exit
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
idx(i) = l_b
l_b = l_b+1
enddo
i = i-1
call get_all_spin_singles_and_doubles_$N_int( &
buffer, idx, spindet, i, &
singles_b, doubles, n_singles_b, n_doubles )
! Compute Hij for all beta singles
! ----------------------------------
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
do i=1,n_singles_b
l_b = singles_b(i)
ASSERT (l_b <= N_det)
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
call i_H_j_mono_spin_erf( tmp_det, tmp_det2, $N_int, 2, hij)
l_a = psi_bilinear_matrix_transp_order(l_b)
ASSERT (l_a <= N_det)
do l=1,N_st
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
! single => sij = 0
enddo
enddo
! Compute Hij for all beta doubles
! ----------------------------------
do i=1,n_doubles
l_b = doubles(i)
ASSERT (l_b <= N_det)
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
call i_H_j_double_spin_erf( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij)
l_a = psi_bilinear_matrix_transp_order(l_b)
ASSERT (l_a <= N_det)
do l=1,N_st
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
! same spin => sij = 0
enddo
enddo
! Diagonal contribution
! =====================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
double precision, external :: diag_H_mat_elem_erf, diag_S_mat_elem
hij = diag_H_mat_elem_erf(tmp_det,$N_int)
sij = diag_S_mat_elem(tmp_det,$N_int)
do l=1,N_st
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a)
s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a)
enddo
end do
!$OMP END DO
deallocate(buffer, singles_a, singles_b, doubles, idx)
!$OMP END PARALLEL
end
SUBST [ N_int ]
1;;
2;;
3;;
4;;
N_int;;
END_TEMPLATE

34
src/dft_utils_two_body/write_effective_rsdft_hamiltonian.irp.f
View File

@ -1,34 +0,0 @@
program write_effective_RSDFT_hamiltonian
implicit none
BEGIN_DOC
! This programs writes the effective RS-DFT Hamiltonian into the EZFIO folder.
! The next programs that will run unto the EZFIO folder will, by default, have the one- and two-body integrals loaded from the EZFIO data.
END_DOC
read_wf = .true.
touch read_wf
disk_access_mo_one_integrals = "None"
touch disk_access_mo_one_integrals
disk_access_mo_integrals = "None"
touch disk_access_mo_integrals
disk_access_ao_integrals = "None"
touch disk_access_ao_integrals
call routines_write_int
call routines_compute_energy
end
subroutine routines_write_int
implicit none
call write_all_integrals_for_mrdft
density_for_dft = "WFT"
touch density_for_dft
end
subroutine routines_compute_energy
implicit none
call print_variational_energy_dft
call ezfio_set_aux_quantities_data_one_body_alpha_dm_mo(one_body_dm_mo_alpha)
call ezfio_set_aux_quantities_data_one_body_beta_dm_mo(one_body_dm_mo_beta)
end

2
src/dummy/NEED
View File

@ -15,7 +15,6 @@ determinants
dft_keywords
dft_utils_in_r
dft_utils_one_e
dft_utils_two_body
dressing
electrons
ezfio_files
@ -32,7 +31,6 @@ mo_one_e_integrals
mo_two_e_erf_integrals
mo_two_e_integrals
mpi
mrpt_utils
nuclei
perturbation
pseudo

2
src/generators_cas/README.rst
View File

@ -7,6 +7,6 @@ The |MOs| belonging to the |CAS| are those which were set as active with
the :ref:`qp_set_mo_class` command.
This module is intended to be included in the :file:`NEED` file to define
generators on a |CAS|.
the generators as the |CAS| determinants, which can be useful to define post-CAS approaches (see cassd module for instance).

9
src/mo_one_e_integrals/README.rst
View File

@ -1,6 +1,13 @@
==================
MO_one_e_integrals
mo_one_e_integrals
==================
All the one-electron integrals in |MO| basis are defined here.
The most important providers for usual quantum-chemistry calculation are:
# `mo_kinetic_integral` which are the kinetic operator integrals on the |AO| basis (see :file:`kin_mo_ints.irp.f`)
# `mo_nucl_elec_integral` which are the nuclear-elctron operator integrals on the |AO| basis (see :file:`pot_mo_ints.irp.f`)
# `mo_mono_elec_integral` which are the the h_core operator integrals on the |AO| basis (see :file:`mo_mono_ints.irp.f`)
Note that you can find other interesting integrals related to the position operator in :file:`spread_dipole_mo.irp.f`.

1
src/mo_two_e_erf_integrals/routines_save_integrals_erf.irp.f
View File

@ -7,6 +7,7 @@ subroutine save_erf_bi_elec_integrals_mo
call ezfio_set_mo_two_e_erf_integrals_disk_access_mo_integrals_erf('Read')
end
subroutine save_erf_bielec_ints_mo_into_ints_mo
implicit none
integer :: i,j,k,l

1
src/mrpt_utils/.gitignore vendored
View File

@ -1 +0,0 @@
../../data/module_gitignore

7
src/mrpt_utils/EZFIO.cfg
View File

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

3
src/mrpt_utils/NEED
View File

@ -1,3 +0,0 @@
determinants
davidson
psiref_cas

5
src/mrpt_utils/README.rst
View File

@ -1,5 +0,0 @@
==========
MRPT_Utils
==========
Subroutines and providers required for |MRPT|.

193
src/mrpt_utils/density_matrix_based.irp.f
View File

@ -1,193 +0,0 @@
subroutine contrib_1h2p_dm_based(accu)
implicit none
integer :: i_i,i_r,i_v,i_a,i_b
integer :: i,r,v,a,b
integer :: ispin,jspin
integer :: istate
double precision, intent(out) :: accu(N_states)
double precision :: active_int(n_act_orb,2)
double precision :: delta_e(n_act_orb,2,N_states)
double precision :: get_mo_bielec_integral
accu = 0.d0
!do i_i = 1, 1
do i_i = 1, n_inact_orb
i = list_inact(i_i)
! do i_r = 1, 1
do i_r = 1, n_virt_orb
r = list_virt(i_r)
! do i_v = 1, 1
do i_v = 1, n_virt_orb
v = list_virt(i_v)
do i_a = 1, n_act_orb
a = list_act(i_a)
active_int(i_a,1) = get_mo_bielec_integral(i,a,r,v,mo_integrals_map) ! direct
active_int(i_a,2) = get_mo_bielec_integral(i,a,v,r,mo_integrals_map) ! exchange
do istate = 1, N_states
do jspin=1, 2
delta_e(i_a,jspin,istate) = one_anhil(i_a,jspin,istate) &
- fock_virt_total_spin_trace(r,istate) &
- fock_virt_total_spin_trace(v,istate) &
+ fock_core_inactive_total_spin_trace(i,istate)
delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate)
enddo
enddo
enddo
do i_a = 1, n_act_orb
a = list_act(i_a)
do i_b = 1, n_act_orb
! do i_b = i_a, i_a
b = list_act(i_b)
do ispin = 1, 2 ! spin of (i --> r)
do jspin = 1, 2 ! spin of (a --> v)
if(ispin == jspin .and. r.le.v)cycle ! condition not to double count
do istate = 1, N_states
if(ispin == jspin)then
accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_mo_spin_index(a,b,istate,ispin) &
* (active_int(i_b,1) - active_int(i_b,2)) &
* delta_e(i_a,jspin,istate)
else
accu(istate) += active_int(i_a,1) * one_body_dm_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) &
* active_int(i_b,1)
endif
enddo
enddo
enddo
enddo
enddo
enddo
enddo
enddo
end
subroutine contrib_2h1p_dm_based(accu)
implicit none
integer :: i_i,i_j,i_v,i_a,i_b
integer :: i,j,v,a,b
integer :: ispin,jspin
integer :: istate
double precision, intent(out) :: accu(N_states)
double precision :: active_int(n_act_orb,2)
double precision :: delta_e(n_act_orb,2,N_states)
double precision :: get_mo_bielec_integral
accu = 0.d0
do i_i = 1, n_inact_orb
i = list_inact(i_i)
do i_j = 1, n_inact_orb
j = list_inact(i_j)
do i_v = 1, n_virt_orb
v = list_virt(i_v)
do i_a = 1, n_act_orb
a = list_act(i_a)
active_int(i_a,1) = get_mo_bielec_integral(i,j,v,a,mo_integrals_map) ! direct
active_int(i_a,2) = get_mo_bielec_integral(i,j,a,v,mo_integrals_map) ! exchange
do istate = 1, N_states
do jspin=1, 2
! delta_e(i_a,jspin,istate) =
!
delta_e(i_a,jspin,istate) = one_creat(i_a,jspin,istate) - fock_virt_total_spin_trace(v,istate) &
+ fock_core_inactive_total_spin_trace(i,istate) &
+ fock_core_inactive_total_spin_trace(j,istate)
delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate)
enddo
enddo
enddo
do i_a = 1, n_act_orb
a = list_act(i_a)
do i_b = 1, n_act_orb
! do i_b = i_a, i_a
b = list_act(i_b)
do ispin = 1, 2 ! spin of (i --> v)
do jspin = 1, 2 ! spin of (j --> a)
if(ispin == jspin .and. i.le.j)cycle ! condition not to double count
do istate = 1, N_states
if(ispin == jspin)then
accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) &
* (active_int(i_b,1) - active_int(i_b,2)) &
* delta_e(i_a,jspin,istate)
else
accu(istate) += active_int(i_a,1) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) &
* active_int(i_b,1)
endif
enddo
enddo
enddo
enddo
enddo
enddo
enddo
enddo
end
!subroutine contrib_2p_dm_based(accu)
!implicit none
!integer :: i_r,i_v,i_a,i_b,i_c,i_d
!integer :: r,v,a,b,c,d
!integer :: ispin,jspin
!integer :: istate
!double precision, intent(out) :: accu(N_states)
!double precision :: active_int(n_act_orb,n_act_orb,2)
!double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states)
!double precision :: get_mo_bielec_integral
!accu = 0.d0
!do i_r = 1, n_virt_orb
! r = list_virt(i_r)
! do i_v = 1, n_virt_orb
! v = list_virt(i_v)
! do i_a = 1, n_act_orb
! a = list_act(i_a)
! do i_b = 1, n_act_orb
! b = list_act(i_b)
! active_int(i_a,i_b,1) = get_mo_bielec_integral(a,b,r,v,mo_integrals_map) ! direct
! active_int(i_a,i_b,2) = get_mo_bielec_integral(a,b,v,r,mo_integrals_map) ! direct
! do istate = 1, N_states
! do jspin=1, 2 ! spin of i_a
! do ispin = 1, 2 ! spin of i_b
! delta_e(i_a,i_b,jspin,ispin,istate) = two_anhil(i_a,i_b,jspin,ispin,istate) &
! - fock_virt_total_spin_trace(r,istate) &
! - fock_virt_total_spin_trace(v,istate)
! delta_e(i_a,i_b,jspin,ispin,istate) = 1.d0/delta_e(i_a,i_b,jspin,ispin,istate)
! enddo
! enddo
! enddo
! enddo
! enddo
! ! diagonal terms
! do i_a = 1, n_act_orb
! a = list_act(i_a)
! do i_b = 1, n_act_orb
! b = list_act(i_b)
! do ispin = 1, 2 ! spin of (a --> r)
! do jspin = 1, 2 ! spin of (b --> v)
! if(ispin == jspin .and. r.le.v)cycle ! condition not to double count
! if(ispin == jspin .and. a.le.b)cycle ! condition not to double count
! do istate = 1, N_states
! if(ispin == jspin)then
! double precision :: contrib_spin
! if(ispin == 1)then
! contrib_spin = two_body_dm_aa_diag_act(i_a,i_b)
! else
! contrib_spin = two_body_dm_bb_diag_act(i_a,i_b)
! endif
! accu(istate) += (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) * contrib_spin &
! * (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) &
! * delta_e(i_a,i_b,ispin,jspin,istate)
! else
! accu(istate) += 0.5d0 * active_int(i_a,i_b,1) * two_body_dm_ab_diag_act(i_a,i_b) * delta_e(i_a,i_b,ispin,jspin,istate) &
! * active_int(i_a,i_b,1)
! endif
! enddo
! enddo
! enddo
! enddo
! enddo
! enddo
! enddo
!end

1109
src/mrpt_utils/energies_cas.irp.f
View File

File diff suppressed because it is too large Load Diff

708
src/mrpt_utils/excitations_cas.irp.f
View File

@ -1,708 +0,0 @@
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(bit_kind) :: 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
src/mrpt_utils/fock_like_operators.irp.f
View File

@ -1,210 +0,0 @@
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

35
src/mrpt_utils/give_2h2p.irp.f
View File

@ -1,35 +0,0 @@
subroutine give_2h2p(contrib_2h2p)
implicit none
double precision, intent(out) :: contrib_2h2p(N_states)
integer :: i,j,k,l,m
integer :: iorb,jorb,korb,lorb
double precision :: get_mo_bielec_integral
double precision :: direct_int,exchange_int
double precision :: numerator,denominator(N_states)
contrib_2h2p = 0.d0
do i = 1, n_inact_orb
iorb = list_inact(i)
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_virt_orb
korb = list_virt(k)
do l = 1, n_virt_orb
lorb = list_virt(l)
direct_int = get_mo_bielec_integral(iorb,jorb,korb,lorb ,mo_integrals_map)
exchange_int = get_mo_bielec_integral(iorb,jorb,lorb,korb ,mo_integrals_map)
numerator = 3.d0 * direct_int*direct_int + exchange_int*exchange_int -2.d0 * exchange_int * direct_int
do m = 1, N_states
denominator(m) = fock_core_inactive_total_spin_trace(iorb,m) + fock_core_inactive_total_spin_trace(jorb,m) &
-fock_virt_total_spin_trace(korb,m) - fock_virt_total_spin_trace(lorb,m)
contrib_2h2p(m) += numerator / denominator(m)
enddo
enddo
enddo
enddo
enddo
contrib_2h2p = contrib_2h2p*0.5d0
end

187
src/mrpt_utils/h_apply.irp.f
View File

@ -1,187 +0,0 @@
use bitmasks
BEGIN_SHELL [ /usr/bin/env python2 ]
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

187
src/mrpt_utils/mrpt_dress.irp.f
View File

@ -1,187 +0,0 @@
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_ref, 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_ref(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_ref(1,1,index_i),tq(1,1,i_alpha),delta_e)
! call get_delta_e_dyall_general_mp(psi_ref(1,1,index_i),tq(1,1,i_alpha),delta_e)
hij_array(index_i) = hialpha
call get_excitation(psi_ref(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_ref(1,1,index_i),psi_ref(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_ref(1,1,index_i),N_int)
! call debug_det(psi_ref(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_ref_sorted, (N_int,2,N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_ref_shortcut, (0:N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_ref_version, (N_int, N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_ref_idx, (N_det_generators,2) ]
gen_det_ref_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators)
gen_det_ref_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators)
call sort_dets_ab_v(gen_det_ref_sorted(:,:,:,1), gen_det_ref_idx(:,1), gen_det_ref_shortcut(0:,1), gen_det_ref_version(:,:,1), N_det_generators, N_int)
call sort_dets_ba_v(gen_det_ref_sorted(:,:,:,2), gen_det_ref_idx(:,2), gen_det_ref_shortcut(0:,2), gen_det_ref_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

365
src/mrpt_utils/mrpt_utils.irp.f
View File

@ -1,365 +0,0 @@
BEGIN_PROVIDER [ double precision, delta_ij_mrpt, (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_local(:,:,:)
delta_ij_mrpt = 0.d0
allocate (delta_ij_local(N_det,N_det,N_states))
! 1h
delta_ij_local = 0.d0
call H_apply_mrpt_1h(delta_ij_local,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_local(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij_mrpt(j,i,i_state) += delta_ij_local(j,i,i_state)
enddo
enddo
second_order_pt_new_1h(i_state) = accu(i_state)
enddo
print*, '1h = ',accu
! 1p
delta_ij_local = 0.d0
call H_apply_mrpt_1p(delta_ij_local,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_local(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij_mrpt(j,i,i_state) += delta_ij_local(j,i,i_state)
enddo
enddo
second_order_pt_new_1p(i_state) = accu(i_state)
enddo
print*, '1p = ',accu
! 1h1p
delta_ij_local = 0.d0
call H_apply_mrpt_1h1p(delta_ij_local,N_det)
double precision :: e_corr_from_1h1p_singles(N_states)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_local(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij_mrpt(j,i,i_state) += delta_ij_local(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_local = 0.d0
call give_1h1p_sec_order_singles_contrib(delta_ij_local)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_local(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij_mrpt(j,i,i_state) += delta_ij_local(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_local = 0.d0
call H_apply_mrpt_2h(delta_ij_local,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_local(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij_mrpt(j,i,i_state) += delta_ij_local(j,i,i_state)
enddo
enddo
second_order_pt_new_2h(i_state) = accu(i_state)
enddo
print*, '2h = ',accu
! 2p
delta_ij_local = 0.d0
call H_apply_mrpt_2p(delta_ij_local,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_local(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij_mrpt(j,i,i_state) += delta_ij_local(j,i,i_state)
enddo
enddo
second_order_pt_new_2p(i_state) = accu(i_state)
enddo
print*, '2p = ',accu
! 1h2p
delta_ij_local = 0.d0
call give_1h2p_contrib(delta_ij_local)
call H_apply_mrpt_1h2p(delta_ij_local,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_local(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij_mrpt(j,i,i_state) += delta_ij_local(j,i,i_state)
enddo
enddo
second_order_pt_new_1h2p(i_state) = accu(i_state)
enddo
print*, '1h2p = ',accu
! 2h1p
delta_ij_local = 0.d0
call give_2h1p_contrib(delta_ij_local)
call H_apply_mrpt_2h1p(delta_ij_local,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_local(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij_mrpt(j,i,i_state) += delta_ij_local(j,i,i_state)
enddo
enddo
second_order_pt_new_2h1p(i_state) = accu(i_state)
enddo
print*, '2h1p = ',accu
! 2h2p
!delta_ij_local = 0.d0
!call H_apply_mrpt_2h2p(delta_ij_local,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_local(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
! delta_ij_mrpt(j,i,i_state) += delta_ij_local(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_mrpt(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_mrpt(i,:,:)
do j = i_state, N_det
accu(i_state) += delta_ij_mrpt(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_mrpt(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_mrpt(j,i,i_state) + delta_ij_mrpt(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) ]
&BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states) ]
&BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states) ]
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" states of the CI_dressed_pt2_new_eigenvectors
do j=1,min(N_states,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
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),size(H_matrix_all_dets,1),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.
call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_ref,N_int,&
N_det,size(eigenvectors,1))
do j=1,N_det
! Select at least n_states states with S^2 values closed to "expected_s2"
if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)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)then
exit
endif
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_eigvalues(i_state+i_other_state)
enddo
else
print*,''
print*,'!!!!!!!! WARNING !!!!!!!!!'
print*,' Within the ',N_det,'determinants selected'
print*,' and the ',N_states,'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 s2_eig to be .True. or just enlarge the CI space'
print*,''
do j=1,min(N_states,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(index_good_state_array,good_state_array)
deallocate(s2_eigvalues)
else
call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2,eigenvectors,N_det,psi_ref,N_int,&
min(N_det,N_states),size(eigenvectors,1))
! Select the "N_states" states of lowest energy
do j=1,min(N_det,N_states)
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)
enddo
endif
deallocate(eigenvectors,eigenvalues)
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states) ]
implicit none
BEGIN_DOC
! N_states lowest eigenvalues of the CI matrix
END_DOC
integer :: j
character*(8) :: st
call write_time(6)
do j=1,N_states
CI_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion
write(st,'(I4)') j
call write_double(6,CI_dressed_pt2_new_energy(j),'Energy of state '//trim(st))
call write_double(6,CI_dressed_pt2_new_eigenvectors_s2(j),'S^2 of state '//trim(st))
enddo
END_PROVIDER

958
src/mrpt_utils/new_way.irp.f
View File

@ -1,958 +0,0 @@
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_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(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_ref,psi_ref(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_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(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_ref(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_ref(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_ref(1,1,idet),psi_ref(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_ref(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_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(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_ref,psi_ref(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_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(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_ref(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_ref(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_ref(1,1,idet),psi_ref(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_ref(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_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(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_ref,psi_ref(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_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(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_ref(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_ref(1,1,idet),psi_ref(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_ref(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_ref(1,1,idx(jdet)),N_int)
call debug_det(det_tmp,N_int)
stop
endif
call get_double_excitation(psi_ref(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_ref(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_ref(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_ref(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_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(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_ref,psi_ref(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_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(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_ref(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_ref(1,1,idet),psi_ref(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_ref(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_ref(1,1,idx(jdet)),N_int)
call debug_det(det_tmp,N_int)
stop
endif
call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
double precision :: hij_test
hij_test = 0.d0
call i_H_j(psi_ref(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_ref(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_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(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_ref,psi_ref(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_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(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_ref(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_ref(1,1,jdet),N_int,himono)
call get_delta_e_dyall(psi_ref(1,1,jdet),det_tmp,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_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(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_ref,psi_ref(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_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(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_ref(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_ref(1,1,idet),psi_ref(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_ref(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1)
call i_H_j(psi_ref(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
src/mrpt_utils/new_way_second_order_coef.irp.f
View File

@ -1,796 +0,0 @@
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_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(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_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
! if(idet == 81)then
! call get_excitation_degree_vector_mono_or_exchange_verbose(psi_ref(1,1,1),psi_ref(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_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(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_ref(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_ref(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_ref(1,1,idet),psi_ref(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_ref(1,1,idet),psi_ref(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_ref(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(hab /= hab)then ! check NaN
print*, '1'
stop
endif
! < jdet | H | det_tmp_bis > = phase * (ir|cv)
call get_double_excitation(det_tmp_bis,psi_ref(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_ref(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(hab /= hab)then ! check NaN
print*, '2'
stop
endif
! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) )
call get_double_excitation(det_tmp_bis,psi_ref(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_ref(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_ref(1,1,idet),psi_ref(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_ref(1,1,idet),N_int)
call debug_det(psi_ref(1,1,idx(jdet)),N_int)
print*, idet,idx(jdet)
print*, 'pb !!!!!!!!!!!!!'
call get_excitation_degree_vector_mono_or_exchange_verbose(psi_ref(1,1,1),psi_ref(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_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(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_ref,psi_ref(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_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(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_ref(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_ref(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_ref(1,1,idet),psi_ref(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_ref(1,1,idet),psi_ref(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_ref(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_ref(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_ref(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_ref(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_ref(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_ref(1,1,idet),N_int)
call debug_det(psi_ref(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_ref(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_ref(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_ref(1,1,idet),N_int)
call debug_det(psi_ref(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_ref(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

579
src/mrpt_utils/psi_active_prov.irp.f
View File

@ -1,579 +0,0 @@
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_ref(j,1,i),cas_bitmask(j,1,1))
psi_active(j,2,i) = iand(psi_ref(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,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)
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 get_excitation_degree(det_1,det_2,degree,N_int)
if(degree>2)then
delta_e_final = -1.d+10
return
endif
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)
do i_state = 1, N_states
delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state)
enddo
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)
do i_state = 1, N_states
delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state)
enddo
else if (n_holes_act == 1 .and. n_particles_act == 1) then
! 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
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
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
! 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
! 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
! 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
! 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
!write(*,'(100(f16.10,X))'), delta_e_final(1) , delta_e_act(1) , delta_e_inactive(1) , delta_e_virt(1)
end
subroutine get_delta_e_dyall_general_mp(det_1,det_2,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 as the sum of energies of excitations a la MP
!
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)
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 ! spin
hole_list_practical(2,icountbis) = holes_active_list(i,1) ! index of active orb
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
do i = 1, n_holes_act
ispin = hole_list_practical(1,i)
i_hole_act = hole_list_practical(2,i)
do i_state = 1, N_states
delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state)
enddo
enddo
do i = 1, n_particles_act
ispin = particle_list_practical(1,i)
i_particle_act = particle_list_practical(2,i)
do i_state = 1, N_states
delta_e_act(i_state) += one_creat(i_particle_act, ispin,i_state)
enddo
enddo
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
src/mrpt_utils/second_order_new.irp.f
View File

@ -1,757 +0,0 @@
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_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(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_ref,psi_ref(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_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(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_ref(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_ref(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_ref(1,1,idet),psi_ref(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_ref(1,1,idet),psi_ref(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_ref(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_ref(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_ref(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_ref(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_ref(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_ref(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_ref(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_ref(1,1,i),N_int)
call debug_det(psi_ref(1,1,idx(jdet)),N_int)
call get_double_excitation(psi_ref(1,1,idet),psi_ref(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_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(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_ref,psi_ref(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_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(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_ref(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_ref(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_ref(1,1,idet),psi_ref(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_ref(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_ref(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
src/mrpt_utils/second_order_new_2p.irp.f
View File

@ -1,283 +0,0 @@
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_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(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_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
call get_excitation_degree_vector(psi_ref,psi_ref(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_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(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_ref(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_ref(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_ref(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_ref(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_ref(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_ref(1,1,idet),psi_ref(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_ref(1,1,idet),psi_ref(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_ref(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

27
src/mrpt_utils/set_as_holes_and_particles.irp.f
View File

@ -1,27 +0,0 @@
subroutine set_generators_bitmasks_as_holes_and_particles
implicit none
integer :: i,k
do k = 1, N_generators_bitmask
do i = 1, N_int
! Pure single part
generators_bitmask(i,1,1,k) = holes_operators(i,1) ! holes for pure single exc alpha
generators_bitmask(i,1,2,k) = particles_operators(i,1) ! particles for pure single exc alpha
generators_bitmask(i,2,1,k) = holes_operators(i,2) ! holes for pure single exc beta
generators_bitmask(i,2,2,k) = particles_operators(i,2) ! particles for pure single exc beta
! Double excitation
generators_bitmask(i,1,3,k) = holes_operators(i,1) ! holes for first single exc alpha
generators_bitmask(i,1,4,k) = particles_operators(i,1) ! particles for first single exc alpha
generators_bitmask(i,2,3,k) = holes_operators(i,2) ! holes for first single exc beta
generators_bitmask(i,2,4,k) = particles_operators(i,2) ! particles for first single exc beta
generators_bitmask(i,1,5,k) = holes_operators(i,1) ! holes for second single exc alpha
generators_bitmask(i,1,6,k) = particles_operators(i,1) ! particles for second single exc alpha
generators_bitmask(i,2,5,k) = holes_operators(i,2) ! holes for second single exc beta
generators_bitmask(i,2,6,k) = particles_operators(i,2) ! particles for second single exc beta
enddo
enddo
touch generators_bitmask
end

36
src/mrpt_utils/utils_bitmask.irp.f
View File

@ -1,36 +0,0 @@
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

1
src/perturbation/NEED
View File

@ -1,4 +1,3 @@
determinants
hartree_fock
davidson
mrpt_utils

71
src/perturbation/pt2_new.irp.f
View File

@ -1,71 +0,0 @@
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)
double precision :: coef_array(Nstate)
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
do i = 1, Nstate
coef_array(i) = coef(i_in_coef,i)
enddo
call get_delta_e_dyall(keys(1,1,i_in_key),key,coef_array,hij,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

4
src/scf_utils/README.rst
View File

@ -4,11 +4,11 @@ scf_utils
The scf_utils module performs *Restricted* SCF calculations (the
The scf_utils module is an abstract module which contains the basics to perform *Restricted* SCF calculations (the
spatial part of the |MOs| is common for alpha and beta spinorbitals) based on a single-determinant wave function.
This module does not produce any executable *and must not do*, but instead it contains everything one needs to perform an orbital optimization based on an Fock matrix.
The ``scf_utils`` module is included in the :file:`NEED` of the various single determinant SCF procedures, such as ``hartree_fock`` or ``kohn_sham``, where a specific definition of the Fock matrix is given (see :file:`hartree_fock fock_matrix_hf.irp.f` for an example).
The ``scf_utils`` module is meant to be included in the :file:`NEED` of the various single determinant SCF procedures, such as ``hartree_fock`` or ``kohn_sham``, where a specific definition of the Fock matrix is given (see :file:`hartree_fock fock_matrix_hf.irp.f` for an example).
All SCF programs perform the following actions: