mirror of
https://github.com/LCPQ/quantum_package
synced 2024-06-19 19:52:15 +02:00
103 lines
3.0 KiB
Fortran
103 lines
3.0 KiB
Fortran
|
program e_curve
|
||
|
|
use bitmasks
|
||
|
|
implicit none
|
||
|
|
integer :: i,j,k, nab, m, l
|
||
|
|
double precision :: norm, E, hij, num, ci, cj
|
||
|
|
integer, allocatable :: iorder(:)
|
||
|
|
double precision , allocatable :: norm_sort(:)
|
||
|
|
nab = n_det_alpha_unique+n_det_beta_unique
|
||
|
|
allocate ( norm_sort(0:nab), iorder(0:nab) )
|
||
|
|
|
||
|
|
|
||
|
|
norm_sort(0) = 0.d0
|
||
|
|
iorder(0) = 0
|
||
|
|
do i=1,n_det_alpha_unique
|
||
|
|
norm_sort(i) = det_alpha_norm(i)
|
||
|
|
iorder(i) = i
|
||
|
|
enddo
|
||
|
|
|
||
|
|
do i=1,n_det_beta_unique
|
||
|
|
norm_sort(i+n_det_alpha_unique) = det_beta_norm(i)
|
||
|
|
iorder(i+n_det_alpha_unique) = -i
|
||
|
|
enddo
|
||
|
|
|
||
|
|
call dsort(norm_sort(1),iorder(1),nab)
|
||
|
|
|
||
|
|
if (.not.read_wf) then
|
||
|
|
stop 'Please set read_wf to true'
|
||
|
|
endif
|
||
|
|
|
||
|
|
PROVIDE psi_bilinear_matrix_values nuclear_repulsion
|
||
|
|
print *, ''
|
||
|
|
print *, '=============================='
|
||
|
|
print *, 'Energies at different cut-offs'
|
||
|
|
print *, '=============================='
|
||
|
|
print *, ''
|
||
|
|
print *, '=========================================================='
|
||
|
|
print '(A8,2X,A8,2X,A12,2X,A10,2X,A12)', 'Thresh.', 'Ndet', 'Cost', 'Norm', 'E'
|
||
|
|
print *, '=========================================================='
|
||
|
|
double precision :: thresh
|
||
|
|
integer(bit_kind), allocatable :: det_i(:,:), det_j(:,:)
|
||
|
|
thresh = 1.d-10
|
||
|
|
do j=0,nab
|
||
|
|
i = iorder(j)
|
||
|
|
if (i<0) then
|
||
|
|
do k=1,n_det
|
||
|
|
if (psi_bilinear_matrix_columns(k) == -i) then
|
||
|
|
psi_bilinear_matrix_values(k,1) = 0.d0
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
else
|
||
|
|
do k=1,n_det
|
||
|
|
if (psi_bilinear_matrix_rows(k) == i) then
|
||
|
|
psi_bilinear_matrix_values(k,1) = 0.d0
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
if (thresh > norm_sort(j)) then
|
||
|
|
cycle
|
||
|
|
endif
|
||
|
|
num = 0.d0
|
||
|
|
norm = 0.d0
|
||
|
|
m = 0
|
||
|
|
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(k,l,det_i,det_j,ci,cj,hij) REDUCTION(+:norm,m,num)
|
||
|
|
allocate( det_i(N_int,2), det_j(N_int,2))
|
||
|
|
!$OMP DO SCHEDULE(guided)
|
||
|
|
do k=1,n_det
|
||
|
|
if (psi_bilinear_matrix_values(k,1) == 0.d0) then
|
||
|
|
cycle
|
||
|
|
endif
|
||
|
|
ci = psi_bilinear_matrix_values(k,1)
|
||
|
|
det_i(:,1) = psi_det_alpha_unique(:,psi_bilinear_matrix_rows(k))
|
||
|
|
det_i(:,2) = psi_det_beta_unique(:,psi_bilinear_matrix_columns(k))
|
||
|
|
do l=1,n_det
|
||
|
|
if (psi_bilinear_matrix_values(l,1) == 0.d0) then
|
||
|
|
cycle
|
||
|
|
endif
|
||
|
|
cj = psi_bilinear_matrix_values(l,1)
|
||
|
|
det_j(:,1) = psi_det_alpha_unique(:,psi_bilinear_matrix_rows(l))
|
||
|
|
det_j(:,2) = psi_det_beta_unique(:,psi_bilinear_matrix_columns(l))
|
||
|
|
call i_h_j(det_i, det_j, N_int, hij)
|
||
|
|
num = num + ci*cj*hij
|
||
|
|
enddo
|
||
|
|
norm = norm + ci*ci
|
||
|
|
m = m+1
|
||
|
|
enddo
|
||
|
|
!$OMP END DO
|
||
|
|
deallocate (det_i,det_j)
|
||
|
|
!$OMP END PARALLEL
|
||
|
|
if (m == 0) then
|
||
|
|
exit
|
||
|
|
endif
|
||
|
|
E = num / norm + nuclear_repulsion
|
||
|
|
print '(E9.1,2X,I8,2X,F10.2,2X,F10.8,2X,F12.6)', thresh, m, &
|
||
|
|
dble( elec_alpha_num**3 + elec_alpha_num**2 * (nab-1) ) / &
|
||
|
|
dble( elec_alpha_num**3 + elec_alpha_num**2 * (j-1)), norm, E
|
||
|
|
thresh = thresh * 2.d0
|
||
|
|
enddo
|
||
|
|
print *, '=========================================================='
|
||
|
|
|
||
|
|
deallocate (iorder, norm_sort)
|
||
|
|
end
|
||
|
|
|