added tc_bi_ortho
This commit is contained in:
eginer
parent
00081668f2
commit
5bd19df0bc
|
|
@ -0,0 +1,500 @@
|
|||
|
||||
! ---
|
||||
|
||||
subroutine davidson_general_diag_dressed_ext_rout_nonsym_b1space(u_in, H_jj, Dress_jj,energies, sze, N_st, N_st_diag_in, converged, hcalc)
|
||||
|
||||
use mmap_module
|
||||
|
||||
BEGIN_DOC
|
||||
! Generic modified-Davidson diagonalization
|
||||
!
|
||||
! H_jj : specific diagonal H matrix elements to diagonalize de Davidson
|
||||
!
|
||||
! u_in : guess coefficients on the various states. Overwritten on exit by right eigenvectors
|
||||
!
|
||||
! sze : Number of determinants
|
||||
!
|
||||
! N_st : Number of eigenstates
|
||||
!
|
||||
! N_st_diag_in : Number of states in which H is diagonalized. Assumed > N_st
|
||||
!
|
||||
! Initial guess vectors are not necessarily orthonormal
|
||||
!
|
||||
! hcalc subroutine to compute W = H U (see routine hcalc_template for template of input/output)
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: sze, N_st, N_st_diag_in
|
||||
double precision, intent(in) :: H_jj(sze),Dress_jj(sze)
|
||||
logical, intent(inout) :: converged
|
||||
double precision, intent(inout) :: u_in(sze,N_st_diag_in)
|
||||
double precision, intent(out) :: energies(N_st)
|
||||
external hcalc
|
||||
|
||||
character*(16384) :: write_buffer
|
||||
integer :: iter, N_st_diag
|
||||
integer :: i, j, k, l, m
|
||||
integer :: iter2, itertot
|
||||
logical :: disk_based
|
||||
integer :: shift, shift2, itermax
|
||||
integer :: nproc_target
|
||||
integer :: order(N_st_diag_in)
|
||||
double precision :: to_print(2,N_st)
|
||||
double precision :: r1, r2, alpha
|
||||
double precision :: cpu, wall
|
||||
double precision :: cmax
|
||||
double precision :: energy_shift(N_st_diag_in*davidson_sze_max)
|
||||
double precision, allocatable :: U(:,:)
|
||||
double precision, allocatable :: y(:,:), h(:,:), lambda(:)
|
||||
double precision, allocatable :: residual_norm(:)
|
||||
|
||||
double precision :: lambda_tmp
|
||||
integer, allocatable :: i_omax(:)
|
||||
double precision, allocatable :: U_tmp(:), overlap(:)
|
||||
|
||||
double precision, allocatable :: W(:,:)
|
||||
!double precision, pointer :: W(:,:)
|
||||
double precision, external :: u_dot_v, u_dot_u
|
||||
|
||||
|
||||
include 'constants.include.F'
|
||||
|
||||
N_st_diag = N_st_diag_in
|
||||
! print*,'trial vector'
|
||||
do i = 1, sze
|
||||
if(isnan(u_in(i,1)))then
|
||||
print*,'pb in input vector of davidson_general_ext_rout_nonsym_b1space'
|
||||
print*,i,u_in(i,1)
|
||||
stop
|
||||
else if (dabs(u_in(i,1)).lt.1.d-16)then
|
||||
u_in(i,1) = 0.d0
|
||||
endif
|
||||
enddo
|
||||
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, y, h, lambda
|
||||
if(N_st_diag*3 > sze) then
|
||||
print *, 'error in Davidson :'
|
||||
print *, 'Increase n_det_max_full to ', N_st_diag*3
|
||||
stop -1
|
||||
endif
|
||||
|
||||
itermax = max(2, min(davidson_sze_max, sze/N_st_diag)) + 1
|
||||
|
||||
provide threshold_nonsym_davidson
|
||||
call write_time(6)
|
||||
write(6,'(A)') ''
|
||||
write(6,'(A)') 'Davidson Diagonalization'
|
||||
write(6,'(A)') '------------------------'
|
||||
write(6,'(A)') ''
|
||||
|
||||
|
||||
! Find max number of cores to fit in memory
|
||||
! -----------------------------------------
|
||||
|
||||
nproc_target = nproc
|
||||
double precision :: rss
|
||||
integer :: maxab
|
||||
maxab = sze
|
||||
|
||||
m=1
|
||||
disk_based = .False.
|
||||
call resident_memory(rss)
|
||||
do
|
||||
r1 = 8.d0 * &! bytes
|
||||
( dble(sze)*(N_st_diag*itermax) &! U
|
||||
+ 1.d0*dble(sze*m)*(N_st_diag*itermax) &! W
|
||||
+ 2.d0*(N_st_diag*itermax)**2 &! h,y
|
||||
+ 2.d0*(N_st_diag*itermax) &! s2,lambda
|
||||
+ 1.d0*(N_st_diag) &! residual_norm
|
||||
! In H_S2_u_0_nstates_zmq
|
||||
+ 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on collector
|
||||
+ 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on slave
|
||||
+ 0.5d0*maxab &! idx0 in H_S2_u_0_nstates_openmp_work_*
|
||||
+ nproc_target * &! In OMP section
|
||||
( 1.d0*(N_int*maxab) &! buffer
|
||||
+ 3.5d0*(maxab) ) &! singles_a, singles_b, doubles, idx
|
||||
) / 1024.d0**3
|
||||
|
||||
if(nproc_target == 0) then
|
||||
call check_mem(r1, irp_here)
|
||||
nproc_target = 1
|
||||
exit
|
||||
endif
|
||||
|
||||
if(r1+rss < qp_max_mem) then
|
||||
exit
|
||||
endif
|
||||
|
||||
if(itermax > 4) then
|
||||
itermax = itermax - 1
|
||||
else if (m==1.and.disk_based_davidson) then
|
||||
m = 0
|
||||
disk_based = .True.
|
||||
itermax = 6
|
||||
else
|
||||
nproc_target = nproc_target - 1
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
nthreads_davidson = nproc_target
|
||||
TOUCH nthreads_davidson
|
||||
|
||||
call write_int(6, N_st, 'Number of states')
|
||||
call write_int(6, N_st_diag, 'Number of states in diagonalization')
|
||||
call write_int(6, sze, 'Number of basis functions')
|
||||
call write_int(6, nproc_target, 'Number of threads for diagonalization')
|
||||
call write_double(6, r1, 'Memory(Gb)')
|
||||
if(disk_based) then
|
||||
print *, 'Using swap space to reduce RAM'
|
||||
endif
|
||||
|
||||
!---------------
|
||||
|
||||
write(6,'(A)') ''
|
||||
write_buffer = '====='
|
||||
do i=1,N_st
|
||||
write_buffer = trim(write_buffer)//' ================ ==========='
|
||||
enddo
|
||||
write(6,'(A)') write_buffer(1:6+41*N_st)
|
||||
write_buffer = 'Iter'
|
||||
do i=1,N_st
|
||||
write_buffer = trim(write_buffer)//' Energy Residual '
|
||||
enddo
|
||||
write(6,'(A)') write_buffer(1:6+41*N_st)
|
||||
write_buffer = '====='
|
||||
do i=1,N_st
|
||||
write_buffer = trim(write_buffer)//' ================ ==========='
|
||||
enddo
|
||||
write(6,'(A)') write_buffer(1:6+41*N_st)
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
allocate( W(sze,N_st_diag*itermax) )
|
||||
|
||||
allocate( &
|
||||
! Large
|
||||
U(sze,N_st_diag*itermax), &
|
||||
! Small
|
||||
h(N_st_diag*itermax,N_st_diag*itermax), &
|
||||
y(N_st_diag*itermax,N_st_diag*itermax), &
|
||||
lambda(N_st_diag*itermax), &
|
||||
residual_norm(N_st_diag), &
|
||||
i_omax(N_st) &
|
||||
)
|
||||
|
||||
U = 0.d0
|
||||
h = 0.d0
|
||||
y = 0.d0
|
||||
lambda = 0.d0
|
||||
residual_norm = 0.d0
|
||||
|
||||
|
||||
ASSERT (N_st > 0)
|
||||
ASSERT (N_st_diag >= N_st)
|
||||
ASSERT (sze > 0)
|
||||
|
||||
! Davidson iterations
|
||||
! ===================
|
||||
|
||||
converged = .False.
|
||||
|
||||
! Initialize from N_st to N_st_diag with gaussian random numbers
|
||||
! to be sure to have overlap with any eigenvectors
|
||||
do k = N_st+1, N_st_diag
|
||||
u_in(k,k) = 10.d0
|
||||
do i = 1, sze
|
||||
call random_number(r1)
|
||||
call random_number(r2)
|
||||
r1 = dsqrt(-2.d0*dlog(r1))
|
||||
r2 = dtwo_pi*r2
|
||||
u_in(i,k) = r1*dcos(r2)
|
||||
enddo
|
||||
enddo
|
||||
! Normalize all states
|
||||
do k = 1, N_st_diag
|
||||
call normalize(u_in(1,k), sze)
|
||||
enddo
|
||||
|
||||
! Copy from the guess input "u_in" to the working vectors "U"
|
||||
do k = 1, N_st_diag
|
||||
do i = 1, sze
|
||||
U(i,k) = u_in(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
itertot = 0
|
||||
|
||||
do while (.not.converged)
|
||||
|
||||
itertot = itertot + 1
|
||||
if(itertot == 8) then
|
||||
exit
|
||||
endif
|
||||
|
||||
do iter = 1, itermax-1
|
||||
|
||||
shift = N_st_diag * (iter-1)
|
||||
shift2 = N_st_diag * iter
|
||||
|
||||
if( (iter > 1) .or. (itertot == 1) ) then
|
||||
|
||||
! Gram-Schmidt to orthogonalize all new guess with the previous vectors
|
||||
call ortho_qr(U, size(U, 1), sze, shift2)
|
||||
call ortho_qr(U, size(U, 1), sze, shift2)
|
||||
|
||||
! W = H U
|
||||
call hcalc(W(1,shift+1), U(1,shift+1), N_st_diag, sze)
|
||||
call dress_calc(W(1,shift+1), Dress_jj, U(1,shift+1), N_st_diag, sze)
|
||||
|
||||
else
|
||||
|
||||
! Already computed in update below
|
||||
continue
|
||||
endif
|
||||
|
||||
! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>
|
||||
! -------------------------------------------
|
||||
call dgemm( 'T', 'N', shift2, shift2, sze, 1.d0 &
|
||||
, U, size(U, 1), W, size(W, 1) &
|
||||
, 0.d0, h, size(h, 1) )
|
||||
|
||||
|
||||
! Diagonalize h y = lambda y
|
||||
! ---------------------------
|
||||
call diag_nonsym_right(shift2, h(1,1), size(h, 1), y(1,1), size(y, 1), lambda(1), size(lambda, 1))
|
||||
|
||||
|
||||
! Express eigenvectors of h in the determinant basis:
|
||||
! ---------------------------------------------------
|
||||
|
||||
! y(:,k) = rk
|
||||
! U(:,k) = Bk
|
||||
! U(:,shift2+k) = Rk = Bk x rk
|
||||
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
|
||||
, U, size(U, 1), y, size(y, 1) &
|
||||
, 0.d0, U(1,shift2+1), size(U, 1) )
|
||||
|
||||
do k = 1, N_st_diag
|
||||
call normalize(U(1,shift2+k), sze)
|
||||
enddo
|
||||
|
||||
! ---
|
||||
! select the max overlap
|
||||
|
||||
!
|
||||
! start test ------------------------------------------------------------------------
|
||||
!
|
||||
!double precision, allocatable :: Utest(:,:), Otest(:)
|
||||
!allocate( Utest(sze,shift2), Otest(shift2) )
|
||||
|
||||
!call dgemm( 'N', 'N', sze, shift2, shift2, 1.d0 &
|
||||
! , U, size(U, 1), y, size(y, 1), 0.d0, Utest(1,1), size(Utest, 1) )
|
||||
!do k = 1, shift2
|
||||
! call normalize(Utest(1,k), sze)
|
||||
!enddo
|
||||
!do j = 1, sze
|
||||
! write(455, '(100(1X, F16.10))') (Utest(j,k), k=1,shift2)
|
||||
!enddo
|
||||
|
||||
!do k = 1, shift2
|
||||
! Otest(k) = 0.d0
|
||||
! do i = 1, sze
|
||||
! Otest(k) += Utest(i,k) * u_in(i,1)
|
||||
! enddo
|
||||
! Otest(k) = dabs(Otest(k))
|
||||
! print *, ' Otest =', k, Otest(k), lambda(k)
|
||||
!enddo
|
||||
|
||||
!deallocate(Utest, Otest)
|
||||
!
|
||||
! end test ------------------------------------------------------------------------
|
||||
!
|
||||
|
||||
! TODO
|
||||
! state_following is more efficient
|
||||
do l = 1, N_st
|
||||
|
||||
allocate( overlap(N_st_diag) )
|
||||
|
||||
do k = 1, N_st_diag
|
||||
overlap(k) = 0.d0
|
||||
do i = 1, sze
|
||||
overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,l)
|
||||
enddo
|
||||
overlap(k) = dabs(overlap(k))
|
||||
!print *, ' overlap =', k, overlap(k)
|
||||
enddo
|
||||
|
||||
lambda_tmp = 0.d0
|
||||
do k = 1, N_st_diag
|
||||
if(overlap(k) .gt. lambda_tmp) then
|
||||
i_omax(l) = k
|
||||
lambda_tmp = overlap(k)
|
||||
endif
|
||||
enddo
|
||||
|
||||
deallocate(overlap)
|
||||
|
||||
if(lambda_tmp .lt. 0.7d0) then
|
||||
print *, ' very small overlap ...', l, i_omax(l)
|
||||
print *, ' max overlap = ', lambda_tmp
|
||||
stop
|
||||
endif
|
||||
|
||||
if(i_omax(l) .ne. l) then
|
||||
print *, ' !!! WARNONG !!!'
|
||||
print *, ' index of state', l, i_omax(l)
|
||||
endif
|
||||
enddo
|
||||
|
||||
! y(:,k) = rk
|
||||
! W(:,k) = H x Bk
|
||||
! W(:,shift2+k) = H x Bk x rk
|
||||
! = Wk
|
||||
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
|
||||
, W, size(W, 1), y, size(y, 1) &
|
||||
, 0.d0, W(1,shift2+1), size(W, 1) )
|
||||
|
||||
! ---
|
||||
|
||||
! Compute residual vector and davidson step
|
||||
! -----------------------------------------
|
||||
|
||||
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k)
|
||||
do k = 1, N_st_diag
|
||||
do i = 1, sze
|
||||
U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2)
|
||||
enddo
|
||||
if(k <= N_st) then
|
||||
l = k
|
||||
residual_norm(k) = u_dot_u(U(1,shift2+l), sze)
|
||||
to_print(1,k) = lambda(l)
|
||||
to_print(2,k) = residual_norm(l)
|
||||
endif
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
!residual_norm(1) = u_dot_u(U(1,shift2+1), sze)
|
||||
!to_print(1,1) = lambda(1)
|
||||
!to_print(2,1) = residual_norm(1)
|
||||
|
||||
|
||||
if( (itertot > 1) .and. (iter == 1) ) then
|
||||
!don't print
|
||||
continue
|
||||
else
|
||||
write(*, '(1X, I3, 1X, 100(1X, F16.10, 1X, F16.10, 1X, F16.10))') iter-1, to_print(1:2,1:N_st)
|
||||
endif
|
||||
|
||||
! Check convergence
|
||||
if(iter > 1) then
|
||||
converged = dabs(maxval(residual_norm(1:N_st))) < threshold_nonsym_davidson
|
||||
endif
|
||||
|
||||
do k = 1, N_st
|
||||
if(residual_norm(k) > 1.e8) then
|
||||
print *, 'Davidson failed'
|
||||
stop -1
|
||||
endif
|
||||
enddo
|
||||
if(converged) then
|
||||
exit
|
||||
endif
|
||||
|
||||
logical, external :: qp_stop
|
||||
if(qp_stop()) then
|
||||
converged = .True.
|
||||
exit
|
||||
endif
|
||||
|
||||
enddo ! loop over iter
|
||||
|
||||
|
||||
! Re-contract U and update W
|
||||
! --------------------------------
|
||||
|
||||
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
|
||||
, W, size(W, 1), y, size(y, 1) &
|
||||
, 0.d0, u_in, size(u_in, 1) )
|
||||
do k = 1, N_st_diag
|
||||
do i = 1, sze
|
||||
W(i,k) = u_in(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
|
||||
, U, size(U, 1), y, size(y, 1) &
|
||||
, 0.d0, u_in, size(u_in, 1) )
|
||||
do k = 1, N_st_diag
|
||||
do i = 1, sze
|
||||
U(i,k) = u_in(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call ortho_qr(U, size(U, 1), sze, N_st_diag)
|
||||
call ortho_qr(U, size(U, 1), sze, N_st_diag)
|
||||
do j = 1, N_st_diag
|
||||
k = 1
|
||||
do while( (k < sze) .and. (U(k,j) == 0.d0) )
|
||||
k = k+1
|
||||
enddo
|
||||
if(U(k,j) * u_in(k,j) < 0.d0) then
|
||||
do i = 1, sze
|
||||
W(i,j) = -W(i,j)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
enddo ! loop over while
|
||||
|
||||
! ---
|
||||
|
||||
do k = 1, N_st
|
||||
energies(k) = lambda(k)
|
||||
enddo
|
||||
write_buffer = '====='
|
||||
do i = 1, N_st
|
||||
write_buffer = trim(write_buffer)//' ================ ==========='
|
||||
enddo
|
||||
write(6,'(A)') trim(write_buffer)
|
||||
write(6,'(A)') ''
|
||||
call write_time(6)
|
||||
|
||||
deallocate(W)
|
||||
deallocate(U, h, y, lambda, residual_norm, i_omax)
|
||||
|
||||
FREE nthreads_davidson
|
||||
|
||||
end subroutine davidson_general_ext_rout_nonsym_b1space
|
||||
|
||||
! ---
|
||||
|
||||
subroutine dress_calc(v,dress,u,N_st,sze)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computed the action of the diagonal dressing dress
|
||||
!
|
||||
! WARNING :: v is not initialiazed !!!
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze
|
||||
double precision, intent(in) :: u(sze,N_st),dress(sze)
|
||||
double precision, intent(inout) :: v(sze,N_st)
|
||||
integer :: i,istate
|
||||
|
||||
do istate = 1, N_st
|
||||
do i = 1, sze
|
||||
v(i,istate) += dress(i) * u(i,istate)
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,473 @@
|
|||
|
||||
! ---
|
||||
|
||||
subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N_st, N_st_diag_in, converged, hcalc)
|
||||
|
||||
use mmap_module
|
||||
|
||||
BEGIN_DOC
|
||||
! Generic modified-Davidson diagonalization
|
||||
!
|
||||
! H_jj : specific diagonal H matrix elements to diagonalize de Davidson
|
||||
!
|
||||
! u_in : guess coefficients on the various states. Overwritten on exit by right eigenvectors
|
||||
!
|
||||
! sze : Number of determinants
|
||||
!
|
||||
! N_st : Number of eigenstates
|
||||
!
|
||||
! N_st_diag_in : Number of states in which H is diagonalized. Assumed > N_st
|
||||
!
|
||||
! Initial guess vectors are not necessarily orthonormal
|
||||
!
|
||||
! hcalc subroutine to compute W = H U (see routine hcalc_template for template of input/output)
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: sze, N_st, N_st_diag_in
|
||||
double precision, intent(in) :: H_jj(sze)
|
||||
logical, intent(inout) :: converged
|
||||
double precision, intent(inout) :: u_in(sze,N_st_diag_in)
|
||||
double precision, intent(out) :: energies(N_st)
|
||||
external hcalc
|
||||
|
||||
character*(16384) :: write_buffer
|
||||
integer :: iter, N_st_diag
|
||||
integer :: i, j, k, l, m
|
||||
integer :: iter2, itertot
|
||||
logical :: disk_based
|
||||
integer :: shift, shift2, itermax
|
||||
integer :: nproc_target
|
||||
integer :: order(N_st_diag_in)
|
||||
double precision :: to_print(2,N_st)
|
||||
double precision :: r1, r2, alpha
|
||||
double precision :: cpu, wall
|
||||
double precision :: cmax
|
||||
double precision :: energy_shift(N_st_diag_in*davidson_sze_max)
|
||||
double precision, allocatable :: U(:,:)
|
||||
double precision, allocatable :: y(:,:), h(:,:), lambda(:)
|
||||
double precision, allocatable :: residual_norm(:)
|
||||
|
||||
double precision :: lambda_tmp
|
||||
integer, allocatable :: i_omax(:)
|
||||
double precision, allocatable :: U_tmp(:), overlap(:)
|
||||
|
||||
double precision, allocatable :: W(:,:)
|
||||
!double precision, pointer :: W(:,:)
|
||||
double precision, external :: u_dot_v, u_dot_u
|
||||
|
||||
|
||||
include 'constants.include.F'
|
||||
|
||||
N_st_diag = N_st_diag_in
|
||||
! print*,'trial vector'
|
||||
do i = 1, sze
|
||||
if(isnan(u_in(i,1)))then
|
||||
print*,'pb in input vector of davidson_general_ext_rout_nonsym_b1space'
|
||||
print*,i,u_in(i,1)
|
||||
stop
|
||||
else if (dabs(u_in(i,1)).lt.1.d-16)then
|
||||
u_in(i,1) = 0.d0
|
||||
endif
|
||||
enddo
|
||||
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, y, h, lambda
|
||||
if(N_st_diag*3 > sze) then
|
||||
print *, 'error in Davidson :'
|
||||
print *, 'Increase n_det_max_full to ', N_st_diag*3
|
||||
stop -1
|
||||
endif
|
||||
|
||||
itermax = max(2, min(davidson_sze_max, sze/N_st_diag)) + 1
|
||||
|
||||
provide threshold_nonsym_davidson
|
||||
call write_time(6)
|
||||
write(6,'(A)') ''
|
||||
write(6,'(A)') 'Davidson Diagonalization'
|
||||
write(6,'(A)') '------------------------'
|
||||
write(6,'(A)') ''
|
||||
|
||||
|
||||
! Find max number of cores to fit in memory
|
||||
! -----------------------------------------
|
||||
|
||||
nproc_target = nproc
|
||||
double precision :: rss
|
||||
integer :: maxab
|
||||
maxab = sze
|
||||
|
||||
m=1
|
||||
disk_based = .False.
|
||||
call resident_memory(rss)
|
||||
do
|
||||
r1 = 8.d0 * &! bytes
|
||||
( dble(sze)*(N_st_diag*itermax) &! U
|
||||
+ 1.d0*dble(sze*m)*(N_st_diag*itermax) &! W
|
||||
+ 2.d0*(N_st_diag*itermax)**2 &! h,y
|
||||
+ 2.d0*(N_st_diag*itermax) &! s2,lambda
|
||||
+ 1.d0*(N_st_diag) &! residual_norm
|
||||
! In H_S2_u_0_nstates_zmq
|
||||
+ 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on collector
|
||||
+ 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on slave
|
||||
+ 0.5d0*maxab &! idx0 in H_S2_u_0_nstates_openmp_work_*
|
||||
+ nproc_target * &! In OMP section
|
||||
( 1.d0*(N_int*maxab) &! buffer
|
||||
+ 3.5d0*(maxab) ) &! singles_a, singles_b, doubles, idx
|
||||
) / 1024.d0**3
|
||||
|
||||
if(nproc_target == 0) then
|
||||
call check_mem(r1, irp_here)
|
||||
nproc_target = 1
|
||||
exit
|
||||
endif
|
||||
|
||||
if(r1+rss < qp_max_mem) then
|
||||
exit
|
||||
endif
|
||||
|
||||
if(itermax > 4) then
|
||||
itermax = itermax - 1
|
||||
! else if (m==1.and.disk_based_davidson) then
|
||||
! m = 0
|
||||
! disk_based = .True.
|
||||
! itermax = 6
|
||||
else
|
||||
nproc_target = nproc_target - 1
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
nthreads_davidson = nproc_target
|
||||
TOUCH nthreads_davidson
|
||||
|
||||
call write_int(6, N_st, 'Number of states')
|
||||
call write_int(6, N_st_diag, 'Number of states in diagonalization')
|
||||
call write_int(6, sze, 'Number of basis functions')
|
||||
call write_int(6, nproc_target, 'Number of threads for diagonalization')
|
||||
call write_double(6, r1, 'Memory(Gb)')
|
||||
if(disk_based) then
|
||||
print *, 'Using swap space to reduce RAM'
|
||||
endif
|
||||
|
||||
!---------------
|
||||
|
||||
write(6,'(A)') ''
|
||||
write_buffer = '====='
|
||||
do i=1,N_st
|
||||
write_buffer = trim(write_buffer)//' ================ ==========='
|
||||
enddo
|
||||
write(6,'(A)') write_buffer(1:6+41*N_st)
|
||||
write_buffer = 'Iter'
|
||||
do i=1,N_st
|
||||
write_buffer = trim(write_buffer)//' Energy Residual '
|
||||
enddo
|
||||
write(6,'(A)') write_buffer(1:6+41*N_st)
|
||||
write_buffer = '====='
|
||||
do i=1,N_st
|
||||
write_buffer = trim(write_buffer)//' ================ ==========='
|
||||
enddo
|
||||
write(6,'(A)') write_buffer(1:6+41*N_st)
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
allocate( W(sze,N_st_diag*itermax) )
|
||||
|
||||
allocate( &
|
||||
! Large
|
||||
U(sze,N_st_diag*itermax), &
|
||||
! Small
|
||||
h(N_st_diag*itermax,N_st_diag*itermax), &
|
||||
y(N_st_diag*itermax,N_st_diag*itermax), &
|
||||
lambda(N_st_diag*itermax), &
|
||||
residual_norm(N_st_diag), &
|
||||
i_omax(N_st) &
|
||||
)
|
||||
|
||||
U = 0.d0
|
||||
h = 0.d0
|
||||
y = 0.d0
|
||||
lambda = 0.d0
|
||||
residual_norm = 0.d0
|
||||
|
||||
|
||||
ASSERT (N_st > 0)
|
||||
ASSERT (N_st_diag >= N_st)
|
||||
ASSERT (sze > 0)
|
||||
|
||||
! Davidson iterations
|
||||
! ===================
|
||||
|
||||
converged = .False.
|
||||
|
||||
! Initialize from N_st to N_st_diag with gaussian random numbers
|
||||
! to be sure to have overlap with any eigenvectors
|
||||
do k = N_st+1, N_st_diag
|
||||
u_in(k,k) = 10.d0
|
||||
do i = 1, sze
|
||||
call random_number(r1)
|
||||
call random_number(r2)
|
||||
r1 = dsqrt(-2.d0*dlog(r1))
|
||||
r2 = dtwo_pi*r2
|
||||
u_in(i,k) = r1*dcos(r2)
|
||||
enddo
|
||||
enddo
|
||||
! Normalize all states
|
||||
do k = 1, N_st_diag
|
||||
call normalize(u_in(1,k), sze)
|
||||
enddo
|
||||
|
||||
! Copy from the guess input "u_in" to the working vectors "U"
|
||||
do k = 1, N_st_diag
|
||||
do i = 1, sze
|
||||
U(i,k) = u_in(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
itertot = 0
|
||||
|
||||
do while (.not.converged)
|
||||
|
||||
itertot = itertot + 1
|
||||
if(itertot == 8) then
|
||||
exit
|
||||
endif
|
||||
|
||||
do iter = 1, itermax-1
|
||||
|
||||
shift = N_st_diag * (iter-1)
|
||||
shift2 = N_st_diag * iter
|
||||
|
||||
if( (iter > 1) .or. (itertot == 1) ) then
|
||||
|
||||
! Gram-Schmidt to orthogonalize all new guess with the previous vectors
|
||||
call ortho_qr(U, size(U, 1), sze, shift2)
|
||||
call ortho_qr(U, size(U, 1), sze, shift2)
|
||||
|
||||
! W = H U
|
||||
call hcalc(W(1,shift+1), U(1,shift+1), N_st_diag, sze)
|
||||
|
||||
else
|
||||
|
||||
! Already computed in update below
|
||||
continue
|
||||
endif
|
||||
|
||||
! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>
|
||||
! -------------------------------------------
|
||||
call dgemm( 'T', 'N', shift2, shift2, sze, 1.d0 &
|
||||
, U, size(U, 1), W, size(W, 1) &
|
||||
, 0.d0, h, size(h, 1) )
|
||||
|
||||
|
||||
! Diagonalize h y = lambda y
|
||||
! ---------------------------
|
||||
call diag_nonsym_right(shift2, h(1,1), size(h, 1), y(1,1), size(y, 1), lambda(1), size(lambda, 1))
|
||||
|
||||
|
||||
! Express eigenvectors of h in the determinant basis:
|
||||
! ---------------------------------------------------
|
||||
|
||||
! y(:,k) = rk
|
||||
! U(:,k) = Bk
|
||||
! U(:,shift2+k) = Rk = Bk x rk
|
||||
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
|
||||
, U, size(U, 1), y, size(y, 1) &
|
||||
, 0.d0, U(1,shift2+1), size(U, 1) )
|
||||
|
||||
do k = 1, N_st_diag
|
||||
call normalize(U(1,shift2+k), sze)
|
||||
enddo
|
||||
|
||||
! ---
|
||||
! select the max overlap
|
||||
|
||||
!
|
||||
! start test ------------------------------------------------------------------------
|
||||
!
|
||||
!double precision, allocatable :: Utest(:,:), Otest(:)
|
||||
!allocate( Utest(sze,shift2), Otest(shift2) )
|
||||
|
||||
!call dgemm( 'N', 'N', sze, shift2, shift2, 1.d0 &
|
||||
! , U, size(U, 1), y, size(y, 1), 0.d0, Utest(1,1), size(Utest, 1) )
|
||||
!do k = 1, shift2
|
||||
! call normalize(Utest(1,k), sze)
|
||||
!enddo
|
||||
!do j = 1, sze
|
||||
! write(455, '(100(1X, F16.10))') (Utest(j,k), k=1,shift2)
|
||||
!enddo
|
||||
|
||||
!do k = 1, shift2
|
||||
! Otest(k) = 0.d0
|
||||
! do i = 1, sze
|
||||
! Otest(k) += Utest(i,k) * u_in(i,1)
|
||||
! enddo
|
||||
! Otest(k) = dabs(Otest(k))
|
||||
! print *, ' Otest =', k, Otest(k), lambda(k)
|
||||
!enddo
|
||||
|
||||
!deallocate(Utest, Otest)
|
||||
!
|
||||
! end test ------------------------------------------------------------------------
|
||||
!
|
||||
|
||||
! TODO
|
||||
! state_following is more efficient
|
||||
do l = 1, N_st
|
||||
|
||||
allocate( overlap(N_st_diag) )
|
||||
|
||||
do k = 1, N_st_diag
|
||||
overlap(k) = 0.d0
|
||||
do i = 1, sze
|
||||
overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,l)
|
||||
enddo
|
||||
overlap(k) = dabs(overlap(k))
|
||||
!print *, ' overlap =', k, overlap(k)
|
||||
enddo
|
||||
|
||||
lambda_tmp = 0.d0
|
||||
do k = 1, N_st_diag
|
||||
if(overlap(k) .gt. lambda_tmp) then
|
||||
i_omax(l) = k
|
||||
lambda_tmp = overlap(k)
|
||||
endif
|
||||
enddo
|
||||
|
||||
deallocate(overlap)
|
||||
|
||||
if(lambda_tmp .lt. 0.7d0) then
|
||||
print *, ' very small overlap ...', l, i_omax(l)
|
||||
print *, ' max overlap = ', lambda_tmp
|
||||
stop
|
||||
endif
|
||||
|
||||
if(i_omax(l) .ne. l) then
|
||||
print *, ' !!! WARNONG !!!'
|
||||
print *, ' index of state', l, i_omax(l)
|
||||
endif
|
||||
enddo
|
||||
|
||||
! y(:,k) = rk
|
||||
! W(:,k) = H x Bk
|
||||
! W(:,shift2+k) = H x Bk x rk
|
||||
! = Wk
|
||||
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
|
||||
, W, size(W, 1), y, size(y, 1) &
|
||||
, 0.d0, W(1,shift2+1), size(W, 1) )
|
||||
|
||||
! ---
|
||||
|
||||
! Compute residual vector and davidson step
|
||||
! -----------------------------------------
|
||||
|
||||
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k)
|
||||
do k = 1, N_st_diag
|
||||
do i = 1, sze
|
||||
U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2)
|
||||
enddo
|
||||
if(k <= N_st) then
|
||||
l = k
|
||||
residual_norm(k) = u_dot_u(U(1,shift2+l), sze)
|
||||
to_print(1,k) = lambda(l)
|
||||
to_print(2,k) = residual_norm(l)
|
||||
endif
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
!residual_norm(1) = u_dot_u(U(1,shift2+1), sze)
|
||||
!to_print(1,1) = lambda(1)
|
||||
!to_print(2,1) = residual_norm(1)
|
||||
|
||||
|
||||
if( (itertot > 1) .and. (iter == 1) ) then
|
||||
!don't print
|
||||
continue
|
||||
else
|
||||
write(*, '(1X, I3, 1X, 100(1X, F16.10, 1X, F16.10, 1X, F16.10))') iter-1, to_print(1:2,1:N_st)
|
||||
endif
|
||||
|
||||
! Check convergence
|
||||
if(iter > 1) then
|
||||
converged = dabs(maxval(residual_norm(1:N_st))) < threshold_nonsym_davidson
|
||||
endif
|
||||
|
||||
do k = 1, N_st
|
||||
if(residual_norm(k) > 1.e8) then
|
||||
print *, 'Davidson failed'
|
||||
stop -1
|
||||
endif
|
||||
enddo
|
||||
if(converged) then
|
||||
exit
|
||||
endif
|
||||
|
||||
logical, external :: qp_stop
|
||||
if(qp_stop()) then
|
||||
converged = .True.
|
||||
exit
|
||||
endif
|
||||
|
||||
enddo ! loop over iter
|
||||
|
||||
|
||||
! Re-contract U and update W
|
||||
! --------------------------------
|
||||
|
||||
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
|
||||
, W, size(W, 1), y, size(y, 1) &
|
||||
, 0.d0, u_in, size(u_in, 1) )
|
||||
do k = 1, N_st_diag
|
||||
do i = 1, sze
|
||||
W(i,k) = u_in(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
|
||||
, U, size(U, 1), y, size(y, 1) &
|
||||
, 0.d0, u_in, size(u_in, 1) )
|
||||
do k = 1, N_st_diag
|
||||
do i = 1, sze
|
||||
U(i,k) = u_in(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call ortho_qr(U, size(U, 1), sze, N_st_diag)
|
||||
call ortho_qr(U, size(U, 1), sze, N_st_diag)
|
||||
do j = 1, N_st_diag
|
||||
k = 1
|
||||
do while( (k < sze) .and. (U(k,j) == 0.d0) )
|
||||
k = k+1
|
||||
enddo
|
||||
if(U(k,j) * u_in(k,j) < 0.d0) then
|
||||
do i = 1, sze
|
||||
W(i,j) = -W(i,j)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
enddo ! loop over while
|
||||
|
||||
! ---
|
||||
|
||||
do k = 1, N_st
|
||||
energies(k) = lambda(k)
|
||||
enddo
|
||||
write_buffer = '====='
|
||||
do i = 1, N_st
|
||||
write_buffer = trim(write_buffer)//' ================ ==========='
|
||||
enddo
|
||||
write(6,'(A)') trim(write_buffer)
|
||||
write(6,'(A)') ''
|
||||
call write_time(6)
|
||||
|
||||
deallocate(W)
|
||||
deallocate(U, h, y, lambda, residual_norm, i_omax)
|
||||
|
||||
FREE nthreads_davidson
|
||||
|
||||
end subroutine davidson_general_ext_rout_nonsym_b1space
|
||||
|
||||
! ---
|
||||
|
|
@ -4,6 +4,12 @@ doc: Thresholds of Davidson's algorithm if threshold_davidson_from_pt2 is false.
|
|||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-10
|
||||
|
||||
[threshold_nonsym_davidson]
|
||||
type: Threshold
|
||||
doc: Thresholds of non-symetric Davidson's algorithm
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-10
|
||||
|
||||
[threshold_davidson_from_pt2]
|
||||
type: logical
|
||||
doc: Thresholds of Davidson's algorithm is set to E(rPT2)*threshold_davidson_from_pt2
|
||||
|
|
|
|||
|
|
@ -589,6 +589,67 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef)
|
|||
endif
|
||||
end
|
||||
|
||||
subroutine save_wavefunction_general_unormalized(ndet,nstates,psidet,dim_psicoef,psicoef)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Save the wave function into the |EZFIO| file
|
||||
END_DOC
|
||||
use bitmasks
|
||||
include 'constants.include.F'
|
||||
integer, intent(in) :: ndet,nstates,dim_psicoef
|
||||
integer(bit_kind), intent(in) :: psidet(N_int,2,ndet)
|
||||
double precision, intent(in) :: psicoef(dim_psicoef,nstates)
|
||||
integer*8, allocatable :: psi_det_save(:,:,:)
|
||||
double precision, allocatable :: psi_coef_save(:,:)
|
||||
|
||||
double precision :: accu_norm
|
||||
integer :: i,j,k, ndet_qp_edit
|
||||
|
||||
if (mpi_master) then
|
||||
ndet_qp_edit = min(ndet,N_det_qp_edit)
|
||||
|
||||
call ezfio_set_determinants_N_int(N_int)
|
||||
call ezfio_set_determinants_bit_kind(bit_kind)
|
||||
call ezfio_set_determinants_N_det(ndet)
|
||||
call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit)
|
||||
call ezfio_set_determinants_n_states(nstates)
|
||||
call ezfio_set_determinants_mo_label(mo_label)
|
||||
|
||||
allocate (psi_det_save(N_int,2,ndet))
|
||||
do i=1,ndet
|
||||
do j=1,2
|
||||
do k=1,N_int
|
||||
psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
call ezfio_set_determinants_psi_det(psi_det_save)
|
||||
call ezfio_set_determinants_psi_det_qp_edit(psi_det_save)
|
||||
deallocate (psi_det_save)
|
||||
|
||||
allocate (psi_coef_save(ndet,nstates))
|
||||
do k=1,nstates
|
||||
do i=1,ndet
|
||||
psi_coef_save(i,k) = psicoef(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call ezfio_set_determinants_psi_coef(psi_coef_save)
|
||||
deallocate (psi_coef_save)
|
||||
|
||||
allocate (psi_coef_save(ndet_qp_edit,nstates))
|
||||
do k=1,nstates
|
||||
do i=1,ndet_qp_edit
|
||||
psi_coef_save(i,k) = psicoef(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save)
|
||||
deallocate (psi_coef_save)
|
||||
|
||||
call write_int(6,ndet,'Saved determinants')
|
||||
endif
|
||||
end
|
||||
|
||||
|
||||
subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,index_det_save)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
[psi_l_coef_bi_ortho]
|
||||
interface: ezfio
|
||||
doc: Coefficients for the left wave function
|
||||
type: double precision
|
||||
size: (determinants.n_det,determinants.n_states)
|
||||
|
||||
[psi_r_coef_bi_ortho]
|
||||
interface: ezfio
|
||||
doc: Coefficients for the right wave function
|
||||
type: double precision
|
||||
size: (determinants.n_det,determinants.n_states)
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
bi_ort_ints
|
||||
bi_ortho_mos
|
||||
tc_keywords
|
||||
non_hermit_dav
|
||||
dav_general_mat
|
||||
tc_scf
|
||||
|
|
@ -0,0 +1,53 @@
|
|||
program compute_deltamu_right
|
||||
|
||||
implicit none
|
||||
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
|
||||
PROVIDE N_int
|
||||
call delta_right()
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine delta_right()
|
||||
|
||||
implicit none
|
||||
integer :: k
|
||||
double precision, allocatable :: delta(:,:)
|
||||
|
||||
print *, j1b_type
|
||||
print *, j1b_pen
|
||||
print *, mu_erf
|
||||
|
||||
allocate( delta(N_det,N_states) )
|
||||
delta = 0.d0
|
||||
|
||||
do k = 1, N_states
|
||||
!do k = 1, 1
|
||||
|
||||
! get < I_left | H_mu - H | psi_right >
|
||||
!call get_h_bitc_right(psi_det, psi_r_coef_bi_ortho(:,k), N_det, N_int, delta(:,k))
|
||||
call get_delta_bitc_right(psi_det, psi_r_coef_bi_ortho(:,k), N_det, N_int, delta(:,k))
|
||||
|
||||
! order as QMCCHEM
|
||||
call dset_order(delta(:,k), psi_bilinear_matrix_order, N_det)
|
||||
|
||||
enddo
|
||||
|
||||
! call ezfio_set_dmc_dress_dmc_delta_h(delta)
|
||||
|
||||
deallocate(delta)
|
||||
|
||||
return
|
||||
end subroutine delta_right
|
||||
|
||||
! ---
|
||||
|
||||
|
|
@ -0,0 +1,155 @@
|
|||
|
||||
! ---
|
||||
|
||||
subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! delta(I) = < I_left | H_TC - H | Psi_right >
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: ndet, Nint
|
||||
double precision, intent(in) :: psicoef(ndet)
|
||||
integer(bit_kind), intent(in) :: psidet(Nint,2,ndet)
|
||||
double precision, intent(out) :: delta(ndet)
|
||||
|
||||
integer :: i, j
|
||||
double precision :: h_mono, h_twoe, h_tot
|
||||
double precision :: htc_mono, htc_twoe, htc_three, htc_tot
|
||||
double precision :: delta_mat
|
||||
|
||||
print *, ' get_delta_bitc_right ...'
|
||||
|
||||
i = 1
|
||||
j = 1
|
||||
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
call hmat_bi_ortho (psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
|
||||
|
||||
delta = 0.d0
|
||||
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
|
||||
!$OMP SHARED(delta, ndet, psidet, psicoef, Nint) &
|
||||
!$OMP PRIVATE(i, j, delta_mat, h_mono, h_twoe, h_tot, &
|
||||
!$OMP htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
do i = 1, ndet
|
||||
do j = 1, ndet
|
||||
|
||||
! < I | Htilde | J >
|
||||
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
! < I | H | J >
|
||||
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
|
||||
|
||||
delta_mat = htc_tot - h_tot
|
||||
|
||||
delta(i) = delta(i) + psicoef(j) * delta_mat
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
end subroutine get_delta_bitc_right
|
||||
|
||||
! ---
|
||||
|
||||
subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! delta(I) = < I_left | H_TC | Psi_right >
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: ndet, Nint
|
||||
double precision, intent(in) :: psicoef(ndet)
|
||||
integer(bit_kind), intent(in) :: psidet(Nint,2,ndet)
|
||||
double precision, intent(out) :: delta(ndet)
|
||||
|
||||
integer :: i, j
|
||||
double precision :: htc_mono, htc_twoe, htc_three, htc_tot
|
||||
|
||||
print *, ' get_htc_bitc_right ...'
|
||||
|
||||
i = 1
|
||||
j = 1
|
||||
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
|
||||
delta = 0.d0
|
||||
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
|
||||
!$OMP SHARED(delta, ndet, psidet, psicoef, Nint) &
|
||||
!$OMP PRIVATE(i, j, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
do i = 1, ndet
|
||||
do j = 1, ndet
|
||||
|
||||
! < I | Htilde | J >
|
||||
call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
|
||||
|
||||
delta(i) = delta(i) + psicoef(j) * htc_tot
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
end subroutine get_htc_bitc_right
|
||||
|
||||
! ---
|
||||
|
||||
subroutine get_h_bitc_right(psidet, psicoef, ndet, Nint, delta)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! delta(I) = < I_left | H | Psi_right >
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: ndet, Nint
|
||||
double precision, intent(in) :: psicoef(ndet)
|
||||
integer(bit_kind), intent(in) :: psidet(Nint,2,ndet)
|
||||
double precision, intent(out) :: delta(ndet)
|
||||
|
||||
integer :: i, j
|
||||
double precision :: h_mono, h_twoe, h_tot
|
||||
|
||||
print *, ' get_h_bitc_right ...'
|
||||
|
||||
i = 1
|
||||
j = 1
|
||||
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
|
||||
|
||||
!double precision :: norm
|
||||
!norm = 0.d0
|
||||
!do i = 1, ndet
|
||||
! norm += psicoef(i) * psicoef(i)
|
||||
!enddo
|
||||
!print*, ' norm = ', norm
|
||||
|
||||
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
|
||||
|
||||
delta = 0.d0
|
||||
! !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
|
||||
! !$OMP SHARED(delta, ndet, psidet, psicoef, Nint) &
|
||||
! !$OMP PRIVATE(i, j, h_mono, h_twoe, h_tot)
|
||||
do i = 1, ndet
|
||||
do j = 1, ndet
|
||||
|
||||
! < I | H | J >
|
||||
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
|
||||
|
||||
delta(i) = delta(i) + psicoef(j) * h_tot
|
||||
enddo
|
||||
enddo
|
||||
! !$OMP END PARALLEL DO
|
||||
|
||||
end subroutine get_h_bitc_right
|
||||
|
||||
! ---
|
||||
|
||||
|
|
@ -0,0 +1,104 @@
|
|||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
BEGIN_PROVIDER [ double precision, e_tilde_00]
|
||||
implicit none
|
||||
double precision :: hmono,htwoe,hthree,htot
|
||||
call htilde_mu_mat_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot)
|
||||
e_tilde_00 = htot
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth]
|
||||
&BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth_single]
|
||||
&BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth_double]
|
||||
implicit none
|
||||
integer :: i,degree
|
||||
double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e
|
||||
e_pt2_tc_bi_orth = 0.d0
|
||||
e_pt2_tc_bi_orth_single = 0.d0
|
||||
e_pt2_tc_bi_orth_double = 0.d0
|
||||
do i = 1, N_det
|
||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||
if(degree == 1 .or. degree == 2)then
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
||||
delta_e = e_tilde_00 - e_i0
|
||||
coef_pt1 = htilde_ij / delta_e
|
||||
call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
e_pt2_tc_bi_orth += coef_pt1 * htilde_ij
|
||||
if(degree == 1)then
|
||||
e_pt2_tc_bi_orth_single += coef_pt1 * htilde_ij
|
||||
else
|
||||
! print*,'coef_pt1, e_pt2',coef_pt1,coef_pt1 * htilde_ij
|
||||
e_pt2_tc_bi_orth_double += coef_pt1 * htilde_ij
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, e_tilde_bi_orth_00]
|
||||
implicit none
|
||||
double precision :: hmono,htwoe,hthree,htilde_ij
|
||||
call htilde_mu_mat_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00)
|
||||
e_tilde_bi_orth_00 += nuclear_repulsion
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, e_corr_bi_orth ]
|
||||
&BEGIN_PROVIDER [ double precision, e_corr_bi_orth_proj ]
|
||||
&BEGIN_PROVIDER [ double precision, e_corr_single_bi_orth ]
|
||||
&BEGIN_PROVIDER [ double precision, e_corr_double_bi_orth ]
|
||||
implicit none
|
||||
integer :: i,degree
|
||||
double precision :: hmono,htwoe,hthree,htilde_ij
|
||||
|
||||
e_corr_bi_orth = 0.d0
|
||||
e_corr_single_bi_orth = 0.d0
|
||||
e_corr_double_bi_orth = 0.d0
|
||||
do i = 1, N_det
|
||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||
call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
if(degree == 1)then
|
||||
e_corr_single_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
|
||||
else if(degree == 2)then
|
||||
e_corr_double_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
|
||||
! print*,'coef_wf , e_cor',reigvec_tc_bi_orth(i,1)/reigvec_tc_bi_orth(1,1), reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
|
||||
endif
|
||||
enddo
|
||||
e_corr_bi_orth_proj = e_corr_single_bi_orth + e_corr_double_bi_orth
|
||||
e_corr_bi_orth = eigval_right_tc_bi_orth(1) - e_tilde_bi_orth_00
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, e_tc_left_right ]
|
||||
implicit none
|
||||
integer :: i,j
|
||||
double precision :: hmono,htwoe,hthree,htilde_ij,accu
|
||||
e_tc_left_right = 0.d0
|
||||
accu = 0.d0
|
||||
do i = 1, N_det
|
||||
accu += reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(i,1)
|
||||
do j = 1, N_det
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
e_tc_left_right += htilde_ij * reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(j,1)
|
||||
enddo
|
||||
enddo
|
||||
e_tc_left_right *= 1.d0/accu
|
||||
e_tc_left_right += nuclear_repulsion
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, coef_pt1_bi_ortho, (N_det)]
|
||||
implicit none
|
||||
integer :: i,degree
|
||||
double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e
|
||||
do i = 1, N_det
|
||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||
if(degree==0)then
|
||||
coef_pt1_bi_ortho(i) = 1.d0
|
||||
else
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
||||
delta_e = e_tilde_00 - e_i0
|
||||
coef_pt1 = htilde_ij / delta_e
|
||||
coef_pt1_bi_ortho(i)= coef_pt1
|
||||
endif
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
|
@ -0,0 +1,243 @@
|
|||
|
||||
! --
|
||||
|
||||
subroutine hmat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! < key_j | H | key_i > where | key_j > is developed on the LEFT basis and | key_i > is developed on the RIGHT basis
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe, htot
|
||||
|
||||
integer :: degree
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
htot = 0.d0
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree .gt. 2) return
|
||||
|
||||
if(degree == 0) then
|
||||
|
||||
call diag_hmat_bi_ortho(Nint, key_i, hmono, htwoe)
|
||||
htot = htot + nuclear_repulsion
|
||||
|
||||
else if (degree == 1) then
|
||||
|
||||
call single_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
|
||||
|
||||
else if(degree == 2) then
|
||||
|
||||
call double_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
|
||||
|
||||
endif
|
||||
|
||||
htot += hmono + htwoe
|
||||
|
||||
return
|
||||
end subroutine hmat_bi_ortho
|
||||
|
||||
! ---
|
||||
|
||||
subroutine diag_hmat_bi_ortho(Nint, key_i, hmono, htwoe)
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe
|
||||
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
|
||||
do ispin = 1, 2
|
||||
do i = 1, Ne(ispin)
|
||||
ii = occ(i,ispin)
|
||||
hmono += mo_bi_ortho_one_e(ii,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! alpha/beta two-body
|
||||
ispin = 1
|
||||
jspin = 2
|
||||
do i = 1, Ne(ispin) ! electron 1
|
||||
ii = occ(i,ispin)
|
||||
do j = 1, Ne(jspin) ! electron 2
|
||||
jj = occ(j,jspin)
|
||||
htwoe += mo_bi_ortho_coul_e(jj,ii,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! alpha/alpha two-body
|
||||
do i = 1, Ne(ispin)
|
||||
ii = occ(i,ispin)
|
||||
do j = i+1, Ne(ispin)
|
||||
jj = occ(j,ispin)
|
||||
htwoe += mo_bi_ortho_coul_e(ii,jj,ii,jj) - mo_bi_ortho_coul_e(ii,jj,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! beta/beta two-body
|
||||
do i = 1, Ne(jspin)
|
||||
ii = occ(i,jspin)
|
||||
do j = i+1, Ne(jspin)
|
||||
jj = occ(j,jspin)
|
||||
htwoe += mo_bi_ortho_coul_e(ii,jj,ii,jj) - mo_bi_ortho_coul_e(ii,jj,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
return
|
||||
end subroutine diag_hmat_bi_ortho
|
||||
|
||||
! ---
|
||||
|
||||
subroutine single_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! < key_j | H | key_i > for single excitation
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe
|
||||
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, ispin, jspin
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
integer :: other_spin(2)
|
||||
double precision :: phase
|
||||
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree .ne. 1) then
|
||||
return
|
||||
endif
|
||||
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
|
||||
call get_single_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc, 1, h1, p1, h2, p2, s1, s2)
|
||||
|
||||
hmono = mo_bi_ortho_one_e(p1,h1) * phase
|
||||
|
||||
! alpha/beta two-body
|
||||
ispin = other_spin(s1)
|
||||
if(s1 == 1) then
|
||||
|
||||
! single alpha
|
||||
do i = 1, Ne(ispin) ! electron 2
|
||||
ii = occ(i,ispin)
|
||||
htwoe += mo_bi_ortho_coul_e(ii,p1,ii,h1)
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
! single beta
|
||||
do i = 1, Ne(ispin) ! electron 1
|
||||
ii = occ(i,ispin)
|
||||
htwoe += mo_bi_ortho_coul_e(p1,ii,h1,ii)
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
! same spin two-body
|
||||
do i = 1, Ne(s1)
|
||||
ii = occ(i,s1)
|
||||
! ( h1 p1 |ii ii ) - ( h1 ii | p1 ii )
|
||||
htwoe += mo_bi_ortho_coul_e(ii,p1,ii,h1) - mo_bi_ortho_coul_e(p1,ii,ii,h1)
|
||||
enddo
|
||||
|
||||
htwoe *= phase
|
||||
|
||||
end subroutine single_hmat_bi_ortho
|
||||
|
||||
! ---
|
||||
|
||||
subroutine double_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! < key_j | H | key_i> for double excitation
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe
|
||||
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, ispin, jspin
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
integer :: other_spin(2)
|
||||
double precision :: phase
|
||||
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
|
||||
if(degree .ne. 2) then
|
||||
return
|
||||
endif
|
||||
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
|
||||
call get_double_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
|
||||
|
||||
if(s1 .ne. s2) then
|
||||
|
||||
htwoe = mo_bi_ortho_coul_e(p2,p1,h2,h1)
|
||||
|
||||
else
|
||||
|
||||
! same spin two-body
|
||||
|
||||
! direct terms exchange terms
|
||||
htwoe = mo_bi_ortho_coul_e(p2,p1,h2,h1) - mo_bi_ortho_coul_e(p1,p2,h2,h1)
|
||||
|
||||
endif
|
||||
|
||||
htwoe *= phase
|
||||
|
||||
end subroutine double_hmat_bi_ortho
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
subroutine htc_bi_ortho_calc_tdav(v, u, N_st, sze)
|
||||
|
||||
use bitmasks
|
||||
|
||||
BEGIN_DOC
|
||||
! Application of H_TC on a vector
|
||||
!
|
||||
! v(i,istate) = \sum_j u(j,istate) H_TC(i,j), with:
|
||||
! H_TC(i,j) = < Di | H_TC | Dj >
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: N_st, sze
|
||||
double precision, intent(in) :: u(sze,N_st)
|
||||
double precision, intent(inout) :: v(sze,N_st)
|
||||
|
||||
integer :: i, j, istate
|
||||
double precision :: htot
|
||||
|
||||
PROVIDE N_int
|
||||
PROVIDE psi_det
|
||||
|
||||
|
||||
! TODO : transform it with the bi-linear representation in terms of alpha-beta.
|
||||
|
||||
i = 1
|
||||
j = 1
|
||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
|
||||
|
||||
v = 0.d0
|
||||
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
|
||||
!$OMP SHARED(N_st, sze, N_int, psi_det, u, v) &
|
||||
!$OMP PRIVATE(istate, i, j, htot)
|
||||
do istate = 1, N_st
|
||||
do i = 1, sze
|
||||
do j = 1, sze
|
||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
|
||||
v(i,istate) = v(i,istate) + htot * u(j,istate)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
end
|
||||
|
||||
subroutine htcdag_bi_ortho_calc_tdav(v, u, N_st, sze)
|
||||
|
||||
use bitmasks
|
||||
|
||||
BEGIN_DOC
|
||||
! Application of (H_TC)^dagger on a vector
|
||||
!
|
||||
! v(i,istate) = \sum_j u(j,istate) H_TC(j,i), with:
|
||||
! H_TC(i,j) = < Di | H_TC | Dj >
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: N_st, sze
|
||||
double precision, intent(in) :: u(sze,N_st)
|
||||
double precision, intent(inout) :: v(sze,N_st)
|
||||
|
||||
integer :: i, j, istate
|
||||
double precision :: htot
|
||||
|
||||
PROVIDE N_int
|
||||
PROVIDE psi_det
|
||||
|
||||
i = 1
|
||||
j = 1
|
||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
|
||||
|
||||
v = 0.d0
|
||||
|
||||
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
|
||||
!$OMP SHARED(N_st, sze, N_int, psi_det, u, v) &
|
||||
!$OMP PRIVATE(istate, i, j, htot)
|
||||
do istate = 1, N_st
|
||||
do i = 1, sze
|
||||
do j = 1, sze
|
||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
|
||||
v(i,istate) = v(i,istate) + htot * u(j,istate)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
end
|
||||
|
||||
|
|
@ -0,0 +1,319 @@
|
|||
BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! Normal ordering of the three body interaction on the HF density
|
||||
END_DOC
|
||||
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i,h1,p1,h2,p2
|
||||
integer :: hh1,hh2,pp1,pp2
|
||||
integer :: Ne(2)
|
||||
integer, allocatable :: occ(:,:)
|
||||
integer(bit_kind), allocatable :: key_i_core(:,:)
|
||||
double precision :: hthree_aba,hthree_aaa,hthree_aab
|
||||
double precision :: wall0,wall1
|
||||
|
||||
PROVIDE N_int
|
||||
|
||||
allocate( occ(N_int*bit_kind_size,2) )
|
||||
allocate( key_i_core(N_int,2) )
|
||||
|
||||
if(core_tc_op) then
|
||||
do i = 1, N_int
|
||||
key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1))
|
||||
key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(key_i_core,occ,Ne,N_int)
|
||||
else
|
||||
call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
|
||||
endif
|
||||
|
||||
normal_two_body_bi_orth = 0.d0
|
||||
print*,'Providing normal_two_body_bi_orth ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, hthree_aba, hthree_aab, hthree_aaa) &
|
||||
!$OMP SHARED (N_int, n_act_orb, list_act, Ne, occ, normal_two_body_bi_orth)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do hh1 = 1, n_act_orb
|
||||
h1 = list_act(hh1)
|
||||
do pp1 = 1, n_act_orb
|
||||
p1 = list_act(pp1)
|
||||
do hh2 = 1, n_act_orb
|
||||
h2 = list_act(hh2)
|
||||
do pp2 = 1, n_act_orb
|
||||
p2 = list_act(pp2)
|
||||
! opposite spin double excitations
|
||||
call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aba)
|
||||
! same spin double excitations with opposite spin contributions
|
||||
if(h1<h2.and.p1.gt.p2)then
|
||||
call give_aab_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aab) ! exchange h1<->h2
|
||||
! same spin double excitations with same spin contributions
|
||||
if(Ne(2).ge.3)then
|
||||
call give_aaa_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aaa) ! exchange h1<->h2
|
||||
else
|
||||
hthree_aaa = 0.d0
|
||||
endif
|
||||
else
|
||||
call give_aab_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aab)
|
||||
if(Ne(2).ge.3)then
|
||||
call give_aaa_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aaa)
|
||||
else
|
||||
hthree_aaa = 0.d0
|
||||
endif
|
||||
endif
|
||||
normal_two_body_bi_orth(p2,h2,p1,h1) = 0.5d0*(hthree_aba + hthree_aab + hthree_aaa)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print*,'Wall time for normal_two_body_bi_orth ',wall1-wall0
|
||||
|
||||
deallocate( occ )
|
||||
deallocate( key_i_core )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
subroutine give_aba_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree)
|
||||
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint, h1, h2, p1, p2
|
||||
integer, intent(in) :: Ne(2), occ(Nint*bit_kind_size,2)
|
||||
double precision, intent(out) :: hthree
|
||||
integer :: ii, i
|
||||
double precision :: int_direct, int_exc_12, int_exc_13, integral
|
||||
|
||||
!!!! double alpha/beta
|
||||
hthree = 0.d0
|
||||
do ii = 1, Ne(2) ! purely closed shell part
|
||||
i = occ(ii,2)
|
||||
call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral)
|
||||
int_direct = -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral)
|
||||
int_exc_13 = -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p2, i,p1,i,h2,h1,integral)
|
||||
int_exc_12 = -1.d0 * integral
|
||||
hthree += 2.d0 * int_direct - 1.d0 * ( int_exc_13 + int_exc_12)
|
||||
enddo
|
||||
do ii = Ne(2) + 1, Ne(1) ! purely open-shell part
|
||||
i = occ(ii,1)
|
||||
call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral)
|
||||
int_direct = -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral)
|
||||
int_exc_13 = -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p2, i,p1,i,h2,h1,integral)
|
||||
int_exc_12 = -1.d0 * integral
|
||||
hthree += 1.d0 * int_direct - 0.5d0* ( int_exc_13 + int_exc_12)
|
||||
enddo
|
||||
|
||||
end subroutine give_aba_contraction
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_ab, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! Normal ordered two-body sector of the three-body terms for opposite spin double excitations
|
||||
END_DOC
|
||||
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
|
||||
implicit none
|
||||
integer :: h1, p1, h2, p2, i
|
||||
integer :: hh1, hh2, pp1, pp2
|
||||
integer :: Ne(2)
|
||||
integer, allocatable :: occ(:,:)
|
||||
integer(bit_kind), allocatable :: key_i_core(:,:)
|
||||
double precision :: hthree
|
||||
|
||||
PROVIDE N_int
|
||||
|
||||
allocate( key_i_core(N_int,2) )
|
||||
allocate( occ(N_int*bit_kind_size,2) )
|
||||
|
||||
if(core_tc_op)then
|
||||
do i = 1, N_int
|
||||
key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1))
|
||||
key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(key_i_core,occ,Ne,N_int)
|
||||
else
|
||||
call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
|
||||
endif
|
||||
normal_two_body_bi_orth_ab = 0.d0
|
||||
do hh1 = 1, n_act_orb
|
||||
h1 = list_act(hh1)
|
||||
do pp1 = 1, n_act_orb
|
||||
p1 = list_act(pp1)
|
||||
do hh2 = 1, n_act_orb
|
||||
h2 = list_act(hh2)
|
||||
do pp2 = 1, n_act_orb
|
||||
p2 = list_act(pp2)
|
||||
call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree)
|
||||
normal_two_body_bi_orth_ab(p2,h2,p1,h1) = hthree
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate( key_i_core )
|
||||
deallocate( occ )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_aa_bb, (n_act_orb, n_act_orb, n_act_orb, n_act_orb)]
|
||||
|
||||
BEGIN_DOC
|
||||
! Normal ordered two-body sector of the three-body terms for same spin double excitations
|
||||
END_DOC
|
||||
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
|
||||
implicit none
|
||||
integer :: i,ii,j,h1,p1,h2,p2
|
||||
integer :: hh1,hh2,pp1,pp2
|
||||
integer :: Ne(2)
|
||||
integer, allocatable :: occ(:,:)
|
||||
integer(bit_kind), allocatable :: key_i_core(:,:)
|
||||
double precision :: hthree_aab, hthree_aaa
|
||||
|
||||
PROVIDE N_int
|
||||
|
||||
allocate( key_i_core(N_int,2) )
|
||||
allocate( occ(N_int*bit_kind_size,2) )
|
||||
|
||||
if(core_tc_op)then
|
||||
do i = 1, N_int
|
||||
key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1))
|
||||
key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(key_i_core, occ, Ne, N_int)
|
||||
else
|
||||
call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int)
|
||||
endif
|
||||
|
||||
normal_two_body_bi_orth_aa_bb = 0.d0
|
||||
do hh1 = 1, n_act_orb
|
||||
h1 = list_act(hh1)
|
||||
do pp1 = 1 , n_act_orb
|
||||
p1 = list_act(pp1)
|
||||
do hh2 = 1, n_act_orb
|
||||
h2 = list_act(hh2)
|
||||
do pp2 = 1 , n_act_orb
|
||||
p2 = list_act(pp2)
|
||||
if(h1<h2.and.p1.gt.p2)then
|
||||
call give_aab_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aab) ! exchange h1<->h2
|
||||
if(Ne(2).ge.3)then
|
||||
call give_aaa_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aaa) ! exchange h1<->h2
|
||||
else
|
||||
hthree_aaa = 0.d0
|
||||
endif
|
||||
else
|
||||
call give_aab_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aab)
|
||||
if(Ne(2).ge.3)then
|
||||
call give_aaa_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aaa)
|
||||
else
|
||||
hthree_aaa = 0.d0
|
||||
endif
|
||||
endif
|
||||
normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1) = hthree_aab + hthree_aaa
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate( key_i_core )
|
||||
deallocate( occ )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
subroutine give_aaa_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree)
|
||||
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint, h1, h2, p1, p2
|
||||
integer, intent(in) :: Ne(2), occ(Nint*bit_kind_size,2)
|
||||
double precision, intent(out) :: hthree
|
||||
integer :: ii,i
|
||||
double precision :: int_direct,int_exc_12,int_exc_13,int_exc_23
|
||||
double precision :: integral,int_exc_l,int_exc_ll
|
||||
|
||||
hthree = 0.d0
|
||||
do ii = 1, Ne(2) ! purely closed shell part
|
||||
i = occ(ii,2)
|
||||
call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral)
|
||||
int_direct = -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p2,p1,i ,i,h2,h1,integral)
|
||||
int_exc_l = -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p1,i ,p2,i,h2,h1,integral)
|
||||
int_exc_ll= -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p2,i ,p1,i,h2,h1,integral)
|
||||
int_exc_12= -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral)
|
||||
int_exc_13= -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(i ,p1,p2,i,h2,h1,integral)
|
||||
int_exc_23= -1.d0 * integral
|
||||
|
||||
hthree += 1.d0 * int_direct + int_exc_l + int_exc_ll -( int_exc_12+ int_exc_13+ int_exc_23 )
|
||||
enddo
|
||||
do ii = Ne(2)+1,Ne(1) ! purely open-shell part
|
||||
i = occ(ii,1)
|
||||
call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral)
|
||||
int_direct = -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p2,p1,i ,i,h2,h1,integral)
|
||||
int_exc_l = -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p1,i ,p2,i,h2,h1,integral)
|
||||
int_exc_ll= -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p2,i ,p1,i,h2,h1,integral)
|
||||
int_exc_12= -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral)
|
||||
int_exc_13= -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(i ,p1,p2,i,h2,h1,integral)
|
||||
int_exc_23= -1.d0 * integral
|
||||
|
||||
hthree += 1.d0 * int_direct + 0.5d0 * (int_exc_l + int_exc_ll -( int_exc_12+ int_exc_13+ int_exc_23 ))
|
||||
enddo
|
||||
|
||||
end subroutine give_aaa_contraction
|
||||
|
||||
|
||||
|
||||
subroutine give_aab_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree)
|
||||
implicit none
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
integer, intent(in) :: Nint, h1, h2, p1, p2
|
||||
integer, intent(in) :: Ne(2), occ(Nint*bit_kind_size,2)
|
||||
double precision, intent(out) :: hthree
|
||||
integer :: ii, i
|
||||
double precision :: int_direct, int_exc_12, int_exc_13, int_exc_23
|
||||
double precision :: integral, int_exc_l, int_exc_ll
|
||||
|
||||
hthree = 0.d0
|
||||
do ii = 1, Ne(2) ! purely closed shell part
|
||||
i = occ(ii,2)
|
||||
call give_integrals_3_body_bi_ort(p2,p1,i,h2,h1,i,integral)
|
||||
int_direct = -1.d0 * integral
|
||||
call give_integrals_3_body_bi_ort(p1,p2,i,h2,h1,i,integral)
|
||||
int_exc_23= -1.d0 * integral
|
||||
hthree += 1.d0 * int_direct - int_exc_23
|
||||
enddo
|
||||
|
||||
end subroutine give_aab_contraction
|
||||
|
|
@ -0,0 +1,142 @@
|
|||
|
||||
! ---
|
||||
|
||||
program print_he_tc_energy
|
||||
|
||||
implicit none
|
||||
|
||||
call print_overlap()
|
||||
|
||||
call print_energy1()
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine print_overlap()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l
|
||||
double precision :: S_ij
|
||||
|
||||
print *, ' ao_overlap:'
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
print *, j, i, ao_overlap(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print *, ' mo_overlap:'
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
|
||||
S_ij = 0.d0
|
||||
do k = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
S_ij += mo_l_coef(k,i) * ao_overlap(k,l) * mo_r_coef(l,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print *, i, j, S_ij
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end subroutine print_overlap
|
||||
|
||||
! ---
|
||||
|
||||
subroutine print_energy1()
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l
|
||||
double precision :: e, n, e_tmp, n_tmp, e_ns
|
||||
double precision, external :: ao_two_e_integral
|
||||
|
||||
e = 0.d0
|
||||
n = 0.d0
|
||||
|
||||
! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
|
||||
|
||||
! < phi_1 phi_1 | h1 | phi_1 phi_1 >
|
||||
|
||||
e_tmp = 0.d0
|
||||
n_tmp = 0.d0
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
e_tmp += mo_l_coef(i,1) * ao_one_e_integrals(i,j) * mo_r_coef(j,1)
|
||||
n_tmp += mo_l_coef(i,1) * ao_overlap(i,j) * mo_r_coef(j,1)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
e += e_tmp * n_tmp
|
||||
|
||||
! ---
|
||||
|
||||
! < phi_1 phi_1 | h2 | phi_1 phi_1 >
|
||||
|
||||
e_tmp = 0.d0
|
||||
n_tmp = 0.d0
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
n_tmp += mo_l_coef(i,1) * ao_overlap(i,j) * mo_r_coef(j,1)
|
||||
e_tmp += mo_l_coef(i,1) * ao_one_e_integrals(i,j) * mo_r_coef(j,1)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
e += e_tmp * n_tmp
|
||||
|
||||
! ---
|
||||
|
||||
! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
|
||||
|
||||
! ---
|
||||
|
||||
e_ns = 0.d0
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
|
||||
! ao_two_e_tc_tot(i,j,k,l) = <k i| V^TC(r_12) |l j>
|
||||
e += mo_l_coef(i,1) * mo_l_coef(k,1) * ao_two_e_tc_tot(i,j,k,l) * mo_r_coef(j,1) * mo_r_coef(l,1)
|
||||
|
||||
e_ns += mo_l_coef(i,1) * mo_l_coef(k,1) * ao_non_hermit_term_chemist(i,j,k,l) * mo_r_coef(j,1) * mo_r_coef(l,1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
|
||||
|
||||
! ---
|
||||
|
||||
! < phi_1 phi_1 | phi_1 phi_1 >
|
||||
e_tmp = 0.d0
|
||||
n_tmp = 0.d0
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
e_tmp += mo_l_coef(i,1) * ao_overlap(i,j) * mo_r_coef(j,1)
|
||||
n_tmp += mo_l_coef(i,1) * ao_overlap(i,j) * mo_r_coef(j,1)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
n += e_tmp * n_tmp
|
||||
|
||||
! ---
|
||||
|
||||
! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
|
||||
|
||||
e = e / n
|
||||
e_ns = e_ns / n
|
||||
|
||||
print *, ' tc energy = ', e
|
||||
print *, ' non-sym energy = ', e_ns
|
||||
|
||||
end subroutine print_energy1
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,104 @@
|
|||
program print_tc_bi_ortho
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
! if(three_body_h_tc)then
|
||||
! call provide_all_three_ints_bi_ortho
|
||||
! endif
|
||||
! call routine
|
||||
call write_l_r_wf
|
||||
end
|
||||
|
||||
subroutine write_l_r_wf
|
||||
implicit none
|
||||
character*(128) :: output
|
||||
integer :: i_unit_output,getUnitAndOpen
|
||||
output=trim(ezfio_filename)//'.tc_wf'
|
||||
i_unit_output = getUnitAndOpen(output,'w')
|
||||
integer :: i
|
||||
print*,'Writing the left-right wf'
|
||||
do i = 1, N_det
|
||||
write(i_unit_output,*)i,psi_l_coef_sorted_bi_ortho_left(i),psi_r_coef_sorted_bi_ortho_right(i)
|
||||
enddo
|
||||
|
||||
|
||||
end
|
||||
|
||||
subroutine routine
|
||||
implicit none
|
||||
integer :: i,degree
|
||||
integer :: exc(0:2,2,2),h1,p1,s1,h2,p2,s2
|
||||
double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e,e_pt2
|
||||
double precision :: contrib_pt,e_corr,coef,contrib,phase
|
||||
double precision :: accu_positive,accu_positive_pt, accu_positive_core,accu_positive_core_pt
|
||||
e_pt2 = 0.d0
|
||||
accu_positive = 0.D0
|
||||
accu_positive_pt = 0.D0
|
||||
accu_positive_core = 0.d0
|
||||
accu_positive_core_pt = 0.d0
|
||||
|
||||
do i = 1, N_det
|
||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||
if(degree == 1 .or. degree == 2)then
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
|
||||
delta_e = e_tilde_00 - e_i0
|
||||
coef_pt1 = htilde_ij / delta_e
|
||||
|
||||
call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
contrib_pt = coef_pt1 * htilde_ij
|
||||
e_pt2 += contrib_pt
|
||||
|
||||
coef = psi_r_coef_bi_ortho(i,1)/psi_r_coef_bi_ortho(1,1)
|
||||
contrib = coef * htilde_ij
|
||||
e_corr += contrib
|
||||
call get_excitation(HF_bitmask,psi_det(1,1,i),exc,degree,phase,N_int)
|
||||
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||
print*,'*********'
|
||||
if(degree==1)then
|
||||
print*,'s1',s1
|
||||
print*,'h1,p1 = ',h1,p1
|
||||
else if(degree ==2)then
|
||||
print*,'s1',s1
|
||||
print*,'h1,p1 = ',h1,p1
|
||||
print*,'s2',s2
|
||||
print*,'h2,p2 = ',h2,p2
|
||||
endif
|
||||
print*,'coef_pt1 = ',coef_pt1
|
||||
print*,'coef = ',coef
|
||||
print*,'contrib_pt ',contrib_pt
|
||||
print*,'contrib = ',contrib
|
||||
if(contrib.gt.0.d0)then
|
||||
accu_positive += contrib
|
||||
if(h1==1.or.h2==1)then
|
||||
accu_positive_core += contrib
|
||||
endif
|
||||
if(dabs(contrib).gt.1.d-5)then
|
||||
print*,'Found a positive contribution to correlation energy !!'
|
||||
endif
|
||||
endif
|
||||
if(contrib_pt.gt.0.d0)then
|
||||
accu_positive_pt += contrib_pt
|
||||
if(h2==1.or.h1==1)then
|
||||
accu_positive_core_pt += contrib_pt
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
print*,''
|
||||
print*,''
|
||||
print*,'Total correlation energy = ',e_corr
|
||||
print*,'Total correlation energy PT = ',e_pt2
|
||||
print*,'Positive contribution to ecorr = ',accu_positive
|
||||
print*,'Positive contribution to ecorr PT = ',accu_positive_pt
|
||||
print*,'Pure core contribution = ',accu_positive_core
|
||||
print*,'Pure core contribution PT = ',accu_positive_core_pt
|
||||
end
|
||||
|
|
@ -0,0 +1,157 @@
|
|||
use bitmasks
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_tc, (psi_det_size) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Contribution of determinants to the state-averaged density.
|
||||
END_DOC
|
||||
integer :: i,j,k
|
||||
double precision :: f
|
||||
|
||||
psi_average_norm_contrib_tc(:) = 0.d0
|
||||
do k=1,N_states
|
||||
do i=1,N_det
|
||||
psi_average_norm_contrib_tc(i) = psi_average_norm_contrib_tc(i) + &
|
||||
dabs(psi_l_coef_bi_ortho(i,k)*psi_r_coef_bi_ortho(i,k))*state_average_weight(k)
|
||||
enddo
|
||||
enddo
|
||||
f = 1.d0/sum(psi_average_norm_contrib_tc(1:N_det))
|
||||
do i=1,N_det
|
||||
psi_average_norm_contrib_tc(i) = psi_average_norm_contrib_tc(i)*f
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_coef_sorted_tc, (psi_det_size,N_states) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted_tc, (psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ integer, psi_det_sorted_tc_order, (psi_det_size) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Wave function sorted by determinants contribution to the norm (state-averaged)
|
||||
!
|
||||
! psi_det_sorted_tc_order(i) -> k : index in psi_det
|
||||
END_DOC
|
||||
integer :: i,j,k
|
||||
integer, allocatable :: iorder(:)
|
||||
allocate ( iorder(N_det) )
|
||||
do i=1,N_det
|
||||
psi_average_norm_contrib_sorted_tc(i) = -psi_average_norm_contrib_tc(i)
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(psi_average_norm_contrib_sorted_tc,iorder,N_det)
|
||||
do i=1,N_det
|
||||
do j=1,N_int
|
||||
psi_det_sorted_tc(j,1,i) = psi_det(j,1,iorder(i))
|
||||
psi_det_sorted_tc(j,2,i) = psi_det(j,2,iorder(i))
|
||||
enddo
|
||||
psi_average_norm_contrib_sorted_tc(i) = -psi_average_norm_contrib_sorted_tc(i)
|
||||
psi_det_sorted_tc_order(iorder(i)) = i
|
||||
enddo
|
||||
double precision :: accu
|
||||
do k=1,N_states
|
||||
accu = 0.d0
|
||||
do i=1,N_det
|
||||
psi_coef_sorted_tc(i,k) = dsqrt(dabs(psi_l_coef_bi_ortho(iorder(i),k)*psi_r_coef_bi_ortho(iorder(i),k)))
|
||||
accu += psi_coef_sorted_tc(i,k)**2
|
||||
enddo
|
||||
accu = 1.d0/dsqrt(accu)
|
||||
do i=1,N_det
|
||||
psi_coef_sorted_tc(i,k) *= accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
psi_det_sorted_tc(:,:,N_det+1:psi_det_size) = 0_bit_kind
|
||||
psi_coef_sorted_tc(N_det+1:psi_det_size,:) = 0.d0
|
||||
psi_average_norm_contrib_sorted_tc(N_det+1:psi_det_size) = 0.d0
|
||||
psi_det_sorted_tc_order(N_det+1:psi_det_size) = 0
|
||||
|
||||
deallocate(iorder)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [double precision, psi_r_coef_sorted_bi_ortho, (psi_det_size, N_states)]
|
||||
&BEGIN_PROVIDER [double precision, psi_l_coef_sorted_bi_ortho, (psi_det_size, N_states)]
|
||||
BEGIN_DOC
|
||||
! psi_r_coef_sorted_bi_ortho : right coefficients corresponding to psi_det_sorted_tc
|
||||
! psi_l_coef_sorted_bi_ortho : left coefficients corresponding to psi_det_sorted_tc
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i, j, k
|
||||
psi_r_coef_sorted_bi_ortho = 0.d0
|
||||
psi_l_coef_sorted_bi_ortho = 0.d0
|
||||
do i = 1, N_det
|
||||
psi_r_coef_sorted_bi_ortho(i,1) = psi_r_coef_bi_ortho(psi_det_sorted_tc_order(i),1)
|
||||
psi_l_coef_sorted_bi_ortho(i,1) = psi_l_coef_bi_ortho(psi_det_sorted_tc_order(i),1)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_bit, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_coef_sorted_tc_bit, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Determinants on which we apply $\langle i|H|psi \rangle$ for perturbation.
|
||||
! They are sorted by determinants interpreted as integers. Useful
|
||||
! to accelerate the search of a random determinant in the wave
|
||||
! function.
|
||||
END_DOC
|
||||
|
||||
call sort_dets_by_det_search_key(N_det, psi_det, psi_coef, size(psi_coef,1), &
|
||||
psi_det_sorted_tc_bit, psi_coef_sorted_tc_bit, N_states)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_right, (N_int,2,N_det) ]
|
||||
&BEGIN_PROVIDER [double precision, psi_r_coef_sorted_bi_ortho_right, (N_det)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! psi_det_sorted_tc_right : Slater determinants sorted by decreasing value of |right- coefficients|
|
||||
!
|
||||
! psi_r_coef_sorted_bi_ortho_right : right wave function according to psi_det_sorted_tc_right
|
||||
END_DOC
|
||||
integer, allocatable :: iorder(:)
|
||||
double precision, allocatable :: coef(:)
|
||||
integer :: i,j
|
||||
allocate ( iorder(N_det) , coef(N_det))
|
||||
do i=1,N_det
|
||||
coef(i) = -dabs(psi_r_coef_bi_ortho(i,1)/psi_r_coef_bi_ortho(1,1))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(coef,iorder,N_det)
|
||||
do i=1,N_det
|
||||
do j=1,N_int
|
||||
psi_det_sorted_tc_right(j,1,i) = psi_det(j,1,iorder(i))
|
||||
psi_det_sorted_tc_right(j,2,i) = psi_det(j,2,iorder(i))
|
||||
enddo
|
||||
psi_r_coef_sorted_bi_ortho_right(i) = psi_r_coef_bi_ortho(iorder(i),1)/psi_r_coef_bi_ortho(iorder(1),1)
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_left, (N_int,2,N_det) ]
|
||||
&BEGIN_PROVIDER [double precision, psi_l_coef_sorted_bi_ortho_left, (N_det)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! psi_det_sorted_tc_left : Slater determinants sorted by decreasing value of |LEFTt- coefficients|
|
||||
!
|
||||
! psi_r_coef_sorted_bi_ortho_left : LEFT wave function according to psi_det_sorted_tc_left
|
||||
END_DOC
|
||||
integer, allocatable :: iorder(:)
|
||||
double precision, allocatable :: coef(:)
|
||||
integer :: i,j
|
||||
allocate ( iorder(N_det) , coef(N_det))
|
||||
do i=1,N_det
|
||||
coef(i) = -dabs(psi_l_coef_bi_ortho(i,1)/psi_r_coef_bi_ortho(1,1))
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(coef,iorder,N_det)
|
||||
do i=1,N_det
|
||||
do j=1,N_int
|
||||
psi_det_sorted_tc_left(j,1,i) = psi_det(j,1,iorder(i))
|
||||
psi_det_sorted_tc_left(j,2,i) = psi_det(j,2,iorder(i))
|
||||
enddo
|
||||
psi_l_coef_sorted_bi_ortho_left(i) = psi_l_coef_bi_ortho(iorder(i),1)/psi_l_coef_bi_ortho(iorder(1),1)
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_bitcleft_bilinear_matrix_values, (N_det,N_states) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! Sparse coefficient matrix if the wave function is expressed in a bilinear form :
|
||||
! $D_\alpha^\dagger.C.D_\beta$
|
||||
!
|
||||
! Rows are $\alpha$ determinants and columns are $\beta$.
|
||||
!
|
||||
! Order refers to psi_det
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer :: k, l
|
||||
|
||||
if(N_det .eq. 1) then
|
||||
|
||||
do l = 1, N_states
|
||||
psi_bitcleft_bilinear_matrix_values(1,l) = 1.d0
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
do l = 1, N_states
|
||||
do k = 1, N_det
|
||||
psi_bitcleft_bilinear_matrix_values(k,l) = psi_l_coef_bi_ortho(k,l)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
PROVIDE psi_bilinear_matrix_order
|
||||
do l = 1, N_states
|
||||
call dset_order(psi_bitcleft_bilinear_matrix_values(1,l), psi_bilinear_matrix_order, N_det)
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
|
|
@ -0,0 +1,234 @@
|
|||
use bitmasks
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_l_coef_bi_ortho, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file
|
||||
! is empty.
|
||||
END_DOC
|
||||
|
||||
integer :: i,k, N_int2
|
||||
logical :: exists
|
||||
character*(64) :: label
|
||||
|
||||
PROVIDE read_wf N_det mo_label ezfio_filename nproc
|
||||
psi_l_coef_bi_ortho = 0.d0
|
||||
do i=1,min(N_states,N_det)
|
||||
psi_l_coef_bi_ortho(i,i) = 1.d0
|
||||
enddo
|
||||
|
||||
if (mpi_master) then
|
||||
if (read_wf) then
|
||||
call ezfio_has_tc_bi_ortho_psi_l_coef_bi_ortho(exists)
|
||||
! if (exists) then
|
||||
! call ezfio_has_tc_bi_ortho_mo_label(exists)
|
||||
! if (exists) then
|
||||
! call ezfio_get_tc_bi_ortho_mo_label(label)
|
||||
! exists = (label == mo_label)
|
||||
! endif
|
||||
! endif
|
||||
|
||||
if (exists) then
|
||||
|
||||
double precision, allocatable :: psi_l_coef_bi_ortho_read(:,:)
|
||||
allocate (psi_l_coef_bi_ortho_read(N_det,N_states))
|
||||
print *, 'Read psi_l_coef_bi_ortho', N_det, N_states
|
||||
call ezfio_get_tc_bi_ortho_psi_l_coef_bi_ortho(psi_l_coef_bi_ortho_read)
|
||||
do k=1,N_states
|
||||
do i=1,N_det
|
||||
psi_l_coef_bi_ortho(i,k) = psi_l_coef_bi_ortho_read(i,k)
|
||||
enddo
|
||||
enddo
|
||||
deallocate(psi_l_coef_bi_ortho_read)
|
||||
|
||||
else
|
||||
|
||||
print*, 'psi_l_coef_bi_ortho are psi_coef'
|
||||
do k=1,N_states
|
||||
do i=1,N_det
|
||||
psi_l_coef_bi_ortho(i,k) = psi_coef(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
IRP_ENDIF
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
call MPI_BCAST( psi_l_coef_bi_ortho, size(psi_l_coef_bi_ortho), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read psi_l_coef_bi_ortho with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_r_coef_bi_ortho, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file
|
||||
! is empty.
|
||||
END_DOC
|
||||
|
||||
integer :: i,k, N_int2
|
||||
logical :: exists
|
||||
character*(64) :: label
|
||||
|
||||
PROVIDE read_wf N_det mo_label ezfio_filename nproc
|
||||
psi_r_coef_bi_ortho = 0.d0
|
||||
do i=1,min(N_states,N_det)
|
||||
psi_r_coef_bi_ortho(i,i) = 1.d0
|
||||
enddo
|
||||
|
||||
if (mpi_master) then
|
||||
if (read_wf) then
|
||||
call ezfio_has_tc_bi_ortho_psi_r_coef_bi_ortho(exists)
|
||||
! if (exists) then
|
||||
! call ezfio_has_tc_bi_ortho_mo_label(exists)
|
||||
! if (exists) then
|
||||
! call ezfio_get_tc_bi_ortho_mo_label(label)
|
||||
! exists = (label == mo_label)
|
||||
! endif
|
||||
! endif
|
||||
|
||||
if (exists) then
|
||||
|
||||
double precision, allocatable :: psi_r_coef_bi_ortho_read(:,:)
|
||||
allocate (psi_r_coef_bi_ortho_read(N_det,N_states))
|
||||
print *, 'Read psi_r_coef_bi_ortho', N_det, N_states
|
||||
call ezfio_get_tc_bi_ortho_psi_r_coef_bi_ortho(psi_r_coef_bi_ortho_read)
|
||||
do k=1,N_states
|
||||
do i=1,N_det
|
||||
psi_r_coef_bi_ortho(i,k) = psi_r_coef_bi_ortho_read(i,k)
|
||||
enddo
|
||||
enddo
|
||||
deallocate(psi_r_coef_bi_ortho_read)
|
||||
|
||||
else
|
||||
|
||||
print*, 'psi_r_coef_bi_ortho are psi_coef'
|
||||
do k=1,N_states
|
||||
do i=1,N_det
|
||||
psi_r_coef_bi_ortho(i,k) = psi_coef(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
IRP_ENDIF
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
call MPI_BCAST( psi_r_coef_bi_ortho, size(psi_r_coef_bi_ortho), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read psi_r_coef_bi_ortho with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
subroutine save_tc_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psilcoef,psircoef)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Save the wave function into the |EZFIO| file
|
||||
END_DOC
|
||||
use bitmasks
|
||||
include 'constants.include.F'
|
||||
integer, intent(in) :: ndet,nstates,dim_psicoef
|
||||
integer(bit_kind), intent(in) :: psidet(N_int,2,ndet)
|
||||
double precision, intent(in) :: psilcoef(dim_psicoef,nstates)
|
||||
double precision, intent(in) :: psircoef(dim_psicoef,nstates)
|
||||
integer*8, allocatable :: psi_det_save(:,:,:)
|
||||
double precision, allocatable :: psil_coef_save(:,:)
|
||||
double precision, allocatable :: psir_coef_save(:,:)
|
||||
|
||||
double precision :: accu_norm
|
||||
integer :: i,j,k, ndet_qp_edit
|
||||
|
||||
if (mpi_master) then
|
||||
ndet_qp_edit = min(ndet,N_det_qp_edit)
|
||||
|
||||
call ezfio_set_determinants_N_int(N_int)
|
||||
call ezfio_set_determinants_bit_kind(bit_kind)
|
||||
call ezfio_set_determinants_N_det(ndet)
|
||||
call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit)
|
||||
call ezfio_set_determinants_n_states(nstates)
|
||||
call ezfio_set_determinants_mo_label(mo_label)
|
||||
|
||||
allocate (psi_det_save(N_int,2,ndet))
|
||||
do i=1,ndet
|
||||
do j=1,2
|
||||
do k=1,N_int
|
||||
psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
call ezfio_set_determinants_psi_det(psi_det_save)
|
||||
call ezfio_set_determinants_psi_det_qp_edit(psi_det_save)
|
||||
deallocate (psi_det_save)
|
||||
|
||||
allocate (psil_coef_save(ndet,nstates),psir_coef_save(ndet,nstates))
|
||||
do k=1,nstates
|
||||
do i=1,ndet
|
||||
psil_coef_save(i,k) = psilcoef(i,k)
|
||||
psir_coef_save(i,k) = psircoef(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call ezfio_set_tc_bi_ortho_psi_l_coef_bi_ortho(psil_coef_save)
|
||||
call ezfio_set_tc_bi_ortho_psi_r_coef_bi_ortho(psir_coef_save)
|
||||
deallocate (psil_coef_save,psir_coef_save)
|
||||
|
||||
! allocate (psi_coef_save(ndet_qp_edit,nstates))
|
||||
! do k=1,nstates
|
||||
! do i=1,ndet_qp_edit
|
||||
! psi_coef_save(i,k) = psicoef(i,k)
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save)
|
||||
! deallocate (psi_coef_save)
|
||||
|
||||
call write_int(6,ndet,'Saved determinantsi and psi_r/psi_l coef')
|
||||
endif
|
||||
end
|
||||
|
||||
subroutine save_tc_bi_ortho_wavefunction
|
||||
implicit none
|
||||
call save_tc_wavefunction_general(N_det,N_states,psi_det,size(psi_l_coef_bi_ortho, 1),psi_l_coef_bi_ortho,psi_r_coef_bi_ortho)
|
||||
call routine_save_right_bi_ortho
|
||||
end
|
||||
|
||||
subroutine routine_save_right_bi_ortho
|
||||
implicit none
|
||||
double precision, allocatable :: coef_tmp(:,:)
|
||||
integer :: i
|
||||
allocate(coef_tmp(N_det, N_states))
|
||||
do i = 1, N_det
|
||||
coef_tmp(i,1:N_states) = psi_r_coef_bi_ortho(i,1:N_states)
|
||||
enddo
|
||||
call save_wavefunction_general_unormalized(N_det,N_states,psi_det,size(coef_tmp,1),coef_tmp(1,1))
|
||||
end
|
||||
|
||||
subroutine routine_save_left_right_bi_ortho
|
||||
implicit none
|
||||
double precision, allocatable :: coef_tmp(:,:)
|
||||
integer :: i,n_states_tmp
|
||||
n_states_tmp = 2
|
||||
allocate(coef_tmp(N_det, n_states_tmp))
|
||||
do i = 1, N_det
|
||||
coef_tmp(i,1) = psi_r_coef_bi_ortho(i,1)
|
||||
coef_tmp(i,2) = psi_l_coef_bi_ortho(i,1)
|
||||
enddo
|
||||
call save_wavefunction_general_unormalized(N_det,n_states_tmp,psi_det,size(coef_tmp,1),coef_tmp(1,1))
|
||||
end
|
||||
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
program save_bitcpsileft_for_qmcchem
|
||||
|
||||
integer :: iunit
|
||||
logical :: exists
|
||||
double precision :: e_ref
|
||||
|
||||
print *, ' '
|
||||
print *, ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
|
||||
print *, ' call save_for_qmcchem before '
|
||||
print *, ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
|
||||
print *, ' '
|
||||
|
||||
call write_lr_spindeterminants()
|
||||
|
||||
e_ref = 0.d0
|
||||
iunit = 13
|
||||
open(unit=iunit, file=trim(ezfio_filename)//'/simulation/e_ref', action='write')
|
||||
|
||||
call ezfio_has_fci_energy_pt2(exists)
|
||||
if(.not.exists) then
|
||||
|
||||
call ezfio_has_fci_energy(exists)
|
||||
if(.not.exists) then
|
||||
|
||||
call ezfio_has_cisd_energy(exists)
|
||||
if(.not.exists) then
|
||||
|
||||
call ezfio_has_tc_scf_bitc_energy(exists)
|
||||
if(exists) then
|
||||
call ezfio_get_tc_scf_bitc_energy(e_ref)
|
||||
endif
|
||||
|
||||
else
|
||||
call ezfio_get_cisd_energy(e_ref)
|
||||
endif
|
||||
|
||||
else
|
||||
call ezfio_get_fci_energy(e_ref)
|
||||
endif
|
||||
|
||||
else
|
||||
call ezfio_get_fci_energy_pt2(e_ref)
|
||||
endif
|
||||
|
||||
write(iunit,*) e_ref
|
||||
|
||||
close(iunit)
|
||||
|
||||
end
|
||||
|
||||
! --
|
||||
|
||||
subroutine write_lr_spindeterminants()
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: k, l
|
||||
double precision, allocatable :: buffer(:,:)
|
||||
|
||||
PROVIDE psi_bitcleft_bilinear_matrix_values
|
||||
|
||||
allocate(buffer(N_det,N_states))
|
||||
do l = 1, N_states
|
||||
do k = 1, N_det
|
||||
buffer(k,l) = psi_bitcleft_bilinear_matrix_values(k,l)
|
||||
enddo
|
||||
enddo
|
||||
call ezfio_set_spindeterminants_psi_left_coef_matrix_values(buffer)
|
||||
deallocate(buffer)
|
||||
|
||||
end subroutine write_lr_spindeterminants
|
||||
|
||||
! ---
|
||||
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
program tc_bi_ortho
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
call routine_save_left_right_bi_ortho
|
||||
! call test
|
||||
end
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
program tc_natorb_bi_ortho
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
call print_energy_and_mos
|
||||
call save_tc_natorb
|
||||
! call minimize_tc_orb_angles
|
||||
end
|
||||
|
||||
subroutine save_tc_natorb
|
||||
implicit none
|
||||
print*,'Saving the natorbs '
|
||||
provide natorb_tc_leigvec_ao natorb_tc_reigvec_ao
|
||||
call ezfio_set_bi_ortho_mos_mo_l_coef(natorb_tc_leigvec_ao)
|
||||
call ezfio_set_bi_ortho_mos_mo_r_coef(natorb_tc_reigvec_ao)
|
||||
call save_ref_determinant_nstates_1
|
||||
call ezfio_set_determinants_read_wf(.False.)
|
||||
end
|
||||
|
||||
subroutine save_ref_determinant_nstates_1
|
||||
implicit none
|
||||
use bitmasks
|
||||
double precision :: buffer(1,N_states)
|
||||
buffer = 0.d0
|
||||
buffer(1,1) = 1.d0
|
||||
call save_wavefunction_general(1,1,ref_bitmask,1,buffer)
|
||||
end
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
program tc_bi_ortho
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
!!!!!!!!!!!!!!! WARNING NO 3-BODY
|
||||
!!!!!!!!!!!!!!! WARNING NO 3-BODY
|
||||
three_body_h_tc = .False.
|
||||
touch three_body_h_tc
|
||||
!!!!!!!!!!!!!!! WARNING NO 3-BODY
|
||||
!!!!!!!!!!!!!!! WARNING NO 3-BODY
|
||||
|
||||
call routine_test
|
||||
! call test
|
||||
end
|
||||
|
||||
subroutine routine_test
|
||||
implicit none
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
integer :: i,n_good,degree
|
||||
integer(bit_kind), allocatable :: dets(:,:,:)
|
||||
integer, allocatable :: iorder(:)
|
||||
double precision, allocatable :: coef(:),coef_new(:,:)
|
||||
double precision :: thr
|
||||
allocate(coef(N_det), iorder(N_det))
|
||||
do i = 1, N_det
|
||||
iorder(i) = i
|
||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||
if(degree==1)then
|
||||
coef(i) = -0.5d0
|
||||
else
|
||||
coef(i) = -dabs(coef_pt1_bi_ortho(i))
|
||||
endif
|
||||
enddo
|
||||
call dsort(coef,iorder,N_det)
|
||||
!thr = save_threshold
|
||||
thr = 1d-15
|
||||
n_good = 0
|
||||
do i = 1, N_det
|
||||
if(dabs(coef(i)).gt.thr)then
|
||||
n_good += 1
|
||||
endif
|
||||
enddo
|
||||
print*,'n_good = ',n_good
|
||||
allocate(dets(N_int,2,n_good),coef_new(n_good,n_states))
|
||||
do i = 1, n_good
|
||||
dets(:,:,i) = psi_det(:,:,iorder(i))
|
||||
coef_new(i,:) = psi_coef(iorder(i),:)
|
||||
enddo
|
||||
call save_wavefunction_general(n_good,n_states,dets,n_good,coef_new)
|
||||
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,376 @@
|
|||
|
||||
! ---
|
||||
|
||||
subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
|
||||
double precision, intent(out) :: htot
|
||||
double precision :: hmono, htwoe, hthree
|
||||
integer :: degree
|
||||
|
||||
call get_excitation_degree(key_j, key_i, degree, Nint)
|
||||
if(degree.gt.2)then
|
||||
htot = 0.d0
|
||||
else
|
||||
call htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
|
||||
endif
|
||||
|
||||
end subroutine htilde_mu_mat_bi_ortho_tot
|
||||
|
||||
! --
|
||||
|
||||
subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
|
||||
!!
|
||||
! Returns the detail of the matrix element in terms of single, two and three electron contribution.
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe, hthree, htot
|
||||
integer :: degree
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
htot = 0.d0
|
||||
hthree = 0.D0
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree.gt.2) return
|
||||
|
||||
if(degree == 0)then
|
||||
call diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot)
|
||||
else if (degree == 1)then
|
||||
call single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
||||
else if(degree == 2)then
|
||||
call double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
||||
endif
|
||||
|
||||
if(three_body_h_tc) then
|
||||
if(degree == 2) then
|
||||
if(.not.double_normal_ord) then
|
||||
call double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
|
||||
endif
|
||||
else if(degree == 1) then
|
||||
call single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
|
||||
else if(degree == 0) then
|
||||
call diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
|
||||
endif
|
||||
endif
|
||||
|
||||
htot = hmono + htwoe + hthree
|
||||
if(degree==0) then
|
||||
htot += nuclear_repulsion
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2)
|
||||
double precision, intent(out) :: hmono,htwoe,htot
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
double precision :: get_mo_two_e_integral_tc_int
|
||||
integer(bit_kind) :: key_i_core(Nint,2)
|
||||
|
||||
! PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e
|
||||
!
|
||||
! PROVIDE mo_integrals_erf_map core_energy nuclear_repulsion core_bitmask
|
||||
! PROVIDE core_fock_operator
|
||||
!
|
||||
! PROVIDE j1b_gauss
|
||||
|
||||
! if(core_tc_op)then
|
||||
! print*,'core_tc_op not already taken into account for bi ortho'
|
||||
! print*,'stopping ...'
|
||||
! stop
|
||||
! do i = 1, Nint
|
||||
! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
|
||||
! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
|
||||
! enddo
|
||||
! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
|
||||
! hmono = core_energy - nuclear_repulsion
|
||||
! else
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
hmono = 0.d0
|
||||
! endif
|
||||
htwoe= 0.d0
|
||||
htot = 0.d0
|
||||
|
||||
do ispin = 1, 2
|
||||
do i = 1, Ne(ispin) !
|
||||
ii = occ(i,ispin)
|
||||
hmono += mo_bi_ortho_tc_one_e(ii,ii)
|
||||
|
||||
! if(j1b_gauss .eq. 1) then
|
||||
! print*,'j1b not implemented for bi ortho TC'
|
||||
! print*,'stopping ....'
|
||||
! stop
|
||||
! !hmono += mo_j1b_gauss_hermI (ii,ii) &
|
||||
! ! + mo_j1b_gauss_hermII (ii,ii) &
|
||||
! ! + mo_j1b_gauss_nonherm(ii,ii)
|
||||
! endif
|
||||
|
||||
! if(core_tc_op)then
|
||||
! print*,'core_tc_op not already taken into account for bi ortho'
|
||||
! print*,'stopping ...'
|
||||
! stop
|
||||
! hmono += core_fock_operator(ii,ii) ! add the usual Coulomb - Exchange from the core
|
||||
! endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
! alpha/beta two-body
|
||||
ispin = 1
|
||||
jspin = 2
|
||||
do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1))
|
||||
ii = occ(i,ispin)
|
||||
do j = 1, Ne(jspin) ! electron 2
|
||||
jj = occ(j,jspin)
|
||||
htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! alpha/alpha two-body
|
||||
do i = 1, Ne(ispin)
|
||||
ii = occ(i,ispin)
|
||||
do j = i+1, Ne(ispin)
|
||||
jj = occ(j,ispin)
|
||||
htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! beta/beta two-body
|
||||
do i = 1, Ne(jspin)
|
||||
ii = occ(i,jspin)
|
||||
do j = i+1, Ne(jspin)
|
||||
jj = occ(j,jspin)
|
||||
htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
htot = hmono + htwoe
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> for double excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe, htot
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
integer :: other_spin(2)
|
||||
integer(bit_kind) :: key_i_core(Nint,2)
|
||||
double precision :: get_mo_two_e_integral_tc_int,phase
|
||||
|
||||
! PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e
|
||||
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe= 0.d0
|
||||
htot = 0.d0
|
||||
|
||||
if(degree.ne.2)then
|
||||
return
|
||||
endif
|
||||
|
||||
! if(core_tc_op)then
|
||||
! print*,'core_tc_op not already taken into account for bi ortho'
|
||||
! print*,'stopping ...'
|
||||
! stop
|
||||
! do i = 1, Nint
|
||||
! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
|
||||
! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
|
||||
! enddo
|
||||
! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
|
||||
! else
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
! endif
|
||||
call get_double_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
|
||||
|
||||
if(s1.ne.s2)then
|
||||
! opposite spin two-body
|
||||
! key_j, key_i
|
||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||
if(double_normal_ord.and.+Ne(1).gt.2)then
|
||||
htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ???
|
||||
endif
|
||||
else
|
||||
! same spin two-body
|
||||
! direct terms
|
||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||
! exchange terms
|
||||
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
|
||||
if(double_normal_ord.and.+Ne(1).gt.2)then
|
||||
htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ???
|
||||
htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ???
|
||||
endif
|
||||
endif
|
||||
htwoe *= phase
|
||||
htot = htwoe
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe, htot
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: get_mo_two_e_integral_tc_int, phase
|
||||
double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13
|
||||
integer :: other_spin(2)
|
||||
integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2)
|
||||
|
||||
! PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e
|
||||
!
|
||||
! PROVIDE core_bitmask core_fock_operator mo_integrals_erf_map
|
||||
|
||||
! PROVIDE j1b_gauss
|
||||
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe= 0.d0
|
||||
htot = 0.d0
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree.ne.1)then
|
||||
return
|
||||
endif
|
||||
! if(core_tc_op)then
|
||||
! print*,'core_tc_op not already taken into account for bi ortho'
|
||||
! print*,'stopping ...'
|
||||
! stop
|
||||
! do i = 1, Nint
|
||||
! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
|
||||
! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
|
||||
! key_j_core(i,1) = xor(key_j(i,1),core_bitmask(i,1))
|
||||
! key_j_core(i,2) = xor(key_j(i,2),core_bitmask(i,2))
|
||||
! enddo
|
||||
! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
|
||||
! else
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
! endif
|
||||
|
||||
call get_single_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
|
||||
! if(h1==14.and.p1==2)then
|
||||
! print*,'h1,p1 old = ',h1,p1
|
||||
! endif
|
||||
|
||||
hmono = mo_bi_ortho_tc_one_e(p1,h1) * phase
|
||||
|
||||
! if(j1b_gauss .eq. 1) then
|
||||
! print*,'j1b not implemented for bi ortho TC'
|
||||
! print*,'stopping ....'
|
||||
! stop
|
||||
! !hmono += ( mo_j1b_gauss_hermI (h1,p1) &
|
||||
! ! + mo_j1b_gauss_hermII (h1,p1) &
|
||||
! ! + mo_j1b_gauss_nonherm(h1,p1) ) * phase
|
||||
! endif
|
||||
|
||||
! if(core_tc_op)then
|
||||
! print*,'core_tc_op not already taken into account for bi ortho'
|
||||
! print*,'stopping ...'
|
||||
! stop
|
||||
! hmono += phase * core_fock_operator(h1,p1)
|
||||
! endif
|
||||
|
||||
! alpha/beta two-body
|
||||
ispin = other_spin(s1)
|
||||
if(s1==1)then
|
||||
! single alpha
|
||||
do i = 1, Ne(ispin) ! electron 2
|
||||
ii = occ(i,ispin)
|
||||
htwoe += mo_bi_ortho_tc_two_e(ii,p1,ii,h1)
|
||||
enddo
|
||||
else
|
||||
! single beta
|
||||
do i = 1, Ne(ispin) ! electron 1
|
||||
ii = occ(i,ispin)
|
||||
htwoe += mo_bi_ortho_tc_two_e(p1,ii,h1,ii)
|
||||
enddo
|
||||
endif
|
||||
! ! same spin two-body
|
||||
do i = 1, Ne(s1)
|
||||
ii = occ(i,s1)
|
||||
! (h1p1|ii ii) - (h1 ii| p1 ii)
|
||||
htwoe += mo_bi_ortho_tc_two_e(ii,p1,ii,h1) - mo_bi_ortho_tc_two_e(p1,ii,ii,h1)
|
||||
enddo
|
||||
|
||||
htwoe *= phase
|
||||
htot = hmono + htwoe
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,288 @@
|
|||
subroutine provide_all_three_ints_bi_ortho
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! routine that provides all necessary three-electron integrals
|
||||
END_DOC
|
||||
if(three_body_h_tc)then
|
||||
PROVIDE three_e_3_idx_direct_bi_ort three_e_3_idx_cycle_1_bi_ort three_e_3_idx_cycle_2_bi_ort
|
||||
PROVIDE three_e_3_idx_exch23_bi_ort three_e_3_idx_exch13_bi_ort three_e_3_idx_exch12_bi_ort
|
||||
PROVIDE three_e_4_idx_direct_bi_ort three_e_4_idx_cycle_1_bi_ort three_e_4_idx_cycle_2_bi_ort
|
||||
PROVIDE three_e_4_idx_exch23_bi_ort three_e_4_idx_exch13_bi_ort three_e_4_idx_exch12_bi_ort
|
||||
endif
|
||||
if(.not.double_normal_ord)then
|
||||
PROVIDE three_e_5_idx_direct_bi_ort three_e_5_idx_cycle_1_bi_ort three_e_5_idx_cycle_2_bi_ort
|
||||
PROVIDE three_e_5_idx_exch23_bi_ort three_e_5_idx_exch13_bi_ort three_e_5_idx_exch12_bi_ort
|
||||
else
|
||||
PROVIDE normal_two_body_bi_orth
|
||||
endif
|
||||
end
|
||||
|
||||
subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
|
||||
|
||||
BEGIN_DOC
|
||||
! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2)
|
||||
double precision, intent(out) :: hthree
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2),i,j,ii,jj,ispin,jspin,m,mm
|
||||
integer(bit_kind) :: key_i_core(Nint,2)
|
||||
double precision :: direct_int, exchange_int
|
||||
double precision :: sym_3_e_int_from_6_idx_tensor
|
||||
double precision :: three_e_diag_parrallel_spin
|
||||
|
||||
if(core_tc_op)then
|
||||
do i = 1, Nint
|
||||
key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
|
||||
key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(key_i_core,occ,Ne,Nint)
|
||||
else
|
||||
call bitstring_to_list_ab(key_i,occ,Ne,Nint)
|
||||
endif
|
||||
hthree = 0.d0
|
||||
|
||||
if(Ne(1)+Ne(2).ge.3)then
|
||||
!! ! alpha/alpha/beta three-body
|
||||
do i = 1, Ne(1)
|
||||
ii = occ(i,1)
|
||||
do j = i+1, Ne(1)
|
||||
jj = occ(j,1)
|
||||
do m = 1, Ne(2)
|
||||
mm = occ(m,2)
|
||||
! direct_int = three_body_ints_bi_ort(mm,jj,ii,mm,jj,ii) USES THE 6-IDX TENSOR
|
||||
! exchange_int = three_body_ints_bi_ort(mm,jj,ii,mm,ii,jj) USES THE 6-IDX TENSOR
|
||||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii) ! USES 3-IDX TENSOR
|
||||
exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii) ! USES 3-IDX TENSOR
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! beta/beta/alpha three-body
|
||||
do i = 1, Ne(2)
|
||||
ii = occ(i,2)
|
||||
do j = i+1, Ne(2)
|
||||
jj = occ(j,2)
|
||||
do m = 1, Ne(1)
|
||||
mm = occ(m,1)
|
||||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii)
|
||||
exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii)
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! alpha/alpha/alpha three-body
|
||||
do i = 1, Ne(1)
|
||||
ii = occ(i,1) ! 1
|
||||
do j = i+1, Ne(1)
|
||||
jj = occ(j,1) ! 2
|
||||
do m = j+1, Ne(1)
|
||||
mm = occ(m,1) ! 3
|
||||
! ref = sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) USES THE 6 IDX TENSOR
|
||||
hthree += three_e_diag_parrallel_spin(mm,jj,ii) ! USES ONLY 3-IDX TENSORS
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! beta/beta/beta three-body
|
||||
do i = 1, Ne(2)
|
||||
ii = occ(i,2) ! 1
|
||||
do j = i+1, Ne(2)
|
||||
jj = occ(j,2) ! 2
|
||||
do m = j+1, Ne(2)
|
||||
mm = occ(m,2) ! 3
|
||||
! ref = sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) USES THE 6 IDX TENSOR
|
||||
hthree += three_e_diag_parrallel_spin(mm,jj,ii) ! USES ONLY 3-IDX TENSORS
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
|
||||
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> for single excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
|
||||
double precision, intent(out) :: hthree
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2),i,j,ii,jj,ispin,jspin,k,kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: direct_int,phase,exchange_int,three_e_single_parrallel_spin
|
||||
double precision :: sym_3_e_int_from_6_idx_tensor
|
||||
integer :: other_spin(2)
|
||||
integer(bit_kind) :: key_j_core(Nint,2),key_i_core(Nint,2)
|
||||
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
|
||||
hthree = 0.d0
|
||||
call get_excitation_degree(key_i,key_j,degree,Nint)
|
||||
if(degree.ne.1)then
|
||||
return
|
||||
endif
|
||||
if(core_tc_op)then
|
||||
do i = 1, Nint
|
||||
key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
|
||||
key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
|
||||
key_j_core(i,1) = xor(key_j(i,1),core_bitmask(i,1))
|
||||
key_j_core(i,2) = xor(key_j(i,2),core_bitmask(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
|
||||
else
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
endif
|
||||
|
||||
call get_single_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc, 1, h1, p1, h2, p2, s1, s2)
|
||||
|
||||
! alpha/alpha/beta three-body
|
||||
! print*,'IN SLAT RULES'
|
||||
if(Ne(1)+Ne(2).ge.3)then
|
||||
! hole of spin s1 :: contribution from purely other spin
|
||||
ispin = other_spin(s1) ! ispin is the other spin than s1
|
||||
do i = 1, Ne(ispin) ! i is the orbitals of the other spin than s1
|
||||
ii = occ(i,ispin)
|
||||
do j = i+1, Ne(ispin) ! j has the same spin than s1
|
||||
jj = occ(j,ispin)
|
||||
! is == ispin in ::: s1 is is s1 is is s1 is is s1 is is
|
||||
! < h1 j i | p1 j i > - < h1 j i | p1 i j >
|
||||
!
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,ii,p1,h1)
|
||||
exchange_int = three_e_4_idx_exch23_bi_ort(jj,ii,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! hole of spin s1 :: contribution from mixed other spin / same spin
|
||||
do i = 1, Ne(ispin) ! other spin
|
||||
ii = occ(i,ispin) ! other spin
|
||||
do j = 1, Ne(s1) ! same spin
|
||||
jj = occ(j,s1) ! same spin
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,ii,p1,h1)
|
||||
exchange_int = three_e_4_idx_exch13_bi_ort(jj,ii,p1,h1)
|
||||
! < h1 j i | p1 j i > - < h1 j i | j p1 i >
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! hole of spin s1 :: PURE SAME SPIN CONTRIBUTIONS !!!
|
||||
do i = 1, Ne(s1)
|
||||
ii = occ(i,s1)
|
||||
do j = i+1, Ne(s1)
|
||||
jj = occ(j,s1)
|
||||
! ref = sym_3_e_int_from_6_idx_tensor(jj,ii,p1,jj,ii,h1)
|
||||
hthree += three_e_single_parrallel_spin(jj,ii,p1,h1) ! USES THE 4-IDX TENSOR
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
hthree *= phase
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
|
||||
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> for double excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
|
||||
double precision, intent(out) :: hthree
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2),i,j,ii,jj,ispin,jspin,m,mm
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: phase
|
||||
integer :: other_spin(2)
|
||||
integer(bit_kind) :: key_i_core(Nint,2)
|
||||
double precision :: direct_int,exchange_int,sym_3_e_int_from_6_idx_tensor
|
||||
double precision :: three_e_double_parrallel_spin
|
||||
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
|
||||
hthree = 0.d0
|
||||
|
||||
if(degree.ne.2)then
|
||||
return
|
||||
endif
|
||||
|
||||
if(core_tc_op) then
|
||||
do i = 1, Nint
|
||||
key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
|
||||
key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
|
||||
else
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
endif
|
||||
call get_double_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
|
||||
|
||||
|
||||
if(Ne(1)+Ne(2).ge.3)then
|
||||
if(s1==s2)then ! same spin excitation
|
||||
ispin = other_spin(s1)
|
||||
do m = 1, Ne(ispin) ! direct(other_spin) - exchange(s1)
|
||||
mm = occ(m,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
do m = 1, Ne(s1) ! pure contribution from s1
|
||||
mm = occ(m,s1)
|
||||
hthree += three_e_double_parrallel_spin(mm,p2,h2,p1,h1)
|
||||
enddo
|
||||
else ! different spin excitation
|
||||
do m = 1, Ne(s1)
|
||||
mm = occ(m,s1) !
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch13_bi_ort(mm,p2,h2,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
do m = 1, Ne(s2)
|
||||
mm = occ(m,s2) !
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch23_bi_ort(mm,p2,h2,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
hthree *= phase
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
subroutine htilde_mu_mat_opt_bi_ortho_tot(key_j, key_i, Nint, htot)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
!
|
||||
! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
|
||||
!!
|
||||
! Returns the total matrix element
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
double precision, intent(out) :: htot
|
||||
double precision :: hmono, htwoe, hthree
|
||||
call htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
|
||||
end
|
||||
subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
|
||||
BEGIN_DOC
|
||||
!
|
||||
! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
|
||||
!!
|
||||
! Returns the detail of the matrix element in terms of single, two and three electron contribution.
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe, hthree, htot
|
||||
integer :: degree
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
htot = 0.d0
|
||||
hthree = 0.D0
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree.gt.2) return
|
||||
|
||||
if(degree == 0)then
|
||||
call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot)
|
||||
else if (degree == 1)then
|
||||
call single_htilde_mu_mat_fock_bi_ortho(Nint,key_j, key_i , hmono, htwoe, hthree, htot)
|
||||
else if(degree == 2)then
|
||||
call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
|
||||
endif
|
||||
|
||||
if(degree==0) then
|
||||
htot += nuclear_repulsion
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine htilde_mu_mat_opt_bi_ortho_no_3e(key_j, key_i, Nint, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
|
||||
!!
|
||||
! Returns the detail of the matrix element WITHOUT ANY CONTRIBUTION FROM THE THREE ELECTRON TERMS
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
double precision, intent(out) :: htot
|
||||
integer :: degree
|
||||
|
||||
htot = 0.d0
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree.gt.2) return
|
||||
|
||||
if(degree == 0)then
|
||||
call diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_i,htot)
|
||||
else if (degree == 1)then
|
||||
call single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint,key_j, key_i , htot)
|
||||
else if(degree == 2)then
|
||||
call double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
|
||||
endif
|
||||
|
||||
if(degree==0) then
|
||||
htot += nuclear_repulsion
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
|
@ -0,0 +1,473 @@
|
|||
BEGIN_PROVIDER [ double precision, ref_tc_energy_tot]
|
||||
&BEGIN_PROVIDER [ double precision, ref_tc_energy_1e]
|
||||
&BEGIN_PROVIDER [ double precision, ref_tc_energy_2e]
|
||||
&BEGIN_PROVIDER [ double precision, ref_tc_energy_3e]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Various component of the TC energy for the reference "HF" Slater determinant
|
||||
END_DOC
|
||||
double precision :: hmono, htwoe, htot, hthree
|
||||
call diag_htilde_mu_mat_bi_ortho(N_int,HF_bitmask , hmono, htwoe, htot)
|
||||
ref_tc_energy_1e = hmono
|
||||
ref_tc_energy_2e = htwoe
|
||||
if(three_body_h_tc)then
|
||||
call diag_htilde_three_body_ints_bi_ort(N_int, HF_bitmask, hthree)
|
||||
ref_tc_energy_3e = hthree
|
||||
else
|
||||
ref_tc_energy_3e = 0.d0
|
||||
endif
|
||||
ref_tc_energy_tot = ref_tc_energy_1e + ref_tc_energy_2e + ref_tc_energy_3e
|
||||
END_PROVIDER
|
||||
|
||||
subroutine diag_htilde_mu_mat_fock_bi_ortho(Nint, det_in, hmono, htwoe, hthree, htot)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $\langle i|H|i \rangle$.
|
||||
END_DOC
|
||||
integer,intent(in) :: Nint
|
||||
integer(bit_kind),intent(in) :: det_in(Nint,2)
|
||||
double precision, intent(out) :: hmono,htwoe,htot,hthree
|
||||
|
||||
integer(bit_kind) :: hole(Nint,2)
|
||||
integer(bit_kind) :: particle(Nint,2)
|
||||
integer :: i, nexc(2), ispin
|
||||
integer :: occ_particle(Nint*bit_kind_size,2)
|
||||
integer :: occ_hole(Nint*bit_kind_size,2)
|
||||
integer(bit_kind) :: det_tmp(Nint,2)
|
||||
integer :: na, nb
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (sum(popcnt(det_in(:,1))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(det_in(:,2))) == elec_beta_num)
|
||||
|
||||
|
||||
nexc(1) = 0
|
||||
nexc(2) = 0
|
||||
do i=1,Nint
|
||||
hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2))
|
||||
particle(i,1) = iand(hole(i,1),det_in(i,1))
|
||||
particle(i,2) = iand(hole(i,2),det_in(i,2))
|
||||
hole(i,1) = iand(hole(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = iand(hole(i,2),ref_bitmask(i,2))
|
||||
nexc(1) = nexc(1) + popcnt(hole(i,1))
|
||||
nexc(2) = nexc(2) + popcnt(hole(i,2))
|
||||
enddo
|
||||
|
||||
if (nexc(1)+nexc(2) == 0) then
|
||||
hmono = ref_tc_energy_1e
|
||||
htwoe = ref_tc_energy_2e
|
||||
hthree= ref_tc_energy_3e
|
||||
htot = ref_tc_energy_tot
|
||||
return
|
||||
endif
|
||||
|
||||
!call debug_det(det_in,Nint)
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(particle, occ_particle, tmp, Nint)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of particle beta
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(hole, occ_hole, tmp, Nint)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of holes beta
|
||||
|
||||
|
||||
det_tmp = ref_bitmask
|
||||
hmono = ref_tc_energy_1e
|
||||
htwoe = ref_tc_energy_2e
|
||||
hthree= ref_tc_energy_3e
|
||||
do ispin=1,2
|
||||
na = elec_num_tab(ispin)
|
||||
nb = elec_num_tab(iand(ispin,1)+1)
|
||||
do i=1,nexc(ispin)
|
||||
!DIR$ FORCEINLINE
|
||||
call ac_tc_operator( occ_particle(i,ispin), ispin, det_tmp, hmono,htwoe,hthree, Nint,na,nb)
|
||||
!DIR$ FORCEINLINE
|
||||
call a_tc_operator ( occ_hole (i,ispin), ispin, det_tmp, hmono,htwoe,hthree, Nint,na,nb)
|
||||
enddo
|
||||
enddo
|
||||
htot = hmono+htwoe+hthree
|
||||
end
|
||||
|
||||
subroutine ac_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computes one- and two-body energy corresponding
|
||||
!
|
||||
! to the ADDITION of an electron in an orbital 'iorb' of spin 'ispin'
|
||||
!
|
||||
! onto a determinant 'key'.
|
||||
!
|
||||
! in output, the determinant key is changed by the ADDITION of that electron
|
||||
!
|
||||
! and the quantities hmono,htwoe,hthree are INCREMENTED
|
||||
END_DOC
|
||||
integer, intent(in) :: iorb, ispin, Nint
|
||||
integer, intent(inout) :: na, nb
|
||||
integer(bit_kind), intent(inout) :: key(Nint,2)
|
||||
double precision, intent(inout) :: hmono,htwoe,hthree
|
||||
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: other_spin
|
||||
integer :: k,l,i,jj,mm,j,m
|
||||
double precision :: direct_int, exchange_int
|
||||
|
||||
|
||||
if (iorb < 1) then
|
||||
print *, irp_here, ': iorb < 1'
|
||||
print *, iorb, mo_num
|
||||
stop -1
|
||||
endif
|
||||
if (iorb > mo_num) then
|
||||
print *, irp_here, ': iorb > mo_num'
|
||||
print *, iorb, mo_num
|
||||
stop -1
|
||||
endif
|
||||
|
||||
ASSERT (ispin > 0)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
ASSERT (tmp(1) == elec_alpha_num)
|
||||
ASSERT (tmp(2) == elec_beta_num)
|
||||
|
||||
k = shiftr(iorb-1,bit_kind_shift)+1
|
||||
ASSERT (k >0)
|
||||
l = iorb - shiftl(k-1,bit_kind_shift)-1
|
||||
ASSERT (l >= 0)
|
||||
key(k,ispin) = ibset(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
hmono = hmono + mo_bi_ortho_tc_one_e(iorb,iorb)
|
||||
|
||||
! Same spin
|
||||
do i=1,na
|
||||
htwoe = htwoe + mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
|
||||
enddo
|
||||
|
||||
! Opposite spin
|
||||
do i=1,nb
|
||||
htwoe = htwoe + mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
|
||||
enddo
|
||||
|
||||
if(three_body_h_tc)then
|
||||
!!!!! 3-e part
|
||||
!! same-spin/same-spin
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
do m = j+1, na
|
||||
mm = occ(m,ispin)
|
||||
hthree += three_e_diag_parrallel_spin_prov(mm,jj,iorb)
|
||||
enddo
|
||||
enddo
|
||||
!! same-spin/oposite-spin
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
do m = 1, nb
|
||||
mm = occ(m,other_spin)
|
||||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
enddo
|
||||
!! oposite-spin/opposite-spin
|
||||
do j = 1, nb
|
||||
jj = occ(j,other_spin)
|
||||
do m = j+1, nb
|
||||
mm = occ(m,other_spin)
|
||||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
exchange_int = three_e_3_idx_exch23_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
na = na+1
|
||||
end
|
||||
|
||||
subroutine a_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computes one- and two-body energy corresponding
|
||||
!
|
||||
! to the REMOVAL of an electron in an orbital 'iorb' of spin 'ispin'
|
||||
!
|
||||
! onto a determinant 'key'.
|
||||
!
|
||||
! in output, the determinant key is changed by the REMOVAL of that electron
|
||||
!
|
||||
! and the quantities hmono,htwoe,hthree are INCREMENTED
|
||||
END_DOC
|
||||
integer, intent(in) :: iorb, ispin, Nint
|
||||
integer, intent(inout) :: na, nb
|
||||
integer(bit_kind), intent(inout) :: key(Nint,2)
|
||||
double precision, intent(inout) :: hmono,htwoe,hthree
|
||||
|
||||
double precision :: direct_int, exchange_int
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: other_spin
|
||||
integer :: k,l,i,jj,mm,j,m
|
||||
integer :: tmp(2)
|
||||
|
||||
ASSERT (iorb > 0)
|
||||
ASSERT (ispin > 0)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
k = shiftr(iorb-1,bit_kind_shift)+1
|
||||
ASSERT (k>0)
|
||||
l = iorb - shiftl(k-1,bit_kind_shift)-1
|
||||
key(k,ispin) = ibclr(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
na = na-1
|
||||
|
||||
hmono = hmono - mo_bi_ortho_tc_one_e(iorb,iorb)
|
||||
|
||||
! Same spin
|
||||
do i=1,na
|
||||
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
|
||||
enddo
|
||||
|
||||
! Opposite spin
|
||||
do i=1,nb
|
||||
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
|
||||
enddo
|
||||
|
||||
if(three_body_h_tc)then
|
||||
!!!!! 3-e part
|
||||
!! same-spin/same-spin
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
do m = j+1, na
|
||||
mm = occ(m,ispin)
|
||||
hthree -= three_e_diag_parrallel_spin_prov(mm,jj,iorb)
|
||||
enddo
|
||||
enddo
|
||||
!! same-spin/oposite-spin
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
do m = 1, nb
|
||||
mm = occ(m,other_spin)
|
||||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
hthree -= (direct_int - exchange_int)
|
||||
enddo
|
||||
enddo
|
||||
!! oposite-spin/opposite-spin
|
||||
do j = 1, nb
|
||||
jj = occ(j,other_spin)
|
||||
do m = j+1, nb
|
||||
mm = occ(m,other_spin)
|
||||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
exchange_int = three_e_3_idx_exch23_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
hthree -= (direct_int - exchange_int)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, det_in,htot)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $\langle i|H|i \rangle$. WITHOUT ANY CONTRIBUTIONS FROM 3E TERMS
|
||||
END_DOC
|
||||
integer,intent(in) :: Nint
|
||||
integer(bit_kind),intent(in) :: det_in(Nint,2)
|
||||
double precision, intent(out) :: htot
|
||||
double precision :: hmono,htwoe
|
||||
|
||||
integer(bit_kind) :: hole(Nint,2)
|
||||
integer(bit_kind) :: particle(Nint,2)
|
||||
integer :: i, nexc(2), ispin
|
||||
integer :: occ_particle(Nint*bit_kind_size,2)
|
||||
integer :: occ_hole(Nint*bit_kind_size,2)
|
||||
integer(bit_kind) :: det_tmp(Nint,2)
|
||||
integer :: na, nb
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (sum(popcnt(det_in(:,1))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(det_in(:,2))) == elec_beta_num)
|
||||
|
||||
|
||||
nexc(1) = 0
|
||||
nexc(2) = 0
|
||||
do i=1,Nint
|
||||
hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2))
|
||||
particle(i,1) = iand(hole(i,1),det_in(i,1))
|
||||
particle(i,2) = iand(hole(i,2),det_in(i,2))
|
||||
hole(i,1) = iand(hole(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = iand(hole(i,2),ref_bitmask(i,2))
|
||||
nexc(1) = nexc(1) + popcnt(hole(i,1))
|
||||
nexc(2) = nexc(2) + popcnt(hole(i,2))
|
||||
enddo
|
||||
|
||||
if (nexc(1)+nexc(2) == 0) then
|
||||
hmono = ref_tc_energy_1e
|
||||
htwoe = ref_tc_energy_2e
|
||||
htot = ref_tc_energy_tot
|
||||
return
|
||||
endif
|
||||
|
||||
!call debug_det(det_in,Nint)
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(particle, occ_particle, tmp, Nint)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of particle beta
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(hole, occ_hole, tmp, Nint)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of holes beta
|
||||
|
||||
|
||||
det_tmp = ref_bitmask
|
||||
hmono = ref_tc_energy_1e
|
||||
htwoe = ref_tc_energy_2e
|
||||
do ispin=1,2
|
||||
na = elec_num_tab(ispin)
|
||||
nb = elec_num_tab(iand(ispin,1)+1)
|
||||
do i=1,nexc(ispin)
|
||||
!DIR$ FORCEINLINE
|
||||
call ac_tc_operator_no_3e( occ_particle(i,ispin), ispin, det_tmp, hmono,htwoe, Nint,na,nb)
|
||||
!DIR$ FORCEINLINE
|
||||
call a_tc_operator_no_3e ( occ_hole (i,ispin), ispin, det_tmp, hmono,htwoe, Nint,na,nb)
|
||||
enddo
|
||||
enddo
|
||||
htot = hmono+htwoe
|
||||
end
|
||||
|
||||
subroutine ac_tc_operator_no_3e(iorb,ispin,key,hmono,htwoe,Nint,na,nb)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computes one- and two-body energy corresponding
|
||||
!
|
||||
! to the ADDITION of an electron in an orbital 'iorb' of spin 'ispin'
|
||||
!
|
||||
! onto a determinant 'key'.
|
||||
!
|
||||
! in output, the determinant key is changed by the ADDITION of that electron
|
||||
!
|
||||
! and the quantities hmono,htwoe are INCREMENTED
|
||||
END_DOC
|
||||
integer, intent(in) :: iorb, ispin, Nint
|
||||
integer, intent(inout) :: na, nb
|
||||
integer(bit_kind), intent(inout) :: key(Nint,2)
|
||||
double precision, intent(inout) :: hmono,htwoe
|
||||
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: other_spin
|
||||
integer :: k,l,i,jj,mm,j,m
|
||||
double precision :: direct_int, exchange_int
|
||||
|
||||
|
||||
if (iorb < 1) then
|
||||
print *, irp_here, ': iorb < 1'
|
||||
print *, iorb, mo_num
|
||||
stop -1
|
||||
endif
|
||||
if (iorb > mo_num) then
|
||||
print *, irp_here, ': iorb > mo_num'
|
||||
print *, iorb, mo_num
|
||||
stop -1
|
||||
endif
|
||||
|
||||
ASSERT (ispin > 0)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
ASSERT (tmp(1) == elec_alpha_num)
|
||||
ASSERT (tmp(2) == elec_beta_num)
|
||||
|
||||
k = shiftr(iorb-1,bit_kind_shift)+1
|
||||
ASSERT (k >0)
|
||||
l = iorb - shiftl(k-1,bit_kind_shift)-1
|
||||
ASSERT (l >= 0)
|
||||
key(k,ispin) = ibset(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
hmono = hmono + mo_bi_ortho_tc_one_e(iorb,iorb)
|
||||
|
||||
! Same spin
|
||||
do i=1,na
|
||||
htwoe = htwoe + mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
|
||||
enddo
|
||||
|
||||
! Opposite spin
|
||||
do i=1,nb
|
||||
htwoe = htwoe + mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
|
||||
enddo
|
||||
|
||||
na = na+1
|
||||
end
|
||||
|
||||
subroutine a_tc_operator_no_3e(iorb,ispin,key,hmono,htwoe,Nint,na,nb)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computes one- and two-body energy corresponding
|
||||
!
|
||||
! to the REMOVAL of an electron in an orbital 'iorb' of spin 'ispin'
|
||||
!
|
||||
! onto a determinant 'key'.
|
||||
!
|
||||
! in output, the determinant key is changed by the REMOVAL of that electron
|
||||
!
|
||||
! and the quantities hmono,htwoe are INCREMENTED
|
||||
END_DOC
|
||||
integer, intent(in) :: iorb, ispin, Nint
|
||||
integer, intent(inout) :: na, nb
|
||||
integer(bit_kind), intent(inout) :: key(Nint,2)
|
||||
double precision, intent(inout) :: hmono,htwoe
|
||||
|
||||
double precision :: direct_int, exchange_int
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: other_spin
|
||||
integer :: k,l,i,jj,mm,j,m
|
||||
integer :: tmp(2)
|
||||
|
||||
ASSERT (iorb > 0)
|
||||
ASSERT (ispin > 0)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
k = shiftr(iorb-1,bit_kind_shift)+1
|
||||
ASSERT (k>0)
|
||||
l = iorb - shiftl(k-1,bit_kind_shift)-1
|
||||
key(k,ispin) = ibclr(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
na = na-1
|
||||
|
||||
hmono = hmono - mo_bi_ortho_tc_one_e(iorb,iorb)
|
||||
|
||||
! Same spin
|
||||
do i=1,na
|
||||
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
|
||||
enddo
|
||||
|
||||
! Opposite spin
|
||||
do i=1,nb
|
||||
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
|
|
@ -0,0 +1,476 @@
|
|||
|
||||
subroutine double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> for double excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe, hthree, htot
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: get_mo_two_e_integral_tc_int,phase
|
||||
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
hthree = 0.d0
|
||||
htot = 0.d0
|
||||
|
||||
if(degree.ne.2)then
|
||||
return
|
||||
endif
|
||||
integer :: degree_i,degree_j
|
||||
call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int)
|
||||
call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int)
|
||||
call get_double_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
|
||||
|
||||
if(s1.ne.s2)then
|
||||
! opposite spin two-body
|
||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||
if(three_body_h_tc)then
|
||||
if(.not.double_normal_ord)then
|
||||
if(degree_i>degree_j)then
|
||||
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
|
||||
else
|
||||
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
|
||||
endif
|
||||
elseif(double_normal_ord.and.elec_num+elec_num.gt.2)then
|
||||
htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ???
|
||||
endif
|
||||
endif
|
||||
else
|
||||
! same spin two-body
|
||||
! direct terms
|
||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||
! exchange terms
|
||||
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
|
||||
if(three_body_h_tc)then
|
||||
if(.not.double_normal_ord)then
|
||||
if(degree_i>degree_j)then
|
||||
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
|
||||
else
|
||||
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
|
||||
endif
|
||||
elseif(double_normal_ord.and.elec_num+elec_num.gt.2)then
|
||||
htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ???
|
||||
htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ???
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
hthree *= phase
|
||||
htwoe *= phase
|
||||
htot = htwoe + hthree
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
|
||||
implicit none
|
||||
integer(bit_kind), intent(in) :: key_i(N_int,2)
|
||||
integer, intent(in) :: h1,h2,p1,p2,s1,s2
|
||||
double precision, intent(out) :: hthree
|
||||
integer :: nexc(2),i,ispin,na,nb
|
||||
integer(bit_kind) :: hole(N_int,2)
|
||||
integer(bit_kind) :: particle(N_int,2)
|
||||
integer :: occ_hole(N_int*bit_kind_size,2)
|
||||
integer :: occ_particle(N_int*bit_kind_size,2)
|
||||
integer :: n_occ_ab_hole(2),n_occ_ab_particle(2)
|
||||
integer(bit_kind) :: det_tmp(N_int,2)
|
||||
integer :: ipart, ihole
|
||||
double precision :: direct_int, exchange_int
|
||||
|
||||
nexc(1) = 0
|
||||
nexc(2) = 0
|
||||
!! Get all the holes and particles of key_i with respect to the ROHF determinant
|
||||
do i=1,N_int
|
||||
hole(i,1) = xor(key_i(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = xor(key_i(i,2),ref_bitmask(i,2))
|
||||
particle(i,1) = iand(hole(i,1),key_i(i,1))
|
||||
particle(i,2) = iand(hole(i,2),key_i(i,2))
|
||||
hole(i,1) = iand(hole(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = iand(hole(i,2),ref_bitmask(i,2))
|
||||
nexc(1) = nexc(1) + popcnt(hole(i,1))
|
||||
nexc(2) = nexc(2) + popcnt(hole(i,2))
|
||||
enddo
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(particle, occ_particle, tmp, N_int)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of particle beta
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(hole, occ_hole, tmp, N_int)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of holes beta
|
||||
if(s1==s2.and.s1==1)then
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!! alpha/alpha double exc
|
||||
hthree = eff_2_e_from_3_e_aa(p2,p1,h2,h1)
|
||||
if(nexc(1)+nexc(2) ==0)return !! if you're on the reference determinant
|
||||
!!!!!!!! the matrix element is already exact
|
||||
!!!!!!!! else you need to take care of holes and particles
|
||||
!!!!!!!!!!!!! Holes and particles !!!!!!!!!!!!!!!!!!!!!!!
|
||||
ispin = 1 ! i==alpha ==> pure same spin terms
|
||||
do i = 1, nexc(ispin) ! number of couple of holes/particles
|
||||
ipart=occ_particle(i,ispin)
|
||||
hthree += three_e_double_parrallel_spin_prov(ipart,p2,h2,p1,h1)
|
||||
ihole=occ_hole(i,ispin)
|
||||
hthree -= three_e_double_parrallel_spin_prov(ihole,p2,h2,p1,h1)
|
||||
enddo
|
||||
ispin = 2 ! i==beta ==> alpha/alpha/beta terms
|
||||
do i = 1, nexc(ispin) ! number of couple of holes/particles
|
||||
! exchange between (h1,p1) and (h2,p2)
|
||||
ipart=occ_particle(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(ipart,p2,h2,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
ihole=occ_hole(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(ihole,p2,h2,p1,h1)
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
elseif(s1==s2.and.s1==2)then
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!! beta/beta double exc
|
||||
hthree = eff_2_e_from_3_e_bb(p2,p1,h2,h1)
|
||||
if(nexc(1)+nexc(2) ==0)return !! if you're on the reference determinant
|
||||
!!!!!!!! the matrix element is already exact
|
||||
!!!!!!!! else you need to take care of holes and particles
|
||||
!!!!!!!!!!!!! Holes and particles !!!!!!!!!!!!!!!!!!!!!!!
|
||||
ispin = 2 ! i==beta ==> pure same spin terms
|
||||
do i = 1, nexc(ispin) ! number of couple of holes/particles
|
||||
ipart=occ_particle(i,ispin)
|
||||
hthree += three_e_double_parrallel_spin_prov(ipart,p2,h2,p1,h1)
|
||||
ihole=occ_hole(i,ispin)
|
||||
hthree -= three_e_double_parrallel_spin_prov(ihole,p2,h2,p1,h1)
|
||||
enddo
|
||||
ispin = 1 ! i==alpha==> beta/beta/alpha terms
|
||||
do i = 1, nexc(ispin) ! number of couple of holes/particles
|
||||
! exchange between (h1,p1) and (h2,p2)
|
||||
ipart=occ_particle(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(ipart,p2,h2,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
ihole=occ_hole(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(ihole,p2,h2,p1,h1)
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
else ! (h1,p1) == alpha/(h2,p2) == beta
|
||||
hthree = eff_2_e_from_3_e_ab(p2,p1,h2,h1)
|
||||
if(nexc(1)+nexc(2) ==0)return !! if you're on the reference determinant
|
||||
!!!!!!!! the matrix element is already exact
|
||||
!!!!!!!! else you need to take care of holes and particles
|
||||
!!!!!!!!!!!!! Holes and particles !!!!!!!!!!!!!!!!!!!!!!!
|
||||
ispin = 1 ! i==alpha ==> alpha/beta/alpha terms
|
||||
do i = 1, nexc(ispin) ! number of couple of holes/particles
|
||||
! exchange between (h1,p1) and i
|
||||
ipart=occ_particle(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch13_bi_ort(ipart,p2,h2,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
ihole=occ_hole(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch13_bi_ort(ihole,p2,h2,p1,h1)
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
ispin = 2 ! i==beta ==> alpha/beta/beta terms
|
||||
do i = 1, nexc(ispin) ! number of couple of holes/particles
|
||||
! exchange between (h2,p2) and i
|
||||
ipart=occ_particle(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch23_bi_ort(ipart,p2,h2,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
ihole=occ_hole(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch23_bi_ort(ihole,p2,h2,p1,h1)
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
endif
|
||||
end
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, eff_2_e_from_3_e_ab, (mo_num, mo_num, mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! eff_2_e_from_3_e_ab(p2,p1,h2,h1) = Effective Two-electron operator for alpha/beta double excitations
|
||||
!
|
||||
! from contraction with HF density = a^{dagger}_p1_alpha a^{dagger}_p2_beta a_h2_beta a_h1_alpha
|
||||
END_DOC
|
||||
integer :: i,h1,p1,h2,p2
|
||||
integer :: hh1,hh2,pp1,pp2,m,mm
|
||||
integer :: Ne(2)
|
||||
integer, allocatable :: occ(:,:)
|
||||
double precision :: contrib
|
||||
allocate( occ(N_int*bit_kind_size,2) )
|
||||
call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
|
||||
call give_contrib_for_abab(1,1,1,1,occ,Ne,contrib)
|
||||
eff_2_e_from_3_e_ab = 0.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, contrib) &
|
||||
!$OMP SHARED (n_act_orb, list_act, Ne,occ, eff_2_e_from_3_e_ab)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do hh1 = 1, n_act_orb !! alpha
|
||||
h1 = list_act(hh1)
|
||||
do hh2 = 1, n_act_orb !! beta
|
||||
h2 = list_act(hh2)
|
||||
do pp1 = 1, n_act_orb !! alpha
|
||||
p1 = list_act(pp1)
|
||||
do pp2 = 1, n_act_orb !! beta
|
||||
p2 = list_act(pp2)
|
||||
call give_contrib_for_abab(h1,h2,p1,p2,occ,Ne,contrib)
|
||||
eff_2_e_from_3_e_ab(p2,p1,h2,h1) = contrib
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine give_contrib_for_abab(h1,h2,p1,p2,occ,Ne,contrib)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! gives the contribution for a double excitation (h1,p1)_alpha (h2,p2)_beta
|
||||
!
|
||||
! on top of a determinant whose occupied orbitals is in (occ, Ne)
|
||||
END_DOC
|
||||
integer, intent(in) :: h1,h2,p1,p2,occ(N_int*bit_kind_size,2),Ne(2)
|
||||
double precision, intent(out) :: contrib
|
||||
integer :: mm,m
|
||||
double precision :: direct_int, exchange_int
|
||||
!! h1,p1 == alpha
|
||||
!! h2,p2 == beta
|
||||
contrib = 0.d0
|
||||
do mm = 1, Ne(1) !! alpha
|
||||
m = occ(mm,1)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
! exchange between (h1,p1) and m
|
||||
exchange_int = three_e_5_idx_exch13_bi_ort(mm,p2,h2,p1,h1)
|
||||
contrib += direct_int - exchange_int
|
||||
enddo
|
||||
|
||||
do mm = 1, Ne(2) !! beta
|
||||
m = occ(mm,2)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
! exchange between (h2,p2) and m
|
||||
exchange_int = three_e_5_idx_exch23_bi_ort(mm,p2,h2,p1,h1)
|
||||
contrib += direct_int - exchange_int
|
||||
enddo
|
||||
end
|
||||
|
||||
BEGIN_PROVIDER [ double precision, eff_2_e_from_3_e_aa, (mo_num, mo_num, mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! eff_2_e_from_3_e_ab(p2,p1,h2,h1) = Effective Two-electron operator for alpha/alpha double excitations
|
||||
!
|
||||
! from contractionelec_alpha_num with HF density = a^{dagger}_p1_alpha a^{dagger}_p2_alpha a_h2_alpha a_h1_alpha
|
||||
!
|
||||
! WARNING :: to be coherent with the phase convention used in the Hamiltonian matrix elements, you must fulfill
|
||||
!
|
||||
! |||| h2>h1, p2>p1 ||||
|
||||
END_DOC
|
||||
integer :: i,h1,p1,h2,p2
|
||||
integer :: hh1,hh2,pp1,pp2,m,mm
|
||||
integer :: Ne(2)
|
||||
integer, allocatable :: occ(:,:)
|
||||
double precision :: contrib
|
||||
allocate( occ(N_int*bit_kind_size,2) )
|
||||
call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
|
||||
call give_contrib_for_aaaa(1 ,1 ,1 ,1 ,occ,Ne,contrib)
|
||||
eff_2_e_from_3_e_aa = 100000000.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, contrib) &
|
||||
!$OMP SHARED (n_act_orb, list_act, Ne,occ, eff_2_e_from_3_e_aa)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do hh1 = 1, n_act_orb !! alpha
|
||||
h1 = list_act(hh1)
|
||||
do hh2 = hh1+1, n_act_orb !! alpha
|
||||
h2 = list_act(hh2)
|
||||
do pp1 = 1, n_act_orb !! alpha
|
||||
p1 = list_act(pp1)
|
||||
do pp2 = pp1+1, n_act_orb !! alpha
|
||||
p2 = list_act(pp2)
|
||||
call give_contrib_for_aaaa(h1,h2,p1,p2,occ,Ne,contrib)
|
||||
eff_2_e_from_3_e_aa(p2,p1,h2,h1) = contrib
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine give_contrib_for_aaaa(h1,h2,p1,p2,occ,Ne,contrib)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! gives the contribution for a double excitation (h1,p1)_alpha (h2,p2)_alpha
|
||||
!
|
||||
! on top of a determinant whose occupied orbitals is in (occ, Ne)
|
||||
END_DOC
|
||||
integer, intent(in) :: h1,h2,p1,p2,occ(N_int*bit_kind_size,2),Ne(2)
|
||||
double precision, intent(out) :: contrib
|
||||
integer :: mm,m
|
||||
double precision :: direct_int, exchange_int
|
||||
!! h1,p1 == alpha
|
||||
!! h2,p2 == alpha
|
||||
contrib = 0.d0
|
||||
do mm = 1, Ne(1) !! alpha ==> pure parallele spin contribution
|
||||
m = occ(mm,1)
|
||||
contrib += three_e_double_parrallel_spin_prov(m,p2,h2,p1,h1)
|
||||
enddo
|
||||
|
||||
do mm = 1, Ne(2) !! beta
|
||||
m = occ(mm,2)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
! exchange between (h1,p1) and (h2,p2)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1)
|
||||
contrib += direct_int - exchange_int
|
||||
enddo
|
||||
end
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, eff_2_e_from_3_e_bb, (mo_num, mo_num, mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! eff_2_e_from_3_e_ab(p2,p1,h2,h1) = Effective Two-electron operator for beta/beta double excitations
|
||||
!
|
||||
! from contractionelec_beta_num with HF density = a^{dagger}_p1_beta a^{dagger}_p2_beta a_h2_beta a_h1_beta
|
||||
!
|
||||
! WARNING :: to be coherent with the phase convention used in the Hamiltonian matrix elements, you must fulfill
|
||||
!
|
||||
! |||| h2>h1, p2>p1 ||||
|
||||
END_DOC
|
||||
integer :: i,h1,p1,h2,p2
|
||||
integer :: hh1,hh2,pp1,pp2,m,mm
|
||||
integer :: Ne(2)
|
||||
integer, allocatable :: occ(:,:)
|
||||
double precision :: contrib
|
||||
allocate( occ(N_int*bit_kind_size,2) )
|
||||
call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
|
||||
call give_contrib_for_bbbb(1,1 ,1 ,1 ,occ,Ne,contrib)
|
||||
eff_2_e_from_3_e_bb = 100000000.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, contrib) &
|
||||
!$OMP SHARED (n_act_orb, list_act, Ne,occ, eff_2_e_from_3_e_bb)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do hh1 = 1, n_act_orb !! beta
|
||||
h1 = list_act(hh1)
|
||||
do hh2 = hh1+1, n_act_orb !! beta
|
||||
h2 = list_act(hh2)
|
||||
do pp1 = 1, n_act_orb !! beta
|
||||
p1 = list_act(pp1)
|
||||
do pp2 = pp1+1, n_act_orb !! beta
|
||||
p2 = list_act(pp2)
|
||||
call give_contrib_for_bbbb(h1,h2,p1,p2,occ,Ne,contrib)
|
||||
eff_2_e_from_3_e_bb(p2,p1,h2,h1) = contrib
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine give_contrib_for_bbbb(h1,h2,p1,p2,occ,Ne,contrib)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! gives the contribution for a double excitation (h1,p1)_beta (h2,p2)_beta
|
||||
!
|
||||
! on top of a determinant whose occupied orbitals is in (occ, Ne)
|
||||
END_DOC
|
||||
integer, intent(in) :: h1,h2,p1,p2,occ(N_int*bit_kind_size,2),Ne(2)
|
||||
double precision, intent(out) :: contrib
|
||||
integer :: mm,m
|
||||
double precision :: direct_int, exchange_int
|
||||
!! h1,p1 == beta
|
||||
!! h2,p2 == beta
|
||||
contrib = 0.d0
|
||||
do mm = 1, Ne(2) !! beta ==> pure parallele spin contribution
|
||||
m = occ(mm,1)
|
||||
contrib += three_e_double_parrallel_spin_prov(m,p2,h2,p1,h1)
|
||||
enddo
|
||||
|
||||
do mm = 1, Ne(1) !! alpha
|
||||
m = occ(mm,1)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
! exchange between (h1,p1) and (h2,p2)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1)
|
||||
contrib += direct_int - exchange_int
|
||||
enddo
|
||||
end
|
||||
|
||||
|
||||
subroutine double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> for double excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: htot
|
||||
double precision :: hmono, htwoe
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: get_mo_two_e_integral_tc_int,phase
|
||||
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
htot = 0.d0
|
||||
|
||||
if(degree.ne.2)then
|
||||
return
|
||||
endif
|
||||
integer :: degree_i,degree_j
|
||||
call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int)
|
||||
call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int)
|
||||
call get_double_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
|
||||
|
||||
if(s1.ne.s2)then
|
||||
! opposite spin two-body
|
||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||
else
|
||||
! same spin two-body
|
||||
! direct terms
|
||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||
! exchange terms
|
||||
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
|
||||
endif
|
||||
htwoe *= phase
|
||||
htot = htwoe
|
||||
|
||||
end
|
||||
|
||||
|
|
@ -0,0 +1,572 @@
|
|||
|
||||
|
||||
subroutine single_htilde_mu_mat_fock_bi_ortho (Nint, key_j, key_i, hmono, htwoe, hthree, htot)
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe, hthree, htot
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: get_mo_two_e_integral_tc_int, phase
|
||||
double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13
|
||||
integer :: other_spin(2)
|
||||
integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2)
|
||||
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
hthree = 0.d0
|
||||
htot = 0.d0
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree.ne.1)then
|
||||
return
|
||||
endif
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
|
||||
call get_single_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
|
||||
call get_single_excitation_from_fock_tc(key_i,key_j,h1,p1,s1,phase,hmono,htwoe,hthree,htot)
|
||||
end
|
||||
|
||||
|
||||
subroutine get_single_excitation_from_fock_tc(key_i,key_j,h,p,spin,phase,hmono,htwoe,hthree,htot)
|
||||
use bitmasks
|
||||
implicit none
|
||||
integer,intent(in) :: h,p,spin
|
||||
double precision, intent(in) :: phase
|
||||
integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2)
|
||||
double precision, intent(out) :: hmono,htwoe,hthree,htot
|
||||
integer(bit_kind) :: differences(N_int,2)
|
||||
integer(bit_kind) :: hole(N_int,2)
|
||||
integer(bit_kind) :: partcl(N_int,2)
|
||||
integer :: occ_hole(N_int*bit_kind_size,2)
|
||||
integer :: occ_partcl(N_int*bit_kind_size,2)
|
||||
integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
|
||||
integer :: i0,i
|
||||
double precision :: buffer_c(mo_num),buffer_x(mo_num)
|
||||
do i=1, mo_num
|
||||
buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
|
||||
buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
|
||||
enddo
|
||||
do i = 1, N_int
|
||||
differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1))
|
||||
differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2))
|
||||
hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
|
||||
hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
|
||||
partcl(i,1) = iand(differences(i,1),key_i(i,1))
|
||||
partcl(i,2) = iand(differences(i,2),key_i(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
|
||||
call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
|
||||
hmono = mo_bi_ortho_tc_one_e(p,h)
|
||||
htwoe = fock_op_2_e_tc_closed_shell(p,h)
|
||||
! holes :: direct terms
|
||||
do i0 = 1, n_occ_ab_hole(1)
|
||||
i = occ_hole(i0,1)
|
||||
htwoe -= buffer_c(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_hole(2)
|
||||
i = occ_hole(i0,2)
|
||||
htwoe -= buffer_c(i)
|
||||
enddo
|
||||
|
||||
! holes :: exchange terms
|
||||
do i0 = 1, n_occ_ab_hole(spin)
|
||||
i = occ_hole(i0,spin)
|
||||
htwoe += buffer_x(i)
|
||||
enddo
|
||||
|
||||
! particles :: direct terms
|
||||
do i0 = 1, n_occ_ab_partcl(1)
|
||||
i = occ_partcl(i0,1)
|
||||
htwoe += buffer_c(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_partcl(2)
|
||||
i = occ_partcl(i0,2)
|
||||
htwoe += buffer_c(i)
|
||||
enddo
|
||||
|
||||
! particles :: exchange terms
|
||||
do i0 = 1, n_occ_ab_partcl(spin)
|
||||
i = occ_partcl(i0,spin)
|
||||
htwoe -= buffer_x(i)
|
||||
enddo
|
||||
hthree = 0.d0
|
||||
if (three_body_h_tc)then
|
||||
call three_comp_fock_elem(key_i,h,p,spin,hthree)
|
||||
endif
|
||||
|
||||
|
||||
htwoe = htwoe * phase
|
||||
hmono = hmono * phase
|
||||
hthree = hthree * phase
|
||||
htot = htwoe + hmono + hthree
|
||||
|
||||
end
|
||||
|
||||
subroutine three_comp_fock_elem(key_i,h_fock,p_fock,ispin_fock,hthree)
|
||||
implicit none
|
||||
integer,intent(in) :: h_fock,p_fock,ispin_fock
|
||||
integer(bit_kind), intent(in) :: key_i(N_int,2)
|
||||
double precision, intent(out) :: hthree
|
||||
integer :: nexc(2),i,ispin,na,nb
|
||||
integer(bit_kind) :: hole(N_int,2)
|
||||
integer(bit_kind) :: particle(N_int,2)
|
||||
integer :: occ_hole(N_int*bit_kind_size,2)
|
||||
integer :: occ_particle(N_int*bit_kind_size,2)
|
||||
integer :: n_occ_ab_hole(2),n_occ_ab_particle(2)
|
||||
integer(bit_kind) :: det_tmp(N_int,2)
|
||||
|
||||
|
||||
nexc(1) = 0
|
||||
nexc(2) = 0
|
||||
!! Get all the holes and particles of key_i with respect to the ROHF determinant
|
||||
do i=1,N_int
|
||||
hole(i,1) = xor(key_i(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = xor(key_i(i,2),ref_bitmask(i,2))
|
||||
particle(i,1) = iand(hole(i,1),key_i(i,1))
|
||||
particle(i,2) = iand(hole(i,2),key_i(i,2))
|
||||
hole(i,1) = iand(hole(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = iand(hole(i,2),ref_bitmask(i,2))
|
||||
nexc(1) = nexc(1) + popcnt(hole(i,1))
|
||||
nexc(2) = nexc(2) + popcnt(hole(i,2))
|
||||
enddo
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(particle, occ_particle, tmp, N_int)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of particle beta
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(hole, occ_hole, tmp, N_int)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of holes beta
|
||||
|
||||
!! Initialize the matrix element with the reference ROHF Slater determinant Fock element
|
||||
if(ispin_fock==1)then
|
||||
hthree = fock_a_tot_3e_bi_orth(p_fock,h_fock)
|
||||
else
|
||||
hthree = fock_b_tot_3e_bi_orth(p_fock,h_fock)
|
||||
endif
|
||||
det_tmp = ref_bitmask
|
||||
do ispin=1,2
|
||||
na = elec_num_tab(ispin)
|
||||
nb = elec_num_tab(iand(ispin,1)+1)
|
||||
do i=1,nexc(ispin)
|
||||
!DIR$ FORCEINLINE
|
||||
call fock_ac_tc_operator( occ_particle(i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, N_int,na,nb)
|
||||
!DIR$ FORCEINLINE
|
||||
call fock_a_tc_operator ( occ_hole (i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, N_int,na,nb)
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine fock_ac_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,Nint,na,nb)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computes the contribution to the three-electron part of the Fock operator
|
||||
!
|
||||
! a^dagger_{p_fock} a_{h_fock} of spin ispin_fock
|
||||
!
|
||||
! on top of a determinant 'key' on which you ADD an electron of spin ispin in orbital iorb
|
||||
!
|
||||
! in output, the determinant key is changed by the ADDITION of that electron
|
||||
!
|
||||
! the output hthree is INCREMENTED
|
||||
END_DOC
|
||||
integer, intent(in) :: iorb, ispin, Nint, h_fock,p_fock, ispin_fock
|
||||
integer, intent(inout) :: na, nb
|
||||
integer(bit_kind), intent(inout) :: key(Nint,2)
|
||||
double precision, intent(inout) :: hthree
|
||||
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: other_spin
|
||||
integer :: k,l,i,jj,j
|
||||
double precision :: direct_int, exchange_int
|
||||
|
||||
|
||||
if (iorb < 1) then
|
||||
print *, irp_here, ': iorb < 1'
|
||||
print *, iorb, mo_num
|
||||
stop -1
|
||||
endif
|
||||
if (iorb > mo_num) then
|
||||
print *, irp_here, ': iorb > mo_num'
|
||||
print *, iorb, mo_num
|
||||
stop -1
|
||||
endif
|
||||
|
||||
ASSERT (ispin > 0)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
ASSERT (tmp(1) == elec_alpha_num)
|
||||
ASSERT (tmp(2) == elec_beta_num)
|
||||
|
||||
k = shiftr(iorb-1,bit_kind_shift)+1
|
||||
ASSERT (k >0)
|
||||
l = iorb - shiftl(k-1,bit_kind_shift)-1
|
||||
ASSERT (l >= 0)
|
||||
key(k,ispin) = ibset(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
|
||||
!! spin of other electrons == ispin
|
||||
if(ispin == ispin_fock)then
|
||||
!! in what follows :: jj == other electrons in the determinant
|
||||
!! :: iorb == electron that has been added of spin ispin
|
||||
!! :: p_fock, h_fock == hole particle of spin ispin_fock
|
||||
!! jj = ispin = ispin_fock >> pure parallel spin
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
hthree += three_e_single_parrallel_spin_prov(jj,iorb,p_fock,h_fock)
|
||||
enddo
|
||||
!! spin of jj == other spin than ispin AND ispin_fock
|
||||
!! exchange between the iorb and (h_fock, p_fock)
|
||||
do j = 1, nb
|
||||
jj = occ(j,other_spin)
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
exchange_int = three_e_4_idx_exch12_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
else !! ispin NE to ispin_fock
|
||||
!! jj = ispin BUT NON EQUAL TO ispin_fock
|
||||
!! exchange between the jj and iorb
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
exchange_int = three_e_4_idx_exch23_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
!! jj = other_spin than ispin BUT jj == ispin_fock
|
||||
!! exchange between jj and (h_fock,p_fock)
|
||||
do j = 1, nb
|
||||
jj = occ(j,other_spin)
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
exchange_int = three_e_4_idx_exch13_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
endif
|
||||
|
||||
na = na+1
|
||||
end
|
||||
|
||||
subroutine fock_a_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,Nint,na,nb)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computes the contribution to the three-electron part of the Fock operator
|
||||
!
|
||||
! a^dagger_{p_fock} a_{h_fock} of spin ispin_fock
|
||||
!
|
||||
! on top of a determinant 'key' on which you REMOVE an electron of spin ispin in orbital iorb
|
||||
!
|
||||
! in output, the determinant key is changed by the REMOVAL of that electron
|
||||
!
|
||||
! the output hthree is INCREMENTED
|
||||
END_DOC
|
||||
integer, intent(in) :: iorb, ispin, Nint, h_fock,p_fock, ispin_fock
|
||||
integer, intent(inout) :: na, nb
|
||||
integer(bit_kind), intent(inout) :: key(Nint,2)
|
||||
double precision, intent(inout) :: hthree
|
||||
|
||||
double precision :: direct_int, exchange_int
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: other_spin
|
||||
integer :: k,l,i,jj,mm,j,m
|
||||
integer :: tmp(2)
|
||||
|
||||
ASSERT (iorb > 0)
|
||||
ASSERT (ispin > 0)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
k = shiftr(iorb-1,bit_kind_shift)+1
|
||||
ASSERT (k>0)
|
||||
l = iorb - shiftl(k-1,bit_kind_shift)-1
|
||||
key(k,ispin) = ibclr(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
na = na-1
|
||||
!! spin of other electrons == ispin
|
||||
if(ispin == ispin_fock)then
|
||||
!! in what follows :: jj == other electrons in the determinant
|
||||
!! :: iorb == electron that has been added of spin ispin
|
||||
!! :: p_fock, h_fock == hole particle of spin ispin_fock
|
||||
!! jj = ispin = ispin_fock >> pure parallel spin
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
hthree -= three_e_single_parrallel_spin_prov(jj,iorb,p_fock,h_fock)
|
||||
enddo
|
||||
!! spin of jj == other spin than ispin AND ispin_fock
|
||||
!! exchange between the iorb and (h_fock, p_fock)
|
||||
do j = 1, nb
|
||||
jj = occ(j,other_spin)
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
exchange_int = three_e_4_idx_exch12_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
else !! ispin NE to ispin_fock
|
||||
!! jj = ispin BUT NON EQUAL TO ispin_fock
|
||||
!! exchange between the jj and iorb
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
exchange_int = three_e_4_idx_exch23_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
!! jj = other_spin than ispin BUT jj == ispin_fock
|
||||
!! exchange between jj and (h_fock,p_fock)
|
||||
do j = 1, nb
|
||||
jj = occ(j,other_spin)
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
exchange_int = three_e_4_idx_exch13_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_op_2_e_tc_closed_shell, (mo_num, mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Closed-shell part of the Fock operator for the TC operator
|
||||
END_DOC
|
||||
integer :: h0,p0,h,p,k0,k,i
|
||||
integer :: n_occ_ab(2)
|
||||
integer :: occ(N_int*bit_kind_size,2)
|
||||
integer :: n_occ_ab_virt(2)
|
||||
integer :: occ_virt(N_int*bit_kind_size,2)
|
||||
integer(bit_kind) :: key_test(N_int)
|
||||
integer(bit_kind) :: key_virt(N_int,2)
|
||||
double precision :: accu
|
||||
|
||||
fock_op_2_e_tc_closed_shell = -1000.d0
|
||||
call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int)
|
||||
do i = 1, N_int
|
||||
key_virt(i,1) = full_ijkl_bitmask(i)
|
||||
key_virt(i,2) = full_ijkl_bitmask(i)
|
||||
key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask(i,1))
|
||||
key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
|
||||
! docc ---> virt single excitations
|
||||
do h0 = 1, n_occ_ab(1)
|
||||
h=occ(h0,1)
|
||||
do p0 = 1, n_occ_ab_virt(1)
|
||||
p = occ_virt(p0,1)
|
||||
accu = 0.d0
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
|
||||
enddo
|
||||
fock_op_2_e_tc_closed_shell(p,h) = accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do h0 = 1, n_occ_ab_virt(1)
|
||||
h = occ_virt(h0,1)
|
||||
do p0 = 1, n_occ_ab(1)
|
||||
p=occ(p0,1)
|
||||
accu = 0.d0
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
|
||||
enddo
|
||||
fock_op_2_e_tc_closed_shell(p,h) = accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! virt ---> virt single excitations
|
||||
do h0 = 1, n_occ_ab_virt(1)
|
||||
h=occ_virt(h0,1)
|
||||
do p0 = 1, n_occ_ab_virt(1)
|
||||
p = occ_virt(p0,1)
|
||||
accu = 0.d0
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
|
||||
enddo
|
||||
fock_op_2_e_tc_closed_shell(p,h) = accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do h0 = 1, n_occ_ab_virt(1)
|
||||
h = occ_virt(h0,1)
|
||||
do p0 = 1, n_occ_ab_virt(1)
|
||||
p=occ_virt(p0,1)
|
||||
accu = 0.d0
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
|
||||
enddo
|
||||
fock_op_2_e_tc_closed_shell(p,h) = accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
! docc ---> docc single excitations
|
||||
do h0 = 1, n_occ_ab(1)
|
||||
h=occ(h0,1)
|
||||
do p0 = 1, n_occ_ab(1)
|
||||
p = occ(p0,1)
|
||||
accu = 0.d0
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
|
||||
enddo
|
||||
fock_op_2_e_tc_closed_shell(p,h) = accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do h0 = 1, n_occ_ab(1)
|
||||
h = occ(h0,1)
|
||||
do p0 = 1, n_occ_ab(1)
|
||||
p=occ(p0,1)
|
||||
accu = 0.d0
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
|
||||
enddo
|
||||
fock_op_2_e_tc_closed_shell(p,h) = accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! do i = 1, mo_num
|
||||
! write(*,'(100(F10.5,X))')fock_op_2_e_tc_closed_shell(:,i)
|
||||
! enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: htot
|
||||
double precision :: hmono, htwoe
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: get_mo_two_e_integral_tc_int, phase
|
||||
double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13
|
||||
integer :: other_spin(2)
|
||||
integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2)
|
||||
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
htot = 0.d0
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree.ne.1)then
|
||||
return
|
||||
endif
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
|
||||
call get_single_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
|
||||
call get_single_excitation_from_fock_tc_no_3e(key_i,key_j,h1,p1,s1,phase,hmono,htwoe,htot)
|
||||
end
|
||||
|
||||
|
||||
subroutine get_single_excitation_from_fock_tc_no_3e(key_i,key_j,h,p,spin,phase,hmono,htwoe,htot)
|
||||
use bitmasks
|
||||
implicit none
|
||||
integer,intent(in) :: h,p,spin
|
||||
double precision, intent(in) :: phase
|
||||
integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2)
|
||||
double precision, intent(out) :: hmono,htwoe,htot
|
||||
integer(bit_kind) :: differences(N_int,2)
|
||||
integer(bit_kind) :: hole(N_int,2)
|
||||
integer(bit_kind) :: partcl(N_int,2)
|
||||
integer :: occ_hole(N_int*bit_kind_size,2)
|
||||
integer :: occ_partcl(N_int*bit_kind_size,2)
|
||||
integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
|
||||
integer :: i0,i
|
||||
double precision :: buffer_c(mo_num),buffer_x(mo_num)
|
||||
do i=1, mo_num
|
||||
buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
|
||||
buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
|
||||
enddo
|
||||
do i = 1, N_int
|
||||
differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1))
|
||||
differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2))
|
||||
hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
|
||||
hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
|
||||
partcl(i,1) = iand(differences(i,1),key_i(i,1))
|
||||
partcl(i,2) = iand(differences(i,2),key_i(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
|
||||
call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
|
||||
hmono = mo_bi_ortho_tc_one_e(p,h)
|
||||
htwoe = fock_op_2_e_tc_closed_shell(p,h)
|
||||
! holes :: direct terms
|
||||
do i0 = 1, n_occ_ab_hole(1)
|
||||
i = occ_hole(i0,1)
|
||||
htwoe -= buffer_c(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_hole(2)
|
||||
i = occ_hole(i0,2)
|
||||
htwoe -= buffer_c(i)
|
||||
enddo
|
||||
|
||||
! holes :: exchange terms
|
||||
do i0 = 1, n_occ_ab_hole(spin)
|
||||
i = occ_hole(i0,spin)
|
||||
htwoe += buffer_x(i)
|
||||
enddo
|
||||
|
||||
! particles :: direct terms
|
||||
do i0 = 1, n_occ_ab_partcl(1)
|
||||
i = occ_partcl(i0,1)
|
||||
htwoe += buffer_c(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_partcl(2)
|
||||
i = occ_partcl(i0,2)
|
||||
htwoe += buffer_c(i)
|
||||
enddo
|
||||
|
||||
! particles :: exchange terms
|
||||
do i0 = 1, n_occ_ab_partcl(spin)
|
||||
i = occ_partcl(i0,spin)
|
||||
htwoe -= buffer_x(i)
|
||||
enddo
|
||||
htwoe = htwoe * phase
|
||||
hmono = hmono * phase
|
||||
htot = htwoe + hmono
|
||||
|
||||
end
|
||||
|
||||
|
|
@ -0,0 +1,111 @@
|
|||
subroutine give_all_perm_for_three_e(n,l,k,m,j,i,idx_list,phase)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! returns all the list of permutting indices for the antimmetrization of
|
||||
!
|
||||
! (k^dagger l^dagger n^dagger m j i) <nlk|L|mji> when all indices have the same spins
|
||||
!
|
||||
! idx_list(:,i) == list of the 6 indices corresponding the permutation "i"
|
||||
!
|
||||
! phase(i) == phase of the permutation "i"
|
||||
!
|
||||
! there are in total 6 permutations with different indices
|
||||
END_DOC
|
||||
integer, intent(in) :: n,l,k,m,j,i
|
||||
integer, intent(out) :: idx_list(6,6)
|
||||
double precision :: phase(6)
|
||||
integer :: list(6)
|
||||
!!! CYCLIC PERMUTATIONS
|
||||
phase(1:3) = 1.d0
|
||||
!!! IDENTITY PERMUTATION
|
||||
list = (/n,l,k,m,j,i/)
|
||||
idx_list(:,1) = list(:)
|
||||
!!! FIRST CYCLIC PERMUTATION
|
||||
list = (/n,l,k,j,i,m/)
|
||||
idx_list(:,2) = list(:)
|
||||
!!! FIRST CYCLIC PERMUTATION
|
||||
list = (/n,l,k,i,m,j/)
|
||||
idx_list(:,3) = list(:)
|
||||
|
||||
!!! NON CYCLIC PERMUTATIONS
|
||||
phase(1:3) = -1.d0
|
||||
!!! PARTICLE 1 is FIXED
|
||||
list = (/n,l,k,j,m,i/)
|
||||
idx_list(:,4) = list(:)
|
||||
!!! PARTICLE 2 is FIXED
|
||||
list = (/n,l,k,i,j,m/)
|
||||
idx_list(:,5) = list(:)
|
||||
!!! PARTICLE 3 is FIXED
|
||||
list = (/n,l,k,m,i,j/)
|
||||
idx_list(:,6) = list(:)
|
||||
|
||||
end
|
||||
|
||||
double precision function sym_3_e_int_from_6_idx_tensor(n,l,k,m,j,i)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! returns all good combinations of permutations of integrals with the good signs
|
||||
!
|
||||
! for a given (k^dagger l^dagger n^dagger m j i) <nlk|L|mji> when all indices have the same spins
|
||||
END_DOC
|
||||
integer, intent(in) :: n,l,k,m,j,i
|
||||
sym_3_e_int_from_6_idx_tensor = three_body_ints_bi_ort(n,l,k,m,j,i) & ! direct
|
||||
+ three_body_ints_bi_ort(n,l,k,j,i,m) & ! 1st cyclic permutation
|
||||
+ three_body_ints_bi_ort(n,l,k,i,m,j) & ! 2nd cyclic permutation
|
||||
- three_body_ints_bi_ort(n,l,k,j,m,i) & ! elec 1 is kept fixed
|
||||
- three_body_ints_bi_ort(n,l,k,i,j,m) & ! elec 2 is kept fixed
|
||||
- three_body_ints_bi_ort(n,l,k,m,i,j) ! elec 3 is kept fixed
|
||||
|
||||
end
|
||||
|
||||
double precision function direct_sym_3_e_int(n,l,k,m,j,i)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! returns all good combinations of permutations of integrals with the good signs
|
||||
!
|
||||
! for a given (k^dagger l^dagger n^dagger m j i) <nlk|L|mji> when all indices have the same spins
|
||||
END_DOC
|
||||
integer, intent(in) :: n,l,k,m,j,i
|
||||
double precision :: integral
|
||||
direct_sym_3_e_int = 0.d0
|
||||
call give_integrals_3_body_bi_ort(n,l,k,m,j,i,integral) ! direct
|
||||
direct_sym_3_e_int += integral
|
||||
call give_integrals_3_body_bi_ort(n,l,k,j,i,m,integral) ! 1st cyclic permutation
|
||||
direct_sym_3_e_int += integral
|
||||
call give_integrals_3_body_bi_ort(n,l,k,i,m,j,integral) ! 2nd cyclic permutation
|
||||
direct_sym_3_e_int += integral
|
||||
call give_integrals_3_body_bi_ort(n,l,k,j,m,i,integral) ! elec 1 is kept fixed
|
||||
direct_sym_3_e_int += -integral
|
||||
call give_integrals_3_body_bi_ort(n,l,k,i,j,m,integral) ! elec 2 is kept fixed
|
||||
direct_sym_3_e_int += -integral
|
||||
call give_integrals_3_body_bi_ort(n,l,k,m,i,j,integral) ! elec 3 is kept fixed
|
||||
direct_sym_3_e_int += -integral
|
||||
|
||||
end
|
||||
|
||||
double precision function three_e_diag_parrallel_spin(m,j,i)
|
||||
implicit none
|
||||
integer, intent(in) :: i,j,m
|
||||
three_e_diag_parrallel_spin = three_e_3_idx_direct_bi_ort(m,j,i) ! direct
|
||||
three_e_diag_parrallel_spin += three_e_3_idx_cycle_1_bi_ort(m,j,i) + three_e_3_idx_cycle_2_bi_ort(m,j,i) & ! two cyclic permutations
|
||||
- three_e_3_idx_exch23_bi_ort(m,j,i) - three_e_3_idx_exch13_bi_ort(m,j,i) & ! two first exchange
|
||||
- three_e_3_idx_exch12_bi_ort(m,j,i) ! last exchange
|
||||
end
|
||||
|
||||
double precision function three_e_single_parrallel_spin(m,j,k,i)
|
||||
implicit none
|
||||
integer, intent(in) :: i,k,j,m
|
||||
three_e_single_parrallel_spin = three_e_4_idx_direct_bi_ort(m,j,k,i) ! direct
|
||||
three_e_single_parrallel_spin += three_e_4_idx_cycle_1_bi_ort(m,j,k,i) + three_e_4_idx_cycle_2_bi_ort(m,j,k,i) & ! two cyclic permutations
|
||||
- three_e_4_idx_exch23_bi_ort(m,j,k,i) - three_e_4_idx_exch13_bi_ort(m,j,k,i) & ! two first exchange
|
||||
- three_e_4_idx_exch12_bi_ort(m,j,k,i) ! last exchange
|
||||
end
|
||||
|
||||
double precision function three_e_double_parrallel_spin(m,l,j,k,i)
|
||||
implicit none
|
||||
integer, intent(in) :: i,k,j,m,l
|
||||
three_e_double_parrallel_spin = three_e_5_idx_direct_bi_ort(m,l,j,k,i) ! direct
|
||||
three_e_double_parrallel_spin += three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) + three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) & ! two cyclic permutations
|
||||
- three_e_5_idx_exch23_bi_ort(m,l,j,k,i) - three_e_5_idx_exch13_bi_ort(m,l,j,k,i) & ! two first exchange
|
||||
- three_e_5_idx_exch12_bi_ort(m,l,j,k,i) ! last exchange
|
||||
end
|
||||
|
|
@ -0,0 +1,140 @@
|
|||
|
||||
BEGIN_PROVIDER [ double precision, three_e_diag_parrallel_spin_prov, (mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS
|
||||
!
|
||||
! three_e_diag_parrallel_spin_prov(m,j,i) = All combinations of the form <mji|-L|mji> for same spin matrix elements
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_diag_parrallel_spin_prov can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, m
|
||||
double precision :: integral, wall1, wall0, three_e_diag_parrallel_spin
|
||||
|
||||
three_e_diag_parrallel_spin_prov = 0.d0
|
||||
print *, ' Providing the three_e_diag_parrallel_spin_prov ...'
|
||||
|
||||
integral = three_e_diag_parrallel_spin(1,1,1) ! to provide all stuffs
|
||||
call wall_time(wall0)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_diag_parrallel_spin_prov)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = j, mo_num
|
||||
three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin(m,j,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, j
|
||||
three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin_prov(j,m,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_diag_parrallel_spin_prov', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_single_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_single_parrallel_spin_prov(m,j,k,i) = All combination of <mjk|-L|mji> for same spin matrix elements
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m
|
||||
double precision :: integral, wall1, wall0, three_e_single_parrallel_spin
|
||||
|
||||
three_e_single_parrallel_spin_prov = 0.d0
|
||||
print *, ' Providing the three_e_single_parrallel_spin_prov ...'
|
||||
|
||||
integral = three_e_single_parrallel_spin(1,1,1,1)
|
||||
call wall_time(wall0)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_single_parrallel_spin_prov)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
three_e_single_parrallel_spin_prov(m,j,k,i) = three_e_single_parrallel_spin(m,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_single_parrallel_spin_prov', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_double_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_double_parrallel_spin_prov(m,l,j,k,i) = <mlk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m, l
|
||||
double precision :: integral, wall1, wall0, three_e_double_parrallel_spin
|
||||
|
||||
three_e_double_parrallel_spin_prov = 0.d0
|
||||
print *, ' Providing the three_e_double_parrallel_spin_prov ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
integral = three_e_double_parrallel_spin(1,1,1,1,1)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,l,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_double_parrallel_spin_prov)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
three_e_double_parrallel_spin_prov(m,l,j,k,i) = three_e_double_parrallel_spin(m,l,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_double_parrallel_spin_prov', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
program tc_bi_ortho
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together with the energy. Saves the left-right wave functions at the end.
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
call routine_diag
|
||||
! call test
|
||||
end
|
||||
|
||||
subroutine test
|
||||
implicit none
|
||||
integer :: i,j
|
||||
double precision :: hmono,htwoe,hthree,htot
|
||||
use bitmasks
|
||||
|
||||
print*,'test'
|
||||
! call htilde_mu_mat_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot)
|
||||
call double_htilde_mu_mat_bi_ortho(N_int,psi_det(1,1,1), psi_det(1,1,2), hmono, htwoe, htot)
|
||||
print*,hmono, htwoe, htot
|
||||
|
||||
end
|
||||
|
||||
subroutine routine_diag
|
||||
implicit none
|
||||
! provide eigval_right_tc_bi_orth
|
||||
provide overlap_bi_ortho
|
||||
! provide htilde_matrix_elmt_bi_ortho
|
||||
integer ::i,j
|
||||
print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1)
|
||||
print*,'e_tc_left_right = ',e_tc_left_right
|
||||
print*,'e_tilde_bi_orth_00 = ',e_tilde_bi_orth_00
|
||||
print*,'e_pt2_tc_bi_orth = ',e_pt2_tc_bi_orth
|
||||
print*,'e_pt2_tc_bi_orth_single = ',e_pt2_tc_bi_orth_single
|
||||
print*,'e_pt2_tc_bi_orth_double = ',e_pt2_tc_bi_orth_double
|
||||
print*,'***'
|
||||
print*,'e_corr_bi_orth = ',e_corr_bi_orth
|
||||
print*,'e_corr_bi_orth_proj = ',e_corr_bi_orth_proj
|
||||
print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth
|
||||
print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth
|
||||
print*,'Left/right eigenvectors'
|
||||
do i = 1,N_det
|
||||
write(*,'(I5,X,(100(F12.7,X)))')i,leigvec_tc_bi_orth(i,1),reigvec_tc_bi_orth(i,1)
|
||||
enddo
|
||||
do j=1,N_states
|
||||
do i=1,N_det
|
||||
psi_l_coef_bi_ortho(i,j) = leigvec_tc_bi_orth(i,j)
|
||||
psi_r_coef_bi_ortho(i,j) = reigvec_tc_bi_orth(i,j)
|
||||
enddo
|
||||
enddo
|
||||
SOFT_TOUCH psi_l_coef_bi_ortho psi_r_coef_bi_ortho
|
||||
call save_tc_bi_ortho_wavefunction
|
||||
! call routine_save_left_right_bi_ortho
|
||||
end
|
||||
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
program tc_bi_ortho_prop
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
! call routine_diag
|
||||
call test
|
||||
end
|
||||
|
||||
subroutine test
|
||||
implicit none
|
||||
integer :: i
|
||||
print*,'TC Dipole components'
|
||||
do i= 1, 3
|
||||
print*,tc_bi_ortho_dipole(i,1)
|
||||
enddo
|
||||
end
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
program tc_bi_ortho
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
call test
|
||||
end
|
||||
|
||||
subroutine test
|
||||
implicit none
|
||||
! double precision, allocatable :: dressing_dets(:),e_corr_dets(:)
|
||||
! allocate(dressing_dets(N_det),e_corr_dets(N_det))
|
||||
! e_corr_dets = 0.d0
|
||||
! call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets)
|
||||
provide eigval_tc_cisd_sc2_bi_ortho
|
||||
end
|
||||
|
|
@ -0,0 +1,145 @@
|
|||
BEGIN_PROVIDER [ double precision, reigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)]
|
||||
&BEGIN_PROVIDER [ double precision, leigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)]
|
||||
&BEGIN_PROVIDER [ double precision, eigval_tc_cisd_sc2_bi_ortho, (N_states)]
|
||||
implicit none
|
||||
integer :: it,n_real,degree,i,istate
|
||||
double precision :: e_before, e_current,thr, hmono,htwoe,hthree,accu
|
||||
double precision, allocatable :: e_corr_dets(:),h0j(:), h_sc2(:,:), dressing_dets(:)
|
||||
double precision, allocatable :: leigvec_tc_bi_orth_tmp(:,:),reigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:)
|
||||
allocate(leigvec_tc_bi_orth_tmp(N_det,N_det),reigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det))
|
||||
allocate(e_corr_dets(N_det),h0j(N_det),h_sc2(N_det,N_det),dressing_dets(N_det))
|
||||
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),eigval_tmp(N_states))
|
||||
dressing_dets = 0.d0
|
||||
do i = 1, N_det
|
||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
|
||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||
if(degree == 1 .or. degree == 2)then
|
||||
call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i))
|
||||
endif
|
||||
enddo
|
||||
reigvec_tc_bi_orth_tmp = 0.d0
|
||||
do i = 1, N_det
|
||||
reigvec_tc_bi_orth_tmp(i,1) = psi_r_coef_bi_ortho(i,1)
|
||||
enddo
|
||||
vec_tmp = 0.d0
|
||||
do istate = 1, N_states
|
||||
vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate)
|
||||
enddo
|
||||
do istate = N_states+1, n_states_diag
|
||||
vec_tmp(istate,istate) = 1.d0
|
||||
enddo
|
||||
print*,'Diagonalizing the TC CISD '
|
||||
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav)
|
||||
do i = 1, N_det
|
||||
e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
|
||||
enddo
|
||||
E_before = eigval_tmp(1)
|
||||
print*,'Starting from ',E_before
|
||||
|
||||
e_current = 10.d0
|
||||
thr = 1.d-5
|
||||
it = 0
|
||||
dressing_dets = 0.d0
|
||||
double precision, allocatable :: H_jj(:),vec_tmp(:,:),eigval_tmp(:)
|
||||
external htc_bi_ortho_calc_tdav
|
||||
external htcdag_bi_ortho_calc_tdav
|
||||
logical :: converged
|
||||
do while (dabs(E_before-E_current).gt.thr)
|
||||
it += 1
|
||||
E_before = E_current
|
||||
! h_sc2 = htilde_matrix_elmt_bi_ortho
|
||||
call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets)
|
||||
do i = 1, N_det
|
||||
! print*,'dressing_dets(i) = ',dressing_dets(i)
|
||||
h_sc2(i,i) += dressing_dets(i)
|
||||
enddo
|
||||
print*,'********************'
|
||||
print*,'iteration ',it
|
||||
! call non_hrmt_real_diag(N_det,h_sc2,&
|
||||
! leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,&
|
||||
! n_real,eigval_right_tmp)
|
||||
! print*,'eigval_right_tmp(1)',eigval_right_tmp(1)
|
||||
vec_tmp = 0.d0
|
||||
do istate = 1, N_states
|
||||
vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate)
|
||||
enddo
|
||||
do istate = N_states+1, n_states_diag
|
||||
vec_tmp(istate,istate) = 1.d0
|
||||
enddo
|
||||
call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav)
|
||||
print*,'outside Davidson'
|
||||
print*,'eigval_tmp(1) = ',eigval_tmp(1)
|
||||
do i = 1, N_det
|
||||
reigvec_tc_bi_orth_tmp(i,1) = vec_tmp(i,1)
|
||||
e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
|
||||
enddo
|
||||
! E_current = eigval_right_tmp(1)
|
||||
E_current = eigval_tmp(1)
|
||||
print*,'it, E(SC)^2 = ',it,E_current
|
||||
enddo
|
||||
eigval_tc_cisd_sc2_bi_ortho(1:N_states) = eigval_right_tmp(1:N_states)
|
||||
reigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = reigvec_tc_bi_orth_tmp(1:N_det,1:N_states)
|
||||
leigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = leigvec_tc_bi_orth_tmp(1:N_det,1:N_states)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine get_cisd_sc2_dressing(dets,e_corr_dets,ndet,dressing_dets)
|
||||
implicit none
|
||||
use bitmasks
|
||||
integer, intent(in) :: ndet
|
||||
integer(bit_kind), intent(in) :: dets(N_int,2,ndet)
|
||||
double precision, intent(in) :: e_corr_dets(ndet)
|
||||
double precision, intent(out) :: dressing_dets(ndet)
|
||||
integer, allocatable :: degree(:),hole(:,:),part(:,:),spin(:,:)
|
||||
integer(bit_kind), allocatable :: hole_part(:,:,:)
|
||||
integer :: i,j,k, exc(0:2,2,2),h1,p1,h2,p2,s1,s2
|
||||
integer(bit_kind) :: xorvec(2,N_int)
|
||||
|
||||
double precision :: phase
|
||||
dressing_dets = 0.d0
|
||||
allocate(degree(ndet),hole(2,ndet),part(2,ndet), spin(2,ndet),hole_part(N_int,2,ndet))
|
||||
do i = 2, ndet
|
||||
call get_excitation_degree(HF_bitmask,dets(1,1,i),degree(i),N_int)
|
||||
do j = 1, N_int
|
||||
hole_part(j,1,i) = xor( HF_bitmask(j,1), dets(j,1,i))
|
||||
hole_part(j,2,i) = xor( HF_bitmask(j,2), dets(j,2,i))
|
||||
enddo
|
||||
if(degree(i) == 1)then
|
||||
call get_single_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int)
|
||||
else if(degree(i) == 2)then
|
||||
call get_double_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int)
|
||||
endif
|
||||
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||
hole(1,i) = h1
|
||||
hole(2,i) = h2
|
||||
part(1,i) = p1
|
||||
part(2,i) = p2
|
||||
spin(1,i) = s1
|
||||
spin(2,i) = s2
|
||||
enddo
|
||||
|
||||
integer :: same
|
||||
if(elec_alpha_num+elec_beta_num<3)return
|
||||
do i = 2, ndet
|
||||
do j = i+1, ndet
|
||||
same = 0
|
||||
if(degree(i) == degree(j) .and. degree(i)==1)cycle
|
||||
do k = 1, N_int
|
||||
xorvec(k,1) = iand(hole_part(k,1,i),hole_part(k,1,j))
|
||||
xorvec(k,2) = iand(hole_part(k,2,i),hole_part(k,2,j))
|
||||
same += popcnt(xorvec(k,1)) + popcnt(xorvec(k,2))
|
||||
enddo
|
||||
! print*,'i,j',i,j
|
||||
! call debug_det(dets(1,1,i),N_int)
|
||||
! call debug_det(hole_part(1,1,i),N_int)
|
||||
! call debug_det(dets(1,1,j),N_int)
|
||||
! call debug_det(hole_part(1,1,j),N_int)
|
||||
! print*,'same = ',same
|
||||
if(same.eq.0)then
|
||||
dressing_dets(i) += e_corr_dets(j)
|
||||
dressing_dets(j) += e_corr_dets(i)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,183 @@
|
|||
use bitmasks
|
||||
|
||||
BEGIN_PROVIDER [ integer, index_HF_psi_det]
|
||||
implicit none
|
||||
integer :: i,degree
|
||||
do i = 1, N_det
|
||||
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
||||
if(degree == 0)then
|
||||
index_HF_psi_det = i
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [double precision, eigval_right_tc_bi_orth, (N_states)]
|
||||
&BEGIN_PROVIDER [double precision, eigval_left_tc_bi_orth, (N_states)]
|
||||
&BEGIN_PROVIDER [double precision, reigvec_tc_bi_orth, (N_det,N_states)]
|
||||
&BEGIN_PROVIDER [double precision, leigvec_tc_bi_orth, (N_det,N_states)]
|
||||
&BEGIN_PROVIDER [double precision, norm_ground_left_right_bi_orth ]
|
||||
|
||||
BEGIN_DOC
|
||||
! eigenvalues, right and left eigenvectors of the transcorrelated Hamiltonian on the BI-ORTHO basis
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, idx_dress, j, istate
|
||||
logical :: converged, dagger
|
||||
integer :: n_real_tc_bi_orth_eigval_right,igood_r,igood_l
|
||||
double precision, allocatable :: reigvec_tc_bi_orth_tmp(:,:),leigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:)
|
||||
|
||||
PROVIDE N_det N_int
|
||||
|
||||
if(n_det.le.N_det_max_full)then
|
||||
allocate(reigvec_tc_bi_orth_tmp(N_det,N_det),leigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det))
|
||||
call non_hrmt_real_diag(N_det,htilde_matrix_elmt_bi_ortho,&
|
||||
leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,&
|
||||
n_real_tc_bi_orth_eigval_right,eigval_right_tmp)
|
||||
double precision, allocatable :: coef_hf_r(:),coef_hf_l(:)
|
||||
integer, allocatable :: iorder(:)
|
||||
allocate(coef_hf_r(N_det),coef_hf_l(N_det),iorder(N_det))
|
||||
do i = 1,N_det
|
||||
iorder(i) = i
|
||||
coef_hf_r(i) = -dabs(reigvec_tc_bi_orth_tmp(index_HF_psi_det,i))
|
||||
enddo
|
||||
call dsort(coef_hf_r,iorder,N_det)
|
||||
igood_r = iorder(1)
|
||||
print*,'igood_r, coef_hf_r = ',igood_r,coef_hf_r(1)
|
||||
do i = 1,N_det
|
||||
iorder(i) = i
|
||||
coef_hf_l(i) = -dabs(leigvec_tc_bi_orth_tmp(index_HF_psi_det,i))
|
||||
enddo
|
||||
call dsort(coef_hf_l,iorder,N_det)
|
||||
igood_l = iorder(1)
|
||||
print*,'igood_l, coef_hf_l = ',igood_l,coef_hf_l(1)
|
||||
|
||||
if(igood_r.ne.igood_l.and.igood_r.ne.1)then
|
||||
print *,''
|
||||
print *,'Warning, the left and right eigenvectors are "not the same" '
|
||||
print *,'Warning, the ground state is not dominated by HF...'
|
||||
print *,'State with largest RIGHT coefficient of HF ',igood_r
|
||||
print *,'coef of HF in RIGHT eigenvector = ',reigvec_tc_bi_orth_tmp(index_HF_psi_det,igood_r)
|
||||
print *,'State with largest LEFT coefficient of HF ',igood_l
|
||||
print *,'coef of HF in LEFT eigenvector = ',leigvec_tc_bi_orth_tmp(index_HF_psi_det,igood_l)
|
||||
endif
|
||||
if(state_following_tc)then
|
||||
print *,'Following the states with the largest coef on HF'
|
||||
print *,'igood_r,igood_l',igood_r,igood_l
|
||||
i= igood_r
|
||||
eigval_right_tc_bi_orth(1) = eigval_right_tmp(i)
|
||||
do j = 1, N_det
|
||||
reigvec_tc_bi_orth(j,1) = reigvec_tc_bi_orth_tmp(j,i)
|
||||
! print*,reigvec_tc_bi_orth(j,1)
|
||||
enddo
|
||||
i= igood_l
|
||||
eigval_left_tc_bi_orth(1) = eigval_right_tmp(i)
|
||||
do j = 1, N_det
|
||||
leigvec_tc_bi_orth(j,1) = leigvec_tc_bi_orth_tmp(j,i)
|
||||
enddo
|
||||
else
|
||||
do i = 1, N_states
|
||||
eigval_right_tc_bi_orth(i) = eigval_right_tmp(i)
|
||||
eigval_left_tc_bi_orth(i) = eigval_right_tmp(i)
|
||||
do j = 1, N_det
|
||||
reigvec_tc_bi_orth(j,i) = reigvec_tc_bi_orth_tmp(j,i)
|
||||
leigvec_tc_bi_orth(j,i) = leigvec_tc_bi_orth_tmp(j,i)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
else
|
||||
double precision, allocatable :: H_jj(:),vec_tmp(:,:)
|
||||
external htc_bi_ortho_calc_tdav
|
||||
external htcdag_bi_ortho_calc_tdav
|
||||
external H_tc_u_0_opt
|
||||
external H_tc_dagger_u_0_opt
|
||||
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag))
|
||||
do i = 1, N_det
|
||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
|
||||
enddo
|
||||
!!!! Preparing the left-eigenvector
|
||||
print*,'Computing the left-eigenvector '
|
||||
vec_tmp = 0.d0
|
||||
do istate = 1, N_states
|
||||
vec_tmp(1:N_det,istate) = psi_l_coef_bi_ortho(1:N_det,istate)
|
||||
enddo
|
||||
do istate = N_states+1, n_states_diag
|
||||
vec_tmp(istate,istate) = 1.d0
|
||||
enddo
|
||||
! call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, converged, htcdag_bi_ortho_calc_tdav)
|
||||
call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, converged, H_tc_dagger_u_0_opt)
|
||||
do istate = 1, N_states
|
||||
leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
|
||||
enddo
|
||||
|
||||
print*,'Computing the right-eigenvector '
|
||||
!!!! Preparing the right-eigenvector
|
||||
vec_tmp = 0.d0
|
||||
do istate = 1, N_states
|
||||
vec_tmp(1:N_det,istate) = psi_r_coef_bi_ortho(1:N_det,istate)
|
||||
enddo
|
||||
do istate = N_states+1, n_states_diag
|
||||
vec_tmp(istate,istate) = 1.d0
|
||||
enddo
|
||||
! call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav)
|
||||
call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, H_tc_u_0_opt)
|
||||
do istate = 1, N_states
|
||||
reigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
|
||||
enddo
|
||||
|
||||
deallocate(H_jj)
|
||||
endif
|
||||
call bi_normalize(leigvec_tc_bi_orth,reigvec_tc_bi_orth,size(reigvec_tc_bi_orth,1),N_det,N_states)
|
||||
print*,'leigvec_tc_bi_orth(1,1),reigvec_tc_bi_orth(1,1) = ',leigvec_tc_bi_orth(1,1),reigvec_tc_bi_orth(1,1)
|
||||
norm_ground_left_right_bi_orth = 0.d0
|
||||
do j = 1, N_det
|
||||
norm_ground_left_right_bi_orth += leigvec_tc_bi_orth(j,1) * reigvec_tc_bi_orth(j,1)
|
||||
enddo
|
||||
print*,'norm l/r = ',norm_ground_left_right_bi_orth
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
subroutine bi_normalize(u_l,u_r,n,ld,nstates)
|
||||
!!!! Normalization of the scalar product of the left/right eigenvectors
|
||||
double precision, intent(inout) :: u_l(ld,nstates), u_r(ld,nstates)
|
||||
integer, intent(in) :: n,ld,nstates
|
||||
integer :: i
|
||||
double precision :: accu, tmp
|
||||
do i = 1, nstates
|
||||
!!!! Normalization of right eigenvectors |Phi>
|
||||
accu = 0.d0
|
||||
do j = 1, n
|
||||
accu += u_r(j,i) * u_r(j,i)
|
||||
enddo
|
||||
accu = 1.d0/dsqrt(accu)
|
||||
print*,'accu_r = ',accu
|
||||
do j = 1, n
|
||||
u_r(j,i) *= accu
|
||||
enddo
|
||||
tmp = u_r(1,i) / dabs(u_r(1,i))
|
||||
do j = 1, n
|
||||
u_r(j,i) *= tmp
|
||||
enddo
|
||||
!!!! Adaptation of the norm of the left eigenvector such that <chi|Phi> = 1
|
||||
accu = 0.d0
|
||||
do j = 1, n
|
||||
accu += u_l(j,i) * u_r(j,i)
|
||||
! print*,j, u_l(j,i) , u_r(j,i)
|
||||
enddo
|
||||
if(accu.gt.0.d0)then
|
||||
accu = 1.d0/dsqrt(accu)
|
||||
else
|
||||
accu = 1.d0/dsqrt(-accu)
|
||||
endif
|
||||
tmp = (u_l(1,i) * u_r(1,i) )/dabs(u_l(1,i) * u_r(1,i))
|
||||
do j = 1, n
|
||||
u_l(j,i) *= accu * tmp
|
||||
u_r(j,i) *= accu
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
|
||||
BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)]
|
||||
|
||||
BEGIN_DOC
|
||||
! htilde_matrix_elmt_bi_ortho(j,i) = <J| H^tilde |I>
|
||||
!
|
||||
! WARNING !!!!!!!!! IT IS NOT HERMITIAN !!!!!!!!!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j
|
||||
double precision :: hmono,htwoe,hthree,htot
|
||||
|
||||
PROVIDE N_int
|
||||
!$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hmono, htwoe, hthree, htot) &
|
||||
!$OMP SHARED (N_det, psi_det, N_int,htilde_matrix_elmt_bi_ortho)
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
! < J | Htilde | I >
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
|
||||
!print *, ' hmono = ', hmono
|
||||
!print *, ' htwoe = ', htwoe
|
||||
!print *, ' hthree = ', hthree
|
||||
htilde_matrix_elmt_bi_ortho(j,i) = htot
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
! print*,'htilde_matrix_elmt_bi_ortho = '
|
||||
! do i = 1, min(100,N_det)
|
||||
! write(*,'(100(F16.10,X))')htilde_matrix_elmt_bi_ortho(1:min(100,N_det),i)
|
||||
! enddo
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho_tranp, (N_det,N_det)]
|
||||
implicit none
|
||||
integer ::i,j
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
htilde_matrix_elmt_bi_ortho_tranp(j,i) = htilde_matrix_elmt_bi_ortho(i,j)
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
|
@ -0,0 +1,218 @@
|
|||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, natorb_tc_reigvec_mo, (mo_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, natorb_tc_leigvec_mo, (mo_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, natorb_tc_eigval, (mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! natorb_tc_reigvec_mo : RIGHT eigenvectors of the ground state transition matrix (equivalent of natural orbitals)
|
||||
! natorb_tc_leigvec_mo : LEFT eigenvectors of the ground state transition matrix (equivalent of natural orbitals)
|
||||
! natorb_tc_eigval : eigenvalues of the ground state transition matrix (equivalent of the occupation numbers). WARNINING :: can be negative !!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k
|
||||
double precision :: thr_d, thr_nd, thr_deg, accu
|
||||
double precision :: accu_d, accu_nd
|
||||
double precision, allocatable :: dm_tmp(:,:), fock_diag(:)
|
||||
|
||||
allocate(dm_tmp(mo_num,mo_num), fock_diag(mo_num))
|
||||
|
||||
dm_tmp(:,:) = -tc_transition_matrix(:,:,1,1)
|
||||
|
||||
print *, ' dm_tmp'
|
||||
do i = 1, mo_num
|
||||
fock_diag(i) = fock_matrix_tc_mo_tot(i,i)
|
||||
write(*, '(100(F16.10,X))') -dm_tmp(:,i)
|
||||
enddo
|
||||
|
||||
thr_d = 1.d-6
|
||||
thr_nd = 1.d-6
|
||||
thr_deg = 1.d-3
|
||||
call diag_mat_per_fock_degen( fock_diag, dm_tmp, mo_num, thr_d, thr_nd, thr_deg &
|
||||
, natorb_tc_leigvec_mo, natorb_tc_reigvec_mo, natorb_tc_eigval)
|
||||
! call non_hrmt_bieig( mo_num, dm_tmp&
|
||||
! , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo&
|
||||
! , mo_num, natorb_tc_eigval )
|
||||
|
||||
accu = 0.d0
|
||||
do i = 1, mo_num
|
||||
print*,'natorb_tc_eigval(i) = ',-natorb_tc_eigval(i)
|
||||
accu += -natorb_tc_eigval(i)
|
||||
enddo
|
||||
print *, ' accu = ', accu
|
||||
|
||||
dm_tmp = 0.d0
|
||||
do i = 1, mo_num
|
||||
accu = 0.d0
|
||||
do k = 1, mo_num
|
||||
accu += natorb_tc_reigvec_mo(k,i) * natorb_tc_leigvec_mo(k,i)
|
||||
enddo
|
||||
accu = 1.d0/dsqrt(dabs(accu))
|
||||
natorb_tc_reigvec_mo(:,i) *= accu
|
||||
natorb_tc_leigvec_mo(:,i) *= accu
|
||||
do j = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
dm_tmp(j,i) += natorb_tc_reigvec_mo(k,i) * natorb_tc_leigvec_mo(k,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
accu_d = 0.d0
|
||||
accu_nd = 0.d0
|
||||
do i = 1, mo_num
|
||||
accu_d += dm_tmp(i,i)
|
||||
!write(*,'(100(F16.10,X))')dm_tmp(:,i)
|
||||
do j = 1, mo_num
|
||||
if(i==j)cycle
|
||||
accu_nd += dabs(dm_tmp(j,i))
|
||||
enddo
|
||||
enddo
|
||||
print *, ' Trace of the overlap between TC natural orbitals ', accu_d
|
||||
print *, ' L1 norm of extra diagonal elements of overlap matrix ', accu_nd
|
||||
|
||||
deallocate(dm_tmp, fock_diag)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_diag_sorted_r_natorb, (mo_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, fock_diag_sorted_l_natorb, (mo_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, fock_diag_sorted_v_natorb, (mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: i,j,k
|
||||
integer, allocatable :: iorder(:)
|
||||
double precision, allocatable :: fock_diag(:)
|
||||
|
||||
print *, ' Diagonal elements of the Fock matrix before '
|
||||
|
||||
do i = 1, mo_num
|
||||
write(*,*) i, Fock_matrix_tc_mo_tot(i,i)
|
||||
enddo
|
||||
|
||||
allocate(fock_diag(mo_num))
|
||||
fock_diag = 0.d0
|
||||
do i = 1, mo_num
|
||||
fock_diag(i) = 0.d0
|
||||
do j = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
fock_diag(i) += natorb_tc_leigvec_mo(k,i) * Fock_matrix_tc_mo_tot(k,j) * natorb_tc_reigvec_mo(j,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
allocate(iorder(mo_num))
|
||||
do i = 1, mo_num
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(fock_diag, iorder, mo_num)
|
||||
|
||||
print *, ' Diagonal elements of the Fock matrix after '
|
||||
do i = 1, mo_num
|
||||
write(*,*) i, fock_diag(i)
|
||||
enddo
|
||||
deallocate(fock_diag)
|
||||
|
||||
do i = 1, mo_num
|
||||
fock_diag_sorted_v_natorb(i) = natorb_tc_eigval(iorder(i))
|
||||
do j = 1, mo_num
|
||||
fock_diag_sorted_r_natorb(j,i) = natorb_tc_reigvec_mo(j,iorder(i))
|
||||
fock_diag_sorted_l_natorb(j,i) = natorb_tc_leigvec_mo(j,iorder(i))
|
||||
enddo
|
||||
enddo
|
||||
deallocate(iorder)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, natorb_tc_reigvec_ao, (ao_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, natorb_tc_leigvec_ao, (ao_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, overlap_natorb_tc_eigvec_ao, (mo_num, mo_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! EIGENVECTORS OF FOCK MATRIX ON THE AO BASIS and their OVERLAP
|
||||
!
|
||||
! THE OVERLAP SHOULD BE THE SAME AS overlap_natorb_tc_eigvec_mo
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, q, p
|
||||
double precision :: accu, accu_d
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
|
||||
! ! MO_R x R
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
|
||||
, mo_r_coef, size(mo_r_coef, 1) &
|
||||
, fock_diag_sorted_r_natorb, size(fock_diag_sorted_r_natorb, 1) &
|
||||
, 0.d0, natorb_tc_reigvec_ao, size(natorb_tc_reigvec_ao, 1) )
|
||||
!
|
||||
! MO_L x L
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
|
||||
, mo_l_coef, size(mo_l_coef, 1) &
|
||||
, fock_diag_sorted_l_natorb, size(fock_diag_sorted_l_natorb, 1) &
|
||||
, 0.d0, natorb_tc_leigvec_ao, size(natorb_tc_leigvec_ao, 1) )
|
||||
|
||||
|
||||
allocate( tmp(mo_num,ao_num) )
|
||||
|
||||
! tmp <-- L.T x S_ao
|
||||
call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
|
||||
, natorb_tc_leigvec_ao, size(natorb_tc_leigvec_ao, 1), ao_overlap, size(ao_overlap, 1) &
|
||||
, 0.d0, tmp, size(tmp, 1) )
|
||||
|
||||
! S <-- tmp x R
|
||||
call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
|
||||
, tmp, size(tmp, 1), natorb_tc_reigvec_ao, size(natorb_tc_reigvec_ao, 1) &
|
||||
, 0.d0, overlap_natorb_tc_eigvec_ao, size(overlap_natorb_tc_eigvec_ao, 1) )
|
||||
|
||||
deallocate( tmp )
|
||||
|
||||
! ---
|
||||
double precision :: norm
|
||||
do i = 1, mo_num
|
||||
norm = 1.d0/dsqrt(dabs(overlap_natorb_tc_eigvec_ao(i,i)))
|
||||
do j = 1, mo_num
|
||||
natorb_tc_reigvec_ao(j,i) *= norm
|
||||
natorb_tc_leigvec_ao(j,i) *= norm
|
||||
enddo
|
||||
enddo
|
||||
|
||||
allocate( tmp(mo_num,ao_num) )
|
||||
|
||||
! tmp <-- L.T x S_ao
|
||||
call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
|
||||
, natorb_tc_leigvec_ao, size(natorb_tc_leigvec_ao, 1), ao_overlap, size(ao_overlap, 1) &
|
||||
, 0.d0, tmp, size(tmp, 1) )
|
||||
|
||||
! S <-- tmp x R
|
||||
call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
|
||||
, tmp, size(tmp, 1), natorb_tc_reigvec_ao, size(natorb_tc_reigvec_ao, 1) &
|
||||
, 0.d0, overlap_natorb_tc_eigvec_ao, size(overlap_natorb_tc_eigvec_ao, 1) )
|
||||
|
||||
|
||||
|
||||
deallocate( tmp )
|
||||
|
||||
accu_d = 0.d0
|
||||
accu = 0.d0
|
||||
do i = 1, mo_num
|
||||
accu_d += overlap_natorb_tc_eigvec_ao(i,i)
|
||||
do j = 1, mo_num
|
||||
if(i==j)cycle
|
||||
accu += dabs(overlap_natorb_tc_eigvec_ao(j,i))
|
||||
enddo
|
||||
enddo
|
||||
print*,'Trace of the overlap_natorb_tc_eigvec_ao = ',accu_d
|
||||
print*,'mo_num = ',mo_num
|
||||
print*,'L1 norm of extra diagonal elements of overlap matrix ',accu
|
||||
accu = accu / dble(mo_num**2)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
|
||||
BEGIN_PROVIDER [ double precision, tc_transition_matrix, (mo_num, mo_num,N_states,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! tc_transition_matrix(p,h,istate,jstate) = <Chi_istate| a^\dagger_p a_h |Phi_jstate>
|
||||
!
|
||||
! where <Chi_istate| and |Phi_jstate> are the left/right eigenvectors on a bi-ortho basis
|
||||
END_DOC
|
||||
integer :: i,j,istate,jstate,m,n,p,h
|
||||
double precision :: phase
|
||||
integer, allocatable :: occ(:,:)
|
||||
integer :: n_occ_ab(2),degree,exc(0:2,2,2)
|
||||
allocate(occ(N_int*bit_kind_size,2))
|
||||
tc_transition_matrix = 0.d0
|
||||
do istate = 1, N_states
|
||||
do jstate = 1, N_states
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int)
|
||||
if(degree.gt.1)then
|
||||
cycle
|
||||
else if (degree == 0)then
|
||||
call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int)
|
||||
do p = 1, n_occ_ab(1) ! browsing the alpha electrons
|
||||
m = occ(p,1)
|
||||
tc_transition_matrix(m,m,istate,jstate)+= psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,jstate)
|
||||
enddo
|
||||
do p = 1, n_occ_ab(2) ! browsing the beta electrons
|
||||
m = occ(p,1)
|
||||
tc_transition_matrix(m,m,istate,jstate)+= psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,jstate)
|
||||
enddo
|
||||
else
|
||||
call get_single_excitation(psi_det(1,1,j),psi_det(1,1,i),exc,phase,N_int)
|
||||
if (exc(0,1,1) == 1) then
|
||||
! Single alpha
|
||||
h = exc(1,1,1) ! hole in psi_det(1,1,j)
|
||||
p = exc(1,2,1) ! particle in psi_det(1,1,j)
|
||||
else
|
||||
! Single beta
|
||||
h = exc(1,1,2) ! hole in psi_det(1,1,j)
|
||||
p = exc(1,2,2) ! particle in psi_det(1,1,j)
|
||||
endif
|
||||
tc_transition_matrix(p,h,istate,jstate)+= phase * psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,jstate)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_bi_ortho_dipole, (3,N_states)]
|
||||
implicit none
|
||||
integer :: i,j,istate,m
|
||||
double precision :: nuclei_part(3)
|
||||
tc_bi_ortho_dipole = 0.d0
|
||||
do istate = 1, N_states
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
tc_bi_ortho_dipole(1,istate) += -(tc_transition_matrix(j,i,istate,istate)) * mo_bi_orth_bipole_x(j,i)
|
||||
tc_bi_ortho_dipole(2,istate) += -(tc_transition_matrix(j,i,istate,istate)) * mo_bi_orth_bipole_y(j,i)
|
||||
tc_bi_ortho_dipole(3,istate) += -(tc_transition_matrix(j,i,istate,istate)) * mo_bi_orth_bipole_z(j,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
nuclei_part = 0.d0
|
||||
do m = 1, 3
|
||||
do i = 1,nucl_num
|
||||
nuclei_part(m) += nucl_charge(i) * nucl_coord(i,m)
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
do istate = 1, N_states
|
||||
do m = 1, 3
|
||||
tc_bi_ortho_dipole(m,istate) += nuclei_part(m)
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
! ---
|
||||
|
||||
program tc_som
|
||||
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
print *, ' starting ...'
|
||||
print *, ' do not forget to do tc-scf first'
|
||||
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
! my_n_pt_r_grid = 10 ! small grid for quick debug
|
||||
! my_n_pt_a_grid = 26 ! small grid for quick debug
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
PROVIDE mu_erf
|
||||
print *, ' mu = ', mu_erf
|
||||
PROVIDE j1b_type
|
||||
print *, ' j1b_type = ', j1b_type
|
||||
print *, j1b_pen
|
||||
|
||||
read_wf = .true.
|
||||
touch read_wf
|
||||
|
||||
call main()
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine main()
|
||||
|
||||
implicit none
|
||||
integer :: i, i_HF, degree
|
||||
double precision :: hmono_1, htwoe_1, hthree_1, htot_1
|
||||
double precision :: hmono_2, htwoe_2, hthree_2, htot_2
|
||||
double precision :: U_SOM
|
||||
|
||||
PROVIDE N_int N_det
|
||||
|
||||
do i = 1, N_det
|
||||
call get_excitation_degree(HF_bitmask, psi_det(1,1,i), degree, N_int)
|
||||
if(degree == 0) then
|
||||
i_HF = i
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
print *, ' HF determinants:', i_HF
|
||||
print *, ' N_det :', N_det
|
||||
|
||||
U_SOM = 0.d0
|
||||
do i = 1, N_det
|
||||
if(i == i_HF) cycle
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1)
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
|
||||
U_SOM += htot_1 * htot_2
|
||||
enddo
|
||||
U_SOM = 0.5d0 * U_SOM
|
||||
print *, ' U_SOM = ', U_SOM
|
||||
|
||||
return
|
||||
end subroutine main
|
||||
|
||||
! ---
|
||||
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
program test_natorb
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together with the energy. Saves the left-right wave functions at the end.
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
call routine
|
||||
! call test
|
||||
|
||||
end
|
||||
|
||||
subroutine routine
|
||||
implicit none
|
||||
double precision, allocatable :: fock_diag(:),eigval(:),leigvec(:,:),reigvec(:,:),mat_ref(:,:)
|
||||
allocate(eigval(mo_num),leigvec(mo_num,mo_num),reigvec(mo_num,mo_num),fock_diag(mo_num),mat_ref(mo_num, mo_num))
|
||||
double precision, allocatable :: eigval_ref(:),leigvec_ref(:,:),reigvec_ref(:,:)
|
||||
allocate(eigval_ref(mo_num),leigvec_ref(mo_num,mo_num),reigvec_ref(mo_num,mo_num))
|
||||
|
||||
double precision :: thr_deg
|
||||
integer :: i,n_real,j
|
||||
print*,'fock_matrix'
|
||||
do i = 1, mo_num
|
||||
fock_diag(i) = Fock_matrix_mo(i,i)
|
||||
print*,i,fock_diag(i)
|
||||
enddo
|
||||
thr_deg = 1.d-6
|
||||
mat_ref = -one_e_dm_mo
|
||||
print*,'diagonalization by block'
|
||||
call diag_mat_per_fock_degen(fock_diag,mat_ref,mo_num,thr_deg,leigvec,reigvec,eigval)
|
||||
call non_hrmt_bieig( mo_num, mat_ref&
|
||||
, leigvec_ref, reigvec_ref&
|
||||
, n_real, eigval_ref)
|
||||
print*,'TEST ***********************************'
|
||||
double precision :: accu_l, accu_r
|
||||
do i = 1, mo_num
|
||||
accu_l = 0.d0
|
||||
accu_r = 0.d0
|
||||
do j = 1, mo_num
|
||||
accu_r += reigvec_ref(j,i) * reigvec(j,i)
|
||||
accu_l += leigvec_ref(j,i) * leigvec(j,i)
|
||||
enddo
|
||||
print*,i
|
||||
write(*,'(I3,X,100(F16.10,X))')i,eigval(i),eigval_ref(i),accu_l,accu_r
|
||||
enddo
|
||||
end
|
||||
|
|
@ -0,0 +1,131 @@
|
|||
program test_normal_order
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
call provide_all_three_ints_bi_ortho
|
||||
call test
|
||||
end
|
||||
|
||||
subroutine test
|
||||
implicit none
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
integer :: h1,h2,p1,p2,s1,s2,i_ok,degree,Ne(2)
|
||||
integer :: exc(0:2,2,2)
|
||||
integer(bit_kind), allocatable :: det_i(:,:)
|
||||
double precision :: hmono,htwoe,hthree,htilde_ij,accu,phase,normal
|
||||
integer, allocatable :: occ(:,:)
|
||||
allocate( occ(N_int*bit_kind_size,2) )
|
||||
call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int)
|
||||
allocate(det_i(N_int,2))
|
||||
s1 = 1
|
||||
s2 = 2
|
||||
accu = 0.d0
|
||||
do h1 = 1, elec_beta_num
|
||||
do p1 = elec_alpha_num+1, mo_num
|
||||
do h2 = 1, elec_beta_num
|
||||
do p2 = elec_beta_num+1, mo_num
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||
call htilde_mu_mat_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||
hthree *= phase
|
||||
! !normal = normal_two_body_bi_orth_ab(p2,h2,p1,h1)
|
||||
call three_comp_two_e_elem(det_i,h1,h2,p1,p2,s1,s2,normal)
|
||||
! normal = eff_2_e_from_3_e_ab(p2,p1,h2,h1)
|
||||
accu += dabs(hthree-normal)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu opposite spin = ',accu
|
||||
stop
|
||||
|
||||
! p2=6
|
||||
! p1=5
|
||||
! h2=2
|
||||
! h1=1
|
||||
|
||||
s1 = 1
|
||||
s2 = 1
|
||||
accu = 0.d0
|
||||
do h1 = 1, elec_alpha_num
|
||||
do p1 = elec_alpha_num+1, mo_num
|
||||
do p2 = p1+1, mo_num
|
||||
do h2 = h1+1, elec_alpha_num
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||
integer :: hh1, pp1, hh2, pp2, ss1, ss2
|
||||
call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
|
||||
hthree *= phase
|
||||
! normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
|
||||
normal = eff_2_e_from_3_e_aa(p2,p1,h2,h1)
|
||||
if(dabs(hthree).lt.1.d-10)cycle
|
||||
if(dabs(hthree-normal).gt.1.d-10)then
|
||||
print*,pp2,pp1,hh2,hh1
|
||||
print*,p2,p1,h2,h1
|
||||
print*,hthree,normal,dabs(hthree-normal)
|
||||
stop
|
||||
endif
|
||||
! print*,hthree,normal,dabs(hthree-normal)
|
||||
accu += dabs(hthree-normal)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu same spin alpha = ',accu
|
||||
|
||||
|
||||
s1 = 2
|
||||
s2 = 2
|
||||
accu = 0.d0
|
||||
do h1 = 1, elec_beta_num
|
||||
do p1 = elec_beta_num+1, mo_num
|
||||
do p2 = p1+1, mo_num
|
||||
do h2 = h1+1, elec_beta_num
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||
call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
|
||||
hthree *= phase
|
||||
! normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
|
||||
normal = eff_2_e_from_3_e_bb(p2,p1,h2,h1)
|
||||
if(dabs(hthree).lt.1.d-10)cycle
|
||||
if(dabs(hthree-normal).gt.1.d-10)then
|
||||
print*,pp2,pp1,hh2,hh1
|
||||
print*,p2,p1,h2,h1
|
||||
print*,hthree,normal,dabs(hthree-normal)
|
||||
stop
|
||||
endif
|
||||
! print*,hthree,normal,dabs(hthree-normal)
|
||||
accu += dabs(hthree-normal)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu same spin beta = ',accu
|
||||
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,254 @@
|
|||
program tc_bi_ortho
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
call test_h_u0
|
||||
! call test_slater_tc_opt
|
||||
! call timing_tot
|
||||
! call timing_diag
|
||||
! call timing_single
|
||||
! call timing_double
|
||||
end
|
||||
|
||||
subroutine test_h_u0
|
||||
implicit none
|
||||
double precision, allocatable :: v_0_ref(:),v_0_new(:),u_0(:), v_0_ref_dagger(:)
|
||||
double precision :: accu
|
||||
logical :: do_right
|
||||
integer :: i
|
||||
allocate(v_0_new(N_det),v_0_ref(N_det),u_0(N_det),v_0_ref_dagger(N_det))
|
||||
do_right = .True.
|
||||
do i = 1, N_det
|
||||
u_0(i) = psi_r_coef_bi_ortho(i,1)
|
||||
enddo
|
||||
call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right)
|
||||
call htc_bi_ortho_calc_tdav (v_0_ref,u_0,N_states,N_det)
|
||||
print*,'difference right '
|
||||
accu = 0.d0
|
||||
do i = 1, N_det
|
||||
print*,dabs(v_0_new(i) - v_0_ref(i)),v_0_new(i) , v_0_ref(i)
|
||||
accu += dabs(v_0_new(i) - v_0_ref(i))
|
||||
enddo
|
||||
print*,'accu = ',accu
|
||||
do_right = .False.
|
||||
v_0_new = 0.d0
|
||||
call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right)
|
||||
call htcdag_bi_ortho_calc_tdav(v_0_ref_dagger,u_0,N_states,N_det, do_right)
|
||||
print*,'difference left'
|
||||
accu = 0.d0
|
||||
do i = 1, N_det
|
||||
print*,dabs(v_0_new(i) - v_0_ref_dagger(i)),v_0_new(i) , v_0_ref_dagger(i)
|
||||
accu += dabs(v_0_new(i) - v_0_ref_dagger(i))
|
||||
enddo
|
||||
print*,'accu = ',accu
|
||||
end
|
||||
|
||||
subroutine test_slater_tc_opt
|
||||
implicit none
|
||||
integer :: i,j,degree
|
||||
double precision :: hmono, htwoe, htot, hthree
|
||||
double precision :: hnewmono, hnewtwoe, hnewthree, hnewtot
|
||||
double precision :: accu_d ,i_count, accu
|
||||
accu = 0.d0
|
||||
accu_d = 0.d0
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1,N_det
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hnewmono, hnewtwoe, hnewthree, hnewtot)
|
||||
if(dabs(htot).gt.1.d-15)then
|
||||
i_count += 1.D0
|
||||
accu += dabs(htot-hnewtot)
|
||||
if(dabs(htot-hnewtot).gt.1.d-8.or.dabs(htot-hnewtot).gt.dabs(htot))then
|
||||
call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
print*,j,i,degree
|
||||
call debug_det(psi_det(1,1,i),N_int)
|
||||
call debug_det(psi_det(1,1,j),N_int)
|
||||
print*,htot,hnewtot,dabs(htot-hnewtot)
|
||||
print*,hthree,hnewthree,dabs(hthree-hnewthree)
|
||||
stop
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu = ',accu/i_count
|
||||
|
||||
end
|
||||
|
||||
subroutine timing_tot
|
||||
implicit none
|
||||
integer :: i,j
|
||||
double precision :: wall0, wall1
|
||||
double precision, allocatable :: mat_old(:,:),mat_new(:,:)
|
||||
double precision :: hmono, htwoe, hthree, htot, i_count
|
||||
integer :: degree
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall0)
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
i_count += 1.d0
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for old hij for total = ',wall1 - wall0
|
||||
|
||||
call wall_time(wall0)
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
i_count += 1.d0
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for new hij for total = ',wall1 - wall0
|
||||
call i_H_j(psi_det(1,1,1), psi_det(1,1,2),N_int,htot)
|
||||
call wall_time(wall0)
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
call i_H_j(psi_det(1,1,j), psi_det(1,1,i),N_int,htot)
|
||||
i_count += 1.d0
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for new hij STANDARD = ',wall1 - wall0
|
||||
|
||||
end
|
||||
|
||||
subroutine timing_diag
|
||||
implicit none
|
||||
integer :: i,j
|
||||
double precision :: wall0, wall1
|
||||
double precision, allocatable :: mat_old(:,:),mat_new(:,:)
|
||||
double precision :: hmono, htwoe, hthree, htot, i_count
|
||||
integer :: degree
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall0)
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = i,i
|
||||
i_count += 1.d0
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for old hij for diagonal= ',wall1 - wall0
|
||||
|
||||
call wall_time(wall0)
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = i,i
|
||||
i_count += 1.d0
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for new hij for diagonal= ',wall1 - wall0
|
||||
|
||||
end
|
||||
|
||||
subroutine timing_single
|
||||
implicit none
|
||||
integer :: i,j
|
||||
double precision :: wall0, wall1,accu
|
||||
double precision, allocatable :: mat_old(:,:),mat_new(:,:)
|
||||
double precision :: hmono, htwoe, hthree, htot, i_count
|
||||
integer :: degree
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
|
||||
i_count = 0.d0
|
||||
accu = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
if(degree.ne.1)cycle
|
||||
i_count += 1.d0
|
||||
call wall_time(wall0)
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall1)
|
||||
accu += wall1 - wall0
|
||||
enddo
|
||||
enddo
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for old hij for singles = ',accu
|
||||
|
||||
i_count = 0.d0
|
||||
accu = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
if(degree.ne.1)cycle
|
||||
i_count += 1.d0
|
||||
call wall_time(wall0)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall1)
|
||||
accu += wall1 - wall0
|
||||
enddo
|
||||
enddo
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for new hij for singles = ',accu
|
||||
|
||||
end
|
||||
|
||||
subroutine timing_double
|
||||
implicit none
|
||||
integer :: i,j
|
||||
double precision :: wall0, wall1,accu
|
||||
double precision, allocatable :: mat_old(:,:),mat_new(:,:)
|
||||
double precision :: hmono, htwoe, hthree, htot, i_count
|
||||
integer :: degree
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
|
||||
i_count = 0.d0
|
||||
accu = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
if(degree.ne.2)cycle
|
||||
i_count += 1.d0
|
||||
call wall_time(wall0)
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall1)
|
||||
accu += wall1 - wall0
|
||||
enddo
|
||||
enddo
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for old hij for doubles = ',accu
|
||||
|
||||
i_count = 0.d0
|
||||
accu = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
if(degree.ne.2)cycle
|
||||
i_count += 1.d0
|
||||
call wall_time(wall0)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall1)
|
||||
accu += wall1 - wall0
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for new hij for doubles = ',accu
|
||||
|
||||
end
|
||||
|
||||
|
|
@ -0,0 +1,194 @@
|
|||
program test_tc_fock
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
print *, 'Hello world'
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
read_wf = .True.
|
||||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
!call routine_1
|
||||
!call routine_2
|
||||
! call routine_3()
|
||||
|
||||
! call test_3e
|
||||
call routine_tot
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_3e
|
||||
implicit none
|
||||
double precision :: integral_aaa,integral_aab,integral_abb,integral_bbb,accu
|
||||
double precision :: hmono, htwoe, hthree, htot
|
||||
call htilde_mu_mat_bi_ortho(ref_bitmask, ref_bitmask, N_int, hmono, htwoe, hthree, htot)
|
||||
! call diag_htilde_three_body_ints_bi_ort(N_int, ref_bitmask, hthree)
|
||||
print*,'hmono = ',hmono
|
||||
print*,'htwoe = ',htwoe
|
||||
print*,'hthree= ',hthree
|
||||
print*,'htot = ',htot
|
||||
print*,''
|
||||
print*,''
|
||||
print*,'TC_one= ',tc_hf_one_e_energy
|
||||
print*,'TC_two= ',TC_HF_two_e_energy
|
||||
print*,'TC_3e = ',diag_three_elem_hf
|
||||
print*,'TC_tot= ',TC_HF_energy
|
||||
print*,''
|
||||
print*,''
|
||||
call give_aaa_contrib(integral_aaa)
|
||||
print*,'integral_aaa = ',integral_aaa
|
||||
call give_aab_contrib(integral_aab)
|
||||
print*,'integral_aab = ',integral_aab
|
||||
call give_abb_contrib(integral_abb)
|
||||
print*,'integral_abb = ',integral_abb
|
||||
call give_bbb_contrib(integral_bbb)
|
||||
print*,'integral_bbb = ',integral_bbb
|
||||
accu = integral_aaa + integral_aab + integral_abb + integral_bbb
|
||||
print*,'accu = ',accu
|
||||
print*,'delta = ',hthree - accu
|
||||
|
||||
end
|
||||
|
||||
subroutine routine_3()
|
||||
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
|
||||
implicit none
|
||||
integer :: i, a, i_ok, s1
|
||||
double precision :: hmono, htwoe, hthree, htilde_ij
|
||||
double precision :: err_ai, err_tot, ref, new
|
||||
integer(bit_kind), allocatable :: det_i(:,:)
|
||||
|
||||
allocate(det_i(N_int,2))
|
||||
|
||||
err_tot = 0.d0
|
||||
|
||||
do s1 = 1, 2
|
||||
|
||||
det_i = ref_bitmask
|
||||
call debug_det(det_i, N_int)
|
||||
print*, ' HF det'
|
||||
call debug_det(det_i, N_int)
|
||||
|
||||
do i = 1, elec_num_tab(s1)
|
||||
do a = elec_num_tab(s1)+1, mo_num ! virtual
|
||||
|
||||
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i, i, a, s1, i_ok)
|
||||
if(i_ok == -1) then
|
||||
print*, 'PB !!'
|
||||
print*, i, a
|
||||
stop
|
||||
endif
|
||||
print*, ' excited det'
|
||||
call debug_det(det_i, N_int)
|
||||
|
||||
call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
|
||||
if(dabs(hthree).lt.1.d-10)cycle
|
||||
ref = hthree
|
||||
if(s1 == 1)then
|
||||
new = fock_a_tot_3e_bi_orth(a,i)
|
||||
else if(s1 == 2)then
|
||||
new = fock_b_tot_3e_bi_orth(a,i)
|
||||
endif
|
||||
err_ai = dabs(dabs(ref) - dabs(new))
|
||||
if(err_ai .gt. 1d-7) then
|
||||
print*,'s1 = ',s1
|
||||
print*, ' warning on', i, a
|
||||
print*, ref,new,err_ai
|
||||
endif
|
||||
print*, ref,new,err_ai
|
||||
err_tot += err_ai
|
||||
|
||||
write(22, *) htilde_ij
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print *, ' err_tot = ', err_tot
|
||||
|
||||
deallocate(det_i)
|
||||
|
||||
end subroutine routine_3
|
||||
|
||||
! ---
|
||||
subroutine routine_tot()
|
||||
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
|
||||
implicit none
|
||||
integer :: i, a, i_ok, s1,other_spin(2)
|
||||
double precision :: hmono, htwoe, hthree, htilde_ij
|
||||
double precision :: err_ai, err_tot, ref, new
|
||||
integer(bit_kind), allocatable :: det_i(:,:)
|
||||
|
||||
allocate(det_i(N_int,2))
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
err_tot = 0.d0
|
||||
|
||||
! do s1 = 1, 2
|
||||
s1 = 2
|
||||
det_i = ref_bitmask
|
||||
call debug_det(det_i, N_int)
|
||||
print*, ' HF det'
|
||||
call debug_det(det_i, N_int)
|
||||
|
||||
! do i = 1, elec_num_tab(s1)
|
||||
! do a = elec_num_tab(s1)+1, mo_num ! virtual
|
||||
do i = 1, elec_beta_num
|
||||
do a = elec_beta_num+1, elec_alpha_num! virtual
|
||||
! do i = elec_beta_num+1, elec_alpha_num
|
||||
! do a = elec_alpha_num+1, mo_num! virtual
|
||||
print*,i,a
|
||||
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i, i, a, s1, i_ok)
|
||||
if(i_ok == -1) then
|
||||
print*, 'PB !!'
|
||||
print*, i, a
|
||||
stop
|
||||
endif
|
||||
|
||||
call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
|
||||
print*,htilde_ij
|
||||
if(dabs(htilde_ij).lt.1.d-10)cycle
|
||||
print*, ' excited det'
|
||||
call debug_det(det_i, N_int)
|
||||
|
||||
if(s1 == 1)then
|
||||
new = Fock_matrix_tc_mo_alpha(a,i)
|
||||
else
|
||||
new = Fock_matrix_tc_mo_beta(a,i)
|
||||
endif
|
||||
ref = htilde_ij
|
||||
! if(s1 == 1)then
|
||||
! new = fock_a_tot_3e_bi_orth(a,i)
|
||||
! else if(s1 == 2)then
|
||||
! new = fock_b_tot_3e_bi_orth(a,i)
|
||||
! endif
|
||||
err_ai = dabs(dabs(ref) - dabs(new))
|
||||
if(err_ai .gt. 1d-7) then
|
||||
print*,'s1 = ',s1
|
||||
print*, ' warning on', i, a
|
||||
print*, ref,new,err_ai
|
||||
endif
|
||||
print*, ref,new,err_ai
|
||||
err_tot += err_ai
|
||||
|
||||
write(22, *) htilde_ij
|
||||
enddo
|
||||
enddo
|
||||
! enddo
|
||||
|
||||
print *, ' err_tot = ', err_tot
|
||||
|
||||
deallocate(det_i)
|
||||
|
||||
end subroutine routine_3
|
||||
|
|
@ -0,0 +1,770 @@
|
|||
subroutine u_0_H_tc_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze, do_right)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $E_0 = \frac{\langle u_0 | H_TC | u_0 \rangle}{\langle u_0 | u_0 \rangle}$
|
||||
!
|
||||
! n : number of determinants
|
||||
!
|
||||
! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi>
|
||||
END_DOC
|
||||
integer, intent(in) :: n,Nint, N_st, sze
|
||||
logical, intent(in) :: do_right
|
||||
double precision, intent(out) :: e_0(N_st)
|
||||
double precision, intent(inout) :: u_0(sze,N_st)
|
||||
integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n)
|
||||
|
||||
double precision, allocatable :: v_0(:,:), u_1(:,:)
|
||||
double precision :: u_dot_u,u_dot_v,diag_H_mat_elem
|
||||
integer :: i,j, istate
|
||||
|
||||
allocate (v_0(n,N_st),u_1(n,N_st))
|
||||
u_1(:,:) = 0.d0
|
||||
u_1(1:n,1:N_st) = u_0(1:n,1:N_st)
|
||||
call H_tc_u_0_nstates_openmp(v_0,u_1,N_st,n, do_right)
|
||||
u_0(1:n,1:N_st) = u_1(1:n,1:N_st)
|
||||
deallocate(u_1)
|
||||
double precision :: norm
|
||||
!$OMP PARALLEL DO PRIVATE(i,norm) DEFAULT(SHARED)
|
||||
do i=1,N_st
|
||||
norm = u_dot_u(u_0(1,i),n)
|
||||
if (norm /= 0.d0) then
|
||||
e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n) / dsqrt(norm)
|
||||
else
|
||||
e_0(i) = 0.d0
|
||||
endif
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
deallocate (v_0)
|
||||
end
|
||||
|
||||
|
||||
subroutine H_tc_u_0_opt(v_0,u_0,N_st,sze)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $v_0 = H | u_0\rangle$.
|
||||
!
|
||||
! Assumes that the determinants are in psi_det
|
||||
!
|
||||
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze
|
||||
double precision, intent(inout) :: v_0(sze,N_st), u_0(sze,N_st)
|
||||
logical :: do_right
|
||||
do_right = .True.
|
||||
call H_tc_u_0_nstates_openmp(v_0,u_0,N_st,sze, do_right)
|
||||
end
|
||||
|
||||
subroutine H_tc_dagger_u_0_opt(v_0,u_0,N_st,sze)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $v_0 = H | u_0\rangle$.
|
||||
!
|
||||
! Assumes that the determinants are in psi_det
|
||||
!
|
||||
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze
|
||||
double precision, intent(inout) :: v_0(sze,N_st), u_0(sze,N_st)
|
||||
logical :: do_right
|
||||
do_right = .False.
|
||||
call H_tc_u_0_nstates_openmp(v_0,u_0,N_st,sze, do_right)
|
||||
end
|
||||
|
||||
|
||||
subroutine H_tc_u_0_nstates_openmp(v_0,u_0,N_st,sze, do_right)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $v_0 = H | u_0\rangle$.
|
||||
!
|
||||
! Assumes that the determinants are in psi_det
|
||||
!
|
||||
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||
!
|
||||
! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi>
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze
|
||||
double precision, intent(inout) :: v_0(sze,N_st), u_0(sze,N_st)
|
||||
logical, intent(in) :: do_right
|
||||
integer :: k
|
||||
double precision, allocatable :: u_t(:,:), v_t(:,:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
|
||||
allocate(u_t(N_st,N_det),v_t(N_st,N_det))
|
||||
provide mo_bi_ortho_tc_one_e mo_bi_ortho_tc_two_e
|
||||
provide ref_tc_energy_tot fock_op_2_e_tc_closed_shell
|
||||
provide eff_2_e_from_3_e_ab eff_2_e_from_3_e_aa eff_2_e_from_3_e_bb
|
||||
do k=1,N_st
|
||||
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
||||
enddo
|
||||
v_t = 0.d0
|
||||
call dtranspose( &
|
||||
u_0, &
|
||||
size(u_0, 1), &
|
||||
u_t, &
|
||||
size(u_t, 1), &
|
||||
N_det, N_st)
|
||||
|
||||
call H_tc_u_0_nstates_openmp_work(v_t,u_t,N_st,sze,1,N_det,0,1, do_right)
|
||||
deallocate(u_t)
|
||||
|
||||
call dtranspose( &
|
||||
v_t, &
|
||||
size(v_t, 1), &
|
||||
v_0, &
|
||||
size(v_0, 1), &
|
||||
N_st, N_det)
|
||||
deallocate(v_t)
|
||||
|
||||
do k=1,N_st
|
||||
call dset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||
call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine H_tc_u_0_nstates_openmp_work(v_t,u_t,N_st,sze,istart,iend,ishift,istep, do_right)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $v_t = H | u_t\rangle$
|
||||
!
|
||||
! Default should be 1,N_det,0,1
|
||||
!
|
||||
! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi>
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||
double precision, intent(in) :: u_t(N_st,N_det)
|
||||
logical, intent(in) :: do_right
|
||||
double precision, intent(out) :: v_t(N_st,sze)
|
||||
|
||||
|
||||
PROVIDE ref_bitmask_energy N_int
|
||||
|
||||
select case (N_int)
|
||||
case (1)
|
||||
call H_tc_u_0_nstates_openmp_work_1(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right)
|
||||
case (2)
|
||||
call H_tc_u_0_nstates_openmp_work_2(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right)
|
||||
case (3)
|
||||
call H_tc_u_0_nstates_openmp_work_3(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right)
|
||||
case (4)
|
||||
call H_tc_u_0_nstates_openmp_work_4(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right)
|
||||
case default
|
||||
call H_tc_u_0_nstates_openmp_work_N_int(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right)
|
||||
end select
|
||||
end
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
subroutine H_tc_u_0_nstates_openmp_work_$N_int(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $v_t = H | u_t \\rangle$
|
||||
!
|
||||
! Default should be 1,N_det,0,1
|
||||
!
|
||||
! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi>
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||
double precision, intent(in) :: u_t(N_st,N_det)
|
||||
logical, intent(in) :: do_right
|
||||
double precision, intent(out) :: v_t(N_st,sze)
|
||||
|
||||
double precision :: hij
|
||||
integer :: i,j,k,l,kk
|
||||
integer :: k_a, k_b, l_a, l_b, m_a, m_b
|
||||
integer :: istate
|
||||
integer :: krow, kcol, krow_b, kcol_b
|
||||
integer :: lrow, lcol
|
||||
integer :: mrow, mcol
|
||||
integer(bit_kind) :: spindet($N_int)
|
||||
integer(bit_kind) :: tmp_det($N_int,2)
|
||||
integer(bit_kind) :: tmp_det2($N_int,2)
|
||||
integer(bit_kind) :: tmp_det3($N_int,2)
|
||||
integer(bit_kind), allocatable :: buffer(:,:)
|
||||
integer :: n_doubles
|
||||
integer, allocatable :: doubles(:)
|
||||
integer, allocatable :: singles_a(:)
|
||||
integer, allocatable :: singles_b(:)
|
||||
integer, allocatable :: idx(:), idx0(:)
|
||||
integer :: maxab, n_singles_a, n_singles_b, kcol_prev
|
||||
integer*8 :: k8
|
||||
logical :: compute_singles
|
||||
integer*8 :: last_found, left, right, right_max
|
||||
double precision :: rss, mem, ratio
|
||||
double precision, allocatable :: utl(:,:)
|
||||
integer, parameter :: block_size=128
|
||||
logical :: u_is_sparse
|
||||
|
||||
! call resident_memory(rss)
|
||||
! mem = dble(singles_beta_csc_size) / 1024.d0**3
|
||||
!
|
||||
! compute_singles = (mem+rss > qp_max_mem)
|
||||
!
|
||||
! if (.not.compute_singles) then
|
||||
! provide singles_beta_csc
|
||||
! endif
|
||||
compute_singles=.True.
|
||||
|
||||
|
||||
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
|
||||
allocate(idx0(maxab))
|
||||
|
||||
do i=1,maxab
|
||||
idx0(i) = i
|
||||
enddo
|
||||
|
||||
! Prepare the array of all alpha single excitations
|
||||
! -------------------------------------------------
|
||||
|
||||
PROVIDE N_int nthreads_davidson
|
||||
!$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads_davidson) &
|
||||
!$OMP SHARED(psi_bilinear_matrix_rows, N_det, &
|
||||
!$OMP psi_bilinear_matrix_columns, &
|
||||
!$OMP psi_det_alpha_unique, psi_det_beta_unique, &
|
||||
!$OMP n_det_alpha_unique, n_det_beta_unique, N_int, &
|
||||
!$OMP psi_bilinear_matrix_transp_rows, &
|
||||
!$OMP psi_bilinear_matrix_transp_columns, &
|
||||
!$OMP psi_bilinear_matrix_transp_order, N_st, &
|
||||
!$OMP psi_bilinear_matrix_order_transp_reverse, &
|
||||
!$OMP psi_bilinear_matrix_columns_loc, &
|
||||
!$OMP psi_bilinear_matrix_transp_rows_loc, &
|
||||
!$OMP istart, iend, istep, irp_here, v_t, &
|
||||
!$OMP ishift, idx0, u_t, maxab, compute_singles, &
|
||||
!$OMP singles_alpha_csc,singles_alpha_csc_idx, &
|
||||
!$OMP singles_beta_csc,singles_beta_csc_idx) &
|
||||
!$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, &
|
||||
!$OMP lcol, lrow, l_a, l_b, utl, kk, u_is_sparse, &
|
||||
!$OMP buffer, doubles, n_doubles, umax, &
|
||||
!$OMP tmp_det2, hij, idx, l, kcol_prev,hmono, htwoe, hthree, &
|
||||
!$OMP singles_a, n_singles_a, singles_b, ratio, &
|
||||
!$OMP n_singles_b, k8, last_found,left,right,right_max)
|
||||
|
||||
! Alpha/Beta double excitations
|
||||
! =============================
|
||||
|
||||
allocate( buffer($N_int,maxab), &
|
||||
singles_a(maxab), &
|
||||
singles_b(maxab), &
|
||||
doubles(maxab), &
|
||||
idx(maxab), utl(N_st,block_size))
|
||||
|
||||
kcol_prev=-1
|
||||
|
||||
! Check if u has multiple zeros
|
||||
kk=1 ! Avoid division by zero
|
||||
!$OMP DO
|
||||
do k=1,N_det
|
||||
umax = 0.d0
|
||||
do l=1,N_st
|
||||
umax = max(umax, dabs(u_t(l,k)))
|
||||
enddo
|
||||
if (umax < 1.d-20) then
|
||||
!$OMP ATOMIC
|
||||
kk = kk+1
|
||||
endif
|
||||
enddo
|
||||
!$OMP END DO
|
||||
u_is_sparse = N_det / kk < 20 ! 5%
|
||||
|
||||
ASSERT (iend <= N_det)
|
||||
ASSERT (istart > 0)
|
||||
ASSERT (istep > 0)
|
||||
|
||||
!$OMP DO SCHEDULE(guided,64)
|
||||
do k_a=istart+ishift,iend,istep ! Loop over all determinants (/!\ not in psidet order)
|
||||
|
||||
krow = psi_bilinear_matrix_rows(k_a) ! Index of alpha part of determinant k_a
|
||||
ASSERT (krow <= N_det_alpha_unique)
|
||||
|
||||
kcol = psi_bilinear_matrix_columns(k_a) ! Index of beta part of determinant k_a
|
||||
ASSERT (kcol <= N_det_beta_unique)
|
||||
|
||||
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||
|
||||
if (kcol /= kcol_prev) then
|
||||
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||
if (compute_singles) then
|
||||
call get_all_spin_singles_$N_int( &
|
||||
psi_det_beta_unique, idx0, &
|
||||
tmp_det(1,2), N_det_beta_unique, &
|
||||
singles_b, n_singles_b)
|
||||
else
|
||||
n_singles_b = 0
|
||||
!DIR$ LOOP COUNT avg(1000)
|
||||
do k8=singles_beta_csc_idx(kcol),singles_beta_csc_idx(kcol+1)-1
|
||||
n_singles_b = n_singles_b+1
|
||||
singles_b(n_singles_b) = singles_beta_csc(k8)
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
kcol_prev = kcol
|
||||
|
||||
! -> Here, tmp_det is determinant k_a
|
||||
|
||||
! Loop over singly excited beta columns
|
||||
! -------------------------------------
|
||||
|
||||
!DIR$ LOOP COUNT avg(1000)
|
||||
do i=1,n_singles_b
|
||||
lcol = singles_b(i)
|
||||
|
||||
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
|
||||
|
||||
! tmp_det2 is a single excitation of tmp_det in the beta spin
|
||||
! the alpha part is not defined yet
|
||||
|
||||
!---
|
||||
! if (compute_singles) then
|
||||
|
||||
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||
ASSERT (l_a <= N_det)
|
||||
! rows : | 1 2 3 4 | 1 3 4 6 | .... | 1 2 4 5 |
|
||||
! cols : | 1 1 1 1 | 2 2 2 2 | .... | 8 8 8 8 |
|
||||
! index : | 1 2 3 4 | 5 6 7 8 | .... | 58 59 60 61 |
|
||||
! ^ ^
|
||||
! | |
|
||||
! l_a N_det
|
||||
! l_a is the index in the big vector os size Ndet of the position of the first element of column lcol
|
||||
|
||||
! Below we identify all the determinants with the same beta part
|
||||
|
||||
!DIR$ UNROLL(8)
|
||||
!DIR$ LOOP COUNT avg(50000)
|
||||
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) ! hot spot
|
||||
|
||||
ASSERT (l_a <= N_det)
|
||||
idx(j) = l_a
|
||||
l_a = l_a+1
|
||||
enddo
|
||||
j = j-1
|
||||
|
||||
! Get all single excitations from tmp_det(1,1) to buffer(1,?)
|
||||
|
||||
call get_all_spin_singles_$N_int( &
|
||||
buffer, idx, tmp_det(1,1), j, &
|
||||
singles_a, n_singles_a )
|
||||
|
||||
! Loop over alpha singles
|
||||
! -----------------------
|
||||
|
||||
double precision :: umax
|
||||
|
||||
!DIR$ LOOP COUNT avg(1000)
|
||||
do k = 1,n_singles_a,block_size
|
||||
umax = 0.d0
|
||||
! Prefetch u_t(:,l_a)
|
||||
if (u_is_sparse) then
|
||||
do kk=0,block_size-1
|
||||
if (k+kk > n_singles_a) exit
|
||||
l_a = singles_a(k+kk)
|
||||
ASSERT (l_a <= N_det)
|
||||
|
||||
do l=1,N_st
|
||||
utl(l,kk+1) = u_t(l,l_a)
|
||||
umax = max(umax, dabs(utl(l,kk+1)))
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do kk=0,block_size-1
|
||||
if (k+kk > n_singles_a) exit
|
||||
l_a = singles_a(k+kk)
|
||||
ASSERT (l_a <= N_det)
|
||||
utl(:,kk+1) = u_t(:,l_a)
|
||||
enddo
|
||||
umax = 1.d0
|
||||
endif
|
||||
if (umax < 1.d-20) cycle
|
||||
|
||||
do kk=0,block_size-1
|
||||
if (k+kk > n_singles_a) exit
|
||||
l_a = singles_a(k+kk)
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||
! call i_H_j( tmp_det, tmp_det2, $N_int, hij) ! double alpha-beta
|
||||
if(do_right)then
|
||||
call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij)
|
||||
else
|
||||
call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij)
|
||||
endif
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do l=1,N_st
|
||||
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
|
||||
enddo
|
||||
!$OMP END DO
|
||||
|
||||
!$OMP DO SCHEDULE(guided,64)
|
||||
do k_a=istart+ishift,iend,istep
|
||||
|
||||
|
||||
! Single and double alpha excitations
|
||||
! ===================================
|
||||
|
||||
|
||||
! Initial determinant is at k_a in alpha-major representation
|
||||
! -----------------------------------------------------------------------
|
||||
|
||||
krow = psi_bilinear_matrix_rows(k_a)
|
||||
ASSERT (krow <= N_det_alpha_unique)
|
||||
|
||||
kcol = psi_bilinear_matrix_columns(k_a)
|
||||
ASSERT (kcol <= N_det_beta_unique)
|
||||
|
||||
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)
|
||||
|
||||
! Initial determinant is at k_b in beta-major representation
|
||||
! ----------------------------------------------------------------------
|
||||
|
||||
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||
ASSERT (k_b <= N_det)
|
||||
|
||||
spindet(1:$N_int) = tmp_det(1:$N_int,1)
|
||||
|
||||
! Loop inside the beta column to gather all the connected alphas
|
||||
lcol = psi_bilinear_matrix_columns(k_a)
|
||||
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||
|
||||
!DIR$ LOOP COUNT avg(200000)
|
||||
do i=1,N_det_alpha_unique
|
||||
if (l_a > N_det) exit
|
||||
lcol = psi_bilinear_matrix_columns(l_a)
|
||||
if (lcol /= kcol) exit
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) ! Hot spot
|
||||
idx(i) = l_a
|
||||
l_a = l_a+1
|
||||
enddo
|
||||
i = i-1
|
||||
|
||||
call get_all_spin_singles_and_doubles_$N_int( &
|
||||
buffer, idx, spindet, i, &
|
||||
singles_a, doubles, n_singles_a, n_doubles )
|
||||
|
||||
! Compute Hij for all alpha singles
|
||||
! ----------------------------------
|
||||
|
||||
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||
!DIR$ LOOP COUNT avg(1000)
|
||||
do i=1,n_singles_a,block_size
|
||||
umax = 0.d0
|
||||
! Prefetch u_t(:,l_a)
|
||||
if (u_is_sparse) then
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_singles_a) exit
|
||||
l_a = singles_a(i+kk)
|
||||
ASSERT (l_a <= N_det)
|
||||
|
||||
do l=1,N_st
|
||||
utl(l,kk+1) = u_t(l,l_a)
|
||||
umax = max(umax, dabs(utl(l,kk+1)))
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_singles_a) exit
|
||||
l_a = singles_a(i+kk)
|
||||
ASSERT (l_a <= N_det)
|
||||
utl(:,kk+1) = u_t(:,l_a)
|
||||
enddo
|
||||
umax = 1.d0
|
||||
endif
|
||||
if (umax < 1.d-20) cycle
|
||||
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_singles_a) exit
|
||||
l_a = singles_a(i+kk)
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||
! call i_h_j_single_spin( tmp_det, tmp_det2, $N_int, 1, hij)
|
||||
if(do_right)then
|
||||
call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij)
|
||||
else
|
||||
call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij)
|
||||
endif
|
||||
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do l=1,N_st
|
||||
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
! Compute Hij for all alpha doubles
|
||||
! ----------------------------------
|
||||
|
||||
!DIR$ LOOP COUNT avg(50000)
|
||||
do i=1,n_doubles,block_size
|
||||
umax = 0.d0
|
||||
! Prefetch u_t(:,l_a)
|
||||
if (u_is_sparse) then
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_doubles) exit
|
||||
l_a = doubles(i+kk)
|
||||
ASSERT (l_a <= N_det)
|
||||
|
||||
do l=1,N_st
|
||||
utl(l,kk+1) = u_t(l,l_a)
|
||||
umax = max(umax, dabs(utl(l,kk+1)))
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_doubles) exit
|
||||
l_a = doubles(i+kk)
|
||||
ASSERT (l_a <= N_det)
|
||||
utl(:,kk+1) = u_t(:,l_a)
|
||||
enddo
|
||||
umax = 1.d0
|
||||
endif
|
||||
if (umax < 1.d-20) cycle
|
||||
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_doubles) exit
|
||||
l_a = doubles(i+kk)
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow)
|
||||
! call i_H_j( tmp_det, tmp_det2, $N_int, hij)
|
||||
! call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij)
|
||||
if(do_right)then
|
||||
call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij)
|
||||
else
|
||||
call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij)
|
||||
endif
|
||||
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do l=1,N_st
|
||||
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
! Single and double beta excitations
|
||||
! ==================================
|
||||
|
||||
|
||||
! Initial determinant is at k_a in alpha-major representation
|
||||
! -----------------------------------------------------------------------
|
||||
|
||||
krow = psi_bilinear_matrix_rows(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,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||
|
||||
spindet(1:$N_int) = tmp_det(1:$N_int,2)
|
||||
|
||||
! Initial determinant is at k_b in beta-major representation
|
||||
! -----------------------------------------------------------------------
|
||||
|
||||
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||
ASSERT (k_b <= N_det)
|
||||
|
||||
! Loop inside the alpha row to gather all the connected betas
|
||||
lrow = psi_bilinear_matrix_transp_rows(k_b)
|
||||
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
|
||||
!DIR$ LOOP COUNT avg(200000)
|
||||
do i=1,N_det_beta_unique
|
||||
if (l_b > N_det) exit
|
||||
lrow = psi_bilinear_matrix_transp_rows(l_b)
|
||||
if (lrow /= krow) exit
|
||||
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||
ASSERT (lcol <= N_det_beta_unique)
|
||||
|
||||
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
|
||||
idx(i) = l_b
|
||||
l_b = l_b+1
|
||||
enddo
|
||||
i = i-1
|
||||
|
||||
call get_all_spin_singles_and_doubles_$N_int( &
|
||||
buffer, idx, spindet, i, &
|
||||
singles_b, doubles, n_singles_b, n_doubles )
|
||||
|
||||
! Compute Hij for all beta singles
|
||||
! ----------------------------------
|
||||
|
||||
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||
!DIR$ LOOP COUNT avg(1000)
|
||||
do i=1,n_singles_b,block_size
|
||||
umax = 0.d0
|
||||
if (u_is_sparse) then
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_singles_b) exit
|
||||
l_b = singles_b(i+kk)
|
||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||
ASSERT (l_b <= N_det)
|
||||
ASSERT (l_a <= N_det)
|
||||
|
||||
do l=1,N_st
|
||||
utl(l,kk+1) = u_t(l,l_a)
|
||||
umax = max(umax, dabs(utl(l,kk+1)))
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_singles_b) exit
|
||||
l_b = singles_b(i+kk)
|
||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||
ASSERT (l_b <= N_det)
|
||||
ASSERT (l_a <= N_det)
|
||||
utl(:,kk+1) = u_t(:,l_a)
|
||||
enddo
|
||||
umax = 1.d0
|
||||
endif
|
||||
if (umax < 1.d-20) cycle
|
||||
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_singles_b) exit
|
||||
l_b = singles_b(i+kk)
|
||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||
ASSERT (lcol <= N_det_beta_unique)
|
||||
|
||||
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
|
||||
! call i_H_j_single_spin( tmp_det, tmp_det2, $N_int, 2, hij)
|
||||
if(do_right)then
|
||||
call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij)
|
||||
else
|
||||
call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij)
|
||||
endif
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do l=1,N_st
|
||||
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Compute Hij for all beta doubles
|
||||
! ----------------------------------
|
||||
|
||||
!DIR$ LOOP COUNT avg(50000)
|
||||
do i=1,n_doubles,block_size
|
||||
umax = 0.d0
|
||||
if (u_is_sparse) then
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_doubles) exit
|
||||
l_b = doubles(i+kk)
|
||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||
ASSERT (l_b <= N_det)
|
||||
ASSERT (l_a <= N_det)
|
||||
do l=1,N_st
|
||||
utl(l,kk+1) = u_t(l,l_a)
|
||||
umax = max(umax, dabs(utl(l,kk+1)))
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_doubles) exit
|
||||
l_b = doubles(i+kk)
|
||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||
ASSERT (l_b <= N_det)
|
||||
ASSERT (l_a <= N_det)
|
||||
utl(:,kk+1) = u_t(:,l_a)
|
||||
enddo
|
||||
umax = 1.d0
|
||||
endif
|
||||
if (umax < 1.d-20) cycle
|
||||
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_doubles) exit
|
||||
l_b = doubles(i+kk)
|
||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||
ASSERT (lcol <= N_det_beta_unique)
|
||||
|
||||
tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, lcol)
|
||||
! call i_H_j( tmp_det, tmp_det2, $N_int, hij)
|
||||
! call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij)
|
||||
if(do_right)then
|
||||
call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij)
|
||||
else
|
||||
call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij)
|
||||
endif
|
||||
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do l=1,N_st
|
||||
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
! Diagonal contribution
|
||||
! =====================
|
||||
|
||||
|
||||
! Initial determinant is at k_a in alpha-major representation
|
||||
! -----------------------------------------------------------------------
|
||||
|
||||
if (u_is_sparse) then
|
||||
umax = 0.d0
|
||||
do l=1,N_st
|
||||
umax = max(umax, dabs(u_t(l,k_a)))
|
||||
enddo
|
||||
else
|
||||
umax = 1.d0
|
||||
endif
|
||||
if (umax < 1.d-20) cycle
|
||||
|
||||
krow = psi_bilinear_matrix_rows(k_a)
|
||||
ASSERT (krow <= N_det_alpha_unique)
|
||||
|
||||
kcol = psi_bilinear_matrix_columns(k_a)
|
||||
ASSERT (kcol <= N_det_beta_unique)
|
||||
|
||||
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)
|
||||
|
||||
double precision, external :: diag_H_mat_elem
|
||||
double precision :: hmono, htwoe, hthree
|
||||
|
||||
! hij = diag_H_mat_elem(tmp_det,$N_int)
|
||||
call diag_htilde_mu_mat_fock_bi_ortho ($N_int, tmp_det, hmono, htwoe, hthree, hij)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do l=1,N_st
|
||||
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a)
|
||||
enddo
|
||||
|
||||
end do
|
||||
!$OMP END DO
|
||||
deallocate(buffer, singles_a, singles_b, doubles, idx, utl)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
end
|
||||
|
||||
SUBST [ N_int ]
|
||||
|
||||
1;;
|
||||
2;;
|
||||
3;;
|
||||
4;;
|
||||
N_int;;
|
||||
|
||||
END_TEMPLATE
|
||||
|
||||
|
||||
|
|
@ -1649,3 +1649,185 @@ subroutine restore_symmetry(m,n,A,LDA,thresh)
|
|||
enddo
|
||||
|
||||
end
|
||||
|
||||
subroutine diag_nonsym_right(n, A, A_ldim, V, V_ldim, energy, E_ldim)
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: n, A_ldim, V_ldim, E_ldim
|
||||
double precision, intent(in) :: A(A_ldim,n)
|
||||
double precision, intent(out) :: energy(E_ldim), V(V_ldim,n)
|
||||
|
||||
character*1 :: JOBVL, JOBVR, BALANC, SENSE
|
||||
integer :: i, j
|
||||
integer :: ILO, IHI, lda, ldvl, ldvr, LWORK, INFO
|
||||
double precision :: ABNRM
|
||||
integer, allocatable :: iorder(:), IWORK(:)
|
||||
double precision, allocatable :: WORK(:), SCALE_array(:), RCONDE(:), RCONDV(:)
|
||||
double precision, allocatable :: Atmp(:,:), WR(:), WI(:), VL(:,:), VR(:,:), Vtmp(:)
|
||||
double precision, allocatable :: energy_loc(:), V_loc(:,:)
|
||||
|
||||
allocate( Atmp(n,n), WR(n), WI(n), VL(1,1), VR(n,n) )
|
||||
do i = 1, n
|
||||
do j = 1, n
|
||||
Atmp(j,i) = A(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
JOBVL = "N" ! computes the left eigenvectors
|
||||
JOBVR = "V" ! computes the right eigenvectors
|
||||
BALANC = "B" ! Diagonal scaling and Permutation for optimization
|
||||
SENSE = "V" ! Determines which reciprocal condition numbers are computed
|
||||
lda = n
|
||||
ldvr = n
|
||||
ldvl = 1
|
||||
|
||||
allocate( WORK(1), SCALE_array(n), RCONDE(n), RCONDV(n), IWORK(2*n-2) )
|
||||
|
||||
LWORK = -1 ! to ask for the optimal size of WORK
|
||||
call dgeevx( BALANC, JOBVL, JOBVR, SENSE & ! CHARACTERS
|
||||
, n, Atmp, lda & ! MATRIX TO DIAGONALIZE
|
||||
, WR, WI & ! REAL AND IMAGINARY PART OF EIGENVALUES
|
||||
, VL, ldvl, VR, ldvr & ! LEFT AND RIGHT EIGENVECTORS
|
||||
, ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & ! OUTPUTS OF OPTIMIZATION
|
||||
, WORK, LWORK, IWORK, INFO )
|
||||
|
||||
if(INFO .ne. 0) then
|
||||
print*, 'dgeevx failed !!', INFO
|
||||
stop
|
||||
endif
|
||||
|
||||
LWORK = max(int(work(1)), 1) ! this is the optimal size of WORK
|
||||
deallocate(WORK)
|
||||
allocate(WORK(LWORK))
|
||||
call dgeevx( BALANC, JOBVL, JOBVR, SENSE &
|
||||
, n, Atmp, lda &
|
||||
, WR, WI &
|
||||
, VL, ldvl, VR, ldvr &
|
||||
, ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV &
|
||||
, WORK, LWORK, IWORK, INFO )
|
||||
if(INFO .ne. 0) then
|
||||
print*, 'dgeevx failed !!', INFO
|
||||
stop
|
||||
endif
|
||||
|
||||
deallocate( WORK, SCALE_array, RCONDE, RCONDV, IWORK )
|
||||
deallocate( VL, Atmp )
|
||||
|
||||
|
||||
allocate( energy_loc(n), V_loc(n,n) )
|
||||
energy_loc = 0.d0
|
||||
V_loc = 0.d0
|
||||
|
||||
i = 1
|
||||
do while(i .le. n)
|
||||
|
||||
! print*, i, WR(i), WI(i)
|
||||
|
||||
if( dabs(WI(i)) .gt. 1e-7 ) then
|
||||
|
||||
print*, ' Found an imaginary component to eigenvalue'
|
||||
print*, ' Re(i) + Im(i)', i, WR(i), WI(i)
|
||||
|
||||
energy_loc(i) = WR(i)
|
||||
do j = 1, n
|
||||
V_loc(j,i) = WR(i) * VR(j,i) - WI(i) * VR(j,i+1)
|
||||
enddo
|
||||
energy_loc(i+1) = WI(i)
|
||||
do j = 1, n
|
||||
V_loc(j,i+1) = WR(i) * VR(j,i+1) + WI(i) * VR(j,i)
|
||||
enddo
|
||||
i = i + 2
|
||||
|
||||
else
|
||||
|
||||
energy_loc(i) = WR(i)
|
||||
do j = 1, n
|
||||
V_loc(j,i) = VR(j,i)
|
||||
enddo
|
||||
i = i + 1
|
||||
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
deallocate(WR, WI, VR)
|
||||
|
||||
|
||||
! ordering
|
||||
! do j = 1, n
|
||||
! write(444, '(100(1X, F16.10))') (V_loc(j,i), i=1,5)
|
||||
! enddo
|
||||
allocate( iorder(n) )
|
||||
do i = 1, n
|
||||
iorder(i) = i
|
||||
enddo
|
||||
call dsort(energy_loc, iorder, n)
|
||||
do i = 1, n
|
||||
energy(i) = energy_loc(i)
|
||||
do j = 1, n
|
||||
V(j,i) = V_loc(j,iorder(i))
|
||||
enddo
|
||||
enddo
|
||||
deallocate(iorder)
|
||||
! do j = 1, n
|
||||
! write(445, '(100(1X, F16.10))') (V_loc(j,i), i=1,5)
|
||||
! enddo
|
||||
deallocate(V_loc, energy_loc)
|
||||
|
||||
end subroutine diag_nonsym_right
|
||||
|
||||
! ---
|
||||
|
||||
! Taken from GammCor thanks to Michal Hapka :-)
|
||||
|
||||
|
||||
subroutine pivoted_cholesky( A, rank, tol, ndim, U)
|
||||
!
|
||||
! A = U**T * U
|
||||
!
|
||||
! matrix A is destroyed inside this subroutine
|
||||
! Cholesky vectors are stored in U
|
||||
! dimension of U: U(1:rank, 1:n)
|
||||
! U is allocated inside this subroutine
|
||||
! rank is the number of Cholesky vectors depending on tol
|
||||
!
|
||||
integer :: ndim
|
||||
integer, intent(inout) :: rank
|
||||
double precision, dimension(ndim, ndim), intent(inout) :: A
|
||||
double precision, dimension(ndim, rank), intent(out) :: U
|
||||
double precision, intent(in) :: tol
|
||||
|
||||
integer, dimension(:), allocatable :: piv
|
||||
double precision, dimension(:), allocatable :: work
|
||||
character, parameter :: uplo = "U"
|
||||
integer :: N, LDA
|
||||
integer :: info
|
||||
integer :: k, l, rank0
|
||||
external :: dpstrf
|
||||
|
||||
rank0 = rank
|
||||
N = size(A, dim=1)
|
||||
LDA = N
|
||||
allocate(piv(N))
|
||||
allocate(work(2*N))
|
||||
call dpstrf(uplo, N, A, LDA, piv, rank, tol, work, info)
|
||||
|
||||
if (rank > rank0) then
|
||||
print *, 'Bug: rank > rank0 in pivoted cholesky. Increase rank before calling'
|
||||
stop
|
||||
end if
|
||||
|
||||
do k = 1, N
|
||||
A(k+1:, k) = 0.00D+0
|
||||
end do
|
||||
! TODO: It should be possible to use only one vector of size (1:rank) as a buffer
|
||||
! to do the swapping in-place
|
||||
U = 0.00D+0
|
||||
do k = 1, N
|
||||
l = piv(k)
|
||||
U(l, :) = A(1:rank, k)
|
||||
end do
|
||||
|
||||
end subroutine pivoted_cholesky
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue