mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-08-24 21:21:47 +02:00
commit
9c9b219aba
@ -1,3 +1,51 @@
|
|||||||
==========================
|
==========================
|
||||||
The core modules of the QP
|
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
5
src/bitmask/EZFIO.cfg
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
[n_act_orb]
|
||||||
|
type: integer
|
||||||
|
doc: Number of active |MOs|
|
||||||
|
interface: ezfio
|
||||||
|
|
@ -49,9 +49,10 @@ BEGIN_PROVIDER [ integer, n_act_orb]
|
|||||||
n_act_orb += 1
|
n_act_orb += 1
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
call write_int(6,n_act_orb, 'Number of active MOs')
|
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
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer, n_virt_orb ]
|
BEGIN_PROVIDER [ integer, n_virt_orb ]
|
||||||
@ -413,3 +414,34 @@ END_PROVIDER
|
|||||||
print *, list_inact_act(1:n_inact_act_orb)
|
print *, list_inact_act(1:n_inact_act_orb)
|
||||||
END_PROVIDER
|
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
|
||||||
|
|
||||||
|
@ -49,15 +49,11 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ]
|
|||||||
P0tuvx= 0.d0
|
P0tuvx= 0.d0
|
||||||
do istate=1,N_states
|
do istate=1,N_states
|
||||||
do x = 1, n_act_orb
|
do x = 1, n_act_orb
|
||||||
xx = list_act(x)
|
|
||||||
do v = 1, n_act_orb
|
do v = 1, n_act_orb
|
||||||
vv = list_act(v)
|
|
||||||
do u = 1, n_act_orb
|
do u = 1, n_act_orb
|
||||||
uu = list_act(u)
|
|
||||||
do t = 1, n_act_orb
|
do t = 1, n_act_orb
|
||||||
tt = list_act(t)
|
! 1 1 2 2 1 2 1 2
|
||||||
P0tuvx(t,u,v,x) = state_av_act_two_rdm_spin_trace_mo(t,v,u,x)
|
P0tuvx(t,u,v,x) = state_av_act_2_rdm_spin_trace_mo(t,v,u,x)
|
||||||
! P0tuvx(t,u,v,x) = act_two_rdm_spin_trace_mo(t,v,u,x)
|
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
@ -24,40 +24,6 @@ subroutine print_grad
|
|||||||
enddo
|
enddo
|
||||||
end
|
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
|
subroutine routine
|
||||||
integer :: i,j,k,l
|
integer :: i,j,k,l
|
||||||
integer :: ii,jj,kk,ll
|
integer :: ii,jj,kk,ll
|
||||||
@ -75,30 +41,11 @@ subroutine routine
|
|||||||
do ii = 1, n_act_orb
|
do ii = 1, n_act_orb
|
||||||
i = list_act(ii)
|
i = list_act(ii)
|
||||||
integral = get_two_e_integral(i,j,k,l,mo_integrals_map)
|
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
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
print*,'accu = ',accu(1)
|
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
|
end
|
||||||
|
@ -11,10 +11,10 @@ interface: ezfio,provider,ocaml
|
|||||||
default: 0.5
|
default: 0.5
|
||||||
|
|
||||||
[no_core_density]
|
[no_core_density]
|
||||||
type: character*(32)
|
type: logical
|
||||||
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
|
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
|
interface: ezfio, provider, ocaml
|
||||||
default: full_density
|
default: False
|
||||||
|
|
||||||
[normalize_dm]
|
[normalize_dm]
|
||||||
type: logical
|
type: logical
|
||||||
|
@ -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(:,:)
|
one_e_dm_mo_alpha_for_dft(:,:,1) = one_e_dm_mo_alpha_average(:,:)
|
||||||
endif
|
endif
|
||||||
|
|
||||||
if(no_core_density .EQ. "no_core_dm")then
|
if(no_core_density)then
|
||||||
integer :: ii,i,j
|
integer :: ii,i,j
|
||||||
do ii = 1, n_core_orb
|
do ii = 1, n_core_orb
|
||||||
i = list_core(ii)
|
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(:,:)
|
one_e_dm_mo_beta_for_dft(:,:,1) = one_e_dm_mo_beta_average(:,:)
|
||||||
endif
|
endif
|
||||||
|
|
||||||
if(no_core_density .EQ. "no_core_dm")then
|
if(no_core_density)then
|
||||||
integer :: ii,i,j
|
integer :: ii,i,j
|
||||||
do ii = 1, n_core_orb
|
do ii = 1, n_core_orb
|
||||||
i = list_core(ii)
|
i = list_core(ii)
|
||||||
|
@ -2,13 +2,13 @@
|
|||||||
type: character*(32)
|
type: character*(32)
|
||||||
doc: name of the exchange functional
|
doc: name of the exchange functional
|
||||||
interface: ezfio, provider, ocaml
|
interface: ezfio, provider, ocaml
|
||||||
default: short_range_LDA
|
default: sr_pbe
|
||||||
|
|
||||||
[correlation_functional]
|
[correlation_functional]
|
||||||
type: character*(32)
|
type: character*(32)
|
||||||
doc: name of the correlation functional
|
doc: name of the correlation functional
|
||||||
interface: ezfio, provider, ocaml
|
interface: ezfio, provider, ocaml
|
||||||
default: short_range_LDA
|
default: sr_pbe
|
||||||
|
|
||||||
[HF_exchange]
|
[HF_exchange]
|
||||||
type: double precision
|
type: double precision
|
||||||
|
@ -1,435 +1,103 @@
|
|||||||
subroutine dm_dft_alpha_beta_at_r(r,dm_a,dm_b)
|
BEGIN_PROVIDER [double precision, one_e_dm_and_grad_alpha_in_r, (4,n_points_final_grid,N_states) ]
|
||||||
implicit none
|
&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
|
BEGIN_DOC
|
||||||
! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z
|
! one_e_dm_and_grad_alpha_in_r(1,i,i_state) = d\dx n_alpha(r_i,istate)
|
||||||
! 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(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
|
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
|
implicit none
|
||||||
integer :: i,j,k,l,m,istate
|
integer :: i,j,k,l,m,istate
|
||||||
double precision :: contrib
|
double precision :: contrib
|
||||||
double precision :: r(3)
|
double precision :: r(3)
|
||||||
double precision :: aos_array(ao_num),mos_array(mo_num)
|
double precision, allocatable :: aos_array(:),grad_aos_array(:,:)
|
||||||
do j = 1, nucl_num
|
double precision, allocatable :: dm_a(:),dm_b(:), dm_a_grad(:,:), dm_b_grad(:,:)
|
||||||
do k = 1, n_points_radial_grid -1
|
allocate(dm_a(N_states),dm_b(N_states), dm_a_grad(3,N_states), dm_b_grad(3,N_states))
|
||||||
do l = 1, n_points_integration_angular
|
allocate(aos_array(ao_num),grad_aos_array(3,ao_num))
|
||||||
do istate = 1, N_States
|
do istate = 1, N_states
|
||||||
one_e_dm_alpha_in_r(l,k,j,istate) = 0.d0
|
do i = 1, n_points_final_grid
|
||||||
one_e_dm_beta_in_r(l,k,j,istate) = 0.d0
|
r(1) = final_grid_points(1,i)
|
||||||
enddo
|
r(2) = final_grid_points(2,i)
|
||||||
r(1) = grid_points_per_atom(1,l,k,j)
|
r(3) = final_grid_points(3,i)
|
||||||
r(2) = grid_points_per_atom(2,l,k,j)
|
|
||||||
r(3) = grid_points_per_atom(3,l,k,j)
|
|
||||||
|
|
||||||
double precision :: dm_a(N_states),dm_b(N_states)
|
call density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, dm_a_grad, dm_b_grad, aos_array, grad_aos_array)
|
||||||
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
|
|
||||||
|
|
||||||
enddo
|
! alpha/beta density
|
||||||
enddo
|
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
|
||||||
|
enddo
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, one_e_dm_alpha_at_r, (n_points_final_grid,N_states) ]
|
BEGIN_PROVIDER [double precision, elec_beta_num_grid_becke , (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_alpha_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
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! one_e_dm_alpha_at_r(i,istate) = n_alpha(r_i,istate)
|
! number of electrons when the one-e alpha/beta densities are numerically integrated on the DFT grid
|
||||||
! 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
|
! !!!!! WARNING !!!! if no_core_density = .True. then all core electrons are removed
|
||||||
END_DOC
|
END_DOC
|
||||||
integer :: i,istate
|
integer :: i,istate
|
||||||
double precision :: r(3)
|
double precision :: r(3),weight
|
||||||
double precision, allocatable :: dm_a(:),dm_b(:)
|
|
||||||
allocate(dm_a(N_states),dm_b(N_states))
|
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
do i = 1, n_points_final_grid
|
do i = 1, n_points_final_grid
|
||||||
r(1) = final_grid_points(1,i)
|
r(1) = final_grid_points(1,i)
|
||||||
r(2) = final_grid_points(2,i)
|
r(2) = final_grid_points(2,i)
|
||||||
r(3) = final_grid_points(3,i)
|
r(3) = final_grid_points(3,i)
|
||||||
call dm_dft_alpha_beta_at_r(r,dm_a,dm_b)
|
weight = final_weight_at_r_vector(i)
|
||||||
one_e_dm_alpha_at_r(i,istate) = dm_a(istate)
|
|
||||||
one_e_dm_beta_at_r(i,istate) = dm_b(istate)
|
elec_alpha_num_grid_becke(istate) += one_e_dm_and_grad_alpha_in_r(4,i,istate) * weight
|
||||||
enddo
|
elec_beta_num_grid_becke(istate) += one_e_dm_and_grad_beta_in_r(4,i,istate) * weight
|
||||||
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)
|
|
||||||
enddo
|
enddo
|
||||||
|
elec_num_grid_becke(istate) = elec_alpha_num_grid_becke(istate) + elec_beta_num_grid_becke(istate)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
290
src/dft_utils_in_r/dm_in_r_routines.irp.f
Normal file
290
src/dft_utils_in_r/dm_in_r_routines.irp.f
Normal 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
|
||||||
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
@ -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$
|
! 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
|
! 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.
|
|
||||||
!
|
!
|
||||||
|
! Taking the expectation value does not provide any energy, but
|
||||||
|
!
|
||||||
|
! 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
|
END_DOC
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
do j = 1, mo_num
|
do j = 1, mo_num
|
||||||
|
264
src/dft_utils_one_e/garbage_func.irp.f
Normal file
264
src/dft_utils_one_e/garbage_func.irp.f
Normal 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
|
@ -1,7 +1,9 @@
|
|||||||
BEGIN_PROVIDER [double precision, mu_erf_dft]
|
BEGIN_PROVIDER [double precision, mu_erf_dft]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
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
|
END_DOC
|
||||||
mu_erf_dft = mu_erf
|
mu_erf_dft = mu_erf
|
||||||
|
|
||||||
|
@ -1,5 +1,10 @@
|
|||||||
subroutine rho_ab_to_rho_oc(rho_a,rho_b,rho_o,rho_c)
|
subroutine rho_ab_to_rho_oc(rho_a,rho_b,rho_o,rho_c)
|
||||||
implicit none
|
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(in) :: rho_a,rho_b
|
||||||
double precision, intent(out) :: rho_o,rho_c
|
double precision, intent(out) :: rho_o,rho_c
|
||||||
rho_c=rho_a+rho_b
|
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)
|
subroutine rho_oc_to_rho_ab(rho_o,rho_c,rho_a,rho_b)
|
||||||
implicit none
|
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(in) :: rho_o,rho_c
|
||||||
double precision, intent(out) :: rho_a,rho_b
|
double precision, intent(out) :: rho_a,rho_b
|
||||||
rho_a= 0.5d0*(rho_c+rho_o)
|
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)
|
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
|
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(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
|
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
|
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)
|
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
|
implicit none
|
||||||
double precision, intent(in) :: v_rho_a,v_rho_b
|
double precision, intent(in) :: v_rho_a,v_rho_b
|
||||||
double precision, intent(out) :: v_rho_o,v_rho_c
|
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)
|
subroutine v_rho_oc_to_v_rho_ab(v_rho_o,v_rho_c,v_rho_a,v_rho_b)
|
||||||
implicit none
|
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(in) :: v_rho_o,v_rho_c
|
||||||
double precision, intent(out) :: v_rho_a,v_rho_b
|
double precision, intent(out) :: v_rho_a,v_rho_b
|
||||||
v_rho_a = v_rho_c + v_rho_o
|
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)
|
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
|
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(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
|
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
|
v_grad_rho_a_2 = v_grad_rho_o_2 + v_grad_rho_c_2 + v_grad_rho_o_c
|
||||||
|
@ -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)
|
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
|
BEGIN_DOC
|
||||||
!mu = range separation parameter
|
!mu = range separation parameter
|
||||||
|
!
|
||||||
!rho_a = density alpha
|
!rho_a = density alpha
|
||||||
|
!
|
||||||
!rho_b = density beta
|
!rho_b = density beta
|
||||||
|
!
|
||||||
!grd_rho_a_2 = (gradient rho_a)^2
|
!grd_rho_a_2 = (gradient rho_a)^2
|
||||||
|
!
|
||||||
!grd_rho_b_2 = (gradient rho_b)^2
|
!grd_rho_b_2 = (gradient rho_b)^2
|
||||||
|
!
|
||||||
!grd_rho_a_b = (gradient rho_a).(gradient rho_b)
|
!grd_rho_a_b = (gradient rho_a).(gradient rho_b)
|
||||||
|
!
|
||||||
!ex = exchange energy density at the density and corresponding gradients of the density
|
!ex = exchange energy density at the density and corresponding gradients of the density
|
||||||
|
!
|
||||||
!vx_rho_a = d ex / d rho_a
|
!vx_rho_a = d ex / d rho_a
|
||||||
|
!
|
||||||
!vx_rho_b = d ex / d rho_b
|
!vx_rho_b = d ex / d rho_b
|
||||||
|
!
|
||||||
!vx_grd_rho_a_2 = d ex / d grd_rho_a_2
|
!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_b_2 = d ex / d grd_rho_b_2
|
||||||
|
!
|
||||||
!vx_grd_rho_a_b = d ex / d grd_rho_a_b
|
!vx_grd_rho_a_b = d ex / d grd_rho_a_b
|
||||||
END_DOC
|
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)
|
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
|
BEGIN_DOC
|
||||||
!rho_a = density alpha
|
!rho_a = density alpha
|
||||||
|
!
|
||||||
!rho_b = density beta
|
!rho_b = density beta
|
||||||
|
!
|
||||||
!grd_rho_a_2 = (gradient rho_a)^2
|
!grd_rho_a_2 = (gradient rho_a)^2
|
||||||
|
!
|
||||||
!grd_rho_b_2 = (gradient rho_b)^2
|
!grd_rho_b_2 = (gradient rho_b)^2
|
||||||
|
!
|
||||||
!grd_rho_a_b = (gradient rho_a).(gradient rho_b)
|
!grd_rho_a_b = (gradient rho_a).(gradient rho_b)
|
||||||
|
!
|
||||||
!ex = exchange energy density at point r
|
!ex = exchange energy density at point r
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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, &
|
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 )
|
ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b )
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! routine that helps in building the x/c potentials on the AO basis for a GGA functional with a short-range interaction
|
! routine that helps in building the x/c potentials on the AO basis for a GGA functional with a short-range interaction
|
||||||
END_DOC
|
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(in) :: mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b
|
||||||
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) :: 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(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)
|
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
|
||||||
integer :: istate
|
double precision :: rhoc,rhoo,sigmacc,sigmaco,sigmaoo,vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo
|
||||||
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 :: 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))
|
! convertion from (alpha,beta) formalism to (closed, open) formalism
|
||||||
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))
|
call rho_ab_to_rho_oc(rho_a,rho_b,rhoo,rhoc)
|
||||||
enddo
|
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
|
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
|
|
||||||
|
|
||||||
|
@ -19,8 +19,8 @@
|
|||||||
r(2) = final_grid_points(2,i)
|
r(2) = final_grid_points(2,i)
|
||||||
r(3) = final_grid_points(3,i)
|
r(3) = final_grid_points(3,i)
|
||||||
weight = final_weight_at_r_vector(i)
|
weight = final_weight_at_r_vector(i)
|
||||||
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
|
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
||||||
rhob(istate) = one_e_dm_beta_at_r(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)
|
call ex_lda(rhoa(istate),rhob(istate),e_x,vx_a,vx_b)
|
||||||
energy_x_lda(istate) += weight * e_x
|
energy_x_lda(istate) += weight * e_x
|
||||||
enddo
|
enddo
|
||||||
@ -46,8 +46,8 @@
|
|||||||
r(2) = final_grid_points(2,i)
|
r(2) = final_grid_points(2,i)
|
||||||
r(3) = final_grid_points(3,i)
|
r(3) = final_grid_points(3,i)
|
||||||
weight = final_weight_at_r_vector(i)
|
weight = final_weight_at_r_vector(i)
|
||||||
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
|
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
||||||
rhob(istate) = one_e_dm_beta_at_r(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)
|
call ec_lda(rhoa(istate),rhob(istate),e_c,vc_a,vc_b)
|
||||||
energy_c_lda(istate) += weight * e_c
|
energy_c_lda(istate) += weight * e_c
|
||||||
enddo
|
enddo
|
||||||
@ -142,8 +142,8 @@ END_PROVIDER
|
|||||||
r(2) = final_grid_points(2,i)
|
r(2) = final_grid_points(2,i)
|
||||||
r(3) = final_grid_points(3,i)
|
r(3) = final_grid_points(3,i)
|
||||||
weight = final_weight_at_r_vector(i)
|
weight = final_weight_at_r_vector(i)
|
||||||
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
|
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
||||||
rhob(istate) = one_e_dm_beta_at_r(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 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)
|
call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,vx_a,vx_b)
|
||||||
do j =1, ao_num
|
do j =1, ao_num
|
||||||
@ -181,8 +181,8 @@ END_PROVIDER
|
|||||||
r(2) = final_grid_points(2,i)
|
r(2) = final_grid_points(2,i)
|
||||||
r(3) = final_grid_points(3,i)
|
r(3) = final_grid_points(3,i)
|
||||||
weight = final_weight_at_r_vector(i)
|
weight = final_weight_at_r_vector(i)
|
||||||
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
|
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
||||||
rhob(istate) = one_e_dm_beta_at_r(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 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)
|
call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,vx_a,vx_b)
|
||||||
do j =1, ao_num
|
do j =1, ao_num
|
||||||
|
@ -1,114 +1,63 @@
|
|||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER[double precision, energy_x_pbe, (N_states) ]
|
BEGIN_PROVIDER[double precision, energy_x_pbe, (N_states) ]
|
||||||
|
&BEGIN_PROVIDER[double precision, energy_c_pbe, (N_states) ]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
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
|
! exchange/correlation energy with the short range pbe functional
|
||||||
END_DOC
|
END_DOC
|
||||||
integer :: istate,i,j,m
|
integer :: istate,i,j,m
|
||||||
double precision :: r(3)
|
|
||||||
double precision :: mu,weight
|
double precision :: mu,weight
|
||||||
double precision, allocatable :: ex(:), ec(:)
|
double precision :: 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 :: 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, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
|
double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b
|
||||||
double precision, allocatable :: 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
|
||||||
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_x_pbe = 0.d0
|
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
|
energy_c_pbe = 0.d0
|
||||||
|
mu = 0.d0
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
do i = 1, n_points_final_grid
|
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)
|
weight = final_weight_at_r_vector(i)
|
||||||
rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
rho_a = 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)
|
rho_b = 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_a(1:3) = 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_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
|
||||||
grad_rho_a_2 = 0.d0
|
grad_rho_a_2 = 0.d0
|
||||||
grad_rho_b_2 = 0.d0
|
grad_rho_b_2 = 0.d0
|
||||||
grad_rho_a_b = 0.d0
|
grad_rho_a_b = 0.d0
|
||||||
do m = 1, 3
|
do m = 1, 3
|
||||||
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
|
grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m)
|
||||||
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
|
grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m)
|
||||||
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
|
grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! inputs
|
! 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
|
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 )
|
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
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, potential_x_alpha_ao_pbe,(ao_num,ao_num,N_states)]
|
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_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_alpha_ao_pbe,(ao_num,ao_num,N_states)]
|
||||||
&BEGIN_PROVIDER [double precision, potential_c_beta_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
|
implicit none
|
||||||
BEGIN_DOC
|
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
|
END_DOC
|
||||||
integer :: i,j,istate
|
integer :: i,j,istate
|
||||||
do istate = 1, n_states
|
do istate = 1, n_states
|
||||||
@ -125,8 +74,6 @@ END_PROVIDER
|
|||||||
|
|
||||||
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_alpha_ao_pbe,(ao_num,ao_num,N_states)]
|
||||||
&BEGIN_PROVIDER [double precision, potential_xc_beta_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
|
implicit none
|
||||||
@ -138,7 +85,7 @@ END_PROVIDER
|
|||||||
do i = 1, ao_num
|
do i = 1, ao_num
|
||||||
do j = 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_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
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -146,82 +93,76 @@ END_PROVIDER
|
|||||||
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_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_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_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_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_d_vc_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_d_vc_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_d_vx_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_vx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
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)
|
! 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
|
END_DOC
|
||||||
integer :: istate,i,j,m
|
integer :: istate,i,j,m
|
||||||
double precision :: r(3)
|
|
||||||
double precision :: mu,weight
|
double precision :: mu,weight
|
||||||
double precision, allocatable :: ex(:), ec(:)
|
double precision :: 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 :: 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, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
|
double precision :: contrib_grad_xa(3),contrib_grad_xb(3),contrib_grad_ca(3),contrib_grad_cb(3)
|
||||||
double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:)
|
double precision :: 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(:)
|
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(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states))
|
aos_d_vc_alpha_pbe_w= 0.d0
|
||||||
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))
|
aos_d_vc_beta_pbe_w = 0.d0
|
||||||
allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states))
|
aos_d_vx_alpha_pbe_w= 0.d0
|
||||||
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))
|
aos_d_vx_beta_pbe_w = 0.d0
|
||||||
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))
|
mu = 0.d0
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
do i = 1, n_points_final_grid
|
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)
|
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)
|
rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
||||||
grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
|
rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate)
|
||||||
grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,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_a_2 = 0.d0
|
||||||
grad_rho_b_2 = 0.d0
|
grad_rho_b_2 = 0.d0
|
||||||
grad_rho_a_b = 0.d0
|
grad_rho_a_b = 0.d0
|
||||||
do m = 1, 3
|
do m = 1, 3
|
||||||
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
|
grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m)
|
||||||
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
|
grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m)
|
||||||
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
|
grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! inputs
|
! 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
|
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 )
|
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
|
vx_rho_a *= weight
|
||||||
vc_rho_a(istate) *= weight
|
vc_rho_a *= weight
|
||||||
vx_rho_b(istate) *= weight
|
vx_rho_b *= weight
|
||||||
vc_rho_b(istate) *= weight
|
vc_rho_b *= weight
|
||||||
do m= 1,3
|
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_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,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_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,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_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,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_xb(m) = weight * (2.d0 * vx_grad_rho_b_2 * grad_rho_b(m) + vx_grad_rho_a_b * grad_rho_a(m) )
|
||||||
enddo
|
enddo
|
||||||
do j = 1, ao_num
|
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_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(istate) * 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(istate) * 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(istate) * aos_in_r_array(j,i)
|
aos_vx_beta_pbe_w (j,i,istate) = vx_rho_b * aos_in_r_array(j,i)
|
||||||
enddo
|
enddo
|
||||||
do j = 1, ao_num
|
do j = 1, ao_num
|
||||||
do m = 1,3
|
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_d_vc_alpha_pbe_w(j,i,istate) += contrib_grad_ca(m) * 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_d_vc_beta_pbe_w (j,i,istate) += contrib_grad_cb(m) * 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_d_vx_alpha_pbe_w(j,i,istate) += contrib_grad_xa(m) * 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_vx_beta_pbe_w (j,i,istate) += contrib_grad_xb(m) * aos_grad_in_r_array_transp_xyz(m,j,i)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
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_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)]
|
&BEGIN_PROVIDER [double precision, pot_scal_c_beta_ao_pbe, (ao_num,ao_num,N_states)]
|
||||||
implicit none
|
implicit none
|
||||||
|
! intermediates to compute the sr_pbe potentials
|
||||||
|
!
|
||||||
integer :: istate
|
integer :: istate
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! intermediate quantity for the calculation of the vxc potentials for the GGA functionals related to the scalar part of the potential
|
! 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)
|
call wall_time(wall_1)
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
! correlation alpha
|
! correlation alpha
|
||||||
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_scal_c_alpha_ao_pbe(1,1,istate),size(pot_scal_c_alpha_ao_pbe,1))
|
||||||
! correlation beta
|
! correlation beta
|
||||||
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_scal_c_beta_ao_pbe(1,1,istate),size(pot_scal_c_beta_ao_pbe,1))
|
||||||
! exchange alpha
|
! exchange alpha
|
||||||
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_scal_x_alpha_ao_pbe(1,1,istate),size(pot_scal_x_alpha_ao_pbe,1))
|
||||||
! exchange beta
|
! exchange beta
|
||||||
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_scal_x_beta_ao_pbe(1,1,istate), size(pot_scal_x_beta_ao_pbe,1))
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
@ -290,24 +233,24 @@ END_PROVIDER
|
|||||||
pot_grad_x_beta_ao_pbe = 0.d0
|
pot_grad_x_beta_ao_pbe = 0.d0
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
! correlation alpha
|
! correlation alpha
|
||||||
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
|
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_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, &
|
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))
|
pot_grad_c_alpha_ao_pbe(1,1,istate),size(pot_grad_c_alpha_ao_pbe,1))
|
||||||
! correlation beta
|
! correlation beta
|
||||||
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
|
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_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, &
|
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))
|
pot_grad_c_beta_ao_pbe(1,1,istate),size(pot_grad_c_beta_ao_pbe,1))
|
||||||
! exchange alpha
|
! exchange alpha
|
||||||
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
|
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_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, &
|
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))
|
pot_grad_x_alpha_ao_pbe(1,1,istate),size(pot_grad_x_alpha_ao_pbe,1))
|
||||||
! exchange beta
|
! exchange beta
|
||||||
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
|
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_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, &
|
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))
|
pot_grad_x_beta_ao_pbe(1,1,istate),size(pot_grad_x_beta_ao_pbe,1))
|
||||||
enddo
|
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_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_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_d_vxc_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_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
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)
|
! 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
|
END_DOC
|
||||||
integer :: istate,i,j,m
|
integer :: istate,i,j,m
|
||||||
double precision :: r(3)
|
|
||||||
double precision :: mu,weight
|
double precision :: mu,weight
|
||||||
double precision, allocatable :: ex(:), ec(:)
|
double precision :: 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 :: 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, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
|
double precision :: contrib_grad_xa(3),contrib_grad_xb(3),contrib_grad_ca(3),contrib_grad_cb(3)
|
||||||
double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:)
|
double precision :: 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(:)
|
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(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_dvxc_alpha_pbe_w = 0.d0
|
mu = 0.d0
|
||||||
aos_dvxc_beta_pbe_w = 0.d0
|
aos_d_vxc_alpha_pbe_w = 0.d0
|
||||||
|
aos_d_vxc_beta_pbe_w = 0.d0
|
||||||
|
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
do i = 1, n_points_final_grid
|
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)
|
weight = final_weight_at_r_vector(i)
|
||||||
rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
rho_a = 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)
|
rho_b = 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_a(1:3) = 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_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
|
||||||
grad_rho_a_2 = 0.d0
|
grad_rho_a_2 = 0.d0
|
||||||
grad_rho_b_2 = 0.d0
|
grad_rho_b_2 = 0.d0
|
||||||
grad_rho_a_b = 0.d0
|
grad_rho_a_b = 0.d0
|
||||||
do m = 1, 3
|
do m = 1, 3
|
||||||
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
|
grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m)
|
||||||
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
|
grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m)
|
||||||
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
|
grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! inputs
|
! 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
|
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 )
|
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
|
vx_rho_a *= weight
|
||||||
vc_rho_a(istate) *= weight
|
vc_rho_a *= weight
|
||||||
vx_rho_b(istate) *= weight
|
vx_rho_b *= weight
|
||||||
vc_rho_b(istate) *= weight
|
vc_rho_b *= weight
|
||||||
do m= 1,3
|
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_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,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_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,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_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,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_xb(m) = weight * (2.d0 * vx_grad_rho_b_2 * grad_rho_b(m) + vx_grad_rho_a_b * grad_rho_a(m) )
|
||||||
enddo
|
enddo
|
||||||
do j = 1, ao_num
|
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_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(istate) + vx_rho_b(istate) ) * 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
|
enddo
|
||||||
do j = 1, ao_num
|
do j = 1, ao_num
|
||||||
do m = 1,3
|
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_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_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_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
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -403,14 +338,14 @@ END_PROVIDER
|
|||||||
call wall_time(wall_1)
|
call wall_time(wall_1)
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
! exchange - correlation alpha
|
! exchange - correlation alpha
|
||||||
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_scal_xc_alpha_ao_pbe(1,1,istate),size(pot_scal_xc_alpha_ao_pbe,1))
|
||||||
! exchange - correlation beta
|
! exchange - correlation beta
|
||||||
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_scal_xc_beta_ao_pbe(1,1,istate),size(pot_scal_xc_beta_ao_pbe,1))
|
||||||
enddo
|
enddo
|
||||||
call wall_time(wall_2)
|
call wall_time(wall_2)
|
||||||
@ -430,18 +365,19 @@ END_PROVIDER
|
|||||||
pot_grad_xc_alpha_ao_pbe = 0.d0
|
pot_grad_xc_alpha_ao_pbe = 0.d0
|
||||||
pot_grad_xc_beta_ao_pbe = 0.d0
|
pot_grad_xc_beta_ao_pbe = 0.d0
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
! correlation alpha
|
! exchange - correlation alpha
|
||||||
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
|
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_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, &
|
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))
|
pot_grad_xc_alpha_ao_pbe(1,1,istate),size(pot_grad_xc_alpha_ao_pbe,1))
|
||||||
! correlation beta
|
! exchange - correlation beta
|
||||||
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, &
|
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_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, &
|
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))
|
pot_grad_xc_beta_ao_pbe(1,1,istate),size(pot_grad_xc_beta_ao_pbe,1))
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
call wall_time(wall_2)
|
call wall_time(wall_2)
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
@ -19,8 +19,8 @@
|
|||||||
r(2) = final_grid_points(2,i)
|
r(2) = final_grid_points(2,i)
|
||||||
r(3) = final_grid_points(3,i)
|
r(3) = final_grid_points(3,i)
|
||||||
weight = final_weight_at_r_vector(i)
|
weight = final_weight_at_r_vector(i)
|
||||||
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
|
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
||||||
rhob(istate) = one_e_dm_beta_at_r(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)
|
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
|
energy_x_sr_lda(istate) += weight * e_x
|
||||||
enddo
|
enddo
|
||||||
@ -46,8 +46,8 @@
|
|||||||
r(2) = final_grid_points(2,i)
|
r(2) = final_grid_points(2,i)
|
||||||
r(3) = final_grid_points(3,i)
|
r(3) = final_grid_points(3,i)
|
||||||
weight = final_weight_at_r_vector(i)
|
weight = final_weight_at_r_vector(i)
|
||||||
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
|
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
||||||
rhob(istate) = one_e_dm_beta_at_r(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)
|
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
|
energy_c_sr_lda(istate) += weight * e_c
|
||||||
enddo
|
enddo
|
||||||
@ -120,8 +120,8 @@ END_PROVIDER
|
|||||||
r(2) = final_grid_points(2,i)
|
r(2) = final_grid_points(2,i)
|
||||||
r(3) = final_grid_points(3,i)
|
r(3) = final_grid_points(3,i)
|
||||||
weight = final_weight_at_r_vector(i)
|
weight = final_weight_at_r_vector(i)
|
||||||
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
|
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
||||||
rhob(istate) = one_e_dm_beta_at_r(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 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)
|
call ex_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_x,sr_vx_a,sr_vx_b)
|
||||||
do j =1, ao_num
|
do j =1, ao_num
|
||||||
@ -156,8 +156,8 @@ END_PROVIDER
|
|||||||
r(2) = final_grid_points(2,i)
|
r(2) = final_grid_points(2,i)
|
||||||
r(3) = final_grid_points(3,i)
|
r(3) = final_grid_points(3,i)
|
||||||
weight = final_weight_at_r_vector(i)
|
weight = final_weight_at_r_vector(i)
|
||||||
rhoa(istate) = one_e_dm_alpha_at_r(i,istate)
|
rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
||||||
rhob(istate) = one_e_dm_beta_at_r(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 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)
|
call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,sr_vx_a,sr_vx_b)
|
||||||
do j =1, ao_num
|
do j =1, ao_num
|
||||||
|
@ -3,55 +3,95 @@
|
|||||||
&BEGIN_PROVIDER[double precision, energy_c_sr_pbe, (N_states) ]
|
&BEGIN_PROVIDER[double precision, energy_c_sr_pbe, (N_states) ]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
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
|
! exchange/correlation energy with the short range pbe functional
|
||||||
END_DOC
|
END_DOC
|
||||||
integer :: istate,i,j,m
|
integer :: istate,i,j,m
|
||||||
double precision :: r(3)
|
|
||||||
double precision :: mu,weight
|
double precision :: mu,weight
|
||||||
double precision, allocatable :: ex(:), ec(:)
|
double precision :: 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 :: 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, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
|
double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b
|
||||||
double precision, allocatable :: 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
|
||||||
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_x_sr_pbe = 0.d0
|
energy_x_sr_pbe = 0.d0
|
||||||
energy_c_sr_pbe = 0.d0
|
energy_c_sr_pbe = 0.d0
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
do i = 1, n_points_final_grid
|
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)
|
weight = final_weight_at_r_vector(i)
|
||||||
rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
rho_a = 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)
|
rho_b = 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_a(1:3) = 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_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
|
||||||
grad_rho_a_2 = 0.d0
|
grad_rho_a_2 = 0.d0
|
||||||
grad_rho_b_2 = 0.d0
|
grad_rho_b_2 = 0.d0
|
||||||
grad_rho_a_b = 0.d0
|
grad_rho_a_b = 0.d0
|
||||||
do m = 1, 3
|
do m = 1, 3
|
||||||
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
|
grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m)
|
||||||
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
|
grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m)
|
||||||
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
|
grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! inputs
|
! 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
|
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 )
|
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_x_sr_pbe(istate) += ex * weight
|
||||||
energy_c_sr_pbe += ec * weight
|
energy_c_sr_pbe(istate) += ec * weight
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
|
||||||
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 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_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)]
|
&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)]
|
&BEGIN_PROVIDER[double precision, aos_dsr_vx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
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)
|
! 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
|
END_DOC
|
||||||
integer :: istate,i,j,m
|
integer :: istate,i,j,m
|
||||||
double precision :: r(3)
|
|
||||||
double precision :: mu,weight
|
double precision :: mu,weight
|
||||||
double precision, allocatable :: ex(:), ec(:)
|
double precision :: 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 :: 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, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
|
double precision :: contrib_grad_xa(3),contrib_grad_xb(3),contrib_grad_ca(3),contrib_grad_cb(3)
|
||||||
double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:)
|
double precision :: 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(:)
|
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(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_dsr_vc_alpha_pbe_w= 0.d0
|
aos_dsr_vc_alpha_pbe_w= 0.d0
|
||||||
aos_dsr_vc_beta_pbe_w = 0.d0
|
aos_dsr_vc_beta_pbe_w = 0.d0
|
||||||
aos_dsr_vx_alpha_pbe_w= 0.d0
|
aos_dsr_vx_alpha_pbe_w= 0.d0
|
||||||
aos_dsr_vx_beta_pbe_w = 0.d0
|
aos_dsr_vx_beta_pbe_w = 0.d0
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
do i = 1, n_points_final_grid
|
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)
|
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)
|
rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
||||||
grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate)
|
rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate)
|
||||||
grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,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_a_2 = 0.d0
|
||||||
grad_rho_b_2 = 0.d0
|
grad_rho_b_2 = 0.d0
|
||||||
grad_rho_a_b = 0.d0
|
grad_rho_a_b = 0.d0
|
||||||
do m = 1, 3
|
do m = 1, 3
|
||||||
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
|
grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m)
|
||||||
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
|
grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m)
|
||||||
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
|
grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! inputs
|
! 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
|
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 )
|
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
|
vx_rho_a *= weight
|
||||||
vc_rho_a(istate) *= weight
|
vc_rho_a *= weight
|
||||||
vx_rho_b(istate) *= weight
|
vx_rho_b *= weight
|
||||||
vc_rho_b(istate) *= weight
|
vc_rho_b *= weight
|
||||||
do m= 1,3
|
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_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,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_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,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_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,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_xb(m) = weight * (2.d0 * vx_grad_rho_b_2 * grad_rho_b(m) + vx_grad_rho_a_b * grad_rho_a(m) )
|
||||||
enddo
|
enddo
|
||||||
do j = 1, ao_num
|
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_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(istate) * 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(istate) * 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(istate) * 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
|
enddo
|
||||||
do j = 1, ao_num
|
do j = 1, ao_num
|
||||||
do m = 1,3
|
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_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,istate) * 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,istate) * 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,istate) * 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
|
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_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)]
|
&BEGIN_PROVIDER [double precision, pot_sr_scal_c_beta_ao_pbe, (ao_num,ao_num,N_states)]
|
||||||
implicit none
|
implicit none
|
||||||
|
! intermediates to compute the sr_pbe potentials
|
||||||
|
!
|
||||||
integer :: istate
|
integer :: istate
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! intermediate quantity for the calculation of the vxc potentials for the GGA functionals related to the scalar part of the potential
|
! 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)
|
call wall_time(wall_1)
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
! correlation alpha
|
! correlation alpha
|
||||||
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_sr_scal_c_alpha_ao_pbe(1,1,istate),size(pot_sr_scal_c_alpha_ao_pbe,1))
|
||||||
! correlation beta
|
! correlation beta
|
||||||
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_sr_scal_c_beta_ao_pbe(1,1,istate),size(pot_sr_scal_c_beta_ao_pbe,1))
|
||||||
! exchange alpha
|
! exchange alpha
|
||||||
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_sr_scal_x_alpha_ao_pbe(1,1,istate),size(pot_sr_scal_x_alpha_ao_pbe,1))
|
||||||
! exchange beta
|
! exchange beta
|
||||||
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_sr_scal_x_beta_ao_pbe(1,1,istate), size(pot_sr_scal_x_beta_ao_pbe,1))
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
@ -197,52 +231,29 @@ END_PROVIDER
|
|||||||
pot_sr_grad_x_beta_ao_pbe = 0.d0
|
pot_sr_grad_x_beta_ao_pbe = 0.d0
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
! correlation alpha
|
! correlation alpha
|
||||||
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_sr_grad_c_alpha_ao_pbe(1,1,istate),size(pot_sr_grad_c_alpha_ao_pbe,1))
|
||||||
! correlation beta
|
! correlation beta
|
||||||
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_sr_grad_c_beta_ao_pbe(1,1,istate),size(pot_sr_grad_c_beta_ao_pbe,1))
|
||||||
! exchange alpha
|
! exchange alpha
|
||||||
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_sr_grad_x_alpha_ao_pbe(1,1,istate),size(pot_sr_grad_x_alpha_ao_pbe,1))
|
||||||
! exchange beta
|
! exchange beta
|
||||||
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_sr_grad_x_beta_ao_pbe(1,1,istate),size(pot_sr_grad_x_beta_ao_pbe,1))
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
call wall_time(wall_2)
|
call wall_time(wall_2)
|
||||||
|
|
||||||
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
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
@ -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)
|
! 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
|
END_DOC
|
||||||
integer :: istate,i,j,m
|
integer :: istate,i,j,m
|
||||||
double precision :: r(3)
|
|
||||||
double precision :: mu,weight
|
double precision :: mu,weight
|
||||||
double precision, allocatable :: ex(:), ec(:)
|
double precision :: 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 :: 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, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:)
|
double precision :: contrib_grad_xa(3),contrib_grad_xb(3),contrib_grad_ca(3),contrib_grad_cb(3)
|
||||||
double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:)
|
double precision :: 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(:)
|
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(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_dsr_vxc_alpha_pbe_w = 0.d0
|
aos_dsr_vxc_alpha_pbe_w = 0.d0
|
||||||
aos_dsr_vxc_beta_pbe_w = 0.d0
|
aos_dsr_vxc_beta_pbe_w = 0.d0
|
||||||
|
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
do i = 1, n_points_final_grid
|
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)
|
weight = final_weight_at_r_vector(i)
|
||||||
rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate)
|
rho_a = 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)
|
rho_b = 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_a(1:3) = 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_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate)
|
||||||
grad_rho_a_2 = 0.d0
|
grad_rho_a_2 = 0.d0
|
||||||
grad_rho_b_2 = 0.d0
|
grad_rho_b_2 = 0.d0
|
||||||
grad_rho_a_b = 0.d0
|
grad_rho_a_b = 0.d0
|
||||||
do m = 1, 3
|
do m = 1, 3
|
||||||
grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate)
|
grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m)
|
||||||
grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate)
|
grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m)
|
||||||
grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate)
|
grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! inputs
|
! 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
|
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 )
|
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
|
vx_rho_a *= weight
|
||||||
vc_rho_a(istate) *= weight
|
vc_rho_a *= weight
|
||||||
vx_rho_b(istate) *= weight
|
vx_rho_b *= weight
|
||||||
vc_rho_b(istate) *= weight
|
vc_rho_b *= weight
|
||||||
do m= 1,3
|
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_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,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_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,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_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,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_xb(m) = weight * (2.d0 * vx_grad_rho_b_2 * grad_rho_b(m) + vx_grad_rho_a_b * grad_rho_a(m) )
|
||||||
enddo
|
enddo
|
||||||
do j = 1, ao_num
|
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_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(istate) + vx_rho_b(istate) ) * 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
|
enddo
|
||||||
do j = 1, ao_num
|
do j = 1, ao_num
|
||||||
do m = 1,3
|
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_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,istate) + contrib_grad_xb(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) + contrib_grad_xb(m) ) * aos_grad_in_r_array_transp_xyz(m,j,i)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -335,14 +335,14 @@ END_PROVIDER
|
|||||||
call wall_time(wall_1)
|
call wall_time(wall_1)
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
! exchange - correlation alpha
|
! exchange - correlation alpha
|
||||||
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_sr_scal_xc_alpha_ao_pbe(1,1,istate),size(pot_sr_scal_xc_alpha_ao_pbe,1))
|
||||||
! exchange - correlation beta
|
! exchange - correlation beta
|
||||||
call dgemm('N','T',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_sr_scal_xc_beta_ao_pbe(1,1,istate),size(pot_sr_scal_xc_beta_ao_pbe,1))
|
||||||
enddo
|
enddo
|
||||||
call wall_time(wall_2)
|
call wall_time(wall_2)
|
||||||
@ -363,14 +363,14 @@ END_PROVIDER
|
|||||||
pot_sr_grad_xc_beta_ao_pbe = 0.d0
|
pot_sr_grad_xc_beta_ao_pbe = 0.d0
|
||||||
do istate = 1, N_states
|
do istate = 1, N_states
|
||||||
! exchange - correlation alpha
|
! exchange - correlation alpha
|
||||||
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_sr_grad_xc_alpha_ao_pbe(1,1,istate),size(pot_sr_grad_xc_alpha_ao_pbe,1))
|
||||||
! exchange - correlation beta
|
! exchange - correlation beta
|
||||||
call dgemm('N','N',ao_num,ao_num,n_points_final_grid,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_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, &
|
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))
|
pot_sr_grad_xc_beta_ao_pbe(1,1,istate),size(pot_sr_grad_xc_beta_ao_pbe,1))
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
@ -378,20 +378,3 @@ END_PROVIDER
|
|||||||
|
|
||||||
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
|
|
||||||
|
@ -11,7 +11,7 @@ function run() {
|
|||||||
qp edit --check
|
qp edit --check
|
||||||
qp reset --mos
|
qp reset --mos
|
||||||
qp run scf
|
qp run scf
|
||||||
qp set_frozen_core
|
# qp set_frozen_core
|
||||||
energy="$(ezfio get hartree_fock energy)"
|
energy="$(ezfio get hartree_fock energy)"
|
||||||
eq $energy $2 $thresh
|
eq $energy $2 $thresh
|
||||||
}
|
}
|
||||||
|
@ -24,7 +24,6 @@ interface: ezfio,provider,ocaml
|
|||||||
default: None
|
default: None
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
[mo_integrals_pseudo]
|
[mo_integrals_pseudo]
|
||||||
type: double precision
|
type: double precision
|
||||||
doc: Pseudopotential integrals in |MO| basis set
|
doc: Pseudopotential integrals in |MO| basis set
|
||||||
|
48
src/two_body_rdm/EZFIO.cfg
Normal file
48
src/two_body_rdm/EZFIO.cfg
Normal 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
|
||||||
|
|
@ -1 +1,2 @@
|
|||||||
davidson_undressed
|
two_rdm_routines
|
||||||
|
density_for_dft
|
||||||
|
@ -3,6 +3,6 @@ two_body_rdm
|
|||||||
============
|
============
|
||||||
|
|
||||||
Contains the two rdms $\alpha\alpha$, $\beta\beta$ and $\alpha\beta$ stored as
|
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
|
arrays, with pysicists notation, consistent with the two-electron integrals in the MO basis.
|
||||||
MO basis.
|
|
||||||
|
|
||||||
|
@ -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
155
src/two_body_rdm/act_2_rdm.irp.f
Normal 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
|
@ -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
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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
286
src/two_body_rdm/example.irp.f
Normal 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
551
src/two_body_rdm/full_orb_2_rdm.irp.f
Normal 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
|
@ -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
|
|
||||||
|
|
@ -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
127
src/two_body_rdm/state_av_act_2rdm.irp.f
Normal 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
537
src/two_body_rdm/state_av_full_orb_2_rdm.irp.f
Normal 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
8
src/two_body_rdm/test_2_rdm.irp.f
Normal 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
|
||||||
|
|
@ -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
1
src/two_rdm_routines/NEED
Normal file
@ -0,0 +1 @@
|
|||||||
|
davidson_undressed
|
@ -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
|
use bitmasks
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
@ -13,9 +13,8 @@ subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reve
|
|||||||
END_DOC
|
END_DOC
|
||||||
integer, intent(in) :: N_st,sze
|
integer, intent(in) :: N_st,sze
|
||||||
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
|
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(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
|
integer :: k
|
||||||
double precision, allocatable :: u_t(:,:)
|
double precision, allocatable :: u_t(:,:)
|
||||||
@ -31,8 +30,7 @@ subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reve
|
|||||||
size(u_t, 1), &
|
size(u_t, 1), &
|
||||||
N_det, N_st)
|
N_det, N_st)
|
||||||
|
|
||||||
|
call orb_range_2_rdm_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,1,N_det,0,1)
|
||||||
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)
|
|
||||||
deallocate(u_t)
|
deallocate(u_t)
|
||||||
|
|
||||||
do k=1,N_st
|
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
|
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
|
use bitmasks
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
@ -51,9 +49,8 @@ subroutine orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb
|
|||||||
END_DOC
|
END_DOC
|
||||||
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
|
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(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
|
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)
|
select case (N_int)
|
||||||
case (1)
|
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)
|
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)
|
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)
|
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
|
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 select
|
||||||
end
|
end
|
||||||
|
|
||||||
@ -77,8 +74,9 @@ end
|
|||||||
|
|
||||||
|
|
||||||
BEGIN_TEMPLATE
|
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 bitmasks
|
||||||
|
use omp_lib
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Computes the two rdm for the N_st vectors |u_t>
|
! 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
|
! == 3 :: alpha/beta 2rdm
|
||||||
! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba))
|
! == 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
|
! 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
|
! Default should be 1,N_det,0,1 for istart,iend,ishift,istep
|
||||||
END_DOC
|
END_DOC
|
||||||
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
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) :: 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(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
|
||||||
|
integer(omp_lock_kind) :: lock_2rdm
|
||||||
integer :: i,j,k,l
|
integer :: i,j,k,l
|
||||||
integer :: k_a, k_b, l_a, l_b, m_a, m_b
|
integer :: k_a, k_b, l_a, l_b
|
||||||
integer :: istate
|
integer :: krow, kcol
|
||||||
integer :: krow, kcol, krow_b, kcol_b
|
|
||||||
integer :: lrow, lcol
|
integer :: lrow, lcol
|
||||||
integer :: mrow, mcol
|
|
||||||
integer(bit_kind) :: spindet($N_int)
|
integer(bit_kind) :: spindet($N_int)
|
||||||
integer(bit_kind) :: tmp_det($N_int,2)
|
integer(bit_kind) :: tmp_det($N_int,2)
|
||||||
integer(bit_kind) :: tmp_det2($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 :: singles_b(:)
|
||||||
integer, allocatable :: idx(:), idx0(:)
|
integer, allocatable :: idx(:), idx0(:)
|
||||||
integer :: maxab, n_singles_a, n_singles_b, kcol_prev
|
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
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
integer(bit_kind) :: orb_bitmask($N_int)
|
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.
|
alpha_alpha = .False.
|
||||||
beta_beta = .False.
|
beta_beta = .False.
|
||||||
alpha_beta = .False.
|
alpha_beta = .False.
|
||||||
@ -131,7 +128,7 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
|
|||||||
else if(ispin == 4)then
|
else if(ispin == 4)then
|
||||||
spin_trace = .True.
|
spin_trace = .True.
|
||||||
else
|
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
|
print*,'ispin = ',ispin
|
||||||
stop
|
stop
|
||||||
endif
|
endif
|
||||||
@ -140,42 +137,47 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
|
|||||||
PROVIDE N_int
|
PROVIDE N_int
|
||||||
|
|
||||||
call list_to_bitstring( orb_bitmask, list_orb, norb, 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
|
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
|
||||||
allocate(idx0(maxab))
|
allocate(idx0(maxab))
|
||||||
|
|
||||||
do i=1,maxab
|
do i=1,maxab
|
||||||
idx0(i) = i
|
idx0(i) = i
|
||||||
enddo
|
enddo
|
||||||
|
call omp_init_lock(lock_2rdm)
|
||||||
|
|
||||||
! Prepare the array of all alpha single excitations
|
! Prepare the array of all alpha single excitations
|
||||||
! -------------------------------------------------
|
! -------------------------------------------------
|
||||||
|
|
||||||
PROVIDE N_int nthreads_davidson
|
PROVIDE N_int nthreads_davidson elec_alpha_num
|
||||||
!!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
|
!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
|
||||||
! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, &
|
!$OMP SHARED(psi_bilinear_matrix_rows, N_det,lock_2rdm,&
|
||||||
! !$OMP psi_bilinear_matrix_columns, &
|
!$OMP psi_bilinear_matrix_columns, &
|
||||||
! !$OMP psi_det_alpha_unique, psi_det_beta_unique,&
|
!$OMP psi_det_alpha_unique, psi_det_beta_unique,&
|
||||||
! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
|
!$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
|
||||||
! !$OMP psi_bilinear_matrix_transp_rows, &
|
!$OMP psi_bilinear_matrix_transp_rows, &
|
||||||
! !$OMP psi_bilinear_matrix_transp_columns, &
|
!$OMP psi_bilinear_matrix_transp_columns, &
|
||||||
! !$OMP psi_bilinear_matrix_transp_order, N_st, &
|
!$OMP psi_bilinear_matrix_transp_order, N_st, &
|
||||||
! !$OMP psi_bilinear_matrix_order_transp_reverse, &
|
!$OMP psi_bilinear_matrix_order_transp_reverse, &
|
||||||
! !$OMP psi_bilinear_matrix_columns_loc, &
|
!$OMP psi_bilinear_matrix_columns_loc, &
|
||||||
! !$OMP psi_bilinear_matrix_transp_rows_loc, &
|
!$OMP psi_bilinear_matrix_transp_rows_loc,elec_alpha_num, &
|
||||||
! !$OMP istart, iend, istep, irp_here, v_t, s_t, &
|
!$OMP istart, iend, istep, irp_here,list_orb_reverse, n_states, dim1, &
|
||||||
! !$OMP ishift, idx0, u_t, maxab) &
|
!$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,&
|
!$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,c_1, &
|
||||||
! !$OMP lcol, lrow, l_a, l_b, &
|
!$OMP lcol, lrow, l_a, l_b, &
|
||||||
! !$OMP buffer, doubles, n_doubles, &
|
!$OMP buffer, doubles, n_doubles, &
|
||||||
! !$OMP tmp_det2, idx, l, kcol_prev, &
|
!$OMP tmp_det2, idx, l, kcol_prev, &
|
||||||
! !$OMP singles_a, n_singles_a, singles_b, &
|
!$OMP singles_a, n_singles_a, singles_b, &
|
||||||
! !$OMP n_singles_b, k8)
|
!$OMP n_singles_b, nkeys, keys, values)
|
||||||
|
|
||||||
! Alpha/Beta double excitations
|
! Alpha/Beta double excitations
|
||||||
! =============================
|
! =============================
|
||||||
|
nkeys = 0
|
||||||
|
allocate( keys(4,sze_buff), values(n_st,sze_buff))
|
||||||
allocate( buffer($N_int,maxab), &
|
allocate( buffer($N_int,maxab), &
|
||||||
singles_a(maxab), &
|
singles_a(maxab), &
|
||||||
singles_b(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 (istart > 0)
|
||||||
ASSERT (istep > 0)
|
ASSERT (istep > 0)
|
||||||
|
|
||||||
!!$OMP DO SCHEDULE(dynamic,64)
|
!$OMP DO SCHEDULE(dynamic,64)
|
||||||
do k_a=istart+ishift,iend,istep
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
krow = psi_bilinear_matrix_rows(k_a)
|
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)
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
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
|
do l= 1, N_states
|
||||||
c_1(l) = u_t(l,l_a)
|
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
|
||||||
c_2(l) = u_t(l,k_a)
|
|
||||||
c_average += c_1(l) * c_2(l) * state_weights(l)
|
|
||||||
enddo
|
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
|
enddo
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
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
|
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)
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
c_average = 0.d0
|
|
||||||
do l= 1, N_states
|
do l= 1, N_states
|
||||||
c_1(l) = u_t(l,l_a)
|
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
|
||||||
c_2(l) = u_t(l,k_a)
|
|
||||||
c_average += c_1(l) * c_2(l) * state_weights(l)
|
|
||||||
enddo
|
enddo
|
||||||
if(alpha_beta.or.spin_trace.or.alpha_alpha)then
|
if(alpha_beta.or.spin_trace.or.alpha_alpha)then
|
||||||
! increment the alpha/beta part for single excitations
|
! 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
|
! 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
|
endif
|
||||||
|
|
||||||
enddo
|
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
|
! 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)
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
ASSERT (lrow <= N_det_alpha_unique)
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
c_average = 0.d0
|
|
||||||
do l= 1, N_states
|
do l= 1, N_states
|
||||||
c_1(l) = u_t(l,l_a)
|
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
|
||||||
c_2(l) = u_t(l,k_a)
|
|
||||||
c_average += c_1(l) * c_2(l) * state_weights(l)
|
|
||||||
enddo
|
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
|
enddo
|
||||||
endif
|
endif
|
||||||
|
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
|
||||||
|
|
||||||
! Single and double beta excitations
|
! 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)
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
|
||||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
c_average = 0.d0
|
|
||||||
do l= 1, N_states
|
do l= 1, N_states
|
||||||
c_1(l) = u_t(l,l_a)
|
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
|
||||||
c_2(l) = u_t(l,k_a)
|
|
||||||
c_average += c_1(l) * c_2(l) * state_weights(l)
|
|
||||||
enddo
|
enddo
|
||||||
if(alpha_beta.or.spin_trace.or.beta_beta)then
|
if(alpha_beta.or.spin_trace.or.beta_beta)then
|
||||||
! increment the alpha/beta part for single excitations
|
! 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
|
! 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
|
endif
|
||||||
enddo
|
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
|
! 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)
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
c_average = 0.d0
|
|
||||||
do l= 1, N_states
|
do l= 1, N_states
|
||||||
c_1(l) = u_t(l,l_a)
|
c_1(l) = u_t(l,l_a) * u_t(l,k_a)
|
||||||
c_2(l) = u_t(l,k_a)
|
|
||||||
c_average += c_1(l) * c_2(l) * state_weights(l)
|
|
||||||
enddo
|
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)
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
endif
|
endif
|
||||||
|
call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
|
||||||
|
|
||||||
! Diagonal contribution
|
! 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, external :: diag_wee_mat_elem, diag_S_mat_elem
|
||||||
|
|
||||||
double precision :: c_1(N_states),c_2(N_states)
|
double precision :: c_1(N_states)
|
||||||
c_average = 0.d0
|
|
||||||
do l = 1, N_states
|
do l = 1, N_states
|
||||||
c_1(l) = u_t(l,k_a)
|
c_1(l) = u_t(l,k_a) * u_t(l,k_a)
|
||||||
c_average += c_1(l) * c_1(l) * state_weights(l)
|
|
||||||
enddo
|
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
|
end do
|
||||||
!!$OMP END DO
|
!$OMP END DO
|
||||||
deallocate(buffer, singles_a, singles_b, doubles, idx)
|
deallocate(buffer, singles_a, singles_b, doubles, idx, keys, values)
|
||||||
!!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
@ -497,3 +536,35 @@ end
|
|||||||
|
|
||||||
END_TEMPLATE
|
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
|
||||||
|
|
@ -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
|
use bitmasks
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
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), &
|
size(u_t, 1), &
|
||||||
N_det, N_st)
|
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)
|
deallocate(u_t)
|
||||||
|
|
||||||
do k=1,N_st
|
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
|
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
|
use bitmasks
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
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)
|
select case (N_int)
|
||||||
case (1)
|
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)
|
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)
|
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)
|
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
|
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 select
|
||||||
end
|
end
|
||||||
|
|
||||||
@ -74,7 +74,7 @@ end
|
|||||||
|
|
||||||
|
|
||||||
BEGIN_TEMPLATE
|
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 bitmasks
|
||||||
use omp_lib
|
use omp_lib
|
||||||
implicit none
|
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
|
else if(ispin == 4)then
|
||||||
spin_trace = .True.
|
spin_trace = .True.
|
||||||
else
|
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
|
print*,'ispin = ',ispin
|
||||||
stop
|
stop
|
||||||
endif
|
endif
|
||||||
@ -139,7 +139,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
|
|||||||
PROVIDE N_int
|
PROVIDE N_int
|
||||||
|
|
||||||
call list_to_bitstring( orb_bitmask, list_orb, norb, 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
|
list_orb_reverse = -1000
|
||||||
do i = 1, norb
|
do i = 1, norb
|
||||||
list_orb_reverse(list_orb(i)) = i
|
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
|
nkeys = 0
|
||||||
endif
|
endif
|
||||||
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
|
enddo
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
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)
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
nkeys = 0
|
nkeys = 0
|
||||||
endif
|
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
|
! increment the alpha/alpha part for single excitations
|
||||||
if (nkeys+4 * elec_alpha_num .ge. sze_buff ) then
|
if (nkeys+4 * elec_alpha_num .ge. sze_buff ) then
|
||||||
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
nkeys = 0
|
nkeys = 0
|
||||||
endif
|
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
|
endif
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
|
||||||
! Compute Hij for all alpha doubles
|
! 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)
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
nkeys = 0
|
nkeys = 0
|
||||||
endif
|
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
|
enddo
|
||||||
endif
|
endif
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
|
||||||
|
|
||||||
! Single and double beta excitations
|
! 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)
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
nkeys = 0
|
nkeys = 0
|
||||||
endif
|
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
|
! increment the beta /beta part for single excitations
|
||||||
if (nkeys+4 * elec_alpha_num .ge. sze_buff) then
|
if (nkeys+4 * elec_alpha_num .ge. sze_buff) then
|
||||||
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
nkeys = 0
|
nkeys = 0
|
||||||
endif
|
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
|
endif
|
||||||
enddo
|
enddo
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
|
||||||
! Compute Hij for all beta doubles
|
! 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)
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
nkeys = 0
|
nkeys = 0
|
||||||
endif
|
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)
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
enddo
|
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)
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
nkeys = 0
|
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)
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
nkeys = 0
|
nkeys = 0
|
||||||
|
|
881
src/two_rdm_routines/update_rdm.irp.f
Normal file
881
src/two_rdm_routines/update_rdm.irp.f
Normal 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
|
||||||
|
|
@ -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
|
use bitmasks
|
||||||
BEGIN_DOC
|
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
|
! 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)
|
i2 = occ(j,2)
|
||||||
h1 = list_orb_reverse(i1)
|
h1 = list_orb_reverse(i1)
|
||||||
h2 = list_orb_reverse(i2)
|
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
|
nkeys += 1
|
||||||
values(nkeys) = c_1
|
values(nkeys) = c_1
|
||||||
keys(1,nkeys) = h1
|
keys(1,nkeys) = h1
|
||||||
@ -173,7 +175,7 @@
|
|||||||
end
|
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
|
use bitmasks
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
@ -255,7 +257,7 @@
|
|||||||
endif
|
endif
|
||||||
end
|
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
|
use bitmasks
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
! 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, intent(in) :: ispin,sze_buff
|
||||||
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
integer, intent(in) :: list_orb_reverse(mo_num)
|
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(in) :: c_1
|
||||||
double precision, intent(out) :: values(sze_buff)
|
double precision, intent(out) :: values(sze_buff)
|
||||||
integer , intent(out) :: keys(4,sze_buff)
|
integer , intent(out) :: keys(4,sze_buff)
|
||||||
@ -314,14 +317,14 @@
|
|||||||
if (exc(0,1,1) == 1) then
|
if (exc(0,1,1) == 1) then
|
||||||
! Mono alpha
|
! Mono alpha
|
||||||
h1 = exc(1,1,1)
|
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)
|
h1 = list_orb_reverse(h1)
|
||||||
p1 = exc(1,2,1)
|
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)
|
p1 = list_orb_reverse(p1)
|
||||||
do i = 1, n_occ_ab(2)
|
do i = 1, n_occ_ab(2)
|
||||||
h2 = occ(i,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)
|
h2 = list_orb_reverse(h2)
|
||||||
nkeys += 1
|
nkeys += 1
|
||||||
values(nkeys) = c_1 * phase
|
values(nkeys) = c_1 * phase
|
||||||
@ -333,14 +336,14 @@
|
|||||||
else
|
else
|
||||||
! Mono beta
|
! Mono beta
|
||||||
h1 = exc(1,1,2)
|
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)
|
h1 = list_orb_reverse(h1)
|
||||||
p1 = exc(1,2,2)
|
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)
|
p1 = list_orb_reverse(p1)
|
||||||
do i = 1, n_occ_ab(1)
|
do i = 1, n_occ_ab(1)
|
||||||
h2 = occ(i,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)
|
h2 = list_orb_reverse(h2)
|
||||||
nkeys += 1
|
nkeys += 1
|
||||||
values(nkeys) = c_1 * phase
|
values(nkeys) = c_1 * phase
|
||||||
@ -354,14 +357,14 @@
|
|||||||
if (exc(0,1,1) == 1) then
|
if (exc(0,1,1) == 1) then
|
||||||
! Mono alpha
|
! Mono alpha
|
||||||
h1 = exc(1,1,1)
|
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)
|
h1 = list_orb_reverse(h1)
|
||||||
p1 = exc(1,2,1)
|
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)
|
p1 = list_orb_reverse(p1)
|
||||||
do i = 1, n_occ_ab(2)
|
do i = 1, n_occ_ab(2)
|
||||||
h2 = occ(i,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)
|
h2 = list_orb_reverse(h2)
|
||||||
nkeys += 1
|
nkeys += 1
|
||||||
values(nkeys) = 0.5d0 * c_1 * phase
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
@ -379,19 +382,15 @@
|
|||||||
else
|
else
|
||||||
! Mono beta
|
! Mono beta
|
||||||
h1 = exc(1,1,2)
|
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)
|
h1 = list_orb_reverse(h1)
|
||||||
p1 = exc(1,2,2)
|
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)
|
p1 = list_orb_reverse(p1)
|
||||||
!print*,'****************'
|
|
||||||
!print*,'****************'
|
|
||||||
!print*,'h1,p1',h1,p1
|
|
||||||
do i = 1, n_occ_ab(1)
|
do i = 1, n_occ_ab(1)
|
||||||
h2 = occ(i,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)
|
h2 = list_orb_reverse(h2)
|
||||||
! print*,'h2 = ',h2
|
|
||||||
nkeys += 1
|
nkeys += 1
|
||||||
values(nkeys) = 0.5d0 * c_1 * phase
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
keys(1,nkeys) = h1
|
keys(1,nkeys) = h1
|
||||||
@ -409,7 +408,7 @@
|
|||||||
endif
|
endif
|
||||||
end
|
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
|
BEGIN_DOC
|
||||||
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
! 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, intent(in) :: ispin,sze_buff
|
||||||
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
integer, intent(in) :: list_orb_reverse(mo_num)
|
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(in) :: c_1
|
||||||
double precision, intent(out) :: values(sze_buff)
|
double precision, intent(out) :: values(sze_buff)
|
||||||
integer , intent(out) :: keys(4,sze_buff)
|
integer , intent(out) :: keys(4,sze_buff)
|
||||||
@ -468,14 +468,14 @@
|
|||||||
if (exc(0,1,1) == 1) then
|
if (exc(0,1,1) == 1) then
|
||||||
! Mono alpha
|
! Mono alpha
|
||||||
h1 = exc(1,1,1)
|
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)
|
h1 = list_orb_reverse(h1)
|
||||||
p1 = exc(1,2,1)
|
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)
|
p1 = list_orb_reverse(p1)
|
||||||
do i = 1, n_occ_ab(1)
|
do i = 1, n_occ_ab(1)
|
||||||
h2 = occ(i,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)
|
h2 = list_orb_reverse(h2)
|
||||||
|
|
||||||
nkeys += 1
|
nkeys += 1
|
||||||
@ -512,7 +512,7 @@
|
|||||||
endif
|
endif
|
||||||
end
|
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
|
use bitmasks
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
! 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, intent(in) :: ispin,sze_buff
|
||||||
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
integer, intent(in) :: list_orb_reverse(mo_num)
|
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(in) :: c_1
|
||||||
double precision, intent(out) :: values(sze_buff)
|
double precision, intent(out) :: values(sze_buff)
|
||||||
integer , intent(out) :: keys(4,sze_buff)
|
integer , intent(out) :: keys(4,sze_buff)
|
||||||
@ -573,14 +574,14 @@
|
|||||||
else
|
else
|
||||||
! Mono beta
|
! Mono beta
|
||||||
h1 = exc(1,1,2)
|
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)
|
h1 = list_orb_reverse(h1)
|
||||||
p1 = exc(1,2,2)
|
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)
|
p1 = list_orb_reverse(p1)
|
||||||
do i = 1, n_occ_ab(2)
|
do i = 1, n_occ_ab(2)
|
||||||
h2 = occ(i,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)
|
h2 = list_orb_reverse(h2)
|
||||||
nkeys += 1
|
nkeys += 1
|
||||||
values(nkeys) = 0.5d0 * c_1 * phase
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
@ -615,7 +616,7 @@
|
|||||||
end
|
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
|
use bitmasks
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
@ -710,7 +711,7 @@
|
|||||||
endif
|
endif
|
||||||
end
|
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
|
use bitmasks
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
Loading…
Reference in New Issue
Block a user