LCPQ
/
quantum_package
mirror of https://github.com/LCPQ/quantum_package
10
0
Fork 0
Code Issues Releases Wiki Activity

Merge branch 'master' of https://github.com/eginer/quantum_package

This commit is contained in:
Emmanuel Giner 2017-03-17 11:47:11 +01:00
parent e8e7985429 c5cc7e4d47
commit dd981ed4e9
134 changed files with 9051 additions and 3151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.travis.yml
View File

@ -25,8 +25,8 @@ python:
- "2.6"
script:
- ./configure --production ./config/gfortran.cfg
- source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD mrcepa0 All_singles
- ./configure --production ./config/travis.cfg
- source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD_ZMQ mrcepa0 All_singles
- source ./quantum_package.rc ; ninja
- source ./quantum_package.rc ; cd ocaml ; make ; cd -
- source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v

4
config/gfortran.cfg
View File

@ -35,14 +35,14 @@ OPENMP : 1 ; Append OpenMP flags
# -ffast-math and the Fortran-specific
# -fno-protect-parens and -fstack-arrays.
[OPT]
FCFLAGS : -Ofast
FCFLAGS :
# Profiling flags
#################
#
[PROFILE]
FC : -p -g
FCFLAGS : -Ofast
FCFLAGS :
# Debugging flags
#################

2
config/gfortran_debug.cfg
View File

@ -13,7 +13,7 @@
FC : gfortran -g -ffree-line-length-none -I . -static-libgcc
LAPACK_LIB : -llapack -lblas
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --assert --align=32
IRPF90_FLAGS : --ninja --align=32
# Global options
################

62
config/travis.cfg Normal file
View File

@ -0,0 +1,62 @@
# Common flags
##############
#
# -ffree-line-length-none : Needed for IRPF90 which produces long lines
# -lblas -llapack : Link with libblas and liblapack libraries provided by the system
# -I . : Include the curent directory (Mandatory)
#
# --ninja : Allow the utilisation of ninja. (Mandatory)
# --align=32 : Align all provided arrays on a 32-byte boundary
#
#
[COMMON]
FC : gfortran -ffree-line-length-none -I . -g
LAPACK_LIB : -llapack -lblas
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32
# Global options
################
#
# 1 : Activate
# 0 : Deactivate
#
[OPTION]
MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below
CACHE : 1 ; Enable cache_compile.py
OPENMP : 1 ; Append OpenMP flags
# Optimization flags
####################
#
# -Ofast : Disregard strict standards compliance. Enables all -O3 optimizations.
# It also enables optimizations that are not valid
# for all standard-compliant programs. It turns on
# -ffast-math and the Fortran-specific
# -fno-protect-parens and -fstack-arrays.
[OPT]
FCFLAGS : -Ofast -march=native
# Profiling flags
#################
#
[PROFILE]
FC : -p -g
FCFLAGS : -Ofast
# Debugging flags
#################
#
# -fcheck=all : Checks uninitialized variables, array subscripts, etc...
# -g : Extra debugging information
#
[DEBUG]
FCFLAGS : -fcheck=all -g
# OpenMP flags
#################
#
[OPENMP]
FC : -fopenmp
IRPF90_FLAGS : --openmp

4
plugins/CAS_SD/cas_sd_selected.irp.f
View File

@ -93,8 +93,8 @@ program full_ci
call diagonalize_CI
if(do_pt2_end)then
print*,'Last iteration only to compute the PT2'
threshold_selectors = 1.d0
threshold_generators = 0.999d0
threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
threshold_generators = max(threshold_generators,threshold_generators_pt2)
call H_apply_CAS_SD_PT2(pt2, norm_pert, H_pert_diag, N_st)
print *, 'Final step'

10
plugins/CAS_SD_ZMQ/EZFIO.cfg Normal file
View File

@ -0,0 +1,10 @@
[energy]
type: double precision
doc: "Calculated CAS-SD energy"
interface: ezfio
[energy_pt2]
type: double precision
doc: "Calculated selected CAS-SD energy with PT2 correction"
interface: ezfio

2
plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1,2 @@
Generators_CAS Perturbation Selectors_CASSD ZMQ

14
plugins/CAS_SD_ZMQ/README.rst Normal file
View File

@ -0,0 +1,14 @@
==========
CAS_SD_ZMQ
==========
Selected CAS+SD module with Zero-MQ parallelization.
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.

234
plugins/CAS_SD_ZMQ/cassd_zmq.irp.f Normal file
View File

@ -0,0 +1,234 @@
program fci_zmq
implicit none
integer :: i,j,k
logical, external :: detEq
double precision, allocatable :: pt2(:)
integer :: degree
allocate (pt2(N_states))
pt2 = 1.d0
diag_algorithm = "Lapack"
if (N_det > N_det_max) then
call diagonalize_CI
call save_wavefunction
psi_det = psi_det_sorted
psi_coef = psi_coef_sorted
N_det = N_det_max
soft_touch N_det psi_det psi_coef
call diagonalize_CI
call save_wavefunction
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
do k=1,N_states
print*,'State ',k
print *, 'PT2 = ', pt2(k)
print *, 'E = ', CI_energy(k)
print *, 'E+PT2 = ', CI_energy(k) + pt2(k)
print *, '-----'
enddo
endif
double precision :: E_CI_before(N_states)
integer :: n_det_before
print*,'Beginning the selection ...'
E_CI_before(1:N_states) = CI_energy(1:N_states)
do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) )
n_det_before = N_det
call ZMQ_selection(max(256-N_det, N_det), pt2)
PROVIDE psi_coef
PROVIDE psi_det
PROVIDE psi_det_sorted
call diagonalize_CI
call save_wavefunction
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
do k=1, N_states
print*,'State ',k
print *, 'PT2 = ', pt2(k)
print *, 'E = ', CI_energy(k)
print *, 'E(before)+PT2 = ', E_CI_before(k)+pt2(k)
enddo
print *, '-----'
if(N_states.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_states
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_states
print*,'Delta E = ',E_CI_before(i)+ pt2(i) - (E_CI_before(1) + pt2(1))
enddo
endif
E_CI_before(1:N_states) = CI_energy(1:N_states)
call ezfio_set_cas_sd_zmq_energy(CI_energy(1))
enddo
integer :: exc_max, degree_min
exc_max = 0
print *, 'CAS determinants : ', N_det_cas
do i=1,min(N_det_cas,10)
do k=i,N_det_cas
call get_excitation_degree(psi_cas(1,1,k),psi_cas(1,1,i),degree,N_int)
exc_max = max(exc_max,degree)
enddo
print *, psi_cas_coef(i,:)
call debug_det(psi_cas(1,1,i),N_int)
print *, ''
enddo
print *, 'Max excitation degree in the CAS :', exc_max
if(do_pt2_end)then
print*,'Last iteration only to compute the PT2'
threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
threshold_generators = max(threshold_generators,threshold_generators_pt2)
TOUCH threshold_selectors threshold_generators
E_CI_before(1:N_states) = CI_energy(1:N_states)
call ZMQ_selection(0, pt2)
print *, 'Final step'
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
do k=1,N_states
print *, 'State', k
print *, 'PT2 = ', pt2(k)
print *, 'E = ', E_CI_before(k)
print *, 'E+PT2 = ', E_CI_before(k)+pt2(k)
print *, '-----'
enddo
call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before+pt2)
endif
call save_wavefunction
call ezfio_set_cas_sd_zmq_energy(CI_energy(1))
call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before+pt2)
end
subroutine ZMQ_selection(N_in, pt2)
use f77_zmq
use selection_types
implicit none
character*(512) :: task
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer, intent(in) :: N_in
type(selection_buffer) :: b
integer :: i, N
integer, external :: omp_get_thread_num
double precision, intent(out) :: pt2(N_states)
if (.True.) then
PROVIDE pt2_e0_denominator
N = max(N_in,1)
provide nproc
call new_parallel_job(zmq_to_qp_run_socket,"selection")
call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator))
call zmq_set_running(zmq_to_qp_run_socket)
call create_selection_buffer(N, N*2, b)
endif
integer :: i_generator, i_generator_start, i_generator_max, step
! step = int(max(1.,10*elec_num/mo_tot_num)
step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num ))
step = max(1,step)
do i= 1, N_det_generators,step
i_generator_start = i
i_generator_max = min(i+step-1,N_det_generators)
write(task,*) i_generator_start, i_generator_max, 1, N
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
end do
!$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1)
i = omp_get_thread_num()
if (i==0) then
call selection_collector(b, pt2)
else
call selection_slave_inproc(i)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, 'selection')
if (N_in > 0) then
call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN
call copy_H_apply_buffer_to_wf()
if (s2_eig) then
call make_s2_eigenfunction
endif
endif
end subroutine
subroutine selection_slave_inproc(i)
implicit none
integer, intent(in) :: i
call run_selection_slave(1,i,pt2_e0_denominator)
end
subroutine selection_collector(b, pt2)
use f77_zmq
use selection_types
use bitmasks
implicit none
type(selection_buffer), intent(inout) :: b
double precision, intent(out) :: pt2(N_states)
double precision :: pt2_mwen(N_states)
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR), external :: new_zmq_pull_socket
integer(ZMQ_PTR) :: zmq_socket_pull
integer :: msg_size, rc, more
integer :: acc, i, j, robin, N, ntask
double precision, allocatable :: val(:)
integer(bit_kind), allocatable :: det(:,:,:)
integer, allocatable :: task_id(:)
integer :: done
real :: time, time0
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_pull = new_zmq_pull_socket()
allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det))
done = 0
more = 1
pt2(:) = 0d0
call CPU_TIME(time0)
do while (more == 1)
call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask)
pt2 += pt2_mwen
do i=1, N
call add_to_selection_buffer(b, det(1,1,i), val(i))
end do
do i=1, ntask
if(task_id(i) == 0) then
print *, "Error in collector"
endif
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more)
end do
done += ntask
call CPU_TIME(time)
! print *, "DONE" , done, time - time0
end do
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_pull_socket(zmq_socket_pull)
call sort_selection_buffer(b)
end subroutine

79
plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f Normal file
View File

@ -0,0 +1,79 @@
use bitmasks
BEGIN_PROVIDER [integer, exc_degree_per_selectors, (N_det_selectors)]
&BEGIN_PROVIDER [integer, double_index_selectors, (N_det_selectors)]
&BEGIN_PROVIDER [integer, n_double_selectors]
implicit none
BEGIN_DOC
! degree of excitation respect to Hartree Fock for the wave function
!
! for the all the selectors determinants
!
! double_index_selectors = list of the index of the double excitations
!
! n_double_selectors = number of double excitations in the selectors determinants
END_DOC
integer :: i,degree
n_double_selectors = 0
do i = 1, N_det_selectors
call get_excitation_degree(psi_selectors(1,1,i),ref_bitmask,degree,N_int)
exc_degree_per_selectors(i) = degree
if(degree==2)then
n_double_selectors += 1
double_index_selectors(n_double_selectors) =i
endif
enddo
END_PROVIDER
BEGIN_PROVIDER[double precision, coef_hf_selector]
&BEGIN_PROVIDER[double precision, inv_selectors_coef_hf]
&BEGIN_PROVIDER[double precision, inv_selectors_coef_hf_squared]
&BEGIN_PROVIDER[double precision, E_corr_per_selectors, (N_det_selectors)]
&BEGIN_PROVIDER[double precision, i_H_HF_per_selectors, (N_det_selectors)]
&BEGIN_PROVIDER[double precision, Delta_E_per_selector, (N_det_selectors)]
&BEGIN_PROVIDER[double precision, E_corr_double_only ]
&BEGIN_PROVIDER[double precision, E_corr_second_order ]
implicit none
BEGIN_DOC
! energy of correlation per determinant respect to the Hartree Fock determinant
!
! for the all the double excitations in the selectors determinants
!
! E_corr_per_selectors(i) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
!
! E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation
!
! coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
END_DOC
PROVIDE ref_bitmask_energy psi_selectors ref_bitmask N_int psi_selectors
integer :: i,degree
double precision :: hij,diag_H_mat_elem
E_corr_double_only = 0.d0
E_corr_second_order = 0.d0
do i = 1, N_det_selectors
if(exc_degree_per_selectors(i)==2)then
call i_H_j(ref_bitmask,psi_selectors(1,1,i),N_int,hij)
i_H_HF_per_selectors(i) = hij
E_corr_per_selectors(i) = psi_selectors_coef(i,1) * hij
E_corr_double_only += E_corr_per_selectors(i)
! E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int))
elseif(exc_degree_per_selectors(i) == 0)then
coef_hf_selector = psi_selectors_coef(i,1)
E_corr_per_selectors(i) = -1000.d0
Delta_E_per_selector(i) = 0.d0
else
E_corr_per_selectors(i) = -1000.d0
endif
enddo
if (dabs(coef_hf_selector) > 1.d-8) then
inv_selectors_coef_hf = 1.d0/coef_hf_selector
inv_selectors_coef_hf_squared = inv_selectors_coef_hf * inv_selectors_coef_hf
else
inv_selectors_coef_hf = 0.d0
inv_selectors_coef_hf_squared = 0.d0
endif
do i = 1,n_double_selectors
E_corr_per_selectors(double_index_selectors(i)) *=inv_selectors_coef_hf
enddo
E_corr_double_only = E_corr_double_only * inv_selectors_coef_hf
END_PROVIDER

11
plugins/CAS_SD_ZMQ/energy.irp.f Normal file
View File

@ -0,0 +1,11 @@
BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
implicit none
BEGIN_DOC
! E0 in the denominator of the PT2
END_DOC
pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states)
! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion
! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states)
call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator')
END_PROVIDER

4
plugins/CAS_SD_ZMQ/ezfio_interface.irp.f Normal file
View File

@ -0,0 +1,4 @@
! DO NOT MODIFY BY HAND
! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py
! from file /home/scemama/quantum_package/src/CAS_SD_ZMQ/EZFIO.cfg

156
plugins/CAS_SD_ZMQ/run_selection_slave.irp.f Normal file
View File

@ -0,0 +1,156 @@
subroutine run_selection_slave(thread,iproc,energy)
use f77_zmq
use selection_types
implicit none
double precision, intent(in) :: energy(N_states)
integer, intent(in) :: thread, iproc
integer :: rc, i
integer :: worker_id, task_id(1), ctask, ltask
character*(512) :: task
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR), external :: new_zmq_push_socket
integer(ZMQ_PTR) :: zmq_socket_push
type(selection_buffer) :: buf, buf2
logical :: done
double precision :: pt2(N_states)
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_push = new_zmq_push_socket(thread)
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
if(worker_id == -1) then
print *, "WORKER -1"
!call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
return
end if
buf%N = 0
ctask = 1
pt2 = 0d0
do
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task)
done = task_id(ctask) == 0
if (done) then
ctask = ctask - 1
else
integer :: i_generator, i_generator_start, i_generator_max, step, N
read (task,*) i_generator_start, i_generator_max, step, N
if(buf%N == 0) then
! Only first time
call create_selection_buffer(N, N*2, buf)
call create_selection_buffer(N, N*3, buf2)
else
if(N /= buf%N) stop "N changed... wtf man??"
end if
!print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1)
!call debug_det(psi_selectors(1,1,N_det_selectors), N_int)
do i_generator=i_generator_start,i_generator_max,step
call select_connected(i_generator,energy,pt2,buf)
enddo
endif
if(done .or. ctask == size(task_id)) then
if(buf%N == 0 .and. ctask > 0) stop "uninitialized selection_buffer"
do i=1, ctask
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i))
end do
if(ctask > 0) then
call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask)
do i=1,buf%cur
call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i))
enddo
call sort_selection_buffer(buf2)
buf%mini = buf2%mini
pt2 = 0d0
buf%cur = 0
end if
ctask = 0
end if
if(done) exit
ctask = ctask + 1
end do
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
end subroutine
subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask)
use f77_zmq
use selection_types
implicit none
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
double precision, intent(in) :: pt2(N_states)
type(selection_buffer), intent(inout) :: b
integer, intent(in) :: ntask, task_id(*)
integer :: rc
call sort_selection_buffer(b)
rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
if(rc /= 4) stop "push"
rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states, ZMQ_SNDMORE)
if(rc /= 8*N_states) stop "push"
rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)
if(rc /= 8*b%cur) stop "push"
rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)
if(rc /= bit_kind*N_int*2*b%cur) stop "push"
rc = f77_zmq_send( zmq_socket_push, ntask, 4, ZMQ_SNDMORE)
if(rc /= 4) stop "push"
rc = f77_zmq_send( zmq_socket_push, task_id(1), ntask*4, 0)
if(rc /= 4*ntask) stop "push"
! Activate is zmq_socket_push is a REQ
! rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0)
end subroutine
subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, ntask)
use f77_zmq
use selection_types
implicit none
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
double precision, intent(inout) :: pt2(N_states)
double precision, intent(out) :: val(*)
integer(bit_kind), intent(out) :: det(N_int, 2, *)
integer, intent(out) :: N, ntask, task_id(*)
integer :: rc, rn, i
rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0)
if(rc /= 4) stop "pull"
rc = f77_zmq_recv( zmq_socket_pull, pt2, N_states*8, 0)
if(rc /= 8*N_states) stop "pull"
rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)
if(rc /= 8*N) stop "pull"
rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)
if(rc /= bit_kind*N_int*2*N) stop "pull"
rc = f77_zmq_recv( zmq_socket_pull, ntask, 4, 0)
if(rc /= 4) stop "pull"
rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntask*4, 0)
if(rc /= 4*ntask) stop "pull"
! Activate is zmq_socket_pull is a REP
! rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0)
end subroutine

1933
plugins/Full_CI_ZMQ/selection_double.irp.f → plugins/CAS_SD_ZMQ/selection.irp.f
View File

File diff suppressed because it is too large Load Diff

70
plugins/CAS_SD_ZMQ/selection_buffer.irp.f Normal file
View File

@ -0,0 +1,70 @@
subroutine create_selection_buffer(N, siz, res)
use selection_types
implicit none
integer, intent(in) :: N, siz
type(selection_buffer), intent(out) :: res
allocate(res%det(N_int, 2, siz), res%val(siz))
res%val = 0d0
res%det = 0_8
res%N = N
res%mini = 0d0
res%cur = 0
end subroutine
subroutine add_to_selection_buffer(b, det, val)
use selection_types
implicit none
type(selection_buffer), intent(inout) :: b
integer(bit_kind), intent(in) :: det(N_int, 2)
double precision, intent(in) :: val
integer :: i
if(dabs(val) >= b%mini) then
b%cur += 1
b%det(:,:,b%cur) = det(:,:)
b%val(b%cur) = val
if(b%cur == size(b%val)) then
call sort_selection_buffer(b)
end if
end if
end subroutine
subroutine sort_selection_buffer(b)
use selection_types
implicit none
type(selection_buffer), intent(inout) :: b
double precision, allocatable :: vals(:), absval(:)
integer, allocatable :: iorder(:)
integer(bit_kind), allocatable :: detmp(:,:,:)
integer :: i, nmwen
logical, external :: detEq
nmwen = min(b%N, b%cur)
allocate(iorder(b%cur), detmp(N_int, 2, nmwen), absval(b%cur), vals(nmwen))
absval = -dabs(b%val(:b%cur))
do i=1,b%cur
iorder(i) = i
end do
call dsort(absval, iorder, b%cur)
do i=1, nmwen
detmp(:,:,i) = b%det(:,:,iorder(i))
vals(i) = b%val(iorder(i))
end do
b%det(:,:,:nmwen) = detmp(:,:,:)
b%det(:,:,nmwen+1:) = 0_bit_kind
b%val(:nmwen) = vals(:)
b%val(nmwen+1:) = 0d0
b%mini = max(b%mini,dabs(b%val(b%N)))
b%cur = nmwen
end subroutine

93
plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f Normal file
View File

@ -0,0 +1,93 @@
program selection_slave
implicit none
BEGIN_DOC
! Helper program to compute the PT2 in distributed mode.
END_DOC
read_wf = .False.
SOFT_TOUCH read_wf
call provide_everything
call switch_qp_run_to_master
call run_wf
end
subroutine provide_everything
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context
PROVIDE pt2_e0_denominator mo_tot_num N_int
end
subroutine run_wf
use f77_zmq
implicit none
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
double precision :: energy(N_states)
character*(64) :: states(1)
integer :: rc, i
call provide_everything
zmq_context = f77_zmq_ctx_new ()
states(1) = 'selection'
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
do
call wait_for_states(states,zmq_state,1)
if(trim(zmq_state) == 'Stopped') then
exit
else if (trim(zmq_state) == 'selection') then
! Selection
! ---------
print *, 'Selection'
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
!$OMP PARALLEL PRIVATE(i)
i = omp_get_thread_num()
call selection_slave_tcp(i, energy)
!$OMP END PARALLEL
print *, 'Selection done'
endif
end do
end
subroutine update_energy(energy)
implicit none
double precision, intent(in) :: energy(N_states)
BEGIN_DOC
! Update energy when it is received from ZMQ
END_DOC
integer :: j,k
do j=1,N_states
do k=1,N_det
CI_eigenvectors(k,j) = psi_coef(k,j)
enddo
enddo
call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int)
if (.True.) then
do k=1,N_states
ci_electronic_energy(k) = energy(k)
enddo
TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors
endif
call write_double(6,ci_energy,'Energy')
end
subroutine selection_slave_tcp(i,energy)
implicit none
double precision, intent(in) :: energy(N_states)
integer, intent(in) :: i
call run_selection_slave(0,i,energy)
end

9
plugins/CAS_SD_ZMQ/selection_types.f90 Normal file
View File

@ -0,0 +1,9 @@
module selection_types
type selection_buffer
integer :: N, cur
integer(8), allocatable :: det(:,:,:)
double precision, allocatable :: val(:)
double precision :: mini
endtype
end module

2
plugins/FCIdump/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Determinants Davidson
Determinants Davidson core_integrals

48
plugins/FCIdump/fcidump.irp.f
View File

@ -1,21 +1,25 @@
program fcidump
implicit none
character*(128) :: output
integer :: i_unit_output,getUnitAndOpen
output=trim(ezfio_filename)//'.FCIDUMP'
i_unit_output = getUnitAndOpen(output,'w')
integer :: i,j,k,l
integer :: ii(8), jj(8), kk(8),ll(8)
integer :: i1,j1,k1,l1
integer :: i2,j2,k2,l2
integer*8 :: m
character*(2), allocatable :: A(:)
print *, '&FCI NORB=', mo_tot_num, ', NELEC=', elec_num, &
write(i_unit_output,*) '&FCI NORB=', n_act_orb, ', NELEC=', elec_num-n_core_orb*2, &
', MS2=', (elec_alpha_num-elec_beta_num), ','
allocate (A(mo_tot_num))
allocate (A(n_act_orb))
A = '1,'
print *, 'ORBSYM=', (A(i), i=1,mo_tot_num)
print *,'ISYM=0,'
print *,'/'
write(i_unit_output,*) 'ORBSYM=', (A(i), i=1,n_act_orb)
write(i_unit_output,*) 'ISYM=0,'
write(i_unit_output,*) '/'
deallocate(A)
integer*8 :: i8, k1
integer(key_kind), allocatable :: keys(:)
double precision, allocatable :: values(:)
integer(cache_map_size_kind) :: n_elements, n_elements_max
@ -23,14 +27,18 @@ program fcidump
double precision :: get_mo_bielec_integral, integral
do l=1,mo_tot_num
do k=1,mo_tot_num
do j=l,mo_tot_num
do i=k,mo_tot_num
if (i>=j) then
integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
do l=1,n_act_orb
l1 = list_act(l)
do k=1,n_act_orb
k1 = list_act(k)
do j=l,n_act_orb
j1 = list_act(j)
do i=k,n_act_orb
i1 = list_act(i)
if (i1>=j1) then
integral = get_mo_bielec_integral(i1,j1,k1,l1,mo_integrals_map)
if (dabs(integral) > mo_integrals_threshold) then
print *, integral, i,k,j,l
write(i_unit_output,*) integral, i,k,j,l
endif
end if
enddo
@ -38,13 +46,15 @@ program fcidump
enddo
enddo
do j=1,mo_tot_num
do i=j,mo_tot_num
integral = mo_mono_elec_integral(i,j)
do j=1,n_act_orb
j1 = list_act(j)
do i=j,n_act_orb
i1 = list_act(i)
integral = mo_mono_elec_integral(i1,j1) + core_fock_operator(i1,j1)
if (dabs(integral) > mo_integrals_threshold) then
print *, integral, i,j,0,0
write(i_unit_output,*) integral, i,j,0,0
endif
enddo
enddo
print *, 0.d0, 0, 0, 0, 0
write(i_unit_output,*) core_energy, 0, 0, 0, 0
end

2
plugins/FOBOCI/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Perturbation Selectors_no_sorted Hartree_Fock Davidson CISD
Perturbation Selectors_no_sorted SCF_density Davidson CISD

2
plugins/FOBOCI/SC2_1h1p.irp.f
View File

@ -210,7 +210,7 @@ subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Ni
integer, intent(in) :: dim_in, sze, N_st, Nint
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(inout) :: u_in(dim_in,N_st)
double precision, intent(out) :: diag_H_elements(dim_in)
double precision, intent(out) :: diag_H_elements(0:dim_in)
double precision, intent(in) :: convergence
integer :: i,j,k,l

1
plugins/FOBOCI/all_singles.irp.f
View File

@ -48,6 +48,7 @@ subroutine all_single(e_pt2)
print*,'-----------------------'
print*,'i = ',i
call H_apply_just_mono(pt2, norm_pert, H_pert_diag, N_st)
call make_s2_eigenfunction_first_order
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)

133
plugins/FOBOCI/create_1h_or_1p.irp.f
View File

@ -29,21 +29,13 @@ subroutine create_restart_and_1h(i_hole)
enddo
enddo
enddo
integer :: N_det_old
N_det_old = N_det
N_det += n_new_det
allocate (new_det(N_int,2,n_new_det))
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, N_det_old
do k = 1, N_int
psi_det(k,1,i) = old_psi_det(k,1,i)
psi_det(k,2,i) = old_psi_det(k,2,i)
enddo
enddo
logical, allocatable :: duplicate(:)
allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det))
n_new_det = 0
do j = 1, n_act_orb
@ -58,19 +50,56 @@ subroutine create_restart_and_1h(i_hole)
if(i_ok .ne. 1)cycle
n_new_det +=1
do k = 1, N_int
psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1)
psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2)
new_det(k,1,n_new_det) = key_tmp(k,1)
new_det(k,2,n_new_det) = key_tmp(k,2)
enddo
psi_coef(n_det_old+n_new_det,:) = 0.d0
enddo
enddo
enddo
SOFT_TOUCH N_det psi_det psi_coef
logical :: found_duplicates
if(n_act_orb.gt.1)then
call remove_duplicates_in_psi_det(found_duplicates)
integer :: i_test
duplicate = .False.
do i = 1, n_new_det
if(duplicate(i))cycle
do j = i+1, n_new_det
i_test = 0
do ispin =1 ,2
do k = 1, N_int
i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j)))
enddo
enddo
if(i_test.eq.0)then
duplicate(j) = .True.
endif
enddo
enddo
integer :: n_new_det_unique
n_new_det_unique = 0
print*, 'uniq det'
do i = 1, n_new_det
if(.not.duplicate(i))then
n_new_det_unique += 1
endif
enddo
print*, n_new_det_unique
N_det += n_new_det_unique
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, n_new_det_unique
do ispin = 1, 2
do k = 1, N_int
psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i)
enddo
enddo
psi_coef(N_det_old+i,:) = 0.d0
enddo
SOFT_TOUCH N_det psi_det psi_coef
deallocate (new_det,duplicate)
end
subroutine create_restart_and_1p(i_particle)
@ -107,18 +136,8 @@ subroutine create_restart_and_1p(i_particle)
integer :: N_det_old
N_det_old = N_det
N_det += n_new_det
allocate (new_det(N_int,2,n_new_det))
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, N_det_old
do k = 1, N_int
psi_det(k,1,i) = old_psi_det(k,1,i)
psi_det(k,2,i) = old_psi_det(k,2,i)
enddo
enddo
logical, allocatable :: duplicate(:)
allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det))
n_new_det = 0
do j = 1, n_act_orb
@ -133,17 +152,59 @@ subroutine create_restart_and_1p(i_particle)
if(i_ok .ne. 1)cycle
n_new_det +=1
do k = 1, N_int
psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1)
psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2)
new_det(k,1,n_new_det) = key_tmp(k,1)
new_Det(k,2,n_new_det) = key_tmp(k,2)
enddo
psi_coef(n_det_old+n_new_det,:) = 0.d0
enddo
enddo
enddo
integer :: i_test
duplicate = .False.
do i = 1, n_new_det
if(duplicate(i))cycle
call debug_det(new_det(1,1,i),N_int)
do j = i+1, n_new_det
i_test = 0
call debug_det(new_det(1,1,j),N_int)
do ispin =1 ,2
do k = 1, N_int
i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j)))
enddo
enddo
if(i_test.eq.0)then
duplicate(j) = .True.
endif
enddo
enddo
integer :: n_new_det_unique
n_new_det_unique = 0
print*, 'uniq det'
do i = 1, n_new_det
if(.not.duplicate(i))then
n_new_det_unique += 1
endif
enddo
print*, n_new_det_unique
N_det += n_new_det_unique
if (psi_det_size < N_det) then
psi_det_size = N_det
TOUCH psi_det_size
endif
do i = 1, n_new_det_unique
do ispin = 1, 2
do k = 1, N_int
psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i)
enddo
enddo
psi_coef(N_det_old+i,:) = 0.d0
enddo
SOFT_TOUCH N_det psi_det psi_coef
logical :: found_duplicates
call remove_duplicates_in_psi_det(found_duplicates)
deallocate (new_det,duplicate)
end
subroutine create_restart_1h_1p(i_hole,i_part)

6
plugins/FOBOCI/density_matrix.irp.f
View File

@ -17,6 +17,7 @@
integer :: degree_respect_to_HF_l,index_ref_generators_restart
double precision :: inv_coef_ref_generators_restart
integer :: i
print*, 'providing the one_body_dm_mo_alpha_generators_restart'
do i = 1, N_det_generators_restart
! Find the reference determinant for intermediate normalization
@ -32,6 +33,11 @@
psi_coef_generators_restart(i,1) = psi_coef_generators_restart(i,1) * inv_coef_ref_generators_restart
norm_generators_restart += psi_coef_generators_restart(i,1)**2
enddo
double precision :: inv_norm
inv_norm = 1.d0/dsqrt(norm_generators_restart)
do i = 1, N_det_generators_restart
psi_coef_generators_restart(i,1) = psi_coef_generators_restart(i,1) * inv_norm
enddo
one_body_dm_mo_alpha_generators_restart = 0.d0

7
plugins/FOBOCI/dress_simple.irp.f
View File

@ -175,6 +175,10 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
endif
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
if(i==j)then
call debug_det(psi_det_generators_input(1,1,i),N_int)
print*, hij
endif
dressed_H_matrix(i,j) = hij
enddo
enddo
@ -234,6 +238,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
do i = 1, N_states
i_state(i) = i
E_ref(i) = eigvalues(i)
print*, 'E_ref(i)',E_ref(i)
enddo
endif
do i = 1,N_states
@ -287,7 +292,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
accu += eigvectors(j,i) * psi_coef_ref(j,k)
enddo
print*,'accu = ',accu
if(dabs(accu).ge.0.72d0)then
if(dabs(accu).ge.0.60d0)then
i_good_state(0) +=1
i_good_state(i_good_state(0)) = i
endif

7
plugins/FOBOCI/fobo_scf.irp.f
View File

@ -15,8 +15,6 @@ end
subroutine run_prepare
implicit none
! no_oa_or_av_opt = .False.
! touch no_oa_or_av_opt
call damping_SCF
call diag_inactive_virt_and_update_mos
end
@ -28,7 +26,8 @@ subroutine routine_fobo_scf
print*,''
character*(64) :: label
label = "Natural"
do i = 1, 5
do i = 1, 10
call initialize_mo_coef_begin_iteration
print*,'*******************************************************************************'
print*,'*******************************************************************************'
print*,'FOBO-SCF Iteration ',i
@ -56,6 +55,8 @@ subroutine routine_fobo_scf
call save_osoci_natural_mos
call damping_SCF
call diag_inactive_virt_and_update_mos
call reorder_active_orb
call save_mos
call clear_mo_map
call provide_properties
enddo

8
plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f
View File

@ -40,6 +40,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
logical :: lmct
double precision, allocatable :: psi_singles_coef(:,:)
logical :: exit_loop
call update_generators_restart_coef
allocate( zero_bitmask(N_int,2) )
do i = 1, n_inact_orb
lmct = .True.
@ -55,6 +56,10 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
call create_restart_and_1h(i_hole_osoci)
call set_generators_to_psi_det
print*,'Passed set generators'
integer :: m
do m = 1, N_det_generators
call debug_det(psi_det_generators(1,1,m),N_int)
enddo
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
double precision :: e_pt2
@ -82,7 +87,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call all_single(e_pt2)
call make_s2_eigenfunction_first_order
! call make_s2_eigenfunction_first_order
threshold_davidson = 1.d-6
soft_touch threshold_davidson davidson_criterion
call diagonalize_ci
@ -541,7 +546,6 @@ subroutine FOBOCI_lmct_mlct_old_thr_restart(iter)
call print_generators_bitmasks_holes
! Impose that only the active part can be reached
call set_bitmask_hole_as_input(unpaired_bitmask)
!!! call all_single_h_core
call create_restart_and_1p(i_particl_osoci)
!!! ! Update the generators
call set_generators_to_psi_det

15
plugins/FOBOCI/generators_restart_save.irp.f
View File

@ -74,3 +74,18 @@ END_PROVIDER
&BEGIN_PROVIDER [ double precision, psi_coef_generators, (10000,N_states) ]
END_PROVIDER
subroutine update_generators_restart_coef
implicit none
call set_generators_to_generators_restart
call set_psi_det_to_generators
call diagonalize_CI
integer :: i,j,k,l
do i = 1, N_det_generators_restart
do j = 1, N_states
psi_coef_generators_restart(i,j) = psi_coef(i,j)
enddo
enddo
soft_touch psi_coef_generators_restart
provide one_body_dm_mo_alpha_generators_restart
end

114
plugins/FOBOCI/routines_foboci.irp.f
View File

@ -13,6 +13,8 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
integer :: n_good_hole
logical,allocatable :: is_a_ref_det(:)
allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det))
double precision, allocatable :: local_norm(:)
allocate(local_norm(N_states))
n_one_hole = 0
n_one_hole_one_p = 0
@ -30,7 +32,6 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
do k = 1, N_states
inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k)
enddo
! cycle
endif
! Find all the determinants present in the reference wave function
@ -59,10 +60,8 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
enddo
endif
enddo
!do k = 1, N_det
! call debug_det(psi_det(1,1,k),N_int)
! print*,'k,coef = ',k,psi_coef(k,1)/psi_coef(index_ref_generators_restart,1)
!enddo
print*,''
print*,'n_good_hole = ',n_good_hole
do k = 1,N_states
@ -72,27 +71,37 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
enddo
print*,''
enddo
norm = 0.d0
! Set the wave function to the intermediate normalization
! Set the wave function to the intermediate normalization
do k = 1, N_states
do i = 1, N_det
psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k)
enddo
enddo
norm = 0.d0
do k = 1,N_states
print*,'state ',k
do i = 1, N_det
!! print*,'psi_coef(i_ref) = ',psi_coef(i,1)
if (is_a_ref_det(i))then
print*,'i,psi_coef_ref = ',psi_coef(i,k)
cycle
endif
norm(k) += psi_coef(i,k) * psi_coef(i,k)
enddo
print*,'norm = ',norm(k)
enddo
do k =1, N_states
local_norm(k) = 1.d0 / dsqrt(norm(k))
enddo
do k = 1,N_states
do i = 1, N_det
psi_coef(i,k) = psi_coef(i,k) * local_norm(k)
enddo
enddo
deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det)
deallocate(local_norm)
soft_touch psi_coef
end
@ -117,6 +126,8 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
integer :: i_count
allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det))
allocate(index_one_hole_two_p(n_det))
double precision, allocatable :: local_norm(:)
allocate(local_norm(N_states))
n_one_hole = 0
n_one_hole_one_p = 0
@ -185,20 +196,29 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k)
enddo
enddo
do k = 1, N_states
norm = 0.d0
do k = 1,N_states
print*,'state ',k
do i = 1, N_det
!! print*,'i = ',i, psi_coef(i,1)
if (is_a_ref_det(i))then
print*,'i,psi_coef_ref = ',psi_coef(i,k)
cycle
endif
norm(k) += psi_coef(i,k) * psi_coef(i,k)
enddo
print*,'norm = ',norm
print*,'norm = ',norm(k)
enddo
do k =1, N_states
local_norm(k) = 1.d0 / dsqrt(norm(k))
enddo
do k = 1,N_states
do i = 1, N_det
psi_coef(i,k) = psi_coef(i,k) * local_norm(k)
enddo
enddo
soft_touch psi_coef
deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det)
deallocate(local_norm)
end
@ -210,12 +230,60 @@ subroutine update_density_matrix_osoci
END_DOC
integer :: i,j
integer :: iorb,jorb
! active <--> inactive block
do i = 1, mo_tot_num
do j = 1, mo_tot_num
one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
one_body_dm_mo_alpha_osoci(i,j) += one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)
one_body_dm_mo_beta_osoci(i,j) += one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j)
enddo
enddo
!do i = 1, n_act_orb
! iorb = list_act(i)
! do j = 1, n_inact_orb
! jorb = list_inact(j)
! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb)
! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb)
! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb)
! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb)
! enddo
!enddo
!! active <--> virt block
!do i = 1, n_act_orb
! iorb = list_act(i)
! do j = 1, n_virt_orb
! jorb = list_virt(j)
! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb)
! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb)
! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb)
! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb)
! enddo
!enddo
!! virt <--> virt block
!do j = 1, n_virt_orb
! jorb = list_virt(j)
! one_body_dm_mo_alpha_osoci(jorb,jorb)+= one_body_dm_mo_alpha_average(jorb,jorb)
! one_body_dm_mo_beta_osoci(jorb,jorb) += one_body_dm_mo_beta_average(jorb,jorb)
!enddo
!! inact <--> inact block
!do j = 1, n_inact_orb
! jorb = list_inact(j)
! one_body_dm_mo_alpha_osoci(jorb,jorb) -= one_body_dm_mo_alpha_average(jorb,jorb)
! one_body_dm_mo_beta_osoci(jorb,jorb) -= one_body_dm_mo_beta_average(jorb,jorb)
!enddo
double precision :: accu_alpha, accu_beta
accu_alpha = 0.d0
accu_beta = 0.d0
do i = 1, mo_tot_num
accu_alpha += one_body_dm_mo_alpha_osoci(i,i)
accu_beta += one_body_dm_mo_beta_osoci(i,i)
! write(*,'(I3,X,100(F16.10,X))') i,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_beta_osoci(i,i),one_body_dm_mo_alpha_osoci(i,i)+one_body_dm_mo_beta_osoci(i,i)
enddo
print*, 'accu_alpha/beta',accu_alpha,accu_beta
end
@ -261,8 +329,18 @@ end
subroutine initialize_density_matrix_osoci
implicit none
call set_generators_to_generators_restart
call set_psi_det_to_generators
call diagonalize_CI
one_body_dm_mo_alpha_osoci = one_body_dm_mo_alpha_generators_restart
one_body_dm_mo_beta_osoci = one_body_dm_mo_beta_generators_restart
integer :: i
print*, '8*********************'
print*, 'initialize_density_matrix_osoci'
do i = 1, mo_tot_num
print*,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_alpha_generators_restart(i,i)
enddo
end
subroutine rescale_density_matrix_osoci(norm)
@ -438,6 +516,10 @@ subroutine save_osoci_natural_mos
endif
enddo
enddo
print*, 'test'
print*, 'test'
print*, 'test'
print*, 'test'
do i = 1, mo_tot_num
do j = i+1, mo_tot_num
if(dabs(tmp(i,j)).le.threshold_fobo_dm)then
@ -445,7 +527,9 @@ subroutine save_osoci_natural_mos
tmp(j,i) = 0.d0
endif
enddo
print*, tmp(i,i)
enddo
label = "Natural"

12
plugins/Full_CI/EZFIO.cfg
View File

@ -8,15 +8,3 @@ type: double precision
doc: Calculated FCI energy + PT2
interface: ezfio
[threshold_generators_pt2]
type: Threshold
doc: Thresholds on generators (fraction of the norm) for final PT2 calculation
interface: ezfio,provider,ocaml
default: 0.999
[threshold_selectors_pt2]
type: Threshold
doc: Thresholds on selectors (fraction of the norm) for final PT2 calculation
interface: ezfio,provider,ocaml
default: 1.

5
plugins/Full_CI/H_apply.irp.f
View File

@ -12,11 +12,6 @@ s.set_perturbation("epstein_nesbet_2x2")
s.unset_openmp()
print s
s = H_apply("FCI_PT2_new")
s.set_perturbation("decontracted")
s.unset_openmp()
print s
s = H_apply("FCI_no_skip")
s.set_selection_pt2("epstein_nesbet_2x2")

11
plugins/Full_CI_ZMQ/EZFIO.cfg Normal file
View File

@ -0,0 +1,11 @@
[energy]
type: double precision
doc: Calculated Selected FCI energy
interface: ezfio
[energy_pt2]
type: double precision
doc: Calculated FCI energy + PT2
interface: ezfio

2
plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Perturbation Selectors_full Generators_full ZMQ Full_CI
Perturbation Selectors_full Generators_full ZMQ

11
plugins/Full_CI_ZMQ/energy.irp.f Normal file
View File

@ -0,0 +1,11 @@
BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
implicit none
BEGIN_DOC
! E0 in the denominator of the PT2
END_DOC
pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states)
! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion
! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states)
call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator')
END_PROVIDER

83
plugins/Full_CI_ZMQ/fci_zmq.irp.f
View File

@ -5,11 +5,16 @@ program fci_zmq
double precision, allocatable :: pt2(:)
integer :: degree
integer :: n_det_before, to_select
double precision :: threshold_davidson_in
allocate (pt2(N_states))
pt2 = 1.d0
diag_algorithm = "Lapack"
threshold_davidson_in = threshold_davidson
SOFT_TOUCH threshold_davidson
threshold_davidson = 1.d-4
if (N_det > N_det_max) then
call diagonalize_CI
@ -33,29 +38,36 @@ program fci_zmq
double precision :: E_CI_before(N_states)
integer :: n_det_before
print*,'Beginning the selection ...'
E_CI_before(1:N_states) = CI_energy(1:N_states)
n_det_before = 0
do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) )
n_det_before = N_det
call ZMQ_selection(max(1024-N_det, N_det), pt2)
to_select = 3*N_det
to_select = max(1024-to_select, to_select)
to_select = min(to_select, N_det_max-n_det_before)
call ZMQ_selection(to_select, pt2)
PROVIDE psi_coef
PROVIDE psi_det
PROVIDE psi_det_sorted
if (N_det == N_det_max) then
threshold_davidson = threshold_davidson_in
SOFT_TOUCH threshold_davidson
endif
call diagonalize_CI
call save_wavefunction
if (N_det > N_det_max) then
psi_det = psi_det_sorted
psi_coef = psi_coef_sorted
N_det = N_det_max
soft_touch N_det psi_det psi_coef
call diagonalize_CI
call save_wavefunction
endif
! if (N_det > N_det_max) then
! psi_det = psi_det_sorted
! psi_coef = psi_coef_sorted
! N_det = N_det_max
! soft_touch N_det psi_det psi_coef
! call diagonalize_CI
! call save_wavefunction
! endif
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
@ -79,13 +91,13 @@ program fci_zmq
enddo
endif
E_CI_before(1:N_states) = CI_energy(1:N_states)
call ezfio_set_full_ci_energy(CI_energy)
call ezfio_set_full_ci_zmq_energy(CI_energy)
enddo
if(do_pt2_end)then
print*,'Last iteration only to compute the PT2'
threshold_selectors = threshold_selectors_pt2
threshold_generators = threshold_generators_pt2
threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
threshold_generators = max(threshold_generators,threshold_generators_pt2)
TOUCH threshold_selectors threshold_generators
E_CI_before(1:N_states) = CI_energy(1:N_states)
call ZMQ_selection(0, pt2)
@ -99,7 +111,7 @@ program fci_zmq
print *, 'E+PT2 = ', E_CI_before+pt2
print *, '-----'
enddo
call ezfio_set_full_ci_energy_pt2(E_CI_before+pt2)
call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before+pt2)
endif
call save_wavefunction
end
@ -122,38 +134,43 @@ subroutine ZMQ_selection(N_in, pt2)
double precision, intent(out) :: pt2(N_states)
N = max(N_in,1)
provide nproc
provide ci_electronic_energy
call new_parallel_job(zmq_to_qp_run_socket,"selection")
call zmq_put_psi(zmq_to_qp_run_socket,1,ci_electronic_energy,size(ci_electronic_energy))
call zmq_set_running(zmq_to_qp_run_socket)
call create_selection_buffer(N, N*2, b)
if (.True.) then
PROVIDE pt2_e0_denominator
N = max(N_in,1)
provide nproc
call new_parallel_job(zmq_to_qp_run_socket,"selection")
call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator))
call zmq_set_running(zmq_to_qp_run_socket)
call create_selection_buffer(N, N*2, b)
endif
integer :: i_generator, i_generator_start, i_generator_max, step
! step = int(max(1.,10*elec_num/mo_tot_num)
step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num ))
step = max(1,step)
do i= N_det_generators, 1, -step
i_generator_start = max(i-step+1,1)
i_generator_max = i
do i= 1, N_det_generators,step
i_generator_start = i
i_generator_max = min(i+step-1,N_det_generators)
write(task,*) i_generator_start, i_generator_max, 1, N
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
end do
!$OMP PARALLEL DEFAULT(none) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) shared(ci_electronic_energy_is_built, n_det_generators_is_built, n_states_is_built, n_int_is_built, nproc_is_built)
i = omp_get_thread_num()
if (i==0) then
call selection_collector(b, pt2)
else
call selection_slave_inproc(i)
endif
!$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1)
i = omp_get_thread_num()
if (i==0) then
call selection_collector(b, pt2)
else
call selection_slave_inproc(i)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, 'selection')
call end_parallel_job(zmq_to_qp_run_socket, 'selection')
if (N_in > 0) then
call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN
call copy_H_apply_buffer_to_wf()
if (s2_eig) then
call make_s2_eigenfunction
endif
endif
end subroutine
@ -162,7 +179,7 @@ subroutine selection_slave_inproc(i)
implicit none
integer, intent(in) :: i
call run_selection_slave(1,i,ci_electronic_energy)
call run_selection_slave(1,i,pt2_e0_denominator)
end
subroutine selection_collector(b, pt2)

2
plugins/Full_CI_ZMQ/run_selection_slave.irp.f
View File

@ -4,7 +4,7 @@ subroutine run_selection_slave(thread,iproc,energy)
use selection_types
implicit none
double precision, intent(in) :: energy(N_states_diag)
double precision, intent(in) :: energy(N_states)
integer, intent(in) :: thread, iproc
integer :: rc, i

1100
plugins/Full_CI_ZMQ/selection.irp.f
View File

File diff suppressed because it is too large Load Diff

12
plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f
View File

@ -13,7 +13,7 @@ end
subroutine provide_everything
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context mo_mono_elec_integral
! PROVIDE ci_electronic_energy mo_tot_num N_int
! PROVIDE pt2_e0_denominator mo_tot_num N_int
end
subroutine run_wf
@ -22,7 +22,7 @@ subroutine run_wf
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
double precision :: energy(N_states_diag)
double precision :: energy(N_states)
character*(64) :: states(2)
integer :: rc, i
@ -48,7 +48,7 @@ subroutine run_wf
! ---------
print *, 'Selection'
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag)
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
!$OMP PARALLEL PRIVATE(i)
i = omp_get_thread_num()
@ -76,7 +76,7 @@ end
subroutine update_energy(energy)
implicit none
double precision, intent(in) :: energy(N_states_diag)
double precision, intent(in) :: energy(N_states)
BEGIN_DOC
! Update energy when it is received from ZMQ
END_DOC
@ -88,7 +88,7 @@ subroutine update_energy(energy)
enddo
call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int)
if (.True.) then
do k=1,size(ci_electronic_energy)
do k=1,N_states
ci_electronic_energy(k) = energy(k)
enddo
TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors
@ -99,7 +99,7 @@ end
subroutine selection_slave_tcp(i,energy)
implicit none
double precision, intent(in) :: energy(N_states_diag)
double precision, intent(in) :: energy(N_states)
integer, intent(in) :: i
call run_selection_slave(0,i,energy)

354
plugins/Full_CI_ZMQ/selection_single.irp.f
View File

@ -1,354 +0,0 @@
subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf)
use bitmasks
use selection_types
implicit none
BEGIN_DOC
! Select determinants connected to i_det by H
END_DOC
integer, intent(in) :: i_gen
integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2)
double precision, intent(in) :: fock_diag_tmp(mo_tot_num)
double precision, intent(in) :: E0(N_states)
double precision, intent(inout) :: pt2(N_states)
type(selection_buffer), intent(inout) :: buf
double precision :: vect(N_states, mo_tot_num)
logical :: bannedOrb(mo_tot_num)
integer :: i, j, k
integer :: h1,h2,s1,s2,i1,i2,ib,sp
integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2)
logical :: fullMatch, ok
do k=1,N_int
hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1))
hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2))
particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1))
particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2))
enddo
! Create lists of holes and particles
! -----------------------------------
integer :: N_holes(2), N_particles(2)
integer :: hole_list(N_int*bit_kind_size,2)
integer :: particle_list(N_int*bit_kind_size,2)
call bitstring_to_list_ab(hole , hole_list , N_holes , N_int)
call bitstring_to_list_ab(particle, particle_list, N_particles, N_int)
do sp=1,2
do i=1, N_holes(sp)
h1 = hole_list(i,sp)
call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int)
bannedOrb = .true.
do j=1,N_particles(sp)
bannedOrb(particle_list(j, sp)) = .false.
end do
call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch)
if(fullMatch) cycle
vect = 0d0
call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect)
call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf)
end do
enddo
end subroutine
subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf)
use bitmasks
use selection_types
implicit none
integer, intent(in) :: i_generator, sp, h1
double precision, intent(in) :: vect(N_states, mo_tot_num)
logical, intent(in) :: bannedOrb(mo_tot_num)
double precision, intent(in) :: fock_diag_tmp(mo_tot_num)
double precision, intent(in) :: E0(N_states)
double precision, intent(inout) :: pt2(N_states)
type(selection_buffer), intent(inout) :: buf
logical :: ok
integer :: s1, s2, p1, p2, ib, istate
integer(bit_kind) :: mask(N_int, 2), det(N_int, 2)
double precision :: e_pert, delta_E, val, Hii, max_e_pert
double precision, external :: diag_H_mat_elem_fock
call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int)
do p1=1,mo_tot_num
if(bannedOrb(p1)) cycle
if(vect(1, p1) == 0d0) cycle
call apply_particle(mask, sp, p1, det, ok, N_int)
Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
max_e_pert = 0d0
do istate=1,N_states
val = vect(istate, p1)
delta_E = E0(istate) - Hii
if (delta_E < 0.d0) then
e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E)
else
e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E)
endif
pt2(istate) += e_pert
if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert
end do
if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert)
end do
end subroutine
subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect)
use bitmasks
implicit none
integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel)
integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel)
double precision, intent(in) :: coefs(N_states, N_sel)
integer, intent(in) :: sp, N_sel
logical, intent(inout) :: bannedOrb(mo_tot_num)
double precision, intent(inout) :: vect(N_states, mo_tot_num)
integer :: i, j, h(0:2,2), p(0:3,2), nt
integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2)
do i=1,N_int
negMask(i,1) = not(mask(i,1))
negMask(i,2) = not(mask(i,2))
end do
do i=1, N_sel
nt = 0
do j=1,N_int
mobMask(j,1) = iand(negMask(j,1), det(j,1,i))
mobMask(j,2) = iand(negMask(j,2), det(j,2,i))
nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
end do
if(nt > 3) cycle
do j=1,N_int
perMask(j,1) = iand(mask(j,1), not(det(j,1,i)))
perMask(j,2) = iand(mask(j,2), not(det(j,2,i)))
end do
call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int)
call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int)
call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int)
call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int)
if(nt == 3) then
call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i))
else if(nt == 2) then
call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i))
else
call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i))
end if
end do
end subroutine
subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
logical, intent(in) :: bannedOrb(mo_tot_num)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: vect(N_states, mo_tot_num)
integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti
double precision :: hij
double precision, external :: get_phase_bi, integral8
integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
integer, parameter :: turn2(2) = (/2,1/)
if(h(0,sp) == 2) then
h1 = h(1, sp)
h2 = h(2, sp)
do i=1,3
puti = p(i, sp)
if(bannedOrb(puti)) cycle
p1 = p(turn3_2(1,i), sp)
p2 = p(turn3_2(2,i), sp)
hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2)
hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2)
vect(:, puti) += hij * coefs
end do
else if(h(0,sp) == 1) then
sfix = turn2(sp)
hfix = h(1,sfix)
pfix = p(1,sfix)
hmob = h(1,sp)
do j=1,2
puti = p(j, sp)
if(bannedOrb(puti)) cycle
pmob = p(turn2(j), sp)
hij = integral8(pfix, pmob, hfix, hmob)
hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix)
vect(:, puti) += hij * coefs
end do
else
puti = p(1,sp)
if(.not. bannedOrb(puti)) then
sfix = turn2(sp)
p1 = p(1,sfix)
p2 = p(2,sfix)
h1 = h(1,sfix)
h2 = h(2,sfix)
hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2))
hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2)
vect(:, puti) += hij * coefs
end if
end if
end subroutine
subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
logical, intent(in) :: bannedOrb(mo_tot_num)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: vect(N_states, mo_tot_num)
integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
integer :: i, hole, p1, p2, sh
logical :: ok, lbanned(mo_tot_num)
integer(bit_kind) :: det(N_int, 2)
double precision :: hij
double precision, external :: get_phase_bi, integral8
lbanned = bannedOrb
sh = 1
if(h(0,2) == 1) sh = 2
hole = h(1, sh)
lbanned(p(1,sp)) = .true.
if(p(0,sp) == 2) lbanned(p(2,sp)) = .true.
!print *, "SPm1", sp, sh
p1 = p(1, sp)
if(sp == sh) then
p2 = p(2, sp)
lbanned(p2) = .true.
do i=1,hole-1
if(lbanned(i)) cycle
hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole))
hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2)
vect(:,i) += hij * coefs
end do
do i=hole+1,mo_tot_num
if(lbanned(i)) cycle
hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i))
hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2)
vect(:,i) += hij * coefs
end do
call apply_particle(mask, sp, p2, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
vect(:, p2) += hij * coefs
else
p2 = p(1, sh)
do i=1,mo_tot_num
if(lbanned(i)) cycle
hij = integral8(p1, p2, i, hole)
hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2)
vect(:,i) += hij * coefs
end do
end if
call apply_particle(mask, sp, p1, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
vect(:, p1) += hij * coefs
end subroutine
subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
use bitmasks
implicit none
integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
logical, intent(in) :: bannedOrb(mo_tot_num)
double precision, intent(in) :: coefs(N_states)
double precision, intent(inout) :: vect(N_states, mo_tot_num)
integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
integer :: i
logical :: ok, lbanned(mo_tot_num)
integer(bit_kind) :: det(N_int, 2)
double precision :: hij
lbanned = bannedOrb
lbanned(p(1,sp)) = .true.
do i=1,mo_tot_num
if(lbanned(i)) cycle
call apply_particle(mask, sp, i, det, ok, N_int)
call i_h_j(gen, det, N_int, hij)
vect(:, i) += hij * coefs
end do
end subroutine
subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch)
use bitmasks
implicit none
integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N)
integer, intent(in) :: i_gen, N, sp
logical, intent(inout) :: banned(mo_tot_num)
logical, intent(out) :: fullMatch
integer :: i, j, na, nb, list(3), nt
integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2)
fullMatch = .false.
do i=1,N_int
negMask(i,1) = not(mask(i,1))
negMask(i,2) = not(mask(i,2))
end do
genl : do i=1, N
nt = 0
do j=1, N_int
myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1))
myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2))
nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2))
end do
if(nt > 3) cycle
if(nt <= 2 .and. i < i_gen) then
fullMatch = .true.
return
end if
call bitstring_to_list(myMask(1,sp), list(1), na, N_int)
if(nt == 3 .and. i < i_gen) then
do j=1,na
banned(list(j)) = .true.
end do
else if(nt == 1 .and. na == 1) then
banned(list(1)) = .true.
end if
end do genl
end subroutine

12
plugins/Full_CI_ZMQ/selection_slave.irp.f
View File

@ -13,7 +13,7 @@ end
subroutine provide_everything
PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context
! PROVIDE ci_electronic_energy mo_tot_num N_int
PROVIDE pt2_e0_denominator mo_tot_num N_int
end
subroutine run_wf
@ -22,7 +22,7 @@ subroutine run_wf
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
double precision :: energy(N_states_diag)
double precision :: energy(N_states)
character*(64) :: states(1)
integer :: rc, i
@ -47,7 +47,7 @@ subroutine run_wf
! ---------
print *, 'Selection'
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag)
call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
!$OMP PARALLEL PRIVATE(i)
i = omp_get_thread_num()
@ -62,7 +62,7 @@ end
subroutine update_energy(energy)
implicit none
double precision, intent(in) :: energy(N_states_diag)
double precision, intent(in) :: energy(N_states)
BEGIN_DOC
! Update energy when it is received from ZMQ
END_DOC
@ -74,7 +74,7 @@ subroutine update_energy(energy)
enddo
call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int)
if (.True.) then
do k=1,size(ci_electronic_energy)
do k=1,N_states
ci_electronic_energy(k) = energy(k)
enddo
TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors
@ -85,7 +85,7 @@ end
subroutine selection_slave_tcp(i,energy)
implicit none
double precision, intent(in) :: energy(N_states_diag)
double precision, intent(in) :: energy(N_states)
integer, intent(in) :: i
call run_selection_slave(0,i,energy)

25
plugins/Generators_CAS/Generators_full/.gitignore vendored Normal file
View File

@ -0,0 +1,25 @@
# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py
IRPF90_temp
IRPF90_man
irpf90_entities
tags
irpf90.make
Makefile
Makefile.depend
build.ninja
.ninja_log
.ninja_deps
ezfio_interface.irp.f
Ezfio_files
Determinants
Integrals_Monoelec
MO_Basis
Utils
Pseudo
Bitmask
AO_Basis
Electrons
MOGuess
Nuclei
Hartree_Fock
Integrals_Bielec

1
plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Determinants Hartree_Fock

61
plugins/Generators_CAS/Generators_full/README.rst Normal file
View File

@ -0,0 +1,61 @@
======================
Generators_full Module
======================
All the determinants of the wave function are generators. In this way, the Full CI
space is explored.
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
.. image:: tree_dependency.png
* `Determinants <http://github.com/LCPQ/quantum_package/tree/master/src/Determinants>`_
* `Hartree_Fock <http://github.com/LCPQ/quantum_package/tree/master/src/Hartree_Fock>`_
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
.. image:: tree_dependency.png
* `Determinants <http://github.com/LCPQ/quantum_package/tree/master/src/Determinants>`_
* `Hartree_Fock <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock>`_
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
`degree_max_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L43>`_
Max degree of excitation (respect to HF) of the generators
`n_det_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L3>`_
For Single reference wave functions, the number of generators is 1 : the
Hartree-Fock determinant
`psi_coef_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L26>`_
For Single reference wave functions, the generator is the
Hartree-Fock determinant
`psi_det_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L25>`_
For Single reference wave functions, the generator is the
Hartree-Fock determinant
`select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L66>`_
Memo to skip useless selectors
`size_select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L58>`_
Size of the select_max array

75
plugins/Generators_CAS/Generators_full/generators.irp.f Normal file
View File

@ -0,0 +1,75 @@
use bitmasks
BEGIN_PROVIDER [ integer, N_det_generators ]
implicit none
BEGIN_DOC
! For Single reference wave functions, the number of generators is 1 : the
! Hartree-Fock determinant
END_DOC
integer :: i
double precision :: norm
call write_time(output_determinants)
norm = 0.d0
N_det_generators = N_det
do i=1,N_det
norm = norm + psi_average_norm_contrib_sorted(i)
if (norm >= threshold_generators) then
N_det_generators = i
exit
endif
enddo
N_det_generators = max(N_det_generators,1)
call write_int(output_determinants,N_det_generators,'Number of generators')
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ]
&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ]
implicit none
BEGIN_DOC
! For Single reference wave functions, the generator is the
! Hartree-Fock determinant
END_DOC
integer :: i, k
psi_coef_generators = 0.d0
psi_det_generators = 0_bit_kind
do i=1,N_det_generators
do k=1,N_int
psi_det_generators(k,1,i) = psi_det_sorted(k,1,i)
psi_det_generators(k,2,i) = psi_det_sorted(k,2,i)
enddo
psi_coef_generators(i,:) = psi_coef_sorted(i,:)
enddo
END_PROVIDER
BEGIN_PROVIDER [integer, degree_max_generators]
implicit none
BEGIN_DOC
! Max degree of excitation (respect to HF) of the generators
END_DOC
integer :: i,degree
degree_max_generators = 0
do i = 1, N_det_generators
call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int)
if(degree .gt. degree_max_generators)then
degree_max_generators = degree
endif
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, size_select_max]
implicit none
BEGIN_DOC
! Size of the select_max array
END_DOC
size_select_max = 10000
END_PROVIDER
BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ]
implicit none
BEGIN_DOC
! Memo to skip useless selectors
END_DOC
select_max = huge(1.d0)
END_PROVIDER

BIN
plugins/Generators_CAS/Generators_full/tree_dependency.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 81 KiB

16
plugins/Generators_CAS/generators.irp.f
View File

@ -9,14 +9,14 @@ BEGIN_PROVIDER [ integer, N_det_generators ]
logical :: good
call write_time(output_determinants)
N_det_generators = 0
do i=1,N_det
do i=1,N_det_ref
do l=1,n_cas_bitmask
good = .True.
do k=1,N_int
good = good .and. ( &
iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) ) .and. ( &
iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2)) )
enddo
if (good) then
@ -41,14 +41,14 @@ END_PROVIDER
integer :: i, k, l, m
logical :: good
m=0
do i=1,N_det
do i=1,N_det_ref
do l=1,n_cas_bitmask
good = .True.
do k=1,N_int
good = good .and. ( &
iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( &
iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) )
enddo
if (good) then
@ -58,8 +58,8 @@ END_PROVIDER
if (good) then
m = m+1
do k=1,N_int
psi_det_generators(k,1,m) = psi_det(k,1,i)
psi_det_generators(k,2,m) = psi_det(k,2,i)
psi_det_generators(k,1,m) = psi_ref(k,1,i)
psi_det_generators(k,2,m) = psi_ref(k,2,i)
enddo
psi_coef_generators(m,:) = psi_coef(m,:)
endif

6
plugins/MP2/mp2.irp.f
View File

@ -1,4 +1,10 @@
program mp2
no_vvvv_integrals = .True.
SOFT_TOUCH no_vvvv_integrals
call run
end
subroutine run
implicit none
double precision, allocatable :: pt2(:), norm_pert(:)
double precision :: H_pert_diag, E_old

6
plugins/MP2/mp2_wf.irp.f
View File

@ -1,4 +1,10 @@
program mp2_wf
no_vvvv_integrals = .True.
SOFT_TOUCH no_vvvv_integrals
call run
end
subroutine run
implicit none
BEGIN_DOC
! Save the MP2 wave function

2
plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS
Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS MRPT_Utils

230
plugins/MRCC_Utils/amplitudes.irp.f Normal file
View File

@ -0,0 +1,230 @@
BEGIN_PROVIDER [ integer, n_exc_active ]
&BEGIN_PROVIDER [ integer, active_pp_idx, (hh_nex) ]
&BEGIN_PROVIDER [ integer, active_hh_idx, (hh_nex) ]
&BEGIN_PROVIDER [ logical, is_active_exc, (hh_nex) ]
implicit none
BEGIN_DOC
! is_active_exc : True if the excitation involves at least one active MO
!
! n_exc_active : Number of active excitations : Number of excitations without the inactive ones.
!
! active_hh_idx :
!
! active_pp_idx :
END_DOC
integer :: hh, pp, II
integer :: ind
logical :: ok
integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2)
integer, allocatable :: pathTo(:)
integer, external :: searchDet
allocate(pathTo(N_det_non_ref))
pathTo(:) = 0
is_active_exc(:) = .false.
n_exc_active = 0
do hh = 1, hh_shortcut(0)
do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
do II = 1, N_det_ref
call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
if(.not. ok) cycle
call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
if(.not. ok) cycle
ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
if(ind == -1) cycle
ind = psi_non_ref_sorted_idx(ind)
if(pathTo(ind) == 0) then
pathTo(ind) = pp
else
is_active_exc(pp) = .true.
is_active_exc(pathTo(ind)) = .true.
end if
end do
end do
end do
!is_active_exc=.true.
do hh = 1, hh_shortcut(0)
do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
if(is_active_exc(pp)) then
n_exc_active = n_exc_active + 1
active_hh_idx(n_exc_active) = hh
active_pp_idx(n_exc_active) = pp
end if
end do
end do
deallocate(pathTo)
print *, n_exc_active, "active excitations /", hh_nex
END_PROVIDER
BEGIN_PROVIDER [ integer, active_excitation_to_determinants_idx, (0:N_det_ref+1, n_exc_active) ]
&BEGIN_PROVIDER [ double precision, active_excitation_to_determinants_val, (N_states,N_det_ref+1, n_exc_active) ]
implicit none
BEGIN_DOC
! Sparse matrix A containing the matrix to transform the active excitations to
! determinants : A | \Psi_0 > = | \Psi_SD >
END_DOC
integer :: s, ppp, pp, hh, II, ind, wk, i
integer, allocatable :: lref(:)
integer(bit_kind) :: myDet(N_int,2), myMask(N_int,2)
double precision :: phase
logical :: ok
integer, external :: searchDet
!$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int,&
!$OMP active_excitation_to_determinants_val, active_excitation_to_determinants_idx)&
!$OMP shared(hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, &
!$OMP psi_non_ref_sorted_idx, psi_ref, N_det_ref, N_states)&
!$OMP shared(is_active_exc, active_hh_idx, active_pp_idx, n_exc_active)&
!$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh, s)
allocate(lref(N_det_non_ref))
!$OMP DO schedule(dynamic)
do ppp=1,n_exc_active
active_excitation_to_determinants_val(:,:,ppp) = 0d0
active_excitation_to_determinants_idx(:,ppp) = 0
pp = active_pp_idx(ppp)
hh = active_hh_idx(ppp)
lref = 0
do II = 1, N_det_ref
call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
if(.not. ok) cycle
call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
if(.not. ok) cycle
ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
if(ind /= -1) then
call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int)
if (phase > 0.d0) then
lref(psi_non_ref_sorted_idx(ind)) = II
else
lref(psi_non_ref_sorted_idx(ind)) = -II
endif
end if
end do
wk = 0
do i=1, N_det_non_ref
if(lref(i) > 0) then
wk += 1
do s=1,N_states
active_excitation_to_determinants_val(s,wk, ppp) = psi_ref_coef(lref(i), s)
enddo
active_excitation_to_determinants_idx(wk, ppp) = i
else if(lref(i) < 0) then
wk += 1
do s=1,N_states
active_excitation_to_determinants_val(s,wk, ppp) = -psi_ref_coef(-lref(i), s)
enddo
active_excitation_to_determinants_idx(wk, ppp) = i
end if
end do
active_excitation_to_determinants_idx(0,ppp) = wk
end do
!$OMP END DO
deallocate(lref)
!$OMP END PARALLEL
END_PROVIDER
BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active) ]
&BEGIN_PROVIDER [ double precision, mrcc_AtA_val, (N_states, N_det_ref * n_exc_active) ]
&BEGIN_PROVIDER [ integer, mrcc_col_shortcut, (n_exc_active) ]
&BEGIN_PROVIDER [ integer, mrcc_N_col, (n_exc_active) ]
implicit none
BEGIN_DOC
! A is active_excitation_to_determinants in At.A
END_DOC
integer :: AtA_size, i,k
integer :: at_roww, at_row, wk, a_coll, a_col, r1, r2, s
double precision, allocatable :: t(:), A_val_mwen(:,:), As2_val_mwen(:,:)
integer, allocatable :: A_ind_mwen(:)
double precision :: sij
PROVIDE psi_non_ref
mrcc_AtA_ind(:) = 0
mrcc_AtA_val(:,:) = 0.d0
mrcc_col_shortcut(:) = 0
mrcc_N_col(:) = 0
AtA_size = 0
!$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,&
!$OMP active_excitation_to_determinants_val, hh_nex) &
!$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen,&
!$OMP As2_val_mwen, a_coll, at_roww,sij) &
!$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, &
!$OMP n_exc_active, active_pp_idx,psi_non_ref)
allocate(A_val_mwen(N_states,hh_nex), As2_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states) )
!$OMP DO schedule(dynamic, 100)
do at_roww = 1, n_exc_active ! hh_nex
at_row = active_pp_idx(at_roww)
wk = 0
if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", hh_nex
do a_coll = 1, n_exc_active
a_col = active_pp_idx(a_coll)
t(:) = 0d0
r1 = 1
r2 = 1
do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(active_excitation_to_determinants_idx(r2, a_coll) /= 0))
if(active_excitation_to_determinants_idx(r1, at_roww) > active_excitation_to_determinants_idx(r2, a_coll)) then
r2 = r2+1
else if(active_excitation_to_determinants_idx(r1, at_roww) < active_excitation_to_determinants_idx(r2, a_coll)) then
r1 = r1+1
else
do s=1,N_states
t(s) = t(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll)
enddo
r1 = r1+1
r2 = r2+1
end if
end do
if (a_col == at_row) then
t(:) = t(:) + 1.d0
endif
if (sum(dabs(t(:))) > 0.d0) then
wk = wk+1
A_ind_mwen(wk) = a_col
A_val_mwen(:,wk) = t(:)
endif
end do
if(wk /= 0) then
!$OMP CRITICAL
mrcc_col_shortcut(at_roww) = AtA_size+1
mrcc_N_col(at_roww) = wk
if (AtA_size+wk > size(mrcc_AtA_ind,1)) then
print *, AtA_size+wk , size(mrcc_AtA_ind,1)
stop 'too small'
endif
do i=1,wk
mrcc_AtA_ind(AtA_size+i) = A_ind_mwen(i)
do s=1,N_states
mrcc_AtA_val(s,AtA_size+i) = A_val_mwen(s,i)
enddo
enddo
AtA_size += wk
!$OMP END CRITICAL
end if
end do
!$OMP END DO NOWAIT
deallocate (A_ind_mwen, A_val_mwen, As2_val_mwen, t)
!$OMP END PARALLEL
print *, "ATA SIZE", ata_size
END_PROVIDER

265
plugins/MRCC_Utils/davidson.irp.f
View File

@ -207,19 +207,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
! -------------------------------------------
! do l=1,N_st_diag
! do k=1,N_st_diag
! do iter2=1,iter-1
! h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze)
! h(k,iter,l,iter2) = h(k,iter2,l,iter)
! enddo
! enddo
! do k=1,l
! h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze)
! h(l,iter,k,iter) = h(k,iter,l,iter)
! enddo
! enddo
call dgemm('T','N', N_st_diag*iter, N_st_diag, sze, &
1.d0, U, size(U,1), W(1,1,iter), size(W,1), &
0.d0, h(1,1,1,iter), size(h,1)*size(h,2))
@ -328,20 +315,10 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
! -----------
do k=1,N_st_diag
energies(k) = lambda(k)
do i=1,sze
u_in(i,k) = 0.d0
enddo
enddo
! do k=1,N_st_diag
! do i=1,sze
! do iter2=1,iter
! do l=1,N_st_diag
! u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1)
! enddo
! enddo
! enddo
! enddo
call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, &
U, size(U,1), y, N_st_diag*davidson_sze_max, &
@ -349,6 +326,9 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
enddo
do k=1,N_st_diag
energies(k) = lambda(k)
enddo
write_buffer = '===== '
do i=1,N_st
write_buffer = trim(write_buffer)//' ================ ================'
@ -570,7 +550,7 @@ subroutine davidson_diag_mrcc_hs2(dets_in,u_in,dim_in,energies,sze,N_st,N_st_dia
integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit, istate
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(inout) :: u_in(dim_in,N_st_diag)
double precision, intent(out) :: energies(N_st)
double precision, intent(out) :: energies(N_st_diag)
double precision, allocatable :: H_jj(:), S2_jj(:)
double precision :: diag_h_mat_elem
@ -648,7 +628,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
integer :: k_pairs, kl
integer :: iter2
double precision, allocatable :: W(:,:), U(:,:), S(:,:)
double precision, allocatable :: W(:,:), U(:,:), S(:,:), overlap(:,:)
double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:)
double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:)
double precision :: diag_h_mat_elem
@ -660,8 +640,10 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
include 'constants.include.F'
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda
if (N_st_diag > sze) then
stop 'error in Davidson : N_st_diag > sze'
if (N_st_diag*3 > sze) then
print *, 'error in Davidson :'
print *, 'Increase n_det_max_jacobi to ', N_st_diag*3
stop -1
endif
PROVIDE nuclear_repulsion
@ -686,7 +668,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
write(iunit,'(A)') trim(write_buffer)
write_buffer = ' Iter'
do i=1,N_st
write_buffer = trim(write_buffer)//' Energy S^2 Residual'
write_buffer = trim(write_buffer)//' Energy S^2 Residual '
enddo
write(iunit,'(A)') trim(write_buffer)
write_buffer = '===== '
@ -698,26 +680,19 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
integer, external :: align_double
sze_8 = align_double(sze)
double precision :: delta
if (s2_eig) then
delta = 1.d0
else
delta = 0.d0
endif
itermax = min(davidson_sze_max, sze/N_st_diag)
allocate( &
W(sze_8,N_st_diag*itermax), &
U(sze_8,N_st_diag*itermax), &
S(sze_8,N_st_diag*itermax), &
h(N_st_diag*itermax,N_st_diag*itermax), &
y(N_st_diag*itermax,N_st_diag*itermax), &
s_(N_st_diag*itermax,N_st_diag*itermax), &
s_tmp(N_st_diag*itermax,N_st_diag*itermax), &
W(sze_8,N_st_diag*itermax), &
U(sze_8,N_st_diag*itermax), &
S(sze_8,N_st_diag*itermax), &
h(N_st_diag*itermax,N_st_diag*itermax), &
y(N_st_diag*itermax,N_st_diag*itermax), &
s_(N_st_diag*itermax,N_st_diag*itermax), &
s_tmp(N_st_diag*itermax,N_st_diag*itermax), &
residual_norm(N_st_diag), &
c(N_st_diag*itermax), &
s2(N_st_diag*itermax), &
c(N_st_diag*itermax), &
s2(N_st_diag*itermax), &
overlap(N_st_diag*itermax,N_st_diag*itermax), &
lambda(N_st_diag*itermax))
h = 0.d0
@ -741,24 +716,18 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
converged = .False.
double precision :: r1, r2
do k=N_st+1,N_st_diag-2,2
do k=N_st+1,N_st_diag
u_in(k,k) = 10.d0
do i=1,sze
call random_number(r1)
call random_number(r2)
r1 = dsqrt(-2.d0*dlog(r1))
r2 = dtwo_pi*r2
u_in(i,k) = r1*dcos(r2)
u_in(i,k+1) = r1*dsin(r2)
enddo
enddo
do k=N_st_diag-1,N_st_diag
do i=1,sze
call random_number(r1)
call random_number(r2)
r1 = dsqrt(-2.d0*dlog(r1))
r2 = dtwo_pi*r2
u_in(i,k) = r1*dcos(r2)
enddo
do k=1,N_st_diag
call normalize(u_in(1,k),sze)
enddo
@ -788,14 +757,53 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
! -------------------------------------------
call dgemm('T','N', shift2, N_st_diag, sze, &
1.d0, U, size(U,1), W(1,shift+1), size(W,1), &
0.d0, h(1,shift+1), size(h,1))
call dgemm('T','N', shift2, shift2, sze, &
1.d0, U, size(U,1), W, size(W,1), &
0.d0, h, size(h,1))
call dgemm('T','N', shift2, N_st_diag, sze, &
1.d0, U, size(U,1), S(1,shift+1), size(S,1), &
0.d0, s_(1,shift+1), size(s_,1))
call dgemm('T','N', shift2, shift2, sze, &
1.d0, U, size(U,1), S, size(S,1), &
0.d0, s_, size(s_,1))
! ! Diagonalize S^2
! ! ---------------
!
! call lapack_diag(s2,y,s_,size(s_,1),shift2)
!
! ! Rotate H in the basis of eigenfunctions of s2
! ! ---------------------------------------------
!
! call dgemm('N','N',shift2,shift2,shift2, &
! 1.d0, h, size(h,1), y, size(y,1), &
! 0.d0, s_tmp, size(s_tmp,1))
!
! call dgemm('T','N',shift2,shift2,shift2, &
! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), &
! 0.d0, h, size(h,1))
!
! ! Damp interaction between different spin states
! ! ------------------------------------------------
!
! do k=1,shift2
! do l=1,shift2
! if (dabs(s2(k) - s2(l)) > 1.d0) then
! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l))))
! endif
! enddo
! enddo
!
! ! Rotate back H
! ! -------------
!
! call dgemm('N','T',shift2,shift2,shift2, &
! 1.d0, h, size(h,1), y, size(y,1), &
! 0.d0, s_tmp, size(s_tmp,1))
!
! call dgemm('N','N',shift2,shift2,shift2, &
! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), &
! 0.d0, h, size(h,1))
! Diagonalize h
! -------------
call lapack_diag(lambda,y,h,size(h,1),shift2)
@ -816,24 +824,73 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
enddo
if (s2_eig) then
logical :: state_ok(N_st_diag*davidson_sze_max)
logical :: state_ok(N_st_diag*davidson_sze_max)
do k=1,shift2
state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0)
enddo
else
state_ok(k) = .True.
endif
do k=1,shift2
if (.not. state_ok(k)) then
do l=k+1,shift2
if (state_ok(l)) then
call dswap(shift2, y(1,k), 1, y(1,l), 1)
call dswap(1, s2(k), 1, s2(l), 1)
call dswap(1, lambda(k), 1, lambda(l), 1)
state_ok(k) = .True.
state_ok(l) = .False.
exit
endif
enddo
endif
enddo
if (state_following) then
! Compute overlap with U_in
! -------------------------
integer :: order(N_st_diag)
double precision :: cmax
overlap = -1.d0
do k=1,shift2
state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0)
do i=1,shift2
overlap(k,i) = dabs(y(k,i))
enddo
enddo
do k=1,shift2
if (.not. state_ok(k)) then
do l=k+1,shift2
if (state_ok(l)) then
call dswap(shift2, y(1,k), 1, y(1,l), 1)
call dswap(1, s2(k), 1, s2(l), 1)
call dswap(1, lambda(k), 1, lambda(l), 1)
state_ok(k) = .True.
state_ok(l) = .False.
exit
endif
enddo
do k=1,N_st
cmax = -1.d0
do i=1,N_st
if (overlap(i,k) > cmax) then
cmax = overlap(i,k)
order(k) = i
endif
enddo
do i=1,shift2
overlap(order(k),i) = -1.d0
enddo
enddo
overlap = y
do k=1,N_st
l = order(k)
if (k /= l) then
y(1:shift2,k) = overlap(1:shift2,l)
endif
enddo
do k=1,N_st
overlap(k,1) = lambda(k)
overlap(k,2) = s2(k)
enddo
do k=1,N_st
l = order(k)
if (k /= l) then
lambda(k) = overlap(l,1)
s2(k) = overlap(l,2)
endif
enddo
endif
@ -851,11 +908,31 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
! -----------------------
do k=1,N_st_diag
do i=1,sze
U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
* (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz &
)/max(H_jj(i) - lambda (k),1.d-2)
enddo
if (state_ok(k)) then
do i=1,sze
U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
* (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz &
)/max(H_jj(i) - lambda (k),1.d-2)
enddo
else
! Randomize components with bad <S2>
do i=1,sze-2,2
call random_number(r1)
call random_number(r2)
r1 = dsqrt(-2.d0*dlog(r1))
r2 = dtwo_pi*r2
U(i,shift2+k) = r1*dcos(r2)
U(i+1,shift2+k) = r1*dsin(r2)
enddo
do i=sze-2+1,sze
call random_number(r1)
call random_number(r2)
r1 = dsqrt(-2.d0*dlog(r1))
r2 = dtwo_pi*r2
U(i,shift2+k) = r1*dcos(r2)
enddo
endif
if (k <= N_st) then
residual_norm(k) = u_dot_u(U(1,shift2+k),sze)
to_print(1,k) = lambda(k) + nuclear_repulsion
@ -878,20 +955,16 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
enddo
if (.not.converged) then
iter = itermax-1
endif
! Re-contract to u_in
! -----------
do k=1,N_st_diag
energies(k) = lambda(k)
enddo
call dgemm('N','N', sze, N_st_diag, shift2, &
1.d0, U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1))
call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, &
U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1))
enddo
do k=1,N_st_diag
energies(k) = lambda(k)
enddo
write_buffer = '===== '
@ -904,7 +977,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
deallocate ( &
W, residual_norm, &
U, &
U, overlap, &
c, S, &
h, &
y, s_, s_tmp, &
@ -970,12 +1043,12 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)&
!$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8, &
!$OMP N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij,istate_in)
!$OMP N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij, delta_ij_s2,istate_in)
allocate(vt(N_st_8,n),st(N_st_8,n))
Vt = 0.d0
St = 0.d0
!$OMP DO SCHEDULE(dynamic)
!$OMP DO SCHEDULE(guided)
do sh=1,shortcut(0,1)
do sh2=sh,shortcut(0,1)
exa = 0
@ -1017,8 +1090,8 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP DO SCHEDULE(dynamic)
!$OMP END DO
!$OMP DO SCHEDULE(guided)
do sh=1,shortcut(0,2)
do i=shortcut(sh,2),shortcut(sh+1,2)-1
org_i = sort_idx(i,2)
@ -1041,7 +1114,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
end do
end do
enddo
!$OMP END DO NOWAIT
!$OMP END DO
! --------------------------
! Begin Specific to dressing
@ -1055,6 +1128,8 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
do istate=1,N_st
vt (istate,i) = vt (istate,i) + delta_ij(istate_in,jj,ii)*ut(istate,j)
vt (istate,j) = vt (istate,j) + delta_ij(istate_in,jj,ii)*ut(istate,i)
st (istate,i) = st (istate,i) + delta_ij_s2(istate_in,jj,ii)*ut(istate,j)
st (istate,j) = st (istate,j) + delta_ij_s2(istate_in,jj,ii)*ut(istate,i)
enddo
enddo
enddo

4
plugins/MRCC_Utils/mrcc_dummy.irp.f
View File

@ -1,4 +0,0 @@
program pouet
end

430
plugins/MRCC_Utils/mrcc_utils.irp.f
View File

@ -77,18 +77,18 @@ BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ]
END_PROVIDER
BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ]
implicit none
BEGIN_DOC
! Dressing matrix in N_det basis
END_DOC
integer :: i,j,m
delta_ij = 0.d0
delta_ii = 0.d0
call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref)
END_PROVIDER
! BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ]
!&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ]
! implicit none
! BEGIN_DOC
! ! Dressing matrix in N_det basis
! END_DOC
! integer :: i,j,m
! delta_ij = 0.d0
! delta_ii = 0.d0
! call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref)
!
!END_PROVIDER
BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ]
@ -139,7 +139,6 @@ END_PROVIDER
integer :: mrcc_state
mrcc_state = N_states
do j=1,min(N_states,N_det)
do i=1,N_det
CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
@ -148,16 +147,33 @@ END_PROVIDER
if (diag_algorithm == "Davidson") then
! call davidson_diag_mrcc(psi_det,CI_eigenvectors_dressed,CI_electronic_energy_dressed,&
! size(CI_eigenvectors_dressed,1),N_det,N_states,N_states_diag,N_int,output_determinants,mrcc_state)
call davidson_diag_mrcc_HS2(psi_det,CI_eigenvectors_dressed,&
size(CI_eigenvectors_dressed,1), &
CI_electronic_energy_dressed,N_det,N_states,N_states_diag,N_int, &
output_determinants,mrcc_state)
call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,&
N_states_diag,size(CI_eigenvectors_dressed,1))
allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), &
eigenvalues(size(CI_electronic_energy_dressed,1)))
do j=1,min(N_states,N_det)
do i=1,N_det
eigenvectors(i,j) = psi_coef(i,j)
enddo
enddo
do mrcc_state=1,N_states
do j=mrcc_state,min(N_states,N_det)
do i=1,N_det
eigenvectors(i,j) = psi_coef(i,j)
enddo
enddo
call davidson_diag_mrcc_HS2(psi_det,eigenvectors,&
size(eigenvectors,1), &
eigenvalues,N_det,N_states,N_states_diag,N_int, &
output_determinants,mrcc_state)
CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state)
CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state)
enddo
do k=N_states+1,N_states_diag
CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k)
CI_electronic_energy_dressed(k) = eigenvalues(k)
enddo
call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,&
N_states_diag,size(CI_eigenvectors_dressed,1))
deallocate (eigenvectors,eigenvalues)
else if (diag_algorithm == "Lapack") then
@ -613,222 +629,114 @@ END_PROVIDER
call sort_det(psi_non_ref_sorted, psi_non_ref_sorted_idx, N_det_non_ref, N_int)
END_PROVIDER
BEGIN_PROVIDER [ double precision, rho_mrpt, (N_det_non_ref, N_states) ]
implicit none
integer :: i, j, k
double precision :: coef_mrpt(N_States),coef_array(N_states),hij,delta_e(N_states)
double precision :: hij_array(N_det_Ref),delta_e_array(N_det_ref,N_states)
integer :: number_of_holes, number_of_particles,nh,np
do i = 1, N_det_non_ref
print*,'i',i
nh = number_of_holes(psi_non_ref(1,1,i))
np = number_of_particles(psi_non_ref(1,1,i))
do j = 1, N_det_ref
do k = 1, N_States
coef_array(k) = psi_ref_coef(j,k)
enddo
call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,i), N_int, Hij_array(j))
call get_delta_e_dyall(psi_ref(1,1,j),psi_non_ref(1,1,i),coef_array,hij_array(j),delta_e)
! write(*,'(A7,x,100(F16.10,x))')'delta_e',delta_e(:)
do k = 1, N_states
delta_e_Array(j,k) = delta_e(k)
enddo
enddo
coef_mrpt = 0.d0
do k = 1, N_states
do j = 1, N_det_Ref
coef_mrpt(k) += psi_ref_coef(j,k) * hij_array(j) / delta_e_array(j,k)
enddo
enddo
BEGIN_PROVIDER [ double precision, dIj_unique, (hh_shortcut(hh_shortcut(0)+1)-1, N_states) ]
write(*,'(A7,X,100(F16.10,x))')'coef ',psi_non_ref_coef(i,1) , coef_mrpt(1),psi_non_ref_coef(i,2) , coef_mrpt(2)
print*, nh,np
do k = 1, N_States
if(dabs(coef_mrpt(k)) .le.1.d-10)then
rho_mrpt(i,k) = 0.d0
exit
endif
if(psi_non_ref_coef(i,k) / coef_mrpt(k) .lt.0d0)then
rho_mrpt(i,k) = 1.d0
else
rho_mrpt(i,k) = psi_non_ref_coef(i,k) / coef_mrpt(k)
endif
enddo
print*,'rho',rho_mrpt(i,:)
write(33,*)i,rho_mrpt(i,:)
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ]
&BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ]
implicit none
logical :: ok
integer :: i, j, k, s, II, pp, ppp, hh, ind, wk, nex, a_col, at_row
integer :: i, j, k, s, II, pp, ppp, hh, ind, wk, a_col, at_row
integer, external :: searchDet, unsortedSearchDet
integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2)
integer :: N, INFO, AtA_size, r1, r2
double precision , allocatable :: AtB(:), AtA_val(:), A_val(:,:), x(:), x_new(:), A_val_mwen(:)
double precision :: t, norm, cx, res
integer, allocatable :: A_ind(:,:), lref(:), AtA_ind(:), A_ind_mwen(:), col_shortcut(:), N_col(:)
integer :: N, INFO, r1, r2
double precision , allocatable :: AtB(:), x(:), x_new(:), A_val_mwen(:,:), t(:)
double precision :: norm, cx, res
integer, allocatable :: lref(:), A_ind_mwen(:)
double precision :: phase
integer, allocatable :: pathTo(:), active_hh_idx(:), active_pp_idx(:)
logical, allocatable :: active(:)
double precision, allocatable :: rho_mrcc_init(:,:)
integer :: nactive
double precision, allocatable :: rho_mrcc_init(:)
integer :: a_coll, at_roww
nex = hh_shortcut(hh_shortcut(0)+1)-1
print *, "TI", nex, N_det_non_ref
allocate(pathTo(N_det_non_ref), active(nex))
allocate(active_pp_idx(nex), active_hh_idx(nex))
allocate(rho_mrcc_init(N_det_non_ref, N_states))
pathTo = 0
active = .false.
nactive = 0
do hh = 1, hh_shortcut(0)
do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
do II = 1, N_det_ref
call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
if(.not. ok) cycle
call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
if(.not. ok) cycle
ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
if(ind == -1) cycle
ind = psi_non_ref_sorted_idx(ind)
if(pathTo(ind) == 0) then
pathTo(ind) = pp
else
active(pp) = .true.
active(pathTo(ind)) = .true.
end if
end do
end do
end do
do hh = 1, hh_shortcut(0)
do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
if(active(pp)) then
nactive = nactive + 1
active_hh_idx(nactive) = hh
active_pp_idx(nactive) = pp
end if
end do
end do
print *, nactive, "inact/", size(active)
allocate(A_ind(0:N_det_ref+1, nactive), A_val(N_det_ref+1, nactive))
allocate(AtA_ind(N_det_ref * nactive), AtA_val(N_det_ref * nactive))
allocate(x(nex), AtB(nex))
allocate(N_col(nactive), col_shortcut(nactive))
allocate(x_new(nex))
print *, "TI", hh_nex, N_det_non_ref
allocate(rho_mrcc_init(N_det_non_ref))
allocate(x_new(hh_nex))
allocate(x(hh_nex), AtB(hh_nex))
x = 0d0
do s=1, N_states
A_val = 0d0
A_ind = 0
AtA_ind = 0
AtB = 0d0
AtA_val = 0d0
x = 0d0
N_col = 0
col_shortcut = 0
!$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int, A_val, A_ind)&
!$OMP shared(s, hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, psi_non_ref_sorted_idx, psi_ref, N_det_ref)&
!$OMP shared(active, active_hh_idx, active_pp_idx, nactive) &
!$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh)
allocate(lref(N_det_non_ref))
!$OMP DO schedule(static,10)
do ppp=1,nactive
pp = active_pp_idx(ppp)
hh = active_hh_idx(ppp)
lref = 0
do II = 1, N_det_ref
call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
if(.not. ok) cycle
call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
if(.not. ok) cycle
ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
if(ind /= -1) then
call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int)
if (phase > 0.d0) then
lref(psi_non_ref_sorted_idx(ind)) = II
else
lref(psi_non_ref_sorted_idx(ind)) = -II
endif
end if
end do
wk = 0
do i=1, N_det_non_ref
if(lref(i) > 0) then
wk += 1
A_val(wk, ppp) = psi_ref_coef(lref(i), s)
A_ind(wk, ppp) = i
else if(lref(i) < 0) then
wk += 1
A_val(wk, ppp) = -psi_ref_coef(-lref(i), s)
A_ind(wk, ppp) = i
end if
end do
A_ind(0,ppp) = wk
end do
!$OMP END DO
deallocate(lref)
!$OMP END PARALLEL
print *, 'Done building A_val, A_ind'
AtA_size = 0
col_shortcut = 0
N_col = 0
integer :: a_coll, at_roww
!$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, A_ind, A_val, x, N_det_ref, nex, N_det_non_ref)&
!$OMP private(at_row, a_col, t, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)&
!$OMP shared(col_shortcut, N_col, AtB, AtA_size, AtA_val, AtA_ind, s, nactive, active_pp_idx)
allocate(A_val_mwen(nex), A_ind_mwen(nex))
do s=1,N_states
AtB(:) = 0.d0
!$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, active_excitation_to_determinants_idx,&
!$OMP active_excitation_to_determinants_val, x, N_det_ref, hh_nex, N_det_non_ref) &
!$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)&
!$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx)
!$OMP DO schedule(dynamic, 100)
do at_roww = 1, nactive ! nex
do at_roww = 1, n_exc_active ! hh_nex
at_row = active_pp_idx(at_roww)
wk = 0
if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", nex
do i=1,A_ind(0,at_roww)
j = active_pp_idx(i)
AtB(at_row) = AtB(at_row) + psi_non_ref_coef(A_ind(i, at_roww), s) * A_val(i, at_roww)
do i=1,active_excitation_to_determinants_idx(0,at_roww)
AtB(at_row) = AtB(at_row) + psi_non_ref_coef(active_excitation_to_determinants_idx(i, at_roww), s) * active_excitation_to_determinants_val(s,i, at_roww)
end do
do a_coll = 1, nactive
a_col = active_pp_idx(a_coll)
t = 0d0
r1 = 1
r2 = 1
do while ((A_ind(r1, at_roww) /= 0).and.(A_ind(r2, a_coll) /= 0))
if(A_ind(r1, at_roww) > A_ind(r2, a_coll)) then
r2 = r2+1
else if(A_ind(r1, at_roww) < A_ind(r2, a_coll)) then
r1 = r1+1
else
t = t - A_val(r1, at_roww) * A_val(r2, a_coll)
r1 = r1+1
r2 = r2+1
end if
end do
if(a_col == at_row) then
t = t + 1.d0
end if
if(t /= 0.d0) then
wk += 1
A_ind_mwen(wk) = a_col
A_val_mwen(wk) = t
end if
end do
if(wk /= 0) then
!$OMP CRITICAL
col_shortcut(at_roww) = AtA_size+1
N_col(at_roww) = wk
if (AtA_size+wk > size(AtA_ind,1)) then
print *, AtA_size+wk , size(AtA_ind,1)
stop 'too small'
endif
do i=1,wk
AtA_ind(AtA_size+i) = A_ind_mwen(i)
AtA_val(AtA_size+i) = A_val_mwen(i)
enddo
AtA_size += wk
!$OMP END CRITICAL
end if
end do
!$OMP END DO NOWAIT
deallocate (A_ind_mwen, A_val_mwen)
!$OMP END DO
!$OMP END PARALLEL
print *, "ATA SIZE", ata_size
x = 0d0
X(:) = 0d0
do a_coll = 1, nactive
do a_coll = 1, n_exc_active
a_col = active_pp_idx(a_coll)
X(a_col) = AtB(a_col)
end do
rho_mrcc_init = 0d0
!$OMP PARALLEL default(shared) &
!$OMP private(lref, hh, pp, II, myMask, myDet, ok, ind, phase)
allocate(lref(N_det_ref))
!$OMP DO schedule(static, 1)
do hh = 1, hh_shortcut(0)
do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
if(active(pp)) cycle
if(is_active_exc(pp)) cycle
lref = 0
AtB(pp) = 0.d0
do II=1,N_det_ref
call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
if(.not. ok) cycle
@ -838,81 +746,74 @@ END_PROVIDER
if(ind == -1) cycle
ind = psi_non_ref_sorted_idx(ind)
call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int)
X(pp) += psi_ref_coef(II,s)**2
AtB(pp) += psi_non_ref_coef(ind, s) * psi_ref_coef(II, s) * phase
lref(II) = ind
if(phase < 0d0) lref(II) = -ind
if(phase < 0.d0) lref(II) = -ind
end do
X(pp) = AtB(pp) / X(pp)
X(pp) = AtB(pp)
do II=1,N_det_ref
if(lref(II) > 0) then
rho_mrcc_init(lref(II),s) = psi_ref_coef(II,s) * X(pp)
rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp)
else if(lref(II) < 0) then
rho_mrcc_init(-lref(II),s) = -psi_ref_coef(II,s) * X(pp)
rho_mrcc_init(-lref(II)) = -psi_ref_coef(II,s) * X(pp)
end if
end do
end do
end do
!$OMP END DO
deallocate(lref)
!$OMP END PARALLEL
x_new = x
double precision :: factor, resold
factor = 1.d0
resold = huge(1.d0)
do k=0,100000
!$OMP PARALLEL default(shared) private(cx, i, j, a_col, a_coll)
do k=0,hh_nex*hh_nex
!$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll)
!$OMP DO
do i=1,N_det_non_ref
rho_mrcc(i,s) = rho_mrcc_init(i,s) ! 0d0
rho_mrcc(i,s) = rho_mrcc_init(i)
enddo
!$OMP END DO
!$OMP END DO NOWAIT
!$OMP DO
do a_coll = 1, nactive !: nex
do a_coll = 1, n_exc_active
a_col = active_pp_idx(a_coll)
cx = 0d0
do i=col_shortcut(a_coll), col_shortcut(a_coll) + N_col(a_coll) - 1
cx = cx + x(AtA_ind(i)) * AtA_val(i)
cx = 0.d0
do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1
cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i)
end do
x_new(a_col) = AtB(a_col) + cx * factor
end do
!$OMP END DO
!$OMP END PARALLEL
res = 0.d0
if (res < resold) then
do a_coll=1,nactive ! nex
a_col = active_pp_idx(a_coll)
do j=1,N_det_non_ref
i = A_ind(j,a_coll)
if (i==0) exit
rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col)
enddo
res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col))
X(a_col) = X_new(a_col)
end do
factor = 1.d0
else
factor = -factor * 0.5d0
do a_coll=1,n_exc_active
a_col = active_pp_idx(a_coll)
do j=1,N_det_non_ref
i = active_excitation_to_determinants_idx(j,a_coll)
if (i==0) exit
rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * X_new(a_col)
enddo
res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col))
X(a_col) = X_new(a_col)
end do
if (res > resold) then
factor = factor * 0.5d0
endif
resold = res
if(mod(k, 100) == 0) then
if(iand(k, 4095) == 0) then
print *, "res ", k, res
end if
if(res < 1d-9) exit
if(res < 1d-12) exit
end do
norm = 0.d0
do i=1,N_det_non_ref
norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s)
@ -1073,6 +974,9 @@ END_PROVIDER
norm = norm*f
print *, 'norm of |T Psi_0> = ', dsqrt(norm)
if (dsqrt(norm) > 1.d0) then
stop 'Error : Norm of the SD larger than the norm of the reference.'
endif
do i=1,N_det_ref
norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s)
@ -1084,7 +988,7 @@ END_PROVIDER
! rho_mrcc now contains the product of the scaling factors and the
! normalization constant
dIj_unique(:size(X), s) = X(:)
dIj_unique(1:size(X), s) = X(1:size(X))
end do
END_PROVIDER
@ -1096,17 +1000,14 @@ BEGIN_PROVIDER [ double precision, dij, (N_det_ref, N_det_non_ref, N_states) ]
integer :: s,i,j
double precision, external :: get_dij_index
print *, "computing amplitudes..."
!$OMP PARALLEL DEFAULT(shared) PRIVATE(s,i,j)
do s=1, N_states
!$OMP DO
do i=1, N_det_non_ref
do j=1, N_det_ref
!DIR$ FORCEINLINE
dij(j, i, s) = get_dij_index(j, i, s, N_int)
end do
end do
!$OMP END DO
end do
!$OMP END PARALLEL
print *, "done computing amplitudes"
END_PROVIDER
@ -1116,15 +1017,23 @@ END_PROVIDER
double precision function get_dij_index(II, i, s, Nint)
integer, intent(in) :: II, i, s, Nint
double precision, external :: get_dij
double precision :: HIi, phase
double precision :: HIi, phase,delta_e_final(N_states)
if(lambda_type == 0) then
call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int)
get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase
get_dij_index = get_dij_index * rho_mrcc(i,s)
else
else if(lambda_type == 1) then
call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi)
get_dij_index = HIi * lambda_mrcc(s, i)
else if(lambda_type == 2) then
call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int)
get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase
get_dij_index = get_dij_index
else if(lambda_type == 3) then
call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi)
call get_delta_e_dyall_fast(psi_ref(1,1,II),psi_non_ref(1,1,i),delta_e_final)
get_dij_index = HIi * rho_mrpt(i, s) / delta_e_final(s)
end if
end function
@ -1182,9 +1091,21 @@ end function
BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ]
&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ]
&BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ]
&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ]
&BEGIN_PROVIDER [ integer, hh_nex ]
implicit none
BEGIN_DOC
!
! hh_exists :
!
! pp_exists :
!
! hh_shortcut :
!
! hh_nex : Total number of excitation operators
!
END_DOC
integer*2,allocatable :: num(:,:)
integer :: exc(0:2, 2, 2), degree, n, on, s, l, i
integer*2 :: h1, h2, p1, p2
@ -1250,6 +1171,7 @@ end function
end if
end do
end do
hh_nex = hh_shortcut(hh_shortcut(0)+1)-1
END_PROVIDER

56
plugins/MRPT/MRPT_Utils.main.irp.f Normal file
View File

@ -0,0 +1,56 @@
program MRPT_Utils
implicit none
read_wf = .True.
touch read_wf
! call routine
! call routine_2
call routine_3
end
subroutine routine_3
implicit none
integer :: i,j
!provide fock_virt_total_spin_trace
provide delta_ij
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
do i = 1, N_States
print*,'State',i
write(*,'(A12,X,I3,A3,XX,F20.16)') ' PT2 ', i,' = ', second_order_pt_new(i)
write(*,'(A12,X,I3,A3,XX,F22.16)') ' E ', i,' = ', psi_ref_average_value(i)
write(*,'(A12,X,I3,A3,XX,F22.16)') ' E+PT2 ', i,' = ', psi_ref_average_value(i)+second_order_pt_new(i)
write(*,'(A12,X,I3,A3,XX,F22.16)') ' E dressed ', i,' = ', CI_dressed_pt2_new_energy(i)
write(*,'(A12,X,I3,A3,XX,F20.16)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i)
print*,'coef before and after'
do j = 1, N_det_ref
print*,psi_ref_coef(j,i),CI_dressed_pt2_new_eigenvectors(j,i)
enddo
enddo
if(save_heff_eigenvectors)then
call save_wavefunction_general(N_det_ref,N_states_diag_heff,psi_ref,N_det_ref,CI_dressed_pt2_new_eigenvectors)
endif
! print*, 'neutral = ',psi_ref_coef(1,1),CI_dressed_pt2_new_eigenvectors(1,1)
! print*, 'ionic = ',psi_ref_coef(3,1),CI_dressed_pt2_new_eigenvectors(3,1)
end
subroutine routine_2
implicit none
integer :: i
do i = 1, n_core_inact_orb
print*,fock_core_inactive_total(i,1,1),fock_core_inactive(i)
enddo
double precision :: accu
accu = 0.d0
do i = 1, n_act_orb
integer :: j_act_orb
j_act_orb = list_act(i)
accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb,1)
print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb,1),one_body_dm_mo_beta(j_act_orb,j_act_orb,1)
enddo
print*,'accu = ',accu
end

1
plugins/MRPT/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
MRPT_Utils Selectors_full Psiref_CAS Generators_CAS

14
plugins/MRPT/README.rst Normal file
View File

@ -0,0 +1,14 @@
====
MRPT
====
Executables for Multi-reference perturbation.
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.

38
plugins/MRPT/mrpt.irp.f Normal file
View File

@ -0,0 +1,38 @@
program MRPT
implicit none
BEGIN_DOC
! TODO
END_DOC
print *, ' _/ '
print *, ' -:\_?, _Jm####La '
print *, 'J"(:" > _]#AZ#Z#UUZ##, '
print *, '_,::./ %(|i%12XmX1*1XL _?, '
print *, ' \..\ _\(vmWQwodY+ia%lnL _",/ ( '
print *, ' .:< ]J=mQD?WXn<uQWmmvd, -.-:=!'
print *, ' "{Z jC]QW|=3Zv)Bi3BmXv3 = _7'
print *, ' ]h[Z6)WQ;)jZs]C;|$BZv+, : ./ '
print *, ' -#sJX%$Wmm#ev]hinW#Xi:` c ; '
print *, ' #X#X23###1}vI$WWmX1>|,)nr" '
print *, ' 4XZ#Xov1v}=)vnXAX1nnv;1n" '
print *, ' ]XX#ZXoovvvivnnnlvvo2*i7 '
print *, ' "23Z#1S2oo2XXSnnnoSo2>v" '
print *, ' miX#L -~`""!!1}oSoe|i7 '
print *, ' 4cn#m, v221=|v[ '
print *, ' ]hI3Zma,;..__wXSe=+vo '
print *, ' ]Zov*XSUXXZXZXSe||vo2 '
print *, ' ]Z#><iiii|i||||==vn2( '
print *, ' ]Z#i<ii||+|=||=:{no2[ '
print *, ' ]ZUsiiiiivi|=||=vo22[ '
print *, ' ]XZvlliiIi|i=|+|vooo '
print *, ' =v1llli||||=|||||lii( '
print *, ' ]iillii||||||||=>=|< '
print *, ' -ziiiii||||||+||==+> '
print *, ' -%|+++||=|=+|=|==/ '
print *, ' -a>====+|====-:- '
print *, ' "~,- -- /- '
print *, ' -. )> '
print *, ' .~ +- '
print *, ' . .... : . '
print *, ' -------~ '
print *, ''
end

58
plugins/MRPT/print_1h2p.irp.f Normal file
View File

@ -0,0 +1,58 @@
program print_1h2p
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
provide one_anhil_one_creat_inact_virt
end
subroutine routine_2
implicit none
integer :: i,j,degree
double precision :: hij
do i =1, n_core_inact_orb
write(*,'(I3,x,100(F16.10,X))')list_core_inact(i),fock_core_inactive_total_spin_trace(list_core_inact(i),1)
enddo
print*,''
do i =1, n_virt_orb
write(*,'(I3,x,100(F16.10,X))')list_virt(i),fock_virt_total_spin_trace(list_virt(i),1)
enddo
stop
do i = 1, n_virt_orb
do j = 1, n_inact_orb
if(dabs(one_anhil_one_creat_inact_virt(j,i,1)) .lt. 1.d-10)cycle
write(*,'(I3,x,I3,X,100(F16.10,X))')list_virt(i),list_inact(j),one_anhil_one_creat_inact_virt(j,i,1)
enddo
enddo
end
subroutine routine_3
implicit none
double precision,allocatable :: matrix_1h2p(:,:,:)
double precision :: accu(2)
allocate (matrix_1h2p(N_det_ref,N_det_ref,N_states))
integer :: i,j,istate
accu = 0.d0
matrix_1h2p = 0.d0
!call H_apply_mrpt_1h2p(matrix_1h2p,N_det_ref)
call give_1h2p_contrib(matrix_1h2p)
do istate = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(istate) += matrix_1h2p(i,j,istate) * psi_coef(i,istate) * psi_coef(j,istate)
enddo
enddo
print*,accu(istate)
enddo
call contrib_1h2p_dm_based(accu)
print*,accu(:)
deallocate (matrix_1h2p)
end

20
plugins/MRPT_Utils/EZFIO.cfg
View File

@ -5,3 +5,23 @@ interface: ezfio,provider,ocaml
default: True
[save_heff_eigenvectors]
type: logical
doc: If true, you save the eigenvectors of the effective hamiltonian
interface: ezfio,provider,ocaml
default: False
[pure_state_specific_mrpt2]
type: logical
doc: If true, diagonalize the dressed matrix for each state and do a state following of the initial states
interface: ezfio,provider,ocaml
default: True
[N_states_diag_heff]
type: States_number
doc: Number of eigenvectors obtained with the effective hamiltonian
interface: ezfio,provider,ocaml
default: 1

8
plugins/MRPT_Utils/H_apply.irp.f
View File

@ -23,6 +23,7 @@ print s
s = H_apply("mrpt_1h")
s.filter_only_1h()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -43,6 +44,7 @@ print s
s = H_apply("mrpt_1p")
s.filter_only_1p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -63,6 +65,7 @@ print s
s = H_apply("mrpt_1h1p")
s.filter_only_1h1p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -83,6 +86,7 @@ print s
s = H_apply("mrpt_2p")
s.filter_only_2p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -103,6 +107,7 @@ print s
s = H_apply("mrpt_2h")
s.filter_only_2h()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -124,6 +129,7 @@ print s
s = H_apply("mrpt_1h2p")
s.filter_only_1h2p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -144,6 +150,7 @@ print s
s = H_apply("mrpt_2h1p")
s.filter_only_2h1p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet
@ -164,6 +171,7 @@ print s
s = H_apply("mrpt_2h2p")
s.filter_only_2h2p()
s.unset_skip()
s.data["parameters"] = ", delta_ij_, Ndet"
s.data["declarations"] += """
integer, intent(in) :: Ndet

43
plugins/MRPT_Utils/MRPT_Utils.main.irp.f
View File

@ -1,43 +0,0 @@
program MRPT_Utils
implicit none
read_wf = .True.
touch read_wf
! call routine
! call routine_2
call routine_3
end
subroutine routine_3
implicit none
!provide fock_virt_total_spin_trace
provide delta_ij
print *, 'N_det = ', N_det
print *, 'N_states = ', N_states
print *, 'PT2 = ', second_order_pt_new(1)
print *, 'E = ', CI_energy(1)
print *, 'E+PT2 = ', CI_energy(1)+second_order_pt_new(1)
print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******'
print *, 'E dressed= ', CI_dressed_pt2_new_energy(1)
end
subroutine routine_2
implicit none
integer :: i
do i = 1, n_core_inact_orb
print*,fock_core_inactive_total(i,1,1),fock_core_inactive(i)
enddo
double precision :: accu
accu = 0.d0
do i = 1, n_act_orb
integer :: j_act_orb
j_act_orb = list_act(i)
accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb,1)
print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb,1),one_body_dm_mo_beta(j_act_orb,j_act_orb,1)
enddo
print*,'accu = ',accu
end

2
plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Determinants Selectors_full Generators_full Davidson
Determinants Davidson

193
plugins/MRPT_Utils/density_matrix_based.irp.f Normal file
View File

@ -0,0 +1,193 @@
subroutine contrib_1h2p_dm_based(accu)
implicit none
integer :: i_i,i_r,i_v,i_a,i_b
integer :: i,r,v,a,b
integer :: ispin,jspin
integer :: istate
double precision, intent(out) :: accu(N_states)
double precision :: active_int(n_act_orb,2)
double precision :: delta_e(n_act_orb,2,N_states)
double precision :: get_mo_bielec_integral
accu = 0.d0
!do i_i = 1, 1
do i_i = 1, n_inact_orb
i = list_inact(i_i)
! do i_r = 1, 1
do i_r = 1, n_virt_orb
r = list_virt(i_r)
! do i_v = 1, 1
do i_v = 1, n_virt_orb
v = list_virt(i_v)
do i_a = 1, n_act_orb
a = list_act(i_a)
active_int(i_a,1) = get_mo_bielec_integral(i,a,r,v,mo_integrals_map) ! direct
active_int(i_a,2) = get_mo_bielec_integral(i,a,v,r,mo_integrals_map) ! exchange
do istate = 1, N_states
do jspin=1, 2
delta_e(i_a,jspin,istate) = one_anhil(i_a,jspin,istate) &
- fock_virt_total_spin_trace(r,istate) &
- fock_virt_total_spin_trace(v,istate) &
+ fock_core_inactive_total_spin_trace(i,istate)
delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate)
enddo
enddo
enddo
do i_a = 1, n_act_orb
a = list_act(i_a)
do i_b = 1, n_act_orb
! do i_b = i_a, i_a
b = list_act(i_b)
do ispin = 1, 2 ! spin of (i --> r)
do jspin = 1, 2 ! spin of (a --> v)
if(ispin == jspin .and. r.le.v)cycle ! condition not to double count
do istate = 1, N_states
if(ispin == jspin)then
accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_mo_spin_index(a,b,istate,ispin) &
* (active_int(i_b,1) - active_int(i_b,2)) &
* delta_e(i_a,jspin,istate)
else
accu(istate) += active_int(i_a,1) * one_body_dm_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) &
* active_int(i_b,1)
endif
enddo
enddo
enddo
enddo
enddo
enddo
enddo
enddo
end
subroutine contrib_2h1p_dm_based(accu)
implicit none
integer :: i_i,i_j,i_v,i_a,i_b
integer :: i,j,v,a,b
integer :: ispin,jspin
integer :: istate
double precision, intent(out) :: accu(N_states)
double precision :: active_int(n_act_orb,2)
double precision :: delta_e(n_act_orb,2,N_states)
double precision :: get_mo_bielec_integral
accu = 0.d0
do i_i = 1, n_inact_orb
i = list_inact(i_i)
do i_j = 1, n_inact_orb
j = list_inact(i_j)
do i_v = 1, n_virt_orb
v = list_virt(i_v)
do i_a = 1, n_act_orb
a = list_act(i_a)
active_int(i_a,1) = get_mo_bielec_integral(i,j,v,a,mo_integrals_map) ! direct
active_int(i_a,2) = get_mo_bielec_integral(i,j,a,v,mo_integrals_map) ! exchange
do istate = 1, N_states
do jspin=1, 2
! delta_e(i_a,jspin,istate) =
!
delta_e(i_a,jspin,istate) = one_creat(i_a,jspin,istate) - fock_virt_total_spin_trace(v,istate) &
+ fock_core_inactive_total_spin_trace(i,istate) &
+ fock_core_inactive_total_spin_trace(j,istate)
delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate)
enddo
enddo
enddo
do i_a = 1, n_act_orb
a = list_act(i_a)
do i_b = 1, n_act_orb
! do i_b = i_a, i_a
b = list_act(i_b)
do ispin = 1, 2 ! spin of (i --> v)
do jspin = 1, 2 ! spin of (j --> a)
if(ispin == jspin .and. i.le.j)cycle ! condition not to double count
do istate = 1, N_states
if(ispin == jspin)then
accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) &
* (active_int(i_b,1) - active_int(i_b,2)) &
* delta_e(i_a,jspin,istate)
else
accu(istate) += active_int(i_a,1) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) &
* active_int(i_b,1)
endif
enddo
enddo
enddo
enddo
enddo
enddo
enddo
enddo
end
subroutine contrib_2p_dm_based(accu)
implicit none
integer :: i_r,i_v,i_a,i_b,i_c,i_d
integer :: r,v,a,b,c,d
integer :: ispin,jspin
integer :: istate
double precision, intent(out) :: accu(N_states)
double precision :: active_int(n_act_orb,n_act_orb,2)
double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states)
double precision :: get_mo_bielec_integral
accu = 0.d0
do i_r = 1, n_virt_orb
r = list_virt(i_r)
do i_v = 1, n_virt_orb
v = list_virt(i_v)
do i_a = 1, n_act_orb
a = list_act(i_a)
do i_b = 1, n_act_orb
b = list_act(i_b)
active_int(i_a,i_b,1) = get_mo_bielec_integral(a,b,r,v,mo_integrals_map) ! direct
active_int(i_a,i_b,2) = get_mo_bielec_integral(a,b,v,r,mo_integrals_map) ! direct
do istate = 1, N_states
do jspin=1, 2 ! spin of i_a
do ispin = 1, 2 ! spin of i_b
delta_e(i_a,i_b,jspin,ispin,istate) = two_anhil(i_a,i_b,jspin,ispin,istate) &
- fock_virt_total_spin_trace(r,istate) &
- fock_virt_total_spin_trace(v,istate)
delta_e(i_a,i_b,jspin,ispin,istate) = 1.d0/delta_e(i_a,i_b,jspin,ispin,istate)
enddo
enddo
enddo
enddo
enddo
! diagonal terms
do i_a = 1, n_act_orb
a = list_act(i_a)
do i_b = 1, n_act_orb
b = list_act(i_b)
do ispin = 1, 2 ! spin of (a --> r)
do jspin = 1, 2 ! spin of (b --> v)
if(ispin == jspin .and. r.le.v)cycle ! condition not to double count
if(ispin == jspin .and. a.le.b)cycle ! condition not to double count
do istate = 1, N_states
if(ispin == jspin)then
double precision :: contrib_spin
if(ispin == 1)then
contrib_spin = two_body_dm_aa_diag_act(i_a,i_b)
else
contrib_spin = two_body_dm_bb_diag_act(i_a,i_b)
endif
accu(istate) += (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) * contrib_spin &
* (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) &
* delta_e(i_a,i_b,ispin,jspin,istate)
else
accu(istate) += 0.5d0 * active_int(i_a,i_b,1) * two_body_dm_ab_diag_act(i_a,i_b) * delta_e(i_a,i_b,ispin,jspin,istate) &
* active_int(i_a,i_b,1)
endif
enddo
enddo
enddo
enddo
enddo
enddo
enddo
end

704
plugins/MRPT_Utils/energies_cas.irp.f
View File

File diff suppressed because it is too large Load Diff

319
plugins/MRPT_Utils/excitations_cas.irp.f
View File

@ -25,6 +25,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, &
integer :: det_tmp(N_int), det_tmp_bis(N_int)
double precision :: phase
double precision :: norm_factor
! print*, orb,hole_particle,spin_exc
elec_num_tab_local = 0
do i = 1, ndet
@ -36,6 +37,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, &
exit
endif
enddo
! print*, elec_num_tab_local(1),elec_num_tab_local(2)
if(hole_particle == 1)then
do i = 1, ndet
call set_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int)
@ -212,52 +214,97 @@ double precision function diag_H_mat_elem_no_elec_check(det_in,Nint)
core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb)
enddo
enddo
! print*,'core_act = ',core_act
! print*,'alpha_alpha = ',alpha_alpha
! print*,'alpha_beta = ',alpha_beta
! print*,'beta_beta = ',beta_beta
! print*,'mono_elec = ',mono_elec
! do i = 1, n_core_inact_orb
! iorb = list_core_inact(i)
! diag_H_mat_elem_no_elec_check += 2.d0 * fock_core_inactive_total_spin_trace(iorb,1)
! enddo
!!!!!!!!!!!!
return
!!!!!!!!!!!!
! alpha - alpha
do i = 1, n_core_inact_orb
iorb = list_core_inact(i)
diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb)
do j = i+1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb)
enddo
enddo
do i = 1, n_core_inact_orb
iorb = list_core_inact(i)
diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb)
do j = i+1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb)
enddo
enddo
do i = 1, n_core_inact_orb
iorb = list_core_inact(i)
do j = 1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
end
double precision function diag_H_mat_elem_no_elec_check_no_spin(det_in,Nint)
implicit none
BEGIN_DOC
! Computes <i|H|i>
END_DOC
integer,intent(in) :: Nint
integer(bit_kind),intent(in) :: det_in(Nint,2)
integer :: i, j, iorb, jorb
integer :: occ(Nint*bit_kind_size,2)
integer :: elec_num_tab_local(2)
double precision :: core_act
double precision :: alpha_alpha
double precision :: alpha_beta
double precision :: beta_beta
double precision :: mono_elec
core_act = 0.d0
alpha_alpha = 0.d0
alpha_beta = 0.d0
beta_beta = 0.d0
mono_elec = 0.d0
diag_H_mat_elem_no_elec_check_no_spin = 0.d0
call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int)
call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int)
! alpha - alpha
do i = 1, elec_num_tab_local(1)
iorb = occ(i,1)
diag_H_mat_elem_no_elec_check_no_spin += mo_mono_elec_integral(iorb,iorb)
mono_elec += mo_mono_elec_integral(iorb,iorb)
do j = i+1, elec_num_tab_local(1)
jorb = occ(j,1)
diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb)
alpha_alpha += mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
! beta - beta
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
diag_H_mat_elem_no_elec_check_no_spin += mo_mono_elec_integral(iorb,iorb)
mono_elec += mo_mono_elec_integral(iorb,iorb)
do j = i+1, elec_num_tab_local(2)
jorb = occ(j,2)
diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb)
beta_beta += mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
! alpha - beta
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
do j = 1, elec_num_tab_local(1)
jorb = occ(j,1)
diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb)
alpha_beta += mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
! alpha - core-act
do i = 1, elec_num_tab_local(1)
iorb = occ(i,1)
do j = 1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check_no_spin += 2.d0 * mo_bielec_integral_jj(jorb,iorb)
core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
! beta - core-act
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
do j = 1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check_no_spin += 2.d0 * mo_bielec_integral_jj(jorb,iorb)
core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb)
enddo
enddo
end
subroutine i_H_j_dyall(key_i,key_j,Nint,hij)
use bitmasks
implicit none
@ -389,6 +436,133 @@ subroutine i_H_j_dyall(key_i,key_j,Nint,hij)
end
subroutine i_H_j_dyall_no_spin(key_i,key_j,Nint,hij)
use bitmasks
implicit none
BEGIN_DOC
! Returns <i|H|j> where i and j are determinants
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hij
integer :: exc(0:2,2,2)
integer :: degree
double precision :: get_mo_bielec_integral
integer :: m,n,p,q
integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem_no_elec_check, phase,phase_2
integer :: n_occ_ab(2)
logical :: has_mipi(Nint*bit_kind_size)
double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size)
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
hij = 0.d0
!DIR$ FORCEINLINE
call get_excitation_degree(key_i,key_j,degree,Nint)
select case (degree)
case (2)
call get_double_excitation(key_i,key_j,exc,phase,Nint)
if (exc(0,1,1) == 1) then
! Mono alpha, mono beta
if(exc(1,1,1) == exc(1,1,2) .and. exc(1,1,2) == exc(1,2,1) )then
hij = 0.d0
else
hij = phase*get_mo_bielec_integral( &
exc(1,1,1), &
exc(1,1,2), &
exc(1,2,1), &
exc(1,2,2) ,mo_integrals_map)
endif
else if (exc(0,1,1) == 2) then
! Double alpha
hij = phase*get_mo_bielec_integral( &
exc(1,1,1), &
exc(2,1,1), &
exc(1,2,1), &
exc(2,2,1) ,mo_integrals_map)
else if (exc(0,1,2) == 2) then
! Double beta
hij = phase*get_mo_bielec_integral( &
exc(1,1,2), &
exc(2,1,2), &
exc(1,2,2), &
exc(2,2,2) ,mo_integrals_map)
endif
case (1)
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
!DIR$ FORCEINLINE
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
has_mipi = .False.
if (exc(0,1,1) == 1) then
! Mono alpha
m = exc(1,1,1)
p = exc(1,2,1)
do k = 1, n_occ_ab(1)
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, n_occ_ab(2)
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, n_occ_ab(1)
hij = hij + mipi(occ(k,1)) !- miip(occ(k,1))
enddo
do k = 1, n_occ_ab(2)
hij = hij + mipi(occ(k,2))
enddo
else
! Mono beta
m = exc(1,1,2)
p = exc(1,2,2)
do k = 1, n_occ_ab(2)
i = occ(k,2)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, n_occ_ab(1)
i = occ(k,1)
if (.not.has_mipi(i)) then
mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
has_mipi(i) = .True.
endif
enddo
do k = 1, n_occ_ab(1)
hij = hij + mipi(occ(k,1))
enddo
do k = 1, n_occ_ab(2)
hij = hij + mipi(occ(k,2)) !- miip(occ(k,2))
enddo
endif
hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) )
case (0)
double precision :: diag_H_mat_elem_no_elec_check_no_spin
hij = diag_H_mat_elem_no_elec_check_no_spin(key_i,Nint)
end select
end
subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target)
use bitmasks
implicit none
@ -414,6 +588,7 @@ subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coe
do j = 1, ndet
if(psi_coef_tmp(j)==0.d0)cycle
call i_H_j_dyall(psi_in(1,1,i),psi_in(1,1,j),N_int,hij)
! call i_H_j_dyall_no_spin(psi_in(1,1,i),psi_in(1,1,j),N_int,hij)
accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij
enddo
enddo
@ -502,6 +677,7 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij)
integer :: n_occ_ab(2)
logical :: has_mipi(Nint*bit_kind_size)
double precision :: mipi(Nint*bit_kind_size)
double precision :: diag_H_mat_elem
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
ASSERT (Nint > 0)
@ -598,9 +774,12 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij)
endif
hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) )
! hij = phase*(hij + mo_mono_elec_integral(m,p) )
case (0)
hij = diag_H_mat_elem_no_elec_check_no_exchange(key_i,Nint)
! hij = diag_H_mat_elem(key_i,Nint)
! hij = 0.d0
end select
end
@ -625,7 +804,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint)
! alpha - alpha
do i = 1, elec_num_tab_local(1)
iorb = occ(i,1)
diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb)
diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb)
do j = i+1, elec_num_tab_local(1)
jorb = occ(j,1)
diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb)
@ -635,7 +814,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint)
! beta - beta
do i = 1, elec_num_tab_local(2)
iorb = occ(i,2)
diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb)
diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb)
do j = i+1, elec_num_tab_local(2)
jorb = occ(j,2)
diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb)
@ -653,13 +832,16 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint)
enddo
! return
! alpha - core-act
do i = 1, elec_num_tab_local(1)
iorb = occ(i,1)
do j = 1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb)
core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb)
! core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb)
! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(1)
enddo
enddo
@ -669,7 +851,8 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint)
do j = 1, n_core_inact_orb
jorb = list_core_inact(j)
diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb)
core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb)
! core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb)
! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(2)
enddo
enddo
@ -706,3 +889,45 @@ subroutine u0_H_dyall_u0_no_exchange(energies,psi_in,psi_in_coef,ndet,dim_psi_in
energies(state_target) = accu
deallocate(psi_coef_tmp)
end
!subroutine u0_H_dyall_u0_no_exchange_bis(energies,psi_in,psi_in_active,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target)
subroutine u0_H_dyall_u0_no_exchange_bis(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target)
use bitmasks
implicit none
integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target
!integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in),psi_in_active(N_int,2,dim_psi_in)
integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in)
double precision, intent(in) :: psi_in_coef(dim_psi_coef,N_states_in)
double precision, intent(out) :: energies(N_states_in)
integer :: i,j
double precision :: hij,accu
energies = 0.d0
accu = 0.d0
double precision, allocatable :: psi_coef_tmp(:)
allocate(psi_coef_tmp(ndet))
do i = 1, ndet
psi_coef_tmp(i) = psi_in_coef(i,state_target)
enddo
double precision :: hij_bis,diag_H_mat_elem
do i = 1, ndet
if(psi_coef_tmp(i)==0.d0)cycle
do j = i+1, ndet
if(psi_coef_tmp(j)==0.d0)cycle
! call i_H_j_dyall_no_exchange(psi_in_active(1,1,i),psi_in_active(1,1,j),N_int,hij)
call i_H_j(psi_in(1,1,i),psi_in(1,1,j),N_int,hij)
accu += 2.d0 * psi_coef_tmp(i) * psi_coef_tmp(j) * hij
enddo
enddo
do i = 1, N_det
if(psi_coef_tmp(i)==0.d0)cycle
accu += psi_coef_tmp(i) * psi_coef_tmp(i) * diag_H_mat_elem(psi_in(1,1,i),N_int)
enddo
energies(state_target) = accu
deallocate(psi_coef_tmp)
end

80
plugins/MRPT_Utils/ezfio_interface.irp.f Normal file
View File

@ -0,0 +1,80 @@
! DO NOT MODIFY BY HAND
! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py
! from file /home/giner/qp_bis/quantum_package/src/MRPT_Utils/EZFIO.cfg
BEGIN_PROVIDER [ logical, do_third_order_1h1p ]
implicit none
BEGIN_DOC
! If true, compute the third order contribution for the 1h1p
END_DOC
logical :: has
PROVIDE ezfio_filename
call ezfio_has_mrpt_utils_do_third_order_1h1p(has)
if (has) then
call ezfio_get_mrpt_utils_do_third_order_1h1p(do_third_order_1h1p)
else
print *, 'mrpt_utils/do_third_order_1h1p not found in EZFIO file'
stop 1
endif
END_PROVIDER
BEGIN_PROVIDER [ logical, save_heff_eigenvectors ]
implicit none
BEGIN_DOC
! If true, you save the eigenvectors of the effective hamiltonian
END_DOC
logical :: has
PROVIDE ezfio_filename
call ezfio_has_mrpt_utils_save_heff_eigenvectors(has)
if (has) then
call ezfio_get_mrpt_utils_save_heff_eigenvectors(save_heff_eigenvectors)
else
print *, 'mrpt_utils/save_heff_eigenvectors not found in EZFIO file'
stop 1
endif
END_PROVIDER
BEGIN_PROVIDER [ integer, n_states_diag_heff ]
implicit none
BEGIN_DOC
! Number of eigenvectors obtained with the effective hamiltonian
END_DOC
logical :: has
PROVIDE ezfio_filename
call ezfio_has_mrpt_utils_n_states_diag_heff(has)
if (has) then
call ezfio_get_mrpt_utils_n_states_diag_heff(n_states_diag_heff)
else
print *, 'mrpt_utils/n_states_diag_heff not found in EZFIO file'
stop 1
endif
END_PROVIDER
BEGIN_PROVIDER [ logical, pure_state_specific_mrpt2 ]
implicit none
BEGIN_DOC
! If true, diagonalize the dressed matrix for each state and do a state following of the initial states
END_DOC
logical :: has
PROVIDE ezfio_filename
call ezfio_has_mrpt_utils_pure_state_specific_mrpt2(has)
if (has) then
call ezfio_get_mrpt_utils_pure_state_specific_mrpt2(pure_state_specific_mrpt2)
else
print *, 'mrpt_utils/pure_state_specific_mrpt2 not found in EZFIO file'
stop 1
endif
END_PROVIDER

2
plugins/MRPT_Utils/fock_like_operators.irp.f
View File

@ -197,7 +197,7 @@
k_inact_core_orb = list_core_inact(k)
coulomb = get_mo_bielec_integral(k_inact_core_orb,iorb,k_inact_core_orb,jorb,mo_integrals_map)
exchange = get_mo_bielec_integral(k_inact_core_orb,jorb,iorb,k_inact_core_orb,mo_integrals_map)
accu += 2.d0 * coulomb - exchange
accu += 2.d0 * coulomb - exchange
enddo
fock_operator_active_from_core_inact(iorb,jorb) = accu
enddo

114
plugins/MRPT_Utils/mrpt_dress.irp.f
View File

@ -44,11 +44,11 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip
integer :: N_miniList, leng
double precision :: delta_e(N_states),hij_tmp
integer :: index_i,index_j
double precision :: phase_array(N_det),phase
double precision :: phase_array(N_det_ref),phase
integer :: exc(0:2,2,2),degree
leng = max(N_det_generators, N_det)
leng = max(N_det_generators, N_det_generators)
allocate(miniList(Nint, 2, leng), idx_miniList(leng))
!create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint)
@ -59,35 +59,76 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip
end if
call find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
call find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
if(N_tq > 0) then
call create_minilist(key_mask, psi_det, miniList, idx_miniList, N_det, N_minilist, Nint)
call create_minilist(key_mask, psi_ref, miniList, idx_miniList, N_det_ref, N_minilist, Nint)
end if
double precision :: coef_array(N_states)
do i_alpha=1,N_tq
! do i = 1, N_det_ref
! do i_state = 1, N_states
! coef_array(i_state) = psi_ref_coef(i,i_state)
! enddo
! call i_H_j(psi_ref(1,1,i),tq(1,1,i_alpha),n_int,hialpha)
! if(dabs(hialpha).le.1.d-20)then
! do i_state = 1, N_states
! delta_e(i_state) = 1.d+20
! enddo
! else
! call get_delta_e_dyall(psi_ref(1,1,i),tq(1,1,i_alpha),coef_array,hialpha,delta_e)
! endif
! hij_array(i) = hialpha
! do i_state = 1,N_states
! delta_e_inv_array(i,i_state) = 1.d0/delta_e(i_state)
! enddo
! enddo
! do i = 1, N_det_ref
! do j = 1, N_det_ref
! do i_state = 1, N_states
! delta_ij_(i,j,i_state) += hij_array(i) * hij_array(j)* delta_e_inv_array(j,i_state)
! enddo
! enddo
! enddo
! cycle
! call get_excitation_degree_vector(psi_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_ref,idx_alpha)
call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
do j=1,idx_alpha(0)
idx_alpha(j) = idx_miniList(idx_alpha(j))
enddo
! double precision :: ihpsi0,coef_pert
! ihpsi0 = 0.d0
! coef_pert = 0.d0
phase_array =0.d0
do i = 1,idx_alpha(0)
index_i = idx_alpha(i)
call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha)
double precision :: coef_array(N_states)
call i_h_j(tq(1,1,i_alpha),psi_ref(1,1,index_i),Nint,hialpha)
do i_state = 1, N_states
coef_array(i_state) = psi_coef(index_i,i_state)
coef_array(i_state) = psi_ref_coef(index_i,i_state)
enddo
call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e)
integer :: degree_scalar
call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,index_i),degree_scalar,N_int)
! if(degree_scalar == 2)then
! hialpha = 0.d0
! endif
if(dabs(hialpha).le.1.d-20)then
do i_state = 1, N_states
delta_e(i_state) = 1.d+20
enddo
else
call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e)
!!!!!!!!!!!!! SHIFTED BK
! double precision :: hjj
! call i_h_j(tq(1,1,i_alpha),tq(1,1,i_alpha),Nint,hjj)
! delta_e(1) = CI_electronic_energy(1) - hjj
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
endif
hij_array(index_i) = hialpha
call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int)
! phase_array(index_i) = phase
do i_state = 1,N_states
delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state)
enddo
@ -99,18 +140,14 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip
call omp_set_lock( psi_ref_bis_lock(index_i) )
do j = 1, idx_alpha(0)
index_j = idx_alpha(j)
! call get_excitation(psi_det(1,1,index_i),psi_det(1,1,index_i),exc,degree,phase,N_int)
! if(index_j.ne.index_i)then
! if(phase_array(index_j) * phase_array(index_i) .ne. phase)then
! print*, phase_array(index_j) , phase_array(index_i) ,phase
! call debug_det(psi_det(1,1,index_i),N_int)
! call debug_det(psi_det(1,1,index_j),N_int)
! call debug_det(tq(1,1,i_alpha),N_int)
! stop
! endif
! endif
!!!!!!!!!!!!!!!!!! WARNING TEST
!!!!!!!!!!!!!!!!!! WARNING TEST
! if(index_j .ne. index_i)cycle
!!!!!!!!!!!!!!!!!! WARNING TEST
!!!!!!!!!!!!!!!!!! WARNING TEST
!!!!!!!!!!!!!!!!!! WARNING TEST
do i_state=1,N_states
! standard dressing first order
! standard dressing first order
delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state)
enddo
enddo
@ -122,23 +159,23 @@ end
BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ]
&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ]
gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators)
gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators)
call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int)
call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int)
BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_ref,2) ]
&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_ref,2) ]
&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_ref,2) ]
&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_ref,2) ]
gen_det_sorted(:,:,:,1) = psi_ref(:,:,:N_det_ref)
gen_det_sorted(:,:,:,2) = psi_ref(:,:,:N_det_ref)
call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_ref, N_int)
call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_ref, N_int)
END_PROVIDER
subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList)
subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList)
use bitmasks
implicit none
integer, intent(in) :: i_generator,n_selected, Nint
integer, intent(in) :: n_selected, Nint
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
integer :: i,j,k,m
@ -155,7 +192,7 @@ subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N
logical, external :: is_connected_to
integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators)
integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_ref)
integer,intent(in) :: N_miniList
@ -168,7 +205,7 @@ subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N
cycle
end if
if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then
if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det_ref)) then
N_tq += 1
do k=1,N_int
tq(k,1,N_tq) = det_buffer(k,1,i)
@ -179,8 +216,3 @@ subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N
end

646
plugins/MRPT_Utils/mrpt_utils.irp.f
View File

@ -1,5 +1,5 @@
BEGIN_PROVIDER [ double precision, delta_ij, (N_det,N_det,N_states) ]
BEGIN_PROVIDER [ double precision, delta_ij, (N_det_ref,N_det_ref,N_states) ]
&BEGIN_PROVIDER [ double precision, second_order_pt_new, (N_states) ]
&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h, (N_states) ]
&BEGIN_PROVIDER [ double precision, second_order_pt_new_1p, (N_states) ]
@ -11,7 +11,7 @@
&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h2p, (N_states) ]
implicit none
BEGIN_DOC
! Dressing matrix in N_det basis
! Dressing matrix in N_det_ref basis
END_DOC
integer :: i,j,m
integer :: i_state
@ -21,17 +21,18 @@
delta_ij = 0.d0
allocate (delta_ij_tmp(N_det,N_det,N_states))
allocate (delta_ij_tmp(N_det_ref,N_det_ref,N_states))
! 1h
delta_ij_tmp = 0.d0
call H_apply_mrpt_1h(delta_ij_tmp,N_det)
call H_apply_mrpt_1h(delta_ij_tmp,N_det_ref)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
do i = 1, N_det_ref
write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state)
do j = 1, N_det_ref
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
@ -39,169 +40,237 @@
enddo
print*, '1h = ',accu
! 1p
delta_ij_tmp = 0.d0
call H_apply_mrpt_1p(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_1p(i_state) = accu(i_state)
enddo
print*, '1p = ',accu
! 1h1p
delta_ij_tmp = 0.d0
call H_apply_mrpt_1h1p(delta_ij_tmp,N_det)
double precision :: e_corr_from_1h1p_singles(N_states)
!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles)
!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_1h1p(i_state) = accu(i_state)
enddo
print*, '1h1p = ',accu
! 1h1p third order
if(do_third_order_1h1p)then
delta_ij_tmp = 0.d0
call give_1h1p_sec_order_singles_contrib(delta_ij_tmp)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
! 1p
delta_ij_tmp = 0.d0
call H_apply_mrpt_1p(delta_ij_tmp,N_det_ref)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det_ref
write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state)
do j = 1, N_det_ref
! print*, accu
! print*,delta_ij_tmp(j,i,i_state) , psi_ref_coef(i,i_state) , psi_ref_coef(j,i_state)
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
enddo
second_order_pt_new_1h1p(i_state) = accu(i_state)
enddo
print*, '1h1p(3)',accu
endif
second_order_pt_new_1p(i_state) = accu(i_state)
enddo
print*, '1p = ',accu
! 1h1p
delta_ij_tmp = 0.d0
call H_apply_mrpt_1h1p(delta_ij_tmp,N_det_ref)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det_ref
write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state)
do j = 1, N_det_ref
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
double precision :: accu_diag,accu_non_diag
accu_diag = 0.d0
accu_non_diag = 0.d0
do i = 1, N_det_ref
accu_diag += delta_ij_tmp(i,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(i,i_state)
do j = 1, N_det_ref
if(i == j)cycle
accu_non_diag += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state)
enddo
enddo
second_order_pt_new_1h1p(i_state) = accu(i_state)
enddo
!double precision :: neutral, ionic
!neutral = 0.d0
!do i = 1, 2
! do j = 1, N_det_ref
! neutral += psi_ref_coef(j,1) * delta_ij_tmp(j,i,1) * psi_ref_coef(i,1)
! enddo
!enddo
!do i = 3, 4
! do j = 1, N_det_ref
! ionic += psi_ref_coef(j,1) * delta_ij_tmp(j,i,1) * psi_ref_coef(i,1)
! enddo
!enddo
!neutral = delta_ij_tmp(1,1,1) * psi_ref_coef(1,1)**2 + delta_ij_tmp(2,2,1) * psi_ref_coef(2,1)**2 &
! + delta_ij_tmp(1,2,1) * psi_ref_coef(1,1)* psi_ref_coef(2,1) + delta_ij_tmp(2,1,1) * psi_ref_coef(1,1)* psi_ref_coef(2,1)
!ionic = delta_ij_tmp(3,3,1) * psi_ref_coef(3,1)**2 + delta_ij_tmp(4,4,1) * psi_ref_coef(4,1)**2 &
! + delta_ij_tmp(3,4,1) * psi_ref_coef(3,1)* psi_ref_coef(4,1) + delta_ij_tmp(4,3,1) * psi_ref_coef(3,1)* psi_ref_coef(4,1)
!neutral = delta_ij_tmp(1,1,1)
!ionic = delta_ij_tmp(3,3,1)
!print*, 'neutral = ',neutral
!print*, 'ionic = ',ionic
print*, '1h1p = ',accu
!! 1h1p third order
!if(do_third_order_1h1p)then
! delta_ij_tmp = 0.d0
! call give_1h1p_sec_order_singles_contrib(delta_ij_tmp)
! accu = 0.d0
! do i_state = 1, N_states
! do i = 1, N_det_ref
! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state)
! do j = 1, N_det_ref
! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state)
! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
! enddo
! enddo
! second_order_pt_new_1h1p(i_state) = accu(i_state)
! enddo
! print*, '1h1p(3)',accu
!endif
! 2h
delta_ij_tmp = 0.d0
call H_apply_mrpt_2h(delta_ij_tmp,N_det_ref)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det_ref
write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state)
do j = 1, N_det_ref
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_2h(i_state) = accu(i_state)
enddo
print*, '2h = ',accu
! 2p
delta_ij_tmp = 0.d0
call H_apply_mrpt_2p(delta_ij_tmp,N_det_ref)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det_ref
write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state)
do j = 1, N_det_ref
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_2p(i_state) = accu(i_state)
enddo
print*, '2p = ',accu
! 1h2p
delta_ij_tmp = 0.d0
call give_1h2p_contrib(delta_ij_tmp)
!!!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det_ref)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det_ref
write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state)
do j = 1, N_det_ref
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_1h2p(i_state) = accu(i_state)
enddo
print*, '1h2p = ',accu
! 2h1p
delta_ij_tmp = 0.d0
call give_2h1p_contrib(delta_ij_tmp)
!!!!call H_apply_mrpt_2h1p(delta_ij_tmp,N_det_ref)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det_ref
write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state)
do j = 1, N_det_ref
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_2h1p(i_state) = accu(i_state)
enddo
print*, '2h1p = ',accu
! 2h2p
double precision :: contrib_2h2p(N_states)
call give_2h2p(contrib_2h2p)
do i_state = 1, N_states
do i = 1, N_det_ref
delta_ij(i,i,i_state) += contrib_2h2p(i_state)
enddo
second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state)
enddo
print*, '2h2p = ',contrib_2h2p(:)
! 2h
delta_ij_tmp = 0.d0
call H_apply_mrpt_2h(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_2h(i_state) = accu(i_state)
enddo
print*, '2h = ',accu
! 2p
delta_ij_tmp = 0.d0
call H_apply_mrpt_2p(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_2p(i_state) = accu(i_state)
enddo
print*, '2p = ',accu
! 1h2p
delta_ij_tmp = 0.d0
!call give_1h2p_contrib(delta_ij_tmp)
call H_apply_mrpt_1h2p(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_1h2p(i_state) = accu(i_state)
enddo
print*, '1h2p = ',accu
! 2h1p
delta_ij_tmp = 0.d0
!call give_2h1p_contrib(delta_ij_tmp)
call H_apply_mrpt_2h1p(delta_ij_tmp,N_det)
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
do j = 1, N_det
accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
enddo
enddo
second_order_pt_new_2h1p(i_state) = accu(i_state)
enddo
print*, '2h1p = ',accu
! 2h2p
!delta_ij_tmp = 0.d0
!call H_apply_mrpt_2h2p(delta_ij_tmp,N_det)
!accu = 0.d0
!do i_state = 1, N_states
!do i = 1, N_det
! do j = 1, N_det
! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
! enddo
!enddo
!second_order_pt_new_2h2p(i_state) = accu(i_state)
!enddo
!print*, '2h2p = ',accu
double precision :: contrib_2h2p(N_states)
call give_2h2p(contrib_2h2p)
do i_state = 1, N_states
do i = 1, N_det
delta_ij(i,i,i_state) += contrib_2h2p(i_state)
enddo
second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state)
enddo
print*, '2h2p = ',contrib_2h2p(1)
! ! 2h2p old fashion
! delta_ij_tmp = 0.d0
! call H_apply_mrpt_2h2p(delta_ij_tmp,N_det_ref)
! accu = 0.d0
! do i_state = 1, N_states
! do i = 1, N_det_ref
! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,i_state)
! do j = 1, N_det_ref
! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state)
! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
! enddo
! enddo
! second_order_pt_new_2h2p(i_state) = accu(i_state)
! enddo
! print*, '2h2p = ',accu
! total
accu = 0.d0
do i_state = 1, N_states
do i = 1, N_det
! write(*,'(1000(F16.10,x))')delta_ij(i,:,:)
do j = i_state, N_det
accu(i_state) += delta_ij(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
print*, 'naked matrix'
double precision, allocatable :: hmatrix(:,:)
double precision:: hij,h00
allocate(hmatrix(N_det_ref, N_det_ref))
call i_h_j(psi_ref(1,1,1),psi_ref(1,1,1),N_int,h00)
do i = 1, N_det_ref
do j = 1, N_det_Ref
call i_h_j(psi_ref(1,1,i),psi_ref(1,1,j),N_int,hij)
hmatrix(i,j) = hij
enddo
print*, hmatrix(i,i), h00
hmatrix(i,i) += - h00
enddo
second_order_pt_new(i_state) = accu(i_state)
print*, 'total= ',accu(i_state)
do i = 1, N_det_ref
write(*,'(1000(F16.10,x))')hmatrix(i,:)
enddo
print*, ''
print*, ''
print*, ''
do i_state = 1, N_states
print*,'state ',i_state
do i = 1, N_det_ref
write(*,'(1000(F16.10,x))')delta_ij(i,:,i_state)
do j = 1 , N_det_ref
accu(i_state) += delta_ij(j,i,i_state) * psi_ref_coef(i,i_state) * psi_ref_coef(j,i_state)
hmatrix(i,j) += delta_ij(j,i,i_state)
enddo
enddo
second_order_pt_new(i_state) = accu(i_state)
print*, 'total= ',accu(i_state)
do i = 1, N_det_ref
write(*,'(1000(F16.10,x))')hmatrix(i,:)
enddo
enddo
deallocate(hmatrix)
END_PROVIDER
BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new, (N_det,N_det,N_states)]
BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new, (N_det_ref,N_det_ref,N_states)]
implicit none
integer :: i,j,i_state
double precision :: hij
do i_state = 1, N_states
do i = 1,N_det
do j = 1,N_det
Hmatrix_dressed_pt2_new(j,i,i_state) = H_matrix_all_dets(j,i) + delta_ij(j,i,i_state)
do i = 1,N_det_ref
do j = 1,N_det_ref
call i_h_j(psi_ref(1,1,j),psi_ref(1,1,i),N_int,hij)
Hmatrix_dressed_pt2_new(j,i,i_state) = hij + delta_ij(j,i,i_state)
enddo
enddo
enddo
@ -209,23 +278,29 @@ END_PROVIDER
BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new_symmetrized, (N_det,N_det,N_states)]
BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new_symmetrized, (N_det_ref,N_det_ref,N_states)]
implicit none
integer :: i,j,i_state
double precision :: hij
double precision :: accu(N_states)
accu = 0.d0
do i_state = 1, N_states
do i = 1,N_det
do j = i,N_det
Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) = H_matrix_all_dets(j,i) &
do i = 1,N_det_ref
do j = 1,N_det_ref
call i_h_j(psi_ref(1,1,j),psi_ref(1,1,i),N_int,hij)
Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) = hij &
+ 0.5d0 * ( delta_ij(j,i,i_state) + delta_ij(i,j,i_state) )
Hmatrix_dressed_pt2_new_symmetrized(i,j,i_state) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state)
! Hmatrix_dressed_pt2_new_symmetrized(i,j,i_state) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state)
accu(i_State) += psi_ref_coef(i,i_State) * Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) * psi_ref_coef(j,i_State)
enddo
enddo
enddo
print*, 'accu = ',accu + nuclear_repulsion
END_PROVIDER
BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag) ]
BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag_heff) ]
&BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det_ref,N_states_diag_heff) ]
&BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag_heff) ]
BEGIN_DOC
! Eigenvectors/values of the CI matrix
END_DOC
@ -236,23 +311,25 @@ END_PROVIDER
logical, allocatable :: good_state_array(:)
double precision, allocatable :: s2_values_tmp(:)
integer :: i_other_state
double precision, allocatable :: eigenvectors(:,:), eigenvalues(:)
double precision, allocatable :: eigenvectors(:,:), eigenvalues(:), hmatrix_tmp(:,:)
integer :: i_state
double precision :: s2,e_0
integer :: i,j,k
double precision, allocatable :: s2_eigvalues(:)
double precision, allocatable :: e_array(:)
integer, allocatable :: iorder(:)
double precision :: overlap(N_det_ref)
double precision, allocatable :: psi_tmp(:)
! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors
do j=1,min(N_states_diag,N_det)
do i=1,N_det
CI_dressed_pt2_new_eigenvectors(i,j) = psi_coef(i,j)
! Guess values for the "N_states_diag_heff" states of the CI_dressed_pt2_new_eigenvectors
do j=1,min(N_states,N_det_ref)
do i=1,N_det_ref
CI_dressed_pt2_new_eigenvectors(i,j) = psi_ref_coef(i,j)
enddo
enddo
do j=N_det+1,N_states_diag
do i=1,N_det
do j=min(N_states,N_det_ref)+1,N_states_diag_heff
do i=1,N_det_ref
CI_dressed_pt2_new_eigenvectors(i,j) = 0.d0
enddo
enddo
@ -262,93 +339,164 @@ END_PROVIDER
print*, 'Davidson not yet implemented for the dressing ... '
stop
else if (diag_algorithm == "Lapack") then
allocate (eigenvectors(size(H_matrix_all_dets,1),N_det))
allocate (eigenvalues(N_det))
call lapack_diag(eigenvalues,eigenvectors, &
H_matrix_all_dets,size(H_matrix_all_dets,1),N_det)
CI_electronic_energy(:) = 0.d0
if (s2_eig) then
i_state = 0
allocate (s2_eigvalues(N_det))
allocate(index_good_state_array(N_det),good_state_array(N_det))
good_state_array = .False.
call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,&
N_det,size(eigenvectors,1))
do j=1,N_det
! Select at least n_states states with S^2 values closed to "expected_s2"
if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then
i_state +=1
index_good_state_array(i_state) = j
good_state_array(j) = .True.
endif
if(i_state.eq.N_states) then
exit
endif
else if (diag_algorithm == "Lapack") then
allocate (eigenvectors(N_det_ref,N_det_ref))
allocate (eigenvalues(N_det_ref))
if(pure_state_specific_mrpt2)then
allocate (hmatrix_tmp(N_det_ref,N_det_ref))
allocate (iorder(N_det_ref))
allocate (psi_tmp(N_det_ref))
print*,''
print*,'***************************'
do i_state = 1, N_states !! Big loop over states
print*,''
print*,'Diagonalizing with the dressing for state',i_state
do i = 1, N_det_ref
do j = 1, N_det_ref
hmatrix_tmp(j,i) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state)
enddo
! print*,i,hmatrix_tmp(i,i)+nuclear_repulsion
enddo
if(i_state .ne.0)then
! Fill the first "i_state" states that have a correct S^2 value
do j = 1, i_state
do i=1,N_det
CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j))
enddo
CI_electronic_energy(j) = eigenvalues(index_good_state_array(j))
CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j))
enddo
i_other_state = 0
do j = 1, N_det
if(good_state_array(j))cycle
i_other_state +=1
if(i_state+i_other_state.gt.n_states_diag)then
exit
endif
do i=1,N_det
CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j)
enddo
CI_electronic_energy(i_state+i_other_state) = eigenvalues(j)
CI_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state)
enddo
else
print*,''
print*,'!!!!!!!! WARNING !!!!!!!!!'
print*,' Within the ',N_det,'determinants selected'
print*,' and the ',N_states_diag,'states requested'
print*,' We did not find any state with S^2 values close to ',expected_s2
print*,' We will then set the first N_states eigenvectors of the H matrix'
print*,' as the CI_eigenvectors'
print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space'
print*,''
do j=1,min(N_states_diag,N_det)
do i=1,N_det
CI_eigenvectors(i,j) = eigenvectors(i,j)
enddo
CI_electronic_energy(j) = eigenvalues(j)
CI_eigenvectors_s2(j) = s2_eigvalues(j)
enddo
endif
deallocate(index_good_state_array,good_state_array)
deallocate(s2_eigvalues)
else
call u_0_S2_u_0(CI_eigenvectors_s2,eigenvectors,N_det,psi_det,N_int,&
min(N_det,N_states_diag),size(eigenvectors,1))
! Select the "N_states_diag" states of lowest energy
do j=1,min(N_det,N_states_diag)
do i=1,N_det
CI_eigenvectors(i,j) = eigenvectors(i,j)
enddo
CI_electronic_energy(j) = eigenvalues(j)
call lapack_diag(eigenvalues,eigenvectors,hmatrix_tmp,N_det_ref,N_det_ref)
write(*,'(A86)')'Looking for the most overlapping state within all eigenvectors of the dressed matrix'
print*,''
print*,'Calculating the overlap for ...'
do i = 1, N_det_ref
overlap(i) = 0.d0
iorder(i) = i
print*,'eigenvector',i
do j = 1, N_det_ref
overlap(i)+= psi_ref_coef(j,i_state) * eigenvectors(j,i)
enddo
overlap(i) = -dabs(overlap(i))
print*,'energy = ',eigenvalues(i) + nuclear_repulsion
print*,'overlap = ',dabs(overlap(i))
enddo
print*,''
print*,'Sorting the eigenvectors per overlap'
call dsort(overlap,iorder,n_det_ref)
do j = 1, N_det_ref
print*,overlap(j),iorder(j)
enddo
print*,''
print*,'The most overlapping state is the ',iorder(1)
print*,'with the overlap of ',dabs(overlap(1))
print*,'and an energy of ',eigenvalues(iorder(1)) + nuclear_repulsion
print*,'Calculating the S^2 value ...'
do i=1,N_det_ref
CI_dressed_pt2_new_eigenvectors(i,i_state) = eigenvectors(i,iorder(1))
psi_tmp(i) = eigenvectors(i,iorder(1))
enddo
CI_electronic_dressed_pt2_new_energy(i_state) = eigenvalues(iorder(1))
call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2(i_state),psi_tmp,N_det_ref,psi_det,N_int,1,N_det_ref)
print*,'S^2 = ', CI_dressed_pt2_new_eigenvectors_s2(i_state)
enddo
!else if(state_average)then
! print*,''
! print*,'***************************'
! print*,''
! print*,'Doing state average dressings'
! allocate (hmatrix_tmp(N_det_ref,N_det_ref))
! hmatrix_tmp = 0.d0
! do i_state = 1, N_states !! Big loop over states
! do i = 1, N_det_ref
! do j = 1, N_det_ref
! hmatrix_tmp(j,i) += Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state)
! enddo
! enddo
! enddo
! deallocate(hmatrix_tmp)
else
call lapack_diag(eigenvalues,eigenvectors, &
Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det_ref,N_det_ref)
CI_electronic_dressed_pt2_new_energy(:) = 0.d0
if (s2_eig) then
i_state = 0
allocate (s2_eigvalues(N_det_ref))
allocate(index_good_state_array(N_det_ref),good_state_array(N_det_ref))
good_state_array = .False.
call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det_ref,psi_det,N_int,&
N_det_ref,size(eigenvectors,1))
do j=1,N_det_ref
! Select at least n_states states with S^2 values closed to "expected_s2"
print*, eigenvalues(j)+nuclear_repulsion, s2_eigvalues(j)
if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then
i_state += 1
index_good_state_array(i_state) = j
good_state_array(j) = .True.
endif
if (i_state==N_states) then
exit
endif
enddo
if (i_state /= 0) then
! Fill the first "i_state" states that have a correct S^2 value
do j = 1, i_state
do i=1,N_det_ref
CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j))
enddo
CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(index_good_state_array(j))
CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j))
enddo
i_other_state = 0
do j = 1, N_det_ref
if(good_state_array(j))cycle
i_other_state +=1
if(i_state+i_other_state.gt.n_states)then
exit
endif
do i=1,N_det_ref
CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j)
enddo
CI_electronic_dressed_pt2_new_energy(i_state+i_other_state) = eigenvalues(j)
CI_dressed_pt2_new_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state)
enddo
else
print*,''
print*,'!!!!!!!! WARNING !!!!!!!!!'
print*,' Within the ',N_det_ref,'determinants selected'
print*,' and the ',N_states_diag_heff,'states requested'
print*,' We did not find any state with S^2 values close to ',expected_s2
print*,' We will then set the first N_states eigenvectors of the H matrix'
print*,' as the CI_dressed_pt2_new_eigenvectors'
print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space'
print*,''
do j=1,min(N_states_diag_heff,N_det_ref)
do i=1,N_det_ref
CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j)
enddo
CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j)
CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(j)
enddo
endif
deallocate(index_good_state_array,good_state_array)
deallocate(s2_eigvalues)
else
call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2,eigenvectors,N_det_ref,psi_det,N_int,&
min(N_det_ref,N_states_diag_heff),size(eigenvectors,1))
! Select the "N_states_diag_heff" states of lowest energy
do j=1,min(N_det_ref,N_states)
do i=1,N_det_ref
CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j)
enddo
CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j)
enddo
endif
deallocate(eigenvectors,eigenvalues)
endif
deallocate(eigenvectors,eigenvalues)
endif
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ]
BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag_heff) ]
implicit none
BEGIN_DOC
! N_states lowest eigenvalues of the CI matrix
@ -357,11 +505,11 @@ BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ]
integer :: j
character*(8) :: st
call write_time(output_determinants)
do j=1,N_states_diag
do j=1,N_states_diag_heff
CI_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion
write(st,'(I4)') j
call write_double(output_determinants,CI_dressed_pt2_new_energy(j),'Energy of state '//trim(st))
call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st))
call write_double(output_determinants, CI_dressed_pt2_new_eigenvectors_s2(j) ,'S^2 of state '//trim(st))
enddo
END_PROVIDER

315
plugins/MRPT_Utils/new_way.irp.f
View File

@ -1,7 +1,7 @@
subroutine give_2h1p_contrib(matrix_2h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*)
double precision , intent(inout) :: matrix_2h1p(N_det_ref,N_det_ref,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb
integer :: ispin,jspin
@ -22,8 +22,8 @@ subroutine give_2h1p_contrib(matrix_2h1p)
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
@ -38,14 +38,14 @@ subroutine give_2h1p_contrib(matrix_2h1p)
active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange
enddo
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: degree(N_det_ref)
integer :: idx(0:N_det_ref)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,3)
integer :: index_orb_act_mono(N_det_ref,3)
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
do idet = 1, N_det_ref
call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a)
@ -53,8 +53,8 @@ subroutine give_2h1p_contrib(matrix_2h1p)
do a = 1, n_act_orb ! First active
aorb = list_act(a)
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
det_tmp(inint,1) = psi_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
@ -64,7 +64,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin
call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
! Check if the excitation is possible or not on psi_ref(idet)
accu_elec= 0
do inint = 1, N_int
accu_elec+= popcnt(det_tmp(inint,jspin))
@ -81,7 +81,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1)
perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
perturb_dets_phase(a,jspin,ispin) = phase
do istate = 1, N_states
delta_e(a,jspin,istate) = one_creat(a,jspin,istate) &
@ -109,7 +109,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a_{b} a^{\dagger}_a | Idet>
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_a
@ -129,6 +129,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
integer :: kspin
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
! cycle
! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator
! are connected by the presence of the perturbers determinants |det_tmp>
aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb}
@ -150,7 +151,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
! you determine the interaction between the excited determinant and the other parent | Jdet >
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet >
! hja = < det_tmp | H | Jdet >
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
if(kspin == ispin)then
hja = phase * (active_int(borb,2) - active_int(borb,1) )
else
@ -195,7 +196,7 @@ end
subroutine give_1h2p_contrib(matrix_1h2p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*)
double precision , intent(inout) :: matrix_1h2p(N_det_ref,N_det_ref,*)
integer :: i,v,r,a,b
integer :: iorb, vorb, rorb, aorb, borb
integer :: ispin,jspin
@ -213,16 +214,18 @@ subroutine give_1h2p_contrib(matrix_1h2p)
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
!matrix_1h2p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
enddo
!do i = 1, 1 ! First inactive
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
! do v = 1, 1
do v = 1, n_virt_orb ! First virtual
vorb = list_virt(v)
! do r = 1, 1
do r = 1, n_virt_orb ! Second virtual
rorb = list_virt(r)
! take all the integral you will need for i,j,r fixed
@ -232,14 +235,14 @@ subroutine give_1h2p_contrib(matrix_1h2p)
active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange
enddo
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: degree(N_det_ref)
integer :: idx(0:N_det_ref)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,3)
integer :: index_orb_act_mono(N_det_ref,3)
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
do idet = 1, N_det_ref
call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb)
do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb)
@ -247,8 +250,8 @@ subroutine give_1h2p_contrib(matrix_1h2p)
aorb = list_act(a)
if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
det_tmp(inint,1) = psi_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
@ -258,7 +261,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin
call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
! Check if the excitation is possible or not on psi_ref(idet)
accu_elec= 0
do inint = 1, N_int
accu_elec+= popcnt(det_tmp(inint,jspin))
@ -280,7 +283,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
perturb_dets_phase(a,jspin,ispin) = phase
do istate = 1, N_states
delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) &
@ -308,7 +311,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a^{\dagger}_b a_{a} | Idet>
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a
@ -350,7 +353,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{borb,kspin} a_{iorb,ispin} | Jdet >
! hja = < det_tmp | H | Jdet >
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
if(kspin == ispin)then
hja = phase * (active_int(borb,1) - active_int(borb,2) )
else
@ -393,130 +396,10 @@ subroutine give_1h2p_contrib(matrix_1h2p)
end
subroutine give_1h1p_contrib(matrix_1h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb
integer :: ispin,jspin
integer :: idet,jdet
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: istate
double precision :: hja,delta_e_inact_virt(N_states)
integer :: kspin,degree_scalar
!matrix_1h1p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
do j = 1, N_states
delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) &
- fock_virt_total_spin_trace(rorb,j)
enddo
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations
do jdet = 1, idx(0)
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
double precision :: himono,delta_e(N_states),coef_mono(N_states)
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono)
do state_target = 1, N_states
! delta_e(state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target)
delta_e(state_target) = one_anhil_one_creat_inact_virt_bis(i,r,idet,state_target)
coef_mono(state_target) = himono / delta_e(state_target)
enddo
if(idx(jdet).ne.idet)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
aorb = (exc(1,2,1)) !!! a^{\dagger}_a
borb = (exc(1,1,1)) !!! a_{b}
jspin = 1
else
! Mono beta
aorb = (exc(1,2,2)) !!! a^{\dagger}_a
borb = (exc(1,1,2)) !!! a_{b}
jspin = 2
endif
call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int)
if(degree_scalar .ne. 2)then
print*, 'pb !!!'
print*, degree_scalar
call debug_det(psi_det(1,1,idx(jdet)),N_int)
call debug_det(det_tmp,N_int)
stop
endif
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
if(ispin == jspin )then
hij = -get_mo_bielec_integral(iorb,aorb,rorb,borb,mo_integrals_map) &
+ get_mo_bielec_integral(iorb,aorb,borb,rorb,mo_integrals_map)
else
hij = get_mo_bielec_integral(iorb,borb,rorb,aorb,mo_integrals_map)
endif
hij = hij * phase
double precision :: hij_test
integer :: state_target
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test)
if(dabs(hij - hij_test).gt.1.d-10)then
print*, 'ahah pb !!'
print*, 'hij .ne. hij_test'
print*, hij,hij_test
call debug_det(psi_det(1,1,idx(jdet)),N_int)
call debug_det(det_tmp,N_int)
print*, ispin, jspin
print*,iorb,borb,rorb,aorb
print*, phase
call i_H_j_verbose(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test)
stop
endif
do state_target = 1, N_states
matrix_1h1p(idx(jdet),idet,state_target) += hij* coef_mono(state_target)
enddo
else
do state_target = 1, N_states
matrix_1h1p(idet,idet,state_target) += himono * coef_mono(state_target)
enddo
endif
enddo
enddo
enddo
enddo
enddo
end
subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*)
double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb,s,sorb
integer :: ispin,jspin
@ -533,8 +416,8 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: degree(N_det_ref)
integer :: idx(0:N_det_ref)
integer :: istate
double precision :: hja,delta_e_inact_virt(N_states)
integer :: kspin,degree_scalar
@ -542,13 +425,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
enddo
double precision :: himono,delta_e(N_states),coef_mono(N_states)
integer :: state_target
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
do idet = 1, N_det_ref
call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx)
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do r = 1, n_virt_orb ! First virtual
@ -563,13 +446,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
- fock_virt_total_spin_trace(rorb,j)
enddo
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
det_tmp(inint,1) = psi_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono)
call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono)
do inint = 1, N_int
det_pert(inint,1,i,r,ispin) = det_tmp(inint,1)
det_pert(inint,2,i,r,ispin) = det_tmp(inint,2)
@ -619,9 +502,9 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do state_target = 1, N_states
coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2)
enddo
!do state_target = 1, N_states
! coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2)
!enddo
do inint = 1, N_int
det_tmp(inint,1) = det_pert(inint,1,i,r,ispin)
@ -629,37 +512,37 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
enddo
do jdet = 1, idx(0)
!
if(idx(jdet).ne.idet)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
aorb = (exc(1,2,1)) !!! a^{\dagger}_a
borb = (exc(1,1,1)) !!! a_{b}
jspin = 1
else
aorb = (exc(1,2,2)) !!! a^{\dagger}_a
borb = (exc(1,1,2)) !!! a_{b}
jspin = 2
endif
call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int)
if(degree_scalar .ne. 2)then
print*, 'pb !!!'
print*, degree_scalar
call debug_det(psi_det(1,1,idx(jdet)),N_int)
call debug_det(det_tmp,N_int)
stop
endif
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
double precision :: hij_test
hij_test = 0.d0
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test)
do state_target = 1, N_states
matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2)
enddo
if(idx(jdet).ne.idet)then
! call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
! if (exc(0,1,1) == 1) then
! ! Mono alpha
! aorb = (exc(1,2,1)) !!! a^{\dagger}_a
! borb = (exc(1,1,1)) !!! a_{b}
! jspin = 1
! else
! aorb = (exc(1,2,2)) !!! a^{\dagger}_a
! borb = (exc(1,1,2)) !!! a_{b}
! jspin = 2
! endif
!
! call get_excitation_degree(psi_ref(1,1,idx(jdet)),det_tmp,degree_scalar,N_int)
! if(degree_scalar .ne. 2)then
! print*, 'pb !!!'
! print*, degree_scalar
! call debug_det(psi_ref(1,1,idx(jdet)),N_int)
! call debug_det(det_tmp,N_int)
! stop
! endif
! call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
! hij_test = 0.d0
! call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test)
! do state_target = 1, N_states
! matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2)
! enddo
else
hij_test = 0.d0
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij_test)
call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hij_test)
do state_target = 1, N_states
matrix_1h1p(idet,idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2)
enddo
@ -676,7 +559,7 @@ end
subroutine give_1p_sec_order_singles_contrib(matrix_1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1p(N_det,N_det,*)
double precision , intent(inout) :: matrix_1p(N_det_ref,N_det_ref,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb,s,sorb
integer :: ispin,jspin
@ -692,8 +575,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
integer :: accu_elec
double precision :: get_mo_bielec_integral
double precision :: hij,phase
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: degree(N_det_ref)
integer :: idx(0:N_det_ref)
integer :: istate
double precision :: hja,delta_e_act_virt(N_states)
integer :: kspin,degree_scalar
@ -701,13 +584,13 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
enddo
double precision :: himono,delta_e(N_states),coef_mono(N_states)
integer :: state_target
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
do idet = 1, N_det_ref
call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx)
do i = 1, n_act_orb ! First active
iorb = list_act(i)
do r = 1, n_virt_orb ! First virtual
@ -721,8 +604,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
delta_e_act_virt(j) = - fock_virt_total_spin_trace(rorb,j)
enddo
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
det_tmp(inint,1) = psi_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(inint,2,idet)
enddo
! Do the excitation active -- > virtual
call do_mono_excitation(det_tmp,iorb,rorb,ispin,i_ok)
@ -739,7 +622,7 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
enddo
cycle
endif
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono)
call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono)
do inint = 1, N_int
det_pert(inint,1,i,r,ispin) = det_tmp(inint,1)
det_pert(inint,2,i,r,ispin) = det_tmp(inint,2)
@ -801,10 +684,10 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
det_tmp(inint,1) = det_pert(inint,1,i,r,ispin)
det_tmp(inint,2) = det_pert(inint,2,i,r,ispin)
enddo
do jdet = 1,N_det
do jdet = 1,N_det_ref
double precision :: coef_array(N_states),hij_test
call i_H_j(det_tmp,psi_det(1,1,jdet),N_int,himono)
call get_delta_e_dyall(psi_det(1,1,jdet),det_tmp,coef_array,hij_test,delta_e)
call i_H_j(det_tmp,psi_ref(1,1,jdet),N_int,himono)
call get_delta_e_dyall(psi_ref(1,1,jdet),det_tmp,coef_array,hij_test,delta_e)
do state_target = 1, N_states
! matrix_1p(idet,jdet,state_target) += himono * coef_det_pert(i,r,ispin,state_target,1)
matrix_1p(idet,jdet,state_target) += himono * hij_det_pert(i,r,ispin) / delta_e(state_target)
@ -822,7 +705,7 @@ end
subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*)
double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb
integer :: ispin,jspin
@ -835,8 +718,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
double precision :: get_mo_bielec_integral
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: degree(N_det_ref)
integer :: idx(0:N_det_ref)
integer :: istate
double precision :: hja,delta_e_inact_virt(N_states)
integer(bit_kind) :: pert_det(N_int,2,n_act_orb,n_act_orb,2)
@ -850,8 +733,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
@ -861,8 +744,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) &
- fock_virt_total_spin_trace(rorb,j)
enddo
do idet = 1, N_det
call get_excitation_degree_vector_double_alpha_beta(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
do idet = 1, N_det_ref
call get_excitation_degree_vector_double_alpha_beta(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations
do ispin = 1, 2
@ -872,8 +755,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
do b = 1, n_act_orb
borb = list_act(b)
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
det_tmp(inint,1) = psi_ref(inint,1,idet)
det_tmp(inint,2) = psi_ref(inint,2,idet)
enddo
! Do the excitation (i-->a)(ispin) + (b-->r)(other_spin(ispin))
integer :: i_ok,corb,dorb
@ -904,7 +787,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
pert_det(inint,2,a,b,ispin) = det_tmp(inint,2)
enddo
call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hidouble)
call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hidouble)
do state_target = 1, N_states
delta_e(state_target) = one_anhil_one_creat(a,b,ispin,jspin,state_target) + delta_e_inact_virt(state_target)
pert_det_coef(a,b,ispin,state_target) = hidouble / delta_e(state_target)
@ -915,7 +798,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
enddo
do jdet = 1, idx(0)
if(idx(jdet).ne.idet)then
call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
integer :: c,d,state_target
integer(bit_kind) :: det_tmp_bis(N_int,2)
! excitation from I --> J
@ -935,8 +818,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
det_tmp_bis(inint,2) = pert_det(inint,2,c,d,2)
enddo
double precision :: hjdouble_1,hjdouble_2
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1)
call i_H_j(psi_det(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2)
call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1)
call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2)
do state_target = 1, N_states
matrix_1h1p(idx(jdet),idet,state_target) += (pert_det_coef(c,d,1,state_target) * hjdouble_1 + pert_det_coef(c,d,2,state_target) * hjdouble_2 )
enddo

8
plugins/MRPT_Utils/new_way_second_order_coef.irp.f
View File

@ -44,8 +44,8 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
perturb_dets_phase(a,2,1) = -1000.d0
enddo
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: degree(N_det_Ref)
integer :: idx(0:N_det_Ref)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
@ -379,8 +379,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
double precision :: accu_contrib
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: degree(N_det_Ref)
integer :: idx(0:N_det_Ref)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,6)

51
plugins/MRPT_Utils/print_1h2p.irp.f
View File

@ -1,51 +0,0 @@
program print_1h2p
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
double precision,allocatable :: matrix_1h2p(:,:,:)
allocate (matrix_1h2p(N_det,N_det,N_states))
integer :: i,j,istate
do i = 1, N_det
do j = 1, N_det
do istate = 1, N_states
matrix_1h2p(i,j,istate) = 0.d0
enddo
enddo
enddo
if(.False.)then
call give_1h2p_contrib(matrix_1h2p)
double precision :: accu
accu = 0.d0
do i = 1, N_det
do j = 1, N_det
accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1)
enddo
enddo
print*, 'second order ', accu
endif
if(.True.)then
do i = 1, N_det
do j = 1, N_det
do istate = 1, N_states
matrix_1h2p(i,j,istate) = 0.d0
enddo
enddo
enddo
call give_1h2p_new(matrix_1h2p)
accu = 0.d0
do i = 1, N_det
do j = 1, N_det
accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1)
enddo
enddo
endif
print*, 'third order ', accu
deallocate (matrix_1h2p)
end

412
plugins/MRPT_Utils/psi_active_prov.irp.f
View File

@ -9,11 +9,12 @@ BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)]
integer :: i,j,k,l
provide cas_bitmask
!print*, 'psi_active '
do i = 1, N_det
do i = 1, N_det_ref
do j = 1, N_int
psi_active(j,1,i) = iand(psi_det(j,1,i),cas_bitmask(j,1,1))
psi_active(j,2,i) = iand(psi_det(j,2,i),cas_bitmask(j,1,1))
psi_active(j,1,i) = iand(psi_ref(j,1,i),cas_bitmask(j,1,1))
psi_active(j,2,i) = iand(psi_ref(j,2,i),cas_bitmask(j,1,1))
enddo
! call debug_det(psi_active(1,1,i),N_int)
enddo
END_PROVIDER
@ -180,25 +181,35 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
double precision :: delta_e_inactive(N_states)
integer :: i_hole_inact
integer :: i_hole_inact, list_holes_inact(n_inact_orb,2)
call get_excitation_degree(det_1,det_2,degree,N_int)
if(degree>2)then
delta_e_final = -1.d+10
do i_state = 1, N_States
delta_e_final(i_state) = -1.d+10
enddo
return
endif
call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list)
delta_e_inactive = 0.d0
integer :: n_holes_total
n_holes_total = 0
do i = 1, n_holes_spin(1)
i_hole_inact = holes_list(i,1)
n_holes_total +=1
list_holes_inact(n_holes_total,1) = i_hole_inact
list_holes_inact(n_holes_total,2) = 1
do i_state = 1, N_states
delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact,i_state)
delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state)
enddo
enddo
do i = 1, n_holes_spin(2)
i_hole_inact = holes_list(i,2)
n_holes_total +=1
list_holes_inact(n_holes_total,1) = i_hole_inact
list_holes_inact(n_holes_total,2) = 2
do i_state = 1, N_states
delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state)
enddo
@ -215,14 +226,14 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
do i = 1, n_particles_spin(1)
i_part_virt = particles_list(i,1)
do i_state = 1, N_states
delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state)
delta_e_virt(i_state) += fock_virt_total_spin_trace(i_part_virt,i_state)
enddo
enddo
do i = 1, n_particles_spin(2)
i_part_virt = particles_list(i,2)
do i_state = 1, N_states
delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state)
delta_e_virt(i_state) += fock_virt_total_spin_trace(i_part_virt,i_state)
enddo
enddo
@ -293,27 +304,39 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
if (n_holes_act == 0 .and. n_particles_act == 1) then
ispin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
! call get_excitation_degree(det_1,det_2,degree,N_int)
! if(degree == 1)then
! call get_excitation(det_1,det_2,exc,degree,phase,N_int)
! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
! i_hole = list_inact_reverse(h1)
! i_part = list_act_reverse(p1)
! do i_state = 1, N_states
! delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state)
! enddo
! else if (degree == 2)then
call get_excitation_degree(det_1,det_2,degree,N_int)
if(degree == 1)then
call get_excitation(det_1,det_2,exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
i_hole = list_inact_reverse(h1)
i_part = list_act_reverse(p1)
do i_state = 1, N_states
delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state)
enddo
else if (degree == 2)then
do i_state = 1, N_states
delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state)
enddo
! endif
endif
else if (n_holes_act == 1 .and. n_particles_act == 0) then
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
call get_excitation_degree(det_1,det_2,degree,N_int)
if(degree == 1)then
call get_excitation(det_1,det_2,exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
i_hole = list_act_reverse(h1)
i_part = list_virt_reverse(p1)
do i_state = 1, N_states
delta_e_act(i_state) += one_creat_virt(i_hole,i_part,i_state)
! delta_e_act += 1.d12
enddo
else if (degree == 2)then
do i_state = 1, N_states
delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state)
enddo
endif
else if (n_holes_act == 1 .and. n_particles_act == 1) then
! first hole
@ -359,18 +382,350 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
enddo
else if (n_holes_act == 1 .and. n_particles_act == 2) then
! first hole
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
! first particle
kspin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
! first particle
jspin = particle_list_practical(1,2)
j_particle_act = particle_list_practical(2,2)
do i_state = 1, N_states
delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,kspin,jspin,ispin,i_state)
enddo
! ! First find the particle that has been added from the inactive
! !
! integer :: spin_hole_inact, spin_hole_part_act
! spin_hole_inact = list_holes_inact(1,2)
!
! ! by convention, you first make a movement in the cas
! ! first hole
! i_hole_act = hole_list_practical(2,1)
! if(particle_list_practical(1,1) == spin_hole_inact)then
! ! first particle
! i_particle_act = particle_list_practical(1,2)
! ! second particle
! j_particle_act = particle_list_practical(2,2)
! else if (particle_list_practical(1,2) == spin_hole_inact)then
! ! first particle
! i_particle_act = particle_list_practical(2,2)
! ! second particle
! j_particle_act = particle_list_practical(1,2)
! else
! print*, 'pb in n_holes_act == 1 .and. n_particles_act == 2 !!'
! stop
! endif
! do i_state = 1, N_states
! delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,i_state)
! enddo
else if (n_holes_act == 3 .and. n_particles_act == 0) then
! first hole
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
! second hole
jspin = hole_list_practical(1,2)
j_hole_act = hole_list_practical(2,2)
! third hole
kspin = hole_list_practical(1,3)
k_hole_act = hole_list_practical(2,3)
do i_state = 1, N_states
delta_e_act(i_state) += three_anhil(i_hole_act,j_hole_act,k_hole_act,ispin,jspin,kspin,i_state)
enddo
else if (n_holes_act == 0 .and. n_particles_act == 3) then
! first particle
ispin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
! second particle
jspin = particle_list_practical(1,2)
j_particle_act = particle_list_practical(2,2)
! second particle
kspin = particle_list_practical(1,3)
k_particle_act = particle_list_practical(2,3)
do i_state = 1, N_states
delta_e_act(i_state) += three_creat(i_particle_act,j_particle_act,k_particle_act,ispin,jspin,kspin,i_state)
enddo
else if (n_holes_act .eq. 0 .and. n_particles_act .eq.0)then
integer :: degree
integer(bit_kind) :: det_1_active(N_int,2)
integer :: h1,h2,p1,p2,s1,s2
integer :: exc(0:2,2,2)
integer :: i_hole, i_part
double precision :: phase
call get_excitation_degree(det_1,det_2,degree,N_int)
if(degree == 1)then
call get_excitation(det_1,det_2,exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
i_hole = list_inact_reverse(h1)
i_part = list_virt_reverse(p1)
do i_state = 1, N_states
delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state)
enddo
endif
else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then
do i = 1, N_states
delta_e_act(i_state) = -1.d12
enddo
endif
!print*, 'one_anhil_spin_trace'
!print*, one_anhil_spin_trace(1), one_anhil_spin_trace(2)
do i_state = 1, n_states
delta_e_final(i_state) = delta_e_act(i_state) + delta_e_inactive(i_state) - delta_e_virt(i_state)
enddo
!write(*,'(100(f16.10,X))'), delta_e_final(1) , delta_e_act(1) , delta_e_inactive(1) , delta_e_virt(1)
!write(*,'(100(f16.10,X))'), delta_e_final(2) , delta_e_act(2) , delta_e_inactive(2) , delta_e_virt(2)
end
subroutine get_delta_e_dyall_fast(det_1,det_2,delta_e_final)
BEGIN_DOC
! routine that returns the delta_e with the Moller Plesset and Dyall operators
!
! with det_1 being a determinant from the cas, and det_2 being a perturber
!
! Delta_e(det_1,det_2) = sum (hole) epsilon(hole) + sum(part) espilon(part) + delta_e(act)
!
! where hole is necessary in the inactive, part necessary in the virtuals
!
! and delta_e(act) is obtained from the contracted application of the excitation
!
! operator in the active space that lead from det_1 to det_2
END_DOC
implicit none
use bitmasks
double precision, intent(out) :: delta_e_final(N_states)
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
integer :: i,j,k,l
integer :: i_state
integer :: n_holes_spin(2)
integer :: n_holes
integer :: holes_list(N_int*bit_kind_size,2)
double precision :: delta_e_inactive(N_states)
integer :: i_hole_inact, list_holes_inact(n_inact_orb,2)
call get_excitation_degree(det_1,det_2,degree,N_int)
if(degree>2)then
do i_state = 1, N_States
delta_e_final(i_state) = -1.d+10
enddo
return
endif
call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list)
delta_e_inactive = 0.d0
integer :: n_holes_total
n_holes_total = 0
do i = 1, n_holes_spin(1)
i_hole_inact = holes_list(i,1)
n_holes_total +=1
list_holes_inact(n_holes_total,1) = i_hole_inact
list_holes_inact(n_holes_total,2) = 1
do i_state = 1, N_states
delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state)
enddo
enddo
do i = 1, n_holes_spin(2)
i_hole_inact = holes_list(i,2)
n_holes_total +=1
list_holes_inact(n_holes_total,1) = i_hole_inact
list_holes_inact(n_holes_total,2) = 2
do i_state = 1, N_states
delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state)
enddo
enddo
double precision :: delta_e_virt(N_states)
integer :: i_part_virt
integer :: n_particles_spin(2)
integer :: n_particles
integer :: particles_list(N_int*bit_kind_size,2)
call give_particles_in_virt_space(det_2,n_particles_spin,n_particles,particles_list)
delta_e_virt = 0.d0
do i = 1, n_particles_spin(1)
i_part_virt = particles_list(i,1)
do i_state = 1, N_states
delta_e_virt(i_state) += fock_virt_total_spin_trace(i_part_virt,i_state)
enddo
enddo
do i = 1, n_particles_spin(2)
i_part_virt = particles_list(i,2)
do i_state = 1, N_states
delta_e_virt(i_state) += fock_virt_total_spin_trace(i_part_virt,i_state)
enddo
enddo
integer :: n_holes_spin_act(2),n_particles_spin_act(2)
integer :: n_holes_act,n_particles_act
integer :: holes_active_list(2*n_act_orb,2)
integer :: holes_active_list_spin_traced(4*n_act_orb)
integer :: particles_active_list(2*n_act_orb,2)
integer :: particles_active_list_spin_traced(4*n_act_orb)
double precision :: delta_e_act(N_states)
delta_e_act = 0.d0
call give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin_act,n_particles_spin_act, &
n_holes_act,n_particles_act,holes_active_list,particles_active_list)
integer :: icount,icountbis
integer :: hole_list_practical(2,elec_num_tab(1)+elec_num_tab(2)), particle_list_practical(2,elec_num_tab(1)+elec_num_tab(2))
icount = 0
icountbis = 0
do i = 1, n_holes_spin_act(1)
icount += 1
icountbis += 1
hole_list_practical(1,icountbis) = 1
hole_list_practical(2,icountbis) = holes_active_list(i,1)
holes_active_list_spin_traced(icount) = holes_active_list(i,1)
enddo
do i = 1, n_holes_spin_act(2)
icount += 1
icountbis += 1
hole_list_practical(1,icountbis) = 2
hole_list_practical(2,icountbis) = holes_active_list(i,2)
holes_active_list_spin_traced(icount) = holes_active_list(i,2)
enddo
if(icount .ne. n_holes_act) then
print*,''
print*, icount, n_holes_act
print * , 'pb in holes_active_list_spin_traced !!'
stop
endif
icount = 0
icountbis = 0
do i = 1, n_particles_spin_act(1)
icount += 1
icountbis += 1
particle_list_practical(1,icountbis) = 1
particle_list_practical(2,icountbis) = particles_active_list(i,1)
particles_active_list_spin_traced(icount) = particles_active_list(i,1)
enddo
do i = 1, n_particles_spin_act(2)
icount += 1
icountbis += 1
particle_list_practical(1,icountbis) = 2
particle_list_practical(2,icountbis) = particles_active_list(i,2)
particles_active_list_spin_traced(icount) = particles_active_list(i,2)
enddo
if(icount .ne. n_particles_act) then
print*, icount, n_particles_act
print * , 'pb in particles_active_list_spin_traced !!'
stop
endif
integer :: i_hole_act, j_hole_act, k_hole_act
integer :: i_particle_act, j_particle_act, k_particle_act
integer :: ispin,jspin,kspin
if (n_holes_act == 0 .and. n_particles_act == 1) then
ispin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
call get_excitation_degree(det_1,det_2,degree,N_int)
if(degree == 1)then
call get_excitation(det_1,det_2,exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
i_hole = list_inact_reverse(h1)
i_part = list_act_reverse(p1)
do i_state = 1, N_states
delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state)
enddo
else if (degree == 2)then
do i_state = 1, N_states
delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state)
enddo
endif
else if (n_holes_act == 1 .and. n_particles_act == 0) then
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
call get_excitation_degree(det_1,det_2,degree,N_int)
if(degree == 1)then
call get_excitation(det_1,det_2,exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
i_hole = list_act_reverse(h1)
i_part = list_virt_reverse(p1)
do i_state = 1, N_states
delta_e_act(i_state) += one_creat_virt(i_hole,i_part,i_state)
enddo
else if (degree == 2)then
do i_state = 1, N_states
delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state)
enddo
endif
else if (n_holes_act == 1 .and. n_particles_act == 1) then
! first hole
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
! first particle
jspin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
! second particle
kspin = particle_list_practical(1,2)
j_particle_act = particle_list_practical(2,2)
do i_state = 1, N_states
delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state)
delta_e_act(i_state) += one_anhil_one_creat(i_particle_act,i_hole_act,jspin,ispin,i_state)
enddo
else if (n_holes_act == 2 .and. n_particles_act == 0) then
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
jspin = hole_list_practical(1,2)
j_hole_act = hole_list_practical(2,2)
do i_state = 1, N_states
delta_e_act(i_state) += two_anhil(i_hole_act,j_hole_act,ispin,jspin,i_state)
enddo
else if (n_holes_act == 0 .and. n_particles_act == 2) then
ispin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
jspin = particle_list_practical(1,2)
j_particle_act = particle_list_practical(2,2)
do i_state = 1, N_states
delta_e_act(i_state) += two_creat(i_particle_act,j_particle_act,ispin,jspin,i_state)
enddo
else if (n_holes_act == 2 .and. n_particles_act == 1) then
! first hole
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
! second hole
jspin = hole_list_practical(1,2)
j_hole_act = hole_list_practical(2,2)
! first particle
kspin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
do i_state = 1, N_states
delta_e_act(i_state) += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin,i_state)
enddo
else if (n_holes_act == 1 .and. n_particles_act == 2) then
! first hole
ispin = hole_list_practical(1,1)
i_hole_act = hole_list_practical(2,1)
! first particle
kspin = particle_list_practical(1,1)
i_particle_act = particle_list_practical(2,1)
! first particle
jspin = particle_list_practical(1,2)
j_particle_act = particle_list_practical(2,2)
do i_state = 1, N_states
delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,kspin,jspin,ispin,i_state)
enddo
else if (n_holes_act == 3 .and. n_particles_act == 0) then
@ -415,11 +770,13 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
i_hole = list_inact_reverse(h1)
i_part = list_virt_reverse(p1)
do i_state = 1, N_states
! delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state)
delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state)
enddo
endif
else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then
delta_e_act = -10000000.d0
do i = 1, N_states
delta_e_act(i_state) = -10000000.d0
enddo
endif
!print*, 'one_anhil_spin_trace'
@ -429,7 +786,8 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
do i_state = 1, n_states
delta_e_final(i_state) = delta_e_act(i_state) + delta_e_inactive(i_state) - delta_e_virt(i_state)
enddo
!write(*,'(100(f16.10,X))'), delta_e_final(1) , delta_e_act(1) , delta_e_inactive(1) , delta_e_virt(1)
!write(*,'(100(f16.10,X))'), delta_e_final(2) , delta_e_act(2) , delta_e_inactive(2) , delta_e_virt(2)
end

0
plugins/Perturbation/pt2_new.irp.f → plugins/MRPT_Utils/pt2_new.irp.f
View File

8
plugins/MRPT_Utils/second_order_new.irp.f
View File

@ -22,8 +22,8 @@ subroutine give_1h2p_new(matrix_1h2p)
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
double precision :: accu_contrib(N_states)
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: degree(N_det_Ref)
integer :: idx(0:N_det_Ref)
double precision :: delta_e(n_act_orb,2,N_states)
double precision :: delta_e_inv(n_act_orb,2,N_states)
double precision :: delta_e_inactive_virt(N_states)
@ -502,8 +502,8 @@ subroutine give_2h1p_new(matrix_2h1p)
double precision :: delta_e_inv(n_act_orb,2,N_states)
double precision :: fock_operator_local(n_act_orb,n_act_orb,2)
double precision :: delta_e_inactive_virt(N_states)
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: degree(N_det_Ref)
integer :: idx(0:N_det_Ref)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,3)

4
plugins/MRPT_Utils/second_order_new_2p.irp.f
View File

@ -21,8 +21,8 @@ subroutine give_2p_new(matrix_2p)
double precision :: active_int(n_act_orb,n_act_orb,2)
double precision :: hij,phase
double precision :: accu_contrib(N_states)
integer :: degree(N_det)
integer :: idx(0:N_det)
integer :: degree(N_det_Ref)
integer :: idx(0:N_det_Ref)
double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states)
double precision :: delta_e_inv(n_act_orb,n_act_orb,2,2,N_states)
double precision :: delta_e_inactive_virt(N_states)

12
plugins/Perturbation/EZFIO.cfg
View File

@ -18,3 +18,15 @@ doc: The selection process stops when the energy ratio variational/(variational+
interface: ezfio,provider,ocaml
default: 0.75
[threshold_generators_pt2]
type: Threshold
doc: Thresholds on generators (fraction of the norm) for final PT2 calculation
interface: ezfio,provider,ocaml
default: 0.999
[threshold_selectors_pt2]
type: Threshold
doc: Thresholds on selectors (fraction of the norm) for final PT2 calculation
interface: ezfio,provider,ocaml
default: 1.

2
plugins/Perturbation/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Determinants Properties Hartree_Fock Davidson MRPT_Utils
Determinants Properties Hartree_Fock Davidson

30
plugins/Perturbation/pt2_equations.irp.f
View File

@ -46,36 +46,6 @@ subroutine pt2_epstein_nesbet ($arguments)
end
subroutine pt2_decontracted ($arguments)
use bitmasks
implicit none
$declarations
BEGIN_DOC
END_DOC
integer :: i,j
double precision :: diag_H_mat_elem_fock, h
double precision :: i_H_psi_array(N_st)
double precision :: coef_pert
PROVIDE selection_criterion
ASSERT (Nint == N_int)
ASSERT (Nint > 0)
!call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array)
call i_H_psi_pert_new_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array,coef_pert)
H_pert_diag = 0.d0
c_pert(1) = coef_pert
e_2_pert(1) = coef_pert * i_H_psi_array(1)
! print*,coef_pert,i_H_psi_array(1)
end
subroutine pt2_epstein_nesbet_2x2 ($arguments)
use bitmasks
implicit none

11
plugins/Psiref_CAS/psi_ref.irp.f
View File

@ -67,3 +67,14 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [double precision, electronic_psi_ref_average_value, (N_states)]
&BEGIN_PROVIDER [double precision, psi_ref_average_value, (N_states)]
implicit none
integer :: i,j
call u_0_H_u_0(electronic_psi_ref_average_value,psi_ref_coef,N_det_ref,psi_ref,N_int,N_states,psi_det_size)
do i = 1, N_states
psi_ref_average_value(i) = electronic_psi_ref_average_value(i) + nuclear_repulsion
enddo
END_PROVIDER

4
plugins/Psiref_Utils/psi_ref_utils.irp.f
View File

@ -97,6 +97,10 @@ END_PROVIDER
endif
enddo
N_det_non_ref = i_non_ref
if (N_det_non_ref < 1) then
print *, 'Error : All determinants are in the reference'
stop -1
endif
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_restart, (N_int,2,psi_det_size) ]

25
plugins/SCF_density/.gitignore vendored Normal file
View File

@ -0,0 +1,25 @@
# Automatically created by $QP_ROOT/scripts/module/module_handler.py
.ninja_deps
.ninja_log
AO_Basis
Bitmask
Electrons
Ezfio_files
Huckel_guess
IRPF90_man
IRPF90_temp
Integrals_Bielec
Integrals_Monoelec
MOGuess
MO_Basis
Makefile
Makefile.depend
Nuclei
Pseudo
SCF
Utils
ZMQ
ezfio_interface.irp.f
irpf90.make
irpf90_entities
tags

35
plugins/SCF_density/EZFIO.cfg Normal file
View File

@ -0,0 +1,35 @@
[thresh_scf]
type: Threshold
doc: Threshold on the convergence of the Hartree Fock energy
interface: ezfio,provider,ocaml
default: 1.e-10
[n_it_scf_max]
type: Strictly_positive_int
doc: Maximum number of SCF iterations
interface: ezfio,provider,ocaml
default: 200
[level_shift]
type: Positive_float
doc: Energy shift on the virtual MOs to improve SCF convergence
interface: ezfio,provider,ocaml
default: 0.5
[mo_guess_type]
type: MO_guess
doc: Initial MO guess. Can be [ Huckel | HCore ]
interface: ezfio,provider,ocaml
default: Huckel
[energy]
type: double precision
doc: Calculated HF energy
interface: ezfio
[no_oa_or_av_opt]
type: logical
doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure
interface: ezfio,provider,ocaml
default: False

437
plugins/SCF_density/Fock_matrix.irp.f Normal file
View File

@ -0,0 +1,437 @@
BEGIN_PROVIDER [ double precision, Fock_matrix_mo, (mo_tot_num_align,mo_tot_num) ]
&BEGIN_PROVIDER [ double precision, Fock_matrix_diag_mo, (mo_tot_num)]
implicit none
BEGIN_DOC
! Fock matrix on the MO basis.
! For open shells, the ROHF Fock Matrix is
!
! | F-K | F + K/2 | F |
! |---------------------------------|
! | F + K/2 | F | F - K/2 |
! |---------------------------------|
! | F | F - K/2 | F + K |
!
! F = 1/2 (Fa + Fb)
!
! K = Fb - Fa
!
END_DOC
integer :: i,j,n
if (elec_alpha_num == elec_beta_num) then
Fock_matrix_mo = Fock_matrix_alpha_mo
else
do j=1,elec_beta_num
! F-K
do i=1,elec_beta_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
- (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F+K/2
do i=elec_beta_num+1,elec_alpha_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
+ 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F
do i=elec_alpha_num+1, mo_tot_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
enddo
enddo
do j=elec_beta_num+1,elec_alpha_num
! F+K/2
do i=1,elec_beta_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
+ 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F
do i=elec_beta_num+1,elec_alpha_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
enddo
! F-K/2
do i=elec_alpha_num+1, mo_tot_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
- 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
enddo
do j=elec_alpha_num+1, mo_tot_num
! F
do i=1,elec_beta_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
enddo
! F-K/2
do i=elec_beta_num+1,elec_alpha_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
- 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
! F+K
do i=elec_alpha_num+1,mo_tot_num
Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) &
+ (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
enddo
enddo
endif
do i = 1, mo_tot_num
Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i)
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ]
&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao, (ao_num_align, ao_num) ]
implicit none
BEGIN_DOC
! Alpha Fock matrix in AO basis set
END_DOC
integer :: i,j
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,ao_num
Fock_matrix_alpha_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j)
Fock_matrix_beta_ao (i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_alpha, (ao_num_align, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_beta , (ao_num_align, ao_num) ]
use map_module
implicit none
BEGIN_DOC
! Alpha Fock matrix in AO basis set
END_DOC
integer :: i,j,k,l,k1,r,s
integer :: i0,j0,k0,l0
integer*8 :: p,q
double precision :: integral, c0, c1, c2
double precision :: ao_bielec_integral, local_threshold
double precision, allocatable :: ao_bi_elec_integral_alpha_tmp(:,:)
double precision, allocatable :: ao_bi_elec_integral_beta_tmp(:,:)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_alpha_tmp
ao_bi_elec_integral_alpha = 0.d0
ao_bi_elec_integral_beta = 0.d0
if (do_direct_integrals) then
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, &
!$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, &
!$OMP local_threshold)&
!$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,&
!$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, &
!$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta)
allocate(keys(1), values(1))
allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), &
ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num))
ao_bi_elec_integral_alpha_tmp = 0.d0
ao_bi_elec_integral_beta_tmp = 0.d0
q = ao_num*ao_num*ao_num*ao_num
!$OMP DO SCHEDULE(dynamic)
do p=1_8,q
call bielec_integrals_index_reverse(kk,ii,ll,jj,p)
if ( (kk(1)>ao_num).or. &
(ii(1)>ao_num).or. &
(jj(1)>ao_num).or. &
(ll(1)>ao_num) ) then
cycle
endif
k = kk(1)
i = ii(1)
l = ll(1)
j = jj(1)
if (ao_overlap_abs(k,l)*ao_overlap_abs(i,j) &
< ao_integrals_threshold) then
cycle
endif
local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j)
if (local_threshold < ao_integrals_threshold) then
cycle
endif
i0 = i
j0 = j
k0 = k
l0 = l
values(1) = 0.d0
local_threshold = ao_integrals_threshold/local_threshold
do k2=1,8
if (kk(k2)==0) then
cycle
endif
i = ii(k2)
j = jj(k2)
k = kk(k2)
l = ll(k2)
c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)
c1 = HF_density_matrix_ao_alpha(k,i)
c2 = HF_density_matrix_ao_beta(k,i)
if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then
cycle
endif
if (values(1) == 0.d0) then
values(1) = ao_bielec_integral(k0,l0,i0,j0)
endif
integral = c0 * values(1)
ao_bi_elec_integral_alpha_tmp(i,j) += integral
ao_bi_elec_integral_beta_tmp (i,j) += integral
integral = values(1)
ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral
ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp
!$OMP END CRITICAL
!$OMP CRITICAL
ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp
!$OMP END CRITICAL
deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)
!$OMP END PARALLEL
else
PROVIDE ao_bielec_integrals_in_map
integer(omp_lock_kind) :: lck(ao_num)
integer*8 :: i8
integer :: ii(8), jj(8), kk(8), ll(8), k2
integer(cache_map_size_kind) :: n_elements_max, n_elements
integer(key_kind), allocatable :: keys(:)
double precision, allocatable :: values(:)
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,n_elements_max, &
!$OMP n_elements,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)&
!$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,&
!$OMP ao_integrals_map, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta)
call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max)
allocate(keys(n_elements_max), values(n_elements_max))
allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), &
ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num))
ao_bi_elec_integral_alpha_tmp = 0.d0
ao_bi_elec_integral_beta_tmp = 0.d0
!$OMP DO SCHEDULE(dynamic)
!DIR$ NOVECTOR
do i8=0_8,ao_integrals_map%map_size
n_elements = n_elements_max
call get_cache_map(ao_integrals_map,i8,keys,values,n_elements)
do k1=1,n_elements
call bielec_integrals_index_reverse(kk,ii,ll,jj,keys(k1))
do k2=1,8
if (kk(k2)==0) then
cycle
endif
i = ii(k2)
j = jj(k2)
k = kk(k2)
l = ll(k2)
integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(k1)
ao_bi_elec_integral_alpha_tmp(i,j) += integral
ao_bi_elec_integral_beta_tmp (i,j) += integral
integral = values(k1)
ao_bi_elec_integral_alpha_tmp(l,j) -= HF_density_matrix_ao_alpha(k,i) * integral
ao_bi_elec_integral_beta_tmp (l,j) -= HF_density_matrix_ao_beta (k,i) * integral
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP CRITICAL
ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp
!$OMP END CRITICAL
!$OMP CRITICAL
ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp
!$OMP END CRITICAL
deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)
!$OMP END PARALLEL
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Fock matrix on the MO basis
END_DOC
double precision, allocatable :: T(:,:)
allocate ( T(ao_num_align,mo_tot_num) )
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
call dgemm('N','N', ao_num, mo_tot_num, ao_num, &
1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1), &
mo_coef, size(mo_coef,1), &
0.d0, T, ao_num_align)
call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, &
1.d0, mo_coef,size(mo_coef,1), &
T, size(T,1), &
0.d0, Fock_matrix_alpha_mo, mo_tot_num_align)
deallocate(T)
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Fock matrix on the MO basis
END_DOC
double precision, allocatable :: T(:,:)
allocate ( T(ao_num_align,mo_tot_num) )
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
call dgemm('N','N', ao_num, mo_tot_num, ao_num, &
1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1), &
mo_coef, size(mo_coef,1), &
0.d0, T, ao_num_align)
call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, &
1.d0, mo_coef,size(mo_coef,1), &
T, size(T,1), &
0.d0, Fock_matrix_beta_mo, mo_tot_num_align)
deallocate(T)
END_PROVIDER
BEGIN_PROVIDER [ double precision, HF_energy ]
implicit none
BEGIN_DOC
! Hartree-Fock energy
END_DOC
HF_energy = nuclear_repulsion
integer :: i,j
do j=1,ao_num
do i=1,ao_num
HF_energy += 0.5d0 * ( &
(ao_mono_elec_integral(i,j) + Fock_matrix_alpha_ao(i,j) ) * HF_density_matrix_ao_alpha(i,j) +&
(ao_mono_elec_integral(i,j) + Fock_matrix_beta_ao (i,j) ) * HF_density_matrix_ao_beta (i,j) )
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ]
implicit none
BEGIN_DOC
! Fock matrix in AO basis set
END_DOC
if ( (elec_alpha_num == elec_beta_num).and. &
(level_shift == 0.) ) &
then
integer :: i,j
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,ao_num_align
Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j)
enddo
enddo
else
double precision, allocatable :: T(:,:), M(:,:)
integer :: ierr
! F_ao = S C F_mo C^t S
allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr)
if (ierr /=0 ) then
print *, irp_here, ' : allocation failed'
endif
! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num)
! -> M(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, &
ao_overlap, size(ao_overlap,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num)
! -> T(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, &
M, size(M,1), &
Fock_matrix_mo, size(Fock_matrix_mo,1), &
0.d0, &
T, size(T,1))
! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num)
! -> M(ao_num,ao_num)
call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, &
T, size(T,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num)
! -> Fock_matrix_ao(ao_num,ao_num)
call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, &
M, size(M,1), &
ao_overlap, size(ao_overlap,1), &
0.d0, &
Fock_matrix_ao, size(Fock_matrix_ao,1))
deallocate(T)
endif
END_PROVIDER
subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO)
implicit none
integer, intent(in) :: LDFMO ! size(FMO,1)
integer, intent(in) :: LDFAO ! size(FAO,1)
double precision, intent(in) :: FMO(LDFMO,*)
double precision, intent(out) :: FAO(LDFAO,*)
double precision, allocatable :: T(:,:), M(:,:)
integer :: ierr
! F_ao = S C F_mo C^t S
allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr)
if (ierr /=0 ) then
print *, irp_here, ' : allocation failed'
endif
! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num)
! -> M(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, &
ao_overlap, size(ao_overlap,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num)
! -> T(ao_num,mo_tot_num)
call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, &
M, size(M,1), &
FMO, size(FMO,1), &
0.d0, &
T, size(T,1))
! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num)
! -> M(ao_num,ao_num)
call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, &
T, size(T,1), &
mo_coef, size(mo_coef,1), &
0.d0, &
M, size(M,1))
! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num)
! -> Fock_matrix_ao(ao_num,ao_num)
call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, &
M, size(M,1), &
ao_overlap, size(ao_overlap,1), &
0.d0, &
FAO, size(FAO,1))
deallocate(T,M)
end

66
plugins/SCF_density/HF_density_matrix_ao.irp.f Normal file
View File

@ -0,0 +1,66 @@
BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ]
implicit none
BEGIN_DOC
! S^-1 x Alpha density matrix in the AO basis x S^-1
END_DOC
! call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, &
! mo_coef, size(mo_coef,1), &
! mo_coef, size(mo_coef,1), 0.d0, &
! HF_density_matrix_ao_alpha, size(HF_density_matrix_ao_alpha,1))
integer :: i,j,k,l
double precision :: test_alpha
HF_density_matrix_ao_alpha = 0.d0
do i = 1, mo_tot_num
do j = 1, mo_tot_num
if(dabs(mo_general_density_alpha(i,j)).le.1.d-10)cycle
do k = 1, ao_num
do l = 1, ao_num
HF_density_matrix_ao_alpha(k,l) += mo_coef(k,i) * mo_coef(l,j) * mo_general_density_alpha(i,j)
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_beta, (ao_num_align,ao_num) ]
implicit none
BEGIN_DOC
! S^-1 Beta density matrix in the AO basis x S^-1
END_DOC
! call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, &
! mo_coef, size(mo_coef,1), &
! mo_coef, size(mo_coef,1), 0.d0, &
! HF_density_matrix_ao_beta, size(HF_density_matrix_ao_beta,1))
integer :: i,j,k,l
double precision :: test_beta
HF_density_matrix_ao_beta = 0.d0
do i = 1, mo_tot_num
do j = 1, mo_tot_num
do k = 1, ao_num
do l = 1, ao_num
HF_density_matrix_ao_beta(k,l) += mo_coef(k,i) * mo_coef(l,j) * mo_general_density_beta(i,j)
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, HF_density_matrix_ao, (ao_num_align,ao_num) ]
implicit none
BEGIN_DOC
! S^-1 Density matrix in the AO basis S^-1
END_DOC
ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_alpha,1))
if (elec_alpha_num== elec_beta_num) then
HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_alpha
else
ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_beta ,1))
HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_beta
endif
END_PROVIDER

1
plugins/SCF_density/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Integrals_Bielec MOGuess Bitmask

175
plugins/SCF_density/README.rst Normal file
View File

@ -0,0 +1,175 @@
===================
SCF_density Module
===================
From the 140 molecules of the G2 set, only LiO, ONa don't converge well.
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
.. image:: tree_dependency.png
* `Integrals_Bielec <http://github.com/LCPQ/quantum_package/tree/master/src/Integrals_Bielec>`_
* `MOGuess <http://github.com/LCPQ/quantum_package/tree/master/src/MOGuess>`_
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
.. image:: tree_dependency.png
* `Integrals_Bielec <http://github.com/LCPQ/quantum_package/tree/master/src/Integrals_Bielec>`_
* `MOGuess <http://github.com/LCPQ/quantum_package/tree/master/src/MOGuess>`_
* `Bitmask <http://github.com/LCPQ/quantum_package/tree/master/src/Bitmask>`_
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
`ao_bi_elec_integral_alpha <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L103>`_
Alpha Fock matrix in AO basis set
`ao_bi_elec_integral_beta <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L104>`_
Alpha Fock matrix in AO basis set
`create_guess <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/SCF.irp.f#L13>`_
Create an MO guess if no MOs are present in the EZFIO directory
`damping_scf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/damping_SCF.irp.f#L1>`_
Undocumented
`diagonal_fock_matrix_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/diagonalize_fock.irp.f#L1>`_
Diagonal Fock matrix in the MO basis
`diagonal_fock_matrix_mo_sum <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/diagonalize_fock.irp.f#L95>`_
diagonal element of the fock matrix calculated as the sum over all the interactions
with all the electrons in the RHF determinant
diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij
`eigenvectors_fock_matrix_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/diagonalize_fock.irp.f#L2>`_
Diagonal Fock matrix in the MO basis
`fock_matrix_alpha_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L84>`_
Alpha Fock matrix in AO basis set
`fock_matrix_alpha_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L268>`_
Fock matrix on the MO basis
`fock_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L326>`_
Fock matrix in AO basis set
`fock_matrix_beta_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L85>`_
Alpha Fock matrix in AO basis set
`fock_matrix_beta_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L288>`_
Fock matrix on the MO basis
`fock_matrix_diag_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L2>`_
Fock matrix on the MO basis.
For open shells, the ROHF Fock Matrix is
.br
| F-K | F + K/2 | F |
|---------------------------------|
| F + K/2 | F | F - K/2 |
|---------------------------------|
| F | F - K/2 | F + K |
.br
F = 1/2 (Fa + Fb)
.br
K = Fb - Fa
.br
`fock_matrix_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L1>`_
Fock matrix on the MO basis.
For open shells, the ROHF Fock Matrix is
.br
| F-K | F + K/2 | F |
|---------------------------------|
| F + K/2 | F | F - K/2 |
|---------------------------------|
| F | F - K/2 | F + K |
.br
F = 1/2 (Fa + Fb)
.br
K = Fb - Fa
.br
`fock_mo_to_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L388>`_
Undocumented
`guess <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Huckel_guess.irp.f#L1>`_
Undocumented
`hf_density_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/HF_density_matrix_ao.irp.f#L27>`_
S^-1 Density matrix in the AO basis S^-1
`hf_density_matrix_ao_alpha <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/HF_density_matrix_ao.irp.f#L1>`_
S^-1 x Alpha density matrix in the AO basis x S^-1
`hf_density_matrix_ao_beta <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/HF_density_matrix_ao.irp.f#L14>`_
S^-1 Beta density matrix in the AO basis x S^-1
`hf_energy <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L307>`_
Hartree-Fock energy
`huckel_guess <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/huckel.irp.f#L1>`_
Build the MOs using the extended Huckel model
`level_shift <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L25>`_
Energy shift on the virtual MOs to improve SCF convergence
`mo_guess_type <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L6>`_
Initial MO guess. Can be [ Huckel | HCore ]
`n_it_scf_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L63>`_
Maximum number of SCF iterations
`no_oa_or_av_opt <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L82>`_
If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure
`run <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/SCF.irp.f#L38>`_
Run SCF calculation
`scf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/SCF.irp.f#L1>`_
Produce `Hartree_Fock` MO orbital
output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ
output: hartree_fock.energy
optional: mo_basis.mo_coef
`thresh_scf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/ezfio_interface.irp.f#L44>`_
Threshold on the convergence of the Hartree Fock energy

132
plugins/SCF_density/damping_SCF.irp.f Normal file
View File

@ -0,0 +1,132 @@
subroutine damping_SCF
implicit none
double precision :: E
double precision, allocatable :: D_alpha(:,:), D_beta(:,:)
double precision :: E_new
double precision, allocatable :: D_new_alpha(:,:), D_new_beta(:,:), F_new(:,:)
double precision, allocatable :: delta_alpha(:,:), delta_beta(:,:)
double precision :: lambda, E_half, a, b, delta_D, delta_E, E_min
integer :: i,j,k
logical :: saving
character :: save_char
allocate( &
D_alpha( ao_num_align, ao_num ), &
D_beta( ao_num_align, ao_num ), &
F_new( ao_num_align, ao_num ), &
D_new_alpha( ao_num_align, ao_num ), &
D_new_beta( ao_num_align, ao_num ), &
delta_alpha( ao_num_align, ao_num ), &
delta_beta( ao_num_align, ao_num ))
do j=1,ao_num
do i=1,ao_num
D_alpha(i,j) = HF_density_matrix_ao_alpha(i,j)
D_beta (i,j) = HF_density_matrix_ao_beta (i,j)
enddo
enddo
call write_time(output_hartree_fock)
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
'====','================','================','================', '===='
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save'
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') &
'====','================','================','================', '===='
E = HF_energy + 1.d0
E_min = HF_energy
delta_D = 0.d0
do k=1,n_it_scf_max
delta_E = HF_energy - E
E = HF_energy
if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then
exit
endif
saving = E < E_min
if (saving) then
call save_mos
save_char = 'X'
E_min = E
else
save_char = ' '
endif
write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') &
k, E, delta_E, delta_D, save_char
D_alpha = HF_density_matrix_ao_alpha
D_beta = HF_density_matrix_ao_beta
mo_coef = eigenvectors_fock_matrix_mo
TOUCH mo_coef
D_new_alpha = HF_density_matrix_ao_alpha
D_new_beta = HF_density_matrix_ao_beta
F_new = Fock_matrix_ao
E_new = HF_energy
delta_alpha = D_new_alpha - D_alpha
delta_beta = D_new_beta - D_beta
lambda = .5d0
E_half = 0.d0
do while (E_half > E)
HF_density_matrix_ao_alpha = D_alpha + lambda * delta_alpha
HF_density_matrix_ao_beta = D_beta + lambda * delta_beta
TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta
mo_coef = eigenvectors_fock_matrix_mo
TOUCH mo_coef
E_half = HF_energy
if ((E_half > E).and.(E_new < E)) then
lambda = 1.d0
exit
else if ((E_half > E).and.(lambda > 5.d-4)) then
lambda = 0.5d0 * lambda
E_new = E_half
else
exit
endif
enddo
a = (E_new + E - 2.d0*E_half)*2.d0
b = -E_new - 3.d0*E + 4.d0*E_half
lambda = -lambda*b/(a+1.d-16)
D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha
D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta
delta_E = HF_energy - E
do j=1,ao_num
do i=1,ao_num
delta_D = delta_D + &
(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j))*(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j)) + &
(D_beta (i,j) - HF_density_matrix_ao_beta (i,j))*(D_beta (i,j) - HF_density_matrix_ao_beta (i,j))
enddo
enddo
delta_D = dsqrt(delta_D/dble(ao_num)**2)
HF_density_matrix_ao_alpha = D_alpha
HF_density_matrix_ao_beta = D_beta
TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta
mo_coef = eigenvectors_fock_matrix_mo
TOUCH mo_coef
enddo
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '===='
write(output_hartree_fock,*)
if(.not.no_oa_or_av_opt)then
call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1)
endif
call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy')
call ezfio_set_hartree_fock_energy(E_min)
call write_time(output_hartree_fock)
deallocate(D_alpha,D_beta,F_new,D_new_alpha,D_new_beta,delta_alpha,delta_beta)
end

124
plugins/SCF_density/diagonalize_fock.irp.f Normal file
View File

@ -0,0 +1,124 @@
BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ]
&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ]
implicit none
BEGIN_DOC
! Diagonal Fock matrix in the MO basis
END_DOC
integer :: i,j
integer :: liwork, lwork, n, info
integer, allocatable :: iwork(:)
double precision, allocatable :: work(:), F(:,:), S(:,:)
allocate( F(mo_tot_num_align,mo_tot_num) )
do j=1,mo_tot_num
do i=1,mo_tot_num
F(i,j) = Fock_matrix_mo(i,j)
enddo
enddo
! print*, no_oa_or_av_opt
if(no_oa_or_av_opt)then
integer :: iorb,jorb
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_inact_orb
jorb = list_inact(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
do j = 1, n_virt_orb
jorb = list_virt(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
do j = 1, n_core_orb
jorb = list_core(j)
F(iorb,jorb) = 0.d0
F(jorb,iorb) = 0.d0
enddo
enddo
! do i = 1, n_act_orb
! iorb = list_act(i)
! write(*,'(100(F16.10,X))')F(iorb,:)
! enddo
endif
! Insert level shift here
do i = elec_beta_num+1, elec_alpha_num
F(i,i) += 0.5d0*level_shift
enddo
do i = elec_alpha_num+1, mo_tot_num
F(i,i) += level_shift
enddo
n = mo_tot_num
lwork = 1+6*n + 2*n*n
liwork = 3 + 5*n
allocate(work(lwork), iwork(liwork) )
lwork = -1
liwork = -1
call dsyevd( 'V', 'U', mo_tot_num, F, &
size(F,1), diagonal_Fock_matrix_mo, &
work, lwork, iwork, liwork, info)
if (info /= 0) then
print *, irp_here//' failed : ', info
stop 1
endif
lwork = int(work(1))
liwork = iwork(1)
deallocate(work,iwork)
allocate(work(lwork), iwork(liwork) )
call dsyevd( 'V', 'U', mo_tot_num, F, &
size(F,1), diagonal_Fock_matrix_mo, &
work, lwork, iwork, liwork, info)
if (info /= 0) then
print *, irp_here//' failed : ', info
stop 1
endif
call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, &
mo_coef, size(mo_coef,1), F, size(F,1), &
0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1))
deallocate(work, iwork, F)
! endif
END_PROVIDER
BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)]
implicit none
BEGIN_DOC
! diagonal element of the fock matrix calculated as the sum over all the interactions
! with all the electrons in the RHF determinant
! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij
END_DOC
integer :: i,j
double precision :: accu
do j = 1,elec_alpha_num
accu = 0.d0
do i = 1, elec_alpha_num
accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
enddo
diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
enddo
do j = elec_alpha_num+1,mo_tot_num
accu = 0.d0
do i = 1, elec_alpha_num
accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
enddo
diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
enddo
END_PROVIDER

32
plugins/SCF_density/huckel.irp.f Normal file
View File

@ -0,0 +1,32 @@
subroutine huckel_guess
implicit none
BEGIN_DOC
! Build the MOs using the extended Huckel model
END_DOC
integer :: i,j
double precision :: accu
double precision :: c
character*(64) :: label
label = "Guess"
call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral, &
size(mo_mono_elec_integral,1), &
size(mo_mono_elec_integral,2),label,1)
TOUCH mo_coef
c = 0.5d0 * 1.75d0
do j=1,ao_num
!DIR$ VECTOR ALIGNED
do i=1,ao_num
Fock_matrix_ao(i,j) = c*ao_overlap(i,j)*(ao_mono_elec_integral_diag(i) + &
ao_mono_elec_integral_diag(j))
enddo
Fock_matrix_ao(j,j) = Fock_matrix_alpha_ao(j,j)
enddo
TOUCH Fock_matrix_ao
mo_coef = eigenvectors_fock_matrix_mo
SOFT_TOUCH mo_coef
call save_mos
end

1
plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@

12
plugins/Selectors_CASSD/README.rst Normal file
View File

@ -0,0 +1,12 @@
===============
Selectors_CASSD
===============
Needed Modules
==============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.
Documentation
=============
.. Do not edit this section It was auto-generated
.. by the `update_README.py` script.

95
plugins/Selectors_CASSD/selectors.irp.f Normal file
View File

@ -0,0 +1,95 @@
use bitmasks
BEGIN_PROVIDER [ integer, psi_selectors_size ]
implicit none
psi_selectors_size = psi_det_size
END_PROVIDER
BEGIN_PROVIDER [ integer, N_det_selectors]
implicit none
BEGIN_DOC
! For Single reference wave functions, the number of selectors is 1 : the
! Hartree-Fock determinant
END_DOC
N_det_selectors = N_det
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_selectors, (N_int,2,psi_selectors_size) ]
&BEGIN_PROVIDER [ double precision, psi_selectors_coef, (psi_selectors_size,N_states) ]
implicit none
BEGIN_DOC
! Determinants on which we apply <i|H|psi> for perturbation.
END_DOC
integer :: i, k, l, m
logical :: good
do i=1,N_det_generators
do k=1,N_int
psi_selectors(k,1,i) = psi_det_generators(k,1,i)
psi_selectors(k,2,i) = psi_det_generators(k,2,i)
enddo
enddo
do k=1,N_states
do i=1,N_det_selectors
psi_selectors_coef(i,k) = psi_coef_generators(i,k)
enddo
enddo
m=N_det_generators
do i=1,N_det
do l=1,n_cas_bitmask
good = .True.
do k=1,N_int
good = good .and. ( &
iand(not(cas_bitmask(k,1,l)), psi_det_sorted(k,1,i)) == &
iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( &
iand(not(cas_bitmask(k,2,l)), psi_det_sorted(k,2,i)) == &
iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) )
enddo
if (good) then
exit
endif
enddo
if (.not.good) then
m = m+1
do k=1,N_int
psi_selectors(k,1,m) = psi_det_sorted(k,1,i)
psi_selectors(k,2,m) = psi_det_sorted(k,2,i)
enddo
psi_selectors_coef(m,:) = psi_coef_sorted(i,:)
endif
enddo
if (N_det /= m) then
print *, N_det, m
stop 'N_det /= m'
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ]
implicit none
BEGIN_DOC
! Transposed psi_selectors
END_DOC
integer :: i,k
do i=1,N_det_selectors
do k=1,N_states
psi_selectors_coef_transp(k,i) = psi_selectors_coef(i,k)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, psi_selectors_diag_h_mat, (psi_selectors_size) ]
implicit none
BEGIN_DOC
! Diagonal elements of the H matrix for each selectors
END_DOC
integer :: i
double precision :: diag_H_mat_elem
do i = 1, N_det_selectors
psi_selectors_diag_h_mat(i) = diag_H_mat_elem(psi_selectors(1,1,i),N_int)
enddo
END_PROVIDER

122
plugins/Selectors_CASSD/zmq.irp.f Normal file
View File

@ -0,0 +1,122 @@
subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy)
use f77_zmq
implicit none
BEGIN_DOC
! Put the wave function on the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer, intent(in) :: size_energy
double precision, intent(out) :: energy(size_energy)
integer :: rc
character*(256) :: msg
write(msg,*) 'put_psi ', worker_id, N_states, N_det, psi_det_size, n_det_generators, n_det_selectors
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)
if (rc /= len(trim(msg))) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)
if (rc /= N_int*2*N_det*bit_kind) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)
if (rc /= psi_det_size*N_states*8) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)
if (rc /= size_energy*8) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:rc) /= 'put_psi_reply 1') then
print *, rc, trim(msg)
print *, 'Error in put_psi_reply'
stop 'error'
endif
end
subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy)
use f77_zmq
implicit none
BEGIN_DOC
! Get the wave function from the qp_run scheduler
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
integer, intent(in) :: worker_id
integer, intent(in) :: size_energy
double precision, intent(out) :: energy(size_energy)
integer :: rc
character*(64) :: msg
write(msg,*) 'get_psi ', worker_id
rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)
if (rc /= len(trim(msg))) then
print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0)
if (msg(1:13) /= 'get_psi_reply') then
print *, rc, trim(msg)
print *, 'Error in get_psi_reply'
stop 'error'
endif
integer :: N_states_read, N_det_read, psi_det_size_read
integer :: N_det_selectors_read, N_det_generators_read
read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, &
N_det_generators_read, N_det_selectors_read
if (rc /= worker_id) then
print *, 'Wrong worker ID'
stop 'error'
endif
N_states = N_states_read
N_det = N_det_read
psi_det_size = psi_det_size_read
rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)
if (rc /= N_int*2*N_det*bit_kind) then
print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)
if (rc /= psi_det_size*N_states*8) then
print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)'
stop 'error'
endif
TOUCH psi_det_size N_det N_states psi_det psi_coef
rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)
if (rc /= size_energy*8) then
print *, 'f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)'
stop 'error'
endif
if (N_det_generators_read > 0) then
N_det_generators = N_det_generators_read
TOUCH N_det_generators
endif
if (N_det_selectors_read > 0) then
N_det_selectors = N_det_selectors_read
TOUCH N_det_selectors
endif
end

2
plugins/Selectors_full/selectors.irp.f
View File

@ -14,7 +14,7 @@ BEGIN_PROVIDER [ integer, N_det_selectors]
integer :: i
double precision :: norm, norm_max
call write_time(output_determinants)
N_det_selectors = N_det_generators
N_det_selectors = N_det
if (threshold_generators < 1.d0) then
norm = 0.d0
do i=1,N_det

2
plugins/loc_cele/loc.f
View File

@ -18,7 +18,7 @@ C
zprt=.true.
niter=1000000
conv=1.d-8
conv=1.d-10
C niter=1000000
C conv=1.d-6

43
plugins/loc_cele/loc_cele.irp.f
View File

@ -101,10 +101,29 @@
cmoref = 0.d0
irot = 0
irot(1,1) = 11
irot(2,1) = 12
cmoref(15,1,1) = 1.d0 !
cmoref(14,2,1) = 1.d0 !
irot(1,1) = 14
irot(2,1) = 15
! cmoref(6,1,1) = 1.d0
! cmoref(26,2,1) = 1.d0
cmoref(36,1,1) = 1.d0
cmoref(56,2,1) = 1.d0
! !!! H2O
! irot(1,1) = 4
! irot(2,1) = 5
! irot(3,1) = 6
! irot(4,1) = 7
! ! O pz
! cmoref(5,1,1) = 1.55362d0
! cmoref(6,1,1) = 1.07578d0
! cmoref(5,2,1) = 1.55362d0
! cmoref(6,2,1) = -1.07578d0
! ! O px - pz
! ! H1
! cmoref(16,3,1) = 1.d0
! ! H1
! cmoref(21,4,1) = 1.d0
! ESATRIENE with 3 bonding and anti bonding orbitals
! First bonding orbital for esa
@ -150,19 +169,19 @@
! ESATRIENE with 1 central bonding and anti bonding orbitals
! AND 4 radical orbitals
! First radical orbital
cmoref(7,1,1) = 1.d0 !
! cmoref(7,1,1) = 1.d0 !
! Second radical orbital
cmoref(26,2,1) = 1.d0 !
! cmoref(26,2,1) = 1.d0 !
! First bonding orbital
cmoref(45,3,1) = 1.d0 !
cmoref(64,3,1) = 1.d0 !
! cmoref(45,3,1) = 1.d0 !
! cmoref(64,3,1) = 1.d0 !
! Third radical orbital for esa
cmoref(83,4,1) = 1.d0 !
! cmoref(83,4,1) = 1.d0 !
! Fourth radical orbital for esa
cmoref(102,5,1) = 1.d0 !
! cmoref(102,5,1) = 1.d0 !
! First anti bonding orbital
cmoref(45,6,1) = 1.d0 !
cmoref(64,6,1) =-1.d0 !
! cmoref(45,6,1) = 1.d0 !
! cmoref(64,6,1) =-1.d0 !
do i = 1, nrot(1)

33
plugins/loc_cele/loc_exchange_int.irp.f
View File

@ -14,20 +14,21 @@ program loc_int
exchange_int = 0.d0
iorder = 0
print*,''
if(list_core_inact_check(iorb) == .False.)cycle
if(list_core_inact_check(iorb) .eqv. .False.)cycle
do j = i+1, n_core_inact_orb
jorb = list_core_inact(j)
iorder(jorb) = jorb
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
if(list_core_inact_check(jorb) == .False.)then
exchange_int(jorb) = 0.d0
else
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
endif
enddo
n_rot += 1
call dsort(exchange_int,iorder,mo_tot_num)
indices(n_rot,1) = iorb
indices(n_rot,2) = iorder(1)
list_core_inact_check(iorder(1)) = .False.
print*,indices(n_rot,1),indices(n_rot,2)
print*,''
print*,''
enddo
print*,'****************************'
print*,'-+++++++++++++++++++++++++'
@ -46,20 +47,21 @@ program loc_int
exchange_int = 0.d0
iorder = 0
print*,''
if(list_core_inact_check(iorb) == .False.)cycle
if(list_core_inact_check(iorb) .eqv. .False.)cycle
do j = i+1, n_act_orb
jorb = list_act(j)
iorder(jorb) = jorb
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
if(list_core_inact_check(jorb) == .False.)then
exchange_int(jorb) = 0.d0
else
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
endif
enddo
n_rot += 1
call dsort(exchange_int,iorder,mo_tot_num)
indices(n_rot,1) = iorb
indices(n_rot,2) = iorder(1)
list_core_inact_check(iorder(1)) = .False.
print*,indices(n_rot,1),indices(n_rot,2)
print*,''
print*,''
enddo
print*,'****************************'
print*,'-+++++++++++++++++++++++++'
@ -78,20 +80,21 @@ program loc_int
exchange_int = 0.d0
iorder = 0
print*,''
if(list_core_inact_check(iorb) == .False.)cycle
if(list_core_inact_check(iorb) .eqv. .False.)cycle
do j = i+1, n_virt_orb
jorb = list_virt(j)
iorder(jorb) = jorb
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
if(list_core_inact_check(jorb) == .False.)then
exchange_int(jorb) = 0.d0
else
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
endif
enddo
n_rot += 1
call dsort(exchange_int,iorder,mo_tot_num)
indices(n_rot,1) = iorb
indices(n_rot,2) = iorder(1)
list_core_inact_check(iorder(1)) = .False.
print*,indices(n_rot,1),indices(n_rot,2)
print*,''
print*,''
enddo
print*,'****************************'
print*,'-+++++++++++++++++++++++++'

11
plugins/loc_cele/loc_exchange_int_act.irp.f
View File

@ -15,20 +15,21 @@ program loc_int
exchange_int = 0.d0
iorder = 0
print*,''
if(list_core_inact_check(iorb) == .False.)cycle
if(list_core_inact_check(iorb) .eqv. .False.)cycle
do j = i+1, n_act_orb
jorb = list_act(j)
iorder(jorb) = jorb
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
if(list_core_inact_check(jorb) == .False.)then
exchange_int(jorb) = 0.d0
else
exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
endif
enddo
n_rot += 1
call dsort(exchange_int,iorder,mo_tot_num)
indices(n_rot,1) = iorb
indices(n_rot,2) = iorder(1)
list_core_inact_check(iorder(1)) = .False.
print*,indices(n_rot,1),indices(n_rot,2)
print*,''
print*,''
enddo
print*,'****************************'
print*,'-+++++++++++++++++++++++++'

2
plugins/loc_cele/loc_exchange_int_inact.irp.f
View File

@ -14,7 +14,7 @@ program loc_int
exchange_int = 0.d0
iorder = 0
print*,''
if(list_core_inact_check(iorb) == .False.)cycle
if(list_core_inact_check(iorb) .eqv. .False.)cycle
do j = i+1, n_core_inact_orb
jorb = list_core_inact(j)
iorder(jorb) = jorb

Some files were not shown because too many files have changed in this diff Show More