mirror of
https://gitlab.com/scemama/qp_plugins_scemama.git
synced 2024-12-23 04:43:38 +01:00
114 lines
3.6 KiB
Forth
114 lines
3.6 KiB
Forth
program e_curve
|
|
use bitmasks
|
|
implicit none
|
|
integer :: i,j,k, kk, nab, m, l
|
|
double precision :: norm, E, hij, num, ci, cj
|
|
integer, allocatable :: iorder(:)
|
|
double precision , allocatable :: norm_sort(:)
|
|
double precision :: e_0(N_states)
|
|
PROVIDE mo_two_e_integrals_in_map
|
|
|
|
nab = n_det_alpha_unique+n_det_beta_unique
|
|
allocate ( norm_sort(0:nab), iorder(0:nab) )
|
|
|
|
double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:)
|
|
double precision, allocatable :: u_0(:,:), v_0(:,:)
|
|
allocate(u_t(N_states,N_det),v_t(N_states,N_det),s_t(N_states,N_det))
|
|
allocate(u_0(N_states,N_det),v_0(N_states,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
|
|
|
|
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
|
|
|
|
u_0 = psi_bilinear_matrix_values(1:N_det,1:N_states)
|
|
v_t = 0.d0
|
|
s_t = 0.d0
|
|
call dtranspose( &
|
|
u_0, &
|
|
size(u_0, 1), &
|
|
u_t, &
|
|
size(u_t, 1), &
|
|
N_det, N_states)
|
|
call H_S2_u_0_nstates_openmp_work(v_t,s_t,u_t,N_states,N_det,1,N_det,0,1)
|
|
call dtranspose( &
|
|
v_t, &
|
|
size(v_t, 1), &
|
|
v_0, &
|
|
size(v_0, 1), &
|
|
N_states, N_det)
|
|
|
|
double precision, external :: u_dot_u, u_dot_v
|
|
do i=1,N_states
|
|
e_0(i) = u_dot_v(v_t(1,i),u_0(1,i),N_det)/u_dot_u(u_0(1,i),N_det)
|
|
enddo
|
|
|
|
m = 0
|
|
do k=1,n_det
|
|
if (psi_bilinear_matrix_values(k,1) /= 0.d0) then
|
|
m = m+1
|
|
endif
|
|
enddo
|
|
|
|
if (m == 0) then
|
|
exit
|
|
endif
|
|
E = E_0(1) + nuclear_repulsion
|
|
norm = u_dot_u(u_0(1,1),N_det)
|
|
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 * dsqrt(10.d0)
|
|
enddo
|
|
print *, '=========================================================='
|
|
|
|
deallocate (iorder, norm_sort)
|
|
end
|
|
|