2009-10-29 18:57:46 +01:00
|
|
|
BEGIN_PROVIDER [ real, density_value_p ]
|
2009-09-11 17:35:23 +02:00
|
|
|
|
|
|
|
BEGIN_DOC
|
2009-10-29 18:57:46 +01:00
|
|
|
! Value of the density_value at the current point
|
2009-09-11 17:35:23 +02:00
|
|
|
END_DOC
|
|
|
|
|
2009-10-29 18:57:46 +01:00
|
|
|
integer :: i
|
|
|
|
density_value_p = density_alpha_value_p + density_beta_value_p
|
|
|
|
|
|
|
|
END_PROVIDER
|
|
|
|
|
|
|
|
|
|
|
|
BEGIN_PROVIDER [ double precision, density_grad_p, (3) ]
|
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Gradient of the density at the current point
|
|
|
|
END_DOC
|
|
|
|
|
2010-04-28 16:07:18 +02:00
|
|
|
density_grad_p(1) = density_alpha_grad_p(1) + density_beta_grad_p(1)
|
|
|
|
density_grad_p(2) = density_alpha_grad_p(2) + density_beta_grad_p(2)
|
|
|
|
density_grad_p(3) = density_alpha_grad_p(3) + density_beta_grad_p(3)
|
2009-10-29 18:57:46 +01:00
|
|
|
|
|
|
|
END_PROVIDER
|
|
|
|
|
|
|
|
|
|
|
|
BEGIN_PROVIDER [ real, density_alpha_value_p ]
|
|
|
|
|
|
|
|
BEGIN_DOC
|
|
|
|
! Value of the alpha density at the current point
|
|
|
|
END_DOC
|
|
|
|
|
|
|
|
integer :: i
|
2010-04-28 16:07:18 +02:00
|
|
|
|
|
|
|
density_alpha_value_p = 0.
|
|
|
|
|
|
|
|
do i=1,mo_closed_num
|
|
|
|
density_alpha_value_p += mo_value_p(i)**2
|
|
|
|
enddo
|
|
|
|
|
|
|
|
! TODO vectorization
|
2010-05-28 18:23:27 +02:00
|
|
|
integer :: k,j,l, ik, il
|
2010-04-28 16:07:18 +02:00
|
|
|
real :: buffer
|
2010-06-04 15:24:54 +02:00
|
|
|
real :: phase
|
2010-06-09 15:10:14 +02:00
|
|
|
integer :: exc(4)
|
2010-05-28 18:23:27 +02:00
|
|
|
PROVIDE det
|
|
|
|
PROVIDE elec_alpha_num
|
2010-04-28 16:07:18 +02:00
|
|
|
do k=1,det_num
|
|
|
|
do l=1,det_num
|
2010-05-28 18:23:27 +02:00
|
|
|
|
2010-06-09 15:10:14 +02:00
|
|
|
exc(1) = abs(det_exc(k,l,1))
|
|
|
|
exc(2) = abs(det_exc(k,l,2))
|
|
|
|
exc(3) = exc(1)+exc(2)
|
|
|
|
exc(4) = exc(1)*exc(2)
|
|
|
|
if (exc(4) /= 0) then
|
|
|
|
exc(4) = exc(4)/abs(exc(4))
|
|
|
|
endif
|
|
|
|
|
|
|
|
phase = dble(exc(4))
|
|
|
|
if (exc(3) == 0) then
|
2010-05-28 18:23:27 +02:00
|
|
|
buffer = 0.
|
|
|
|
do i=1,elec_alpha_num-mo_closed_num
|
|
|
|
buffer += mo_value_p(det(i,k,1))*mo_value_p(det(i,l,1))
|
|
|
|
enddo
|
2010-06-04 15:24:54 +02:00
|
|
|
density_alpha_value_p += phase*det_coef(k)*det_coef(l)*buffer
|
2010-06-09 15:10:14 +02:00
|
|
|
else if ( (exc(3) == 1).and.(exc(1) == 1) ) then
|
2010-05-28 18:23:27 +02:00
|
|
|
call get_single_excitation(k,l,ik,il,1)
|
|
|
|
buffer = mo_value_p(ik)*mo_value_p(il)
|
2010-06-04 15:24:54 +02:00
|
|
|
density_alpha_value_p += phase*det_coef(k)*det_coef(l)*buffer
|
2010-05-28 18:23:27 +02:00
|
|
|
endif
|
|
|
|
|
2010-04-28 16:07:18 +02:00
|
|
|
enddo
|
2009-10-29 18:57:46 +01:00
|
|
|
enddo
|
|
|
|
|
|
|
|
END_PROVIDER
|
|
|
|
|
|
|
|
BEGIN_PROVIDER [ real, density_beta_value_p ]
|
|
|
|
|
|
|
|
BEGIN_DOC
|
|
|
|
! Value of the beta density at the current point
|
|
|
|
END_DOC
|
|
|
|
|
|
|
|
density_beta_value_p = 0.
|
2009-09-11 17:35:23 +02:00
|
|
|
integer :: i
|
2010-04-28 16:07:18 +02:00
|
|
|
do i=1,mo_closed_num
|
|
|
|
density_beta_value_p += mo_value_p(i)**2
|
|
|
|
enddo
|
|
|
|
|
|
|
|
! TODO vectorization
|
2010-05-28 18:23:27 +02:00
|
|
|
integer :: k,j,l, ik, il
|
2010-04-28 16:07:18 +02:00
|
|
|
real :: buffer
|
2010-06-04 15:24:54 +02:00
|
|
|
real :: phase
|
2010-06-09 15:10:14 +02:00
|
|
|
integer :: exc(4)
|
2010-05-28 18:23:27 +02:00
|
|
|
PROVIDE det
|
|
|
|
PROVIDE elec_beta_num
|
2010-04-28 16:07:18 +02:00
|
|
|
do k=1,det_num
|
|
|
|
do l=1,det_num
|
2010-06-09 15:10:14 +02:00
|
|
|
exc(1) = abs(det_exc(k,l,1))
|
|
|
|
exc(2) = abs(det_exc(k,l,2))
|
|
|
|
exc(3) = exc(1)+exc(2)
|
|
|
|
exc(4) = exc(1)*exc(2)
|
|
|
|
if (exc(4) /= 0) then
|
|
|
|
exc(4) = exc(4)/abs(exc(4))
|
|
|
|
endif
|
|
|
|
|
|
|
|
phase = dble(exc(4))
|
|
|
|
if (exc(3) == 0) then
|
2010-05-28 18:23:27 +02:00
|
|
|
buffer = 0.
|
|
|
|
do i=1,elec_beta_num-mo_closed_num
|
|
|
|
buffer += mo_value_p(det(i,k,2))*mo_value_p(det(i,l,2))
|
|
|
|
enddo
|
2010-06-04 15:24:54 +02:00
|
|
|
density_beta_value_p += phase*det_coef(k)*det_coef(l)*buffer
|
2010-06-09 15:10:14 +02:00
|
|
|
else if ( (exc(3) == 1).and.(exc(2) == 1) ) then
|
2010-05-28 18:23:27 +02:00
|
|
|
call get_single_excitation(k,l,ik,il,2)
|
|
|
|
buffer = mo_value_p(ik)*mo_value_p(il)
|
2010-06-04 15:24:54 +02:00
|
|
|
density_beta_value_p += phase*det_coef(k)*det_coef(l)*buffer
|
2010-05-28 18:23:27 +02:00
|
|
|
endif
|
2010-04-28 16:07:18 +02:00
|
|
|
enddo
|
2009-10-29 18:57:46 +01:00
|
|
|
enddo
|
|
|
|
|
|
|
|
END_PROVIDER
|
|
|
|
|
|
|
|
|
|
|
|
BEGIN_PROVIDER [ double precision, density_alpha_grad_p, (3) ]
|
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Gradient of the density at the current point
|
|
|
|
END_DOC
|
|
|
|
|
2010-04-28 16:07:18 +02:00
|
|
|
integer :: i
|
|
|
|
|
|
|
|
density_alpha_grad_p(1) = 0.
|
|
|
|
density_alpha_grad_p(2) = 0.
|
|
|
|
density_alpha_grad_p(3) = 0.
|
2009-10-29 18:57:46 +01:00
|
|
|
|
2010-04-28 16:07:18 +02:00
|
|
|
do i=1,mo_closed_num
|
|
|
|
density_alpha_grad_p(1) += 2.*mo_grad_p(i,1)*mo_value_p(i)
|
|
|
|
density_alpha_grad_p(2) += 2.*mo_grad_p(i,2)*mo_value_p(i)
|
|
|
|
density_alpha_grad_p(3) += 2.*mo_grad_p(i,3)*mo_value_p(i)
|
2009-09-11 17:35:23 +02:00
|
|
|
enddo
|
|
|
|
|
2010-05-28 18:23:27 +02:00
|
|
|
! TODO Faux !! => Regles de Slater
|
2010-04-28 16:07:18 +02:00
|
|
|
integer :: k,j,l
|
|
|
|
real :: buffer(3)
|
2010-05-28 18:23:27 +02:00
|
|
|
if (det_num > 1) then
|
|
|
|
call abrt(irp_here,'Need to implement Slater rules for gradient')
|
|
|
|
endif
|
2010-04-28 16:07:18 +02:00
|
|
|
do k=1,det_num
|
|
|
|
do l=1,det_num
|
|
|
|
buffer(1) = 0.
|
|
|
|
buffer(2) = 0.
|
|
|
|
buffer(3) = 0.
|
|
|
|
do i=1,mo_active_num
|
|
|
|
buffer(1) += mo_grad_p(det(i,k,1),1)*mo_value_p(det(i,l,1)) &
|
|
|
|
+ mo_grad_p(det(i,l,1),1)*mo_value_p(det(i,k,1))
|
|
|
|
buffer(2) += mo_grad_p(det(i,k,1),2)*mo_value_p(det(i,l,1)) &
|
|
|
|
+ mo_grad_p(det(i,l,1),2)*mo_value_p(det(i,k,1))
|
|
|
|
buffer(3) += mo_grad_p(det(i,k,1),3)*mo_value_p(det(i,l,1)) &
|
|
|
|
+ mo_grad_p(det(i,l,1),3)*mo_value_p(det(i,k,1))
|
|
|
|
enddo
|
|
|
|
density_alpha_grad_p(1) += det_coef(k)*det_coef(l)*buffer(1)
|
|
|
|
density_alpha_grad_p(2) += det_coef(k)*det_coef(l)*buffer(2)
|
|
|
|
density_alpha_grad_p(3) += det_coef(k)*det_coef(l)*buffer(3)
|
2009-10-29 18:57:46 +01:00
|
|
|
enddo
|
|
|
|
enddo
|
|
|
|
|
|
|
|
END_PROVIDER
|
|
|
|
|
|
|
|
|
|
|
|
BEGIN_PROVIDER [ double precision, density_beta_grad_p, (3) ]
|
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Gradient of the density at the current point
|
|
|
|
END_DOC
|
|
|
|
|
2010-04-28 16:07:18 +02:00
|
|
|
integer :: i
|
|
|
|
|
|
|
|
density_beta_grad_p(1) = 0.
|
|
|
|
density_beta_grad_p(2) = 0.
|
|
|
|
density_beta_grad_p(3) = 0.
|
2009-10-29 18:57:46 +01:00
|
|
|
|
2010-04-28 16:07:18 +02:00
|
|
|
do i=1,mo_closed_num
|
|
|
|
density_beta_grad_p(1) += 2.*mo_grad_p(i,1)*mo_value_p(i)
|
|
|
|
density_beta_grad_p(2) += 2.*mo_grad_p(i,2)*mo_value_p(i)
|
|
|
|
density_beta_grad_p(3) += 2.*mo_grad_p(i,3)*mo_value_p(i)
|
2009-10-29 18:57:46 +01:00
|
|
|
enddo
|
|
|
|
|
2010-04-28 16:07:18 +02:00
|
|
|
! TODO vectorization
|
2010-05-28 18:23:27 +02:00
|
|
|
if (det_num > 1) then
|
|
|
|
call abrt(irp_here,'Need to implement Slater rules for gradient')
|
|
|
|
endif
|
2010-04-28 16:07:18 +02:00
|
|
|
integer :: k,j,l
|
|
|
|
real :: buffer(3)
|
|
|
|
do k=1,det_num
|
|
|
|
do l=1,det_num
|
|
|
|
buffer(1) = 0.
|
|
|
|
buffer(2) = 0.
|
|
|
|
buffer(3) = 0.
|
|
|
|
do i=1,mo_active_num
|
|
|
|
buffer(1) += mo_grad_p(det(i,k,2),1)*mo_value_p(det(i,l,2)) &
|
|
|
|
+ mo_grad_p(det(i,l,2),1)*mo_value_p(det(i,k,2))
|
|
|
|
buffer(2) += mo_grad_p(det(i,k,2),2)*mo_value_p(det(i,l,2)) &
|
|
|
|
+ mo_grad_p(det(i,l,2),2)*mo_value_p(det(i,k,2))
|
|
|
|
buffer(3) += mo_grad_p(det(i,k,2),3)*mo_value_p(det(i,l,2)) &
|
|
|
|
+ mo_grad_p(det(i,l,2),3)*mo_value_p(det(i,k,2))
|
|
|
|
enddo
|
|
|
|
density_beta_grad_p(1) += det_coef(k)*det_coef(l)*buffer(1)
|
|
|
|
density_beta_grad_p(2) += det_coef(k)*det_coef(l)*buffer(2)
|
|
|
|
density_beta_grad_p(3) += det_coef(k)*det_coef(l)*buffer(3)
|
2009-10-29 18:57:46 +01:00
|
|
|
enddo
|
2009-09-11 17:35:23 +02:00
|
|
|
enddo
|
|
|
|
|
|
|
|
END_PROVIDER
|
|
|
|
|
|
|
|
|
2009-10-29 18:57:46 +01:00
|
|
|
|
|
|
|
|
2009-10-30 10:44:03 +01:00
|
|
|
BEGIN_PROVIDER [ double precision, density_alpha_lapl_p ]
|
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Laplacian of the density at the current point
|
|
|
|
END_DOC
|
|
|
|
|
2010-04-28 16:07:18 +02:00
|
|
|
integer :: i
|
2009-10-30 10:44:03 +01:00
|
|
|
|
|
|
|
density_alpha_lapl_p = 0.
|
|
|
|
|
2010-04-28 16:07:18 +02:00
|
|
|
do i=1,mo_closed_num
|
|
|
|
density_alpha_lapl_p += mo_grad_p(i,1)**2
|
|
|
|
density_alpha_lapl_p += mo_grad_p(i,2)**2
|
|
|
|
density_alpha_lapl_p += mo_grad_p(i,3)**2
|
|
|
|
density_alpha_lapl_p += mo_value_p(i)*mo_lapl_p(i)
|
|
|
|
enddo
|
|
|
|
density_alpha_lapl_p *= 2.
|
|
|
|
|
|
|
|
! TODO vectorization
|
|
|
|
integer :: k,j,l
|
|
|
|
real :: buffer
|
2010-05-28 18:23:27 +02:00
|
|
|
if (det_num > 1) then
|
|
|
|
call abrt(irp_here,'Need to implement Slater rules for gradient')
|
|
|
|
endif
|
2010-04-28 16:07:18 +02:00
|
|
|
do k=1,det_num
|
|
|
|
do l=1,det_num
|
|
|
|
buffer = 0.
|
|
|
|
do i=1,mo_active_num
|
|
|
|
buffer += 2.*(mo_grad_p(det(i,k,1),1)*mo_grad_p(det(i,l,1),1) &
|
|
|
|
+ mo_grad_p(det(i,k,1),2)*mo_grad_p(det(i,l,1),2) &
|
|
|
|
+ mo_grad_p(det(i,k,1),3)*mo_grad_p(det(i,l,1),3))&
|
|
|
|
+ mo_value_p(det(i,k,1))*mo_lapl_p(det(i,l,1)) &
|
|
|
|
+ mo_value_p(det(i,l,1))*mo_lapl_p(det(i,k,1))
|
|
|
|
enddo
|
|
|
|
density_alpha_lapl_p += det_coef(k)*det_coef(l)*buffer
|
2009-10-30 10:44:03 +01:00
|
|
|
enddo
|
|
|
|
enddo
|
|
|
|
|
|
|
|
END_PROVIDER
|
|
|
|
|
|
|
|
|
|
|
|
BEGIN_PROVIDER [ double precision, density_beta_lapl_p ]
|
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Laplacian of the density at the current point
|
|
|
|
END_DOC
|
|
|
|
|
2010-04-28 16:07:18 +02:00
|
|
|
integer :: i
|
2009-10-30 10:44:03 +01:00
|
|
|
|
|
|
|
density_beta_lapl_p = 0.
|
|
|
|
|
2010-04-28 16:07:18 +02:00
|
|
|
do i=1,mo_closed_num
|
|
|
|
density_beta_lapl_p += mo_grad_p(i,1)**2
|
|
|
|
density_beta_lapl_p += mo_grad_p(i,2)**2
|
|
|
|
density_beta_lapl_p += mo_grad_p(i,3)**2
|
|
|
|
density_beta_lapl_p += mo_value_p(i)*mo_lapl_p(i)
|
|
|
|
enddo
|
|
|
|
density_beta_lapl_p *= 2.
|
|
|
|
|
|
|
|
! TODO vectorization
|
2010-05-28 18:23:27 +02:00
|
|
|
if (det_num > 1) then
|
|
|
|
call abrt(irp_here,'Need to implement Slater rules for laplacian')
|
|
|
|
endif
|
2010-04-28 16:07:18 +02:00
|
|
|
integer :: k,j,l
|
|
|
|
real :: buffer
|
|
|
|
do k=1,det_num
|
|
|
|
do l=1,det_num
|
|
|
|
buffer = 0.
|
|
|
|
do i=1,mo_active_num
|
|
|
|
buffer += 2.*(mo_grad_p(det(i,k,2),1)*mo_grad_p(det(i,l,2),1) &
|
|
|
|
+ mo_grad_p(det(i,k,2),2)*mo_grad_p(det(i,l,2),2) &
|
|
|
|
+ mo_grad_p(det(i,k,2),3)*mo_grad_p(det(i,l,2),3))&
|
|
|
|
+ mo_value_p(det(i,k,2))*mo_lapl_p(det(i,l,2)) &
|
|
|
|
+ mo_value_p(det(i,l,2))*mo_lapl_p(det(i,k,2))
|
|
|
|
enddo
|
|
|
|
density_beta_lapl_p += det_coef(k)*det_coef(l)*buffer
|
2009-10-30 10:44:03 +01:00
|
|
|
enddo
|
|
|
|
enddo
|
|
|
|
|
|
|
|
END_PROVIDER
|
|
|
|
|
|
|
|
BEGIN_PROVIDER [ double precision, density_lapl_p ]
|
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Laplacian of the density at the current point
|
|
|
|
END_DOC
|
|
|
|
|
|
|
|
density_lapl_p = density_alpha_lapl_p + density_beta_lapl_p
|
|
|
|
|
|
|
|
END_PROVIDER
|
2009-10-29 18:57:46 +01:00
|
|
|
|