LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-09 05:03:29 +01:00
Code Releases Activity
f5ecf72f5c
qp2/src/determinants/slater_rules.irp.f

2260 lines
68 KiB
Fortran
Raw Normal View History

Initial commit
2019-01-25 11:39:31 +01:00
subroutine get_excitation_degree(key1,key2,degree,Nint)
use bitmasks
include 'utils/constants.include.F'
implicit none
BEGIN_DOC
! Returns the excitation degree between two determinants.
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key1(Nint*2)
integer(bit_kind), intent(in) :: key2(Nint*2)
integer, intent(out) :: degree
integer(bit_kind) :: xorvec(2*N_int_max)
integer :: l
ASSERT (Nint > 0)
select case (Nint)
case (1)
xorvec(1) = xor( key1(1), key2(1))
xorvec(2) = xor( key1(2), key2(2))
degree = popcnt(xorvec(1))+popcnt(xorvec(2))
case (2)
xorvec(1) = xor( key1(1), key2(1))
xorvec(2) = xor( key1(2), key2(2))
xorvec(3) = xor( key1(3), key2(3))
xorvec(4) = xor( key1(4), key2(4))
degree = sum(popcnt(xorvec(1:4)))
case (3)
do l=1,6
xorvec(l) = xor( key1(l), key2(l))
enddo
degree = sum(popcnt(xorvec(1:6)))
case (4)
do l=1,8
xorvec(l) = xor( key1(l), key2(l))
enddo
degree = sum(popcnt(xorvec(1:8)))
case default
integer :: lmax
lmax = shiftl(Nint,1)
do l=1,lmax
xorvec(l) = xor( key1(l), key2(l))
enddo
degree = sum(popcnt(xorvec(1:lmax)))
end select
degree = shiftr(degree,1)
end
subroutine get_excitation(det1,det2,exc,degree,phase,Nint)
use bitmasks
implicit none
BEGIN_DOC
! Returns the excitation operators between two determinants and the phase.
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: det1(Nint,2)
integer(bit_kind), intent(in) :: det2(Nint,2)
integer, intent(out) :: exc(0:2,2,2)
integer, intent(out) :: degree
double precision, intent(out) :: phase
! exc(number,hole/particle,spin)
! ex :
! exc(0,1,1) = number of holes alpha
! exc(0,2,1) = number of particle alpha
! exc(0,2,2) = number of particle beta
! exc(1,2,1) = first particle alpha
! exc(1,1,1) = first hole alpha
! exc(1,2,2) = first particle beta
! exc(1,1,2) = first hole beta
ASSERT (Nint > 0)
!DIR$ FORCEINLINE
call get_excitation_degree(det1,det2,degree,Nint)
select case (degree)
case (3:)
degree = -1
return
case (2)
call get_double_excitation(det1,det2,exc,phase,Nint)
return
case (1)
Mono -> Single
2019-02-04 23:51:09 +01:00
call get_single_excitation(det1,det2,exc,phase,Nint)
Initial commit
2019-01-25 11:39:31 +01:00
return
case(0)
return
end select
end
subroutine decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
use bitmasks
implicit none
BEGIN_DOC
! Decodes the exc arrays returned by get_excitation.
! h1,h2 : Holes
! p1,p2 : Particles
! s1,s2 : Spins (1:alpha, 2:beta)
! degree : Degree of excitation
END_DOC
integer, intent(in) :: exc(0:2,2,2),degree
integer, intent(out) :: h1,h2,p1,p2,s1,s2
ASSERT (degree > 0)
ASSERT (degree < 3)
select case(degree)
case(2)
if (exc(0,1,1) == 2) then
h1 = exc(1,1,1)
h2 = exc(2,1,1)
p1 = exc(1,2,1)
p2 = exc(2,2,1)
s1 = 1
s2 = 1
else if (exc(0,1,2) == 2) then
h1 = exc(1,1,2)
h2 = exc(2,1,2)
p1 = exc(1,2,2)
p2 = exc(2,2,2)
s1 = 2
s2 = 2
else
h1 = exc(1,1,1)
h2 = exc(1,1,2)
p1 = exc(1,2,1)
p2 = exc(1,2,2)
s1 = 1
s2 = 2
endif
case(1)
if (exc(0,1,1) == 1) then
h1 = exc(1,1,1)
h2 = 0
p1 = exc(1,2,1)
p2 = 0
s1 = 1
s2 = 0
else
h1 = exc(1,1,2)
h2 = 0
p1 = exc(1,2,2)
p2 = 0
s1 = 2
s2 = 0
endif
case(0)
h1 = 0
p1 = 0
h2 = 0
p2 = 0
s1 = 0
s2 = 0
end select
end
subroutine get_double_excitation(det1,det2,exc,phase,Nint)
use bitmasks
implicit none
BEGIN_DOC
! Returns the two excitation operators between two doubly excited determinants and the phase.
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: det1(Nint,2)
integer(bit_kind), intent(in) :: det2(Nint,2)
integer, intent(out) :: exc(0:2,2,2)
double precision, intent(out) :: phase
integer :: tz
integer :: l, ispin, idx_hole, idx_particle, ishift
integer :: nperm
integer :: i,j,k,m,n
integer :: high, low
integer :: a,b,c,d
integer(bit_kind) :: hole, particle, tmp
double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /)
ASSERT (Nint > 0)
nperm = 0
exc(0,1,1) = 0
exc(0,2,1) = 0
exc(0,1,2) = 0
exc(0,2,2) = 0
do ispin = 1,2
idx_particle = 0
idx_hole = 0
ishift = 1-bit_kind_size
do l=1,Nint
ishift = ishift + bit_kind_size
if (det1(l,ispin) == det2(l,ispin)) then
cycle
endif
tmp = xor( det1(l,ispin), det2(l,ispin) )
particle = iand(tmp, det2(l,ispin))
hole = iand(tmp, det1(l,ispin))
do while (particle /= 0_bit_kind)
tz = trailz(particle)
idx_particle = idx_particle + 1
exc(0,2,ispin) = exc(0,2,ispin) + 1
exc(idx_particle,2,ispin) = tz+ishift
particle = iand(particle,particle-1_bit_kind)
enddo
if (iand(exc(0,1,ispin),exc(0,2,ispin))==2) then ! exc(0,1,ispin)==2 or exc(0,2,ispin)==2
exit
endif
do while (hole /= 0_bit_kind)
tz = trailz(hole)
idx_hole = idx_hole + 1
exc(0,1,ispin) = exc(0,1,ispin) + 1
exc(idx_hole,1,ispin) = tz+ishift
hole = iand(hole,hole-1_bit_kind)
enddo
if (iand(exc(0,1,ispin),exc(0,2,ispin))==2) then ! exc(0,1,ispin)==2 or exc(0,2,ispin)
exit
endif
enddo
select case (exc(0,1,ispin))
case(0)
cycle
case(1)
high = max(exc(1,1,ispin), exc(1,2,ispin))-1
low = min(exc(1,1,ispin), exc(1,2,ispin))
ASSERT (low >= 0)
ASSERT (high > 0)
k = shiftr(high,bit_kind_shift)+1
j = shiftr(low,bit_kind_shift)+1
m = iand(high,bit_kind_size-1)
n = iand(low,bit_kind_size-1)
if (j==k) then
nperm = nperm + popcnt(iand(det1(j,ispin), &
iand( shiftl(1_bit_kind,m)-1_bit_kind, &
not(shiftl(1_bit_kind,n))+1_bit_kind)) )
else
nperm = nperm + popcnt( &
iand(det1(j,ispin), &
iand(not(0_bit_kind), &
(not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) &
+ popcnt(iand(det1(k,ispin), &
(shiftl(1_bit_kind,m) - 1_bit_kind ) ))
do i=j+1,k-1
nperm = nperm + popcnt(det1(i,ispin))
end do
endif
case (2)
do l=1,2
high = max(exc(l,1,ispin), exc(l,2,ispin))-1
low = min(exc(l,1,ispin), exc(l,2,ispin))
ASSERT (low > 0)
ASSERT (high > 0)
k = shiftr(high,bit_kind_shift)+1
j = shiftr(low,bit_kind_shift)+1
m = iand(high,bit_kind_size-1)
n = iand(low,bit_kind_size-1)
if (j==k) then
nperm = nperm + popcnt(iand(det1(j,ispin), &
iand( shiftl(1_bit_kind,m)-1_bit_kind, &
not(shiftl(1_bit_kind,n))+1_bit_kind)) )
else
nperm = nperm + popcnt( &
iand(det1(j,ispin), &
iand(not(0_bit_kind), &
(not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) &
+ popcnt(iand(det1(k,ispin), &
(shiftl(1_bit_kind,m) - 1_bit_kind ) ))
do i=j+1,k-1
nperm = nperm + popcnt(det1(i,ispin))
end do
endif
enddo
a = min(exc(1,1,ispin), exc(1,2,ispin))
b = max(exc(1,1,ispin), exc(1,2,ispin))
c = min(exc(2,1,ispin), exc(2,2,ispin))
d = max(exc(2,1,ispin), exc(2,2,ispin))
if ((a<c) .and. (c<b) .and. (b<d)) then
nperm = nperm + 1
endif
exit
end select
enddo
phase = phase_dble(iand(nperm,1))
end
subroutine get_phasemask_bit(det1, pm, Nint)
use bitmasks
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: det1(Nint,2)
integer(bit_kind), intent(out) :: pm(Nint,2)
integer(bit_kind) :: tmp
integer :: ispin, i
do ispin=1,2
tmp = 0_8
do i=1,Nint
pm(i,ispin) = xor(det1(i,ispin), shiftl(det1(i,ispin), 1))
pm(i,ispin) = xor(pm(i,ispin), shiftl(pm(i,ispin), 2))
pm(i,ispin) = xor(pm(i,ispin), shiftl(pm(i,ispin), 4))
pm(i,ispin) = xor(pm(i,ispin), shiftl(pm(i,ispin), 8))
pm(i,ispin) = xor(pm(i,ispin), shiftl(pm(i,ispin), 16))
pm(i,ispin) = xor(pm(i,ispin), shiftl(pm(i,ispin), 32))
pm(i,ispin) = xor(pm(i,ispin), tmp)
if(iand(popcnt(det1(i,ispin)), 1) == 1) tmp = not(tmp)
end do
end do
end
Mono -> Single
2019-02-04 23:51:09 +01:00
subroutine get_single_excitation(det1,det2,exc,phase,Nint)
Initial commit
2019-01-25 11:39:31 +01:00
use bitmasks
implicit none
BEGIN_DOC
! Returns the excitation operator between two singly excited determinants and the phase.
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: det1(Nint,2)
integer(bit_kind), intent(in) :: det2(Nint,2)
integer, intent(out) :: exc(0:2,2,2)
double precision, intent(out) :: phase
integer :: tz
integer :: l, ispin, idx_hole, idx_particle, ishift
integer :: nperm
integer :: i,j,k,m,n
integer :: high, low
integer :: a,b,c,d
integer(bit_kind) :: hole, particle, tmp
double precision, parameter :: phase_dble(0:1) = (/ 1.d0, -1.d0 /)
ASSERT (Nint > 0)
nperm = 0
exc(0,1,1) = 0
exc(0,2,1) = 0
exc(0,1,2) = 0
exc(0,2,2) = 0
do ispin = 1,2
ishift = 1-bit_kind_size
do l=1,Nint
ishift = ishift + bit_kind_size
if (det1(l,ispin) == det2(l,ispin)) then
cycle
endif
tmp = xor( det1(l,ispin), det2(l,ispin) )
particle = iand(tmp, det2(l,ispin))
hole = iand(tmp, det1(l,ispin))
if (particle /= 0_bit_kind) then
tz = trailz(particle)
exc(0,2,ispin) = 1
exc(1,2,ispin) = tz+ishift
endif
if (hole /= 0_bit_kind) then
tz = trailz(hole)
exc(0,1,ispin) = 1
exc(1,1,ispin) = tz+ishift
endif
if ( iand(exc(0,1,ispin),exc(0,2,ispin)) /= 1) then ! exc(0,1,ispin)/=1 and exc(0,2,ispin) /= 1
cycle
endif
high = max(exc(1,1,ispin), exc(1,2,ispin))-1
low = min(exc(1,1,ispin), exc(1,2,ispin))
ASSERT (low >= 0)
ASSERT (high > 0)
k = shiftr(high,bit_kind_shift)+1
j = shiftr(low,bit_kind_shift)+1
m = iand(high,bit_kind_size-1)
n = iand(low,bit_kind_size-1)
if (j==k) then
nperm = nperm + popcnt(iand(det1(j,ispin), &
iand( shiftl(1_bit_kind,m)-1_bit_kind, &
not(shiftl(1_bit_kind,n))+1_bit_kind)) )
else
nperm = nperm + popcnt( &
iand(det1(j,ispin), &
iand(not(0_bit_kind), &
(not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) &
+ popcnt(iand(det1(k,ispin), &
(shiftl(1_bit_kind,m) - 1_bit_kind ) ))
do i=j+1,k-1
nperm = nperm + popcnt(det1(i,ispin))
end do
endif
phase = phase_dble(iand(nperm,1))
return
enddo
enddo
end
subroutine bitstring_to_list_ab( string, list, n_elements, Nint)
use bitmasks
implicit none
BEGIN_DOC
! Gives the inidices(+1) of the bits set to 1 in the bit string
! For alpha/beta determinants.
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: string(Nint,2)
integer, intent(out) :: list(Nint*bit_kind_size,2)
integer, intent(out) :: n_elements(2)
integer :: i, j, ishift
integer(bit_kind) :: l
n_elements(1) = 0
n_elements(2) = 0
ishift = 1
do i=1,Nint
l = string(i,1)
do while (l /= 0_bit_kind)
j = trailz(l)
n_elements(1) = n_elements(1)+1
l = ibclr(l,j)
list(n_elements(1),1) = ishift+j
enddo
l = string(i,2)
do while (l /= 0_bit_kind)
j = trailz(l)
n_elements(2) = n_elements(2)+1
l = ibclr(l,j)
list(n_elements(2),2) = ishift+j
enddo
ishift = ishift + bit_kind_size
enddo
end
subroutine i_H_j_s2(key_i,key_j,Nint,hij,s2)
use bitmasks
implicit none
BEGIN_DOC
! Returns $\langle i|H|j \rangle$ and $\langle i|S^2|j \rangle$
! where $i$ and $j$ are determinants.
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hij, s2
integer :: exc(0:2,2,2)
integer :: degree
double precision :: get_two_e_integral
integer :: m,n,p,q
integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem, phase
integer :: n_occ_ab(2)
PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num)
ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num)
ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num)
ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
hij = 0.d0
s2 = 0d0
!DIR$ FORCEINLINE
call get_excitation_degree(key_i,key_j,degree,Nint)
integer :: spin
select case (degree)
case (2)
call get_double_excitation(key_i,key_j,exc,phase,Nint)
Mono -> Single
2019-02-04 23:51:09 +01:00
! Single alpha, single beta
Initial commit
2019-01-25 11:39:31 +01:00
if (exc(0,1,1) == 1) then
if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then
s2 = -phase
endif
if(exc(1,1,1) == exc(1,2,2) )then
hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1))
else if (exc(1,2,1) ==exc(1,1,2))then
hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2))
else
hij = phase*get_two_e_integral( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map)
endif
! Double alpha
else if (exc(0,1,1) == 2) then
hij = phase*(get_two_e_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map) - &
get_two_e_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(2,2,1), &
exc(1,2,1) ,mo_integrals_map) )
! Double beta
else if (exc(0,1,2) == 2) then
hij = phase*(get_two_e_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map) - &
get_two_e_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(2,2,2), &
exc(1,2,2) ,mo_integrals_map) )
endif
case (1)
Mono -> Single
2019-02-04 23:51:09 +01:00
call get_single_excitation(key_i,key_j,exc,phase,Nint)
Initial commit
2019-01-25 11:39:31 +01:00
!DIR$ FORCEINLINE
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
Mono -> Single
2019-02-04 23:51:09 +01:00
! Single alpha
Initial commit
2019-01-25 11:39:31 +01:00
if (exc(0,1,1) == 1) then
m = exc(1,1,1)
p = exc(1,2,1)
spin = 1
Mono -> Single
2019-02-04 23:51:09 +01:00
! Single beta
Initial commit
2019-01-25 11:39:31 +01:00
else
m = exc(1,1,2)
p = exc(1,2,2)
spin = 2
endif
Mono -> Single
2019-02-04 23:51:09 +01:00
call get_single_excitation_from_fock(key_i,key_j,p,m,spin,phase,hij)
Initial commit
2019-01-25 11:39:31 +01:00
case (0)
double precision, external :: diag_S_mat_elem
s2 = diag_S_mat_elem(key_i,Nint)
hij = diag_H_mat_elem(key_i,Nint)
end select
end
subroutine i_H_j(key_i,key_j,Nint,hij)
use bitmasks
implicit none
BEGIN_DOC
! Returns $\langle i|H|j \rangle$ where $i$ and $j$ are determinants.
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hij
integer :: exc(0:2,2,2)
integer :: degree
double precision :: get_two_e_integral
integer :: m,n,p,q
integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem, phase
integer :: n_occ_ab(2)
PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num)
ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num)
ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num)
ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
hij = 0.d0
!DIR$ FORCEINLINE
call get_excitation_degree(key_i,key_j,degree,Nint)
integer :: spin
select case (degree)
case (2)
call get_double_excitation(key_i,key_j,exc,phase,Nint)
if (exc(0,1,1) == 1) then
Mono -> Single
2019-02-04 23:51:09 +01:00
! Single alpha, single beta
Initial commit
2019-01-25 11:39:31 +01:00
if(exc(1,1,1) == exc(1,2,2) )then
hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1))
else if (exc(1,2,1) ==exc(1,1,2))then
hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2))
else
hij = phase*get_two_e_integral( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map)
endif
else if (exc(0,1,1) == 2) then
! Double alpha
hij = phase*(get_two_e_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map) - &
get_two_e_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(2,2,1), &
exc(1,2,1) ,mo_integrals_map) )
else if (exc(0,1,2) == 2) then
! Double beta
hij = phase*(get_two_e_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map) - &
get_two_e_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(2,2,2), &
exc(1,2,2) ,mo_integrals_map) )
endif
case (1)
Mono -> Single
2019-02-04 23:51:09 +01:00
call get_single_excitation(key_i,key_j,exc,phase,Nint)
Initial commit
2019-01-25 11:39:31 +01:00
!DIR$ FORCEINLINE
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
if (exc(0,1,1) == 1) then
Mono -> Single
2019-02-04 23:51:09 +01:00
! Single alpha
Initial commit
2019-01-25 11:39:31 +01:00
m = exc(1,1,1)
p = exc(1,2,1)
spin = 1
else
Mono -> Single
2019-02-04 23:51:09 +01:00
! Single beta
Initial commit
2019-01-25 11:39:31 +01:00
m = exc(1,1,2)
p = exc(1,2,2)
spin = 2
endif
Mono -> Single
2019-02-04 23:51:09 +01:00
call get_single_excitation_from_fock(key_i,key_j,p,m,spin,phase,hij)
Initial commit
2019-01-25 11:39:31 +01:00
case (0)
hij = diag_H_mat_elem(key_i,Nint)
end select
end
subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble,phase)
use bitmasks
implicit none
BEGIN_DOC
! Returns $\langle i|H|j \rangle$ where $i$ and $j$ are determinants.
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hij,hmono,hdouble,phase
integer :: exc(0:2,2,2)
integer :: degree
double precision :: get_two_e_integral
integer :: m,n,p,q
integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem
integer :: n_occ_ab(2)
logical :: has_mipi(Nint*bit_kind_size)
double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size)
PROVIDE mo_two_e_integrals_in_map mo_integrals_map
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num)
ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num)
ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num)
ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
hij = 0.d0
hmono = 0.d0
hdouble = 0.d0
!DIR$ FORCEINLINE
call get_excitation_degree(key_i,key_j,degree,Nint)
select case (degree)
case (2)
call get_double_excitation(key_i,key_j,exc,phase,Nint)
if (exc(0,1,1) == 1) then
Mono -> Single
2019-02-04 23:51:09 +01:00
! Single alpha, single beta
Initial commit
2019-01-25 11:39:31 +01:00
hij = phase*get_two_e_integral( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map)
else if (exc(0,1,1) == 2) then
! Double alpha
hij = phase*(get_two_e_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map) - &
get_two_e_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(2,2,1), &
exc(1,2,1) ,mo_integrals_map) )
else if (exc(0,1,2) == 2) then
! Double beta
hij = phase*(get_two_e_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map) - &
get_two_e_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(2,2,2), &
exc(1,2,2) ,mo_integrals_map) )
endif
case (1)
Mono -> Single
2019-02-04 23:51:09 +01:00
call get_single_excitation(key_i,key_j,exc,phase,Nint)
Initial commit
2019-01-25 11:39:31 +01:00
!DIR$ FORCEINLINE
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
has_mipi = .False.
if (exc(0,1,1) == 1) then
Mono -> Single
2019-02-04 23:51:09 +01:00
! Single alpha
Initial commit
2019-01-25 11:39:31 +01:00
m = exc(1,1,1)
p = exc(1,2,1)
do k = 1, elec_alpha_num
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_two_e_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_two_e_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_beta_num
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_two_e_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_alpha_num
hdouble = hdouble + mipi(occ(k,1)) - miip(occ(k,1))
enddo
do k = 1, elec_beta_num
hdouble = hdouble + mipi(occ(k,2))
enddo
else
Mono -> Single
2019-02-04 23:51:09 +01:00
! Single beta
Initial commit
2019-01-25 11:39:31 +01:00
m = exc(1,1,2)
p = exc(1,2,2)
do k = 1, elec_beta_num
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_two_e_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_two_e_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_alpha_num
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_two_e_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, elec_alpha_num
hdouble = hdouble + mipi(occ(k,1))
enddo
do k = 1, elec_beta_num
hdouble = hdouble + mipi(occ(k,2)) - miip(occ(k,2))
enddo
endif
hmono = mo_one_e_integrals(m,p)
hij = phase*(hdouble + hmono)
case (0)
phase = 1.d0
hij = diag_H_mat_elem(key_i,Nint)
end select
end
subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullList, N_miniList, Nint)
use bitmasks
implicit none
integer, intent(in) :: N_fullList
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList)
integer,intent(out) :: idx_miniList(N_fullList), N_miniList
integer(bit_kind) :: key_mask(Nint, 2)
integer :: ni, k, i, n_a, n_b, e_a, e_b
n_a = popcnt(key_mask(1,1))
n_b = popcnt(key_mask(1,2))
do ni=2,nint
n_a = n_a + popcnt(key_mask(ni,1))
n_b = n_b + popcnt(key_mask(ni,2))
end do
if(n_a == 0) then
N_miniList = N_fullList
do k=1,N_fullList
do ni=1,Nint
miniList(ni,1,k) = fullList(ni,1,k)
miniList(ni,2,k) = fullList(ni,2,k)
enddo
enddo
do i=1,N_fullList
idx_miniList(i) = i
end do
return
end if
N_miniList = 0
integer :: e_ab
e_ab = n_a+n_b
do i=1,N_fullList
e_a = e_ab - popcnt(iand(fullList(1, 1, i), key_mask(1, 1))) &
- popcnt(iand(fullList(1, 2, i), key_mask(1, 2)))
do ni=2,nint
e_a = e_a - popcnt(iand(fullList(ni, 1, i), key_mask(ni, 1))) &
- popcnt(iand(fullList(ni, 2, i), key_mask(ni, 2)))
end do
if(e_a > 2) then
cycle
endif
N_miniList = N_miniList + 1
miniList(1,1,N_miniList) = fullList(1,1,i)
miniList(1,2,N_miniList) = fullList(1,2,i)
do ni=2,Nint
miniList(ni,1,N_miniList) = fullList(ni,1,i)
miniList(ni,2,N_miniList) = fullList(ni,2,i)
enddo
idx_miniList(N_miniList) = i
end do
end subroutine
subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint)
use bitmasks
implicit none
integer, intent(in) :: N_fullList
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList)
integer(bit_kind), allocatable :: subList(:,:,:)
logical,intent(out) :: fullMatch
integer,intent(out) :: N_miniList
integer(bit_kind) :: key_mask(Nint, 2)
integer :: ni, i, k, l, N_subList
allocate (subList(Nint, 2, N_fullList))
fullMatch = .false.
N_miniList = 0
N_subList = 0
l = popcnt(key_mask(1,1)) + popcnt(key_mask(1,2))
do ni = 2,Nint
l = l + popcnt(key_mask(ni,1)) + popcnt(key_mask(ni,2))
end do
if(l == 0) then
N_miniList = N_fullList
do k=1,N_fullList
do ni=1,Nint
miniList(ni,1,k) = fullList(ni,1,k)
miniList(ni,2,k) = fullList(ni,2,k)
enddo
enddo
else
do i=N_fullList,1,-1
k = l
do ni=1,nint
k -= popcnt(iand(key_mask(ni,1), fullList(ni,1,i))) + popcnt(iand(key_mask(ni,2), fullList(ni,2,i)))
end do
if(k == 2) then
N_subList += 1
do ni=1,Nint
subList(ni,1,N_subList) = fullList(ni,1,i)
subList(ni,2,N_subList) = fullList(ni,2,i)
enddo
else if(k == 1) then
N_minilist += 1
do ni=1,Nint
miniList(ni,1,N_minilist) = fullList(ni,1,i)
miniList(ni,2,N_minilist) = fullList(ni,2,i)
enddo
else if(k == 0) then
N_minilist += 1
do ni=1,Nint
miniList(ni,1,N_minilist) = fullList(ni,1,i)
miniList(ni,2,N_minilist) = fullList(ni,2,i)
enddo
! fullMatch = .true.
! return
end if
end do
end if
if(N_subList > 0) then
do k=1,N_subList
do ni=1,Nint
miniList(ni,1,N_minilist+k) = sublist(ni,1,k)
miniList(ni,2,N_minilist+k) = sublist(ni,2,k)
enddo
enddo
N_minilist = N_minilist + N_subList
end if
deallocate(sublist)
end subroutine
subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
use bitmasks
implicit none
BEGIN_DOC
! Computes $\langle i|H|Psi \rangle = \sum_J c_J \langle i | H | J \rangle$.
!
! Uses filter_connected_i_H_psi0 to get all the $|J \rangle$ to which $|i \rangle$
! is connected.
! The i_H_psi_minilist is much faster but requires to build the
! minilists.
END_DOC
integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate
integer(bit_kind), intent(in) :: keys(Nint,2,Ndet)
integer(bit_kind), intent(in) :: key(Nint,2)
double precision, intent(in) :: coef(Ndet_max,Nstate)
double precision, intent(out) :: i_H_psi_array(Nstate)
integer :: i, ii,j
double precision :: phase
integer :: exc(0:2,2,2)
double precision :: hij
integer, allocatable :: idx(:)
ASSERT (Nint > 0)