mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-12-22 04:13:55 +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_ia_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
|
||||
|
||||
|
||||
@ -35,3 +37,95 @@ subroutine test
|
||||
print*,'accu = ',accu
|
||||
|
||||
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