mirror of
https://github.com/LCPQ/quantum_package
synced 2025-01-03 10:05:57 +01:00
New Davidson OK
This commit is contained in:
parent
3a824d5d0a
commit
23685ab5d0
@ -668,6 +668,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8)
|
|||||||
logical, allocatable :: is_single_b(:)
|
logical, allocatable :: is_single_b(:)
|
||||||
integer :: maxab, n_singles_max
|
integer :: maxab, n_singles_max
|
||||||
double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:)
|
double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:)
|
||||||
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: v_t, s_t, u_t
|
||||||
|
|
||||||
maxab = max(N_det_alpha_unique, N_det_beta_unique)
|
maxab = max(N_det_alpha_unique, N_det_beta_unique)
|
||||||
allocate( buffer(N_int,maxab), &
|
allocate( buffer(N_int,maxab), &
|
||||||
@ -681,18 +682,12 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8)
|
|||||||
idx0(i) = i
|
idx0(i) = i
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! call dtranspose( &
|
call dtranspose( &
|
||||||
! u_0, &
|
u_0, &
|
||||||
! size(u_0, 1), &
|
size(u_0, 1), &
|
||||||
! u_t, &
|
u_t, &
|
||||||
! size(u_t, 1), &
|
size(u_t, 1), &
|
||||||
! N_det, N_st)
|
N_det, N_st)
|
||||||
!
|
|
||||||
do k=1,N_det
|
|
||||||
do l=1,N_st
|
|
||||||
u_t(l,k) = u_0(k,l)
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
|
|
||||||
! Prepare the array of all alpha single excitations
|
! Prepare the array of all alpha single excitations
|
||||||
! -------------------------------------------------
|
! -------------------------------------------------
|
||||||
@ -770,8 +765,8 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8)
|
|||||||
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_mono_spin( tmp_det, tmp_det2, N_int, 1, hij)
|
call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 1, hij)
|
||||||
do l=1,N_st
|
do l=1,N_st
|
||||||
v_t(l,l_a) += hij * u_t(l,k_a)
|
v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a)
|
||||||
v_t(l,k_a) += hij * u_t(l,l_a)
|
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
|
||||||
! single => sij = 0
|
! single => sij = 0
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -788,8 +783,8 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8)
|
|||||||
enddo
|
enddo
|
||||||
call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, doubles(i)), N_int, hij)
|
call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, doubles(i)), N_int, hij)
|
||||||
do l=1,N_st
|
do l=1,N_st
|
||||||
v_t(l,l_a) += hij * u_t(l,k_a)
|
v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a)
|
||||||
v_t(l,k_a) += hij * u_t(l,l_a)
|
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
|
||||||
! same spin => sij = 0
|
! same spin => sij = 0
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -836,8 +831,8 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8)
|
|||||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 2, hij)
|
call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 2, hij)
|
||||||
do l=1,N_st
|
do l=1,N_st
|
||||||
v_t(l,l_a) += hij * u_t(l,k_a)
|
v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a)
|
||||||
v_t(l,k_a) += hij * u_t(l,l_a)
|
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
|
||||||
! single => sij = 0
|
! single => sij = 0
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -855,8 +850,8 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8)
|
|||||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, doubles(i)), N_int, hij)
|
call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, doubles(i)), N_int, hij)
|
||||||
do l=1,N_st
|
do l=1,N_st
|
||||||
v_t(l,l_a) += hij * u_t(l,k_a)
|
v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a)
|
||||||
v_t(l,k_a) += hij * u_t(l,l_a)
|
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
|
||||||
! same spin => sij = 0
|
! same spin => sij = 0
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -867,15 +862,20 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8)
|
|||||||
! Alpha/Beta double excitations
|
! Alpha/Beta double excitations
|
||||||
! =============================
|
! =============================
|
||||||
|
|
||||||
|
is_single_a = .False.
|
||||||
|
krow = 1
|
||||||
do k_a=1,N_det
|
do k_a=1,N_det
|
||||||
|
|
||||||
|
do k=1,singles_a(0,krow)
|
||||||
|
is_single_a( singles_a(k,krow) ) = .False.
|
||||||
|
enddo
|
||||||
|
|
||||||
krow = psi_bilinear_matrix_rows(k_a)
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
kcol = psi_bilinear_matrix_columns(k_a)
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
|
||||||
tmp_det(1:N_int,1) = psi_det_alpha_unique(1:N_int, krow)
|
tmp_det(1:N_int,1) = psi_det_alpha_unique(1:N_int, krow)
|
||||||
tmp_det(1:N_int,2) = psi_det_beta_unique (1:N_int, kcol)
|
tmp_det(1:N_int,2) = psi_det_beta_unique (1:N_int, kcol)
|
||||||
|
|
||||||
is_single_a = .False.
|
|
||||||
do k=1,singles_a(0,krow)
|
do k=1,singles_a(0,krow)
|
||||||
is_single_a( singles_a(k,krow) ) = .True.
|
is_single_a( singles_a(k,krow) ) = .True.
|
||||||
enddo
|
enddo
|
||||||
@ -906,23 +906,33 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8)
|
|||||||
l_a += 1
|
l_a += 1
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
n_doubles=0
|
||||||
do while ( l_a < psi_bilinear_matrix_columns_loc(lcol+1) )
|
do while ( l_a < psi_bilinear_matrix_columns_loc(lcol+1) )
|
||||||
lrow = psi_bilinear_matrix_rows(l_a)
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
if (is_single_a(lrow)) then
|
if (.not.is_single_a(lrow)) then
|
||||||
tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow)
|
continue
|
||||||
|
else
|
||||||
call i_H_j_double_alpha_beta(tmp_det,tmp_det2,N_int,hij)
|
n_doubles = n_doubles+1
|
||||||
call get_s2(tmp_det,tmp_det2,N_int,sij)
|
doubles(n_doubles) = lrow
|
||||||
do l=1,N_st
|
idx(n_doubles) = l_a
|
||||||
v_t(l,k_a) += hij * u_t(l,l_a)
|
|
||||||
v_t(l,l_a) += hij * u_t(l,k_a)
|
|
||||||
s_t(l,k_a) += sij * u_t(l,l_a)
|
|
||||||
s_t(l,l_a) += sij * u_t(l,k_a)
|
|
||||||
enddo
|
|
||||||
endif
|
endif
|
||||||
l_a += 1
|
l_a = l_a+1
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
do k=1,n_doubles
|
||||||
|
lrow = doubles(k)
|
||||||
|
l_a = idx(k)
|
||||||
|
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)
|
||||||
|
call get_s2(tmp_det,tmp_det2,N_int,sij)
|
||||||
|
do l=1,N_st
|
||||||
|
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
|
||||||
|
v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a)
|
||||||
|
s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a)
|
||||||
|
s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! Diagonal contribution
|
! Diagonal contribution
|
||||||
@ -939,25 +949,19 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8)
|
|||||||
|
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! call dtranspose( &
|
call dtranspose( &
|
||||||
! v_t, &
|
v_t, &
|
||||||
! size(v_t, 1), &
|
size(v_t, 1), &
|
||||||
! v_0, &
|
v_0, &
|
||||||
! size(v_0, 1), &
|
size(v_0, 1), &
|
||||||
! N_st, N_det)
|
N_st, N_det)
|
||||||
!
|
|
||||||
! call dtranspose( &
|
call dtranspose( &
|
||||||
! s_t, &
|
s_t, &
|
||||||
! size(s_t, 1), &
|
size(s_t, 1), &
|
||||||
! s_0, &
|
s_0, &
|
||||||
! size(s_0, 1), &
|
size(s_0, 1), &
|
||||||
! N_st, N_det)
|
N_st, N_det)
|
||||||
do k=1,N_det
|
|
||||||
do l=1,N_st
|
|
||||||
v_0(k,l) = v_t(l,k)
|
|
||||||
s_0(k,l) = s_t(l,k)
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user