LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2025-01-03 10:05:57 +01:00
Code Issues Releases Wiki Activity

working on davidson

Browse Source
This commit is contained in:
Anthony Scemama 2017-04-14 11:09:55 +02:00
parent 6d30e194b8
commit 77f38a94a2
3 changed files with 195 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

279
src/Davidson/u0Hu0.irp.f
View File

@ -632,9 +632,9 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8)
PROVIDE ref_bitmask_energy PROVIDE ref_bitmask_energy
double precision :: hij, s2 double precision :: hij, s2
integer :: i,j integer :: i,j,k
integer :: k_a, k_b, l_a, l_b, m_a, m_b integer :: k_a, k_b, l_a, l_b, m_a, m_b
integer :: degree, istate integer :: istate
integer :: krow, kcol, krow_b, kcol_b integer :: krow, kcol, krow_b, kcol_b
integer :: lrow, lcol integer :: lrow, lcol
integer :: mrow, mcol integer :: mrow, mcol
@ -646,16 +646,20 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8)
double precision :: ck(N_st), cl(N_st), cm(N_st) double precision :: ck(N_st), cl(N_st), cm(N_st)
integer :: n_singles, n_doubles integer :: n_singles, n_doubles
integer, allocatable :: singles(:), doubles(:) integer, allocatable :: singles(:), doubles(:)
integer, allocatable :: singles_a(:,:), singles_b(:,:)
integer, allocatable :: idx(:), idx0(:) integer, allocatable :: idx(:), idx0(:)
logical, allocatable :: is_single_a(:) logical, allocatable :: is_single_a(:)
logical, allocatable :: is_single_b(:)
integer :: maxab, n_singles_max
allocate( buffer(N_int,N_det_alpha_unique), & maxab = max(N_det_alpha_unique, N_det_beta_unique)
singles(N_det_alpha_unique), doubles(N_det_alpha_unique), & allocate( buffer(N_int,maxab), &
singles(maxab), doubles(maxab), &
is_single_a(N_det_alpha_unique), & is_single_a(N_det_alpha_unique), &
idx(N_det_alpha_unique), idx0(N_det_alpha_unique) ) is_single_b(N_det_beta_unique), &
idx(maxab), idx0(maxab))
v_0 = 0.d0 v_0 = 0.d0
do k_a=1,N_det do k_a=1,N_det
! Initial determinant is at k_a in alpha-major representation ! Initial determinant is at k_a in alpha-major representation
@ -690,12 +694,13 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8)
i=1 i=1
l_a = k_a+1 l_a = k_a+1
lcol = psi_bilinear_matrix_columns(l_a) lcol = psi_bilinear_matrix_columns(l_a)
do while ( (lcol == kcol).and.(l_a <= N_det) ) do while (lcol == kcol)
lrow = psi_bilinear_matrix_rows(l_a) lrow = psi_bilinear_matrix_rows(l_a)
buffer(1:N_int,i) = psi_det_alpha_unique(1:N_int, lrow) buffer(1:N_int,i) = psi_det_alpha_unique(1:N_int, lrow)
idx(i) = lrow idx(i) = lrow
i=i+1 i = i +1
l_a = l_a + 1 l_a = l_a+1
if (l_a > N_det) exit
lcol = psi_bilinear_matrix_columns(l_a) lcol = psi_bilinear_matrix_columns(l_a)
enddo enddo
i = i-1 i = i-1
@ -747,12 +752,13 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8)
i=1 i=1
l_b = k_b+1 l_b = k_b+1
lrow = psi_bilinear_matrix_transp_rows(l_b) lrow = psi_bilinear_matrix_transp_rows(l_b)
do while ( (lrow == krow).and.(l_b <= N_det) ) do while (lrow == krow)
lcol = psi_bilinear_matrix_transp_columns(l_b) lcol = psi_bilinear_matrix_transp_columns(l_b)
buffer(1:N_int,i) = psi_det_beta_unique(1:N_int, lcol) buffer(1:N_int,i) = psi_det_beta_unique(1:N_int, lcol)
idx(i) = lcol idx(i) = lcol
i=i+1 i = i +1
l_b = l_b + 1 l_b = l_b+1
if (l_b > N_det) exit
lrow = psi_bilinear_matrix_transp_rows(l_b) lrow = psi_bilinear_matrix_transp_rows(l_b)
enddo enddo
i = i-1 i = i-1
@ -801,115 +807,190 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8)
! Alpha/Beta double excitations ! Alpha/Beta double excitations
! ============================= ! =============================
do i=1,N_det_beta_unique do i=1,maxab
idx0(i) = i idx0(i) = i
enddo enddo
is_single_a(:) = .False.
k_a=1 ! Prepare the array of all alpha single excitations
do i=1,N_det_beta_unique ! -------------------------------------------------
! Select a beta determinant
! -------------------------
spindet(1:N_int) = psi_det_beta_unique(1:N_int, i)
tmp_det(1:N_int,2) = spindet(1:N_int)
n_singles_max = 0
do i=1,N_det_alpha_unique
spindet(1:N_int) = psi_det_alpha_unique(1:N_int, i)
call get_all_spin_singles( & call get_all_spin_singles( &
psi_det_beta_unique, idx0, spindet, N_int, N_det_beta_unique, & psi_det_alpha_unique, idx0, spindet, N_int, N_det_alpha_unique,&
singles, n_singles ) singles, n_singles)
n_singles_max = max(n_singles_max, n_singles)
enddo
do j=1,n_singles allocate (singles_a(0:n_singles_max, N_det_alpha_unique))
is_single_a( singles(j) ) = .True. do i=1,N_det_alpha_unique
enddo spindet(1:N_int) = psi_det_alpha_unique(1:N_int, i)
call get_all_spin_singles( &
psi_det_alpha_unique, idx0, spindet, N_int, N_det_alpha_unique,&
singles_a(1,i), singles_a(0,i))
enddo
! For all alpha.beta pairs with the selected beta do k_a=1,N_det
! -----------------------------------------------
! Initial determinant is at k_a in alpha-major representation
! -----------------------------------------------------------------------
krow = psi_bilinear_matrix_rows(k_a)
kcol = psi_bilinear_matrix_columns(k_a) kcol = psi_bilinear_matrix_columns(k_a)
do while (kcol < i)
k_a = k_a+1 tmp_det(1:N_int,1) = psi_det_alpha_unique(1:N_int, krow)
if (k_a > N_det) exit tmp_det(1:N_int,2) = psi_det_beta_unique (1:N_int, kcol)
kcol = psi_bilinear_matrix_columns(k_a)
is_single_a = .False.
do k=1,singles_a(0,krow)
is_single_a( singles_a(k,krow) ) = .True.
enddo enddo
do while (kcol == i) if (k_a > 1) then
if (kcol /= psi_bilinear_matrix_columns(k_a-1)) then
call get_all_spin_singles( &
psi_det_beta_unique, idx0, tmp_det(1,2), N_int, N_det_beta_unique,&
singles, n_singles)
endif
else
call get_all_spin_singles( &
psi_det_beta_unique, idx0, tmp_det(1,2), N_int, N_det_beta_unique,&
singles, n_singles)
endif
krow = psi_bilinear_matrix_rows(k_a) ! Loop over singly excited beta columns
tmp_det(1:N_int,1) = psi_det_alpha_unique(1:N_int,krow) ! -------------------------------------
! Loop over all alpha.beta pairs with a single exc alpha do i=1,n_singles
! ------------------------------------------------------ lcol = singles(i)
! TODO cycle if lcol <= kcol
tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, lcol)
l_a = k_a+1 l_a = psi_bilinear_matrix_columns_loc(lcol)
if (l_a > N_det) exit ! TODO loop
lrow = psi_bilinear_matrix_rows(l_a)
lcol = psi_bilinear_matrix_columns(l_a)
do while (lrow == krow) do while ( l_a < psi_bilinear_matrix_columns_loc(lcol+1) )
lrow = psi_bilinear_matrix_rows(l_a)
! Loop over all alpha.beta pairs with a single exc alpha
! ------------------------------------------------------
if (is_single_a(lrow)) then if (is_single_a(lrow)) then
tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow)
tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int,lrow) call i_H_j_double_alpha_beta(tmp_det,tmp_det2,N_int,hij)
v_0(k_a, 1:N_st) += hij * psi_bilinear_matrix_values(l_a,1:N_st)
! Build list of singly excited beta endif
! --------------------------------- l_a += 1
m_b = psi_bilinear_matrix_order_reverse(l_a) enddo
m_b = m_b+1 enddo
j=1
do while ( (mrow == lrow) )
mcol = psi_bilinear_matrix_transp_columns(m_b)
buffer(1:N_int,j) = psi_det_beta_unique(1:N_int,mcol)
idx(j) = mcol
j = j+1
m_b = m_b+1
if (m_b <= N_det) exit
mrow = psi_bilinear_matrix_transp_rows(m_b)
enddo
j=j-1
call get_all_spin_singles( & enddo
buffer, idx, tmp_det(1,2), N_int, j, &
doubles, n_doubles)
! Compute Hij for all doubles !----
! ---------------------------
m_b = psi_bilinear_matrix_order(l_a)+1 ! k_a=1
mcol = psi_bilinear_matrix_transp_columns(m_b) ! do i=1,N_det_beta_unique
do j=1,n_doubles !
tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, doubles(j) ) ! ! Select a beta determinant
call i_H_j_double_alpha_beta(tmp_det,tmp_det2,N_int,hij) ! ! -------------------------
do while (mcol /= doubles(j)) !
m_b = m_b+1 ! spindet(1:N_int) = psi_det_beta_unique(1:N_int, i)
if (m_b > N_det) exit ! tmp_det(1:N_int,2) = spindet(1:N_int)
mcol = psi_bilinear_matrix_transp_columns(m_b) !
enddo ! call get_all_spin_singles( &
m_a = psi_bilinear_matrix_order_reverse(m_b) ! psi_det_beta_unique, idx0, spindet, N_int, N_det_beta_unique, &
! singles, n_singles )
!
! do j=1,n_singles
! is_single_a( singles(j) ) = .True.
! enddo
!
! ! For all alpha.beta pairs with the selected beta
! ! -----------------------------------------------
!
! kcol = psi_bilinear_matrix_columns(k_a)
! do while (kcol < i)
! k_a = k_a+1
! if (k_a > N_det) exit
! kcol = psi_bilinear_matrix_columns(k_a)
! enddo
!
! do while (kcol == i)
!
! krow = psi_bilinear_matrix_rows(k_a)
! tmp_det(1:N_int,1) = psi_det_alpha_unique(1:N_int,krow)
!
! ! Loop over all alpha.beta pairs with a single exc alpha
! ! ------------------------------------------------------
!
! l_a = k_a+1
! if (l_a > N_det) exit
! lrow = psi_bilinear_matrix_rows(l_a)
! lcol = psi_bilinear_matrix_columns(l_a)
!
! do while (lrow == krow)
!
! ! Loop over all alpha.beta pairs with a single exc alpha
! ! ------------------------------------------------------
! if (is_single_a(lrow)) then
!
! tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int,lrow)
!
! ! Build list of singly excited beta
! ! ---------------------------------
!
! m_b = psi_bilinear_matrix_order_reverse(l_a)
! m_b = m_b+1
! j=1
! do while ( (mrow == lrow) )
! mcol = psi_bilinear_matrix_transp_columns(m_b)
! buffer(1:N_int,j) = psi_det_beta_unique(1:N_int,mcol)
! idx(j) = mcol
! j = j+1
! m_b = m_b+1
! if (m_b <= N_det) exit
! mrow = psi_bilinear_matrix_transp_rows(m_b)
! enddo
! j=j-1
!
! call get_all_spin_singles( &
! buffer, idx, tmp_det(1,2), N_int, j, &
! doubles, n_doubles)
!
! ! Compute Hij for all doubles
! ! ---------------------------
!
! m_b = psi_bilinear_matrix_order(l_a)+1
! mcol = psi_bilinear_matrix_transp_columns(m_b)
! do j=1,n_doubles
! tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, doubles(j) )
! call i_H_j_double_alpha_beta(tmp_det,tmp_det2,N_int,hij)
! do while (mcol /= doubles(j))
! m_b = m_b+1
! if (m_b > N_det) exit
! mcol = psi_bilinear_matrix_transp_columns(m_b)
! enddo
! m_a = psi_bilinear_matrix_order_reverse(m_b)
! v_0(m_a, 1:N_st) += hij * psi_bilinear_matrix_values(k_a,1:N_st) ! v_0(m_a, 1:N_st) += hij * psi_bilinear_matrix_values(k_a,1:N_st)
! v_0(k_a, 1:N_st) += hij * psi_bilinear_matrix_values(m_a,1:N_st) ! v_0(k_a, 1:N_st) += hij * psi_bilinear_matrix_values(m_a,1:N_st)
enddo ! enddo
!
endif ! endif
l_a = l_a+1 ! l_a = l_a+1
if (l_a > N_det) exit ! if (l_a > N_det) exit
lrow = psi_bilinear_matrix_rows(l_a) ! lrow = psi_bilinear_matrix_rows(l_a)
lcol = psi_bilinear_matrix_columns(l_a) ! lcol = psi_bilinear_matrix_columns(l_a)
enddo ! enddo
!
k_b = k_b+1 ! k_b = k_b+1
if (k_b > N_det) exit ! if (k_b > N_det) exit
kcol = psi_bilinear_matrix_transp_columns(k_b) ! kcol = psi_bilinear_matrix_transp_columns(k_b)
enddo ! enddo
!
do j=1,n_singles ! do j=1,n_singles
is_single_a( singles(j) ) = .False. ! is_single_a( singles(j) ) = .False.
enddo ! enddo
!
enddo ! enddo
end end
@ -946,7 +1027,7 @@ subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze
integer :: degree integer :: degree
integer :: exc(0:2,2,2) integer :: exc(0:2,2,2)
call get_excitation(keys_tmp(1,1,j),keys_tmp(1,1,i),exc,degree,phase,Nint) call get_excitation(keys_tmp(1,1,j),keys_tmp(1,1,i),exc,degree,phase,Nint)
if ((degree == 2).and.(exc(0,1,1)==1)) cycle ! if ((degree == 2).and.(exc(0,1,1)==1)) cycle
! if ((degree > 1)) cycle ! if ((degree > 1)) cycle
! if (exc(0,1,2) /= 0) cycle ! if (exc(0,1,2) /= 0) cycle
call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij)

5
src/Determinants/slater_rules.irp.f
View File

@ -2566,13 +2566,14 @@ subroutine i_H_j_double_alpha_beta(key_i,key_j,Nint,hij)
double precision, intent(out) :: hij double precision, intent(out) :: hij
integer :: exc(0:2,2,2) integer :: exc(0:2,2,2)
double precision :: phase double precision :: phase, phase2
double precision, external :: get_mo_bielec_integral double precision, external :: get_mo_bielec_integral
PROVIDE big_array_exchange_integrals mo_bielec_integrals_in_map PROVIDE big_array_exchange_integrals mo_bielec_integrals_in_map
call get_mono_excitation_spin(key_i(1,1),key_j(1,1),exc(0,1,1),phase,Nint) call get_mono_excitation_spin(key_i(1,1),key_j(1,1),exc(0,1,1),phase,Nint)
call get_mono_excitation_spin(key_i(1,2),key_j(1,2),exc(0,1,2),phase,Nint) call get_mono_excitation_spin(key_i(1,2),key_j(1,2),exc(0,1,2),phase2,Nint)
phase = phase*phase2
if (exc(1,1,1) == exc(1,2,2)) then 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)) 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 else if (exc(1,2,1) == exc(1,1,2)) then

12
src/Determinants/spindeterminants.irp.f
View File

@ -389,6 +389,7 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states)
&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_rows , (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_rows , (N_det) ]
&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns, (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns, (N_det) ]
&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order , (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order , (N_det) ]
&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns_loc, (N_det_beta_unique+1) ]
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -428,6 +429,17 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states)
do l=1,N_states do l=1,N_states
call dset_order(psi_bilinear_matrix_values(1,l),psi_bilinear_matrix_order,N_det) call dset_order(psi_bilinear_matrix_values(1,l),psi_bilinear_matrix_order,N_det)
enddo enddo
psi_bilinear_matrix_columns_loc(1:N_det_beta_unique) = -1
psi_bilinear_matrix_columns_loc(1) = 1
do k=2,N_det
if (psi_bilinear_matrix_columns(k) == psi_bilinear_matrix_columns(k-1)) then
cycle
else
l = psi_bilinear_matrix_columns(k)
psi_bilinear_matrix_columns_loc(l) = k
endif
enddo
psi_bilinear_matrix_columns_loc(N_det_beta_unique+1) = N_det+1
deallocate(to_sort) deallocate(to_sort)
END_PROVIDER END_PROVIDER