LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-06-09 14:55:26 +02:00
Code Issues Releases Wiki Activity
94f01c0892
quantum_package/plugins/FOBOCI/dress_simple.irp.f
Anthony Scemama 94f01c0892 Bugs to fix (#50) 
* Add config for knl

* Add mising readme

* Add .gitignore

* Add pseudo to qp_convert

* Working pseudo

* Dressed matrix for pt2 works for one state

* now eigenfunction of S^2

* minor modifs in printing

* Fixed the perturbation with psi_ref instead of psi_det

* Trying do really fo sin free multiple excitations

* Beginning to merge MRCC and MRPT

* final version of MRPT, at least I hope

* Fix 404: Update Zlib Url.

* Delete ifort_knl.cfg

* Update module_handler.py

* Update pot_ao_pseudo_ints.irp.f

* Update map_module.f90

* Restaure map_module.f90

* Update configure

* Update configure

* Update sort.irp.f

* Update sort.irp.f

* Update selection.irp.f

* Update selection.irp.f

* Update dressing.irp.f

* TApplencourt IRPF90 -> LCPQ

* Remove `irpf90.make` in dependency

* Update configure

* Missing PROVIDE

* Missing PROVIDE

* Missing PROVIDE

* Missing PROVIDE

* Update configure

* pouet

* density based mrpt2

* debugging FOBOCI

* Added SCF_density

* New version of FOBOCI

* added density.irp.f

* minor changes in plugins/FOBOCI/SC2_1h1p.irp.f

* added track_orb.irp.f

* minor changes

* minor modifs in FOBOCI

* med

* Minor changes

* minor changes

* strange things in MRPT

* minor modifs

mend

* Fix #185 (Graphviz API / Python 2.6)

* beginning to debug dft

* fixed the factor 2 in lebedev

* DFT integration works for non overlapping densities

* DFT begins to work with lda

* KS LDA is okay

* added core integrals

* mend

* Beginning logn range integrals

* Trying to handle two sets of integrals

* beginning to clean erf integrals

* Handling of two different mo and ao integrals map
2017-04-20 08:36:11 +02:00

459 lines
16 KiB
Fortran
Raw Blame History

subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_generator,n_selected,det_buffer,Nint,iproc,psi_det_generators_input,E_ref)
use bitmasks
implicit none
integer, intent(in) :: i_generator,n_selected, Nint, iproc
integer, intent(in) :: Ndet_generators,size_buffer
double precision, intent(inout) :: delta_ij_generators_(Ndet_generators,Ndet_generators),E_ref
integer(bit_kind), intent(in) :: det_buffer(Nint,2,size_buffer)
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators)
integer :: i,j,k,m
integer :: new_size
integer :: degree(Ndet_generators)
integer :: idx(0:Ndet_generators)
logical :: good
integer :: c_ref
integer :: connected_to_ref
double precision :: hka, haa
double precision :: haj
double precision :: f
integer :: connected_to_ref_by_mono
logical :: is_in_wavefunction
double precision :: H_array(Ndet_generators)
double precision :: H_matrix_tmp(Ndet_generators+1,Ndet_generators+1)
double precision :: eigenvectors(Ndet_generators+1,Ndet_generators+1), eigenvalues(Ndet_generators+1)
double precision :: contrib,lambda_i,accu
do k = 1, Ndet_generators
call i_h_j(psi_det_generators_input(1,1,k),psi_det_generators_input(1,1,k),Nint,hka)
H_matrix_tmp(k,k) = hka
do j = k+1, Ndet_generators
call i_h_j(psi_det_generators_input(1,1,k),psi_det_generators_input(1,1,j),Nint,hka)
H_matrix_tmp(k,j) = hka
H_matrix_tmp(j,k) = hka
enddo
H_matrix_tmp(k,Ndet_generators+1) = 0.d0
enddo
do i=1,n_selected
c_ref = connected_to_ref_by_mono(det_buffer(1,1,i),psi_det_generators_input,N_int,i_generator,Ndet_generators)
if (c_ref /= 0) then
cycle
endif
if (is_in_wavefunction(det_buffer(1,1,i),Nint)) then
cycle
endif
call get_excitation_degree_vector(psi_det_generators_input,det_buffer(1,1,i),degree,N_int,Ndet_generators,idx)
H_array = 0.d0
do k=1,idx(0)
call i_h_j(det_buffer(1,1,i),psi_det_generators_input(1,1,idx(k)),Nint,hka)
H_array(idx(k)) = hka
enddo
call i_h_j(det_buffer(1,1,i),det_buffer(1,1,i),Nint,haa)
f = 1.d0/(E_ref-haa)
lambda_i = f
do k=1,idx(0)
contrib = H_array(idx(k)) * H_array(idx(k)) * lambda_i
delta_ij_generators_(idx(k), idx(k)) += contrib
do j=k+1,idx(0)
contrib = H_array(idx(k)) * H_array(idx(j)) * lambda_i
delta_ij_generators_(idx(k), idx(j)) += contrib
delta_ij_generators_(idx(j), idx(k)) += contrib
enddo
enddo
enddo
end
subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
use bitmasks
implicit none
double precision, intent(in) :: threshold
double precision, intent(out):: e_pt2
logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative
logical, intent(in) :: verbose
integer :: l,k,m
double precision,allocatable :: dressed_H_matrix(:,:)
double precision, allocatable :: psi_coef_diagonalized_tmp(:,:)
integer(bit_kind), allocatable :: psi_det_generators_input(:,:,:)
double precision :: hij
allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators),psi_coef_diagonalized_tmp(N_det_generators,N_states))
dressed_H_matrix = 0.d0
do k = 1, N_det_generators
do l = 1, N_int
psi_det_generators_input(l,1,k) = psi_det_generators(l,1,k)
psi_det_generators_input(l,2,k) = psi_det_generators(l,2,k)
enddo
enddo
!call H_apply_dressed_pert(dressed_H_matrix,N_det_generators,psi_det_generators_input)
call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop,is_ok_perturbative)
!do m = 1, N_states
! do k = 1, N_det_generators
! do l = 1, N_int
! psi_selectors(l,1,k) = psi_det_generators_input(l,1,k)
! psi_selectors(l,2,k) = psi_det_generators_input(l,2,k)
! enddo
! psi_selectors_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
! enddo
!enddo
!soft_touch psi_selectors psi_selectors_coef
!if(do_it_perturbative)then
if(is_ok.or.is_ok_perturbative)then
N_det = N_det_generators
do m = 1, N_states
do k = 1, N_det_generators
do l = 1, N_int
psi_det(l,1,k) = psi_det_generators_input(l,1,k)
psi_det(l,2,k) = psi_det_generators_input(l,2,k)
enddo
psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
enddo
enddo
soft_touch psi_det psi_coef N_det
e_pt2 = 0.d0
do m =1, N_det_generators
do l = 1, N_det_generators
call i_h_j(psi_det_generators_input(1,1,m),psi_det_generators_input(1,1,l),N_int,hij) ! Fill the zeroth order H matrix
e_pt2 += (dressed_H_matrix(m,l) - hij)* psi_coef_diagonalized_tmp(m,1)* psi_coef_diagonalized_tmp(l,1)
enddo
enddo
endif
!endif
deallocate(psi_det_generators_input,dressed_H_matrix,psi_coef_diagonalized_tmp)
end
subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop,is_ok_perturbative)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators)
integer, intent(in) :: Ndet_generators
double precision, intent(in) :: threshold
logical, intent(in) :: verbose
logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative
double precision, intent(out) :: psi_coef_diagonalized_tmp(Ndet_generators,N_states)
double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators)
integer :: i,j,degree,index_ref_generators_restart(N_states),i_count,k,i_det_no_ref
double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij
double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average
logical :: is_a_ref_det(Ndet_generators)
exit_loop = .False.
is_a_ref_det = .False.
do i = 1, N_det_generators
do j = 1, N_det_generators_restart
call get_excitation_degree(psi_det_generators_input(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int)
if(degree == 0)then
is_a_ref_det(i) = .True.
exit
endif
enddo
enddo
integer :: istate
do istate = 1, N_states
do i = 1, Ndet_generators
call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_input(1,1,i),degree,N_int)
if(degree == 0)then
index_ref_generators_restart(istate) = i
exit
endif
enddo
enddo
do i = 1, Ndet_generators
do j = 1, Ndet_generators
call i_h_j(psi_det_generators_input(1,1,j),psi_det_generators_input(1,1,i),N_int,hij) ! Fill the zeroth order H matrix
dressed_H_matrix(i,j) = hij
enddo
enddo
i_det_no_ref = 0
diag_h_mat_average = 0.d0
do i = 1, Ndet_generators
if(is_a_ref_det(i))cycle
i_det_no_ref +=1
diag_h_mat_average+=dressed_H_matrix(i,i)
enddo
double precision :: average_ref_h_mat
average_ref_h_mat = 0.d0
do istate = 1, N_states
average_ref_h_mat += dressed_H_matrix(index_ref_generators_restart(istate),index_ref_generators_restart(istate))
enddo
average_ref_h_mat = 1.d0/dble(N_states)
diag_h_mat_average = diag_h_mat_average/dble(i_det_no_ref)
print*,'diag_h_mat_average = ',diag_h_mat_average
print*,'ref h_mat average = ',average_ref_h_mat
integer :: number_of_particles, number_of_holes
! Filter the the MLCT that are higher than 27.2 eV in energy with respect to the reference determinant
do i = 1, Ndet_generators
if(is_a_ref_det(i))cycle
if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then
if(diag_h_mat_average - average_ref_h_mat .gt.2.d0)then
is_ok = .False.
exit_loop = .True.
return
endif
endif
! Filter the the LMCT that are higher than 54.4 eV in energy with respect to the reference determinant
if(number_of_holes(psi_det_generators_input(1,1,i)).eq.1 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.0)then
if(diag_h_mat_average - average_ref_h_mat .gt.1.d0)then
is_ok = .False.
return
endif
endif
exit
enddo
call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the naked matrix
double precision :: s2(N_det_generators),E_ref(N_states)
integer :: i_state(N_states)
integer :: n_state_good
n_state_good = 0
if(s2_eig)then
call u_0_S2_u_0(s2,eigvectors,Ndet_generators,psi_det_generators_input,N_int,N_det_generators,size(eigvectors,1))
do i = 1, Ndet_generators
print*,'s2 = ',s2(i)
print*,dabs(s2(i)-expected_s2)
if(dabs(s2(i)-expected_s2).le.0.3d0)then
n_state_good +=1
i_state(n_state_good) = i
E_ref(n_state_good) = eigvalues(i)
endif
if(n_state_good==N_states)then
exit
endif
enddo
else
do i = 1, N_states
i_state(i) = i
E_ref(i) = eigvalues(i)
enddo
endif
do k = 1, N_states
do i = 1, Ndet_generators
psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k))
psi_coef_ref(i,k) = eigvectors(i,i_state(k))
enddo
enddo
if(verbose)then
print*,'Zeroth order space :'
do i = 1, Ndet_generators
write(*,'(10(F16.8),X)')dressed_H_matrix(i,:)
enddo
print*,''
print*,'Zeroth order space Diagonalized :'
do k = 1, N_states
print*,'state ',k
do i = 1, Ndet_generators
print*,'coef, <I|H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i)
enddo
enddo
endif
double precision :: E_ref_average
E_ref_average = 0.d0
do i = 1, N_states
E_ref_average += E_ref(i)
enddo
E_ref_average = E_ref_average / dble(N_states)
call H_apply_dressed_pert(dressed_H_matrix,Ndet_generators,psi_det_generators_input,E_ref_average) ! Calculate the dressing of the H matrix
if(verbose)then
print*,'Zeroth order space Dressed by outer space:'
do i = 1, Ndet_generators
write(*,'(10(F16.8),X)')dressed_H_matrix(i,:)
enddo
endif
call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix
integer :: i_good_state(0:N_states)
i_good_state(0) = 0
do k = 1, N_states
! print*,'state',k
do i = 1, Ndet_generators
! State following
accu = 0.d0
do j =1, Ndet_generators
accu += eigvectors(j,i) * psi_coef_ref(j,k)
enddo
! print*,i,accu
if(dabs(accu).ge.0.60d0)then
i_good_state(0) +=1
i_good_state(i_good_state(0)) = i
print*, 'state, ovrlap',k,i,accu
exit
endif
enddo
if(i_good_state(0)==N_states)then
exit
endif
enddo
do i = 1, N_states
i_state(i) = i_good_state(i)
E_ref(i) = eigvalues(i_good_state(i))
enddo
double precision :: accu
accu = 0.d0
do k = 1, N_states
do i = 1, Ndet_generators
psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k))
enddo
enddo
if(verbose)then
do k = 1, N_states
print*,'state ',k
do i = 1, Ndet_generators
print*,'coef, <I|H+Delta H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i)
enddo
enddo
endif
is_ok = .False.
do i = 1, Ndet_generators
if(is_a_ref_det(i))cycle
do k = 1, N_states
if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold)then
is_ok = .True.
exit
endif
enddo
if(is_ok)then
exit
endif
enddo
if(.not.is_ok)then
is_ok_perturbative = .True.
do i = 1, Ndet_generators
if(is_a_ref_det(i))cycle
do k = 1, N_states
! print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative
if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold_perturbative)then
is_ok_perturbative = .False.
exit
endif
enddo
if(.not.is_ok_perturbative)then
exit
endif
enddo
endif
if(verbose)then
print*,'is_ok = ',is_ok
print*,'is_ok_perturbative = ',is_ok_perturbative
endif
end
subroutine fill_H_apply_buffer_no_selection_first_order_coef(n_selected,det_buffer,Nint,iproc)
use bitmasks
implicit none
BEGIN_DOC
! Fill the H_apply buffer with determiants for CISD
END_DOC
integer, intent(in) :: n_selected, Nint, iproc
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
integer :: i,j,k
integer :: new_size
PROVIDE H_apply_buffer_allocated
call omp_set_lock(H_apply_buffer_lock(1,iproc))
new_size = H_apply_buffer(iproc)%N_det + n_selected
if (new_size > H_apply_buffer(iproc)%sze) then
call resize_h_apply_buffer(max(2*H_apply_buffer(iproc)%sze,new_size),iproc)
endif
do i=1,H_apply_buffer(iproc)%N_det
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num)
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num)
enddo
do i=1,n_selected
do j=1,N_int
H_apply_buffer(iproc)%det(j,1,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,1,i)
H_apply_buffer(iproc)%det(j,2,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,2,i)
enddo
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i+H_apply_buffer(iproc)%N_det)) )== elec_alpha_num)
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num)
enddo
double precision :: i_H_psi_array(N_states),h,diag_H_mat_elem_fock,delta_e
do i=1,N_selected
call i_H_psi(det_buffer(1,1,i),psi_selectors,psi_selectors_coef,N_int,N_det_selectors,psi_selectors_size,N_states,i_H_psi_array)
call i_H_j(det_buffer(1,1,i),det_buffer(1,1,i),N_int,h)
do j=1,N_states
delta_e = -1.d0 /(h - psi_energy(j))
H_apply_buffer(iproc)%coef(i+H_apply_buffer(iproc)%N_det,j) = i_H_psi_array(j) * delta_e
enddo
enddo
H_apply_buffer(iproc)%N_det = new_size
do i=1,H_apply_buffer(iproc)%N_det
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num)
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num)
enddo
call omp_unset_lock(H_apply_buffer_lock(1,iproc))
end
subroutine make_s2_eigenfunction_first_order
implicit none
integer :: i,j,k
integer :: smax, s
integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:)
integer :: N_det_new
integer, parameter :: bufsze = 1000
logical, external :: is_in_wavefunction
allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) )
smax = 1
N_det_new = 0
do i=1,N_occ_pattern
call occ_pattern_to_dets_size(psi_occ_pattern(1,1,i),s,elec_alpha_num,N_int)
s += 1
if (s > smax) then
deallocate(d)
allocate ( d(N_int,2,s) )
smax = s
endif
call occ_pattern_to_dets(psi_occ_pattern(1,1,i),d,s,elec_alpha_num,N_int)
do j=1,s
if (.not. is_in_wavefunction(d(1,1,j), N_int) ) then
N_det_new += 1
do k=1,N_int
det_buffer(k,1,N_det_new) = d(k,1,j)
det_buffer(k,2,N_det_new) = d(k,2,j)
enddo
if (N_det_new == bufsze) then
call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0)
N_det_new = 0
endif
endif
enddo
enddo
if (N_det_new > 0) then
call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0)
call copy_H_apply_buffer_to_wf
SOFT_TOUCH N_det psi_coef psi_det
endif
deallocate(d,det_buffer)
call write_int(output_determinants,N_det_new, 'Added deteminants for S^2')
end
Reference in New Issue View Git Blame Copy Permalink