mirror of
https://github.com/LCPQ/quantum_package
synced 2024-12-23 12:56:14 +01:00
122 lines
3.8 KiB
Fortran
122 lines
3.8 KiB
Fortran
program e_curve
|
|
use bitmasks
|
|
implicit none
|
|
integer :: i,j,k, nab, m, l, n_up, n_dn, n
|
|
double precision :: norm, E, hij, num, ci, cj
|
|
integer, allocatable :: iorder(:)
|
|
double precision , allocatable :: norm_sort(:), psi_bilinear_matrix_values_save(:)
|
|
nab = n_det_alpha_unique+n_det_beta_unique
|
|
|
|
allocate ( norm_sort(0:nab), iorder(0:nab), psi_bilinear_matrix_values_save(N_det) )
|
|
|
|
|
|
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
|
|
|
|
psi_bilinear_matrix_values_save = psi_bilinear_matrix_values(:,1)
|
|
print *, '=========================================================='
|
|
print '(A8,2X,A8,2X,A12,2X,A10,2X,A12)', 'Thresh.', 'Ndet', 'Cost', 'Norm', 'E'
|
|
print *, '=========================================================='
|
|
integer(bit_kind), allocatable :: det_i(:,:), det_j(:,:)
|
|
|
|
double precision :: thresh, E_min, E_max, E_prev
|
|
thresh = 0.d0
|
|
call compute_energy(psi_bilinear_matrix_values_save,E_max,m,norm)
|
|
call i_h_j(psi_det_sorted(1,1,1), psi_det_sorted(1,1,1), N_int, E_min)
|
|
print *, E_min, E_max
|
|
|
|
n_up = nab
|
|
n_dn = 0
|
|
do while (n_up > n_dn)
|
|
n = n_dn + (n_up-n_dn)/2
|
|
psi_bilinear_matrix_values_save = psi_bilinear_matrix_values(:,1)
|
|
do j=1,n
|
|
i = iorder(j)
|
|
if (i<0) then
|
|
do k=1,n_det
|
|
if (psi_bilinear_matrix_columns(k) == -i) then
|
|
psi_bilinear_matrix_values_save(k) = 0.d0
|
|
endif
|
|
enddo
|
|
else
|
|
do k=1,n_det
|
|
if (psi_bilinear_matrix_rows(k) == i) then
|
|
psi_bilinear_matrix_values_save(k) = 0.d0
|
|
endif
|
|
enddo
|
|
endif
|
|
enddo
|
|
call compute_energy(psi_bilinear_matrix_values_save,E,m,norm)
|
|
print '(E9.1,2X,I8,2X,F10.2,2X,F10.6,2X,F12.6)', norm_sort(n), m, &
|
|
dble( elec_alpha_num**3 + elec_alpha_num**2 * m ) / &
|
|
dble( elec_alpha_num**3 + elec_alpha_num**2 * n ), norm, E
|
|
if (E < target_energy) then
|
|
n_dn = n+1
|
|
else
|
|
n_up = n
|
|
endif
|
|
enddo
|
|
print *, '=========================================================='
|
|
print *, norm_sort(n), target_energy
|
|
|
|
deallocate (iorder, norm_sort, psi_bilinear_matrix_values_save)
|
|
end
|
|
|
|
subroutine compute_energy(psi_bilinear_matrix_values_save, E, m, norm)
|
|
implicit none
|
|
BEGIN_DOC
|
|
! Compute an energy when a threshold is applied
|
|
END_DOC
|
|
double precision, intent(in) :: psi_bilinear_matrix_values_save(n_det)
|
|
integer(bit_kind), allocatable :: det_i(:,:), det_j(:,:)
|
|
integer :: i,j, k, l, m
|
|
double precision :: num, norm, ci, cj, hij, E
|
|
|
|
|
|
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_save(k) == 0.d0) then
|
|
cycle
|
|
endif
|
|
ci = psi_bilinear_matrix_values_save(k)
|
|
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_save(l) == 0.d0) then
|
|
cycle
|
|
endif
|
|
cj = psi_bilinear_matrix_values_save(l)
|
|
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
|
|
E = num / norm + nuclear_repulsion
|
|
end
|