LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2025-01-08 20:33:26 +01:00
Code Issues Releases Wiki Activity

Accelerated (7%) access to integrals in PT2

Browse Source
This commit is contained in:
Anthony Scemama 2016-11-04 19:15:45 +01:00
parent 4aec6f2f00
commit ab7735e3f3
1 changed files with 26 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
plugins/Full_CI_ZMQ/selection.irp.f
View File

@ -6,8 +6,20 @@ double precision function integral8(i,j,k,l)
integer, intent(in) :: i,j,k,l integer, intent(in) :: i,j,k,l
double precision, external :: get_mo_bielec_integral double precision, external :: get_mo_bielec_integral
integer :: ii
integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) ii = l-mo_integrals_cache_min
ii = ior(ii, k-mo_integrals_cache_min)
ii = ior(ii, j-mo_integrals_cache_min)
ii = ior(ii, i-mo_integrals_cache_min)
if (iand(ii, -64) /= 0) then
integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
else
ii = l-mo_integrals_cache_min
ii = ior( ishft(ii,6), k-mo_integrals_cache_min)
ii = ior( ishft(ii,6), j-mo_integrals_cache_min)
ii = ior( ishft(ii,6), i-mo_integrals_cache_min)
integral8 = mo_integrals_cache(ii)
endif
end function end function
@ -179,7 +191,7 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0,
logical :: ok logical :: ok
integer :: s1, s2, p1, p2, ib, istate integer :: s1, s2, p1, p2, ib, istate
integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) integer(bit_kind) :: mask(N_int, 2), det(N_int, 2)
double precision :: e_pert, delta_E, val, Hii, max_e_pert double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp
double precision, external :: diag_H_mat_elem_fock double precision, external :: diag_H_mat_elem_fock
@ -195,13 +207,13 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0,
max_e_pert = 0d0 max_e_pert = 0d0
do istate=1,N_states do istate=1,N_states
val = vect(istate, p1) val = vect(istate, p1) + vect(istate, p1)
delta_E = E0(istate) - Hii delta_E = E0(istate) - Hii
tmp = dsqrt(delta_E * delta_E + val * val)
if (delta_E < 0.d0) then if (delta_E < 0.d0) then
e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) tmp = -tmp
else
e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E)
endif endif
e_pert = 0.5d0 * ( tmp - delta_E)
pt2(istate) += e_pert pt2(istate) += e_pert
if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert
end do end do
@ -632,7 +644,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
logical :: ok logical :: ok
integer :: s1, s2, p1, p2, ib, j, istate integer :: s1, s2, p1, p2, ib, j, istate
integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) integer(bit_kind) :: mask(N_int, 2), det(N_int, 2)
double precision :: e_pert, delta_E, val, Hii, max_e_pert double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp
double precision, external :: diag_H_mat_elem_fock double precision, external :: diag_H_mat_elem_fock
logical, external :: detEq logical, external :: detEq
@ -664,14 +676,14 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
do istate=1,N_states do istate=1,N_states
delta_E = E0(istate) - Hii delta_E = E0(istate) - Hii
val = mat(istate, p1, p2) val = mat(istate, p1, p2) + mat(istate, p1, p2)
tmp = dsqrt(delta_E * delta_E + val * val)
if (delta_E < 0.d0) then if (delta_E < 0.d0) then
e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) tmp = -tmp
else
e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E)
endif endif
pt2(istate) += e_pert e_pert = 0.5d0 * ( tmp - delta_E)
if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert pt2(istate) = pt2(istate) + e_pert
max_e_pert = min(e_pert,max_e_pert)
end do end do
if(dabs(max_e_pert) > buf%mini) then if(dabs(max_e_pert) > buf%mini) then