qp2/src/cisd/lccsd_prov.irp.f

51 lines
1.5 KiB
Fortran

BEGIN_PROVIDER [ double precision, lccsd_coef, (N_det, N_states)]
&BEGIN_PROVIDER [ double precision, lccsd_energies, (N_states)]
implicit none
double precision, allocatable :: Dress_jj(:), H_jj(:), u_in(:,:)
double precision :: ebefore, eafter, ecorr, thresh
integer :: i,it,degree
logical :: converged
external H_u_0_nstates_openmp
allocate(Dress_jj(N_det),H_jj(N_det),u_in(N_det,N_states_diag))
thresh = 1.d-6
converged = .False.
Dress_jj = 0.d0
u_in = 0.d0
it = 0
! initial guess
do i = 1, N_states_diag
u_in(i,i) = 1.d0
enddo
do i = 1,N_det
call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,H_jj(i))
enddo
ebefore = H_jj(1)
do while (.not.converged)
it += 1
print*,'N_det = ',N_det
call davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,lccsd_energies,&
N_det,N_states,N_states_diag,converged,H_u_0_nstates_openmp)
ecorr = lccsd_energies(1) - H_jj(1)
print*,'---------------------'
print*,'it = ',it
print*,'ecorr = ',ecorr
Dress_jj(1) = 0.d0
do i = 2, N_det
if(ecorr + H_jj(i) .lt. H_jj(1))then
print*,'Warning, some dets are not dressed: '
call get_excitation_degree(ref_bitmask,psi_det(1,1,i),degree,N_int)
print*,'degree, Delta E, coef', degree, H_jj(i)-H_jj(1), u_in(i,1)/u_in(1,1)
else
Dress_jj(i) = ecorr
endif
enddo
eafter = lccsd_energies(1)
converged = (dabs(eafter - ebefore).lt.thresh)
ebefore = eafter
enddo
do i = 1, N_states
lccsd_coef(1:N_det,i) = u_in(1:N_det,i)
enddo
END_PROVIDER