mirror of
https://github.com/LCPQ/quantum_package
synced 2024-06-24 06:02:17 +02:00
67 lines
2.1 KiB
Fortran
67 lines
2.1 KiB
Fortran
|
|
subroutine get_dm_from_psi(dets_in,u_in,sze,dim_in,Nint,dm_alpha,dm_beta)
|
|
implicit none
|
|
BEGIN_DOC
|
|
! Alpha and beta one-body density matrix
|
|
!
|
|
! dets_in :: bitsrings corresponding to the determinants in the wave function
|
|
!
|
|
! u_in :: coefficients of the wave function
|
|
!
|
|
! sze :: number of determinants in the wave function
|
|
!
|
|
! dim_in :: physical dimension of the array u_in and dets_in
|
|
!
|
|
! Nint :: should be equal to N_int
|
|
!
|
|
! dm_alpha :: alpha one body density matrix
|
|
!
|
|
! dm_beta :: beta one body density matrix
|
|
END_DOC
|
|
use bitmasks
|
|
integer, intent(in) :: sze,dim_in,Nint
|
|
integer(bit_kind), intent(in) :: dets_in(Nint,2,dim_in)
|
|
double precision, intent(in) :: u_in(dim_in)
|
|
double precision, intent(out) :: dm_alpha(mo_tot_num,mo_tot_num)
|
|
double precision, intent(out) :: dm_beta(mo_tot_num,mo_tot_num)
|
|
|
|
integer :: j,k,l
|
|
integer :: occ(N_int*bit_kind_size,2)
|
|
double precision :: ck, cl, ckl
|
|
double precision :: phase
|
|
integer :: h1,h2,p1,p2,s1,s2, degree
|
|
integer :: exc(0:2,2,2),n_occ_alpha
|
|
dm_alpha = 0.d0
|
|
dm_beta = 0.d0
|
|
|
|
do k=1,sze
|
|
call bitstring_to_list(dets_in(1,1,k), occ(1,1), n_occ_alpha, N_int)
|
|
call bitstring_to_list(dets_in(1,2,k), occ(1,2), n_occ_alpha, N_int)
|
|
ck = u_in(k)
|
|
do l=1,elec_alpha_num
|
|
j = occ(l,1)
|
|
dm_alpha(j,j) += ck*ck
|
|
enddo
|
|
do l=1,elec_beta_num
|
|
j = occ(l,2)
|
|
dm_beta(j,j) += ck*ck
|
|
enddo
|
|
do l=1,k-1
|
|
call get_excitation_degree(dets_in(1,1,k),dets_in(1,1,l),degree,N_int)
|
|
if (degree /= 1) then
|
|
cycle
|
|
endif
|
|
call get_mono_excitation(dets_in(1,1,k),dets_in(1,1,l),exc,phase,N_int)
|
|
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
|
ckl = ck * u_in(l) * phase
|
|
if (s1==1) then
|
|
dm_alpha(h1,p1) += ckl
|
|
dm_alpha(p1,h1) += ckl
|
|
else
|
|
dm_beta(h1,p1) += ckl
|
|
dm_beta(p1,h1) += ckl
|
|
endif
|
|
enddo
|
|
enddo
|
|
end
|