10
0
mirror of https://github.com/LCPQ/quantum_package synced 2024-07-03 18:05:59 +02:00
quantum_package/plugins/dress_zmq/dressing.irp.f
2018-02-19 17:15:59 +01:00

104 lines
3.4 KiB
Fortran

use bitmasks
BEGIN_PROVIDER [ integer, N_dress_teeth ]
N_dress_teeth = 10
END_PROVIDER
BEGIN_PROVIDER [ double precision, dress_norm_acc, (0:N_det_non_ref, N_states) ]
&BEGIN_PROVIDER [ double precision, dress_norm, (0:N_det_non_ref, N_states) ]
&BEGIN_PROVIDER [ double precision, dress_teeth_size, (0:N_det_non_ref, N_states) ]
&BEGIN_PROVIDER [ integer, dress_teeth, (0:N_dress_teeth+1, N_states) ]
implicit none
integer :: i, j, st, nt
double precision :: norm_sto, jump, norm_mwen, norm_loc
if(N_states /= 1) stop "dress_sto may not work with N_states /= 1"
do st=1,N_states
dress_teeth(0,st) = 1
norm_sto = 1d0
do i=1,N_det
dress_teeth(1,st) = i
jump = (1d0 / dfloat(N_dress_teeth)) * norm_sto
if(psi_coef_generators(i,1)**2 < jump / 2d0) exit
norm_sto -= psi_coef_generators(i,1)**2
end do
norm_loc = 0d0
dress_norm_acc(0,st) = 0d0
nt = 1
do i=1,dress_teeth(1,st)-1
dress_norm_acc(i,st) = dress_norm_acc(i-1,st) + psi_coef_generators(i,st)**2
end do
do i=dress_teeth(1,st), N_det_generators!-dress_teeth(1,st)+1
norm_mwen = psi_coef_generators(i,st)**2!-1+dress_teeth(1,st),st)**2
dress_norm_acc(i,st) = dress_norm_acc(i-1,st) + norm_mwen
norm_loc += norm_mwen
if(norm_loc > (jump*dfloat(nt))) then
nt = nt + 1
dress_teeth(nt,st) = i
end if
end do
if(nt > N_dress_teeth+1) then
print *, "foireouse dress_teeth", nt, dress_teeth(nt,st), N_det_non_ref
stop
end if
dress_teeth(N_dress_teeth+1,st) = N_det_non_ref+1
norm_loc = 0d0
do i=N_dress_teeth, 0, -1
dress_teeth_size(i,st) = dress_norm_acc(dress_teeth(i+1,st)-1,st) - dress_norm_acc(dress_teeth(i,st)-1, st)
dress_norm_acc(dress_teeth(i,st):dress_teeth(i+1,st)-1,st) -= dress_norm_acc(dress_teeth(i,st)-1, st)
dress_norm_acc(dress_teeth(i,st):dress_teeth(i+1,st)-1,st) = &
dress_norm_acc(dress_teeth(i,st):dress_teeth(i+1,st)-1,st) / dress_teeth_size(i,st)
dress_norm(dress_teeth(i,st), st) = dress_norm_acc(dress_teeth(i,st), st)
do j=dress_teeth(i,st)+1, dress_teeth(i+1,1)-1
dress_norm(j,1) = dress_norm_acc(j, st) - dress_norm_acc(j-1, st)
end do
end do
end do
END_PROVIDER
BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det,2) ]
use bitmasks
implicit none
integer :: i,j,k
double precision, allocatable :: dress(:), del(:,:), del_s2(:,:)
double precision :: E_CI_before, relative_error
double precision, save :: errr = 0d0
allocate(dress(N_states), del(N_states, N_det), del_s2(N_states, N_det))
delta_ij = 0d0
E_CI_before = dress_E0_denominator(1) + nuclear_repulsion
threshold_selectors = 1.d0
threshold_generators = 1d0
if(errr /= 0d0) then
errr = errr / 2d0
else
errr = 1d-4
end if
relative_error = errr * 0d0
print *, "RELATIVE ERROR", relative_error
call ZMQ_dress(E_CI_before, dress, del, del_s2, abs(relative_error))
delta_ij(:,:,1) = del(:,:)
!delta_ij_s2(:,:,1) = del_s2(:,:)
delta_ij(:,:,2) = del_s2(:,:)
!do i=N_det,1,-1
! delta_ii(dress_stoch_istate,1) -= delta_ij(dress_stoch_istate, i, 1) / psi_ref_coef(1,dress_stoch_istate) * psi_coef(i, dress_stoch_istate)
! delta_ii_s2(dress_stoch_istate,1) -= delta_ij_s2(dress_stoch_istate, i, 1) / psi_ref_coef(1,dress_stoch_istate) * psi_coef(i, dress_stoch_istate)
!end do
END_PROVIDER