LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-11-18 19:32:20 +01:00
Code Releases Activity

added gradients of mu_mf
Some checks failed
continuous-integration/drone/push Build is failing
Details

Browse Source
This commit is contained in:
eginer 2024-07-24 12:43:20 +02:00
parent a0140b9b0a
commit cb8bef2ecd
2 changed files with 85 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
src/mu_of_r/mu_of_r_mean_field.irp.f
View File

@ -130,3 +130,42 @@ subroutine get_grad_f_mf_ab(r,grad_f_mf_ab, grad_two_bod_dens,f_mf_ab,two_bod_de
grad_f_mf_ab *= 2.D0
grad_two_bod_dens *= 2.d0
end
subroutine mu_of_r_mean_field(r,mu_mf, dm)
implicit none
include 'constants.include.F'
double precision, intent(in) :: r(3)
double precision, intent(out):: mu_mf, dm
double precision :: f_mf_ab,two_bod_dens, dm_a, dm_b
call get_f_mf_ab(r,f_mf_ab,two_bod_dens, dm_a, dm_b)
dm = dm_a + dm_b
if(dabs(two_bod_dens).lt.1.d-10)then
mu_mf = 1.d+10
else
mu_mf = 0.5d0 * sqpi * f_mf_ab/two_bod_dens
endif
end
subroutine grad_mu_of_r_mean_field(r,mu_mf, dm, grad_mu_mf, grad_dm)
implicit none
include 'constants.include.F'
double precision, intent(in) :: r(3)
double precision, intent(out):: grad_mu_mf(3), grad_dm(3)
double precision, intent(out):: mu_mf, dm
double precision :: grad_f_mf_ab(3), grad_two_bod_dens(3),grad_dm_a(3), grad_dm_b(3)
double precision :: f_mf_ab,two_bod_dens, dm_a, dm_b
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)
dm = dm_a + dm_b
grad_dm(1:3) = grad_dm_a(1:3) + grad_dm_b(1:3)
if(dabs(two_bod_dens).lt.1.d-10)then
mu_mf = 1.d+10
grad_mu_mf = 0.d0
else
mu_mf = 0.5d0 * sqpi * f_mf_ab/two_bod_dens
grad_mu_mf(1:3) = 0.5d0 * sqpi * (grad_f_mf_ab(1:3) * two_bod_dens - f_mf_ab * grad_two_bod_dens(1:3))&
/(two_bod_dens*two_bod_dens)
endif
end

47
src/mu_of_r/test_proj_op.irp.f
View File

@ -19,7 +19,8 @@ program projected_operators
! call test_f_ii_ia_aa_valence_ab
! call test
! call test_f_mean_field
call test_grad_f_mean_field
! call test_grad_f_mean_field
call test_grad_mu_mf
end
@ -129,3 +130,47 @@ subroutine test_grad_f_mean_field
print*,accu_grad_dm_b
end
subroutine test_grad_mu_mf
implicit none
integer :: i_point,k
double precision :: weight,r(3),rbis(3)
double precision :: mu_mf, dm,grad_mu_mf(3), grad_dm(3)
double precision :: mu_mf_p, mu_mf_m, dm_m, dm_p, num_grad_mu_mf(3),dr, num_grad_dm(3)
double precision :: accu_mu, accu_dm, accu_grad_dm(3), accu_grad_mu_mf(3)
dr = 0.00001d0
accu_grad_mu_mf = 0.d0
accu_mu = 0.d0
accu_grad_dm = 0.d0
accu_dm = 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 grad_mu_of_r_mean_field(r,mu_mf, dm, grad_mu_mf, grad_dm)
call mu_of_r_mean_field(r,mu_mf_p, dm_p)
accu_mu += weight*dabs(mu_mf_p - mu_mf)
accu_dm += weight*dabs(dm_p - dm)
do k = 1, 3
rbis = r
rbis(k) += dr
call mu_of_r_mean_field(rbis,mu_mf_p, dm_p)
rbis = r
rbis(k) -= dr
call mu_of_r_mean_field(rbis,mu_mf_m, dm_m)
num_grad_mu_mf(k) = (mu_mf_p - mu_mf_m)/(2.d0*dr)
num_grad_dm(k) = (dm_p - dm_m)/(2.d0*dr)
enddo
do k = 1, 3
accu_grad_dm(k)+= weight *dabs(num_grad_dm(k) - grad_dm(k))
accu_grad_mu_mf(k)+= weight *dabs(num_grad_mu_mf(k) - grad_mu_mf(k))
enddo
enddo
print*,'accu_mu = ',accu_mu
print*,'accu_dm = ',accu_dm
print*,'accu_grad_dm = '
print*, accu_grad_dm
print*,'accu_grad_mu_mf = '
print*, accu_grad_mu_mf
end