LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-12-22 12:23:48 +01:00
Code Issues Releases Wiki Activity

Merge branch 'scemama-master'

Browse Source
This commit is contained in:
Emmanuel Giner 2016-11-25 19:32:53 +01:00
commit 67a37a145a
91 changed files with 5200 additions and 1799 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

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/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

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.

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)

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

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

377
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
@ -614,221 +630,66 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [ double precision, dIj_unique, (hh_shortcut(hh_shortcut(0)+1)-1, N_states) ]
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 +699,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 +927,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 +941,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 +953,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
@ -1122,9 +976,13 @@ double precision function get_dij_index(II, i, s, Nint)
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
end if
end function
@ -1182,9 +1040,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 +1120,7 @@ end function
end if
end do
end do
hh_nex = hh_shortcut(hh_shortcut(0)+1)-1
END_PROVIDER

0
plugins/MRPT_Utils/MRPT_Utils.main.irp.f → plugins/MRPT/MRPT_Utils.main.irp.f
View File

1
plugins/MRPT/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
MRPT_Utils Selectors_full Generators_full

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

0
plugins/MRPT_Utils/print_1h2p.irp.f → plugins/MRPT/print_1h2p.irp.f
View File

1
plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES
View File

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

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.

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) ]

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

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

@ -13,7 +13,8 @@ program loc_int
iorb = list_core_inact(i)
exchange_int = 0.d0
iorder = 0
if(list_core_inact_check(iorb) == .False.)cycle
print*,''
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
@ -45,7 +46,8 @@ program loc_int
iorb = list_act(i)
exchange_int = 0.d0
iorder = 0
if(list_core_inact_check(iorb) == .False.)cycle
print*,''
if(list_core_inact_check(iorb) .eqv. .False.)cycle
do j = i+1, n_act_orb
jorb = list_act(j)
iorder(jorb) = jorb
@ -78,7 +80,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_virt_orb
jorb = list_virt(j)
iorder(jorb) = jorb

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

@ -15,7 +15,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_act_orb
jorb = list_act(j)
iorder(jorb) = jorb

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

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

@ -15,7 +15,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_virt_orb
jorb = list_virt(j)
iorder(jorb) = jorb

2
plugins/mrcepa0/EZFIO.cfg
View File

@ -23,7 +23,7 @@ interface: ezfio
type: Threshold
doc: Threshold on the convergence of the dressed CI energy
interface: ezfio,provider,ocaml
default: 5.e-5
default: 1.e-5
[n_it_max_dressed_ci]
type: Strictly_positive_int

178
plugins/mrcepa0/dressing.irp.f
View File

@ -4,6 +4,8 @@ use bitmasks
BEGIN_PROVIDER [ double precision, delta_ij_mrcc, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ij_s2_mrcc, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_s2_mrcc, (N_states, N_det_ref) ]
use bitmasks
implicit none
integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc
@ -14,11 +16,13 @@ use bitmasks
delta_ij_mrcc = 0d0
delta_ii_mrcc = 0d0
print *, "Dij", dij(1,1,1)
delta_ij_s2_mrcc = 0d0
delta_ii_s2_mrcc = 0d0
PROVIDE dij
provide hh_shortcut psi_det_size! lambda_mrcc
!$OMP PARALLEL DO default(none) schedule(dynamic) &
!$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) &
!$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc) &
!$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc, delta_ii_s2_mrcc, delta_ij_s2_mrcc) &
!$OMP private(h, n, mask, omask, buf, ok, iproc)
do gen= 1, N_det_generators
allocate(buf(N_int, 2, N_det_non_ref))
@ -37,7 +41,9 @@ use bitmasks
end do
n = n - 1
if(n /= 0) call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc,gen,n,buf,N_int,omask)
if(n /= 0) then
call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc, delta_ij_s2_mrcc, delta_ii_s2_mrcc, gen,n,buf,N_int,omask)
endif
end do
deallocate(buf)
@ -52,13 +58,15 @@ END_PROVIDER
! end subroutine
subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffer,Nint,key_mask)
subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_generator,n_selected,det_buffer,Nint,key_mask)
use bitmasks
implicit none
integer, intent(in) :: i_generator,n_selected, Nint
double precision, intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref)
double precision, intent(inout) :: delta_ii_(N_states,N_det_ref)
double precision, intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref)
double precision, intent(inout) :: delta_ii_s2_(N_states,N_det_ref)
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
integer :: i,j,k,l,m
@ -68,8 +76,8 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
integer(bit_kind),allocatable :: tq(:,:,:)
integer :: N_tq, c_ref ,degree
double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states)
double precision, allocatable :: dIa_hla(:,:)
double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states)
double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:)
double precision :: haj, phase, phase2
double precision :: f(N_states), ci_inv(N_states)
integer :: exc(0:2,2,2)
@ -82,7 +90,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
integer(bit_kind),intent(in) :: key_mask(Nint, 2)
integer,allocatable :: idx_miniList(:)
integer :: N_miniList, ni, leng
double precision, allocatable :: hij_cache(:)
double precision, allocatable :: hij_cache(:), sij_cache(:)
integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:)
integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:)
@ -92,7 +100,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
leng = max(N_det_generators, N_det_non_ref)
allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref))
allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref))
allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size))
!create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint)
call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint)
@ -117,7 +125,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
deallocate(microlist, idx_microlist)
allocate (dIa_hla(N_states,N_det_non_ref))
allocate (dIa_hla(N_states,N_det_non_ref), dIa_sla(N_states,N_det_non_ref))
! |I>
@ -185,6 +193,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd))
call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_cache(k_sd))
enddo
! |I>
do i_I=1,N_det_ref
@ -282,31 +291,36 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
hla = hij_cache(k_sd)
sla = sij_cache(k_sd)
! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla)
do i_state=1,N_states
dIa_hla(i_state,k_sd) = dIa(i_state) * hla
dIa_sla(i_state,k_sd) = dIa(i_state) * sla
enddo
enddo
call omp_set_lock( psi_ref_lock(i_I) )
do i_state=1,N_states
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd)
delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd)
enddo
else
! if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then
! do l_sd=1,idx_alpha(0)
! k_sd = idx_alpha(l_sd)
! delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd)
! delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd)
! delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd)
! delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd)
! enddo
! else
delta_ii_(i_state,i_I) = 0.d0
do l_sd=1,idx_alpha(0)
k_sd = idx_alpha(l_sd)
delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd)
delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd)
enddo
endif
! endif
enddo
call omp_unset_lock( psi_ref_lock(i_I) )
enddo
enddo
deallocate (dIa_hla,hij_cache)
deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache)
deallocate(miniList, idx_miniList)
end
@ -315,45 +329,84 @@ end
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) ]
&BEGIN_PROVIDER [ double precision, delta_ij_s2, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_s2, (N_states, N_det_ref) ]
use bitmasks
implicit none
integer :: i, j, i_state
integer :: i, j, i_state
!mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc
do i_state = 1, N_states
if(mrmode == 3) then
if(mrmode == 3) then
do i = 1, N_det_ref
delta_ii(i_state,i)= delta_ii_mrcc(i_state,i)
do i_state = 1, N_states
delta_ii(i_state,i)= delta_ii_mrcc(i_state,i)
delta_ii_s2(i_state,i)= delta_ii_s2_mrcc(i_state,i)
enddo
do j = 1, N_det_non_ref
delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i)
do i_state = 1, N_states
delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i)
delta_ij_s2(i_state,j,i) = delta_ij_s2_mrcc(i_state,j,i)
enddo
end do
end do
!
! do i = 1, N_det_ref
! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state)
! do j = 1, N_det_non_ref
! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state)
! end do
! end do
else if(mrmode == 2) then
do i = 1, N_det_ref
! =-=-= BEGIN STATE AVERAGE
! do i = 1, N_det_ref
! delta_ii(:,i)= delta_ii_mrcc(1,i)
! delta_ii_s2(:,i)= delta_ii_s2_mrcc(1,i)
! do i_state = 2, N_states
! delta_ii(:,i) += delta_ii_mrcc(i_state,i)
! delta_ii_s2(:,i) += delta_ii_s2_mrcc(i_state,i)
! enddo
! do j = 1, N_det_non_ref
! delta_ij(:,j,i) = delta_ij_mrcc(1,j,i)
! delta_ij_s2(:,j,i) = delta_ij_s2_mrcc(1,j,i)
! do i_state = 2, N_states
! delta_ij(:,j,i) += delta_ij_mrcc(i_state,j,i)
! delta_ij_s2(:,j,i) += delta_ij_s2_mrcc(i_state,j,i)
! enddo
! end do
! end do
! delta_ij = delta_ij * (1.d0/dble(N_states))
! delta_ii = delta_ii * (1.d0/dble(N_states))
! =-=-= END STATE AVERAGE
!
! do i = 1, N_det_ref
! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state)
! do j = 1, N_det_non_ref
! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state)
! end do
! end do
else if(mrmode == 2) then
do i = 1, N_det_ref
do i_state = 1, N_states
delta_ii(i_state,i)= delta_ii_old(i_state,i)
do j = 1, N_det_non_ref
delta_ii_s2(i_state,i)= delta_ii_s2_old(i_state,i)
enddo
do j = 1, N_det_non_ref
do i_state = 1, N_states
delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i)
end do
delta_ij_s2(i_state,j,i) = delta_ij_s2_old(i_state,j,i)
enddo
end do
else if(mrmode == 1) then
do i = 1, N_det_ref
end do
else if(mrmode == 1) then
do i = 1, N_det_ref
do i_state = 1, N_states
delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state)
do j = 1, N_det_non_ref
delta_ii_s2(i_state,i)= delta_mrcepa0_ii_s2(i,i_state)
enddo
do j = 1, N_det_non_ref
do i_state = 1, N_states
delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state)
end do
delta_ij_s2(i_state,j,i) = delta_mrcepa0_ij_s2(i,j,i_state)
enddo
end do
else
stop "invalid mrmode"
end if
end do
end do
else
stop "invalid mrmode"
end if
END_PROVIDER
@ -537,28 +590,32 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ]
&BEGIN_PROVIDER [ double precision, delta_cas_s2, (N_det_ref, N_det_ref, N_states) ]
use bitmasks
implicit none
integer :: i,j,k
double precision :: Hjk, Hki, Hij
double precision :: Sjk,Hjk, Hki, Hij
!double precision, external :: get_dij
integer i_state, degree
provide lambda_mrcc dIj
do i_state = 1, N_states
!$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref,dij)
!$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,delta_cas_s2,N_det_ref,dij)
do i=1,N_det_ref
do j=1,i
call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int)
delta_cas(i,j,i_state) = 0d0
delta_cas_s2(i,j,i_state) = 0d0
do k=1,N_det_non_ref
call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk)
call get_s2(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Sjk)
delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k)
!print *, Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int), Hki * get_dij(psi_ref(1,1,j), psi_non_ref(1,1,k), N_int)
delta_cas_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * lambda_mrcc(i_state, k)
end do
delta_cas(j,i,i_state) = delta_cas(i,j,i_state)
delta_cas_s2(j,i,i_state) = delta_cas_s2(i,j,i_state)
end do
end do
!$OMP END PARALLEL DO
@ -639,6 +696,8 @@ end function
BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ]
&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii, (N_det_ref,N_states) ]
&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij_s2, (N_det_ref,N_det_non_ref,N_states) ]
&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii_s2, (N_det_ref,N_states) ]
use bitmasks
implicit none
@ -646,7 +705,7 @@ end function
integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref)
logical :: ok
double precision :: phase_iI, phase_Ik, phase_Jl, phase_IJ, phase_al, diI, hIi, hJi, delta_JI, dkI(1), HkI, ci_inv(1), dia_hla(1)
double precision :: contrib, contrib2, HIIi, HJk, wall
double precision :: contrib, contrib2, contrib_s2, contrib2_s2, HIIi, HJk, wall
integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ
integer(bit_kind) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2)
integer(bit_kind),allocatable :: sortRef(:,:,:)
@ -671,14 +730,16 @@ end function
! To provide everything
contrib = dij(1, 1, 1)
do i_state = 1, N_states
delta_mrcepa0_ii(:,:) = 0d0
delta_mrcepa0_ij(:,:,:) = 0d0
delta_mrcepa0_ii(:,:) = 0d0
delta_mrcepa0_ij(:,:,:) = 0d0
delta_mrcepa0_ii_s2(:,:) = 0d0
delta_mrcepa0_ij_s2(:,:,:) = 0d0
!$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii) &
!$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2) &
do i_state = 1, N_states
!$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii, delta_mrcepa0_ij_s2, delta_mrcepa0_ii_s2) &
!$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2,contrib_s2,contrib2_s2) &
!$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) &
!$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas) &
!$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas, delta_cas_s2) &
!$OMP shared(notf,i_state, sortRef, sortRefIdx, dij)
do blok=1,cepa0_shortcut(0)
do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1
@ -721,16 +782,21 @@ end function
! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk)
contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state)
contrib_s2 = delta_cas_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state)
if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then
contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state)
contrib2_s2 = contrib_s2 / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state)
!$OMP ATOMIC
delta_mrcepa0_ii(J,i_state) -= contrib2
delta_mrcepa0_ii_s2(J,i_state) -= contrib2_s2
else
contrib = contrib * 0.5d0
contrib_s2 = contrib_s2 * 0.5d0
end if
!$OMP ATOMIC
delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib
delta_mrcepa0_ij_s2(J, det_cepa0_idx(i), i_state) += contrib_s2
end do kloop
end do
@ -741,7 +807,7 @@ end function
deallocate(idx_sorted_bit)
call wall_time(wall)
print *, "cepa0", wall, notf
!stop
END_PROVIDER
@ -860,12 +926,14 @@ subroutine set_det_bit(det, p, s)
end subroutine
BEGIN_PROVIDER [ double precision, h_, (N_det_ref,N_det_non_ref) ]
BEGIN_PROVIDER [ double precision, h_cache, (N_det_ref,N_det_non_ref) ]
&BEGIN_PROVIDER [ double precision, s2_cache, (N_det_ref,N_det_non_ref) ]
implicit none
integer :: i,j
do i=1,N_det_ref
do j=1,N_det_non_ref
call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_(i,j))
call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_cache(i,j))
call get_s2(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, s2_cache(i,j))
end do
end do
END_PROVIDER

86
plugins/mrcepa0/dressing_slave.irp.f
View File

@ -37,7 +37,7 @@ subroutine mrsc2_dressing_slave(thread,iproc)
integer(ZMQ_PTR), external :: new_zmq_push_socket
integer(ZMQ_PTR) :: zmq_socket_push
double precision, allocatable :: delta(:,:,:)
double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:)
@ -47,8 +47,8 @@ subroutine mrsc2_dressing_slave(thread,iproc)
logical :: ok
double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al
double precision :: diI, hIi, hJi, delta_JI, dkI, HkI, ci_inv(N_states), cj_inv(N_states)
double precision :: contrib, wall, iwall
double precision, allocatable :: dleat(:,:,:)
double precision :: contrib, contrib_s2, wall, iwall
double precision, allocatable :: dleat(:,:,:), dleat_s2(:,:,:)
integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ
integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt
integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp
@ -63,6 +63,7 @@ subroutine mrsc2_dressing_slave(thread,iproc)
call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
allocate (dleat(N_states, N_det_non_ref, 2), delta(N_states,0:N_det_non_ref, 2))
allocate (dleat_s2(N_states, N_det_non_ref, 2), delta_s2(N_states,0:N_det_non_ref, 2))
allocate(komon(0:N_det_non_ref))
do
@ -74,10 +75,14 @@ subroutine mrsc2_dressing_slave(thread,iproc)
cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state)
end do
!delta = 0.d0
!delta_s2 = 0.d0
n = 0
delta(:,0,:) = 0d0
delta(:,:nlink(J),1) = 0d0
delta(:,:nlink(i_I),2) = 0d0
delta_s2(:,0,:) = 0d0
delta_s2(:,:nlink(J),1) = 0d0
delta_s2(:,:nlink(i_I),2) = 0d0
komon(0) = 0
komoned = .false.
@ -121,8 +126,8 @@ subroutine mrsc2_dressing_slave(thread,iproc)
end if
i = det_cepa0_idx(linked(m, i_I))
if(h_(J,i) == 0.d0) cycle
if(h_(i_I,i) == 0.d0) cycle
if(h_cache(J,i) == 0.d0) cycle
if(h_cache(i_I,i) == 0.d0) cycle
!ok = .false.
!do i_state=1, N_states
@ -144,10 +149,13 @@ subroutine mrsc2_dressing_slave(thread,iproc)
! if(I_i == J) phase_Ii = phase_Ji
do i_state = 1,N_states
dkI = h_(J,i) * dij(i_I, i, i_state)!get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,i), N_int)
!dkI = h_(J,i) * h_(i_I,i) * lambda_mrcc(i_state, i)
dkI = h_cache(J,i) * dij(i_I, i, i_state)
dleat(i_state, kn, 1) = dkI
dleat(i_state, kn, 2) = dkI
dkI = s2_cache(J,i) * dij(i_I, i, i_state)
dleat_s2(i_state, kn, 1) = dkI
dleat_s2(i_state, kn, 2) = dkI
end do
end do
@ -173,26 +181,32 @@ subroutine mrsc2_dressing_slave(thread,iproc)
!if(lambda_mrcc(i_state, i) == 0d0) cycle
!contrib = h_(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al
!contrib = h_cache(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al
contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2)
contrib_s2 = dij(i_I, k, i_state) * dleat_s2(i_state, m, 2)
delta(i_state,ll,1) += contrib
delta_s2(i_state,ll,1) += contrib_s2
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then
delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state)
delta_s2(i_state,0,1) -= contrib_s2 * ci_inv(i_state) * psi_non_ref_coef(l,i_state)
endif
if(I_i == J) cycle
!contrib = h_(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al
!contrib = h_cache(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al
contrib = dij(J, l, i_state) * dleat(i_state, m, 1)
contrib_s2 = dij(J, l, i_state) * dleat_s2(i_state, m, 1)
delta(i_state,kk,2) += contrib
delta_s2(i_state,kk,2) += contrib_s2
if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then
delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state)
delta_s2(i_state,0,2) -= contrib_s2 * cj_inv(i_state) * psi_non_ref_coef(k,i_state)
end if
enddo !i_state
end do ! while
end do ! kk
call push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id)
call push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id)
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
! end if
@ -208,7 +222,7 @@ subroutine mrsc2_dressing_slave(thread,iproc)
end
subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id)
subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id)
use f77_zmq
implicit none
BEGIN_DOC
@ -218,6 +232,7 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id)
integer, intent(in) :: i_I, J
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
double precision,intent(inout) :: delta(N_states, 0:N_det_non_ref, 2)
double precision,intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2)
integer, intent(in) :: task_id
integer :: rc , i_state, i, kk, li
integer,allocatable :: idx(:,:)
@ -278,6 +293,12 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id)
print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta_s2(1,0,1) = delta_I delta_s2(1,0,2) = delta_J
if (rc /= (n(kk)+1)*8*N_states) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)
if (rc /= n(kk)*4) then
@ -305,7 +326,7 @@ end
subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id)
subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id)
use f77_zmq
implicit none
BEGIN_DOC
@ -315,6 +336,7 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id)
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
integer, intent(out) :: i_I, J, n(2)
double precision, intent(inout) :: delta(N_states, 0:N_det_non_ref, 2)
double precision, intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2)
integer, intent(out) :: task_id
integer :: rc , i, kk
integer,intent(inout) :: idx(N_det_non_ref,2)
@ -346,9 +368,15 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id)
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE)
if (rc /= (n(kk)+1)*8*N_states) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)
if (rc /= n(kk)*4) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, n(kk)*4, ZMQ_SNDMORE)'
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)'
stop 'error'
endif
end if
@ -372,7 +400,7 @@ end
subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_)
subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2_)
use f77_zmq
implicit none
BEGIN_DOC
@ -381,11 +409,13 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_)
double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref)
double precision,intent(inout) :: delta_ii_(N_states,N_det_ref)
double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref)
double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref)
! integer :: j,l
integer :: rc
double precision, allocatable :: delta(:,:,:)
double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:)
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
@ -401,49 +431,47 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_)
delta_ii_(:,:) = 0d0
delta_ij_(:,:,:) = 0d0
delta_ii_s2_(:,:) = 0d0
delta_ij_s2_(:,:,:) = 0d0
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_pull = new_zmq_pull_socket()
allocate ( delta(N_states,0:N_det_non_ref,2) )
allocate ( delta(N_states,0:N_det_non_ref,2), delta_s2(N_states,0:N_det_non_ref,2) )
allocate(idx(N_det_non_ref,2))
more = 1
do while (more == 1)
call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id)
call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id)
do l=1, n(1)
do i_state=1,N_states
delta_ij_(i_state,idx(l,1),i_I) += delta(i_state,l,1)
delta_ij_s2_(i_state,idx(l,1),i_I) += delta_s2(i_state,l,1)
end do
end do
do l=1, n(2)
do i_state=1,N_states
delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2)
delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(i_state,l,2)
end do
end do
!
! do l=1,nlink(J)
! do i_state=1,N_states
! delta_ij_(i_state,det_cepa0_idx(linked(l,J)),i_I) += delta(i_state,l,1)
! delta_ij_(i_state,det_cepa0_idx(linked(l,i_I)),j) += delta(i_state,l,2)
! end do
! end do
!
if(n(1) /= 0) then
do i_state=1,N_states
delta_ii_(i_state,i_I) += delta(i_state,0,1)
delta_ii_s2_(i_state,i_I) += delta_s2(i_state,0,1)
end do
end if
if(n(2) /= 0) then
do i_state=1,N_states
delta_ii_(i_state,J) += delta(i_state,0,2)
delta_ii_s2_(i_state,J) += delta_s2(i_state,0,2)
end do
end if
@ -454,7 +482,7 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_)
enddo
deallocate( delta )
deallocate( delta, delta_s2 )
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_pull_socket(zmq_socket_pull)
@ -466,6 +494,8 @@ end
BEGIN_PROVIDER [ double precision, delta_ij_old, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_old, (N_states,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ij_s2_old, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_s2_old, (N_states,N_det_ref) ]
implicit none
integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2
@ -574,10 +604,10 @@ end
! rc = pthread_create(collector_thread, mrsc2_dressing_collector)
print *, nzer, ntot, float(nzer) / float(ntot)
provide nproc
!$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old) PRIVATE(i) NUM_THREADS(nproc+1)
!$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) PRIVATE(i) NUM_THREADS(nproc+1)
i = omp_get_thread_num()
if (i==0) then
call mrsc2_dressing_collector(delta_ii_old,delta_ij_old)
call mrsc2_dressing_collector(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old)
else
call mrsc2_dressing_slave_inproc(i)
endif

10
plugins/mrcepa0/mrcc.irp.f
View File

@ -8,8 +8,16 @@ program mrsc2sub
read_wf = .True.
SOFT_TOUCH read_wf
call print_cas_coefs
call set_generators_bitmasks_as_holes_and_particles
if (.True.) then
integer :: i,j
do j=1,N_states
do i=1,N_det
psi_coef(i,j) = CI_eigenvectors(i,j)
enddo
enddo
SOFT_TOUCH psi_coef
endif
call run(N_states,energy)
if(do_pt2_end)then
call run_pt2(N_states,energy)

12
plugins/mrcepa0/mrcepa0.irp.f
View File

@ -8,8 +8,18 @@ program mrcepa0
read_wf = .True.
SOFT_TOUCH read_wf
call print_cas_coefs
call set_generators_bitmasks_as_holes_and_particles
if (.True.) then
integer :: i,j
do j=1,N_states
do i=1,N_det
psi_coef(i,j) = CI_eigenvectors(i,j)
enddo
enddo
TOUCH psi_coef
endif
call print_cas_coefs
call run(N_states,energy)
if(do_pt2_end)then
call run_pt2(N_states,energy)

37
plugins/mrcepa0/mrcepa0_general.irp.f
View File

@ -10,18 +10,18 @@ subroutine run(N_st,energy)
double precision :: E_new, E_old, delta_e
integer :: iteration
double precision :: E_past(4), lambda
double precision :: E_past(4)
integer :: n_it_mrcc_max
double precision :: thresh_mrcc
double precision, allocatable :: lambda(:)
allocate (lambda(N_states))
thresh_mrcc = thresh_dressed_ci
n_it_mrcc_max = n_it_max_dressed_ci
if(n_it_mrcc_max == 1) then
do j=1,N_states_diag
do j=1,N_states
do i=1,N_det
psi_coef(i,j) = CI_eigenvectors_dressed(i,j)
enddo
@ -30,7 +30,6 @@ subroutine run(N_st,energy)
call write_double(6,ci_energy_dressed(1),"Final MRCC energy")
call ezfio_set_mrcepa0_energy(ci_energy_dressed(1))
call save_wavefunction
energy(:) = ci_energy_dressed(:)
else
E_new = 0.d0
delta_E = 1.d0
@ -38,15 +37,21 @@ subroutine run(N_st,energy)
lambda = 1.d0
do while (delta_E > thresh_mrcc)
iteration += 1
print *, '==========================='
print *, 'MRCEPA0 Iteration', iteration
print *, '==========================='
print *, '==============================================='
print *, 'MRCEPA0 Iteration', iteration, '/', n_it_mrcc_max
print *, '==============================================='
print *, ''
E_old = sum(ci_energy_dressed)
call write_double(6,ci_energy_dressed(1),"MRCEPA0 energy")
E_old = sum(ci_energy_dressed(1:N_states))
do i=1,N_st
call write_double(6,ci_energy_dressed(i),"MRCEPA0 energy")
enddo
call diagonalize_ci_dressed(lambda)
E_new = sum(ci_energy_dressed)
delta_E = dabs(E_new - E_old)
E_new = sum(ci_energy_dressed(1:N_states))
delta_E = (E_new - E_old)/dble(N_states)
print *, ''
call write_double(6,thresh_mrcc,"thresh_mrcc")
call write_double(6,delta_E,"delta_E")
delta_E = dabs(delta_E)
call save_wavefunction
call ezfio_set_mrcepa0_energy(ci_energy_dressed(1))
if (iteration >= n_it_mrcc_max) then
@ -54,8 +59,8 @@ subroutine run(N_st,energy)
endif
enddo
call write_double(6,ci_energy_dressed(1),"Final MRCEPA0 energy")
energy(:) = ci_energy_dressed(:)
endif
energy(1:N_st) = ci_energy_dressed(1:N_st)
end
@ -66,7 +71,7 @@ subroutine print_cas_coefs
print *, 'CAS'
print *, '==='
do i=1,N_det_cas
print *, psi_cas_coef(i,:)
print *, (psi_cas_coef(i,j), j=1,N_states)
call debug_det(psi_cas(1,1,i),N_int)
enddo
call write_double(6,ci_energy(1),"Initial CI energy")
@ -139,8 +144,8 @@ subroutine run_pt2_old(N_st,energy)
print * ,'Computing the remaining contribution'
threshold_selectors = 1.d0
threshold_generators = 0.999d0
threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
threshold_generators = max(threshold_generators,threshold_generators_pt2)
N_det_generators = N_det_non_ref + N_det_ref
N_det_selectors = N_det_non_ref + N_det_ref

10
plugins/mrcepa0/mrsc2.irp.f
View File

@ -7,8 +7,16 @@ program mrsc2
mrmode = 2
read_wf = .True.
SOFT_TOUCH read_wf
call print_cas_coefs
call set_generators_bitmasks_as_holes_and_particles
if (.True.) then
integer :: i,j
do j=1,N_states
do i=1,N_det
psi_coef(i,j) = CI_eigenvectors(i,j)
enddo
enddo
TOUCH psi_coef
endif
call run(N_states,energy)
if(do_pt2_end)then
call run_pt2(N_states,energy)

2
scripts/generate_h_apply.py
View File

@ -422,7 +422,7 @@ class H_apply(object):
if (s2_eig) then
call make_s2_eigenfunction
endif
! SOFT_TOUCH psi_det psi_coef N_det
SOFT_TOUCH psi_det psi_coef N_det
selection_criterion_min = min(selection_criterion_min, maxval(select_max))*0.1d0
selection_criterion = selection_criterion_min
call write_double(output_determinants,selection_criterion,'Selection criterion')

20
src/Davidson/EZFIO.cfg
View File

@ -6,7 +6,25 @@ default: 1.e-12
[n_states_diag]
type: States_number
doc: n_states_diag
doc: Number of states to consider during the Davdison diagonalization
default: 10
interface: ezfio,provider,ocaml
[davidson_sze_max]
type: Strictly_positive_int
doc: Number of micro-iterations before re-contracting
default: 10
interface: ezfio,provider,ocaml
[state_following]
type: logical
doc: If true, the states are re-ordered to match the input states
default: False
interface: ezfio,provider,ocaml
[disk_based_davidson]
type: logical
doc: If true, disk space is used to store the vectors
default: False
interface: ezfio,provider,ocaml

703
src/Davidson/diagonalization_hs2.irp.f
View File

@ -22,7 +22,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d
integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit
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), s2_out(N_st_diag)
double precision, intent(out) :: energies(N_st_diag), s2_out(N_st_diag)
double precision, allocatable :: H_jj(:), S2_jj(:)
double precision :: diag_h_mat_elem
@ -45,7 +45,11 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d
!$OMP END DO
!$OMP END PARALLEL
call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit)
if (disk_based_davidson) then
call davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit)
else
call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit)
endif
do i=1,N_st_diag
s2_out(i) = S2_jj(i)
enddo
@ -83,8 +87,8 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(in) :: H_jj(sze)
double precision, intent(inout) :: S2_jj(sze)
integer, intent(in) :: iunit
double precision, intent(inout) :: S2_jj(sze)
integer, intent(in) :: iunit
double precision, intent(inout) :: u_in(dim_in,N_st_diag)
double precision, intent(out) :: energies(N_st_diag)
@ -98,7 +102,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
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
@ -107,17 +111,19 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
double precision :: to_print(3,N_st)
double precision :: cpu, wall
integer :: shift, shift2, itermax
double precision :: r1, r2
logical :: state_ok(N_st_diag*davidson_sze_max)
include 'constants.include.F'
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda
if (N_st_diag*3 > sze) then
print *, 'error in Davidson :'
print *, 'Increase n_det_max_jacobi to ', N_st_diag*3
stop -1
print *, 'error in Davidson :'
print *, 'Increase n_det_max_jacobi to ', N_st_diag*3
stop -1
endif
PROVIDE nuclear_repulsion
PROVIDE nuclear_repulsion expected_s2
call write_time(iunit)
call wall_time(wall)
call cpu_time(cpu)
@ -136,7 +142,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
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 = '===== '
@ -144,31 +150,32 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
write_buffer = trim(write_buffer)//' ================ =========== ==========='
enddo
write(iunit,'(A)') trim(write_buffer)
integer, external :: align_double
integer, external :: align_double
sze_8 = align_double(sze)
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
s_ = 0.d0
s_tmp = 0.d0
h = 0.d0
U = 0.d0
W = 0.d0
S = 0.d0
y = 0.d0
s_ = 0.d0
s_tmp = 0.d0
ASSERT (N_st > 0)
@ -182,28 +189,21 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
converged = .False.
double precision :: r1, r2
do k=N_st+1,N_st_diag-2,2
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
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)
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
do while (.not.converged)
do k=1,N_st_diag
@ -211,18 +211,19 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
U(i,k) = u_in(i,k)
enddo
enddo
do iter=1,itermax-1
shift = N_st_diag*(iter-1)
shift2 = N_st_diag*iter
call ortho_qr(U,size(U,1),sze,shift2)
! Compute |W_k> = \sum_i |i><i|H|u_k>
! -----------------------------------------
! call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8)
call H_S2_u_0_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8)
@ -230,16 +231,57 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
! -------------------------------------------
call dgemm('T','N', shift2, shift2, sze, &
1.d0, U(1,1), size(U,1), W(1,1), size(W,1), &
0.d0, h(1,1), size(h,1))
1.d0, U, size(U,1), W, size(W,1), &
0.d0, h, size(h,1))
call dgemm('T','N', shift2, shift2, sze, &
1.d0, U(1,1), size(U,1), S(1,1), size(S,1), &
0.d0, s_(1,1), size(s_,1))
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)
! Compute S2 for each eigenvector
@ -252,30 +294,78 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
call dgemm('T','N',shift2,shift2,shift2, &
1.d0, y, size(y,1), s_tmp, size(s_tmp,1), &
0.d0, s_, size(s_,1))
do k=1,shift2
s2(k) = s_(k,k) + S_z2_Sz
enddo
if (s2_eig) then
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
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,N_st_diag
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
@ -293,11 +383,31 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
! -----------------------------------------
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
@ -320,23 +430,16 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
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, N_st_diag*iter, 1.d0, &
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))
enddo
do k=1,N_st_diag
energies(k) = lambda(k)
S2_jj(k) = s2(k)
enddo
write_buffer = '===== '
@ -349,7 +452,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
deallocate ( &
W, residual_norm, &
U, &
U, overlap, &
c, S, &
h, &
y, s_, s_tmp, &
@ -357,3 +460,439 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
)
end
subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit)
use bitmasks
use mmap_module
implicit none
BEGIN_DOC
! Davidson diagonalization with specific diagonal elements of the H matrix
!
! H_jj : specific diagonal H matrix elements to diagonalize de Davidson
!
! S2_jj : specific diagonal S^2 matrix elements
!
! dets_in : bitmasks corresponding to determinants
!
! u_in : guess coefficients on the various states. Overwritten
! on exit
!
! dim_in : leftmost dimension of u_in
!
! sze : Number of determinants
!
! N_st : Number of eigenstates
!
! N_st_diag : Number of states in which H is diagonalized. Assumed > sze
!
! iunit : Unit for the I/O
!
! Initial guess vectors are not necessarily orthonormal
END_DOC
integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(in) :: H_jj(sze)
double precision, intent(inout) :: S2_jj(sze)
integer, intent(in) :: iunit
double precision, intent(inout) :: u_in(dim_in,N_st_diag)
double precision, intent(out) :: energies(N_st_diag)
integer :: sze_8
integer :: iter
integer :: i,j,k,l,m
logical :: converged
double precision :: u_dot_v, u_dot_u
integer :: k_pairs, kl
integer :: iter2
double precision, pointer :: W(:,:), U(:,:), S(:,:), overlap(:,:)
double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:)
double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:)
double precision :: diag_h_mat_elem
double precision, allocatable :: residual_norm(:)
character*(16384) :: write_buffer
double precision :: to_print(3,N_st)
double precision :: cpu, wall
logical :: state_ok(N_st_diag*davidson_sze_max)
integer :: shift, shift2, itermax
include 'constants.include.F'
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda
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 expected_s2
call write_time(iunit)
call wall_time(wall)
call cpu_time(cpu)
write(iunit,'(A)') ''
write(iunit,'(A)') 'Davidson Diagonalization'
write(iunit,'(A)') '------------------------'
write(iunit,'(A)') ''
call write_int(iunit,N_st,'Number of states')
call write_int(iunit,N_st_diag,'Number of states in diagonalization')
call write_int(iunit,sze,'Number of determinants')
write(iunit,'(A)') ''
write_buffer = '===== '
do i=1,N_st
write_buffer = trim(write_buffer)//' ================ =========== ==========='
enddo
write(iunit,'(A)') trim(write_buffer)
write_buffer = ' Iter'
do i=1,N_st
write_buffer = trim(write_buffer)//' Energy S^2 Residual '
enddo
write(iunit,'(A)') trim(write_buffer)
write_buffer = '===== '
do i=1,N_st
write_buffer = trim(write_buffer)//' ================ =========== ==========='
enddo
write(iunit,'(A)') trim(write_buffer)
integer, external :: align_double
integer :: fd(3)
type(c_ptr) :: c_pointer(3)
sze_8 = align_double(sze)
itermax = min(davidson_sze_max, sze/N_st_diag)
call mmap( &
trim(ezfio_work_dir)//'U', &
(/ int(sze_8,8),int(N_st_diag*itermax,8) /), &
8, fd(1), .False., c_pointer(1))
call c_f_pointer(c_pointer(1), W, (/ sze_8,N_st_diag*itermax /) )
call mmap( &
trim(ezfio_work_dir)//'W', &
(/ int(sze_8,8),int(N_st_diag*itermax,8) /), &
8, fd(2), .False., c_pointer(2))
call c_f_pointer(c_pointer(2), U, (/ sze_8,N_st_diag*itermax /) )
call mmap( &
trim(ezfio_work_dir)//'S', &
(/ int(sze_8,8),int(N_st_diag*itermax,8) /), &
8, fd(3), .False., c_pointer(3))
call c_f_pointer(c_pointer(3), S, (/ sze_8,N_st_diag*itermax /) )
allocate( &
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), &
overlap(N_st_diag*itermax, N_st_diag*itermax), &
residual_norm(N_st_diag), &
c(N_st_diag*itermax), &
s2(N_st_diag*itermax), &
lambda(N_st_diag*itermax))
h = 0.d0
U = 0.d0
W = 0.d0
S = 0.d0
y = 0.d0
s_ = 0.d0
s_tmp = 0.d0
ASSERT (N_st > 0)
ASSERT (N_st_diag >= N_st)
ASSERT (sze > 0)
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
! Davidson iterations
! ===================
converged = .False.
double precision :: r1, r2
do k=N_st+1,N_st_diag
u_in(k,k) = 10.d0
do i=1,sze
call random_number(r1)
r1 = dsqrt(-2.d0*dlog(r1))
r2 = dtwo_pi*r2
u_in(i,k) = r1*dcos(r2)
enddo
enddo
do k=1,N_st_diag
call normalize(u_in(1,k),sze)
enddo
do while (.not.converged)
do k=1,N_st_diag
do i=1,sze
U(i,k) = u_in(i,k)
enddo
enddo
do iter=1,itermax-1
shift = N_st_diag*(iter-1)
shift2 = N_st_diag*iter
call ortho_qr(U,size(U,1),sze,shift2)
! Compute |W_k> = \sum_i |i><i|H|u_k>
! -----------------------------------------
! call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8)
call H_S2_u_0_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8)
! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>
! -------------------------------------------
do k=1,iter
shift = N_st_diag*(k-1)
call dgemm('T','N', N_st_diag, shift2, sze, &
1.d0, U(1,shift+1), size(U,1), W, size(W,1), &
0.d0, h(shift+1,1), size(h,1))
call dgemm('T','N', N_st_diag, shift2, sze, &
1.d0, U(1,shift+1), size(U,1), S, size(S,1), &
0.d0, s_(shift+1,1), size(s_,1))
enddo
! ! 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)
! Compute S2 for each eigenvector
! -------------------------------
call dgemm('N','N',shift2,shift2,shift2, &
1.d0, s_, size(s_,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, s_, size(s_,1))
do k=1,shift2
s2(k) = s_(k,k) + S_z2_Sz
enddo
if (s2_eig) then
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
do i=1,shift2
overlap(k,i) = dabs(y(k,i))
enddo
enddo
do k=1,N_st
cmax = -1.d0
do i=1,shift2
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
! Express eigenvectors of h in the determinant basis
! --------------------------------------------------
call dgemm('N','N', sze, N_st_diag, shift2, &
1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1))
call dgemm('N','N', sze, N_st_diag, shift2, &
1.d0, W, size(W,1), y, size(y,1), 0.d0, W(1,shift2+1), size(W,1))
call dgemm('N','N', sze, N_st_diag, shift2, &
1.d0, S, size(S,1), y, size(y,1), 0.d0, S(1,shift2+1), size(S,1))
! Compute residual vector and davidson step
! -----------------------------------------
do k=1,N_st_diag
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
to_print(2,k) = s2(k)
to_print(3,k) = residual_norm(k)
endif
enddo
write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))') iter, to_print(1:3,1:N_st)
call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged)
do k=1,N_st
if (residual_norm(k) > 1.e8) then
print *, ''
stop 'Davidson failed'
endif
enddo
if (converged) then
exit
endif
enddo
! Re-contract to u_in
! -----------
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))
enddo
do k=1,N_st_diag
energies(k) = lambda(k)
S2_jj(k) = s2(k)
enddo
write_buffer = '===== '
do i=1,N_st
write_buffer = trim(write_buffer)//' ================ =========== ==========='
enddo
write(iunit,'(A)') trim(write_buffer)
write(iunit,'(A)') ''
call write_time(iunit)
call munmap( &
(/ int(sze_8,8),int(N_st_diag*itermax,8) /), &
8, fd(1), c_pointer(1))
call munmap( &
(/ int(sze_8,8),int(N_st_diag*itermax,8) /), &
8, fd(2), c_pointer(2))
call munmap( &
(/ int(sze_8,8),int(N_st_diag*itermax,8) /), &
8, fd(3), c_pointer(3))
deallocate ( &
residual_norm, &
c, overlap, &
h, &
y, s_, s_tmp, &
lambda &
)
end

18
src/Davidson/parameters.irp.f
View File

@ -1,21 +1,3 @@
BEGIN_PROVIDER [ integer, davidson_iter_max ]
implicit none
BEGIN_DOC
! Max number of Davidson iterations
END_DOC
davidson_iter_max = 100
END_PROVIDER
BEGIN_PROVIDER [ integer, davidson_sze_max ]
implicit none
BEGIN_DOC
! Max number of Davidson sizes
END_DOC
ASSERT (davidson_sze_max <= davidson_iter_max)
davidson_sze_max = N_states+7
END_PROVIDER
BEGIN_PROVIDER [ character(64), davidson_criterion ]
implicit none
BEGIN_DOC

163
src/Davidson/u0Hu0.irp.f
View File

@ -177,7 +177,7 @@ BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ]
END_PROVIDER
subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8)
subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8)
use bitmasks
use f77_zmq
implicit none
@ -280,3 +280,164 @@ end
subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8)
use bitmasks
implicit none
BEGIN_DOC
! Computes v_0 = H|u_0> and s_0 = S^2 |u_0>
!
! n : number of determinants
!
! H_jj : array of <j|H|j>
!
! S2_jj : array of <j|S^2|j>
END_DOC
integer, intent(in) :: N_st,n,Nint, sze_8
double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st)
double precision, intent(in) :: u_0(sze_8,N_st)
double precision, intent(in) :: H_jj(n), S2_jj(n)
integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n)
double precision :: hij,s2
double precision, allocatable :: vt(:,:), ut(:,:), st(:,:)
integer :: i,j,k,l, jj,ii
integer :: i0, j0
integer, allocatable :: shortcut(:,:), sort_idx(:,:)
integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:)
integer(bit_kind) :: sorted_i(Nint)
integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate
integer :: N_st_8
integer, external :: align_double
integer :: blockb, blockb2, istep
double precision :: ave_workload, workload, target_workload_inv
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut
N_st_8 = align_double(N_st)
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
ASSERT (n>0)
PROVIDE ref_bitmask_energy
allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2))
allocate(ut(N_st_8,n))
v_0 = 0.d0
s_0 = 0.d0
do i=1,n
do istate=1,N_st
ut(istate,i) = u_0(i,istate)
enddo
enddo
call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint)
call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint)
!$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)
allocate(vt(N_st_8,n),st(N_st_8,n))
Vt = 0.d0
St = 0.d0
!$OMP DO SCHEDULE(static,1)
do sh=1,shortcut(0,2)
do i=shortcut(sh,2),shortcut(sh+1,2)-1
org_i = sort_idx(i,2)
do j=shortcut(sh,2),i-1
org_j = sort_idx(j,2)
ext = 0
do ni=1,Nint
ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2)))
end do
if(ext == 4) then
call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij)
call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2)
do istate=1,n_st
vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j)
vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i)
st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j)
st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i)
enddo
end if
end do
end do
enddo
!$OMP END DO NOWAIT
do sh=1,shortcut(0,1)
!$OMP DO SCHEDULE(static,1)
do sh2=sh,shortcut(0,1)
exa = 0
do ni=1,Nint
exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1)))
end do
if(exa > 2) then
cycle
end if
do i=shortcut(sh,1),shortcut(sh+1,1)-1
org_i = sort_idx(i,1)
if(sh==sh2) then
endi = i-1
else
endi = shortcut(sh2+1,1)-1
end if
do ni=1,Nint
sorted_i(ni) = sorted(ni,i,1)
enddo
do j=shortcut(sh2,1),endi
ext = exa
do ni=1,Nint
ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1)))
end do
if(ext <= 4) then
org_j = sort_idx(j,1)
call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij)
if (hij /= 0.d0) then
do istate=1,n_st
vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j)
vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i)
enddo
endif
if (ext /= 2) then
call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2)
if (s2 /= 0.d0) then
do istate=1,n_st
st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j)
st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i)
enddo
endif
endif
endif
enddo
enddo
enddo
!$OMP END DO NOWAIT
enddo
!$OMP CRITICAL (u0Hu0)
do istate=1,N_st
do i=1,n
v_0(i,istate) = v_0(i,istate) + vt(istate,i)
s_0(i,istate) = s_0(i,istate) + st(istate,i)
enddo
enddo
!$OMP END CRITICAL (u0Hu0)
deallocate(vt,st)
!$OMP END PARALLEL
do istate=1,N_st
do i=1,n
v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate)
s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate)
enddo
enddo
deallocate (shortcut, sort_idx, sorted, version, ut)
end

13
src/Determinants/H_apply.irp.f
View File

@ -222,7 +222,11 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
do while (bit_tmp(j)==bit_tmp(i))
if (duplicate(j)) then
j += 1
cycle
if (j > N_det) then
exit
else
cycle
endif
endif
duplicate(j) = .True.
do k=1,N_int
@ -248,17 +252,20 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
enddo
if (found_duplicates) then
call write_bool(output_determinants,found_duplicates,'Found duplicate determinants')
k=0
do i=1,N_det
if (.not.duplicate(i)) then
k += 1
psi_det(:,:,k) = psi_det_sorted_bit (:,:,i)
psi_coef(k,:) = psi_coef_sorted_bit(i,:)
else
call debug_det(psi_det_sorted_bit(1,1,i),N_int)
stop 'duplicates in psi_det'
endif
enddo
N_det = k
TOUCH N_det psi_det psi_coef
call write_bool(output_determinants,found_duplicates,'Found duplicate determinants')
SOFT_TOUCH N_det psi_det psi_coef
endif
deallocate (duplicate,bit_tmp)
end

85
src/Determinants/occ_pattern.irp.f
View File

@ -35,7 +35,8 @@ subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint)
bmax += popcnt( o(k,1) )
amax -= popcnt( o(k,2) )
enddo
sze = 2*int( min(binom_func(bmax, amax), 1.d8) )
sze = int( min(binom_func(bmax, amax), 1.d8) )
sze = sze*sze
end
@ -51,8 +52,8 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint)
integer(bit_kind),intent(out) :: d(Nint,2,sze)
integer :: i, k, nt, na, nd, amax
integer :: list_todo(n_alpha)
integer :: list_a(n_alpha)
integer :: list_todo(2*n_alpha)
integer :: list_a(2*n_alpha)
amax = n_alpha
do k=1,Nint
@ -68,13 +69,24 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint)
sze = nd
integer :: ne(2), l
l=0
do i=1,nd
ne(1) = 0
ne(2) = 0
l=l+1
! Doubly occupied orbitals
do k=1,Nint
d(k,1,i) = ior(d(k,1,i),o(k,2))
d(k,2,i) = ior(d(k,2,i),o(k,2))
d(k,1,l) = ior(d(k,1,i),o(k,2))
d(k,2,l) = ior(d(k,2,i),o(k,2))
ne(1) += popcnt(d(k,1,l))
ne(2) += popcnt(d(k,2,l))
enddo
if ( (ne(1) /= elec_alpha_num).or.(ne(2) /= elec_beta_num) ) then
l = l-1
endif
enddo
sze = l
end
@ -123,8 +135,8 @@ end
implicit none
BEGIN_DOC
! array of the occ_pattern present in the wf
! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation
! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation
! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupations
! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupations
END_DOC
integer :: i,j,k
@ -144,7 +156,7 @@ end
logical,allocatable :: duplicate(:)
allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,psi_det_size) )
allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,N_det) )
do i=1,N_det
iorder(i) = i
@ -161,12 +173,7 @@ end
duplicate(i) = .False.
enddo
i=1
integer (bit_kind) :: occ_pattern_tmp
do i=1,N_det
duplicate(i) = .False.
enddo
! Find duplicates
do i=1,N_det-1
if (duplicate(i)) then
cycle
@ -175,6 +182,9 @@ end
do while (bit_tmp(j)==bit_tmp(i))
if (duplicate(j)) then
j+=1
if (j>N_det) then
exit
endif
cycle
endif
duplicate(j) = .True.
@ -192,6 +202,7 @@ end
enddo
enddo
! Copy filtered result
N_occ_pattern=0
do i=1,N_det
if (duplicate(i)) then
@ -204,6 +215,28 @@ end
enddo
enddo
!- Check
! do i=1,N_occ_pattern
! do j=i+1,N_occ_pattern
! duplicate(1) = .True.
! do k=1,N_int
! if (psi_occ_pattern(k,1,i) /= psi_occ_pattern(k,1,j)) then
! duplicate(1) = .False.
! exit
! endif
! if (psi_occ_pattern(k,2,i) /= psi_occ_pattern(k,2,j)) then
! duplicate(1) = .False.
! exit
! endif
! enddo
! if (duplicate(1)) then
! call debug_det(psi_occ_pattern(1,1,i),N_int)
! call debug_det(psi_occ_pattern(1,1,j),N_int)
! stop 'DUPLICATE'
! endif
! enddo
! enddo
!-
deallocate(iorder,duplicate,bit_tmp,tmp_array)
END_PROVIDER
@ -213,7 +246,7 @@ subroutine make_s2_eigenfunction
integer :: i,j,k
integer :: smax, s
integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:)
integer :: N_det_new, iproc
integer :: N_det_new
integer, parameter :: bufsze = 1000
logical, external :: is_in_wavefunction
@ -237,6 +270,20 @@ subroutine make_s2_eigenfunction
det_buffer(k,1,N_det_new) = d(k,1,j)
det_buffer(k,2,N_det_new) = d(k,2,j)
enddo
! integer :: ne(2)
! ne(:) = 0
! do k=1,N_int
! ne(1) += popcnt(d(k,1,j))
! ne(2) += popcnt(d(k,2,j))
! enddo
! if (ne(1) /= elec_alpha_num) then
! call debug_det(d(1,1,j),N_int)
! stop "ALPHA"
! endif
! if (ne(2) /= elec_beta_num) then
! call debug_det(d(1,1,j),N_int)
! stop "BETA"
! endif
if (N_det_new == bufsze) then
call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0)
N_det_new = 0
@ -248,13 +295,15 @@ subroutine make_s2_eigenfunction
if (N_det_new > 0) then
call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,0)
! call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0)
call copy_H_apply_buffer_to_wf
SOFT_TOUCH N_det psi_coef psi_det
endif
deallocate(d,det_buffer)
call write_int(output_determinants,N_det_new, 'Added determinants for S^2')
call copy_H_apply_buffer_to_wf
SOFT_TOUCH N_det psi_coef psi_det
print *, 'Added determinants for S^2'
! logical :: found
! call remove_duplicates_in_psi_det(found)
end

54
src/Determinants/s2.irp.f
View File

@ -1,36 +1,36 @@
subroutine get_s2(key_i,key_j,Nint,s2)
implicit none
use bitmasks
BEGIN_DOC
! Returns <S^2>
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2)
integer(bit_kind), intent(in) :: key_j(Nint,2)
double precision, intent(out) :: s2
integer :: exc(0:2,2,2)
integer :: degree
double precision :: phase_spsm
integer :: nup, i
s2 = 0.d0
!$FORCEINLINE
call get_excitation_degree(key_i,key_j,degree,Nint)
select case (degree)
case(2)
call get_double_excitation(key_j,key_i,exc,phase_spsm,Nint)
if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta
if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then
s2 = -phase_spsm
endif
endif
case(0)
implicit none
use bitmasks
BEGIN_DOC
! Returns <S^2>
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2)
integer(bit_kind), intent(in) :: key_j(Nint,2)
double precision, intent(out) :: s2
integer :: exc(0:2,2,2)
integer :: degree
double precision :: phase_spsm
integer :: nup, i
s2 = 0.d0
!$FORCEINLINE
call get_excitation_degree(key_i,key_j,degree,Nint)
select case (degree)
case(2)
call get_double_excitation(key_j,key_i,exc,phase_spsm,Nint)
if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta
if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then
s2 = -phase_spsm
endif
endif
case(0)
nup = 0
do i=1,Nint
nup += popcnt(iand(xor(key_i(i,1),key_i(i,2)),key_i(i,1)))
enddo
s2 = dble(nup)
end select
end select
end
BEGIN_PROVIDER [ double precision, S_z ]

2
src/Determinants/slater_rules.irp.f
View File

@ -513,7 +513,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem, phase,phase_2
integer :: n_occ_ab(2)
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
PROVIDE mo_bielec_integrals_in_map mo_integrals_map big_array_exchange_integrals
ASSERT (Nint > 0)
ASSERT (Nint == N_int)

3
src/Integrals_Bielec/ao_bi_integrals.irp.f
View File

@ -350,8 +350,7 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ]
integral = ao_bielec_integral(1,1,1,1)
real :: map_mb
print*, 'read_ao_integrals',read_ao_integrals
print*, 'disk_access_ao_integrals',disk_access_ao_integrals
PROVIDE read_ao_integrals disk_access_ao_integrals
if (read_ao_integrals) then
print*,'Reading the AO integrals'
call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)

7
src/Integrals_Bielec/map_integrals.irp.f
View File

@ -677,7 +677,6 @@ integer function load_$ao_integrals(filename)
real(integral_kind), pointer :: val(:)
integer :: iknd, kknd
integer*8 :: n, j
double precision :: get_$ao_bielec_integral
load_$ao_integrals = 1
open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN')
read(66,err=98,end=98) iknd, kknd
@ -712,7 +711,7 @@ integer function load_$ao_integrals(filename)
end
SUBST [ ao_integrals_map, ao_integrals, ao_num , get_ao_bielec_integral ]
ao_integrals_map ; ao_integrals ; ao_num ; get_ao_bielec_integral ;;
mo_integrals_map ; mo_integrals ; mo_tot_num ; get_mo_bielec_integral ;;
SUBST [ ao_integrals_map, ao_integrals, ao_num ]
ao_integrals_map ; ao_integrals ; ao_num ;;
mo_integrals_map ; mo_integrals ; mo_tot_num ;;
END_TEMPLATE

0
plugins/MRPT_Utils/EZFIO.cfg → src/MRPT_Utils/EZFIO.cfg
View File

0
plugins/MRPT_Utils/H_apply.irp.f → src/MRPT_Utils/H_apply.irp.f
View File

1
src/MRPT_Utils/NEEDED_CHILDREN_MODULES Normal file
View File

@ -0,0 +1 @@
Determinants Davidson

0
plugins/MRPT_Utils/README.rst → src/MRPT_Utils/README.rst
View File

0
plugins/MRPT_Utils/energies_cas.irp.f → src/MRPT_Utils/energies_cas.irp.f
View File

0
plugins/MRPT_Utils/excitations_cas.irp.f → src/MRPT_Utils/excitations_cas.irp.f
View File

0
plugins/MRPT_Utils/fock_like_operators.irp.f → src/MRPT_Utils/fock_like_operators.irp.f
View File

0
plugins/MRPT_Utils/give_2h2p.irp.f → src/MRPT_Utils/give_2h2p.irp.f
View File

0
plugins/MRPT_Utils/mrpt_dress.irp.f → src/MRPT_Utils/mrpt_dress.irp.f
View File

0
plugins/MRPT_Utils/mrpt_utils.irp.f → src/MRPT_Utils/mrpt_utils.irp.f
View File

0
plugins/MRPT_Utils/new_way.irp.f → src/MRPT_Utils/new_way.irp.f
View File

0
plugins/MRPT_Utils/new_way_second_order_coef.irp.f → src/MRPT_Utils/new_way_second_order_coef.irp.f
View File

0
plugins/MRPT_Utils/psi_active_prov.irp.f → src/MRPT_Utils/psi_active_prov.irp.f
View File

0
plugins/MRPT_Utils/second_order_new.irp.f → src/MRPT_Utils/second_order_new.irp.f
View File

0
plugins/MRPT_Utils/second_order_new_2p.irp.f → src/MRPT_Utils/second_order_new_2p.irp.f
View File

0
plugins/MRPT_Utils/utils_bitmask.irp.f → src/MRPT_Utils/utils_bitmask.irp.f
View File

38
src/Utils/LinearAlgebra.irp.f
View File

@ -148,17 +148,42 @@ subroutine ortho_qr(A,LDA,m,n)
allocate (jpvt(n), tau(n), work(1))
LWORK=-1
! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO)
call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO )
LWORK=WORK(1)
LWORK=2*WORK(1)
deallocate(WORK)
allocate(WORK(LWORK))
! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO)
call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO )
call dorgqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO)
deallocate(WORK,jpvt,tau)
end
subroutine ortho_qr_unblocked(A,LDA,m,n)
implicit none
BEGIN_DOC
! Orthogonalization using Q.R factorization
!
! A : matrix to orthogonalize
!
! LDA : leftmost dimension of A
!
! n : Number of rows of A
!
! m : Number of columns of A
!
END_DOC
integer, intent(in) :: m,n, LDA
double precision, intent(inout) :: A(LDA,n)
integer :: info
integer, allocatable :: jpvt(:)
double precision, allocatable :: tau(:), work(:)
allocate (jpvt(n), tau(n), work(n))
call dgeqr2( m, n, A, LDA, TAU, WORK, INFO )
call dorg2r(m, n, n, A, LDA, tau, WORK, INFO)
deallocate(WORK,jpvt,tau)
end
subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m)
implicit none
BEGIN_DOC
@ -444,7 +469,12 @@ subroutine lapack_diag(eigvalues,eigvectors,H,nmax,n)
print *, irp_here, ': DSYEV: the ',-info,'-th argument had an illegal value'
stop 2
else if( info > 0 ) then
write(*,*)'DSYEV Failed'
write(*,*)'DSYEV Failed : ', info
do i=1,n
do j=1,n
print *, H(i,j)
enddo
enddo
stop 1
end if

12
src/Utils/map_module.f90
View File

@ -622,7 +622,7 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in)
istep = ishft(iend-ibegin,-1)
idx = ibegin + istep
do while (istep > 16)
do while (istep > 64)
idx = ibegin + istep
! TODO : Cache misses
if (cache_key < X(idx)) then
@ -660,8 +660,8 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in)
endif
enddo
idx = ibegin
if (min(iend_in,sze) > ibegin+16) then
iend = ibegin+16
if (min(iend_in,sze) > ibegin+64) then
iend = ibegin+64
do while (cache_key > X(idx))
idx = idx+1
end do
@ -730,7 +730,7 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in
istep = ishft(iend-ibegin,-1)
idx = ibegin + istep
do while (istep > 16)
do while (istep > 64)
idx = ibegin + istep
if (cache_key < X(idx)) then
iend = idx
@ -771,8 +771,8 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in
enddo
idx = ibegin
value = Y(idx)
if (min(iend_in,sze) > ibegin+16) then
iend = ibegin+16
if (min(iend_in,sze) > ibegin+64) then
iend = ibegin+64
do while (cache_key > X(idx))
idx = idx+1
value = Y(idx)

21
tests/bats/cassd.bats
View File

@ -3,15 +3,24 @@
source $QP_ROOT/tests/bats/common.bats.sh
@test "CAS_SD H2O cc-pVDZ" {
test_exe cas_sd_selected || skip
test_exe cassd_zmq || skip
INPUT=h2o.ezfio
rm -rf work/h2o.ezfio/determinants/
qp_edit -c $INPUT
ezfio set_file $INPUT
ezfio set perturbation do_pt2_end False
ezfio set determinants n_det_max 1000
ezfio set perturbation do_pt2_end True
ezfio set determinants n_det_max 16384
qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]"
qp_run cas_sd_selected $INPUT
energy="$(ezfio get cas_sd energy)"
eq $energy -76.2221842108163 1.E-5
qp_run cassd_zmq $INPUT
energy="$(ezfio get cas_sd_zmq energy_pt2)"
eq $energy -76.23109 2.E-5
ezfio set determinants n_det_max 2048
ezfio set determinants read_wf True
ezfio set perturbation do_pt2_end True
qp_run cassd_zmq $INPUT
ezfio set determinants read_wf False
energy="$(ezfio get cas_sd_zmq energy)"
eq $energy -76.2300888408526 2.E-5
}

6
tests/bats/fci.bats
View File

@ -20,7 +20,7 @@ function run_FCI() {
function run_FCI_ZMQ() {
thresh=5.e-5
test_exe full_ci || skip
test_exe fci_zmq || skip
qp_edit -c $1
ezfio set_file $1
ezfio set perturbation do_pt2_end True
@ -28,9 +28,9 @@ function run_FCI_ZMQ() {
ezfio set davidson threshold_davidson 1.e-10
qp_run fci_zmq $1
energy="$(ezfio get full_ci energy)"
energy="$(ezfio get full_ci_zmq energy)"
eq $energy $3 $thresh
energy_pt2="$(ezfio get full_ci energy_pt2)"
energy_pt2="$(ezfio get full_ci_zmq energy_pt2)"
eq $energy_pt2 $4 $thresh
}

16
tests/bats/mrcepa0.bats
View File

@ -15,8 +15,8 @@ source $QP_ROOT/tests/bats/common.bats.sh
ezfio set mrcepa0 lambda_type 1
ezfio set mrcepa0 n_it_max_dressed_ci 3
qp_run $EXE $INPUT
energy="$(ezfio get mrcepa0 energy)"
eq $energy -76.22903276183061 1.e-4
energy="$(ezfio get mrcepa0 energy_pt2)"
eq $energy -76.238562120457431 1.e-4
}
@test "MRCC H2O cc-pVDZ" {
@ -32,8 +32,8 @@ source $QP_ROOT/tests/bats/common.bats.sh
ezfio set mrcepa0 lambda_type 0
ezfio set mrcepa0 n_it_max_dressed_ci 3
qp_run $EXE $INPUT
energy="$(ezfio get mrcepa0 energy)"
eq $energy -76.22899302846875 1.e-4
energy="$(ezfio get mrcepa0 energy_pt2)"
eq $energy -76.238527498388962 1.e-4
}
@test "MRSC2 H2O cc-pVDZ" {
@ -48,8 +48,8 @@ source $QP_ROOT/tests/bats/common.bats.sh
ezfio set mrcepa0 lambda_type 0
ezfio set mrcepa0 n_it_max_dressed_ci 3
qp_run $EXE $INPUT
energy="$(ezfio get mrcepa0 energy)"
eq $energy -76.22647345292708 1.e-4
energy="$(ezfio get mrcepa0 energy_pt2)"
eq $energy -76.235833732594187 1.e-4
}
@test "MRCEPA0 H2O cc-pVDZ" {
@ -64,7 +64,7 @@ source $QP_ROOT/tests/bats/common.bats.sh
ezfio set mrcepa0 lambda_type 0
ezfio set mrcepa0 n_it_max_dressed_ci 3
qp_run $EXE $INPUT
energy="$(ezfio get mrcepa0 energy)"
eq $energy -76.23199784430074 1.e-4
energy="$(ezfio get mrcepa0 energy_pt2)"
eq $energy -76.2418799284763 1.e-4
}

6
tests/bats/pseudo.bats
View File

@ -23,7 +23,7 @@ function run_HF() {
function run_FCI_ZMQ() {
thresh=5.e-5
test_exe full_ci || skip
test_exe fci_zmq|| skip
qp_edit -c $1
ezfio set_file $1
ezfio set perturbation do_pt2_end True
@ -31,9 +31,9 @@ function run_FCI_ZMQ() {
ezfio set davidson threshold_davidson 1.e-10
qp_run fci_zmq $1
energy="$(ezfio get full_ci energy)"
energy="$(ezfio get full_ci_zmq energy)"
eq $energy $3 $thresh
energy_pt2="$(ezfio get full_ci energy_pt2)"
energy_pt2="$(ezfio get full_ci_zmq energy_pt2)"
eq $energy_pt2 $4 $thresh
}

2
tests/run_tests.sh
View File

@ -14,7 +14,7 @@ mrcepa0.bats
export QP_PREFIX="timeout -s 9 300"
export QP_TASK_DEBUG=1
#export QP_TASK_DEBUG=1
rm -rf work output