LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2025-01-03 10:05:57 +01:00
Code Issues Releases Wiki Activity

Bugs to fix (#50)

Browse Source 
* Add config for knl

* Add mising readme

* Add .gitignore

* Add pseudo to qp_convert

* Working pseudo

* Dressed matrix for pt2 works for one state

* now eigenfunction of S^2

* minor modifs in printing

* Fixed the perturbation with psi_ref instead of psi_det

* Trying do really fo sin free multiple excitations

* Beginning to merge MRCC and MRPT

* final version of MRPT, at least I hope

* Fix 404: Update Zlib Url.

* Delete ifort_knl.cfg

* Update module_handler.py

* Update pot_ao_pseudo_ints.irp.f

* Update map_module.f90

* Restaure map_module.f90

* Update configure

* Update configure

* Update sort.irp.f

* Update sort.irp.f

* Update selection.irp.f

* Update selection.irp.f

* Update dressing.irp.f

* TApplencourt IRPF90 -> LCPQ

* Remove `irpf90.make` in dependency

* Update configure

* Missing PROVIDE

* Missing PROVIDE

* Missing PROVIDE

* Missing PROVIDE

* Update configure

* pouet

* density based mrpt2

* debugging FOBOCI

* Added SCF_density

* New version of FOBOCI

* added density.irp.f

* minor changes in plugins/FOBOCI/SC2_1h1p.irp.f

* added track_orb.irp.f

* minor changes

* minor modifs in FOBOCI

* med

* Minor changes

* minor changes

* strange things in MRPT

* minor modifs

mend

* Fix #185 (Graphviz API / Python 2.6)

* beginning to debug dft

* fixed the factor 2 in lebedev

* DFT integration works for non overlapping densities

* DFT begins to work with lda

* KS LDA is okay

* added core integrals

* mend

* Beginning logn range integrals

* Trying to handle two sets of integrals

* beginning to clean erf integrals

* Handling of two different mo and ao integrals map
This commit is contained in:
Anthony Scemama 2017-04-20 08:36:11 +02:00 committed by GitHub
parent a9414b4a64
commit 94f01c0892
144 changed files with 15878 additions and 1412 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
config/gfortran.cfg
View File

@ -35,14 +35,14 @@ OPENMP : 1 ; Append OpenMP flags
# -ffast-math and the Fortran-specific
# -fno-protect-parens and -fstack-arrays.
[OPT]
FCFLAGS : -Ofast
FCFLAGS :
# Profiling flags
#################
#
[PROFILE]
FC : -p -g
FCFLAGS : -Ofast
FCFLAGS :
# Debugging flags
#################

2
config/ifort.cfg
View File

@ -58,6 +58,6 @@ FCFLAGS : -xSSE2 -C -fpe0
#################
#
[OPENMP]
FC : -qopenmp
FC : -openmp
IRPF90_FLAGS : --openmp

5
plugins/All_singles/.gitignore vendored Normal file
View File

@ -0,0 +1,5 @@
IRPF90_temp/
IRPF90_man/
irpf90.make
irpf90_entities
tags

1
plugins/CAS_SD_ZMQ/selection.irp.f
View File

@ -1332,3 +1332,4 @@ subroutine selection_collector(b, pt2)
call sort_selection_buffer(b)
end subroutine

2
plugins/DDCI_selected/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Perturbation Selectors_full Generators_CAS Davidson
Perturbation Selectors_full Generators_CAS Davidson Psiref_CAS

2
plugins/DDCI_selected/ddci.irp.f
View File

@ -5,7 +5,7 @@ program ddci
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:)
integer :: N_st, degree
N_st = N_states_diag
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
character*(64) :: perturbation

4
plugins/DFT_Utils/EZFIO.cfg
View File

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

6951
plugins/DFT_Utils/angular.f Normal file
View File

File diff suppressed because it is too large Load Diff

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

@ -0,0 +1,54 @@
subroutine ex_lda(rho_a,rho_b,ex,vx_a,vx_b)
include 'constants.include.F'
implicit none
double precision, intent(in) :: rho_a,rho_b
double precision, intent(out) :: ex,vx_a,vx_b
double precision :: tmp_a,tmp_b
tmp_a = rho_a**(c_1_3)
tmp_b = rho_b**(c_1_3)
ex = cst_lda * (tmp_a*tmp_a*tmp_a*tmp_a + tmp_b*tmp_b*tmp_b*tmp_b)
vx_a = cst_lda * c_4_3 * tmp_a
vx_b = cst_lda * c_4_3 * tmp_b
end
BEGIN_PROVIDER [double precision, lda_exchange, (N_states)]
&BEGIN_PROVIDER [double precision, lda_ex_potential_alpha_ao,(ao_num_align,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, lda_ex_potential_beta_ao,(ao_num_align,ao_num,N_states)]
implicit none
integer :: i,j,k,l
integer :: m,n
double precision :: aos_array(ao_num)
double precision :: r(3)
lda_ex_potential_alpha_ao = 0.d0
lda_ex_potential_beta_ao = 0.d0
do l = 1, N_states
lda_exchange(l) = 0.d0
do j = 1, nucl_num
do i = 1, n_points_radial_grid
do k = 1, n_points_integration_angular
double precision :: rho_a,rho_b,ex
double precision :: vx_a,vx_b
rho_a = one_body_dm_mo_alpha_at_grid_points(k,i,j,l)
rho_b = one_body_dm_mo_beta_at_grid_points(k,i,j,l)
call ex_lda(rho_a,rho_b,ex,vx_a,vx_b)
lda_exchange(l) += final_weight_functions_at_grid_points(k,i,j) * ex
r(1) = grid_points_per_atom(1,k,i,j)
r(2) = grid_points_per_atom(2,k,i,j)
r(3) = grid_points_per_atom(3,k,i,j)
call give_all_aos_at_r(r,aos_array)
do m = 1, ao_num
! lda_ex_potential_ao(m,m,l) += (vx_a + vx_b) * aos_array(m)*aos_array(m)
do n = 1, ao_num
lda_ex_potential_alpha_ao(m,n,l) += (vx_a ) * aos_array(m)*aos_array(n) * final_weight_functions_at_grid_points(k,i,j)
lda_ex_potential_beta_ao(m,n,l) += (vx_b) * aos_array(m)*aos_array(n) * final_weight_functions_at_grid_points(k,i,j)
enddo
enddo
enddo
enddo
enddo
enddo
END_PROVIDER

115
plugins/DFT_Utils/grid_density.irp.f
View File

@ -1,42 +1,60 @@
BEGIN_PROVIDER [integer, n_points_angular_grid]
BEGIN_PROVIDER [integer, n_points_integration_angular]
implicit none
n_points_angular_grid = 50
n_points_integration_angular = 110
END_PROVIDER
BEGIN_PROVIDER [integer, n_points_radial_grid]
implicit none
n_points_radial_grid = 10000
n_points_radial_grid = 100
END_PROVIDER
BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_angular_grid,3) ]
&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_angular_grid)]
BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_integration_angular,3) ]
&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_integration_angular)]
implicit none
BEGIN_DOC
! weights and grid points for the integration on the angular variables on
! the unit sphere centered on (0,0,0)
! According to the LEBEDEV scheme
END_DOC
call cal_quad(n_points_angular_grid, angular_quadrature_points,weights_angular_points)
angular_quadrature_points = 0.d0
weights_angular_points = 0.d0
!call cal_quad(n_points_integration_angular, angular_quadrature_points,weights_angular_points)
include 'constants.include.F'
integer :: i
integer :: i,n
double precision :: accu
double precision :: degre_rad
!degre_rad = 180.d0/pi
!accu = 0.d0
!do i = 1, n_points_integration_angular_lebedev
degre_rad = pi/180.d0
accu = 0.d0
double precision :: x(n_points_integration_angular),y(n_points_integration_angular),z(n_points_integration_angular),w(n_points_integration_angular)
call LD0110(X,Y,Z,W,N)
do i = 1, n_points_integration_angular
angular_quadrature_points(i,1) = x(i)
angular_quadrature_points(i,2) = y(i)
angular_quadrature_points(i,3) = z(i)
weights_angular_points(i) = w(i) * 4.d0 * pi
accu += w(i)
enddo
!do i = 1, n_points_integration_angular
! accu += weights_angular_integration_lebedev(i)
! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 2.d0 * pi
! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 4.d0 * pi
! angular_quadrature_points(i,1) = dcos ( degre_rad * theta_angular_integration_lebedev(i)) &
! * dsin ( degre_rad * phi_angular_integration_lebedev(i))
! angular_quadrature_points(i,2) = dsin ( degre_rad * theta_angular_integration_lebedev(i)) &
! * dsin ( degre_rad * phi_angular_integration_lebedev(i))
! angular_quadrature_points(i,3) = dcos ( degre_rad * phi_angular_integration_lebedev(i))
!!weights_angular_points(i) = weights_angular_integration_lebedev(i)
!!angular_quadrature_points(i,1) = dcos ( degre_rad * phi_angular_integration_lebedev(i)) &
!! * dsin ( degre_rad * theta_angular_integration_lebedev(i))
!!angular_quadrature_points(i,2) = dsin ( degre_rad * phi_angular_integration_lebedev(i)) &
!! * dsin ( degre_rad * theta_angular_integration_lebedev(i))
!!angular_quadrature_points(i,3) = dcos ( degre_rad * theta_angular_integration_lebedev(i))
!enddo
!print*,'ANGULAR'
!print*,''
!print*,'accu = ',accu
!ASSERT( dabs(accu - 1.D0) < 1.d-10)
print*,'ANGULAR'
print*,''
print*,'accu = ',accu
ASSERT( dabs(accu - 1.D0) < 1.d-10)
END_PROVIDER
@ -63,7 +81,7 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid,n_points_radial_grid,nucl_num)]
BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)]
BEGIN_DOC
! points for integration over space
END_DOC
@ -79,7 +97,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid
double precision :: x,r
x = grid_points_radial(j) ! x value for the mapping of the [0, +\infty] to [0,1]
r = knowles_function(alpha_knowles(int(nucl_charge(i))),m_knowles,x) ! value of the radial coordinate for the integration
do k = 1, n_points_angular_grid ! explicit values of the grid points centered around each atom
do k = 1, n_points_integration_angular ! explicit values of the grid points centered around each atom
grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r
grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r
grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r
@ -88,7 +106,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (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)
! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension
@ -102,7 +120,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_ang
! run over all points in space
do j = 1, nucl_num ! that are referred to each atom
do k = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom
do l = 1, n_points_angular_grid ! for each angular point attached to the "jth" atom
do l = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
r(1) = grid_points_per_atom(1,l,k,j)
r(2) = grid_points_per_atom(2,l,k,j)
r(3) = grid_points_per_atom(3,l,k,j)
@ -115,7 +133,6 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_ang
enddo
accu = 1.d0/accu
weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu
! print*,weight_functions_at_grid_points(l,k,j)
enddo
enddo
enddo
@ -123,43 +140,65 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_ang
END_PROVIDER
BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
BEGIN_PROVIDER [double precision, final_weight_functions_at_grid_points, (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)
! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension
! and the points are labelled by the other dimensions
END_DOC
implicit none
integer :: i,j,k,l,m
double precision :: r(3)
double precision :: accu,cell_function_becke
double precision :: tmp_array(nucl_num)
double precision :: contrib_integration,x
double precision :: derivative_knowles_function,knowles_function
! run over all points in space
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom
x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
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
enddo
enddo
enddo
END_PROVIDER
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) ]
implicit none
integer :: i,j,k,l,m,i_state
double precision :: contrib
double precision :: r(3)
double precision :: aos_array(ao_num),mos_array(mo_tot_num)
do i_state = 1, N_states
do j = 1, nucl_num
do k = 1, n_points_radial_grid -1
do l = 1, n_points_angular_grid
one_body_dm_mo_alpha_at_grid_points(l,k,j) = 0.d0
one_body_dm_mo_beta_at_grid_points(l,k,j) = 0.d0
do k = 1, n_points_radial_grid
do l = 1, n_points_integration_angular
one_body_dm_mo_alpha_at_grid_points(l,k,j,i_state) = 0.d0
one_body_dm_mo_beta_at_grid_points(l,k,j,i_state) = 0.d0
r(1) = grid_points_per_atom(1,l,k,j)
r(2) = grid_points_per_atom(2,l,k,j)
r(3) = grid_points_per_atom(3,l,k,j)
! call give_all_aos_at_r(r,aos_array)
! do i = 1, ao_num
! do m = 1, ao_num
! contrib = aos_array(i) * aos_array(m)
! one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_ao_alpha(i,m) * contrib
! one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_ao_beta(i,m) * contrib
! enddo
! enddo
call give_all_mos_at_r(r,mos_array)
do i = 1, mo_tot_num
do m = 1, mo_tot_num
do i = 1, mo_tot_num
if(dabs(one_body_dm_mo_alpha(i,m,i_state)).lt.1.d-10)cycle
contrib = mos_array(i) * mos_array(m)
one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_mo_alpha(i,m) * contrib
one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_mo_beta(i,m) * contrib
one_body_dm_mo_alpha_at_grid_points(l,k,j,i_state) += one_body_dm_mo_alpha(i,m,i_state) * contrib
one_body_dm_mo_beta_at_grid_points(l,k,j,i_state) += one_body_dm_mo_beta(i,m,i_state) * contrib
enddo
enddo
enddo
enddo
enddo
enddo
END_PROVIDER

9
plugins/DFT_Utils/integration_3d.irp.f
View File

@ -4,18 +4,11 @@ double precision function step_function_becke(x)
double precision :: f_function_becke
integer :: i,n_max_becke
!if(x.lt.-1.d0)then
! step_function_becke = 0.d0
!else if (x .gt.1)then
! step_function_becke = 0.d0
!else
step_function_becke = f_function_becke(x)
!!n_max_becke = 1
do i = 1, 4
do i = 1,5
step_function_becke = f_function_becke(step_function_becke)
enddo
step_function_becke = 0.5d0*(1.d0 - step_function_becke)
!endif
end
double precision function f_function_becke(x)

11
plugins/DFT_Utils/integration_radial.irp.f
View File

@ -4,7 +4,7 @@
double precision :: accu
integer :: i,j,k,l
double precision :: x
double precision :: integrand(n_points_angular_grid), weights(n_points_angular_grid)
double precision :: 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
@ -12,7 +12,7 @@
! according ot equation (6) of the paper of Becke (JCP, (88), 1988)
! Here the m index is referred to the w_m(r) weight functions of equation (22)
! Run over all points of integrations : there are
! n_points_radial_grid (i) * n_points_angular_grid (k)
! 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
@ -20,14 +20,13 @@
! Angular integration over the solid angle Omega for a FIXED angular coordinate "r"
f_average_angular_alpha = 0.d0
f_average_angular_beta = 0.d0
do k = 1, n_points_angular_grid
f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j)
f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j)
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,1) * 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,1) * weight_functions_at_grid_points(k,i,j)
enddo
!
x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
double precision :: contrib_integration
! print*,m_knowles
contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) &
*knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2
integral_density_alpha_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_alpha

54
plugins/DFT_Utils/test_integration_3d_density.irp.f
View File

@ -4,13 +4,55 @@ program pouet
touch read_wf
print*,'m_knowles = ',m_knowles
call routine
call routine3
end
subroutine routine3
implicit none
integer :: i,j,k,l
double precision :: accu
accu = 0.d0
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom
do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
accu += final_weight_functions_at_grid_points(k,i,j) * one_body_dm_mo_alpha_at_grid_points(k,i,j,1)
enddo
enddo
enddo
print*, accu
print*, 'lda_exchange',lda_exchange
end
subroutine routine2
implicit none
integer :: i,j,k,l
double precision :: x,y,z
double precision :: r
double precision :: accu
accu = 0.d0
r = 1.d0
do k = 1, n_points_integration_angular
x = angular_quadrature_points(k,1) * r
y = angular_quadrature_points(k,2) * r
z = angular_quadrature_points(k,3) * r
accu += weights_angular_points(k) * (x**2 + y**2 + z**2)
enddo
print*, accu
end
subroutine routine
implicit none
integer :: i
double precision :: accu(2)
accu = 0.d0
do i = 1, N_det
call debug_det(psi_det(1,1,i),N_int)
enddo
do i = 1, nucl_num
accu(1) += integral_density_alpha_knowles_becke_per_atom(i)
accu(2) += integral_density_beta_knowles_becke_per_atom(i)
@ -20,5 +62,17 @@ subroutine routine
print*,'accu(2) = ',accu(2)
print*,'Nalpha = ',elec_beta_num
accu = 0.d0
do i = 1, mo_tot_num
accu(1) += one_body_dm_mo_alpha_average(i,i)
accu(2) += one_body_dm_mo_beta_average(i,i)
enddo
print*,' '
print*,' '
print*,'accu(1) = ',accu(1)
print*,'accu(2) = ',accu(2)
end

2
plugins/FCIdump/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Determinants Davidson
Determinants Davidson core_integrals

48
plugins/FCIdump/fcidump.irp.f
View File

@ -1,21 +1,25 @@
program fcidump
implicit none
character*(128) :: output
integer :: i_unit_output,getUnitAndOpen
output=trim(ezfio_filename)//'.FCIDUMP'
i_unit_output = getUnitAndOpen(output,'w')
integer :: i,j,k,l
integer :: ii(8), jj(8), kk(8),ll(8)
integer :: i1,j1,k1,l1
integer :: i2,j2,k2,l2
integer*8 :: m
character*(2), allocatable :: A(:)
print *, '&FCI NORB=', mo_tot_num, ', NELEC=', elec_num, &
write(i_unit_output,*) '&FCI NORB=', n_act_orb, ', NELEC=', elec_num-n_core_orb*2, &
', MS2=', (elec_alpha_num-elec_beta_num), ','
allocate (A(mo_tot_num))
allocate (A(n_act_orb))
A = '1,'
print *, 'ORBSYM=', (A(i), i=1,mo_tot_num)
print *,'ISYM=0,'
print *,'/'
write(i_unit_output,*) 'ORBSYM=', (A(i), i=1,n_act_orb)
write(i_unit_output,*) 'ISYM=0,'
write(i_unit_output,*) '/'
deallocate(A)
integer*8 :: i8, k1
integer(key_kind), allocatable :: keys(:)
double precision, allocatable :: values(:)
integer(cache_map_size_kind) :: n_elements, n_elements_max
@ -23,14 +27,18 @@ program fcidump
double precision :: get_mo_bielec_integral, integral
do l=1,mo_tot_num
do k=1,mo_tot_num
do j=l,mo_tot_num
do i=k,mo_tot_num
if (i>=j) then
integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
do l=1,n_act_orb
l1 = list_act(l)
do k=1,n_act_orb
k1 = list_act(k)
do j=l,n_act_orb
j1 = list_act(j)
do i=k,n_act_orb
i1 = list_act(i)
if (i1>=j1) then
integral = get_mo_bielec_integral(i1,j1,k1,l1,mo_integrals_map)
if (dabs(integral) > mo_integrals_threshold) then
print *, integral, i,k,j,l
write(i_unit_output,*) integral, i,k,j,l
endif
end if
enddo
@ -38,13 +46,15 @@ program fcidump
enddo
enddo
do j=1,mo_tot_num
do i=j,mo_tot_num
integral = mo_mono_elec_integral(i,j)
do j=1,n_act_orb
j1 = list_act(j)
do i=j,n_act_orb
i1 = list_act(i)
integral = mo_mono_elec_integral(i1,j1) + core_fock_operator(i1,j1)
if (dabs(integral) > mo_integrals_threshold) then
print *, integral, i,j,0,0
write(i_unit_output,*) integral, i,j,0,0
endif
enddo
enddo
print *, 0.d0, 0, 0, 0, 0
write(i_unit_output,*) core_energy, 0, 0, 0, 0
end

2
plugins/FOBOCI/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Perturbation Selectors_no_sorted Hartree_Fock Davidson CISD
Perturbation Selectors_no_sorted SCF_density Davidson CISD

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

@ -356,7 +356,7 @@ subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Ni
c_ref = 1.d0/u_in(index_hf,1)
do k = 1, n_singles
l = index_singles(k)
diag_H_elements(0) -= diag_H_elements(l)
diag_H_elements(1) -= diag_H_elements(l)
enddo
! do k = 1, n_doubles
! l = index_doubles(k)

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

@ -48,6 +48,7 @@ subroutine all_single(e_pt2)
print*,'-----------------------'
print*,'i = ',i
call H_apply_just_mono(pt2, norm_pert, H_pert_diag, N_st)
call make_s2_eigenfunction_first_order
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)

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

@ -30,20 +30,12 @@ subroutine create_restart_and_1h(i_hole)
enddo
enddo
integer :: N_det_old
N_det_old = N_det
N_det += n_new_det
allocate (new_det(N_int,2,n_new_det))
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, N_det_old
do k = 1, N_int
psi_det(k,1,i) = old_psi_det(k,1,i)
psi_det(k,2,i) = old_psi_det(k,2,i)
enddo
enddo
logical, allocatable :: duplicate(:)
allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det))
n_new_det = 0
do j = 1, n_act_orb
@ -58,19 +50,56 @@ subroutine create_restart_and_1h(i_hole)
if(i_ok .ne. 1)cycle
n_new_det +=1
do k = 1, N_int
psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1)
psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2)
new_det(k,1,n_new_det) = key_tmp(k,1)
new_det(k,2,n_new_det) = key_tmp(k,2)
enddo
psi_coef(n_det_old+n_new_det,:) = 0.d0
enddo
enddo
enddo
SOFT_TOUCH N_det psi_det psi_coef
logical :: found_duplicates
if(n_act_orb.gt.1)then
call remove_duplicates_in_psi_det(found_duplicates)
integer :: i_test
duplicate = .False.
do i = 1, n_new_det
if(duplicate(i))cycle
do j = i+1, n_new_det
i_test = 0
do ispin =1 ,2
do k = 1, N_int
i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j)))
enddo
enddo
if(i_test.eq.0)then
duplicate(j) = .True.
endif
enddo
enddo
integer :: n_new_det_unique
n_new_det_unique = 0
print*, 'uniq det'
do i = 1, n_new_det
if(.not.duplicate(i))then
n_new_det_unique += 1
endif
enddo
print*, n_new_det_unique
N_det += n_new_det_unique
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, n_new_det_unique
do ispin = 1, 2
do k = 1, N_int
psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i)
enddo
enddo
psi_coef(N_det_old+i,:) = 0.d0
enddo
SOFT_TOUCH N_det psi_det psi_coef
deallocate (new_det,duplicate)
end
subroutine create_restart_and_1p(i_particle)
@ -107,18 +136,8 @@ subroutine create_restart_and_1p(i_particle)
integer :: N_det_old
N_det_old = N_det
N_det += n_new_det
allocate (new_det(N_int,2,n_new_det))
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, N_det_old
do k = 1, N_int
psi_det(k,1,i) = old_psi_det(k,1,i)
psi_det(k,2,i) = old_psi_det(k,2,i)
enddo
enddo
logical, allocatable :: duplicate(:)
allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det))
n_new_det = 0
do j = 1, n_act_orb
@ -133,17 +152,59 @@ subroutine create_restart_and_1p(i_particle)
if(i_ok .ne. 1)cycle
n_new_det +=1
do k = 1, N_int
psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1)
psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2)
new_det(k,1,n_new_det) = key_tmp(k,1)
new_Det(k,2,n_new_det) = key_tmp(k,2)
enddo
psi_coef(n_det_old+n_new_det,:) = 0.d0
enddo
enddo
enddo
integer :: i_test
duplicate = .False.
do i = 1, n_new_det
if(duplicate(i))cycle
call debug_det(new_det(1,1,i),N_int)
do j = i+1, n_new_det
i_test = 0
call debug_det(new_det(1,1,j),N_int)
do ispin =1 ,2
do k = 1, N_int
i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j)))
enddo
enddo
if(i_test.eq.0)then
duplicate(j) = .True.
endif
enddo
enddo
integer :: n_new_det_unique
n_new_det_unique = 0
print*, 'uniq det'
do i = 1, n_new_det
if(.not.duplicate(i))then
n_new_det_unique += 1
endif
enddo
print*, n_new_det_unique
N_det += n_new_det_unique
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, n_new_det_unique
do ispin = 1, 2
do k = 1, N_int
psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i)
enddo
enddo
psi_coef(N_det_old+i,:) = 0.d0
enddo
SOFT_TOUCH N_det psi_det psi_coef
logical :: found_duplicates
call remove_duplicates_in_psi_det(found_duplicates)
deallocate (new_det,duplicate)
end
subroutine create_restart_1h_1p(i_hole,i_part)

16
plugins/FOBOCI/density.irp.f Normal file
View File

@ -0,0 +1,16 @@
BEGIN_PROVIDER [double precision, mo_general_density_alpha, (mo_tot_num_align,mo_tot_num)]
implicit none
integer :: i,j,k,l
mo_general_density_alpha = one_body_dm_mo_alpha_generators_restart
END_PROVIDER
BEGIN_PROVIDER [double precision, mo_general_density_beta, (mo_tot_num_align,mo_tot_num)]
implicit none
integer :: i,j,k,l
mo_general_density_beta = one_body_dm_mo_beta_generators_restart
END_PROVIDER

32
plugins/FOBOCI/density_matrix.irp.f
View File

@ -1,12 +1,12 @@
BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_generators_restart, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_generators_restart, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, norm_generators_restart]
&BEGIN_PROVIDER [ double precision, norm_generators_restart, (N_states)]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix for the generators restart
END_DOC
integer :: j,k,l,m
integer :: j,k,l,m,istate
integer :: occ(N_int*bit_kind_size,2)
double precision :: ck, cl, ckl
double precision :: phase
@ -14,23 +14,37 @@
integer :: exc(0:2,2,2),n_occ_alpha
double precision, allocatable :: tmp_a(:,:), tmp_b(:,:)
integer :: degree_respect_to_HF_k
integer :: degree_respect_to_HF_l,index_ref_generators_restart
double precision :: inv_coef_ref_generators_restart
integer :: degree_respect_to_HF_l,index_ref_generators_restart(N_states)
double precision :: inv_coef_ref_generators_restart(N_states)
integer :: i
print*, 'providing the one_body_dm_mo_alpha_generators_restart'
do istate = 1, N_states
do i = 1, N_det_generators_restart
! Find the reference determinant for intermediate normalization
call get_excitation_degree(ref_generators_restart,psi_det_generators_restart(1,1,i),degree,N_int)
call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_restart(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart = i
inv_coef_ref_generators_restart = 1.d0/psi_coef_generators_restart(i,1)
index_ref_generators_restart(istate) = i
inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef_generators_restart(i,istate)
exit
endif
enddo
enddo
norm_generators_restart = 0.d0
do istate = 1, N_states
do i = 1, N_det_generators_restart
psi_coef_generators_restart(i,1) = psi_coef_generators_restart(i,1) * inv_coef_ref_generators_restart
norm_generators_restart += psi_coef_generators_restart(i,1)**2
psi_coef_generators_restart(i,istate) = psi_coef_generators_restart(i,istate) * inv_coef_ref_generators_restart(istate)
norm_generators_restart(istate) += psi_coef_generators_restart(i,istate)**2
enddo
enddo
double precision :: inv_norm(N_States)
do istate = 1, N_states
inv_norm(istate) = 1.d0/dsqrt(norm_generators_restart(istate))
enddo
do istate = 1, N_states
do i = 1, N_det_generators_restart
psi_coef_generators_restart(i,istate) = psi_coef_generators_restart(i,istate) * inv_norm(istate)
enddo
enddo

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

@ -107,7 +107,6 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per
!enddo
!soft_touch psi_selectors psi_selectors_coef
!if(do_it_perturbative)then
print*, 'is_ok_perturbative',is_ok_perturbative
if(is_ok.or.is_ok_perturbative)then
N_det = N_det_generators
do m = 1, N_states
@ -117,7 +116,6 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per
psi_det(l,2,k) = psi_det_generators_input(l,2,k)
enddo
psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
print*, 'psi_coef(k,m)',psi_coef(k,m)
enddo
enddo
soft_touch psi_det psi_coef N_det
@ -150,7 +148,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators)
integer :: i,j,degree,index_ref_generators_restart,i_count,k,i_det_no_ref
integer :: i,j,degree,index_ref_generators_restart(N_states),i_count,k,i_det_no_ref
double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij
double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average
logical :: is_a_ref_det(Ndet_generators)
@ -168,11 +166,17 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
enddo
integer :: istate
do istate = 1, N_states
do i = 1, Ndet_generators
call get_excitation_degree(ref_generators_restart,psi_det_generators_input(1,1,i),degree,N_int)
call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_input(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart = i
index_ref_generators_restart(istate) = i
exit
endif
enddo
enddo
do i = 1, Ndet_generators
do j = 1, Ndet_generators
call i_h_j(psi_det_generators_input(1,1,j),psi_det_generators_input(1,1,i),N_int,hij) ! Fill the zeroth order H matrix
dressed_H_matrix(i,j) = hij
@ -185,15 +189,21 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
i_det_no_ref +=1
diag_h_mat_average+=dressed_H_matrix(i,i)
enddo
double precision :: average_ref_h_mat
average_ref_h_mat = 0.d0
do istate = 1, N_states
average_ref_h_mat += dressed_H_matrix(index_ref_generators_restart(istate),index_ref_generators_restart(istate))
enddo
average_ref_h_mat = 1.d0/dble(N_states)
diag_h_mat_average = diag_h_mat_average/dble(i_det_no_ref)
print*,'diag_h_mat_average = ',diag_h_mat_average
print*,'ref h_mat = ',dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart)
print*,'ref h_mat average = ',average_ref_h_mat
integer :: number_of_particles, number_of_holes
! Filter the the MLCT that are higher than 27.2 eV in energy with respect to the reference determinant
do i = 1, Ndet_generators
if(is_a_ref_det(i))cycle
if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then
if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then
if(diag_h_mat_average - average_ref_h_mat .gt.2.d0)then
is_ok = .False.
exit_loop = .True.
return
@ -202,7 +212,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
! Filter the the LMCT that are higher than 54.4 eV in energy with respect to the reference determinant
if(number_of_holes(psi_det_generators_input(1,1,i)).eq.1 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.0)then
if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then
if(diag_h_mat_average - average_ref_h_mat .gt.1.d0)then
is_ok = .False.
return
endif
@ -210,7 +220,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
exit
enddo
call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix
call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the naked matrix
double precision :: s2(N_det_generators),E_ref(N_states)
integer :: i_state(N_states)
@ -236,15 +246,10 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
E_ref(i) = eigvalues(i)
enddo
endif
do i = 1,N_states
print*,'i_state = ',i_state(i)
enddo
do k = 1, N_states
print*,'state ',k
do i = 1, Ndet_generators
psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k))
psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k))
psi_coef_ref(i,k) = eigvectors(i,i_state(k))
print*,'psi_coef_ref(i) = ',psi_coef_ref(i,k)
enddo
enddo
if(verbose)then
@ -257,7 +262,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
do k = 1, N_states
print*,'state ',k
do i = 1, Ndet_generators
print*,'coef, <I|H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i)
print*,'coef, <I|H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i)
enddo
enddo
endif
@ -278,18 +283,20 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix
integer :: i_good_state(0:N_states)
i_good_state(0) = 0
do k = 1, N_states
! print*,'state',k
do i = 1, Ndet_generators
! State following
do k = 1, N_states
accu = 0.d0
do j =1, Ndet_generators
print*,'',eigvectors(j,i) , psi_coef_ref(j,k)
accu += eigvectors(j,i) * psi_coef_ref(j,k)
enddo
print*,'accu = ',accu
if(dabs(accu).ge.0.72d0)then
! print*,i,accu
if(dabs(accu).ge.0.60d0)then
i_good_state(0) +=1
i_good_state(i_good_state(0)) = i
print*, 'state, ovrlap',k,i,accu
exit
endif
enddo
if(i_good_state(0)==N_states)then
@ -304,14 +311,14 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
accu = 0.d0
do k = 1, N_states
do i = 1, Ndet_generators
psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k))
psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k))
enddo
enddo
if(verbose)then
do k = 1, N_states
print*,'state ',k
do i = 1, Ndet_generators
print*,'coef, <I|H+Delta H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i)
print*,'coef, <I|H+Delta H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i)
enddo
enddo
endif
@ -333,7 +340,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
do i = 1, Ndet_generators
if(is_a_ref_det(i))cycle
do k = 1, N_states
print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative
! print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative
if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold_perturbative)then
is_ok_perturbative = .False.
exit

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

@ -15,8 +15,6 @@ end
subroutine run_prepare
implicit none
! no_oa_or_av_opt = .False.
! touch no_oa_or_av_opt
call damping_SCF
call diag_inactive_virt_and_update_mos
end
@ -28,7 +26,8 @@ subroutine routine_fobo_scf
print*,''
character*(64) :: label
label = "Natural"
do i = 1, 5
do i = 1, 10
call initialize_mo_coef_begin_iteration
print*,'*******************************************************************************'
print*,'*******************************************************************************'
print*,'FOBO-SCF Iteration ',i
@ -56,6 +55,8 @@ subroutine routine_fobo_scf
call save_osoci_natural_mos
call damping_SCF
call diag_inactive_virt_and_update_mos
call reorder_active_orb
call save_mos
call clear_mo_map
call provide_properties
enddo

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

@ -40,11 +40,13 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
logical :: lmct
double precision, allocatable :: psi_singles_coef(:,:)
logical :: exit_loop
call update_generators_restart_coef
allocate( zero_bitmask(N_int,2) )
do i = 1, n_inact_orb
lmct = .True.
integer :: i_hole_osoci
i_hole_osoci = list_inact(i)
! if(i_hole_osoci.ne.26)cycle
print*,'--------------------------'
! First set the current generators to the one of restart
call check_symetry(i_hole_osoci,thr,test_sym)
@ -54,7 +56,6 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
print*,'i_hole_osoci = ',i_hole_osoci
call create_restart_and_1h(i_hole_osoci)
call set_generators_to_psi_det
print*,'Passed set generators'
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
double precision :: e_pt2
@ -82,10 +83,10 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call all_single(e_pt2)
call make_s2_eigenfunction_first_order
threshold_davidson = 1.d-6
soft_touch threshold_davidson davidson_criterion
call diagonalize_ci
! call make_s2_eigenfunction_first_order
! threshold_davidson = 1.d-6
! soft_touch threshold_davidson davidson_criterion
! call diagonalize_ci
double precision :: hkl
call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
hkl = dressing_matrix(1,1)
@ -118,6 +119,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
do i = 1, n_virt_orb
integer :: i_particl_osoci
i_particl_osoci = list_virt(i)
! cycle
print*,'--------------------------'
! First set the current generators to the one of restart
@ -152,11 +154,11 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
enddo
enddo
call all_single(e_pt2)
call make_s2_eigenfunction_first_order
threshold_davidson = 1.d-6
soft_touch threshold_davidson davidson_criterion
call diagonalize_ci
! call make_s2_eigenfunction_first_order
! threshold_davidson = 1.d-6
! soft_touch threshold_davidson davidson_criterion
!
! call diagonalize_ci
deallocate(dressing_matrix)
else
if(exit_loop)then
@ -541,7 +543,6 @@ subroutine FOBOCI_lmct_mlct_old_thr_restart(iter)
call print_generators_bitmasks_holes
! Impose that only the active part can be reached
call set_bitmask_hole_as_input(unpaired_bitmask)
!!! call all_single_h_core
call create_restart_and_1p(i_particl_osoci)
!!! ! Update the generators
call set_generators_to_psi_det

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

@ -21,23 +21,19 @@ END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_restart, (N_int,2,N_det_generators_restart) ]
&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2) ]
&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2,N_states) ]
&BEGIN_PROVIDER [ double precision, psi_coef_generators_restart, (N_det_generators_restart,N_states) ]
implicit none
BEGIN_DOC
! read wf
!
END_DOC
integer :: i, k
integer :: i, k,j
integer, save :: ifirst = 0
double precision, allocatable :: psi_coef_read(:,:)
print*, ' Providing psi_det_generators_restart'
if(ifirst == 0)then
call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart)
do k = 1, N_int
ref_generators_restart(k,1) = psi_det_generators_restart(k,1,1)
ref_generators_restart(k,2) = psi_det_generators_restart(k,2,1)
enddo
allocate (psi_coef_read(N_det_generators_restart,N_states))
call ezfio_get_determinants_psi_coef(psi_coef_read)
do k = 1, N_states
@ -45,6 +41,18 @@ END_PROVIDER
psi_coef_generators_restart(i,k) = psi_coef_read(i,k)
enddo
enddo
do k = 1, N_states
do i = 1, N_det_generators_restart
if(dabs(psi_coef_generators_restart(i,k)).gt.0.5d0)then
do j = 1, N_int
ref_generators_restart(j,1,k) = psi_det_generators_restart(j,1,i)
ref_generators_restart(j,2,k) = psi_det_generators_restart(j,2,i)
enddo
exit
endif
enddo
call debug_det(ref_generators_restart(1,1,k),N_int)
enddo
ifirst = 1
deallocate(psi_coef_read)
else
@ -74,3 +82,18 @@ END_PROVIDER
&BEGIN_PROVIDER [ double precision, psi_coef_generators, (10000,N_states) ]
END_PROVIDER
subroutine update_generators_restart_coef
implicit none
call set_generators_to_generators_restart
call set_psi_det_to_generators
call diagonalize_CI
integer :: i,j,k,l
do i = 1, N_det_generators_restart
do j = 1, N_states
psi_coef_generators_restart(i,j) = psi_coef(i,j)
enddo
enddo
soft_touch psi_coef_generators_restart
provide one_body_dm_mo_alpha_generators_restart
end

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

@ -2,7 +2,7 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
implicit none
integer, intent(in) :: i_hole
double precision, intent(out) :: norm(N_states)
integer :: i,j,degree,index_ref_generators_restart,k
integer :: i,j,degree,index_ref_generators_restart(N_states),k
integer:: number_of_holes,n_h, number_of_particles,n_p
integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:)
integer, allocatable :: index_one_p(:)
@ -13,6 +13,8 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
integer :: n_good_hole
logical,allocatable :: is_a_ref_det(:)
allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det))
double precision, allocatable :: local_norm(:)
allocate(local_norm(N_states))
n_one_hole = 0
n_one_hole_one_p = 0
@ -22,17 +24,18 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
n_good_hole = 0
! Find the one holes and one hole one particle
is_a_ref_det = .False.
integer :: istate
do istate = 1, N_States
do i = 1, N_det
! Find the reference determinant for intermediate normalization
call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int)
call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart = i
do k = 1, N_states
inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k)
enddo
! cycle
index_ref_generators_restart(istate) = i
inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef(i,istate)
endif
enddo
enddo
do i = 1, N_det
! Find all the determinants present in the reference wave function
do j = 1, N_det_generators_restart
call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int)
@ -59,20 +62,17 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
enddo
endif
enddo
!do k = 1, N_det
! call debug_det(psi_det(1,1,k),N_int)
! print*,'k,coef = ',k,psi_coef(k,1)/psi_coef(index_ref_generators_restart,1)
!enddo
print*,''
print*,'n_good_hole = ',n_good_hole
do k = 1,N_states
print*,'state ',k
do i = 1, n_good_hole
print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart,k)
print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart(k),k)
enddo
print*,''
enddo
norm = 0.d0
! Set the wave function to the intermediate normalization
do k = 1, N_states
@ -80,19 +80,30 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k)
enddo
enddo
norm = 0.d0
do k = 1,N_states
print*,'state ',k
do i = 1, N_det
!! print*,'psi_coef(i_ref) = ',psi_coef(i,1)
if (is_a_ref_det(i))then
print*,'i,psi_coef_ref = ',psi_coef(i,k)
cycle
endif
norm(k) += psi_coef(i,k) * psi_coef(i,k)
enddo
print*,'norm = ',norm(k)
enddo
do k =1, N_states
local_norm(k) = 1.d0 / dsqrt(norm(k))
enddo
do k = 1,N_states
do i = 1, N_det
psi_coef(i,k) = psi_coef(i,k) * local_norm(k)
enddo
enddo
deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det)
deallocate(local_norm)
soft_touch psi_coef
end
@ -101,7 +112,7 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
implicit none
integer, intent(in) :: i_particl
double precision, intent(out) :: norm(N_states)
integer :: i,j,degree,index_ref_generators_restart,k
integer :: i,j,degree,index_ref_generators_restart(N_states),k
integer:: number_of_holes,n_h, number_of_particles,n_p
integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:)
integer, allocatable :: index_one_p(:),index_one_hole_two_p(:)
@ -117,6 +128,8 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
integer :: i_count
allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det))
allocate(index_one_hole_two_p(n_det))
double precision, allocatable :: local_norm(:)
allocate(local_norm(N_states))
n_one_hole = 0
n_one_hole_one_p = 0
@ -128,16 +141,18 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
! Find the one holes and one hole one particle
i_count = 0
is_a_ref_det = .False.
integer :: istate
do istate = 1, N_states
do i = 1, N_det
call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int)
call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart = i
do k = 1, N_states
inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k)
enddo
! cycle
index_ref_generators_restart(istate) = i
inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef(i,istate)
endif
enddo
enddo
do i = 1, N_det
! Find all the determinants present in the reference wave function
do j = 1, N_det_generators_restart
call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int)
@ -173,7 +188,7 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
do k = 1, N_states
print*,'state ',k
do i = 1, n_good_particl
print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart,k)
print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart(k),k)
enddo
print*,''
enddo
@ -185,20 +200,29 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k)
enddo
enddo
norm = 0.d0
do k = 1,N_states
print*,'state ',k
do i = 1, N_det
!! print*,'i = ',i, psi_coef(i,1)
if (is_a_ref_det(i))then
print*,'i,psi_coef_ref = ',psi_coef(i,k)
cycle
endif
norm(k) += psi_coef(i,k) * psi_coef(i,k)
enddo
print*,'norm = ',norm
print*,'norm = ',norm(k)
enddo
do k =1, N_states
local_norm(k) = 1.d0 / dsqrt(norm(k))
enddo
do k = 1,N_states
do i = 1, N_det
psi_coef(i,k) = psi_coef(i,k) * local_norm(k)
enddo
enddo
soft_touch psi_coef
deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det)
deallocate(local_norm)
end
@ -210,12 +234,60 @@ subroutine update_density_matrix_osoci
END_DOC
integer :: i,j
integer :: iorb,jorb
! active <--> inactive block
do i = 1, mo_tot_num
do j = 1, mo_tot_num
one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
one_body_dm_mo_alpha_osoci(i,j) += one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)
one_body_dm_mo_beta_osoci(i,j) += one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j)
enddo
enddo
!do i = 1, n_act_orb
! iorb = list_act(i)
! do j = 1, n_inact_orb
! jorb = list_inact(j)
! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb)
! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb)
! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb)
! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb)
! enddo
!enddo
!! active <--> virt block
!do i = 1, n_act_orb
! iorb = list_act(i)
! do j = 1, n_virt_orb
! jorb = list_virt(j)
! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb)
! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb)
! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb)
! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb)
! enddo
!enddo
!! virt <--> virt block
!do j = 1, n_virt_orb
! jorb = list_virt(j)
! one_body_dm_mo_alpha_osoci(jorb,jorb)+= one_body_dm_mo_alpha_average(jorb,jorb)
! one_body_dm_mo_beta_osoci(jorb,jorb) += one_body_dm_mo_beta_average(jorb,jorb)
!enddo
!! inact <--> inact block
!do j = 1, n_inact_orb
! jorb = list_inact(j)
! one_body_dm_mo_alpha_osoci(jorb,jorb) -= one_body_dm_mo_alpha_average(jorb,jorb)
! one_body_dm_mo_beta_osoci(jorb,jorb) -= one_body_dm_mo_beta_average(jorb,jorb)
!enddo
double precision :: accu_alpha, accu_beta
accu_alpha = 0.d0
accu_beta = 0.d0
do i = 1, mo_tot_num
accu_alpha += one_body_dm_mo_alpha_osoci(i,i)
accu_beta += one_body_dm_mo_beta_osoci(i,i)
! write(*,'(I3,X,100(F16.10,X))') i,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_beta_osoci(i,i),one_body_dm_mo_alpha_osoci(i,i)+one_body_dm_mo_beta_osoci(i,i)
enddo
print*, 'accu_alpha/beta',accu_alpha,accu_beta
end
@ -261,8 +333,18 @@ end
subroutine initialize_density_matrix_osoci
implicit none
call set_generators_to_generators_restart
call set_psi_det_to_generators
call diagonalize_CI
one_body_dm_mo_alpha_osoci = one_body_dm_mo_alpha_generators_restart
one_body_dm_mo_beta_osoci = one_body_dm_mo_beta_generators_restart
integer :: i
print*, '8*********************'
print*, 'initialize_density_matrix_osoci'
do i = 1, mo_tot_num
print*,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_alpha_generators_restart(i,i)
enddo
end
subroutine rescale_density_matrix_osoci(norm)
@ -438,6 +520,10 @@ subroutine save_osoci_natural_mos
endif
enddo
enddo
print*, 'test'
print*, 'test'
print*, 'test'
print*, 'test'
do i = 1, mo_tot_num
do j = i+1, mo_tot_num
if(dabs(tmp(i,j)).le.threshold_fobo_dm)then
@ -445,8 +531,10 @@ subroutine save_osoci_natural_mos
tmp(j,i) = 0.d0
endif
enddo
print*, tmp(i,i)
enddo
label = "Natural"
call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1)

57
plugins/FOBOCI/track_orb.irp.f Normal file
View File

@ -0,0 +1,57 @@
BEGIN_PROVIDER [ double precision, mo_coef_begin_iteration, (ao_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Alpha and beta one-body density matrix that will be used for the 1h1p approach
END_DOC
END_PROVIDER
subroutine initialize_mo_coef_begin_iteration
implicit none
mo_coef_begin_iteration = mo_coef
end
subroutine reorder_active_orb
implicit none
integer :: i,j,iorb
integer :: k,l
double precision, allocatable :: accu(:)
integer, allocatable :: index_active_orb(:),iorder(:)
double precision, allocatable :: mo_coef_tmp(:,:)
allocate(accu(mo_tot_num),index_active_orb(n_act_orb),iorder(mo_tot_num))
allocate(mo_coef_tmp(ao_num_align,mo_Tot_num))
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, mo_tot_num
accu(j) = 0.d0
iorder(j) = j
do k = 1, ao_num
do l = 1, ao_num
accu(j) += mo_coef_begin_iteration(k,iorb) * mo_coef(l,j) * ao_overlap(k,l)
enddo
enddo
accu(j) = -dabs(accu(j))
enddo
call dsort(accu,iorder,mo_tot_num)
index_active_orb(i) = iorder(1)
enddo
double precision :: x
integer :: i1,i2
print*, 'swapping the active MOs'
do j = 1, n_act_orb
i1 = list_act(j)
i2 = index_active_orb(j)
print*, i1,i2
do i=1,ao_num_align
x = mo_coef(i,i1)
mo_coef(i,i1) = mo_coef(i,i2)
mo_coef(i,i2) = x
enddo
enddo
deallocate(accu,index_active_orb, iorder)
end

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

@ -12,11 +12,6 @@ s.set_perturbation("epstein_nesbet_2x2")
s.unset_openmp()
print s
s = H_apply("FCI_PT2_new")
s.set_perturbation("decontracted")
s.unset_openmp()
print s
s = H_apply("FCI_no_skip")
s.set_selection_pt2("epstein_nesbet_2x2")

5
plugins/Full_CI_ZMQ/.gitignore vendored Normal file
View File

@ -0,0 +1,5 @@
IRPF90_temp/
IRPF90_man/
irpf90.make
irpf90_entities
tags

1113
plugins/Full_CI_ZMQ/selection.irp.f
View File

File diff suppressed because it is too large Load Diff

25
plugins/Generators_CAS/Generators_full/.gitignore vendored Normal file
View File

@ -0,0 +1,25 @@
# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py
IRPF90_temp
IRPF90_man
irpf90_entities
tags
irpf90.make
Makefile
Makefile.depend
build.ninja
.ninja_log
.ninja_deps
ezfio_interface.irp.f
Ezfio_files
Determinants
Integrals_Monoelec
MO_Basis
Utils
Pseudo
Bitmask
AO_Basis
Electrons
MOGuess
Nuclei
Hartree_Fock
Integrals_Bielec

1
plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Determinants Hartree_Fock

61
plugins/Generators_CAS/Generators_full/README.rst Normal file
View File

@ -0,0 +1,61 @@
======================
Generators_full Module
======================
All the determinants of the wave function are generators. In this way, the Full CI
space is explored.
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
.. image:: tree_dependency.png
* `Determinants <http://github.com/LCPQ/quantum_package/tree/master/src/Determinants>`_
* `Hartree_Fock <http://github.com/LCPQ/quantum_package/tree/master/src/Hartree_Fock>`_
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
.. image:: tree_dependency.png
* `Determinants <http://github.com/LCPQ/quantum_package/tree/master/src/Determinants>`_
* `Hartree_Fock <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock>`_
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
`degree_max_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L43>`_
Max degree of excitation (respect to HF) of the generators
`n_det_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L3>`_
For Single reference wave functions, the number of generators is 1 : the
Hartree-Fock determinant
`psi_coef_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L26>`_
For Single reference wave functions, the generator is the
Hartree-Fock determinant
`psi_det_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L25>`_
For Single reference wave functions, the generator is the
Hartree-Fock determinant
`select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L66>`_
Memo to skip useless selectors
`size_select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L58>`_
Size of the select_max array

75
plugins/Generators_CAS/Generators_full/generators.irp.f Normal file
View File

@ -0,0 +1,75 @@
use bitmasks
BEGIN_PROVIDER [ integer, N_det_generators ]
implicit none
BEGIN_DOC
! For Single reference wave functions, the number of generators is 1 : the
! Hartree-Fock determinant
END_DOC
integer :: i
double precision :: norm
call write_time(output_determinants)
norm = 0.d0
N_det_generators = N_det
do i=1,N_det
norm = norm + psi_average_norm_contrib_sorted(i)
if (norm >= threshold_generators) then
N_det_generators = i
exit
endif
enddo
N_det_generators = max(N_det_generators,1)
call write_int(output_determinants,N_det_generators,'Number of generators')
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ]
&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ]
implicit none
BEGIN_DOC
! For Single reference wave functions, the generator is the
! Hartree-Fock determinant
END_DOC
integer :: i, k
psi_coef_generators = 0.d0
psi_det_generators = 0_bit_kind
do i=1,N_det_generators
do k=1,N_int
psi_det_generators(k,1,i) = psi_det_sorted(k,1,i)
psi_det_generators(k,2,i) = psi_det_sorted(k,2,i)
enddo
psi_coef_generators(i,:) = psi_coef_sorted(i,:)
enddo
END_PROVIDER
BEGIN_PROVIDER [integer, degree_max_generators]
implicit none
BEGIN_DOC
! Max degree of excitation (respect to HF) of the generators
END_DOC
integer :: i,degree
degree_max_generators = 0
do i = 1, N_det_generators
call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int)
if(degree .gt. degree_max_generators)then
degree_max_generators = degree
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, size_select_max]
implicit none
BEGIN_DOC
! Size of the select_max array
END_DOC
size_select_max = 10000
END_PROVIDER
BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ]
implicit none
BEGIN_DOC
! Memo to skip useless selectors
END_DOC
select_max = huge(1.d0)
END_PROVIDER

BIN
plugins/Generators_CAS/Generators_full/tree_dependency.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 81 KiB

16
plugins/Generators_CAS/generators.irp.f
View File

@ -9,14 +9,14 @@ BEGIN_PROVIDER [ integer, N_det_generators ]
logical :: good
call write_time(output_determinants)
N_det_generators = 0
do i=1,N_det
do i=1,N_det_ref
do l=1,n_cas_bitmask
good = .True.
do k=1,N_int
good = good .and. ( &
iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) ) .and. ( &
iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2)) )
enddo
if (good) then
@ -41,14 +41,14 @@ END_PROVIDER
integer :: i, k, l, m
logical :: good
m=0
do i=1,N_det
do i=1,N_det_ref
do l=1,n_cas_bitmask
good = .True.
do k=1,N_int
good = good .and. ( &
iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( &
iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) )
enddo
if (good) then
@ -58,8 +58,8 @@ END_PROVIDER
if (good) then
m = m+1
do k=1,N_int
psi_det_generators(k,1,m) = psi_det(k,1,i)
psi_det_generators(k,2,m) = psi_det(k,2,i)
psi_det_generators(k,1,m) = psi_ref(k,1,i)
psi_det_generators(k,2,m) = psi_ref(k,2,i)
enddo
psi_coef_generators(m,:) = psi_coef(m,:)
endif

34
plugins/Integrals_erf/EZFIO.cfg Normal file
View File

@ -0,0 +1,34 @@
[disk_access_ao_integrals_erf]
type: Disk_access
doc: Read/Write AO integrals with the long range interaction from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
[disk_access_mo_integrals_erf]
type: Disk_access
doc: Read/Write MO integrals with the long range interaction from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
[ao_integrals_threshold]
type: Threshold
doc: If |<pq|rs>| < ao_integrals_threshold then <pq|rs> is zero
interface: ezfio,provider,ocaml
default: 1.e-15
ezfio_name: threshold_ao
[mo_integrals_threshold]
type: Threshold
doc: If |<ij|kl>| < ao_integrals_threshold then <pq|rs> is zero
interface: ezfio,provider,ocaml
default: 1.e-15
ezfio_name: threshold_mo
[mu_erf]
type: double precision
doc: cutting of the interaction in the range separated model
interface: ezfio,provider,ocaml
default: 0.5
ezfio_name: mu_erf

1
plugins/Integrals_erf/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Pseudo Bitmask ZMQ Integrals_Bielec

570
plugins/Integrals_erf/ao_bi_integrals_erf.irp.f Normal file
View File

@ -0,0 +1,570 @@
double precision function ao_bielec_integral_erf(i,j,k,l)
implicit none
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
! i(r1) j(r1) 1/r12 k(r2) l(r2)
END_DOC
integer,intent(in) :: i,j,k,l
integer :: p,q,r,s
double precision :: I_center(3),J_center(3),K_center(3),L_center(3)
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
double precision :: integral
include 'Utils/constants.include.F'
double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp
double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq
integer :: iorder_p(3), iorder_q(3)
double precision :: ao_bielec_integral_schwartz_accel_erf
if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
ao_bielec_integral_erf = ao_bielec_integral_schwartz_accel_erf(i,j,k,l)
return
endif
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
ao_bielec_integral_erf = 0.d0
if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
double precision :: coef1, coef2, coef3, coef4
double precision :: p_inv,q_inv
double precision :: general_primitive_integral_erf
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
I_power,J_power,I_center,J_center,dim1)
p_inv = 1.d0/pp
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
integral = general_primitive_integral_erf(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
ao_bielec_integral_erf = ao_bielec_integral_erf + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
else
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
enddo
double precision :: ERI_erf
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
integral = ERI_erf( &
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
I_power(1),J_power(1),K_power(1),L_power(1), &
I_power(2),J_power(2),K_power(2),L_power(2), &
I_power(3),J_power(3),K_power(3),L_power(3))
ao_bielec_integral_erf = ao_bielec_integral_erf + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
endif
end
double precision function ao_bielec_integral_schwartz_accel_erf(i,j,k,l)
implicit none
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
! i(r1) j(r1) 1/r12 k(r2) l(r2)
END_DOC
integer,intent(in) :: i,j,k,l
integer :: p,q,r,s
double precision :: I_center(3),J_center(3),K_center(3),L_center(3)
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
double precision :: integral
include 'Utils/constants.include.F'
double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp
double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq
integer :: iorder_p(3), iorder_q(3)
double precision, allocatable :: schwartz_kl(:,:)
double precision :: schwartz_ij
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
ao_bielec_integral_schwartz_accel_erf = 0.d0
double precision :: thr
thr = ao_integrals_threshold*ao_integrals_threshold
allocate(schwartz_kl(0:ao_prim_num(l),0:ao_prim_num(k)))
if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
schwartz_kl(0,0) = 0.d0
do r = 1, ao_prim_num(k)
coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k)
schwartz_kl(0,r) = 0.d0
do s = 1, ao_prim_num(l)
coef2 = coef1 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
schwartz_kl(s,r) = general_primitive_integral_erf(dim1, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q) &
* coef2
schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r))
enddo
schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0))
enddo
do p = 1, ao_prim_num(i)
double precision :: coef1
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
double precision :: coef2
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
double precision :: p_inv,q_inv
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
I_power,J_power,I_center,J_center,dim1)
p_inv = 1.d0/pp
schwartz_ij = general_primitive_integral_erf(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
P_new,P_center,fact_p,pp,p_inv,iorder_p) * &
coef2*coef2
if (schwartz_kl(0,0)*schwartz_ij < thr) then
cycle
endif
do r = 1, ao_prim_num(k)
if (schwartz_kl(0,r)*schwartz_ij < thr) then
cycle
endif
double precision :: coef3
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
double precision :: coef4
if (schwartz_kl(s,r)*schwartz_ij < thr) then
cycle
endif
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
double precision :: general_primitive_integral_erf
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
integral = general_primitive_integral_erf(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
ao_bielec_integral_schwartz_accel_erf = ao_bielec_integral_schwartz_accel_erf + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
else
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
enddo
double precision :: ERI_erf
schwartz_kl(0,0) = 0.d0
do r = 1, ao_prim_num(k)
coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k)
schwartz_kl(0,r) = 0.d0
do s = 1, ao_prim_num(l)
coef2 = coef1*ao_coef_normalized_ordered_transp(s,l)*ao_coef_normalized_ordered_transp(s,l)
schwartz_kl(s,r) = ERI_erf( &
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
K_power(1),L_power(1),K_power(1),L_power(1), &
K_power(2),L_power(2),K_power(2),L_power(2), &
K_power(3),L_power(3),K_power(3),L_power(3)) * &
coef2
schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r))
enddo
schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0))
enddo
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
schwartz_ij = ERI_erf( &
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),&
I_power(1),J_power(1),I_power(1),J_power(1), &
I_power(2),J_power(2),I_power(2),J_power(2), &
I_power(3),J_power(3),I_power(3),J_power(3))*coef2*coef2
if (schwartz_kl(0,0)*schwartz_ij < thr) then
cycle
endif
do r = 1, ao_prim_num(k)
if (schwartz_kl(0,r)*schwartz_ij < thr) then
cycle
endif
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
if (schwartz_kl(s,r)*schwartz_ij < thr) then
cycle
endif
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
integral = ERI_erf( &
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
I_power(1),J_power(1),K_power(1),L_power(1), &
I_power(2),J_power(2),K_power(2),L_power(2), &
I_power(3),J_power(3),K_power(3),L_power(3))
ao_bielec_integral_schwartz_accel_erf = ao_bielec_integral_schwartz_accel_erf + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
endif
deallocate (schwartz_kl)
end
subroutine compute_ao_bielec_integrals_erf(j,k,l,sze,buffer_value)
implicit none
use map_module
BEGIN_DOC
! Compute AO 1/r12 integrals for all i and fixed j,k,l
END_DOC
include 'Utils/constants.include.F'
integer, intent(in) :: j,k,l,sze
real(integral_kind), intent(out) :: buffer_value(sze)
double precision :: ao_bielec_integral_erf
integer :: i
if (ao_overlap_abs(j,l) < thresh) then
buffer_value = 0._integral_kind
return
endif
if (ao_bielec_integral_erf_schwartz(j,l) < thresh ) then
buffer_value = 0._integral_kind
return
endif
do i = 1, ao_num
if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thresh) then
buffer_value(i) = 0._integral_kind
cycle
endif
if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thresh ) then
buffer_value(i) = 0._integral_kind
cycle
endif
!DIR$ FORCEINLINE
buffer_value(i) = ao_bielec_integral_erf(i,k,j,l)
enddo
end
double precision function general_primitive_integral_erf(dim, &
P_new,P_center,fact_p,p,p_inv,iorder_p, &
Q_new,Q_center,fact_q,q,q_inv,iorder_q)
implicit none
BEGIN_DOC
! Computes the integral <pq|rs> where p,q,r,s are Gaussian primitives
END_DOC
integer,intent(in) :: dim
include 'Utils/constants.include.F'
double precision, intent(in) :: P_new(0:max_dim,3),P_center(3),fact_p,p,p_inv
double precision, intent(in) :: Q_new(0:max_dim,3),Q_center(3),fact_q,q,q_inv
integer, intent(in) :: iorder_p(3)
integer, intent(in) :: iorder_q(3)
double precision :: r_cut,gama_r_cut,rho,dist
double precision :: dx(0:max_dim),Ix_pol(0:max_dim),dy(0:max_dim),Iy_pol(0:max_dim),dz(0:max_dim),Iz_pol(0:max_dim)
integer :: n_Ix,n_Iy,n_Iz,nx,ny,nz
double precision :: bla
integer :: ix,iy,iz,jx,jy,jz,i
double precision :: a,b,c,d,e,f,accu,pq,const
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2,pq_inv_2
integer :: n_pt_tmp,n_pt_out, iorder
double precision :: d1(0:max_dim),d_poly(0:max_dim),rint,d1_screened(0:max_dim)
general_primitive_integral_erf = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx,Ix_pol,dy,Iy_pol,dz,Iz_pol
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
! Gaussian Product
! ----------------
double precision :: p_plus_q
p_plus_q = (p+q) * ((p*q)/(p+q) + mu_erf*mu_erf)/(mu_erf*mu_erf)
pq = p_inv*0.5d0*q_inv
pq_inv = 0.5d0/p_plus_q
p10_1 = q*pq ! 1/(2p)
p01_1 = p*pq ! 1/(2q)
pq_inv_2 = pq_inv+pq_inv
p10_2 = pq_inv_2 * p10_1*q !0.5d0*q/(pq + p*p)
p01_2 = pq_inv_2 * p01_1*p !0.5d0*p/(q*q + pq)
accu = 0.d0
iorder = iorder_p(1)+iorder_q(1)+iorder_p(1)+iorder_q(1)
!DIR$ VECTOR ALIGNED
do ix=0,iorder
Ix_pol(ix) = 0.d0
enddo
n_Ix = 0
do ix = 0, iorder_p(1)
if (abs(P_new(ix,1)) < thresh) cycle
a = P_new(ix,1)
do jx = 0, iorder_q(1)
d = a*Q_new(jx,1)
if (abs(d) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x(P_center(1),Q_center(1),ix,jx,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dx,nx)
!DEC$ FORCEINLINE
call add_poly_multiply(dx,nx,d,Ix_pol,n_Ix)
enddo
enddo
if (n_Ix == -1) then
return
endif
iorder = iorder_p(2)+iorder_q(2)+iorder_p(2)+iorder_q(2)
!DIR$ VECTOR ALIGNED
do ix=0, iorder
Iy_pol(ix) = 0.d0
enddo
n_Iy = 0
do iy = 0, iorder_p(2)
if (abs(P_new(iy,2)) > thresh) then
b = P_new(iy,2)
do jy = 0, iorder_q(2)
e = b*Q_new(jy,2)
if (abs(e) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x(P_center(2),Q_center(2),iy,jy,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dy,ny)
!DEC$ FORCEINLINE
call add_poly_multiply(dy,ny,e,Iy_pol,n_Iy)
enddo
endif
enddo
if (n_Iy == -1) then
return
endif
iorder = iorder_p(3)+iorder_q(3)+iorder_p(3)+iorder_q(3)
do ix=0,iorder
Iz_pol(ix) = 0.d0
enddo
n_Iz = 0
do iz = 0, iorder_p(3)
if (abs(P_new(iz,3)) > thresh) then
c = P_new(iz,3)
do jz = 0, iorder_q(3)
f = c*Q_new(jz,3)
if (abs(f) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x(P_center(3),Q_center(3),iz,jz,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dz,nz)
!DEC$ FORCEINLINE
call add_poly_multiply(dz,nz,f,Iz_pol,n_Iz)
enddo
endif
enddo
if (n_Iz == -1) then
return
endif
rho = p*q *pq_inv_2 ! le rho qui va bien
dist = (P_center(1) - Q_center(1))*(P_center(1) - Q_center(1)) + &
(P_center(2) - Q_center(2))*(P_center(2) - Q_center(2)) + &
(P_center(3) - Q_center(3))*(P_center(3) - Q_center(3))
const = dist*rho
n_pt_tmp = n_Ix+n_Iy
do i=0,n_pt_tmp
d_poly(i)=0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp)
if (n_pt_tmp == -1) then
return
endif
n_pt_out = n_pt_tmp+n_Iz
do i=0,n_pt_out
d1(i)=0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out)
double precision :: rint_sum
accu = accu + rint_sum(n_pt_out,const,d1)
! change p+q in dsqrt
general_primitive_integral_erf = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p_plus_q)
end
double precision function ERI_erf(alpha,beta,delta,gama,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z)
implicit none
BEGIN_DOC
! ATOMIC PRIMTIVE bielectronic integral between the 4 primitives ::
! primitive_1 = x1**(a_x) y1**(a_y) z1**(a_z) exp(-alpha * r1**2)
! primitive_2 = x1**(b_x) y1**(b_y) z1**(b_z) exp(- beta * r1**2)
! primitive_3 = x2**(c_x) y2**(c_y) z2**(c_z) exp(-delta * r2**2)
! primitive_4 = x2**(d_x) y2**(d_y) z2**(d_z) exp(- gama * r2**2)
END_DOC
double precision, intent(in) :: delta,gama,alpha,beta
integer, intent(in) :: a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z
integer :: a_x_2,b_x_2,c_x_2,d_x_2,a_y_2,b_y_2,c_y_2,d_y_2,a_z_2,b_z_2,c_z_2,d_z_2
integer :: i,j,k,l,n_pt
integer :: n_pt_sup
double precision :: p,q,denom,coeff
double precision :: I_f
integer :: nx,ny,nz
include 'Utils/constants.include.F'
nx = a_x+b_x+c_x+d_x
if(iand(nx,1) == 1) then
ERI_erf = 0.d0
return
endif
ny = a_y+b_y+c_y+d_y
if(iand(ny,1) == 1) then
ERI_erf = 0.d0
return
endif
nz = a_z+b_z+c_z+d_z
if(iand(nz,1) == 1) then
ERI_erf = 0.d0
return
endif
ASSERT (alpha >= 0.d0)
ASSERT (beta >= 0.d0)
ASSERT (delta >= 0.d0)
ASSERT (gama >= 0.d0)
p = alpha + beta
q = delta + gama
double precision :: p_plus_q
p_plus_q = (p+q) * ((p*q)/(p+q) + mu_erf*mu_erf)/(mu_erf*mu_erf)
ASSERT (p+q >= 0.d0)
n_pt = ishft( nx+ny+nz,1 )
coeff = pi_5_2 / (p * q * dsqrt(p_plus_q))
if (n_pt == 0) then
ERI_erf = coeff
return
endif
call integrale_new(I_f,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z,p,q,n_pt)
ERI_erf = I_f * coeff
end
subroutine compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value)
implicit none
use map_module
BEGIN_DOC
! Parallel client for AO integrals
END_DOC
integer, intent(in) :: j,l
integer,intent(out) :: n_integrals
integer(key_kind),intent(out) :: buffer_i(ao_num*ao_num)
real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num)
integer :: i,k
double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2
double precision :: integral, wall_0
double precision :: thr
integer :: kk, m, j1, i1
thr = ao_integrals_threshold
n_integrals = 0
j1 = j+ishft(l*l-l,-1)
do k = 1, ao_num ! r1
i1 = ishft(k*k-k,-1)
if (i1 > j1) then
exit
endif
do i = 1, k
i1 += 1
if (i1 > j1) then
exit
endif
if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thr) then
cycle
endif
if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thr ) then
cycle
endif
!DIR$ FORCEINLINE
integral = ao_bielec_integral_erf(i,k,j,l) ! i,k : r1 j,l : r2
if (abs(integral) < thr) then
cycle
endif
n_integrals += 1
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,buffer_i(n_integrals))
buffer_value(n_integrals) = integral
enddo
enddo
end

175
plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f Normal file
View File

@ -0,0 +1,175 @@
subroutine ao_bielec_integrals_erf_in_map_slave_tcp(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_bielec_integrals_erf_in_map_slave(0,i)
end
subroutine ao_bielec_integrals_erf_in_map_slave_inproc(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_bielec_integrals_erf_in_map_slave(1,i)
end
subroutine ao_bielec_integrals_erf_in_map_slave(thread,iproc)
use map_module
use f77_zmq
implicit none
BEGIN_DOC
! Computes a buffer of integrals
END_DOC
integer, intent(in) :: thread, iproc
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
integer :: worker_id, task_id
character*(512) :: task
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR), external :: new_zmq_push_socket
integer(ZMQ_PTR) :: zmq_socket_push
character*(64) :: state
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_push = new_zmq_push_socket(thread)
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
do
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
if (task_id == 0) exit
read(task,*) j, l
call compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value)
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
enddo
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
deallocate( buffer_i, buffer_value )
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
end
subroutine ao_bielec_integrals_erf_in_map_collector
use map_module
use f77_zmq
implicit none
BEGIN_DOC
! Collects results from the AO integral calculation
END_DOC
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR), external :: new_zmq_pull_socket
integer(ZMQ_PTR) :: zmq_socket_pull
integer*8 :: control, accu
integer :: task_id, more, sze
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_pull = new_zmq_pull_socket()
sze = ao_num*ao_num
allocate ( buffer_i(sze), buffer_value(sze) )
accu = 0_8
more = 1
do while (more == 1)
rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
if (rc == -1) then
n_integrals = 0
return
endif
if (rc /= 4) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)'
stop 'error'
endif
if (n_integrals >= 0) then
if (n_integrals > sze) then
deallocate (buffer_value, buffer_i)
sze = n_integrals
allocate (buffer_value(sze), buffer_i(sze))
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
if (rc /= key_kind*n_integrals) then
print *, rc, key_kind, n_integrals
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
if (rc /= integral_kind*n_integrals) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
! Activate if zmq_socket_pull is a REP
rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0)
if (rc /= 4) then
print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...'
stop 'error'
endif
call insert_into_ao_integrals_erf_map(n_integrals,buffer_i,buffer_value)
accu += n_integrals
if (task_id /= 0) then
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
endif
endif
enddo
deallocate( buffer_i, buffer_value )
integer (map_size_kind) :: get_ao_erf_map_size
control = get_ao_erf_map_size(ao_integrals_erf_map)
if (control /= accu) then
print *, ''
print *, irp_here
print *, 'Control : ', control
print *, 'Accu : ', accu
print *, 'Some integrals were lost during the parallel computation.'
print *, 'Try to reduce the number of threads.'
stop
endif
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_pull_socket(zmq_socket_pull)
end

22
plugins/Integrals_erf/integrals_3_index_erf.irp.f Normal file
View File

@ -0,0 +1,22 @@
BEGIN_PROVIDER [double precision, big_array_coulomb_integrals_erf, (mo_tot_num_align,mo_tot_num, mo_tot_num)]
&BEGIN_PROVIDER [double precision, big_array_exchange_integrals_erf,(mo_tot_num_align,mo_tot_num, mo_tot_num)]
implicit none
integer :: i,j,k,l
double precision :: get_mo_bielec_integral_erf
double precision :: integral
do k = 1, mo_tot_num
do i = 1, mo_tot_num
do j = 1, mo_tot_num
l = j
integral = get_mo_bielec_integral_erf(i,j,k,l,mo_integrals_erf_map)
big_array_coulomb_integrals_erf(j,i,k) = integral
l = j
integral = get_mo_bielec_integral_erf(i,j,l,k,mo_integrals_erf_map)
big_array_exchange_integrals_erf(j,i,k) = integral
enddo
enddo
enddo
END_PROVIDER

626
plugins/Integrals_erf/map_integrals_erf.irp.f Normal file
View File

@ -0,0 +1,626 @@
use map_module
!! AO Map
!! ======
BEGIN_PROVIDER [ type(map_type), ao_integrals_erf_map ]
implicit none
BEGIN_DOC
! AO integrals
END_DOC
integer(key_kind) :: key_max
integer(map_size_kind) :: sze
call bielec_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max)
sze = key_max
call map_init(ao_integrals_erf_map,sze)
print*, 'AO map initialized : ', sze
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_integrals_erf_cache_min ]
&BEGIN_PROVIDER [ integer, ao_integrals_erf_cache_max ]
implicit none
BEGIN_DOC
! Min and max values of the AOs for which the integrals are in the cache
END_DOC
ao_integrals_erf_cache_min = max(1,ao_num - 63)
ao_integrals_erf_cache_max = ao_num
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_integrals_erf_cache, (0:64*64*64*64) ]
use map_module
implicit none
BEGIN_DOC
! Cache of AO integrals for fast access
END_DOC
PROVIDE ao_bielec_integrals_erf_in_map
integer :: i,j,k,l,ii
integer(key_kind) :: idx
real(integral_kind) :: integral
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
do l=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max
do k=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max
do j=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max
do i=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(ao_integrals_erf_map,idx,integral)
ii = l-ao_integrals_erf_cache_min
ii = ior( ishft(ii,6), k-ao_integrals_erf_cache_min)
ii = ior( ishft(ii,6), j-ao_integrals_erf_cache_min)
ii = ior( ishft(ii,6), i-ao_integrals_erf_cache_min)
ao_integrals_erf_cache(ii) = integral
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
double precision function get_ao_bielec_integral_erf(i,j,k,l,map) result(result)
use map_module
implicit none
BEGIN_DOC
! Gets one AO bi-electronic integral from the AO map
END_DOC
integer, intent(in) :: i,j,k,l
integer(key_kind) :: idx
type(map_type), intent(inout) :: map
integer :: ii
real(integral_kind) :: tmp
PROVIDE ao_bielec_integrals_erf_in_map ao_integrals_erf_cache ao_integrals_erf_cache_min
!DIR$ FORCEINLINE
if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < ao_integrals_threshold ) then
tmp = 0.d0
else if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < ao_integrals_threshold) then
tmp = 0.d0
else
ii = l-ao_integrals_erf_cache_min
ii = ior(ii, k-ao_integrals_erf_cache_min)
ii = ior(ii, j-ao_integrals_erf_cache_min)
ii = ior(ii, i-ao_integrals_erf_cache_min)
if (iand(ii, -64) /= 0) then
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(map,idx,tmp)
tmp = tmp
else
ii = l-ao_integrals_erf_cache_min
ii = ior( ishft(ii,6), k-ao_integrals_erf_cache_min)
ii = ior( ishft(ii,6), j-ao_integrals_erf_cache_min)
ii = ior( ishft(ii,6), i-ao_integrals_erf_cache_min)
tmp = ao_integrals_erf_cache(ii)
endif
endif
result = tmp
end
subroutine get_ao_bielec_integrals_erf(j,k,l,sze,out_val)
use map_module
BEGIN_DOC
! Gets multiple AO bi-electronic integral from the AO map .
! All i are retrieved for j,k,l fixed.
END_DOC
implicit none
integer, intent(in) :: j,k,l, sze
real(integral_kind), intent(out) :: out_val(sze)
integer :: i
integer(key_kind) :: hash
double precision :: thresh
PROVIDE ao_bielec_integrals_erf_in_map ao_integrals_erf_map
thresh = ao_integrals_threshold
if (ao_overlap_abs(j,l) < thresh) then
out_val = 0.d0
return
endif
double precision :: get_ao_bielec_integral_erf
do i=1,sze
out_val(i) = get_ao_bielec_integral_erf(i,j,k,l,ao_integrals_erf_map)
enddo
end
subroutine get_ao_bielec_integrals_erf_non_zero(j,k,l,sze,out_val,out_val_index,non_zero_int)
use map_module
implicit none
BEGIN_DOC
! Gets multiple AO bi-electronic integral from the AO map .
! All non-zero i are retrieved for j,k,l fixed.
END_DOC
integer, intent(in) :: j,k,l, sze
real(integral_kind), intent(out) :: out_val(sze)
integer, intent(out) :: out_val_index(sze),non_zero_int
integer :: i
integer(key_kind) :: hash
double precision :: thresh,tmp
PROVIDE ao_bielec_integrals_erf_in_map
thresh = ao_integrals_threshold
non_zero_int = 0
if (ao_overlap_abs(j,l) < thresh) then
out_val = 0.d0
return
endif
non_zero_int = 0
do i=1,sze
integer, external :: ao_l4
double precision, external :: ao_bielec_integral_erf
!DIR$ FORCEINLINE
if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thresh) then
cycle
endif
call bielec_integrals_index(i,j,k,l,hash)
call map_get(ao_integrals_erf_map, hash,tmp)
if (dabs(tmp) < thresh ) cycle
non_zero_int = non_zero_int+1
out_val_index(non_zero_int) = i
out_val(non_zero_int) = tmp
enddo
end
function get_ao_erf_map_size()
implicit none
integer (map_size_kind) :: get_ao_erf_map_size
BEGIN_DOC
! Returns the number of elements in the AO map
END_DOC
get_ao_erf_map_size = ao_integrals_erf_map % n_elements
end
subroutine clear_ao_erf_map
implicit none
BEGIN_DOC
! Frees the memory of the AO map
END_DOC
call map_deinit(ao_integrals_erf_map)
FREE ao_integrals_erf_map
end
BEGIN_TEMPLATE
subroutine dump_$ao_integrals(filename)
use map_module
implicit none
BEGIN_DOC
! Save to disk the $ao integrals
END_DOC
character*(*), intent(in) :: filename
integer(cache_key_kind), pointer :: key(:)
real(integral_kind), pointer :: val(:)
integer*8 :: i,j, n
call ezfio_set_work_empty(.False.)
open(unit=66,file=filename,FORM='unformatted')
write(66) integral_kind, key_kind
write(66) $ao_integrals_map%sorted, $ao_integrals_map%map_size, &
$ao_integrals_map%n_elements
do i=0_8,$ao_integrals_map%map_size
write(66) $ao_integrals_map%map(i)%sorted, $ao_integrals_map%map(i)%map_size,&
$ao_integrals_map%map(i)%n_elements
enddo
do i=0_8,$ao_integrals_map%map_size
key => $ao_integrals_map%map(i)%key
val => $ao_integrals_map%map(i)%value
n = $ao_integrals_map%map(i)%n_elements
write(66) (key(j), j=1,n), (val(j), j=1,n)
enddo
close(66)
end
IRP_IF COARRAY
subroutine communicate_$ao_integrals()
use map_module
implicit none
BEGIN_DOC
! Communicate the $ao integrals with co-array
END_DOC
integer(cache_key_kind), pointer :: key(:)
real(integral_kind), pointer :: val(:)
integer*8 :: i,j, k, nmax
integer*8, save :: n[*]
integer :: copy_n
real(integral_kind), allocatable :: buffer_val(:)[:]
integer(cache_key_kind), allocatable :: buffer_key(:)[:]
real(integral_kind), allocatable :: copy_val(:)
integer(key_kind), allocatable :: copy_key(:)
n = 0_8
do i=0_8,$ao_integrals_map%map_size
n = max(n,$ao_integrals_map%map(i)%n_elements)
enddo
sync all
nmax = 0_8
do j=1,num_images()
nmax = max(nmax,n[j])
enddo
allocate( buffer_key(nmax)[*], buffer_val(nmax)[*])
allocate( copy_key(nmax), copy_val(nmax))
do i=0_8,$ao_integrals_map%map_size
key => $ao_integrals_map%map(i)%key
val => $ao_integrals_map%map(i)%value
n = $ao_integrals_map%map(i)%n_elements
do j=1,n
buffer_key(j) = key(j)
buffer_val(j) = val(j)
enddo
sync all
do j=1,num_images()
if (j /= this_image()) then
copy_n = n[j]
do k=1,copy_n
copy_val(k) = buffer_val(k)[j]
copy_key(k) = buffer_key(k)[j]
copy_key(k) = copy_key(k)+ishft(i,-map_shift)
enddo
call map_append($ao_integrals_map, copy_key, copy_val, copy_n )
endif
enddo
sync all
enddo
deallocate( buffer_key, buffer_val, copy_val, copy_key)
end
IRP_ENDIF
integer function load_$ao_integrals(filename)
implicit none
BEGIN_DOC
! Read from disk the $ao integrals
END_DOC
character*(*), intent(in) :: filename
integer*8 :: i
integer(cache_key_kind), pointer :: key(:)
real(integral_kind), pointer :: val(:)
integer :: iknd, kknd
integer*8 :: n, j
load_$ao_integrals = 1
open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN')
read(66,err=98,end=98) iknd, kknd
if (iknd /= integral_kind) then
print *, 'Wrong integrals kind in file :', iknd
stop 1
endif
if (kknd /= key_kind) then
print *, 'Wrong key kind in file :', kknd
stop 1
endif
read(66,err=98,end=98) $ao_integrals_map%sorted, $ao_integrals_map%map_size,&
$ao_integrals_map%n_elements
do i=0_8, $ao_integrals_map%map_size
read(66,err=99,end=99) $ao_integrals_map%map(i)%sorted, &
$ao_integrals_map%map(i)%map_size, $ao_integrals_map%map(i)%n_elements
call cache_map_reallocate($ao_integrals_map%map(i),$ao_integrals_map%map(i)%map_size)
enddo
do i=0_8, $ao_integrals_map%map_size
key => $ao_integrals_map%map(i)%key
val => $ao_integrals_map%map(i)%value
n = $ao_integrals_map%map(i)%n_elements
read(66,err=99,end=99) (key(j), j=1,n), (val(j), j=1,n)
enddo
call map_sort($ao_integrals_map)
load_$ao_integrals = 0
return
99 continue
call map_deinit($ao_integrals_map)
98 continue
stop 'Problem reading $ao_integrals_map file in work/'
end
SUBST [ ao_integrals_map, ao_integrals, ao_num ]
ao_integrals_erf_map ; ao_integrals_erf ; ao_num ;;
mo_integrals_erf_map ; mo_integrals_erf ; mo_tot_num;;
END_TEMPLATE
BEGIN_PROVIDER [ type(map_type), mo_integrals_erf_map ]
implicit none
BEGIN_DOC
! MO integrals
END_DOC
integer(key_kind) :: key_max
integer(map_size_kind) :: sze
call bielec_integrals_index(mo_tot_num,mo_tot_num,mo_tot_num,mo_tot_num,key_max)
sze = key_max
call map_init(mo_integrals_erf_map,sze)
print*, 'MO map initialized'
END_PROVIDER
subroutine insert_into_ao_integrals_erf_map(n_integrals,buffer_i, buffer_values)
use map_module
implicit none
BEGIN_DOC
! Create new entry into AO map
END_DOC
integer, intent(in) :: n_integrals
integer(key_kind), intent(inout) :: buffer_i(n_integrals)
real(integral_kind), intent(inout) :: buffer_values(n_integrals)
call map_append(ao_integrals_erf_map, buffer_i, buffer_values, n_integrals)
end
subroutine insert_into_mo_integrals_erf_map(n_integrals, &
buffer_i, buffer_values, thr)
use map_module
implicit none
BEGIN_DOC
! Create new entry into MO map, or accumulate in an existing entry
END_DOC
integer, intent(in) :: n_integrals
integer(key_kind), intent(inout) :: buffer_i(n_integrals)
real(integral_kind), intent(inout) :: buffer_values(n_integrals)
real(integral_kind), intent(in) :: thr
call map_update(mo_integrals_erf_map, buffer_i, buffer_values, n_integrals, thr)
end
BEGIN_PROVIDER [ integer, mo_integrals_erf_cache_min ]
&BEGIN_PROVIDER [ integer, mo_integrals_erf_cache_max ]
implicit none
BEGIN_DOC
! Min and max values of the MOs for which the integrals are in the cache
END_DOC
mo_integrals_erf_cache_min = max(1,elec_alpha_num - 31)
mo_integrals_erf_cache_max = min(mo_tot_num,mo_integrals_erf_cache_min+63)
END_PROVIDER
BEGIN_PROVIDER [ double precision, mo_integrals_erf_cache, (0:64*64*64*64) ]
implicit none
BEGIN_DOC
! Cache of MO integrals for fast access
END_DOC
PROVIDE mo_bielec_integrals_erf_in_map
integer :: i,j,k,l
integer :: ii
integer(key_kind) :: idx
real(integral_kind) :: integral
FREE ao_integrals_erf_cache
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
do l=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max
do k=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max
do j=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max
do i=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(mo_integrals_erf_map,idx,integral)
ii = l-mo_integrals_erf_cache_min
ii = ior( ishft(ii,6), k-mo_integrals_erf_cache_min)
ii = ior( ishft(ii,6), j-mo_integrals_erf_cache_min)
ii = ior( ishft(ii,6), i-mo_integrals_erf_cache_min)
mo_integrals_erf_cache(ii) = integral
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
double precision function get_mo_bielec_integral_erf(i,j,k,l,map)
use map_module
implicit none
BEGIN_DOC
! Returns one integral <ij|kl> in the MO basis
END_DOC
integer, intent(in) :: i,j,k,l
integer(key_kind) :: idx
integer :: ii
type(map_type), intent(inout) :: map
real(integral_kind) :: tmp
PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_cache
ii = l-mo_integrals_erf_cache_min
ii = ior(ii, k-mo_integrals_erf_cache_min)
ii = ior(ii, j-mo_integrals_erf_cache_min)
ii = ior(ii, i-mo_integrals_erf_cache_min)
if (iand(ii, -64) /= 0) then
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(map,idx,tmp)
get_mo_bielec_integral_erf = dble(tmp)
else
ii = l-mo_integrals_erf_cache_min
ii = ior( ishft(ii,6), k-mo_integrals_erf_cache_min)
ii = ior( ishft(ii,6), j-mo_integrals_erf_cache_min)
ii = ior( ishft(ii,6), i-mo_integrals_erf_cache_min)
get_mo_bielec_integral_erf = mo_integrals_erf_cache(ii)
endif
end
double precision function mo_bielec_integral_erf(i,j,k,l)
implicit none
BEGIN_DOC
! Returns one integral <ij|kl> in the MO basis
END_DOC
integer, intent(in) :: i,j,k,l
double precision :: get_mo_bielec_integral_erf
PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_cache
!DIR$ FORCEINLINE
PROVIDE mo_bielec_integrals_erf_in_map
mo_bielec_integral_erf = get_mo_bielec_integral_erf(i,j,k,l,mo_integrals_erf_map)
return
end
subroutine get_mo_bielec_integrals_erf(j,k,l,sze,out_val,map)
use map_module
implicit none
BEGIN_DOC
! Returns multiple integrals <ij|kl> in the MO basis, all
! i for j,k,l fixed.
END_DOC
integer, intent(in) :: j,k,l, sze
double precision, intent(out) :: out_val(sze)
type(map_type), intent(inout) :: map
integer :: i
integer(key_kind) :: hash(sze)
real(integral_kind) :: tmp_val(sze)
PROVIDE mo_bielec_integrals_erf_in_map
do i=1,sze
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,hash(i))
enddo
if (key_kind == 8) then
call map_get_many(map, hash, out_val, sze)
else
call map_get_many(map, hash, tmp_val, sze)
! Conversion to double precision
do i=1,sze
out_val(i) = dble(tmp_val(i))
enddo
endif
end
subroutine get_mo_bielec_integrals_erf_ij(k,l,sze,out_array,map)
use map_module
implicit none
BEGIN_DOC
! Returns multiple integrals <ij|kl> in the MO basis, all
! i(1)j(2) 1/r12 k(1)l(2)
! i, j for k,l fixed.
END_DOC
integer, intent(in) :: k,l, sze
double precision, intent(out) :: out_array(sze,sze)
type(map_type), intent(inout) :: map
integer :: i,j,kk,ll,m
integer(key_kind),allocatable :: hash(:)
integer ,allocatable :: pairs(:,:), iorder(:)
real(integral_kind), allocatable :: tmp_val(:)
PROVIDE mo_bielec_integrals_erf_in_map
allocate (hash(sze*sze), pairs(2,sze*sze),iorder(sze*sze), &
tmp_val(sze*sze))
kk=0
out_array = 0.d0
do j=1,sze
do i=1,sze
kk += 1
!DIR$ FORCEINLINE
call bielec_integrals_index(i,j,k,l,hash(kk))
pairs(1,kk) = i
pairs(2,kk) = j
iorder(kk) = kk
enddo
enddo
logical :: integral_is_in_map
if (key_kind == 8) then
call i8radix_sort(hash,iorder,kk,-1)
else if (key_kind == 4) then
call iradix_sort(hash,iorder,kk,-1)
else if (key_kind == 2) then
call i2radix_sort(hash,iorder,kk,-1)
endif
call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk)
do ll=1,kk
m = iorder(ll)
i=pairs(1,m)
j=pairs(2,m)
out_array(i,j) = tmp_val(ll)
enddo
deallocate(pairs,hash,iorder,tmp_val)
end
subroutine get_mo_bielec_integrals_erf_coulomb_ii(k,l,sze,out_val,map)
use map_module
implicit none
BEGIN_DOC
! Returns multiple integrals <ki|li>
! k(1)i(2) 1/r12 l(1)i(2) :: out_val(i1)
! for k,l fixed.
END_DOC
integer, intent(in) :: k,l, sze
double precision, intent(out) :: out_val(sze)
type(map_type), intent(inout) :: map
integer :: i
integer(key_kind) :: hash(sze)
real(integral_kind) :: tmp_val(sze)
PROVIDE mo_bielec_integrals_erf_in_map
integer :: kk
do i=1,sze
!DIR$ FORCEINLINE
call bielec_integrals_index(k,i,l,i,hash(i))
enddo
if (key_kind == 8) then
call map_get_many(map, hash, out_val, sze)
else
call map_get_many(map, hash, tmp_val, sze)
! Conversion to double precision
do i=1,sze
out_val(i) = dble(tmp_val(i))
enddo
endif
end
subroutine get_mo_bielec_integrals_erf_exch_ii(k,l,sze,out_val,map)
use map_module
implicit none
BEGIN_DOC
! Returns multiple integrals <ki|il>
! k(1)i(2) 1/r12 i(1)l(2) :: out_val(i1)
! for k,l fixed.
END_DOC
integer, intent(in) :: k,l, sze
double precision, intent(out) :: out_val(sze)
type(map_type), intent(inout) :: map
integer :: i
integer(key_kind) :: hash(sze)
real(integral_kind) :: tmp_val(sze)
PROVIDE mo_bielec_integrals_erf_in_map
integer :: kk
do i=1,sze
!DIR$ FORCEINLINE
call bielec_integrals_index(k,i,i,l,hash(i))
enddo
if (key_kind == 8) then
call map_get_many(map, hash, out_val, sze)
else
call map_get_many(map, hash, tmp_val, sze)
! Conversion to double precision
do i=1,sze
out_val(i) = dble(tmp_val(i))
enddo
endif
end
integer*8 function get_mo_erf_map_size()
implicit none
BEGIN_DOC
! Return the number of elements in the MO map
END_DOC
get_mo_erf_map_size = mo_integrals_erf_map % n_elements
end

616
plugins/Integrals_erf/mo_bi_integrals_erf.irp.f Normal file
View File

@ -0,0 +1,616 @@
subroutine mo_bielec_integrals_erf_index(i,j,k,l,i1)
use map_module
implicit none
BEGIN_DOC
! Computes an unique index for i,j,k,l integrals
END_DOC
integer, intent(in) :: i,j,k,l
integer(key_kind), intent(out) :: i1
integer(key_kind) :: p,q,r,s,i2
p = min(i,k)
r = max(i,k)
p = p+ishft(r*r-r,-1)
q = min(j,l)
s = max(j,l)
q = q+ishft(s*s-s,-1)
i1 = min(p,q)
i2 = max(p,q)
i1 = i1+ishft(i2*i2-i2,-1)
end
BEGIN_PROVIDER [ logical, mo_bielec_integrals_erf_in_map ]
use map_module
implicit none
integer(bit_kind) :: mask_ijkl(N_int,4)
integer(bit_kind) :: mask_ijk(N_int,3)
BEGIN_DOC
! If True, the map of MO bielectronic integrals is provided
END_DOC
mo_bielec_integrals_erf_in_map = .True.
if (read_mo_integrals_erf) then
print*,'Reading the MO integrals_erf'
call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map)
print*, 'MO integrals_erf provided'
return
else
PROVIDE ao_bielec_integrals_erf_in_map
endif
!if(no_vvvv_integrals)then
! integer :: i,j,k,l
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!!
! ! (core+inact+act) ^ 4
! ! <ii|ii>
! print*, ''
! print*, '<ii|ii>'
! do i = 1,N_int
! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1)
! enddo
! call add_integrals_to_map(mask_ijkl)
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!!
! ! (core+inact+act) ^ 2 (virt) ^2
! ! <iv|iv> = J_iv
! print*, ''
! print*, '<iv|iv>'
! do i = 1,N_int
! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,2) = virt_bitmask(i,1)
! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,4) = virt_bitmask(i,1)
! enddo
! call add_integrals_to_map(mask_ijkl)
!
! ! (core+inact+act) ^ 2 (virt) ^2
! ! <ii|vv> = (iv|iv)
! print*, ''
! print*, '<ii|vv>'
! do i = 1,N_int
! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,3) = virt_bitmask(i,1)
! mask_ijkl(i,4) = virt_bitmask(i,1)
! enddo
! call add_integrals_to_map(mask_ijkl)
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!!
! if(.not.no_vvv_integrals)then
! print*, ''
! print*, '<rv|sv> and <rv|vs>'
! do i = 1,N_int
! mask_ijk(i,1) = virt_bitmask(i,1)
! mask_ijk(i,2) = virt_bitmask(i,1)
! mask_ijk(i,3) = virt_bitmask(i,1)
! enddo
! call add_integrals_to_map_three_indices(mask_ijk)
! endif
!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!!
! ! (core+inact+act) ^ 3 (virt) ^1
! ! <iv|ii>
! print*, ''
! print*, '<iv|ii>'
! do i = 1,N_int
! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,4) = virt_bitmask(i,1)
! enddo
! call add_integrals_to_map(mask_ijkl)
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!!
! ! (core+inact+act) ^ 1 (virt) ^3
! ! <iv|vv>
! if(.not.no_ivvv_integrals)then
! print*, ''
! print*, '<iv|vv>'
! do i = 1,N_int
! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
! mask_ijkl(i,2) = virt_bitmask(i,1)
! mask_ijkl(i,3) = virt_bitmask(i,1)
! mask_ijkl(i,4) = virt_bitmask(i,1)
! enddo
! call add_integrals_to_map_no_exit_34(mask_ijkl)
! endif
!
!else
call add_integrals_erf_to_map(full_ijkl_bitmask_4)
!endif
if (write_mo_integrals_erf) then
call ezfio_set_work_empty(.False.)
call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map)
call ezfio_set_integrals_erf_disk_access_mo_integrals_erf("Read")
endif
END_PROVIDER
subroutine add_integrals_erf_to_map(mask_ijkl)
use bitmasks
implicit none
BEGIN_DOC
! Adds integrals to tha MO map according to some bitmask
END_DOC
integer(bit_kind), intent(in) :: mask_ijkl(N_int,4)
integer :: i,j,k,l
integer :: i0,j0,k0,l0
double precision :: c, cpu_1, cpu_2, wall_1, wall_2, wall_0
integer, allocatable :: list_ijkl(:,:)
integer :: n_i, n_j, n_k, n_l
integer, allocatable :: bielec_tmp_0_idx(:)
real(integral_kind), allocatable :: bielec_tmp_0(:,:)
double precision, allocatable :: bielec_tmp_1(:)
double precision, allocatable :: bielec_tmp_2(:,:)
double precision, allocatable :: bielec_tmp_3(:,:,:)
!DEC$ ATTRIBUTES ALIGN : 64 :: bielec_tmp_1, bielec_tmp_2, bielec_tmp_3
integer :: n_integrals
integer :: size_buffer
integer(key_kind),allocatable :: buffer_i(:)
real(integral_kind),allocatable :: buffer_value(:)
real :: map_mb
integer :: i1,j1,k1,l1, ii1, kmax, thread_num
integer :: i2,i3,i4
double precision,parameter :: thr_coef = 1.d-10
PROVIDE ao_bielec_integrals_erf_in_map mo_coef
!Get list of MOs for i,j,k and l
!-------------------------------
allocate(list_ijkl(mo_tot_num,4))
call bitstring_to_list( mask_ijkl(1,1), list_ijkl(1,1), n_i, N_int )
call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int )
call bitstring_to_list( mask_ijkl(1,3), list_ijkl(1,3), n_k, N_int )
call bitstring_to_list( mask_ijkl(1,4), list_ijkl(1,4), n_l, N_int )
character*(2048) :: output(1)
print*, 'i'
call bitstring_to_str( output(1), mask_ijkl(1,1), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijkl(i,1))
enddo
if(j==0)then
return
endif
print*, 'j'
call bitstring_to_str( output(1), mask_ijkl(1,2), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijkl(i,2))
enddo
if(j==0)then
return
endif
print*, 'k'
call bitstring_to_str( output(1), mask_ijkl(1,3), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijkl(i,3))
enddo
if(j==0)then
return
endif
print*, 'l'
call bitstring_to_str( output(1), mask_ijkl(1,4), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijkl(i,4))
enddo
if(j==0)then
return
endif
size_buffer = min(ao_num*ao_num*ao_num,16000000)
print*, 'Providing the molecular integrals '
print*, 'Buffers : ', 8.*(mo_tot_num_align*(n_j)*(n_k+1) + mo_tot_num_align +&
ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core'
call wall_time(wall_1)
call cpu_time(cpu_1)
double precision :: accu_bis
accu_bis = 0.d0
!$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, &
!$OMP bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,&
!$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, &
!$OMP wall_0,thread_num,accu_bis) &
!$OMP DEFAULT(NONE) &
!$OMP SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,n_l,mo_tot_num_align,&
!$OMP mo_coef_transp, &
!$OMP mo_coef_transp_is_built, list_ijkl, &
!$OMP mo_coef_is_built, wall_1, &
!$OMP mo_coef,mo_integrals_threshold,mo_integrals_erf_map)
n_integrals = 0
wall_0 = wall_1
allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k), &
bielec_tmp_1(mo_tot_num_align), &
bielec_tmp_0(ao_num,ao_num), &
bielec_tmp_0_idx(ao_num), &
bielec_tmp_2(mo_tot_num_align, n_j), &
buffer_i(size_buffer), &
buffer_value(size_buffer) )
thread_num = 0
!$ thread_num = omp_get_thread_num()
!$OMP DO SCHEDULE(guided)
do l1 = 1,ao_num
!DEC$ VECTOR ALIGNED
bielec_tmp_3 = 0.d0
do k1 = 1,ao_num
!DEC$ VECTOR ALIGNED
bielec_tmp_2 = 0.d0
do j1 = 1,ao_num
call get_ao_bielec_integrals_erf(j1,k1,l1,ao_num,bielec_tmp_0(1,j1))
! call compute_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1))
enddo
do j1 = 1,ao_num
kmax = 0
do i1 = 1,ao_num
c = bielec_tmp_0(i1,j1)
if (c == 0.d0) then
cycle
endif
kmax += 1
bielec_tmp_0(kmax,j1) = c
bielec_tmp_0_idx(kmax) = i1
enddo
if (kmax==0) then
cycle
endif
!DEC$ VECTOR ALIGNED
bielec_tmp_1 = 0.d0
ii1=1
do ii1 = 1,kmax-4,4
i1 = bielec_tmp_0_idx(ii1)
i2 = bielec_tmp_0_idx(ii1+1)
i3 = bielec_tmp_0_idx(ii1+2)
i4 = bielec_tmp_0_idx(ii1+3)
do i = list_ijkl(1,1), list_ijkl(n_i,1)
bielec_tmp_1(i) = bielec_tmp_1(i) + &
mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) + &
mo_coef_transp(i,i2) * bielec_tmp_0(ii1+1,j1) + &
mo_coef_transp(i,i3) * bielec_tmp_0(ii1+2,j1) + &
mo_coef_transp(i,i4) * bielec_tmp_0(ii1+3,j1)
enddo ! i
enddo ! ii1
i2 = ii1
do ii1 = i2,kmax
i1 = bielec_tmp_0_idx(ii1)
do i = list_ijkl(1,1), list_ijkl(n_i,1)
bielec_tmp_1(i) = bielec_tmp_1(i) + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1)
enddo ! i
enddo ! ii1
c = 0.d0
do i = list_ijkl(1,1), list_ijkl(n_i,1)
c = max(c,abs(bielec_tmp_1(i)))
if (c>mo_integrals_threshold) exit
enddo
if ( c < mo_integrals_threshold ) then
cycle
endif
do j0 = 1, n_j
j = list_ijkl(j0,2)
c = mo_coef_transp(j,j1)
if (abs(c) < thr_coef) then
cycle
endif
do i = list_ijkl(1,1), list_ijkl(n_i,1)
bielec_tmp_2(i,j0) = bielec_tmp_2(i,j0) + c * bielec_tmp_1(i)
enddo ! i
enddo ! j
enddo !j1
if ( maxval(abs(bielec_tmp_2)) < mo_integrals_threshold ) then
cycle
endif
do k0 = 1, n_k
k = list_ijkl(k0,3)
c = mo_coef_transp(k,k1)
if (abs(c) < thr_coef) then
cycle
endif
do j0 = 1, n_j
j = list_ijkl(j0,2)
do i = list_ijkl(1,1), k
bielec_tmp_3(i,j0,k0) = bielec_tmp_3(i,j0,k0) + c* bielec_tmp_2(i,j0)
enddo!i
enddo !j
enddo !k
enddo !k1
do l0 = 1,n_l
l = list_ijkl(l0,4)
c = mo_coef_transp(l,l1)
if (abs(c) < thr_coef) then
cycle
endif
j1 = ishft((l*l-l),-1)
do j0 = 1, n_j
j = list_ijkl(j0,2)
if (j > l) then
exit
endif
j1 += 1
do k0 = 1, n_k
k = list_ijkl(k0,3)
i1 = ishft((k*k-k),-1)
if (i1<=j1) then
continue
else
exit
endif
bielec_tmp_1 = 0.d0
do i0 = 1, n_i
i = list_ijkl(i0,1)
if (i>k) then
exit
endif
bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0)
! i1+=1
enddo
do i0 = 1, n_i
i = list_ijkl(i0,1)
if(i> min(k,j1-i1+list_ijkl(1,1)-1))then
exit
endif
if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then
cycle
endif
n_integrals += 1
buffer_value(n_integrals) = bielec_tmp_1(i)
!DEC$ FORCEINLINE
call mo_bielec_integrals_erf_index(i,j,k,l,buffer_i(n_integrals))
if (n_integrals == size_buffer) then
call insert_into_mo_integrals_erf_map(n_integrals,buffer_i,buffer_value,&
real(mo_integrals_threshold,integral_kind))
n_integrals = 0
endif
enddo
enddo
enddo
enddo
call wall_time(wall_2)
if (thread_num == 0) then
if (wall_2 - wall_0 > 1.d0) then
wall_0 = wall_2
print*, 100.*float(l1)/float(ao_num), '% in ', &
wall_2-wall_1, 's', map_mb(mo_integrals_erf_map) ,'MB'
endif
endif
enddo
!$OMP END DO NOWAIT
deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3)
integer :: index_needed
call insert_into_mo_integrals_erf_map(n_integrals,buffer_i,buffer_value,&
real(mo_integrals_threshold,integral_kind))
deallocate(buffer_i, buffer_value)
!$OMP END PARALLEL
call map_unique(mo_integrals_erf_map)
call wall_time(wall_2)
call cpu_time(cpu_2)
integer*8 :: get_mo_erf_map_size, mo_erf_map_size
mo_erf_map_size = get_mo_erf_map_size()
deallocate(list_ijkl)
print*,'Molecular integrals provided:'
print*,' Size of MO map ', map_mb(mo_integrals_erf_map) ,'MB'
print*,' Number of MO integrals: ', mo_erf_map_size
print*,' cpu time :',cpu_2 - cpu_1, 's'
print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')'
end
BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_from_ao, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_exchange_from_ao, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_anti_from_ao, (mo_tot_num_align,mo_tot_num) ]
BEGIN_DOC
! mo_bielec_integral_jj_from_ao(i,j) = J_ij
! mo_bielec_integral_jj_exchange_from_ao(i,j) = J_ij
! mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij
END_DOC
implicit none
integer :: i,j,p,q,r,s
double precision :: c
real(integral_kind) :: integral
integer :: n, pp
real(integral_kind), allocatable :: int_value(:)
integer, allocatable :: int_idx(:)
double precision, allocatable :: iqrs(:,:), iqsr(:,:), iqis(:), iqri(:)
if (.not.do_direct_integrals) then
PROVIDE ao_bielec_integrals_erf_in_map mo_coef
endif
mo_bielec_integral_erf_jj_from_ao = 0.d0
mo_bielec_integral_erf_jj_exchange_from_ao = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: iqrs, iqsr
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE (i,j,p,q,r,s,integral,c,n,pp,int_value,int_idx, &
!$OMP iqrs, iqsr,iqri,iqis) &
!$OMP SHARED(mo_tot_num,mo_coef_transp,mo_tot_num_align,ao_num,&
!$OMP ao_integrals_threshold,do_direct_integrals) &
!$OMP REDUCTION(+:mo_bielec_integral_erf_jj_from_ao,mo_bielec_integral_erf_jj_exchange_from_ao)
allocate( int_value(ao_num), int_idx(ao_num), &
iqrs(mo_tot_num_align,ao_num), iqis(mo_tot_num), iqri(mo_tot_num),&
iqsr(mo_tot_num_align,ao_num) )
!$OMP DO SCHEDULE (guided)
do s=1,ao_num
do q=1,ao_num
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,mo_tot_num
iqrs(i,j) = 0.d0
iqsr(i,j) = 0.d0
enddo
enddo
if (do_direct_integrals) then
double precision :: ao_bielec_integral_erf
do r=1,ao_num
call compute_ao_bielec_integrals_erf(q,r,s,ao_num,int_value)
do p=1,ao_num
integral = int_value(p)
if (abs(integral) > ao_integrals_threshold) then
!DIR$ VECTOR ALIGNED
do i=1,mo_tot_num
iqrs(i,r) += mo_coef_transp(i,p) * integral
enddo
endif
enddo
call compute_ao_bielec_integrals_erf(q,s,r,ao_num,int_value)
do p=1,ao_num
integral = int_value(p)
if (abs(integral) > ao_integrals_threshold) then
!DIR$ VECTOR ALIGNED
do i=1,mo_tot_num
iqsr(i,r) += mo_coef_transp(i,p) * integral
enddo
endif
enddo
enddo
else
do r=1,ao_num
call get_ao_bielec_integrals_erf_non_zero(q,r,s,ao_num,int_value,int_idx,n)
do pp=1,n
p = int_idx(pp)
integral = int_value(pp)
if (abs(integral) > ao_integrals_threshold) then
!DIR$ VECTOR ALIGNED
do i=1,mo_tot_num
iqrs(i,r) += mo_coef_transp(i,p) * integral
enddo
endif
enddo
call get_ao_bielec_integrals_erf_non_zero(q,s,r,ao_num,int_value,int_idx,n)
do pp=1,n
p = int_idx(pp)
integral = int_value(pp)
if (abs(integral) > ao_integrals_threshold) then
!DIR$ VECTOR ALIGNED
do i=1,mo_tot_num
iqsr(i,r) += mo_coef_transp(i,p) * integral
enddo
endif
enddo
enddo
endif
iqis = 0.d0
iqri = 0.d0
do r=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,mo_tot_num
iqis(i) += mo_coef_transp(i,r) * iqrs(i,r)
iqri(i) += mo_coef_transp(i,r) * iqsr(i,r)
enddo
enddo
do i=1,mo_tot_num
!DIR$ VECTOR ALIGNED
do j=1,mo_tot_num
c = mo_coef_transp(j,q)*mo_coef_transp(j,s)
mo_bielec_integral_erf_jj_from_ao(j,i) += c * iqis(i)
mo_bielec_integral_erf_jj_exchange_from_ao(j,i) += c * iqri(i)
enddo
enddo
enddo
enddo
!$OMP END DO NOWAIT
deallocate(iqrs,iqsr,int_value,int_idx)
!$OMP END PARALLEL
mo_bielec_integral_erf_jj_anti_from_ao = mo_bielec_integral_erf_jj_from_ao - mo_bielec_integral_erf_jj_exchange_from_ao
! end
END_PROVIDER
BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_exchange, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_anti, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! mo_bielec_integral_jj(i,j) = J_ij
! mo_bielec_integral_jj_exchange(i,j) = K_ij
! mo_bielec_integral_jj_anti(i,j) = J_ij - K_ij
END_DOC
integer :: i,j
double precision :: get_mo_bielec_integral_erf
PROVIDE mo_bielec_integrals_erf_in_map
mo_bielec_integral_erf_jj = 0.d0
mo_bielec_integral_erf_jj_exchange = 0.d0
do j=1,mo_tot_num
do i=1,mo_tot_num
mo_bielec_integral_erf_jj(i,j) = get_mo_bielec_integral_erf(i,j,i,j,mo_integrals_erf_map)
mo_bielec_integral_erf_jj_exchange(i,j) = get_mo_bielec_integral_erf(i,j,j,i,mo_integrals_erf_map)
mo_bielec_integral_erf_jj_anti(i,j) = mo_bielec_integral_erf_jj(i,j) - mo_bielec_integral_erf_jj_exchange(i,j)
enddo
enddo
END_PROVIDER
subroutine clear_mo_erf_map
implicit none
BEGIN_DOC
! Frees the memory of the MO map
END_DOC
call map_deinit(mo_integrals_erf_map)
FREE mo_integrals_erf_map mo_bielec_integral_erf_jj mo_bielec_integral_erf_jj_anti
FREE mo_bielec_integral_Erf_jj_exchange mo_bielec_integrals_erf_in_map
end
subroutine provide_all_mo_integrals_erf
implicit none
provide mo_integrals_erf_map mo_bielec_integral_erf_jj mo_bielec_integral_erf_jj_anti
provide mo_bielec_integral_erf_jj_exchange mo_bielec_integrals_erf_in_map
end

119
plugins/Integrals_erf/providers_ao_erf.irp.f Normal file
View File

@ -0,0 +1,119 @@
BEGIN_PROVIDER [ logical, ao_bielec_integrals_erf_in_map ]
implicit none
use f77_zmq
use map_module
BEGIN_DOC
! Map of Atomic integrals
! i(r1) j(r2) 1/r12 k(r1) l(r2)
END_DOC
integer :: i,j,k,l
double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2
double precision :: integral, wall_0
include 'Utils/constants.include.F'
! For integrals file
integer(key_kind),allocatable :: buffer_i(:)
integer,parameter :: size_buffer = 1024*64
real(integral_kind),allocatable :: buffer_value(:)
integer :: n_integrals, rc
integer :: kk, m, j1, i1, lmax
character*(64) :: fmt
integral = ao_bielec_integral_erf(1,1,1,1)
real :: map_mb
PROVIDE read_ao_integrals_erf disk_access_ao_integrals_erf
if (read_ao_integrals_erf) then
print*,'Reading the AO integrals_erf'
call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map)
print*, 'AO integrals_erf provided'
ao_bielec_integrals_erf_in_map = .True.
return
endif
print*, 'Providing the AO integrals_erf'
call wall_time(wall_0)
call wall_time(wall_1)
call cpu_time(cpu_1)
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals_erf')
character(len=:), allocatable :: task
allocate(character(len=ao_num*12) :: task)
write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))'
do l=1,ao_num
write(task,fmt) (i,l, i=1,l)
call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task))
enddo
deallocate(task)
call zmq_set_running(zmq_to_qp_run_socket)
PROVIDE nproc
!$OMP PARALLEL DEFAULT(private) num_threads(nproc+1)
i = omp_get_thread_num()
if (i==0) then
call ao_bielec_integrals_erf_in_map_collector(i)
else
call ao_bielec_integrals_erf_in_map_slave_inproc(i)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, 'ao_integrals_erf')
print*, 'Sorting the map'
call map_sort(ao_integrals_erf_map)
call cpu_time(cpu_2)
call wall_time(wall_2)
integer(map_size_kind) :: get_ao_erf_map_size, ao_erf_map_size
ao_erf_map_size = get_ao_erf_map_size()
print*, 'AO integrals provided:'
print*, ' Size of AO map : ', map_mb(ao_integrals_erf_map) ,'MB'
print*, ' Number of AO integrals :', ao_erf_map_size
print*, ' cpu time :',cpu_2 - cpu_1, 's'
print*, ' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )'
ao_bielec_integrals_erf_in_map = .True.
if (write_ao_integrals_erf) then
call ezfio_set_work_empty(.False.)
call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map)
call ezfio_set_integrals_erf_disk_access_ao_integrals_erf("Read")
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_bielec_integral_erf_schwartz,(ao_num,ao_num) ]
implicit none
BEGIN_DOC
! Needed to compute Schwartz inequalities
END_DOC
integer :: i,k
double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2
ao_bielec_integral_erf_schwartz(1,1) = ao_bielec_integral_erf(1,1,1,1)
!$OMP PARALLEL DO PRIVATE(i,k) &
!$OMP DEFAULT(NONE) &
!$OMP SHARED (ao_num,ao_bielec_integral_erf_schwartz) &
!$OMP SCHEDULE(dynamic)
do i=1,ao_num
do k=1,i
ao_bielec_integral_erf_schwartz(i,k) = dsqrt(ao_bielec_integral_erf(i,k,i,k))
ao_bielec_integral_erf_schwartz(k,i) = ao_bielec_integral_erf_schwartz(i,k)
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER

32
plugins/Integrals_erf/qp_ao_erf_ints.irp.f Normal file
View File

@ -0,0 +1,32 @@
program qp_ao_ints
use omp_lib
implicit none
BEGIN_DOC
! Increments a running calculation to compute AO integral_erfs
END_DOC
integer :: i
call switch_qp_run_to_master
zmq_context = f77_zmq_ctx_new ()
! Set the state of the ZMQ
zmq_state = 'ao_integral_erfs'
! Provide everything needed
double precision :: integral_erf, ao_bielec_integral_erf
integral_erf = ao_bielec_integral_erf(1,1,1,1)
character*(64) :: state
call wait_for_state(zmq_state,state)
do while (state /= 'Stopped')
!$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i)
i = omp_get_thread_num()
call ao_bielec_integrals_erf_in_map_slave_tcp(i)
!$OMP END PARALLEL
call wait_for_state(zmq_state,state)
enddo
print *, 'Done'
end

47
plugins/Integrals_erf/read_write.irp.f Normal file
View File

@ -0,0 +1,47 @@
BEGIN_PROVIDER [ logical, read_ao_integrals_erf ]
&BEGIN_PROVIDER [ logical, read_mo_integrals_erf ]
&BEGIN_PROVIDER [ logical, write_ao_integrals_erf ]
&BEGIN_PROVIDER [ logical, write_mo_integrals_erf ]
BEGIN_DOC
! One level of abstraction for disk_access_ao_integrals_erf and disk_access_mo_integrals_erf
END_DOC
implicit none
if (disk_access_ao_integrals_erf.EQ.'Read') then
read_ao_integrals_erf = .True.
write_ao_integrals_erf = .False.
else if (disk_access_ao_integrals_erf.EQ.'Write') then
read_ao_integrals_erf = .False.
write_ao_integrals_erf = .True.
else if (disk_access_ao_integrals_erf.EQ.'None') then
read_ao_integrals_erf = .False.
write_ao_integrals_erf = .False.
else
print *, 'bielec_integrals_erf/disk_access_ao_integrals_erf has a wrong type'
stop 1
endif
if (disk_access_mo_integrals_erf.EQ.'Read') then
read_mo_integrals_erf = .True.
write_mo_integrals_erf = .False.
else if (disk_access_mo_integrals_erf.EQ.'Write') then
read_mo_integrals_erf = .False.
write_mo_integrals_erf = .True.
else if (disk_access_mo_integrals_erf.EQ.'None') then
read_mo_integrals_erf = .False.
write_mo_integrals_erf = .False.
else
print *, 'bielec_integrals_erf/disk_access_mo_integrals_erf has a wrong type'
stop 1
endif
END_PROVIDER

1
plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Integrals_Monoelec Integrals_erf Determinants DFT_Utils

12
plugins/Integrals_restart_DFT/README.rst Normal file
View File

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

79
plugins/Integrals_restart_DFT/short_range_coulomb.irp.f Normal file
View File

@ -0,0 +1,79 @@
BEGIN_PROVIDER [double precision, density_matrix_read, (mo_tot_num, mo_tot_num)]
implicit none
integer :: i,j,k,l
logical :: exists
call ezfio_has_determinants_density_matrix_mo_disk(exists)
if(exists)then
print*, 'reading the density matrix from input'
call ezfio_get_determinants_density_matrix_mo_disk(exists)
print*, 'reading done'
else
print*, 'no density matrix found in EZFIO file ...'
print*, 'stopping ..'
stop
endif
END_PROVIDER
BEGIN_PROVIDER [double precision, effective_short_range_operator, (mo_tot_num,mo_tot_num)]
implicit none
integer :: i,j,k,l,m,n
double precision :: get_mo_bielec_integral,get_mo_bielec_integral_erf
double precision :: integral, integral_erf
effective_short_range_operator = 0.d0
do i = 1, mo_tot_num
do j = 1, mo_tot_num
if(dabs(one_body_dm_mo(i,j)).le.1.d-10)cycle
do k = 1, mo_tot_num
do l = 1, mo_tot_num
integral = get_mo_bielec_integral(i,k,j,l,mo_integrals_map)
! integral_erf = get_mo_bielec_integral_erf(i,k,j,l,mo_integrals_erf_map)
effective_short_range_operator(l,k) += one_body_dm_mo(i,j) * integral
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, effective_one_e_potential, (mo_tot_num_align, mo_tot_num,N_states)]
implicit none
integer :: i,j,i_state
effective_one_e_potential = 0.d0
do i_state = 1, N_states
do i = 1, mo_tot_num
do j = 1, mo_tot_num
effective_one_e_potential(i,j,i_state) = effective_short_range_operator(i,j) + mo_nucl_elec_integral(i,j) + mo_kinetic_integral(i,j) &
+ 0.5d0 * (lda_ex_potential_alpha_ao(i,j,i_state) + lda_ex_potential_beta_ao(i,j,i_state))
enddo
enddo
enddo
END_PROVIDER
subroutine save_one_e_effective_potential
implicit none
double precision, allocatable :: tmp(:,:)
allocate(tmp(size(effective_one_e_potential,1),size(effective_one_e_potential,2)))
integer :: i,j
do i = 1, mo_tot_num
do j = 1, mo_tot_num
tmp(i,j) = effective_one_e_potential(i,j,1)
enddo
enddo
call write_one_e_integrals('mo_one_integral', tmp, &
size(tmp,1), size(tmp,2))
call ezfio_set_integrals_monoelec_disk_access_only_mo_one_integrals("Read")
deallocate(tmp)
end
subroutine save_erf_bi_elec_integrals
implicit none
integer :: i,j,k,l
PROVIDE mo_bielec_integrals_erf_in_map
call ezfio_set_work_empty(.False.)
call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_erf_map)
call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read")
end

18
plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f Normal file
View File

@ -0,0 +1,18 @@
program write_integrals
implicit none
read_wf = .true.
touch read_wf
disk_access_only_mo_one_integrals = "None"
touch disk_access_only_mo_one_integrals
disk_access_mo_integrals = "None"
touch disk_access_mo_integrals
call routine
end
subroutine routine
implicit none
call save_one_e_effective_potential
call save_erf_bi_elec_integrals
end

54
plugins/Kohn_Sham/EZFIO.cfg Normal file
View File

@ -0,0 +1,54 @@
[thresh_scf]
type: Threshold
doc: Threshold on the convergence of the Hartree Fock energy
interface: ezfio,provider,ocaml
default: 1.e-10
[exchange_functional]
type: character*(256)
doc: name of the exchange functional
interface: ezfio, provider, ocaml
default: "LDA"
[correlation_functional]
type: character*(256)
doc: name of the correlation functional
interface: ezfio, provider, ocaml
default: "LDA"
[HF_exchange]
type: double precision
doc: Percentage of HF exchange in the DFT model
interface: ezfio,provider,ocaml
default: 0.
[n_it_scf_max]
type: Strictly_positive_int
doc: Maximum number of SCF iterations
interface: ezfio,provider,ocaml
default: 200
[level_shift]
type: Positive_float
doc: Energy shift on the virtual MOs to improve SCF convergence
interface: ezfio,provider,ocaml
default: 0.5
[mo_guess_type]
type: MO_guess
doc: Initial MO guess. Can be [ Huckel | HCore ]
interface: ezfio,provider,ocaml
default: Huckel
[energy]
type: double precision
doc: Calculated HF energy
interface: ezfio
[no_oa_or_av_opt]
type: logical
doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure
interface: ezfio,provider,ocaml
default: False

468
plugins/Kohn_Sham/Fock_matrix.irp.f Normal file
View File

@ -0,0 +1,468 @@
BEGIN_PROVIDER [ double precision, Fock_matrix_mo, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, Fock_matrix_diag_mo, (mo_tot_num)]
implicit none
BEGIN_DOC
! Fock matrix on the MO basis.
! For open shells, the ROHF Fock Matrix is
!
! | F-K | F + K/2 | F |
! |---------------------------------|
! | F + K/2 | F | F - K/2 |
! |---------------------------------|
! | F | F - K/2 | F + K |
!
! F = 1/2 (Fa + Fb)
!
! K = Fb - Fa
!
END_DOC
integer :: i,j,n
if (elec_alpha_num == elec_beta_num) then
Fock_matrix_mo = Fock_matrix_alpha_mo
else
do j=1,elec_beta_num
! F-K
do i=1,elec_beta_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
- (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F+K/2
do i=elec_beta_num+1,elec_alpha_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
+ 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F
do i=elec_alpha_num+1, mo_tot_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
enddo
enddo
do j=elec_beta_num+1,elec_alpha_num
! F+K/2
do i=1,elec_beta_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
+ 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F
do i=elec_beta_num+1,elec_alpha_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
enddo
! F-K/2
do i=elec_alpha_num+1, mo_tot_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
- 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
enddo
do j=elec_alpha_num+1, mo_tot_num
! F
do i=1,elec_beta_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
enddo
! F-K/2
do i=elec_beta_num+1,elec_alpha_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
- 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F+K
do i=elec_alpha_num+1,mo_tot_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) &
+ (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
enddo
endif
do i = 1, mo_tot_num
Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i)
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ]
&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao, (ao_num_align, ao_num) ]
implicit none
BEGIN_DOC
! Alpha Fock matrix in AO basis set
END_DOC
integer :: i,j
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,ao_num
Fock_matrix_alpha_ao(i,j) = Fock_matrix_alpha_no_xc_ao(i,j) + ao_potential_alpha_xc(i,j)
Fock_matrix_beta_ao (i,j) = Fock_matrix_beta_no_xc_ao(i,j) + ao_potential_beta_xc(i,j)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_no_xc_ao, (ao_num_align, ao_num) ]
&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_no_xc_ao, (ao_num_align, ao_num) ]
implicit none
BEGIN_DOC
! Mono electronic an Coulomb matrix in AO basis set
END_DOC
integer :: i,j
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,ao_num
Fock_matrix_alpha_no_xc_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j)
Fock_matrix_beta_no_xc_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_alpha, (ao_num_align, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_beta , (ao_num_align, ao_num) ]
use map_module
implicit none
BEGIN_DOC
! Alpha Fock matrix in AO basis set
END_DOC
integer :: i,j,k,l,k1,r,s
integer :: i0,j0,k0,l0
integer*8 :: p,q
double precision :: integral, c0, c1, c2
double precision :: ao_bielec_integral, local_threshold
double precision, allocatable :: ao_bi_elec_integral_alpha_tmp(:,:)
double precision, allocatable :: ao_bi_elec_integral_beta_tmp(:,:)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_alpha_tmp
ao_bi_elec_integral_alpha = 0.d0
ao_bi_elec_integral_beta = 0.d0
if (do_direct_integrals) then
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, &
!$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, &
!$OMP local_threshold)&
!$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,&
!$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, &
!$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta)
allocate(keys(1), values(1))
allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), &
ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num))
ao_bi_elec_integral_alpha_tmp = 0.d0
ao_bi_elec_integral_beta_tmp = 0.d0
q = ao_num*ao_num*ao_num*ao_num
!$OMP DO SCHEDULE(dynamic)
do p=1_8,q
call bielec_integrals_index_reverse(kk,ii,ll,jj,p)
if ( (kk(1)>ao_num).or. &
(ii(1)>ao_num).or. &
(jj(1)>ao_num).or. &
(ll(1)>ao_num) ) then
cycle
endif
k = kk(1)
i = ii(1)
l = ll(1)
j = jj(1)
if (ao_overlap_abs(k,l)*ao_overlap_abs(i,j) &
< ao_integrals_threshold) then
cycle
endif
local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j)
if (local_threshold < ao_integrals_threshold) then
cycle
endif
i0 = i
j0 = j
k0 = k
l0 = l
values(1) = 0.d0
local_threshold = ao_integrals_threshold/local_threshold
do k2=1,8
if (kk(k2)==0) then
cycle
endif
i = ii(k2)
j = jj(k2)
k = kk(k2)
l = ll(k2)
c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)
c1 = HF_density_matrix_ao_alpha(k,i)
c2 = HF_density_matrix_ao_beta(k,i)
if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then
cycle
endif
if (values(1) == 0.d0) then
values(1) = ao_bielec_integral(k0,l0,i0,j0)
endif
integral = c0 * values(1)
ao_bi_elec_integral_alpha_tmp(i,j) += integral
ao_bi_elec_integral_beta_tmp (i,j) += integral
integral = values(1)
ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral
ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp
!$OMP END CRITICAL
!$OMP CRITICAL
ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp
!$OMP END CRITICAL
deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)
!$OMP END PARALLEL
else
PROVIDE ao_bielec_integrals_in_map
integer(omp_lock_kind) :: lck(ao_num)
integer*8 :: i8
integer :: ii(8), jj(8), kk(8), ll(8), k2
integer(cache_map_size_kind) :: n_elements_max, n_elements
integer(key_kind), allocatable :: keys(:)
double precision, allocatable :: values(:)
! !$OMP PARALLEL DEFAULT(NONE) &
! !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,n_elements_max, &
! !$OMP n_elements,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)&
! !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,&
! !$OMP ao_integrals_map, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta,HF_exchange)
call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max)
allocate(keys(n_elements_max), values(n_elements_max))
allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), &
ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num))
ao_bi_elec_integral_alpha_tmp = 0.d0
ao_bi_elec_integral_beta_tmp = 0.d0
! !OMP DO SCHEDULE(dynamic)
! !DIR$ NOVECTOR
do i8=0_8,ao_integrals_map%map_size
n_elements = n_elements_max
call get_cache_map(ao_integrals_map,i8,keys,values,n_elements)
do k1=1,n_elements
call bielec_integrals_index_reverse(kk,ii,ll,jj,keys(k1))
do k2=1,8
if (kk(k2)==0) then
cycle
endif
i = ii(k2)
j = jj(k2)
k = kk(k2)
l = ll(k2)
integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(k1)
ao_bi_elec_integral_alpha_tmp(i,j) += integral
ao_bi_elec_integral_beta_tmp (i,j) += integral
integral = values(k1)
ao_bi_elec_integral_alpha_tmp(l,j) -= HF_exchange * (HF_density_matrix_ao_alpha(k,i) * integral)
ao_bi_elec_integral_beta_tmp (l,j) -= HF_exchange * (HF_density_matrix_ao_beta (k,i) * integral)
enddo
enddo
enddo
! !$OMP END DO NOWAIT
! !$OMP CRITICAL
ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp
! !$OMP END CRITICAL
! !$OMP CRITICAL
ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp
! !$OMP END CRITICAL
deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)
! !$OMP END PARALLEL
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Fock matrix on the MO basis
END_DOC
double precision, allocatable :: T(:,:)
allocate ( T(ao_num_align,mo_tot_num) )
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
call dgemm('N','N', ao_num, mo_tot_num, ao_num, &
1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1), &
mo_coef, size(mo_coef,1), &
0.d0, T, ao_num_align)
call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, &
1.d0, mo_coef,size(mo_coef,1), &
T, size(T,1), &
0.d0, Fock_matrix_alpha_mo, mo_tot_num_align)
deallocate(T)
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Fock matrix on the MO basis
END_DOC
double precision, allocatable :: T(:,:)
allocate ( T(ao_num_align,mo_tot_num) )
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
call dgemm('N','N', ao_num, mo_tot_num, ao_num, &
1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1), &
mo_coef, size(mo_coef,1), &
0.d0, T, ao_num_align)
call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, &
1.d0, mo_coef,size(mo_coef,1), &
T, size(T,1), &
0.d0, Fock_matrix_beta_mo, mo_tot_num_align)
deallocate(T)
END_PROVIDER
BEGIN_PROVIDER [ double precision, HF_energy ]
&BEGIN_PROVIDER [ double precision, two_electron_energy]
&BEGIN_PROVIDER [ double precision, one_electron_energy]
implicit none
BEGIN_DOC
! Hartree-Fock energy
END_DOC
HF_energy = nuclear_repulsion
integer :: i,j
double precision :: accu_mono,accu_fock
one_electron_energy = 0.d0
two_electron_energy = 0.d0
do j=1,ao_num
do i=1,ao_num
two_electron_energy += 0.5d0 * ( ao_bi_elec_integral_alpha(i,j) * HF_density_matrix_ao_alpha(i,j) &
+ao_bi_elec_integral_beta(i,j) * HF_density_matrix_ao_beta(i,j) )
one_electron_energy += ao_mono_elec_integral(i,j) * (HF_density_matrix_ao_alpha(i,j) + HF_density_matrix_ao_beta (i,j) )
enddo
enddo
print*, 'one_electron_energy = ',one_electron_energy
print*, 'two_electron_energy = ',two_electron_energy
print*, 'e_exchange_dft = ',(1.d0 - HF_exchange) * e_exchange_dft
!print*, 'accu_cor = ',e_correlation_dft
HF_energy += (1.d0 - HF_exchange) * e_exchange_dft + e_correlation_dft + one_electron_energy + two_electron_energy
!print*, 'HF_energy '
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ]
implicit none
BEGIN_DOC
! Fock matrix in AO basis set
END_DOC
if ( (elec_alpha_num == elec_beta_num).and. &
(level_shift == 0.) ) &
then
integer :: i,j
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,ao_num_align
Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j)
enddo
enddo
else
double precision, allocatable :: T(:,:), M(:,:)
integer :: ierr
! F_ao = S C F_mo C^t S
allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr)
if (ierr /=0 ) then
print *, irp_here, ' : allocation failed'
endif
! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num)
! -> M(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, &
ao_overlap, size(ao_overlap,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num)
! -> T(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, &
M, size(M,1), &
Fock_matrix_mo, size(Fock_matrix_mo,1), &
0.d0, &
T, size(T,1))
! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num)
! -> M(ao_num,ao_num)
call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, &
T, size(T,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num)
! -> Fock_matrix_ao(ao_num,ao_num)
call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, &
M, size(M,1), &
ao_overlap, size(ao_overlap,1), &
0.d0, &
Fock_matrix_ao, size(Fock_matrix_ao,1))
deallocate(T)
endif
END_PROVIDER
subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO)
implicit none
integer, intent(in) :: LDFMO ! size(FMO,1)
integer, intent(in) :: LDFAO ! size(FAO,1)
double precision, intent(in) :: FMO(LDFMO,*)
double precision, intent(out) :: FAO(LDFAO,*)
double precision, allocatable :: T(:,:), M(:,:)
integer :: ierr
! F_ao = S C F_mo C^t S
allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr)
if (ierr /=0 ) then
print *, irp_here, ' : allocation failed'
endif
! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num)
! -> M(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, &
ao_overlap, size(ao_overlap,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num)
! -> T(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, &
M, size(M,1), &
FMO, size(FMO,1), &
0.d0, &
T, size(T,1))
! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num)
! -> M(ao_num,ao_num)
call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, &
T, size(T,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num)
! -> Fock_matrix_ao(ao_num,ao_num)
call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, &
M, size(M,1), &
ao_overlap, size(ao_overlap,1), &
0.d0, &
FAO, size(FAO,1))
deallocate(T,M)
end

41
plugins/Kohn_Sham/HF_density_matrix_ao.irp.f Normal file
View File

@ -0,0 +1,41 @@
BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ]
implicit none
BEGIN_DOC
! S^-1 x Alpha density matrix in the AO basis x S^-1
END_DOC
call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, &
mo_coef, size(mo_coef,1), &
mo_coef, size(mo_coef,1), 0.d0, &
HF_density_matrix_ao_alpha, size(HF_density_matrix_ao_alpha,1))
END_PROVIDER
BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_beta, (ao_num_align,ao_num) ]
implicit none
BEGIN_DOC
! S^-1 Beta density matrix in the AO basis x S^-1
END_DOC
call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, &
mo_coef, size(mo_coef,1), &
mo_coef, size(mo_coef,1), 0.d0, &
HF_density_matrix_ao_beta, size(HF_density_matrix_ao_beta,1))
END_PROVIDER
BEGIN_PROVIDER [ double precision, HF_density_matrix_ao, (ao_num_align,ao_num) ]
implicit none
BEGIN_DOC
! S^-1 Density matrix in the AO basis S^-1
END_DOC
ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_alpha,1))
if (elec_alpha_num== elec_beta_num) then
HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_alpha
else
ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_beta ,1))
HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_beta
endif
END_PROVIDER

54
plugins/Kohn_Sham/KS_SCF.irp.f Normal file
View File

@ -0,0 +1,54 @@
program scf
BEGIN_DOC
! Produce `Hartree_Fock` MO orbital
! output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ
! output: hartree_fock.energy
! optional: mo_basis.mo_coef
END_DOC
call create_guess
call orthonormalize_mos
call run
end
subroutine create_guess
implicit none
BEGIN_DOC
! Create an MO guess if no MOs are present in the EZFIO directory
END_DOC
logical :: exists
PROVIDE ezfio_filename
call ezfio_has_mo_basis_mo_coef(exists)
if (.not.exists) then
if (mo_guess_type == "HCore") then
mo_coef = ao_ortho_lowdin_coef
TOUCH mo_coef
mo_label = 'Guess'
call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral,size(mo_mono_elec_integral,1),size(mo_mono_elec_integral,2),mo_label)
SOFT_TOUCH mo_coef mo_label
else if (mo_guess_type == "Huckel") then
call huckel_guess
else
print *, 'Unrecognized MO guess type : '//mo_guess_type
stop 1
endif
endif
end
subroutine run
use bitmasks
implicit none
BEGIN_DOC
! Run SCF calculation
END_DOC
double precision :: SCF_energy_before,SCF_energy_after,diag_H_mat_elem
double precision :: E0
integer :: i_it, i, j, k
E0 = HF_energy
mo_label = "Canonical"
call damping_SCF
end

1
plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Integrals_Bielec MOGuess Bitmask DFT_Utils

132
plugins/Kohn_Sham/damping_SCF.irp.f Normal file
View File

@ -0,0 +1,132 @@
subroutine damping_SCF
implicit none
double precision :: E
double precision, allocatable :: D_alpha(:,:), D_beta(:,:)
double precision :: E_new
double precision, allocatable :: D_new_alpha(:,:), D_new_beta(:,:), F_new(:,:)
double precision, allocatable :: delta_alpha(:,:), delta_beta(:,:)
double precision :: lambda, E_half, a, b, delta_D, delta_E, E_min
integer :: i,j,k
logical :: saving
character :: save_char
allocate( &
D_alpha( ao_num_align, ao_num ), &
D_beta( ao_num_align, ao_num ), &
F_new( ao_num_align, ao_num ), &
D_new_alpha( ao_num_align, ao_num ), &
D_new_beta( ao_num_align, ao_num ), &
delta_alpha( ao_num_align, ao_num ), &
delta_beta( ao_num_align, ao_num ))
do j=1,ao_num
do i=1,ao_num
D_alpha(i,j) = HF_density_matrix_ao_alpha(i,j)
D_beta (i,j) = HF_density_matrix_ao_beta (i,j)
enddo
enddo
call write_time(output_hartree_fock)
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
'====','================','================','================', '===='
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save'
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
'====','================','================','================', '===='
E = HF_energy + 1.d0
E_min = HF_energy
delta_D = 0.d0
do k=1,n_it_scf_max
delta_E = HF_energy - E
E = HF_energy
if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then
exit
endif
saving = E < E_min
if (saving) then
call save_mos
save_char = 'X'
E_min = E
else
save_char = ' '
endif
write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') &
k, E, delta_E, delta_D, save_char
D_alpha = HF_density_matrix_ao_alpha
D_beta = HF_density_matrix_ao_beta
mo_coef = eigenvectors_fock_matrix_mo
TOUCH mo_coef
D_new_alpha = HF_density_matrix_ao_alpha
D_new_beta = HF_density_matrix_ao_beta
F_new = Fock_matrix_ao
E_new = HF_energy
delta_alpha = D_new_alpha - D_alpha
delta_beta = D_new_beta - D_beta
lambda = .5d0
E_half = 0.d0
do while (E_half > E)
HF_density_matrix_ao_alpha = D_alpha + lambda * delta_alpha
HF_density_matrix_ao_beta = D_beta + lambda * delta_beta
TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta
mo_coef = eigenvectors_fock_matrix_mo
TOUCH mo_coef
E_half = HF_energy
if ((E_half > E).and.(E_new < E)) then
lambda = 1.d0
exit
else if ((E_half > E).and.(lambda > 5.d-4)) then
lambda = 0.5d0 * lambda
E_new = E_half
else
exit
endif
enddo
a = (E_new + E - 2.d0*E_half)*2.d0
b = -E_new - 3.d0*E + 4.d0*E_half
lambda = -lambda*b/(a+1.d-16)
D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha
D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta
delta_E = HF_energy - E
do j=1,ao_num
do i=1,ao_num
delta_D = delta_D + &
(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j))*(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j)) + &
(D_beta (i,j) - HF_density_matrix_ao_beta (i,j))*(D_beta (i,j) - HF_density_matrix_ao_beta (i,j))
enddo
enddo
delta_D = dsqrt(delta_D/dble(ao_num)**2)
HF_density_matrix_ao_alpha = D_alpha
HF_density_matrix_ao_beta = D_beta
TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta
mo_coef = eigenvectors_fock_matrix_mo
TOUCH mo_coef
enddo
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '===='
write(output_hartree_fock,*)
if(.not.no_oa_or_av_opt)then
call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1)
endif
call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy')
call ezfio_set_hartree_fock_energy(E_min)
call write_time(output_hartree_fock)
deallocate(D_alpha,D_beta,F_new,D_new_alpha,D_new_beta,delta_alpha,delta_beta)
end

119
plugins/Kohn_Sham/diagonalize_fock.irp.f Normal file
View File

@ -0,0 +1,119 @@
BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ]
&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Diagonal Fock matrix in the MO basis
END_DOC
integer :: i,j
integer :: liwork, lwork, n, info
integer, allocatable :: iwork(:)
double precision, allocatable :: work(:), F(:,:), S(:,:)
allocate( F(mo_tot_num_align,mo_tot_num) )
do j=1,mo_tot_num
do i=1,mo_tot_num
F(i,j) = Fock_matrix_mo(i,j)
enddo
enddo
if(no_oa_or_av_opt)then
integer :: iorb,jorb
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_inact_orb
jorb = list_inact(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
do j = 1, n_virt_orb
jorb = list_virt(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
do j = 1, n_core_orb
jorb = list_core(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
enddo
endif
! Insert level shift here
do i = elec_beta_num+1, elec_alpha_num
F(i,i) += 0.5d0*level_shift
enddo
do i = elec_alpha_num+1, mo_tot_num
F(i,i) += level_shift
enddo
n = mo_tot_num
lwork = 1+6*n + 2*n*n
liwork = 3 + 5*n
allocate(work(lwork), iwork(liwork) )
lwork = -1
liwork = -1
call dsyevd( 'V', 'U', mo_tot_num, F, &
size(F,1), diagonal_Fock_matrix_mo, &
work, lwork, iwork, liwork, info)
if (info /= 0) then
print *, irp_here//' failed : ', info
stop 1
endif
lwork = int(work(1))
liwork = iwork(1)
deallocate(work,iwork)
allocate(work(lwork), iwork(liwork) )
call dsyevd( 'V', 'U', mo_tot_num, F, &
size(F,1), diagonal_Fock_matrix_mo, &
work, lwork, iwork, liwork, info)
if (info /= 0) then
print *, irp_here//' failed : ', info
stop 1
endif
call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, &
mo_coef, size(mo_coef,1), F, size(F,1), &
0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1))
deallocate(work, iwork, F)
! endif
END_PROVIDER
BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)]
implicit none
BEGIN_DOC
! diagonal element of the fock matrix calculated as the sum over all the interactions
! with all the electrons in the RHF determinant
! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij
END_DOC
integer :: i,j
double precision :: accu
do j = 1,elec_alpha_num
accu = 0.d0
do i = 1, elec_alpha_num
accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
enddo
diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
enddo
do j = elec_alpha_num+1,mo_tot_num
accu = 0.d0
do i = 1, elec_alpha_num
accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
enddo
diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
enddo
END_PROVIDER

31
plugins/Kohn_Sham/potential_functional.irp.f Normal file
View File

@ -0,0 +1,31 @@
BEGIN_PROVIDER [double precision, ao_potential_alpha_xc, (ao_num_align, ao_num)]
&BEGIN_PROVIDER [double precision, ao_potential_beta_xc, (ao_num_align, ao_num)]
implicit none
integer :: i,j,k,l
ao_potential_alpha_xc = 0.d0
ao_potential_beta_xc = 0.d0
!if(exchange_functional == "LDA")then
do i = 1, ao_num
do j = 1, ao_num
ao_potential_alpha_xc(i,j) = (1.d0 - HF_exchange) * lda_ex_potential_alpha_ao(i,j,1)
ao_potential_beta_xc(i,j) = (1.d0 - HF_exchange) * lda_ex_potential_beta_ao(i,j,1)
enddo
enddo
!endif
END_PROVIDER
BEGIN_PROVIDER [double precision, e_exchange_dft]
implicit none
!if(exchange_functional == "LDA")then
e_exchange_dft = lda_exchange(1)
!endif
END_PROVIDER
BEGIN_PROVIDER [double precision, e_correlation_dft]
implicit none
!if(correlation_functional == "LDA")then
e_correlation_dft = 0.d0
!endif
END_PROVIDER

2
plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS
Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS MRPT_Utils

5
plugins/MRCC_Utils/amplitudes.irp.f
View File

@ -122,6 +122,7 @@ END_PROVIDER
logical :: ok
integer, external :: searchDet
PROVIDE psi_non_ref_sorted_idx psi_ref_coef
!$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int,&
!$OMP active_excitation_to_determinants_val, active_excitation_to_determinants_idx)&
@ -158,6 +159,7 @@ END_PROVIDER
wk += 1
do s=1,N_states
active_excitation_to_determinants_val(s,wk, ppp) = psi_ref_coef(lref(i), s)
enddo
active_excitation_to_determinants_idx(wk, ppp) = i
else if(lref(i) < 0) then
@ -190,7 +192,7 @@ END_PROVIDER
double precision, allocatable :: t(:), A_val_mwen(:,:), As2_val_mwen(:,:)
integer, allocatable :: A_ind_mwen(:)
double precision :: sij
PROVIDE psi_non_ref
PROVIDE psi_non_ref active_excitation_to_determinants_val
mrcc_AtA_ind(:) = 0
mrcc_AtA_val(:,:) = 0.d0
@ -198,7 +200,6 @@ END_PROVIDER
mrcc_N_col(:) = 0
AtA_size = 0
!$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,&
!$OMP active_excitation_to_determinants_val, hh_nex) &
!$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen,&

55
plugins/MRCC_Utils/mrcc_utils.irp.f
View File

@ -678,6 +678,53 @@ END_PROVIDER
call sort_det(psi_non_ref_sorted, psi_non_ref_sorted_idx, N_det_non_ref, N_int)
END_PROVIDER
BEGIN_PROVIDER [ double precision, rho_mrpt, (N_det_non_ref, N_states) ]
implicit none
integer :: i, j, k
double precision :: coef_mrpt(N_States),coef_array(N_states),hij,delta_e(N_states)
double precision :: hij_array(N_det_Ref),delta_e_array(N_det_ref,N_states)
integer :: number_of_holes, number_of_particles,nh,np
do i = 1, N_det_non_ref
print*,'i',i
nh = number_of_holes(psi_non_ref(1,1,i))
np = number_of_particles(psi_non_ref(1,1,i))
do j = 1, N_det_ref
do k = 1, N_States
coef_array(k) = psi_ref_coef(j,k)
enddo
call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,i), N_int, Hij_array(j))
call get_delta_e_dyall(psi_ref(1,1,j),psi_non_ref(1,1,i),coef_array,hij_array(j),delta_e)
! write(*,'(A7,x,100(F16.10,x))')'delta_e',delta_e(:)
do k = 1, N_states
delta_e_Array(j,k) = delta_e(k)
enddo
enddo
coef_mrpt = 0.d0
do k = 1, N_states
do j = 1, N_det_Ref
coef_mrpt(k) += psi_ref_coef(j,k) * hij_array(j) / delta_e_array(j,k)
enddo
enddo
write(*,'(A7,X,100(F16.10,x))')'coef ',psi_non_ref_coef(i,1) , coef_mrpt(1),psi_non_ref_coef(i,2) , coef_mrpt(2)
print*, nh,np
do k = 1, N_States
if(dabs(coef_mrpt(k)) .le.1.d-10)then
rho_mrpt(i,k) = 0.d0
exit
endif
if(psi_non_ref_coef(i,k) / coef_mrpt(k) .lt.0d0)then
rho_mrpt(i,k) = 1.d0
else
rho_mrpt(i,k) = psi_non_ref_coef(i,k) / coef_mrpt(k)
endif
enddo
print*,'rho',rho_mrpt(i,:)
write(33,*)i,rho_mrpt(i,:)
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ]
&BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ]
@ -957,7 +1004,7 @@ END_PROVIDER
double precision function get_dij_index(II, i, s, Nint)
integer, intent(in) :: II, i, s, Nint
double precision, external :: get_dij
double precision :: HIi, phase
double precision :: HIi, phase,delta_e_final(N_states)
if(lambda_type == 0) then
call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int)
@ -969,7 +1016,11 @@ double precision function get_dij_index(II, i, s, Nint)
else if(lambda_type == 2) then
call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int)
get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase
get_dij_index = get_dij_index * rho_mrcc(i,s)
get_dij_index = get_dij_index
else if(lambda_type == 3) then
call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi)
call get_delta_e_dyall(psi_ref(1,1,II),psi_non_ref(1,1,i),delta_e_final)
get_dij_index = HIi * rho_mrpt(i, s) / delta_e_final(s)
end if
end function

46
plugins/MRPT/MRPT_Utils.main.irp.f
View File

@ -10,34 +10,42 @@ end
subroutine routine_3
implicit none
integer :: i,j
!provide fock_virt_total_spin_trace
provide delta_ij
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
print *, 'PT2 = ', second_order_pt_new(1)
print *, 'E = ', CI_energy(1)
print *, 'E+PT2 = ', CI_energy(1)+second_order_pt_new(1)
print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******'
print *, 'E dressed= ', CI_dressed_pt2_new_energy(1)
do i = 1, N_States
print*,'State',i
write(*,'(A12,X,I3,A3,XX,F20.16)') ' PT2 ', i,' = ', second_order_pt_new(i)
write(*,'(A12,X,I3,A3,XX,F22.16)') ' E ', i,' = ', psi_ref_average_value(i)
write(*,'(A12,X,I3,A3,XX,F22.16)') ' E+PT2 ', i,' = ', psi_ref_average_value(i)+second_order_pt_new(i)
write(*,'(A12,X,I3,A3,XX,F22.16)') ' E dressed ', i,' = ', CI_dressed_pt2_new_energy(i)
write(*,'(A12,X,I3,A3,XX,F20.16)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i)
print*,'coef before and after'
do j = 1, N_det_ref
print*,psi_ref_coef(j,i),CI_dressed_pt2_new_eigenvectors(j,i)
enddo
enddo
if(save_heff_eigenvectors)then
call save_wavefunction_general(N_det_ref,N_states,psi_ref,N_det_ref,CI_dressed_pt2_new_eigenvectors)
endif
if(N_states.gt.1)then
print*, 'Energy differences : E(i) - E(0)'
do i = 2, N_States
print*,'State',i
write(*,'(A12,X,I3,A3,XX,F20.16)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i)
write(*,'(A12,X,I3,A3,XX,F20.16)') 'Variational ', i,' = ', -(psi_ref_average_value(1) - psi_ref_average_value(i))
write(*,'(A12,X,I3,A3,XX,F20.16)') 'Perturbative', i,' = ', -(psi_ref_average_value(1)+second_order_pt_new(1) - (psi_ref_average_value(i)+second_order_pt_new(i)))
write(*,'(A12,X,I3,A3,XX,F20.16)') 'Dressed ', i,' = ', -( CI_dressed_pt2_new_energy(1) - CI_dressed_pt2_new_energy(i) )
enddo
endif
end
subroutine routine_2
implicit none
integer :: i
do i = 1, n_core_inact_orb
print*,fock_core_inactive_total(i,1,1),fock_core_inactive(i)
enddo
double precision :: accu
accu = 0.d0
do i = 1, n_act_orb
integer :: j_act_orb
j_act_orb = list_act(i)
accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb,1)
print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb,1),one_body_dm_mo_beta(j_act_orb,j_act_orb,1)
enddo
print*,'accu = ',accu
provide electronic_psi_ref_average_value
end

2
plugins/MRPT/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
MRPT_Utils Selectors_full Generators_full
MRPT_Utils Selectors_full Psiref_CAS Generators_CAS

69
plugins/MRPT/print_1h2p.irp.f
View File

@ -7,45 +7,52 @@ end
subroutine routine
implicit none
double precision,allocatable :: matrix_1h2p(:,:,:)
allocate (matrix_1h2p(N_det,N_det,N_states))
integer :: i,j,istate
do i = 1, N_det
do j = 1, N_det
do istate = 1, N_states
matrix_1h2p(i,j,istate) = 0.d0
enddo
enddo
enddo
if(.False.)then
call give_1h2p_contrib(matrix_1h2p)
double precision :: accu
accu = 0.d0
do i = 1, N_det
do j = 1, N_det
accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1)
enddo
enddo
print*, 'second order ', accu
endif
provide one_anhil_one_creat_inact_virt
if(.True.)then
do i = 1, N_det
do j = 1, N_det
do istate = 1, N_states
matrix_1h2p(i,j,istate) = 0.d0
end
subroutine routine_2
implicit none
integer :: i,j,degree
double precision :: hij
do i =1, n_core_inact_orb
write(*,'(I3,x,100(F16.10,X))')list_core_inact(i),fock_core_inactive_total_spin_trace(list_core_inact(i),1)
enddo
print*,''
do i =1, n_virt_orb
write(*,'(I3,x,100(F16.10,X))')list_virt(i),fock_virt_total_spin_trace(list_virt(i),1)
enddo
stop
do i = 1, n_virt_orb
do j = 1, n_inact_orb
if(dabs(one_anhil_one_creat_inact_virt(j,i,1)) .lt. 1.d-10)cycle
write(*,'(I3,x,I3,X,100(F16.10,X))')list_virt(i),list_inact(j),one_anhil_one_creat_inact_virt(j,i,1)
enddo
enddo
enddo
call give_1h2p_new(matrix_1h2p)
end
subroutine routine_3
implicit none
double precision,allocatable :: matrix_1h2p(:,:,:)
double precision :: accu(2)
allocate (matrix_1h2p(N_det_ref,N_det_ref,N_states))
integer :: i,j,istate
accu = 0.d0
matrix_1h2p = 0.d0
!call H_apply_mrpt_1h2p(matrix_1h2p,N_det_ref)
call give_1h2p_contrib(matrix_1h2p)
do istate = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1)
accu(istate) += matrix_1h2p(i,j,istate) * psi_coef(i,istate) * psi_coef(j,istate)
enddo
enddo
endif
print*, 'third order ', accu
print*,accu(istate)
enddo
call contrib_1h2p_dm_based(accu)
print*,accu(:)
deallocate (matrix_1h2p)
end

7
plugins/MRPT_Utils/EZFIO.cfg
View File

@ -5,3 +5,10 @@ interface: ezfio,provider,ocaml
default: True
[save_heff_eigenvectors]
type: logical
doc: If true, save the eigenvectors of the dressed matrix at the end of the MRPT calculation
interface: ezfio,provider,ocaml
default: False

8
plugins/MRPT_Utils/H_apply.irp.f
View File

@ -23,6 +23,7 @@ print s
s = H_apply("mrpt_1h")
s.filter_only_1h()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -43,6 +44,7 @@ print s
s = H_apply("mrpt_1p")
s.filter_only_1p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -63,6 +65,7 @@ print s
s = H_apply("mrpt_1h1p")
s.filter_only_1h1p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -83,6 +86,7 @@ print s
s = H_apply("mrpt_2p")
s.filter_only_2p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -103,6 +107,7 @@ print s
s = H_apply("mrpt_2h")
s.filter_only_2h()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -124,6 +129,7 @@ print s
s = H_apply("mrpt_1h2p")
s.filter_only_1h2p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -144,6 +150,7 @@ print s
s = H_apply("mrpt_2h1p")
s.filter_only_2h1p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -164,6 +171,7 @@ print s
s = H_apply("mrpt_2h2p")
s.filter_only_2h2p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet

46
plugins/MRPT_Utils/MRMP2_density.irp.f Normal file
View File

@ -0,0 +1,46 @@
BEGIN_PROVIDER [double precision, MRMP2_density, (mo_tot_num_align, mo_tot_num)]
implicit none
integer :: i,j,k,l
double precision :: accu, mp2_dm(mo_tot_num)
MRMP2_density = one_body_dm_mo
call give_2h2p_density(mp2_dm)
accu = 0.d0
do i = 1, n_virt_orb
j = list_virt(i)
accu += mp2_dm(j)
MRMP2_density(j,j)+= mp2_dm(j)
enddo
END_PROVIDER
subroutine give_2h2p_density(mp2_density_diag_alpha_beta)
implicit none
double precision, intent(out) :: mp2_density_diag_alpha_beta(mo_tot_num)
integer :: i,j,k,l,m
integer :: iorb,jorb,korb,lorb
double precision :: get_mo_bielec_integral
double precision :: direct_int
double precision :: coef_double
mp2_density_diag_alpha_beta = 0.d0
do k = 1, n_virt_orb
korb = list_virt(k)
do i = 1, n_inact_orb
iorb = list_inact(i)
do j = 1, n_inact_orb
jorb = list_inact(j)
do l = 1, n_virt_orb
lorb = list_virt(l)
direct_int = get_mo_bielec_integral(iorb,jorb,korb,lorb ,mo_integrals_map)
coef_double = direct_int/(fock_core_inactive_total_spin_trace(iorb,1) + fock_core_inactive_total_spin_trace(jorb,1) &
-fock_virt_total_spin_trace(korb,1) - fock_virt_total_spin_trace(lorb,1))
mp2_density_diag_alpha_beta(korb) += coef_double * coef_double
enddo
enddo
enddo
print*, mp2_density_diag_alpha_beta(korb)
enddo
end

193
plugins/MRPT_Utils/density_matrix_based.irp.f Normal file
View File

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

760
plugins/MRPT_Utils/energies_cas.irp.f
View File

File diff suppressed because it is too large Load Diff

287
plugins/MRPT_Utils/excitations_cas.irp.f
View File

@ -25,6 +25,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, &
integer(bit_kind) :: det_tmp(N_int), det_tmp_bis(N_int)
double precision :: phase
double precision :: norm_factor
! print*, orb,hole_particle,spin_exc
elec_num_tab_local = 0
do i = 1, ndet
@ -36,6 +37,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, &
exit
endif
enddo
! print*, elec_num_tab_local(1),elec_num_tab_local(2)
if(hole_particle == 1)then
do i = 1, ndet
call set_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int)
@ -212,52 +214,97 @@ double precision function diag_H_mat_elem_no_elec_check(det_in,Nint)
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
end
!!!!!!!!!!!!
return
!!!!!!!!!!!!
double precision function diag_H_mat_elem_no_elec_check_no_spin(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_no_spin = 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, 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)
do i = 1, elec_num_tab_local(1)
iorb = occ(i,1)
diag_H_mat_elem_no_elec_check_no_spin += 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_no_spin += mo_bielec_integral_jj(jorb,iorb)
alpha_alpha += mo_bielec_integral_jj(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)
! beta - beta
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
diag_H_mat_elem_no_elec_check_no_spin += 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_no_spin += mo_bielec_integral_jj(jorb,iorb)
beta_beta += mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
do i = 1, n_core_inact_orb
iorb = list_core_inact(i)
! 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_spin += 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 += 1.d0 * mo_bielec_integral_jj(jorb,iorb)
diag_H_mat_elem_no_elec_check_no_spin += 2.d0 * mo_bielec_integral_jj(jorb,iorb)
core_act += 2.d0 * mo_bielec_integral_jj(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_spin += 2.d0 * mo_bielec_integral_jj(jorb,iorb)
core_act += 2.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
@ -389,6 +436,133 @@ subroutine i_H_j_dyall(key_i,key_j,Nint,hij)
end
subroutine i_H_j_dyall_no_spin(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
if(exc(1,1,1) == exc(1,1,2) .and. exc(1,1,2) == exc(1,2,1) )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)
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)
double precision :: diag_H_mat_elem_no_elec_check_no_spin
hij = diag_H_mat_elem_no_elec_check_no_spin(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
@ -414,6 +588,7 @@ subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coe
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)
! call i_H_j_dyall_no_spin(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
@ -502,6 +677,7 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij)
integer :: n_occ_ab(2)
logical :: has_mipi(Nint*bit_kind_size)
double precision :: mipi(Nint*bit_kind_size)
double precision :: diag_H_mat_elem
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
ASSERT (Nint > 0)
@ -598,9 +774,12 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij)
endif
hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) )
! hij = phase*(hij + mo_mono_elec_integral(m,p) )
case (0)
hij = diag_H_mat_elem_no_elec_check_no_exchange(key_i,Nint)
! hij = diag_H_mat_elem(key_i,Nint)
! hij = 0.d0
end select
end
@ -625,7 +804,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint)
! 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)
diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(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)
@ -635,7 +814,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint)
! 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)
diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(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)
@ -653,13 +832,16 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint)
enddo
! return
! 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)
! core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb)
! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(1)
enddo
enddo
@ -669,7 +851,8 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint)
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)
! core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb)
! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(2)
enddo
enddo
@ -706,3 +889,45 @@ subroutine u0_H_dyall_u0_no_exchange(energies,psi_in,psi_in_coef,ndet,dim_psi_in
energies(state_target) = accu
deallocate(psi_coef_tmp)
end
!subroutine u0_H_dyall_u0_no_exchange_bis(energies,psi_in,psi_in_active,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target)
subroutine u0_H_dyall_u0_no_exchange_bis(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),psi_in_active(N_int,2,dim_psi_in)
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,diag_H_mat_elem
do i = 1, ndet
if(psi_coef_tmp(i)==0.d0)cycle
do j = i+1, ndet
if(psi_coef_tmp(j)==0.d0)cycle
! call i_H_j_dyall_no_exchange(psi_in_active(1,1,i),psi_in_active(1,1,j),N_int,hij)
call i_H_j(psi_in(1,1,i),psi_in(1,1,j),N_int,hij)
accu += 2.d0 * psi_coef_tmp(i) * psi_coef_tmp(j) * hij
enddo
enddo
do i = 1, N_det
if(psi_coef_tmp(i)==0.d0)cycle
accu += psi_coef_tmp(i) * psi_coef_tmp(i) * diag_H_mat_elem(psi_in(1,1,i),N_int)
enddo
energies(state_target) = accu
deallocate(psi_coef_tmp)
end

117
plugins/MRPT_Utils/mrpt_dress.irp.f
View File

@ -44,11 +44,11 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip
integer :: N_miniList, leng
double precision :: delta_e(N_states),hij_tmp
integer :: index_i,index_j
double precision :: phase_array(N_det),phase
double precision :: phase_array(N_det_ref),phase
integer :: exc(0:2,2,2),degree
leng = max(N_det_generators, N_det)
leng = max(N_det_generators, N_det_generators)
allocate(miniList(Nint, 2, leng), idx_miniList(leng))
!create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint)
@ -59,35 +59,81 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip
end if
call find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
call find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
if(N_tq > 0) then
call create_minilist(key_mask, psi_det, miniList, idx_miniList, N_det, N_minilist, Nint)
call create_minilist(key_mask, psi_ref, miniList, idx_miniList, N_det_ref, N_minilist, Nint)
end if
double precision :: coef_array(N_states)
do i_alpha=1,N_tq
! do i = 1, N_det_ref
! do i_state = 1, N_states
! coef_array(i_state) = psi_ref_coef(i,i_state)
! enddo
! call i_H_j(psi_ref(1,1,i),tq(1,1,i_alpha),n_int,hialpha)
! if(dabs(hialpha).le.1.d-20)then
! do i_state = 1, N_states
! delta_e(i_state) = 1.d+20
! enddo
! else
! call get_delta_e_dyall(psi_ref(1,1,i),tq(1,1,i_alpha),coef_array,hialpha,delta_e)
! endif
! hij_array(i) = hialpha
! do i_state = 1,N_states
! delta_e_inv_array(i,i_state) = 1.d0/delta_e(i_state)
! enddo
! enddo
! do i = 1, N_det_ref
! do j = 1, N_det_ref
! do i_state = 1, N_states
! delta_ij_(i,j,i_state) += hij_array(i) * hij_array(j)* delta_e_inv_array(j,i_state)
! enddo
! enddo
! enddo
! cycle
! call get_excitation_degree_vector(psi_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_ref,idx_alpha)
call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
do j=1,idx_alpha(0)
idx_alpha(j) = idx_miniList(idx_alpha(j))
enddo
! double precision :: ihpsi0,coef_pert
! ihpsi0 = 0.d0
! coef_pert = 0.d0
phase_array =0.d0
do i = 1,idx_alpha(0)
index_i = idx_alpha(i)
call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha)
double precision :: coef_array(N_states)
call i_h_j(tq(1,1,i_alpha),psi_ref(1,1,index_i),Nint,hialpha)
do i_state = 1, N_states
coef_array(i_state) = psi_coef(index_i,i_state)
coef_array(i_state) = psi_ref_coef(index_i,i_state)
enddo
call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e)
integer :: degree_scalar
call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,index_i),degree_scalar,N_int)
! if(degree_scalar == 2)then
! hialpha = 0.d0
! endif
if(dabs(hialpha).le.1.d-20)then
do i_state = 1, N_states
delta_e(i_state) = 1.d+20
enddo
else
call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),delta_e)
if(degree_scalar.eq.1)then
delta_e = 1.d+20
endif
! print*, 'delta_e',delta_e
!!!!!!!!!!!!! SHIFTED BK
! double precision :: hjj
! call i_h_j(tq(1,1,i_alpha),tq(1,1,i_alpha),Nint,hjj)
! delta_e(1) = electronic_psi_ref_average_value(1) - hjj
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
endif
hij_array(index_i) = hialpha
call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int)
! phase_array(index_i) = phase
! print*, 'hialpha ',hialpha
do i_state = 1,N_states
delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state)
enddo
@ -99,16 +145,12 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip
call omp_set_lock( psi_ref_bis_lock(index_i) )
do j = 1, idx_alpha(0)
index_j = idx_alpha(j)
! call get_excitation(psi_det(1,1,index_i),psi_det(1,1,index_i),exc,degree,phase,N_int)
! if(index_j.ne.index_i)then
! if(phase_array(index_j) * phase_array(index_i) .ne. phase)then
! print*, phase_array(index_j) , phase_array(index_i) ,phase
! call debug_det(psi_det(1,1,index_i),N_int)
! call debug_det(psi_det(1,1,index_j),N_int)
! call debug_det(tq(1,1,i_alpha),N_int)
! stop
! endif
! endif
!!!!!!!!!!!!!!!!!! WARNING TEST
!!!!!!!!!!!!!!!!!! WARNING TEST
! if(index_j .ne. index_i)cycle
!!!!!!!!!!!!!!!!!! WARNING TEST
!!!!!!!!!!!!!!!!!! WARNING TEST
!!!!!!!!!!!!!!!!!! WARNING TEST
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)
@ -122,23 +164,23 @@ end
BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ]
gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators)
gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators)
call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int)
call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int)
BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_ref,2) ]
&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_ref,2) ]
&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_ref,2) ]
&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_ref,2) ]
gen_det_sorted(:,:,:,1) = psi_ref(:,:,:N_det_ref)
gen_det_sorted(:,:,:,2) = psi_ref(:,:,:N_det_ref)
call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_ref, N_int)
call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_ref, N_int)
END_PROVIDER
subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList)
subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList)
use bitmasks
implicit none
integer, intent(in) :: i_generator,n_selected, Nint
integer, intent(in) :: n_selected, Nint
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
integer :: i,j,k,m
@ -155,7 +197,7 @@ subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N
logical, external :: is_connected_to
integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators)
integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_ref)
integer,intent(in) :: N_miniList
@ -168,7 +210,7 @@ subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N
cycle
end if
if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then
if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det_ref)) then
N_tq += 1
do k=1,N_int
tq(k,1,N_tq) = det_buffer(k,1,i)
@ -179,8 +221,3 @@ subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N
end

213
plugins/MRPT_Utils/mrpt_utils.irp.f
View File

@ -34,43 +34,44 @@
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:)
enddo
second_order_pt_new_1h(i_state) = accu(i_state)
enddo
print*, '1h = ',accu
! 1p
delta_ij_tmp = 0.d0
call H_apply_mrpt_1p(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_1p(i_state) = accu(i_state)
enddo
print*, '1p = ',accu
!! 1p
!delta_ij_tmp = 0.d0
!call H_apply_mrpt_1p(delta_ij_tmp,N_det)
!accu = 0.d0
!do i_state = 1, N_states
!do i = 1, N_det
! do j = 1, N_det
! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
! enddo
! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:)
!enddo
!second_order_pt_new_1p(i_state) = accu(i_state)
!enddo
!print*, '1p = ',accu
! 1h1p
delta_ij_tmp = 0.d0
call H_apply_mrpt_1h1p(delta_ij_tmp,N_det)
double precision :: e_corr_from_1h1p_singles(N_states)
!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles)
!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_1h1p(i_state) = accu(i_state)
enddo
print*, '1h1p = ',accu
!delta_ij_tmp = 0.d0
!call H_apply_mrpt_1h1p(delta_ij_tmp,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_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
! enddo
! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:)
!enddo
!second_order_pt_new_1h1p(i_state) = accu(i_state)
!enddo
!print*, '1h1p = ',accu
! 1h1p third order
if(do_third_order_1h1p)then
@ -83,75 +84,80 @@
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:)
enddo
second_order_pt_new_1h1p(i_state) = accu(i_state)
enddo
print*, '1h1p(3)',accu
endif
! 2h
delta_ij_tmp = 0.d0
call H_apply_mrpt_2h(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_2h(i_state) = accu(i_state)
enddo
print*, '2h = ',accu
!! 2h
!delta_ij_tmp = 0.d0
!call H_apply_mrpt_2h(delta_ij_tmp,N_det)
!accu = 0.d0
!do i_state = 1, N_states
!do i = 1, N_det
! do j = 1, N_det
! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
! enddo
! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:)
!enddo
!second_order_pt_new_2h(i_state) = accu(i_state)
!enddo
!print*, '2h = ',accu
! 2p
delta_ij_tmp = 0.d0
call H_apply_mrpt_2p(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_2p(i_state) = accu(i_state)
enddo
print*, '2p = ',accu
!! 2p
!delta_ij_tmp = 0.d0
!call H_apply_mrpt_2p(delta_ij_tmp,N_det)
!accu = 0.d0
!do i_state = 1, N_states
!do i = 1, N_det
! do j = 1, N_det
! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
! enddo
! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:)
!enddo
!second_order_pt_new_2p(i_state) = accu(i_state)
!enddo
!print*, '2p = ',accu
! 1h2p
delta_ij_tmp = 0.d0
!call give_1h2p_contrib(delta_ij_tmp)
call H_apply_mrpt_1h2p(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_1h2p(i_state) = accu(i_state)
enddo
print*, '1h2p = ',accu
!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det)
!accu = 0.d0
!do i_state = 1, N_states
!do i = 1, N_det
! do j = 1, N_det
! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
! enddo
! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:)
!enddo
!second_order_pt_new_1h2p(i_state) = accu(i_state)
!enddo
!print*, '1h2p = ',accu
! 2h1p
delta_ij_tmp = 0.d0
!! 2h1p
!delta_ij_tmp = 0.d0
!call give_2h1p_contrib(delta_ij_tmp)
call H_apply_mrpt_2h1p(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_2h1p(i_state) = accu(i_state)
enddo
print*, '2h1p = ',accu
!call H_apply_mrpt_2h1p(delta_ij_tmp,N_det)
!accu = 0.d0
!do i_state = 1, N_states
!do i = 1, N_det
! do j = 1, N_det
! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
! enddo
! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:)
!enddo
!second_order_pt_new_2h1p(i_state) = accu(i_state)
!enddo
!print*, '2h1p = ',accu
! 2h2p
!! 2h2p
!delta_ij_tmp = 0.d0
!call H_apply_mrpt_2h2p(delta_ij_tmp,N_det)
!accu = 0.d0
@ -178,10 +184,13 @@
! total
print*, ''
print*, 'total dressing'
print*, ''
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
! write(*,'(1000(F16.10,x))')delta_ij(i,:,:)
write(*,'(1000(F16.10,x))')delta_ij(i,:,:)
do j = i_state, N_det
accu(i_state) += delta_ij(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
enddo
@ -223,7 +232,7 @@ END_PROVIDER
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag) ]
BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_electronic_energy, (N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag) ]
BEGIN_DOC
@ -245,7 +254,7 @@ END_PROVIDER
integer, allocatable :: iorder(:)
! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors
do j=1,min(N_states_diag,N_det)
do j=1,min(N_states,N_det)
do i=1,N_det
CI_dressed_pt2_new_eigenvectors(i,j) = psi_coef(i,j)
enddo
@ -267,7 +276,7 @@ END_PROVIDER
allocate (eigenvectors(size(H_matrix_all_dets,1),N_det))
allocate (eigenvalues(N_det))
call lapack_diag(eigenvalues,eigenvectors, &
H_matrix_all_dets,size(H_matrix_all_dets,1),N_det)
Hmatrix_dressed_pt2_new_symmetrized,size(H_matrix_all_dets,1),N_det)
CI_electronic_energy(:) = 0.d0
if (s2_eig) then
i_state = 0
@ -276,8 +285,10 @@ END_PROVIDER
good_state_array = .False.
call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,&
N_det,size(eigenvectors,1))
print*,'N_det',N_det
do j=1,N_det
! Select at least n_states states with S^2 values closed to "expected_s2"
print*, s2_eigvalues(j),expected_s2
if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then
i_state +=1
index_good_state_array(i_state) = j
@ -291,10 +302,10 @@ END_PROVIDER
! Fill the first "i_state" states that have a correct S^2 value
do j = 1, i_state
do i=1,N_det
CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j))
CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j))
enddo
CI_electronic_energy(j) = eigenvalues(index_good_state_array(j))
CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j))
CI_dressed_pt2_new_electronic_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
@ -304,10 +315,10 @@ END_PROVIDER
exit
endif
do i=1,N_det
CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j)
CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j)
enddo
CI_electronic_energy(i_state+i_other_state) = eigenvalues(j)
CI_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state)
CI_dressed_pt2_new_electronic_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
@ -322,10 +333,10 @@ END_PROVIDER
print*,''
do j=1,min(N_states_diag,N_det)
do i=1,N_det
CI_eigenvectors(i,j) = eigenvectors(i,j)
CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j)
enddo
CI_electronic_energy(j) = eigenvalues(j)
CI_eigenvectors_s2(j) = s2_eigvalues(j)
CI_dressed_pt2_new_electronic_energy(j) = eigenvalues(j)
CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(j)
enddo
endif
deallocate(index_good_state_array,good_state_array)
@ -336,9 +347,9 @@ END_PROVIDER
! Select the "N_states_diag" states of lowest energy
do j=1,min(N_det,N_states_diag)
do i=1,N_det
CI_eigenvectors(i,j) = eigenvectors(i,j)
CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j)
enddo
CI_electronic_energy(j) = eigenvalues(j)
CI_dressed_pt2_new_electronic_energy(j) = eigenvalues(j)
enddo
endif
deallocate(eigenvectors,eigenvalues)
@ -358,7 +369,7 @@ BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ]
character*(8) :: st
call write_time(output_determinants)
do j=1,N_states_diag
CI_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion
CI_dressed_pt2_new_energy(j) = CI_dressed_pt2_new_electronic_energy(j) + nuclear_repulsion
write(st,'(I4)') j
call write_double(output_determinants,CI_dressed_pt2_new_energy(j),'Energy of state '//trim(st))
call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st))

315
plugins/MRPT_Utils/new_way.irp.f
View File

@ -1,7 +1,7 @@
subroutine give_2h1p_contrib(matrix_2h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*)
double precision , intent(inout) :: matrix_2h1p(N_det_ref,N_det_ref,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb
integer :: ispin,jspin
@ -22,8 +22,8 @@ subroutine give_2h1p_contrib(matrix_2h1p)
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
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)
@ -38,14 +38,14 @@ subroutine give_2h1p_contrib(matrix_2h1p)
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)
integer :: degree(N_det_ref)
integer :: idx(0:N_det_ref)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,3)
integer :: index_orb_act_mono(N_det_ref,3)
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
do idet = 1, N_det_ref
call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,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)
@ -53,8 +53,8 @@ subroutine give_2h1p_contrib(matrix_2h1p)
do a = 1, n_act_orb ! First active
aorb = list_act(a)
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
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
@ -64,7 +64,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin
call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
! 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))
@ -81,7 +81,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1)
perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
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) &
@ -109,7 +109,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a_{b} a^{\dagger}_a | Idet>
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
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
@ -129,6 +129,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
integer :: kspin
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
! cycle
! 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}
@ -150,7 +151,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
! you determine the interaction between the excited determinant and the other parent | Jdet >
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet >
! hja = < det_tmp | H | Jdet >
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
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
@ -195,7 +196,7 @@ end
subroutine give_1h2p_contrib(matrix_1h2p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*)
double precision , intent(inout) :: matrix_1h2p(N_det_ref,N_det_ref,*)
integer :: i,v,r,a,b
integer :: iorb, vorb, rorb, aorb, borb
integer :: ispin,jspin
@ -213,16 +214,18 @@ subroutine give_1h2p_contrib(matrix_1h2p)
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
!matrix_1h2p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
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, 1 ! First inactive
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
! do v = 1, 1
do v = 1, n_virt_orb ! First virtual
vorb = list_virt(v)
! do r = 1, 1
do r = 1, n_virt_orb ! Second virtual
rorb = list_virt(r)
! take all the integral you will need for i,j,r fixed
@ -232,14 +235,14 @@ subroutine give_1h2p_contrib(matrix_1h2p)
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)
integer :: degree(N_det_ref)
integer :: idx(0:N_det_ref)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,3)
integer :: index_orb_act_mono(N_det_ref,3)
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
do idet = 1, N_det_ref
call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,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)
@ -247,8 +250,8 @@ subroutine give_1h2p_contrib(matrix_1h2p)
aorb = list_act(a)
if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
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
@ -258,7 +261,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin
call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
! 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))
@ -280,7 +283,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
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) &
@ -308,7 +311,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a^{\dagger}_b a_{a} | Idet>
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
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
@ -350,7 +353,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{borb,kspin} a_{iorb,ispin} | Jdet >
! hja = < det_tmp | H | Jdet >
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
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
@ -393,130 +396,10 @@ subroutine give_1h2p_contrib(matrix_1h2p)
end
subroutine give_1h1p_contrib(matrix_1h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb
integer :: ispin,jspin
integer :: idet,jdet
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: istate
double precision :: hja,delta_e_inact_virt(N_states)
integer :: kspin,degree_scalar
!matrix_1h1p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
do j = 1, N_states
delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) &
- fock_virt_total_spin_trace(rorb,j)
enddo
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations
do jdet = 1, idx(0)
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
double precision :: himono,delta_e(N_states),coef_mono(N_states)
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono)
do state_target = 1, N_states
! delta_e(state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target)
delta_e(state_target) = one_anhil_one_creat_inact_virt_bis(i,r,idet,state_target)
coef_mono(state_target) = himono / delta_e(state_target)
enddo
if(idx(jdet).ne.idet)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
aorb = (exc(1,2,1)) !!! a^{\dagger}_a
borb = (exc(1,1,1)) !!! a_{b}
jspin = 1
else
! Mono beta
aorb = (exc(1,2,2)) !!! a^{\dagger}_a
borb = (exc(1,1,2)) !!! a_{b}
jspin = 2
endif
call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int)
if(degree_scalar .ne. 2)then
print*, 'pb !!!'
print*, degree_scalar
call debug_det(psi_det(1,1,idx(jdet)),N_int)
call debug_det(det_tmp,N_int)
stop
endif
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
if(ispin == jspin )then
hij = -get_mo_bielec_integral(iorb,aorb,rorb,borb,mo_integrals_map) &
+ get_mo_bielec_integral(iorb,aorb,borb,rorb,mo_integrals_map)
else
hij = get_mo_bielec_integral(iorb,borb,rorb,aorb,mo_integrals_map)
endif
hij = hij * phase
double precision :: hij_test
integer :: state_target
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test)
if(dabs(hij - hij_test).gt.1.d-10)then
print*, 'ahah pb !!'
print*, 'hij .ne. hij_test'
print*, hij,hij_test
call debug_det(psi_det(1,1,idx(jdet)),N_int)
call debug_det(det_tmp,N_int)
print*, ispin, jspin
print*,iorb,borb,rorb,aorb
print*, phase
call i_H_j_verbose(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test)
stop
endif
do state_target = 1, N_states
matrix_1h1p(idx(jdet),idet,state_target) += hij* coef_mono(state_target)
enddo
else
do state_target = 1, N_states
matrix_1h1p(idet,idet,state_target) += himono * coef_mono(state_target)
enddo
endif
enddo
enddo
enddo
enddo
enddo
end
subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*)
double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb,s,sorb
integer :: ispin,jspin
@ -533,8 +416,8 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
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 :: degree(N_det_ref)
integer :: idx(0:N_det_ref)
integer :: istate
double precision :: hja,delta_e_inact_virt(N_states)
integer :: kspin,degree_scalar
@ -542,13 +425,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
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_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
do idet = 1, N_det_ref
call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx)
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do r = 1, n_virt_orb ! First virtual
@ -563,13 +446,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
- fock_virt_total_spin_trace(rorb,j)
enddo
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
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_det(1,1,idet),det_tmp,N_int,himono)
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)
@ -619,9 +502,9 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
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 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)
@ -629,37 +512,37 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
enddo
do jdet = 1, idx(0)
!
if(idx(jdet).ne.idet)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
aorb = (exc(1,2,1)) !!! a^{\dagger}_a
borb = (exc(1,1,1)) !!! a_{b}
jspin = 1
else
aorb = (exc(1,2,2)) !!! a^{\dagger}_a
borb = (exc(1,1,2)) !!! a_{b}
jspin = 2
endif
call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int)
if(degree_scalar .ne. 2)then
print*, 'pb !!!'
print*, degree_scalar
call debug_det(psi_det(1,1,idx(jdet)),N_int)
call debug_det(det_tmp,N_int)
stop
endif
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
double precision :: hij_test
hij_test = 0.d0
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test)
do state_target = 1, N_states
matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2)
enddo
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)
! 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_det(1,1,idet),det_tmp,N_int,hij_test)
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
@ -676,7 +559,7 @@ end
subroutine give_1p_sec_order_singles_contrib(matrix_1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1p(N_det,N_det,*)
double precision , intent(inout) :: matrix_1p(N_det_ref,N_det_ref,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb,s,sorb
integer :: ispin,jspin
@ -692,8 +575,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: hij,phase
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: degree(N_det_ref)
integer :: idx(0:N_det_ref)
integer :: istate
double precision :: hja,delta_e_act_virt(N_states)
integer :: kspin,degree_scalar
@ -701,13 +584,13 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
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_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
do idet = 1, N_det_ref
call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx)
do i = 1, n_act_orb ! First active
iorb = list_act(i)
do r = 1, n_virt_orb ! First virtual
@ -721,8 +604,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
delta_e_act_virt(j) = - fock_virt_total_spin_trace(rorb,j)
enddo
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
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)
@ -739,7 +622,7 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
enddo
cycle
endif
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono)
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)
@ -801,10 +684,10 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
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
do jdet = 1,N_det_ref
double precision :: coef_array(N_states),hij_test
call i_H_j(det_tmp,psi_det(1,1,jdet),N_int,himono)
call get_delta_e_dyall(psi_det(1,1,jdet),det_tmp,coef_array,hij_test,delta_e)
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,coef_array,hij_test,delta_e)
do state_target = 1, N_states
! matrix_1p(idet,jdet,state_target) += himono * coef_det_pert(i,r,ispin,state_target,1)
matrix_1p(idet,jdet,state_target) += himono * hij_det_pert(i,r,ispin) / delta_e(state_target)
@ -822,7 +705,7 @@ end
subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*)
double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb
integer :: ispin,jspin
@ -835,8 +718,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
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 :: degree(N_det_ref)
integer :: idx(0:N_det_ref)
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)
@ -850,8 +733,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
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)
@ -861,8 +744,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) &
- fock_virt_total_spin_trace(rorb,j)
enddo
do idet = 1, N_det
call get_excitation_degree_vector_double_alpha_beta(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
do idet = 1, N_det_ref
call get_excitation_degree_vector_double_alpha_beta(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations
do ispin = 1, 2
@ -872,8 +755,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
do b = 1, n_act_orb
borb = list_act(b)
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
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
@ -904,7 +787,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
pert_det(inint,2,a,b,ispin) = det_tmp(inint,2)
enddo
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hidouble)
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)
@ -915,7 +798,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
enddo
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
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
@ -935,8 +818,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
det_tmp_bis(inint,2) = pert_det(inint,2,c,d,2)
enddo
double precision :: hjdouble_1,hjdouble_2
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1)
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2)
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

8
plugins/MRPT_Utils/new_way_second_order_coef.irp.f
View File

@ -44,8 +44,8 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
perturb_dets_phase(a,2,1) = -1000.d0
enddo
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: degree(N_det_Ref)
integer :: idx(0:N_det_Ref)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
@ -376,8 +376,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
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)
integer :: degree(N_det_Ref)
integer :: idx(0:N_det_Ref)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,6)

11
plugins/MRPT_Utils/psi_active_prov.irp.f
View File

@ -152,7 +152,7 @@ subroutine give_particles_in_virt_space(det_1,n_particles_spin,n_particles,parti
end
subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
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
!
@ -170,7 +170,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
use bitmasks
double precision, intent(out) :: delta_e_final(N_states)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
double precision, intent(in) :: coef_array(N_states),hij
integer :: i,j,k,l
integer :: i_state
@ -355,7 +354,8 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
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)
! delta_e_act(i_state) += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin,i_state)
delta_e_act(i_state) += two_anhil_one_creat_spin_average(i_particle_act,i_hole_act,j_hole_act,i_state)
enddo
else if (n_holes_act == 1 .and. n_particles_act == 2) then
@ -370,7 +370,9 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
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)
! delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state)
delta_e_act(i_state) += 0.5d0 * (two_creat_one_anhil_spin_average(i_particle_act,j_particle_act,i_hole_act,i_state) &
+two_creat_one_anhil_spin_average(j_particle_act,i_particle_act,i_hole_act,i_state))
enddo
else if (n_holes_act == 3 .and. n_particles_act == 0) then
@ -433,3 +435,4 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
end

0
plugins/Perturbation/pt2_new.irp.f → plugins/MRPT_Utils/pt2_new.irp.f
View File

8
plugins/MRPT_Utils/second_order_new.irp.f
View File

@ -22,8 +22,8 @@ subroutine give_1h2p_new(matrix_1h2p)
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)
integer :: degree(N_det_Ref)
integer :: idx(0:N_det_Ref)
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)
@ -502,8 +502,8 @@ subroutine give_2h1p_new(matrix_2h1p)
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)
integer :: degree(N_det_Ref)
integer :: idx(0:N_det_Ref)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,3)

4
plugins/MRPT_Utils/second_order_new_2p.irp.f
View File

@ -21,8 +21,8 @@ subroutine give_2p_new(matrix_2p)
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)
integer :: degree(N_det_Ref)
integer :: idx(0:N_det_Ref)
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)

2
plugins/Perturbation/NEEDED_CHILDREN_MODULES
View File

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

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

@ -46,36 +46,6 @@ subroutine pt2_epstein_nesbet ($arguments)
end
subroutine pt2_decontracted ($arguments)
use bitmasks
implicit none
$declarations
BEGIN_DOC
END_DOC
integer :: i,j
double precision :: diag_H_mat_elem_fock, h
double precision :: i_H_psi_array(N_st)
double precision :: coef_pert
PROVIDE selection_criterion
ASSERT (Nint == N_int)
ASSERT (Nint > 0)
!call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array)
call i_H_psi_pert_new_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array,coef_pert)
H_pert_diag = 0.d0
c_pert(1) = coef_pert
e_2_pert(1) = coef_pert * i_H_psi_array(1)
! print*,coef_pert,i_H_psi_array(1)
end
subroutine pt2_epstein_nesbet_2x2 ($arguments)
use bitmasks
implicit none

21
plugins/Psiref_CAS/psi_ref.irp.f
View File

@ -67,6 +67,27 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [double precision, electronic_psi_ref_average_value, (N_states)]
&BEGIN_PROVIDER [double precision, psi_ref_average_value, (N_states)]
implicit none
integer :: i,j
electronic_psi_ref_average_value = psi_energy
do i = 1, N_states
psi_ref_average_value(i) = psi_energy(i) + nuclear_repulsion
enddo
double precision :: accu,hij
accu = 0.d0
do i = 1, N_det_ref
do j = 1, N_det_ref
call i_H_j(psi_ref(1,1,i),psi_ref(1,1,j),N_int,hij)
accu += psi_ref_coef(i,1) * psi_ref_coef(j,1) * hij
enddo
enddo
electronic_psi_ref_average_value(1) = accu
psi_ref_average_value(1) = electronic_psi_ref_average_value(1) + nuclear_repulsion
END_PROVIDER
BEGIN_PROVIDER [double precision, norm_psi_ref, (N_states)]
&BEGIN_PROVIDER [double precision, inv_norm_psi_ref, (N_states)]
implicit none

25
plugins/SCF_density/.gitignore vendored Normal file
View File

@ -0,0 +1,25 @@
# Automatically created by $QP_ROOT/scripts/module/module_handler.py
.ninja_deps
.ninja_log
AO_Basis
Bitmask
Electrons
Ezfio_files
Huckel_guess
IRPF90_man
IRPF90_temp
Integrals_Bielec
Integrals_Monoelec
MOGuess
MO_Basis
Makefile
Makefile.depend
Nuclei
Pseudo
SCF
Utils
ZMQ
ezfio_interface.irp.f
irpf90.make
irpf90_entities
tags

35
plugins/SCF_density/EZFIO.cfg Normal file
View File

@ -0,0 +1,35 @@
[thresh_scf]
type: Threshold
doc: Threshold on the convergence of the Hartree Fock energy
interface: ezfio,provider,ocaml
default: 1.e-10
[n_it_scf_max]
type: Strictly_positive_int
doc: Maximum number of SCF iterations
interface: ezfio,provider,ocaml
default: 200
[level_shift]
type: Positive_float
doc: Energy shift on the virtual MOs to improve SCF convergence
interface: ezfio,provider,ocaml
default: 0.5
[mo_guess_type]
type: MO_guess
doc: Initial MO guess. Can be [ Huckel | HCore ]
interface: ezfio,provider,ocaml
default: Huckel
[energy]
type: double precision
doc: Calculated HF energy
interface: ezfio
[no_oa_or_av_opt]
type: logical
doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure
interface: ezfio,provider,ocaml
default: False

437
plugins/SCF_density/Fock_matrix.irp.f Normal file
View File

@ -0,0 +1,437 @@
BEGIN_PROVIDER [ double precision, Fock_matrix_mo, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, Fock_matrix_diag_mo, (mo_tot_num)]
implicit none
BEGIN_DOC
! Fock matrix on the MO basis.
! For open shells, the ROHF Fock Matrix is
!
! | F-K | F + K/2 | F |
! |---------------------------------|
! | F + K/2 | F | F - K/2 |
! |---------------------------------|
! | F | F - K/2 | F + K |
!
! F = 1/2 (Fa + Fb)
!
! K = Fb - Fa
!
END_DOC
integer :: i,j,n
if (elec_alpha_num == elec_beta_num) then
Fock_matrix_mo = Fock_matrix_alpha_mo
else
do j=1,elec_beta_num
! F-K
do i=1,elec_beta_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
- (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F+K/2
do i=elec_beta_num+1,elec_alpha_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
+ 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F
do i=elec_alpha_num+1, mo_tot_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
enddo
enddo
do j=elec_beta_num+1,elec_alpha_num
! F+K/2
do i=1,elec_beta_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
+ 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F
do i=elec_beta_num+1,elec_alpha_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
enddo
! F-K/2
do i=elec_alpha_num+1, mo_tot_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
- 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
enddo
do j=elec_alpha_num+1, mo_tot_num
! F
do i=1,elec_beta_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
enddo
! F-K/2
do i=elec_beta_num+1,elec_alpha_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
- 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F+K
do i=elec_alpha_num+1,mo_tot_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) &
+ (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
enddo
endif
do i = 1, mo_tot_num
Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i)
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ]
&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao, (ao_num_align, ao_num) ]
implicit none
BEGIN_DOC
! Alpha Fock matrix in AO basis set
END_DOC
integer :: i,j
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,ao_num
Fock_matrix_alpha_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j)
Fock_matrix_beta_ao (i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_alpha, (ao_num_align, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_beta , (ao_num_align, ao_num) ]
use map_module
implicit none
BEGIN_DOC
! Alpha Fock matrix in AO basis set
END_DOC
integer :: i,j,k,l,k1,r,s
integer :: i0,j0,k0,l0
integer*8 :: p,q
double precision :: integral, c0, c1, c2
double precision :: ao_bielec_integral, local_threshold
double precision, allocatable :: ao_bi_elec_integral_alpha_tmp(:,:)
double precision, allocatable :: ao_bi_elec_integral_beta_tmp(:,:)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_alpha_tmp
ao_bi_elec_integral_alpha = 0.d0
ao_bi_elec_integral_beta = 0.d0
if (do_direct_integrals) then
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, &
!$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, &
!$OMP local_threshold)&
!$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,&
!$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, &
!$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta)
allocate(keys(1), values(1))
allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), &
ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num))
ao_bi_elec_integral_alpha_tmp = 0.d0
ao_bi_elec_integral_beta_tmp = 0.d0
q = ao_num*ao_num*ao_num*ao_num
!$OMP DO SCHEDULE(dynamic)
do p=1_8,q
call bielec_integrals_index_reverse(kk,ii,ll,jj,p)
if ( (kk(1)>ao_num).or. &
(ii(1)>ao_num).or. &
(jj(1)>ao_num).or. &
(ll(1)>ao_num) ) then
cycle
endif
k = kk(1)
i = ii(1)
l = ll(1)
j = jj(1)
if (ao_overlap_abs(k,l)*ao_overlap_abs(i,j) &
< ao_integrals_threshold) then
cycle
endif
local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j)
if (local_threshold < ao_integrals_threshold) then
cycle
endif
i0 = i
j0 = j
k0 = k
l0 = l
values(1) = 0.d0
local_threshold = ao_integrals_threshold/local_threshold
do k2=1,8
if (kk(k2)==0) then
cycle
endif
i = ii(k2)
j = jj(k2)
k = kk(k2)
l = ll(k2)
c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)
c1 = HF_density_matrix_ao_alpha(k,i)
c2 = HF_density_matrix_ao_beta(k,i)
if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then
cycle
endif
if (values(1) == 0.d0) then
values(1) = ao_bielec_integral(k0,l0,i0,j0)
endif
integral = c0 * values(1)
ao_bi_elec_integral_alpha_tmp(i,j) += integral
ao_bi_elec_integral_beta_tmp (i,j) += integral
integral = values(1)
ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral
ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp
!$OMP END CRITICAL
!$OMP CRITICAL
ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp
!$OMP END CRITICAL
deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)
!$OMP END PARALLEL
else
PROVIDE ao_bielec_integrals_in_map
integer(omp_lock_kind) :: lck(ao_num)
integer*8 :: i8
integer :: ii(8), jj(8), kk(8), ll(8), k2
integer(cache_map_size_kind) :: n_elements_max, n_elements
integer(key_kind), allocatable :: keys(:)
double precision, allocatable :: values(:)
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,n_elements_max, &
!$OMP n_elements,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)&
!$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,&
!$OMP ao_integrals_map, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta)
call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max)
allocate(keys(n_elements_max), values(n_elements_max))
allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), &
ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num))
ao_bi_elec_integral_alpha_tmp = 0.d0
ao_bi_elec_integral_beta_tmp = 0.d0
!$OMP DO SCHEDULE(dynamic)
!DIR$ NOVECTOR
do i8=0_8,ao_integrals_map%map_size
n_elements = n_elements_max
call get_cache_map(ao_integrals_map,i8,keys,values,n_elements)
do k1=1,n_elements
call bielec_integrals_index_reverse(kk,ii,ll,jj,keys(k1))
do k2=1,8
if (kk(k2)==0) then
cycle
endif
i = ii(k2)
j = jj(k2)
k = kk(k2)
l = ll(k2)
integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(k1)
ao_bi_elec_integral_alpha_tmp(i,j) += integral
ao_bi_elec_integral_beta_tmp (i,j) += integral
integral = values(k1)
ao_bi_elec_integral_alpha_tmp(l,j) -= HF_density_matrix_ao_alpha(k,i) * integral
ao_bi_elec_integral_beta_tmp (l,j) -= HF_density_matrix_ao_beta (k,i) * integral
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp
!$OMP END CRITICAL
!$OMP CRITICAL
ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp
!$OMP END CRITICAL
deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)
!$OMP END PARALLEL
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Fock matrix on the MO basis
END_DOC
double precision, allocatable :: T(:,:)
allocate ( T(ao_num_align,mo_tot_num) )
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
call dgemm('N','N', ao_num, mo_tot_num, ao_num, &
1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1), &
mo_coef, size(mo_coef,1), &
0.d0, T, ao_num_align)
call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, &
1.d0, mo_coef,size(mo_coef,1), &
T, size(T,1), &
0.d0, Fock_matrix_alpha_mo, mo_tot_num_align)
deallocate(T)
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Fock matrix on the MO basis
END_DOC
double precision, allocatable :: T(:,:)
allocate ( T(ao_num_align,mo_tot_num) )
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
call dgemm('N','N', ao_num, mo_tot_num, ao_num, &
1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1), &
mo_coef, size(mo_coef,1), &
0.d0, T, ao_num_align)
call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, &
1.d0, mo_coef,size(mo_coef,1), &
T, size(T,1), &
0.d0, Fock_matrix_beta_mo, mo_tot_num_align)
deallocate(T)
END_PROVIDER
BEGIN_PROVIDER [ double precision, HF_energy ]
implicit none
BEGIN_DOC
! Hartree-Fock energy
END_DOC
HF_energy = nuclear_repulsion
integer :: i,j
do j=1,ao_num
do i=1,ao_num
HF_energy += 0.5d0 * ( &
(ao_mono_elec_integral(i,j) + Fock_matrix_alpha_ao(i,j) ) * HF_density_matrix_ao_alpha(i,j) +&
(ao_mono_elec_integral(i,j) + Fock_matrix_beta_ao (i,j) ) * HF_density_matrix_ao_beta (i,j) )
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ]
implicit none
BEGIN_DOC
! Fock matrix in AO basis set
END_DOC
if ( (elec_alpha_num == elec_beta_num).and. &
(level_shift == 0.) ) &
then
integer :: i,j
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,ao_num_align
Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j)
enddo
enddo
else
double precision, allocatable :: T(:,:), M(:,:)
integer :: ierr
! F_ao = S C F_mo C^t S
allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr)
if (ierr /=0 ) then
print *, irp_here, ' : allocation failed'
endif
! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num)
! -> M(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, &
ao_overlap, size(ao_overlap,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num)
! -> T(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, &
M, size(M,1), &
Fock_matrix_mo, size(Fock_matrix_mo,1), &
0.d0, &
T, size(T,1))
! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num)
! -> M(ao_num,ao_num)
call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, &
T, size(T,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num)
! -> Fock_matrix_ao(ao_num,ao_num)
call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, &
M, size(M,1), &
ao_overlap, size(ao_overlap,1), &
0.d0, &
Fock_matrix_ao, size(Fock_matrix_ao,1))
deallocate(T)
endif
END_PROVIDER
subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO)
implicit none
integer, intent(in) :: LDFMO ! size(FMO,1)
integer, intent(in) :: LDFAO ! size(FAO,1)
double precision, intent(in) :: FMO(LDFMO,*)
double precision, intent(out) :: FAO(LDFAO,*)
double precision, allocatable :: T(:,:), M(:,:)
integer :: ierr
! F_ao = S C F_mo C^t S
allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr)
if (ierr /=0 ) then
print *, irp_here, ' : allocation failed'
endif
! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num)
! -> M(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, &
ao_overlap, size(ao_overlap,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num)
! -> T(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, &
M, size(M,1), &
FMO, size(FMO,1), &
0.d0, &
T, size(T,1))
! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num)
! -> M(ao_num,ao_num)
call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, &
T, size(T,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num)
! -> Fock_matrix_ao(ao_num,ao_num)
call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, &
M, size(M,1), &
ao_overlap, size(ao_overlap,1), &
0.d0, &
FAO, size(FAO,1))
deallocate(T,M)
end

66
plugins/SCF_density/HF_density_matrix_ao.irp.f Normal file
View File

@ -0,0 +1,66 @@
BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ]
implicit none
BEGIN_DOC
! S^-1 x Alpha density matrix in the AO basis x S^-1
END_DOC
! call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, &
! mo_coef, size(mo_coef,1), &
! mo_coef, size(mo_coef,1), 0.d0, &
! HF_density_matrix_ao_alpha, size(HF_density_matrix_ao_alpha,1))
integer :: i,j,k,l
double precision :: test_alpha
HF_density_matrix_ao_alpha = 0.d0
do i = 1, mo_tot_num
do j = 1, mo_tot_num
if(dabs(mo_general_density_alpha(i,j)).le.1.d-10)cycle
do k = 1, ao_num
do l = 1, ao_num
HF_density_matrix_ao_alpha(k,l) += mo_coef(k,i) * mo_coef(l,j) * mo_general_density_alpha(i,j)
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_beta, (ao_num_align,ao_num) ]
implicit none
BEGIN_DOC
! S^-1 Beta density matrix in the AO basis x S^-1
END_DOC
! call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, &
! mo_coef, size(mo_coef,1), &
! mo_coef, size(mo_coef,1), 0.d0, &
! HF_density_matrix_ao_beta, size(HF_density_matrix_ao_beta,1))
integer :: i,j,k,l
double precision :: test_beta
HF_density_matrix_ao_beta = 0.d0
do i = 1, mo_tot_num
do j = 1, mo_tot_num
do k = 1, ao_num
do l = 1, ao_num
HF_density_matrix_ao_beta(k,l) += mo_coef(k,i) * mo_coef(l,j) * mo_general_density_beta(i,j)
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, HF_density_matrix_ao, (ao_num_align,ao_num) ]
implicit none
BEGIN_DOC
! S^-1 Density matrix in the AO basis S^-1
END_DOC
ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_alpha,1))
if (elec_alpha_num== elec_beta_num) then
HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_alpha
else
ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_beta ,1))
HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_beta
endif
END_PROVIDER

1
plugins/SCF_density/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Integrals_Bielec MOGuess Bitmask

175
plugins/SCF_density/README.rst Normal file
View File

@ -0,0 +1,175 @@
===================
SCF_density Module
===================
From the 140 molecules of the G2 set, only LiO, ONa don't converge well.
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
.. image:: tree_dependency.png
* `Integrals_Bielec <http://github.com/LCPQ/quantum_package/tree/master/src/Integrals_Bielec>`_
* `MOGuess <http://github.com/LCPQ/quantum_package/tree/master/src/MOGuess>`_
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
.. image:: tree_dependency.png
* `Integrals_Bielec <http://github.com/LCPQ/quantum_package/tree/master/src/Integrals_Bielec>`_
* `MOGuess <http://github.com/LCPQ/quantum_package/tree/master/src/MOGuess>`_
* `Bitmask <http://github.com/LCPQ/quantum_package/tree/master/src/Bitmask>`_
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
`ao_bi_elec_integral_alpha <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L103>`_
Alpha Fock matrix in AO basis set
`ao_bi_elec_integral_beta <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L104>`_
Alpha Fock matrix in AO basis set
`create_guess <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/SCF.irp.f#L13>`_
Create an MO guess if no MOs are present in the EZFIO directory
`damping_scf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/damping_SCF.irp.f#L1>`_
Undocumented
`diagonal_fock_matrix_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/diagonalize_fock.irp.f#L1>`_
Diagonal Fock matrix in the MO basis
`diagonal_fock_matrix_mo_sum <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/diagonalize_fock.irp.f#L95>`_
diagonal element of the fock matrix calculated as the sum over all the interactions
with all the electrons in the RHF determinant
diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij
`eigenvectors_fock_matrix_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/diagonalize_fock.irp.f#L2>`_
Diagonal Fock matrix in the MO basis
`fock_matrix_alpha_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L84>`_
Alpha Fock matrix in AO basis set
`fock_matrix_alpha_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L268>`_
Fock matrix on the MO basis
`fock_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L326>`_
Fock matrix in AO basis set
`fock_matrix_beta_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L85>`_
Alpha Fock matrix in AO basis set
`fock_matrix_beta_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L288>`_
Fock matrix on the MO basis
`fock_matrix_diag_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L2>`_
Fock matrix on the MO basis.
For open shells, the ROHF Fock Matrix is
.br
| F-K | F + K/2 | F |
|---------------------------------|
| F + K/2 | F | F - K/2 |
|---------------------------------|
| F | F - K/2 | F + K |
.br
F = 1/2 (Fa + Fb)
.br
K = Fb - Fa
.br
`fock_matrix_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L1>`_
Fock matrix on the MO basis.
For open shells, the ROHF Fock Matrix is
.br
| F-K | F + K/2 | F |
|---------------------------------|
| F + K/2 | F | F - K/2 |
|---------------------------------|
| F | F - K/2 | F + K |
.br
F = 1/2 (Fa + Fb)
.br
K = Fb - Fa
.br
`fock_mo_to_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L388>`_
Undocumented
`guess <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Huckel_guess.irp.f#L1>`_
Undocumented
`hf_density_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/HF_density_matrix_ao.irp.f#L27>`_
S^-1 Density matrix in the AO basis S^-1
`hf_density_matrix_ao_alpha <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/HF_density_matrix_ao.irp.f#L1>`_
S^-1 x Alpha density matrix in the AO basis x S^-1
`hf_density_matrix_ao_beta <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/HF_density_matrix_ao.irp.f#L14>`_
S^-1 Beta density matrix in the AO basis x S^-1
`hf_energy <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L307>`_
Hartree-Fock energy
`huckel_guess <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/huckel.irp.f#L1>`_
Build the MOs using the extended Huckel model
`level_shift <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L25>`_
Energy shift on the virtual MOs to improve SCF convergence
`mo_guess_type <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L6>`_
Initial MO guess. Can be [ Huckel | HCore ]
`n_it_scf_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L63>`_
Maximum number of SCF iterations
`no_oa_or_av_opt <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L82>`_
If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure
`run <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/SCF.irp.f#L38>`_
Run SCF calculation
`scf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/SCF.irp.f#L1>`_
Produce `Hartree_Fock` MO orbital
output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ
output: hartree_fock.energy
optional: mo_basis.mo_coef
`thresh_scf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L44>`_
Threshold on the convergence of the Hartree Fock energy

132
plugins/SCF_density/damping_SCF.irp.f Normal file
View File

@ -0,0 +1,132 @@
subroutine damping_SCF
implicit none
double precision :: E
double precision, allocatable :: D_alpha(:,:), D_beta(:,:)
double precision :: E_new
double precision, allocatable :: D_new_alpha(:,:), D_new_beta(:,:), F_new(:,:)
double precision, allocatable :: delta_alpha(:,:), delta_beta(:,:)
double precision :: lambda, E_half, a, b, delta_D, delta_E, E_min
integer :: i,j,k
logical :: saving
character :: save_char
allocate( &
D_alpha( ao_num_align, ao_num ), &
D_beta( ao_num_align, ao_num ), &
F_new( ao_num_align, ao_num ), &
D_new_alpha( ao_num_align, ao_num ), &
D_new_beta( ao_num_align, ao_num ), &
delta_alpha( ao_num_align, ao_num ), &
delta_beta( ao_num_align, ao_num ))
do j=1,ao_num
do i=1,ao_num
D_alpha(i,j) = HF_density_matrix_ao_alpha(i,j)
D_beta (i,j) = HF_density_matrix_ao_beta (i,j)
enddo
enddo
call write_time(output_hartree_fock)
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
'====','================','================','================', '===='
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save'
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
'====','================','================','================', '===='
E = HF_energy + 1.d0
E_min = HF_energy
delta_D = 0.d0
do k=1,n_it_scf_max
delta_E = HF_energy - E
E = HF_energy
if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then
exit
endif
saving = E < E_min
if (saving) then
call save_mos
save_char = 'X'
E_min = E
else
save_char = ' '
endif
write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') &
k, E, delta_E, delta_D, save_char
D_alpha = HF_density_matrix_ao_alpha
D_beta = HF_density_matrix_ao_beta
mo_coef = eigenvectors_fock_matrix_mo
TOUCH mo_coef
D_new_alpha = HF_density_matrix_ao_alpha
D_new_beta = HF_density_matrix_ao_beta
F_new = Fock_matrix_ao
E_new = HF_energy
delta_alpha = D_new_alpha - D_alpha
delta_beta = D_new_beta - D_beta
lambda = .5d0
E_half = 0.d0
do while (E_half > E)
HF_density_matrix_ao_alpha = D_alpha + lambda * delta_alpha
HF_density_matrix_ao_beta = D_beta + lambda * delta_beta
TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta
mo_coef = eigenvectors_fock_matrix_mo
TOUCH mo_coef
E_half = HF_energy
if ((E_half > E).and.(E_new < E)) then
lambda = 1.d0
exit
else if ((E_half > E).and.(lambda > 5.d-4)) then
lambda = 0.5d0 * lambda
E_new = E_half
else
exit
endif
enddo
a = (E_new + E - 2.d0*E_half)*2.d0
b = -E_new - 3.d0*E + 4.d0*E_half
lambda = -lambda*b/(a+1.d-16)
D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha
D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta
delta_E = HF_energy - E
do j=1,ao_num
do i=1,ao_num
delta_D = delta_D + &
(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j))*(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j)) + &
(D_beta (i,j) - HF_density_matrix_ao_beta (i,j))*(D_beta (i,j) - HF_density_matrix_ao_beta (i,j))
enddo
enddo
delta_D = dsqrt(delta_D/dble(ao_num)**2)
HF_density_matrix_ao_alpha = D_alpha
HF_density_matrix_ao_beta = D_beta
TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta
mo_coef = eigenvectors_fock_matrix_mo
TOUCH mo_coef
enddo
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '===='
write(output_hartree_fock,*)
if(.not.no_oa_or_av_opt)then
call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1)
endif
call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy')
call ezfio_set_hartree_fock_energy(E_min)
call write_time(output_hartree_fock)
deallocate(D_alpha,D_beta,F_new,D_new_alpha,D_new_beta,delta_alpha,delta_beta)
end

124
plugins/SCF_density/diagonalize_fock.irp.f Normal file
View File

@ -0,0 +1,124 @@
BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ]
&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Diagonal Fock matrix in the MO basis
END_DOC
integer :: i,j
integer :: liwork, lwork, n, info
integer, allocatable :: iwork(:)
double precision, allocatable :: work(:), F(:,:), S(:,:)
allocate( F(mo_tot_num_align,mo_tot_num) )
do j=1,mo_tot_num
do i=1,mo_tot_num
F(i,j) = Fock_matrix_mo(i,j)
enddo
enddo
! print*, no_oa_or_av_opt
if(no_oa_or_av_opt)then
integer :: iorb,jorb
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_inact_orb
jorb = list_inact(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
do j = 1, n_virt_orb
jorb = list_virt(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
do j = 1, n_core_orb
jorb = list_core(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
enddo
! do i = 1, n_act_orb
! iorb = list_act(i)
! write(*,'(100(F16.10,X))')F(iorb,:)
! enddo
endif
! Insert level shift here
do i = elec_beta_num+1, elec_alpha_num
F(i,i) += 0.5d0*level_shift
enddo
do i = elec_alpha_num+1, mo_tot_num
F(i,i) += level_shift
enddo
n = mo_tot_num
lwork = 1+6*n + 2*n*n
liwork = 3 + 5*n
allocate(work(lwork), iwork(liwork) )
lwork = -1
liwork = -1
call dsyevd( 'V', 'U', mo_tot_num, F, &
size(F,1), diagonal_Fock_matrix_mo, &
work, lwork, iwork, liwork, info)
if (info /= 0) then
print *, irp_here//' failed : ', info
stop 1
endif
lwork = int(work(1))
liwork = iwork(1)
deallocate(work,iwork)
allocate(work(lwork), iwork(liwork) )
call dsyevd( 'V', 'U', mo_tot_num, F, &
size(F,1), diagonal_Fock_matrix_mo, &
work, lwork, iwork, liwork, info)
if (info /= 0) then
print *, irp_here//' failed : ', info
stop 1
endif
call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, &
mo_coef, size(mo_coef,1), F, size(F,1), &
0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1))
deallocate(work, iwork, F)
! endif
END_PROVIDER
BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)]
implicit none
BEGIN_DOC
! diagonal element of the fock matrix calculated as the sum over all the interactions
! with all the electrons in the RHF determinant
! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij
END_DOC
integer :: i,j
double precision :: accu
do j = 1,elec_alpha_num
accu = 0.d0
do i = 1, elec_alpha_num
accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
enddo
diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
enddo
do j = elec_alpha_num+1,mo_tot_num
accu = 0.d0
do i = 1, elec_alpha_num
accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
enddo
diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
enddo
END_PROVIDER

32
plugins/SCF_density/huckel.irp.f Normal file
View File

@ -0,0 +1,32 @@
subroutine huckel_guess
implicit none
BEGIN_DOC
! Build the MOs using the extended Huckel model
END_DOC
integer :: i,j
double precision :: accu
double precision :: c
character*(64) :: label
label = "Guess"
call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral, &
size(mo_mono_elec_integral,1), &
size(mo_mono_elec_integral,2),label,1)
TOUCH mo_coef
c = 0.5d0 * 1.75d0
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,ao_num
Fock_matrix_ao(i,j) = c*ao_overlap(i,j)*(ao_mono_elec_integral_diag(i) + &
ao_mono_elec_integral_diag(j))
enddo
Fock_matrix_ao(j,j) = Fock_matrix_alpha_ao(j,j)
enddo
TOUCH Fock_matrix_ao
mo_coef = eigenvectors_fock_matrix_mo
SOFT_TOUCH mo_coef
call save_mos
end

1
plugins/Slater_rules_DFT/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Determinants Integrals_restart_DFT Davidson

12
plugins/Slater_rules_DFT/README.rst Normal file
View File

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

38
plugins/Slater_rules_DFT/Slater_rules_DFT.main.irp.f Normal file
View File

@ -0,0 +1,38 @@
program Slater_rules_DFT
implicit none
BEGIN_DOC
! TODO
END_DOC
print *, ' _/ '
print *, ' -:\_?, _Jm####La '
print *, 'J"(:" > _]#AZ#Z#UUZ##, '
print *, '_,::./ %(|i%12XmX1*1XL _?, '
print *, ' \..\ _\(vmWQwodY+ia%lnL _",/ ( '
print *, ' .:< ]J=mQD?WXn<uQWmmvd, -.-:=!'
print *, ' "{Z jC]QW|=3Zv)Bi3BmXv3 = _7'
print *, ' ]h[Z6)WQ;)jZs]C;|$BZv+, : ./ '
print *, ' -#sJX%$Wmm#ev]hinW#Xi:` c ; '
print *, ' #X#X23###1}vI$WWmX1>|,)nr" '
print *, ' 4XZ#Xov1v}=)vnXAX1nnv;1n" '
print *, ' ]XX#ZXoovvvivnnnlvvo2*i7 '
print *, ' "23Z#1S2oo2XXSnnnoSo2>v" '
print *, ' miX#L -~`""!!1}oSoe|i7 '
print *, ' 4cn#m, v221=|v[ '
print *, ' ]hI3Zma,;..__wXSe=+vo '
print *, ' ]Zov*XSUXXZXZXSe||vo2 '
print *, ' ]Z#><iiii|i||||==vn2( '
print *, ' ]Z#i<ii||+|=||=:{no2[ '
print *, ' ]ZUsiiiiivi|=||=vo22[ '
print *, ' ]XZvlliiIi|i=|+|vooo '
print *, ' =v1llli||||=|||||lii( '
print *, ' ]iillii||||||||=>=|< '
print *, ' -ziiiii||||||+||==+> '
print *, ' -%|+++||=|=+|=|==/ '
print *, ' -a>====+|====-:- '
print *, ' "~,- -- /- '
print *, ' -. )> '
print *, ' .~ +- '
print *, ' . .... : . '
print *, ' -------~ '
print *, ''
end

7
plugins/Slater_rules_DFT/energy.irp.f Normal file
View File

@ -0,0 +1,7 @@
! BEGIN_PROVIDER [double precision, energy_total]
!&BEGIN_PROVIDER [double precision, energy_one_electron]
!&BEGIN_PROVIDER [double precision, energy_hartree]
!&BEGIN_PROVIDER [double precision, energy]
! implicit none
!
!END_PROVIDER

445
plugins/Slater_rules_DFT/slater_rules_erf.irp.f Normal file
View File

@ -0,0 +1,445 @@
subroutine i_H_j_erf(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_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 big_array_exchange_integrals_erf
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 * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1))
else if (exc(1,2,1) ==exc(1,1,2))then
hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2))
else
hij = phase*get_mo_bielec_integral_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 += -big_array_exchange_integrals_erf(occ(i,1),m,p) + big_array_coulomb_integrals_erf(occ(i,1),m,p)
enddo
do i = 1, n_occ_ab(2)
hij += big_array_coulomb_integrals_erf(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 += -big_array_exchange_integrals_erf(occ(i,2),m,p) + big_array_coulomb_integrals_erf(occ(i,2),m,p)
enddo
do i = 1, n_occ_ab(1)
hij += big_array_coulomb_integrals_erf(occ(i,1),m,p)
enddo
endif
hij = hij + mo_nucl_elec_integral(m,p) + mo_kinetic_integral(m,p)
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)
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)
diag_H_mat_elem_erf += mo_nucl_elec_integral(occ(i,1),mo_nucl_elec_integral(i,1))
do j = i+1, n_occ_ab(1)
diag_H_mat_elem_erf += mo_bielec_integral_erf_jj_anti(occ(i,1),occ(j,1))
enddo
enddo
! beta - beta
do i = 1, n_occ_ab(2)
diag_H_mat_elem_erf += mo_nucl_elec_integral(occ(i,2),mo_nucl_elec_integral(i,2))
do j = i+1, n_occ_ab(2)
diag_H_mat_elem_erf += mo_bielec_integral_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_bielec_integral_erf_jj(occ(i,1),occ(j,2))
enddo
enddo
end
subroutine i_H_j_erf_and_short_coulomb(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_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 big_array_exchange_integrals_erf
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 * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1))
else if (exc(1,2,1) ==exc(1,1,2))then
hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2))
else
hij = phase*get_mo_bielec_integral_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 += -big_array_exchange_integrals_erf(occ(i,1),m,p) + big_array_coulomb_integrals_erf(occ(i,1),m,p)
enddo
do i = 1, n_occ_ab(2)
hij += big_array_coulomb_integrals_erf(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 += -big_array_exchange_integrals_erf(occ(i,2),m,p) + big_array_coulomb_integrals_erf(occ(i,2),m,p)
enddo
do i = 1, n_occ_ab(1)
hij += big_array_coulomb_integrals_erf(occ(i,1),m,p)
enddo
endif
hij = hij + mo_nucl_elec_integral(m,p) + mo_kinetic_integral(m,p) + effective_short_range_operator(m,p)
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_and_short_coulomb(key_i,Nint)
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_and_short_coulomb = 0.d0
! alpha - alpha
do i = 1, n_occ_ab(1)
diag_H_mat_elem_erf_and_short_coulomb += mo_nucl_elec_integral(occ(i,1),mo_nucl_elec_integral(i,1)) + mo_kinetic_integral(occ(i,1),mo_nucl_elec_integral(i,1)) &
+ effective_short_range_operator(occ(i,1),occ(i,1))
do j = i+1, n_occ_ab(1)
diag_H_mat_elem_erf_and_short_coulomb += mo_bielec_integral_erf_jj_anti(occ(i,1),occ(j,1))
enddo
enddo
! beta - beta
do i = 1, n_occ_ab(2)
diag_H_mat_elem_erf_and_short_coulomb += mo_nucl_elec_integral(occ(i,2),mo_nucl_elec_integral(i,2)) + mo_kinetic_integral(occ(i,2),mo_nucl_elec_integral(i,2)) &
+ effective_short_range_operator(occ(i,2),occ(i,2))
do j = i+1, n_occ_ab(2)
diag_H_mat_elem_erf_and_short_coulomb += mo_bielec_integral_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_and_short_coulomb += mo_bielec_integral_erf_jj(occ(i,1),occ(j,2))
enddo
enddo
end
subroutine i_H_j_erf_component(key_i,key_j,Nint,hij_core,hij_hartree,hij_erf,hij_total)
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_core
double precision, intent(out) :: hij_hartree
double precision, intent(out) :: hij_erf
double precision, intent(out) :: hij_total
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 big_array_exchange_integrals_erf
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_core = 0.d0
hij_hartree = 0.d0
hij_erf = 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_erf = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1))
else if (exc(1,2,1) ==exc(1,1,2))then
hij_erf = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2))
else
hij_erf = 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_erf = 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_erf = 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_erf += -big_array_exchange_integrals_erf(occ(i,1),m,p) + big_array_coulomb_integrals_erf(occ(i,1),m,p)
enddo
do i = 1, n_occ_ab(2)
hij_erf += big_array_coulomb_integrals_erf(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_erf += -big_array_exchange_integrals_erf(occ(i,2),m,p) + big_array_coulomb_integrals_erf(occ(i,2),m,p)
enddo
do i = 1, n_occ_ab(1)
hij_erf += big_array_coulomb_integrals_erf(occ(i,1),m,p)
enddo
endif
hij_core = mo_nucl_elec_integral(m,p) + mo_kinetic_integral(m,p)
hij_hartree = effective_short_range_operator(m,p)
hij_total = (hij_erf + hij_core + hij_hartree) * phase
case (0)
call diag_H_mat_elem_erf_component(key_i,hij_core,hij_hartree,hij_erf,hij_total,Nint)
end select
end
subroutine diag_H_mat_elem_erf_component(key_i,hij_core,hij_hartree,hij_erf,hij_total,Nint)
implicit none
integer(bit_kind), intent(in) :: key_i(N_int,2)
integer, intent(in) :: Nint
double precision, intent(out) :: hij_core
double precision, intent(out) :: hij_hartree
double precision, intent(out) :: hij_erf
double precision, intent(out) :: hij_total
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)
hij_core = 0.d0
hij_hartree = 0.d0
hij_erf = 0.d0
! alpha - alpha
do i = 1, n_occ_ab(1)
hij_core += mo_nucl_elec_integral(occ(i,1),mo_nucl_elec_integral(i,1)) + mo_kinetic_integral(occ(i,1),mo_nucl_elec_integral(i,1))
hij_hartree += effective_short_range_operator(occ(i,1),occ(i,1))
do j = i+1, n_occ_ab(1)
hij_erf += mo_bielec_integral_erf_jj_anti(occ(i,1),occ(j,1))
enddo
enddo
! beta - beta
do i = 1, n_occ_ab(2)
hij_core += mo_nucl_elec_integral(occ(i,2),mo_nucl_elec_integral(i,2)) + mo_kinetic_integral(occ(i,2),mo_nucl_elec_integral(i,2))
hij_hartree += effective_short_range_operator(occ(i,2),occ(i,2))
do j = i+1, n_occ_ab(2)
hij_erf += mo_bielec_integral_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)
hij_erf += mo_bielec_integral_erf_jj(occ(i,1),occ(j,2))
enddo
enddo
hij_total = hij_erf + hij_hartree + hij_core
end

5
plugins/core_integrals/.gitignore vendored Normal file
View File

@ -0,0 +1,5 @@
IRPF90_temp/
IRPF90_man/
irpf90.make
irpf90_entities
tags

1
plugins/core_integrals/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Integrals_Monoelec Integrals_Bielec Bitmask

12
plugins/core_integrals/README.rst Normal file
View File

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

7
plugins/core_integrals/core_integrals.main.irp.f Normal file
View File

@ -0,0 +1,7 @@
program core_integrals
implicit none
BEGIN_DOC
! TODO
END_DOC
print*,'core energy = ',core_energy
end

32
plugins/core_integrals/core_quantities.irp.f Normal file
View File

@ -0,0 +1,32 @@
BEGIN_PROVIDER [double precision, core_energy]
implicit none
integer :: i,j,k,l
core_energy = 0.d0
do i = 1, n_core_orb
j = list_core(i)
core_energy += 2.d0 * mo_mono_elec_integral(j,j) + mo_bielec_integral_jj(j,j)
do k = i+1, n_core_orb
l = list_core(k)
core_energy += 2.d0 * (2.d0 * mo_bielec_integral_jj(j,l) - mo_bielec_integral_jj_exchange(j,l))
enddo
enddo
core_energy += nuclear_repulsion
END_PROVIDER
BEGIN_PROVIDER [double precision, core_fock_operator, (mo_tot_num,mo_tot_num)]
implicit none
integer :: i,j,k,l,m,n
double precision :: get_mo_bielec_integral
core_fock_operator = 0.d0
do i = 1, n_act_orb
j = list_act(i)
do k = 1, n_act_orb
l = list_act(k)
do m = 1, n_core_orb
n = list_core(m)
core_fock_operator(j,l) += 2.d0 * get_mo_bielec_integral(j,n,l,n,mo_integrals_map) - get_mo_bielec_integral(j,n,n,l,mo_integrals_map)
enddo
enddo
enddo
END_PROVIDER

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