mirror of
https://github.com/LCPQ/quantum_package
synced 2024-12-23 04:43:50 +01:00
Merge branch 'scemama-master'
This commit is contained in:
commit
67a37a145a
@ -25,8 +25,8 @@ python:
|
|||||||
- "2.6"
|
- "2.6"
|
||||||
|
|
||||||
script:
|
script:
|
||||||
- ./configure --production ./config/gfortran.cfg
|
- ./configure --production ./config/travis.cfg
|
||||||
- source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD mrcepa0 All_singles
|
- 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 ; ninja
|
||||||
- source ./quantum_package.rc ; cd ocaml ; make ; cd -
|
- source ./quantum_package.rc ; cd ocaml ; make ; cd -
|
||||||
- source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v
|
- source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v
|
||||||
|
@ -13,7 +13,7 @@
|
|||||||
FC : gfortran -g -ffree-line-length-none -I . -static-libgcc
|
FC : gfortran -g -ffree-line-length-none -I . -static-libgcc
|
||||||
LAPACK_LIB : -llapack -lblas
|
LAPACK_LIB : -llapack -lblas
|
||||||
IRPF90 : irpf90
|
IRPF90 : irpf90
|
||||||
IRPF90_FLAGS : --ninja --assert --align=32
|
IRPF90_FLAGS : --ninja --align=32
|
||||||
|
|
||||||
# Global options
|
# Global options
|
||||||
################
|
################
|
||||||
|
62
config/travis.cfg
Normal file
62
config/travis.cfg
Normal 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
|
||||||
|
|
@ -93,8 +93,8 @@ program full_ci
|
|||||||
call diagonalize_CI
|
call diagonalize_CI
|
||||||
if(do_pt2_end)then
|
if(do_pt2_end)then
|
||||||
print*,'Last iteration only to compute the PT2'
|
print*,'Last iteration only to compute the PT2'
|
||||||
threshold_selectors = 1.d0
|
threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
|
||||||
threshold_generators = 0.999d0
|
threshold_generators = max(threshold_generators,threshold_generators_pt2)
|
||||||
call H_apply_CAS_SD_PT2(pt2, norm_pert, H_pert_diag, N_st)
|
call H_apply_CAS_SD_PT2(pt2, norm_pert, H_pert_diag, N_st)
|
||||||
|
|
||||||
print *, 'Final step'
|
print *, 'Final step'
|
||||||
|
10
plugins/CAS_SD_ZMQ/EZFIO.cfg
Normal file
10
plugins/CAS_SD_ZMQ/EZFIO.cfg
Normal 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
2
plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
Generators_CAS Perturbation Selectors_CASSD ZMQ
|
||||||
|
|
14
plugins/CAS_SD_ZMQ/README.rst
Normal file
14
plugins/CAS_SD_ZMQ/README.rst
Normal 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
234
plugins/CAS_SD_ZMQ/cassd_zmq.irp.f
Normal 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
79
plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f
Normal 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
11
plugins/CAS_SD_ZMQ/energy.irp.f
Normal 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
4
plugins/CAS_SD_ZMQ/ezfio_interface.irp.f
Normal 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
156
plugins/CAS_SD_ZMQ/run_selection_slave.irp.f
Normal 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
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -1,3 +1,480 @@
|
|||||||
|
use bitmasks
|
||||||
|
|
||||||
|
|
||||||
|
double precision function integral8(i,j,k,l)
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: i,j,k,l
|
||||||
|
double precision, external :: get_mo_bielec_integral
|
||||||
|
integer :: ii
|
||||||
|
ii = l-mo_integrals_cache_min
|
||||||
|
ii = ior(ii, k-mo_integrals_cache_min)
|
||||||
|
ii = ior(ii, j-mo_integrals_cache_min)
|
||||||
|
ii = ior(ii, i-mo_integrals_cache_min)
|
||||||
|
if (iand(ii, -64) /= 0) then
|
||||||
|
integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
|
||||||
|
else
|
||||||
|
ii = l-mo_integrals_cache_min
|
||||||
|
ii = ior( ishft(ii,6), k-mo_integrals_cache_min)
|
||||||
|
ii = ior( ishft(ii,6), j-mo_integrals_cache_min)
|
||||||
|
ii = ior( ishft(ii,6), i-mo_integrals_cache_min)
|
||||||
|
integral8 = mo_integrals_cache(ii)
|
||||||
|
endif
|
||||||
|
end function
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)]
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer :: i
|
||||||
|
do i=1, N_det
|
||||||
|
call get_mask_phase(psi_selectors(1,1,i), psi_phasemask(1,1,i))
|
||||||
|
end do
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
subroutine assert(cond, msg)
|
||||||
|
character(*), intent(in) :: msg
|
||||||
|
logical, intent(in) :: cond
|
||||||
|
|
||||||
|
if(.not. cond) then
|
||||||
|
print *, "assert fail: "//msg
|
||||||
|
stop
|
||||||
|
end if
|
||||||
|
end subroutine
|
||||||
|
|
||||||
|
|
||||||
|
subroutine get_mask_phase(det, phasemask)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer(bit_kind), intent(in) :: det(N_int, 2)
|
||||||
|
integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2)
|
||||||
|
integer :: s, ni, i
|
||||||
|
logical :: change
|
||||||
|
|
||||||
|
phasemask = 0_1
|
||||||
|
do s=1,2
|
||||||
|
change = .false.
|
||||||
|
do ni=1,N_int
|
||||||
|
do i=0,bit_kind_size-1
|
||||||
|
if(BTEST(det(ni, s), i)) change = .not. change
|
||||||
|
if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end subroutine
|
||||||
|
|
||||||
|
|
||||||
|
subroutine select_connected(i_generator,E0,pt2,b)
|
||||||
|
use bitmasks
|
||||||
|
use selection_types
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: i_generator
|
||||||
|
type(selection_buffer), intent(inout) :: b
|
||||||
|
double precision, intent(inout) :: pt2(N_states)
|
||||||
|
integer :: k,l
|
||||||
|
double precision, intent(in) :: E0(N_states)
|
||||||
|
|
||||||
|
integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2)
|
||||||
|
double precision :: fock_diag_tmp(2,mo_tot_num+1)
|
||||||
|
|
||||||
|
call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
|
||||||
|
|
||||||
|
do l=1,N_generators_bitmask
|
||||||
|
do k=1,N_int
|
||||||
|
hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator))
|
||||||
|
hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator))
|
||||||
|
particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) )
|
||||||
|
particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) )
|
||||||
|
|
||||||
|
enddo
|
||||||
|
call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b)
|
||||||
|
call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b)
|
||||||
|
enddo
|
||||||
|
end subroutine
|
||||||
|
|
||||||
|
|
||||||
|
double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
|
||||||
|
integer, intent(in) :: s1, s2, h1, h2, p1, p2
|
||||||
|
logical :: change
|
||||||
|
integer(1) :: np
|
||||||
|
double precision, parameter :: res(0:1) = (/1d0, -1d0/)
|
||||||
|
|
||||||
|
np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2)
|
||||||
|
if(p1 < h1) np = np + 1_1
|
||||||
|
if(p2 < h2) np = np + 1_1
|
||||||
|
|
||||||
|
if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1
|
||||||
|
get_phase_bi = res(iand(np,1_1))
|
||||||
|
end subroutine
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
! Selection single
|
||||||
|
! ----------------
|
||||||
|
|
||||||
|
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_selectors, 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, tmp
|
||||||
|
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) + vect(istate, p1)
|
||||||
|
delta_E = E0(istate) - Hii
|
||||||
|
tmp = dsqrt(delta_E * delta_E + val * val)
|
||||||
|
if (delta_E < 0.d0) then
|
||||||
|
tmp = -tmp
|
||||||
|
endif
|
||||||
|
e_pert = 0.5d0 * ( tmp - delta_E)
|
||||||
|
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) then
|
||||||
|
call add_to_selection_buffer(buf, det, max_e_pert)
|
||||||
|
endif
|
||||||
|
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
|
||||||
|
|
||||||
|
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
|
||||||
|
end subroutine
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
! Selection double
|
||||||
|
! ----------------
|
||||||
|
|
||||||
subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf)
|
subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf)
|
||||||
use bitmasks
|
use bitmasks
|
||||||
@ -49,8 +526,8 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p
|
|||||||
do i=1,N_det
|
do i=1,N_det
|
||||||
nt = 0
|
nt = 0
|
||||||
do j=1,N_int
|
do j=1,N_int
|
||||||
mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i))
|
mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i))
|
||||||
mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i))
|
mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i))
|
||||||
nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
|
nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
|
||||||
end do
|
end do
|
||||||
|
|
||||||
@ -83,19 +560,19 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p
|
|||||||
i = preinteresting(ii)
|
i = preinteresting(ii)
|
||||||
nt = 0
|
nt = 0
|
||||||
do j=1,N_int
|
do j=1,N_int
|
||||||
mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i))
|
mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i))
|
||||||
mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i))
|
mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i))
|
||||||
nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
|
nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
|
||||||
end do
|
end do
|
||||||
|
|
||||||
if(nt <= 4) then
|
if(nt <= 4) then
|
||||||
interesting(0) += 1
|
interesting(0) += 1
|
||||||
interesting(interesting(0)) = i
|
interesting(interesting(0)) = i
|
||||||
minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i)
|
minilist(:,:,interesting(0)) = psi_selectors(:,:,i)
|
||||||
if(nt <= 2) then
|
if(nt <= 2) then
|
||||||
fullinteresting(0) += 1
|
fullinteresting(0) += 1
|
||||||
fullinteresting(fullinteresting(0)) = i
|
fullinteresting(fullinteresting(0)) = i
|
||||||
fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i)
|
fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i)
|
||||||
end if
|
end if
|
||||||
end if
|
end if
|
||||||
end do
|
end do
|
||||||
@ -104,15 +581,15 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p
|
|||||||
i = prefullinteresting(ii)
|
i = prefullinteresting(ii)
|
||||||
nt = 0
|
nt = 0
|
||||||
do j=1,N_int
|
do j=1,N_int
|
||||||
mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i))
|
mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i))
|
||||||
mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i))
|
mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i))
|
||||||
nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
|
nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
|
||||||
end do
|
end do
|
||||||
|
|
||||||
if(nt <= 2) then
|
if(nt <= 2) then
|
||||||
fullinteresting(0) += 1
|
fullinteresting(0) += 1
|
||||||
fullinteresting(fullinteresting(0)) = i
|
fullinteresting(fullinteresting(0)) = i
|
||||||
fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i)
|
fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i)
|
||||||
end if
|
end if
|
||||||
end do
|
end do
|
||||||
|
|
||||||
@ -168,7 +645,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
|||||||
logical :: ok
|
logical :: ok
|
||||||
integer :: s1, s2, p1, p2, ib, j, istate
|
integer :: s1, s2, p1, p2, ib, j, istate
|
||||||
integer(bit_kind) :: mask(N_int, 2), det(N_int, 2)
|
integer(bit_kind) :: mask(N_int, 2), det(N_int, 2)
|
||||||
double precision :: e_pert, delta_E, val, Hii, max_e_pert
|
double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp
|
||||||
double precision, external :: diag_H_mat_elem_fock
|
double precision, external :: diag_H_mat_elem_fock
|
||||||
|
|
||||||
logical, external :: detEq
|
logical, external :: detEq
|
||||||
@ -193,6 +670,10 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
|||||||
if(banned(p1,p2)) cycle
|
if(banned(p1,p2)) cycle
|
||||||
if(mat(1, p1, p2) == 0d0) cycle
|
if(mat(1, p1, p2) == 0d0) cycle
|
||||||
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
|
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
|
||||||
|
logical, external :: is_in_wavefunction
|
||||||
|
if (is_in_wavefunction(det,N_int)) then
|
||||||
|
cycle
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
|
Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
|
||||||
@ -200,14 +681,14 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
|||||||
|
|
||||||
do istate=1,N_states
|
do istate=1,N_states
|
||||||
delta_E = E0(istate) - Hii
|
delta_E = E0(istate) - Hii
|
||||||
val = mat(istate, p1, p2)
|
val = mat(istate, p1, p2) + mat(istate, p1, p2)
|
||||||
|
tmp = dsqrt(delta_E * delta_E + val * val)
|
||||||
if (delta_E < 0.d0) then
|
if (delta_E < 0.d0) then
|
||||||
e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E)
|
tmp = -tmp
|
||||||
else
|
|
||||||
e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E)
|
|
||||||
endif
|
endif
|
||||||
pt2(istate) += e_pert
|
e_pert = 0.5d0 * ( tmp - delta_E)
|
||||||
if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert
|
pt2(istate) = pt2(istate) + e_pert
|
||||||
|
max_e_pert = min(e_pert,max_e_pert)
|
||||||
end do
|
end do
|
||||||
|
|
||||||
if(dabs(max_e_pert) > buf%mini) then
|
if(dabs(max_e_pert) > buf%mini) then
|
70
plugins/CAS_SD_ZMQ/selection_buffer.irp.f
Normal file
70
plugins/CAS_SD_ZMQ/selection_buffer.irp.f
Normal 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
93
plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f
Normal 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
9
plugins/CAS_SD_ZMQ/selection_types.f90
Normal 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
|
||||||
|
|
@ -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, intent(in) :: dim_in, sze, N_st, Nint
|
||||||
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
|
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
|
||||||
double precision, intent(inout) :: u_in(dim_in,N_st)
|
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
|
double precision, intent(in) :: convergence
|
||||||
|
|
||||||
integer :: i,j,k,l
|
integer :: i,j,k,l
|
||||||
|
@ -8,15 +8,3 @@ type: double precision
|
|||||||
doc: Calculated FCI energy + PT2
|
doc: Calculated FCI energy + PT2
|
||||||
interface: ezfio
|
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
11
plugins/Full_CI_ZMQ/EZFIO.cfg
Normal 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
|
||||||
|
|
||||||
|
|
@ -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
11
plugins/Full_CI_ZMQ/energy.irp.f
Normal 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
|
||||||
|
|
@ -5,11 +5,16 @@ program fci_zmq
|
|||||||
|
|
||||||
double precision, allocatable :: pt2(:)
|
double precision, allocatable :: pt2(:)
|
||||||
integer :: degree
|
integer :: degree
|
||||||
|
integer :: n_det_before, to_select
|
||||||
|
double precision :: threshold_davidson_in
|
||||||
|
|
||||||
allocate (pt2(N_states))
|
allocate (pt2(N_states))
|
||||||
|
|
||||||
pt2 = 1.d0
|
pt2 = 1.d0
|
||||||
diag_algorithm = "Lapack"
|
diag_algorithm = "Lapack"
|
||||||
|
threshold_davidson_in = threshold_davidson
|
||||||
|
SOFT_TOUCH threshold_davidson
|
||||||
|
threshold_davidson = 1.d-4
|
||||||
|
|
||||||
if (N_det > N_det_max) then
|
if (N_det > N_det_max) then
|
||||||
call diagonalize_CI
|
call diagonalize_CI
|
||||||
@ -33,29 +38,36 @@ program fci_zmq
|
|||||||
double precision :: E_CI_before(N_states)
|
double precision :: E_CI_before(N_states)
|
||||||
|
|
||||||
|
|
||||||
integer :: n_det_before
|
|
||||||
print*,'Beginning the selection ...'
|
print*,'Beginning the selection ...'
|
||||||
E_CI_before(1:N_states) = CI_energy(1:N_states)
|
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) )
|
do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) )
|
||||||
n_det_before = N_det
|
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_coef
|
||||||
PROVIDE psi_det
|
PROVIDE psi_det
|
||||||
PROVIDE psi_det_sorted
|
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 diagonalize_CI
|
||||||
call save_wavefunction
|
call save_wavefunction
|
||||||
|
|
||||||
if (N_det > N_det_max) then
|
! if (N_det > N_det_max) then
|
||||||
psi_det = psi_det_sorted
|
! psi_det = psi_det_sorted
|
||||||
psi_coef = psi_coef_sorted
|
! psi_coef = psi_coef_sorted
|
||||||
N_det = N_det_max
|
! N_det = N_det_max
|
||||||
soft_touch N_det psi_det psi_coef
|
! soft_touch N_det psi_det psi_coef
|
||||||
call diagonalize_CI
|
! call diagonalize_CI
|
||||||
call save_wavefunction
|
! call save_wavefunction
|
||||||
endif
|
! endif
|
||||||
|
|
||||||
print *, 'N_det = ', N_det
|
print *, 'N_det = ', N_det
|
||||||
print *, 'N_states = ', N_states
|
print *, 'N_states = ', N_states
|
||||||
@ -79,13 +91,13 @@ program fci_zmq
|
|||||||
enddo
|
enddo
|
||||||
endif
|
endif
|
||||||
E_CI_before(1:N_states) = CI_energy(1:N_states)
|
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
|
enddo
|
||||||
|
|
||||||
if(do_pt2_end)then
|
if(do_pt2_end)then
|
||||||
print*,'Last iteration only to compute the PT2'
|
print*,'Last iteration only to compute the PT2'
|
||||||
threshold_selectors = threshold_selectors_pt2
|
threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
|
||||||
threshold_generators = threshold_generators_pt2
|
threshold_generators = max(threshold_generators,threshold_generators_pt2)
|
||||||
TOUCH threshold_selectors threshold_generators
|
TOUCH threshold_selectors threshold_generators
|
||||||
E_CI_before(1:N_states) = CI_energy(1:N_states)
|
E_CI_before(1:N_states) = CI_energy(1:N_states)
|
||||||
call ZMQ_selection(0, pt2)
|
call ZMQ_selection(0, pt2)
|
||||||
@ -99,7 +111,7 @@ program fci_zmq
|
|||||||
print *, 'E+PT2 = ', E_CI_before+pt2
|
print *, 'E+PT2 = ', E_CI_before+pt2
|
||||||
print *, '-----'
|
print *, '-----'
|
||||||
enddo
|
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
|
endif
|
||||||
call save_wavefunction
|
call save_wavefunction
|
||||||
end
|
end
|
||||||
@ -122,38 +134,43 @@ subroutine ZMQ_selection(N_in, pt2)
|
|||||||
double precision, intent(out) :: pt2(N_states)
|
double precision, intent(out) :: pt2(N_states)
|
||||||
|
|
||||||
|
|
||||||
N = max(N_in,1)
|
if (.True.) then
|
||||||
provide nproc
|
PROVIDE pt2_e0_denominator
|
||||||
provide ci_electronic_energy
|
N = max(N_in,1)
|
||||||
call new_parallel_job(zmq_to_qp_run_socket,"selection")
|
provide nproc
|
||||||
call zmq_put_psi(zmq_to_qp_run_socket,1,ci_electronic_energy,size(ci_electronic_energy))
|
call new_parallel_job(zmq_to_qp_run_socket,"selection")
|
||||||
call zmq_set_running(zmq_to_qp_run_socket)
|
call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator))
|
||||||
call create_selection_buffer(N, N*2, b)
|
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
|
integer :: i_generator, i_generator_start, i_generator_max, step
|
||||||
! step = int(max(1.,10*elec_num/mo_tot_num)
|
! 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 = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num ))
|
||||||
step = max(1,step)
|
step = max(1,step)
|
||||||
do i= N_det_generators, 1, -step
|
do i= 1, N_det_generators,step
|
||||||
i_generator_start = max(i-step+1,1)
|
i_generator_start = i
|
||||||
i_generator_max = i
|
i_generator_max = min(i+step-1,N_det_generators)
|
||||||
write(task,*) i_generator_start, i_generator_max, 1, N
|
write(task,*) i_generator_start, i_generator_max, 1, N
|
||||||
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
|
call add_task_to_taskserver(zmq_to_qp_run_socket,task)
|
||||||
end do
|
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)
|
!$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1)
|
||||||
i = omp_get_thread_num()
|
i = omp_get_thread_num()
|
||||||
if (i==0) then
|
if (i==0) then
|
||||||
call selection_collector(b, pt2)
|
call selection_collector(b, pt2)
|
||||||
else
|
else
|
||||||
call selection_slave_inproc(i)
|
call selection_slave_inproc(i)
|
||||||
endif
|
endif
|
||||||
!$OMP END PARALLEL
|
!$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
|
if (N_in > 0) then
|
||||||
call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN
|
call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN
|
||||||
call copy_H_apply_buffer_to_wf()
|
call copy_H_apply_buffer_to_wf()
|
||||||
|
if (s2_eig) then
|
||||||
|
call make_s2_eigenfunction
|
||||||
|
endif
|
||||||
endif
|
endif
|
||||||
end subroutine
|
end subroutine
|
||||||
|
|
||||||
@ -162,7 +179,7 @@ subroutine selection_slave_inproc(i)
|
|||||||
implicit none
|
implicit none
|
||||||
integer, intent(in) :: i
|
integer, intent(in) :: i
|
||||||
|
|
||||||
call run_selection_slave(1,i,ci_electronic_energy)
|
call run_selection_slave(1,i,pt2_e0_denominator)
|
||||||
end
|
end
|
||||||
|
|
||||||
subroutine selection_collector(b, pt2)
|
subroutine selection_collector(b, pt2)
|
||||||
|
@ -4,7 +4,7 @@ subroutine run_selection_slave(thread,iproc,energy)
|
|||||||
use selection_types
|
use selection_types
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
double precision, intent(in) :: energy(N_states_diag)
|
double precision, intent(in) :: energy(N_states)
|
||||||
integer, intent(in) :: thread, iproc
|
integer, intent(in) :: thread, iproc
|
||||||
integer :: rc, i
|
integer :: rc, i
|
||||||
|
|
||||||
|
File diff suppressed because it is too large
Load Diff
@ -13,7 +13,7 @@ end
|
|||||||
|
|
||||||
subroutine provide_everything
|
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 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
|
end
|
||||||
|
|
||||||
subroutine run_wf
|
subroutine run_wf
|
||||||
@ -22,7 +22,7 @@ subroutine run_wf
|
|||||||
|
|
||||||
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
|
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
|
||||||
integer(ZMQ_PTR) :: 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)
|
character*(64) :: states(2)
|
||||||
integer :: rc, i
|
integer :: rc, i
|
||||||
|
|
||||||
@ -48,7 +48,7 @@ subroutine run_wf
|
|||||||
! ---------
|
! ---------
|
||||||
|
|
||||||
print *, 'Selection'
|
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)
|
!$OMP PARALLEL PRIVATE(i)
|
||||||
i = omp_get_thread_num()
|
i = omp_get_thread_num()
|
||||||
@ -76,7 +76,7 @@ end
|
|||||||
|
|
||||||
subroutine update_energy(energy)
|
subroutine update_energy(energy)
|
||||||
implicit none
|
implicit none
|
||||||
double precision, intent(in) :: energy(N_states_diag)
|
double precision, intent(in) :: energy(N_states)
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Update energy when it is received from ZMQ
|
! Update energy when it is received from ZMQ
|
||||||
END_DOC
|
END_DOC
|
||||||
@ -88,7 +88,7 @@ subroutine update_energy(energy)
|
|||||||
enddo
|
enddo
|
||||||
call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int)
|
call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int)
|
||||||
if (.True.) then
|
if (.True.) then
|
||||||
do k=1,size(ci_electronic_energy)
|
do k=1,N_states
|
||||||
ci_electronic_energy(k) = energy(k)
|
ci_electronic_energy(k) = energy(k)
|
||||||
enddo
|
enddo
|
||||||
TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors
|
TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors
|
||||||
@ -99,7 +99,7 @@ end
|
|||||||
|
|
||||||
subroutine selection_slave_tcp(i,energy)
|
subroutine selection_slave_tcp(i,energy)
|
||||||
implicit none
|
implicit none
|
||||||
double precision, intent(in) :: energy(N_states_diag)
|
double precision, intent(in) :: energy(N_states)
|
||||||
integer, intent(in) :: i
|
integer, intent(in) :: i
|
||||||
|
|
||||||
call run_selection_slave(0,i,energy)
|
call run_selection_slave(0,i,energy)
|
||||||
|
@ -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
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -13,7 +13,7 @@ end
|
|||||||
|
|
||||||
subroutine provide_everything
|
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 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
|
end
|
||||||
|
|
||||||
subroutine run_wf
|
subroutine run_wf
|
||||||
@ -22,7 +22,7 @@ subroutine run_wf
|
|||||||
|
|
||||||
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
|
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
|
||||||
integer(ZMQ_PTR) :: 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)
|
character*(64) :: states(1)
|
||||||
integer :: rc, i
|
integer :: rc, i
|
||||||
|
|
||||||
@ -47,7 +47,7 @@ subroutine run_wf
|
|||||||
! ---------
|
! ---------
|
||||||
|
|
||||||
print *, 'Selection'
|
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)
|
!$OMP PARALLEL PRIVATE(i)
|
||||||
i = omp_get_thread_num()
|
i = omp_get_thread_num()
|
||||||
@ -62,7 +62,7 @@ end
|
|||||||
|
|
||||||
subroutine update_energy(energy)
|
subroutine update_energy(energy)
|
||||||
implicit none
|
implicit none
|
||||||
double precision, intent(in) :: energy(N_states_diag)
|
double precision, intent(in) :: energy(N_states)
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Update energy when it is received from ZMQ
|
! Update energy when it is received from ZMQ
|
||||||
END_DOC
|
END_DOC
|
||||||
@ -74,7 +74,7 @@ subroutine update_energy(energy)
|
|||||||
enddo
|
enddo
|
||||||
call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int)
|
call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int)
|
||||||
if (.True.) then
|
if (.True.) then
|
||||||
do k=1,size(ci_electronic_energy)
|
do k=1,N_states
|
||||||
ci_electronic_energy(k) = energy(k)
|
ci_electronic_energy(k) = energy(k)
|
||||||
enddo
|
enddo
|
||||||
TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors
|
TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors
|
||||||
@ -85,7 +85,7 @@ end
|
|||||||
|
|
||||||
subroutine selection_slave_tcp(i,energy)
|
subroutine selection_slave_tcp(i,energy)
|
||||||
implicit none
|
implicit none
|
||||||
double precision, intent(in) :: energy(N_states_diag)
|
double precision, intent(in) :: energy(N_states)
|
||||||
integer, intent(in) :: i
|
integer, intent(in) :: i
|
||||||
|
|
||||||
call run_selection_slave(0,i,energy)
|
call run_selection_slave(0,i,energy)
|
||||||
|
@ -1,4 +1,10 @@
|
|||||||
program mp2
|
program mp2
|
||||||
|
no_vvvv_integrals = .True.
|
||||||
|
SOFT_TOUCH no_vvvv_integrals
|
||||||
|
call run
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine run
|
||||||
implicit none
|
implicit none
|
||||||
double precision, allocatable :: pt2(:), norm_pert(:)
|
double precision, allocatable :: pt2(:), norm_pert(:)
|
||||||
double precision :: H_pert_diag, E_old
|
double precision :: H_pert_diag, E_old
|
||||||
|
@ -1,4 +1,10 @@
|
|||||||
program mp2_wf
|
program mp2_wf
|
||||||
|
no_vvvv_integrals = .True.
|
||||||
|
SOFT_TOUCH no_vvvv_integrals
|
||||||
|
call run
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine run
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Save the MP2 wave function
|
! Save the MP2 wave function
|
||||||
|
230
plugins/MRCC_Utils/amplitudes.irp.f
Normal file
230
plugins/MRCC_Utils/amplitudes.irp.f
Normal 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
|
||||||
|
|
@ -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, &
|
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), &
|
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))
|
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
|
do k=1,N_st_diag
|
||||||
energies(k) = lambda(k)
|
|
||||||
do i=1,sze
|
do i=1,sze
|
||||||
u_in(i,k) = 0.d0
|
u_in(i,k) = 0.d0
|
||||||
enddo
|
enddo
|
||||||
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, &
|
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, &
|
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
|
enddo
|
||||||
|
|
||||||
|
do k=1,N_st_diag
|
||||||
|
energies(k) = lambda(k)
|
||||||
|
enddo
|
||||||
write_buffer = '===== '
|
write_buffer = '===== '
|
||||||
do i=1,N_st
|
do i=1,N_st
|
||||||
write_buffer = trim(write_buffer)//' ================ ================'
|
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, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit, istate
|
||||||
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
|
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
|
||||||
double precision, intent(inout) :: u_in(dim_in,N_st_diag)
|
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, allocatable :: H_jj(:), S2_jj(:)
|
||||||
|
|
||||||
double precision :: diag_h_mat_elem
|
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 :: k_pairs, kl
|
||||||
|
|
||||||
integer :: iter2
|
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 :: y(:,:), h(:,:), lambda(:), s2(:)
|
||||||
double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:)
|
double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:)
|
||||||
double precision :: diag_h_mat_elem
|
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'
|
include 'constants.include.F'
|
||||||
|
|
||||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda
|
||||||
if (N_st_diag > sze) then
|
if (N_st_diag*3 > sze) then
|
||||||
stop 'error in Davidson : N_st_diag > sze'
|
print *, 'error in Davidson :'
|
||||||
|
print *, 'Increase n_det_max_jacobi to ', N_st_diag*3
|
||||||
|
stop -1
|
||||||
endif
|
endif
|
||||||
|
|
||||||
PROVIDE nuclear_repulsion
|
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(iunit,'(A)') trim(write_buffer)
|
||||||
write_buffer = ' Iter'
|
write_buffer = ' Iter'
|
||||||
do i=1,N_st
|
do i=1,N_st
|
||||||
write_buffer = trim(write_buffer)//' Energy S^2 Residual'
|
write_buffer = trim(write_buffer)//' Energy S^2 Residual '
|
||||||
enddo
|
enddo
|
||||||
write(iunit,'(A)') trim(write_buffer)
|
write(iunit,'(A)') trim(write_buffer)
|
||||||
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
|
integer, external :: align_double
|
||||||
sze_8 = align_double(sze)
|
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)
|
itermax = min(davidson_sze_max, sze/N_st_diag)
|
||||||
allocate( &
|
allocate( &
|
||||||
W(sze_8,N_st_diag*itermax), &
|
W(sze_8,N_st_diag*itermax), &
|
||||||
U(sze_8,N_st_diag*itermax), &
|
U(sze_8,N_st_diag*itermax), &
|
||||||
S(sze_8,N_st_diag*itermax), &
|
S(sze_8,N_st_diag*itermax), &
|
||||||
h(N_st_diag*itermax,N_st_diag*itermax), &
|
h(N_st_diag*itermax,N_st_diag*itermax), &
|
||||||
y(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_(N_st_diag*itermax,N_st_diag*itermax), &
|
||||||
s_tmp(N_st_diag*itermax,N_st_diag*itermax), &
|
s_tmp(N_st_diag*itermax,N_st_diag*itermax), &
|
||||||
residual_norm(N_st_diag), &
|
residual_norm(N_st_diag), &
|
||||||
c(N_st_diag*itermax), &
|
c(N_st_diag*itermax), &
|
||||||
s2(N_st_diag*itermax), &
|
s2(N_st_diag*itermax), &
|
||||||
|
overlap(N_st_diag*itermax,N_st_diag*itermax), &
|
||||||
lambda(N_st_diag*itermax))
|
lambda(N_st_diag*itermax))
|
||||||
|
|
||||||
h = 0.d0
|
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.
|
converged = .False.
|
||||||
|
|
||||||
double precision :: r1, r2
|
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
|
do i=1,sze
|
||||||
call random_number(r1)
|
call random_number(r1)
|
||||||
call random_number(r2)
|
call random_number(r2)
|
||||||
r1 = dsqrt(-2.d0*dlog(r1))
|
r1 = dsqrt(-2.d0*dlog(r1))
|
||||||
r2 = dtwo_pi*r2
|
r2 = dtwo_pi*r2
|
||||||
u_in(i,k) = r1*dcos(r2)
|
u_in(i,k) = r1*dcos(r2)
|
||||||
u_in(i,k+1) = r1*dsin(r2)
|
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
do k=N_st_diag-1,N_st_diag
|
do k=1,N_st_diag
|
||||||
do i=1,sze
|
call normalize(u_in(1,k),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
|
enddo
|
||||||
|
|
||||||
|
|
||||||
@ -788,13 +757,52 @@ 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, &
|
call dgemm('T','N', shift2, shift2, sze, &
|
||||||
1.d0, U, size(U,1), W(1,shift+1), size(W,1), &
|
1.d0, U, size(U,1), W, size(W,1), &
|
||||||
0.d0, h(1,shift+1), size(h,1))
|
0.d0, h, size(h,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))
|
||||||
|
|
||||||
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))
|
|
||||||
|
|
||||||
! Diagonalize h
|
! Diagonalize h
|
||||||
! -------------
|
! -------------
|
||||||
@ -816,24 +824,73 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
|
|||||||
enddo
|
enddo
|
||||||
|
|
||||||
if (s2_eig) then
|
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
|
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
|
enddo
|
||||||
do k=1,shift2
|
do k=1,N_st
|
||||||
if (.not. state_ok(k)) then
|
cmax = -1.d0
|
||||||
do l=k+1,shift2
|
do i=1,N_st
|
||||||
if (state_ok(l)) then
|
if (overlap(i,k) > cmax) then
|
||||||
call dswap(shift2, y(1,k), 1, y(1,l), 1)
|
cmax = overlap(i,k)
|
||||||
call dswap(1, s2(k), 1, s2(l), 1)
|
order(k) = i
|
||||||
call dswap(1, lambda(k), 1, lambda(l), 1)
|
endif
|
||||||
state_ok(k) = .True.
|
enddo
|
||||||
state_ok(l) = .False.
|
do i=1,shift2
|
||||||
exit
|
overlap(order(k),i) = -1.d0
|
||||||
endif
|
enddo
|
||||||
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
|
endif
|
||||||
enddo
|
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
|
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 k=1,N_st_diag
|
||||||
do i=1,sze
|
if (state_ok(k)) then
|
||||||
U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
|
do i=1,sze
|
||||||
* (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz &
|
U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
|
||||||
)/max(H_jj(i) - lambda (k),1.d-2)
|
* (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz &
|
||||||
enddo
|
)/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
|
if (k <= N_st) then
|
||||||
residual_norm(k) = u_dot_u(U(1,shift2+k),sze)
|
residual_norm(k) = u_dot_u(U(1,shift2+k),sze)
|
||||||
to_print(1,k) = lambda(k) + nuclear_repulsion
|
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
|
enddo
|
||||||
|
|
||||||
if (.not.converged) then
|
|
||||||
iter = itermax-1
|
|
||||||
endif
|
|
||||||
|
|
||||||
! Re-contract to u_in
|
! Re-contract to u_in
|
||||||
! -----------
|
! -----------
|
||||||
|
|
||||||
do k=1,N_st_diag
|
call dgemm('N','N', sze, N_st_diag, shift2, &
|
||||||
energies(k) = lambda(k)
|
1.d0, U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1))
|
||||||
enddo
|
|
||||||
|
|
||||||
call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, &
|
enddo
|
||||||
U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1))
|
|
||||||
|
|
||||||
|
do k=1,N_st_diag
|
||||||
|
energies(k) = lambda(k)
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
write_buffer = '===== '
|
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 ( &
|
deallocate ( &
|
||||||
W, residual_norm, &
|
W, residual_norm, &
|
||||||
U, &
|
U, overlap, &
|
||||||
c, S, &
|
c, S, &
|
||||||
h, &
|
h, &
|
||||||
y, s_, s_tmp, &
|
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 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 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 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))
|
allocate(vt(N_st_8,n),st(N_st_8,n))
|
||||||
Vt = 0.d0
|
Vt = 0.d0
|
||||||
St = 0.d0
|
St = 0.d0
|
||||||
|
|
||||||
!$OMP DO SCHEDULE(dynamic)
|
!$OMP DO SCHEDULE(guided)
|
||||||
do sh=1,shortcut(0,1)
|
do sh=1,shortcut(0,1)
|
||||||
do sh2=sh,shortcut(0,1)
|
do sh2=sh,shortcut(0,1)
|
||||||
exa = 0
|
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
|
enddo
|
||||||
enddo
|
enddo
|
||||||
!$OMP END DO NOWAIT
|
!$OMP END DO
|
||||||
!$OMP DO SCHEDULE(dynamic)
|
!$OMP DO SCHEDULE(guided)
|
||||||
do sh=1,shortcut(0,2)
|
do sh=1,shortcut(0,2)
|
||||||
do i=shortcut(sh,2),shortcut(sh+1,2)-1
|
do i=shortcut(sh,2),shortcut(sh+1,2)-1
|
||||||
org_i = sort_idx(i,2)
|
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
|
||||||
end do
|
end do
|
||||||
enddo
|
enddo
|
||||||
!$OMP END DO NOWAIT
|
!$OMP END DO
|
||||||
|
|
||||||
! --------------------------
|
! --------------------------
|
||||||
! Begin Specific to dressing
|
! 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
|
do istate=1,N_st
|
||||||
vt (istate,i) = vt (istate,i) + delta_ij(istate_in,jj,ii)*ut(istate,j)
|
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)
|
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
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
@ -1,4 +0,0 @@
|
|||||||
program pouet
|
|
||||||
|
|
||||||
|
|
||||||
end
|
|
@ -77,18 +77,18 @@ BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ]
|
|||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ]
|
! 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_ii, (N_states,N_det_ref) ]
|
||||||
implicit none
|
! implicit none
|
||||||
BEGIN_DOC
|
! BEGIN_DOC
|
||||||
! Dressing matrix in N_det basis
|
! ! Dressing matrix in N_det basis
|
||||||
END_DOC
|
! END_DOC
|
||||||
integer :: i,j,m
|
! integer :: i,j,m
|
||||||
delta_ij = 0.d0
|
! delta_ij = 0.d0
|
||||||
delta_ii = 0.d0
|
! delta_ii = 0.d0
|
||||||
call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref)
|
! call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref)
|
||||||
|
!
|
||||||
END_PROVIDER
|
!END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ]
|
BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ]
|
||||||
@ -139,7 +139,6 @@ END_PROVIDER
|
|||||||
|
|
||||||
integer :: mrcc_state
|
integer :: mrcc_state
|
||||||
|
|
||||||
mrcc_state = N_states
|
|
||||||
do j=1,min(N_states,N_det)
|
do j=1,min(N_states,N_det)
|
||||||
do i=1,N_det
|
do i=1,N_det
|
||||||
CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
|
CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
|
||||||
@ -148,16 +147,33 @@ END_PROVIDER
|
|||||||
|
|
||||||
if (diag_algorithm == "Davidson") then
|
if (diag_algorithm == "Davidson") then
|
||||||
|
|
||||||
! call davidson_diag_mrcc(psi_det,CI_eigenvectors_dressed,CI_electronic_energy_dressed,&
|
allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), &
|
||||||
! size(CI_eigenvectors_dressed,1),N_det,N_states,N_states_diag,N_int,output_determinants,mrcc_state)
|
eigenvalues(size(CI_electronic_energy_dressed,1)))
|
||||||
|
do j=1,min(N_states,N_det)
|
||||||
call davidson_diag_mrcc_HS2(psi_det,CI_eigenvectors_dressed,&
|
do i=1,N_det
|
||||||
size(CI_eigenvectors_dressed,1), &
|
eigenvectors(i,j) = psi_coef(i,j)
|
||||||
CI_electronic_energy_dressed,N_det,N_states,N_states_diag,N_int, &
|
enddo
|
||||||
output_determinants,mrcc_state)
|
enddo
|
||||||
|
do mrcc_state=1,N_states
|
||||||
call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,&
|
do j=mrcc_state,min(N_states,N_det)
|
||||||
N_states_diag,size(CI_eigenvectors_dressed,1))
|
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
|
else if (diag_algorithm == "Lapack") then
|
||||||
@ -614,221 +630,66 @@ END_PROVIDER
|
|||||||
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) ]
|
&BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ]
|
||||||
implicit none
|
implicit none
|
||||||
logical :: ok
|
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, external :: searchDet, unsortedSearchDet
|
||||||
integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2)
|
integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2)
|
||||||
integer :: N, INFO, AtA_size, r1, r2
|
integer :: N, INFO, r1, r2
|
||||||
double precision , allocatable :: AtB(:), AtA_val(:), A_val(:,:), x(:), x_new(:), A_val_mwen(:)
|
double precision , allocatable :: AtB(:), x(:), x_new(:), A_val_mwen(:,:), t(:)
|
||||||
double precision :: t, norm, cx, res
|
double precision :: norm, cx, res
|
||||||
integer, allocatable :: A_ind(:,:), lref(:), AtA_ind(:), A_ind_mwen(:), col_shortcut(:), N_col(:)
|
integer, allocatable :: lref(:), A_ind_mwen(:)
|
||||||
double precision :: phase
|
double precision :: phase
|
||||||
|
|
||||||
|
|
||||||
integer, allocatable :: pathTo(:), active_hh_idx(:), active_pp_idx(:)
|
double precision, allocatable :: rho_mrcc_init(:)
|
||||||
logical, allocatable :: active(:)
|
integer :: a_coll, at_roww
|
||||||
double precision, allocatable :: rho_mrcc_init(:,:)
|
|
||||||
integer :: nactive
|
|
||||||
|
|
||||||
nex = hh_shortcut(hh_shortcut(0)+1)-1
|
print *, "TI", hh_nex, N_det_non_ref
|
||||||
print *, "TI", nex, N_det_non_ref
|
|
||||||
|
|
||||||
allocate(pathTo(N_det_non_ref), active(nex))
|
allocate(rho_mrcc_init(N_det_non_ref))
|
||||||
allocate(active_pp_idx(nex), active_hh_idx(nex))
|
allocate(x_new(hh_nex))
|
||||||
allocate(rho_mrcc_init(N_det_non_ref, N_states))
|
allocate(x(hh_nex), AtB(hh_nex))
|
||||||
|
x = 0d0
|
||||||
pathTo = 0
|
|
||||||
active = .false.
|
|
||||||
nactive = 0
|
|
||||||
|
|
||||||
|
|
||||||
do hh = 1, hh_shortcut(0)
|
do s=1,N_states
|
||||||
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)
|
AtB(:) = 0.d0
|
||||||
do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
|
!$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, active_excitation_to_determinants_idx,&
|
||||||
if(active(pp)) then
|
!$OMP active_excitation_to_determinants_val, x, N_det_ref, hh_nex, N_det_non_ref) &
|
||||||
nactive = nactive + 1
|
!$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)&
|
||||||
active_hh_idx(nactive) = hh
|
!$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx)
|
||||||
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))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
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))
|
|
||||||
|
|
||||||
!$OMP DO schedule(dynamic, 100)
|
!$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)
|
at_row = active_pp_idx(at_roww)
|
||||||
wk = 0
|
do i=1,active_excitation_to_determinants_idx(0,at_roww)
|
||||||
if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", nex
|
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)
|
||||||
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)
|
|
||||||
end do
|
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
|
end do
|
||||||
!$OMP END DO NOWAIT
|
!$OMP END DO
|
||||||
deallocate (A_ind_mwen, A_val_mwen)
|
|
||||||
!$OMP END PARALLEL
|
!$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)
|
a_col = active_pp_idx(a_coll)
|
||||||
X(a_col) = AtB(a_col)
|
X(a_col) = AtB(a_col)
|
||||||
end do
|
end do
|
||||||
|
|
||||||
rho_mrcc_init = 0d0
|
rho_mrcc_init = 0d0
|
||||||
|
|
||||||
!$OMP PARALLEL default(shared) &
|
|
||||||
!$OMP private(lref, hh, pp, II, myMask, myDet, ok, ind, phase)
|
|
||||||
allocate(lref(N_det_ref))
|
allocate(lref(N_det_ref))
|
||||||
!$OMP DO schedule(static, 1)
|
|
||||||
do hh = 1, hh_shortcut(0)
|
do hh = 1, hh_shortcut(0)
|
||||||
do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
|
do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
|
||||||
if(active(pp)) cycle
|
if(is_active_exc(pp)) cycle
|
||||||
lref = 0
|
lref = 0
|
||||||
|
AtB(pp) = 0.d0
|
||||||
do II=1,N_det_ref
|
do II=1,N_det_ref
|
||||||
call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
|
call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
|
||||||
if(.not. ok) cycle
|
if(.not. ok) cycle
|
||||||
@ -838,45 +699,43 @@ END_PROVIDER
|
|||||||
if(ind == -1) cycle
|
if(ind == -1) cycle
|
||||||
ind = psi_non_ref_sorted_idx(ind)
|
ind = psi_non_ref_sorted_idx(ind)
|
||||||
call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int)
|
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
|
AtB(pp) += psi_non_ref_coef(ind, s) * psi_ref_coef(II, s) * phase
|
||||||
lref(II) = ind
|
lref(II) = ind
|
||||||
if(phase < 0d0) lref(II) = -ind
|
if(phase < 0.d0) lref(II) = -ind
|
||||||
end do
|
end do
|
||||||
X(pp) = AtB(pp) / X(pp)
|
X(pp) = AtB(pp)
|
||||||
do II=1,N_det_ref
|
do II=1,N_det_ref
|
||||||
if(lref(II) > 0) then
|
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
|
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 if
|
||||||
end do
|
end do
|
||||||
end do
|
end do
|
||||||
end do
|
end do
|
||||||
!$OMP END DO
|
|
||||||
deallocate(lref)
|
deallocate(lref)
|
||||||
!$OMP END PARALLEL
|
|
||||||
|
|
||||||
x_new = x
|
x_new = x
|
||||||
|
|
||||||
double precision :: factor, resold
|
double precision :: factor, resold
|
||||||
factor = 1.d0
|
factor = 1.d0
|
||||||
resold = huge(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
|
!$OMP DO
|
||||||
do i=1,N_det_non_ref
|
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
|
enddo
|
||||||
!$OMP END DO
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
!$OMP DO
|
!$OMP DO
|
||||||
do a_coll = 1, nactive !: nex
|
do a_coll = 1, n_exc_active
|
||||||
a_col = active_pp_idx(a_coll)
|
a_col = active_pp_idx(a_coll)
|
||||||
cx = 0d0
|
cx = 0.d0
|
||||||
do i=col_shortcut(a_coll), col_shortcut(a_coll) + N_col(a_coll) - 1
|
do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1
|
||||||
cx = cx + x(AtA_ind(i)) * AtA_val(i)
|
cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i)
|
||||||
end do
|
end do
|
||||||
x_new(a_col) = AtB(a_col) + cx * factor
|
x_new(a_col) = AtB(a_col) + cx * factor
|
||||||
end do
|
end do
|
||||||
@ -884,35 +743,30 @@ END_PROVIDER
|
|||||||
|
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
|
||||||
res = 0.d0
|
res = 0.d0
|
||||||
|
do a_coll=1,n_exc_active
|
||||||
|
a_col = active_pp_idx(a_coll)
|
||||||
if (res < resold) then
|
do j=1,N_det_non_ref
|
||||||
do a_coll=1,nactive ! nex
|
i = active_excitation_to_determinants_idx(j,a_coll)
|
||||||
a_col = active_pp_idx(a_coll)
|
if (i==0) exit
|
||||||
do j=1,N_det_non_ref
|
rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * X_new(a_col)
|
||||||
i = A_ind(j,a_coll)
|
enddo
|
||||||
if (i==0) exit
|
res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col))
|
||||||
rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col)
|
X(a_col) = X_new(a_col)
|
||||||
enddo
|
end do
|
||||||
res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col))
|
if (res > resold) then
|
||||||
X(a_col) = X_new(a_col)
|
factor = factor * 0.5d0
|
||||||
end do
|
|
||||||
factor = 1.d0
|
|
||||||
else
|
|
||||||
factor = -factor * 0.5d0
|
|
||||||
endif
|
endif
|
||||||
resold = res
|
resold = res
|
||||||
|
|
||||||
if(mod(k, 100) == 0) then
|
if(iand(k, 4095) == 0) then
|
||||||
print *, "res ", k, res
|
print *, "res ", k, res
|
||||||
end if
|
end if
|
||||||
|
|
||||||
if(res < 1d-9) exit
|
if(res < 1d-12) exit
|
||||||
end do
|
end do
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
norm = 0.d0
|
norm = 0.d0
|
||||||
do i=1,N_det_non_ref
|
do i=1,N_det_non_ref
|
||||||
norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s)
|
norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s)
|
||||||
@ -1073,6 +927,9 @@ END_PROVIDER
|
|||||||
|
|
||||||
norm = norm*f
|
norm = norm*f
|
||||||
print *, 'norm of |T Psi_0> = ', dsqrt(norm)
|
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
|
do i=1,N_det_ref
|
||||||
norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s)
|
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
|
! rho_mrcc now contains the product of the scaling factors and the
|
||||||
! normalization constant
|
! normalization constant
|
||||||
|
|
||||||
dIj_unique(:size(X), s) = X(:)
|
dIj_unique(1:size(X), s) = X(1:size(X))
|
||||||
end do
|
end do
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
@ -1096,17 +953,14 @@ BEGIN_PROVIDER [ double precision, dij, (N_det_ref, N_det_non_ref, N_states) ]
|
|||||||
integer :: s,i,j
|
integer :: s,i,j
|
||||||
double precision, external :: get_dij_index
|
double precision, external :: get_dij_index
|
||||||
print *, "computing amplitudes..."
|
print *, "computing amplitudes..."
|
||||||
!$OMP PARALLEL DEFAULT(shared) PRIVATE(s,i,j)
|
|
||||||
do s=1, N_states
|
do s=1, N_states
|
||||||
!$OMP DO
|
|
||||||
do i=1, N_det_non_ref
|
do i=1, N_det_non_ref
|
||||||
do j=1, N_det_ref
|
do j=1, N_det_ref
|
||||||
|
!DIR$ FORCEINLINE
|
||||||
dij(j, i, s) = get_dij_index(j, i, s, N_int)
|
dij(j, i, s) = get_dij_index(j, i, s, N_int)
|
||||||
end do
|
end do
|
||||||
end do
|
end do
|
||||||
!$OMP END DO
|
|
||||||
end do
|
end do
|
||||||
!$OMP END PARALLEL
|
|
||||||
print *, "done computing amplitudes"
|
print *, "done computing amplitudes"
|
||||||
END_PROVIDER
|
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)
|
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(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase
|
||||||
get_dij_index = get_dij_index * rho_mrcc(i,s)
|
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)
|
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)
|
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 if
|
||||||
end function
|
end function
|
||||||
|
|
||||||
@ -1182,9 +1040,21 @@ end function
|
|||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ]
|
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*2, pp_exists, (4, N_pp_exists) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, hh_nex ]
|
||||||
implicit none
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! hh_exists :
|
||||||
|
!
|
||||||
|
! pp_exists :
|
||||||
|
!
|
||||||
|
! hh_shortcut :
|
||||||
|
!
|
||||||
|
! hh_nex : Total number of excitation operators
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
integer*2,allocatable :: num(:,:)
|
integer*2,allocatable :: num(:,:)
|
||||||
integer :: exc(0:2, 2, 2), degree, n, on, s, l, i
|
integer :: exc(0:2, 2, 2), degree, n, on, s, l, i
|
||||||
integer*2 :: h1, h2, p1, p2
|
integer*2 :: h1, h2, p1, p2
|
||||||
@ -1250,6 +1120,7 @@ end function
|
|||||||
end if
|
end if
|
||||||
end do
|
end do
|
||||||
end do
|
end do
|
||||||
|
hh_nex = hh_shortcut(hh_shortcut(0)+1)-1
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
1
plugins/MRPT/NEEDED_CHILDREN_MODULES
Normal file
1
plugins/MRPT/NEEDED_CHILDREN_MODULES
Normal file
@ -0,0 +1 @@
|
|||||||
|
MRPT_Utils Selectors_full Generators_full
|
14
plugins/MRPT/README.rst
Normal file
14
plugins/MRPT/README.rst
Normal 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
38
plugins/MRPT/mrpt.irp.f
Normal 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
|
@ -1 +0,0 @@
|
|||||||
Determinants Selectors_full Generators_full Davidson
|
|
@ -18,3 +18,15 @@ doc: The selection process stops when the energy ratio variational/(variational+
|
|||||||
interface: ezfio,provider,ocaml
|
interface: ezfio,provider,ocaml
|
||||||
default: 0.75
|
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.
|
||||||
|
|
||||||
|
@ -97,6 +97,10 @@ END_PROVIDER
|
|||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
N_det_non_ref = i_non_ref
|
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
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_restart, (N_int,2,psi_det_size) ]
|
BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_restart, (N_int,2,psi_det_size) ]
|
||||||
|
1
plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES
Normal file
1
plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES
Normal file
@ -0,0 +1 @@
|
|||||||
|
|
12
plugins/Selectors_CASSD/README.rst
Normal file
12
plugins/Selectors_CASSD/README.rst
Normal 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
95
plugins/Selectors_CASSD/selectors.irp.f
Normal 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
122
plugins/Selectors_CASSD/zmq.irp.f
Normal 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
|
||||||
|
|
||||||
|
|
@ -14,7 +14,7 @@ BEGIN_PROVIDER [ integer, N_det_selectors]
|
|||||||
integer :: i
|
integer :: i
|
||||||
double precision :: norm, norm_max
|
double precision :: norm, norm_max
|
||||||
call write_time(output_determinants)
|
call write_time(output_determinants)
|
||||||
N_det_selectors = N_det_generators
|
N_det_selectors = N_det
|
||||||
if (threshold_generators < 1.d0) then
|
if (threshold_generators < 1.d0) then
|
||||||
norm = 0.d0
|
norm = 0.d0
|
||||||
do i=1,N_det
|
do i=1,N_det
|
||||||
|
@ -13,7 +13,8 @@ program loc_int
|
|||||||
iorb = list_core_inact(i)
|
iorb = list_core_inact(i)
|
||||||
exchange_int = 0.d0
|
exchange_int = 0.d0
|
||||||
iorder = 0
|
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
|
do j = i+1, n_core_inact_orb
|
||||||
jorb = list_core_inact(j)
|
jorb = list_core_inact(j)
|
||||||
iorder(jorb) = jorb
|
iorder(jorb) = jorb
|
||||||
@ -45,7 +46,8 @@ program loc_int
|
|||||||
iorb = list_act(i)
|
iorb = list_act(i)
|
||||||
exchange_int = 0.d0
|
exchange_int = 0.d0
|
||||||
iorder = 0
|
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
|
do j = i+1, n_act_orb
|
||||||
jorb = list_act(j)
|
jorb = list_act(j)
|
||||||
iorder(jorb) = jorb
|
iorder(jorb) = jorb
|
||||||
@ -78,7 +80,7 @@ program loc_int
|
|||||||
exchange_int = 0.d0
|
exchange_int = 0.d0
|
||||||
iorder = 0
|
iorder = 0
|
||||||
print*,''
|
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
|
do j = i+1, n_virt_orb
|
||||||
jorb = list_virt(j)
|
jorb = list_virt(j)
|
||||||
iorder(jorb) = jorb
|
iorder(jorb) = jorb
|
||||||
|
@ -15,7 +15,7 @@ program loc_int
|
|||||||
exchange_int = 0.d0
|
exchange_int = 0.d0
|
||||||
iorder = 0
|
iorder = 0
|
||||||
print*,''
|
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
|
do j = i+1, n_act_orb
|
||||||
jorb = list_act(j)
|
jorb = list_act(j)
|
||||||
iorder(jorb) = jorb
|
iorder(jorb) = jorb
|
||||||
|
@ -14,7 +14,7 @@ program loc_int
|
|||||||
exchange_int = 0.d0
|
exchange_int = 0.d0
|
||||||
iorder = 0
|
iorder = 0
|
||||||
print*,''
|
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
|
do j = i+1, n_core_inact_orb
|
||||||
jorb = list_core_inact(j)
|
jorb = list_core_inact(j)
|
||||||
iorder(jorb) = jorb
|
iorder(jorb) = jorb
|
||||||
|
@ -15,7 +15,7 @@ program loc_int
|
|||||||
exchange_int = 0.d0
|
exchange_int = 0.d0
|
||||||
iorder = 0
|
iorder = 0
|
||||||
print*,''
|
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
|
do j = i+1, n_virt_orb
|
||||||
jorb = list_virt(j)
|
jorb = list_virt(j)
|
||||||
iorder(jorb) = jorb
|
iorder(jorb) = jorb
|
||||||
|
@ -23,7 +23,7 @@ interface: ezfio
|
|||||||
type: Threshold
|
type: Threshold
|
||||||
doc: Threshold on the convergence of the dressed CI energy
|
doc: Threshold on the convergence of the dressed CI energy
|
||||||
interface: ezfio,provider,ocaml
|
interface: ezfio,provider,ocaml
|
||||||
default: 5.e-5
|
default: 1.e-5
|
||||||
|
|
||||||
[n_it_max_dressed_ci]
|
[n_it_max_dressed_ci]
|
||||||
type: Strictly_positive_int
|
type: Strictly_positive_int
|
||||||
|
@ -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_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_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
|
use bitmasks
|
||||||
implicit none
|
implicit none
|
||||||
integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc
|
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_ij_mrcc = 0d0
|
||||||
delta_ii_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
|
provide hh_shortcut psi_det_size! lambda_mrcc
|
||||||
!$OMP PARALLEL DO default(none) schedule(dynamic) &
|
!$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(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)
|
!$OMP private(h, n, mask, omask, buf, ok, iproc)
|
||||||
do gen= 1, N_det_generators
|
do gen= 1, N_det_generators
|
||||||
allocate(buf(N_int, 2, N_det_non_ref))
|
allocate(buf(N_int, 2, N_det_non_ref))
|
||||||
@ -37,7 +41,9 @@ use bitmasks
|
|||||||
end do
|
end do
|
||||||
n = n - 1
|
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
|
end do
|
||||||
deallocate(buf)
|
deallocate(buf)
|
||||||
@ -52,13 +58,15 @@ END_PROVIDER
|
|||||||
! end subroutine
|
! 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
|
use bitmasks
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
integer, intent(in) :: i_generator,n_selected, Nint
|
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_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_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(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
|
||||||
integer :: i,j,k,l,m
|
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(bit_kind),allocatable :: tq(:,:,:)
|
||||||
integer :: N_tq, c_ref ,degree
|
integer :: N_tq, c_ref ,degree
|
||||||
|
|
||||||
double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states)
|
double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states)
|
||||||
double precision, allocatable :: dIa_hla(:,:)
|
double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:)
|
||||||
double precision :: haj, phase, phase2
|
double precision :: haj, phase, phase2
|
||||||
double precision :: f(N_states), ci_inv(N_states)
|
double precision :: f(N_states), ci_inv(N_states)
|
||||||
integer :: exc(0:2,2,2)
|
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(bit_kind),intent(in) :: key_mask(Nint, 2)
|
||||||
integer,allocatable :: idx_miniList(:)
|
integer,allocatable :: idx_miniList(:)
|
||||||
integer :: N_miniList, ni, leng
|
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(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:)
|
||||||
integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_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)
|
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))
|
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)
|
!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)
|
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)
|
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>
|
! |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)
|
do l_sd=1,idx_alpha(0)
|
||||||
k_sd = idx_alpha(l_sd)
|
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 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
|
enddo
|
||||||
! |I>
|
! |I>
|
||||||
do i_I=1,N_det_ref
|
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)
|
do l_sd=1,idx_alpha(0)
|
||||||
k_sd = idx_alpha(l_sd)
|
k_sd = idx_alpha(l_sd)
|
||||||
hla = hij_cache(k_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)
|
! 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
|
do i_state=1,N_states
|
||||||
dIa_hla(i_state,k_sd) = dIa(i_state) * hla
|
dIa_hla(i_state,k_sd) = dIa(i_state) * hla
|
||||||
|
dIa_sla(i_state,k_sd) = dIa(i_state) * sla
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
call omp_set_lock( psi_ref_lock(i_I) )
|
call omp_set_lock( psi_ref_lock(i_I) )
|
||||||
do i_state=1,N_states
|
do i_state=1,N_states
|
||||||
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then
|
! if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then
|
||||||
do l_sd=1,idx_alpha(0)
|
! do l_sd=1,idx_alpha(0)
|
||||||
k_sd = idx_alpha(l_sd)
|
! 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_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_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
|
! delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd)
|
||||||
else
|
! 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
|
delta_ii_(i_state,i_I) = 0.d0
|
||||||
do l_sd=1,idx_alpha(0)
|
do l_sd=1,idx_alpha(0)
|
||||||
k_sd = idx_alpha(l_sd)
|
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_(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
|
enddo
|
||||||
endif
|
! endif
|
||||||
enddo
|
enddo
|
||||||
call omp_unset_lock( psi_ref_lock(i_I) )
|
call omp_unset_lock( psi_ref_lock(i_I) )
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
deallocate (dIa_hla,hij_cache)
|
deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache)
|
||||||
deallocate(miniList, idx_miniList)
|
deallocate(miniList, idx_miniList)
|
||||||
end
|
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_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_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
|
use bitmasks
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i, j, i_state
|
integer :: i, j, i_state
|
||||||
|
|
||||||
!mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc
|
!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
|
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
|
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
|
||||||
end do
|
end do
|
||||||
!
|
|
||||||
! do i = 1, N_det_ref
|
! =-=-= BEGIN STATE AVERAGE
|
||||||
! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state)
|
! do i = 1, N_det_ref
|
||||||
! do j = 1, N_det_non_ref
|
! delta_ii(:,i)= delta_ii_mrcc(1,i)
|
||||||
! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state)
|
! delta_ii_s2(:,i)= delta_ii_s2_mrcc(1,i)
|
||||||
! end do
|
! do i_state = 2, N_states
|
||||||
! end do
|
! delta_ii(:,i) += delta_ii_mrcc(i_state,i)
|
||||||
else if(mrmode == 2) then
|
! delta_ii_s2(:,i) += delta_ii_s2_mrcc(i_state,i)
|
||||||
do i = 1, N_det_ref
|
! 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)
|
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)
|
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
|
end do
|
||||||
else if(mrmode == 1) then
|
end do
|
||||||
do i = 1, N_det_ref
|
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)
|
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)
|
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
|
end do
|
||||||
else
|
end do
|
||||||
stop "invalid mrmode"
|
else
|
||||||
end if
|
stop "invalid mrmode"
|
||||||
end do
|
end if
|
||||||
END_PROVIDER
|
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, (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
|
use bitmasks
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i,j,k
|
integer :: i,j,k
|
||||||
double precision :: Hjk, Hki, Hij
|
double precision :: Sjk,Hjk, Hki, Hij
|
||||||
!double precision, external :: get_dij
|
!double precision, external :: get_dij
|
||||||
integer i_state, degree
|
integer i_state, degree
|
||||||
|
|
||||||
provide lambda_mrcc dIj
|
provide lambda_mrcc dIj
|
||||||
do i_state = 1, N_states
|
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 i=1,N_det_ref
|
||||||
do j=1,i
|
do j=1,i
|
||||||
call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int)
|
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(i,j,i_state) = 0d0
|
||||||
|
delta_cas_s2(i,j,i_state) = 0d0
|
||||||
do k=1,N_det_non_ref
|
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 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)
|
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
|
end do
|
||||||
delta_cas(j,i,i_state) = delta_cas(i,j,i_state)
|
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
|
||||||
end do
|
end do
|
||||||
!$OMP END PARALLEL 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_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_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
|
use bitmasks
|
||||||
implicit none
|
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)
|
integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref)
|
||||||
logical :: ok
|
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 :: 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, 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) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2)
|
||||||
integer(bit_kind),allocatable :: sortRef(:,:,:)
|
integer(bit_kind),allocatable :: sortRef(:,:,:)
|
||||||
@ -671,14 +730,16 @@ end function
|
|||||||
! To provide everything
|
! To provide everything
|
||||||
contrib = dij(1, 1, 1)
|
contrib = dij(1, 1, 1)
|
||||||
|
|
||||||
do i_state = 1, N_states
|
delta_mrcepa0_ii(:,:) = 0d0
|
||||||
delta_mrcepa0_ii(:,:) = 0d0
|
delta_mrcepa0_ij(:,:,:) = 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) &
|
do i_state = 1, N_states
|
||||||
!$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2) &
|
!$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(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)
|
!$OMP shared(notf,i_state, sortRef, sortRefIdx, dij)
|
||||||
do blok=1,cepa0_shortcut(0)
|
do blok=1,cepa0_shortcut(0)
|
||||||
do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1
|
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)
|
! 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 = 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
|
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 = 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
|
!$OMP ATOMIC
|
||||||
delta_mrcepa0_ii(J,i_state) -= contrib2
|
delta_mrcepa0_ii(J,i_state) -= contrib2
|
||||||
|
delta_mrcepa0_ii_s2(J,i_state) -= contrib2_s2
|
||||||
else
|
else
|
||||||
contrib = contrib * 0.5d0
|
contrib = contrib * 0.5d0
|
||||||
|
contrib_s2 = contrib_s2 * 0.5d0
|
||||||
end if
|
end if
|
||||||
!$OMP ATOMIC
|
!$OMP ATOMIC
|
||||||
delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib
|
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 kloop
|
||||||
end do
|
end do
|
||||||
@ -741,7 +807,7 @@ end function
|
|||||||
deallocate(idx_sorted_bit)
|
deallocate(idx_sorted_bit)
|
||||||
call wall_time(wall)
|
call wall_time(wall)
|
||||||
print *, "cepa0", wall, notf
|
print *, "cepa0", wall, notf
|
||||||
!stop
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
@ -860,12 +926,14 @@ subroutine set_det_bit(det, p, s)
|
|||||||
end subroutine
|
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
|
implicit none
|
||||||
integer :: i,j
|
integer :: i,j
|
||||||
do i=1,N_det_ref
|
do i=1,N_det_ref
|
||||||
do j=1,N_det_non_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 do
|
end do
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
@ -37,7 +37,7 @@ subroutine mrsc2_dressing_slave(thread,iproc)
|
|||||||
integer(ZMQ_PTR), external :: new_zmq_push_socket
|
integer(ZMQ_PTR), external :: new_zmq_push_socket
|
||||||
integer(ZMQ_PTR) :: zmq_socket_push
|
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
|
logical :: ok
|
||||||
double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al
|
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 :: diI, hIi, hJi, delta_JI, dkI, HkI, ci_inv(N_states), cj_inv(N_states)
|
||||||
double precision :: contrib, wall, iwall
|
double precision :: contrib, contrib_s2, wall, iwall
|
||||||
double precision, allocatable :: dleat(:,:,:)
|
double precision, allocatable :: dleat(:,:,:), dleat_s2(:,:,:)
|
||||||
integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ
|
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(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
|
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)
|
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(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))
|
allocate(komon(0:N_det_non_ref))
|
||||||
|
|
||||||
do
|
do
|
||||||
@ -74,10 +75,14 @@ subroutine mrsc2_dressing_slave(thread,iproc)
|
|||||||
cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state)
|
cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state)
|
||||||
end do
|
end do
|
||||||
!delta = 0.d0
|
!delta = 0.d0
|
||||||
|
!delta_s2 = 0.d0
|
||||||
n = 0
|
n = 0
|
||||||
delta(:,0,:) = 0d0
|
delta(:,0,:) = 0d0
|
||||||
delta(:,:nlink(J),1) = 0d0
|
delta(:,:nlink(J),1) = 0d0
|
||||||
delta(:,:nlink(i_I),2) = 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
|
komon(0) = 0
|
||||||
komoned = .false.
|
komoned = .false.
|
||||||
|
|
||||||
@ -121,8 +126,8 @@ subroutine mrsc2_dressing_slave(thread,iproc)
|
|||||||
end if
|
end if
|
||||||
i = det_cepa0_idx(linked(m, i_I))
|
i = det_cepa0_idx(linked(m, i_I))
|
||||||
|
|
||||||
if(h_(J,i) == 0.d0) cycle
|
if(h_cache(J,i) == 0.d0) cycle
|
||||||
if(h_(i_I,i) == 0.d0) cycle
|
if(h_cache(i_I,i) == 0.d0) cycle
|
||||||
|
|
||||||
!ok = .false.
|
!ok = .false.
|
||||||
!do i_state=1, N_states
|
!do i_state=1, N_states
|
||||||
@ -144,10 +149,13 @@ subroutine mrsc2_dressing_slave(thread,iproc)
|
|||||||
! if(I_i == J) phase_Ii = phase_Ji
|
! if(I_i == J) phase_Ii = phase_Ji
|
||||||
|
|
||||||
do i_state = 1,N_states
|
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_cache(J,i) * dij(i_I, i, i_state)
|
||||||
!dkI = h_(J,i) * h_(i_I,i) * lambda_mrcc(i_state, i)
|
|
||||||
dleat(i_state, kn, 1) = dkI
|
dleat(i_state, kn, 1) = dkI
|
||||||
dleat(i_state, kn, 2) = 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
|
||||||
|
|
||||||
end do
|
end do
|
||||||
@ -173,26 +181,32 @@ subroutine mrsc2_dressing_slave(thread,iproc)
|
|||||||
!if(lambda_mrcc(i_state, i) == 0d0) cycle
|
!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 = 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(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
|
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(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
|
endif
|
||||||
|
|
||||||
if(I_i == J) cycle
|
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 = 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(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
|
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(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
|
end if
|
||||||
enddo !i_state
|
enddo !i_state
|
||||||
end do ! while
|
end do ! while
|
||||||
end do ! kk
|
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)
|
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
|
||||||
|
|
||||||
! end if
|
! end if
|
||||||
@ -208,7 +222,7 @@ subroutine mrsc2_dressing_slave(thread,iproc)
|
|||||||
end
|
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
|
use f77_zmq
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
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, intent(in) :: i_I, J
|
||||||
integer(ZMQ_PTR), intent(in) :: zmq_socket_push
|
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(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, intent(in) :: task_id
|
||||||
integer :: rc , i_state, i, kk, li
|
integer :: rc , i_state, i, kk, li
|
||||||
integer,allocatable :: idx(:,:)
|
integer,allocatable :: idx(:,:)
|
||||||
@ -279,6 +294,12 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id)
|
|||||||
stop 'error'
|
stop 'error'
|
||||||
endif
|
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)
|
rc = f77_zmq_send( zmq_socket_push, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)
|
||||||
if (rc /= n(kk)*4) then
|
if (rc /= n(kk)*4) then
|
||||||
print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, 8*n(kk), ZMQ_SNDMORE)'
|
print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, 8*n(kk), ZMQ_SNDMORE)'
|
||||||
@ -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
|
use f77_zmq
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
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(ZMQ_PTR), intent(in) :: zmq_socket_pull
|
||||||
integer, intent(out) :: i_I, J, n(2)
|
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(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, intent(out) :: task_id
|
||||||
integer :: rc , i, kk
|
integer :: rc , i, kk
|
||||||
integer,intent(inout) :: idx(N_det_non_ref,2)
|
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'
|
stop 'error'
|
||||||
endif
|
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)
|
rc = f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)
|
||||||
if (rc /= n(kk)*4) then
|
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'
|
stop 'error'
|
||||||
endif
|
endif
|
||||||
end if
|
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
|
use f77_zmq
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
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_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_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 :: j,l
|
||||||
integer :: rc
|
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),external :: new_zmq_to_qp_run_socket
|
||||||
integer(ZMQ_PTR) :: 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_ii_(:,:) = 0d0
|
||||||
delta_ij_(:,:,:) = 0d0
|
delta_ij_(:,:,:) = 0d0
|
||||||
|
delta_ii_s2_(:,:) = 0d0
|
||||||
|
delta_ij_s2_(:,:,:) = 0d0
|
||||||
|
|
||||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||||
zmq_socket_pull = new_zmq_pull_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))
|
allocate(idx(N_det_non_ref,2))
|
||||||
more = 1
|
more = 1
|
||||||
do while (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 l=1, n(1)
|
||||||
do i_state=1,N_states
|
do i_state=1,N_states
|
||||||
delta_ij_(i_state,idx(l,1),i_I) += delta(i_state,l,1)
|
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
|
||||||
end do
|
end do
|
||||||
|
|
||||||
do l=1, n(2)
|
do l=1, n(2)
|
||||||
do i_state=1,N_states
|
do i_state=1,N_states
|
||||||
delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2)
|
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
|
||||||
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
|
if(n(1) /= 0) then
|
||||||
do i_state=1,N_states
|
do i_state=1,N_states
|
||||||
delta_ii_(i_state,i_I) += delta(i_state,0,1)
|
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 do
|
||||||
end if
|
end if
|
||||||
|
|
||||||
if(n(2) /= 0) then
|
if(n(2) /= 0) then
|
||||||
do i_state=1,N_states
|
do i_state=1,N_states
|
||||||
delta_ii_(i_state,J) += delta(i_state,0,2)
|
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 do
|
||||||
end if
|
end if
|
||||||
|
|
||||||
@ -454,7 +482,7 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_)
|
|||||||
|
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
deallocate( delta )
|
deallocate( delta, delta_s2 )
|
||||||
|
|
||||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||||
call end_zmq_pull_socket(zmq_socket_pull)
|
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_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_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
|
implicit none
|
||||||
|
|
||||||
integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2
|
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)
|
! rc = pthread_create(collector_thread, mrsc2_dressing_collector)
|
||||||
print *, nzer, ntot, float(nzer) / float(ntot)
|
print *, nzer, ntot, float(nzer) / float(ntot)
|
||||||
provide nproc
|
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()
|
i = omp_get_thread_num()
|
||||||
if (i==0) then
|
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
|
else
|
||||||
call mrsc2_dressing_slave_inproc(i)
|
call mrsc2_dressing_slave_inproc(i)
|
||||||
endif
|
endif
|
||||||
|
@ -8,8 +8,16 @@ program mrsc2sub
|
|||||||
|
|
||||||
read_wf = .True.
|
read_wf = .True.
|
||||||
SOFT_TOUCH read_wf
|
SOFT_TOUCH read_wf
|
||||||
call print_cas_coefs
|
|
||||||
call set_generators_bitmasks_as_holes_and_particles
|
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)
|
call run(N_states,energy)
|
||||||
if(do_pt2_end)then
|
if(do_pt2_end)then
|
||||||
call run_pt2(N_states,energy)
|
call run_pt2(N_states,energy)
|
||||||
|
@ -8,8 +8,18 @@ program mrcepa0
|
|||||||
|
|
||||||
read_wf = .True.
|
read_wf = .True.
|
||||||
SOFT_TOUCH read_wf
|
SOFT_TOUCH read_wf
|
||||||
call print_cas_coefs
|
|
||||||
call set_generators_bitmasks_as_holes_and_particles
|
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)
|
call run(N_states,energy)
|
||||||
if(do_pt2_end)then
|
if(do_pt2_end)then
|
||||||
call run_pt2(N_states,energy)
|
call run_pt2(N_states,energy)
|
||||||
|
@ -10,18 +10,18 @@ subroutine run(N_st,energy)
|
|||||||
|
|
||||||
double precision :: E_new, E_old, delta_e
|
double precision :: E_new, E_old, delta_e
|
||||||
integer :: iteration
|
integer :: iteration
|
||||||
double precision :: E_past(4), lambda
|
double precision :: E_past(4)
|
||||||
|
|
||||||
integer :: n_it_mrcc_max
|
integer :: n_it_mrcc_max
|
||||||
double precision :: thresh_mrcc
|
double precision :: thresh_mrcc
|
||||||
|
double precision, allocatable :: lambda(:)
|
||||||
|
allocate (lambda(N_states))
|
||||||
|
|
||||||
thresh_mrcc = thresh_dressed_ci
|
thresh_mrcc = thresh_dressed_ci
|
||||||
n_it_mrcc_max = n_it_max_dressed_ci
|
n_it_mrcc_max = n_it_max_dressed_ci
|
||||||
|
|
||||||
if(n_it_mrcc_max == 1) then
|
if(n_it_mrcc_max == 1) then
|
||||||
do j=1,N_states_diag
|
do j=1,N_states
|
||||||
do i=1,N_det
|
do i=1,N_det
|
||||||
psi_coef(i,j) = CI_eigenvectors_dressed(i,j)
|
psi_coef(i,j) = CI_eigenvectors_dressed(i,j)
|
||||||
enddo
|
enddo
|
||||||
@ -30,7 +30,6 @@ subroutine run(N_st,energy)
|
|||||||
call write_double(6,ci_energy_dressed(1),"Final MRCC energy")
|
call write_double(6,ci_energy_dressed(1),"Final MRCC energy")
|
||||||
call ezfio_set_mrcepa0_energy(ci_energy_dressed(1))
|
call ezfio_set_mrcepa0_energy(ci_energy_dressed(1))
|
||||||
call save_wavefunction
|
call save_wavefunction
|
||||||
energy(:) = ci_energy_dressed(:)
|
|
||||||
else
|
else
|
||||||
E_new = 0.d0
|
E_new = 0.d0
|
||||||
delta_E = 1.d0
|
delta_E = 1.d0
|
||||||
@ -38,15 +37,21 @@ subroutine run(N_st,energy)
|
|||||||
lambda = 1.d0
|
lambda = 1.d0
|
||||||
do while (delta_E > thresh_mrcc)
|
do while (delta_E > thresh_mrcc)
|
||||||
iteration += 1
|
iteration += 1
|
||||||
print *, '==========================='
|
print *, '==============================================='
|
||||||
print *, 'MRCEPA0 Iteration', iteration
|
print *, 'MRCEPA0 Iteration', iteration, '/', n_it_mrcc_max
|
||||||
print *, '==========================='
|
print *, '==============================================='
|
||||||
print *, ''
|
print *, ''
|
||||||
E_old = sum(ci_energy_dressed)
|
E_old = sum(ci_energy_dressed(1:N_states))
|
||||||
call write_double(6,ci_energy_dressed(1),"MRCEPA0 energy")
|
do i=1,N_st
|
||||||
|
call write_double(6,ci_energy_dressed(i),"MRCEPA0 energy")
|
||||||
|
enddo
|
||||||
call diagonalize_ci_dressed(lambda)
|
call diagonalize_ci_dressed(lambda)
|
||||||
E_new = sum(ci_energy_dressed)
|
E_new = sum(ci_energy_dressed(1:N_states))
|
||||||
delta_E = dabs(E_new - E_old)
|
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 save_wavefunction
|
||||||
call ezfio_set_mrcepa0_energy(ci_energy_dressed(1))
|
call ezfio_set_mrcepa0_energy(ci_energy_dressed(1))
|
||||||
if (iteration >= n_it_mrcc_max) then
|
if (iteration >= n_it_mrcc_max) then
|
||||||
@ -54,8 +59,8 @@ subroutine run(N_st,energy)
|
|||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
call write_double(6,ci_energy_dressed(1),"Final MRCEPA0 energy")
|
call write_double(6,ci_energy_dressed(1),"Final MRCEPA0 energy")
|
||||||
energy(:) = ci_energy_dressed(:)
|
|
||||||
endif
|
endif
|
||||||
|
energy(1:N_st) = ci_energy_dressed(1:N_st)
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
@ -66,7 +71,7 @@ subroutine print_cas_coefs
|
|||||||
print *, 'CAS'
|
print *, 'CAS'
|
||||||
print *, '==='
|
print *, '==='
|
||||||
do i=1,N_det_cas
|
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)
|
call debug_det(psi_cas(1,1,i),N_int)
|
||||||
enddo
|
enddo
|
||||||
call write_double(6,ci_energy(1),"Initial CI energy")
|
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'
|
print * ,'Computing the remaining contribution'
|
||||||
|
|
||||||
threshold_selectors = 1.d0
|
threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
|
||||||
threshold_generators = 0.999d0
|
threshold_generators = max(threshold_generators,threshold_generators_pt2)
|
||||||
|
|
||||||
N_det_generators = N_det_non_ref + N_det_ref
|
N_det_generators = N_det_non_ref + N_det_ref
|
||||||
N_det_selectors = N_det_non_ref + N_det_ref
|
N_det_selectors = N_det_non_ref + N_det_ref
|
||||||
|
@ -7,8 +7,16 @@ program mrsc2
|
|||||||
mrmode = 2
|
mrmode = 2
|
||||||
read_wf = .True.
|
read_wf = .True.
|
||||||
SOFT_TOUCH read_wf
|
SOFT_TOUCH read_wf
|
||||||
call print_cas_coefs
|
|
||||||
call set_generators_bitmasks_as_holes_and_particles
|
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)
|
call run(N_states,energy)
|
||||||
if(do_pt2_end)then
|
if(do_pt2_end)then
|
||||||
call run_pt2(N_states,energy)
|
call run_pt2(N_states,energy)
|
||||||
|
@ -422,7 +422,7 @@ class H_apply(object):
|
|||||||
if (s2_eig) then
|
if (s2_eig) then
|
||||||
call make_s2_eigenfunction
|
call make_s2_eigenfunction
|
||||||
endif
|
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_min = min(selection_criterion_min, maxval(select_max))*0.1d0
|
||||||
selection_criterion = selection_criterion_min
|
selection_criterion = selection_criterion_min
|
||||||
call write_double(output_determinants,selection_criterion,'Selection criterion')
|
call write_double(output_determinants,selection_criterion,'Selection criterion')
|
||||||
|
@ -6,7 +6,25 @@ default: 1.e-12
|
|||||||
|
|
||||||
[n_states_diag]
|
[n_states_diag]
|
||||||
type: States_number
|
type: States_number
|
||||||
doc: n_states_diag
|
doc: Number of states to consider during the Davdison diagonalization
|
||||||
default: 10
|
default: 10
|
||||||
interface: ezfio,provider,ocaml
|
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
|
||||||
|
|
||||||
|
@ -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, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit
|
||||||
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
|
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
|
||||||
double precision, intent(inout) :: u_in(dim_in,N_st_diag)
|
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, allocatable :: H_jj(:), S2_jj(:)
|
||||||
|
|
||||||
double precision :: diag_h_mat_elem
|
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 DO
|
||||||
!$OMP END PARALLEL
|
!$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
|
do i=1,N_st_diag
|
||||||
s2_out(i) = S2_jj(i)
|
s2_out(i) = S2_jj(i)
|
||||||
enddo
|
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, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint
|
||||||
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
|
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
|
||||||
double precision, intent(in) :: H_jj(sze)
|
double precision, intent(in) :: H_jj(sze)
|
||||||
double precision, intent(inout) :: S2_jj(sze)
|
double precision, intent(inout) :: S2_jj(sze)
|
||||||
integer, intent(in) :: iunit
|
integer, intent(in) :: iunit
|
||||||
double precision, intent(inout) :: u_in(dim_in,N_st_diag)
|
double precision, intent(inout) :: u_in(dim_in,N_st_diag)
|
||||||
double precision, intent(out) :: energies(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 :: k_pairs, kl
|
||||||
|
|
||||||
integer :: iter2
|
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 :: y(:,:), h(:,:), lambda(:), s2(:)
|
||||||
double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:)
|
double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:)
|
||||||
double precision :: diag_h_mat_elem
|
double precision :: diag_h_mat_elem
|
||||||
@ -107,16 +111,18 @@ 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 :: to_print(3,N_st)
|
||||||
double precision :: cpu, wall
|
double precision :: cpu, wall
|
||||||
integer :: shift, shift2, itermax
|
integer :: shift, shift2, itermax
|
||||||
|
double precision :: r1, r2
|
||||||
|
logical :: state_ok(N_st_diag*davidson_sze_max)
|
||||||
include 'constants.include.F'
|
include 'constants.include.F'
|
||||||
|
|
||||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda
|
||||||
if (N_st_diag*3 > sze) then
|
if (N_st_diag*3 > sze) then
|
||||||
print *, 'error in Davidson :'
|
print *, 'error in Davidson :'
|
||||||
print *, 'Increase n_det_max_jacobi to ', N_st_diag*3
|
print *, 'Increase n_det_max_jacobi to ', N_st_diag*3
|
||||||
stop -1
|
stop -1
|
||||||
endif
|
endif
|
||||||
|
|
||||||
PROVIDE nuclear_repulsion
|
PROVIDE nuclear_repulsion expected_s2
|
||||||
|
|
||||||
call write_time(iunit)
|
call write_time(iunit)
|
||||||
call wall_time(wall)
|
call wall_time(wall)
|
||||||
@ -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(iunit,'(A)') trim(write_buffer)
|
||||||
write_buffer = ' Iter'
|
write_buffer = ' Iter'
|
||||||
do i=1,N_st
|
do i=1,N_st
|
||||||
write_buffer = trim(write_buffer)//' Energy S^2 Residual'
|
write_buffer = trim(write_buffer)//' Energy S^2 Residual '
|
||||||
enddo
|
enddo
|
||||||
write(iunit,'(A)') trim(write_buffer)
|
write(iunit,'(A)') trim(write_buffer)
|
||||||
write_buffer = '===== '
|
write_buffer = '===== '
|
||||||
@ -145,30 +151,31 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
|
|||||||
enddo
|
enddo
|
||||||
write(iunit,'(A)') trim(write_buffer)
|
write(iunit,'(A)') trim(write_buffer)
|
||||||
|
|
||||||
integer, external :: align_double
|
integer, external :: align_double
|
||||||
sze_8 = align_double(sze)
|
sze_8 = align_double(sze)
|
||||||
|
|
||||||
itermax = min(davidson_sze_max, sze/N_st_diag)
|
itermax = min(davidson_sze_max, sze/N_st_diag)
|
||||||
allocate( &
|
allocate( &
|
||||||
W(sze_8,N_st_diag*itermax), &
|
W(sze_8,N_st_diag*itermax), &
|
||||||
U(sze_8,N_st_diag*itermax), &
|
U(sze_8,N_st_diag*itermax), &
|
||||||
S(sze_8,N_st_diag*itermax), &
|
S(sze_8,N_st_diag*itermax), &
|
||||||
h(N_st_diag*itermax,N_st_diag*itermax), &
|
h(N_st_diag*itermax,N_st_diag*itermax), &
|
||||||
y(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_(N_st_diag*itermax,N_st_diag*itermax), &
|
||||||
s_tmp(N_st_diag*itermax,N_st_diag*itermax), &
|
s_tmp(N_st_diag*itermax,N_st_diag*itermax), &
|
||||||
residual_norm(N_st_diag), &
|
residual_norm(N_st_diag), &
|
||||||
c(N_st_diag*itermax), &
|
c(N_st_diag*itermax), &
|
||||||
s2(N_st_diag*itermax), &
|
s2(N_st_diag*itermax), &
|
||||||
|
overlap(N_st_diag*itermax, N_st_diag*itermax), &
|
||||||
lambda(N_st_diag*itermax))
|
lambda(N_st_diag*itermax))
|
||||||
|
|
||||||
h = 0.d0
|
h = 0.d0
|
||||||
s_ = 0.d0
|
|
||||||
s_tmp = 0.d0
|
|
||||||
U = 0.d0
|
U = 0.d0
|
||||||
W = 0.d0
|
W = 0.d0
|
||||||
S = 0.d0
|
S = 0.d0
|
||||||
y = 0.d0
|
y = 0.d0
|
||||||
|
s_ = 0.d0
|
||||||
|
s_tmp = 0.d0
|
||||||
|
|
||||||
|
|
||||||
ASSERT (N_st > 0)
|
ASSERT (N_st > 0)
|
||||||
@ -182,25 +189,18 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
|
|||||||
|
|
||||||
converged = .False.
|
converged = .False.
|
||||||
|
|
||||||
double precision :: r1, r2
|
do k=N_st+1,N_st_diag
|
||||||
do k=N_st+1,N_st_diag-2,2
|
u_in(k,k) = 10.d0
|
||||||
do i=1,sze
|
do i=1,sze
|
||||||
call random_number(r1)
|
call random_number(r1)
|
||||||
call random_number(r2)
|
call random_number(r2)
|
||||||
r1 = dsqrt(-2.d0*dlog(r1))
|
r1 = dsqrt(-2.d0*dlog(r1))
|
||||||
r2 = dtwo_pi*r2
|
r2 = dtwo_pi*r2
|
||||||
u_in(i,k) = r1*dcos(r2)
|
u_in(i,k) = r1*dcos(r2)
|
||||||
u_in(i,k+1) = r1*dsin(r2)
|
enddo
|
||||||
enddo
|
|
||||||
enddo
|
enddo
|
||||||
do k=N_st_diag-1,N_st_diag
|
do k=1,N_st_diag
|
||||||
do i=1,sze
|
call normalize(u_in(1,k),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
|
enddo
|
||||||
|
|
||||||
|
|
||||||
@ -223,6 +223,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
|
|||||||
! -----------------------------------------
|
! -----------------------------------------
|
||||||
|
|
||||||
|
|
||||||
|
! 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)
|
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, &
|
call dgemm('T','N', shift2, shift2, sze, &
|
||||||
1.d0, U(1,1), size(U,1), W(1,1), size(W,1), &
|
1.d0, U, size(U,1), W, size(W,1), &
|
||||||
0.d0, h(1,1), size(h,1))
|
0.d0, h, size(h,1))
|
||||||
|
|
||||||
call dgemm('T','N', shift2, shift2, sze, &
|
call dgemm('T','N', shift2, shift2, sze, &
|
||||||
1.d0, U(1,1), size(U,1), S(1,1), size(S,1), &
|
1.d0, U, size(U,1), S, size(S,1), &
|
||||||
0.d0, s_(1,1), 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
|
! Diagonalize h
|
||||||
! -------------
|
! -------------
|
||||||
|
|
||||||
call lapack_diag(lambda,y,h,size(h,1),shift2)
|
call lapack_diag(lambda,y,h,size(h,1),shift2)
|
||||||
|
|
||||||
! Compute S2 for each eigenvector
|
! Compute S2 for each eigenvector
|
||||||
@ -253,29 +295,77 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s
|
|||||||
1.d0, y, size(y,1), s_tmp, size(s_tmp,1), &
|
1.d0, y, size(y,1), s_tmp, size(s_tmp,1), &
|
||||||
0.d0, s_, size(s_,1))
|
0.d0, s_, size(s_,1))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
do k=1,shift2
|
do k=1,shift2
|
||||||
s2(k) = s_(k,k) + S_z2_Sz
|
s2(k) = s_(k,k) + S_z2_Sz
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
if (s2_eig) then
|
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
|
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
|
enddo
|
||||||
do k=1,shift2
|
do k=1,N_st
|
||||||
if (.not. state_ok(k)) then
|
cmax = -1.d0
|
||||||
do l=k+1,shift2
|
do i=1,N_st
|
||||||
if (state_ok(l)) then
|
if (overlap(i,k) > cmax) then
|
||||||
call dswap(shift2, y(1,k), 1, y(1,l), 1)
|
cmax = overlap(i,k)
|
||||||
call dswap(1, s2(k), 1, s2(l), 1)
|
order(k) = i
|
||||||
call dswap(1, lambda(k), 1, lambda(l), 1)
|
endif
|
||||||
state_ok(k) = .True.
|
enddo
|
||||||
state_ok(l) = .False.
|
do i=1,N_st_diag
|
||||||
exit
|
overlap(order(k),i) = -1.d0
|
||||||
endif
|
enddo
|
||||||
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
|
endif
|
||||||
enddo
|
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
|
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 k=1,N_st_diag
|
||||||
do i=1,sze
|
if (state_ok(k)) then
|
||||||
U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
|
do i=1,sze
|
||||||
* (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz &
|
U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
|
||||||
)/max(H_jj(i) - lambda (k),1.d-2)
|
* (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz &
|
||||||
enddo
|
)/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
|
if (k <= N_st) then
|
||||||
residual_norm(k) = u_dot_u(U(1,shift2+k),sze)
|
residual_norm(k) = u_dot_u(U(1,shift2+k),sze)
|
||||||
to_print(1,k) = lambda(k) + nuclear_repulsion
|
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
|
enddo
|
||||||
|
|
||||||
if (.not.converged) then
|
|
||||||
iter = itermax-1
|
|
||||||
endif
|
|
||||||
|
|
||||||
! Re-contract to u_in
|
! Re-contract to u_in
|
||||||
! -----------
|
! -----------
|
||||||
|
|
||||||
do k=1,N_st_diag
|
call dgemm('N','N', sze, N_st_diag, shift2, 1.d0, &
|
||||||
energies(k) = lambda(k)
|
|
||||||
enddo
|
|
||||||
|
|
||||||
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))
|
U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1))
|
||||||
|
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
do k=1,N_st_diag
|
do k=1,N_st_diag
|
||||||
|
energies(k) = lambda(k)
|
||||||
S2_jj(k) = s2(k)
|
S2_jj(k) = s2(k)
|
||||||
enddo
|
enddo
|
||||||
write_buffer = '===== '
|
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 ( &
|
deallocate ( &
|
||||||
W, residual_norm, &
|
W, residual_norm, &
|
||||||
U, &
|
U, overlap, &
|
||||||
c, S, &
|
c, S, &
|
||||||
h, &
|
h, &
|
||||||
y, s_, s_tmp, &
|
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
|
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
|
||||||
|
|
||||||
|
@ -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 ]
|
BEGIN_PROVIDER [ character(64), davidson_criterion ]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
|
@ -177,7 +177,7 @@ BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ]
|
|||||||
END_PROVIDER
|
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 bitmasks
|
||||||
use f77_zmq
|
use f77_zmq
|
||||||
implicit none
|
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
|
||||||
|
|
||||||
|
@ -222,7 +222,11 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
|
|||||||
do while (bit_tmp(j)==bit_tmp(i))
|
do while (bit_tmp(j)==bit_tmp(i))
|
||||||
if (duplicate(j)) then
|
if (duplicate(j)) then
|
||||||
j += 1
|
j += 1
|
||||||
cycle
|
if (j > N_det) then
|
||||||
|
exit
|
||||||
|
else
|
||||||
|
cycle
|
||||||
|
endif
|
||||||
endif
|
endif
|
||||||
duplicate(j) = .True.
|
duplicate(j) = .True.
|
||||||
do k=1,N_int
|
do k=1,N_int
|
||||||
@ -248,17 +252,20 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
|
|||||||
enddo
|
enddo
|
||||||
|
|
||||||
if (found_duplicates) then
|
if (found_duplicates) then
|
||||||
call write_bool(output_determinants,found_duplicates,'Found duplicate determinants')
|
|
||||||
k=0
|
k=0
|
||||||
do i=1,N_det
|
do i=1,N_det
|
||||||
if (.not.duplicate(i)) then
|
if (.not.duplicate(i)) then
|
||||||
k += 1
|
k += 1
|
||||||
psi_det(:,:,k) = psi_det_sorted_bit (:,:,i)
|
psi_det(:,:,k) = psi_det_sorted_bit (:,:,i)
|
||||||
psi_coef(k,:) = psi_coef_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
|
endif
|
||||||
enddo
|
enddo
|
||||||
N_det = k
|
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
|
endif
|
||||||
deallocate (duplicate,bit_tmp)
|
deallocate (duplicate,bit_tmp)
|
||||||
end
|
end
|
||||||
|
@ -35,7 +35,8 @@ subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint)
|
|||||||
bmax += popcnt( o(k,1) )
|
bmax += popcnt( o(k,1) )
|
||||||
amax -= popcnt( o(k,2) )
|
amax -= popcnt( o(k,2) )
|
||||||
enddo
|
enddo
|
||||||
sze = 2*int( min(binom_func(bmax, amax), 1.d8) )
|
sze = int( min(binom_func(bmax, amax), 1.d8) )
|
||||||
|
sze = sze*sze
|
||||||
|
|
||||||
end
|
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(bit_kind),intent(out) :: d(Nint,2,sze)
|
||||||
|
|
||||||
integer :: i, k, nt, na, nd, amax
|
integer :: i, k, nt, na, nd, amax
|
||||||
integer :: list_todo(n_alpha)
|
integer :: list_todo(2*n_alpha)
|
||||||
integer :: list_a(n_alpha)
|
integer :: list_a(2*n_alpha)
|
||||||
|
|
||||||
amax = n_alpha
|
amax = n_alpha
|
||||||
do k=1,Nint
|
do k=1,Nint
|
||||||
@ -68,13 +69,24 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint)
|
|||||||
|
|
||||||
sze = nd
|
sze = nd
|
||||||
|
|
||||||
|
integer :: ne(2), l
|
||||||
|
l=0
|
||||||
do i=1,nd
|
do i=1,nd
|
||||||
|
ne(1) = 0
|
||||||
|
ne(2) = 0
|
||||||
|
l=l+1
|
||||||
! Doubly occupied orbitals
|
! Doubly occupied orbitals
|
||||||
do k=1,Nint
|
do k=1,Nint
|
||||||
d(k,1,i) = ior(d(k,1,i),o(k,2))
|
d(k,1,l) = ior(d(k,1,i),o(k,2))
|
||||||
d(k,2,i) = ior(d(k,2,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
|
enddo
|
||||||
|
if ( (ne(1) /= elec_alpha_num).or.(ne(2) /= elec_beta_num) ) then
|
||||||
|
l = l-1
|
||||||
|
endif
|
||||||
enddo
|
enddo
|
||||||
|
sze = l
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
@ -123,8 +135,8 @@ end
|
|||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! array of the occ_pattern present in the wf
|
! 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(:,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 occupation
|
! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupations
|
||||||
END_DOC
|
END_DOC
|
||||||
integer :: i,j,k
|
integer :: i,j,k
|
||||||
|
|
||||||
@ -144,7 +156,7 @@ end
|
|||||||
logical,allocatable :: duplicate(:)
|
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
|
do i=1,N_det
|
||||||
iorder(i) = i
|
iorder(i) = i
|
||||||
@ -161,12 +173,7 @@ end
|
|||||||
duplicate(i) = .False.
|
duplicate(i) = .False.
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
i=1
|
! Find duplicates
|
||||||
integer (bit_kind) :: occ_pattern_tmp
|
|
||||||
do i=1,N_det
|
|
||||||
duplicate(i) = .False.
|
|
||||||
enddo
|
|
||||||
|
|
||||||
do i=1,N_det-1
|
do i=1,N_det-1
|
||||||
if (duplicate(i)) then
|
if (duplicate(i)) then
|
||||||
cycle
|
cycle
|
||||||
@ -175,6 +182,9 @@ end
|
|||||||
do while (bit_tmp(j)==bit_tmp(i))
|
do while (bit_tmp(j)==bit_tmp(i))
|
||||||
if (duplicate(j)) then
|
if (duplicate(j)) then
|
||||||
j+=1
|
j+=1
|
||||||
|
if (j>N_det) then
|
||||||
|
exit
|
||||||
|
endif
|
||||||
cycle
|
cycle
|
||||||
endif
|
endif
|
||||||
duplicate(j) = .True.
|
duplicate(j) = .True.
|
||||||
@ -192,6 +202,7 @@ end
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
! Copy filtered result
|
||||||
N_occ_pattern=0
|
N_occ_pattern=0
|
||||||
do i=1,N_det
|
do i=1,N_det
|
||||||
if (duplicate(i)) then
|
if (duplicate(i)) then
|
||||||
@ -204,6 +215,28 @@ end
|
|||||||
enddo
|
enddo
|
||||||
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)
|
deallocate(iorder,duplicate,bit_tmp,tmp_array)
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
@ -213,7 +246,7 @@ subroutine make_s2_eigenfunction
|
|||||||
integer :: i,j,k
|
integer :: i,j,k
|
||||||
integer :: smax, s
|
integer :: smax, s
|
||||||
integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:)
|
integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:)
|
||||||
integer :: N_det_new, iproc
|
integer :: N_det_new
|
||||||
integer, parameter :: bufsze = 1000
|
integer, parameter :: bufsze = 1000
|
||||||
logical, external :: is_in_wavefunction
|
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,1,N_det_new) = d(k,1,j)
|
||||||
det_buffer(k,2,N_det_new) = d(k,2,j)
|
det_buffer(k,2,N_det_new) = d(k,2,j)
|
||||||
enddo
|
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
|
if (N_det_new == bufsze) then
|
||||||
call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0)
|
call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0)
|
||||||
N_det_new = 0
|
N_det_new = 0
|
||||||
@ -248,13 +295,15 @@ subroutine make_s2_eigenfunction
|
|||||||
if (N_det_new > 0) then
|
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(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 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
|
endif
|
||||||
|
|
||||||
deallocate(d,det_buffer)
|
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
|
end
|
||||||
|
|
||||||
|
@ -1,36 +1,36 @@
|
|||||||
subroutine get_s2(key_i,key_j,Nint,s2)
|
subroutine get_s2(key_i,key_j,Nint,s2)
|
||||||
implicit none
|
implicit none
|
||||||
use bitmasks
|
use bitmasks
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Returns <S^2>
|
! Returns <S^2>
|
||||||
END_DOC
|
END_DOC
|
||||||
integer, intent(in) :: Nint
|
integer, intent(in) :: Nint
|
||||||
integer(bit_kind), intent(in) :: key_i(Nint,2)
|
integer(bit_kind), intent(in) :: key_i(Nint,2)
|
||||||
integer(bit_kind), intent(in) :: key_j(Nint,2)
|
integer(bit_kind), intent(in) :: key_j(Nint,2)
|
||||||
double precision, intent(out) :: s2
|
double precision, intent(out) :: s2
|
||||||
integer :: exc(0:2,2,2)
|
integer :: exc(0:2,2,2)
|
||||||
integer :: degree
|
integer :: degree
|
||||||
double precision :: phase_spsm
|
double precision :: phase_spsm
|
||||||
integer :: nup, i
|
integer :: nup, i
|
||||||
|
|
||||||
s2 = 0.d0
|
s2 = 0.d0
|
||||||
!$FORCEINLINE
|
!$FORCEINLINE
|
||||||
call get_excitation_degree(key_i,key_j,degree,Nint)
|
call get_excitation_degree(key_i,key_j,degree,Nint)
|
||||||
select case (degree)
|
select case (degree)
|
||||||
case(2)
|
case(2)
|
||||||
call get_double_excitation(key_j,key_i,exc,phase_spsm,Nint)
|
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(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
|
if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then
|
||||||
s2 = -phase_spsm
|
s2 = -phase_spsm
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
case(0)
|
case(0)
|
||||||
nup = 0
|
nup = 0
|
||||||
do i=1,Nint
|
do i=1,Nint
|
||||||
nup += popcnt(iand(xor(key_i(i,1),key_i(i,2)),key_i(i,1)))
|
nup += popcnt(iand(xor(key_i(i,1),key_i(i,2)),key_i(i,1)))
|
||||||
enddo
|
enddo
|
||||||
s2 = dble(nup)
|
s2 = dble(nup)
|
||||||
end select
|
end select
|
||||||
end
|
end
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, S_z ]
|
BEGIN_PROVIDER [ double precision, S_z ]
|
||||||
|
@ -513,7 +513,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
|
|||||||
integer :: occ(Nint*bit_kind_size,2)
|
integer :: occ(Nint*bit_kind_size,2)
|
||||||
double precision :: diag_H_mat_elem, phase,phase_2
|
double precision :: diag_H_mat_elem, phase,phase_2
|
||||||
integer :: n_occ_ab(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 > 0)
|
||||||
ASSERT (Nint == N_int)
|
ASSERT (Nint == N_int)
|
||||||
|
@ -350,8 +350,7 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ]
|
|||||||
integral = ao_bielec_integral(1,1,1,1)
|
integral = ao_bielec_integral(1,1,1,1)
|
||||||
|
|
||||||
real :: map_mb
|
real :: map_mb
|
||||||
print*, 'read_ao_integrals',read_ao_integrals
|
PROVIDE read_ao_integrals disk_access_ao_integrals
|
||||||
print*, 'disk_access_ao_integrals',disk_access_ao_integrals
|
|
||||||
if (read_ao_integrals) then
|
if (read_ao_integrals) then
|
||||||
print*,'Reading the AO integrals'
|
print*,'Reading the AO integrals'
|
||||||
call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)
|
call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)
|
||||||
|
@ -677,7 +677,6 @@ integer function load_$ao_integrals(filename)
|
|||||||
real(integral_kind), pointer :: val(:)
|
real(integral_kind), pointer :: val(:)
|
||||||
integer :: iknd, kknd
|
integer :: iknd, kknd
|
||||||
integer*8 :: n, j
|
integer*8 :: n, j
|
||||||
double precision :: get_$ao_bielec_integral
|
|
||||||
load_$ao_integrals = 1
|
load_$ao_integrals = 1
|
||||||
open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN')
|
open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN')
|
||||||
read(66,err=98,end=98) iknd, kknd
|
read(66,err=98,end=98) iknd, kknd
|
||||||
@ -712,7 +711,7 @@ integer function load_$ao_integrals(filename)
|
|||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
SUBST [ ao_integrals_map, ao_integrals, ao_num , get_ao_bielec_integral ]
|
SUBST [ ao_integrals_map, ao_integrals, ao_num ]
|
||||||
ao_integrals_map ; ao_integrals ; ao_num ; get_ao_bielec_integral ;;
|
ao_integrals_map ; ao_integrals ; ao_num ;;
|
||||||
mo_integrals_map ; mo_integrals ; mo_tot_num ; get_mo_bielec_integral ;;
|
mo_integrals_map ; mo_integrals ; mo_tot_num ;;
|
||||||
END_TEMPLATE
|
END_TEMPLATE
|
||||||
|
1
src/MRPT_Utils/NEEDED_CHILDREN_MODULES
Normal file
1
src/MRPT_Utils/NEEDED_CHILDREN_MODULES
Normal file
@ -0,0 +1 @@
|
|||||||
|
Determinants Davidson
|
@ -148,17 +148,42 @@ subroutine ortho_qr(A,LDA,m,n)
|
|||||||
|
|
||||||
allocate (jpvt(n), tau(n), work(1))
|
allocate (jpvt(n), tau(n), work(1))
|
||||||
LWORK=-1
|
LWORK=-1
|
||||||
! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO)
|
|
||||||
call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO )
|
call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO )
|
||||||
LWORK=WORK(1)
|
LWORK=2*WORK(1)
|
||||||
deallocate(WORK)
|
deallocate(WORK)
|
||||||
allocate(WORK(LWORK))
|
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 dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO )
|
||||||
call dorgqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO)
|
call dorgqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO)
|
||||||
deallocate(WORK,jpvt,tau)
|
deallocate(WORK,jpvt,tau)
|
||||||
end
|
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)
|
subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m)
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
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'
|
print *, irp_here, ': DSYEV: the ',-info,'-th argument had an illegal value'
|
||||||
stop 2
|
stop 2
|
||||||
else if( info > 0 ) then
|
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
|
stop 1
|
||||||
end if
|
end if
|
||||||
|
|
||||||
|
@ -622,7 +622,7 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in)
|
|||||||
|
|
||||||
istep = ishft(iend-ibegin,-1)
|
istep = ishft(iend-ibegin,-1)
|
||||||
idx = ibegin + istep
|
idx = ibegin + istep
|
||||||
do while (istep > 16)
|
do while (istep > 64)
|
||||||
idx = ibegin + istep
|
idx = ibegin + istep
|
||||||
! TODO : Cache misses
|
! TODO : Cache misses
|
||||||
if (cache_key < X(idx)) then
|
if (cache_key < X(idx)) then
|
||||||
@ -660,8 +660,8 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in)
|
|||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
idx = ibegin
|
idx = ibegin
|
||||||
if (min(iend_in,sze) > ibegin+16) then
|
if (min(iend_in,sze) > ibegin+64) then
|
||||||
iend = ibegin+16
|
iend = ibegin+64
|
||||||
do while (cache_key > X(idx))
|
do while (cache_key > X(idx))
|
||||||
idx = idx+1
|
idx = idx+1
|
||||||
end do
|
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)
|
istep = ishft(iend-ibegin,-1)
|
||||||
idx = ibegin + istep
|
idx = ibegin + istep
|
||||||
do while (istep > 16)
|
do while (istep > 64)
|
||||||
idx = ibegin + istep
|
idx = ibegin + istep
|
||||||
if (cache_key < X(idx)) then
|
if (cache_key < X(idx)) then
|
||||||
iend = idx
|
iend = idx
|
||||||
@ -771,8 +771,8 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in
|
|||||||
enddo
|
enddo
|
||||||
idx = ibegin
|
idx = ibegin
|
||||||
value = Y(idx)
|
value = Y(idx)
|
||||||
if (min(iend_in,sze) > ibegin+16) then
|
if (min(iend_in,sze) > ibegin+64) then
|
||||||
iend = ibegin+16
|
iend = ibegin+64
|
||||||
do while (cache_key > X(idx))
|
do while (cache_key > X(idx))
|
||||||
idx = idx+1
|
idx = idx+1
|
||||||
value = Y(idx)
|
value = Y(idx)
|
||||||
|
@ -3,15 +3,24 @@
|
|||||||
source $QP_ROOT/tests/bats/common.bats.sh
|
source $QP_ROOT/tests/bats/common.bats.sh
|
||||||
|
|
||||||
@test "CAS_SD H2O cc-pVDZ" {
|
@test "CAS_SD H2O cc-pVDZ" {
|
||||||
test_exe cas_sd_selected || skip
|
test_exe cassd_zmq || skip
|
||||||
INPUT=h2o.ezfio
|
INPUT=h2o.ezfio
|
||||||
|
rm -rf work/h2o.ezfio/determinants/
|
||||||
qp_edit -c $INPUT
|
qp_edit -c $INPUT
|
||||||
ezfio set_file $INPUT
|
ezfio set_file $INPUT
|
||||||
ezfio set perturbation do_pt2_end False
|
ezfio set perturbation do_pt2_end True
|
||||||
ezfio set determinants n_det_max 1000
|
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_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]"
|
||||||
qp_run cas_sd_selected $INPUT
|
qp_run cassd_zmq $INPUT
|
||||||
energy="$(ezfio get cas_sd energy)"
|
energy="$(ezfio get cas_sd_zmq energy_pt2)"
|
||||||
eq $energy -76.2221842108163 1.E-5
|
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
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -20,7 +20,7 @@ function run_FCI() {
|
|||||||
|
|
||||||
function run_FCI_ZMQ() {
|
function run_FCI_ZMQ() {
|
||||||
thresh=5.e-5
|
thresh=5.e-5
|
||||||
test_exe full_ci || skip
|
test_exe fci_zmq || skip
|
||||||
qp_edit -c $1
|
qp_edit -c $1
|
||||||
ezfio set_file $1
|
ezfio set_file $1
|
||||||
ezfio set perturbation do_pt2_end True
|
ezfio set perturbation do_pt2_end True
|
||||||
@ -28,9 +28,9 @@ function run_FCI_ZMQ() {
|
|||||||
ezfio set davidson threshold_davidson 1.e-10
|
ezfio set davidson threshold_davidson 1.e-10
|
||||||
|
|
||||||
qp_run fci_zmq $1
|
qp_run fci_zmq $1
|
||||||
energy="$(ezfio get full_ci energy)"
|
energy="$(ezfio get full_ci_zmq energy)"
|
||||||
eq $energy $3 $thresh
|
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
|
eq $energy_pt2 $4 $thresh
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -15,8 +15,8 @@ source $QP_ROOT/tests/bats/common.bats.sh
|
|||||||
ezfio set mrcepa0 lambda_type 1
|
ezfio set mrcepa0 lambda_type 1
|
||||||
ezfio set mrcepa0 n_it_max_dressed_ci 3
|
ezfio set mrcepa0 n_it_max_dressed_ci 3
|
||||||
qp_run $EXE $INPUT
|
qp_run $EXE $INPUT
|
||||||
energy="$(ezfio get mrcepa0 energy)"
|
energy="$(ezfio get mrcepa0 energy_pt2)"
|
||||||
eq $energy -76.22903276183061 1.e-4
|
eq $energy -76.238562120457431 1.e-4
|
||||||
}
|
}
|
||||||
|
|
||||||
@test "MRCC H2O cc-pVDZ" {
|
@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 lambda_type 0
|
||||||
ezfio set mrcepa0 n_it_max_dressed_ci 3
|
ezfio set mrcepa0 n_it_max_dressed_ci 3
|
||||||
qp_run $EXE $INPUT
|
qp_run $EXE $INPUT
|
||||||
energy="$(ezfio get mrcepa0 energy)"
|
energy="$(ezfio get mrcepa0 energy_pt2)"
|
||||||
eq $energy -76.22899302846875 1.e-4
|
eq $energy -76.238527498388962 1.e-4
|
||||||
}
|
}
|
||||||
|
|
||||||
@test "MRSC2 H2O cc-pVDZ" {
|
@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 lambda_type 0
|
||||||
ezfio set mrcepa0 n_it_max_dressed_ci 3
|
ezfio set mrcepa0 n_it_max_dressed_ci 3
|
||||||
qp_run $EXE $INPUT
|
qp_run $EXE $INPUT
|
||||||
energy="$(ezfio get mrcepa0 energy)"
|
energy="$(ezfio get mrcepa0 energy_pt2)"
|
||||||
eq $energy -76.22647345292708 1.e-4
|
eq $energy -76.235833732594187 1.e-4
|
||||||
}
|
}
|
||||||
|
|
||||||
@test "MRCEPA0 H2O cc-pVDZ" {
|
@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 lambda_type 0
|
||||||
ezfio set mrcepa0 n_it_max_dressed_ci 3
|
ezfio set mrcepa0 n_it_max_dressed_ci 3
|
||||||
qp_run $EXE $INPUT
|
qp_run $EXE $INPUT
|
||||||
energy="$(ezfio get mrcepa0 energy)"
|
energy="$(ezfio get mrcepa0 energy_pt2)"
|
||||||
eq $energy -76.23199784430074 1.e-4
|
eq $energy -76.2418799284763 1.e-4
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -23,7 +23,7 @@ function run_HF() {
|
|||||||
|
|
||||||
function run_FCI_ZMQ() {
|
function run_FCI_ZMQ() {
|
||||||
thresh=5.e-5
|
thresh=5.e-5
|
||||||
test_exe full_ci || skip
|
test_exe fci_zmq|| skip
|
||||||
qp_edit -c $1
|
qp_edit -c $1
|
||||||
ezfio set_file $1
|
ezfio set_file $1
|
||||||
ezfio set perturbation do_pt2_end True
|
ezfio set perturbation do_pt2_end True
|
||||||
@ -31,9 +31,9 @@ function run_FCI_ZMQ() {
|
|||||||
ezfio set davidson threshold_davidson 1.e-10
|
ezfio set davidson threshold_davidson 1.e-10
|
||||||
|
|
||||||
qp_run fci_zmq $1
|
qp_run fci_zmq $1
|
||||||
energy="$(ezfio get full_ci energy)"
|
energy="$(ezfio get full_ci_zmq energy)"
|
||||||
eq $energy $3 $thresh
|
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
|
eq $energy_pt2 $4 $thresh
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -14,7 +14,7 @@ mrcepa0.bats
|
|||||||
|
|
||||||
|
|
||||||
export QP_PREFIX="timeout -s 9 300"
|
export QP_PREFIX="timeout -s 9 300"
|
||||||
export QP_TASK_DEBUG=1
|
#export QP_TASK_DEBUG=1
|
||||||
|
|
||||||
rm -rf work output
|
rm -rf work output
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user