PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2025-04-05 16:31:40 +02:00
Code Releases Activity

update two_rdm_routines

Browse Source
This commit is contained in:
Anthony Scemama 2025-02-26 14:42:39 +01:00
parent ed1253f629
commit 62c13860ba
4 changed files with 854 additions and 835 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
src/bitmask/bitmasks_routines.irp.f
View File

@ -283,33 +283,16 @@ subroutine print_det_one_dimension(string,Nint)
end
logical function is_integer_in_string(bite,string,Nint)
logical function is_integer_in_string(orb,bitmask,Nint)
use bitmasks
implicit none
integer, intent(in) :: bite,Nint
integer(bit_kind), intent(in) :: string(Nint)
integer(bit_kind) :: string_bite(Nint)
integer :: i,itot,itot_and
character*(2048) :: output(1)
string_bite = 0_bit_kind
call set_bit_to_integer(bite,string_bite,Nint)
itot = 0
itot_and = 0
is_integer_in_string = .False.
!print*,''
!print*,''
!print*,'bite = ',bite
!call bitstring_to_str( output(1), string_bite, Nint )
! print *, trim(output(1))
!call bitstring_to_str( output(1), string, Nint )
! print *, trim(output(1))
do i = 1, Nint
itot += popcnt(string(i))
itot_and += popcnt(ior(string(i),string_bite(i)))
enddo
!print*,'itot,itot_and',itot,itot_and
if(itot == itot_and)then
is_integer_in_string = .True.
endif
!pause
BEGIN_DOC
! Checks is the orbital orb is set to 1 in the bit string
END_DOC
integer, intent(in) :: orb, Nint
integer(bit_kind), intent(in) :: bitmask(Nint)
integer :: j, k
k = ishft(orb-1,-bit_kind_shift)+1
j = orb-ishft(k-1,bit_kind_shift)-1
is_integer_in_string = iand(bitmask(k), ibset(0_bit_kind, j)) /= 0_bit_kind
end

1
src/two_body_rdm/act_2_rdm.irp.f
View File

@ -145,6 +145,7 @@
print*,''
print*,'Providing act_2_rdm_spin_trace_mo '
character*(128) :: name_file
PROVIDE all_mo_integrals
name_file = 'act_2_rdm_spin_trace_mo'
ispin = 4
act_2_rdm_spin_trace_mo = 0.d0

2
src/two_rdm_routines/davidson_like_2rdm.irp.f
View File

@ -194,6 +194,7 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
!$OMP DO SCHEDULE(dynamic)
do k_a=istart+ishift,iend,istep
!print *, 'aa', k_a, '/', iend
krow = psi_bilinear_matrix_rows(k_a)
ASSERT (krow <= N_det_alpha_unique)
@ -282,6 +283,7 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin
!$OMP DO SCHEDULE(dynamic)
do k_a=istart+ishift,iend,istep
!print *, 'ab', k_a, '/', iend
! Single and double alpha exitations

589
src/two_rdm_routines/update_rdm.irp.f
View File

@ -1,4 +1,15 @@
subroutine orb_range_diag_to_all_states_2_rdm_dm_buffer(det_1,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
logical function is_integer_in_string_local(orb,bitmask,Nint)
use bitmasks
implicit none
integer, intent(in) :: orb, Nint
integer(bit_kind), intent(in) :: bitmask(Nint)
integer :: j, k
k = ishft(orb-1,-bit_kind_shift)+1
j = orb-ishft(k-1,bit_kind_shift)-1
is_integer_in_string_local = iand(bitmask(k), ibset(0_bit_kind, j)) /= 0_bit_kind
end
subroutine orb_range_diag_to_all_states_2_rdm_dm_buffer(det_1,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1
@ -22,7 +33,7 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
@ -47,15 +58,16 @@
else if(ispin == 4)then
spin_trace = .True.
endif
call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int)
logical :: is_integer_in_string
logical :: is_integer_in_string_local
integer :: i1,i2,istate
if(alpha_beta)then
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
h1 = list_orb_reverse(i1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
! If alpha/beta, electron 1 is alpha, electron 2 is beta
! Therefore you don't necessayr have symmetry between electron 1 and 2
@ -80,11 +92,12 @@
enddo
else if (alpha_alpha)then
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
h1 = list_orb_reverse(i1)
do j = 1, n_occ_ab(1)
i2 = occ(j,1)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
@ -104,12 +117,14 @@
keys(4,nkeys) = h1
enddo
enddo
else if (beta_beta)then
do i = 1, n_occ_ab(2)
i1 = occ(i,2)
h1 = list_orb_reverse(i1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
@ -129,13 +144,15 @@
keys(4,nkeys) = h1
enddo
enddo
else if(spin_trace)then
! 0.5 * (alpha beta + beta alpha)
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
h1 = list_orb_reverse(i1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
@ -154,12 +171,8 @@
keys(3,nkeys) = h2
keys(4,nkeys) = h1
enddo
enddo
do i = 1, n_occ_ab(1)
i1 = occ(i,1)
do j = 1, n_occ_ab(1)
i2 = occ(j,1)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
@ -181,9 +194,9 @@
enddo
do i = 1, n_occ_ab(2)
i1 = occ(i,2)
h1 = list_orb_reverse(i1)
do j = 1, n_occ_ab(2)
i2 = occ(j,2)
h1 = list_orb_reverse(i1)
h2 = list_orb_reverse(i2)
nkeys += 1
do istate = 1, N_st
@ -204,28 +217,28 @@
enddo
enddo
endif
end
end
subroutine orb_range_off_diag_double_to_all_states_ab_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_double_to_all_states_ab_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
!
! c_1 is the array of the contributions to the rdm for all states
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 3 or 4 will do something
! routine that updates the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
!
! c_1 is the array of the contributions to the rdm for all states
!
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
!
! ispin determines which spin-spin component of the two-rdm you will update
!
! ispin == 1 :: alpha/ alpha
! ispin == 2 :: beta / beta
! ispin == 3 :: alpha/ beta
! ispin == 4 :: spin traced <=> total two-rdm
!
! here, only ispin == 3 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: ispin,sze_buff,N_st
@ -234,26 +247,29 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
endif
logical :: is_integer_in_string_local
if (ispin <= 2) return
! alpha_alpha = .False.
! beta_beta = .False.
! alpha_beta = .False.
! spin_trace = .False.
! if( ispin == 1)then
! alpha_alpha = .True.
! else if(ispin == 2)then
! beta_beta = .True.
! else if(ispin == 3)then
! alpha_beta = .True.
! else if(ispin == 4)then
! spin_trace = .True.
! endif
call get_double_excitation(det_1,det_2,exc,phase,N_int)
h1 = exc(1,1,1)
if(list_orb_reverse(h1).lt.0)return
h1 = list_orb_reverse(h1)
@ -266,10 +282,11 @@
p2 = exc(1,2,2)
if(list_orb_reverse(p2).lt.0)return
p2 = list_orb_reverse(p2)
if(alpha_beta)then
! if(alpha_beta)then
nkeys += 1
phase = phase * 0.5d0
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -277,36 +294,36 @@
keys(4,nkeys) = p2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p2
keys(4,nkeys) = p1
else if(spin_trace)then
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = p2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p2
keys(4,nkeys) = p1
endif
end
! else if(spin_trace)then
! nkeys += 1
! do istate = 1, N_st
! values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
! enddo
! keys(1,nkeys) = h1
! keys(2,nkeys) = h2
! keys(3,nkeys) = p1
! keys(4,nkeys) = p2
! nkeys += 1
! do istate = 1, N_st
! values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
! enddo
! keys(1,nkeys) = h2
! keys(2,nkeys) = h1
! keys(3,nkeys) = p2
! keys(4,nkeys) = p1
! endif
end
subroutine orb_range_off_diag_single_to_all_states_ab_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_single_to_all_states_ab_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
! routine that updates the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another
!
@ -333,7 +350,7 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
@ -342,16 +359,12 @@
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
beta_beta = .False.
logical :: is_integer_in_string_local
if (ispin <= 2) return
alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
@ -360,129 +373,145 @@
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(alpha_beta)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
endif
else if(spin_trace)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1)
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
endif
endif
end
subroutine orb_range_off_diag_single_to_all_states_aa_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string_local(h1,orb_bitmask,N_int))return
p1 = exc(1,2,1)
if(.not.is_integer_in_string_local(p1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = list_orb_reverse(p1)
phase = 0.5d0 * phase
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string_local(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string_local(h1,orb_bitmask,N_int))return
p1 = exc(1,2,2)
if(.not.is_integer_in_string_local(p1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = list_orb_reverse(p1)
phase = 0.5d0 * phase
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string_local(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
endif
else if(spin_trace)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string_local(h1,orb_bitmask,N_int))return
p1 = exc(1,2,1)
if(.not.is_integer_in_string_local(p1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = list_orb_reverse(p1)
phase = 0.5d0 * phase
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string_local(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string_local(h1,orb_bitmask,N_int))return
p1 = exc(1,2,2)
if(.not.is_integer_in_string_local(p1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
p1 = list_orb_reverse(p1)
phase = 0.5d0 * phase
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string_local(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
endif
endif
end
subroutine orb_range_off_diag_single_to_all_states_aa_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
!
@ -512,7 +541,7 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
@ -521,40 +550,42 @@
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
logical :: is_integer_in_string_local
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
! beta_beta = .False.
! alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
else
return
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
! if(alpha_alpha.or.spin_trace)then
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(alpha_alpha.or.spin_trace)then
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
if(.not.is_integer_in_string_local(h1,orb_bitmask,N_int))return
p1 = exc(1,2,1)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
if(.not.is_integer_in_string_local(p1,orb_bitmask,N_int))return
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
h1 = list_orb_reverse(h1)
p1 = list_orb_reverse(p1)
phase = 0.5d0*phase
do i = 1, n_occ_ab(1)
h2 = occ(i,1)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
if(.not.is_integer_in_string_local(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -563,7 +594,7 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -572,7 +603,7 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
@ -581,7 +612,7 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
@ -591,10 +622,10 @@
else
return
endif
endif
end
! endif
end
subroutine orb_range_off_diag_single_to_all_states_bb_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_single_to_all_states_bb_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
@ -624,7 +655,7 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
@ -632,42 +663,43 @@
integer :: exc(0:2,2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
logical :: is_integer_in_string_local
! alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
! alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
else
return
endif
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
! if(beta_beta.or.spin_trace)then
call get_single_excitation(det_1,det_2,exc,phase,N_int)
if(beta_beta.or.spin_trace)then
if (exc(0,1,1) == 1) then
return
else
! Mono beta
h1 = exc(1,1,2)
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
h1 = list_orb_reverse(h1)
if(.not.is_integer_in_string_local(h1,orb_bitmask,N_int))return
p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
if(.not.is_integer_in_string_local(p1,orb_bitmask,N_int))return
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
h1 = list_orb_reverse(h1)
p1 = list_orb_reverse(p1)
phase = 0.5d0*phase
do i = 1, n_occ_ab(2)
h2 = occ(i,2)
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
if(.not.is_integer_in_string_local(h2,orb_bitmask,N_int))cycle
h2 = list_orb_reverse(h2)
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -676,7 +708,7 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -685,7 +717,7 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
@ -694,7 +726,7 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
@ -702,11 +734,11 @@
keys(4,nkeys) = h2
enddo
endif
endif
end
! endif
end
subroutine orb_range_off_diag_double_to_all_states_aa_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_double_to_all_states_aa_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
@ -735,7 +767,7 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: i,j,h1,h2,p1,p2,istate
@ -743,38 +775,39 @@
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
logical :: is_integer_in_string_local
alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
! beta_beta = .False.
! alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
else
return
endif
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
h1 =exc(1,1)
if(list_orb_reverse(h1).lt.0)return
h1 = list_orb_reverse(h1)
h2 =exc(2,1)
if(list_orb_reverse(h2).lt.0)return
h2 = list_orb_reverse(h2)
p1 =exc(1,2)
if(list_orb_reverse(p1).lt.0)return
p1 = list_orb_reverse(p1)
p2 =exc(2,2)
if(list_orb_reverse(p2).lt.0)return
h1 = list_orb_reverse(h1)
h2 = list_orb_reverse(h2)
p1 = list_orb_reverse(p1)
p2 = list_orb_reverse(p2)
if(alpha_alpha.or.spin_trace)then
phase = 0.5d0*phase
! if(alpha_alpha.or.spin_trace)then
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -783,7 +816,7 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -792,7 +825,7 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
@ -801,16 +834,16 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = p2
endif
end
! endif
end
subroutine orb_range_off_diag_double_to_all_states_bb_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
subroutine orb_range_off_diag_double_to_all_states_bb_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
use bitmasks
BEGIN_DOC
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
@ -840,25 +873,23 @@
double precision, intent(in) :: c_1(N_st)
double precision, intent(out) :: values(N_st,sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer , intent(inout) :: nkeys
integer :: i,j,h1,h2,p1,p2,istate
integer :: exc(0:2,2)
double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
logical :: is_integer_in_string
alpha_alpha = .False.
logical :: is_integer_in_string_local
! alpha_alpha = .False.
beta_beta = .False.
alpha_beta = .False.
! alpha_beta = .False.
spin_trace = .False.
if( ispin == 1)then
alpha_alpha = .True.
else if(ispin == 2)then
if(ispin == 2)then
beta_beta = .True.
else if(ispin == 3)then
alpha_beta = .True.
else if(ispin == 4)then
spin_trace = .True.
else
return
endif
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
@ -874,10 +905,12 @@
p2 =exc(2,2)
if(list_orb_reverse(p2).lt.0)return
p2 = list_orb_reverse(p2)
if(beta_beta.or.spin_trace)then
! if(beta_beta.or.spin_trace)then
phase = 0.5d0*phase
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -886,7 +919,7 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h1
keys(2,nkeys) = h2
@ -895,7 +928,7 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
@ -904,12 +937,12 @@
nkeys += 1
do istate = 1, N_st
values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase
values(istate,nkeys) = - c_1(istate) * phase
enddo
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = p2
endif
end
! endif
end