LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-06-30 00:14:17 +02:00
Code Releases Activity

two rdm seems to work with buffer, ready for openmp

Browse Source
This commit is contained in:
Emmanuel Giner 2019-07-04 17:34:56 +02:00
parent 59aaf3806d
commit 887afe97b4
5 changed files with 440 additions and 335 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/bitmask/core_inact_act_virt.irp.f
View File

@ -322,6 +322,7 @@ END_PROVIDER
enddo enddo
print *, 'Active MOs:' print *, 'Active MOs:'
print *, list_act(1:n_act_orb) print *, list_act(1:n_act_orb)
print*, list_act_reverse(1:n_act_orb)
END_PROVIDER END_PROVIDER

2
src/two_body_rdm/orb_range_routines.irp.f
View File

@ -31,6 +31,7 @@ subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reve
size(u_t, 1), & size(u_t, 1), &
N_det, N_st) N_det, N_st)
call orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) call orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1)
deallocate(u_t) deallocate(u_t)
@ -135,6 +136,7 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l
stop stop
endif endif
PROVIDE N_int PROVIDE N_int
call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) call list_to_bitstring( orb_bitmask, list_orb, norb, N_int)

35
src/two_body_rdm/orb_range_routines_openmp.irp.f
View File

@ -145,7 +145,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
PROVIDE N_int PROVIDE N_int
call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) call list_to_bitstring( orb_bitmask, list_orb, norb, N_int)
sze_buff = norb ** 3 sze_buff = norb ** 3 + 6 * norb
list_orb_reverse = -1000 list_orb_reverse = -1000
do i = 1, norb do i = 1, norb
list_orb_reverse(list_orb(i)) = i list_orb_reverse(list_orb(i)) = i
@ -353,13 +353,17 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
enddo enddo
if(alpha_beta.or.spin_trace.or.alpha_alpha)then if(alpha_beta.or.spin_trace.or.alpha_alpha)then
! increment the alpha/beta part for single excitations ! increment the alpha/beta part for single excitations
if (nkeys+norb .ge. size(values)) then if (nkeys+ 2 * norb .ge. size(values)) then
call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) call update_keys_values(keys,values,size(values),nkeys,dim1,big_array)
nkeys = 0 nkeys = 0
endif endif
call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! increment the alpha/alpha part for single excitations ! increment the alpha/alpha part for single excitations
!!!! call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) if (nkeys+2 * norb .ge. size(values)) then
call update_keys_values(keys,values,size(values),nkeys,dim1,big_array)
nkeys = 0
endif
call orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
endif endif
enddo enddo
@ -382,7 +386,11 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
c_2(l) = u_t(l,k_a) c_2(l) = u_t(l,k_a)
c_average += c_1(l) * c_2(l) * state_weights(l) c_average += c_1(l) * c_2(l) * state_weights(l)
enddo enddo
!!!! call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) if (nkeys+4 .ge. size(values)) then
call update_keys_values(keys,values,size(values),nkeys,dim1,big_array)
nkeys = 0
endif
call orb_range_off_diag_double_to_two_rdm_aa_dm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
enddo enddo
endif endif
@ -455,7 +463,11 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
endif endif
call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! increment the beta /beta part for single excitations ! increment the beta /beta part for single excitations
!!!! call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) if (nkeys+norb .ge. size(values)) then
call update_keys_values(keys,values,size(values),nkeys,dim1,big_array)
nkeys = 0
endif
call orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
endif endif
enddo enddo
@ -477,7 +489,12 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis
c_2(l) = u_t(l,k_a) c_2(l) = u_t(l,k_a)
c_average += c_1(l) * c_2(l) * state_weights(l) c_average += c_1(l) * c_2(l) * state_weights(l)
enddo enddo
!!!! call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) ! call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
if (nkeys+4 .ge. size(values)) then
call update_keys_values(keys,values,size(values),nkeys,dim1,big_array)
nkeys = 0
endif
call orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
ASSERT (l_a <= N_det) ASSERT (l_a <= N_det)
enddo enddo

36
src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f
View File

@ -13,7 +13,7 @@
double precision, intent(in) :: c_1 double precision, intent(in) :: c_1
integer :: occ(N_int*bit_kind_size,2) integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2) integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate integer :: i,j,h1,h2
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
do i = 1, n_occ_ab(1) do i = 1, n_occ_ab(1)
h1 = occ(i,1) h1 = occ(i,1)
@ -53,7 +53,7 @@
integer :: occ(N_int*bit_kind_size,2) integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2) integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate integer :: i,j,h1,h2
integer(bit_kind) :: det_1_act(N_int,2) integer(bit_kind) :: det_1_act(N_int,2)
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
do i = 1, N_int do i = 1, N_int
@ -193,7 +193,7 @@
integer(bit_kind), intent(in) :: orb_bitmask(N_int) integer(bit_kind), intent(in) :: orb_bitmask(N_int)
integer, intent(in) :: list_orb_reverse(mo_num) integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1 double precision, intent(in) :: c_1
integer :: i,j,h1,h2,p1,p2,istate integer :: i,j,h1,h2,p1,p2
integer :: exc(0:2,2,2) integer :: exc(0:2,2,2)
double precision :: phase double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
@ -278,7 +278,7 @@
integer :: occ(N_int*bit_kind_size,2) integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2) integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate,p1 integer :: i,j,h1,h2,p1
integer :: exc(0:2,2,2) integer :: exc(0:2,2,2)
double precision :: phase double precision :: phase
@ -397,7 +397,7 @@
integer :: occ(N_int*bit_kind_size,2) integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2) integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate,p1 integer :: i,j,h1,h2,p1
integer :: exc(0:2,2,2) integer :: exc(0:2,2,2)
double precision :: phase double precision :: phase
@ -477,7 +477,7 @@
integer :: occ(N_int*bit_kind_size,2) integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2) integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate,p1 integer :: i,j,h1,h2,p1
integer :: exc(0:2,2,2) integer :: exc(0:2,2,2)
double precision :: phase double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
@ -510,17 +510,15 @@
p1 = exc(1,2,2) p1 = exc(1,2,2)
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
p1 = list_orb_reverse(p1) p1 = list_orb_reverse(p1)
do istate = 1, N_states do i = 1, n_occ_ab(2)
do i = 1, n_occ_ab(2) h2 = occ(i,2)
h2 = occ(i,2) if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle h2 = list_orb_reverse(h2)
h2 = list_orb_reverse(h2) big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase
big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase
big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase
enddo
enddo enddo
endif endif
endif endif
@ -557,7 +555,7 @@
integer, intent(in) :: list_orb_reverse(mo_num) integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1 double precision, intent(in) :: c_1
integer :: i,j,h1,h2,p1,p2,istate integer :: i,j,h1,h2,p1,p2
integer :: exc(0:2,2) integer :: exc(0:2,2)
double precision :: phase double precision :: phase
@ -590,13 +588,11 @@
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
p2 = list_orb_reverse(p2) p2 = list_orb_reverse(p2)
if(alpha_alpha.or.spin_trace)then if(alpha_alpha.or.spin_trace)then
do istate = 1, N_states
big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase
big_array(h1,h2,p2,p1) -= 0.5d0 * c_1 * phase big_array(h1,h2,p2,p1) -= 0.5d0 * c_1 * phase
big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase
big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase
enddo
endif endif
end end
@ -631,7 +627,7 @@
integer, intent(in) :: list_orb_reverse(mo_num) integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1 double precision, intent(in) :: c_1
integer :: i,j,h1,h2,p1,p2,istate integer :: i,j,h1,h2,p1,p2
integer :: exc(0:2,2) integer :: exc(0:2,2)
double precision :: phase double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace

699
src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f
View File

@ -26,7 +26,7 @@
integer :: occ(N_int*bit_kind_size,2) integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2) integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate integer :: i,j,h1,h2
integer(bit_kind) :: det_1_act(N_int,2) integer(bit_kind) :: det_1_act(N_int,2)
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
do i = 1, N_int do i = 1, N_int
@ -201,7 +201,7 @@
double precision, intent(out) :: values(sze_buff) double precision, intent(out) :: values(sze_buff)
integer , intent(out) :: keys(4,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 :: i,j,h1,h2,p1,p2
integer :: exc(0:2,2,2) integer :: exc(0:2,2,2)
double precision :: phase double precision :: phase
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
@ -288,7 +288,7 @@
integer :: occ(N_int*bit_kind_size,2) integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2) integer :: n_occ_ab(2)
integer :: i,j,h1,h2,istate,p1 integer :: i,j,h1,h2,p1
integer :: exc(0:2,2,2) integer :: exc(0:2,2,2)
double precision :: phase double precision :: phase
@ -409,310 +409,399 @@
endif endif
end end
! subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) subroutine orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! BEGIN_DOC BEGIN_DOC
!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for ! 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 SINGLE excitation with respect to one another ! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another
!! !
!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!! !
!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation ! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!! !
!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals ! 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 determines which spin-spin component of the two-rdm you will update
!! !
!! ispin == 1 :: alpha/ alpha ! ispin == 1 :: alpha/ alpha
!! ispin == 2 :: beta / beta ! ispin == 2 :: beta / beta
!! ispin == 3 :: alpha/ beta ! ispin == 3 :: alpha/ beta
!! ispin == 4 :: spin traced <=> total two-rdm ! ispin == 4 :: spin traced <=> total two-rdm
!! !
!! here, only ispin == 1 or 4 will do something ! here, only ispin == 1 or 4 will do something
! END_DOC END_DOC
! use bitmasks use bitmasks
! implicit none implicit none
! integer, intent(in) :: dim1,ispin integer, intent(in) :: ispin,sze_buff
! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
! integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) integer, intent(in) :: list_orb_reverse(mo_num)
! integer(bit_kind), intent(in) :: orb_bitmask(N_int) double precision, intent(in) :: c_1
! integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(out) :: values(sze_buff)
! double precision, intent(in) :: c_1 integer , intent(out) :: keys(4,sze_buff)
! integer , intent(inout):: nkeys
! integer :: occ(N_int*bit_kind_size,2)
! integer :: n_occ_ab(2)
! integer :: i,j,h1,h2,istate,p1
! 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
!
! 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_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)
! 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(1)
! h2 = occ(i,1)
! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
! h2 = list_orb_reverse(h2)
! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
! big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase
!
! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
! big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase
! enddo
! else
! return
! endif
! endif
! end
! subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) integer :: occ(N_int*bit_kind_size,2)
! use bitmasks integer :: n_occ_ab(2)
! BEGIN_DOC integer :: i,j,h1,h2,p1
!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for integer :: exc(0:2,2,2)
!! double precision :: phase
!! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another
!! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 logical :: is_integer_in_string
!! alpha_alpha = .False.
!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation beta_beta = .False.
!! alpha_beta = .False.
!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals spin_trace = .False.
!! if( ispin == 1)then
!! ispin determines which spin-spin component of the two-rdm you will update alpha_alpha = .True.
!! else if(ispin == 2)then
!! ispin == 1 :: alpha/ alpha beta_beta = .True.
!! ispin == 2 :: beta / beta else if(ispin == 3)then
!! ispin == 3 :: alpha/ beta alpha_beta = .True.
!! ispin == 4 :: spin traced <=> total two-rdm else if(ispin == 4)then
!! spin_trace = .True.
!! here, only ispin == 2 or 4 will do something endif
! END_DOC
! implicit none call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
! integer, intent(in) :: dim1,ispin call get_single_excitation(det_1,det_2,exc,phase,N_int)
! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) if(alpha_alpha.or.spin_trace)then
! integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) if (exc(0,1,1) == 1) then
! integer(bit_kind), intent(in) :: orb_bitmask(N_int) ! Mono alpha
! integer, intent(in) :: list_orb_reverse(mo_num) h1 = exc(1,1,1)
! double precision, intent(in) :: c_1 if(list_orb_reverse(h1).lt.0)return
! h1 = list_orb_reverse(h1)
! p1 = exc(1,2,1)
! integer :: occ(N_int*bit_kind_size,2) if(list_orb_reverse(p1).lt.0)return
! integer :: n_occ_ab(2) p1 = list_orb_reverse(p1)
! integer :: i,j,h1,h2,istate,p1 do i = 1, n_occ_ab(1)
! integer :: exc(0:2,2,2) h2 = occ(i,1)
! double precision :: phase if(list_orb_reverse(h2).lt.0)return
! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace h2 = list_orb_reverse(h2)
! logical :: is_integer_in_string
! alpha_alpha = .False. nkeys += 1
! beta_beta = .False. values(nkeys) = 0.5d0 * c_1 * phase
! alpha_beta = .False. keys(1,nkeys) = h1
! spin_trace = .False. keys(2,nkeys) = h2
! if( ispin == 1)then keys(3,nkeys) = p1
! alpha_alpha = .True. keys(4,nkeys) = h2
! else if(ispin == 2)then
! beta_beta = .True. nkeys += 1
! else if(ispin == 3)then values(nkeys) = - 0.5d0 * c_1 * phase
! alpha_beta = .True. keys(1,nkeys) = h1
! else if(ispin == 4)then keys(2,nkeys) = h2
! spin_trace = .True. keys(3,nkeys) = h2
! endif keys(4,nkeys) = p1
!
! nkeys += 1
! call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) values(nkeys) = 0.5d0 * c_1 * phase
! call get_single_excitation(det_1,det_2,exc,phase,N_int) keys(1,nkeys) = h2
! if(beta_beta.or.spin_trace)then keys(2,nkeys) = h1
! if (exc(0,1,1) == 1) then keys(3,nkeys) = h2
! return keys(4,nkeys) = p1
! else
! ! Mono beta nkeys += 1
! h1 = exc(1,1,2) values(nkeys) = - 0.5d0 * c_1 * phase
! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return keys(1,nkeys) = h2
! h1 = list_orb_reverse(h1) keys(2,nkeys) = h1
! p1 = exc(1,2,2) keys(3,nkeys) = p1
! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return keys(4,nkeys) = h2
! p1 = list_orb_reverse(p1) enddo
! do istate = 1, N_states else
! do i = 1, n_occ_ab(2) return
! h2 = occ(i,2) endif
! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle endif
! h2 = list_orb_reverse(h2) end
! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
! big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase subroutine orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! use bitmasks
! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase BEGIN_DOC
! big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
! enddo !
! enddo ! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another
! endif !
! endif ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
! end !
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! 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 == 2 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: ispin,sze_buff
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1
double precision, intent(out) :: values(sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2)
integer :: i,j,h1,h2,p1
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
! subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
! use bitmasks call get_single_excitation(det_1,det_2,exc,phase,N_int)
! BEGIN_DOC if(beta_beta.or.spin_trace)then
!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for if (exc(0,1,1) == 1) then
!! return
!! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another else
!! ! Mono beta
!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 h1 = exc(1,1,2)
!! if(list_orb_reverse(h1).lt.0)return
!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation h1 = list_orb_reverse(h1)
!! p1 = exc(1,2,2)
!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals if(list_orb_reverse(p1).lt.0)return
!! p1 = list_orb_reverse(p1)
!! ispin determines which spin-spin component of the two-rdm you will update do i = 1, n_occ_ab(2)
!! h2 = occ(i,2)
!! ispin == 1 :: alpha/ alpha if(list_orb_reverse(h2).lt.0)return
!! ispin == 2 :: beta / beta h2 = list_orb_reverse(h2)
!! ispin == 3 :: alpha/ beta nkeys += 1
!! ispin == 4 :: spin traced <=> total two-rdm values(nkeys) = 0.5d0 * c_1 * phase
!! keys(1,nkeys) = h1
!! here, only ispin == 1 or 4 will do something keys(2,nkeys) = h2
! END_DOC keys(3,nkeys) = p1
! implicit none keys(4,nkeys) = h2
! integer, intent(in) :: dim1,ispin
! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
! integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
! integer(bit_kind), intent(in) :: orb_bitmask(N_int)
! integer, intent(in) :: list_orb_reverse(mo_num)
! double precision, intent(in) :: c_1
!
! 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.
! 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_spin(det_1,det_2,exc,phase,N_int)
! h1 =exc(1,1)
! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
! h1 = list_orb_reverse(h1)
! h2 =exc(2,1)
! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
! h2 = list_orb_reverse(h2)
! p1 =exc(1,2)
! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
! p1 = list_orb_reverse(p1)
! p2 =exc(2,2)
! if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
! p2 = list_orb_reverse(p2)
! if(alpha_alpha.or.spin_trace)then
! do istate = 1, N_states
! big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase
! big_array(h1,h2,p2,p1) -= 0.5d0 * c_1 * phase
!
! big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase
! big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase
! enddo
! endif
! end
! subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) nkeys += 1
! use bitmasks values(nkeys) = - 0.5d0 * c_1 * phase
! BEGIN_DOC keys(1,nkeys) = h1
!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for keys(2,nkeys) = h2
!! keys(3,nkeys) = h2
!! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another keys(4,nkeys) = p1
!!
!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 nkeys += 1
!! values(nkeys) = 0.5d0 * c_1 * phase
!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation keys(1,nkeys) = h2
!! keys(2,nkeys) = h1
!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals keys(3,nkeys) = h2
!! keys(4,nkeys) = p1
!! ispin determines which spin-spin component of the two-rdm you will update
!! nkeys += 1
!! ispin == 1 :: alpha/ alpha values(nkeys) = - 0.5d0 * c_1 * phase
!! ispin == 2 :: beta / beta keys(1,nkeys) = h2
!! ispin == 3 :: alpha/ beta keys(2,nkeys) = h1
!! ispin == 4 :: spin traced <=> total two-rdm keys(3,nkeys) = p1
!! keys(4,nkeys) = h2
!! here, only ispin == 2 or 4 will do something enddo
! END_DOC endif
! implicit none endif
! end
! integer, intent(in) :: dim1,ispin
! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
! integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) subroutine orb_range_off_diag_double_to_two_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
! integer(bit_kind), intent(in) :: orb_bitmask(N_int) use bitmasks
! integer, intent(in) :: list_orb_reverse(mo_num) BEGIN_DOC
! double precision, intent(in) :: c_1 ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
! !
! integer :: i,j,h1,h2,p1,p2,istate ! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another
! integer :: exc(0:2,2) !
! double precision :: phase ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace !
! logical :: is_integer_in_string ! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
! alpha_alpha = .False. !
! beta_beta = .False. ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
! alpha_beta = .False. !
! spin_trace = .False. ! ispin determines which spin-spin component of the two-rdm you will update
! if( ispin == 1)then !
! alpha_alpha = .True. ! ispin == 1 :: alpha/ alpha
! else if(ispin == 2)then ! ispin == 2 :: beta / beta
! beta_beta = .True. ! ispin == 3 :: alpha/ beta
! else if(ispin == 3)then ! ispin == 4 :: spin traced <=> total two-rdm
! alpha_beta = .True. !
! else if(ispin == 4)then ! here, only ispin == 1 or 4 will do something
! spin_trace = .True. END_DOC
! endif implicit none
! integer, intent(in) :: ispin,sze_buff
! call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
! h1 =exc(1,1) integer, intent(in) :: list_orb_reverse(mo_num)
! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return double precision, intent(in) :: c_1
! h1 = list_orb_reverse(h1) double precision, intent(out) :: values(sze_buff)
! h2 =exc(2,1) integer , intent(out) :: keys(4,sze_buff)
! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return integer , intent(inout):: nkeys
! h2 = list_orb_reverse(h2)
! p1 =exc(1,2)
! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return integer :: i,j,h1,h2,p1,p2
! p1 = list_orb_reverse(p1) integer :: exc(0:2,2)
! p2 =exc(2,2) double precision :: phase
! if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
! p2 = list_orb_reverse(p2) logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
! if(beta_beta.or.spin_trace)then logical :: is_integer_in_string
! big_array(h1,h2,p1,p2) += 0.5d0 * c_1* phase alpha_alpha = .False.
! big_array(h1,h2,p2,p1) -= 0.5d0 * c_1* phase beta_beta = .False.
! alpha_beta = .False.
! big_array(h2,h1,p2,p1) += 0.5d0 * c_1* phase spin_trace = .False.
! big_array(h2,h1,p1,p2) -= 0.5d0 * c_1* phase if( ispin == 1)then
! endif alpha_alpha = .True.
! end 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_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
p2 = list_orb_reverse(p2)
if(alpha_alpha.or.spin_trace)then
nkeys += 1
values(nkeys) = 0.5d0 * c_1 * phase
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = p2
nkeys += 1
values(nkeys) = - 0.5d0 * c_1 * phase
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p2
keys(4,nkeys) = p1
nkeys += 1
values(nkeys) = 0.5d0 * c_1 * phase
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p2
keys(4,nkeys) = p1
nkeys += 1
values(nkeys) = - 0.5d0 * c_1 * phase
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = p2
endif
end
subroutine orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(det_1,det_2,c_1,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 BETA /BETA DOUBLE excitation with respect to one another
!
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
!
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
!
! 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 == 2 or 4 will do something
END_DOC
implicit none
integer, intent(in) :: ispin,sze_buff
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer, intent(in) :: list_orb_reverse(mo_num)
double precision, intent(in) :: c_1
double precision, intent(out) :: values(sze_buff)
integer , intent(out) :: keys(4,sze_buff)
integer , intent(inout):: nkeys
integer :: i,j,h1,h2,p1,p2
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.
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_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
p2 = list_orb_reverse(p2)
if(beta_beta.or.spin_trace)then
nkeys += 1
values(nkeys) = 0.5d0 * c_1 * phase
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = p2
nkeys += 1
values(nkeys) = - 0.5d0 * c_1 * phase
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p2
keys(4,nkeys) = p1
nkeys += 1
values(nkeys) = 0.5d0 * c_1 * phase
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p2
keys(4,nkeys) = p1
nkeys += 1
values(nkeys) = - 0.5d0 * c_1 * phase
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = p2
endif
end