mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-12-22 20:34:58 +01:00
added mu_of_r_mean_field.irp.f
This commit is contained in:
eginer
parent
4af118c4e6
commit
a0140b9b0a
132
src/mu_of_r/mu_of_r_mean_field.irp.f
Normal file
132
src/mu_of_r/mu_of_r_mean_field.irp.f
Normal file
@ -0,0 +1,132 @@
|
|||||||
|
BEGIN_PROVIDER [ double precision, two_e_int_mf, (elec_beta_num,elec_alpha_num,elec_beta_num,elec_alpha_num)]
|
||||||
|
implicit none
|
||||||
|
integer :: i,j,k,l
|
||||||
|
double precision :: get_two_e_integral
|
||||||
|
do i = 1, elec_alpha_num
|
||||||
|
do j = 1, elec_beta_num
|
||||||
|
do k = 1, elec_alpha_num
|
||||||
|
do l = 1, elec_beta_num
|
||||||
|
two_e_int_mf(l,k,j,i) = get_two_e_integral(l,k,j,i,mo_integrals_map)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
subroutine get_f_mf_ab(r,f_mf_ab,two_bod_dens, dm_a, dm_b)
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: r(3)
|
||||||
|
double precision, intent(out):: f_mf_ab,two_bod_dens, dm_a, dm_b
|
||||||
|
double precision, allocatable :: mos_array_r(:),mos_array_a(:), mos_array_b(:)
|
||||||
|
integer :: i,j,k,l
|
||||||
|
allocate(mos_array_r(mo_num), mos_array_a(elec_alpha_num), mos_array_b(elec_alpha_num))
|
||||||
|
call give_all_mos_at_r(r,mos_array_r)
|
||||||
|
do i = 1, elec_alpha_num
|
||||||
|
mos_array_a(i) = mos_array_r(i)
|
||||||
|
enddo
|
||||||
|
do i = 1, elec_beta_num
|
||||||
|
mos_array_b(i) = mos_array_r(i)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
dm_a = 0.d0
|
||||||
|
do i = 1, elec_alpha_num
|
||||||
|
dm_a += mos_array_a(i) * mos_array_a(i)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
dm_b = 0.d0
|
||||||
|
do i = 1, elec_beta_num
|
||||||
|
dm_b += mos_array_b(i) * mos_array_b(i)
|
||||||
|
enddo
|
||||||
|
two_bod_dens = dm_a * dm_b
|
||||||
|
|
||||||
|
f_mf_ab = 0.d0
|
||||||
|
do i = 1, elec_alpha_num
|
||||||
|
do j = 1, elec_beta_num
|
||||||
|
do k = 1, elec_alpha_num
|
||||||
|
do l = 1, elec_beta_num
|
||||||
|
f_mf_ab += two_e_int_mf(l,k,j,i) * mos_array_a(i) * mos_array_a(k) * mos_array_b(j) * mos_array_b(l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
! multiply by two to adapt to the N(N-1) normalization condition of the active two-rdm
|
||||||
|
f_mf_ab *= 2.d0
|
||||||
|
two_bod_dens *= 2.d0
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine get_grad_f_mf_ab(r,grad_f_mf_ab, grad_two_bod_dens,f_mf_ab,two_bod_dens, dm_a, dm_b,grad_dm_a, grad_dm_b)
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: r(3)
|
||||||
|
double precision, intent(out) :: f_mf_ab, two_bod_dens
|
||||||
|
double precision, intent(out) :: grad_two_bod_dens(3), grad_f_mf_ab(3)
|
||||||
|
double precision, intent(out) :: dm_a, dm_b, grad_dm_a(3), grad_dm_b(3)
|
||||||
|
|
||||||
|
double precision, allocatable :: mos_array_r(:), mos_grad_array_r(:,:)
|
||||||
|
double precision, allocatable :: mos_array_a(:), mos_array_b(:)
|
||||||
|
double precision, allocatable :: mos_grad_array_a(:,:), mos_grad_array_b(:,:)
|
||||||
|
double precision :: mo_i, mo_j, mo_k, mo_l
|
||||||
|
double precision :: grad_mo_i(3), grad_mo_j(3), grad_mo_k(3), grad_mo_l(3)
|
||||||
|
|
||||||
|
integer :: i,j,k,l
|
||||||
|
allocate(mos_array_r(mo_num),mos_grad_array_r(3,mo_num))
|
||||||
|
allocate(mos_array_a(elec_alpha_num), mos_array_b(elec_beta_num))
|
||||||
|
allocate(mos_grad_array_a(3,elec_alpha_num), mos_grad_array_b(3,elec_beta_num))
|
||||||
|
call give_all_mos_and_grad_at_r(r,mos_array_r,mos_grad_array_r)
|
||||||
|
do i = 1, elec_alpha_num
|
||||||
|
mos_array_a(i) = mos_array_r(i)
|
||||||
|
mos_grad_array_a(1:3,i) = mos_grad_array_r(1:3,i)
|
||||||
|
enddo
|
||||||
|
do i = 1, elec_beta_num
|
||||||
|
mos_array_b(i) = mos_array_r(i)
|
||||||
|
mos_grad_array_b(1:3,i) = mos_grad_array_r(1:3,i)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! ALPHA DENSITY AND GRADIENT
|
||||||
|
dm_a = 0.d0
|
||||||
|
grad_dm_a = 0.d0
|
||||||
|
do i = 1, elec_alpha_num
|
||||||
|
dm_a += mos_array_a(i) * mos_array_a(i)
|
||||||
|
grad_dm_a(1:3) += 2.d0 * mos_array_a(i) * mos_grad_array_a(1:3,i)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! BETA DENSITY AND GRADIENT
|
||||||
|
dm_b = 0.d0
|
||||||
|
grad_dm_b = 0.d0
|
||||||
|
do i = 1, elec_beta_num
|
||||||
|
dm_b += mos_array_b(i) * mos_array_b(i)
|
||||||
|
grad_dm_b(1:3) += 2.d0 * mos_array_b(i) * mos_grad_array_b(1:3,i)
|
||||||
|
enddo
|
||||||
|
! TWO-BODY DENSITY AND GRADIENT
|
||||||
|
two_bod_dens = dm_a * dm_b
|
||||||
|
grad_two_bod_dens(1:3) = dm_a * grad_dm_b(1:3) + dm_b * grad_dm_a(1:3)
|
||||||
|
|
||||||
|
! F_MF and GRADIENT
|
||||||
|
grad_f_mf_ab = 0.d0
|
||||||
|
f_mf_ab = 0.d0
|
||||||
|
do i = 1, elec_alpha_num
|
||||||
|
mo_i = mos_array_a(i)
|
||||||
|
grad_mo_i(1:3) = mos_grad_array_a(1:3,i)
|
||||||
|
do j = 1, elec_beta_num
|
||||||
|
mo_j = mos_array_b(j)
|
||||||
|
grad_mo_j(1:3) = mos_grad_array_b(1:3,j)
|
||||||
|
do k = 1, elec_alpha_num
|
||||||
|
mo_k = mos_array_a(k)
|
||||||
|
grad_mo_k(1:3) = mos_grad_array_a(1:3,k)
|
||||||
|
do l = 1, elec_beta_num
|
||||||
|
mo_l = mos_array_b(l)
|
||||||
|
grad_mo_l(1:3) = mos_grad_array_b(1:3,l)
|
||||||
|
f_mf_ab += two_e_int_mf(l,k,j,i) * mo_i * mo_j * mo_k * mo_l
|
||||||
|
grad_f_mf_ab(1:3) += two_e_int_mf(l,k,j,i) * &
|
||||||
|
(mo_i * mo_j * mo_k * grad_mo_l(1:3) + mo_i * mo_j * grad_mo_k(1:3) * mo_l &
|
||||||
|
+mo_i * grad_mo_j(1:3) * mo_k * mo_l + grad_mo_i(1:3) * mo_j * mo_k * mo_l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
f_mf_ab *= 2.d0
|
||||||
|
two_bod_dens *= 2.d0
|
||||||
|
grad_f_mf_ab *= 2.D0
|
||||||
|
grad_two_bod_dens *= 2.d0
|
||||||
|
end
|
||||||
@ -17,7 +17,9 @@ program projected_operators
|
|||||||
! call test_f_ii_valence_ab
|
! call test_f_ii_valence_ab
|
||||||
! call test_f_ia_valence_ab
|
! call test_f_ia_valence_ab
|
||||||
! call test_f_ii_ia_aa_valence_ab
|
! call test_f_ii_ia_aa_valence_ab
|
||||||
call test
|
! call test
|
||||||
|
! call test_f_mean_field
|
||||||
|
call test_grad_f_mean_field
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
@ -35,3 +37,95 @@ subroutine test
|
|||||||
print*,'accu = ',accu
|
print*,'accu = ',accu
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
subroutine test_f_mean_field
|
||||||
|
implicit none
|
||||||
|
integer :: i_point
|
||||||
|
double precision :: weight,r(3)
|
||||||
|
double precision :: ref_f, new_f, accu_f
|
||||||
|
double precision :: ref_two_dens, new_two_dens, accu_two_dens, dm_a, dm_b
|
||||||
|
accu_f = 0.d0
|
||||||
|
accu_two_dens = 0.d0
|
||||||
|
do i_point = 1, n_points_final_grid
|
||||||
|
r(1:3) = final_grid_points(1:3,i_point)
|
||||||
|
weight = final_weight_at_r_vector(i_point)
|
||||||
|
call get_f_mf_ab(r,new_f,new_two_dens, dm_a, dm_b)
|
||||||
|
call f_HF_valence_ab(r,r,ref_f,ref_two_dens)
|
||||||
|
accu_f += weight * dabs(new_f- ref_f)
|
||||||
|
accu_two_dens += weight * dabs(new_two_dens - ref_two_dens)
|
||||||
|
enddo
|
||||||
|
print*,'accu_f = ',accu_f
|
||||||
|
print*,'accu_two_dens = ',accu_two_dens
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine test_grad_f_mean_field
|
||||||
|
implicit none
|
||||||
|
integer :: i_point,k
|
||||||
|
double precision :: weight,r(3)
|
||||||
|
double precision :: grad_f_mf_ab(3), grad_two_bod_dens(3)
|
||||||
|
double precision :: grad_dm_a(3), grad_dm_b(3)
|
||||||
|
double precision :: f_mf_ab,two_bod_dens, dm_a, dm_b
|
||||||
|
|
||||||
|
double precision :: num_grad_f_mf_ab(3), num_grad_two_bod_dens(3)
|
||||||
|
double precision :: num_grad_dm_a(3), num_grad_dm_b(3)
|
||||||
|
double precision :: f_mf_ab_p,f_mf_ab_m
|
||||||
|
double precision :: two_bod_dens_p, two_bod_dens_m
|
||||||
|
double precision :: dm_a_p, dm_a_m
|
||||||
|
double precision :: dm_b_p, dm_b_m
|
||||||
|
double precision :: rbis(3), dr
|
||||||
|
double precision :: accu_grad_f_mf_ab(3),accu_grad_two_bod_dens(3)
|
||||||
|
double precision :: accu_grad_dm_a(3),accu_grad_dm_b(3)
|
||||||
|
double precision :: accu_f_mf_ab, accu_two_bod_dens, accu_dm_a, accu_dm_b
|
||||||
|
dr = 0.00001d0
|
||||||
|
accu_f_mf_ab = 0.d0
|
||||||
|
accu_two_bod_dens = 0.d0
|
||||||
|
accu_dm_a = 0.d0
|
||||||
|
accu_dm_b = 0.d0
|
||||||
|
|
||||||
|
accu_grad_f_mf_ab = 0.d0
|
||||||
|
accu_grad_two_bod_dens = 0.d0
|
||||||
|
accu_grad_dm_a = 0.d0
|
||||||
|
accu_grad_dm_b = 0.d0
|
||||||
|
do i_point = 1, n_points_final_grid
|
||||||
|
r(1:3) = final_grid_points(1:3,i_point)
|
||||||
|
weight = final_weight_at_r_vector(i_point)
|
||||||
|
call get_grad_f_mf_ab(r,grad_f_mf_ab, grad_two_bod_dens,f_mf_ab,two_bod_dens, dm_a, dm_b,grad_dm_a, grad_dm_b)
|
||||||
|
call get_f_mf_ab(r,f_mf_ab_p,two_bod_dens_p, dm_a_p, dm_b_p)
|
||||||
|
accu_f_mf_ab += weight * dabs(f_mf_ab - f_mf_ab_p)
|
||||||
|
accu_two_bod_dens += weight * dabs(two_bod_dens - two_bod_dens_p)
|
||||||
|
accu_dm_a += weight*dabs(dm_a - dm_a_p)
|
||||||
|
accu_dm_b += weight*dabs(dm_b - dm_b_p)
|
||||||
|
do k = 1, 3
|
||||||
|
rbis = r
|
||||||
|
rbis(k) += dr
|
||||||
|
call get_f_mf_ab(rbis,f_mf_ab_p,two_bod_dens_p, dm_a_p, dm_b_p)
|
||||||
|
rbis = r
|
||||||
|
rbis(k) -= dr
|
||||||
|
call get_f_mf_ab(rbis,f_mf_ab_m,two_bod_dens_m, dm_a_m, dm_b_m)
|
||||||
|
num_grad_f_mf_ab(k) = (f_mf_ab_p - f_mf_ab_m)/(2.d0*dr)
|
||||||
|
num_grad_two_bod_dens(k) = (two_bod_dens_p - two_bod_dens_m)/(2.d0*dr)
|
||||||
|
num_grad_dm_a(k) = (dm_a_p - dm_a_m)/(2.d0*dr)
|
||||||
|
num_grad_dm_b(k) = (dm_b_p - dm_b_m)/(2.d0*dr)
|
||||||
|
enddo
|
||||||
|
do k = 1, 3
|
||||||
|
accu_grad_f_mf_ab(k) += weight * dabs(grad_f_mf_ab(k) - num_grad_f_mf_ab(k))
|
||||||
|
accu_grad_two_bod_dens(k) += weight * dabs(grad_two_bod_dens(k) - num_grad_two_bod_dens(k))
|
||||||
|
accu_grad_dm_a(k) += weight * dabs(grad_dm_a(k) - num_grad_dm_a(k))
|
||||||
|
accu_grad_dm_b(k) += weight * dabs(grad_dm_b(k) - num_grad_dm_b(k))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*,'accu_f_mf_ab = ',accu_f_mf_ab
|
||||||
|
print*,'accu_two_bod_dens = ',accu_two_bod_dens
|
||||||
|
print*,'accu_dm_a = ',accu_dm_a
|
||||||
|
print*,'accu_dm_b = ',accu_dm_b
|
||||||
|
print*,'accu_grad_f_mf_ab = '
|
||||||
|
print*,accu_grad_f_mf_ab
|
||||||
|
print*,'accu_grad_two_bod_dens = '
|
||||||
|
print*,accu_grad_two_bod_dens
|
||||||
|
print*,'accu_dm_a = '
|
||||||
|
print*,accu_grad_dm_a
|
||||||
|
print*,'accu_dm_b = '
|
||||||
|
print*,accu_grad_dm_b
|
||||||
|
|
||||||
|
end
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user