diff --git a/.travis.yml b/.travis.yml index 5e032609..57991ba3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -25,8 +25,8 @@ python: - "2.6" script: - - ./configure --production ./config/gfortran.cfg - - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD mrcepa0 All_singles + - ./configure --production ./config/travis.cfg + - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD_ZMQ mrcepa0 All_singles - source ./quantum_package.rc ; ninja - source ./quantum_package.rc ; cd ocaml ; make ; cd - - source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg index 03663eea..4b06c5e9 100644 --- a/config/gfortran_debug.cfg +++ b/config/gfortran_debug.cfg @@ -13,7 +13,7 @@ FC : gfortran -g -ffree-line-length-none -I . -static-libgcc LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 -IRPF90_FLAGS : --ninja --assert --align=32 +IRPF90_FLAGS : --ninja --align=32 # Global options ################ diff --git a/config/travis.cfg b/config/travis.cfg new file mode 100644 index 00000000..024e330b --- /dev/null +++ b/config/travis.cfg @@ -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 + diff --git a/plugins/CAS_SD/cas_sd_selected.irp.f b/plugins/CAS_SD/cas_sd_selected.irp.f index d12e8430..acca7dd8 100644 --- a/plugins/CAS_SD/cas_sd_selected.irp.f +++ b/plugins/CAS_SD/cas_sd_selected.irp.f @@ -93,8 +93,8 @@ program full_ci call diagonalize_CI if(do_pt2_end)then print*,'Last iteration only to compute the PT2' - threshold_selectors = 1.d0 - threshold_generators = 0.999d0 + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) call H_apply_CAS_SD_PT2(pt2, norm_pert, H_pert_diag, N_st) print *, 'Final step' diff --git a/plugins/CAS_SD_ZMQ/EZFIO.cfg b/plugins/CAS_SD_ZMQ/EZFIO.cfg new file mode 100644 index 00000000..7425c8ba --- /dev/null +++ b/plugins/CAS_SD_ZMQ/EZFIO.cfg @@ -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 + diff --git a/plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES b/plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..ae599426 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES @@ -0,0 +1,2 @@ +Generators_CAS Perturbation Selectors_CASSD ZMQ + diff --git a/plugins/CAS_SD_ZMQ/README.rst b/plugins/CAS_SD_ZMQ/README.rst new file mode 100644 index 00000000..45ba97e4 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/README.rst @@ -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. diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f new file mode 100644 index 00000000..6844ed90 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -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 + diff --git a/plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f b/plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f new file mode 100644 index 00000000..fec480f0 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f @@ -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) = * 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 diff --git a/plugins/CAS_SD_ZMQ/energy.irp.f b/plugins/CAS_SD_ZMQ/energy.irp.f new file mode 100644 index 00000000..db1e7d1a --- /dev/null +++ b/plugins/CAS_SD_ZMQ/energy.irp.f @@ -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 + diff --git a/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f b/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f new file mode 100644 index 00000000..8adab518 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f @@ -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 + diff --git a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f new file mode 100644 index 00000000..dfaee629 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f @@ -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 + + + diff --git a/plugins/Full_CI_ZMQ/selection_double.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f similarity index 55% rename from plugins/Full_CI_ZMQ/selection_double.irp.f rename to plugins/CAS_SD_ZMQ/selection.irp.f index 977622fd..f90ee488 100644 --- a/plugins/Full_CI_ZMQ/selection_double.irp.f +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -1,726 +1,1207 @@ - -subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator - 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 :: mat(N_states, mo_tot_num, mo_tot_num) - integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) - logical :: fullMatch, ok - - integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) - integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) - integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) - - allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) - allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) - enddo - - 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) - - - preinteresting(0) = 0 - prefullinteresting(0) = 0 - - do i=1,N_int - negMask(i,1) = not(psi_det_generators(i,1,i_generator)) - negMask(i,2) = not(psi_det_generators(i,2,i_generator)) - end do - - do i=1,N_det - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - if(i <= N_det_selectors) then - preinteresting(0) += 1 - preinteresting(preinteresting(0)) = i - else if(nt <= 2) then - prefullinteresting(0) += 1 - prefullinteresting(prefullinteresting(0)) = i - end if - end if - end do - - - do s1=1,2 - do i1=N_holes(s1),1,-1 ! Generate low excitations first - h1 = hole_list(i1,s1) - call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) - - do i=1,N_int - negMask(i,1) = not(pmask(i,1)) - negMask(i,2) = not(pmask(i,2)) - end do - - interesting(0) = 0 - fullinteresting(0) = 0 - - do ii=1,preinteresting(0) - i = preinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - interesting(0) += 1 - interesting(interesting(0)) = i - minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i) - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) - end if - end if - end do - - do ii=1,prefullinteresting(0) - i = prefullinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) - end if - end do - - do s2=s1,2 - sp = s1 - if(s1 /= s2) sp = 3 - - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=N_holes(s2),ib,-1 ! Generate low excitations first - - h2 = hole_list(i2,s2) - call apply_hole(pmask, s2,h2, mask, ok, N_int) - - logical :: banned(mo_tot_num, mo_tot_num,2) - logical :: bannedOrb(mo_tot_num, 2) - - banned = .false. - - call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) - - if(fullMatch) cycle - - bannedOrb(1:mo_tot_num, 1:2) = .true. - do s3=1,2 - do i=1,N_particles(s3) - bannedOrb(particle_list(i,s3), s3) = .false. - enddo - enddo - - mat = 0d0 - call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) - call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - enddo - enddo - enddo - enddo -end subroutine - - -subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1, h2 - double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, 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, j, 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 - - logical, external :: detEq - - - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1, s1)) cycle - ib = 1 - if(sp /= 3) ib = p1+1 - do p2=ib,mo_tot_num - if(bannedOrb(p2, s2)) cycle - if(banned(p1,p2)) cycle - if(mat(1, p1, p2) == 0d0) cycle - call apply_particles(mask, s1, p1, s2, p2, 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 - delta_E = E0(istate) - Hii - val = mat(istate, p1, p2) - 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) then - call add_to_selection_buffer(buf, det, max_e_pert) - end if - end do - end do -end subroutine - - -subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N_sel) - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) - integer, intent(in) :: sp, i_gen, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - - integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) -! logical :: bandon -! -! bandon = .false. - mat = 0d0 - - 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 ! interesting(0) - !i = interesting(ii) - - 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 > 4) 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(interesting(i) < i_gen) then - if(nt == 4) call past_d2(banned, p, sp) - if(nt == 3) call past_d1(bannedOrb, p) - else - if(interesting(i) == i_gen) then -! bandon = .true. - if(sp == 3) then - banned(:,:,2) = transpose(banned(:,:,1)) - else - do k=1,mo_tot_num - do l=k+1,mo_tot_num - banned(l,k,1) = banned(k,l,1) - end do - end do - end if - end if - if(nt == 4) then - call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else if(nt == 3) then - call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else - call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - end if - end if - end do -end subroutine - - -subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - double precision, external :: get_phase_bi, integral8 - - integer :: i, j, tip, ma, mi, puti, putj - integer :: h1, h2, p1, p2, i1, i2 - double precision :: hij, phase - - integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) - integer, parameter :: turn2(2) = (/2, 1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - bant = 1 - - tip = p(0,1) * p(0,2) - - ma = sp - if(p(0,1) > p(0,2)) ma = 1 - if(p(0,1) < p(0,2)) ma = 2 - mi = mod(ma, 2) + 1 - - if(sp == 3) then - if(ma == 2) bant = 2 - - if(tip == 3) then - puti = p(1, mi) - do i = 1, 3 - putj = p(i, ma) - if(banned(putj,puti,bant)) cycle - i1 = turn3(1,i) - i2 = turn3(2,i) - p1 = p(i1, ma) - p2 = p(i2, ma) - h1 = h(1, ma) - h2 = h(2, ma) - - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - if(ma == 1) then - mat(:, putj, puti) += coefs * hij - else - mat(:, puti, putj) += coefs * hij - end if - end do - else - do i = 1,2 - do j = 1,2 - puti = p(i, 1) - putj = p(j, 2) - - if(banned(puti,putj,bant)) cycle - p1 = p(turn2(i), 1) - p2 = p(turn2(j), 2) - h1 = h(1,1) - h2 = h(1,2) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - end if - - else - if(tip == 0) then - h1 = h(1, ma) - h2 = h(2, ma) - do i=1,3 - puti = p(i, ma) - do j=i+1,4 - putj = p(j, ma) - if(banned(puti,putj,1)) cycle - - i1 = turn2d(1, i, j) - i2 = turn2d(2, i, j) - p1 = p(i1, ma) - p2 = p(i2, ma) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - else if(tip == 3) then - h1 = h(1, mi) - h2 = h(1, ma) - p1 = p(1, mi) - do i=1,3 - puti = p(turn3(1,i), ma) - putj = p(turn3(2,i), ma) - if(banned(puti,putj,1)) cycle - p2 = p(i, ma) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) - mat(:, min(puti, putj), max(puti, putj)) += coefs * hij - end do - else ! tip == 4 - puti = p(1, sp) - putj = p(2, sp) - if(.not. banned(puti,putj,1)) then - p1 = p(1, mi) - p2 = p(2, mi) - h1 = h(1, mi) - h2 = h(2, mi) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end if - end if - end if -end subroutine - - -subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) - double precision, external :: get_phase_bi, integral8 - - logical :: lbanned(mo_tot_num, 2), ok - integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib - - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer, parameter :: turn2(2) = (/2,1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - - - lbanned = bannedOrb - - do i=1, p(0,1) - lbanned(p(i,1), 1) = .true. - end do - do i=1, p(0,2) - lbanned(p(i,2), 2) = .true. - end do - - ma = 1 - if(p(0,2) >= 2) ma = 2 - mi = turn2(ma) - - bant = 1 - - if(sp == 3) then - !move MA - if(ma == 2) bant = 2 - puti = p(1,mi) - hfix = h(1,ma) - p1 = p(1,ma) - p2 = p(2,ma) - if(.not. bannedOrb(puti, mi)) then - tmp_row = 0d0 - do putj=1, hfix-1 - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - do putj=hfix+1, mo_tot_num - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - - if(ma == 1) then - mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) - else - mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) - end if - end if - - !MOVE MI - pfix = p(1,mi) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,mi)) cycle - !p1 fixed - putj = p1 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) - tmp_row(:,puti) += hij * coefs - end if - - putj = p2 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) - tmp_row2(:,puti) += hij * coefs - end if - end do - - if(mi == 1) then - mat(:,:,p1) += tmp_row(:,:) - mat(:,:,p2) += tmp_row2(:,:) - else - mat(:,p1,:) += tmp_row(:,:) - mat(:,p2,:) += tmp_row2(:,:) - end if - else - if(p(0,ma) == 3) then - do i=1,3 - hfix = h(1,ma) - puti = p(i, ma) - p1 = p(turn3(1,i), ma) - p2 = p(turn3(2,i), ma) - tmp_row = 0d0 - do putj=1,hfix-1 - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(:,putj) += hij * coefs - end do - do putj=hfix+1,mo_tot_num - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(:,putj) += hij * coefs - end do - - mat(:, :puti-1, puti) += tmp_row(:,:puti-1) - mat(:, puti, puti:) += tmp_row(:,puti:) - end do - else - hfix = h(1,mi) - pfix = p(1,mi) - p1 = p(1,ma) - p2 = p(2,ma) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,ma)) cycle - putj = p2 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) - tmp_row(:,puti) += hij * coefs - end if - - putj = p1 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) - tmp_row2(:,puti) += hij * coefs - end if - end do - mat(:,:p2-1,p2) += tmp_row(:,:p2-1) - mat(:,p2,p2:) += tmp_row(:,p2:) - mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) - mat(:,p1,p1:) += tmp_row2(:,p1:) - end if - end if - - !! MONO - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - do i1=1,p(0,s1) - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=ib,p(0,s2) - p1 = p(i1,s1) - p2 = p(i2,s2) - if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - mat(:, p1, p2) += coefs * hij - end do - end do -end subroutine - - - - -subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, 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, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer :: i, j, s, h1, h2, p1, p2, puti, putj - double precision :: hij, phase - double precision, external :: get_phase_bi, integral8 - logical :: ok - - integer :: bant - bant = 1 - - - if(sp == 3) then ! AB - h1 = p(1,1) - h2 = p(1,2) - do p1=1, mo_tot_num - if(bannedOrb(p1, 1)) cycle - do p2=1, mo_tot_num - if(bannedOrb(p2,2)) cycle - if(banned(p1, p2, bant)) cycle ! rentable? - if(p1 == h1 .or. p2 == h2) then - call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - end if - mat(:, p1, p2) += coefs(:) * hij - end do - end do - else ! AA BB - p1 = p(1,sp) - p2 = p(2,sp) - do puti=1, mo_tot_num - if(bannedOrb(puti, sp)) cycle - do putj=puti+1, mo_tot_num - if(bannedOrb(putj, sp)) cycle - if(banned(puti, putj, bant)) cycle ! rentable? - if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then - call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) - end if - mat(:, puti, putj) += coefs(:) * hij - end do - end do - end if -end subroutine - - -subroutine past_d1(bannedOrb, p) - use bitmasks - implicit none - - logical, intent(inout) :: bannedOrb(mo_tot_num, 2) - integer, intent(in) :: p(0:4, 2) - integer :: i,s - - do s = 1, 2 - do i = 1, p(0, s) - bannedOrb(p(i, s), s) = .true. - end do - end do -end subroutine - - -subroutine past_d2(banned, p, sp) - use bitmasks - implicit none - - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - integer, intent(in) :: p(0:4, 2), sp - integer :: i,j - - if(sp == 3) then - do i=1,p(0,1) - do j=1,p(0,2) - banned(p(i,1), p(j,2)) = .true. - end do - end do - else - do i=1,p(0, sp) - do j=1,i-1 - banned(p(j,sp), p(i,sp)) = .true. - banned(p(i,sp), p(j,sp)) = .true. - end do - end do - end if -end subroutine - - - -subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N) - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3) - 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 - do j=1, N_int - if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl - if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl - end do - - if(interesting(i) < i_gen) then - fullMatch = .true. - return - end if - - 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)) - end do - - call bitstring_to_list(myMask(1,1), list(1), na, N_int) - call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) - banned(list(1), list(2)) = .true. - end do genl -end subroutine - +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) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator + 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 :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + logical :: fullMatch, ok + + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) + allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + 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) + + + preinteresting(0) = 0 + prefullinteresting(0) = 0 + + do i=1,N_int + negMask(i,1) = not(psi_det_generators(i,1,i_generator)) + negMask(i,2) = not(psi_det_generators(i,2,i_generator)) + end do + + do i=1,N_det + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + if(i <= N_det_selectors) then + preinteresting(0) += 1 + preinteresting(preinteresting(0)) = i + else if(nt <= 2) then + prefullinteresting(0) += 1 + prefullinteresting(prefullinteresting(0)) = i + end if + end if + end do + + + do s1=1,2 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) + + do i=1,N_int + negMask(i,1) = not(pmask(i,1)) + negMask(i,2) = not(pmask(i,2)) + end do + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii=1,preinteresting(0) + i = preinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(:,:,interesting(0)) = psi_selectors(:,:,i) + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) + end if + end if + end do + + do ii=1,prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) + end if + end do + + do s2=s1,2 + sp = s1 + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=N_holes(s2),ib,-1 ! Generate low excitations first + + h2 = hole_list(i2,s2) + call apply_hole(pmask, s2,h2, mask, ok, N_int) + + logical :: banned(mo_tot_num, mo_tot_num,2) + logical :: bannedOrb(mo_tot_num, 2) + + banned = .false. + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + + if(fullMatch) cycle + + bannedOrb(1:mo_tot_num, 1:2) = .true. + do s3=1,2 + do i=1,N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + enddo + enddo + enddo + enddo +end subroutine + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, 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, j, 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 + + logical, external :: detEq + + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + 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) + max_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + val = mat(istate, p1, p2) + mat(istate, p1, p2) + 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) = pt2(istate) + e_pert + max_e_pert = min(e_pert,max_e_pert) + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + end if + end do + end do +end subroutine + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N_sel) + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, i_gen, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + + integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) +! logical :: bandon +! +! bandon = .false. + mat = 0d0 + + 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 ! interesting(0) + !i = interesting(ii) + + 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 > 4) 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(interesting(i) < i_gen) then + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + else + if(interesting(i) == i_gen) then +! bandon = .true. + if(sp == 3) then + banned(:,:,2) = transpose(banned(:,:,1)) + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + end if + end do +end subroutine + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi, integral8 + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, phase + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + bant = 1 + + tip = p(0,1) * p(0,2) + + ma = sp + if(p(0,1) > p(0,2)) ma = 1 + if(p(0,1) < p(0,2)) ma = 2 + mi = mod(ma, 2) + 1 + + if(sp == 3) then + if(ma == 2) bant = 2 + + if(tip == 3) then + puti = p(1, mi) + do i = 1, 3 + putj = p(i, ma) + if(banned(putj,puti,bant)) cycle + i1 = turn3(1,i) + i2 = turn3(2,i) + p1 = p(i1, ma) + p2 = p(i2, ma) + h1 = h(1, ma) + h2 = h(2, ma) + + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + if(ma == 1) then + mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij + end if + end do + else + do i = 1,2 + do j = 1,2 + puti = p(i, 1) + putj = p(j, 2) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + p2 = p(turn2(j), 2) + h1 = h(1,1) + h2 = h(1,2) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else + if(tip == 0) then + h1 = h(1, ma) + h2 = h(2, ma) + do i=1,3 + puti = p(i, ma) + do j=i+1,4 + putj = p(j, ma) + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + do i=1,3 + puti = p(turn3(1,i), ma) + putj = p(turn3(2,i), ma) + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if + end if +end subroutine + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) + double precision, external :: get_phase_bi, integral8 + + logical :: lbanned(mo_tot_num, 2), ok + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + lbanned = bannedOrb + + do i=1, p(0,1) + lbanned(p(i,1), 1) = .true. + end do + do i=1, p(0,2) + lbanned(p(i,2), 2) = .true. + end do + + ma = 1 + if(p(0,2) >= 2) ma = 2 + mi = turn2(ma) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then + tmp_row = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) + else + mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + tmp_row2(:,puti) += hij * coefs + end if + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + tmp_row(:,puti) += hij * coefs + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + tmp_row2(:,puti) += hij * coefs + end if + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do + end do +end subroutine + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, 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, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi, integral8 + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_tot_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + end if + mat(:, p1, p2) += coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, bant)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + end if + mat(:, puti, putj) += coefs(:) * hij + end do + end do + end if +end subroutine + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end subroutine + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end subroutine + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + 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 + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl + end do + + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + 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)) + end do + + call bitstring_to_list(myMask(1,1), list(1), na, N_int) + call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl +end subroutine + diff --git a/plugins/CAS_SD_ZMQ/selection_buffer.irp.f b/plugins/CAS_SD_ZMQ/selection_buffer.irp.f new file mode 100644 index 00000000..2bcb11d3 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/selection_buffer.irp.f @@ -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 + diff --git a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f new file mode 100644 index 00000000..657ad63c --- /dev/null +++ b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f @@ -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 + diff --git a/plugins/CAS_SD_ZMQ/selection_types.f90 b/plugins/CAS_SD_ZMQ/selection_types.f90 new file mode 100644 index 00000000..9506629c --- /dev/null +++ b/plugins/CAS_SD_ZMQ/selection_types.f90 @@ -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 + diff --git a/plugins/FOBOCI/SC2_1h1p.irp.f b/plugins/FOBOCI/SC2_1h1p.irp.f index b9378575..7733831c 100644 --- a/plugins/FOBOCI/SC2_1h1p.irp.f +++ b/plugins/FOBOCI/SC2_1h1p.irp.f @@ -210,7 +210,7 @@ subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Ni integer, intent(in) :: dim_in, sze, N_st, Nint integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(inout) :: u_in(dim_in,N_st) - double precision, intent(out) :: diag_H_elements(dim_in) + double precision, intent(out) :: diag_H_elements(0:dim_in) double precision, intent(in) :: convergence integer :: i,j,k,l diff --git a/plugins/Full_CI/EZFIO.cfg b/plugins/Full_CI/EZFIO.cfg index afb25d2e..9a552cd0 100644 --- a/plugins/Full_CI/EZFIO.cfg +++ b/plugins/Full_CI/EZFIO.cfg @@ -8,15 +8,3 @@ type: double precision doc: Calculated FCI energy + PT2 interface: ezfio -[threshold_generators_pt2] -type: Threshold -doc: Thresholds on generators (fraction of the norm) for final PT2 calculation -interface: ezfio,provider,ocaml -default: 0.999 - -[threshold_selectors_pt2] -type: Threshold -doc: Thresholds on selectors (fraction of the norm) for final PT2 calculation -interface: ezfio,provider,ocaml -default: 1. - diff --git a/plugins/Full_CI_ZMQ/EZFIO.cfg b/plugins/Full_CI_ZMQ/EZFIO.cfg new file mode 100644 index 00000000..26f1a8e5 --- /dev/null +++ b/plugins/Full_CI_ZMQ/EZFIO.cfg @@ -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 + + diff --git a/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES b/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES index cb6ff46e..7ff203d4 100644 --- a/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES +++ b/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full ZMQ Full_CI +Perturbation Selectors_full Generators_full ZMQ diff --git a/plugins/Full_CI_ZMQ/energy.irp.f b/plugins/Full_CI_ZMQ/energy.irp.f new file mode 100644 index 00000000..db1e7d1a --- /dev/null +++ b/plugins/Full_CI_ZMQ/energy.irp.f @@ -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 + diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 964edf62..382e8652 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -5,11 +5,16 @@ program fci_zmq double precision, allocatable :: pt2(:) integer :: degree + integer :: n_det_before, to_select + double precision :: threshold_davidson_in allocate (pt2(N_states)) pt2 = 1.d0 diag_algorithm = "Lapack" + threshold_davidson_in = threshold_davidson + SOFT_TOUCH threshold_davidson + threshold_davidson = 1.d-4 if (N_det > N_det_max) then call diagonalize_CI @@ -33,29 +38,36 @@ program fci_zmq double precision :: E_CI_before(N_states) - integer :: n_det_before print*,'Beginning the selection ...' E_CI_before(1:N_states) = CI_energy(1:N_states) + n_det_before = 0 do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) ) n_det_before = N_det - call ZMQ_selection(max(1024-N_det, N_det), pt2) + to_select = 3*N_det + to_select = max(1024-to_select, to_select) + to_select = min(to_select, N_det_max-n_det_before) + call ZMQ_selection(to_select, pt2) PROVIDE psi_coef PROVIDE psi_det PROVIDE psi_det_sorted + if (N_det == N_det_max) then + threshold_davidson = threshold_davidson_in + SOFT_TOUCH threshold_davidson + endif call diagonalize_CI call save_wavefunction - if (N_det > N_det_max) then - psi_det = psi_det_sorted - psi_coef = psi_coef_sorted - N_det = N_det_max - soft_touch N_det psi_det psi_coef - call diagonalize_CI - call save_wavefunction - endif +! if (N_det > N_det_max) then +! psi_det = psi_det_sorted +! psi_coef = psi_coef_sorted +! N_det = N_det_max +! soft_touch N_det psi_det psi_coef +! call diagonalize_CI +! call save_wavefunction +! endif print *, 'N_det = ', N_det print *, 'N_states = ', N_states @@ -79,13 +91,13 @@ program fci_zmq enddo endif E_CI_before(1:N_states) = CI_energy(1:N_states) - call ezfio_set_full_ci_energy(CI_energy) + call ezfio_set_full_ci_zmq_energy(CI_energy) enddo if(do_pt2_end)then print*,'Last iteration only to compute the PT2' - threshold_selectors = threshold_selectors_pt2 - threshold_generators = threshold_generators_pt2 + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) TOUCH threshold_selectors threshold_generators E_CI_before(1:N_states) = CI_energy(1:N_states) call ZMQ_selection(0, pt2) @@ -99,7 +111,7 @@ program fci_zmq print *, 'E+PT2 = ', E_CI_before+pt2 print *, '-----' enddo - call ezfio_set_full_ci_energy_pt2(E_CI_before+pt2) + call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before+pt2) endif call save_wavefunction end @@ -122,38 +134,43 @@ subroutine ZMQ_selection(N_in, pt2) double precision, intent(out) :: pt2(N_states) - N = max(N_in,1) - provide nproc - provide ci_electronic_energy - call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,ci_electronic_energy,size(ci_electronic_energy)) - call zmq_set_running(zmq_to_qp_run_socket) - call create_selection_buffer(N, N*2, b) + if (.True.) then + PROVIDE pt2_e0_denominator + N = max(N_in,1) + provide nproc + call new_parallel_job(zmq_to_qp_run_socket,"selection") + call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) + call zmq_set_running(zmq_to_qp_run_socket) + call create_selection_buffer(N, N*2, b) + endif integer :: i_generator, i_generator_start, i_generator_max, step ! step = int(max(1.,10*elec_num/mo_tot_num) step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) step = max(1,step) - do i= N_det_generators, 1, -step - i_generator_start = max(i-step+1,1) - i_generator_max = i + do i= 1, N_det_generators,step + i_generator_start = i + i_generator_max = min(i+step-1,N_det_generators) write(task,*) i_generator_start, i_generator_max, 1, N call add_task_to_taskserver(zmq_to_qp_run_socket,task) end do - !$OMP PARALLEL DEFAULT(none) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) shared(ci_electronic_energy_is_built, n_det_generators_is_built, n_states_is_built, n_int_is_built, nproc_is_built) - i = omp_get_thread_num() - if (i==0) then - call selection_collector(b, pt2) - else - call selection_slave_inproc(i) - endif + !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) + i = omp_get_thread_num() + if (i==0) then + call selection_collector(b, pt2) + else + call selection_slave_inproc(i) + endif !$OMP END PARALLEL - call end_parallel_job(zmq_to_qp_run_socket, 'selection') + call end_parallel_job(zmq_to_qp_run_socket, 'selection') if (N_in > 0) then call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN call copy_H_apply_buffer_to_wf() + if (s2_eig) then + call make_s2_eigenfunction + endif endif end subroutine @@ -162,7 +179,7 @@ subroutine selection_slave_inproc(i) implicit none integer, intent(in) :: i - call run_selection_slave(1,i,ci_electronic_energy) + call run_selection_slave(1,i,pt2_e0_denominator) end subroutine selection_collector(b, pt2) diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index 36550116..dfaee629 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -4,7 +4,7 @@ subroutine run_selection_slave(thread,iproc,energy) use selection_types implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: thread, iproc integer :: rc, i diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index a0209cc5..3f351004 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -6,8 +6,20 @@ double precision function integral8(i,j,k,l) integer, intent(in) :: i,j,k,l double precision, external :: get_mo_bielec_integral - - integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + 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 @@ -104,3 +116,1087 @@ 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_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, 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) 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 + + + + +! Selection double +! ---------------- + +subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator + 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 :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + logical :: fullMatch, ok + + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) + allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + 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) + + + preinteresting(0) = 0 + prefullinteresting(0) = 0 + + do i=1,N_int + negMask(i,1) = not(psi_det_generators(i,1,i_generator)) + negMask(i,2) = not(psi_det_generators(i,2,i_generator)) + end do + + do i=1,N_det + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + if(i <= N_det_selectors) then + preinteresting(0) += 1 + preinteresting(preinteresting(0)) = i + else if(nt <= 2) then + prefullinteresting(0) += 1 + prefullinteresting(prefullinteresting(0)) = i + end if + end if + end do + + + do s1=1,2 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) + + do i=1,N_int + negMask(i,1) = not(pmask(i,1)) + negMask(i,2) = not(pmask(i,2)) + end do + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii=1,preinteresting(0) + i = preinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i) + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) + end if + end if + end do + + do ii=1,prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) + end if + end do + + do s2=s1,2 + sp = s1 + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=N_holes(s2),ib,-1 ! Generate low excitations first + + h2 = hole_list(i2,s2) + call apply_hole(pmask, s2,h2, mask, ok, N_int) + + logical :: banned(mo_tot_num, mo_tot_num,2) + logical :: bannedOrb(mo_tot_num, 2) + + banned = .false. + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + + if(fullMatch) cycle + + bannedOrb(1:mo_tot_num, 1:2) = .true. + do s3=1,2 + do i=1,N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + enddo + enddo + enddo + enddo +end subroutine + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, 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, j, 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 + + logical, external :: detEq + + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, 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 + delta_E = E0(istate) - Hii + val = mat(istate, p1, p2) + mat(istate, p1, p2) + 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) = pt2(istate) + e_pert + max_e_pert = min(e_pert,max_e_pert) + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + end if + end do + end do +end subroutine + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N_sel) + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, i_gen, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + + integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) +! logical :: bandon +! +! bandon = .false. + mat = 0d0 + + 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 ! interesting(0) + !i = interesting(ii) + + 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 > 4) 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(interesting(i) < i_gen) then + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + else + if(interesting(i) == i_gen) then +! bandon = .true. + if(sp == 3) then + banned(:,:,2) = transpose(banned(:,:,1)) + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + end if + end do +end subroutine + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi, integral8 + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, phase + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + bant = 1 + + tip = p(0,1) * p(0,2) + + ma = sp + if(p(0,1) > p(0,2)) ma = 1 + if(p(0,1) < p(0,2)) ma = 2 + mi = mod(ma, 2) + 1 + + if(sp == 3) then + if(ma == 2) bant = 2 + + if(tip == 3) then + puti = p(1, mi) + do i = 1, 3 + putj = p(i, ma) + if(banned(putj,puti,bant)) cycle + i1 = turn3(1,i) + i2 = turn3(2,i) + p1 = p(i1, ma) + p2 = p(i2, ma) + h1 = h(1, ma) + h2 = h(2, ma) + + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + if(ma == 1) then + mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij + end if + end do + else + do i = 1,2 + do j = 1,2 + puti = p(i, 1) + putj = p(j, 2) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + p2 = p(turn2(j), 2) + h1 = h(1,1) + h2 = h(1,2) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else + if(tip == 0) then + h1 = h(1, ma) + h2 = h(2, ma) + do i=1,3 + puti = p(i, ma) + do j=i+1,4 + putj = p(j, ma) + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + do i=1,3 + puti = p(turn3(1,i), ma) + putj = p(turn3(2,i), ma) + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if + end if +end subroutine + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) + double precision, external :: get_phase_bi, integral8 + + logical :: lbanned(mo_tot_num, 2), ok + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + lbanned = bannedOrb + + do i=1, p(0,1) + lbanned(p(i,1), 1) = .true. + end do + do i=1, p(0,2) + lbanned(p(i,2), 2) = .true. + end do + + ma = 1 + if(p(0,2) >= 2) ma = 2 + mi = turn2(ma) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then + tmp_row = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) + else + mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + tmp_row2(:,puti) += hij * coefs + end if + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + tmp_row(:,puti) += hij * coefs + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + tmp_row2(:,puti) += hij * coefs + end if + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do + end do +end subroutine + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, 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, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi, integral8 + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_tot_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + end if + mat(:, p1, p2) += coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, bant)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + end if + mat(:, puti, putj) += coefs(:) * hij + end do + end do + end if +end subroutine + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end subroutine + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end subroutine + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + 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 + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl + end do + + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + 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)) + end do + + call bitstring_to_list(myMask(1,1), list(1), na, N_int) + call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl +end subroutine + diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index 6e4cf44f..d6204cc3 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -13,7 +13,7 @@ end subroutine provide_everything PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context mo_mono_elec_integral -! PROVIDE ci_electronic_energy mo_tot_num N_int +! PROVIDE pt2_e0_denominator mo_tot_num N_int end subroutine run_wf @@ -22,7 +22,7 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - double precision :: energy(N_states_diag) + double precision :: energy(N_states) character*(64) :: states(2) integer :: rc, i @@ -48,7 +48,7 @@ subroutine run_wf ! --------- print *, 'Selection' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() @@ -76,7 +76,7 @@ end subroutine update_energy(energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) BEGIN_DOC ! Update energy when it is received from ZMQ END_DOC @@ -88,7 +88,7 @@ subroutine update_energy(energy) enddo call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) if (.True.) then - do k=1,size(ci_electronic_energy) + do k=1,N_states ci_electronic_energy(k) = energy(k) enddo TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors @@ -99,7 +99,7 @@ end subroutine selection_slave_tcp(i,energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: i call run_selection_slave(0,i,energy) diff --git a/plugins/Full_CI_ZMQ/selection_single.irp.f b/plugins/Full_CI_ZMQ/selection_single.irp.f deleted file mode 100644 index f107db11..00000000 --- a/plugins/Full_CI_ZMQ/selection_single.irp.f +++ /dev/null @@ -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 - - - diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f index 06bcf533..657ad63c 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -13,7 +13,7 @@ end subroutine provide_everything PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context -! PROVIDE ci_electronic_energy mo_tot_num N_int + PROVIDE pt2_e0_denominator mo_tot_num N_int end subroutine run_wf @@ -22,7 +22,7 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - double precision :: energy(N_states_diag) + double precision :: energy(N_states) character*(64) :: states(1) integer :: rc, i @@ -47,7 +47,7 @@ subroutine run_wf ! --------- print *, 'Selection' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() @@ -62,7 +62,7 @@ end subroutine update_energy(energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) BEGIN_DOC ! Update energy when it is received from ZMQ END_DOC @@ -74,7 +74,7 @@ subroutine update_energy(energy) enddo call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) if (.True.) then - do k=1,size(ci_electronic_energy) + do k=1,N_states ci_electronic_energy(k) = energy(k) enddo TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors @@ -85,7 +85,7 @@ end subroutine selection_slave_tcp(i,energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: i call run_selection_slave(0,i,energy) diff --git a/plugins/MP2/mp2.irp.f b/plugins/MP2/mp2.irp.f index 3a049f7b..d4721c71 100644 --- a/plugins/MP2/mp2.irp.f +++ b/plugins/MP2/mp2.irp.f @@ -1,4 +1,10 @@ program mp2 + no_vvvv_integrals = .True. + SOFT_TOUCH no_vvvv_integrals + call run +end + +subroutine run implicit none double precision, allocatable :: pt2(:), norm_pert(:) double precision :: H_pert_diag, E_old diff --git a/plugins/MP2/mp2_wf.irp.f b/plugins/MP2/mp2_wf.irp.f index 5efbb9cd..e7419319 100644 --- a/plugins/MP2/mp2_wf.irp.f +++ b/plugins/MP2/mp2_wf.irp.f @@ -1,4 +1,10 @@ program mp2_wf + no_vvvv_integrals = .True. + SOFT_TOUCH no_vvvv_integrals + call run +end + +subroutine run implicit none BEGIN_DOC ! Save the MP2 wave function diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f new file mode 100644 index 00000000..72d3ea67 --- /dev/null +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -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 + diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 7033ea61..e667d255 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -207,19 +207,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s ! ------------------------------------------- -! do l=1,N_st_diag -! do k=1,N_st_diag -! do iter2=1,iter-1 -! h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) -! h(k,iter,l,iter2) = h(k,iter2,l,iter) -! enddo -! enddo -! do k=1,l -! h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) -! h(l,iter,k,iter) = h(k,iter,l,iter) -! enddo -! enddo - call dgemm('T','N', N_st_diag*iter, N_st_diag, sze, & 1.d0, U, size(U,1), W(1,1,iter), size(W,1), & 0.d0, h(1,1,1,iter), size(h,1)*size(h,2)) @@ -328,20 +315,10 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s ! ----------- do k=1,N_st_diag - energies(k) = lambda(k) do i=1,sze u_in(i,k) = 0.d0 enddo enddo -! do k=1,N_st_diag -! do i=1,sze -! do iter2=1,iter -! do l=1,N_st_diag -! u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1) -! enddo -! enddo -! enddo -! enddo call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & U, size(U,1), y, N_st_diag*davidson_sze_max, & @@ -349,6 +326,9 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s enddo + do k=1,N_st_diag + energies(k) = lambda(k) + enddo write_buffer = '===== ' do i=1,N_st write_buffer = trim(write_buffer)//' ================ ================' @@ -570,7 +550,7 @@ subroutine davidson_diag_mrcc_hs2(dets_in,u_in,dim_in,energies,sze,N_st,N_st_dia integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit, istate integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(inout) :: u_in(dim_in,N_st_diag) - double precision, intent(out) :: energies(N_st) + double precision, intent(out) :: energies(N_st_diag) double precision, allocatable :: H_jj(:), S2_jj(:) double precision :: diag_h_mat_elem @@ -648,7 +628,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer :: k_pairs, kl integer :: iter2 - double precision, allocatable :: W(:,:), U(:,:), S(:,:) + double precision, allocatable :: W(:,:), U(:,:), S(:,:), overlap(:,:) double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) double precision :: diag_h_mat_elem @@ -660,8 +640,10 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz include 'constants.include.F' !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda - if (N_st_diag > sze) then - stop 'error in Davidson : N_st_diag > sze' + if (N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 endif PROVIDE nuclear_repulsion @@ -686,7 +668,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual' + write_buffer = trim(write_buffer)//' Energy S^2 Residual ' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' @@ -698,26 +680,19 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer, external :: align_double sze_8 = align_double(sze) - double precision :: delta - - if (s2_eig) then - delta = 1.d0 - else - delta = 0.d0 - endif - itermax = min(davidson_sze_max, sze/N_st_diag) allocate( & - W(sze_8,N_st_diag*itermax), & - U(sze_8,N_st_diag*itermax), & - S(sze_8,N_st_diag*itermax), & - h(N_st_diag*itermax,N_st_diag*itermax), & - y(N_st_diag*itermax,N_st_diag*itermax), & - s_(N_st_diag*itermax,N_st_diag*itermax), & - s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + W(sze_8,N_st_diag*itermax), & + U(sze_8,N_st_diag*itermax), & + S(sze_8,N_st_diag*itermax), & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & residual_norm(N_st_diag), & - c(N_st_diag*itermax), & - s2(N_st_diag*itermax), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + overlap(N_st_diag*itermax,N_st_diag*itermax), & lambda(N_st_diag*itermax)) h = 0.d0 @@ -741,24 +716,18 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz converged = .False. double precision :: r1, r2 - do k=N_st+1,N_st_diag-2,2 + do k=N_st+1,N_st_diag + u_in(k,k) = 10.d0 do i=1,sze call random_number(r1) call random_number(r2) r1 = dsqrt(-2.d0*dlog(r1)) r2 = dtwo_pi*r2 u_in(i,k) = r1*dcos(r2) - u_in(i,k+1) = r1*dsin(r2) enddo enddo - do k=N_st_diag-1,N_st_diag - do i=1,sze - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - u_in(i,k) = r1*dcos(r2) - enddo + do k=1,N_st_diag + call normalize(u_in(1,k),sze) enddo @@ -788,14 +757,53 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ------------------------------------------- - call dgemm('T','N', shift2, N_st_diag, sze, & - 1.d0, U, size(U,1), W(1,shift+1), size(W,1), & - 0.d0, h(1,shift+1), size(h,1)) + call dgemm('T','N', shift2, shift2, sze, & + 1.d0, U, size(U,1), W, size(W,1), & + 0.d0, h, size(h,1)) - call dgemm('T','N', shift2, N_st_diag, sze, & - 1.d0, U, size(U,1), S(1,shift+1), size(S,1), & - 0.d0, s_(1,shift+1), size(s_,1)) + call dgemm('T','N', shift2, shift2, sze, & + 1.d0, U, size(U,1), S, size(S,1), & + 0.d0, s_, size(s_,1)) +! ! Diagonalize S^2 +! ! --------------- +! +! call lapack_diag(s2,y,s_,size(s_,1),shift2) +! +! ! Rotate H in the basis of eigenfunctions of s2 +! ! --------------------------------------------- +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('T','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) +! +! ! Damp interaction between different spin states +! ! ------------------------------------------------ +! +! do k=1,shift2 +! do l=1,shift2 +! if (dabs(s2(k) - s2(l)) > 1.d0) then +! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) +! endif +! enddo +! enddo +! +! ! Rotate back H +! ! ------------- +! +! call dgemm('N','T',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) + + ! Diagonalize h ! ------------- call lapack_diag(lambda,y,h,size(h,1),shift2) @@ -816,24 +824,73 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz enddo if (s2_eig) then - logical :: state_ok(N_st_diag*davidson_sze_max) + logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + enddo + else + state_ok(k) = .True. + endif + + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + enddo + + if (state_following) then + + ! Compute overlap with U_in + ! ------------------------- + + integer :: order(N_st_diag) + double precision :: cmax + overlap = -1.d0 do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + do i=1,shift2 + overlap(k,i) = dabs(y(k,i)) + enddo enddo - do k=1,shift2 - if (.not. state_ok(k)) then - do l=k+1,shift2 - if (state_ok(l)) then - call dswap(shift2, y(1,k), 1, y(1,l), 1) - call dswap(1, s2(k), 1, s2(l), 1) - call dswap(1, lambda(k), 1, lambda(l), 1) - state_ok(k) = .True. - state_ok(l) = .False. - exit - endif - enddo + do k=1,N_st + cmax = -1.d0 + do i=1,N_st + if (overlap(i,k) > cmax) then + cmax = overlap(i,k) + order(k) = i + endif + enddo + do i=1,shift2 + overlap(order(k),i) = -1.d0 + enddo + enddo + overlap = y + do k=1,N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) endif enddo + do k=1,N_st + overlap(k,1) = lambda(k) + overlap(k,2) = s2(k) + enddo + do k=1,N_st + l = order(k) + if (k /= l) then + lambda(k) = overlap(l,1) + s2(k) = overlap(l,2) + endif + enddo + endif @@ -851,11 +908,31 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ----------------------- do k=1,N_st_diag - do i=1,sze - U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & - )/max(H_jj(i) - lambda (k),1.d-2) - enddo + if (state_ok(k)) then + do i=1,sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo + else + ! Randomize components with bad + do i=1,sze-2,2 + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + U(i+1,shift2+k) = r1*dsin(r2) + enddo + do i=sze-2+1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + enddo + endif + if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) to_print(1,k) = lambda(k) + nuclear_repulsion @@ -878,20 +955,16 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz enddo - if (.not.converged) then - iter = itermax-1 - endif - ! Re-contract to u_in ! ----------- - do k=1,N_st_diag - energies(k) = lambda(k) - enddo + call dgemm('N','N', sze, N_st_diag, shift2, & + 1.d0, U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) - call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & - U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) + enddo + do k=1,N_st_diag + energies(k) = lambda(k) enddo write_buffer = '===== ' @@ -904,7 +977,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz deallocate ( & W, residual_norm, & - U, & + U, overlap, & c, S, & h, & y, s_, s_tmp, & @@ -970,12 +1043,12 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& !$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8, & - !$OMP N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij,istate_in) + !$OMP N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij, delta_ij_s2,istate_in) allocate(vt(N_st_8,n),st(N_st_8,n)) Vt = 0.d0 St = 0.d0 - !$OMP DO SCHEDULE(dynamic) + !$OMP DO SCHEDULE(guided) do sh=1,shortcut(0,1) do sh2=sh,shortcut(0,1) exa = 0 @@ -1017,8 +1090,8 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i enddo enddo enddo - !$OMP END DO NOWAIT - !$OMP DO SCHEDULE(dynamic) + !$OMP END DO + !$OMP DO SCHEDULE(guided) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) @@ -1041,7 +1114,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i end do end do enddo - !$OMP END DO NOWAIT + !$OMP END DO ! -------------------------- ! Begin Specific to dressing @@ -1055,6 +1128,8 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i do istate=1,N_st vt (istate,i) = vt (istate,i) + delta_ij(istate_in,jj,ii)*ut(istate,j) vt (istate,j) = vt (istate,j) + delta_ij(istate_in,jj,ii)*ut(istate,i) + st (istate,i) = st (istate,i) + delta_ij_s2(istate_in,jj,ii)*ut(istate,j) + st (istate,j) = st (istate,j) + delta_ij_s2(istate_in,jj,ii)*ut(istate,i) enddo enddo enddo diff --git a/plugins/MRCC_Utils/mrcc_dummy.irp.f b/plugins/MRCC_Utils/mrcc_dummy.irp.f deleted file mode 100644 index 8f1deda8..00000000 --- a/plugins/MRCC_Utils/mrcc_dummy.irp.f +++ /dev/null @@ -1,4 +0,0 @@ -program pouet - - -end diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 48fa2e80..0540eed9 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -77,18 +77,18 @@ BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ] END_PROVIDER - BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ] - implicit none - BEGIN_DOC - ! Dressing matrix in N_det basis - END_DOC - integer :: i,j,m - delta_ij = 0.d0 - delta_ii = 0.d0 - call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref) - -END_PROVIDER +! BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] +!&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ] +! implicit none +! BEGIN_DOC +! ! Dressing matrix in N_det basis +! END_DOC +! integer :: i,j,m +! delta_ij = 0.d0 +! delta_ii = 0.d0 +! call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref) +! +!END_PROVIDER BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ] @@ -139,7 +139,6 @@ END_PROVIDER integer :: mrcc_state - mrcc_state = N_states do j=1,min(N_states,N_det) do i=1,N_det CI_eigenvectors_dressed(i,j) = psi_coef(i,j) @@ -148,16 +147,33 @@ END_PROVIDER if (diag_algorithm == "Davidson") then -! call davidson_diag_mrcc(psi_det,CI_eigenvectors_dressed,CI_electronic_energy_dressed,& -! size(CI_eigenvectors_dressed,1),N_det,N_states,N_states_diag,N_int,output_determinants,mrcc_state) - - call davidson_diag_mrcc_HS2(psi_det,CI_eigenvectors_dressed,& - size(CI_eigenvectors_dressed,1), & - CI_electronic_energy_dressed,N_det,N_states,N_states_diag,N_int, & - output_determinants,mrcc_state) - - call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& - N_states_diag,size(CI_eigenvectors_dressed,1)) + allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), & + eigenvalues(size(CI_electronic_energy_dressed,1))) + do j=1,min(N_states,N_det) + do i=1,N_det + eigenvectors(i,j) = psi_coef(i,j) + enddo + enddo + do mrcc_state=1,N_states + do j=mrcc_state,min(N_states,N_det) + do i=1,N_det + eigenvectors(i,j) = psi_coef(i,j) + enddo + enddo + call davidson_diag_mrcc_HS2(psi_det,eigenvectors,& + size(eigenvectors,1), & + eigenvalues,N_det,N_states,N_states_diag,N_int, & + output_determinants,mrcc_state) + CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) + CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + enddo + do k=N_states+1,N_states_diag + CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k) + CI_electronic_energy_dressed(k) = eigenvalues(k) + enddo + call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& + N_states_diag,size(CI_eigenvectors_dressed,1)) + deallocate (eigenvectors,eigenvalues) else if (diag_algorithm == "Lapack") then @@ -614,221 +630,66 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [ double precision, dIj_unique, (hh_shortcut(hh_shortcut(0)+1)-1, N_states) ] + BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ] &BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ] implicit none logical :: ok - integer :: i, j, k, s, II, pp, ppp, hh, ind, wk, nex, a_col, at_row + integer :: i, j, k, s, II, pp, ppp, hh, ind, wk, a_col, at_row integer, external :: searchDet, unsortedSearchDet integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2) - integer :: N, INFO, AtA_size, r1, r2 - double precision , allocatable :: AtB(:), AtA_val(:), A_val(:,:), x(:), x_new(:), A_val_mwen(:) - double precision :: t, norm, cx, res - integer, allocatable :: A_ind(:,:), lref(:), AtA_ind(:), A_ind_mwen(:), col_shortcut(:), N_col(:) + integer :: N, INFO, r1, r2 + double precision , allocatable :: AtB(:), x(:), x_new(:), A_val_mwen(:,:), t(:) + double precision :: norm, cx, res + integer, allocatable :: lref(:), A_ind_mwen(:) double precision :: phase - integer, allocatable :: pathTo(:), active_hh_idx(:), active_pp_idx(:) - logical, allocatable :: active(:) - double precision, allocatable :: rho_mrcc_init(:,:) - integer :: nactive + double precision, allocatable :: rho_mrcc_init(:) + integer :: a_coll, at_roww - nex = hh_shortcut(hh_shortcut(0)+1)-1 - print *, "TI", nex, N_det_non_ref - - allocate(pathTo(N_det_non_ref), active(nex)) - allocate(active_pp_idx(nex), active_hh_idx(nex)) - allocate(rho_mrcc_init(N_det_non_ref, N_states)) - - pathTo = 0 - active = .false. - nactive = 0 - - - do hh = 1, hh_shortcut(0) - do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - do II = 1, N_det_ref - call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) - if(.not. ok) cycle - call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) - if(.not. ok) cycle - ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) - if(ind == -1) cycle - ind = psi_non_ref_sorted_idx(ind) - if(pathTo(ind) == 0) then - pathTo(ind) = pp - else - active(pp) = .true. - active(pathTo(ind)) = .true. - end if - end do - end do - end do - - do hh = 1, hh_shortcut(0) - do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - if(active(pp)) then - nactive = nactive + 1 - active_hh_idx(nactive) = hh - active_pp_idx(nactive) = pp - end if - end do - end do - - print *, nactive, "inact/", size(active) - - allocate(A_ind(0:N_det_ref+1, nactive), A_val(N_det_ref+1, nactive)) - allocate(AtA_ind(N_det_ref * nactive), AtA_val(N_det_ref * nactive)) - allocate(x(nex), AtB(nex)) - allocate(N_col(nactive), col_shortcut(nactive)) - allocate(x_new(nex)) + print *, "TI", hh_nex, N_det_non_ref + + allocate(rho_mrcc_init(N_det_non_ref)) + allocate(x_new(hh_nex)) + allocate(x(hh_nex), AtB(hh_nex)) + x = 0d0 - - do s=1, N_states - - A_val = 0d0 - A_ind = 0 - AtA_ind = 0 - AtB = 0d0 - AtA_val = 0d0 - x = 0d0 - N_col = 0 - col_shortcut = 0 - - !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int, A_val, A_ind)& - !$OMP shared(s, hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, psi_non_ref_sorted_idx, psi_ref, N_det_ref)& - !$OMP shared(active, active_hh_idx, active_pp_idx, nactive) & - !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh) - allocate(lref(N_det_non_ref)) - !$OMP DO schedule(static,10) - do ppp=1,nactive - pp = active_pp_idx(ppp) - hh = active_hh_idx(ppp) - lref = 0 - do II = 1, N_det_ref - call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) - if(.not. ok) cycle - call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) - if(.not. ok) cycle - ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) - if(ind /= -1) then - call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) - if (phase > 0.d0) then - lref(psi_non_ref_sorted_idx(ind)) = II - else - lref(psi_non_ref_sorted_idx(ind)) = -II - endif - end if - end do - wk = 0 - do i=1, N_det_non_ref - if(lref(i) > 0) then - wk += 1 - A_val(wk, ppp) = psi_ref_coef(lref(i), s) - A_ind(wk, ppp) = i - else if(lref(i) < 0) then - wk += 1 - A_val(wk, ppp) = -psi_ref_coef(-lref(i), s) - A_ind(wk, ppp) = i - end if - end do - A_ind(0,ppp) = wk - end do - !$OMP END DO - deallocate(lref) - !$OMP END PARALLEL - - - print *, 'Done building A_val, A_ind' - - AtA_size = 0 - col_shortcut = 0 - N_col = 0 - integer :: a_coll, at_roww - - - !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, A_ind, A_val, x, N_det_ref, nex, N_det_non_ref)& - !$OMP private(at_row, a_col, t, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& - !$OMP shared(col_shortcut, N_col, AtB, AtA_size, AtA_val, AtA_ind, s, nactive, active_pp_idx) - allocate(A_val_mwen(nex), A_ind_mwen(nex)) + do s=1,N_states + + AtB(:) = 0.d0 + !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, active_excitation_to_determinants_idx,& + !$OMP active_excitation_to_determinants_val, x, N_det_ref, hh_nex, N_det_non_ref) & + !$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& + !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx) !$OMP DO schedule(dynamic, 100) - do at_roww = 1, nactive ! nex + do at_roww = 1, n_exc_active ! hh_nex at_row = active_pp_idx(at_roww) - wk = 0 - if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", nex - do i=1,A_ind(0,at_roww) - j = active_pp_idx(i) - AtB(at_row) = AtB(at_row) + psi_non_ref_coef(A_ind(i, at_roww), s) * A_val(i, at_roww) + do i=1,active_excitation_to_determinants_idx(0,at_roww) + AtB(at_row) = AtB(at_row) + psi_non_ref_coef(active_excitation_to_determinants_idx(i, at_roww), s) * active_excitation_to_determinants_val(s,i, at_roww) end do - - do a_coll = 1, nactive - a_col = active_pp_idx(a_coll) - t = 0d0 - r1 = 1 - r2 = 1 - do while ((A_ind(r1, at_roww) /= 0).and.(A_ind(r2, a_coll) /= 0)) - if(A_ind(r1, at_roww) > A_ind(r2, a_coll)) then - r2 = r2+1 - else if(A_ind(r1, at_roww) < A_ind(r2, a_coll)) then - r1 = r1+1 - else - t = t - A_val(r1, at_roww) * A_val(r2, a_coll) - r1 = r1+1 - r2 = r2+1 - end if - end do - - if(a_col == at_row) then - t = t + 1.d0 - end if - if(t /= 0.d0) then - wk += 1 - A_ind_mwen(wk) = a_col - A_val_mwen(wk) = t - end if - end do - - if(wk /= 0) then - !$OMP CRITICAL - col_shortcut(at_roww) = AtA_size+1 - N_col(at_roww) = wk - if (AtA_size+wk > size(AtA_ind,1)) then - print *, AtA_size+wk , size(AtA_ind,1) - stop 'too small' - endif - do i=1,wk - AtA_ind(AtA_size+i) = A_ind_mwen(i) - AtA_val(AtA_size+i) = A_val_mwen(i) - enddo - AtA_size += wk - !$OMP END CRITICAL - end if end do - !$OMP END DO NOWAIT - deallocate (A_ind_mwen, A_val_mwen) + !$OMP END DO + !$OMP END PARALLEL - - print *, "ATA SIZE", ata_size - x = 0d0 + + X(:) = 0d0 - do a_coll = 1, nactive + do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) X(a_col) = AtB(a_col) end do rho_mrcc_init = 0d0 - !$OMP PARALLEL default(shared) & - !$OMP private(lref, hh, pp, II, myMask, myDet, ok, ind, phase) allocate(lref(N_det_ref)) - !$OMP DO schedule(static, 1) do hh = 1, hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - if(active(pp)) cycle + if(is_active_exc(pp)) cycle lref = 0 + AtB(pp) = 0.d0 do II=1,N_det_ref call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) if(.not. ok) cycle @@ -838,81 +699,74 @@ END_PROVIDER if(ind == -1) cycle ind = psi_non_ref_sorted_idx(ind) call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) - X(pp) += psi_ref_coef(II,s)**2 AtB(pp) += psi_non_ref_coef(ind, s) * psi_ref_coef(II, s) * phase lref(II) = ind - if(phase < 0d0) lref(II) = -ind + if(phase < 0.d0) lref(II) = -ind end do - X(pp) = AtB(pp) / X(pp) + X(pp) = AtB(pp) do II=1,N_det_ref if(lref(II) > 0) then - rho_mrcc_init(lref(II),s) = psi_ref_coef(II,s) * X(pp) + rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp) else if(lref(II) < 0) then - rho_mrcc_init(-lref(II),s) = -psi_ref_coef(II,s) * X(pp) + rho_mrcc_init(-lref(II)) = -psi_ref_coef(II,s) * X(pp) end if end do end do end do - !$OMP END DO deallocate(lref) - !$OMP END PARALLEL - + x_new = x double precision :: factor, resold factor = 1.d0 resold = huge(1.d0) - do k=0,100000 - !$OMP PARALLEL default(shared) private(cx, i, j, a_col, a_coll) + + do k=0,hh_nex*hh_nex + !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) !$OMP DO do i=1,N_det_non_ref - rho_mrcc(i,s) = rho_mrcc_init(i,s) ! 0d0 + rho_mrcc(i,s) = rho_mrcc_init(i) enddo - !$OMP END DO + !$OMP END DO NOWAIT !$OMP DO - do a_coll = 1, nactive !: nex + do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) - cx = 0d0 - do i=col_shortcut(a_coll), col_shortcut(a_coll) + N_col(a_coll) - 1 - cx = cx + x(AtA_ind(i)) * AtA_val(i) + cx = 0.d0 + do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 + cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i) end do x_new(a_col) = AtB(a_col) + cx * factor end do !$OMP END DO - + !$OMP END PARALLEL + res = 0.d0 - - - if (res < resold) then - do a_coll=1,nactive ! nex - a_col = active_pp_idx(a_coll) - do j=1,N_det_non_ref - i = A_ind(j,a_coll) - if (i==0) exit - rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col) - enddo - res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) - X(a_col) = X_new(a_col) - end do - factor = 1.d0 - else - factor = -factor * 0.5d0 + do a_coll=1,n_exc_active + a_col = active_pp_idx(a_coll) + do j=1,N_det_non_ref + i = active_excitation_to_determinants_idx(j,a_coll) + if (i==0) exit + rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * X_new(a_col) + enddo + res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) + X(a_col) = X_new(a_col) + end do + if (res > resold) then + factor = factor * 0.5d0 endif resold = res - if(mod(k, 100) == 0) then + if(iand(k, 4095) == 0) then print *, "res ", k, res end if - if(res < 1d-9) exit + if(res < 1d-12) exit end do - - norm = 0.d0 do i=1,N_det_non_ref norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s) @@ -1073,6 +927,9 @@ END_PROVIDER norm = norm*f print *, 'norm of |T Psi_0> = ', dsqrt(norm) + if (dsqrt(norm) > 1.d0) then + stop 'Error : Norm of the SD larger than the norm of the reference.' + endif do i=1,N_det_ref norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) @@ -1084,7 +941,7 @@ END_PROVIDER ! rho_mrcc now contains the product of the scaling factors and the ! normalization constant - dIj_unique(:size(X), s) = X(:) + dIj_unique(1:size(X), s) = X(1:size(X)) end do END_PROVIDER @@ -1096,17 +953,14 @@ BEGIN_PROVIDER [ double precision, dij, (N_det_ref, N_det_non_ref, N_states) ] integer :: s,i,j double precision, external :: get_dij_index print *, "computing amplitudes..." - !$OMP PARALLEL DEFAULT(shared) PRIVATE(s,i,j) do s=1, N_states - !$OMP DO do i=1, N_det_non_ref do j=1, N_det_ref + !DIR$ FORCEINLINE dij(j, i, s) = get_dij_index(j, i, s, N_int) end do end do - !$OMP END DO end do - !$OMP END PARALLEL print *, "done computing amplitudes" END_PROVIDER @@ -1122,9 +976,13 @@ double precision function get_dij_index(II, i, s, Nint) call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase get_dij_index = get_dij_index * rho_mrcc(i,s) - else + else if(lambda_type == 1) then call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) get_dij_index = HIi * lambda_mrcc(s, i) + else if(lambda_type == 2) then + call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) + get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase + get_dij_index = get_dij_index end if end function @@ -1182,9 +1040,21 @@ end function BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ] -&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ] &BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ] +&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ] +&BEGIN_PROVIDER [ integer, hh_nex ] implicit none + BEGIN_DOC + ! + ! hh_exists : + ! + ! pp_exists : + ! + ! hh_shortcut : + ! + ! hh_nex : Total number of excitation operators + ! + END_DOC integer*2,allocatable :: num(:,:) integer :: exc(0:2, 2, 2), degree, n, on, s, l, i integer*2 :: h1, h2, p1, p2 @@ -1250,6 +1120,7 @@ end function end if end do end do + hh_nex = hh_shortcut(hh_shortcut(0)+1)-1 END_PROVIDER diff --git a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f b/plugins/MRPT/MRPT_Utils.main.irp.f similarity index 100% rename from plugins/MRPT_Utils/MRPT_Utils.main.irp.f rename to plugins/MRPT/MRPT_Utils.main.irp.f diff --git a/plugins/MRPT/NEEDED_CHILDREN_MODULES b/plugins/MRPT/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..7340c609 --- /dev/null +++ b/plugins/MRPT/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +MRPT_Utils Selectors_full Generators_full diff --git a/plugins/MRPT/README.rst b/plugins/MRPT/README.rst new file mode 100644 index 00000000..a9a0860c --- /dev/null +++ b/plugins/MRPT/README.rst @@ -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. diff --git a/plugins/MRPT/mrpt.irp.f b/plugins/MRPT/mrpt.irp.f new file mode 100644 index 00000000..8c8d746d --- /dev/null +++ b/plugins/MRPT/mrpt.irp.f @@ -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|,)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#>=|< ' + print *, ' -ziiiii||||||+||==+> ' + print *, ' -%|+++||=|=+|=|==/ ' + print *, ' -a>====+|====-:- ' + print *, ' "~,- -- /- ' + print *, ' -. )> ' + print *, ' .~ +- ' + print *, ' . .... : . ' + print *, ' -------~ ' + print *, '' +end diff --git a/plugins/MRPT_Utils/print_1h2p.irp.f b/plugins/MRPT/print_1h2p.irp.f similarity index 100% rename from plugins/MRPT_Utils/print_1h2p.irp.f rename to plugins/MRPT/print_1h2p.irp.f diff --git a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES deleted file mode 100644 index a613d5f2..00000000 --- a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Determinants Selectors_full Generators_full Davidson diff --git a/plugins/Perturbation/EZFIO.cfg b/plugins/Perturbation/EZFIO.cfg index 9023accf..4f0457a2 100644 --- a/plugins/Perturbation/EZFIO.cfg +++ b/plugins/Perturbation/EZFIO.cfg @@ -18,3 +18,15 @@ doc: The selection process stops when the energy ratio variational/(variational+ interface: ezfio,provider,ocaml default: 0.75 +[threshold_generators_pt2] +type: Threshold +doc: Thresholds on generators (fraction of the norm) for final PT2 calculation +interface: ezfio,provider,ocaml +default: 0.999 + +[threshold_selectors_pt2] +type: Threshold +doc: Thresholds on selectors (fraction of the norm) for final PT2 calculation +interface: ezfio,provider,ocaml +default: 1. + diff --git a/plugins/Psiref_Utils/psi_ref_utils.irp.f b/plugins/Psiref_Utils/psi_ref_utils.irp.f index 41db2f10..c4147ebc 100644 --- a/plugins/Psiref_Utils/psi_ref_utils.irp.f +++ b/plugins/Psiref_Utils/psi_ref_utils.irp.f @@ -97,6 +97,10 @@ END_PROVIDER endif enddo N_det_non_ref = i_non_ref + if (N_det_non_ref < 1) then + print *, 'Error : All determinants are in the reference' + stop -1 + endif END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_restart, (N_int,2,psi_det_size) ] diff --git a/plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES b/plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..8b137891 --- /dev/null +++ b/plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ + diff --git a/plugins/Selectors_CASSD/README.rst b/plugins/Selectors_CASSD/README.rst new file mode 100644 index 00000000..19b4ec2b --- /dev/null +++ b/plugins/Selectors_CASSD/README.rst @@ -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. diff --git a/plugins/Selectors_CASSD/selectors.irp.f b/plugins/Selectors_CASSD/selectors.irp.f new file mode 100644 index 00000000..ab36527d --- /dev/null +++ b/plugins/Selectors_CASSD/selectors.irp.f @@ -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 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 + + diff --git a/plugins/Selectors_CASSD/zmq.irp.f b/plugins/Selectors_CASSD/zmq.irp.f new file mode 100644 index 00000000..4359a876 --- /dev/null +++ b/plugins/Selectors_CASSD/zmq.irp.f @@ -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 + + diff --git a/plugins/Selectors_full/selectors.irp.f b/plugins/Selectors_full/selectors.irp.f index fd719136..e8e746c8 100644 --- a/plugins/Selectors_full/selectors.irp.f +++ b/plugins/Selectors_full/selectors.irp.f @@ -14,7 +14,7 @@ BEGIN_PROVIDER [ integer, N_det_selectors] integer :: i double precision :: norm, norm_max call write_time(output_determinants) - N_det_selectors = N_det_generators + N_det_selectors = N_det if (threshold_generators < 1.d0) then norm = 0.d0 do i=1,N_det diff --git a/plugins/loc_cele/loc_exchange_int.irp.f b/plugins/loc_cele/loc_exchange_int.irp.f index fa3cf8bf..eabdf35c 100644 --- a/plugins/loc_cele/loc_exchange_int.irp.f +++ b/plugins/loc_cele/loc_exchange_int.irp.f @@ -13,7 +13,8 @@ program loc_int iorb = list_core_inact(i) exchange_int = 0.d0 iorder = 0 - if(list_core_inact_check(iorb) == .False.)cycle + print*,'' + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_core_inact_orb jorb = list_core_inact(j) iorder(jorb) = jorb @@ -45,7 +46,8 @@ program loc_int iorb = list_act(i) exchange_int = 0.d0 iorder = 0 - if(list_core_inact_check(iorb) == .False.)cycle + print*,'' + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb @@ -78,7 +80,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_virt_orb jorb = list_virt(j) iorder(jorb) = jorb diff --git a/plugins/loc_cele/loc_exchange_int_act.irp.f b/plugins/loc_cele/loc_exchange_int_act.irp.f index b9bbeb82..f332dd5d 100644 --- a/plugins/loc_cele/loc_exchange_int_act.irp.f +++ b/plugins/loc_cele/loc_exchange_int_act.irp.f @@ -15,7 +15,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb diff --git a/plugins/loc_cele/loc_exchange_int_inact.irp.f b/plugins/loc_cele/loc_exchange_int_inact.irp.f index 2ff3c85f..fcf20ced 100644 --- a/plugins/loc_cele/loc_exchange_int_inact.irp.f +++ b/plugins/loc_cele/loc_exchange_int_inact.irp.f @@ -14,7 +14,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_core_inact_orb jorb = list_core_inact(j) iorder(jorb) = jorb diff --git a/plugins/loc_cele/loc_exchange_int_virt.irp.f b/plugins/loc_cele/loc_exchange_int_virt.irp.f index 333f189b..8302b5d2 100644 --- a/plugins/loc_cele/loc_exchange_int_virt.irp.f +++ b/plugins/loc_cele/loc_exchange_int_virt.irp.f @@ -15,7 +15,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_virt_orb jorb = list_virt(j) iorder(jorb) = jorb diff --git a/plugins/mrcepa0/EZFIO.cfg b/plugins/mrcepa0/EZFIO.cfg index 61f3392f..b64637e6 100644 --- a/plugins/mrcepa0/EZFIO.cfg +++ b/plugins/mrcepa0/EZFIO.cfg @@ -23,7 +23,7 @@ interface: ezfio type: Threshold doc: Threshold on the convergence of the dressed CI energy interface: ezfio,provider,ocaml -default: 5.e-5 +default: 1.e-5 [n_it_max_dressed_ci] type: Strictly_positive_int diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 3646b0b2..0c67ab99 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -4,6 +4,8 @@ use bitmasks BEGIN_PROVIDER [ double precision, delta_ij_mrcc, (N_states,N_det_non_ref,N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ij_s2_mrcc, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_s2_mrcc, (N_states, N_det_ref) ] use bitmasks implicit none integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc @@ -14,11 +16,13 @@ use bitmasks delta_ij_mrcc = 0d0 delta_ii_mrcc = 0d0 - print *, "Dij", dij(1,1,1) + delta_ij_s2_mrcc = 0d0 + delta_ii_s2_mrcc = 0d0 + PROVIDE dij provide hh_shortcut psi_det_size! lambda_mrcc !$OMP PARALLEL DO default(none) schedule(dynamic) & !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & - !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc) & + !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc, delta_ii_s2_mrcc, delta_ij_s2_mrcc) & !$OMP private(h, n, mask, omask, buf, ok, iproc) do gen= 1, N_det_generators allocate(buf(N_int, 2, N_det_non_ref)) @@ -37,7 +41,9 @@ use bitmasks end do n = n - 1 - if(n /= 0) call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc,gen,n,buf,N_int,omask) + if(n /= 0) then + call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc, delta_ij_s2_mrcc, delta_ii_s2_mrcc, gen,n,buf,N_int,omask) + endif end do deallocate(buf) @@ -52,13 +58,15 @@ END_PROVIDER ! end subroutine -subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffer,Nint,key_mask) +subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_generator,n_selected,det_buffer,Nint,key_mask) use bitmasks implicit none integer, intent(in) :: i_generator,n_selected, Nint double precision, intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) double precision, intent(inout) :: delta_ii_(N_states,N_det_ref) + double precision, intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) + double precision, intent(inout) :: delta_ii_s2_(N_states,N_det_ref) integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) integer :: i,j,k,l,m @@ -68,8 +76,8 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe integer(bit_kind),allocatable :: tq(:,:,:) integer :: N_tq, c_ref ,degree - double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states) - double precision, allocatable :: dIa_hla(:,:) + double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states) + double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:) double precision :: haj, phase, phase2 double precision :: f(N_states), ci_inv(N_states) integer :: exc(0:2,2,2) @@ -82,7 +90,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe integer(bit_kind),intent(in) :: key_mask(Nint, 2) integer,allocatable :: idx_miniList(:) integer :: N_miniList, ni, leng - double precision, allocatable :: hij_cache(:) + double precision, allocatable :: hij_cache(:), sij_cache(:) integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:) integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:) @@ -92,7 +100,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe leng = max(N_det_generators, N_det_non_ref) - allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref)) + allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref)) allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size)) !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) @@ -117,7 +125,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe deallocate(microlist, idx_microlist) - allocate (dIa_hla(N_states,N_det_non_ref)) + allocate (dIa_hla(N_states,N_det_non_ref), dIa_sla(N_states,N_det_non_ref)) ! |I> @@ -185,6 +193,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) + call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_cache(k_sd)) enddo ! |I> do i_I=1,N_det_ref @@ -282,31 +291,36 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) hla = hij_cache(k_sd) + sla = sij_cache(k_sd) ! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) do i_state=1,N_states dIa_hla(i_state,k_sd) = dIa(i_state) * hla + dIa_sla(i_state,k_sd) = dIa(i_state) * sla enddo enddo call omp_set_lock( psi_ref_lock(i_I) ) do i_state=1,N_states - if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) - delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) - enddo - else +! if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then +! do l_sd=1,idx_alpha(0) +! k_sd = idx_alpha(l_sd) +! delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) +! delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) +! delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) +! delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) +! enddo +! else delta_ii_(i_state,i_I) = 0.d0 do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) + delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) enddo - endif +! endif enddo call omp_unset_lock( psi_ref_lock(i_I) ) enddo enddo - deallocate (dIa_hla,hij_cache) + deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache) deallocate(miniList, idx_miniList) end @@ -315,45 +329,84 @@ end BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii, (N_states, N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ij_s2, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_s2, (N_states, N_det_ref) ] use bitmasks implicit none - integer :: i, j, i_state + integer :: i, j, i_state !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc - do i_state = 1, N_states - if(mrmode == 3) then + if(mrmode == 3) then do i = 1, N_det_ref - delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) + do i_state = 1, N_states + delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) + delta_ii_s2(i_state,i)= delta_ii_s2_mrcc(i_state,i) + enddo do j = 1, N_det_non_ref - delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) + do i_state = 1, N_states + delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) + delta_ij_s2(i_state,j,i) = delta_ij_s2_mrcc(i_state,j,i) + enddo end do end do -! -! do i = 1, N_det_ref -! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) -! do j = 1, N_det_non_ref -! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) -! end do -! end do - else if(mrmode == 2) then - do i = 1, N_det_ref + + ! =-=-= BEGIN STATE AVERAGE +! do i = 1, N_det_ref +! delta_ii(:,i)= delta_ii_mrcc(1,i) +! delta_ii_s2(:,i)= delta_ii_s2_mrcc(1,i) +! do i_state = 2, N_states +! delta_ii(:,i) += delta_ii_mrcc(i_state,i) +! delta_ii_s2(:,i) += delta_ii_s2_mrcc(i_state,i) +! enddo +! do j = 1, N_det_non_ref +! delta_ij(:,j,i) = delta_ij_mrcc(1,j,i) +! delta_ij_s2(:,j,i) = delta_ij_s2_mrcc(1,j,i) +! do i_state = 2, N_states +! delta_ij(:,j,i) += delta_ij_mrcc(i_state,j,i) +! delta_ij_s2(:,j,i) += delta_ij_s2_mrcc(i_state,j,i) +! enddo +! end do +! end do +! delta_ij = delta_ij * (1.d0/dble(N_states)) +! delta_ii = delta_ii * (1.d0/dble(N_states)) + ! =-=-= END STATE AVERAGE + ! + ! do i = 1, N_det_ref + ! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) + ! do j = 1, N_det_non_ref + ! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) + ! end do + ! end do + else if(mrmode == 2) then + do i = 1, N_det_ref + do i_state = 1, N_states delta_ii(i_state,i)= delta_ii_old(i_state,i) - do j = 1, N_det_non_ref + delta_ii_s2(i_state,i)= delta_ii_s2_old(i_state,i) + enddo + do j = 1, N_det_non_ref + do i_state = 1, N_states delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) - end do + delta_ij_s2(i_state,j,i) = delta_ij_s2_old(i_state,j,i) + enddo end do - else if(mrmode == 1) then - do i = 1, N_det_ref + end do + else if(mrmode == 1) then + do i = 1, N_det_ref + do i_state = 1, N_states delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - do j = 1, N_det_non_ref + delta_ii_s2(i_state,i)= delta_mrcepa0_ii_s2(i,i_state) + enddo + do j = 1, N_det_non_ref + do i_state = 1, N_states delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - end do + delta_ij_s2(i_state,j,i) = delta_mrcepa0_ij_s2(i,j,i_state) + enddo end do - else - stop "invalid mrmode" - end if - end do + end do + else + stop "invalid mrmode" + end if END_PROVIDER @@ -537,28 +590,32 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] +&BEGIN_PROVIDER [ double precision, delta_cas_s2, (N_det_ref, N_det_ref, N_states) ] use bitmasks implicit none integer :: i,j,k - double precision :: Hjk, Hki, Hij + double precision :: Sjk,Hjk, Hki, Hij !double precision, external :: get_dij integer i_state, degree provide lambda_mrcc dIj do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref,dij) + !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,delta_cas_s2,N_det_ref,dij) do i=1,N_det_ref do j=1,i call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int) delta_cas(i,j,i_state) = 0d0 + delta_cas_s2(i,j,i_state) = 0d0 do k=1,N_det_non_ref call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) + call get_s2(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Sjk) delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) - !print *, Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int), Hki * get_dij(psi_ref(1,1,j), psi_non_ref(1,1,k), N_int) + delta_cas_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * lambda_mrcc(i_state, k) end do delta_cas(j,i,i_state) = delta_cas(i,j,i_state) + delta_cas_s2(j,i,i_state) = delta_cas_s2(i,j,i_state) end do end do !$OMP END PARALLEL DO @@ -639,6 +696,8 @@ end function BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] &BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii, (N_det_ref,N_states) ] +&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij_s2, (N_det_ref,N_det_non_ref,N_states) ] +&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii_s2, (N_det_ref,N_states) ] use bitmasks implicit none @@ -646,7 +705,7 @@ end function integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref) logical :: ok double precision :: phase_iI, phase_Ik, phase_Jl, phase_IJ, phase_al, diI, hIi, hJi, delta_JI, dkI(1), HkI, ci_inv(1), dia_hla(1) - double precision :: contrib, contrib2, HIIi, HJk, wall + double precision :: contrib, contrib2, contrib_s2, contrib2_s2, HIIi, HJk, wall integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ integer(bit_kind) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2) integer(bit_kind),allocatable :: sortRef(:,:,:) @@ -671,14 +730,16 @@ end function ! To provide everything contrib = dij(1, 1, 1) - do i_state = 1, N_states - delta_mrcepa0_ii(:,:) = 0d0 - delta_mrcepa0_ij(:,:,:) = 0d0 + delta_mrcepa0_ii(:,:) = 0d0 + delta_mrcepa0_ij(:,:,:) = 0d0 + delta_mrcepa0_ii_s2(:,:) = 0d0 + delta_mrcepa0_ij_s2(:,:,:) = 0d0 - !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii) & - !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2) & + do i_state = 1, N_states + !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii, delta_mrcepa0_ij_s2, delta_mrcepa0_ii_s2) & + !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2,contrib_s2,contrib2_s2) & !$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) & - !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas) & + !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas, delta_cas_s2) & !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij) do blok=1,cepa0_shortcut(0) do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 @@ -721,16 +782,21 @@ end function ! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) + contrib_s2 = delta_cas_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) + contrib2_s2 = contrib_s2 / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) !$OMP ATOMIC delta_mrcepa0_ii(J,i_state) -= contrib2 + delta_mrcepa0_ii_s2(J,i_state) -= contrib2_s2 else contrib = contrib * 0.5d0 + contrib_s2 = contrib_s2 * 0.5d0 end if !$OMP ATOMIC delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib + delta_mrcepa0_ij_s2(J, det_cepa0_idx(i), i_state) += contrib_s2 end do kloop end do @@ -741,7 +807,7 @@ end function deallocate(idx_sorted_bit) call wall_time(wall) print *, "cepa0", wall, notf - !stop + END_PROVIDER @@ -860,12 +926,14 @@ subroutine set_det_bit(det, p, s) end subroutine -BEGIN_PROVIDER [ double precision, h_, (N_det_ref,N_det_non_ref) ] + BEGIN_PROVIDER [ double precision, h_cache, (N_det_ref,N_det_non_ref) ] +&BEGIN_PROVIDER [ double precision, s2_cache, (N_det_ref,N_det_non_ref) ] implicit none integer :: i,j do i=1,N_det_ref do j=1,N_det_non_ref - call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_(i,j)) + call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_cache(i,j)) + call get_s2(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, s2_cache(i,j)) end do end do END_PROVIDER diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f index f1d6f029..9e9fa65a 100644 --- a/plugins/mrcepa0/dressing_slave.irp.f +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -37,7 +37,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) integer(ZMQ_PTR), external :: new_zmq_push_socket integer(ZMQ_PTR) :: zmq_socket_push - double precision, allocatable :: delta(:,:,:) + double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) @@ -47,8 +47,8 @@ subroutine mrsc2_dressing_slave(thread,iproc) logical :: ok double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al double precision :: diI, hIi, hJi, delta_JI, dkI, HkI, ci_inv(N_states), cj_inv(N_states) - double precision :: contrib, wall, iwall - double precision, allocatable :: dleat(:,:,:) + double precision :: contrib, contrib_s2, wall, iwall + double precision, allocatable :: dleat(:,:,:), dleat_s2(:,:,:) integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp @@ -63,6 +63,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) allocate (dleat(N_states, N_det_non_ref, 2), delta(N_states,0:N_det_non_ref, 2)) + allocate (dleat_s2(N_states, N_det_non_ref, 2), delta_s2(N_states,0:N_det_non_ref, 2)) allocate(komon(0:N_det_non_ref)) do @@ -74,10 +75,14 @@ subroutine mrsc2_dressing_slave(thread,iproc) cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state) end do !delta = 0.d0 + !delta_s2 = 0.d0 n = 0 delta(:,0,:) = 0d0 delta(:,:nlink(J),1) = 0d0 delta(:,:nlink(i_I),2) = 0d0 + delta_s2(:,0,:) = 0d0 + delta_s2(:,:nlink(J),1) = 0d0 + delta_s2(:,:nlink(i_I),2) = 0d0 komon(0) = 0 komoned = .false. @@ -121,8 +126,8 @@ subroutine mrsc2_dressing_slave(thread,iproc) end if i = det_cepa0_idx(linked(m, i_I)) - if(h_(J,i) == 0.d0) cycle - if(h_(i_I,i) == 0.d0) cycle + if(h_cache(J,i) == 0.d0) cycle + if(h_cache(i_I,i) == 0.d0) cycle !ok = .false. !do i_state=1, N_states @@ -144,10 +149,13 @@ subroutine mrsc2_dressing_slave(thread,iproc) ! if(I_i == J) phase_Ii = phase_Ji do i_state = 1,N_states - dkI = h_(J,i) * dij(i_I, i, i_state)!get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,i), N_int) - !dkI = h_(J,i) * h_(i_I,i) * lambda_mrcc(i_state, i) + dkI = h_cache(J,i) * dij(i_I, i, i_state) dleat(i_state, kn, 1) = dkI dleat(i_state, kn, 2) = dkI + + dkI = s2_cache(J,i) * dij(i_I, i, i_state) + dleat_s2(i_state, kn, 1) = dkI + dleat_s2(i_state, kn, 2) = dkI end do end do @@ -173,26 +181,32 @@ subroutine mrsc2_dressing_slave(thread,iproc) !if(lambda_mrcc(i_state, i) == 0d0) cycle - !contrib = h_(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al + !contrib = h_cache(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2) + contrib_s2 = dij(i_I, k, i_state) * dleat_s2(i_state, m, 2) delta(i_state,ll,1) += contrib + delta_s2(i_state,ll,1) += contrib_s2 if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state) + delta_s2(i_state,0,1) -= contrib_s2 * ci_inv(i_state) * psi_non_ref_coef(l,i_state) endif if(I_i == J) cycle - !contrib = h_(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al + !contrib = h_cache(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al contrib = dij(J, l, i_state) * dleat(i_state, m, 1) + contrib_s2 = dij(J, l, i_state) * dleat_s2(i_state, m, 1) delta(i_state,kk,2) += contrib + delta_s2(i_state,kk,2) += contrib_s2 if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state) + delta_s2(i_state,0,2) -= contrib_s2 * cj_inv(i_state) * psi_non_ref_coef(k,i_state) end if enddo !i_state end do ! while end do ! kk - call push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) + call push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) ! end if @@ -208,7 +222,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) end -subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) +subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) use f77_zmq implicit none BEGIN_DOC @@ -218,6 +232,7 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) integer, intent(in) :: i_I, J integer(ZMQ_PTR), intent(in) :: zmq_socket_push double precision,intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) + double precision,intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) integer, intent(in) :: task_id integer :: rc , i_state, i, kk, li integer,allocatable :: idx(:,:) @@ -278,6 +293,12 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' stop 'error' endif + + rc = f77_zmq_send( zmq_socket_push, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta_s2(1,0,1) = delta_I delta_s2(1,0,2) = delta_J + if (rc /= (n(kk)+1)*8*N_states) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' + stop 'error' + endif rc = f77_zmq_send( zmq_socket_push, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) if (rc /= n(kk)*4) then @@ -305,7 +326,7 @@ end -subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) +subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) use f77_zmq implicit none BEGIN_DOC @@ -315,6 +336,7 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) integer(ZMQ_PTR), intent(in) :: zmq_socket_pull integer, intent(out) :: i_I, J, n(2) double precision, intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) + double precision, intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) integer, intent(out) :: task_id integer :: rc , i, kk integer,intent(inout) :: idx(N_det_non_ref,2) @@ -346,9 +368,15 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) stop 'error' endif + rc = f77_zmq_recv( zmq_socket_pull, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) + if (rc /= (n(kk)+1)*8*N_states) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' + stop 'error' + endif + rc = f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) if (rc /= n(kk)*4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, n(kk)*4, ZMQ_SNDMORE)' + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)' stop 'error' endif end if @@ -372,7 +400,7 @@ end -subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) +subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2_) use f77_zmq implicit none BEGIN_DOC @@ -381,11 +409,13 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) double precision,intent(inout) :: delta_ii_(N_states,N_det_ref) + double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) + double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref) ! integer :: j,l integer :: rc - double precision, allocatable :: delta(:,:,:) + double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket @@ -401,49 +431,47 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) delta_ii_(:,:) = 0d0 delta_ij_(:,:,:) = 0d0 + delta_ii_s2_(:,:) = 0d0 + delta_ij_s2_(:,:,:) = 0d0 zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_socket_pull = new_zmq_pull_socket() - allocate ( delta(N_states,0:N_det_non_ref,2) ) + allocate ( delta(N_states,0:N_det_non_ref,2), delta_s2(N_states,0:N_det_non_ref,2) ) allocate(idx(N_det_non_ref,2)) more = 1 do while (more == 1) - call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) + call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) do l=1, n(1) do i_state=1,N_states delta_ij_(i_state,idx(l,1),i_I) += delta(i_state,l,1) + delta_ij_s2_(i_state,idx(l,1),i_I) += delta_s2(i_state,l,1) end do end do do l=1, n(2) do i_state=1,N_states delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2) + delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(i_state,l,2) end do end do -! -! do l=1,nlink(J) -! do i_state=1,N_states -! delta_ij_(i_state,det_cepa0_idx(linked(l,J)),i_I) += delta(i_state,l,1) -! delta_ij_(i_state,det_cepa0_idx(linked(l,i_I)),j) += delta(i_state,l,2) -! end do -! end do -! if(n(1) /= 0) then do i_state=1,N_states delta_ii_(i_state,i_I) += delta(i_state,0,1) + delta_ii_s2_(i_state,i_I) += delta_s2(i_state,0,1) end do end if if(n(2) /= 0) then do i_state=1,N_states delta_ii_(i_state,J) += delta(i_state,0,2) + delta_ii_s2_(i_state,J) += delta_s2(i_state,0,2) end do end if @@ -454,7 +482,7 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) enddo - deallocate( delta ) + deallocate( delta, delta_s2 ) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_pull_socket(zmq_socket_pull) @@ -466,6 +494,8 @@ end BEGIN_PROVIDER [ double precision, delta_ij_old, (N_states,N_det_non_ref,N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii_old, (N_states,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ij_s2_old, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_s2_old, (N_states,N_det_ref) ] implicit none integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2 @@ -574,10 +604,10 @@ end ! rc = pthread_create(collector_thread, mrsc2_dressing_collector) print *, nzer, ntot, float(nzer) / float(ntot) provide nproc - !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old) PRIVATE(i) NUM_THREADS(nproc+1) + !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) PRIVATE(i) NUM_THREADS(nproc+1) i = omp_get_thread_num() if (i==0) then - call mrsc2_dressing_collector(delta_ii_old,delta_ij_old) + call mrsc2_dressing_collector(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) else call mrsc2_dressing_slave_inproc(i) endif diff --git a/plugins/mrcepa0/mrcc.irp.f b/plugins/mrcepa0/mrcc.irp.f index 91592e62..a5614942 100644 --- a/plugins/mrcepa0/mrcc.irp.f +++ b/plugins/mrcepa0/mrcc.irp.f @@ -8,8 +8,16 @@ program mrsc2sub read_wf = .True. SOFT_TOUCH read_wf - call print_cas_coefs call set_generators_bitmasks_as_holes_and_particles + if (.True.) then + integer :: i,j + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + SOFT_TOUCH psi_coef + endif call run(N_states,energy) if(do_pt2_end)then call run_pt2(N_states,energy) diff --git a/plugins/mrcepa0/mrcepa0.irp.f b/plugins/mrcepa0/mrcepa0.irp.f index 34d3dec5..aeacbb39 100644 --- a/plugins/mrcepa0/mrcepa0.irp.f +++ b/plugins/mrcepa0/mrcepa0.irp.f @@ -8,8 +8,18 @@ program mrcepa0 read_wf = .True. SOFT_TOUCH read_wf - call print_cas_coefs call set_generators_bitmasks_as_holes_and_particles + if (.True.) then + integer :: i,j + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + TOUCH psi_coef + endif + call print_cas_coefs + call run(N_states,energy) if(do_pt2_end)then call run_pt2(N_states,energy) diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index 63f03360..1b2e2fcb 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -10,18 +10,18 @@ subroutine run(N_st,energy) double precision :: E_new, E_old, delta_e integer :: iteration - double precision :: E_past(4), lambda + double precision :: E_past(4) integer :: n_it_mrcc_max double precision :: thresh_mrcc - + double precision, allocatable :: lambda(:) + allocate (lambda(N_states)) - thresh_mrcc = thresh_dressed_ci n_it_mrcc_max = n_it_max_dressed_ci if(n_it_mrcc_max == 1) then - do j=1,N_states_diag + do j=1,N_states do i=1,N_det psi_coef(i,j) = CI_eigenvectors_dressed(i,j) enddo @@ -30,7 +30,6 @@ subroutine run(N_st,energy) call write_double(6,ci_energy_dressed(1),"Final MRCC energy") call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) call save_wavefunction - energy(:) = ci_energy_dressed(:) else E_new = 0.d0 delta_E = 1.d0 @@ -38,15 +37,21 @@ subroutine run(N_st,energy) lambda = 1.d0 do while (delta_E > thresh_mrcc) iteration += 1 - print *, '===========================' - print *, 'MRCEPA0 Iteration', iteration - print *, '===========================' + print *, '===============================================' + print *, 'MRCEPA0 Iteration', iteration, '/', n_it_mrcc_max + print *, '===============================================' print *, '' - E_old = sum(ci_energy_dressed) - call write_double(6,ci_energy_dressed(1),"MRCEPA0 energy") + E_old = sum(ci_energy_dressed(1:N_states)) + do i=1,N_st + call write_double(6,ci_energy_dressed(i),"MRCEPA0 energy") + enddo call diagonalize_ci_dressed(lambda) - E_new = sum(ci_energy_dressed) - delta_E = dabs(E_new - E_old) + E_new = sum(ci_energy_dressed(1:N_states)) + delta_E = (E_new - E_old)/dble(N_states) + print *, '' + call write_double(6,thresh_mrcc,"thresh_mrcc") + call write_double(6,delta_E,"delta_E") + delta_E = dabs(delta_E) call save_wavefunction call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) if (iteration >= n_it_mrcc_max) then @@ -54,8 +59,8 @@ subroutine run(N_st,energy) endif enddo call write_double(6,ci_energy_dressed(1),"Final MRCEPA0 energy") - energy(:) = ci_energy_dressed(:) endif + energy(1:N_st) = ci_energy_dressed(1:N_st) end @@ -66,7 +71,7 @@ subroutine print_cas_coefs print *, 'CAS' print *, '===' do i=1,N_det_cas - print *, psi_cas_coef(i,:) + print *, (psi_cas_coef(i,j), j=1,N_states) call debug_det(psi_cas(1,1,i),N_int) enddo call write_double(6,ci_energy(1),"Initial CI energy") @@ -139,8 +144,8 @@ subroutine run_pt2_old(N_st,energy) print * ,'Computing the remaining contribution' - threshold_selectors = 1.d0 - threshold_generators = 0.999d0 + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) N_det_generators = N_det_non_ref + N_det_ref N_det_selectors = N_det_non_ref + N_det_ref diff --git a/plugins/mrcepa0/mrsc2.irp.f b/plugins/mrcepa0/mrsc2.irp.f index d0f44a33..948b1b5c 100644 --- a/plugins/mrcepa0/mrsc2.irp.f +++ b/plugins/mrcepa0/mrsc2.irp.f @@ -7,8 +7,16 @@ program mrsc2 mrmode = 2 read_wf = .True. SOFT_TOUCH read_wf - call print_cas_coefs call set_generators_bitmasks_as_holes_and_particles + if (.True.) then + integer :: i,j + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + TOUCH psi_coef + endif call run(N_states,energy) if(do_pt2_end)then call run_pt2(N_states,energy) diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index cfb1d6bf..c7714e8a 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -422,7 +422,7 @@ class H_apply(object): if (s2_eig) then call make_s2_eigenfunction endif -! SOFT_TOUCH psi_det psi_coef N_det + SOFT_TOUCH psi_det psi_coef N_det selection_criterion_min = min(selection_criterion_min, maxval(select_max))*0.1d0 selection_criterion = selection_criterion_min call write_double(output_determinants,selection_criterion,'Selection criterion') diff --git a/src/Davidson/EZFIO.cfg b/src/Davidson/EZFIO.cfg index 415e359e..7724400f 100644 --- a/src/Davidson/EZFIO.cfg +++ b/src/Davidson/EZFIO.cfg @@ -6,7 +6,25 @@ default: 1.e-12 [n_states_diag] type: States_number -doc: n_states_diag +doc: Number of states to consider during the Davdison diagonalization default: 10 interface: ezfio,provider,ocaml +[davidson_sze_max] +type: Strictly_positive_int +doc: Number of micro-iterations before re-contracting +default: 10 +interface: ezfio,provider,ocaml + +[state_following] +type: logical +doc: If true, the states are re-ordered to match the input states +default: False +interface: ezfio,provider,ocaml + +[disk_based_davidson] +type: logical +doc: If true, disk space is used to store the vectors +default: False +interface: ezfio,provider,ocaml + diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 12265810..7cba0f60 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -22,7 +22,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(inout) :: u_in(dim_in,N_st_diag) - double precision, intent(out) :: energies(N_st), s2_out(N_st_diag) + double precision, intent(out) :: energies(N_st_diag), s2_out(N_st_diag) double precision, allocatable :: H_jj(:), S2_jj(:) double precision :: diag_h_mat_elem @@ -45,7 +45,11 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d !$OMP END DO !$OMP END PARALLEL - call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + if (disk_based_davidson) then + call davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + else + call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + endif do i=1,N_st_diag s2_out(i) = S2_jj(i) enddo @@ -83,8 +87,8 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(in) :: H_jj(sze) - double precision, intent(inout) :: S2_jj(sze) - integer, intent(in) :: iunit + double precision, intent(inout) :: S2_jj(sze) + integer, intent(in) :: iunit double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st_diag) @@ -98,7 +102,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer :: k_pairs, kl integer :: iter2 - double precision, allocatable :: W(:,:), U(:,:), S(:,:) + double precision, allocatable :: W(:,:), U(:,:), S(:,:), overlap(:,:) double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) double precision :: diag_h_mat_elem @@ -107,17 +111,19 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s double precision :: to_print(3,N_st) double precision :: cpu, wall integer :: shift, shift2, itermax + double precision :: r1, r2 + logical :: state_ok(N_st_diag*davidson_sze_max) include 'constants.include.F' !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda if (N_st_diag*3 > sze) then - print *, 'error in Davidson :' - print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 - stop -1 + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 endif - - PROVIDE nuclear_repulsion - + + PROVIDE nuclear_repulsion expected_s2 + call write_time(iunit) call wall_time(wall) call cpu_time(cpu) @@ -136,7 +142,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual' + write_buffer = trim(write_buffer)//' Energy S^2 Residual ' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' @@ -144,31 +150,32 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s write_buffer = trim(write_buffer)//' ================ =========== ===========' enddo write(iunit,'(A)') trim(write_buffer) - - integer, external :: align_double + + integer, external :: align_double sze_8 = align_double(sze) - + itermax = min(davidson_sze_max, sze/N_st_diag) allocate( & - W(sze_8,N_st_diag*itermax), & - U(sze_8,N_st_diag*itermax), & - S(sze_8,N_st_diag*itermax), & - h(N_st_diag*itermax,N_st_diag*itermax), & - y(N_st_diag*itermax,N_st_diag*itermax), & - s_(N_st_diag*itermax,N_st_diag*itermax), & - s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + W(sze_8,N_st_diag*itermax), & + U(sze_8,N_st_diag*itermax), & + S(sze_8,N_st_diag*itermax), & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & residual_norm(N_st_diag), & - c(N_st_diag*itermax), & - s2(N_st_diag*itermax), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + overlap(N_st_diag*itermax, N_st_diag*itermax), & lambda(N_st_diag*itermax)) - h = 0.d0 - s_ = 0.d0 - s_tmp = 0.d0 + h = 0.d0 U = 0.d0 W = 0.d0 S = 0.d0 y = 0.d0 + s_ = 0.d0 + s_tmp = 0.d0 ASSERT (N_st > 0) @@ -182,28 +189,21 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s converged = .False. - double precision :: r1, r2 - do k=N_st+1,N_st_diag-2,2 - do i=1,sze - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - u_in(i,k) = r1*dcos(r2) - u_in(i,k+1) = r1*dsin(r2) - enddo + do k=N_st+1,N_st_diag + u_in(k,k) = 10.d0 + do i=1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + enddo enddo - do k=N_st_diag-1,N_st_diag - do i=1,sze - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - u_in(i,k) = r1*dcos(r2) - enddo + do k=1,N_st_diag + call normalize(u_in(1,k),sze) enddo - - + + do while (.not.converged) do k=1,N_st_diag @@ -211,18 +211,19 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s U(i,k) = u_in(i,k) enddo enddo - + do iter=1,itermax-1 shift = N_st_diag*(iter-1) shift2 = N_st_diag*iter - + call ortho_qr(U,size(U,1),sze,shift2) ! Compute |W_k> = \sum_i |i> ! ----------------------------------------- +! call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) call H_S2_u_0_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) @@ -230,16 +231,57 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ------------------------------------------- call dgemm('T','N', shift2, shift2, sze, & - 1.d0, U(1,1), size(U,1), W(1,1), size(W,1), & - 0.d0, h(1,1), size(h,1)) + 1.d0, U, size(U,1), W, size(W,1), & + 0.d0, h, size(h,1)) call dgemm('T','N', shift2, shift2, sze, & - 1.d0, U(1,1), size(U,1), S(1,1), size(S,1), & - 0.d0, s_(1,1), size(s_,1)) + 1.d0, U, size(U,1), S, size(S,1), & + 0.d0, s_, size(s_,1)) +! ! Diagonalize S^2 +! ! --------------- +! +! call lapack_diag(s2,y,s_,size(s_,1),shift2) +! +! +! ! Rotate H in the basis of eigenfunctions of s2 +! ! --------------------------------------------- +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('T','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) +! +! ! Damp interaction between different spin states +! ! ------------------------------------------------ +! +! do k=1,shift2 +! do l=1,shift2 +! if (dabs(s2(k) - s2(l)) > 1.d0) then +! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) +! endif +! enddo +! enddo +! +! ! Rotate back H +! ! ------------- +! +! call dgemm('N','T',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) + + ! Diagonalize h ! ------------- + call lapack_diag(lambda,y,h,size(h,1),shift2) ! Compute S2 for each eigenvector @@ -252,30 +294,78 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s call dgemm('T','N',shift2,shift2,shift2, & 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & 0.d0, s_, size(s_,1)) + + do k=1,shift2 s2(k) = s_(k,k) + S_z2_Sz enddo if (s2_eig) then - logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + enddo + else + state_ok(k) = .True. + endif + + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + enddo + + if (state_following) then + + integer :: order(N_st_diag) + double precision :: cmax + + overlap = -1.d0 do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + do i=1,shift2 + overlap(k,i) = dabs(y(k,i)) + enddo enddo - do k=1,shift2 - if (.not. state_ok(k)) then - do l=k+1,shift2 - if (state_ok(l)) then - call dswap(shift2, y(1,k), 1, y(1,l), 1) - call dswap(1, s2(k), 1, s2(l), 1) - call dswap(1, lambda(k), 1, lambda(l), 1) - state_ok(k) = .True. - state_ok(l) = .False. - exit - endif - enddo + do k=1,N_st + cmax = -1.d0 + do i=1,N_st + if (overlap(i,k) > cmax) then + cmax = overlap(i,k) + order(k) = i + endif + enddo + do i=1,N_st_diag + overlap(order(k),i) = -1.d0 + enddo + enddo + overlap = y + do k=1,N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) endif enddo + do k=1,N_st + overlap(k,1) = lambda(k) + overlap(k,2) = s2(k) + enddo + do k=1,N_st + l = order(k) + if (k /= l) then + lambda(k) = overlap(l,1) + s2(k) = overlap(l,2) + endif + enddo + endif @@ -293,11 +383,31 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ----------------------------------------- do k=1,N_st_diag - do i=1,sze - U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & - )/max(H_jj(i) - lambda (k),1.d-2) - enddo + if (state_ok(k)) then + do i=1,sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo + else + ! Randomize components with bad + do i=1,sze-2,2 + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + U(i+1,shift2+k) = r1*dsin(r2) + enddo + do i=sze-2+1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + enddo + endif + if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) to_print(1,k) = lambda(k) + nuclear_repulsion @@ -320,23 +430,16 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s enddo - if (.not.converged) then - iter = itermax-1 - endif - ! Re-contract to u_in ! ----------- - do k=1,N_st_diag - energies(k) = lambda(k) - enddo - - call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & + call dgemm('N','N', sze, N_st_diag, shift2, 1.d0, & U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) enddo do k=1,N_st_diag + energies(k) = lambda(k) S2_jj(k) = s2(k) enddo write_buffer = '===== ' @@ -349,7 +452,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s deallocate ( & W, residual_norm, & - U, & + U, overlap, & c, S, & h, & y, s_, s_tmp, & @@ -357,3 +460,439 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ) end +subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + use bitmasks + use mmap_module + implicit none + BEGIN_DOC + ! Davidson diagonalization with specific diagonal elements of the H matrix + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! S2_jj : specific diagonal S^2 matrix elements + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! N_st_diag : Number of states in which H is diagonalized. Assumed > sze + ! + ! iunit : Unit for the I/O + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(in) :: H_jj(sze) + double precision, intent(inout) :: S2_jj(sze) + integer, intent(in) :: iunit + double precision, intent(inout) :: u_in(dim_in,N_st_diag) + double precision, intent(out) :: energies(N_st_diag) + + integer :: sze_8 + integer :: iter + integer :: i,j,k,l,m + logical :: converged + + double precision :: u_dot_v, u_dot_u + + integer :: k_pairs, kl + + integer :: iter2 + double precision, pointer :: W(:,:), U(:,:), S(:,:), overlap(:,:) + double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) + double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) + double precision :: diag_h_mat_elem + double precision, allocatable :: residual_norm(:) + character*(16384) :: write_buffer + double precision :: to_print(3,N_st) + double precision :: cpu, wall + logical :: state_ok(N_st_diag*davidson_sze_max) + integer :: shift, shift2, itermax + include 'constants.include.F' + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda + if (N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 + endif + + PROVIDE nuclear_repulsion expected_s2 + + call write_time(iunit) + call wall_time(wall) + call cpu_time(cpu) + write(iunit,'(A)') '' + write(iunit,'(A)') 'Davidson Diagonalization' + write(iunit,'(A)') '------------------------' + write(iunit,'(A)') '' + call write_int(iunit,N_st,'Number of states') + call write_int(iunit,N_st_diag,'Number of states in diagonalization') + call write_int(iunit,sze,'Number of determinants') + write(iunit,'(A)') '' + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = ' Iter' + do i=1,N_st + write_buffer = trim(write_buffer)//' Energy S^2 Residual ' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + + integer, external :: align_double + integer :: fd(3) + type(c_ptr) :: c_pointer(3) + sze_8 = align_double(sze) + + itermax = min(davidson_sze_max, sze/N_st_diag) + + call mmap( & + trim(ezfio_work_dir)//'U', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(1), .False., c_pointer(1)) + call c_f_pointer(c_pointer(1), W, (/ sze_8,N_st_diag*itermax /) ) + + call mmap( & + trim(ezfio_work_dir)//'W', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(2), .False., c_pointer(2)) + call c_f_pointer(c_pointer(2), U, (/ sze_8,N_st_diag*itermax /) ) + + call mmap( & + trim(ezfio_work_dir)//'S', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(3), .False., c_pointer(3)) + call c_f_pointer(c_pointer(3), S, (/ sze_8,N_st_diag*itermax /) ) + + allocate( & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + overlap(N_st_diag*itermax, N_st_diag*itermax), & + residual_norm(N_st_diag), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + lambda(N_st_diag*itermax)) + + h = 0.d0 + U = 0.d0 + W = 0.d0 + S = 0.d0 + y = 0.d0 + s_ = 0.d0 + s_tmp = 0.d0 + + + ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + ! Davidson iterations + ! =================== + + converged = .False. + + double precision :: r1, r2 + do k=N_st+1,N_st_diag + u_in(k,k) = 10.d0 + do i=1,sze + call random_number(r1) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + enddo + enddo + do k=1,N_st_diag + call normalize(u_in(1,k),sze) + enddo + + + do while (.not.converged) + + do k=1,N_st_diag + do i=1,sze + U(i,k) = u_in(i,k) + enddo + enddo + + do iter=1,itermax-1 + + shift = N_st_diag*(iter-1) + shift2 = N_st_diag*iter + + call ortho_qr(U,size(U,1),sze,shift2) + + ! Compute |W_k> = \sum_i |i> + ! ----------------------------------------- + + +! 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 = = + ! ------------------------------------------- + + 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 + 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 + diff --git a/src/Davidson/parameters.irp.f b/src/Davidson/parameters.irp.f index 82315495..ae8babaa 100644 --- a/src/Davidson/parameters.irp.f +++ b/src/Davidson/parameters.irp.f @@ -1,21 +1,3 @@ -BEGIN_PROVIDER [ integer, davidson_iter_max ] - implicit none - BEGIN_DOC - ! Max number of Davidson iterations - END_DOC - davidson_iter_max = 100 -END_PROVIDER - -BEGIN_PROVIDER [ integer, davidson_sze_max ] - implicit none - BEGIN_DOC - ! Max number of Davidson sizes - END_DOC - ASSERT (davidson_sze_max <= davidson_iter_max) - davidson_sze_max = N_states+7 -END_PROVIDER - - BEGIN_PROVIDER [ character(64), davidson_criterion ] implicit none BEGIN_DOC diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 9ab30476..dd5ab1ab 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -177,7 +177,7 @@ BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ] END_PROVIDER -subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) +subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) use bitmasks use f77_zmq implicit none @@ -280,3 +280,164 @@ end +subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + ! + ! S2_jj : array of + 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 + diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 20eb3e83..411fe703 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -222,7 +222,11 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) do while (bit_tmp(j)==bit_tmp(i)) if (duplicate(j)) then j += 1 - cycle + if (j > N_det) then + exit + else + cycle + endif endif duplicate(j) = .True. do k=1,N_int @@ -248,17 +252,20 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) enddo if (found_duplicates) then - call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') k=0 do i=1,N_det if (.not.duplicate(i)) then k += 1 psi_det(:,:,k) = psi_det_sorted_bit (:,:,i) psi_coef(k,:) = psi_coef_sorted_bit(i,:) + else + call debug_det(psi_det_sorted_bit(1,1,i),N_int) + stop 'duplicates in psi_det' endif enddo N_det = k - TOUCH N_det psi_det psi_coef + call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') + SOFT_TOUCH N_det psi_det psi_coef endif deallocate (duplicate,bit_tmp) end diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index 6abdf13e..42bca8eb 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -35,7 +35,8 @@ subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint) bmax += popcnt( o(k,1) ) amax -= popcnt( o(k,2) ) enddo - sze = 2*int( min(binom_func(bmax, amax), 1.d8) ) + sze = int( min(binom_func(bmax, amax), 1.d8) ) + sze = sze*sze end @@ -51,8 +52,8 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) integer(bit_kind),intent(out) :: d(Nint,2,sze) integer :: i, k, nt, na, nd, amax - integer :: list_todo(n_alpha) - integer :: list_a(n_alpha) + integer :: list_todo(2*n_alpha) + integer :: list_a(2*n_alpha) amax = n_alpha do k=1,Nint @@ -68,13 +69,24 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) sze = nd + integer :: ne(2), l + l=0 do i=1,nd + ne(1) = 0 + ne(2) = 0 + l=l+1 ! Doubly occupied orbitals do k=1,Nint - d(k,1,i) = ior(d(k,1,i),o(k,2)) - d(k,2,i) = ior(d(k,2,i),o(k,2)) + d(k,1,l) = ior(d(k,1,i),o(k,2)) + d(k,2,l) = ior(d(k,2,i),o(k,2)) + ne(1) += popcnt(d(k,1,l)) + ne(2) += popcnt(d(k,2,l)) enddo + if ( (ne(1) /= elec_alpha_num).or.(ne(2) /= elec_beta_num) ) then + l = l-1 + endif enddo + sze = l end @@ -123,8 +135,8 @@ end implicit none BEGIN_DOC ! array of the occ_pattern present in the wf - ! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation - ! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation + ! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupations + ! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupations END_DOC integer :: i,j,k @@ -144,7 +156,7 @@ end logical,allocatable :: duplicate(:) - allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,psi_det_size) ) + allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,N_det) ) do i=1,N_det iorder(i) = i @@ -161,12 +173,7 @@ end duplicate(i) = .False. enddo - i=1 - integer (bit_kind) :: occ_pattern_tmp - do i=1,N_det - duplicate(i) = .False. - enddo - + ! Find duplicates do i=1,N_det-1 if (duplicate(i)) then cycle @@ -175,6 +182,9 @@ end do while (bit_tmp(j)==bit_tmp(i)) if (duplicate(j)) then j+=1 + if (j>N_det) then + exit + endif cycle endif duplicate(j) = .True. @@ -192,6 +202,7 @@ end enddo enddo + ! Copy filtered result N_occ_pattern=0 do i=1,N_det if (duplicate(i)) then @@ -204,6 +215,28 @@ end enddo enddo +!- Check +! do i=1,N_occ_pattern +! do j=i+1,N_occ_pattern +! duplicate(1) = .True. +! do k=1,N_int +! if (psi_occ_pattern(k,1,i) /= psi_occ_pattern(k,1,j)) then +! duplicate(1) = .False. +! exit +! endif +! if (psi_occ_pattern(k,2,i) /= psi_occ_pattern(k,2,j)) then +! duplicate(1) = .False. +! exit +! endif +! enddo +! if (duplicate(1)) then +! call debug_det(psi_occ_pattern(1,1,i),N_int) +! call debug_det(psi_occ_pattern(1,1,j),N_int) +! stop 'DUPLICATE' +! endif +! enddo +! enddo +!- deallocate(iorder,duplicate,bit_tmp,tmp_array) END_PROVIDER @@ -213,7 +246,7 @@ subroutine make_s2_eigenfunction integer :: i,j,k integer :: smax, s integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:) - integer :: N_det_new, iproc + integer :: N_det_new integer, parameter :: bufsze = 1000 logical, external :: is_in_wavefunction @@ -237,6 +270,20 @@ subroutine make_s2_eigenfunction det_buffer(k,1,N_det_new) = d(k,1,j) det_buffer(k,2,N_det_new) = d(k,2,j) enddo +! integer :: ne(2) +! ne(:) = 0 +! do k=1,N_int +! ne(1) += popcnt(d(k,1,j)) +! ne(2) += popcnt(d(k,2,j)) +! enddo +! if (ne(1) /= elec_alpha_num) then +! call debug_det(d(1,1,j),N_int) +! stop "ALPHA" +! endif +! if (ne(2) /= elec_beta_num) then +! call debug_det(d(1,1,j),N_int) +! stop "BETA" +! endif if (N_det_new == bufsze) then call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) N_det_new = 0 @@ -248,13 +295,15 @@ subroutine make_s2_eigenfunction if (N_det_new > 0) then call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,0) ! call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0) - call copy_H_apply_buffer_to_wf - SOFT_TOUCH N_det psi_coef psi_det endif deallocate(d,det_buffer) - call write_int(output_determinants,N_det_new, 'Added determinants for S^2') + call copy_H_apply_buffer_to_wf + SOFT_TOUCH N_det psi_coef psi_det + print *, 'Added determinants for S^2' +! logical :: found +! call remove_duplicates_in_psi_det(found) end diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index c6bb8390..7e62befb 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -1,36 +1,36 @@ subroutine get_s2(key_i,key_j,Nint,s2) - implicit none - use bitmasks - BEGIN_DOC -! Returns - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2) - integer(bit_kind), intent(in) :: key_j(Nint,2) - double precision, intent(out) :: s2 - integer :: exc(0:2,2,2) - integer :: degree - double precision :: phase_spsm - integer :: nup, i - - s2 = 0.d0 - !$FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - select case (degree) - case(2) - call get_double_excitation(key_j,key_i,exc,phase_spsm,Nint) - if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta - if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then - s2 = -phase_spsm - endif - endif - case(0) + implicit none + use bitmasks + BEGIN_DOC + ! Returns + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + integer(bit_kind), intent(in) :: key_j(Nint,2) + double precision, intent(out) :: s2 + integer :: exc(0:2,2,2) + integer :: degree + double precision :: phase_spsm + integer :: nup, i + + s2 = 0.d0 + !$FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case(2) + call get_double_excitation(key_j,key_i,exc,phase_spsm,Nint) + if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta + if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then + s2 = -phase_spsm + endif + endif + case(0) nup = 0 do i=1,Nint nup += popcnt(iand(xor(key_i(i,1),key_i(i,2)),key_i(i,1))) enddo s2 = dble(nup) - end select + end select end BEGIN_PROVIDER [ double precision, S_z ] diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 47d02758..59776ed0 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -513,7 +513,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij) integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem, phase,phase_2 integer :: n_occ_ab(2) - PROVIDE mo_bielec_integrals_in_map mo_integrals_map + PROVIDE mo_bielec_integrals_in_map mo_integrals_map big_array_exchange_integrals ASSERT (Nint > 0) ASSERT (Nint == N_int) diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index d8a18437..68a7a050 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -350,8 +350,7 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] integral = ao_bielec_integral(1,1,1,1) real :: map_mb - print*, 'read_ao_integrals',read_ao_integrals - print*, 'disk_access_ao_integrals',disk_access_ao_integrals + PROVIDE read_ao_integrals disk_access_ao_integrals if (read_ao_integrals) then print*,'Reading the AO integrals' call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map) diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 5f6df0bd..1f2a7a1b 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -677,7 +677,6 @@ integer function load_$ao_integrals(filename) real(integral_kind), pointer :: val(:) integer :: iknd, kknd integer*8 :: n, j - double precision :: get_$ao_bielec_integral load_$ao_integrals = 1 open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN') read(66,err=98,end=98) iknd, kknd @@ -712,7 +711,7 @@ integer function load_$ao_integrals(filename) end -SUBST [ ao_integrals_map, ao_integrals, ao_num , get_ao_bielec_integral ] -ao_integrals_map ; ao_integrals ; ao_num ; get_ao_bielec_integral ;; -mo_integrals_map ; mo_integrals ; mo_tot_num ; get_mo_bielec_integral ;; +SUBST [ ao_integrals_map, ao_integrals, ao_num ] +ao_integrals_map ; ao_integrals ; ao_num ;; +mo_integrals_map ; mo_integrals ; mo_tot_num ;; END_TEMPLATE diff --git a/plugins/MRPT_Utils/EZFIO.cfg b/src/MRPT_Utils/EZFIO.cfg similarity index 100% rename from plugins/MRPT_Utils/EZFIO.cfg rename to src/MRPT_Utils/EZFIO.cfg diff --git a/plugins/MRPT_Utils/H_apply.irp.f b/src/MRPT_Utils/H_apply.irp.f similarity index 100% rename from plugins/MRPT_Utils/H_apply.irp.f rename to src/MRPT_Utils/H_apply.irp.f diff --git a/src/MRPT_Utils/NEEDED_CHILDREN_MODULES b/src/MRPT_Utils/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..34de8ddb --- /dev/null +++ b/src/MRPT_Utils/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants Davidson diff --git a/plugins/MRPT_Utils/README.rst b/src/MRPT_Utils/README.rst similarity index 100% rename from plugins/MRPT_Utils/README.rst rename to src/MRPT_Utils/README.rst diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/src/MRPT_Utils/energies_cas.irp.f similarity index 100% rename from plugins/MRPT_Utils/energies_cas.irp.f rename to src/MRPT_Utils/energies_cas.irp.f diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/src/MRPT_Utils/excitations_cas.irp.f similarity index 100% rename from plugins/MRPT_Utils/excitations_cas.irp.f rename to src/MRPT_Utils/excitations_cas.irp.f diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/src/MRPT_Utils/fock_like_operators.irp.f similarity index 100% rename from plugins/MRPT_Utils/fock_like_operators.irp.f rename to src/MRPT_Utils/fock_like_operators.irp.f diff --git a/plugins/MRPT_Utils/give_2h2p.irp.f b/src/MRPT_Utils/give_2h2p.irp.f similarity index 100% rename from plugins/MRPT_Utils/give_2h2p.irp.f rename to src/MRPT_Utils/give_2h2p.irp.f diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/src/MRPT_Utils/mrpt_dress.irp.f similarity index 100% rename from plugins/MRPT_Utils/mrpt_dress.irp.f rename to src/MRPT_Utils/mrpt_dress.irp.f diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/src/MRPT_Utils/mrpt_utils.irp.f similarity index 100% rename from plugins/MRPT_Utils/mrpt_utils.irp.f rename to src/MRPT_Utils/mrpt_utils.irp.f diff --git a/plugins/MRPT_Utils/new_way.irp.f b/src/MRPT_Utils/new_way.irp.f similarity index 100% rename from plugins/MRPT_Utils/new_way.irp.f rename to src/MRPT_Utils/new_way.irp.f diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/src/MRPT_Utils/new_way_second_order_coef.irp.f similarity index 100% rename from plugins/MRPT_Utils/new_way_second_order_coef.irp.f rename to src/MRPT_Utils/new_way_second_order_coef.irp.f diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/src/MRPT_Utils/psi_active_prov.irp.f similarity index 100% rename from plugins/MRPT_Utils/psi_active_prov.irp.f rename to src/MRPT_Utils/psi_active_prov.irp.f diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/src/MRPT_Utils/second_order_new.irp.f similarity index 100% rename from plugins/MRPT_Utils/second_order_new.irp.f rename to src/MRPT_Utils/second_order_new.irp.f diff --git a/plugins/MRPT_Utils/second_order_new_2p.irp.f b/src/MRPT_Utils/second_order_new_2p.irp.f similarity index 100% rename from plugins/MRPT_Utils/second_order_new_2p.irp.f rename to src/MRPT_Utils/second_order_new_2p.irp.f diff --git a/plugins/MRPT_Utils/utils_bitmask.irp.f b/src/MRPT_Utils/utils_bitmask.irp.f similarity index 100% rename from plugins/MRPT_Utils/utils_bitmask.irp.f rename to src/MRPT_Utils/utils_bitmask.irp.f diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 9c3b35b5..44a15ddf 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -148,17 +148,42 @@ subroutine ortho_qr(A,LDA,m,n) allocate (jpvt(n), tau(n), work(1)) LWORK=-1 -! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) - LWORK=WORK(1) + LWORK=2*WORK(1) deallocate(WORK) allocate(WORK(LWORK)) -! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) call dorgqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO) deallocate(WORK,jpvt,tau) end +subroutine ortho_qr_unblocked(A,LDA,m,n) + implicit none + BEGIN_DOC + ! Orthogonalization using Q.R factorization + ! + ! A : matrix to orthogonalize + ! + ! LDA : leftmost dimension of A + ! + ! n : Number of rows of A + ! + ! m : Number of columns of A + ! + END_DOC + integer, intent(in) :: m,n, LDA + double precision, intent(inout) :: A(LDA,n) + + integer :: info + integer, allocatable :: jpvt(:) + double precision, allocatable :: tau(:), work(:) + + allocate (jpvt(n), tau(n), work(n)) + call dgeqr2( m, n, A, LDA, TAU, WORK, INFO ) + call dorg2r(m, n, n, A, LDA, tau, WORK, INFO) + deallocate(WORK,jpvt,tau) +end + subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) implicit none BEGIN_DOC @@ -444,7 +469,12 @@ subroutine lapack_diag(eigvalues,eigvectors,H,nmax,n) print *, irp_here, ': DSYEV: the ',-info,'-th argument had an illegal value' stop 2 else if( info > 0 ) then - write(*,*)'DSYEV Failed' + write(*,*)'DSYEV Failed : ', info + do i=1,n + do j=1,n + print *, H(i,j) + enddo + enddo stop 1 end if diff --git a/src/Utils/map_module.f90 b/src/Utils/map_module.f90 index 4a83582f..80260233 100644 --- a/src/Utils/map_module.f90 +++ b/src/Utils/map_module.f90 @@ -622,7 +622,7 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) istep = ishft(iend-ibegin,-1) idx = ibegin + istep - do while (istep > 16) + do while (istep > 64) idx = ibegin + istep ! TODO : Cache misses if (cache_key < X(idx)) then @@ -660,8 +660,8 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) endif enddo idx = ibegin - if (min(iend_in,sze) > ibegin+16) then - iend = ibegin+16 + if (min(iend_in,sze) > ibegin+64) then + iend = ibegin+64 do while (cache_key > X(idx)) idx = idx+1 end do @@ -730,7 +730,7 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in istep = ishft(iend-ibegin,-1) idx = ibegin + istep - do while (istep > 16) + do while (istep > 64) idx = ibegin + istep if (cache_key < X(idx)) then iend = idx @@ -771,8 +771,8 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in enddo idx = ibegin value = Y(idx) - if (min(iend_in,sze) > ibegin+16) then - iend = ibegin+16 + if (min(iend_in,sze) > ibegin+64) then + iend = ibegin+64 do while (cache_key > X(idx)) idx = idx+1 value = Y(idx) diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 07d79f1a..f43ffaaa 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -3,15 +3,24 @@ source $QP_ROOT/tests/bats/common.bats.sh @test "CAS_SD H2O cc-pVDZ" { - test_exe cas_sd_selected || skip + test_exe cassd_zmq || skip INPUT=h2o.ezfio + rm -rf work/h2o.ezfio/determinants/ qp_edit -c $INPUT ezfio set_file $INPUT - ezfio set perturbation do_pt2_end False - ezfio set determinants n_det_max 1000 + ezfio set perturbation do_pt2_end True + ezfio set determinants n_det_max 16384 qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" - qp_run cas_sd_selected $INPUT - energy="$(ezfio get cas_sd energy)" - eq $energy -76.2221842108163 1.E-5 + qp_run cassd_zmq $INPUT + energy="$(ezfio get cas_sd_zmq energy_pt2)" + eq $energy -76.23109 2.E-5 + + ezfio set determinants n_det_max 2048 + ezfio set determinants read_wf True + ezfio set perturbation do_pt2_end True + qp_run cassd_zmq $INPUT + ezfio set determinants read_wf False + energy="$(ezfio get cas_sd_zmq energy)" + eq $energy -76.2300888408526 2.E-5 } diff --git a/tests/bats/fci.bats b/tests/bats/fci.bats index 174c8f61..79ff91ab 100644 --- a/tests/bats/fci.bats +++ b/tests/bats/fci.bats @@ -20,7 +20,7 @@ function run_FCI() { function run_FCI_ZMQ() { thresh=5.e-5 - test_exe full_ci || skip + test_exe fci_zmq || skip qp_edit -c $1 ezfio set_file $1 ezfio set perturbation do_pt2_end True @@ -28,9 +28,9 @@ function run_FCI_ZMQ() { ezfio set davidson threshold_davidson 1.e-10 qp_run fci_zmq $1 - energy="$(ezfio get full_ci energy)" + energy="$(ezfio get full_ci_zmq energy)" eq $energy $3 $thresh - energy_pt2="$(ezfio get full_ci energy_pt2)" + energy_pt2="$(ezfio get full_ci_zmq energy_pt2)" eq $energy_pt2 $4 $thresh } diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index 8b56c606..ed69681f 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -15,8 +15,8 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 1 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22903276183061 1.e-4 + energy="$(ezfio get mrcepa0 energy_pt2)" + eq $energy -76.238562120457431 1.e-4 } @test "MRCC H2O cc-pVDZ" { @@ -32,8 +32,8 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 0 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22899302846875 1.e-4 + energy="$(ezfio get mrcepa0 energy_pt2)" + eq $energy -76.238527498388962 1.e-4 } @test "MRSC2 H2O cc-pVDZ" { @@ -48,8 +48,8 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 0 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22647345292708 1.e-4 + energy="$(ezfio get mrcepa0 energy_pt2)" + eq $energy -76.235833732594187 1.e-4 } @test "MRCEPA0 H2O cc-pVDZ" { @@ -64,7 +64,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 0 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.23199784430074 1.e-4 + energy="$(ezfio get mrcepa0 energy_pt2)" + eq $energy -76.2418799284763 1.e-4 } diff --git a/tests/bats/pseudo.bats b/tests/bats/pseudo.bats index 8cccf229..a20b0842 100644 --- a/tests/bats/pseudo.bats +++ b/tests/bats/pseudo.bats @@ -23,7 +23,7 @@ function run_HF() { function run_FCI_ZMQ() { thresh=5.e-5 - test_exe full_ci || skip + test_exe fci_zmq|| skip qp_edit -c $1 ezfio set_file $1 ezfio set perturbation do_pt2_end True @@ -31,9 +31,9 @@ function run_FCI_ZMQ() { ezfio set davidson threshold_davidson 1.e-10 qp_run fci_zmq $1 - energy="$(ezfio get full_ci energy)" + energy="$(ezfio get full_ci_zmq energy)" eq $energy $3 $thresh - energy_pt2="$(ezfio get full_ci energy_pt2)" + energy_pt2="$(ezfio get full_ci_zmq energy_pt2)" eq $energy_pt2 $4 $thresh } diff --git a/tests/run_tests.sh b/tests/run_tests.sh index 4664ce82..9e560d38 100755 --- a/tests/run_tests.sh +++ b/tests/run_tests.sh @@ -14,7 +14,7 @@ mrcepa0.bats export QP_PREFIX="timeout -s 9 300" -export QP_TASK_DEBUG=1 +#export QP_TASK_DEBUG=1 rm -rf work output