LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-06-26 06:22:04 +02:00
Code Releases Activity

Merge pull request #98 from QuantumPackage/cleaning_dft

Browse Source 
Cleaning dft
This commit is contained in:
Anthony Scemama 2020-04-02 16:17:27 +02:00 committed by GitHub
commit 9c9b219aba
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
52 changed files with 3928 additions and 4753 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
src/README.rst
View File

@ -1,3 +1,51 @@
==========================
The core modules of the QP
==========================
*** How are handled the DFT functionals in QP2 ?
================================================
The Exchange and Correlation energies/potentials can be accessed by the following providers
energy_x
energy_c
potential_x_alpha_ao
potential_c_alpha_ao
potential_x_beta_ao
potential_c_beta_ao
These providers are automatically linked to the providers of the actual exchange/correlation energies of a given functional
through the character keywords
"exchange_functional"
"correlation_functional"
All the providers for the available functionals are in the folder "functionals", with one file "my_functional.irp.f" per functional.
Ex : if "exchange_functional" == "sr_pbe", then energy_x will contain the exchange correlation functional defined in "functiona/sr_pbe.irp.f", which corresponds to the short-range PBE functional (at the value mu_erf for the range separation parameter)
*** How are handled the DFT functionals in QP2 ?
================================================
Creating a new functional and propagating it through the whole QP2 programs is easy as all dependencies are handled by a script.
To do so, let us assume that the name of your functional is "my_func".
Then you just have to create the file "my_func.irp.f" in the folder "functional" which shoud contain
+) if you're adding an exchange functional, then create the provider "energy_x_my_func"
+) if you're adding a correlation functional, create the provider "energy_c_my_func"
+) if you want to add the echange potentials, create the providers "potential_x_alpha_ao_my_func", "potential_x_beta_ao_my_func" which are the exchange potentials on the AO basis for the alpha/beta electrons
+) if you want to add the correlation potentials, create the providers "potential_c_alpha_ao_my_func", "potential_c_beta_ao_my_func" which are the correlation potentials on the AO basis for the alpha/beta electrons
That's all :)
Then, when running whatever DFT calculation or accessing/using the providers:
energy_x
energy_c
potential_x_alpha_ao
potential_c_alpha_ao
potential_x_beta_ao
potential_c_beta_ao
if exchange_functional = mu_func, then you will automatically have access to what you need, such as kohn sham orbital optimization and so on ...

5
src/bitmask/EZFIO.cfg Normal file
View File

@ -0,0 +1,5 @@
[n_act_orb]
type: integer
doc: Number of active |MOs|
interface: ezfio

36
src/bitmask/core_inact_act_virt.irp.f
View File

@ -49,9 +49,10 @@ BEGIN_PROVIDER [ integer, n_act_orb]
n_act_orb += 1
endif
enddo
call write_int(6,n_act_orb, 'Number of active MOs')
if (mpi_master) then
call ezfio_set_bitmask_n_act_orb(n_act_orb)
endif
END_PROVIDER
BEGIN_PROVIDER [ integer, n_virt_orb ]
@ -413,3 +414,34 @@ END_PROVIDER
print *, list_inact_act(1:n_inact_act_orb)
END_PROVIDER
BEGIN_PROVIDER [integer, n_all_but_del_orb]
implicit none
integer :: i
n_all_but_del_orb = 0
do i = 1, mo_num
if( trim(mo_class(i))=="Core" &
.or. trim(mo_class(i))=="Inactive" &
.or. trim(mo_class(i))=="Active" &
.or. trim(mo_class(i))=="Virtual" )then
n_all_but_del_orb +=1
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [integer, list_all_but_del_orb, (n_all_but_del_orb)]
implicit none
integer :: i,j
j = 0
do i = 1, mo_num
if( trim(mo_class(i))=="Core" &
.or. trim(mo_class(i))=="Inactive" &
.or. trim(mo_class(i))=="Active" &
.or. trim(mo_class(i))=="Virtual" )then
j += 1
list_all_but_del_orb(j) = i
endif
enddo
END_PROVIDER

8
src/casscf/densities.irp.f
View File

@ -49,15 +49,11 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ]
P0tuvx= 0.d0
do istate=1,N_states
do x = 1, n_act_orb
xx = list_act(x)
do v = 1, n_act_orb
vv = list_act(v)
do u = 1, n_act_orb
uu = list_act(u)
do t = 1, n_act_orb
tt = list_act(t)
P0tuvx(t,u,v,x) = state_av_act_two_rdm_spin_trace_mo(t,v,u,x)
! P0tuvx(t,u,v,x) = act_two_rdm_spin_trace_mo(t,v,u,x)
! 1 1 2 2 1 2 1 2
P0tuvx(t,u,v,x) = state_av_act_2_rdm_spin_trace_mo(t,v,u,x)
enddo
enddo
enddo

55
src/casscf/get_energy.irp.f
View File

@ -24,40 +24,6 @@ subroutine print_grad
enddo
end
subroutine routine_bis
implicit none
integer :: i,j
double precision :: accu_d,accu_od
!accu_d = 0.d0
!accu_od = 0.d0
!print*,''
!print*,''
!print*,''
!do i = 1, mo_num
! write(*,'(100(F8.5,X))')super_ci_dm(i,:)
! accu_d += super_ci_dm(i,i)
! do j = i+1, mo_num
! accu_od += dabs(super_ci_dm(i,j) - super_ci_dm(j,i))
! enddo
!enddo
!print*,''
!print*,''
!print*,'accu_d = ',accu_d
!print*,'n_elec = ',elec_num
!print*,'accu_od= ',accu_od
!print*,''
!accu_d = 0.d0
!do i = 1, N_det
! accu_d += psi_coef(i,1)**2
!enddo
!print*,'accu_d = ',accu_d
!provide superci_natorb
provide switch_mo_coef
mo_coef = switch_mo_coef
call save_mos
end
subroutine routine
integer :: i,j,k,l
integer :: ii,jj,kk,ll
@ -75,30 +41,11 @@ subroutine routine
do ii = 1, n_act_orb
i = list_act(ii)
integral = get_two_e_integral(i,j,k,l,mo_integrals_map)
accu(1) += state_av_act_two_rdm_spin_trace_mo(ii,jj,kk,ll) * integral
accu(1) += state_av_act_2_rdm_spin_trace_mo(ii,jj,kk,ll) * integral
enddo
enddo
enddo
enddo
print*,'accu = ',accu(1)
accu = 0.d0
do ll = 1, n_act_orb
l = list_act(ll)
do kk = 1, n_act_orb
k = list_act(kk)
do jj = 1, n_act_orb
j = list_act(jj)
do ii = 1, n_act_orb
i = list_act(ii)
integral = get_two_e_integral(i,j,k,l,mo_integrals_map)
accu(1) += state_av_act_two_rdm_openmp_spin_trace_mo(ii,jj,kk,ll) * integral
enddo
enddo
enddo
enddo
print*,'accu = ',accu(1)
print*,'psi_energy_two_e = ',psi_energy_two_e
print *, psi_energy_with_nucl_rep
end

6
src/density_for_dft/EZFIO.cfg
View File

@ -11,10 +11,10 @@ interface: ezfio,provider,ocaml
default: 0.5
[no_core_density]
type: character*(32)
doc: Type of density. If [no_core_dm] then all elements of the density matrix involving at least one orbital set as core are set to zero
type: logical
doc: If [no_core_density] then all elements of the density matrix involving at least one orbital set as core are set to zero. The default is False in order to take all the density.
interface: ezfio, provider, ocaml
default: full_density
default: False
[normalize_dm]
type: logical

4
src/density_for_dft/density_for_dft.irp.f
View File

@ -22,7 +22,7 @@ BEGIN_PROVIDER [double precision, one_e_dm_mo_alpha_for_dft, (mo_num,mo_num, N_s
one_e_dm_mo_alpha_for_dft(:,:,1) = one_e_dm_mo_alpha_average(:,:)
endif
if(no_core_density .EQ. "no_core_dm")then
if(no_core_density)then
integer :: ii,i,j
do ii = 1, n_core_orb
i = list_core(ii)
@ -73,7 +73,7 @@ BEGIN_PROVIDER [double precision, one_e_dm_mo_beta_for_dft, (mo_num,mo_num, N_st
one_e_dm_mo_beta_for_dft(:,:,1) = one_e_dm_mo_beta_average(:,:)
endif
if(no_core_density .EQ. "no_core_dm")then
if(no_core_density)then
integer :: ii,i,j
do ii = 1, n_core_orb
i = list_core(ii)

4
src/dft_keywords/EZFIO.cfg
View File

@ -2,13 +2,13 @@
type: character*(32)
doc: name of the exchange functional
interface: ezfio, provider, ocaml
default: short_range_LDA
default: sr_pbe
[correlation_functional]
type: character*(32)
doc: name of the correlation functional
interface: ezfio, provider, ocaml
default: short_range_LDA
default: sr_pbe
[HF_exchange]
type: double precision

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

@ -1,435 +1,103 @@
subroutine dm_dft_alpha_beta_at_r(r,dm_a,dm_b)
implicit none
BEGIN_PROVIDER [double precision, one_e_dm_and_grad_alpha_in_r, (4,n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_e_dm_and_grad_beta_in_r, (4,n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_e_grad_2_dm_alpha_at_r, (n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_e_grad_2_dm_beta_at_r, (n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, scal_prod_grad_one_e_dm_ab, (n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_e_stuff_for_pbe, (3,n_points_final_grid,N_states) ]
BEGIN_DOC
! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z
! output : dm_a = alpha density evaluated at r(3)
! output : dm_b = beta density evaluated at r(3)
! one_e_dm_and_grad_alpha_in_r(1,i,i_state) = d\dx n_alpha(r_i,istate)
!
! one_e_dm_and_grad_alpha_in_r(2,i,i_state) = d\dy n_alpha(r_i,istate)
!
! one_e_dm_and_grad_alpha_in_r(3,i,i_state) = d\dz n_alpha(r_i,istate)
!
! one_e_dm_and_grad_alpha_in_r(4,i,i_state) = n_alpha(r_i,istate)
!
! one_e_grad_2_dm_alpha_at_r(i,istate) = (d\dx n_alpha(r_i,istate))^2 + (d\dy n_alpha(r_i,istate))^2 + (d\dz n_alpha(r_i,istate))^2
!
! scal_prod_grad_one_e_dm_ab(i,istate) = grad n_alpha(r_i) . grad n_beta(r_i)
!
! where r_i is the ith point of the grid and istate is the state number
!
! !!!!! WARNING !!!! if no_core_density = .True. then all core electrons are removed
END_DOC
double precision, intent(in) :: r(3)
double precision, intent(out) :: dm_a(N_states),dm_b(N_states)
integer :: istate
double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v
call give_all_aos_at_r(r,aos_array)
do istate = 1, N_states
aos_array_bis = aos_array
! alpha density
call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1)
dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! beta density
aos_array_bis = aos_array
call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1)
dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
enddo
end
subroutine dm_dft_alpha_beta_and_all_aos_at_r(r,dm_a,dm_b,aos_array)
BEGIN_DOC
! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z
! output : dm_a = alpha density evaluated at r
! output : dm_b = beta density evaluated at r
! output : aos_array(i) = ao(i) evaluated at r
END_DOC
implicit none
double precision, intent(in) :: r(3)
double precision, intent(out) :: dm_a(N_states),dm_b(N_states)
double precision, intent(out) :: aos_array(ao_num)
integer :: istate
double precision :: aos_array_bis(ao_num),u_dot_v
call give_all_aos_at_r(r,aos_array)
do istate = 1, N_states
aos_array_bis = aos_array
! alpha density
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1)
dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! beta density
aos_array_bis = aos_array
call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),size(one_e_dm_beta_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1)
dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
enddo
end
subroutine density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, grad_dm_a, grad_dm_b, aos_array, grad_aos_array)
implicit none
BEGIN_DOC
! input:
!
! * r(1) ==> r(1) = x, r(2) = y, r(3) = z
!
! output:
!
! * dm_a = alpha density evaluated at r
! * dm_b = beta density evaluated at r
! * aos_array(i) = ao(i) evaluated at r
! * grad_dm_a(1) = X gradient of the alpha density evaluated in r
! * grad_dm_a(1) = X gradient of the beta density evaluated in r
! * grad_aos_array(1) = X gradient of the aos(i) evaluated at r
!
END_DOC
double precision, intent(in) :: r(3)
double precision, intent(out) :: dm_a(N_states),dm_b(N_states)
double precision, intent(out) :: grad_dm_a(3,N_states),grad_dm_b(3,N_states)
double precision, intent(out) :: grad_aos_array(3,ao_num)
integer :: i,j,istate
double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v
double precision :: aos_grad_array(ao_num,3), aos_grad_array_bis(ao_num,3)
call give_all_aos_and_grad_at_r(r,aos_array,grad_aos_array)
do i = 1, ao_num
do j = 1, 3
aos_grad_array(i,j) = grad_aos_array(j,i)
enddo
enddo
do istate = 1, N_states
! alpha density
! aos_array_bis = \rho_ao * aos_array
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1)
dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i)
grad_dm_a(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num)
grad_dm_a(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num)
grad_dm_a(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num)
! aos_grad_array_bis = \rho_ao * aos_grad_array
! beta density
call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),size(one_e_dm_beta_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1)
dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i)
grad_dm_b(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num)
grad_dm_b(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num)
grad_dm_b(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num)
! aos_grad_array_bis = \rho_ao * aos_grad_array
enddo
grad_dm_a *= 2.d0
grad_dm_b *= 2.d0
end
subroutine density_and_grad_lapl_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, grad_dm_a, grad_dm_b, lapl_dm_a, lapl_dm_b, aos_array, grad_aos_array, lapl_aos_array)
implicit none
BEGIN_DOC
! input:
!
! * r(1) ==> r(1) = x, r(2) = y, r(3) = z
!
! output:
!
! * dm_a = alpha density evaluated at r
! * dm_b = beta density evaluated at r
! * aos_array(i) = ao(i) evaluated at r
! * grad_dm_a(1) = X gradient of the alpha density evaluated in r
! * grad_dm_a(1) = X gradient of the beta density evaluated in r
! * grad_aos_array(1) = X gradient of the aos(i) evaluated at r
!
END_DOC
double precision, intent(in) :: r(3)
double precision, intent(out) :: dm_a(N_states),dm_b(N_states)
double precision, intent(out) :: grad_dm_a(3,N_states),grad_dm_b(3,N_states)
double precision, intent(out) :: lapl_dm_a(3,N_states),lapl_dm_b(3,N_states)
double precision, intent(out) :: grad_aos_array(3,ao_num)
double precision, intent(out) :: lapl_aos_array(3,ao_num)
integer :: i,j,istate
double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v
double precision :: aos_grad_array(ao_num,3), aos_grad_array_bis(ao_num,3)
double precision :: aos_lapl_array(ao_num,3)
call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,grad_aos_array,lapl_aos_array)
do i = 1, ao_num
do j = 1, 3
aos_grad_array(i,j) = grad_aos_array(j,i)
aos_lapl_array(i,j) = lapl_aos_array(j,i)
enddo
enddo
do istate = 1, N_states
! alpha density
! aos_array_bis = \rho_ao * aos_array
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1)
dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i)
grad_dm_a(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num)
grad_dm_a(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num)
grad_dm_a(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num)
! lapl_dm(1) = \sum_i aos_lapl_array(i,1) * aos_array_bis(i)
lapl_dm_a(1,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,1),aos_array_bis,ao_num)
lapl_dm_a(2,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,2),aos_array_bis,ao_num)
lapl_dm_a(3,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,3),aos_array_bis,ao_num)
! aos_grad_array_bis(1) = \rho_ao * aos_grad_array(1)
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,1),1,0.d0,aos_grad_array_bis(1,1),1)
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,2),1,0.d0,aos_grad_array_bis(1,2),1)
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,3),1,0.d0,aos_grad_array_bis(1,3),1)
! lapl_dm(1) += \sum_i aos_grad_array(i,1) * aos_grad_array_bis(i)
lapl_dm_a(1,istate) += 2.d0 * u_dot_v(aos_grad_array(1,1),aos_grad_array_bis,ao_num)
lapl_dm_a(2,istate) += 2.d0 * u_dot_v(aos_grad_array(1,2),aos_grad_array_bis,ao_num)
lapl_dm_a(3,istate) += 2.d0 * u_dot_v(aos_grad_array(1,3),aos_grad_array_bis,ao_num)
! beta density
call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),size(one_e_dm_beta_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1)
dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i)
grad_dm_b(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num)
grad_dm_b(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num)
grad_dm_b(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num)
! lapl_dm(1) = \sum_i aos_lapl_array(i,1) * aos_array_bis(i)
lapl_dm_b(1,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,1),aos_array_bis,ao_num)
lapl_dm_b(2,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,2),aos_array_bis,ao_num)
lapl_dm_b(3,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,3),aos_array_bis,ao_num)
! aos_grad_array_bis(1) = \rho_ao * aos_grad_array(1)
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,1),1,0.d0,aos_grad_array_bis(1,1),1)
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,2),1,0.d0,aos_grad_array_bis(1,2),1)
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,3),1,0.d0,aos_grad_array_bis(1,3),1)
! lapl_dm(1) += \sum_i aos_grad_array(i,1) * aos_grad_array_bis(i)
lapl_dm_b(1,istate) += 2.d0 * u_dot_v(aos_grad_array(1,1),aos_grad_array_bis,ao_num)
lapl_dm_b(2,istate) += 2.d0 * u_dot_v(aos_grad_array(1,2),aos_grad_array_bis,ao_num)
lapl_dm_b(3,istate) += 2.d0 * u_dot_v(aos_grad_array(1,3),aos_grad_array_bis,ao_num)
enddo
grad_dm_a *= 2.d0
grad_dm_b *= 2.d0
end
subroutine dm_dft_alpha_beta_no_core_at_r(r,dm_a,dm_b)
implicit none
BEGIN_DOC
! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z
! output : dm_a = alpha density evaluated at r(3) without the core orbitals
! output : dm_b = beta density evaluated at r(3) without the core orbitals
END_DOC
double precision, intent(in) :: r(3)
double precision, intent(out) :: dm_a(N_states),dm_b(N_states)
integer :: istate
double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v
call give_all_aos_at_r(r,aos_array)
do istate = 1, N_states
aos_array_bis = aos_array
! alpha density
call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_alpha_ao_for_dft_no_core(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1)
dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! beta density
aos_array_bis = aos_array
call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_beta_ao_for_dft_no_core(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1)
dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
enddo
end
subroutine dens_grad_a_b_no_core_and_aos_grad_aos_at_r(r,dm_a,dm_b, grad_dm_a, grad_dm_b, aos_array, grad_aos_array)
implicit none
BEGIN_DOC
! input:
!
! * r(1) ==> r(1) = x, r(2) = y, r(3) = z
!
! output:
!
! * dm_a = alpha density evaluated at r without the core orbitals
! * dm_b = beta density evaluated at r without the core orbitals
! * aos_array(i) = ao(i) evaluated at r without the core orbitals
! * grad_dm_a(1) = X gradient of the alpha density evaluated in r without the core orbitals
! * grad_dm_a(1) = X gradient of the beta density evaluated in r without the core orbitals
! * grad_aos_array(1) = X gradient of the aos(i) evaluated at r
!
END_DOC
double precision, intent(in) :: r(3)
double precision, intent(out) :: dm_a(N_states),dm_b(N_states)
double precision, intent(out) :: grad_dm_a(3,N_states),grad_dm_b(3,N_states)
double precision, intent(out) :: grad_aos_array(3,ao_num)
integer :: i,j,istate
double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v
double precision :: aos_grad_array(ao_num,3), aos_grad_array_bis(ao_num,3)
call give_all_aos_and_grad_at_r(r,aos_array,grad_aos_array)
do i = 1, ao_num
do j = 1, 3
aos_grad_array(i,j) = grad_aos_array(j,i)
enddo
enddo
do istate = 1, N_states
! alpha density
! aos_array_bis = \rho_ao * aos_array
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft_no_core(1,1,istate),size(one_e_dm_alpha_ao_for_dft_no_core,1),aos_array,1,0.d0,aos_array_bis,1)
dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i)
grad_dm_a(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num)
grad_dm_a(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num)
grad_dm_a(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num)
! aos_grad_array_bis = \rho_ao * aos_grad_array
! beta density
call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft_no_core(1,1,istate),size(one_e_dm_beta_ao_for_dft_no_core,1),aos_array,1,0.d0,aos_array_bis,1)
dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i)
grad_dm_b(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num)
grad_dm_b(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num)
grad_dm_b(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num)
! aos_grad_array_bis = \rho_ao * aos_grad_array
enddo
grad_dm_a *= 2.d0
grad_dm_b *= 2.d0
end
BEGIN_PROVIDER [double precision, one_e_dm_alpha_in_r, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ]
&BEGIN_PROVIDER [double precision, one_e_dm_beta_in_r, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ]
implicit none
integer :: i,j,k,l,m,istate
double precision :: contrib
double precision :: r(3)
double precision :: aos_array(ao_num),mos_array(mo_num)
do j = 1, nucl_num
do k = 1, n_points_radial_grid -1
do l = 1, n_points_integration_angular
do istate = 1, N_States
one_e_dm_alpha_in_r(l,k,j,istate) = 0.d0
one_e_dm_beta_in_r(l,k,j,istate) = 0.d0
enddo
r(1) = grid_points_per_atom(1,l,k,j)
r(2) = grid_points_per_atom(2,l,k,j)
r(3) = grid_points_per_atom(3,l,k,j)
double precision, allocatable :: aos_array(:),grad_aos_array(:,:)
double precision, allocatable :: dm_a(:),dm_b(:), dm_a_grad(:,:), dm_b_grad(:,:)
allocate(dm_a(N_states),dm_b(N_states), dm_a_grad(3,N_states), dm_b_grad(3,N_states))
allocate(aos_array(ao_num),grad_aos_array(3,ao_num))
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
double precision :: dm_a(N_states),dm_b(N_states)
call dm_dft_alpha_beta_at_r(r,dm_a,dm_b)
do istate=1,N_states
one_e_dm_alpha_in_r(l,k,j,istate) = dm_a(istate)
one_e_dm_beta_in_r(l,k,j,istate) = dm_b(istate)
enddo
call density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, dm_a_grad, dm_b_grad, aos_array, grad_aos_array)
enddo
enddo
! alpha/beta density
one_e_dm_and_grad_alpha_in_r(4,i,istate) = dm_a(istate)
one_e_dm_and_grad_beta_in_r(4,i,istate) = dm_b(istate)
! alpha/beta density gradients
one_e_dm_and_grad_alpha_in_r(1,i,istate) = dm_a_grad(1,istate)
one_e_dm_and_grad_alpha_in_r(2,i,istate) = dm_a_grad(2,istate)
one_e_dm_and_grad_alpha_in_r(3,i,istate) = dm_a_grad(3,istate)
one_e_dm_and_grad_beta_in_r(1,i,istate) = dm_b_grad(1,istate)
one_e_dm_and_grad_beta_in_r(2,i,istate) = dm_b_grad(2,istate)
one_e_dm_and_grad_beta_in_r(3,i,istate) = dm_b_grad(3,istate)
! alpha/beta squared of the gradients
one_e_grad_2_dm_alpha_at_r(i,istate) = dm_a_grad(1,istate) * dm_a_grad(1,istate) &
+ dm_a_grad(2,istate) * dm_a_grad(2,istate) &
+ dm_a_grad(3,istate) * dm_a_grad(3,istate)
one_e_grad_2_dm_beta_at_r(i,istate) = dm_b_grad(1,istate) * dm_b_grad(1,istate) &
+ dm_b_grad(2,istate) * dm_b_grad(2,istate) &
+ dm_b_grad(3,istate) * dm_b_grad(3,istate)
! scalar product between alpha and beta density gradient
scal_prod_grad_one_e_dm_ab(i,istate) = dm_a_grad(1,istate) * dm_b_grad(1,istate) &
+ dm_a_grad(2,istate) * dm_b_grad(2,istate) &
+ dm_a_grad(3,istate) * dm_b_grad(3,istate)
! some stuffs needed for GGA type potentials
one_e_stuff_for_pbe(1,i,istate) = 2.D0 * (dm_a_grad(1,istate) + dm_b_grad(1,istate) ) &
* (dm_a(istate) + dm_b(istate))
one_e_stuff_for_pbe(2,i,istate) = 2.D0 * (dm_a_grad(2,istate) + dm_b_grad(2,istate) ) &
* (dm_a(istate) + dm_b(istate))
one_e_stuff_for_pbe(3,i,istate) = 2.D0 * (dm_a_grad(3,istate) + dm_b_grad(3,istate) ) &
* (dm_a(istate) + dm_b(istate))
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, one_e_dm_alpha_at_r, (n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_e_dm_beta_at_r, (n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, elec_beta_num_grid_becke , (N_states) ]
BEGIN_PROVIDER [double precision, elec_beta_num_grid_becke , (N_states) ]
&BEGIN_PROVIDER [double precision, elec_alpha_num_grid_becke , (N_states) ]
&BEGIN_PROVIDER [double precision, elec_num_grid_becke , (N_states) ]
implicit none
BEGIN_DOC
! one_e_dm_alpha_at_r(i,istate) = n_alpha(r_i,istate)
! one_e_dm_beta_at_r(i,istate) = n_beta(r_i,istate)
! where r_i is the ith point of the grid and istate is the state number
! number of electrons when the one-e alpha/beta densities are numerically integrated on the DFT grid
!
! !!!!! WARNING !!!! if no_core_density = .True. then all core electrons are removed
END_DOC
integer :: i,istate
double precision :: r(3)
double precision, allocatable :: dm_a(:),dm_b(:)
allocate(dm_a(N_states),dm_b(N_states))
double precision :: r(3),weight
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
call dm_dft_alpha_beta_at_r(r,dm_a,dm_b)
one_e_dm_alpha_at_r(i,istate) = dm_a(istate)
one_e_dm_beta_at_r(i,istate) = dm_b(istate)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, one_e_dm_and_grad_alpha_in_r, (4,n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_e_dm_and_grad_beta_in_r, (4,n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_e_grad_2_dm_alpha_at_r, (n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_e_grad_2_dm_beta_at_r, (n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_e_grad_dm_squared_at_r, (3,n_points_final_grid,N_states) ]
BEGIN_DOC
! one_e_dm_and_grad_alpha_in_r(1,i,i_state) = d\dx n_alpha(r_i,istate)
! one_e_dm_and_grad_alpha_in_r(2,i,i_state) = d\dy n_alpha(r_i,istate)
! one_e_dm_and_grad_alpha_in_r(3,i,i_state) = d\dz n_alpha(r_i,istate)
! one_e_dm_and_grad_alpha_in_r(4,i,i_state) = n_alpha(r_i,istate)
! one_e_grad_2_dm_alpha_at_r(i,istate) = (d\dx n_alpha(r_i,istate))^2 + (d\dy n_alpha(r_i,istate))^2 + (d\dz n_alpha(r_i,istate))^2
! where r_i is the ith point of the grid and istate is the state number
END_DOC
implicit none
integer :: i,j,k,l,m,istate
double precision :: contrib
double precision :: r(3)
double precision, allocatable :: aos_array(:),grad_aos_array(:,:)
double precision, allocatable :: dm_a(:),dm_b(:), dm_a_grad(:,:), dm_b_grad(:,:)
allocate(dm_a(N_states),dm_b(N_states), dm_a_grad(3,N_states), dm_b_grad(3,N_states))
allocate(aos_array(ao_num),grad_aos_array(3,ao_num))
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
!!!! Works also with the ao basis
call density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, dm_a_grad, dm_b_grad, aos_array, grad_aos_array)
one_e_dm_and_grad_alpha_in_r(1,i,istate) = dm_a_grad(1,istate)
one_e_dm_and_grad_alpha_in_r(2,i,istate) = dm_a_grad(2,istate)
one_e_dm_and_grad_alpha_in_r(3,i,istate) = dm_a_grad(3,istate)
one_e_dm_and_grad_alpha_in_r(4,i,istate) = dm_a(istate)
one_e_grad_2_dm_alpha_at_r(i,istate) = dm_a_grad(1,istate) * dm_a_grad(1,istate) + dm_a_grad(2,istate) * dm_a_grad(2,istate) + dm_a_grad(3,istate) * dm_a_grad(3,istate)
one_e_dm_and_grad_beta_in_r(1,i,istate) = dm_b_grad(1,istate)
one_e_dm_and_grad_beta_in_r(2,i,istate) = dm_b_grad(2,istate)
one_e_dm_and_grad_beta_in_r(3,i,istate) = dm_b_grad(3,istate)
one_e_dm_and_grad_beta_in_r(4,i,istate) = dm_b(istate)
one_e_grad_2_dm_beta_at_r(i,istate) = dm_b_grad(1,istate) * dm_b_grad(1,istate) + dm_b_grad(2,istate) * dm_b_grad(2,istate) + dm_b_grad(3,istate) * dm_b_grad(3,istate)
one_e_grad_dm_squared_at_r(1,i,istate) = 2.D0 * (dm_a_grad(1,istate) + dm_b_grad(1,istate) ) * (one_e_dm_and_grad_alpha_in_r(4,i,istate) + one_e_dm_and_grad_beta_in_r(4,i,istate))
one_e_grad_dm_squared_at_r(2,i,istate) = 2.D0 * (dm_a_grad(2,istate) + dm_b_grad(2,istate) ) * (one_e_dm_and_grad_alpha_in_r(4,i,istate) + one_e_dm_and_grad_beta_in_r(4,i,istate))
one_e_grad_dm_squared_at_r(3,i,istate) = 2.D0 * (dm_a_grad(3,istate) + dm_b_grad(3,istate) ) * (one_e_dm_and_grad_alpha_in_r(4,i,istate) + one_e_dm_and_grad_beta_in_r(4,i,istate))
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, one_e_dm_no_core_and_grad_alpha_in_r, (4,n_points_final_grid,N_states) ]
&BEGIN_PROVIDER [double precision, one_e_dm_no_core_and_grad_beta_in_r, (4,n_points_final_grid,N_states) ]
BEGIN_DOC
! one_e_dm_no_core_and_grad_alpha_in_r(1,i,i_state) = d\dx n_alpha(r_i,istate) without core orbitals
! one_e_dm_no_core_and_grad_alpha_in_r(2,i,i_state) = d\dy n_alpha(r_i,istate) without core orbitals
! one_e_dm_no_core_and_grad_alpha_in_r(3,i,i_state) = d\dz n_alpha(r_i,istate) without core orbitals
! one_e_dm_no_core_and_grad_alpha_in_r(4,i,i_state) = n_alpha(r_i,istate) without core orbitals
! where r_i is the ith point of the grid and istate is the state number
END_DOC
implicit none
integer :: i,j,k,l,m,istate
double precision :: contrib
double precision :: r(3)
double precision, allocatable :: aos_array(:),grad_aos_array(:,:)
double precision, allocatable :: dm_a(:),dm_b(:), dm_a_grad(:,:), dm_b_grad(:,:)
allocate(dm_a(N_states),dm_b(N_states), dm_a_grad(3,N_states), dm_b_grad(3,N_states))
allocate(aos_array(ao_num),grad_aos_array(3,ao_num))
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
!!!! Works also with the ao basis
call dens_grad_a_b_no_core_and_aos_grad_aos_at_r(r,dm_a,dm_b, dm_a_grad, dm_b_grad, aos_array, grad_aos_array)
one_e_dm_no_core_and_grad_alpha_in_r(1,i,istate) = dm_a_grad(1,istate)
one_e_dm_no_core_and_grad_alpha_in_r(2,i,istate) = dm_a_grad(2,istate)
one_e_dm_no_core_and_grad_alpha_in_r(3,i,istate) = dm_a_grad(3,istate)
one_e_dm_no_core_and_grad_alpha_in_r(4,i,istate) = dm_a(istate)
one_e_dm_no_core_and_grad_beta_in_r(1,i,istate) = dm_b_grad(1,istate)
one_e_dm_no_core_and_grad_beta_in_r(2,i,istate) = dm_b_grad(2,istate)
one_e_dm_no_core_and_grad_beta_in_r(3,i,istate) = dm_b_grad(3,istate)
one_e_dm_no_core_and_grad_beta_in_r(4,i,istate) = dm_b(istate)
weight = final_weight_at_r_vector(i)
elec_alpha_num_grid_becke(istate) += one_e_dm_and_grad_alpha_in_r(4,i,istate) * weight
elec_beta_num_grid_becke(istate) += one_e_dm_and_grad_beta_in_r(4,i,istate) * weight
enddo
elec_num_grid_becke(istate) = elec_alpha_num_grid_becke(istate) + elec_beta_num_grid_becke(istate)
enddo
END_PROVIDER

290
src/dft_utils_in_r/dm_in_r_routines.irp.f Normal file
View File

@ -0,0 +1,290 @@
subroutine dm_dft_alpha_beta_at_r(r,dm_a,dm_b)
implicit none
BEGIN_DOC
! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z
! output : dm_a = alpha density evaluated at r(3)
! output : dm_b = beta density evaluated at r(3)
END_DOC
double precision, intent(in) :: r(3)
double precision, intent(out) :: dm_a(N_states),dm_b(N_states)
integer :: istate
double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v
call give_all_aos_at_r(r,aos_array)
do istate = 1, N_states
aos_array_bis = aos_array
! alpha density
call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1)
dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! beta density
aos_array_bis = aos_array
call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1)
dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
enddo
end
subroutine dm_dft_alpha_beta_and_all_aos_at_r(r,dm_a,dm_b,aos_array)
BEGIN_DOC
! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z
! output : dm_a = alpha density evaluated at r
! output : dm_b = beta density evaluated at r
! output : aos_array(i) = ao(i) evaluated at r
END_DOC
implicit none
double precision, intent(in) :: r(3)
double precision, intent(out) :: dm_a(N_states),dm_b(N_states)
double precision, intent(out) :: aos_array(ao_num)
integer :: istate
double precision :: aos_array_bis(ao_num),u_dot_v
call give_all_aos_at_r(r,aos_array)
do istate = 1, N_states
aos_array_bis = aos_array
! alpha density
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1)
dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! beta density
aos_array_bis = aos_array
call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),size(one_e_dm_beta_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1)
dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
enddo
end
subroutine density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, grad_dm_a, grad_dm_b, aos_array, grad_aos_array)
implicit none
BEGIN_DOC
! input:
!
! * r(1) ==> r(1) = x, r(2) = y, r(3) = z
!
! output:
!
! * dm_a = alpha density evaluated at r
! * dm_b = beta density evaluated at r
! * aos_array(i) = ao(i) evaluated at r
! * grad_dm_a(1) = X gradient of the alpha density evaluated in r
! * grad_dm_a(1) = X gradient of the beta density evaluated in r
! * grad_aos_array(1) = X gradient of the aos(i) evaluated at r
!
END_DOC
double precision, intent(in) :: r(3)
double precision, intent(out) :: dm_a(N_states),dm_b(N_states)
double precision, intent(out) :: grad_dm_a(3,N_states),grad_dm_b(3,N_states)
double precision, intent(out) :: grad_aos_array(3,ao_num)
integer :: i,j,istate
double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v
double precision :: aos_grad_array(ao_num,3), aos_grad_array_bis(ao_num,3)
call give_all_aos_and_grad_at_r(r,aos_array,grad_aos_array)
do i = 1, ao_num
do j = 1, 3
aos_grad_array(i,j) = grad_aos_array(j,i)
enddo
enddo
do istate = 1, N_states
! alpha density
! aos_array_bis = \rho_ao * aos_array
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1)
dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i)
grad_dm_a(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num)
grad_dm_a(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num)
grad_dm_a(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num)
! aos_grad_array_bis = \rho_ao * aos_grad_array
! beta density
call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),size(one_e_dm_beta_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1)
dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i)
grad_dm_b(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num)
grad_dm_b(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num)
grad_dm_b(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num)
! aos_grad_array_bis = \rho_ao * aos_grad_array
enddo
grad_dm_a *= 2.d0
grad_dm_b *= 2.d0
end
subroutine density_and_grad_lapl_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, grad_dm_a, grad_dm_b, lapl_dm_a, lapl_dm_b, aos_array, grad_aos_array, lapl_aos_array)
implicit none
BEGIN_DOC
! input:
!
! * r(1) ==> r(1) = x, r(2) = y, r(3) = z
!
! output:
!
! * dm_a = alpha density evaluated at r
! * dm_b = beta density evaluated at r
! * aos_array(i) = ao(i) evaluated at r
! * grad_dm_a(1) = X gradient of the alpha density evaluated in r
! * grad_dm_a(1) = X gradient of the beta density evaluated in r
! * grad_aos_array(1) = X gradient of the aos(i) evaluated at r
!
END_DOC
double precision, intent(in) :: r(3)
double precision, intent(out) :: dm_a(N_states),dm_b(N_states)
double precision, intent(out) :: grad_dm_a(3,N_states),grad_dm_b(3,N_states)
double precision, intent(out) :: lapl_dm_a(3,N_states),lapl_dm_b(3,N_states)
double precision, intent(out) :: grad_aos_array(3,ao_num)
double precision, intent(out) :: lapl_aos_array(3,ao_num)
integer :: i,j,istate
double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v
double precision :: aos_grad_array(ao_num,3), aos_grad_array_bis(ao_num,3)
double precision :: aos_lapl_array(ao_num,3)
call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,grad_aos_array,lapl_aos_array)
do i = 1, ao_num
do j = 1, 3
aos_grad_array(i,j) = grad_aos_array(j,i)
aos_lapl_array(i,j) = lapl_aos_array(j,i)
enddo
enddo
do istate = 1, N_states
! alpha density
! aos_array_bis = \rho_ao * aos_array
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1)
dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i)
grad_dm_a(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num)
grad_dm_a(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num)
grad_dm_a(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num)
! lapl_dm(1) = \sum_i aos_lapl_array(i,1) * aos_array_bis(i)
lapl_dm_a(1,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,1),aos_array_bis,ao_num)
lapl_dm_a(2,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,2),aos_array_bis,ao_num)
lapl_dm_a(3,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,3),aos_array_bis,ao_num)
! aos_grad_array_bis(1) = \rho_ao * aos_grad_array(1)
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,1),1,0.d0,aos_grad_array_bis(1,1),1)
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,2),1,0.d0,aos_grad_array_bis(1,2),1)
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,3),1,0.d0,aos_grad_array_bis(1,3),1)
! lapl_dm(1) += \sum_i aos_grad_array(i,1) * aos_grad_array_bis(i)
lapl_dm_a(1,istate) += 2.d0 * u_dot_v(aos_grad_array(1,1),aos_grad_array_bis,ao_num)
lapl_dm_a(2,istate) += 2.d0 * u_dot_v(aos_grad_array(1,2),aos_grad_array_bis,ao_num)
lapl_dm_a(3,istate) += 2.d0 * u_dot_v(aos_grad_array(1,3),aos_grad_array_bis,ao_num)
! beta density
call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),size(one_e_dm_beta_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1)
dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i)
grad_dm_b(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num)
grad_dm_b(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num)
grad_dm_b(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num)
! lapl_dm(1) = \sum_i aos_lapl_array(i,1) * aos_array_bis(i)
lapl_dm_b(1,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,1),aos_array_bis,ao_num)
lapl_dm_b(2,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,2),aos_array_bis,ao_num)
lapl_dm_b(3,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,3),aos_array_bis,ao_num)
! aos_grad_array_bis(1) = \rho_ao * aos_grad_array(1)
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,1),1,0.d0,aos_grad_array_bis(1,1),1)
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,2),1,0.d0,aos_grad_array_bis(1,2),1)
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,3),1,0.d0,aos_grad_array_bis(1,3),1)
! lapl_dm(1) += \sum_i aos_grad_array(i,1) * aos_grad_array_bis(i)
lapl_dm_b(1,istate) += 2.d0 * u_dot_v(aos_grad_array(1,1),aos_grad_array_bis,ao_num)
lapl_dm_b(2,istate) += 2.d0 * u_dot_v(aos_grad_array(1,2),aos_grad_array_bis,ao_num)
lapl_dm_b(3,istate) += 2.d0 * u_dot_v(aos_grad_array(1,3),aos_grad_array_bis,ao_num)
enddo
grad_dm_a *= 2.d0
grad_dm_b *= 2.d0
end
subroutine dm_dft_alpha_beta_no_core_at_r(r,dm_a,dm_b)
implicit none
BEGIN_DOC
! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z
! output : dm_a = alpha density evaluated at r(3) without the core orbitals
! output : dm_b = beta density evaluated at r(3) without the core orbitals
END_DOC
double precision, intent(in) :: r(3)
double precision, intent(out) :: dm_a(N_states),dm_b(N_states)
integer :: istate
double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v
call give_all_aos_at_r(r,aos_array)
do istate = 1, N_states
aos_array_bis = aos_array
! alpha density
call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_alpha_ao_for_dft_no_core(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1)
dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! beta density
aos_array_bis = aos_array
call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_beta_ao_for_dft_no_core(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1)
dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
enddo
end
subroutine dens_grad_a_b_no_core_and_aos_grad_aos_at_r(r,dm_a,dm_b, grad_dm_a, grad_dm_b, aos_array, grad_aos_array)
implicit none
BEGIN_DOC
! input:
!
! * r(1) ==> r(1) = x, r(2) = y, r(3) = z
!
! output:
!
! * dm_a = alpha density evaluated at r without the core orbitals
! * dm_b = beta density evaluated at r without the core orbitals
! * aos_array(i) = ao(i) evaluated at r without the core orbitals
! * grad_dm_a(1) = X gradient of the alpha density evaluated in r without the core orbitals
! * grad_dm_a(1) = X gradient of the beta density evaluated in r without the core orbitals
! * grad_aos_array(1) = X gradient of the aos(i) evaluated at r
!
END_DOC
double precision, intent(in) :: r(3)
double precision, intent(out) :: dm_a(N_states),dm_b(N_states)
double precision, intent(out) :: grad_dm_a(3,N_states),grad_dm_b(3,N_states)
double precision, intent(out) :: grad_aos_array(3,ao_num)
integer :: i,j,istate
double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v
double precision :: aos_grad_array(ao_num,3), aos_grad_array_bis(ao_num,3)
call give_all_aos_and_grad_at_r(r,aos_array,grad_aos_array)
do i = 1, ao_num
do j = 1, 3
aos_grad_array(i,j) = grad_aos_array(j,i)
enddo
enddo
do istate = 1, N_states
! alpha density
! aos_array_bis = \rho_ao * aos_array
call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft_no_core(1,1,istate),size(one_e_dm_alpha_ao_for_dft_no_core,1),aos_array,1,0.d0,aos_array_bis,1)
dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i)
grad_dm_a(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num)
grad_dm_a(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num)
grad_dm_a(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num)
! aos_grad_array_bis = \rho_ao * aos_grad_array
! beta density
call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft_no_core(1,1,istate),size(one_e_dm_beta_ao_for_dft_no_core,1),aos_array,1,0.d0,aos_array_bis,1)
dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num)
! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i)
grad_dm_b(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num)
grad_dm_b(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num)
grad_dm_b(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num)
! aos_grad_array_bis = \rho_ao * aos_grad_array
enddo
grad_dm_a *= 2.d0
grad_dm_b *= 2.d0
end

125
src/dft_utils_one_e/ec_lyp.irp.f
View File

@ -1,125 +0,0 @@
subroutine give_all_stuffs_in_r_for_lyp_88(r,rho,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_2)
implicit none
double precision, intent(in) :: r(3)
double precision, intent(out) :: rho_a(N_states),rho_b(N_states),grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_2(N_states),rho(N_states)
double precision :: grad_rho_a(3,N_states),grad_rho_b(3,N_states),grad_rho_a_b(N_states)
double precision :: grad_aos_array(3,ao_num),aos_array(ao_num)
call density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,rho_a,rho_b, grad_rho_a, grad_rho_b, aos_array, grad_aos_array)
integer :: i,istate
rho = rho_a + rho_b
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do istate = 1, N_states
do i = 1, 3
grad_rho_a_2(istate) += grad_rho_a(i,istate) * grad_rho_a(i,istate)
grad_rho_b_2(istate) += grad_rho_b(i,istate) * grad_rho_b(i,istate)
grad_rho_a_b(istate) += grad_rho_a(i,istate) * grad_rho_b(i,istate)
enddo
enddo
grad_rho_2 = grad_rho_a_2 + grad_rho_b_2 + 2.d0 * grad_rho_a_b
end
double precision function ec_lyp_88(rho,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_2)
implicit none
BEGIN_DOC
! LYP functional of the Lee, Yan, Parr, Phys. Rev B 1988, Vol 37, page 785.
! The expression used is the one by Miehlich, Savin, Stoll, Preuss, CPL, 1989 which gets rid of the laplacian of the density
END_DOC
include 'constants.include.F'
! Input variables
double precision, intent(in) :: rho,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_2
! Local variables
double precision :: a,b,c,d,c_f,omega,delta
double precision :: rho_13,rho_inv_13,rho_83,rho_113,rho_inv_113,denom
double precision :: thr,huge_num,rho_inv
double precision :: cst_2_113,cst_8_3,rho_2,rho_a_2,rho_b_2
double precision :: tmp1,tmp2,tmp3,tmp4
double precision :: big1,big2,big3
! Constants of the LYP correlation functional
a = 0.04918d0
b = 0.132d0
c = 0.2533d0
d = 0.349d0
ec_lyp_88 = 0.d0
thr = 1d-15
huge_num = 1.d0/thr
if(dabs(rho_a).lt.thr)then
return
endif
if(dabs(rho_b).lt.thr)then
return
endif
if(rho.lt.0.d0)then
print*,'pb !! rho.lt.0.d0'
stop
endif
rho_13 = rho**(1.d0/3.d0)
rho_113 = rho**(11.d0/3.d0)
if(dabs(rho_13) < thr) then
rho_inv_13 = huge_num
else
rho_inv_13 = 1.d0/rho_13
endif
if (dabs(rho_113) < thr) then
rho_inv_113 = huge_num
else
rho_inv_113 = 1.d0/rho_113
endif
if (dabs(rho) < thr) then
rho_inv = huge_num
else
rho_inv = 1.d0/rho
endif
! Useful quantities to predefine
denom = 1d0/(1d0 + d*rho_inv_13)
omega = rho_inv_113*exp(-c*rho_inv_13)*denom
delta = c*rho_inv_13 + d*rho_inv_13*denom
c_f = 0.3d0*(3.d0*pi*pi)**(2.d0/3.d0)
rho_2 = rho *rho
rho_a_2 = rho_a*rho_a
rho_b_2 = rho_b*rho_b
cst_2_113 = 2.d0**(11.d0/3.d0)
cst_8_3 = 8.d0/3.d0
! first term in the equation (2) of Preuss CPL, 1989
big1 = 4.d0*denom*rho_a*rho_b*rho_inv
tmp1 = cst_2_113*c_f*(rho_a**cst_8_3 + rho_b**cst_8_3)
tmp2 = (47.d0/18.d0 - 7.d0/18.d0*delta)*grad_rho_2
tmp3 = - (5d0/2d0 - 1.d0/18d0*delta)*(grad_rho_a_2 + grad_rho_b_2)
tmp4 = - (delta - 11d0)/9d0*(rho_a*rho_inv*grad_rho_a_2 + rho_b*rho_inv*grad_rho_b_2)
big2 = rho_a*rho_b*(tmp1 + tmp2 + tmp3 + tmp4)
tmp1 = -2d0/3d0*rho_2*grad_rho_2
tmp2 = grad_rho_b_2*(2d0/3d0*rho_2 - rho_a_2)
tmp3 = grad_rho_a_2*(2d0/3d0*rho_2 - rho_b_2)
big3 = tmp1 + tmp2 + tmp3
ec_lyp_88 = -a*big1 -a*b*omega*big2 -a*b*omega*big3
end

28
src/dft_utils_one_e/ec_lyp_2.irp.f
View File

@ -1,28 +0,0 @@
double precision function ec_lyp2(RhoA,RhoB,GA,GB,GAB)
include 'constants.include.F'
implicit none
double precision, intent(in) :: RhoA,RhoB,GA,GB,GAB
double precision :: Tol,caa,cab,cac,cad,cae,RA,RB,comega,cdelta,cLaa,cLbb,cLab,E
ec_lyp2 = 0.d0
Tol=1D-14
E=2.718281828459045D0
caa=0.04918D0
cab=0.132D0
cac=0.2533D0
cad=0.349D0
cae=(2D0**(11D0/3D0))*((3D0/10D0)*((3D0*(Pi**2D0))**(2D0/3D0)))
RA = MAX(RhoA,0D0)
RB = MAX(RhoB,0D0)
IF ((RA.gt.Tol).OR.(RB.gt.Tol)) THEN
IF ((RA.gt.Tol).AND.(RB.gt.Tol)) THEN
comega = 1D0/(E**(cac/(RA+RB)**(1D0/3D0))*(RA+RB)**(10D0/3D0)*(cad+(RA+RB)**(1D0/3D0)))
cdelta = (cac+cad+(cac*cad)/(RA+RB)**(1D0/3D0))/(cad+(RA+RB)**(1D0/3D0))
cLaa = (cab*comega*RB*(RA-3D0*cdelta*RA-9D0*RB-((-11D0+cdelta)*RA**2D0)/(RA+RB)))/9D0
cLbb = (cab*comega*RA*(-9D0*RA+(RB*(RA-3D0*cdelta*RA-4D0*(-3D0+cdelta)*RB))/(RA+RB)))/9D0
cLab = cab*comega*(((47D0-7D0*cdelta)*RA*RB)/9D0-(4D0*(RA+RB)**2D0)/3D0)
ec_lyp2 = -(caa*(cLaa*GA+cLab*GAB+cLbb*GB+cab*cae*comega*RA*RB*(RA**(8D0/3D0)+RB**(8D0/3D0))+(4D0*RA*RB)/(RA+RB+cad*(RA+RB)**(2D0/3D0))))
endif
endif
end

99
src/dft_utils_one_e/ec_scan.irp.f
View File

@ -1,99 +0,0 @@
double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2)
include 'constants.include.F'
implicit none
double precision, intent(in) :: rho_a,rho_b,tau,grad_rho_2
double precision :: cst_13,cst_23,cst_43,cst_53,rho_inv,cst_18,cst_3pi2
double precision :: thr,nup,ndo,xi,s,spin_d,drho,drho2,rho,inv_1alph,e_c_lsda1,h0
double precision :: rs,t_w,t_unif,ds_xi,alpha,fc_alpha,step_f,cst_1alph,beta_inf
double precision :: c_1c,c_2c,d_c,e_c_ldsa1,h1,phi,t,beta_rs,gama,a,w_1,g_at2,phi_3,e_c_1
double precision :: b_1c,b_2c,b_3c,dx_xi,gc_xi,e_c_lsda0,w_0,g_inf,cx_xi,x_inf,f0,e_c_0
thr = 1.d-12
nup = max(rho_a,thr)
ndo = max(rho_b,thr)
rho = nup + ndo
ec_scan = 0.d0
if((rho).lt.thr)return
! constants ...
rho_inv = 1.d0/rho
cst_13 = 1.d0/3.d0
cst_23 = 2.d0 * cst_13
cst_43 = 4.d0 * cst_13
cst_53 = 5.d0 * cst_13
cst_18 = 1.d0/8.d0
cst_3pi2 = 3.d0 * pi*pi
drho2 = max(grad_rho_2,thr)
drho = dsqrt(drho2)
if((nup-ndo).gt.0.d0)then
spin_d = max(nup-ndo,thr)
else
spin_d = min(nup-ndo,-thr)
endif
c_1c = 0.64d0
c_2c = 1.5d0
d_c = 0.7d0
b_1c = 0.0285764d0
b_2c = 0.0889d0
b_3c = 0.125541d0
gama = 0.031091d0
! correlation energy lsda1
call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1)
! correlation energy per particle
e_c_lsda1 = e_c_lsda1/rho
xi = spin_d/rho
rs = (cst_43 * pi * rho)**(-cst_13)
s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 )
t_w = drho2 * cst_18 * rho_inv
ds_xi = 0.5d0 * ( (1.d0+xi)**cst_53 + (1.d0 - xi)**cst_53)
t_unif = 0.3d0 * (cst_3pi2)**cst_23 * rho**cst_53*ds_xi
t_unif = max(t_unif,thr)
alpha = (tau - t_w)/t_unif
cst_1alph= 1.d0 - alpha
if(cst_1alph.gt.0.d0)then
cst_1alph= max(cst_1alph,thr)
else
cst_1alph= min(cst_1alph,-thr)
endif
inv_1alph= 1.d0/cst_1alph
phi = 0.5d0 * ( (1.d0+xi)**cst_23 + (1.d0 - xi)**cst_23)
phi_3 = phi*phi*phi
t = (cst_3pi2/16.d0)**cst_13 * s / (phi * rs**0.5d0)
w_1 = dexp(-e_c_lsda1/(gama * phi_3)) - 1.d0
a = beta_rs(rs) /(gama * w_1)
g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0
h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2))
! interpolation function
if(cst_1alph.gt.0.d0)then
fc_alpha = dexp(-c_1c * alpha * inv_1alph)
else
fc_alpha = - d_c * dexp(c_2c * inv_1alph)
endif
! first part of the correlation energy
e_c_1 = e_c_lsda1 + h1
dx_xi = 0.5d0 * ( (1.d0+xi)**cst_43 + (1.d0 - xi)**cst_43)
gc_xi = (1.d0 - 2.3631d0 * (dx_xi - 1.d0) ) * (1.d0 - xi**12.d0)
e_c_lsda0= - b_1c / (1.d0 + b_2c * rs**0.5d0 + b_3c * rs)
w_0 = dexp(-e_c_lsda0/b_1c) - 1.d0
beta_inf = 0.066725d0 * 0.1d0 / 0.1778d0
cx_xi = -3.d0/(4.d0*pi) * (9.d0 * pi/4.d0)**cst_13 * dx_xi
x_inf = 0.128026d0
f0 = -0.9d0
g_inf = 1.d0/(1.d0 + 4.d0 * x_inf * s*s)**0.25d0
h0 = b_1c * dlog(1.d0 + w_0 * (1.d0 - g_inf))
e_c_0 = (e_c_lsda0 + h0) * gc_xi
ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1)
end
double precision function beta_rs(rs)
implicit none
double precision, intent(in) ::rs
beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs)
end

100
src/dft_utils_one_e/ec_scan_2.irp.f
View File

@ -1,100 +0,0 @@
double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2)
include 'constants.include.F'
implicit none
double precision, intent(in) :: rho_a,rho_b,tau,grad_rho_2
double precision :: cst_13,cst_23,cst_43,cst_53,rho_inv,cst_18,cst_3pi2
double precision :: thr,nup,ndo,xi,s,spin_d,drho,drho2,rho,inv_1alph,e_c_lsda1,h0
double precision :: rs,t_w,t_unif,ds_xi,alpha,fc_alpha,step_f,cst_1alph,beta_inf
double precision :: c_1c,c_2c,d_c,e_c_ldsa1,h1,phi,t,beta_rs,gama,a,w_1,g_at2,phi_3,e_c_1
double precision :: b_1c,b_2c,b_3c,dx_xi,gc_xi,e_c_lsda0,w_0,g_inf,cx_xi,x_inf,f0,e_c_0
thr = 1.d-12
nup = max(rho_a,thr)
ndo = max(rho_b,thr)
rho = nup + ndo
ec_scan = 0.d0
if((rho).lt.thr)return
! constants ...
rho_inv = 1.d0/rho
cst_13 = 1.d0/3.d0
cst_23 = 2.d0 * cst_13
cst_43 = 4.d0 * cst_13
cst_53 = 5.d0 * cst_13
cst_18 = 1.d0/8.d0
cst_3pi2 = 3.d0 * pi*pi
drho2 = max(grad_rho_2,thr)
drho = dsqrt(drho2)
if((nup-ndo).gt.0.d0)then
spin_d = max(nup-ndo,thr)
else
spin_d = min(nup-ndo,-thr)
endif
c_1c = 0.64d0
c_2c = 1.5d0
d_c = 0.7d0
b_1c = 0.0285764d0
b_2c = 0.0889d0
b_3c = 0.125541d0
gama = 0.031091d0
! correlation energy lsda1
call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1)
xi = spin_d/rho
rs = (cst_43 * pi * rho)**(-cst_13)
s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 )
t_w = drho2 * cst_18 * rho_inv
ds_xi = 0.5d0 * ( (1.d0+xi)**cst_53 + (1.d0 - xi)**cst_53)
t_unif = 0.3d0 * (cst_3pi2)**cst_23 * rho**cst_53*ds_xi
t_unif = max(t_unif,thr)
alpha = (tau - t_w)/t_unif
cst_1alph= 1.d0 - alpha
if(cst_1alph.gt.0.d0)then
cst_1alph= max(cst_1alph,thr)
else
cst_1alph= min(cst_1alph,-thr)
endif
inv_1alph= 1.d0/cst_1alph
phi = 0.5d0 * ( (1.d0+xi)**cst_23 + (1.d0 - xi)**cst_23)
phi_3 = phi*phi*phi
t = (cst_3pi2/16.d0)**cst_13 * s / (phi * rs**0.5d0)
w_1 = dexp(-e_c_lsda1/(gama * phi_3)) - 1.d0
a = beta_rs(rs) /(gama * w_1)
g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0
h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2))
! interpolation function
fc_alpha = dexp(-c_1c * alpha * inv_1alph) * step_f(cst_1alph) - d_c * dexp(c_2c * inv_1alph) * step_f(-cst_1alph)
! first part of the correlation energy
e_c_1 = e_c_lsda1 + h1
dx_xi = 0.5d0 * ( (1.d0+xi)**cst_43 + (1.d0 - xi)**cst_43)
gc_xi = (1.d0 - 2.3631d0 * (dx_xi - 1.d0) ) * (1.d0 - xi**12.d0)
e_c_lsda0= - b_1c / (1.d0 + b_2c * rs**0.5d0 + b_3c * rs)
w_0 = dexp(-e_c_lsda0/b_1c) - 1.d0
beta_inf = 0.066725d0 * 0.1d0 / 0.1778d0
cx_xi = -3.d0/(4.d0*pi) * (9.d0 * pi/4.d0)**cst_13 * dx_xi
x_inf = 0.128026d0
f0 = -0.9d0
g_inf = 1.d0/(1.d0 + 4.d0 * x_inf * s*s)**0.25d0
h0 = b_1c * dlog(1.d0 + w_0 * (1.d0 - g_inf))
e_c_0 = (e_c_lsda0 + h0) * gc_xi
ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1)
end
double precision function step_f(x)
implicit none
double precision, intent(in) :: x
if(x.lt.0.d0)then
step_f = 0.d0
else
step_f = 1.d0
endif
end
double precision function beta_rs(rs)
implicit none
double precision, intent(in) ::rs
beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs)
end

6
src/dft_utils_one_e/effective_pot.irp.f
View File

@ -7,10 +7,12 @@
! Effective_one_e_potential(i,j) = $\rangle i_{MO}| v_{H}^{sr} |j_{MO}\rangle + \rangle i_{MO}| h_{core} |j_{MO}\rangle + \rangle i_{MO}|v_{xc} |j_{MO}\rangle$
!
! on the |MO| basis
!
! Taking the expectation value does not provide any energy, but
! effective_one_e_potential(i,j) is the potential coupling DFT and WFT part to
! be used in any WFT calculation.
!
! effective_one_e_potential(i,j) is the potential coupling DFT and WFT parts
!
! and it is used in any RS-DFT based calculations
END_DOC
do istate = 1, N_states
do j = 1, mo_num

264
src/dft_utils_one_e/garbage_func.irp.f Normal file
View File

@ -0,0 +1,264 @@
subroutine give_all_stuffs_in_r_for_lyp_88(r,rho,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_2)
implicit none
double precision, intent(in) :: r(3)
double precision, intent(out) :: rho_a(N_states),rho_b(N_states),grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_2(N_states),rho(N_states)
double precision :: grad_rho_a(3,N_states),grad_rho_b(3,N_states),grad_rho_a_b(N_states)
double precision :: grad_aos_array(3,ao_num),aos_array(ao_num)
call density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,rho_a,rho_b, grad_rho_a, grad_rho_b, aos_array, grad_aos_array)
integer :: i,istate
rho = rho_a + rho_b
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do istate = 1, N_states
do i = 1, 3
grad_rho_a_2(istate) += grad_rho_a(i,istate) * grad_rho_a(i,istate)
grad_rho_b_2(istate) += grad_rho_b(i,istate) * grad_rho_b(i,istate)
grad_rho_a_b(istate) += grad_rho_a(i,istate) * grad_rho_b(i,istate)
enddo
enddo
grad_rho_2 = grad_rho_a_2 + grad_rho_b_2 + 2.d0 * grad_rho_a_b
end
double precision function ec_lyp_88(rho,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_2)
implicit none
BEGIN_DOC
! LYP functional of the Lee, Yan, Parr, Phys. Rev B 1988, Vol 37, page 785.
! The expression used is the one by Miehlich, Savin, Stoll, Preuss, CPL, 1989 which gets rid of the laplacian of the density
END_DOC
include 'constants.include.F'
! Input variables
double precision, intent(in) :: rho,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_2
! Local variables
double precision :: a,b,c,d,c_f,omega,delta
double precision :: rho_13,rho_inv_13,rho_83,rho_113,rho_inv_113,denom
double precision :: thr,huge_num,rho_inv
double precision :: cst_2_113,cst_8_3,rho_2,rho_a_2,rho_b_2
double precision :: tmp1,tmp2,tmp3,tmp4
double precision :: big1,big2,big3
! Constants of the LYP correlation functional
a = 0.04918d0
b = 0.132d0
c = 0.2533d0
d = 0.349d0
ec_lyp_88 = 0.d0
thr = 1d-15
huge_num = 1.d0/thr
if(dabs(rho_a).lt.thr)then
return
endif
if(dabs(rho_b).lt.thr)then
return
endif
if(rho.lt.0.d0)then
print*,'pb !! rho.lt.0.d0'
stop
endif
rho_13 = rho**(1.d0/3.d0)
rho_113 = rho**(11.d0/3.d0)
if(dabs(rho_13) < thr) then
rho_inv_13 = huge_num
else
rho_inv_13 = 1.d0/rho_13
endif
if (dabs(rho_113) < thr) then
rho_inv_113 = huge_num
else
rho_inv_113 = 1.d0/rho_113
endif
if (dabs(rho) < thr) then
rho_inv = huge_num
else
rho_inv = 1.d0/rho
endif
! Useful quantities to predefine
denom = 1d0/(1d0 + d*rho_inv_13)
omega = rho_inv_113*exp(-c*rho_inv_13)*denom
delta = c*rho_inv_13 + d*rho_inv_13*denom
c_f = 0.3d0*(3.d0*pi*pi)**(2.d0/3.d0)
rho_2 = rho *rho
rho_a_2 = rho_a*rho_a
rho_b_2 = rho_b*rho_b
cst_2_113 = 2.d0**(11.d0/3.d0)
cst_8_3 = 8.d0/3.d0
! first term in the equation (2) of Preuss CPL, 1989
big1 = 4.d0*denom*rho_a*rho_b*rho_inv
tmp1 = cst_2_113*c_f*(rho_a**cst_8_3 + rho_b**cst_8_3)
tmp2 = (47.d0/18.d0 - 7.d0/18.d0*delta)*grad_rho_2
tmp3 = - (5d0/2d0 - 1.d0/18d0*delta)*(grad_rho_a_2 + grad_rho_b_2)
tmp4 = - (delta - 11d0)/9d0*(rho_a*rho_inv*grad_rho_a_2 + rho_b*rho_inv*grad_rho_b_2)
big2 = rho_a*rho_b*(tmp1 + tmp2 + tmp3 + tmp4)
tmp1 = -2d0/3d0*rho_2*grad_rho_2
tmp2 = grad_rho_b_2*(2d0/3d0*rho_2 - rho_a_2)
tmp3 = grad_rho_a_2*(2d0/3d0*rho_2 - rho_b_2)
big3 = tmp1 + tmp2 + tmp3
ec_lyp_88 = -a*big1 -a*b*omega*big2 -a*b*omega*big3
end
double precision function ec_lyp2(RhoA,RhoB,GA,GB,GAB)
include 'constants.include.F'
implicit none
double precision, intent(in) :: RhoA,RhoB,GA,GB,GAB
double precision :: Tol,caa,cab,cac,cad,cae,RA,RB,comega,cdelta,cLaa,cLbb,cLab,E
ec_lyp2 = 0.d0
Tol=1D-14
E=2.718281828459045D0
caa=0.04918D0
cab=0.132D0
cac=0.2533D0
cad=0.349D0
cae=(2D0**(11D0/3D0))*((3D0/10D0)*((3D0*(Pi**2D0))**(2D0/3D0)))
RA = MAX(RhoA,0D0)
RB = MAX(RhoB,0D0)
IF ((RA.gt.Tol).OR.(RB.gt.Tol)) THEN
IF ((RA.gt.Tol).AND.(RB.gt.Tol)) THEN
comega = 1D0/(E**(cac/(RA+RB)**(1D0/3D0))*(RA+RB)**(10D0/3D0)*(cad+(RA+RB)**(1D0/3D0)))
cdelta = (cac+cad+(cac*cad)/(RA+RB)**(1D0/3D0))/(cad+(RA+RB)**(1D0/3D0))
cLaa = (cab*comega*RB*(RA-3D0*cdelta*RA-9D0*RB-((-11D0+cdelta)*RA**2D0)/(RA+RB)))/9D0
cLbb = (cab*comega*RA*(-9D0*RA+(RB*(RA-3D0*cdelta*RA-4D0*(-3D0+cdelta)*RB))/(RA+RB)))/9D0
cLab = cab*comega*(((47D0-7D0*cdelta)*RA*RB)/9D0-(4D0*(RA+RB)**2D0)/3D0)
ec_lyp2 = -(caa*(cLaa*GA+cLab*GAB+cLbb*GB+cab*cae*comega*RA*RB*(RA**(8D0/3D0)+RB**(8D0/3D0))+(4D0*RA*RB)/(RA+RB+cad*(RA+RB)**(2D0/3D0))))
endif
endif
end
double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2)
include 'constants.include.F'
implicit none
double precision, intent(in) :: rho_a,rho_b,tau,grad_rho_2
double precision :: cst_13,cst_23,cst_43,cst_53,rho_inv,cst_18,cst_3pi2
double precision :: thr,nup,ndo,xi,s,spin_d,drho,drho2,rho,inv_1alph,e_c_lsda1,h0
double precision :: rs,t_w,t_unif,ds_xi,alpha,fc_alpha,step_f,cst_1alph,beta_inf
double precision :: c_1c,c_2c,d_c,e_c_ldsa1,h1,phi,t,beta_rs,gama,a,w_1,g_at2,phi_3,e_c_1
double precision :: b_1c,b_2c,b_3c,dx_xi,gc_xi,e_c_lsda0,w_0,g_inf,cx_xi,x_inf,f0,e_c_0
thr = 1.d-12
nup = max(rho_a,thr)
ndo = max(rho_b,thr)
rho = nup + ndo
ec_scan = 0.d0
if((rho).lt.thr)return
! constants ...
rho_inv = 1.d0/rho
cst_13 = 1.d0/3.d0
cst_23 = 2.d0 * cst_13
cst_43 = 4.d0 * cst_13
cst_53 = 5.d0 * cst_13
cst_18 = 1.d0/8.d0
cst_3pi2 = 3.d0 * pi*pi
drho2 = max(grad_rho_2,thr)
drho = dsqrt(drho2)
if((nup-ndo).gt.0.d0)then
spin_d = max(nup-ndo,thr)
else
spin_d = min(nup-ndo,-thr)
endif
c_1c = 0.64d0
c_2c = 1.5d0
d_c = 0.7d0
b_1c = 0.0285764d0
b_2c = 0.0889d0
b_3c = 0.125541d0
gama = 0.031091d0
! correlation energy lsda1
call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1)
! correlation energy per particle
e_c_lsda1 = e_c_lsda1/rho
xi = spin_d/rho
rs = (cst_43 * pi * rho)**(-cst_13)
s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 )
t_w = drho2 * cst_18 * rho_inv
ds_xi = 0.5d0 * ( (1.d0+xi)**cst_53 + (1.d0 - xi)**cst_53)
t_unif = 0.3d0 * (cst_3pi2)**cst_23 * rho**cst_53*ds_xi
t_unif = max(t_unif,thr)
alpha = (tau - t_w)/t_unif
cst_1alph= 1.d0 - alpha
if(cst_1alph.gt.0.d0)then
cst_1alph= max(cst_1alph,thr)
else
cst_1alph= min(cst_1alph,-thr)
endif
inv_1alph= 1.d0/cst_1alph
phi = 0.5d0 * ( (1.d0+xi)**cst_23 + (1.d0 - xi)**cst_23)
phi_3 = phi*phi*phi
t = (cst_3pi2/16.d0)**cst_13 * s / (phi * rs**0.5d0)
w_1 = dexp(-e_c_lsda1/(gama * phi_3)) - 1.d0
a = beta_rs(rs) /(gama * w_1)
g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0
h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2))
! interpolation function
if(cst_1alph.gt.0.d0)then
fc_alpha = dexp(-c_1c * alpha * inv_1alph)
else
fc_alpha = - d_c * dexp(c_2c * inv_1alph)
endif
! first part of the correlation energy
e_c_1 = e_c_lsda1 + h1
dx_xi = 0.5d0 * ( (1.d0+xi)**cst_43 + (1.d0 - xi)**cst_43)
gc_xi = (1.d0 - 2.3631d0 * (dx_xi - 1.d0) ) * (1.d0 - xi**12.d0)
e_c_lsda0= - b_1c / (1.d0 + b_2c * rs**0.5d0 + b_3c * rs)
w_0 = dexp(-e_c_lsda0/b_1c) - 1.d0
beta_inf = 0.066725d0 * 0.1d0 / 0.1778d0
cx_xi = -3.d0/(4.d0*pi) * (9.d0 * pi/4.d0)**cst_13 * dx_xi
x_inf = 0.128026d0
f0 = -0.9d0
g_inf = 1.d0/(1.d0 + 4.d0 * x_inf * s*s)**0.25d0
h0 = b_1c * dlog(1.d0 + w_0 * (1.d0 - g_inf))
e_c_0 = (e_c_lsda0 + h0) * gc_xi
ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1)
end
double precision function beta_rs(rs)
implicit none
double precision, intent(in) ::rs
beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs)
end
double precision function step_f(x)
implicit none
double precision, intent(in) :: x
if(x.lt.0.d0)then
step_f = 0.d0
else
step_f = 1.d0
endif
end

4
src/dft_utils_one_e/mu_erf_dft.irp.f
View File

@ -1,7 +1,9 @@
BEGIN_PROVIDER [double precision, mu_erf_dft]
implicit none
BEGIN_DOC
! range separation parameter used in RS-DFT. It is set to mu_erf in order to be consistent with the two electrons integrals erf
! range separation parameter used in RS-DFT.
!
! It is set to mu_erf in order to be consistent with the module "ao_two_e_erf_ints"
END_DOC
mu_erf_dft = mu_erf

34
src/dft_utils_one_e/rho_ab_to_rho_tot.irp.f
View File

@ -1,5 +1,10 @@
subroutine rho_ab_to_rho_oc(rho_a,rho_b,rho_o,rho_c)
implicit none
BEGIN_DOC
! convert rho_alpha, rho_beta to rho_c, rho_o
!
! rho_c = total density, rho_o spin density
END_DOC
double precision, intent(in) :: rho_a,rho_b
double precision, intent(out) :: rho_o,rho_c
rho_c=rho_a+rho_b
@ -8,6 +13,11 @@ end
subroutine rho_oc_to_rho_ab(rho_o,rho_c,rho_a,rho_b)
implicit none
BEGIN_DOC
! convert rho_c, rho_o to rho_alpha, rho_beta
!
! rho_c = total density, rho_o spin density
END_DOC
double precision, intent(in) :: rho_o,rho_c
double precision, intent(out) :: rho_a,rho_b
rho_a= 0.5d0*(rho_c+rho_o)
@ -18,6 +28,13 @@ end
subroutine grad_rho_ab_to_grad_rho_oc(grad_rho_a_2,grad_rho_b_2,grad_rho_a_b,grad_rho_o_2,grad_rho_c_2,grad_rho_o_c)
implicit none
BEGIN_DOC
! convert (grad_rho_a_2, grad_rho_b_2, grad_rho_a.grad_rho_b, )
!
! to (grad_rho_c_2, grad_rho_o_2, grad_rho_o.grad_rho_c)
!
! rho_c = total density, rho_o spin density
END_DOC
double precision, intent(in) :: grad_rho_a_2,grad_rho_b_2,grad_rho_a_b
double precision, intent(out) :: grad_rho_o_2,grad_rho_c_2,grad_rho_o_c
grad_rho_c_2 = grad_rho_a_2 + grad_rho_b_2 + 2d0*grad_rho_a_b
@ -28,6 +45,11 @@ end
subroutine v_rho_ab_to_v_rho_oc(v_rho_a,v_rho_b,v_rho_o,v_rho_c)
BEGIN_DOC
! convert v_rho_alpha, v_rho_beta to v_rho_c, v_rho_o
!
! rho_c = total density, rho_o spin density
END_DOC
implicit none
double precision, intent(in) :: v_rho_a,v_rho_b
double precision, intent(out) :: v_rho_o,v_rho_c
@ -37,6 +59,11 @@ end
subroutine v_rho_oc_to_v_rho_ab(v_rho_o,v_rho_c,v_rho_a,v_rho_b)
implicit none
BEGIN_DOC
! convert v_rho_alpha, v_rho_beta to v_rho_c, v_rho_o
!
! rho_c = total density, rho_o spin density
END_DOC
double precision, intent(in) :: v_rho_o,v_rho_c
double precision, intent(out) :: v_rho_a,v_rho_b
v_rho_a = v_rho_c + v_rho_o
@ -47,6 +74,13 @@ end
subroutine v_grad_rho_oc_to_v_grad_rho_ab(v_grad_rho_o_2,v_grad_rho_c_2,v_grad_rho_o_c,v_grad_rho_a_2,v_grad_rho_b_2,v_grad_rho_a_b)
implicit none
BEGIN_DOC
! convert (v_grad_rho_c_2, v_grad_rho_o_2, v_grad_rho_o.grad_rho_c)
!
! to (v_grad_rho_a_2, v_grad_rho_b_2, v_grad_rho_a.grad_rho_b)
!
! rho_c = total density, rho_o spin density
END_DOC
double precision, intent(in) :: v_grad_rho_o_2,v_grad_rho_c_2,v_grad_rho_o_c
double precision, intent(out) :: v_grad_rho_a_2,v_grad_rho_b_2,v_grad_rho_a_b
v_grad_rho_a_2 = v_grad_rho_o_2 + v_grad_rho_c_2 + v_grad_rho_o_c

0
src/dft_utils_one_e/exc_sr_lda.irp.f → src/dft_utils_one_e/routines_exc_sr_lda.irp.f
View File

16
src/dft_utils_one_e/exc_sr_pbe.irp.f → src/dft_utils_one_e/routines_exc_sr_pbe.irp.f
View File

@ -189,16 +189,27 @@ end
subroutine ex_pbe_sr(mu,rho_a,rho_b,grd_rho_a_2,grd_rho_b_2,grd_rho_a_b,ex,vx_rho_a,vx_rho_b,vx_grd_rho_a_2,vx_grd_rho_b_2,vx_grd_rho_a_b)
BEGIN_DOC
!mu = range separation parameter
!
!rho_a = density alpha
!
!rho_b = density beta
!
!grd_rho_a_2 = (gradient rho_a)^2
!
!grd_rho_b_2 = (gradient rho_b)^2
!
!grd_rho_a_b = (gradient rho_a).(gradient rho_b)
!
!ex = exchange energy density at the density and corresponding gradients of the density
!
!vx_rho_a = d ex / d rho_a
!
!vx_rho_b = d ex / d rho_b
!
!vx_grd_rho_a_2 = d ex / d grd_rho_a_2
!
!vx_grd_rho_b_2 = d ex / d grd_rho_b_2
!
!vx_grd_rho_a_b = d ex / d grd_rho_a_b
END_DOC
@ -313,10 +324,15 @@ END_DOC
subroutine ex_pbe_sr_only(mu,rho_a,rho_b,grd_rho_a_2,grd_rho_b_2,grd_rho_a_b,ex)
BEGIN_DOC
!rho_a = density alpha
!
!rho_b = density beta
!
!grd_rho_a_2 = (gradient rho_a)^2
!
!grd_rho_b_2 = (gradient rho_b)^2
!
!grd_rho_a_b = (gradient rho_a).(gradient rho_b)
!
!ex = exchange energy density at point r
END_DOC

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

@ -1,86 +0,0 @@
BEGIN_PROVIDER[double precision, energy_sr_x_lda, (N_states) ]
&BEGIN_PROVIDER[double precision, energy_sr_c_lda, (N_states) ]
implicit none
BEGIN_DOC
! exchange/correlation energy with the short range lda functional
END_DOC
integer :: istate,i,j
double precision :: r(3)
double precision :: mu,weight
double precision :: e_c,vc_a,vc_b,e_x,vx_a,vx_b
double precision, allocatable :: rhoa(:),rhob(:)
allocate(rhoa(N_states), rhob(N_states))
energy_sr_x_lda = 0.d0
energy_sr_c_lda = 0.d0
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
rhob(istate) = one_e_dm_beta_at_r(i,istate)
call ec_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_c,vc_a,vc_b)
call ex_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_x,vx_a,vx_b)
energy_sr_x_lda(istate) += weight * e_x
energy_sr_c_lda(istate) += weight * e_c
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, energy_sr_x_pbe, (N_states) ]
&BEGIN_PROVIDER[double precision, energy_sr_c_pbe, (N_states) ]
implicit none
BEGIN_DOC
! exchange/correlation energy with the short range pbe functional
END_DOC
integer :: istate,i,j,m
double precision :: r(3)
double precision :: mu,weight
double precision, allocatable :: ex(:), ec(:)
double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:)
double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:)
double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:)
allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states))
allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states))
allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states))
allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states))
energy_sr_x_pbe = 0.d0
energy_sr_c_pbe = 0.d0
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do m = 1, 3
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
enddo
! inputs
call GGA_sr_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation
ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b )
energy_sr_x_pbe += ex * weight
energy_sr_c_pbe += ec * weight
enddo
enddo
END_PROVIDER

62
src/dft_utils_one_e/utils.irp.f
View File

@ -1,58 +1,30 @@
subroutine GGA_sr_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, &
subroutine GGA_sr_type_functionals(mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, &
ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, &
ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b )
implicit none
BEGIN_DOC
! routine that helps in building the x/c potentials on the AO basis for a GGA functional with a short-range interaction
END_DOC
double precision, intent(in) :: r(3),rho_a(N_states),rho_b(N_states),grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states)
double precision, intent(out) :: ex(N_states),vx_rho_a(N_states),vx_rho_b(N_states),vx_grad_rho_a_2(N_states),vx_grad_rho_b_2(N_states),vx_grad_rho_a_b(N_states)
double precision, intent(out) :: ec(N_states),vc_rho_a(N_states),vc_rho_b(N_states),vc_grad_rho_a_2(N_states),vc_grad_rho_b_2(N_states),vc_grad_rho_a_b(N_states)
integer :: istate
double precision :: r2(3),dr2(3), local_potential,r12,dx2,mu
do istate = 1, N_states
call ex_pbe_sr(mu_erf_dft,rho_a(istate),rho_b(istate),grad_rho_a_2(istate),grad_rho_b_2(istate),grad_rho_a_b(istate),ex(istate),vx_rho_a(istate),vx_rho_b(istate),vx_grad_rho_a_2(istate),vx_grad_rho_b_2(istate),vx_grad_rho_a_b(istate))
double precision, intent(in) :: mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b
double precision, intent(out) :: ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b
double precision, intent(out) :: ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b
double precision :: rhoc,rhoo,sigmacc,sigmaco,sigmaoo,vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo
double precision :: rhoc,rhoo,sigmacc,sigmaco,sigmaoo,vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo
! convertion from (alpha,beta) formalism to (closed, open) formalism
call rho_ab_to_rho_oc(rho_a(istate),rho_b(istate),rhoo,rhoc)
call grad_rho_ab_to_grad_rho_oc(grad_rho_a_2(istate),grad_rho_b_2(istate),grad_rho_a_b(istate),sigmaoo,sigmacc,sigmaco)
call ec_pbe_sr(mu_erf_dft,rhoc,rhoo,sigmacc,sigmaco,sigmaoo,ec(istate),vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo)
! exhange energy and potentials
call ex_pbe_sr(mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b,ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b)
call v_rho_oc_to_v_rho_ab(vrhoo,vrhoc,vc_rho_a(istate),vc_rho_b(istate))
call v_grad_rho_oc_to_v_grad_rho_ab(vsigmaoo,vsigmacc,vsigmaco,vc_grad_rho_a_2(istate),vc_grad_rho_b_2(istate),vc_grad_rho_a_b(istate))
enddo
! convertion from (alpha,beta) formalism to (closed, open) formalism
call rho_ab_to_rho_oc(rho_a,rho_b,rhoo,rhoc)
call grad_rho_ab_to_grad_rho_oc(grad_rho_a_2,grad_rho_b_2,grad_rho_a_b,sigmaoo,sigmacc,sigmaco)
! correlation energy and potentials
call ec_pbe_sr(mu,rhoc,rhoo,sigmacc,sigmaco,sigmaoo,ec,vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo)
! convertion from (closed, open) formalism to (alpha,beta) formalism
call v_rho_oc_to_v_rho_ab(vrhoo,vrhoc,vc_rho_a,vc_rho_b)
call v_grad_rho_oc_to_v_grad_rho_ab(vsigmaoo,vsigmacc,vsigmaco,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b)
end
subroutine GGA_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, &
ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, &
ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b )
implicit none
BEGIN_DOC
! routine that helps in building the x/c potentials on the AO basis for a GGA functional
END_DOC
double precision, intent(in) :: r(3),rho_a(N_states),rho_b(N_states),grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states)
double precision, intent(out) :: ex(N_states),vx_rho_a(N_states),vx_rho_b(N_states),vx_grad_rho_a_2(N_states),vx_grad_rho_b_2(N_states),vx_grad_rho_a_b(N_states)
double precision, intent(out) :: ec(N_states),vc_rho_a(N_states),vc_rho_b(N_states),vc_grad_rho_a_2(N_states),vc_grad_rho_b_2(N_states),vc_grad_rho_a_b(N_states)
integer :: istate
double precision :: r2(3),dr2(3), local_potential,r12,dx2
double precision :: mu_local
mu_local = 1.d-9
do istate = 1, N_states
call ex_pbe_sr(mu_local,rho_a(istate),rho_b(istate),grad_rho_a_2(istate),grad_rho_b_2(istate),grad_rho_a_b(istate),ex(istate),vx_rho_a(istate),vx_rho_b(istate),vx_grad_rho_a_2(istate),vx_grad_rho_b_2(istate),vx_grad_rho_a_b(istate))
double precision :: rhoc,rhoo,sigmacc,sigmaco,sigmaoo,vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo
! convertion from (alpha,beta) formalism to (closed, open) formalism
call rho_ab_to_rho_oc(rho_a(istate),rho_b(istate),rhoo,rhoc)
call grad_rho_ab_to_grad_rho_oc(grad_rho_a_2(istate),grad_rho_b_2(istate),grad_rho_a_b(istate),sigmaoo,sigmacc,sigmaco)
call ec_pbe_sr(mu_local,rhoc,rhoo,sigmacc,sigmaco,sigmaoo,ec(istate),vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo)
call v_rho_oc_to_v_rho_ab(vrhoo,vrhoc,vc_rho_a(istate),vc_rho_b(istate))
call v_grad_rho_oc_to_v_grad_rho_ab(vsigmaoo,vsigmacc,vsigmaco,vc_grad_rho_a_2(istate),vc_grad_rho_b_2(istate),vc_grad_rho_a_b(istate))
enddo
end

16
src/functionals/lda.irp.f
View File

@ -19,8 +19,8 @@
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
rhob(istate) = one_e_dm_beta_at_r(i,istate)
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
call ex_lda(rhoa(istate),rhob(istate),e_x,vx_a,vx_b)
energy_x_lda(istate) += weight * e_x
enddo
@ -46,8 +46,8 @@
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
rhob(istate) = one_e_dm_beta_at_r(i,istate)
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
call ec_lda(rhoa(istate),rhob(istate),e_c,vc_a,vc_b)
energy_c_lda(istate) += weight * e_c
enddo
@ -142,8 +142,8 @@ END_PROVIDER
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
rhob(istate) = one_e_dm_beta_at_r(i,istate)
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
call ec_lda_sr(mu_local,rhoa(istate),rhob(istate),e_c,vc_a,vc_b)
call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,vx_a,vx_b)
do j =1, ao_num
@ -181,8 +181,8 @@ END_PROVIDER
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
rhob(istate) = one_e_dm_beta_at_r(i,istate)
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
call ec_lda_sr(mu_local,rhoa(istate),rhob(istate),e_c,vc_a,vc_b)
call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,vx_a,vx_b)
do j =1, ao_num

340
src/functionals/pbe.irp.f
View File

@ -1,114 +1,63 @@
BEGIN_PROVIDER[double precision, energy_x_pbe, (N_states) ]
&BEGIN_PROVIDER[double precision, energy_c_pbe, (N_states) ]
implicit none
BEGIN_DOC
! exchange / correlation energies with the short-range version Perdew-Burke-Ernzerhof GGA functional
!
! defined in Chem. Phys.329, 276 (2006)
END_DOC
BEGIN_DOC
! exchange/correlation energy with the short range pbe functional
END_DOC
integer :: istate,i,j,m
double precision :: r(3)
double precision :: mu,weight
double precision, allocatable :: ex(:), ec(:)
double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:)
double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:)
double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:)
allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states))
allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states))
double precision :: ex, ec
double precision :: rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),grad_rho_a_2,grad_rho_b_2,grad_rho_a_b
double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b
double precision :: vx_grad_rho_a_2, vx_grad_rho_b_2, vx_grad_rho_a_b, vc_grad_rho_a_2, vc_grad_rho_b_2, vc_grad_rho_a_b
allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states))
allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states))
energy_x_pbe = 0.d0
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do m = 1, 3
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
enddo
! inputs
call GGA_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation
ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b )
energy_x_pbe += ex * weight
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, energy_c_pbe, (N_states) ]
implicit none
BEGIN_DOC
! exchange/correlation energy with the short range pbe functional
END_DOC
integer :: istate,i,j,m
double precision :: r(3)
double precision :: mu,weight
double precision, allocatable :: ex(:), ec(:)
double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:)
double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:)
double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:)
allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states))
allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states))
allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states))
allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states))
energy_c_pbe = 0.d0
mu = 0.d0
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do m = 1, 3
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m)
grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m)
grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m)
enddo
! inputs
call GGA_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
call GGA_sr_type_functionals(mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation
ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b )
energy_c_pbe += ec * weight
energy_x_pbe(istate) += ex * weight
energy_c_pbe(istate) += ec * weight
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, potential_x_alpha_ao_pbe,(ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, potential_x_beta_ao_pbe,(ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, potential_c_alpha_ao_pbe,(ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, potential_c_beta_ao_pbe,(ao_num,ao_num,N_states)]
implicit none
BEGIN_DOC
! exchange / correlation potential for alpha / beta electrons with the Perdew-Burke-Ernzerhof GGA functional
! exchange / correlation potential for alpha / beta electrons with the short-range version Perdew-Burke-Ernzerhof GGA functional
!
! defined in Chem. Phys.329, 276 (2006)
END_DOC
integer :: i,j,istate
do istate = 1, n_states
@ -125,8 +74,6 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [double precision, potential_xc_alpha_ao_pbe,(ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, potential_xc_beta_ao_pbe,(ao_num,ao_num,N_states)]
implicit none
@ -138,7 +85,7 @@ END_PROVIDER
do i = 1, ao_num
do j = 1, ao_num
potential_xc_alpha_ao_pbe(j,i,istate) = pot_scal_xc_alpha_ao_pbe(j,i,istate) + pot_grad_xc_alpha_ao_pbe(j,i,istate) + pot_grad_xc_alpha_ao_pbe(i,j,istate)
potential_xc_beta_ao_pbe(j,i,istate) = pot_scal_xc_beta_ao_pbe(j,i,istate) + pot_grad_xc_beta_ao_pbe(j,i,istate) + pot_grad_xc_beta_ao_pbe(i,j,istate)
potential_xc_beta_ao_pbe(j,i,istate) = pot_scal_xc_beta_ao_pbe(j,i,istate) + pot_grad_xc_beta_ao_pbe(j,i,istate) + pot_grad_xc_beta_ao_pbe(i,j,istate)
enddo
enddo
enddo
@ -146,82 +93,76 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER[double precision, aos_vc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_vc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_vx_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_vx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_dvc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_dvc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_dvx_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_dvx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_d_vc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_d_vc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_d_vx_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_d_vx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
implicit none
BEGIN_DOC
! intermediates to compute the sr_pbe potentials
!
! aos_vxc_alpha_pbe_w(j,i) = ao_i(r_j) * (v^x_alpha(r_j) + v^c_alpha(r_j)) * W(r_j)
END_DOC
integer :: istate,i,j,m
double precision :: r(3)
double precision :: mu,weight
double precision, allocatable :: ex(:), ec(:)
double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:)
double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:)
double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:)
allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states))
allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states))
allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states))
allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states))
allocate(contrib_grad_xa(3,N_states),contrib_grad_xb(3,N_states),contrib_grad_ca(3,N_states),contrib_grad_cb(3,N_states))
aos_dvc_alpha_pbe_w = 0.d0
aos_dvc_beta_pbe_w = 0.d0
aos_dvx_alpha_pbe_w = 0.d0
aos_dvx_beta_pbe_w = 0.d0
double precision :: ex, ec
double precision :: rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),grad_rho_a_2,grad_rho_b_2,grad_rho_a_b
double precision :: contrib_grad_xa(3),contrib_grad_xb(3),contrib_grad_ca(3),contrib_grad_cb(3)
double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b
double precision :: vx_grad_rho_a_2, vx_grad_rho_b_2, vx_grad_rho_a_b, vc_grad_rho_a_2, vc_grad_rho_b_2, vc_grad_rho_a_b
aos_d_vc_alpha_pbe_w= 0.d0
aos_d_vc_beta_pbe_w = 0.d0
aos_d_vx_alpha_pbe_w= 0.d0
aos_d_vx_beta_pbe_w = 0.d0
mu = 0.d0
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do m = 1, 3
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m)
grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m)
grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m)
enddo
! inputs
call GGA_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
call GGA_sr_type_functionals(mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation
ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b )
vx_rho_a(istate) *= weight
vc_rho_a(istate) *= weight
vx_rho_b(istate) *= weight
vc_rho_b(istate) *= weight
vx_rho_a *= weight
vc_rho_a *= weight
vx_rho_b *= weight
vc_rho_b *= weight
do m= 1,3
contrib_grad_ca(m,istate) = weight * (2.d0 * vc_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_b(m,istate))
contrib_grad_xa(m,istate) = weight * (2.d0 * vx_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_b(m,istate))
contrib_grad_cb(m,istate) = weight * (2.d0 * vc_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_a(m,istate))
contrib_grad_xb(m,istate) = weight * (2.d0 * vx_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_a(m,istate))
contrib_grad_ca(m) = weight * (2.d0 * vc_grad_rho_a_2 * grad_rho_a(m) + vc_grad_rho_a_b * grad_rho_b(m) )
contrib_grad_xa(m) = weight * (2.d0 * vx_grad_rho_a_2 * grad_rho_a(m) + vx_grad_rho_a_b * grad_rho_b(m) )
contrib_grad_cb(m) = weight * (2.d0 * vc_grad_rho_b_2 * grad_rho_b(m) + vc_grad_rho_a_b * grad_rho_a(m) )
contrib_grad_xb(m) = weight * (2.d0 * vx_grad_rho_b_2 * grad_rho_b(m) + vx_grad_rho_a_b * grad_rho_a(m) )
enddo
do j = 1, ao_num
aos_vc_alpha_pbe_w(j,i,istate) = vc_rho_a(istate) * aos_in_r_array(j,i)
aos_vc_beta_pbe_w (j,i,istate) = vc_rho_b(istate) * aos_in_r_array(j,i)
aos_vx_alpha_pbe_w(j,i,istate) = vx_rho_a(istate) * aos_in_r_array(j,i)
aos_vx_beta_pbe_w (j,i,istate) = vx_rho_b(istate) * aos_in_r_array(j,i)
aos_vc_alpha_pbe_w(j,i,istate) = vc_rho_a * aos_in_r_array(j,i)
aos_vc_beta_pbe_w (j,i,istate) = vc_rho_b * aos_in_r_array(j,i)
aos_vx_alpha_pbe_w(j,i,istate) = vx_rho_a * aos_in_r_array(j,i)
aos_vx_beta_pbe_w (j,i,istate) = vx_rho_b * aos_in_r_array(j,i)
enddo
do j = 1, ao_num
do m = 1,3
aos_dvc_alpha_pbe_w(j,i,istate) += contrib_grad_ca(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dvc_beta_pbe_w (j,i,istate) += contrib_grad_cb(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dvx_alpha_pbe_w(j,i,istate) += contrib_grad_xa(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dvx_beta_pbe_w (j,i,istate) += contrib_grad_xb(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_d_vc_alpha_pbe_w(j,i,istate) += contrib_grad_ca(m) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_d_vc_beta_pbe_w (j,i,istate) += contrib_grad_cb(m) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_d_vx_alpha_pbe_w(j,i,istate) += contrib_grad_xa(m) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_d_vx_beta_pbe_w (j,i,istate) += contrib_grad_xb(m) * aos_grad_in_r_array_transp_xyz(m,j,i)
enddo
enddo
enddo
@ -235,6 +176,8 @@ END_PROVIDER
&BEGIN_PROVIDER [double precision, pot_scal_x_beta_ao_pbe, (ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, pot_scal_c_beta_ao_pbe, (ao_num,ao_num,N_states)]
implicit none
! intermediates to compute the sr_pbe potentials
!
integer :: istate
BEGIN_DOC
! intermediate quantity for the calculation of the vxc potentials for the GGA functionals related to the scalar part of the potential
@ -247,24 +190,24 @@ END_PROVIDER
call wall_time(wall_1)
do istate = 1, N_states
! correlation alpha
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_vc_alpha_pbe_w(1,1,istate),size(aos_vc_alpha_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_vc_alpha_pbe_w(1,1,istate),size(aos_vc_alpha_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
pot_scal_c_alpha_ao_pbe(1,1,istate),size(pot_scal_c_alpha_ao_pbe,1))
! correlation beta
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_vc_beta_pbe_w(1,1,istate),size(aos_vc_beta_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_vc_beta_pbe_w(1,1,istate),size(aos_vc_beta_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
pot_scal_c_beta_ao_pbe(1,1,istate),size(pot_scal_c_beta_ao_pbe,1))
! exchange alpha
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_vx_alpha_pbe_w(1,1,istate),size(aos_vx_alpha_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_vx_alpha_pbe_w(1,1,istate),size(aos_vx_alpha_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
pot_scal_x_alpha_ao_pbe(1,1,istate),size(pot_scal_x_alpha_ao_pbe,1))
! exchange beta
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_vx_beta_pbe_w(1,1,istate),size(aos_vx_beta_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_vx_beta_pbe_w(1,1,istate),size(aos_vx_beta_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
pot_scal_x_beta_ao_pbe(1,1,istate), size(pot_scal_x_beta_ao_pbe,1))
enddo
@ -290,24 +233,24 @@ END_PROVIDER
pot_grad_x_beta_ao_pbe = 0.d0
do istate = 1, N_states
! correlation alpha
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dvc_alpha_pbe_w(1,1,istate),size(aos_dvc_alpha_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_d_vc_alpha_pbe_w(1,1,istate),size(aos_d_vc_alpha_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
pot_grad_c_alpha_ao_pbe(1,1,istate),size(pot_grad_c_alpha_ao_pbe,1))
! correlation beta
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dvc_beta_pbe_w(1,1,istate),size(aos_dvc_beta_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_d_vc_beta_pbe_w(1,1,istate),size(aos_d_vc_beta_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
pot_grad_c_beta_ao_pbe(1,1,istate),size(pot_grad_c_beta_ao_pbe,1))
! exchange alpha
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dvx_alpha_pbe_w(1,1,istate),size(aos_dvx_alpha_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_d_vx_alpha_pbe_w(1,1,istate),size(aos_d_vx_alpha_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
pot_grad_x_alpha_ao_pbe(1,1,istate),size(pot_grad_x_alpha_ao_pbe,1))
! exchange beta
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dvx_beta_pbe_w(1,1,istate),size(aos_dvx_beta_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_d_vx_beta_pbe_w(1,1,istate),size(aos_d_vx_beta_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
pot_grad_x_beta_ao_pbe(1,1,istate),size(pot_grad_x_beta_ao_pbe,1))
enddo
@ -318,70 +261,62 @@ END_PROVIDER
BEGIN_PROVIDER[double precision, aos_vxc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_vxc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_dvxc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_dvxc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_d_vxc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_d_vxc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
implicit none
BEGIN_DOC
! aos_vxc_alpha_pbe_w(j,i) = ao_i(r_j) * (v^x_alpha(r_j) + v^c_alpha(r_j)) * W(r_j)
END_DOC
integer :: istate,i,j,m
double precision :: r(3)
double precision :: mu,weight
double precision, allocatable :: ex(:), ec(:)
double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:)
double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:)
double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:)
allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states))
allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states))
allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states))
allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states))
allocate(contrib_grad_xa(3,N_states),contrib_grad_xb(3,N_states),contrib_grad_ca(3,N_states),contrib_grad_cb(3,N_states))
double precision :: ex, ec
double precision :: rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),grad_rho_a_2,grad_rho_b_2,grad_rho_a_b
double precision :: contrib_grad_xa(3),contrib_grad_xb(3),contrib_grad_ca(3),contrib_grad_cb(3)
double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b
double precision :: vx_grad_rho_a_2, vx_grad_rho_b_2, vx_grad_rho_a_b, vc_grad_rho_a_2, vc_grad_rho_b_2, vc_grad_rho_a_b
aos_dvxc_alpha_pbe_w = 0.d0
aos_dvxc_beta_pbe_w = 0.d0
mu = 0.d0
aos_d_vxc_alpha_pbe_w = 0.d0
aos_d_vxc_beta_pbe_w = 0.d0
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do m = 1, 3
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m)
grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m)
grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m)
enddo
! inputs
call GGA_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
call GGA_sr_type_functionals(mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation
ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b )
vx_rho_a(istate) *= weight
vc_rho_a(istate) *= weight
vx_rho_b(istate) *= weight
vc_rho_b(istate) *= weight
vx_rho_a *= weight
vc_rho_a *= weight
vx_rho_b *= weight
vc_rho_b *= weight
do m= 1,3
contrib_grad_ca(m,istate) = weight * (2.d0 * vc_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_b(m,istate))
contrib_grad_xa(m,istate) = weight * (2.d0 * vx_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_b(m,istate))
contrib_grad_cb(m,istate) = weight * (2.d0 * vc_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_a(m,istate))
contrib_grad_xb(m,istate) = weight * (2.d0 * vx_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_a(m,istate))
contrib_grad_ca(m) = weight * (2.d0 * vc_grad_rho_a_2 * grad_rho_a(m) + vc_grad_rho_a_b * grad_rho_b(m) )
contrib_grad_xa(m) = weight * (2.d0 * vx_grad_rho_a_2 * grad_rho_a(m) + vx_grad_rho_a_b * grad_rho_b(m) )
contrib_grad_cb(m) = weight * (2.d0 * vc_grad_rho_b_2 * grad_rho_b(m) + vc_grad_rho_a_b * grad_rho_a(m) )
contrib_grad_xb(m) = weight * (2.d0 * vx_grad_rho_b_2 * grad_rho_b(m) + vx_grad_rho_a_b * grad_rho_a(m) )
enddo
do j = 1, ao_num
aos_vxc_alpha_pbe_w(j,i,istate) = ( vc_rho_a(istate) + vx_rho_a(istate) ) * aos_in_r_array(j,i)
aos_vxc_beta_pbe_w (j,i,istate) = ( vc_rho_b(istate) + vx_rho_b(istate) ) * aos_in_r_array(j,i)
aos_vxc_alpha_pbe_w(j,i,istate) = ( vc_rho_a + vx_rho_a ) * aos_in_r_array(j,i)
aos_vxc_beta_pbe_w (j,i,istate) = ( vc_rho_b + vx_rho_b ) * aos_in_r_array(j,i)
enddo
do j = 1, ao_num
do m = 1,3
aos_dvxc_alpha_pbe_w(j,i,istate) += ( contrib_grad_ca(m,istate) + contrib_grad_xa(m,istate) ) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dvxc_beta_pbe_w (j,i,istate) += ( contrib_grad_cb(m,istate) + contrib_grad_xb(m,istate) ) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_d_vxc_alpha_pbe_w(j,i,istate) += ( contrib_grad_ca(m) + contrib_grad_xa(m) ) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_d_vxc_beta_pbe_w (j,i,istate) += ( contrib_grad_cb(m) + contrib_grad_xb(m) ) * aos_grad_in_r_array_transp_xyz(m,j,i)
enddo
enddo
enddo
@ -403,14 +338,14 @@ END_PROVIDER
call wall_time(wall_1)
do istate = 1, N_states
! exchange - correlation alpha
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_vxc_alpha_pbe_w(1,1,istate),size(aos_vxc_alpha_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_vxc_alpha_pbe_w(1,1,istate),size(aos_vxc_alpha_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
pot_scal_xc_alpha_ao_pbe(1,1,istate),size(pot_scal_xc_alpha_ao_pbe,1))
! exchange - correlation beta
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_vxc_beta_pbe_w(1,1,istate),size(aos_vxc_beta_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_vxc_beta_pbe_w(1,1,istate),size(aos_vxc_beta_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
pot_scal_xc_beta_ao_pbe(1,1,istate),size(pot_scal_xc_beta_ao_pbe,1))
enddo
call wall_time(wall_2)
@ -430,18 +365,19 @@ END_PROVIDER
pot_grad_xc_alpha_ao_pbe = 0.d0
pot_grad_xc_beta_ao_pbe = 0.d0
do istate = 1, N_states
! correlation alpha
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dvxc_alpha_pbe_w(1,1,istate),size(aos_dvxc_alpha_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
! exchange - correlation alpha
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_d_vxc_alpha_pbe_w(1,1,istate),size(aos_d_vxc_alpha_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
pot_grad_xc_alpha_ao_pbe(1,1,istate),size(pot_grad_xc_alpha_ao_pbe,1))
! correlation beta
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dvxc_beta_pbe_w(1,1,istate),size(aos_dvxc_beta_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
! exchange - correlation beta
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_d_vxc_beta_pbe_w(1,1,istate),size(aos_d_vxc_beta_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
pot_grad_xc_beta_ao_pbe(1,1,istate),size(pot_grad_xc_beta_ao_pbe,1))
enddo
call wall_time(wall_2)
END_PROVIDER

16
src/functionals/sr_lda.irp.f
View File

@ -19,8 +19,8 @@
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
rhob(istate) = one_e_dm_beta_at_r(i,istate)
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
call ex_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_x,vx_a,vx_b)
energy_x_sr_lda(istate) += weight * e_x
enddo
@ -46,8 +46,8 @@
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
rhob(istate) = one_e_dm_beta_at_r(i,istate)
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
call ec_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_c,vc_a,vc_b)
energy_c_sr_lda(istate) += weight * e_c
enddo
@ -120,8 +120,8 @@ END_PROVIDER
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
rhob(istate) = one_e_dm_beta_at_r(i,istate)
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
call ec_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_c,sr_vc_a,sr_vc_b)
call ex_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_x,sr_vx_a,sr_vx_b)
do j =1, ao_num
@ -156,8 +156,8 @@ END_PROVIDER
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
rhob(istate) = one_e_dm_beta_at_r(i,istate)
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
call ec_lda_sr(mu_local,rhoa(istate),rhob(istate),e_c,sr_vc_a,sr_vc_b)
call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,sr_vx_a,sr_vx_b)
do j =1, ao_num

333
src/functionals/sr_pbe.irp.f
View File

@ -3,55 +3,95 @@
&BEGIN_PROVIDER[double precision, energy_c_sr_pbe, (N_states) ]
implicit none
BEGIN_DOC
! exchange / correlation energies with the short-range version Perdew-Burke-Ernzerhof GGA functional
!
! defined in Chem. Phys.329, 276 (2006)
END_DOC
BEGIN_DOC
! exchange/correlation energy with the short range pbe functional
END_DOC
integer :: istate,i,j,m
double precision :: r(3)
double precision :: mu,weight
double precision, allocatable :: ex(:), ec(:)
double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:)
double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:)
double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:)
allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states))
allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states))
double precision :: ex, ec
double precision :: rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),grad_rho_a_2,grad_rho_b_2,grad_rho_a_b
double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b
double precision :: vx_grad_rho_a_2, vx_grad_rho_b_2, vx_grad_rho_a_b, vc_grad_rho_a_2, vc_grad_rho_b_2, vc_grad_rho_a_b
allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states))
allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states))
energy_x_sr_pbe = 0.d0
energy_c_sr_pbe = 0.d0
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do m = 1, 3
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m)
grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m)
grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m)
enddo
! inputs
call GGA_sr_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
call GGA_sr_type_functionals(mu_erf_dft,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation
ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b )
energy_x_sr_pbe += ex * weight
energy_c_sr_pbe += ec * weight
energy_x_sr_pbe(istate) += ex * weight
energy_c_sr_pbe(istate) += ec * weight
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, potential_x_alpha_ao_sr_pbe,(ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, potential_x_beta_ao_sr_pbe,(ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, potential_c_alpha_ao_sr_pbe,(ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, potential_c_beta_ao_sr_pbe,(ao_num,ao_num,N_states)]
implicit none
BEGIN_DOC
! exchange / correlation potential for alpha / beta electrons with the short-range version Perdew-Burke-Ernzerhof GGA functional
!
! defined in Chem. Phys.329, 276 (2006)
END_DOC
integer :: i,j,istate
do istate = 1, n_states
do i = 1, ao_num
do j = 1, ao_num
potential_x_alpha_ao_sr_pbe(j,i,istate) = pot_sr_scal_x_alpha_ao_pbe(j,i,istate) + pot_sr_grad_x_alpha_ao_pbe(j,i,istate) + pot_sr_grad_x_alpha_ao_pbe(i,j,istate)
potential_x_beta_ao_sr_pbe(j,i,istate) = pot_sr_scal_x_beta_ao_pbe(j,i,istate) + pot_sr_grad_x_beta_ao_pbe(j,i,istate) + pot_sr_grad_x_beta_ao_pbe(i,j,istate)
potential_c_alpha_ao_sr_pbe(j,i,istate) = pot_sr_scal_c_alpha_ao_pbe(j,i,istate) + pot_sr_grad_c_alpha_ao_pbe(j,i,istate) + pot_sr_grad_c_alpha_ao_pbe(i,j,istate)
potential_c_beta_ao_sr_pbe(j,i,istate) = pot_sr_scal_c_beta_ao_pbe(j,i,istate) + pot_sr_grad_c_beta_ao_pbe(j,i,istate) + pot_sr_grad_c_beta_ao_pbe(i,j,istate)
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, potential_xc_alpha_ao_sr_pbe,(ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, potential_xc_beta_ao_sr_pbe,(ao_num,ao_num,N_states)]
implicit none
BEGIN_DOC
! exchange / correlation potential for alpha / beta electrons with the Perdew-Burke-Ernzerhof GGA functional
END_DOC
integer :: i,j,istate
do istate = 1, n_states
do i = 1, ao_num
do j = 1, ao_num
potential_xc_alpha_ao_sr_pbe(j,i,istate) = pot_sr_scal_xc_alpha_ao_pbe(j,i,istate) + pot_sr_grad_xc_alpha_ao_pbe(j,i,istate) + pot_sr_grad_xc_alpha_ao_pbe(i,j,istate)
potential_xc_beta_ao_sr_pbe(j,i,istate) = pot_sr_scal_xc_beta_ao_pbe(j,i,istate) + pot_sr_grad_xc_beta_ao_pbe(j,i,istate) + pot_sr_grad_xc_beta_ao_pbe(i,j,istate)
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, aos_sr_vc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_sr_vc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
@ -63,72 +103,64 @@ END_PROVIDER
&BEGIN_PROVIDER[double precision, aos_dsr_vx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
implicit none
BEGIN_DOC
! intermediates to compute the sr_pbe potentials
!
! aos_sr_vxc_alpha_pbe_w(j,i) = ao_i(r_j) * (v^x_alpha(r_j) + v^c_alpha(r_j)) * W(r_j)
END_DOC
integer :: istate,i,j,m
double precision :: r(3)
double precision :: mu,weight
double precision, allocatable :: ex(:), ec(:)
double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:)
double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:)
double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:)
allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states))
allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states))
allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states))
allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states))
allocate(contrib_grad_xa(3,N_states),contrib_grad_xb(3,N_states),contrib_grad_ca(3,N_states),contrib_grad_cb(3,N_states))
double precision :: ex, ec
double precision :: rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),grad_rho_a_2,grad_rho_b_2,grad_rho_a_b
double precision :: contrib_grad_xa(3),contrib_grad_xb(3),contrib_grad_ca(3),contrib_grad_cb(3)
double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b
double precision :: vx_grad_rho_a_2, vx_grad_rho_b_2, vx_grad_rho_a_b, vc_grad_rho_a_2, vc_grad_rho_b_2, vc_grad_rho_a_b
aos_dsr_vc_alpha_pbe_w= 0.d0
aos_dsr_vc_beta_pbe_w = 0.d0
aos_dsr_vx_alpha_pbe_w= 0.d0
aos_dsr_vx_beta_pbe_w = 0.d0
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do m = 1, 3
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m)
grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m)
grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m)
enddo
! inputs
call GGA_sr_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
call GGA_sr_type_functionals(mu_erf_dft,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation
ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b )
vx_rho_a(istate) *= weight
vc_rho_a(istate) *= weight
vx_rho_b(istate) *= weight
vc_rho_b(istate) *= weight
vx_rho_a *= weight
vc_rho_a *= weight
vx_rho_b *= weight
vc_rho_b *= weight
do m= 1,3
contrib_grad_ca(m,istate) = weight * (2.d0 * vc_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_b(m,istate))
contrib_grad_xa(m,istate) = weight * (2.d0 * vx_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_b(m,istate))
contrib_grad_cb(m,istate) = weight * (2.d0 * vc_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_a(m,istate))
contrib_grad_xb(m,istate) = weight * (2.d0 * vx_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_a(m,istate))
contrib_grad_ca(m) = weight * (2.d0 * vc_grad_rho_a_2 * grad_rho_a(m) + vc_grad_rho_a_b * grad_rho_b(m) )
contrib_grad_xa(m) = weight * (2.d0 * vx_grad_rho_a_2 * grad_rho_a(m) + vx_grad_rho_a_b * grad_rho_b(m) )
contrib_grad_cb(m) = weight * (2.d0 * vc_grad_rho_b_2 * grad_rho_b(m) + vc_grad_rho_a_b * grad_rho_a(m) )
contrib_grad_xb(m) = weight * (2.d0 * vx_grad_rho_b_2 * grad_rho_b(m) + vx_grad_rho_a_b * grad_rho_a(m) )
enddo
do j = 1, ao_num
aos_sr_vc_alpha_pbe_w(j,i,istate) = vc_rho_a(istate) * aos_in_r_array(j,i)
aos_sr_vc_beta_pbe_w (j,i,istate) = vc_rho_b(istate) * aos_in_r_array(j,i)
aos_sr_vx_alpha_pbe_w(j,i,istate) = vx_rho_a(istate) * aos_in_r_array(j,i)
aos_sr_vx_beta_pbe_w (j,i,istate) = vx_rho_b(istate) * aos_in_r_array(j,i)
aos_sr_vc_alpha_pbe_w(j,i,istate) = vc_rho_a * aos_in_r_array(j,i)
aos_sr_vc_beta_pbe_w (j,i,istate) = vc_rho_b * aos_in_r_array(j,i)
aos_sr_vx_alpha_pbe_w(j,i,istate) = vx_rho_a * aos_in_r_array(j,i)
aos_sr_vx_beta_pbe_w (j,i,istate) = vx_rho_b * aos_in_r_array(j,i)
enddo
do j = 1, ao_num
do m = 1,3
aos_dsr_vc_alpha_pbe_w(j,i,istate) += contrib_grad_ca(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dsr_vc_beta_pbe_w (j,i,istate) += contrib_grad_cb(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dsr_vx_alpha_pbe_w(j,i,istate) += contrib_grad_xa(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dsr_vx_beta_pbe_w (j,i,istate) += contrib_grad_xb(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dsr_vc_alpha_pbe_w(j,i,istate) += contrib_grad_ca(m) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dsr_vc_beta_pbe_w (j,i,istate) += contrib_grad_cb(m) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dsr_vx_alpha_pbe_w(j,i,istate) += contrib_grad_xa(m) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dsr_vx_beta_pbe_w (j,i,istate) += contrib_grad_xb(m) * aos_grad_in_r_array_transp_xyz(m,j,i)
enddo
enddo
enddo
@ -142,6 +174,8 @@ END_PROVIDER
&BEGIN_PROVIDER [double precision, pot_sr_scal_x_beta_ao_pbe, (ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, pot_sr_scal_c_beta_ao_pbe, (ao_num,ao_num,N_states)]
implicit none
! intermediates to compute the sr_pbe potentials
!
integer :: istate
BEGIN_DOC
! intermediate quantity for the calculation of the vxc potentials for the GGA functionals related to the scalar part of the potential
@ -154,24 +188,24 @@ END_PROVIDER
call wall_time(wall_1)
do istate = 1, N_states
! correlation alpha
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_sr_vc_alpha_pbe_w(1,1,istate),size(aos_sr_vc_alpha_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_sr_vc_alpha_pbe_w(1,1,istate),size(aos_sr_vc_alpha_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
pot_sr_scal_c_alpha_ao_pbe(1,1,istate),size(pot_sr_scal_c_alpha_ao_pbe,1))
! correlation beta
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_sr_vc_beta_pbe_w(1,1,istate),size(aos_sr_vc_beta_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_sr_vc_beta_pbe_w(1,1,istate),size(aos_sr_vc_beta_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
pot_sr_scal_c_beta_ao_pbe(1,1,istate),size(pot_sr_scal_c_beta_ao_pbe,1))
! exchange alpha
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_sr_vx_alpha_pbe_w(1,1,istate),size(aos_sr_vx_alpha_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_sr_vx_alpha_pbe_w(1,1,istate),size(aos_sr_vx_alpha_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
pot_sr_scal_x_alpha_ao_pbe(1,1,istate),size(pot_sr_scal_x_alpha_ao_pbe,1))
! exchange beta
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_sr_vx_beta_pbe_w(1,1,istate),size(aos_sr_vx_beta_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_sr_vx_beta_pbe_w(1,1,istate),size(aos_sr_vx_beta_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
pot_sr_scal_x_beta_ao_pbe(1,1,istate), size(pot_sr_scal_x_beta_ao_pbe,1))
enddo
@ -197,24 +231,24 @@ END_PROVIDER
pot_sr_grad_x_beta_ao_pbe = 0.d0
do istate = 1, N_states
! correlation alpha
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dsr_vc_alpha_pbe_w(1,1,istate),size(aos_dsr_vc_alpha_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dsr_vc_alpha_pbe_w(1,1,istate),size(aos_dsr_vc_alpha_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
pot_sr_grad_c_alpha_ao_pbe(1,1,istate),size(pot_sr_grad_c_alpha_ao_pbe,1))
! correlation beta
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dsr_vc_beta_pbe_w(1,1,istate),size(aos_dsr_vc_beta_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dsr_vc_beta_pbe_w(1,1,istate),size(aos_dsr_vc_beta_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
pot_sr_grad_c_beta_ao_pbe(1,1,istate),size(pot_sr_grad_c_beta_ao_pbe,1))
! exchange alpha
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dsr_vx_alpha_pbe_w(1,1,istate),size(aos_dsr_vx_alpha_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dsr_vx_alpha_pbe_w(1,1,istate),size(aos_dsr_vx_alpha_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
pot_sr_grad_x_alpha_ao_pbe(1,1,istate),size(pot_sr_grad_x_alpha_ao_pbe,1))
! exchange beta
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dsr_vx_beta_pbe_w(1,1,istate),size(aos_dsr_vx_beta_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dsr_vx_beta_pbe_w(1,1,istate),size(aos_dsr_vx_beta_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
pot_sr_grad_x_beta_ao_pbe(1,1,istate),size(pot_sr_grad_x_beta_ao_pbe,1))
enddo
@ -222,29 +256,6 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [double precision, potential_x_alpha_ao_sr_pbe,(ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, potential_x_beta_ao_sr_pbe,(ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, potential_c_alpha_ao_sr_pbe,(ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, potential_c_beta_ao_sr_pbe,(ao_num,ao_num,N_states)]
implicit none
BEGIN_DOC
! exchange / correlation potential for alpha / beta electrons with the Perdew-Burke-Ernzerhof GGA functional
END_DOC
integer :: i,j,istate
do istate = 1, n_states
do i = 1, ao_num
do j = 1, ao_num
potential_x_alpha_ao_sr_pbe(j,i,istate) = pot_sr_scal_x_alpha_ao_pbe(j,i,istate) + pot_sr_grad_x_alpha_ao_pbe(j,i,istate) + pot_sr_grad_x_alpha_ao_pbe(i,j,istate)
potential_x_beta_ao_sr_pbe(j,i,istate) = pot_sr_scal_x_beta_ao_pbe(j,i,istate) + pot_sr_grad_x_beta_ao_pbe(j,i,istate) + pot_sr_grad_x_beta_ao_pbe(i,j,istate)
potential_c_alpha_ao_sr_pbe(j,i,istate) = pot_sr_scal_c_alpha_ao_pbe(j,i,istate) + pot_sr_grad_c_alpha_ao_pbe(j,i,istate) + pot_sr_grad_c_alpha_ao_pbe(i,j,istate)
potential_c_beta_ao_sr_pbe(j,i,istate) = pot_sr_scal_c_beta_ao_pbe(j,i,istate) + pot_sr_grad_c_beta_ao_pbe(j,i,istate) + pot_sr_grad_c_beta_ao_pbe(i,j,istate)
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, aos_sr_vxc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)]
&BEGIN_PROVIDER[double precision, aos_sr_vxc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
@ -255,65 +266,54 @@ END_PROVIDER
! aos_sr_vxc_alpha_pbe_w(j,i) = ao_i(r_j) * (v^x_alpha(r_j) + v^c_alpha(r_j)) * W(r_j)
END_DOC
integer :: istate,i,j,m
double precision :: r(3)
double precision :: mu,weight
double precision, allocatable :: ex(:), ec(:)
double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:)
double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:)
double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:)
allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states))
allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states))
allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states))
allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states))
allocate(contrib_grad_xa(3,N_states),contrib_grad_xb(3,N_states),contrib_grad_ca(3,N_states),contrib_grad_cb(3,N_states))
double precision :: ex, ec
double precision :: rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),grad_rho_a_2,grad_rho_b_2,grad_rho_a_b
double precision :: contrib_grad_xa(3),contrib_grad_xb(3),contrib_grad_ca(3),contrib_grad_cb(3)
double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b
double precision :: vx_grad_rho_a_2, vx_grad_rho_b_2, vx_grad_rho_a_b, vc_grad_rho_a_2, vc_grad_rho_b_2, vc_grad_rho_a_b
aos_dsr_vxc_alpha_pbe_w = 0.d0
aos_dsr_vxc_beta_pbe_w = 0.d0
do istate = 1, N_states
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
weight = final_weight_at_r_vector(i)
rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate)
rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate)
grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do m = 1, 3
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m)
grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m)
grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m)
enddo
! inputs
call GGA_sr_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
call GGA_sr_type_functionals(mu_erf_dft,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange
ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation
ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b )
vx_rho_a(istate) *= weight
vc_rho_a(istate) *= weight
vx_rho_b(istate) *= weight
vc_rho_b(istate) *= weight
vx_rho_a *= weight
vc_rho_a *= weight
vx_rho_b *= weight
vc_rho_b *= weight
do m= 1,3
contrib_grad_ca(m,istate) = weight * (2.d0 * vc_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_b(m,istate))
contrib_grad_xa(m,istate) = weight * (2.d0 * vx_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_b(m,istate))
contrib_grad_cb(m,istate) = weight * (2.d0 * vc_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_a(m,istate))
contrib_grad_xb(m,istate) = weight * (2.d0 * vx_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_a(m,istate))
contrib_grad_ca(m) = weight * (2.d0 * vc_grad_rho_a_2 * grad_rho_a(m) + vc_grad_rho_a_b * grad_rho_b(m) )
contrib_grad_xa(m) = weight * (2.d0 * vx_grad_rho_a_2 * grad_rho_a(m) + vx_grad_rho_a_b * grad_rho_b(m) )
contrib_grad_cb(m) = weight * (2.d0 * vc_grad_rho_b_2 * grad_rho_b(m) + vc_grad_rho_a_b * grad_rho_a(m) )
contrib_grad_xb(m) = weight * (2.d0 * vx_grad_rho_b_2 * grad_rho_b(m) + vx_grad_rho_a_b * grad_rho_a(m) )
enddo
do j = 1, ao_num
aos_sr_vxc_alpha_pbe_w(j,i,istate) = ( vc_rho_a(istate) + vx_rho_a(istate) ) * aos_in_r_array(j,i)
aos_sr_vxc_beta_pbe_w (j,i,istate) = ( vc_rho_b(istate) + vx_rho_b(istate) ) * aos_in_r_array(j,i)
aos_sr_vxc_alpha_pbe_w(j,i,istate) = ( vc_rho_a + vx_rho_a ) * aos_in_r_array(j,i)
aos_sr_vxc_beta_pbe_w (j,i,istate) = ( vc_rho_b + vx_rho_b ) * aos_in_r_array(j,i)
enddo
do j = 1, ao_num
do m = 1,3
aos_dsr_vxc_alpha_pbe_w(j,i,istate) += ( contrib_grad_ca(m,istate) + contrib_grad_xa(m,istate) ) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dsr_vxc_beta_pbe_w (j,i,istate) += ( contrib_grad_cb(m,istate) + contrib_grad_xb(m,istate) ) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dsr_vxc_alpha_pbe_w(j,i,istate) += ( contrib_grad_ca(m) + contrib_grad_xa(m) ) * aos_grad_in_r_array_transp_xyz(m,j,i)
aos_dsr_vxc_beta_pbe_w (j,i,istate) += ( contrib_grad_cb(m) + contrib_grad_xb(m) ) * aos_grad_in_r_array_transp_xyz(m,j,i)
enddo
enddo
enddo
@ -335,14 +335,14 @@ END_PROVIDER
call wall_time(wall_1)
do istate = 1, N_states
! exchange - correlation alpha
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_sr_vxc_alpha_pbe_w(1,1,istate),size(aos_sr_vxc_alpha_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_sr_vxc_alpha_pbe_w(1,1,istate),size(aos_sr_vxc_alpha_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
pot_sr_scal_xc_alpha_ao_pbe(1,1,istate),size(pot_sr_scal_xc_alpha_ao_pbe,1))
! exchange - correlation beta
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_sr_vxc_beta_pbe_w(1,1,istate),size(aos_sr_vxc_beta_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_sr_vxc_beta_pbe_w(1,1,istate),size(aos_sr_vxc_beta_pbe_w,1), &
aos_in_r_array,size(aos_in_r_array,1),1.d0, &
pot_sr_scal_xc_beta_ao_pbe(1,1,istate),size(pot_sr_scal_xc_beta_ao_pbe,1))
enddo
call wall_time(wall_2)
@ -363,14 +363,14 @@ END_PROVIDER
pot_sr_grad_xc_beta_ao_pbe = 0.d0
do istate = 1, N_states
! exchange - correlation alpha
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dsr_vxc_alpha_pbe_w(1,1,istate),size(aos_dsr_vxc_alpha_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dsr_vxc_alpha_pbe_w(1,1,istate),size(aos_dsr_vxc_alpha_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
pot_sr_grad_xc_alpha_ao_pbe(1,1,istate),size(pot_sr_grad_xc_alpha_ao_pbe,1))
! exchange - correlation beta
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dsr_vxc_beta_pbe_w(1,1,istate),size(aos_dsr_vxc_beta_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
aos_dsr_vxc_beta_pbe_w(1,1,istate),size(aos_dsr_vxc_beta_pbe_w,1), &
aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, &
pot_sr_grad_xc_beta_ao_pbe(1,1,istate),size(pot_sr_grad_xc_beta_ao_pbe,1))
enddo
@ -378,20 +378,3 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [double precision, potential_xc_alpha_ao_sr_pbe,(ao_num,ao_num,N_states)]
&BEGIN_PROVIDER [double precision, potential_xc_beta_ao_sr_pbe,(ao_num,ao_num,N_states)]
implicit none
BEGIN_DOC
! exchange / correlation potential for alpha / beta electrons with the Perdew-Burke-Ernzerhof GGA functional
END_DOC
integer :: i,j,istate
do istate = 1, n_states
do i = 1, ao_num
do j = 1, ao_num
potential_xc_alpha_ao_sr_pbe(j,i,istate) = pot_sr_scal_xc_alpha_ao_pbe(j,i,istate) + pot_sr_grad_xc_alpha_ao_pbe(j,i,istate) + pot_sr_grad_xc_alpha_ao_pbe(i,j,istate)
potential_xc_beta_ao_sr_pbe(j,i,istate) = pot_sr_scal_xc_beta_ao_pbe(j,i,istate) + pot_sr_grad_xc_beta_ao_pbe(j,i,istate) + pot_sr_grad_xc_beta_ao_pbe(i,j,istate)
enddo
enddo
enddo
END_PROVIDER

2
src/hartree_fock/10.hf.bats
View File

@ -11,7 +11,7 @@ function run() {
qp edit --check
qp reset --mos
qp run scf
qp set_frozen_core
# qp set_frozen_core
energy="$(ezfio get hartree_fock energy)"
eq $energy $2 $thresh
}

1
src/mo_one_e_ints/EZFIO.cfg
View File

@ -24,7 +24,6 @@ interface: ezfio,provider,ocaml
default: None
[mo_integrals_pseudo]
type: double precision
doc: Pseudopotential integrals in |MO| basis set

48
src/two_body_rdm/EZFIO.cfg Normal file
View File

@ -0,0 +1,48 @@
[two_rdm_ab_disk]
type: double precision
doc: active part of the two body rdm alpha/beta stored on disk
interface: ezfio
size: (bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,determinants.n_states)
[io_two_body_rdm_ab]
type: Disk_access
doc: Read/Write the active part of the two-body rdm for alpha/beta electrons from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
[two_rdm_aa_disk]
type: double precision
doc: active part of the two body rdm alpha/alpha stored on disk
interface: ezfio
size: (bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,determinants.n_states)
[io_two_body_rdm_aa]
type: Disk_access
doc: Read/Write the active part of the two-body rdm for alpha/alpha electrons from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
[two_rdm_bb_disk]
type: double precision
doc: active part of the two body rdm beta/beta stored on disk
interface: ezfio
size: (bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,determinants.n_states)
[io_two_body_rdm_bb]
type: Disk_access
doc: Read/Write the active part of the two-body rdm for beta/beta electrons from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
[two_rdm_spin_trace_disk]
type: double precision
doc: active part of the two body rdm spin trace stored on disk
interface: ezfio
size: (bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,determinants.n_states)
[io_two_body_rdm_spin_trace]
type: Disk_access
doc: Read/Write the active part of the two-body rdm for spin trace electrons from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None

3
src/two_body_rdm/NEED
View File

@ -1 +1,2 @@
davidson_undressed
two_rdm_routines
density_for_dft

4
src/two_body_rdm/README.rst
View File

@ -3,6 +3,6 @@ two_body_rdm
============
Contains the two rdms $\alpha\alpha$, $\beta\beta$ and $\alpha\beta$ stored as
arrays, with pysicists notation, consistent with the two-electron integrals in the
MO basis.
arrays, with pysicists notation, consistent with the two-electron integrals in the MO basis.

402
src/two_body_rdm/ab_only_routines.irp.f
View File

@ -1,402 +0,0 @@
subroutine two_rdm_ab_nstates(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze)
use bitmasks
implicit none
BEGIN_DOC
! Computes the alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS
!
! Assumes that the determinants are in psi_det
!
! istart, iend, ishift, istep are used in ZMQ parallelization.
END_DOC
integer, intent(in) :: N_st,sze
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
double precision, intent(inout) :: u_0(sze,N_st)
integer :: k
double precision, allocatable :: u_t(:,:)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
allocate(u_t(N_st,N_det))
do k=1,N_st
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
enddo
call dtranspose( &
u_0, &
size(u_0, 1), &
u_t, &
size(u_t, 1), &
N_det, N_st)
call two_rdm_ab_nstates_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1)
deallocate(u_t)
do k=1,N_st
call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
enddo
end
subroutine two_rdm_ab_nstates_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
implicit none
BEGIN_DOC
! Computes the alpha/beta part of the two-body density matrix
!
! Default should be 1,N_det,0,1
END_DOC
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
double precision, intent(in) :: u_t(N_st,N_det)
PROVIDE N_int
select case (N_int)
case (1)
call two_rdm_ab_nstates_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case (2)
call two_rdm_ab_nstates_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case (3)
call two_rdm_ab_nstates_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case (4)
call two_rdm_ab_nstates_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case default
call two_rdm_ab_nstates_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
end select
end
BEGIN_TEMPLATE
subroutine two_rdm_ab_nstates_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
implicit none
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
double precision, intent(in) :: u_t(N_st,N_det)
double precision :: hij, sij
integer :: i,j,k,l
integer :: k_a, k_b, l_a, l_b, m_a, m_b
integer :: istate
integer :: krow, kcol, krow_b, kcol_b
integer :: lrow, lcol
integer :: mrow, mcol
integer(bit_kind) :: spindet($N_int)
integer(bit_kind) :: tmp_det($N_int,2)
integer(bit_kind) :: tmp_det2($N_int,2)
integer(bit_kind) :: tmp_det3($N_int,2)
integer(bit_kind), allocatable :: buffer(:,:)
integer :: n_doubles
integer, allocatable :: doubles(:)
integer, allocatable :: singles_a(:)
integer, allocatable :: singles_b(:)
integer, allocatable :: idx(:), idx0(:)
integer :: maxab, n_singles_a, n_singles_b, kcol_prev, nmax
integer*8 :: k8
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
allocate(idx0(maxab))
do i=1,maxab
idx0(i) = i
enddo
! Prepare the array of all alpha single excitations
! -------------------------------------------------
PROVIDE N_int nthreads_davidson
! Alpha/Beta double excitations
! =============================
allocate( buffer($N_int,maxab), &
singles_a(maxab), &
singles_b(maxab), &
doubles(maxab), &
idx(maxab))
kcol_prev=-1
ASSERT (iend <= N_det)
ASSERT (istart > 0)
ASSERT (istep > 0)
do k_a=istart+ishift,iend,istep
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
if (kcol /= kcol_prev) then
call get_all_spin_singles_$N_int( &
psi_det_beta_unique, idx0, &
tmp_det(1,2), N_det_beta_unique, &
singles_b, n_singles_b)
endif
kcol_prev = kcol
! Loop over singly excited beta columns
! -------------------------------------
do i=1,n_singles_b
lcol = singles_b(i)
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
l_a = psi_bilinear_matrix_columns_loc(lcol)
ASSERT (l_a <= N_det)
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
ASSERT (l_a <= N_det)
idx(j) = l_a
l_a = l_a+1
enddo
j = j-1
call get_all_spin_singles_$N_int( &
buffer, idx, tmp_det(1,1), j, &
singles_a, n_singles_a )
! Loop over alpha singles
! -----------------------
do k = 1,n_singles_a
l_a = singles_a(k)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
!!!!!!!!!!!!!!!!!! ALPHA BETA
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
enddo
call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
enddo
enddo
enddo
do k_a=istart+ishift,iend,istep
! Single and double alpha excitations
! ===================================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
! Initial determinant is at k_b in beta-major representation
! ----------------------------------------------------------------------
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
spindet(1:$N_int) = tmp_det(1:$N_int,1)
! Loop inside the beta column to gather all the connected alphas
lcol = psi_bilinear_matrix_columns(k_a)
l_a = psi_bilinear_matrix_columns_loc(lcol)
do i=1,N_det_alpha_unique
if (l_a > N_det) exit
lcol = psi_bilinear_matrix_columns(l_a)
if (lcol /= kcol) exit
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
idx(i) = l_a
l_a = l_a+1
enddo
i = i-1
call get_all_spin_singles_and_doubles_$N_int( &
buffer, idx, spindet, i, &
singles_a, doubles, n_singles_a, n_doubles )
! Compute Hij for all alpha singles
! ----------------------------------
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
do i=1,n_singles_a
l_a = singles_a(i)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
!!!! MONO SPIN
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
enddo
call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
enddo
!! Compute Hij for all alpha doubles
!! ----------------------------------
!
!do i=1,n_doubles
! l_a = doubles(i)
! ASSERT (l_a <= N_det)
! lrow = psi_bilinear_matrix_rows(l_a)
! ASSERT (lrow <= N_det_alpha_unique)
! call i_H_j_double_spin_erf( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij)
! do l=1,N_st
! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
! ! same spin => sij = 0
! enddo
!enddo
! Single and double beta excitations
! ==================================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
kcol = psi_bilinear_matrix_columns(k_a)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
spindet(1:$N_int) = tmp_det(1:$N_int,2)
! Initial determinant is at k_b in beta-major representation
! -----------------------------------------------------------------------
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
! Loop inside the alpha row to gather all the connected betas
lrow = psi_bilinear_matrix_transp_rows(k_b)
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
do i=1,N_det_beta_unique
if (l_b > N_det) exit
lrow = psi_bilinear_matrix_transp_rows(l_b)
if (lrow /= krow) exit
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
idx(i) = l_b
l_b = l_b+1
enddo
i = i-1
call get_all_spin_singles_and_doubles_$N_int( &
buffer, idx, spindet, i, &
singles_b, doubles, n_singles_b, n_doubles )
! Compute Hij for all beta singles
! ----------------------------------
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
do i=1,n_singles_b
l_b = singles_b(i)
ASSERT (l_b <= N_det)
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
l_a = psi_bilinear_matrix_transp_order(l_b)
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
enddo
call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
ASSERT (l_a <= N_det)
enddo
!
!! Compute Hij for all beta doubles
!! ----------------------------------
!
!do i=1,n_doubles
! l_b = doubles(i)
! ASSERT (l_b <= N_det)
! lcol = psi_bilinear_matrix_transp_columns(l_b)
! ASSERT (lcol <= N_det_beta_unique)
! call i_H_j_double_spin_erf( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij)
! l_a = psi_bilinear_matrix_transp_order(l_b)
! ASSERT (l_a <= N_det)
! do l=1,N_st
! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
! ! same spin => sij = 0
! enddo
!enddo
! Diagonal contribution
! =====================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
double precision, external :: diag_H_mat_elem_erf, diag_S_mat_elem
double precision :: c_1(N_states),c_2(N_states)
do l = 1, N_states
c_1(l) = u_t(l,k_a)
enddo
call diagonal_contrib_to_two_rdm_ab_dm(tmp_det,c_1,big_array,dim1,dim2,dim3,dim4)
end do
deallocate(buffer, singles_a, singles_b, doubles, idx)
end
SUBST [ N_int ]
1;;
2;;
3;;
4;;
N_int;;
END_TEMPLATE

155
src/two_body_rdm/act_2_rdm.irp.f Normal file
View File

@ -0,0 +1,155 @@
BEGIN_PROVIDER [double precision, act_2_rdm_ab_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)]
implicit none
BEGIN_DOC
! act_2_rdm_ab_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons
!
! <Psi_{istate}| a^{\dagger}_{i \alpha} a^{\dagger}_{j \beta} a_{l \beta} a_{k \alpha} |Psi_{istate}>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha}^{act} * N_{\beta}^{act}
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is alpha, electron 2 is beta
!
! act_2_rdm_ab_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta
!
! Therefore you don't necessary have symmetry between electron 1 and 2
END_DOC
integer :: ispin
double precision :: wall_1, wall_2
! condition for alpha/beta spin
print*,''
print*,'Providing act_2_rdm_ab_mo '
ispin = 3
act_2_rdm_ab_mo = 0.d0
call wall_time(wall_1)
if(read_two_body_rdm_ab)then
print*,'Reading act_2_rdm_ab_mo from disk ...'
call ezfio_get_two_body_rdm_two_rdm_ab_disk(act_2_rdm_ab_mo)
else
call orb_range_2_rdm_openmp(act_2_rdm_ab_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
endif
if(write_two_body_rdm_ab)then
print*,'Writing act_2_rdm_ab_mo on disk ...'
call ezfio_set_two_body_rdm_two_rdm_ab_disk(act_2_rdm_ab_mo)
call ezfio_set_two_body_rdm_io_two_body_rdm_ab("Read")
endif
call wall_time(wall_2)
print*,'Wall time to provide act_2_rdm_ab_mo',wall_2 - wall_1
END_PROVIDER
BEGIN_PROVIDER [double precision, act_2_rdm_aa_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)]
implicit none
BEGIN_DOC
! act_2_rdm_aa_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of ALPHA/ALPHA electrons
!
! <Psi_{istate}| a^{\dagger}_{i \alpha} a^{\dagger}_{j \alpha} a_{l \alpha} a_{k \alpha} |Psi_{istate}>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha}^{act} * (N_{\alpha}^{act} - 1)/2
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
END_DOC
integer :: ispin
double precision :: wall_1, wall_2
! condition for alpha/beta spin
print*,''
print*,'Providing act_2_rdm_aa_mo '
ispin = 1
act_2_rdm_aa_mo = 0.d0
call wall_time(wall_1)
if(read_two_body_rdm_aa)then
print*,'Reading act_2_rdm_aa_mo from disk ...'
call ezfio_get_two_body_rdm_two_rdm_aa_disk(act_2_rdm_aa_mo)
else
call orb_range_2_rdm_openmp(act_2_rdm_aa_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
endif
if(write_two_body_rdm_aa)then
print*,'Writing act_2_rdm_aa_mo on disk ...'
call ezfio_set_two_body_rdm_two_rdm_aa_disk(act_2_rdm_aa_mo)
call ezfio_set_two_body_rdm_io_two_body_rdm_aa("Read")
endif
call wall_time(wall_2)
print*,'Wall time to provide act_2_rdm_aa_mo',wall_2 - wall_1
END_PROVIDER
BEGIN_PROVIDER [double precision, act_2_rdm_bb_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)]
implicit none
BEGIN_DOC
! act_2_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of BETA/BETA electrons
!
! <Psi_{istate}| a^{\dagger}_{i \beta} a^{\dagger}_{j \beta} a_{l \beta} a_{k \beta} |Psi_{istate}>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\beta}^{act} * (N_{\beta}^{act} - 1)/2
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
END_DOC
integer :: ispin
double precision :: wall_1, wall_2
! condition for beta/beta spin
print*,''
print*,'Providing act_2_rdm_bb_mo '
ispin = 2
act_2_rdm_bb_mo = 0.d0
call wall_time(wall_1)
if(read_two_body_rdm_bb)then
print*,'Reading act_2_rdm_bb_mo from disk ...'
call ezfio_get_two_body_rdm_two_rdm_bb_disk(act_2_rdm_bb_mo)
else
call orb_range_2_rdm_openmp(act_2_rdm_bb_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
endif
if(write_two_body_rdm_bb)then
print*,'Writing act_2_rdm_bb_mo on disk ...'
call ezfio_set_two_body_rdm_two_rdm_bb_disk(act_2_rdm_bb_mo)
call ezfio_set_two_body_rdm_io_two_body_rdm_bb("Read")
endif
call wall_time(wall_2)
print*,'Wall time to provide act_2_rdm_bb_mo',wall_2 - wall_1
END_PROVIDER
BEGIN_PROVIDER [double precision, act_2_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)]
implicit none
BEGIN_DOC
! act_2_rdm_spin_trace_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM
!
! \sum_{\sigma,\sigma'}<Psi_{istate}| a^{\dagger}_{i \sigma} a^{\dagger}_{j \sigma'} a_{l \sigma'} a_{k \sigma} |Psi_{istate}>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{elec}^{act} * (N_{elec}^{act} - 1)/2
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
END_DOC
integer :: ispin
double precision :: wall_1, wall_2
! condition for beta/beta spin
print*,''
print*,'Providing act_2_rdm_spin_trace_mo '
ispin = 4
act_2_rdm_spin_trace_mo = 0.d0
call wall_time(wall_1)
if(read_two_body_rdm_spin_trace)then
print*,'Reading act_2_rdm_spin_trace_mo from disk ...'
call ezfio_get_two_body_rdm_two_rdm_spin_trace_disk(act_2_rdm_spin_trace_mo)
else
call orb_range_2_rdm_openmp(act_2_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
endif
if(write_two_body_rdm_spin_trace)then
print*,'Writing act_2_rdm_spin_trace_mo on disk ...'
call ezfio_set_two_body_rdm_two_rdm_spin_trace_disk(act_2_rdm_spin_trace_mo)
call ezfio_set_two_body_rdm_io_two_body_rdm_spin_trace("Read")
endif
call wall_time(wall_2)
print*,'Wall time to provide act_2_rdm_spin_trace_mo',wall_2 - wall_1
END_PROVIDER

442
src/two_body_rdm/all_2rdm_routines.irp.f
View File

@ -1,442 +0,0 @@
subroutine all_two_rdm_dm_nstates(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze)
use bitmasks
implicit none
BEGIN_DOC
! Computes the alpha/alpha, beta/beta and alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS
!
! Assumes that the determinants are in psi_det
!
! istart, iend, ishift, istep are used in ZMQ parallelization.
END_DOC
integer, intent(in) :: N_st,sze
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states)
double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states)
double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states)
double precision, intent(inout) :: u_0(sze,N_st)
integer :: k
double precision, allocatable :: u_t(:,:)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
allocate(u_t(N_st,N_det))
do k=1,N_st
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
enddo
call dtranspose( &
u_0, &
size(u_0, 1), &
u_t, &
size(u_t, 1), &
N_det, N_st)
call all_two_rdm_dm_nstates_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1)
deallocate(u_t)
do k=1,N_st
call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
enddo
end
subroutine all_two_rdm_dm_nstates_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
implicit none
BEGIN_DOC
! Computes two-rdm
!
! Default should be 1,N_det,0,1
END_DOC
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states)
double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states)
double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states)
double precision, intent(in) :: u_t(N_st,N_det)
PROVIDE N_int
select case (N_int)
case (1)
call all_two_rdm_dm_nstates_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case (2)
call all_two_rdm_dm_nstates_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case (3)
call all_two_rdm_dm_nstates_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case (4)
call all_two_rdm_dm_nstates_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
case default
call all_two_rdm_dm_nstates_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
end select
end
BEGIN_TEMPLATE
subroutine all_two_rdm_dm_nstates_work_$N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
implicit none
BEGIN_DOC
! Computes $v_t = H | u_t \\rangle$ and $s_t = S^2 | u_t \\rangle$
!
! Default should be 1,N_det,0,1
END_DOC
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
double precision, intent(in) :: u_t(N_st,N_det)
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states)
double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states)
double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states)
integer :: i,j,k,l
integer :: k_a, k_b, l_a, l_b, m_a, m_b
integer :: istate
integer :: krow, kcol, krow_b, kcol_b
integer :: lrow, lcol
integer :: mrow, mcol
integer(bit_kind) :: spindet($N_int)
integer(bit_kind) :: tmp_det($N_int,2)
integer(bit_kind) :: tmp_det2($N_int,2)
integer(bit_kind) :: tmp_det3($N_int,2)
integer(bit_kind), allocatable :: buffer(:,:)
integer :: n_doubles
integer, allocatable :: doubles(:)
integer, allocatable :: singles_a(:)
integer, allocatable :: singles_b(:)
integer, allocatable :: idx(:), idx0(:)
integer :: maxab, n_singles_a, n_singles_b, kcol_prev
integer*8 :: k8
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
allocate(idx0(maxab))
do i=1,maxab
idx0(i) = i
enddo
! Prepare the array of all alpha single excitations
! -------------------------------------------------
PROVIDE N_int nthreads_davidson
!!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, &
! !$OMP psi_bilinear_matrix_columns, &
! !$OMP psi_det_alpha_unique, psi_det_beta_unique,&
! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
! !$OMP psi_bilinear_matrix_transp_rows, &
! !$OMP psi_bilinear_matrix_transp_columns, &
! !$OMP psi_bilinear_matrix_transp_order, N_st, &
! !$OMP psi_bilinear_matrix_order_transp_reverse, &
! !$OMP psi_bilinear_matrix_columns_loc, &
! !$OMP psi_bilinear_matrix_transp_rows_loc, &
! !$OMP istart, iend, istep, irp_here, v_t, s_t, &
! !$OMP ishift, idx0, u_t, maxab) &
! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,&
! !$OMP lcol, lrow, l_a, l_b, &
! !$OMP buffer, doubles, n_doubles, &
! !$OMP tmp_det2, idx, l, kcol_prev, &
! !$OMP singles_a, n_singles_a, singles_b, &
! !$OMP n_singles_b, k8)
! Alpha/Beta double excitations
! =============================
allocate( buffer($N_int,maxab), &
singles_a(maxab), &
singles_b(maxab), &
doubles(maxab), &
idx(maxab))
kcol_prev=-1
ASSERT (iend <= N_det)
ASSERT (istart > 0)
ASSERT (istep > 0)
!!$OMP DO SCHEDULE(dynamic,64)
do k_a=istart+ishift,iend,istep
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
if (kcol /= kcol_prev) then
call get_all_spin_singles_$N_int( &
psi_det_beta_unique, idx0, &
tmp_det(1,2), N_det_beta_unique, &
singles_b, n_singles_b)
endif
kcol_prev = kcol
! Loop over singly excited beta columns
! -------------------------------------
do i=1,n_singles_b
lcol = singles_b(i)
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
l_a = psi_bilinear_matrix_columns_loc(lcol)
ASSERT (l_a <= N_det)
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
ASSERT (l_a <= N_det)
idx(j) = l_a
l_a = l_a+1
enddo
j = j-1
call get_all_spin_singles_$N_int( &
buffer, idx, tmp_det(1,1), j, &
singles_a, n_singles_a )
! Loop over alpha singles
! -----------------------
do k = 1,n_singles_a
l_a = singles_a(k)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
!call i_H_j_double_alpha_beta(tmp_det,tmp_det2,$N_int,hij)
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
enddo
call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4)
enddo
enddo
enddo
! !$OMP END DO
! !$OMP DO SCHEDULE(dynamic,64)
do k_a=istart+ishift,iend,istep
! Single and double alpha exitations
! ===================================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
! Initial determinant is at k_b in beta-major representation
! ----------------------------------------------------------------------
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
ASSERT (k_b <= N_det)
spindet(1:$N_int) = tmp_det(1:$N_int,1)
! Loop inside the beta column to gather all the connected alphas
lcol = psi_bilinear_matrix_columns(k_a)
l_a = psi_bilinear_matrix_columns_loc(lcol)
do i=1,N_det_alpha_unique
if (l_a > N_det) exit
lcol = psi_bilinear_matrix_columns(l_a)
if (lcol /= kcol) exit
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
idx(i) = l_a
l_a = l_a+1
enddo
i = i-1
call get_all_spin_singles_and_doubles_$N_int( &
buffer, idx, spindet, i, &
singles_a, doubles, n_singles_a, n_doubles )
! Compute Hij for all alpha singles
! ----------------------------------
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
do i=1,n_singles_a
l_a = singles_a(i)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
enddo
! increment the alpha/beta part for single excitations
call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4)
! increment the alpha/alpha part for single excitations
call off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4)
enddo
! Compute Hij for all alpha doubles
! ----------------------------------
do i=1,n_doubles
l_a = doubles(i)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
enddo
call off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4)
enddo
! Single and double beta excitations
! ==================================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
kcol = psi_bilinear_matrix_columns(k_a)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
spindet(1:$N_int) = tmp_det(1:$N_int,2)
! Initial determinant is at k_b in beta-major representation
! -----------------------------------------------------------------------
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
ASSERT (k_b <= N_det)
! Loop inside the alpha row to gather all the connected betas
lrow = psi_bilinear_matrix_transp_rows(k_b)
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
do i=1,N_det_beta_unique
if (l_b > N_det) exit
lrow = psi_bilinear_matrix_transp_rows(l_b)
if (lrow /= krow) exit
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
idx(i) = l_b
l_b = l_b+1
enddo
i = i-1
call get_all_spin_singles_and_doubles_$N_int( &
buffer, idx, spindet, i, &
singles_b, doubles, n_singles_b, n_doubles )
! Compute Hij for all beta singles
! ----------------------------------
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
do i=1,n_singles_b
l_b = singles_b(i)
ASSERT (l_b <= N_det)
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
l_a = psi_bilinear_matrix_transp_order(l_b)
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
enddo
! increment the alpha/beta part for single excitations
call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4)
! increment the beta /beta part for single excitations
call off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4)
enddo
! Compute Hij for all beta doubles
! ----------------------------------
do i=1,n_doubles
l_b = doubles(i)
ASSERT (l_b <= N_det)
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
l_a = psi_bilinear_matrix_transp_order(l_b)
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
enddo
call off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4)
ASSERT (l_a <= N_det)
enddo
! Diagonal contribution
! =====================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
double precision, external :: diag_wee_mat_elem, diag_S_mat_elem
double precision :: c_1(N_states),c_2(N_states)
do l = 1, N_states
c_1(l) = u_t(l,k_a)
enddo
call diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4)
end do
!!$OMP END DO
deallocate(buffer, singles_a, singles_b, doubles, idx)
!!$OMP END PARALLEL
end
SUBST [ N_int ]
1;;
2;;
3;;
4;;
N_int;;
END_TEMPLATE

83
src/two_body_rdm/all_states_2_rdm.irp.f
View File

@ -1,83 +0,0 @@
BEGIN_PROVIDER [double precision, all_states_act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! all_states_act_two_rdm_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
END_DOC
allocate(state_weights(N_states))
state_weights = 1.d0/dble(N_states)
integer :: ispin
! condition for alpha/beta spin
ispin = 1
all_states_act_two_rdm_alpha_alpha_mo = 0.D0
call orb_range_all_states_two_rdm(all_states_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER
BEGIN_PROVIDER [double precision, all_states_act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! all_states_act_two_rdm_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
END_DOC
allocate(state_weights(N_states))
state_weights = 1.d0/dble(N_states)
integer :: ispin
! condition for alpha/beta spin
ispin = 2
all_states_act_two_rdm_beta_beta_mo = 0.d0
call orb_range_all_states_two_rdm(all_states_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER
BEGIN_PROVIDER [double precision, all_states_act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! all_states_act_two_rdm_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs
! = <Psi| a^{\dagger}_{i,alpha} a^{\dagger}_{j,beta} a_{l,beta} a_{k,alpha} |Psi>
END_DOC
allocate(state_weights(N_states))
state_weights = 1.d0/dble(N_states)
integer :: ispin
! condition for alpha/beta spin
print*,''
print*,''
print*,''
print*,'providint all_states_act_two_rdm_alpha_beta_mo '
ispin = 3
print*,'ispin = ',ispin
all_states_act_two_rdm_alpha_beta_mo = 0.d0
call orb_range_all_states_two_rdm(all_states_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER
BEGIN_PROVIDER [double precision, all_states_act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)]
implicit none
BEGIN_DOC
! all_states_act_two_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices
! The active part of the two-electron energy can be computed as:
!
! \sum_{i,j,k,l = 1, n_act_orb} all_states_act_two_rdm_spin_trace_mo(i,j,k,l) * < ii jj | kk ll >
!
! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l)
END_DOC
double precision, allocatable :: state_weights(:)
allocate(state_weights(N_states))
state_weights = 1.d0/dble(N_states)
integer :: ispin
! condition for alpha/beta spin
ispin = 4
all_states_act_two_rdm_spin_trace_mo = 0.d0
integer :: i
call orb_range_all_states_two_rdm(all_states_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER

495
src/two_body_rdm/all_states_routines.irp.f
View File

@ -1,495 +0,0 @@
subroutine orb_range_all_states_two_rdm(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_0,N_st,sze)
use bitmasks
implicit none
BEGIN_DOC
! if ispin == 1 :: alpha/alpha 2rdm
! == 2 :: beta /beta 2rdm
! == 3 :: alpha/beta 2rdm
! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba))
!
! Assumes that the determinants are in psi_det
!
! istart, iend, ishift, istep are used in ZMQ parallelization.
END_DOC
integer, intent(in) :: N_st,sze
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
double precision, intent(in) :: u_0(sze,N_st)
integer :: k
double precision, allocatable :: u_t(:,:)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
allocate(u_t(N_st,N_det))
do k=1,N_st
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
enddo
call dtranspose( &
u_0, &
size(u_0, 1), &
u_t, &
size(u_t, 1), &
N_det, N_st)
call orb_range_all_states_two_rdm_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,1,N_det,0,1)
deallocate(u_t)
do k=1,N_st
call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
enddo
end
subroutine orb_range_all_states_two_rdm_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
implicit none
BEGIN_DOC
! Computes two-rdm
!
! Default should be 1,N_det,0,1
END_DOC
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
double precision, intent(in) :: u_t(N_st,N_det)
integer :: k
PROVIDE N_int
select case (N_int)
case (1)
call orb_range_all_states_two_rdm_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (2)
call orb_range_all_states_two_rdm_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (3)
call orb_range_all_states_two_rdm_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (4)
call orb_range_all_states_two_rdm_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case default
call orb_range_all_states_two_rdm_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
end select
end
BEGIN_TEMPLATE
subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
implicit none
BEGIN_DOC
! Computes the two rdm for the N_st vectors |u_t>
! if ispin == 1 :: alpha/alpha 2rdm
! == 2 :: beta /beta 2rdm
! == 3 :: alpha/beta 2rdm
! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba))
! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb
! Default should be 1,N_det,0,1 for istart,iend,ishift,istep
END_DOC
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
double precision, intent(in) :: u_t(N_st,N_det)
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
integer :: i,j,k,l
integer :: k_a, k_b, l_a, l_b, m_a, m_b
integer :: istate
integer :: krow, kcol, krow_b, kcol_b
integer :: lrow, lcol
integer :: mrow, mcol
integer(bit_kind) :: spindet($N_int)
integer(bit_kind) :: tmp_det($N_int,2)
integer(bit_kind) :: tmp_det2($N_int,2)
integer(bit_kind) :: tmp_det3($N_int,2)
integer(bit_kind), allocatable :: buffer(:,:)
integer :: n_doubles
integer, allocatable :: doubles(:)
integer, allocatable :: singles_a(:)
integer, allocatable :: singles_b(:)
integer, allocatable :: idx(:), idx0(:)
integer :: maxab, n_singles_a, n_singles_b, kcol_prev
integer*8 :: k8
double precision,allocatable :: c_contrib(:)
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
integer(bit_kind) :: orb_bitmask($N_int)
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
else
print*,'Wrong parameter for ispin in general_two_rdm_dm_nstates_work'
print*,'ispin = ',ispin
stop
endif
PROVIDE N_int
call list_to_bitstring( orb_bitmask, list_orb, norb, N_int)
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
allocate(idx0(maxab))
do i=1,maxab
idx0(i) = i
enddo
! Prepare the array of all alpha single excitations
! -------------------------------------------------
PROVIDE N_int nthreads_davidson
!!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, &
! !$OMP psi_bilinear_matrix_columns, &
! !$OMP psi_det_alpha_unique, psi_det_beta_unique,&
! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
! !$OMP psi_bilinear_matrix_transp_rows, &
! !$OMP psi_bilinear_matrix_transp_columns, &
! !$OMP psi_bilinear_matrix_transp_order, N_st, &
! !$OMP psi_bilinear_matrix_order_transp_reverse, &
! !$OMP psi_bilinear_matrix_columns_loc, &
! !$OMP psi_bilinear_matrix_transp_rows_loc, &
! !$OMP istart, iend, istep, irp_here, v_t, s_t, &
! !$OMP ishift, idx0, u_t, maxab) &
! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,&
! !$OMP lcol, lrow, l_a, l_b, &
! !$OMP buffer, doubles, n_doubles, &
! !$OMP tmp_det2, idx, l, kcol_prev, &
! !$OMP singles_a, n_singles_a, singles_b, &
! !$OMP n_singles_b, k8)
! Alpha/Beta double excitations
! =============================
allocate( buffer($N_int,maxab), &
singles_a(maxab), &
singles_b(maxab), &
doubles(maxab), &
idx(maxab),c_contrib(N_st))
kcol_prev=-1
ASSERT (iend <= N_det)
ASSERT (istart > 0)
ASSERT (istep > 0)
!!$OMP DO SCHEDULE(dynamic,64)
do k_a=istart+ishift,iend,istep
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
if (kcol /= kcol_prev) then
call get_all_spin_singles_$N_int( &
psi_det_beta_unique, idx0, &
tmp_det(1,2), N_det_beta_unique, &
singles_b, n_singles_b)
endif
kcol_prev = kcol
! Loop over singly excited beta columns
! -------------------------------------
do i=1,n_singles_b
lcol = singles_b(i)
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
l_a = psi_bilinear_matrix_columns_loc(lcol)
ASSERT (l_a <= N_det)
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
ASSERT (l_a <= N_det)
idx(j) = l_a
l_a = l_a+1
enddo
j = j-1
call get_all_spin_singles_$N_int( &
buffer, idx, tmp_det(1,1), j, &
singles_a, n_singles_a )
! Loop over alpha singles
! -----------------------
if(alpha_beta.or.spin_trace)then
do k = 1,n_singles_a
l_a = singles_a(k)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
c_contrib = 0.d0
do l= 1, N_st
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_contrib(l) = c_1(l) * c_2(l)
enddo
call orb_range_off_diagonal_double_to_two_rdm_ab_dm_all_states(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
enddo
endif
enddo
enddo
! !$OMP END DO
! !$OMP DO SCHEDULE(dynamic,64)
do k_a=istart+ishift,iend,istep
! Single and double alpha exitations
! ===================================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
! Initial determinant is at k_b in beta-major representation
! ----------------------------------------------------------------------
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
ASSERT (k_b <= N_det)
spindet(1:$N_int) = tmp_det(1:$N_int,1)
! Loop inside the beta column to gather all the connected alphas
lcol = psi_bilinear_matrix_columns(k_a)
l_a = psi_bilinear_matrix_columns_loc(lcol)
do i=1,N_det_alpha_unique
if (l_a > N_det) exit
lcol = psi_bilinear_matrix_columns(l_a)
if (lcol /= kcol) exit
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
idx(i) = l_a
l_a = l_a+1
enddo
i = i-1
call get_all_spin_singles_and_doubles_$N_int( &
buffer, idx, spindet, i, &
singles_a, doubles, n_singles_a, n_doubles )
! Compute Hij for all alpha singles
! ----------------------------------
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
do i=1,n_singles_a
l_a = singles_a(i)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
c_contrib = 0.d0
do l= 1, N_st
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_contrib(l) = c_1(l) * c_2(l)
enddo
if(alpha_beta.or.spin_trace.or.alpha_alpha)then
! increment the alpha/beta part for single excitations
call orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
! increment the alpha/alpha part for single excitations
call orb_range_off_diagonal_single_to_two_rdm_aa_dm_all_states(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
endif
enddo
! Compute Hij for all alpha doubles
! ----------------------------------
if(alpha_alpha.or.spin_trace)then
do i=1,n_doubles
l_a = doubles(i)
ASSERT (l_a <= N_det)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
c_contrib = 0.d0
do l= 1, N_st
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_contrib(l) += c_1(l) * c_2(l)
enddo
call orb_range_off_diagonal_double_to_two_rdm_aa_dm_all_states(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
enddo
endif
! Single and double beta excitations
! ==================================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
kcol = psi_bilinear_matrix_columns(k_a)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
spindet(1:$N_int) = tmp_det(1:$N_int,2)
! Initial determinant is at k_b in beta-major representation
! -----------------------------------------------------------------------
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
ASSERT (k_b <= N_det)
! Loop inside the alpha row to gather all the connected betas
lrow = psi_bilinear_matrix_transp_rows(k_b)
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
do i=1,N_det_beta_unique
if (l_b > N_det) exit
lrow = psi_bilinear_matrix_transp_rows(l_b)
if (lrow /= krow) exit
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
idx(i) = l_b
l_b = l_b+1
enddo
i = i-1
call get_all_spin_singles_and_doubles_$N_int( &
buffer, idx, spindet, i, &
singles_b, doubles, n_singles_b, n_doubles )
! Compute Hij for all beta singles
! ----------------------------------
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
do i=1,n_singles_b
l_b = singles_b(i)
ASSERT (l_b <= N_det)
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
l_a = psi_bilinear_matrix_transp_order(l_b)
c_contrib = 0.d0
do l= 1, N_st
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_contrib(l) = c_1(l) * c_2(l)
enddo
if(alpha_beta.or.spin_trace.or.beta_beta)then
! increment the alpha/beta part for single excitations
call orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
! increment the beta /beta part for single excitations
call orb_range_off_diagonal_single_to_two_rdm_bb_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
endif
enddo
! Compute Hij for all beta doubles
! ----------------------------------
if(beta_beta.or.spin_trace)then
do i=1,n_doubles
l_b = doubles(i)
ASSERT (l_b <= N_det)
lcol = psi_bilinear_matrix_transp_columns(l_b)
ASSERT (lcol <= N_det_beta_unique)
l_a = psi_bilinear_matrix_transp_order(l_b)
c_contrib = 0.d0
do l= 1, N_st
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_contrib(l) = c_1(l) * c_2(l)
enddo
call orb_range_off_diagonal_double_to_two_rdm_bb_dm_all_states(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
ASSERT (l_a <= N_det)
enddo
endif
! Diagonal contribution
! =====================
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
kcol = psi_bilinear_matrix_columns(k_a)
ASSERT (kcol <= N_det_beta_unique)
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
double precision, external :: diag_wee_mat_elem, diag_S_mat_elem
double precision :: c_1(N_states),c_2(N_states)
c_contrib = 0.d0
do l = 1, N_st
c_1(l) = u_t(l,k_a)
c_contrib(l) = c_1(l) * c_1(l)
enddo
call orb_range_diagonal_contrib_to_all_two_rdm_dm_all_states(tmp_det,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
end do
!!$OMP END DO
deallocate(buffer, singles_a, singles_b, doubles, idx)
!!$OMP END PARALLEL
end
SUBST [ N_int ]
1;;
2;;
3;;
4;;
N_int;;
END_TEMPLATE

269
src/two_body_rdm/compute.irp.f
View File

@ -1,269 +0,0 @@
subroutine diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,dim2,dim3,dim4)
use bitmasks
BEGIN_DOC
! routine that update the DIAGONAL PART of the alpha/beta two body rdm IN CHEMIST NOTATIONS
END_DOC
implicit none
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
integer(bit_kind), intent(in) :: det_1(N_int,2)
double precision, intent(in) :: c_1(N_states)
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate
double precision :: c_1_bis
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
do istate = 1, N_states
c_1_bis = c_1(istate) * c_1(istate)
do i = 1, n_occ_ab(1)
h1 = occ(i,1)
do j = 1, n_occ_ab(2)
h2 = occ(j,2)
big_array(h1,h1,h2,h2,istate) += c_1_bis
enddo
enddo
enddo
end
subroutine diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4)
use bitmasks
BEGIN_DOC
! routine that update the DIAGONAL PART of ALL THREE two body rdm IN CHEMIST NOTATIONS
END_DOC
implicit none
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states)
double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states)
double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states)
integer(bit_kind), intent(in) :: det_1(N_int,2)
double precision, intent(in) :: c_1(N_states)
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate
double precision :: c_1_bis
BEGIN_DOC
! no factor 1/2 have to be taken into account as the permutations are already taken into account
END_DOC
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
do istate = 1, N_states
c_1_bis = c_1(istate) * c_1(istate)
do i = 1, n_occ_ab(1)
h1 = occ(i,1)
do j = 1, n_occ_ab(2)
h2 = occ(j,2)
big_array_ab(h1,h1,h2,h2,istate) += c_1_bis
enddo
do j = 1, n_occ_ab(1)
h2 = occ(j,1)
big_array_aa(h1,h1,h2,h2,istate) += 0.5d0 * c_1_bis
big_array_aa(h1,h2,h2,h1,istate) -= 0.5d0 * c_1_bis
enddo
enddo
do i = 1, n_occ_ab(2)
h1 = occ(i,2)
do j = 1, n_occ_ab(2)
h2 = occ(j,2)
big_array_bb(h1,h1,h2,h2,istate) += 0.5d0 * c_1_bis
big_array_bb(h1,h2,h2,h1,istate) -= 0.5d0 * c_1_bis
enddo
enddo
enddo
end
subroutine off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for DOUBLE EXCITATIONS IN CHEMIST NOTATIONS
END_DOC
implicit none
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
double precision, intent(in) :: c_1(N_states),c_2(N_states)
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2,2)
double precision :: phase
call get_double_excitation(det_1,det_2,exc,phase,N_int)
h1 = exc(1,1,1)
h2 = exc(1,1,2)
p1 = exc(1,2,1)
p2 = exc(1,2,2)
do istate = 1, N_states
big_array(h1,p1,h2,p2,istate) += c_1(istate) * phase * c_2(istate)
! big_array(p1,h1,p2,h2,istate) += c_1(istate) * phase * c_2(istate)
enddo
end
subroutine off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS
END_DOC
implicit none
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
double precision, intent(in) :: c_1(N_states),c_2(N_states)
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate,p1
integer :: exc(0:2,2,2)
double precision :: phase
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
p1 = exc(1,2,1)
do istate = 1, N_states
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
big_array(h1,p1,h2,h2,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase
enddo
enddo
else
! Mono beta
h1 = exc(1,1,2)
p1 = exc(1,2,2)
do istate = 1, N_states
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
big_array(h2,h2,h1,p1,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase
enddo
enddo
endif
end
subroutine off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS
END_DOC
use bitmasks
implicit none
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
double precision, intent(in) :: c_1(N_states),c_2(N_states)
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate,p1
integer :: exc(0:2,2,2)
double precision :: phase
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
p1 = exc(1,2,1)
do istate = 1, N_states
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
big_array(h1,p1,h2,h2,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase
big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase
big_array(h2,h2,h1,p1,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase
big_array(h2,p1,h1,h2,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase
enddo
enddo
else
return
endif
end
subroutine off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS
END_DOC
implicit none
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
double precision, intent(in) :: c_1(N_states),c_2(N_states)
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate,p1
integer :: exc(0:2,2,2)
double precision :: phase
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if (exc(0,1,1) == 1) then
return
else
! Mono beta
h1 = exc(1,1,2)
p1 = exc(1,2,2)
do istate = 1, N_states
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
big_array(h1,p1,h2,h2,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase
big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase
big_array(h2,h2,h1,p1,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase
big_array(h2,p1,h1,h2,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase
enddo
enddo
endif
end
subroutine off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for DOUBLE EXCITATIONS IN CHEMIST NOTATIONS
END_DOC
implicit none
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
double precision, intent(in) :: c_1(N_states),c_2(N_states)
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2)
double precision :: phase
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
h1 =exc(1,1)
h2 =exc(2,1)
p1 =exc(1,2)
p2 =exc(2,2)
!print*,'h1,p1,h2,p2',h1,p1,h2,p2,c_1(istate) * phase * c_2(istate)
do istate = 1, N_states
big_array(h1,p1,h2,p2,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate)
big_array(h1,p2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate)
big_array(h2,p2,h1,p1,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate)
big_array(h2,p1,h1,p2,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate)
enddo
end
subroutine off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for DOUBLE EXCITATIONS
END_DOC
implicit none
integer, intent(in) :: dim1,dim2,dim3,dim4
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
double precision, intent(in) :: c_1(N_states),c_2(N_states)
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2)
double precision :: phase
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
h1 =exc(1,1)
h2 =exc(2,1)
p1 =exc(1,2)
p2 =exc(2,2)
!print*,'h1,p1,h2,p2',h1,p1,h2,p2,c_1(istate) * phase * c_2(istate)
do istate = 1, N_states
big_array(h1,p1,h2,p2,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate)
big_array(h1,p2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate)
big_array(h2,p2,h1,p1,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate)
big_array(h2,p1,h1,p2,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate)
enddo
end

660
src/two_body_rdm/compute_all_states.irp.f
View File

@ -1,660 +0,0 @@
subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm_all_states(det_1,c_1,N_st,big_array,dim1,orb_bitmask)
use bitmasks
BEGIN_DOC
! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals
END_DOC
implicit none
integer, intent(in) :: dim1,N_st
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
integer(bit_kind), intent(in) :: det_1(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
double precision, intent(in) :: c_1(N_st)
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
do istate = 1, N_st
do i = 1, n_occ_ab(1)
h1 = occ(i,1)
do j = 1, n_occ_ab(2)
h2 = occ(j,2)
big_array(h1,h2,h1,h2,istate) += c_1(istate)
enddo
enddo
enddo
end
subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm_all_states(det_1,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
use bitmasks
BEGIN_DOC
! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1
!
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
END_DOC
implicit none
integer, intent(in) :: dim1,N_st,ispin
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
integer(bit_kind), intent(in) :: det_1(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
double precision, intent(in) :: c_1(N_st)
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate
integer(bit_kind) :: det_1_act(N_int,2)
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
do i = 1, N_int
det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i))
det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i))
enddo
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int)
logical :: is_integer_in_string
integer :: i1,i2
if(alpha_beta)then
do istate = 1, N_st
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
big_array(h1,h2,h1,h2,istate) += c_1(istate)
enddo
enddo
enddo
else if (alpha_alpha)then
do istate = 1, N_st
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(1)
i2 = occ(j,1)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate)
big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate)
enddo
enddo
enddo
else if (beta_beta)then
do istate = 1, N_st
do i = 1, n_occ_ab(2)
i1 = occ(i,2)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate)
big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate)
enddo
enddo
enddo
else if(spin_trace)then
! 0.5 * (alpha beta + beta alpha)
do istate = 1, N_st
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate)
big_array(h2,h1,h2,h1,istate) += 0.5d0 * c_1(istate)
enddo
enddo
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(1)
i2 = occ(j,1)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate)
big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate)
enddo
enddo
do i = 1, n_occ_ab(2)
i1 = occ(i,2)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate)
big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate)
enddo
enddo
enddo
endif
end
subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 3 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: dim1,N_st,ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1(N_st)
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call get_double_excitation(det_1,det_2,exc,phase,N_int)
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
h2 = exc(1,1,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
h2 = list_orb_reverse(h2)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
p2 = exc(1,2,2)
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
p2 = list_orb_reverse(p2)
do istate = 1, N_st
if(alpha_beta)then
big_array(h1,h2,p1,p2,istate) += c_1(istate) * phase
else if(spin_trace)then
big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate) * phase
big_array(p1,p2,h1,h2,istate) += 0.5d0 * c_1(istate) * phase
endif
enddo
end
subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 3 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: dim1,N_st,ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1(N_st)
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate,p1
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(alpha_beta)then
do istate = 1, N_st
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
big_array(h1,h2,p1,h2,istate) += c_1(istate) * phase
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
big_array(h2,h1,h2,p1,istate) += c_1(istate) * phase
enddo
endif
enddo
else if(spin_trace)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do istate = 1, N_st
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase
big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase
enddo
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do istate = 1, N_st
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase
big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase
enddo
enddo
endif
endif
end
subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 1 or 4 will do something
END_DOC
use bitmasks
implicit none
integer, intent(in) :: dim1,N_st,ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1(N_st)
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate,p1
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(alpha_alpha.or.spin_trace)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do istate = 1, N_st
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase
big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase
big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase
big_array(h2,h1,p1,h2,istate) -= 0.5d0 * c_1(istate) * phase
enddo
enddo
else
return
endif
endif
end
subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 2 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: dim1,N_st,ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1(N_st)
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate,p1
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(beta_beta.or.spin_trace)then
if (exc(0,1,1) == 1) then
return
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do istate = 1, N_st
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase
big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase
big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase
big_array(h2,h1,p1,h2,istate) -= 0.5d0 * c_1(istate) * phase
enddo
enddo
endif
endif
end
subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 1 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: dim1,N_st,ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1(N_st)
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
h1 =exc(1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
h2 =exc(2,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
h2 = list_orb_reverse(h2)
p1 =exc(1,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
p2 =exc(2,2)
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
p2 = list_orb_reverse(p2)
if(alpha_alpha.or.spin_trace)then
do istate = 1, N_st
big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate) * phase
big_array(h1,h2,p2,p1,istate) -= 0.5d0 * c_1(istate) * phase
big_array(h2,h1,p2,p1,istate) += 0.5d0 * c_1(istate) * phase
big_array(h2,h1,p1,p2,istate) -= 0.5d0 * c_1(istate) * phase
enddo
endif
end
subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 2 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: dim1,N_st,ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1(N_st)
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
h1 =exc(1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
h2 =exc(2,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
h2 = list_orb_reverse(h2)
p1 =exc(1,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
p2 =exc(2,2)
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
p2 = list_orb_reverse(p2)
do istate = 1, N_st
if(beta_beta.or.spin_trace)then
big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate)* phase
big_array(h1,h2,p2,p1,istate) -= 0.5d0 * c_1(istate)* phase
big_array(h2,h1,p2,p1,istate) += 0.5d0 * c_1(istate)* phase
big_array(h2,h1,p1,p2,istate) -= 0.5d0 * c_1(istate)* phase
endif
enddo
end

670
src/two_body_rdm/compute_orb_range.irp.f
View File

@ -1,670 +0,0 @@
subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,orb_bitmask)
use bitmasks
BEGIN_DOC
! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals
! c_1 is supposed to be a scalar quantity, such as state averaged coef
END_DOC
implicit none
integer, intent(in) :: dim1
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
integer(bit_kind), intent(in) :: det_1(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
double precision, intent(in) :: c_1
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
do i = 1, n_occ_ab(1)
h1 = occ(i,1)
do j = 1, n_occ_ab(2)
h2 = occ(j,2)
big_array(h1,h2,h1,h2) += c_1
enddo
enddo
end
subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
use bitmasks
BEGIN_DOC
! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
END_DOC
implicit none
integer, intent(in) :: dim1,ispin
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
integer(bit_kind), intent(in) :: det_1(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
double precision, intent(in) :: c_1
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2
integer(bit_kind) :: det_1_act(N_int,2)
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
do i = 1, N_int
det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i))
det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i))
enddo
!print*,'ahah'
!call debug_det(det_1_act,N_int)
!pause
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
BEGIN_DOC
! no factor 1/2 have to be taken into account as the permutations are already taken into account
END_DOC
call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int)
logical :: is_integer_in_string
integer :: i1,i2
if(alpha_beta)then
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle
do j = 1, n_occ_ab(2)
! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
big_array(h1,h2,h1,h2) += c_1
enddo
enddo
else if (alpha_alpha)then
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle
do j = 1, n_occ_ab(1)
i2 = occ(j,1)
! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
big_array(h1,h2,h1,h2) += 0.5d0 * c_1
big_array(h1,h2,h2,h1) -= 0.5d0 * c_1
enddo
enddo
else if (beta_beta)then
do i = 1, n_occ_ab(2)
i1 = occ(i,2)
! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
big_array(h1,h2,h1,h2) += 0.5d0 * c_1
big_array(h1,h2,h2,h1) -= 0.5d0 * c_1
enddo
enddo
else if(spin_trace)then
! 0.5 * (alpha beta + beta alpha)
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
big_array(h1,h2,h1,h2) += 0.5d0 * (c_1 )
big_array(h2,h1,h2,h1) += 0.5d0 * (c_1 )
enddo
enddo
!stop
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle
do j = 1, n_occ_ab(1)
i2 = occ(j,1)
! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
big_array(h1,h2,h1,h2) += 0.5d0 * c_1
big_array(h1,h2,h2,h1) -= 0.5d0 * c_1
enddo
enddo
do i = 1, n_occ_ab(2)
i1 = occ(i,2)
! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
big_array(h1,h2,h1,h2) += 0.5d0 * c_1
big_array(h1,h2,h2,h1) -= 0.5d0 * c_1
enddo
enddo
endif
end
subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 3 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: dim1,ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1
integer :: i,j,h1,h2,p1,p2
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
!print*,''
!do i = 1, mo_num
! print*,'list_orb',i,list_orb_reverse(i)
!enddo
call get_double_excitation(det_1,det_2,exc,phase,N_int)
h1 = exc(1,1,1)
!print*,'h1',h1
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
!print*,'passed h1 = ',h1
h2 = exc(1,1,2)
!print*,'h2',h2
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
h2 = list_orb_reverse(h2)
!print*,'passed h2 = ',h2
p1 = exc(1,2,1)
!print*,'p1',p1
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
!print*,'passed p1 = ',p1
p2 = exc(1,2,2)
!print*,'p2',p2
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
p2 = list_orb_reverse(p2)
!print*,'passed p2 = ',p2
if(alpha_beta)then
big_array(h1,h2,p1,p2) += c_1 * phase
else if(spin_trace)then
big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase
big_array(p1,p2,h1,h2) += 0.5d0 * c_1 * phase
!print*,'h1,h2,p1,p2',h1,h2,p1,p2
!print*,'',big_array(h1,h2,p1,p2)
endif
end
subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 3 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: dim1,ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,p1
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(alpha_beta)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
big_array(h1,h2,p1,h2) += c_1 * phase
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
big_array(h2,h1,h2,p1) += c_1 * phase
enddo
endif
else if(spin_trace)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
enddo
endif
endif
end
subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 1 or 4 will do something
END_DOC
use bitmasks
implicit none
integer, intent(in) :: dim1,ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,p1
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(alpha_alpha.or.spin_trace)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase
big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase
enddo
else
return
endif
endif
end
subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 2 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: dim1,ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,p1
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(beta_beta.or.spin_trace)then
if (exc(0,1,1) == 1) then
return
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase
big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase
enddo
endif
endif
end
subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 1 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: dim1,ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1
integer :: i,j,h1,h2,p1,p2
integer :: exc(0:2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
h1 =exc(1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
h2 =exc(2,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
h2 = list_orb_reverse(h2)
p1 =exc(1,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
p2 =exc(2,2)
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
p2 = list_orb_reverse(p2)
if(alpha_alpha.or.spin_trace)then
big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase
big_array(h1,h2,p2,p1) -= 0.5d0 * c_1 * phase
big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase
big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase
endif
end
subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 2 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: dim1,ispin
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1
integer :: i,j,h1,h2,p1,p2
integer :: exc(0:2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
h1 =exc(1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
h2 =exc(2,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
h2 = list_orb_reverse(h2)
p1 =exc(1,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
p2 =exc(2,2)
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
p2 = list_orb_reverse(p2)
if(beta_beta.or.spin_trace)then
big_array(h1,h2,p1,p2) += 0.5d0 * c_1* phase
big_array(h1,h2,p2,p1) -= 0.5d0 * c_1* phase
big_array(h2,h1,p2,p1) += 0.5d0 * c_1* phase
big_array(h2,h1,p1,p2) -= 0.5d0 * c_1* phase
endif
end

286
src/two_body_rdm/example.irp.f Normal file
View File

@ -0,0 +1,286 @@
subroutine routine_active_only
implicit none
integer :: i,j,k,l,iorb,jorb,korb,lorb,istate
BEGIN_DOC
! This routine computes the two electron repulsion within the active space using various providers
!
END_DOC
double precision :: vijkl,get_two_e_integral
double precision :: wee_ab(N_states),rdmab
double precision :: wee_bb(N_states),rdmbb
double precision :: wee_aa(N_states),rdmaa
double precision :: wee_tot(N_states),rdmtot
double precision :: wee_aa_st_av, rdm_aa_st_av
double precision :: wee_bb_st_av, rdm_bb_st_av
double precision :: wee_ab_st_av, rdm_ab_st_av
double precision :: wee_tot_st_av, rdm_tot_st_av
double precision :: wee_aa_st_av_2,wee_ab_st_av_2,wee_bb_st_av_2,wee_tot_st_av_2,wee_tot_st_av_3
wee_ab = 0.d0
wee_bb = 0.d0
wee_aa = 0.d0
wee_tot = 0.d0
wee_aa_st_av_2 = 0.d0
wee_bb_st_av_2 = 0.d0
wee_ab_st_av_2 = 0.d0
wee_tot_st_av_2 = 0.d0
wee_tot_st_av_3 = 0.d0
iorb = 1
jorb = 1
korb = 1
lorb = 1
vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map)
provide act_2_rdm_ab_mo act_2_rdm_aa_mo act_2_rdm_bb_mo act_2_rdm_spin_trace_mo
provide state_av_act_2_rdm_ab_mo state_av_act_2_rdm_aa_mo
provide state_av_act_2_rdm_bb_mo state_av_act_2_rdm_spin_trace_mo
print*,'**************************'
print*,'**************************'
do istate = 1, N_states
!! PURE ACTIVE PART
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_act_orb
korb = list_act(k)
do l = 1, n_act_orb
lorb = list_act(l)
vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map)
rdmab = act_2_rdm_ab_mo(l,k,j,i,istate)
rdmaa = act_2_rdm_aa_mo(l,k,j,i,istate)
rdmbb = act_2_rdm_bb_mo(l,k,j,i,istate)
rdmtot = act_2_rdm_spin_trace_mo(l,k,j,i,istate)
wee_ab(istate) += vijkl * rdmab
wee_aa(istate) += vijkl * rdmaa
wee_bb(istate) += vijkl * rdmbb
wee_tot(istate) += vijkl * rdmtot
enddo
enddo
enddo
enddo
wee_aa_st_av_2 += wee_aa(istate) * state_average_weight(istate)
wee_bb_st_av_2 += wee_aa(istate) * state_average_weight(istate)
wee_ab_st_av_2 += wee_aa(istate) * state_average_weight(istate)
wee_tot_st_av_2 += wee_tot(istate) * state_average_weight(istate)
wee_tot_st_av_3 += psi_energy_two_e(istate) * state_average_weight(istate)
print*,''
print*,''
print*,'Active space only energy for state ',istate
print*,'wee_aa(istate) = ',wee_aa(istate)
print*,'wee_bb(istate) = ',wee_bb(istate)
print*,'wee_ab(istate) = ',wee_ab(istate)
print*,''
print*,'sum (istate) = ',wee_aa(istate) + wee_bb(istate) + wee_ab(istate)
print*,'wee_tot = ',wee_tot(istate)
print*,'Full energy '
print*,'psi_energy_two_e(istate)= ',psi_energy_two_e(istate)
enddo
wee_aa_st_av = 0.d0
wee_bb_st_av = 0.d0
wee_ab_st_av = 0.d0
wee_tot_st_av = 0.d0
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_act_orb
korb = list_act(k)
do l = 1, n_act_orb
lorb = list_act(l)
vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map)
rdm_aa_st_av = state_av_act_2_rdm_aa_mo(l,k,j,i)
rdm_bb_st_av = state_av_act_2_rdm_bb_mo(l,k,j,i)
rdm_ab_st_av = state_av_act_2_rdm_ab_mo(l,k,j,i)
rdm_tot_st_av = state_av_act_2_rdm_spin_trace_mo(l,k,j,i)
wee_aa_st_av += vijkl * rdm_aa_st_av
wee_bb_st_av += vijkl * rdm_bb_st_av
wee_ab_st_av += vijkl * rdm_ab_st_av
wee_tot_st_av += vijkl * rdm_tot_st_av
enddo
enddo
enddo
enddo
print*,''
print*,''
print*,''
print*,'STATE AVERAGE ENERGY '
print*,'Active space only energy for state ',istate
print*,'wee_aa_st_av = ',wee_aa_st_av
print*,'wee_aa_st_av_2 = ',wee_aa_st_av_2
print*,'wee_bb_st_av = ',wee_bb_st_av
print*,'wee_bb_st_av_2 = ',wee_bb_st_av_2
print*,'wee_ab_st_av = ',wee_ab_st_av
print*,'wee_ab_st_av_2 = ',wee_ab_st_av_2
print*,'Sum of components = ',wee_aa_st_av+wee_bb_st_av+wee_ab_st_av
print*,'Sum of components_2 = ',wee_aa_st_av_2+wee_bb_st_av_2+wee_ab_st_av_2
print*,''
print*,'Full energy '
print*,'wee_tot_st_av = ',wee_tot_st_av
print*,'wee_tot_st_av_2 = ',wee_tot_st_av_2
print*,'wee_tot_st_av_3 = ',wee_tot_st_av_3
end
subroutine routine_full_mos
implicit none
integer :: i,j,k,l,iorb,jorb,korb,lorb,istate
BEGIN_DOC
! This routine computes the two electron repulsion using various providers
!
END_DOC
double precision :: vijkl,rdmaa,get_two_e_integral,rdmab,rdmbb,rdmtot
double precision :: wee_aa(N_states),wee_bb(N_states),wee_ab(N_states),wee_tot(N_states)
double precision :: wee_aa_st_av, rdm_aa_st_av
double precision :: wee_bb_st_av, rdm_bb_st_av
double precision :: wee_ab_st_av, rdm_ab_st_av
double precision :: wee_tot_st_av, rdm_tot_st_av
double precision :: wee_aa_st_av_2,wee_ab_st_av_2,wee_bb_st_av_2,wee_tot_st_av_2,wee_tot_st_av_3
double precision :: aa_norm(N_states),bb_norm(N_states),ab_norm(N_states),tot_norm(N_states)
aa_norm = 0.d0
bb_norm = 0.d0
ab_norm = 0.d0
tot_norm = 0.d0
wee_aa = 0.d0
wee_ab = 0.d0
wee_bb = 0.d0
wee_tot = 0.d0
wee_aa_st_av_2 = 0.d0
wee_bb_st_av_2 = 0.d0
wee_ab_st_av_2 = 0.d0
wee_tot_st_av_2 = 0.d0
wee_tot_st_av_3 = 0.d0
iorb = 1
jorb = 1
korb = 1
lorb = 1
vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map)
provide full_occ_2_rdm_ab_mo full_occ_2_rdm_aa_mo full_occ_2_rdm_bb_mo full_occ_2_rdm_spin_trace_mo
print*,'**************************'
print*,'**************************'
do istate = 1, N_states
do i = 1, n_core_inact_act_orb
iorb = list_core_inact_act(i)
do j = 1, n_core_inact_act_orb
jorb = list_core_inact_act(j)
do k = 1, n_core_inact_act_orb
korb = list_core_inact_act(k)
do l = 1, n_core_inact_act_orb
lorb = list_core_inact_act(l)
vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map)
rdmaa = full_occ_2_rdm_aa_mo(l,k,j,i,istate)
rdmab = full_occ_2_rdm_ab_mo(l,k,j,i,istate)
rdmbb = full_occ_2_rdm_bb_mo(l,k,j,i,istate)
rdmtot = full_occ_2_rdm_spin_trace_mo(l,k,j,i,istate)
wee_ab(istate) += vijkl * rdmab
wee_aa(istate) += vijkl * rdmaa
wee_bb(istate) += vijkl * rdmbb
wee_tot(istate)+= vijkl * rdmtot
enddo
enddo
aa_norm(istate) += full_occ_2_rdm_aa_mo(j,i,j,i,istate)
bb_norm(istate) += full_occ_2_rdm_bb_mo(j,i,j,i,istate)
ab_norm(istate) += full_occ_2_rdm_ab_mo(j,i,j,i,istate)
tot_norm(istate)+= full_occ_2_rdm_spin_trace_mo(j,i,j,i,istate)
enddo
enddo
wee_aa_st_av_2 += wee_aa(istate) * state_average_weight(istate)
wee_bb_st_av_2 += wee_bb(istate) * state_average_weight(istate)
wee_ab_st_av_2 += wee_ab(istate) * state_average_weight(istate)
wee_tot_st_av_2 += wee_tot(istate) * state_average_weight(istate)
wee_tot_st_av_3 += psi_energy_two_e(istate) * state_average_weight(istate)
print*,''
print*,''
print*,'Full energy for state ',istate
print*,'wee_aa(istate) = ',wee_aa(istate)
print*,'wee_bb(istate) = ',wee_bb(istate)
print*,'wee_ab(istate) = ',wee_ab(istate)
print*,''
print*,'sum (istate) = ',wee_aa(istate) + wee_bb(istate) + wee_ab(istate)
print*,'wee_tot(istate) = ',wee_tot(istate)
print*,'psi_energy_two_e(istate)= ',psi_energy_two_e(istate)
print*,''
print*,'Normalization of two-rdms '
print*,''
print*,'aa_norm(istate) = ',aa_norm(istate)
print*,'N_alpha(N_alpha-1)/2 = ',elec_num_tab(1) * (elec_num_tab(1) - 1)/2
print*,''
print*,'bb_norm(istate) = ',bb_norm(istate)
print*,'N_alpha(N_alpha-1)/2 = ',elec_num_tab(2) * (elec_num_tab(2) - 1)/2
print*,''
print*,'ab_norm(istate) = ',ab_norm(istate)
print*,'N_alpha * N_beta = ',elec_num_tab(1) * elec_num_tab(2)
print*,''
print*,'tot_norm(istate) = ',tot_norm(istate)
print*,'N(N-1)/2 = ',elec_num*(elec_num - 1)/2
enddo
wee_aa_st_av = 0.d0
wee_bb_st_av = 0.d0
wee_ab_st_av = 0.d0
wee_tot_st_av = 0.d0
do i = 1, n_core_inact_act_orb
iorb = list_core_inact_act(i)
do j = 1, n_core_inact_act_orb
jorb = list_core_inact_act(j)
do k = 1, n_core_inact_act_orb
korb = list_core_inact_act(k)
do l = 1, n_core_inact_act_orb
lorb = list_core_inact_act(l)
vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map)
rdm_aa_st_av = state_av_full_occ_2_rdm_aa_mo(l,k,j,i)
rdm_bb_st_av = state_av_full_occ_2_rdm_bb_mo(l,k,j,i)
rdm_ab_st_av = state_av_full_occ_2_rdm_ab_mo(l,k,j,i)
rdm_tot_st_av = state_av_full_occ_2_rdm_spin_trace_mo(l,k,j,i)
wee_aa_st_av += vijkl * rdm_aa_st_av
wee_bb_st_av += vijkl * rdm_bb_st_av
wee_ab_st_av += vijkl * rdm_ab_st_av
wee_tot_st_av += vijkl * rdm_tot_st_av
enddo
enddo
enddo
enddo
print*,''
print*,''
print*,''
print*,'STATE AVERAGE ENERGY '
print*,'wee_aa_st_av = ',wee_aa_st_av
print*,'wee_aa_st_av_2 = ',wee_aa_st_av_2
print*,'wee_bb_st_av = ',wee_bb_st_av
print*,'wee_bb_st_av_2 = ',wee_bb_st_av_2
print*,'wee_ab_st_av = ',wee_ab_st_av
print*,'wee_ab_st_av_2 = ',wee_ab_st_av_2
print*,'Sum of components = ',wee_aa_st_av + wee_bb_st_av + wee_ab_st_av
print*,'Sum of components_2 = ',wee_aa_st_av_2 + wee_bb_st_av_2 + wee_ab_st_av_2
print*,''
print*,'Full energy '
print*,'wee_tot_st_av = ',wee_tot_st_av
print*,'wee_tot_st_av_2 = ',wee_tot_st_av_2
print*,'wee_tot_st_av_3 = ',wee_tot_st_av_3
end

551
src/two_body_rdm/full_orb_2_rdm.irp.f Normal file
View File

@ -0,0 +1,551 @@
BEGIN_PROVIDER [double precision, full_occ_2_rdm_ab_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,N_states)]
implicit none
full_occ_2_rdm_ab_mo = 0.d0
integer :: i,j,k,l,iorb,jorb,korb,lorb,istate
BEGIN_DOC
! full_occ_2_rdm_ab_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons
!
! <Psi| a^{\dagger}_{i \alpha} a^{\dagger}_{j \beta} a_{l \beta} a_{k \alpha} |Psi>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * N_{\beta}
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is ALPHA, electron 2 is BETA
!
! full_occ_2_rdm_ab_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta
!
! Therefore you don't necessary have symmetry between electron 1 and 2
!
! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO ARE SET TO ZERO
END_DOC
full_occ_2_rdm_ab_mo = 0.d0
do istate = 1, N_states
!! PURE ACTIVE PART ALPHA-BETA
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_act_orb
korb = list_act(k)
do l = 1, n_act_orb
lorb = list_act(l)
! alph beta alph beta
full_occ_2_rdm_ab_mo(lorb,korb,jorb,iorb,istate) = &
act_2_rdm_ab_mo(l,k,j,i,istate)
enddo
enddo
enddo
enddo
!! BETA ACTIVE - ALPHA inactive
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! alph beta alph beta
full_occ_2_rdm_ab_mo(korb,jorb,korb,iorb,istate) = one_e_dm_mo_beta(jorb,iorb,istate)
enddo
enddo
enddo
!! ALPHA ACTIVE - BETA inactive
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! alph beta alph beta
full_occ_2_rdm_ab_mo(jorb,korb,iorb,korb,istate) = one_e_dm_mo_alpha(jorb,iorb,istate)
enddo
enddo
enddo
!! ALPHA INACTIVE - BETA INACTIVE
!!
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! alph beta alph beta
full_occ_2_rdm_ab_mo(korb,jorb,korb,jorb,istate) = 1.D0
enddo
enddo
!!!!!!!!!!!!
!!!!!!!!!!!! if "no_core_density" then you don't put the core part
!!!!!!!!!!!! CAN BE USED
if (.not.no_core_density)then
!! BETA ACTIVE - ALPHA CORE
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
! alph beta alph beta
full_occ_2_rdm_ab_mo(korb,jorb,korb,iorb,istate) = one_e_dm_mo_beta(jorb,iorb,istate)
enddo
enddo
enddo
!! ALPHA ACTIVE - BETA CORE
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
! alph beta alph beta
full_occ_2_rdm_ab_mo(jorb,korb,iorb,korb,istate) = one_e_dm_mo_alpha(jorb,iorb,istate)
enddo
enddo
enddo
!! ALPHA CORE - BETA CORE
!!
do j = 1, n_core_orb
jorb = list_core(j)
do k = 1, n_core_orb
korb = list_core(k)
! alph beta alph beta
full_occ_2_rdm_ab_mo(korb,jorb,korb,jorb,istate) = 1.D0
enddo
enddo
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, full_occ_2_rdm_aa_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,N_states)]
implicit none
full_occ_2_rdm_aa_mo = 0.d0
integer :: i,j,k,l,iorb,jorb,korb,lorb,istate
BEGIN_DOC
! full_occ_2_rdm_aa_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/alpha electrons
!
! <Psi| a^{\dagger}_{i \alpha} a^{\dagger}_{j \alpha} a_{l \alpha} a_{k \alpha} |Psi>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * (N_{\alpha} - 1)/2
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero
END_DOC
do istate = 1, N_states
!! PURE ACTIVE PART ALPHA-ALPHA
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_act_orb
korb = list_act(k)
do l = 1, n_act_orb
lorb = list_act(l)
full_occ_2_rdm_aa_mo(lorb,korb,jorb,iorb,istate) = &
act_2_rdm_aa_mo(l,k,j,i,istate)
enddo
enddo
enddo
enddo
!! ALPHA ACTIVE - ALPHA inactive
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! 1 2 1 2 : DIRECT TERM
full_occ_2_rdm_aa_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
full_occ_2_rdm_aa_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
! 1 2 1 2 : EXCHANGE TERM
full_occ_2_rdm_aa_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
full_occ_2_rdm_aa_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
enddo
enddo
enddo
!! ALPHA INACTIVE - ALPHA INACTIVE
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_inact_orb
korb = list_inact(k)
full_occ_2_rdm_aa_mo(korb,jorb,korb,jorb,istate) += 0.5d0
full_occ_2_rdm_aa_mo(korb,jorb,jorb,korb,istate) -= 0.5d0
enddo
enddo
!!!!!!!!!!
!!!!!!!!!! if "no_core_density" then you don't put the core part
!!!!!!!!!! CAN BE USED
if (.not.no_core_density)then
!! ALPHA ACTIVE - ALPHA CORE
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
! 1 2 1 2 : DIRECT TERM
full_occ_2_rdm_aa_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
full_occ_2_rdm_aa_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
! 1 2 1 2 : EXCHANGE TERM
full_occ_2_rdm_aa_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
full_occ_2_rdm_aa_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
enddo
enddo
enddo
!! ALPHA CORE - ALPHA CORE
do j = 1, n_core_orb
jorb = list_core(j)
do k = 1, n_core_orb
korb = list_core(k)
full_occ_2_rdm_aa_mo(korb,jorb,korb,jorb,istate) += 0.5d0
full_occ_2_rdm_aa_mo(korb,jorb,jorb,korb,istate) -= 0.5d0
enddo
enddo
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, full_occ_2_rdm_bb_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,N_states)]
implicit none
full_occ_2_rdm_bb_mo = 0.d0
integer :: i,j,k,l,iorb,jorb,korb,lorb,istate
BEGIN_DOC
! full_occ_2_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons
!
! <Psi| a^{\dagger}_{i \beta} a^{\dagger}_{j \beta} a_{l \beta} a_{k \beta} |Psi>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\beta} * (N_{\beta} - 1)/2
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero
END_DOC
do istate = 1, N_states
!! PURE ACTIVE PART beta-beta
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_act_orb
korb = list_act(k)
do l = 1, n_act_orb
lorb = list_act(l)
full_occ_2_rdm_bb_mo(lorb,korb,jorb,iorb,istate) = &
act_2_rdm_bb_mo(l,k,j,i,istate)
enddo
enddo
enddo
enddo
!! beta ACTIVE - beta inactive
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! 1 2 1 2 : DIRECT TERM
full_occ_2_rdm_bb_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
full_occ_2_rdm_bb_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
! 1 2 1 2 : EXCHANGE TERM
full_occ_2_rdm_bb_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
full_occ_2_rdm_bb_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
enddo
enddo
enddo
!! beta INACTIVE - beta INACTIVE
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_inact_orb
korb = list_inact(k)
full_occ_2_rdm_bb_mo(korb,jorb,korb,jorb,istate) += 0.5d0
full_occ_2_rdm_bb_mo(korb,jorb,jorb,korb,istate) -= 0.5d0
enddo
enddo
!!!!!!!!!!!!
!!!!!!!!!!!! if "no_core_density" then you don't put the core part
!!!!!!!!!!!! CAN BE USED
if (.not.no_core_density)then
!! beta ACTIVE - beta CORE
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
! 1 2 1 2 : DIRECT TERM
full_occ_2_rdm_bb_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
full_occ_2_rdm_bb_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
! 1 2 1 2 : EXCHANGE TERM
full_occ_2_rdm_bb_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
full_occ_2_rdm_bb_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
enddo
enddo
enddo
!! beta CORE - beta CORE
do j = 1, n_core_orb
jorb = list_core(j)
do k = 1, n_core_orb
korb = list_core(k)
full_occ_2_rdm_bb_mo(korb,jorb,korb,jorb,istate) += 0.5d0
full_occ_2_rdm_bb_mo(korb,jorb,jorb,korb,istate) -= 0.5d0
enddo
enddo
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, full_occ_2_rdm_spin_trace_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,N_states)]
implicit none
full_occ_2_rdm_spin_trace_mo = 0.d0
integer :: i,j,k,l,iorb,jorb,korb,lorb,istate
BEGIN_DOC
! full_occ_2_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons
!
! <Psi| a^{\dagger}_{i \beta} a^{\dagger}_{j \beta} a_{l \beta} a_{k \beta} |Psi>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{elec} * (N_{elec} - 1)/2
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero
! The two-electron energy of each state can be computed as:
!
! \sum_{i,j,k,l = 1, n_core_inact_act_orb} full_occ_2_rdm_spin_trace_mo(i,j,k,l,istate) * < ii jj | kk ll >
!
! with ii = list_core_inact_act(i), jj = list_core_inact_act(j), kk = list_core_inact_act(k), ll = list_core_inact_act(l)
END_DOC
do istate = 1, N_states
!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!
!! PURE ACTIVE PART SPIN-TRACE
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_act_orb
korb = list_act(k)
do l = 1, n_act_orb
lorb = list_act(l)
full_occ_2_rdm_spin_trace_mo(lorb,korb,jorb,iorb,istate) += &
act_2_rdm_spin_trace_mo(l,k,j,i,istate)
enddo
enddo
enddo
enddo
!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!
!!!!! BETA-BETA !!!!!
!! beta ACTIVE - beta inactive
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! 1 2 1 2 : DIRECT TERM
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
! 1 2 1 2 : EXCHANGE TERM
full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
enddo
enddo
enddo
!! beta INACTIVE - beta INACTIVE
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_inact_orb
korb = list_inact(k)
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0
full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0
enddo
enddo
if (.not.no_core_density)then
!! beta ACTIVE - beta CORE
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
! 1 2 1 2 : DIRECT TERM
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
! 1 2 1 2 : EXCHANGE TERM
full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
enddo
enddo
enddo
!! beta CORE - beta CORE
do j = 1, n_core_orb
jorb = list_core(j)
do k = 1, n_core_orb
korb = list_core(k)
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0
full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0
enddo
enddo
endif
!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!
!!!!! ALPHA-ALPHA !!!!!
!! ALPHA ACTIVE - ALPHA inactive
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! 1 2 1 2 : DIRECT TERM
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
! 1 2 1 2 : EXCHANGE TERM
full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
enddo
enddo
enddo
!! ALPHA INACTIVE - ALPHA INACTIVE
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_inact_orb
korb = list_inact(k)
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0
full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0
enddo
enddo
if (.not.no_core_density)then
!! ALPHA ACTIVE - ALPHA CORE
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
! 1 2 1 2 : DIRECT TERM
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
! 1 2 1 2 : EXCHANGE TERM
full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
enddo
enddo
enddo
!! ALPHA CORE - ALPHA CORE
do j = 1, n_core_orb
jorb = list_core(j)
do k = 1, n_core_orb
korb = list_core(k)
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0
full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0
enddo
enddo
endif
!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!
!!!!! ALPHA-BETA + BETA-ALPHA !!!!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! ALPHA INACTIVE - BETA ACTIVE
! alph beta alph beta
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
! beta alph beta alph
full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate)
! BETA INACTIVE - ALPHA ACTIVE
! beta alph beta alpha
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
! alph beta alph beta
full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate)
enddo
enddo
enddo
!! ALPHA INACTIVE - BETA INACTIVE
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! alph beta alph beta
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5D0
full_occ_2_rdm_spin_trace_mo(jorb,korb,jorb,korb,istate) += 0.5D0
enddo
enddo
!!!!!!!!!!!!
!!!!!!!!!!!! if "no_core_density" then you don't put the core part
!!!!!!!!!!!! CAN BE USED
if (.not.no_core_density)then
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
!! BETA ACTIVE - ALPHA CORE
! alph beta alph beta
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5D0 * one_e_dm_mo_beta(jorb,iorb,istate)
! beta alph beta alph
full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5D0 * one_e_dm_mo_beta(jorb,iorb,istate)
!! ALPHA ACTIVE - BETA CORE
! alph beta alph beta
full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5D0 * one_e_dm_mo_alpha(jorb,iorb,istate)
! beta alph beta alph
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5D0 * one_e_dm_mo_alpha(jorb,iorb,istate)
enddo
enddo
enddo
!! ALPHA CORE - BETA CORE
do j = 1, n_core_orb
jorb = list_core(j)
do k = 1, n_core_orb
korb = list_core(k)
! alph beta alph beta
full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5D0
full_occ_2_rdm_spin_trace_mo(jorb,korb,jorb,korb,istate) += 0.5D0
enddo
enddo
endif
enddo
END_PROVIDER

89
src/two_body_rdm/orb_range.irp.f
View File

@ -1,89 +0,0 @@
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! state_av_act_two_rdm_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
END_DOC
allocate(state_weights(N_states))
state_weights = state_average_weight
integer :: ispin
! condition for alpha/beta spin
ispin = 1
state_av_act_two_rdm_alpha_alpha_mo = 0.D0
call orb_range_two_rdm_state_av(state_av_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! state_av_act_two_rdm_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
END_DOC
allocate(state_weights(N_states))
state_weights = state_average_weight
integer :: ispin
! condition for alpha/beta spin
ispin = 2
state_av_act_two_rdm_beta_beta_mo = 0.d0
call orb_range_two_rdm_state_av(state_av_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! state_av_act_two_rdm_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs
! = <Psi| a^{\dagger}_{i,alpha} a^{\dagger}_{j,beta} a_{l,beta} a_{k,alpha} |Psi>
END_DOC
allocate(state_weights(N_states))
state_weights = state_average_weight
integer :: ispin
! condition for alpha/beta spin
print*,''
print*,''
print*,''
print*,'providint state_av_act_two_rdm_alpha_beta_mo '
ispin = 3
print*,'ispin = ',ispin
state_av_act_two_rdm_alpha_beta_mo = 0.d0
call orb_range_two_rdm_state_av(state_av_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
BEGIN_DOC
! state_av_act_two_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices
! The active part of the two-electron energy can be computed as:
!
! \sum_{i,j,k,l = 1, n_act_orb} state_av_act_two_rdm_spin_trace_mo(i,j,k,l) * < ii jj | kk ll >
!
! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l)
END_DOC
double precision, allocatable :: state_weights(:)
allocate(state_weights(N_states))
state_weights = state_average_weight
integer :: ispin
! condition for alpha/beta spin
ispin = 4
state_av_act_two_rdm_spin_trace_mo = 0.d0
integer :: i
double precision :: wall_0,wall_1
call wall_time(wall_0)
print*,'providing the state average TWO-RDM ...'
print*,'psi_det_size = ',psi_det_size
print*,'N_det = ',N_det
call orb_range_two_rdm_state_av(state_av_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,N_states,size(psi_coef,1))
call wall_time(wall_1)
print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0
END_PROVIDER

85
src/two_body_rdm/orb_range_omp.irp.f
View File

@ -1,85 +0,0 @@
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! state_av_act_two_rdm_openmp_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
END_DOC
allocate(state_weights(N_states))
state_weights = state_average_weight
integer :: ispin
! condition for alpha/beta spin
ispin = 1
state_av_act_two_rdm_openmp_alpha_alpha_mo = 0.D0
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! state_av_act_two_rdm_openmp_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
END_DOC
allocate(state_weights(N_states))
state_weights = state_average_weight
integer :: ispin
! condition for alpha/beta spin
ispin = 2
state_av_act_two_rdm_openmp_beta_beta_mo = 0.d0
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_beta_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! state_av_act_two_rdm_openmp_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs
! = <Psi| a^{\dagger}_{i,alpha} a^{\dagger}_{j,beta} a_{l,beta} a_{k,alpha} |Psi>
END_DOC
allocate(state_weights(N_states))
state_weights = state_average_weight
integer :: ispin
! condition for alpha/beta spin
print*,''
print*,''
print*,''
print*,'providint state_av_act_two_rdm_openmp_alpha_beta_mo '
ispin = 3
print*,'ispin = ',ispin
state_av_act_two_rdm_openmp_alpha_beta_mo = 0.d0
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_alpha_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
BEGIN_DOC
! state_av_act_two_rdm_openmp_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices
! The active part of the two-electron energy can be computed as:
!
! \sum_{i,j,k,l = 1, n_act_orb} state_av_act_two_rdm_openmp_spin_trace_mo(i,j,k,l) * < ii jj | kk ll >
!
! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l)
END_DOC
double precision, allocatable :: state_weights(:)
allocate(state_weights(N_states))
state_weights = state_average_weight
integer :: ispin
! condition for alpha/beta spin
ispin = 4
state_av_act_two_rdm_openmp_spin_trace_mo = 0.d0
integer :: i
double precision :: wall_0,wall_1
call wall_time(wall_0)
print*,'providing the state average TWO-RDM ...'
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
call wall_time(wall_1)
print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0
END_PROVIDER

127
src/two_body_rdm/state_av_act_2rdm.irp.f Normal file
View File

@ -0,0 +1,127 @@
BEGIN_PROVIDER [double precision, state_av_act_2_rdm_ab_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! state_av_act_2_rdm_ab_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs
!
! = \sum_{istate} w(istate) * <Psi_{istate}| a^{\dagger}_{i,alpha} a^{\dagger}_{j,beta} a_{l,beta} a_{k,alpha} |Psi_{istate}>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha}^{act} * N_{\beta}^{act}
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is alpha, electron 2 is beta
!
! state_av_act_2_rdm_ab_mo(i,j,k,l) = i:alpha, j:beta, j:alpha, l:beta
!
! Therefore you don't necessary have symmetry between electron 1 and 2
END_DOC
allocate(state_weights(N_states))
state_weights = state_average_weight
integer :: ispin
! condition for alpha/beta spin
print*,''
print*,''
print*,''
print*,'providint state_av_act_2_rdm_ab_mo '
ispin = 3
print*,'ispin = ',ispin
state_av_act_2_rdm_ab_mo = 0.d0
call wall_time(wall_1)
double precision :: wall_1, wall_2
call orb_range_2_rdm_state_av_openmp(state_av_act_2_rdm_ab_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
call wall_time(wall_2)
print*,'Wall time to provide state_av_act_2_rdm_ab_mo',wall_2 - wall_1
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_act_2_rdm_aa_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! state_av_act_2_rdm_aa_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs
!
! = \sum_{istate} w(istate) * <Psi_{istate}| a^{\dagger}_{i,alpha} a^{\dagger}_{j,alpha} a_{l,alpha} a_{k,alpha} |Psi_{istate}>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha}^{act} * (N_{\alpha}^{act} - 1)/2
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
END_DOC
allocate(state_weights(N_states))
state_weights = state_average_weight
integer :: ispin
! condition for alpha/beta spin
ispin = 1
state_av_act_2_rdm_aa_mo = 0.D0
call wall_time(wall_1)
double precision :: wall_1, wall_2
call orb_range_2_rdm_state_av_openmp(state_av_act_2_rdm_aa_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
call wall_time(wall_2)
print*,'Wall time to provide state_av_act_2_rdm_aa_mo',wall_2 - wall_1
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_act_2_rdm_bb_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
double precision, allocatable :: state_weights(:)
BEGIN_DOC
! state_av_act_2_rdm_bb_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs
!
! = \sum_{istate} w(istate) * <Psi_{istate}| a^{\dagger}_{i,beta} a^{\dagger}_{j,beta} a_{l,beta} a_{k,beta} |Psi_{istate}>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\beta}^{act} * (N_{\beta}^{act} - 1)/2
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
END_DOC
allocate(state_weights(N_states))
state_weights = state_average_weight
integer :: ispin
! condition for alpha/beta spin
ispin = 2
state_av_act_2_rdm_bb_mo = 0.d0
call wall_time(wall_1)
double precision :: wall_1, wall_2
call orb_range_2_rdm_state_av_openmp(state_av_act_2_rdm_bb_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
call wall_time(wall_2)
print*,'Wall time to provide state_av_act_2_rdm_bb_mo',wall_2 - wall_1
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_act_2_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
BEGIN_DOC
! state_av_act_2_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices
!
! = \sum_{istate} w(istate) * \sum_{sigma,sigma'} <Psi_{istate}| a^{\dagger}_{i,sigma} a^{\dagger'}_{j,sigma} a_{l,sigma'} a_{k,sigma} |Psi_{istate}>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{elec} * (N_{elec} - 1)/2
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
END_DOC
double precision, allocatable :: state_weights(:)
allocate(state_weights(N_states))
state_weights = state_average_weight
integer :: ispin
! condition for alpha/beta spin
ispin = 4
state_av_act_2_rdm_spin_trace_mo = 0.d0
integer :: i
call wall_time(wall_1)
double precision :: wall_1, wall_2
print*,'providing state_av_act_2_rdm_spin_trace_mo '
call orb_range_2_rdm_state_av_openmp(state_av_act_2_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
call wall_time(wall_2)
print*,'Time to provide state_av_act_2_rdm_spin_trace_mo',wall_2 - wall_1
END_PROVIDER

537
src/two_body_rdm/state_av_full_orb_2_rdm.irp.f Normal file
View File

@ -0,0 +1,537 @@
BEGIN_PROVIDER [double precision, state_av_full_occ_2_rdm_ab_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)]
implicit none
state_av_full_occ_2_rdm_ab_mo = 0.d0
integer :: i,j,k,l,iorb,jorb,korb,lorb
BEGIN_DOC
! state_av_full_occ_2_rdm_ab_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of alpha/beta electrons
!
! = \sum_{istate} w(istate) * <Psi_{istate}| a^{\dagger}_{i,alpha} a^{\dagger}_{j,beta} a_{l,beta} a_{k,alpha} |Psi_{istate}>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * N_{\beta}
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is ALPHA, electron 2 is BETA
!
! state_av_full_occ_2_rdm_ab_mo(i,j,k,l) = i:alpha, j:beta, j:alpha, l:beta
!
! Therefore you don't necessary have symmetry between electron 1 and 2
!
! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero
END_DOC
state_av_full_occ_2_rdm_ab_mo = 0.d0
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_act_orb
korb = list_act(k)
do l = 1, n_act_orb
lorb = list_act(l)
! alph beta alph beta
state_av_full_occ_2_rdm_ab_mo(lorb,korb,jorb,iorb) = &
state_av_act_2_rdm_ab_mo(l,k,j,i)
enddo
enddo
enddo
enddo
!! BETA ACTIVE - ALPHA inactive
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! alph beta alph beta
state_av_full_occ_2_rdm_ab_mo(korb,jorb,korb,iorb) = one_e_dm_mo_beta_average(jorb,iorb)
enddo
enddo
enddo
!! ALPHA ACTIVE - BETA inactive
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! alph beta alph beta
state_av_full_occ_2_rdm_ab_mo(jorb,korb,iorb,korb) = one_e_dm_mo_alpha_average(jorb,iorb)
enddo
enddo
enddo
!! ALPHA INACTIVE - BETA INACTIVE
!!
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! alph beta alph beta
state_av_full_occ_2_rdm_ab_mo(korb,jorb,korb,jorb) = 1.D0
enddo
enddo
!!!!!!!!!!!!
!!!!!!!!!!!! if "no_core_density" then you don't put the core part
!!!!!!!!!!!! CAN BE USED
if (.not.no_core_density)then
!! BETA ACTIVE - ALPHA CORE
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
! alph beta alph beta
state_av_full_occ_2_rdm_ab_mo(korb,jorb,korb,iorb) = one_e_dm_mo_beta_average(jorb,iorb)
enddo
enddo
enddo
!! ALPHA ACTIVE - BETA CORE
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
! alph beta alph beta
state_av_full_occ_2_rdm_ab_mo(jorb,korb,iorb,korb) = one_e_dm_mo_alpha_average(jorb,iorb)
enddo
enddo
enddo
!! ALPHA CORE - BETA CORE
!!
do j = 1, n_core_orb
jorb = list_core(j)
do k = 1, n_core_orb
korb = list_core(k)
! alph beta alph beta
state_av_full_occ_2_rdm_ab_mo(korb,jorb,korb,jorb) = 1.D0
enddo
enddo
endif
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_full_occ_2_rdm_aa_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)]
implicit none
state_av_full_occ_2_rdm_aa_mo = 0.d0
integer :: i,j,k,l,iorb,jorb,korb,lorb
BEGIN_DOC
! state_av_full_occ_2_rdm_aa_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of alpha/alpha electrons
!
! = \sum_{istate} w(istate) * <Psi_{istate}| a^{\dagger}_{i,alpha} a^{\dagger}_{j,alpha} a_{l,alpha} a_{k,alpha} |Psi_{istate}>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * (N_{\alpha} - 1)/2
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero
END_DOC
!! PURE ACTIVE PART ALPHA-ALPHA
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_act_orb
korb = list_act(k)
do l = 1, n_act_orb
lorb = list_act(l)
state_av_full_occ_2_rdm_aa_mo(lorb,korb,jorb,iorb) = &
state_av_act_2_rdm_aa_mo(l,k,j,i)
enddo
enddo
enddo
enddo
!! ALPHA ACTIVE - ALPHA inactive
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! 1 2 1 2 : DIRECT TERM
state_av_full_occ_2_rdm_aa_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
state_av_full_occ_2_rdm_aa_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
! 1 2 1 2 : EXCHANGE TERM
state_av_full_occ_2_rdm_aa_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
state_av_full_occ_2_rdm_aa_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
enddo
enddo
enddo
!! ALPHA INACTIVE - ALPHA INACTIVE
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_inact_orb
korb = list_inact(k)
state_av_full_occ_2_rdm_aa_mo(korb,jorb,korb,jorb) += 0.5d0
state_av_full_occ_2_rdm_aa_mo(korb,jorb,jorb,korb) -= 0.5d0
enddo
enddo
!!!!!!!!!!
!!!!!!!!!! if "no_core_density" then you don't put the core part
!!!!!!!!!! CAN BE USED
if (.not.no_core_density)then
!! ALPHA ACTIVE - ALPHA CORE
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
! 1 2 1 2 : DIRECT TERM
state_av_full_occ_2_rdm_aa_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
state_av_full_occ_2_rdm_aa_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
! 1 2 1 2 : EXCHANGE TERM
state_av_full_occ_2_rdm_aa_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
state_av_full_occ_2_rdm_aa_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
enddo
enddo
enddo
!! ALPHA CORE - ALPHA CORE
do j = 1, n_core_orb
jorb = list_core(j)
do k = 1, n_core_orb
korb = list_core(k)
state_av_full_occ_2_rdm_aa_mo(korb,jorb,korb,jorb) += 0.5d0
state_av_full_occ_2_rdm_aa_mo(korb,jorb,jorb,korb) -= 0.5d0
enddo
enddo
endif
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_full_occ_2_rdm_bb_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)]
implicit none
state_av_full_occ_2_rdm_bb_mo = 0.d0
integer :: i,j,k,l,iorb,jorb,korb,lorb
BEGIN_DOC
! state_av_full_occ_2_rdm_bb_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of beta/beta electrons
!
! = \sum_{istate} w(istate) * <Psi_{istate}| a^{\dagger}_{i,beta} a^{\dagger}_{j,beta} a_{l,beta} a_{k,beta} |Psi_{istate}>
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\beta} * (N_{\beta} - 1)/2
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero
END_DOC
!! PURE ACTIVE PART beta-beta
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_act_orb
korb = list_act(k)
do l = 1, n_act_orb
lorb = list_act(l)
state_av_full_occ_2_rdm_bb_mo(lorb,korb,jorb,iorb) = &
state_av_act_2_rdm_bb_mo(l,k,j,i)
enddo
enddo
enddo
enddo
!! beta ACTIVE - beta inactive
!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! 1 2 1 2 : DIRECT TERM
state_av_full_occ_2_rdm_bb_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
state_av_full_occ_2_rdm_bb_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
! 1 2 1 2 : EXCHANGE TERM
state_av_full_occ_2_rdm_bb_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
state_av_full_occ_2_rdm_bb_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
enddo
enddo
enddo
!! beta INACTIVE - beta INACTIVE
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_inact_orb
korb = list_inact(k)
state_av_full_occ_2_rdm_bb_mo(korb,jorb,korb,jorb) += 0.5d0
state_av_full_occ_2_rdm_bb_mo(korb,jorb,jorb,korb) -= 0.5d0
enddo
enddo
!!!!!!!!!!!!
!!!!!!!!!!!! if "no_core_density" then you don't put the core part
!!!!!!!!!!!! CAN BE USED
if (.not.no_core_density)then
!! beta ACTIVE - beta CORE
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
! 1 2 1 2 : DIRECT TERM
state_av_full_occ_2_rdm_bb_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
state_av_full_occ_2_rdm_bb_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
! 1 2 1 2 : EXCHANGE TERM
state_av_full_occ_2_rdm_bb_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
state_av_full_occ_2_rdm_bb_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
enddo
enddo
enddo
!! beta CORE - beta CORE
do j = 1, n_core_orb
jorb = list_core(j)
do k = 1, n_core_orb
korb = list_core(k)
state_av_full_occ_2_rdm_bb_mo(korb,jorb,korb,jorb) += 0.5d0
state_av_full_occ_2_rdm_bb_mo(korb,jorb,jorb,korb) -= 0.5d0
enddo
enddo
endif
END_PROVIDER
BEGIN_PROVIDER [double precision, state_av_full_occ_2_rdm_spin_trace_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)]
implicit none
state_av_full_occ_2_rdm_spin_trace_mo = 0.d0
integer :: i,j,k,l,iorb,jorb,korb,lorb
BEGIN_DOC
! state_av_full_occ_2_rdm_bb_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of beta/beta electrons
!
! = \sum_{istate} w(istate) * \sum_{sigma,sigma'} <Psi_{istate}| a^{\dagger}_{i,sigma} a^{\dagger'}_{j,sigma} a_{l,sigma'} a_{k,sigma} |Psi_{istate}>
!
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active
!
! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{elec} * (N_{elec} - 1)/2
!
! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
!
! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero
END_DOC
!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!
!! PURE ACTIVE PART SPIN-TRACE
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_act_orb
korb = list_act(k)
do l = 1, n_act_orb
lorb = list_act(l)
state_av_full_occ_2_rdm_spin_trace_mo(lorb,korb,jorb,iorb) += &
state_av_act_2_rdm_spin_trace_mo(l,k,j,i)
enddo
enddo
enddo
enddo
!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!
!!!!! BETA-BETA !!!!!
!! beta ACTIVE - beta inactive
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! 1 2 1 2 : DIRECT TERM
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
! 1 2 1 2 : EXCHANGE TERM
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
enddo
enddo
enddo
!! beta INACTIVE - beta INACTIVE
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_inact_orb
korb = list_inact(k)
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb) -= 0.5d0
enddo
enddo
if (.not.no_core_density)then
!! beta ACTIVE - beta CORE
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
! 1 2 1 2 : DIRECT TERM
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
! 1 2 1 2 : EXCHANGE TERM
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
enddo
enddo
enddo
!! beta CORE - beta CORE
do j = 1, n_core_orb
jorb = list_core(j)
do k = 1, n_core_orb
korb = list_core(k)
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb) -= 0.5d0
enddo
enddo
endif
!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!
!!!!! ALPHA-ALPHA !!!!!
!! ALPHA ACTIVE - ALPHA inactive
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! 1 2 1 2 : DIRECT TERM
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
! 1 2 1 2 : EXCHANGE TERM
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
enddo
enddo
enddo
!! ALPHA INACTIVE - ALPHA INACTIVE
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_inact_orb
korb = list_inact(k)
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb) -= 0.5d0
enddo
enddo
if (.not.no_core_density)then
!! ALPHA ACTIVE - ALPHA CORE
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
! 1 2 1 2 : DIRECT TERM
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
! 1 2 1 2 : EXCHANGE TERM
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
enddo
enddo
enddo
!! ALPHA CORE - ALPHA CORE
do j = 1, n_core_orb
jorb = list_core(j)
do k = 1, n_core_orb
korb = list_core(k)
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb) -= 0.5d0
enddo
enddo
endif
!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!
!!!!! ALPHA-BETA + BETA-ALPHA !!!!!
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! ALPHA INACTIVE - BETA ACTIVE
! alph beta alph beta
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
! beta alph beta alph
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb)
! BETA INACTIVE - ALPHA ACTIVE
! beta alph beta alpha
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
! alph beta alph beta
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb)
enddo
enddo
enddo
!! ALPHA INACTIVE - BETA INACTIVE
do j = 1, n_inact_orb
jorb = list_inact(j)
do k = 1, n_inact_orb
korb = list_inact(k)
! alph beta alph beta
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5D0
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,jorb,korb) += 0.5D0
enddo
enddo
!!!!!!!!!!!!
!!!!!!!!!!!! if "no_core_density" then you don't put the core part
!!!!!!!!!!!! CAN BE USED
if (.not.no_core_density)then
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_act_orb
jorb = list_act(j)
do k = 1, n_core_orb
korb = list_core(k)
!! BETA ACTIVE - ALPHA CORE
! alph beta alph beta
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5D0 * one_e_dm_mo_beta_average(jorb,iorb)
! beta alph beta alph
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5D0 * one_e_dm_mo_beta_average(jorb,iorb)
!! ALPHA ACTIVE - BETA CORE
! alph beta alph beta
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5D0 * one_e_dm_mo_alpha_average(jorb,iorb)
! beta alph beta alph
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5D0 * one_e_dm_mo_alpha_average(jorb,iorb)
enddo
enddo
enddo
!! ALPHA CORE - BETA CORE
do j = 1, n_core_orb
jorb = list_core(j)
do k = 1, n_core_orb
korb = list_core(k)
! alph beta alph beta
state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5D0
state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,jorb,korb) += 0.5D0
enddo
enddo
endif
END_PROVIDER

8
src/two_body_rdm/test_2_rdm.irp.f Normal file
View File

@ -0,0 +1,8 @@
program test_2_rdm
implicit none
read_wf = .True.
touch read_wf
call routine_active_only
call routine_full_mos
end

62
src/two_body_rdm/two_rdm.irp.f
View File

@ -1,62 +0,0 @@
BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)]
&BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo, (mo_num,mo_num,mo_num,mo_num,N_states)]
&BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)]
implicit none
BEGIN_DOC
! two_rdm_alpha_beta(i,j,k,l) = <Psi| a^{dagger}_{j,alpha} a^{dagger}_{l,beta} a_{k,beta} a_{i,alpha} | Psi>
! 1 1 2 2 = chemist notations
! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry
!
END_DOC
integer :: dim1,dim2,dim3,dim4
double precision :: cpu_0,cpu_1
dim1 = mo_num
dim2 = mo_num
dim3 = mo_num
dim4 = mo_num
two_rdm_alpha_beta_mo = 0.d0
two_rdm_alpha_alpha_mo= 0.d0
two_rdm_beta_beta_mo = 0.d0
print*,'providing two_rdm_alpha_beta ...'
call wall_time(cpu_0)
call all_two_rdm_dm_nstates(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1))
call wall_time(cpu_1)
print*,'two_rdm_alpha_beta provided in',dabs(cpu_1-cpu_0)
END_PROVIDER
BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)]
&BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)]
&BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)]
implicit none
BEGIN_DOC
! two_rdm_alpha_beta_mo_physicist,(i,j,k,l) = <Psi| a^{dagger}_{k,alpha} a^{dagger}_{l,beta} a_{j,beta} a_{i,alpha} | Psi>
! 1 2 1 2 = physicist notations
! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry
!
END_DOC
integer :: i,j,k,l,istate
double precision :: cpu_0,cpu_1
two_rdm_alpha_beta_mo_physicist = 0.d0
print*,'providing two_rdm_alpha_beta_mo_physicist ...'
call wall_time(cpu_0)
do istate = 1, N_states
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
! 1 2 1 2 1 1 2 2
two_rdm_alpha_beta_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_beta_mo(i,l,j,k,istate)
two_rdm_alpha_alpha_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_alpha_mo(i,l,j,k,istate)
two_rdm_beta_beta_mo_physicist(l,k,i,j,istate) = two_rdm_beta_beta_mo(i,l,j,k,istate)
enddo
enddo
enddo
enddo
enddo
call wall_time(cpu_1)
print*,'two_rdm_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0)
END_PROVIDER

1
src/two_rdm_routines/NEED Normal file
View File

@ -0,0 +1 @@
davidson_undressed

243
src/two_body_rdm/orb_range_routines.irp.f → src/two_rdm_routines/davidson_like_2rdm.irp.f
View File

@ -1,4 +1,4 @@
subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_0,N_st,sze)
subroutine orb_range_2_rdm_openmp(big_array,dim1,norb,list_orb,ispin,u_0,N_st,sze)
use bitmasks
implicit none
BEGIN_DOC
@ -13,9 +13,8 @@ subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reve
END_DOC
integer, intent(in) :: N_st,sze
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
double precision, intent(in) :: u_0(sze,N_st),state_weights(N_st)
double precision, intent(in) :: u_0(sze,N_st)
integer :: k
double precision, allocatable :: u_t(:,:)
@ -30,9 +29,8 @@ subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reve
u_t, &
size(u_t, 1), &
N_det, N_st)
call orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1)
call orb_range_2_rdm_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,1,N_det,0,1)
deallocate(u_t)
do k=1,N_st
@ -41,7 +39,7 @@ subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reve
end
subroutine orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
subroutine orb_range_2_rdm_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
implicit none
BEGIN_DOC
@ -51,9 +49,8 @@ subroutine orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb
END_DOC
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st)
double precision, intent(in) :: u_t(N_st,N_det)
integer :: k
@ -61,15 +58,15 @@ subroutine orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb
select case (N_int)
case (1)
call orb_range_two_rdm_state_av_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
call orb_range_2_rdm_openmp_work_1(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (2)
call orb_range_two_rdm_state_av_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
call orb_range_2_rdm_openmp_work_2(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (3)
call orb_range_two_rdm_state_av_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
call orb_range_2_rdm_openmp_work_3(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (4)
call orb_range_two_rdm_state_av_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
call orb_range_2_rdm_openmp_work_4(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case default
call orb_range_two_rdm_state_av_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
call orb_range_2_rdm_openmp_work_N_int(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
end select
end
@ -77,8 +74,9 @@ end
BEGIN_TEMPLATE
subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
use omp_lib
implicit none
BEGIN_DOC
! Computes the two rdm for the N_st vectors |u_t>
@ -87,21 +85,18 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
! == 3 :: alpha/beta 2rdm
! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba))
! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb
! In any cases, the state average weights will be used with an array state_weights
! Default should be 1,N_det,0,1 for istart,iend,ishift,istep
END_DOC
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st)
double precision, intent(in) :: u_t(N_st,N_det)
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
integer(omp_lock_kind) :: lock_2rdm
integer :: i,j,k,l
integer :: k_a, k_b, l_a, l_b, m_a, m_b
integer :: istate
integer :: krow, kcol, krow_b, kcol_b
integer :: k_a, k_b, l_a, l_b
integer :: krow, kcol
integer :: lrow, lcol
integer :: mrow, mcol
integer(bit_kind) :: spindet($N_int)
integer(bit_kind) :: tmp_det($N_int,2)
integer(bit_kind) :: tmp_det2($N_int,2)
@ -113,11 +108,13 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
integer, allocatable :: singles_b(:)
integer, allocatable :: idx(:), idx0(:)
integer :: maxab, n_singles_a, n_singles_b, kcol_prev
integer*8 :: k8
double precision :: c_average
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
integer(bit_kind) :: orb_bitmask($N_int)
integer :: list_orb_reverse(mo_num)
integer, allocatable :: keys(:,:)
double precision, allocatable :: values(:,:)
integer :: nkeys,sze_buff
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
@ -131,51 +128,56 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
else if(ispin == 4)then
spin_trace = .True.
else
print*,'Wrong parameter for ispin in general_two_rdm_state_av_work'
print*,'Wrong parameter for ispin in general_2_rdm_state_av_openmp_work'
print*,'ispin = ',ispin
stop
endif
PROVIDE N_int
call list_to_bitstring( orb_bitmask, list_orb, norb, N_int)
sze_buff = 6 * norb + elec_alpha_num * elec_alpha_num * 60
list_orb_reverse = -1000
do i = 1, norb
list_orb_reverse(list_orb(i)) = i
enddo
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
allocate(idx0(maxab))
do i=1,maxab
idx0(i) = i
enddo
call omp_init_lock(lock_2rdm)
! Prepare the array of all alpha single excitations
! -------------------------------------------------
PROVIDE N_int nthreads_davidson
!!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, &
! !$OMP psi_bilinear_matrix_columns, &
! !$OMP psi_det_alpha_unique, psi_det_beta_unique,&
! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
! !$OMP psi_bilinear_matrix_transp_rows, &
! !$OMP psi_bilinear_matrix_transp_columns, &
! !$OMP psi_bilinear_matrix_transp_order, N_st, &
! !$OMP psi_bilinear_matrix_order_transp_reverse, &
! !$OMP psi_bilinear_matrix_columns_loc, &
! !$OMP psi_bilinear_matrix_transp_rows_loc, &
! !$OMP istart, iend, istep, irp_here, v_t, s_t, &
! !$OMP ishift, idx0, u_t, maxab) &
! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,&
! !$OMP lcol, lrow, l_a, l_b, &
! !$OMP buffer, doubles, n_doubles, &
! !$OMP tmp_det2, idx, l, kcol_prev, &
! !$OMP singles_a, n_singles_a, singles_b, &
! !$OMP n_singles_b, k8)
PROVIDE N_int nthreads_davidson elec_alpha_num
!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
!$OMP SHARED(psi_bilinear_matrix_rows, N_det,lock_2rdm,&
!$OMP psi_bilinear_matrix_columns, &
!$OMP psi_det_alpha_unique, psi_det_beta_unique,&
!$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
!$OMP psi_bilinear_matrix_transp_rows, &
!$OMP psi_bilinear_matrix_transp_columns, &
!$OMP psi_bilinear_matrix_transp_order, N_st, &
!$OMP psi_bilinear_matrix_order_transp_reverse, &
!$OMP psi_bilinear_matrix_columns_loc, &
!$OMP psi_bilinear_matrix_transp_rows_loc,elec_alpha_num, &
!$OMP istart, iend, istep, irp_here,list_orb_reverse, n_states, dim1, &
!$OMP ishift, idx0, u_t, maxab, alpha_alpha,beta_beta,alpha_beta,spin_trace,ispin,big_array,sze_buff,orb_bitmask) &
!$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,c_1, &
!$OMP lcol, lrow, l_a, l_b, &
!$OMP buffer, doubles, n_doubles, &
!$OMP tmp_det2, idx, l, kcol_prev, &
!$OMP singles_a, n_singles_a, singles_b, &
!$OMP n_singles_b, nkeys, keys, values)
! Alpha/Beta double excitations
! =============================
nkeys = 0
allocate( keys(4,sze_buff), values(n_st,sze_buff))
allocate( buffer($N_int,maxab), &
singles_a(maxab), &
singles_b(maxab), &
@ -188,7 +190,7 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
ASSERT (istart > 0)
ASSERT (istep > 0)
!!$OMP DO SCHEDULE(dynamic,64)
!$OMP DO SCHEDULE(dynamic,64)
do k_a=istart+ishift,iend,istep
krow = psi_bilinear_matrix_rows(k_a)
@ -247,22 +249,36 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
c_average = 0.d0
! print*,'nkeys before = ',nkeys
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_average += c_1(l) * c_2(l) * state_weights(l)
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
enddo
call orb_range_off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
if(alpha_beta)then
! only ONE contribution
if (nkeys+1 .ge. sze_buff) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
endif
else if (spin_trace)then
! TWO contributions
if (nkeys+2 .ge. sze_buff) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
endif
endif
call orb_range_off_diag_double_to_all_states_ab_dm_buffer(tmp_det,tmp_det2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
enddo
endif
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
enddo
enddo
! !$OMP END DO
!$OMP END DO
! !$OMP DO SCHEDULE(dynamic,64)
!$OMP DO SCHEDULE(dynamic,64)
do k_a=istart+ishift,iend,istep
@ -322,21 +338,28 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
c_average = 0.d0
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_average += c_1(l) * c_2(l) * state_weights(l)
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
enddo
if(alpha_beta.or.spin_trace.or.alpha_alpha)then
! increment the alpha/beta part for single excitations
call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
if (nkeys+ 2 * elec_alpha_num .ge. sze_buff) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
endif
call orb_range_off_diag_single_to_all_states_ab_dm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! increment the alpha/alpha part for single excitations
call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
if (nkeys+4 * elec_alpha_num .ge. sze_buff ) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
endif
call orb_range_off_diag_single_to_all_states_aa_dm_buffer(tmp_det,tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
endif
enddo
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
! Compute Hij for all alpha doubles
! ----------------------------------
@ -349,15 +372,18 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
c_average = 0.d0
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_average += c_1(l) * c_2(l) * state_weights(l)
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
enddo
call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
if (nkeys+4 .ge. sze_buff) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
endif
call orb_range_off_diag_double_to_all_states_aa_dm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
enddo
endif
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
! Single and double beta excitations
@ -414,19 +440,26 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
l_a = psi_bilinear_matrix_transp_order(l_b)
c_average = 0.d0
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_average += c_1(l) * c_2(l) * state_weights(l)
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
enddo
if(alpha_beta.or.spin_trace.or.beta_beta)then
! increment the alpha/beta part for single excitations
call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
if (nkeys+2 * elec_alpha_num .ge. sze_buff ) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
endif
call orb_range_off_diag_single_to_all_states_ab_dm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! increment the beta /beta part for single excitations
call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
if (nkeys+4 * elec_alpha_num .ge. sze_buff) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
endif
call orb_range_off_diag_single_to_all_states_bb_dm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
endif
enddo
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
! Compute Hij for all beta doubles
! ----------------------------------
@ -440,17 +473,21 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
ASSERT (lcol <= N_det_beta_unique)
l_a = psi_bilinear_matrix_transp_order(l_b)
c_average = 0.d0
do l= 1, N_states
c_1(l) = u_t(l,l_a)
c_2(l) = u_t(l,k_a)
c_average += c_1(l) * c_2(l) * state_weights(l)
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
enddo
call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
if (nkeys+4 .ge. sze_buff) then
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
endif
call orb_range_off_diag_double_to_all_states_bb_dm_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! print*,'to do orb_range_off_diag_double_to_2_rdm_bb_dm_buffer'
ASSERT (l_a <= N_det)
enddo
endif
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
! Diagonal contribution
@ -471,19 +508,21 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
double precision, external :: diag_wee_mat_elem, diag_S_mat_elem
double precision :: c_1(N_states),c_2(N_states)
c_average = 0.d0
double precision :: c_1(N_states)
do l = 1, N_states
c_1(l) = u_t(l,k_a)
c_average += c_1(l) * c_1(l) * state_weights(l)
c_1(l) = u_t(l,k_a) * u_t(l,k_a)
enddo
call orb_range_diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
call orb_range_diag_to_all_states_2_rdm_dm_buffer(tmp_det,c_1,N_states,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
nkeys = 0
end do
!!$OMP END DO
deallocate(buffer, singles_a, singles_b, doubles, idx)
!!$OMP END PARALLEL
!$OMP END DO
deallocate(buffer, singles_a, singles_b, doubles, idx, keys, values)
!$OMP END PARALLEL
end
@ -497,3 +536,35 @@ end
END_TEMPLATE
subroutine update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
use omp_lib
implicit none
integer, intent(in) :: n_st,nkeys,dim1
integer, intent(in) :: keys(4,nkeys)
double precision, intent(in) :: values(n_st,nkeys)
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,n_st)
integer(omp_lock_kind),intent(inout):: lock_2rdm
integer :: istate
integer :: i,h1,h2,p1,p2
call omp_set_lock(lock_2rdm)
! print*,'*************'
! print*,'updating'
! print*,'nkeys',nkeys
do i = 1, nkeys
h1 = keys(1,i)
h2 = keys(2,i)
p1 = keys(3,i)
p2 = keys(4,i)
do istate = 1, N_st
! print*,h1,h2,p1,p2,values(istate,i)
big_array(h1,h2,p1,p2,istate) += values(istate,i)
enddo
enddo
call omp_unset_lock(lock_2rdm)
end

49
src/two_body_rdm/orb_range_routines_omp.irp.f → src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f
View File

@ -1,4 +1,4 @@
subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_weights,ispin,u_0,N_st,sze)
subroutine orb_range_2_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_weights,ispin,u_0,N_st,sze)
use bitmasks
implicit none
BEGIN_DOC
@ -30,7 +30,7 @@ subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_
size(u_t, 1), &
N_det, N_st)
call orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1)
call orb_range_2_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1)
deallocate(u_t)
do k=1,N_st
@ -39,7 +39,7 @@ subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_
end
subroutine orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
subroutine orb_range_2_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
implicit none
BEGIN_DOC
@ -58,15 +58,15 @@ subroutine orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,s
select case (N_int)
case (1)
call orb_range_two_rdm_state_av_openmp_work_1(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
call orb_range_2_rdm_state_av_openmp_work_1(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (2)
call orb_range_two_rdm_state_av_openmp_work_2(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
call orb_range_2_rdm_state_av_openmp_work_2(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (3)
call orb_range_two_rdm_state_av_openmp_work_3(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
call orb_range_2_rdm_state_av_openmp_work_3(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case (4)
call orb_range_two_rdm_state_av_openmp_work_4(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
call orb_range_2_rdm_state_av_openmp_work_4(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
case default
call orb_range_two_rdm_state_av_openmp_work_N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
call orb_range_2_rdm_state_av_openmp_work_N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
end select
end
@ -74,7 +74,7 @@ end
BEGIN_TEMPLATE
subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
subroutine orb_range_2_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
use bitmasks
use omp_lib
implicit none
@ -130,7 +130,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
else if(ispin == 4)then
spin_trace = .True.
else
print*,'Wrong parameter for ispin in general_two_rdm_state_av_openmp_work'
print*,'Wrong parameter for ispin in general_2_rdm_state_av_openmp_work'
print*,'ispin = ',ispin
stop
endif
@ -139,7 +139,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
PROVIDE N_int
call list_to_bitstring( orb_bitmask, list_orb, norb, N_int)
sze_buff = norb ** 3 + 6 * norb
sze_buff = 6 * norb + elec_alpha_num * elec_alpha_num * 60
list_orb_reverse = -1000
do i = 1, norb
list_orb_reverse(list_orb(i)) = i
@ -270,11 +270,13 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
nkeys = 0
endif
endif
call orb_range_off_diag_double_to_two_rdm_ab_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
call orb_range_off_diag_double_to_2_rdm_ab_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
enddo
endif
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
nkeys = 0
enddo
enddo
@ -352,17 +354,19 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
nkeys = 0
endif
call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
call orb_range_off_diag_single_to_2_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! increment the alpha/alpha part for single excitations
if (nkeys+4 * elec_alpha_num .ge. sze_buff ) then
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
nkeys = 0
endif
call orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
call orb_range_off_diag_single_to_2_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
endif
enddo
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
nkeys = 0
! Compute Hij for all alpha doubles
! ----------------------------------
@ -385,9 +389,11 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
nkeys = 0
endif
call orb_range_off_diag_double_to_two_rdm_aa_dm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
call orb_range_off_diag_double_to_2_rdm_aa_dm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
enddo
endif
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
nkeys = 0
! Single and double beta excitations
@ -456,15 +462,17 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
nkeys = 0
endif
call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
call orb_range_off_diag_single_to_2_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! increment the beta /beta part for single excitations
if (nkeys+4 * elec_alpha_num .ge. sze_buff) then
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
nkeys = 0
endif
call orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
call orb_range_off_diag_single_to_2_rdm_bb_dm_buffer(tmp_det, tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
endif
enddo
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
nkeys = 0
! Compute Hij for all beta doubles
! ----------------------------------
@ -488,7 +496,8 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
nkeys = 0
endif
call orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
call orb_range_off_diag_double_to_2_rdm_bb_dm_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! print*,'to do orb_range_off_diag_double_to_2_rdm_bb_dm_buffer'
ASSERT (l_a <= N_det)
enddo
@ -522,7 +531,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
nkeys = 0
call orb_range_diag_to_all_two_rdm_dm_buffer(tmp_det,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
call orb_range_diag_to_all_2_rdm_dm_buffer(tmp_det,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
nkeys = 0

881
src/two_rdm_routines/update_rdm.irp.f Normal file
View File

@ -0,0 +1,881 @@
subroutine orb_range_diag_to_all_states_2_rdm_dm_buffer(det_1,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1
!
! c_1 is the array of the contributions to the rdm for all states
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
END_DOC
implicit none
integer, intent(in) :: ispin,sze_buff,N_st
integer, intent(in) :: list_orb_reverse(mo_num)
integer(bit_kind), intent(in) :: det_1(N_int,2)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2
integer(bit_kind) :: det_1_act(N_int,2)
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
do i = 1, N_int
det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i))
det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i))
enddo
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int)
logical :: is_integer_in_string
integer :: i1,i2,istate
if(alpha_beta)then
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
! If alpha/beta, electron 1 is alpha, electron 2 is beta
! Therefore you don't necessayr have symmetry between electron 1 and 2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate)
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
enddo
enddo
else if (alpha_alpha)then
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(1)
i2 = occ(j,1)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate)
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = -0.5d0 * c_1(istate)
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h2
keys(4,nkeys) = h1
enddo
enddo
else if (beta_beta)then
do i = 1, n_occ_ab(2)
i1 = occ(i,2)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate)
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = -0.5d0 * c_1(istate)
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h2
keys(4,nkeys) = h1
enddo
enddo
else if(spin_trace)then
! 0.5 * (alpha beta + beta alpha)
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate)
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate)
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = h1
enddo
enddo
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(1)
i2 = occ(j,1)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate)
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = -0.5d0 * c_1(istate)
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h2
keys(4,nkeys) = h1
enddo
enddo
do i = 1, n_occ_ab(2)
i1 = occ(i,2)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate)
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = -0.5d0 * c_1(istate)
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h2
keys(4,nkeys) = h1
enddo
enddo
endif
end
subroutine orb_range_off_diag_double_to_all_states_ab_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
!
! c_1 is the array of the contributions to the rdm for all states
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 3 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: ispin,sze_buff,N_st
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call get_double_excitation(det_1,det_2,exc,phase,N_int)
h1 = exc(1,1,1)
if(list_orb_reverse(h1).lt.0)return
h1 = list_orb_reverse(h1)
h2 = exc(1,1,2)
if(list_orb_reverse(h2).lt.0)return
h2 = list_orb_reverse(h2)
p1 = exc(1,2,1)
if(list_orb_reverse(p1).lt.0)return
p1 = list_orb_reverse(p1)
p2 = exc(1,2,2)
if(list_orb_reverse(p2).lt.0)return
p2 = list_orb_reverse(p2)
if(alpha_beta)then
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = p2
else if(spin_trace)then
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = p2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = p1
keys(2,nkeys) = p2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
endif
end
subroutine orb_range_off_diag_single_to_all_states_ab_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 3 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: ispin,sze_buff,N_st
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer, intent(in) :: list_orb_reverse(mo_num)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,p1,istate
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(alpha_beta)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
enddo
endif
else if(spin_trace)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
endif
endif
end
subroutine orb_range_off_diag_single_to_all_states_aa_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 1 or 4 will do something
END_DOC
use bitmasks
implicit none
integer, intent(in) :: ispin,sze_buff,N_st
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer, intent(in) :: list_orb_reverse(mo_num)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,p1,istate
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(alpha_alpha.or.spin_trace)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h2
keys(4,nkeys) = p1
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = h2
enddo
else
return
endif
endif
end
subroutine orb_range_off_diag_single_to_all_states_bb_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 2 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: ispin,sze_buff,N_st
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer, intent(in) :: list_orb_reverse(mo_num)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,p1,istate
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(beta_beta.or.spin_trace)then
if (exc(0,1,1) == 1) then
return
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = h2
keys(4,nkeys) = p1
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = h2
enddo
endif
endif
end
subroutine orb_range_off_diag_double_to_all_states_aa_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 1 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: ispin,sze_buff,N_st
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
h1 =exc(1,1)
if(list_orb_reverse(h1).lt.0)return
h1 = list_orb_reverse(h1)
h2 =exc(2,1)
if(list_orb_reverse(h2).lt.0)return
h2 = list_orb_reverse(h2)
p1 =exc(1,2)
if(list_orb_reverse(p1).lt.0)return
p1 = list_orb_reverse(p1)
p2 =exc(2,2)
if(list_orb_reverse(p2).lt.0)return
p2 = list_orb_reverse(p2)
if(alpha_alpha.or.spin_trace)then
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = p2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p2
keys(4,nkeys) = p1
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p2
keys(4,nkeys) = p1
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = p2
endif
end
subroutine orb_range_off_diag_double_to_all_states_bb_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 2 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: ispin,sze_buff,N_st
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
h1 =exc(1,1)
if(list_orb_reverse(h1).lt.0)return
h1 = list_orb_reverse(h1)
h2 =exc(2,1)
if(list_orb_reverse(h2).lt.0)return
h2 = list_orb_reverse(h2)
p1 =exc(1,2)
if(list_orb_reverse(p1).lt.0)return
p1 = list_orb_reverse(p1)
p2 =exc(2,2)
if(list_orb_reverse(p2).lt.0)return
p2 = list_orb_reverse(p2)
if(beta_beta.or.spin_trace)then
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = p2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p2
keys(4,nkeys) = p1
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p2
keys(4,nkeys) = p1
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = p2
endif
end

59
src/two_body_rdm/compute_orb_range_omp.irp.f → src/two_rdm_routines/update_state_av_rdm.irp.f
View File

@ -1,4 +1,4 @@
subroutine orb_range_diag_to_all_two_rdm_dm_buffer(det_1,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_diag_to_all_2_rdm_dm_buffer(det_1,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1
@ -57,6 +57,8 @@
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
! If alpha/beta, electron 1 is alpha, electron 2 is beta
! Therefore you don't necessayr have symmetry between electron 1 and 2
nkeys += 1
values(nkeys) = c_1
keys(1,nkeys) = h1
@ -173,7 +175,7 @@
end
subroutine orb_range_off_diag_double_to_two_rdm_ab_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_double_to_2_rdm_ab_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
@ -255,7 +257,7 @@
endif
end
subroutine orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_single_to_2_rdm_ab_dm_buffer(det_1,det_2,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
@ -281,6 +283,7 @@
integer, intent(in) :: ispin,sze_buff
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer, intent(in) :: list_orb_reverse(mo_num)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
double precision, intent(in) :: c_1
double precision, intent(out) :: values(sze_buff)
integer , intent(out) :: keys(4,sze_buff)
@ -314,14 +317,14 @@
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(list_orb_reverse(h1).lt.0)return
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(list_orb_reverse(p1).lt.0)return
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(list_orb_reverse(h2).lt.0)return
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
values(nkeys) = c_1 * phase
@ -333,14 +336,14 @@
else
! Mono beta
h1 = exc(1,1,2)
if(list_orb_reverse(h1).lt.0)return
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(list_orb_reverse(p1).lt.0)return
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(list_orb_reverse(h2).lt.0)return
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
values(nkeys) = c_1 * phase
@ -354,14 +357,14 @@
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(list_orb_reverse(h1).lt.0)return
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(list_orb_reverse(p1).lt.0)return
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(list_orb_reverse(h2).lt.0)return
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
values(nkeys) = 0.5d0 * c_1 * phase
@ -379,19 +382,15 @@
else
! Mono beta
h1 = exc(1,1,2)
if(list_orb_reverse(h1).lt.0)return
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(list_orb_reverse(p1).lt.0)return
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
!print*,'****************'
!print*,'****************'
!print*,'h1,p1',h1,p1
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(list_orb_reverse(h2).lt.0)return
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
! print*,'h2 = ',h2
nkeys += 1
values(nkeys) = 0.5d0 * c_1 * phase
keys(1,nkeys) = h1
@ -409,7 +408,7 @@
endif
end
subroutine orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_single_to_2_rdm_aa_dm_buffer(det_1,det_2,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
@ -435,6 +434,7 @@
integer, intent(in) :: ispin,sze_buff
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer, intent(in) :: list_orb_reverse(mo_num)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
double precision, intent(in) :: c_1
double precision, intent(out) :: values(sze_buff)
integer , intent(out) :: keys(4,sze_buff)
@ -468,14 +468,14 @@
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(list_orb_reverse(h1).lt.0)return
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(list_orb_reverse(p1).lt.0)return
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(list_orb_reverse(h2).lt.0)return
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
@ -512,7 +512,7 @@
endif
end
subroutine orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_single_to_2_rdm_bb_dm_buffer(det_1,det_2,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
@ -538,6 +538,7 @@
integer, intent(in) :: ispin,sze_buff
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer, intent(in) :: list_orb_reverse(mo_num)
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
double precision, intent(in) :: c_1
double precision, intent(out) :: values(sze_buff)
integer , intent(out) :: keys(4,sze_buff)
@ -573,14 +574,14 @@
else
! Mono beta
h1 = exc(1,1,2)
if(list_orb_reverse(h1).lt.0)return
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(list_orb_reverse(p1).lt.0)return
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(list_orb_reverse(h2).lt.0)return
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
values(nkeys) = 0.5d0 * c_1 * phase
@ -615,7 +616,7 @@
end
subroutine orb_range_off_diag_double_to_two_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_double_to_2_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
@ -710,7 +711,7 @@
endif
end
subroutine orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_double_to_2_rdm_bb_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for