mirror of
https://github.com/LCPQ/quantum_package
synced 2025-01-03 10:05:57 +01:00
Working on Slater dressing
This commit is contained in:
parent
9242ca4584
commit
4cb4d5e416
@ -13,7 +13,7 @@
|
|||||||
FC : gfortran -g -ffree-line-length-none -I .
|
FC : gfortran -g -ffree-line-length-none -I .
|
||||||
LAPACK_LIB : -llapack -lblas
|
LAPACK_LIB : -llapack -lblas
|
||||||
IRPF90 : irpf90
|
IRPF90 : irpf90
|
||||||
IRPF90_FLAGS : --ninja --align=32
|
IRPF90_FLAGS : --ninja --align=32 --assert
|
||||||
|
|
||||||
# Global options
|
# Global options
|
||||||
################
|
################
|
||||||
|
|||||||
@ -216,8 +216,25 @@ END_DOC
|
|||||||
double precision, allocatable :: AF(:,:)
|
double precision, allocatable :: AF(:,:)
|
||||||
allocate (AF(dim_DIIS+1,dim_DIIS+1))
|
allocate (AF(dim_DIIS+1,dim_DIIS+1))
|
||||||
double precision :: rcond, ferr, berr
|
double precision :: rcond, ferr, berr
|
||||||
integer :: iwork(dim_DIIS+1)
|
integer :: iwork(dim_DIIS+1), lwork
|
||||||
|
|
||||||
|
call dsysvx('N','U',dim_DIIS+1,1, &
|
||||||
|
B_matrix_DIIS,size(B_matrix_DIIS,1), &
|
||||||
|
AF, size(AF,1), &
|
||||||
|
ipiv, &
|
||||||
|
C_vector_DIIS,size(C_vector_DIIS,1), &
|
||||||
|
X_vector_DIIS,size(X_vector_DIIS,1), &
|
||||||
|
rcond, &
|
||||||
|
ferr, &
|
||||||
|
berr, &
|
||||||
|
scratch,-1, &
|
||||||
|
iwork, &
|
||||||
|
info &
|
||||||
|
)
|
||||||
|
lwork = int(scratch(1,1))
|
||||||
|
deallocate(scratch)
|
||||||
|
allocate(scratch(lwork,1))
|
||||||
|
|
||||||
call dsysvx('N','U',dim_DIIS+1,1, &
|
call dsysvx('N','U',dim_DIIS+1,1, &
|
||||||
B_matrix_DIIS,size(B_matrix_DIIS,1), &
|
B_matrix_DIIS,size(B_matrix_DIIS,1), &
|
||||||
AF, size(AF,1), &
|
AF, size(AF,1), &
|
||||||
|
|||||||
@ -1,115 +1,129 @@
|
|||||||
BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (mo_tot_num) ]
|
BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ]
|
||||||
&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ]
|
&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Diagonal Fock matrix in the MO basis
|
! Diagonal Fock matrix in the MO basis
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
integer :: i,j, m
|
integer :: i,j
|
||||||
integer :: liwork, lwork, n, info
|
integer :: liwork, lwork, n, info
|
||||||
integer, allocatable :: iwork(:), isuppz(:)
|
integer, allocatable :: iwork(:)
|
||||||
double precision, allocatable :: work(:), F(:,:), F2(:,:)
|
double precision, allocatable :: work(:), F(:,:), S(:,:)
|
||||||
integer :: iorb,jorb
|
|
||||||
|
|
||||||
|
|
||||||
allocate( F(mo_tot_num,mo_tot_num),F2(mo_tot_num,mo_tot_num), isuppz(2*mo_tot_num) )
|
allocate( F(mo_tot_num,mo_tot_num) )
|
||||||
do j=1,mo_tot_num
|
do j=1,mo_tot_num
|
||||||
do i=1,mo_tot_num
|
do i=1,mo_tot_num
|
||||||
F(i,j) = Fock_matrix_mo(i,j)
|
F(i,j) = Fock_matrix_mo(i,j)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
if(no_oa_or_av_opt)then
|
if(no_oa_or_av_opt)then
|
||||||
|
integer :: iorb,jorb
|
||||||
do i = 1, n_act_orb
|
do i = 1, n_act_orb
|
||||||
iorb = list_act(i)
|
iorb = list_act(i)
|
||||||
ASSERT (iorb > 0)
|
|
||||||
ASSERT (iorb <= mo_tot_num)
|
|
||||||
do j = 1, n_inact_orb
|
do j = 1, n_inact_orb
|
||||||
jorb = list_inact(j)
|
jorb = list_inact(j)
|
||||||
ASSERT (jorb > 0)
|
|
||||||
ASSERT (jorb <= mo_tot_num)
|
|
||||||
F(iorb,jorb) = 0.d0
|
F(iorb,jorb) = 0.d0
|
||||||
F(jorb,iorb) = 0.d0
|
F(jorb,iorb) = 0.d0
|
||||||
enddo
|
enddo
|
||||||
do j = 1, n_virt_orb
|
do j = 1, n_virt_orb
|
||||||
jorb = list_virt(j)
|
jorb = list_virt(j)
|
||||||
ASSERT (jorb > 0)
|
|
||||||
ASSERT (jorb <= mo_tot_num)
|
|
||||||
F(iorb,jorb) = 0.d0
|
F(iorb,jorb) = 0.d0
|
||||||
F(jorb,iorb) = 0.d0
|
F(jorb,iorb) = 0.d0
|
||||||
enddo
|
enddo
|
||||||
do j = 1, n_core_orb
|
do j = 1, n_core_orb
|
||||||
jorb = list_core(j)
|
jorb = list_core(j)
|
||||||
ASSERT (jorb > 0)
|
|
||||||
ASSERT (jorb <= mo_tot_num)
|
|
||||||
F(iorb,jorb) = 0.d0
|
F(iorb,jorb) = 0.d0
|
||||||
F(jorb,iorb) = 0.d0
|
F(jorb,iorb) = 0.d0
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
! Insert level shift here
|
|
||||||
do i = elec_beta_num+1, elec_alpha_num
|
|
||||||
F(i,i) += 0.5d0*level_shift
|
|
||||||
enddo
|
|
||||||
|
|
||||||
do i = elec_alpha_num+1, mo_tot_num
|
|
||||||
F(i,i) += level_shift
|
|
||||||
enddo
|
|
||||||
|
|
||||||
n = mo_tot_num
|
|
||||||
lwork = 1+6*n + 2*n*n
|
|
||||||
liwork = 10*n
|
|
||||||
|
|
||||||
allocate(work(lwork))
|
|
||||||
allocate(iwork(liwork) )
|
|
||||||
|
|
||||||
call dsyevr('V', 'A', 'U', mo_tot_num, F, size(F,1), &
|
|
||||||
-100.d0, 100.d0, 1, mo_tot_num, 0.d0, &
|
|
||||||
m, diagonal_Fock_matrix_mo, &
|
|
||||||
F2, size(F2,1), &
|
|
||||||
isuppz, work, lwork, iwork, liwork, info)
|
|
||||||
|
|
||||||
if (info /= 0) then
|
|
||||||
print *, irp_here//' DSYEV failed : ', info
|
|
||||||
stop 1
|
|
||||||
endif
|
|
||||||
|
|
||||||
call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, &
|
|
||||||
mo_coef, size(mo_coef,1), F2, size(F2,1), &
|
|
||||||
0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1))
|
|
||||||
deallocate(work, F2, F)
|
|
||||||
deallocate(iwork, isuppz)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
END_PROVIDER
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)]
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! diagonal element of the fock matrix calculated as the sum over all the interactions
|
! Insert level shift here
|
||||||
! with all the electrons in the RHF determinant
|
do i = elec_beta_num+1, elec_alpha_num
|
||||||
! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij
|
F(i,i) += 0.5d0*level_shift
|
||||||
END_DOC
|
enddo
|
||||||
integer :: i,j
|
|
||||||
double precision :: accu
|
do i = elec_alpha_num+1, mo_tot_num
|
||||||
do j = 1,elec_alpha_num
|
F(i,i) += level_shift
|
||||||
accu = 0.d0
|
enddo
|
||||||
do i = 1, elec_alpha_num
|
|
||||||
accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
|
n = mo_tot_num
|
||||||
enddo
|
lwork = 1+6*n + 2*n*n
|
||||||
diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
|
liwork = 3 + 5*n
|
||||||
enddo
|
|
||||||
do j = elec_alpha_num+1,mo_tot_num
|
allocate(work(lwork))
|
||||||
accu = 0.d0
|
allocate(iwork(liwork) )
|
||||||
do i = 1, elec_alpha_num
|
|
||||||
accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
|
lwork = -1
|
||||||
enddo
|
liwork = -1
|
||||||
diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
|
|
||||||
enddo
|
call dsyevd( 'V', 'U', mo_tot_num, F, &
|
||||||
|
size(F,1), diagonal_Fock_matrix_mo, &
|
||||||
|
work, lwork, iwork, liwork, info)
|
||||||
|
|
||||||
|
if (info /= 0) then
|
||||||
|
print *, irp_here//' DSYEVD failed : ', info
|
||||||
|
stop 1
|
||||||
|
endif
|
||||||
|
lwork = int(work(1))
|
||||||
|
liwork = iwork(1)
|
||||||
|
deallocate(iwork)
|
||||||
|
deallocate(work)
|
||||||
|
|
||||||
|
allocate(work(lwork))
|
||||||
|
allocate(iwork(liwork) )
|
||||||
|
call dsyevd( 'V', 'U', mo_tot_num, F, &
|
||||||
|
size(F,1), diagonal_Fock_matrix_mo, &
|
||||||
|
work, lwork, iwork, liwork, info)
|
||||||
|
deallocate(iwork)
|
||||||
|
|
||||||
|
|
||||||
|
if (info /= 0) then
|
||||||
|
call dsyev( 'V', 'L', mo_tot_num, F, &
|
||||||
|
size(F,1), diagonal_Fock_matrix_mo, &
|
||||||
|
work, lwork, info)
|
||||||
|
|
||||||
|
if (info /= 0) then
|
||||||
|
print *, irp_here//' DSYEV failed : ', info
|
||||||
|
stop 1
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
|
||||||
|
call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, &
|
||||||
|
mo_coef, size(mo_coef,1), F, size(F,1), &
|
||||||
|
0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1))
|
||||||
|
deallocate(work, F)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! diagonal element of the fock matrix calculated as the sum over all the interactions
|
||||||
|
! with all the electrons in the RHF determinant
|
||||||
|
! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij
|
||||||
|
END_DOC
|
||||||
|
integer :: i,j
|
||||||
|
double precision :: accu
|
||||||
|
do j = 1,elec_alpha_num
|
||||||
|
accu = 0.d0
|
||||||
|
do i = 1, elec_alpha_num
|
||||||
|
accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
|
||||||
|
enddo
|
||||||
|
diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
|
||||||
|
enddo
|
||||||
|
do j = elec_alpha_num+1,mo_tot_num
|
||||||
|
accu = 0.d0
|
||||||
|
do i = 1, elec_alpha_num
|
||||||
|
accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
|
||||||
|
enddo
|
||||||
|
diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
|
||||||
|
enddo
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|||||||
14
plugins/Hartree_Fock_SlaterDressed/EZFIO.cfg
Normal file
14
plugins/Hartree_Fock_SlaterDressed/EZFIO.cfg
Normal file
@ -0,0 +1,14 @@
|
|||||||
|
[slater_expo_ezfio]
|
||||||
|
type: double precision
|
||||||
|
doc: Exponents of the additional Slater functions
|
||||||
|
size: (nuclei.nucl_num)
|
||||||
|
interface: ezfio, provider
|
||||||
|
|
||||||
|
[slater_coef_ezfio]
|
||||||
|
type: double precision
|
||||||
|
doc: Exponents of the additional Slater functions
|
||||||
|
size: (mo_basis.mo_tot_num,nuclei.nucl_num)
|
||||||
|
interface: ezfio, provider
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -6,21 +6,19 @@ BEGIN_PROVIDER [ double precision, cusp_A, (nucl_num, nucl_num) ]
|
|||||||
|
|
||||||
integer :: mu, A, B
|
integer :: mu, A, B
|
||||||
|
|
||||||
do B=1,nucl_num
|
cusp_A = 0.d0
|
||||||
do A=1,nucl_num
|
do A=1,nucl_num
|
||||||
cusp_A(A,B) = 0.d0
|
cusp_A(A,A) = slater_expo(A)/nucl_charge(A) * slater_value_at_nucl(A,A)
|
||||||
if (A/=B) then
|
do B=1,nucl_num
|
||||||
cusp_A(A,B) -= slater_value_at_nucl(A,B)
|
cusp_A(A,B) -= slater_value_at_nucl(B,A)
|
||||||
endif
|
do mu=1,ao_num
|
||||||
do mu=1,ao_num
|
cusp_A(A,B) += GauSlaOverlap_matrix(mu,B) * ao_value_at_nucl(mu,A)
|
||||||
cusp_A(A,B) += slater_overlap(mu,B) * ao_value_at_nucl(mu,A)
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, cusp_C, (nucl_num, mo_tot_num) ]
|
BEGIN_PROVIDER [ double precision, cusp_B, (nucl_num, mo_tot_num) ]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Equations to solve : A.C = B
|
! Equations to solve : A.C = B
|
||||||
@ -30,20 +28,25 @@ BEGIN_PROVIDER [ double precision, cusp_C, (nucl_num, mo_tot_num) ]
|
|||||||
|
|
||||||
do i=1,mo_tot_num
|
do i=1,mo_tot_num
|
||||||
do A=1,nucl_num
|
do A=1,nucl_num
|
||||||
cusp_C(A,i) = mo_value_at_nucl(i,A)
|
cusp_B(A,i) = mo_value_at_nucl(i,A)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
END_PROVIDER
|
||||||
integer, allocatable :: ipiv(:)
|
|
||||||
allocate ( ipiv(nucl_num) )
|
|
||||||
call dgegv(nucl_num, mo_tot_num, cusp_A, size(cusp_A,1), &
|
BEGIN_PROVIDER [ double precision, cusp_C, (nucl_num, mo_tot_num) ]
|
||||||
ipiv, cusp_C, size(cusp_C,1), info)
|
implicit none
|
||||||
deallocate (ipiv)
|
BEGIN_DOC
|
||||||
|
! Equations to solve : A.C = B
|
||||||
if (info /= 0) then
|
END_DOC
|
||||||
print *, 'Cusp : linear solve failed'
|
|
||||||
stop -1
|
double precision, allocatable :: AF(:,:)
|
||||||
endif
|
integer :: info
|
||||||
|
allocate ( AF(nucl_num,nucl_num) )
|
||||||
|
|
||||||
|
call get_pseudo_inverse(cusp_A,nucl_num,nucl_num,AF,size(AF,1))
|
||||||
|
call dgemm('N','N',nucl_num,mo_tot_num,nucl_num,1.d0, &
|
||||||
|
AF,size(AF,1), cusp_B, size(cusp_B,1), 0.d0, cusp_C, size(cusp_C,1))
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|||||||
69
plugins/Hartree_Fock_SlaterDressed/SCF_dressed.irp.f
Normal file
69
plugins/Hartree_Fock_SlaterDressed/SCF_dressed.irp.f
Normal file
@ -0,0 +1,69 @@
|
|||||||
|
program scf
|
||||||
|
BEGIN_DOC
|
||||||
|
! Produce `Hartree_Fock` MO orbital with Slater cusp dressing
|
||||||
|
! output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ
|
||||||
|
! output: hartree_fock.energy
|
||||||
|
! optional: mo_basis.mo_coef
|
||||||
|
END_DOC
|
||||||
|
call check_mos
|
||||||
|
call debug
|
||||||
|
call run
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine check_mos
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Create a MO guess if no MOs are present in the EZFIO directory
|
||||||
|
END_DOC
|
||||||
|
logical :: exists
|
||||||
|
PROVIDE ezfio_filename
|
||||||
|
call ezfio_has_mo_basis_mo_coef(exists)
|
||||||
|
if (.not.exists) then
|
||||||
|
print *, 'Please run SCF first'
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine debug
|
||||||
|
implicit none
|
||||||
|
integer :: i
|
||||||
|
print *, 'A'
|
||||||
|
do i=1,nucl_num
|
||||||
|
print *, i, cusp_A(1:nucl_num, i)
|
||||||
|
enddo
|
||||||
|
print *, 'B'
|
||||||
|
do i=1,mo_tot_num
|
||||||
|
print *, i, cusp_B(1:nucl_num, i)
|
||||||
|
enddo
|
||||||
|
print *, 'C'
|
||||||
|
do i=1,mo_tot_num
|
||||||
|
print *, i, cusp_C(1:nucl_num, i)
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine run
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Run SCF calculation
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
double precision :: SCF_energy_before,SCF_energy_after,diag_H_mat_elem
|
||||||
|
double precision :: EHF
|
||||||
|
integer :: i_it, i, j, k
|
||||||
|
|
||||||
|
EHF = HF_energy
|
||||||
|
|
||||||
|
mo_label = "CuspDressed"
|
||||||
|
|
||||||
|
call ezfio_set_Hartree_Fock_SlaterDressed_slater_coef_ezfio(cusp_B)
|
||||||
|
! Choose SCF algorithm
|
||||||
|
|
||||||
|
|
||||||
|
! call Roothaan_Hall_SCF
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
@ -58,7 +58,7 @@ BEGIN_PROVIDER [ double precision , slater_value_at_nucl, (nucl_num,nucl_num) ]
|
|||||||
expo = slater_expo(i)*slater_expo(i)*((x*x) + (y*y) + (z*z))
|
expo = slater_expo(i)*slater_expo(i)*((x*x) + (y*y) + (z*z))
|
||||||
if (expo > 160.d0) cycle
|
if (expo > 160.d0) cycle
|
||||||
expo = dsqrt(expo)
|
expo = dsqrt(expo)
|
||||||
slater_value_at_nucl(i,k) = dexp(-expo)
|
slater_value_at_nucl(i,k) = dexp(-expo) * slater_normalization(i)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|||||||
@ -1,15 +1,17 @@
|
|||||||
!*****************************************************************************
|
!*****************************************************************************
|
||||||
subroutine GauSlaOverlap(expGau,cGau,aGau,expSla,cSla)
|
subroutine GauSlaOverlap(expGau,cGau,aGau,expSla,cSla,result)
|
||||||
|
|
||||||
! Compute the overlap integral between a Gaussian function
|
|
||||||
! with arbitrary angular momemtum and a s-type Slater function
|
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Compute the overlap integral between a Gaussian function
|
||||||
|
! with arbitrary angular momemtum and a s-type Slater function
|
||||||
|
END_DOC
|
||||||
|
|
||||||
! Input variables
|
! Input variables
|
||||||
double precision,intent(in) :: expGau,expSla
|
double precision,intent(in) :: expGau,expSla
|
||||||
double precision,intent(in) :: cGau(3),cSla(3)
|
double precision,intent(in) :: cGau(3),cSla(3)
|
||||||
integer,intent(in) :: aGau(3)
|
integer,intent(in) :: aGau(3)
|
||||||
|
double precision,intent(out) :: result
|
||||||
|
|
||||||
! Final value of the integrals
|
! Final value of the integrals
|
||||||
double precision :: ss,ps,ds
|
double precision :: ss,ps,ds
|
||||||
@ -82,13 +84,38 @@ subroutine GauSlaOverlap(expGau,cGau,aGau,expSla,cSla)
|
|||||||
dxzs = AxBx*AzBz*ds
|
dxzs = AxBx*AzBz*ds
|
||||||
dyzs = AyBy*AzBz*ds
|
dyzs = AyBy*AzBz*ds
|
||||||
|
|
||||||
! Print result
|
select case (sum(aGau))
|
||||||
write(*,'(A10,F16.10)') &
|
case (0)
|
||||||
'(s|s) = ',ss
|
result = ss
|
||||||
write(*,'(A10,F16.10,3X,A10,F16.10,3X,A10,F16.10)') &
|
|
||||||
'(px|s) = ',pxs,'(py|s) = ',pys,'(pz|s) = ',pzs
|
case (1)
|
||||||
write(*,'(A10,F16.10,3X,A10,F16.10,3X,A10,F16.10,3X,A10,F16.10,3X,A10,F16.10,3X,A10,F16.10)') &
|
if (aGau(1) == 1) then
|
||||||
'(dx2|s) = ',dxxs,'(dy2|s) = ',dyys,'(dz2|s) = ',dzzs,'(dxy|s) = ',dxys,'(dxz|s) = ',dxzs,'(dyz|s) = ',dyzs
|
result = pxs
|
||||||
|
else if (aGau(2) == 1) then
|
||||||
|
result = pys
|
||||||
|
else if (aGau(3) == 1) then
|
||||||
|
result = pzs
|
||||||
|
endif
|
||||||
|
|
||||||
|
case (2)
|
||||||
|
if (aGau(1) == 2) then
|
||||||
|
result = dxxs
|
||||||
|
else if (aGau(2) == 2) then
|
||||||
|
result = dyys
|
||||||
|
else if (aGau(3) == 2) then
|
||||||
|
result = dzzs
|
||||||
|
else if (aGau(1)+aGau(2) == 2) then
|
||||||
|
result = dxys
|
||||||
|
else if (aGau(1)+aGau(3) == 2) then
|
||||||
|
result = dxzs
|
||||||
|
else if (aGau(2)+aGau(3) == 2) then
|
||||||
|
result = dyzs
|
||||||
|
endif
|
||||||
|
|
||||||
|
case default
|
||||||
|
stop 'GauSlaOverlap not implemented'
|
||||||
|
|
||||||
|
end select
|
||||||
|
|
||||||
end
|
end
|
||||||
!*****************************************************************************
|
!*****************************************************************************
|
||||||
@ -97,11 +124,13 @@ end
|
|||||||
!*****************************************************************************
|
!*****************************************************************************
|
||||||
subroutine GauSlaKinetic(expGau,cGau,aGau,expSla,cSla)
|
subroutine GauSlaKinetic(expGau,cGau,aGau,expSla,cSla)
|
||||||
|
|
||||||
! Compute the kinetic energy integral between a Gaussian function
|
|
||||||
! with arbitrary angular momemtum and a s-type Slater function
|
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Compute the kinetic energy integral between a Gaussian function
|
||||||
|
! with arbitrary angular momemtum and a s-type Slater function
|
||||||
|
END_DOC
|
||||||
|
|
||||||
! Input variables
|
! Input variables
|
||||||
double precision,intent(in) :: expGau,expSla
|
double precision,intent(in) :: expGau,expSla
|
||||||
double precision,intent(in) :: cGau(3),cSla(3)
|
double precision,intent(in) :: cGau(3),cSla(3)
|
||||||
@ -195,11 +224,13 @@ end
|
|||||||
!*****************************************************************************
|
!*****************************************************************************
|
||||||
subroutine GauSlaNuclear(expGau,cGau,aGau,expSla,cSla,ZNuc,cNuc)
|
subroutine GauSlaNuclear(expGau,cGau,aGau,expSla,cSla,ZNuc,cNuc)
|
||||||
|
|
||||||
! Compute the nuclear attraction integral between a Gaussian function
|
|
||||||
! with arbitrary angular momemtum and a s-type Slater function
|
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
! Compute the nuclear attraction integral between a Gaussian function
|
||||||
|
! with arbitrary angular momemtum and a s-type Slater function
|
||||||
|
END_DOC
|
||||||
|
|
||||||
! Input variables
|
! Input variables
|
||||||
double precision,intent(in) :: expGau,expSla
|
double precision,intent(in) :: expGau,expSla
|
||||||
double precision,intent(in) :: cGau(3),cSla(3)
|
double precision,intent(in) :: cGau(3),cSla(3)
|
||||||
@ -242,7 +273,8 @@ subroutine GauSlaNuclear(expGau,cGau,aGau,expSla,cSla,ZNuc,cNuc)
|
|||||||
end
|
end
|
||||||
!*****************************************************************************
|
!*****************************************************************************
|
||||||
double precision function BoysF0(t)
|
double precision function BoysF0(t)
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: t
|
||||||
double precision :: pi
|
double precision :: pi
|
||||||
|
|
||||||
pi = 4d0*atan(1d0)
|
pi = 4d0*atan(1d0)
|
||||||
@ -257,4 +289,35 @@ end
|
|||||||
!*****************************************************************************
|
!*****************************************************************************
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, GauSlaOverlap_matrix, (ao_num, nucl_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! <Gaussian | Slater> overlap matrix
|
||||||
|
END_DOC
|
||||||
|
integer :: i,j,k
|
||||||
|
double precision :: cGau(3)
|
||||||
|
double precision :: cSla(3)
|
||||||
|
double precision :: expSla, res, expGau
|
||||||
|
integer :: aGau(3)
|
||||||
|
|
||||||
|
do k=1,nucl_num
|
||||||
|
cSla(1:3) = nucl_coord_transp(1:3,k)
|
||||||
|
expSla = slater_expo(k)
|
||||||
|
|
||||||
|
do i=1,ao_num
|
||||||
|
cGau(1:3) = nucl_coord_transp(1:3, ao_nucl(i))
|
||||||
|
aGau(1:3) = ao_power(i,1:3)
|
||||||
|
GauSlaOverlap_matrix(i,k) = 0.d0
|
||||||
|
|
||||||
|
do j=1,ao_prim_num(i)
|
||||||
|
expGau = ao_expo_ordered_transp(j,i)
|
||||||
|
call GauSlaOverlap(expGau,cGau,aGau,expSla,cSla,res)
|
||||||
|
GauSlaOverlap_matrix(i,k) += ao_coef_normalized_ordered_transp(j,i) * res
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|||||||
43
plugins/Hartree_Fock_SlaterDressed/slater.irp.f
Normal file
43
plugins/Hartree_Fock_SlaterDressed/slater.irp.f
Normal file
@ -0,0 +1,43 @@
|
|||||||
|
BEGIN_PROVIDER [ double precision, slater_expo, (nucl_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Exponents of the Slater functions
|
||||||
|
END_DOC
|
||||||
|
logical :: exists
|
||||||
|
call ezfio_has_Hartree_Fock_SlaterDressed_slater_expo_ezfio(exists)
|
||||||
|
if (exists) then
|
||||||
|
slater_expo(1:nucl_num) = slater_expo_ezfio(1:nucl_num)
|
||||||
|
else
|
||||||
|
slater_expo(1:nucl_num) = nucl_charge(1:nucl_num)
|
||||||
|
call ezfio_set_Hartree_Fock_SlaterDressed_slater_expo_ezfio(slater_expo)
|
||||||
|
endif
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, slater_coef, (nucl_num,mo_tot_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Exponents of the Slater functions
|
||||||
|
END_DOC
|
||||||
|
logical :: exists
|
||||||
|
slater_coef = 0.d0
|
||||||
|
call ezfio_has_Hartree_Fock_SlaterDressed_slater_coef_ezfio(exists)
|
||||||
|
if (exists) then
|
||||||
|
slater_coef = slater_coef_ezfio
|
||||||
|
else
|
||||||
|
call ezfio_set_Hartree_Fock_SlaterDressed_slater_coef_ezfio(slater_coef)
|
||||||
|
endif
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, slater_normalization, (nucl_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Normalization of Slater functions : sqrt(expo^3/pi)
|
||||||
|
END_DOC
|
||||||
|
integer :: i
|
||||||
|
do i=1,nucl_num
|
||||||
|
slater_normalization(i) = dsqrt( slater_expo(i)**3/dacos(-1.d0) )
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
@ -252,25 +252,28 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen
|
|||||||
else if (perturbative_triples) then
|
else if (perturbative_triples) then
|
||||||
! Linked
|
! Linked
|
||||||
|
|
||||||
call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),tq(1,1,i_alpha),Delta_E_inv)
|
|
||||||
|
|
||||||
hka = hij_cache(idx_alpha(k_sd))
|
hka = hij_cache(idx_alpha(k_sd))
|
||||||
do i_state=1,N_states
|
if (dabs(hka) > 1.d-12) then
|
||||||
ASSERT (Delta_E_inv(i_state) < 0.d0)
|
call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),tq(1,1,i_alpha),Delta_E_inv)
|
||||||
dka(i_state) = hka / Delta_E_inv(i_state)
|
|
||||||
enddo
|
do i_state=1,N_states
|
||||||
|
ASSERT (Delta_E_inv(i_state) < 0.d0)
|
||||||
|
dka(i_state) = hka / Delta_E_inv(i_state)
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
if (perturbative_triples.and. (degree2 == 1) ) then
|
if (perturbative_triples.and. (degree2 == 1) ) then
|
||||||
call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),tq(1,1,i_alpha),Delta_E_inv)
|
|
||||||
call i_h_j(psi_ref(1,1,i_I),tmp_det,Nint,hka)
|
call i_h_j(psi_ref(1,1,i_I),tmp_det,Nint,hka)
|
||||||
hka = hij_cache(idx_alpha(k_sd)) - hka
|
hka = hij_cache(idx_alpha(k_sd)) - hka
|
||||||
|
if (dabs(hka) > 1.d-12) then
|
||||||
do i_state=1,N_states
|
call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),tq(1,1,i_alpha),Delta_E_inv)
|
||||||
ASSERT (Delta_E_inv(i_state) < 0.d0)
|
do i_state=1,N_states
|
||||||
dka(i_state) = hka / Delta_E_inv(i_state)
|
ASSERT (Delta_E_inv(i_state) < 0.d0)
|
||||||
enddo
|
dka(i_state) = hka / Delta_E_inv(i_state)
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user