Merge pull request #176 from scemama/master

CAS_SD_ZMQ

.travis.yml

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

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

config/ifort.cfg

@@ -38,7 +38,7 @@ FCFLAGS  : -xSSE4.2  -O2 -ip -ftz -g
 #################
 #
 [PROFILE]
-FC       : -p -g -traceback
+FC       : -p -g
 FCFLAGS  : -xSSE4.2 -O2 -ip -ftz
 
 # Debugging flags
@@ -53,7 +53,6 @@ FCFLAGS  : -xSSE4.2 -O2 -ip -ftz
 [DEBUG]
 FC      : -g -traceback
 FCFLAGS : -xSSE2 -C -fpe0 
-IRPF90_FLAGS : --openmp
 
 # OpenMP flags
 #################

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 
+

plugins/All_singles/H_apply.irp.f

@@ -8,6 +8,13 @@ s.unset_skip()
 s.filter_only_1h1p()
 print s
 
+s = H_apply("just_1h_1p_singles",do_double_exc=False)
+s.set_selection_pt2("epstein_nesbet_2x2")
+s.unset_skip()
+s.filter_only_1h1p()
+print s
+
+
 s = H_apply("just_mono",do_double_exc=False)
 s.set_selection_pt2("epstein_nesbet_2x2")
 s.unset_skip()

plugins/All_singles/all_1h_1p.irp.f

@@ -49,7 +49,7 @@ subroutine routine
     endif
     call save_wavefunction
     if(n_det_before == N_det)then
-     selection_criterion = selection_criterion * 0.5d0
+     selection_criterion_factor = selection_criterion_factor * 0.5d0
     endif
     
   enddo

plugins/All_singles/all_1h_1p_singles.irp.f

@@ -0,0 +1,76 @@
+program restart_more_singles
+  BEGIN_DOC
+  ! Generates and select single and double excitations of type 1h-1p
+  ! on the top of a given restart wave function of type CAS
+  END_DOC
+  read_wf = .true.
+  touch read_wf 
+  print*,'ref_bitmask_energy = ',ref_bitmask_energy
+  call routine
+
+end 
+subroutine routine
+  implicit none
+  integer                        :: i,k
+  double precision, allocatable  :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:)
+  integer                        :: N_st, degree
+  integer :: n_det_before
+  N_st = N_states
+  allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
+  i = 0
+  print*,'N_det = ',N_det
+  print*,'n_det_max = ',n_det_max
+  print*,'pt2_max = ',pt2_max
+  pt2=-1.d0
+  E_before = ref_bitmask_energy
+  do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
+    n_det_before = N_det
+    i += 1
+    print*,'-----------------------'
+    print*,'i = ',i
+    call H_apply_just_1h_1p_singles(pt2, norm_pert, H_pert_diag,  N_st)
+    call diagonalize_CI
+    print*,'N_det = ',N_det
+    print*,'E        = ',CI_energy(1)
+    print*,'pt2      = ',pt2(1)
+    print*,'E+PT2    = ',E_before + pt2(1)
+    E_before = CI_energy
+    if(N_states_diag.gt.1)then
+     print*,'Variational Energy difference'
+     do i = 2, N_st
+      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_st
+      print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
+     enddo
+    endif
+    call save_wavefunction
+    if(n_det_before == N_det)then
+     selection_criterion_factor = selection_criterion_factor * 0.5d0
+    endif
+    
+  enddo
+
+  threshold_davidson = 1.d-10
+  soft_touch threshold_davidson davidson_criterion
+  call diagonalize_CI
+  if(N_states_diag.gt.1)then
+   print*,'Variational Energy difference'
+   do i = 2, N_st
+    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_st
+    print*,'Delta E = ',CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1))
+   enddo
+  endif
+  call ezfio_set_all_singles_energy(CI_energy)
+
+  call save_wavefunction
+  deallocate(pt2,norm_pert)
+end

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_selectors = max(threshold_selectors,threshold_selectors_pt2)
-    threshold_generators = 0.999d0
+    threshold_generators = max(threshold_generators,threshold_generators_pt2)
     call H_apply_CAS_SD_PT2(pt2, norm_pert, H_pert_diag,  N_st)
 
     print *,  'Final step'

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
+

plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES

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

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.

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
+

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) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
+ ! 
+ ! E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation 
+ !
+ ! coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
+ END_DOC
+ PROVIDE  ref_bitmask_energy psi_selectors ref_bitmask N_int psi_selectors
+ integer :: i,degree
+ double precision :: hij,diag_H_mat_elem
+ E_corr_double_only = 0.d0
+ E_corr_second_order = 0.d0
+ do i = 1, N_det_selectors
+  if(exc_degree_per_selectors(i)==2)then
+   call i_H_j(ref_bitmask,psi_selectors(1,1,i),N_int,hij)
+   i_H_HF_per_selectors(i) = hij
+   E_corr_per_selectors(i) = psi_selectors_coef(i,1) * hij
+   E_corr_double_only += E_corr_per_selectors(i)
+!  E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int))
+  elseif(exc_degree_per_selectors(i) == 0)then
+   coef_hf_selector = psi_selectors_coef(i,1)
+   E_corr_per_selectors(i) = -1000.d0
+   Delta_E_per_selector(i) = 0.d0
+  else
+   E_corr_per_selectors(i) = -1000.d0
+  endif
+ enddo
+ if (dabs(coef_hf_selector) > 1.d-8) then
+   inv_selectors_coef_hf = 1.d0/coef_hf_selector
+   inv_selectors_coef_hf_squared = inv_selectors_coef_hf * inv_selectors_coef_hf
+ else
+   inv_selectors_coef_hf = 0.d0
+   inv_selectors_coef_hf_squared = 0.d0
+ endif
+ do i = 1,n_double_selectors
+  E_corr_per_selectors(double_index_selectors(i)) *=inv_selectors_coef_hf
+ enddo
+ E_corr_double_only = E_corr_double_only * inv_selectors_coef_hf
+ END_PROVIDER

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
+

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
+

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

plugins/CAS_SD_ZMQ/selection.irp.f

@@ -1,3 +1,480 @@
+use bitmasks
+
+
+double precision function integral8(i,j,k,l)
+  implicit none
+  
+  integer, intent(in) :: i,j,k,l
+  double precision, external :: get_mo_bielec_integral
+  integer :: ii
+  ii = l-mo_integrals_cache_min
+  ii = ior(ii, k-mo_integrals_cache_min)
+  ii = ior(ii, j-mo_integrals_cache_min)
+  ii = ior(ii, i-mo_integrals_cache_min)
+  if (iand(ii, -64) /= 0) then
+    integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
+  else
+    ii = l-mo_integrals_cache_min
+    ii = ior( ishft(ii,6), k-mo_integrals_cache_min)
+    ii = ior( ishft(ii,6), j-mo_integrals_cache_min)
+    ii = ior( ishft(ii,6), i-mo_integrals_cache_min)
+    integral8 = mo_integrals_cache(ii)
+  endif
+end function
+
+
+BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)]
+  use bitmasks
+  implicit none
+  
+  integer :: i
+  do i=1, N_det
+    call get_mask_phase(psi_selectors(1,1,i), psi_phasemask(1,1,i))
+  end do
+END_PROVIDER
+
+
+subroutine assert(cond, msg)
+  character(*), intent(in) :: msg
+  logical, intent(in) :: cond
+  
+  if(.not. cond) then
+    print *, "assert fail: "//msg
+    stop
+  end if
+end subroutine
+
+
+subroutine get_mask_phase(det, phasemask)
+  use bitmasks
+  implicit none
+
+  integer(bit_kind), intent(in) :: det(N_int, 2)
+  integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2)
+  integer :: s, ni, i
+  logical :: change
+
+  phasemask = 0_1
+  do s=1,2
+    change = .false.
+    do ni=1,N_int
+      do i=0,bit_kind_size-1
+        if(BTEST(det(ni, s), i)) change = .not. change
+          if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1
+      end do
+    end do
+  end do
+end subroutine
+
+
+subroutine select_connected(i_generator,E0,pt2,b)
+  use bitmasks
+  use selection_types
+  implicit none
+  integer, intent(in)            :: i_generator
+  type(selection_buffer), intent(inout) :: b
+  double precision, intent(inout)  :: pt2(N_states)
+  integer :: k,l
+  double precision, intent(in)   :: E0(N_states)
+
+  integer(bit_kind)              :: hole_mask(N_int,2), particle_mask(N_int,2)
+  double precision               :: fock_diag_tmp(2,mo_tot_num+1)
+  
+  call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
+
+  do l=1,N_generators_bitmask
+    do k=1,N_int
+      hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator))
+      hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator))
+      particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) )
+      particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) )
+
+    enddo
+    call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b)
+    call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b)
+  enddo
+end subroutine
+
+
+double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2)
+  use bitmasks
+  implicit none
+
+  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
+  integer, intent(in) :: s1, s2, h1, h2, p1, p2
+  logical :: change
+  integer(1) :: np
+  double precision, parameter :: res(0:1) = (/1d0, -1d0/)
+
+  np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2)
+  if(p1 < h1) np = np + 1_1
+  if(p2 < h2) np = np + 1_1
+  
+  if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1
+  get_phase_bi = res(iand(np,1_1))
+end subroutine
+
+
+
+! Selection single
+! ----------------
+
+subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf)
+  use bitmasks
+  use selection_types
+  implicit none
+  BEGIN_DOC
+! Select determinants connected to i_det by H
+  END_DOC
+  integer, intent(in)             :: i_gen
+  integer(bit_kind), intent(in)   :: hole_mask(N_int,2), particle_mask(N_int,2)
+  double precision, intent(in)    :: fock_diag_tmp(mo_tot_num)
+  double precision, intent(in)    :: E0(N_states)
+  double precision, intent(inout) :: pt2(N_states)
+  type(selection_buffer), intent(inout) :: buf
+  
+  double precision                :: vect(N_states, mo_tot_num)
+  logical                         :: bannedOrb(mo_tot_num)
+  integer                         :: i, j, k
+  integer                         :: h1,h2,s1,s2,i1,i2,ib,sp
+  integer(bit_kind)               :: hole(N_int,2), particle(N_int,2), mask(N_int, 2)
+  logical                         :: fullMatch, ok
+  
+  
+  do k=1,N_int
+    hole    (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1))
+    hole    (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2))
+    particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1))
+    particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2))
+  enddo
+
+  ! Create lists of holes and particles
+  ! -----------------------------------
+
+  integer                        :: N_holes(2), N_particles(2)
+  integer                        :: hole_list(N_int*bit_kind_size,2)
+  integer                        :: particle_list(N_int*bit_kind_size,2)
+
+  call bitstring_to_list_ab(hole    , hole_list    , N_holes    , N_int)
+  call bitstring_to_list_ab(particle, particle_list, N_particles, N_int)
+
+  do sp=1,2
+    do i=1, N_holes(sp)
+      h1 = hole_list(i,sp)
+      call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int)
+      bannedOrb = .true.
+      do j=1,N_particles(sp)
+        bannedOrb(particle_list(j, sp)) = .false.
+      end do
+      call spot_hasBeen(mask, sp, psi_selectors, i_gen, N_det, bannedOrb, fullMatch)
+      if(fullMatch) cycle
+      vect = 0d0
+      call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect)
+      call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf)
+    end do
+  enddo
+end subroutine
+
+
+subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf)
+  use bitmasks
+  use selection_types
+  implicit none
+  
+  integer, intent(in) :: i_generator, sp, h1
+  double precision, intent(in) :: vect(N_states, mo_tot_num)
+  logical, intent(in) :: bannedOrb(mo_tot_num)
+  double precision, intent(in)           :: fock_diag_tmp(mo_tot_num)
+  double precision, intent(in)    :: E0(N_states)
+  double precision, intent(inout) :: pt2(N_states)
+  type(selection_buffer), intent(inout) :: buf
+  logical :: ok
+  integer :: s1, s2, p1, p2, ib, istate
+  integer(bit_kind) :: mask(N_int, 2), det(N_int, 2)
+  double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp
+  double precision, external :: diag_H_mat_elem_fock
+  
+  
+  call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int)
+  
+  do p1=1,mo_tot_num
+    if(bannedOrb(p1)) cycle
+    if(vect(1, p1) == 0d0) cycle
+    call apply_particle(mask, sp, p1, det, ok, N_int)
+    
+    Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
+    max_e_pert = 0d0
+    
+    do istate=1,N_states
+      val = vect(istate, p1) + vect(istate, p1)
+      delta_E = E0(istate) - Hii
+      tmp = dsqrt(delta_E * delta_E + val * val)
+      if (delta_E < 0.d0) then
+        tmp = -tmp
+      endif
+      e_pert = 0.5d0 * ( tmp - delta_E)
+      pt2(istate) += e_pert
+      if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert
+    end do
+    
+    if(dabs(max_e_pert) > buf%mini) then
+       call add_to_selection_buffer(buf, det, max_e_pert)
+     endif
+  end do
+end subroutine
+
+
+subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect)
+  use bitmasks
+  implicit none
+
+  integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel)
+  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel)
+  double precision, intent(in) :: coefs(N_states, N_sel)
+  integer, intent(in) :: sp, N_sel
+  logical, intent(inout) :: bannedOrb(mo_tot_num)
+  double precision, intent(inout)     :: vect(N_states, mo_tot_num)
+
+  integer :: i, j, h(0:2,2), p(0:3,2), nt
+  integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2)
+  
+  do i=1,N_int
+    negMask(i,1) = not(mask(i,1))
+    negMask(i,2) = not(mask(i,2))
+  end do
+
+  do i=1, N_sel
+    nt = 0
+    do j=1,N_int
+      mobMask(j,1) = iand(negMask(j,1), det(j,1,i))
+      mobMask(j,2) = iand(negMask(j,2), det(j,2,i))
+      nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
+    end do
+
+    if(nt > 3) cycle
+      
+    do j=1,N_int
+      perMask(j,1) = iand(mask(j,1), not(det(j,1,i)))
+      perMask(j,2) = iand(mask(j,2), not(det(j,2,i)))
+    end do
+
+    call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int)
+    call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int)
+
+    call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int)
+    call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int)
+    
+    if(nt == 3) then
+      call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i))
+    else if(nt == 2) then
+      call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i))
+    else
+      call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i))
+    end if
+  end do
+end subroutine
+
+
+subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
+  use bitmasks
+  implicit none
+  
+  integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
+  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
+  logical, intent(in) :: bannedOrb(mo_tot_num)
+  double precision, intent(in) :: coefs(N_states)
+  double precision, intent(inout) :: vect(N_states, mo_tot_num)
+  integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
+  integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti
+  double precision :: hij
+  double precision, external :: get_phase_bi, integral8
+  
+  integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
+  integer, parameter :: turn2(2) = (/2,1/) 
+  
+  if(h(0,sp) == 2) then
+    h1 = h(1, sp)
+    h2 = h(2, sp)
+    do i=1,3
+      puti = p(i, sp)
+      if(bannedOrb(puti)) cycle
+      p1 = p(turn3_2(1,i), sp)
+      p2 = p(turn3_2(2,i), sp)
+      hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2)
+      hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2)
+      vect(:, puti) += hij * coefs
+    end do
+  else if(h(0,sp) == 1) then
+    sfix = turn2(sp)
+    hfix = h(1,sfix)
+    pfix = p(1,sfix)
+    hmob = h(1,sp)
+    do j=1,2
+      puti = p(j, sp)
+      if(bannedOrb(puti)) cycle
+      pmob = p(turn2(j), sp)
+      hij = integral8(pfix, pmob, hfix, hmob)
+      hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix)
+      vect(:, puti) += hij * coefs
+    end do
+  else
+    puti = p(1,sp)
+    if(.not. bannedOrb(puti)) then
+      sfix = turn2(sp)
+      p1 = p(1,sfix)
+      p2 = p(2,sfix)
+      h1 = h(1,sfix)
+      h2 = h(2,sfix)
+      hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2))
+      hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2)
+      vect(:, puti) += hij * coefs
+    end if
+  end if
+end subroutine
+
+
+
+subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
+  use bitmasks
+  implicit none
+  
+  integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
+  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
+  logical, intent(in) :: bannedOrb(mo_tot_num)
+  double precision, intent(in) :: coefs(N_states)
+  double precision, intent(inout) :: vect(N_states, mo_tot_num)
+  integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
+  integer :: i, hole, p1, p2, sh
+  logical :: ok, lbanned(mo_tot_num)
+  integer(bit_kind) :: det(N_int, 2)
+  double precision :: hij
+  double precision, external :: get_phase_bi, integral8
+  
+  lbanned = bannedOrb
+  sh = 1
+  if(h(0,2) == 1) sh = 2
+  hole = h(1, sh)
+  lbanned(p(1,sp)) = .true.
+  if(p(0,sp) == 2) lbanned(p(2,sp)) = .true.
+  !print *, "SPm1", sp, sh
+  
+  p1 = p(1, sp)
+  
+  if(sp == sh) then
+    p2 = p(2, sp)
+    lbanned(p2) = .true.
+    
+    do i=1,hole-1
+      if(lbanned(i)) cycle
+      hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole))
+      hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2)
+      vect(:,i) += hij * coefs
+    end do
+    do i=hole+1,mo_tot_num
+      if(lbanned(i)) cycle
+      hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i))
+      hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2)
+      vect(:,i) += hij * coefs
+    end do
+
+    call apply_particle(mask, sp, p2, det, ok,  N_int)
+    call i_h_j(gen, det, N_int, hij)
+    vect(:, p2) += hij * coefs
+  else
+    p2 = p(1, sh)
+    do i=1,mo_tot_num
+      if(lbanned(i)) cycle
+      hij = integral8(p1, p2, i, hole)
+      hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2)
+      vect(:,i) += hij * coefs
+    end do
+  end if
+
+  call apply_particle(mask, sp, p1, det, ok,  N_int)
+  call i_h_j(gen, det, N_int, hij)
+  vect(:, p1) += hij * coefs
+end subroutine
+
+
+subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
+  use bitmasks
+  implicit none
+  
+  integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
+  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
+  logical, intent(in) :: bannedOrb(mo_tot_num)
+  double precision, intent(in) :: coefs(N_states)
+  double precision, intent(inout) :: vect(N_states, mo_tot_num)
+  integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
+  integer :: i
+  logical :: ok, lbanned(mo_tot_num)
+  integer(bit_kind) :: det(N_int, 2)
+  double precision :: hij
+  
+  lbanned = bannedOrb
+  lbanned(p(1,sp)) = .true.
+  do i=1,mo_tot_num
+    if(lbanned(i)) cycle
+    call apply_particle(mask, sp, i, det, ok, N_int)
+    call i_h_j(gen, det, N_int, hij)
+    vect(:, i) += hij * coefs
+  end do
+end subroutine
+
+
+subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch)
+  use bitmasks
+  implicit none
+  
+  integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N)
+  integer, intent(in) :: i_gen, N, sp
+  logical, intent(inout) :: banned(mo_tot_num)
+  logical, intent(out) :: fullMatch
+
+
+  integer :: i, j, na, nb, list(3), nt
+  integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2)
+
+  fullMatch = .false.
+
+  do i=1,N_int
+    negMask(i,1) = not(mask(i,1))
+    negMask(i,2) = not(mask(i,2))
+  end do
+
+  do i=1, N
+    nt = 0
+    
+    do j=1, N_int
+      myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1))
+      myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2))
+      nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2))
+    end do
+    
+    if(nt > 3) cycle
+    
+    if(nt <= 2 .and. i < i_gen) then
+      fullMatch = .true.
+      return
+    end if
+    
+    call bitstring_to_list(myMask(1,sp), list(1), na, N_int)
+    
+    if(nt == 3 .and. i < i_gen) then
+      do j=1,na
+        banned(list(j)) = .true.
+      end do
+    else if(nt == 1 .and. na == 1) then
+      banned(list(1)) = .true.
+    end if
+  end do 
+end subroutine
+
+
+
+
+! Selection double
+! ----------------
  
 subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf)
   use bitmasks
@@ -49,8 +526,8 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p
   do i=1,N_det
     nt = 0
     do j=1,N_int
-      mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i))
+      mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i))
-      mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i))
+      mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i))
       nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
     end do
 
@@ -83,19 +560,19 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p
         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,1) = iand(negMask(j,1), psi_selectors(j,1,i))
-          mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i))
+          mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i))
           nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
         end do
         
         if(nt <= 4) then
           interesting(0) += 1
           interesting(interesting(0)) = i
-          minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i)
+          minilist(:,:,interesting(0)) = psi_selectors(:,:,i)
           if(nt <= 2) then
             fullinteresting(0) += 1
             fullinteresting(fullinteresting(0)) = i
-            fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i)
+            fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i)
           end if
         end if
       end do
@@ -104,15 +581,15 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p
         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,1) = iand(negMask(j,1), psi_selectors(j,1,i))
-          mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i))
+          mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i))
           nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
         end do
 
         if(nt <= 2) then
           fullinteresting(0) += 1
           fullinteresting(fullinteresting(0)) = i
-          fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i)
+          fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i)
         end if
       end do
       
@@ -168,7 +645,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
   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 :: e_pert, delta_E, val, Hii, max_e_pert,tmp
   double precision, external :: diag_H_mat_elem_fock
   
   logical, external :: detEq
@@ -193,6 +670,10 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
       if(banned(p1,p2)) cycle
       if(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)
@@ -200,14 +681,14 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
       
       do istate=1,N_states
         delta_E = E0(istate) - Hii
-        val = mat(istate, p1, p2)
+        val = mat(istate, p1, p2) + mat(istate, p1, p2) 
+        tmp = dsqrt(delta_E * delta_E + val * val)
         if (delta_E < 0.d0) then
-          e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E)
+          tmp = -tmp
-        else
-          e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E)
         endif
-        pt2(istate) += e_pert
+        e_pert = 0.5d0 * ( tmp - delta_E)
-        if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert
+        pt2(istate) = pt2(istate) + e_pert
+        max_e_pert = min(e_pert,max_e_pert)
       end do
       
       if(dabs(max_e_pert) > buf%mini) then

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
+

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
+

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
+

plugins/DFT_Utils/EZFIO.cfg

@@ -0,0 +1,4 @@
+[energy]
+type: double precision
+doc: Calculated energy
+interface: ezfio

plugins/DFT_Utils/NEEDED_CHILDREN_MODULES

@@ -0,0 +1 @@
+Determinants 

plugins/DFT_Utils/grid_density.irp.f

@@ -0,0 +1,165 @@
+BEGIN_PROVIDER [integer, n_points_angular_grid]
+ implicit none
+ n_points_angular_grid = 50
+END_PROVIDER 
+
+BEGIN_PROVIDER [integer, n_points_radial_grid]
+ implicit none
+ n_points_radial_grid = 10000
+END_PROVIDER 
+
+
+ BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_angular_grid,3) ]
+&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_angular_grid)]
+ implicit none
+ BEGIN_DOC
+! weights and grid points for the integration on the angular variables on 
+! the unit sphere centered on (0,0,0)
+! According to the LEBEDEV scheme
+ END_DOC
+ call cal_quad(n_points_angular_grid, angular_quadrature_points,weights_angular_points)
+ include 'constants.include.F'
+ integer :: i
+ double precision :: accu
+ double precision :: degre_rad
+!degre_rad = 180.d0/pi
+!accu = 0.d0
+!do i = 1, n_points_integration_angular_lebedev
+! accu += weights_angular_integration_lebedev(i)
+! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 2.d0 * pi
+! angular_quadrature_points(i,1) = dcos ( degre_rad *  theta_angular_integration_lebedev(i)) & 
+!                                * dsin ( degre_rad *  phi_angular_integration_lebedev(i))
+! angular_quadrature_points(i,2) = dsin ( degre_rad *  theta_angular_integration_lebedev(i)) & 
+!                                * dsin ( degre_rad *  phi_angular_integration_lebedev(i))
+! angular_quadrature_points(i,3) = dcos ( degre_rad *  phi_angular_integration_lebedev(i))   
+!enddo
+!print*,'ANGULAR'
+!print*,''
+!print*,'accu = ',accu
+!ASSERT( dabs(accu - 1.D0) < 1.d-10)
+
+END_PROVIDER 
+
+BEGIN_PROVIDER [integer , m_knowles]
+ implicit none
+ BEGIN_DOC
+! value of the "m" parameter in the equation (7) of the paper of Knowles (JCP, 104, 1996)
+ END_DOC
+ m_knowles = 3
+END_PROVIDER 
+
+ BEGIN_PROVIDER [double precision, grid_points_radial, (n_points_radial_grid)]
+&BEGIN_PROVIDER [double precision, dr_radial_integral]
+
+ implicit none
+ BEGIN_DOC
+! points in [0,1] to map the radial integral [0,\infty] 
+ END_DOC
+ dr_radial_integral = 1.d0/dble(n_points_radial_grid-1)
+ integer :: i
+ do i = 1, n_points_radial_grid-1
+  grid_points_radial(i) = (i-1) * dr_radial_integral
+ enddo
+
+END_PROVIDER 
+
+BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid,n_points_radial_grid,nucl_num)]
+ BEGIN_DOC
+! points for integration over space
+ END_DOC
+ implicit none
+ integer :: i,j,k
+ double precision :: dr,x_ref,y_ref,z_ref
+ double precision :: knowles_function
+ do i = 1, nucl_num
+  x_ref = nucl_coord(i,1)
+  y_ref = nucl_coord(i,2)
+  z_ref = nucl_coord(i,3)
+  do j = 1, n_points_radial_grid-1
+   double precision :: x,r
+   x = grid_points_radial(j) ! x value for the mapping of the [0, +\infty] to [0,1]
+   r = knowles_function(alpha_knowles(int(nucl_charge(i))),m_knowles,x) ! value of the radial coordinate for the integration 
+   do k = 1, n_points_angular_grid  ! explicit values of the grid points centered around each atom 
+    grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r
+    grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r
+    grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r
+   enddo
+  enddo
+ enddo
+END_PROVIDER 
+
+BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
+ BEGIN_DOC 
+! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988)
+! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension 
+! and the points are labelled by the other dimensions
+ END_DOC
+ implicit none
+ integer :: i,j,k,l,m
+ double precision :: r(3)
+ double precision :: accu,cell_function_becke
+ double precision :: tmp_array(nucl_num)
+ ! run over all points in space
+  do j = 1, nucl_num  ! that are referred to each atom 
+   do k = 1, n_points_radial_grid -1  !for each radial grid attached to the "jth" atom
+    do l = 1, n_points_angular_grid ! for each angular point attached to the "jth" atom
+     r(1) = grid_points_per_atom(1,l,k,j)
+     r(2) = grid_points_per_atom(2,l,k,j)
+     r(3) = grid_points_per_atom(3,l,k,j)
+     accu = 0.d0
+     do i = 1, nucl_num ! For each of these points in space, ou need to evaluate the P_n(r)
+                        ! function defined for each atom "i" by equation (13) and (21) with k == 3
+      tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
+      ! Then you compute the summ the P_n(r) function for each of the "r" points
+      accu += tmp_array(i)
+     enddo
+     accu = 1.d0/accu
+     weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu 
+!    print*,weight_functions_at_grid_points(l,k,j)
+    enddo
+   enddo
+  enddo
+
+
+END_PROVIDER 
+
+ BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
+&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
+ implicit none
+ integer :: i,j,k,l,m
+ double precision :: contrib
+ double precision :: r(3)
+ double precision :: aos_array(ao_num),mos_array(mo_tot_num)
+  do j = 1, nucl_num
+   do k = 1, n_points_radial_grid -1
+    do l = 1, n_points_angular_grid
+     one_body_dm_mo_alpha_at_grid_points(l,k,j) = 0.d0
+     one_body_dm_mo_beta_at_grid_points(l,k,j) = 0.d0
+     r(1) = grid_points_per_atom(1,l,k,j)
+     r(2) = grid_points_per_atom(2,l,k,j)
+     r(3) = grid_points_per_atom(3,l,k,j)
+
+!    call give_all_aos_at_r(r,aos_array)
+!    do i = 1, ao_num
+!      do m = 1, ao_num
+!       contrib = aos_array(i) * aos_array(m)
+!       one_body_dm_mo_alpha_at_grid_points(l,k,j) +=  one_body_dm_ao_alpha(i,m) * contrib
+!       one_body_dm_mo_beta_at_grid_points(l,k,j) +=  one_body_dm_ao_beta(i,m)  * contrib
+!      enddo
+!    enddo
+
+     call give_all_mos_at_r(r,mos_array)
+     do i = 1, mo_tot_num
+      do m = 1, mo_tot_num
+       contrib = mos_array(i) * mos_array(m)
+       one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_mo_alpha(i,m) * contrib
+       one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_mo_beta(i,m) * contrib
+      enddo
+     enddo
+
+    enddo
+   enddo
+  enddo
+
+END_PROVIDER 
+

plugins/DFT_Utils/integration_3d.irp.f

@@ -0,0 +1,54 @@
+double precision function step_function_becke(x)
+ implicit none
+ double precision, intent(in) :: x
+ double precision :: f_function_becke
+ integer :: i,n_max_becke
+
+!if(x.lt.-1.d0)then
+! step_function_becke = 0.d0
+!else if (x .gt.1)then
+! step_function_becke = 0.d0
+!else 
+  step_function_becke = f_function_becke(x)
+!!n_max_becke = 1
+  do i = 1, 4
+   step_function_becke = f_function_becke(step_function_becke)
+  enddo
+  step_function_becke = 0.5d0*(1.d0 - step_function_becke)
+!endif
+end
+
+double precision function f_function_becke(x)
+ implicit none
+ double precision, intent(in) :: x
+ f_function_becke = 1.5d0 * x - 0.5d0 * x*x*x
+end
+
+double precision function cell_function_becke(r,atom_number)
+ implicit none
+ double precision, intent(in) :: r(3)
+ integer, intent(in) :: atom_number
+ BEGIN_DOC
+ ! atom_number :: atom on which the cell function of Becke (1988, JCP,88(4))
+ ! r(1:3) :: x,y,z coordinantes of the current point 
+ END_DOC
+ double precision :: mu_ij,nu_ij
+ double precision :: distance_i,distance_j,step_function_becke
+ integer :: j
+ distance_i = (r(1) - nucl_coord_transp(1,atom_number) ) * (r(1) - nucl_coord_transp(1,atom_number))  
+ distance_i += (r(2) - nucl_coord_transp(2,atom_number) ) * (r(2) - nucl_coord_transp(2,atom_number))  
+ distance_i += (r(3) - nucl_coord_transp(3,atom_number) ) * (r(3) - nucl_coord_transp(3,atom_number))
+ distance_i = dsqrt(distance_i)
+ cell_function_becke = 1.d0
+ do j = 1, nucl_num
+  if(j==atom_number)cycle
+  distance_j = (r(1) - nucl_coord_transp(1,j) ) * (r(1) - nucl_coord_transp(1,j))  
+  distance_j+= (r(2) - nucl_coord_transp(2,j) ) * (r(2) - nucl_coord_transp(2,j))  
+  distance_j+= (r(3) - nucl_coord_transp(3,j) ) * (r(3) - nucl_coord_transp(3,j))
+  distance_j = dsqrt(distance_j)
+  mu_ij = (distance_i - distance_j)/nucl_dist(atom_number,j)
+  nu_ij = mu_ij + slater_bragg_type_inter_distance_ua(atom_number,j) * (1.d0 - mu_ij*mu_ij)
+  cell_function_becke *= step_function_becke(nu_ij)
+ enddo
+end
+

plugins/DFT_Utils/integration_radial.irp.f

@@ -0,0 +1,109 @@
+ BEGIN_PROVIDER [ double precision, integral_density_alpha_knowles_becke_per_atom, (nucl_num)]
+&BEGIN_PROVIDER [ double precision, integral_density_beta_knowles_becke_per_atom, (nucl_num)]
+ implicit none
+ double precision :: accu
+ integer :: i,j,k,l
+ double precision :: x
+ double precision :: integrand(n_points_angular_grid), weights(n_points_angular_grid)
+ double precision :: f_average_angular_alpha,f_average_angular_beta
+ double precision :: derivative_knowles_function,knowles_function
+
+ ! Run over all nuclei in order to perform the Voronoi partition 
+ ! according ot equation (6) of the paper of Becke (JCP, (88), 1988)
+ ! Here the m index is referred to the w_m(r) weight functions of equation (22)
+   ! Run over all points of integrations : there are  
+   ! n_points_radial_grid (i) * n_points_angular_grid (k) 
+   do j = 1, nucl_num 
+    integral_density_alpha_knowles_becke_per_atom(j) = 0.d0
+    integral_density_beta_knowles_becke_per_atom(j) = 0.d0
+    do i = 1, n_points_radial_grid-1
+     ! Angular integration over the solid angle Omega for a FIXED angular coordinate "r"
+     f_average_angular_alpha = 0.d0
+     f_average_angular_beta = 0.d0
+     do k = 1, n_points_angular_grid
+      f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j)
+      f_average_angular_beta  += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j)  * weight_functions_at_grid_points(k,i,j)
+     enddo
+     ! 
+     x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
+     double precision ::  contrib_integration
+!    print*,m_knowles
+     contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) & 
+                          *knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2          
+     integral_density_alpha_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_alpha
+     integral_density_beta_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_beta
+    enddo
+    integral_density_alpha_knowles_becke_per_atom(j) *= dr_radial_integral
+    integral_density_beta_knowles_becke_per_atom(j) *= dr_radial_integral
+   enddo
+ 
+END_PROVIDER 
+
+ double precision function knowles_function(alpha,m,x)
+ implicit none
+ BEGIN_DOC
+! function proposed by Knowles (JCP, 104, 1996) for distributing the radial points : 
+! the Log "m" function ( equation (7) in the paper )
+ END_DOC
+ double precision, intent(in) :: alpha,x
+ integer, intent(in) :: m
+ knowles_function = -alpha * dlog(1.d0-x**m)
+ end
+
+ double precision function derivative_knowles_function(alpha,m,x)
+ implicit none
+ BEGIN_DOC
+! derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points
+ END_DOC
+ double precision, intent(in) :: alpha,x
+ integer, intent(in) :: m
+ derivative_knowles_function = alpha * dble(m) * x**(m-1) / (1.d0 - x**m)
+ end
+
+ BEGIN_PROVIDER [double precision, alpha_knowles, (100)]
+ implicit none
+ integer :: i
+ BEGIN_DOC
+! recommended values for the alpha parameters according to the paper of Knowles (JCP, 104, 1996)
+! as a function of the nuclear charge
+ END_DOC
+
+ ! H-He
+ alpha_knowles(1) = 5.d0 
+ alpha_knowles(2) = 5.d0 
+ 
+ ! Li-Be
+ alpha_knowles(3) = 7.d0 
+ alpha_knowles(4) = 7.d0 
+
+ ! B-Ne
+ do i = 5, 10
+  alpha_knowles(i) = 5.d0 
+ enddo
+
+ ! Na-Mg
+ do i = 11, 12
+  alpha_knowles(i) = 7.d0 
+ enddo
+
+ ! Al-Ar
+ do i = 13, 18
+  alpha_knowles(i) = 5.d0 
+ enddo
+
+ ! K-Ca 
+ do i = 19, 20
+  alpha_knowles(i) = 7.d0 
+ enddo
+
+ ! Sc-Zn
+ do i = 21, 30
+  alpha_knowles(i) = 5.d0 
+ enddo
+
+ ! Ga-Kr
+ do i = 31, 36
+  alpha_knowles(i) = 7.d0 
+ enddo
+
+ END_PROVIDER 

plugins/DFT_Utils/routines_roland.irp.f

@@ -0,0 +1,219 @@
+
+  subroutine cal_quad(n_quad, quad, weight)
+! --------------------------------------------------------------------------------
+! 
+! Arguments  : subroutine cal_quad
+! Description: evaluates quadrature points an weights
+! 
+! Authors    : B. Lévy, P. Pernot
+! Date       : 15 Nov 2000
+! --------------------------------------------------------------------------------
+  implicit none
+  integer, intent(in) :: n_quad
+  double precision, intent(out) :: weight(n_quad)
+  double precision, intent(out) :: quad(n_quad,3)
+  
+! local:
+    double precision, parameter :: zero=0.d0, one= 1.d0
+
+    double precision, parameter :: p=0.707106781186547462d0
+    double precision, parameter :: q=0.577350269189625842d0
+    double precision, parameter :: r=0.301511344577763629d0
+    double precision, parameter :: s=0.904534033733290888d0
+
+    double precision, parameter :: fourpi= 12.5663706143591725d0
+
+    double precision, parameter :: a6=0.166666666666666657d0
+    double precision, parameter :: a18=0.333333333333333329d-01
+    double precision, parameter :: b18=0.666666666666666657d-01
+    double precision, parameter :: a26=0.476190476190476164d-01
+    double precision, parameter :: b26=0.380952380952380987d-01
+    double precision, parameter :: c26=0.321428571428571397d-01
+    double precision, parameter :: a50=0.126984126984126984d-01
+    double precision, parameter :: b50=0.225749559082892431d-01
+    double precision, parameter :: c50=0.210937500000000014d-01
+    double precision, parameter :: d50=0.201733355379188697d-01
+
+    double precision            :: apt(3,6),bpt(3,12),cpt(3,8),dpt(3,24)
+    double precision            :: awght,bwght,cwght,dwght
+    double precision            :: s1, s2, s3
+    integer             :: idim, ipt, i1, i2, i3, is1, is2, is3
+    integer             :: iquad
+
+! begin:
+! l_here ='cal_quad'
+! call enter (l_here,3)
+
+! verifications:
+!   message = 'in '//trim(l_here)//', number of dimensions='//&
+!             trim(encode(dimensions_nb))//', must be 3'
+!   call ensure(message, dimensions_nb .eq. 3 )
+
+!   message = 'in '//trim(l_here)//', invalid number of quadrature points ='&
+!             //trim(encode(n_quad))
+!   call ensure(message,(n_quad-2)*(n_quad-6)*(n_quad-18)*(n_quad-26)*(n_quad-50) .eq. 0)
+
+! initialize weights
+    awght = zero
+    bwght = zero
+    cwght = zero
+    dwght = zero
+
+! type A points : (+/-1,0,0)
+    awght=a6*fourpi
+    ipt= 1
+    apt=0.
+    do idim = 1, 3
+      apt(idim,ipt)=one
+      ipt=ipt+1
+      apt(idim,ipt)=-one
+      ipt=ipt+1
+    enddo     
+
+! type B points : (+/-p,+/-p,0) with p= 1/sqrt(2)
+    if(n_quad.gt.6) then
+
+      awght=a18*fourpi
+      bwght=b18*fourpi
+
+      s1=p
+      s2=p
+      ipt= 1
+      bpt=0.
+      do idim = 1, 3
+        i1=idim+1
+        if(i1.gt.3) i1=i1-3
+        i2=idim+2
+        if(i2.gt.3) i2=i2-3
+        do is1= 1,2
+          do is2= 1,2
+            bpt(i1,ipt)=s1
+            bpt(i2,ipt)=s2
+            s2=-s2
+            ipt=ipt+1
+          enddo      
+          s1=-s1
+        enddo       
+      enddo    
+    endif
+
+! type C points : (+/-q,+/-q,+/-q) with q= 1/sqrt(3)
+   if(n_quad.gt.18) then
+
+      awght=a26*fourpi
+      bwght=b26*fourpi
+      cwght=c26*fourpi
+
+      s1=q
+      s2=q
+      s3=q
+      ipt= 1
+      cpt=0.
+      do is1= 1,2
+        do is2= 1,2
+          do is3= 1,2
+            cpt(1,ipt)=s1
+            cpt(2,ipt)=s2
+            cpt(3,ipt)=s3
+            s3=-s3
+            ipt=ipt+1
+          enddo       
+          s2=-s2
+        enddo       
+        s1=-s1
+      enddo    
+    endif
+
+! type D points : (+/-r,+/-r,+/-s)
+    if(n_quad.gt.26) then
+
+      awght=a50*fourpi
+      bwght=b50*fourpi
+      cwght=c50*fourpi
+      dwght=d50*fourpi
+
+      ipt= 1
+      dpt=0.
+      do i1= 1, 3
+        s1=s
+        s2=r
+        s3=r
+        i2=i1+1
+        if(i2.gt.3) i2=i2-3
+        i3=i1+2
+        if(i3.gt.3) i3=i3-3
+        do is1= 1,2
+          do is2= 1,2
+            do is3= 1,2
+              dpt(i1,ipt)=s1
+              dpt(i2,ipt)=s2
+              dpt(i3,ipt)=s3
+              s3=-s3
+              ipt=ipt+1
+            enddo         
+            s2=-s2
+          enddo        
+          s1=-s1
+        enddo         
+      enddo     
+    endif
+
+! fill the points and weights tables
+    iquad= 1
+    do ipt= 1, 6
+      do idim = 1, 3
+        quad(iquad,idim)=apt(idim,ipt)
+      enddo
+      weight(iquad)=awght
+      iquad=iquad+1
+    enddo     
+
+    if(n_quad.gt.6) then
+      do ipt= 1,12
+        do idim = 1, 3
+          quad(iquad,idim)=bpt(idim,ipt)
+        enddo
+        weight(iquad)=bwght
+        iquad=iquad+1
+      enddo            
+    endif
+
+    if(n_quad.gt.18) then
+      do ipt= 1,8
+        do idim = 1, 3
+          quad(iquad,idim)=cpt(idim,ipt)
+        enddo
+        weight(iquad)=cwght
+        iquad=iquad+1
+      enddo            
+    endif
+
+    if(n_quad.gt.26) then
+      do ipt= 1,24
+        do idim = 1, 3
+          quad(iquad,idim)=dpt(idim,ipt)
+        enddo
+        weight(iquad)=dwght
+        iquad=iquad+1
+      enddo            
+    endif
+
+!   if (debug) then
+!     write(6,*)
+!     write(6,'(1X,a)') trim(l_here)//'-d : '//&
+!       '------------------------------------------------------'
+!     write(6,'(1X,a)') trim(l_here)//'-d : '//'  I    Weight      Quad_points'
+!     write(6,'(1X,a)') trim(l_here)//'-d : '//&
+!       '-----  ----------  -----------------------------------'
+!     do iquad= 1, n_quad
+!        write(6,'(1X,A,i5,4e12.3)') trim(l_here)//'-d : ',&
+!          iquad,weight(iquad),quad(iquad,1:3)
+!     enddo
+!     write(6,'(1X,a)') trim(l_here)//'-d : '//&
+!       '------------------------------------------------------'
+!     write(6,*)
+!   endif
+
+! call exit (l_here,3)
+
+  end subroutine cal_quad

plugins/DFT_Utils/test_integration_3d_density.irp.f

@@ -0,0 +1,24 @@
+program pouet
+ print*,'coucou'
+ read_wf = .True.
+ touch read_wf
+ print*,'m_knowles = ',m_knowles
+ call routine
+
+end
+subroutine routine
+ implicit none
+ integer :: i
+ double precision :: accu(2)
+ accu = 0.d0
+ do i = 1, nucl_num
+  accu(1) += integral_density_alpha_knowles_becke_per_atom(i)
+  accu(2) += integral_density_beta_knowles_becke_per_atom(i)
+ enddo
+ print*,'accu(1) = ',accu(1)
+ print*,'Nalpha  = ',elec_alpha_num
+ print*,'accu(2) = ',accu(2)
+ print*,'Nalpha  = ',elec_beta_num
+
+
+end

plugins/FOBOCI/EZFIO.cfg

@@ -19,10 +19,15 @@ default: 0.00001
 
 [do_it_perturbative]
 type: logical
-doc: if true, you do the FOBOCI calculation perturbatively 
+doc: if true, when a given 1h or 1p determinant is not selected because of its perturbation estimate, then if its coefficient is lower than threshold_perturbative, it is acounted in the FOBOCI differential density matrices
 interface: ezfio,provider,ocaml
 default: .False.
 
+[threshold_perturbative]
+type: double precision
+doc: when do_it_perturbative is True, threshold_perturbative select if a given determinant ia selected or not for beign taken into account in the FOBO-SCF treatment. In practive, if the coefficient is larger then threshold_perturbative it means that it not selected as the perturbation should not be too importan. A value of 0.01 is in general OK.
+interface: ezfio,provider,ocaml
+default: 0.001
 
 [speed_up_convergence_foboscf]
 type: logical
@@ -49,3 +54,9 @@ doc: if true, you do all 2p type excitation on the LMCT
 interface: ezfio,provider,ocaml
 default: .True.
 
+[selected_fobo_ci]
+type: logical
+doc: if true, for each CI step you will run a CIPSI calculation that stops at  pt2_max 
+interface: ezfio,provider,ocaml
+default: .False.
+

plugins/FOBOCI/SC2_1h1p.irp.f

@@ -0,0 +1,889 @@
+subroutine dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! CISD+SC2 method              :: take off all the disconnected terms of a ROHF+1h1p (selected or not)
+  !
+  ! 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
+  !
+  ! Initial guess vectors are not necessarily orthonormal
+  END_DOC
+  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(in)   :: convergence
+  
+  integer :: i,j,k,l
+  integer :: n_singles
+  integer :: index_singles(sze),hole_particles_singles(sze,3)
+  integer :: n_doubles
+  integer :: index_doubles(sze),hole_particles_doubles(sze,2)
+  integer :: index_hf
+  double precision :: e_corr_singles(mo_tot_num,2)
+  double precision :: e_corr_doubles(mo_tot_num)
+  double precision :: e_corr_singles_total(2)
+  double precision :: e_corr_doubles_1h1p
+
+  integer :: exc(0:2,2,2),degree
+  integer :: h1,h2,p1,p2,s1,s2
+  integer :: other_spin(2)
+  double precision :: phase
+  integer(bit_kind) :: key_tmp(N_int,2)
+  integer :: i_ok
+  double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral
+  double precision :: hij,c_ref,contrib
+  integer :: iorb
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  n_singles = 0
+  n_doubles = 0
+  do i = 1,sze
+   call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   call i_H_j(dets_in(1,1,i),dets_in(1,1,i),N_int,hij)
+   diag_H_elements(i) = hij
+   if(degree == 0)then
+    index_hf = i
+   else if (degree == 1)then
+    n_singles +=1
+    index_singles(n_singles) = i
+    ! h1 = inactive orbital of the hole
+    hole_particles_singles(n_singles,1) = h1
+    ! p1 = virtual orbital of the particle
+    hole_particles_singles(n_singles,2) = p1
+    ! s1 = spin of the electron excited
+    hole_particles_singles(n_singles,3) = s1
+   else if (degree == 2)then
+    n_doubles +=1
+    index_doubles(n_doubles) = i
+    ! h1 = inactive orbital of the hole (beta of course)
+    hole_particles_doubles(n_doubles,1) = h1
+    ! p1 = virtual orbital of the particle (alpha of course)
+    hole_particles_doubles(n_doubles,2) = p2
+   else 
+    print*,'PB !! found out other thing than a single or double'
+    print*,'stopping ..'
+    stop
+   endif
+  enddo
+
+  e_corr_singles = 0.d0
+  e_corr_doubles = 0.d0
+  e_corr_singles_total = 0.d0
+  e_corr_doubles_1h1p = 0.d0
+  c_ref = 1.d0/u_in(index_hf,1)
+  print*,'c_ref = ',c_ref
+  do i = 1,sze
+   call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   call i_H_j(ref_bitmask,dets_in(1,1,i),N_int,hij)
+   contrib = hij * u_in(i,1) * c_ref
+   if (degree == 1)then
+    e_corr_singles(h1,s1) += contrib
+    e_corr_singles(p1,s1) += contrib
+    e_corr_singles_total(s1)+= contrib
+   else if (degree == 2)then
+    e_corr_doubles_1h1p += contrib
+    e_corr_doubles(h1) += contrib
+    e_corr_doubles(p2) += contrib
+   endif
+  enddo
+  print*,'e_corr_singles alpha = ',e_corr_singles_total(1)
+  print*,'e_corr_singles beta  = ',e_corr_singles_total(2)
+  print*,'e_corr_doubles_1h1p  = ',e_corr_doubles_1h1p
+  
+  ! repeat all the correlation energy on the singles
+  do i = 1,n_singles
+   ! you can repeat all the correlation energy of the single excitation of the other spin
+   diag_H_elements(index_singles(i)) += e_corr_singles_total(other_spin(hole_particles_singles(i,3)))
+
+   ! you can repeat all the correlation energy of the single excitation of the same spin
+   do j = 1, n_inact_orb
+    iorb = list_inact(j)
+    ! except the one of the hole
+    if(iorb == hole_particles_singles(i,1))cycle
+    ! ispin = hole_particles_singles(i,3)
+    diag_H_elements(index_singles(i)) += e_corr_singles(iorb,hole_particles_singles(i,3))
+   enddo
+   ! also exclude all the energy coming from the virtual orbital
+   diag_H_elements(index_singles(i)) -= e_corr_singles(hole_particles_singles(i,2),hole_particles_singles(i,3))
+ 
+   ! If it is a single excitation alpha, you can repeat : 
+   !  +) all the double excitation 1h1p, appart the part involving the virtual orbital "r"
+   ! If it is a single excitation alpha, you can repeat : 
+   !  +) all the double excitation 1h1p, appart the part involving the inactive orbital "i"
+   diag_H_elements(index_singles(i)) += e_corr_doubles_1h1p
+   if(hole_particles_singles(i,3) == 1)then  ! alpha single excitation
+    diag_H_elements(index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,2))
+   else  ! beta single exctitation 
+    diag_H_elements(index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,1))
+   endif
+  enddo
+
+  ! repeat all the correlation energy on the doubles
+  ! as all the doubles involve the active space, you cannot repeat any of them one on another
+  do i = 1, n_doubles
+   ! on a given double, you can repeat all the correlation energy of the singles alpha 
+   do j = 1, n_inact_orb
+    iorb = list_inact(j)
+    ! ispin = hole_particles_singles(i,3)
+    diag_H_elements(index_doubles(i)) += e_corr_singles(iorb,1)
+   enddo
+   ! except the part involving the virtual orbital "hole_particles_doubles(i,2)"
+   diag_H_elements(index_doubles(i)) -= e_corr_singles(hole_particles_doubles(i,2),1)
+   ! on a given double, you can repeat all the correlation energy of the singles beta
+   do j = 1, n_inact_orb
+    iorb = list_inact(j)
+    ! except the one of the hole
+    if(iorb == hole_particles_doubles(i,1))cycle
+    ! ispin = hole_particles_singles(i,3)
+    diag_H_elements(index_doubles(i)) += e_corr_singles(iorb,2)
+   enddo
+  enddo
+
+
+  ! Taking into account the connected part of the 2h2p on the HF determinant 
+  ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma}
+  
+! diag_H_elements(index_hf) += total_corr_e_2h2p
+  return
+  c_ref = c_ref * c_ref
+  print*,'diag_H_elements(index_hf) = ',diag_H_elements(index_hf)
+  do i = 1, n_singles
+   ! start on the single excitation "|i>"
+   h1 = hole_particles_singles(i,1)
+   p1 = hole_particles_singles(i,2)
+   do j = 1, n_singles
+    do k = 1, N_int
+     key_tmp(k,1) = dets_in(k,1,index_singles(i))
+     key_tmp(k,2) = dets_in(k,2,index_singles(i))
+    enddo
+    h2 = hole_particles_singles(j,1)
+    p2 = hole_particles_singles(j,2)
+    call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok)    
+    ! apply the excitation operator from the single excitation "|j>"
+    if(i_ok .ne. 1)cycle
+    double precision :: phase_ref_other_single,diag_H_mat_elem,hijj,contrib_e2,coef_1
+    call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_single_double,N_int)
+    call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_ref_other_single,N_int)
+    call i_H_j(ref_bitmask,key_tmp,N_int,hij)
+    diag_H_elements(index_hf) += u_in(index_singles(i),1) * u_in(index_singles(j),1) * c_ref * hij & 
+                                * phase_single_double * phase_ref_other_single
+   enddo
+  enddo
+  print*,'diag_H_elements(index_hf) = ',diag_H_elements(index_hf)
+
+end
+
+
+subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! CISD+SC2 method              :: take off all the disconnected terms of a ROHF+1h1p (selected or not)
+  !
+  ! 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
+  !
+  ! Initial guess vectors are not necessarily orthonormal
+  END_DOC
+  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(0:dim_in)
+  double precision, intent(in)   :: convergence
+  
+  integer :: i,j,k,l
+  integer :: r,s,i0,j0,r0,s0
+  integer :: n_singles
+  integer :: index_singles(sze),hole_particles_singles(sze,3)
+  integer :: n_doubles
+  integer :: index_doubles(sze),hole_particles_doubles(sze,2)
+  integer :: index_hf
+  double precision :: e_corr_singles(mo_tot_num,2)
+  double precision :: e_corr_doubles(mo_tot_num)
+  double precision :: e_corr_singles_total(2)
+  double precision :: e_corr_doubles_1h1p
+
+  integer :: exc(0:2,2,2),degree
+  integer :: h1,h2,p1,p2,s1,s2
+  integer :: other_spin(2)
+  double precision :: phase
+  integer(bit_kind) :: key_tmp(N_int,2)
+  integer :: i_ok
+  double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral
+  double precision :: hij,c_ref,contrib
+  integer :: iorb
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  n_singles = 0
+  n_doubles = 0
+  do i = 1,sze
+   call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   call i_H_j(dets_in(1,1,i),dets_in(1,1,i),N_int,hij)
+   diag_H_elements(i) = hij
+   if(degree == 0)then
+    index_hf = i
+   else if (degree == 1)then
+    n_singles +=1
+    index_singles(n_singles) = i
+    ! h1 = inactive orbital of the hole
+    hole_particles_singles(n_singles,1) = h1
+    ! p1 = virtual orbital of the particle
+    hole_particles_singles(n_singles,2) = p1
+    ! s1 = spin of the electron excited
+    hole_particles_singles(n_singles,3) = s1
+   else if (degree == 2)then
+    n_doubles +=1
+    index_doubles(n_doubles) = i
+    ! h1 = inactive orbital of the hole (beta of course)
+    hole_particles_doubles(n_doubles,1) = h1
+    ! p1 = virtual orbital of the particle (alpha of course)
+    hole_particles_doubles(n_doubles,2) = p2
+   else 
+    print*,'PB !! found out other thing than a single or double'
+    print*,'stopping ..'
+    stop
+   endif
+  enddo
+  double precision :: delta_e
+  double precision :: coef_ijrs
+  diag_H_elements = 0.d0
+  do i0 = 1, n_core_inact_orb
+   i= list_core_inact(i0)
+   do j0 = i0+1, n_core_inact_orb
+    j = list_core_inact(j0)
+    print*, i,j
+    do r0 = 1, n_virt_orb
+     r = list_virt(r0)
+     do s0 = r0+1, n_virt_orb
+      s = list_virt(s0)
+     !!! alpha (i-->r) / beta (j-->s)
+      s1 = 1
+      s2 = 2
+      key_tmp = ref_bitmask
+      call do_mono_excitation(key_tmp,i,r,s1,i_ok)
+      if(i_ok .ne.1)then
+       print*, 'pb !!'
+       stop
+      endif
+      call do_mono_excitation(key_tmp,j,s,s2,i_ok)
+      if(i_ok .ne.1)then
+       print*, 'pb !!'
+       stop
+      endif
+      call i_H_j(ref_bitmask, key_tmp, N_int,hij)
+      delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s)
+      coef_ijrs = hij/delta_e
+      do k = 1, n_singles
+       l = index_singles(k) 
+       call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij)
+       diag_H_elements(l) += coef_ijrs * hij
+      enddo
+     !if(i>j.and.r>s)then
+       !! alpha (i-->r) / alpha (j-->s)
+       s1 = 1
+       s2 = 1
+       key_tmp = ref_bitmask
+       call do_mono_excitation(key_tmp,i,r,s1,i_ok)
+       if(i_ok .ne.1)then
+        print*, 'pb !!'
+        stop
+       endif
+       call do_mono_excitation(key_tmp,j,s,s2,i_ok)
+       if(i_ok .ne.1)then
+        print*, 'pb !!'
+        stop
+       endif
+       call i_H_j(ref_bitmask, key_tmp, N_int,hij)
+       delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s)
+       coef_ijrs = hij/delta_e
+       do k = 1, n_singles
+        l = index_singles(k) 
+        call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij)
+        diag_H_elements(l) += coef_ijrs * hij
+       enddo
+       !! beta (i-->r) / beta (j-->s)
+       s1 = 2
+       s2 = 2
+       key_tmp = ref_bitmask
+       call do_mono_excitation(key_tmp,i,r,s1,i_ok)
+       if(i_ok .ne.1)then
+        print*, 'pb !!'
+        stop
+       endif
+       call do_mono_excitation(key_tmp,j,s,s2,i_ok)
+       if(i_ok .ne.1)then
+        print*, 'pb !!'
+        stop
+       endif
+       call i_H_j(ref_bitmask, key_tmp, N_int,hij)
+       delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s)
+       coef_ijrs = hij/delta_e
+       do k = 1, n_singles
+        l = index_singles(k) 
+        call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij)
+        diag_H_elements(l) += coef_ijrs * hij
+       enddo
+     !endif
+     enddo
+    enddo
+   enddo
+  enddo
+  c_ref = 1.d0/u_in(index_hf,1)
+  do k = 1, n_singles
+   l = index_singles(k)
+   diag_H_elements(0) -= diag_H_elements(l)
+  enddo
+! do k = 1, n_doubles
+!  l = index_doubles(k)
+!  diag_H_elements(0) += diag_H_elements(l)
+! enddo
+
+
+end
+  
+
+subroutine dressing_1h1p_full(dets_in,u_in,H_matrix,dim_in,sze,N_st,Nint,convergence)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! CISD+SC2 method              :: take off all the disconnected terms of a ROHF+1h1p (selected or not)
+  !
+  ! 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
+  !
+  ! Initial guess vectors are not necessarily orthonormal
+  END_DOC
+  integer, intent(in)            :: dim_in, sze, N_st, Nint
+  integer(bit_kind), intent(in)  :: dets_in(Nint,2,sze)
+  double precision, intent(in) :: u_in(dim_in,N_st)
+  double precision, intent(inout)  :: H_matrix(sze,sze)
+  double precision, intent(in)   :: convergence
+  
+  integer :: i,j,k,l
+  integer :: n_singles
+  integer :: index_singles(sze),hole_particles_singles(sze,3)
+  integer :: n_doubles
+  integer :: index_doubles(sze),hole_particles_doubles(sze,2)
+  integer :: index_hf
+  double precision :: e_corr_singles(mo_tot_num,2)
+  double precision :: e_corr_doubles(mo_tot_num)
+  double precision :: e_corr_singles_total(2)
+  double precision :: e_corr_doubles_1h1p
+
+  integer :: exc(0:2,2,2),degree
+  integer :: h1,h2,p1,p2,s1,s2
+  integer :: other_spin(2)
+  double precision :: phase
+  integer(bit_kind) :: key_tmp(N_int,2)
+  integer :: i_ok
+  double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral
+  double precision :: hij,c_ref,contrib
+  integer :: iorb
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  n_singles = 0
+  n_doubles = 0
+  do i = 1,sze
+   call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   if(degree == 0)then
+    index_hf = i
+   else if (degree == 1)then
+    n_singles +=1
+    index_singles(n_singles) = i
+    ! h1 = inactive orbital of the hole
+    hole_particles_singles(n_singles,1) = h1
+    ! p1 = virtual orbital of the particle
+    hole_particles_singles(n_singles,2) = p1
+    ! s1 = spin of the electron excited
+    hole_particles_singles(n_singles,3) = s1
+   else if (degree == 2)then
+    n_doubles +=1
+    index_doubles(n_doubles) = i
+    ! h1 = inactive orbital of the hole (beta of course)
+    hole_particles_doubles(n_doubles,1) = h1
+    ! p1 = virtual orbital of the particle (alpha of course)
+    hole_particles_doubles(n_doubles,2) = p2
+   else 
+    print*,'PB !! found out other thing than a single or double'
+    print*,'stopping ..'
+    stop
+   endif
+  enddo
+  double precision, allocatable :: dressing_H_mat_elem(:)
+  allocate(dressing_H_mat_elem(N_det))
+  logical :: lmct
+  dressing_H_mat_elem = 0.d0
+  call dress_diag_elem_2h2p(dressing_H_mat_elem,N_det)
+  lmct = .False.
+  call dress_diag_elem_2h1p(dressing_H_mat_elem,N_det,lmct,1000)
+  lmct = .true.
+  call dress_diag_elem_1h2p(dressing_H_mat_elem,N_det,lmct,1000)
+  do i = 1, N_det
+   H_matrix(i,i) += dressing_H_mat_elem(i)
+  enddo
+
+  e_corr_singles = 0.d0
+  e_corr_doubles = 0.d0
+  e_corr_singles_total = 0.d0
+  e_corr_doubles_1h1p = 0.d0
+  c_ref = 1.d0/u_in(index_hf,1)
+  print*,'c_ref = ',c_ref
+  do i = 1,sze
+   call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   call i_H_j(ref_bitmask,dets_in(1,1,i),N_int,hij)
+   contrib = hij * u_in(i,1) * c_ref
+   if (degree == 1)then
+    e_corr_singles(h1,s1) += contrib
+    e_corr_singles(p1,s1) += contrib
+    e_corr_singles_total(s1)+= contrib
+   else if (degree == 2)then
+    e_corr_doubles_1h1p += contrib
+    e_corr_doubles(h1) += contrib
+    e_corr_doubles(p2) += contrib
+   endif
+  enddo
+  print*,'e_corr_singles alpha = ',e_corr_singles_total(1)
+  print*,'e_corr_singles beta  = ',e_corr_singles_total(2)
+  print*,'e_corr_doubles_1h1p  = ',e_corr_doubles_1h1p
+ 
+  
+  ! repeat all the correlation energy on the singles
+! do i = 1,n_singles
+!  ! you can repeat all the correlation energy of the single excitation of the other spin
+!  H_matrix(index_singles(i),index_singles(i)) += e_corr_singles_total(other_spin(hole_particles_singles(i,3)))
+
+!  ! you can repeat all the correlation energy of the single excitation of the same spin
+!  do j = 1, n_inact_orb
+!   iorb = list_inact(j)
+!   ! except the one of the hole
+!   if(iorb == hole_particles_singles(i,1))cycle
+!   ! ispin = hole_particles_singles(i,3)
+!   H_matrix(index_singles(i),index_singles(i)) += e_corr_singles(iorb,hole_particles_singles(i,3))
+!  enddo
+!  ! also exclude all the energy coming from the virtual orbital
+!  H_matrix(index_singles(i),index_singles(i)) -= e_corr_singles(hole_particles_singles(i,2),hole_particles_singles(i,3))
+!
+!  ! If it is a single excitation alpha, you can repeat : 
+!  !  +) all the double excitation 1h1p, appart the part involving the virtual orbital "r"
+!  ! If it is a single excitation alpha, you can repeat : 
+!  !  +) all the double excitation 1h1p, appart the part involving the inactive orbital "i"
+!  H_matrix(index_singles(i),index_singles(i)) += e_corr_doubles_1h1p
+!  if(hole_particles_singles(i,3) == 1)then  ! alpha single excitation
+!   H_matrix(index_singles(i),index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,2))
+!  else  ! beta single exctitation 
+!   H_matrix(index_singles(i),index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,1))
+!  endif
+! enddo
+
+! ! repeat all the correlation energy on the doubles
+! ! as all the doubles involve the active space, you cannot repeat any of them one on another
+! do i = 1, n_doubles
+!  ! on a given double, you can repeat all the correlation energy of the singles alpha 
+!  do j = 1, n_inact_orb
+!   iorb = list_inact(j)
+!   ! ispin = hole_particles_singles(i,3)
+!   H_matrix(index_doubles(i),index_doubles(i)) += e_corr_singles(iorb,1)
+!  enddo
+!  ! except the part involving the virtual orbital "hole_particles_doubles(i,2)"
+!  H_matrix(index_doubles(i),index_doubles(i)) -= e_corr_singles(hole_particles_doubles(i,2),1)
+!  ! on a given double, you can repeat all the correlation energy of the singles beta
+!  do j = 1, n_inact_orb
+!   iorb = list_inact(j)
+!   ! except the one of the hole
+!   if(iorb == hole_particles_doubles(i,1))cycle
+!   ! ispin = hole_particles_singles(i,3)
+!   H_matrix(index_doubles(i),index_doubles(i)) += e_corr_singles(iorb,2)
+!  enddo
+! enddo
+
+
+  ! Taking into account the connected part of the 2h2p on the HF determinant 
+  ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma}
+  
+! H_matrix(index_hf) += total_corr_e_2h2p
+  print*,'H_matrix(index_hf,index_hf) = ',H_matrix(index_hf,index_hf)
+  do i = 1, n_singles
+   ! start on the single excitation "|i>"
+   h1 = hole_particles_singles(i,1)
+   p1 = hole_particles_singles(i,2)
+   print*,'i = ',i
+   do j = i+1, n_singles
+    do k = 1, N_int
+     key_tmp(k,1) = dets_in(k,1,index_singles(i))
+     key_tmp(k,2) = dets_in(k,2,index_singles(i))
+    enddo
+    h2 = hole_particles_singles(j,1)
+    p2 = hole_particles_singles(j,2)
+    call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok)    
+    ! apply the excitation operator from the single excitation "|j>"
+    if(i_ok .ne. 1)cycle
+    double precision :: H_array(sze),diag_H_mat_elem,hjj
+    do k = 1, sze
+     call get_excitation_degree(dets_in(1,1,k),key_tmp,degree,N_int)
+     H_array(k) = 0.d0
+     if(degree > 2)cycle
+     call i_H_j(dets_in(1,1,k),key_tmp,N_int,hij)
+     H_array(k) = hij
+    enddo
+    hjj = 1.d0/(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
+!   contrib_e2 = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * hij * hij))
+    do l = 2, sze
+!    pause
+     H_matrix(l,l) += H_array(l) * H_array(l) * hjj
+!    H_matrix(1,l) += H_array(1) * H_array(l) * hjj
+!    H_matrix(l,1) += H_array(1) * H_array(l) * hjj
+    enddo
+   enddo
+  enddo
+  print*,'H_matrix(index_hf,index_hf) = ',H_matrix(index_hf,index_hf)
+
+end
+
+subroutine SC2_1h1p_full(dets_in,u_in,energies,H_matrix,dim_in,sze,N_st,Nint,convergence)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! CISD+SC2 method              :: take off all the disconnected terms of a CISD (selected or not)
+  !
+  ! 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
+  !
+  ! Initial guess vectors are not necessarily orthonormal
+  END_DOC
+  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)  :: energies(N_st)
+  double precision, intent(out)  :: H_matrix(sze,sze)
+  double precision, intent(in)   :: convergence
+  integer :: i,j,iter
+  print*,'sze = ',sze
+  H_matrix = 0.d0
+  do iter = 1, 1
+!   if(sze<=N_det_max_jacobi)then
+      double precision, allocatable  :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:)
+      allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze))
+      H_matrix_tmp = 0.d0
+      call dressing_1h1p_full(dets_in,u_in,H_matrix_tmp,dim_in,sze,N_st,Nint,convergence)
+      do j=1,sze
+        do i=1,sze
+          H_matrix_tmp(i,j) += H_matrix_all_dets(i,j)
+        enddo
+      enddo
+      print*,'passed the dressing'
+      call lapack_diag(eigenvalues,eigenvectors,                     &
+          H_matrix_tmp,size(H_matrix_all_dets,1),sze)
+      do j=1,min(N_states_diag,sze)
+        do i=1,sze
+          u_in(i,j) = eigenvectors(i,j)
+        enddo
+        energies(j) = eigenvalues(j)
+      enddo
+      deallocate (H_matrix_tmp, eigenvalues, eigenvectors)
+!   else
+!     call davidson_diag_hjj(dets_in,u_in,diag_H_elements,energies,dim_in,sze,N_st,Nint,output_determinants)
+!   endif
+    print*,'E = ',energies(1) + nuclear_repulsion
+
+  enddo
+
+  
+end
+
+
+subroutine SC2_1h1p(dets_in,u_in,energies,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! CISD+SC2 method              :: take off all the disconnected terms of a CISD (selected or not)
+  !
+  ! 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
+  !
+  ! Initial guess vectors are not necessarily orthonormal
+  END_DOC
+  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)  :: energies(N_st)
+  double precision, intent(out)  :: diag_H_elements(dim_in)
+  double precision               :: extra_diag_H_elements(dim_in)
+  double precision, intent(in)   :: convergence
+  integer :: i,j,iter
+  DIAG_H_ELEMENTS = 0.d0
+  do iter = 1, 1
+!  call dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
+   call dressing_1h1p_by_2h2p(dets_in,u_in,extra_diag_H_elements,dim_in,sze,N_st,Nint,convergence)
+!   if(sze<=N_det_max_jacobi)then
+      double precision, allocatable  :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:)
+      allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze))
+      do j=1,sze
+        do i=1,sze
+          H_matrix_tmp(i,j) = H_matrix_all_dets(i,j)
+        enddo
+      enddo
+      H_matrix_tmp(1,1) += extra_diag_H_elements(1)
+      do i = 2,sze
+        H_matrix_tmp(1,i) += extra_diag_H_elements(i)
+        H_matrix_tmp(i,1) += extra_diag_H_elements(i)
+      enddo
+     !do i = 1,sze
+     !  H_matrix_tmp(i,i) = diag_H_elements(i)
+     !enddo
+      call lapack_diag(eigenvalues,eigenvectors,                     &
+          H_matrix_tmp,size(H_matrix_all_dets,1),sze)
+      do j=1,min(N_states_diag,sze)
+        do i=1,sze
+          u_in(i,j) = eigenvectors(i,j)
+        enddo
+        energies(j) = eigenvalues(j)
+      enddo
+      deallocate (H_matrix_tmp, eigenvalues, eigenvectors)
+!   else
+!     call davidson_diag_hjj(dets_in,u_in,diag_H_elements,energies,dim_in,sze,N_st,Nint,output_determinants)
+!   endif
+    print*,'E = ',energies(1) + nuclear_repulsion
+
+  enddo
+
+  
+end
+
+
+subroutine density_matrix_1h1p(dets_in,u_in,density_matrix_alpha,density_matrix_beta,norm,dim_in,sze,N_st,Nint)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! CISD+SC2 method              :: take off all the disconnected terms of a ROHF+1h1p (selected or not)
+  !
+  ! 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
+  !
+  ! Initial guess vectors are not necessarily orthonormal
+  END_DOC
+  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(inout)  :: density_matrix_alpha(mo_tot_num_align,mo_tot_num)
+  double precision, intent(inout)  :: density_matrix_beta(mo_tot_num_align,mo_tot_num)
+  double precision, intent(inout)  :: norm
+  
+  integer :: i,j,k,l
+  integer :: n_singles
+  integer :: index_singles(sze),hole_particles_singles(sze,3)
+  integer :: n_doubles
+  integer :: index_doubles(sze),hole_particles_doubles(sze,2)
+  integer :: index_hf
+
+  integer :: exc(0:2,2,2),degree
+  integer :: h1,h2,p1,p2,s1,s2
+  integer :: other_spin(2)
+  double precision :: phase
+  integer(bit_kind) :: key_tmp(N_int,2)
+  integer :: i_ok
+  double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral
+  double precision :: hij,c_ref,contrib
+  integer :: iorb
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  n_singles = 0
+  n_doubles = 0
+  norm = 0.d0
+  do i = 1,sze
+   call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   norm += u_in(i,1)* u_in(i,1)
+   if(degree == 0)then
+    index_hf = i
+    c_ref = 1.d0/psi_coef(i,1)
+   else if (degree == 1)then
+    n_singles +=1
+    index_singles(n_singles) = i
+    ! h1 = inactive orbital of the hole
+    hole_particles_singles(n_singles,1) = h1
+    ! p1 = virtual orbital of the particle
+    hole_particles_singles(n_singles,2) = p1
+    ! s1 = spin of the electron excited
+    hole_particles_singles(n_singles,3) = s1
+   else if (degree == 2)then
+    n_doubles +=1
+    index_doubles(n_doubles) = i
+    ! h1 = inactive orbital of the hole (beta of course)
+    hole_particles_doubles(n_doubles,1) = h1
+    ! p1 = virtual orbital of the particle (alpha of course)
+    hole_particles_doubles(n_doubles,2) = p2
+   else 
+    print*,'PB !! found out other thing than a single or double'
+    print*,'stopping ..'
+    stop
+   endif
+  enddo
+  print*,'norm = ',norm
+
+  ! Taking into account the connected part of the 2h2p on the HF determinant 
+  ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma}
+  
+  do i = 1, n_singles
+   ! start on the single excitation "|i>"
+   h1 = hole_particles_singles(i,1)
+   p1 = hole_particles_singles(i,2)
+   do j = 1, n_singles
+    do k = 1, N_int
+     key_tmp(k,1) = dets_in(k,1,index_singles(i))
+     key_tmp(k,2) = dets_in(k,2,index_singles(i))
+    enddo
+    h2 = hole_particles_singles(j,1)
+    p2 = hole_particles_singles(j,2)
+    call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok)    
+    ! apply the excitation operator from the single excitation "|j>"
+    if(i_ok .ne. 1)cycle
+    double precision :: coef_ijrs,phase_other_single_ref
+    integer                        :: occ(N_int*bit_kind_size,2),n_occ(2)
+    call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_single_double,N_int)
+    call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int)
+    call get_excitation(key_tmp,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int)
+    coef_ijrs = u_in(index_singles(i),1) * u_in(index_singles(j),1) * c_ref * c_ref & 
+                                * phase_single_double * phase_other_single_ref
+    call bitstring_to_list_ab(key_tmp, occ, n_occ, N_int)
+    do k=1,elec_alpha_num
+      l = occ(k,1)
+      density_matrix_alpha(l,l) += coef_ijrs*coef_ijrs
+    enddo
+    do k=1,elec_beta_num
+      l = occ(k,1)
+      density_matrix_beta(l,l) += coef_ijrs*coef_ijrs
+    enddo
+    norm += coef_ijrs* coef_ijrs
+    if(hole_particles_singles(j,3) == 1)then ! single alpha
+     density_matrix_alpha(h2,p2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref
+     density_matrix_alpha(p2,h2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref
+    else
+     density_matrix_beta(h2,p2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref
+     density_matrix_beta(p2,h2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref
+    endif
+   enddo
+  enddo
+
+
+  do i = 1, n_doubles
+   ! start on the double excitation "|i>"
+   h1 = hole_particles_doubles(i,1)
+   p1 = hole_particles_doubles(i,2)
+   do j = 1, n_singles
+    do k = 1, N_int
+     key_tmp(k,1) = dets_in(k,1,index_doubles(i))
+     key_tmp(k,2) = dets_in(k,2,index_doubles(i))
+    enddo
+    h2 = hole_particles_singles(j,1)
+    p2 = hole_particles_singles(j,2)
+    call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok)    
+    ! apply the excitation operator from the single excitation "|j>"
+    if(i_ok .ne. 1)cycle
+    double precision :: coef_ijrs_kv,phase_double_triple
+    call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_double_triple,N_int)
+    call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int)
+    call get_excitation(key_tmp,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int)
+    coef_ijrs_kv = u_in(index_doubles(i),1) * u_in(index_singles(j),1) * c_ref * c_ref & 
+                                * phase_double_triple * phase_other_single_ref
+    call bitstring_to_list_ab(key_tmp, occ, n_occ, N_int)
+    do k=1,elec_alpha_num
+      l = occ(k,1)
+      density_matrix_alpha(l,l) += coef_ijrs_kv*coef_ijrs_kv
+    enddo
+    do k=1,elec_beta_num
+      l = occ(k,1)
+      density_matrix_beta(l,l) += coef_ijrs_kv*coef_ijrs_kv
+    enddo
+    norm += coef_ijrs_kv* coef_ijrs_kv
+    if(hole_particles_singles(j,3) == 1)then ! single alpha
+     density_matrix_alpha(h2,p2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref
+     density_matrix_alpha(p2,h2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref
+    else
+     density_matrix_beta(h2,p2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref
+     density_matrix_beta(p2,h2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref
+    endif
+   enddo
+  enddo
+
+
+
+
+  print*,'norm = ',norm
+  norm = 1.d0/norm
+  do i = 1, mo_tot_num
+   do j = 1, mo_tot_num
+    density_matrix_alpha(i,j) *= norm
+    density_matrix_beta(i,j) *= norm
+   enddo
+  enddo
+  coef_ijrs = 0.d0
+  do i = 1, mo_tot_num
+   coef_ijrs += density_matrix_beta(i,i) + density_matrix_beta(i,i)
+  enddo
+  print*,'accu = ',coef_ijrs
+
+end
+

plugins/FOBOCI/all_singles.irp.f

@@ -1,13 +1,25 @@
-subroutine all_single
+subroutine all_single(e_pt2)
   implicit none
+  double precision, intent(in)   :: e_pt2
   integer                        :: i,k
   double precision, allocatable  :: pt2(:), norm_pert(:), H_pert_diag(:)
   integer                        :: N_st, degree
   double precision,allocatable :: E_before(:)
   N_st = N_states
   allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
+  if(.not.selected_fobo_ci)then
    selection_criterion = 0.d0
    soft_touch selection_criterion
+  else 
+   selection_criterion =  0.1d0 
+   selection_criterion_factor = 0.01d0
+   selection_criterion_min = selection_criterion
+   soft_touch selection_criterion
+  endif
+  print*, 'e_pt2 = ',e_pt2
+  pt2_max = 0.15d0 * e_pt2
+  soft_touch pt2_max
+  print*, 'pt2_max = ',pt2_max
   threshold_davidson = 1.d-9
   soft_touch threshold_davidson davidson_criterion
   i = 0
@@ -17,6 +29,8 @@ subroutine all_single
   print*,'pt2_max = ',pt2_max
   print*,'N_det_generators = ',N_det_generators
   pt2=-1.d0
+  print*, 'ref_bitmask_energy   =',ref_bitmask_energy
+  print*, 'CI_expectation_value =',psi_energy(1)
   E_before = ref_bitmask_energy
  
   print*,'Initial Step '
@@ -29,7 +43,7 @@ subroutine all_single
    print*,'S^2      = ',CI_eigenvectors_s2(i)
   enddo
   n_det_max = 100000
-  do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
+  do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > dabs(pt2_max))
     i += 1
     print*,'-----------------------'
     print*,'i = ',i
@@ -39,6 +53,8 @@ subroutine all_single
     print*,'E        = ',CI_energy(1)
     print*,'pt2      = ',pt2(1)
     print*,'E+PT2    = ',E_before + pt2(1)
+    print*,'pt2_max  = ',pt2_max
+    print*, maxval(abs(pt2(1:N_st))) > dabs(pt2_max)
     if(N_states_diag.gt.1)then
      print*,'Variational Energy difference'
      do i = 2, N_st
@@ -53,7 +69,6 @@ subroutine all_single
     endif
     E_before = CI_energy
     !!!!!!!!!!!!!!!!!!!!!!!!!!! DOING ONLY ONE ITERATION OF SELECTION AS THE SELECTION CRITERION IS SET TO ZERO
-    exit
   enddo
 ! threshold_davidson = 1.d-8
 ! soft_touch threshold_davidson davidson_criterion

plugins/FOBOCI/corr_energy_2h2p.irp.f

@@ -15,7 +15,7 @@
  integer(bit_kind) :: key_tmp(N_int,2)
  integer :: i,j,k,l
  integer :: i_hole,j_hole,k_part,l_part
- double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
+ double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib
  double precision :: diag_H_mat_elem
  integer :: i_ok,ispin
  ! Alpha - Beta correlation energy
@@ -46,7 +46,7 @@
      if(i_ok .ne.1)cycle
      delta_e  = (ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
 
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
      contrib = hij*hij/delta_e
      total_corr_e_2h2p += contrib
      ! Single orbital contribution
@@ -81,8 +81,8 @@
     k_part = list_virt(k)
     do l = k+1,n_virt_orb
      l_part = list_virt(l)
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
      key_tmp = ref_bitmask
      ispin = 1
      call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
@@ -114,8 +114,8 @@
     k_part = list_virt(k)
     do l = k+1,n_virt_orb
      l_part = list_virt(l)
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
      key_tmp = ref_bitmask
      ispin = 2
      call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
@@ -161,7 +161,7 @@ END_PROVIDER
  integer(bit_kind) :: key_tmp(N_int,2)
  integer :: i,j,k,l
  integer :: i_hole,j_hole,k_part,l_part
- double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
+ double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib
  double precision :: diag_H_mat_elem
  integer :: i_ok,ispin
  ! Alpha - Beta correlation energy
@@ -191,7 +191,7 @@ END_PROVIDER
      if(i_ok .ne.1)cycle
      delta_e  = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
 
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
      contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
      total_corr_e_2h1p += contrib
      corr_energy_2h1p_ab_bb_per_2_orb(i_hole,j_hole) += contrib
@@ -211,8 +211,8 @@ END_PROVIDER
     k_part = list_act(k)
     do l = 1,n_virt_orb
      l_part = list_virt(l)
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
      key_tmp = ref_bitmask
      ispin = 1
      call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
@@ -241,8 +241,8 @@ END_PROVIDER
     k_part = list_act(k)
     do l = 1,n_virt_orb
      l_part = list_virt(l)
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
      key_tmp = ref_bitmask
      ispin = 2
      call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
@@ -276,7 +276,7 @@ END_PROVIDER
  integer(bit_kind) :: key_tmp(N_int,2)
  integer :: i,j,k,l
  integer :: i_hole,j_hole,k_part,l_part
- double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
+ double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib
  double precision :: diag_H_mat_elem
  integer :: i_ok,ispin
  ! Alpha - Beta correlation energy
@@ -302,7 +302,7 @@ END_PROVIDER
      if(i_ok .ne.1)cycle
      delta_e  = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
 
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
      contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
 
      total_corr_e_1h2p += contrib
@@ -324,8 +324,8 @@ END_PROVIDER
     k_part = list_act(k)
     do l = i+1,n_virt_orb
      l_part = list_virt(l)
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
 
      key_tmp = ref_bitmask
      ispin = 1
@@ -356,8 +356,8 @@ END_PROVIDER
     k_part = list_act(k)
     do l = i+1,n_virt_orb
      l_part = list_virt(l)
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
 
      key_tmp = ref_bitmask
      ispin = 2
@@ -388,7 +388,7 @@ END_PROVIDER
  integer(bit_kind) :: key_tmp(N_int,2)
  integer :: i,j,k,l
  integer :: i_hole,j_hole,k_part,l_part
- double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
+ double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib
  double precision :: diag_H_mat_elem
  integer :: i_ok,ispin
  ! Alpha - Beta correlation energy
@@ -412,7 +412,7 @@ END_PROVIDER
      if(i_ok .ne.1)cycle
      delta_e  = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
 
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
      contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
 
      total_corr_e_1h1p_spin_flip += contrib

plugins/FOBOCI/create_1h_or_1p.irp.f

@@ -68,7 +68,9 @@ subroutine create_restart_and_1h(i_hole)
 
   SOFT_TOUCH N_det psi_det psi_coef
   logical :: found_duplicates
+  if(n_act_orb.gt.1)then
   call remove_duplicates_in_psi_det(found_duplicates)
+  endif
 end
 
 subroutine create_restart_and_1p(i_particle)
@@ -213,6 +215,8 @@ subroutine create_restart_1h_1p(i_hole,i_part)
 
   SOFT_TOUCH N_det psi_det psi_coef
   logical :: found_duplicates
+  if(n_act_orb.gt.1)then
   call remove_duplicates_in_psi_det(found_duplicates)
+  endif
 
 end

plugins/FOBOCI/diag_fock_inactiv_virt.irp.f

@@ -38,7 +38,7 @@ end
 subroutine diag_inactive_virt_new_and_update_mos
  implicit none
  integer :: i,j,i_inact,j_inact,i_virt,j_virt,k,k_act
- double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral_schwartz
+ double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral
  character*(64) :: label
  tmp = 0.d0
  do i = 1, mo_tot_num
@@ -52,8 +52,8 @@ subroutine diag_inactive_virt_new_and_update_mos
    accu =0.d0
    do k = 1, n_act_orb
     k_act = list_act(k)
-    accu += get_mo_bielec_integral_schwartz(i_inact,k_act,j_inact,k_act,mo_integrals_map)
+    accu += get_mo_bielec_integral(i_inact,k_act,j_inact,k_act,mo_integrals_map)
-    accu -= get_mo_bielec_integral_schwartz(i_inact,k_act,k_act,j_inact,mo_integrals_map)
+    accu -= get_mo_bielec_integral(i_inact,k_act,k_act,j_inact,mo_integrals_map)
    enddo
    tmp(i_inact,j_inact) = Fock_matrix_mo(i_inact,j_inact) + accu
    tmp(j_inact,i_inact) = Fock_matrix_mo(j_inact,i_inact) + accu
@@ -67,7 +67,7 @@ subroutine diag_inactive_virt_new_and_update_mos
    accu =0.d0
    do k = 1, n_act_orb
     k_act = list_act(k)
-    accu += get_mo_bielec_integral_schwartz(i_virt,k_act,j_virt,k_act,mo_integrals_map)
+    accu += get_mo_bielec_integral(i_virt,k_act,j_virt,k_act,mo_integrals_map)
    enddo
    tmp(i_virt,j_virt) = Fock_matrix_mo(i_virt,j_virt) - accu
    tmp(j_virt,i_virt) = Fock_matrix_mo(j_virt,i_virt) - accu

plugins/FOBOCI/dress_simple.irp.f

@@ -58,24 +58,7 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen
        call i_h_j(det_buffer(1,1,i),det_buffer(1,1,i),Nint,haa)
        f = 1.d0/(E_ref-haa)
        
-!    if(second_order_h)then
       lambda_i = f
-!    else
-!      ! You write the new Hamiltonian matrix
-!      do k = 1, Ndet_generators
-!       H_matrix_tmp(k,Ndet_generators+1) = H_array(k)
-!       H_matrix_tmp(Ndet_generators+1,k) = H_array(k)
-!      enddo
-!      H_matrix_tmp(Ndet_generators+1,Ndet_generators+1) = haa
-!      ! Then diagonalize it
-!      call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,Ndet_generators+1,Ndet_generators+1)
-!      ! Then you extract the effective denominator
-!      accu = 0.d0
-!      do k = 1, Ndet_generators
-!       accu += eigenvectors(k,1) * H_array(k)
-!      enddo
-!      lambda_i = eigenvectors(Ndet_generators+1,1)/accu
-!    endif
      do k=1,idx(0)
        contrib = H_array(idx(k)) * H_array(idx(k)) * lambda_i
        delta_ij_generators_(idx(k), idx(k)) += contrib
@@ -89,20 +72,21 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen
 end
 
 
-subroutine is_a_good_candidate(threshold,is_ok,verbose)
+subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
  use bitmasks
  implicit none
  double precision, intent(in) :: threshold
- logical, intent(out) :: is_ok
+ double precision, intent(out):: e_pt2
+ logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative
  logical, intent(in) :: verbose
  
  integer :: l,k,m
  double precision,allocatable :: dressed_H_matrix(:,:)
- double precision,allocatable :: psi_coef_diagonalized_tmp(:,:)
+ double precision, allocatable :: psi_coef_diagonalized_tmp(:,:)
  integer(bit_kind), allocatable :: psi_det_generators_input(:,:,:)
+ double precision :: hij
 
- allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators))
+ allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators),psi_coef_diagonalized_tmp(N_det_generators,N_states))
- allocate(psi_coef_diagonalized_tmp(N_det_generators,N_states))
  dressed_H_matrix = 0.d0
  do k = 1, N_det_generators
   do l = 1, N_int
@@ -111,9 +95,20 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose)
   enddo
  enddo
 !call H_apply_dressed_pert(dressed_H_matrix,N_det_generators,psi_det_generators_input)
- call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose)
+ call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop,is_ok_perturbative)
- if(do_it_perturbative)then
+!do m = 1, N_states
-  if(is_ok)then
+! do k = 1, N_det_generators
+!  do l = 1, N_int
+!    psi_selectors(l,1,k) = psi_det_generators_input(l,1,k) 
+!    psi_selectors(l,2,k) = psi_det_generators_input(l,2,k) 
+!  enddo
+!  psi_selectors_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
+! enddo
+!enddo
+!soft_touch psi_selectors psi_selectors_coef 
+!if(do_it_perturbative)then
+   print*, 'is_ok_perturbative',is_ok_perturbative
+  if(is_ok.or.is_ok_perturbative)then
    N_det = N_det_generators
    do m = 1, N_states
     do k = 1, N_det_generators
@@ -122,11 +117,19 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose)
        psi_det(l,2,k) = psi_det_generators_input(l,2,k) 
      enddo
      psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
+     print*, 'psi_coef(k,m)',psi_coef(k,m)
+    enddo
+   enddo
+   soft_touch psi_det psi_coef  N_det
+   e_pt2 = 0.d0
+   do m =1, N_det_generators
+    do l = 1, N_det_generators
+     call i_h_j(psi_det_generators_input(1,1,m),psi_det_generators_input(1,1,l),N_int,hij)  ! Fill the zeroth order H matrix
+     e_pt2 += (dressed_H_matrix(m,l) - hij)* psi_coef_diagonalized_tmp(m,1)* psi_coef_diagonalized_tmp(l,1)
     enddo
    enddo
-   touch psi_coef psi_det N_det
-  endif
   endif
+!endif
  
  deallocate(psi_det_generators_input,dressed_H_matrix,psi_coef_diagonalized_tmp)
 
@@ -135,14 +138,14 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose)
 
 end
 
-subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose)
+subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop,is_ok_perturbative)
  use bitmasks
  implicit none
  integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators)
  integer, intent(in) :: Ndet_generators
  double precision, intent(in) :: threshold
  logical, intent(in) :: verbose
- logical, intent(out) :: is_ok
+ logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative
  double precision, intent(out) :: psi_coef_diagonalized_tmp(Ndet_generators,N_states)
  double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators)
 
@@ -151,6 +154,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
  double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij
  double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average
  logical :: is_a_ref_det(Ndet_generators)
+ exit_loop = .False.
  
  is_a_ref_det = .False.
  do i = 1, N_det_generators
@@ -191,6 +195,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
   if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then
    if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then
     is_ok = .False.
+    exit_loop = .True.
     return
    endif
   endif
@@ -278,9 +283,11 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
     do k = 1, N_states 
      accu = 0.d0
      do j =1, Ndet_generators
+      print*,'',eigvectors(j,i) , psi_coef_ref(j,k)
       accu += eigvectors(j,i) * psi_coef_ref(j,k)
      enddo
-     if(dabs(accu).ge.0.8d0)then
+     print*,'accu = ',accu
+     if(dabs(accu).ge.0.72d0)then
       i_good_state(0) +=1
       i_good_state(i_good_state(0)) = i
      endif
@@ -321,10 +328,124 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
    exit
   endif
  enddo
+ if(.not.is_ok)then
+  is_ok_perturbative = .True.
+  do i = 1, Ndet_generators
+   if(is_a_ref_det(i))cycle
+   do k = 1, N_states
+    print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative
+    if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold_perturbative)then
+     is_ok_perturbative = .False.
+     exit
+    endif
+   enddo
+   if(.not.is_ok_perturbative)then
+    exit
+   endif
+  enddo
+ endif
  if(verbose)then
   print*,'is_ok              = ',is_ok
+  print*,'is_ok_perturbative = ',is_ok_perturbative
  endif
  
 
 end
 
+subroutine fill_H_apply_buffer_no_selection_first_order_coef(n_selected,det_buffer,Nint,iproc)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  !  Fill the H_apply buffer with determiants for CISD
+  END_DOC
+  
+  integer, intent(in)            :: n_selected, Nint, iproc
+  integer(bit_kind), intent(in)  :: det_buffer(Nint,2,n_selected)
+  integer                        :: i,j,k
+  integer                        :: new_size
+  PROVIDE H_apply_buffer_allocated
+  call omp_set_lock(H_apply_buffer_lock(1,iproc))
+  new_size = H_apply_buffer(iproc)%N_det + n_selected
+  if (new_size > H_apply_buffer(iproc)%sze) then
+    call resize_h_apply_buffer(max(2*H_apply_buffer(iproc)%sze,new_size),iproc)
+  endif
+  do i=1,H_apply_buffer(iproc)%N_det
+    ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num)
+    ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num)
+  enddo
+  do i=1,n_selected
+    do j=1,N_int
+      H_apply_buffer(iproc)%det(j,1,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,1,i)
+      H_apply_buffer(iproc)%det(j,2,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,2,i)
+    enddo
+    ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i+H_apply_buffer(iproc)%N_det)) )== elec_alpha_num)
+    ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num)
+  enddo
+  double precision               :: i_H_psi_array(N_states),h,diag_H_mat_elem_fock,delta_e
+  do i=1,N_selected
+   call i_H_psi(det_buffer(1,1,i),psi_selectors,psi_selectors_coef,N_int,N_det_selectors,psi_selectors_size,N_states,i_H_psi_array)
+   call i_H_j(det_buffer(1,1,i),det_buffer(1,1,i),N_int,h)
+   do j=1,N_states
+      delta_e = -1.d0 /(h - psi_energy(j))
+      H_apply_buffer(iproc)%coef(i+H_apply_buffer(iproc)%N_det,j) = i_H_psi_array(j) * delta_e
+    enddo
+  enddo
+  H_apply_buffer(iproc)%N_det = new_size
+  do i=1,H_apply_buffer(iproc)%N_det
+    ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num)
+    ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num)
+  enddo
+  call omp_unset_lock(H_apply_buffer_lock(1,iproc))
+end
+
+
+
+subroutine make_s2_eigenfunction_first_order
+  implicit none
+  integer                        :: i,j,k
+  integer                        :: smax, s
+  integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:)
+  integer                        :: N_det_new
+  integer, parameter             :: bufsze = 1000
+  logical, external              :: is_in_wavefunction
+
+  allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) )
+  smax = 1
+  N_det_new = 0
+
+  do i=1,N_occ_pattern
+    call occ_pattern_to_dets_size(psi_occ_pattern(1,1,i),s,elec_alpha_num,N_int)
+    s += 1
+    if (s > smax) then
+      deallocate(d)
+      allocate ( d(N_int,2,s) )
+      smax = s
+    endif
+    call occ_pattern_to_dets(psi_occ_pattern(1,1,i),d,s,elec_alpha_num,N_int)
+    do j=1,s
+      if (.not. is_in_wavefunction(d(1,1,j), N_int) ) then
+        N_det_new += 1
+        do k=1,N_int
+          det_buffer(k,1,N_det_new) = d(k,1,j)
+          det_buffer(k,2,N_det_new) = d(k,2,j)
+        enddo
+        if (N_det_new == bufsze) then
+          call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0)
+          N_det_new = 0
+        endif
+      endif
+    enddo
+  enddo
+
+  if (N_det_new > 0) then
+    call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0)
+    call copy_H_apply_buffer_to_wf
+    SOFT_TOUCH N_det psi_coef psi_det
+  endif
+
+  deallocate(d,det_buffer)
+
+   call write_int(output_determinants,N_det_new, 'Added deteminants for S^2')
+
+end
+

plugins/FOBOCI/fobo_scf.irp.f

@@ -1,8 +1,13 @@
 program foboscf
  implicit none
- call run_prepare
+!if(disk_access_ao_integrals == "None" .or. disk_access_ao_integrals == "Read" )then
+! disk_access_ao_integrals = "Write"
+! touch disk_access_ao_integrals
+!endif
+!print*, 'disk_access_ao_integrals',disk_access_ao_integrals
  no_oa_or_av_opt = .True.
  touch no_oa_or_av_opt
+ call run_prepare
  call routine_fobo_scf
  call save_mos
 
@@ -10,8 +15,8 @@ end
 
 subroutine run_prepare
  implicit none
-  no_oa_or_av_opt = .False.
+! no_oa_or_av_opt = .False.
-  touch no_oa_or_av_opt
+! touch no_oa_or_av_opt
   call damping_SCF
   call diag_inactive_virt_and_update_mos
 end
@@ -27,6 +32,7 @@ subroutine routine_fobo_scf
   print*,'*******************************************************************************'
   print*,'*******************************************************************************'
   print*,'FOBO-SCF Iteration ',i
+  print*, 'ao_bielec_integrals_in_map = ',ao_bielec_integrals_in_map
   print*,'*******************************************************************************'
   print*,'*******************************************************************************'
   if(speed_up_convergence_foboscf)then
@@ -46,7 +52,7 @@ subroutine routine_fobo_scf
     soft_touch threshold_lmct threshold_mlct
    endif
   endif
-  call FOBOCI_lmct_mlct_old_thr
+  call FOBOCI_lmct_mlct_old_thr(i)
   call save_osoci_natural_mos
   call damping_SCF
   call diag_inactive_virt_and_update_mos

plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f

@@ -1,7 +1,8 @@
 
-subroutine FOBOCI_lmct_mlct_old_thr
+subroutine FOBOCI_lmct_mlct_old_thr(iter)
   use bitmasks
  implicit none
+ integer, intent(in) :: iter
  integer :: i,j,k,l
  integer(bit_kind),allocatable :: unpaired_bitmask(:,:)
  integer, allocatable :: occ(:,:)
@@ -10,7 +11,7 @@ subroutine FOBOCI_lmct_mlct_old_thr
  logical :: test_sym
  double precision :: thr,hij
  double precision, allocatable :: dressing_matrix(:,:)
- logical :: verbose,is_ok
+ logical :: verbose,is_ok,is_ok_perturbative
  verbose = .True.
  thr = 1.d-12
  allocate(unpaired_bitmask(N_int,2))
@@ -38,6 +39,7 @@ subroutine FOBOCI_lmct_mlct_old_thr
  integer(bit_kind) , allocatable :: psi_singles(:,:,:)
  logical :: lmct
  double precision, allocatable :: psi_singles_coef(:,:)
+ logical :: exit_loop
  allocate( zero_bitmask(N_int,2) )
   do i = 1, n_inact_orb
    lmct = .True.
@@ -45,23 +47,22 @@ subroutine FOBOCI_lmct_mlct_old_thr
    i_hole_osoci = list_inact(i)
    print*,'--------------------------'
    ! First set the current generators to the one of restart
-   call set_generators_to_generators_restart
-   call set_psi_det_to_generators
    call check_symetry(i_hole_osoci,thr,test_sym)
    if(.not.test_sym)cycle
+   call set_generators_to_generators_restart
+   call set_psi_det_to_generators
    print*,'i_hole_osoci = ',i_hole_osoci
    call create_restart_and_1h(i_hole_osoci)
    call set_generators_to_psi_det
    print*,'Passed set generators'
    call set_bitmask_particl_as_input(reunion_of_bitmask)
    call set_bitmask_hole_as_input(reunion_of_bitmask)
-   call is_a_good_candidate(threshold_lmct,is_ok,verbose)
+   double precision :: e_pt2
+   call is_a_good_candidate(threshold_lmct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
    print*,'is_ok = ',is_ok
-   if(.not.is_ok)cycle
+   if(is_ok)then
     allocate(dressing_matrix(N_det_generators,N_det_generators))
     dressing_matrix = 0.d0
-   if(.not.do_it_perturbative)then
-
      do k = 1, N_det_generators
       do l = 1, N_det_generators
         call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
@@ -80,52 +81,11 @@ subroutine FOBOCI_lmct_mlct_old_thr
      ! Do all the single excitations on top of the CAS and 1h determinants
      call set_bitmask_particl_as_input(reunion_of_bitmask)
      call set_bitmask_hole_as_input(reunion_of_bitmask)
-    call all_single
+     call all_single(e_pt2)
-!   if(dressing_2h2p)then
+     call make_s2_eigenfunction_first_order
-!    call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_hole_osoci,lmct)
+     threshold_davidson = 1.d-6
-!   endif
+     soft_touch threshold_davidson davidson_criterion
-
+     call diagonalize_ci
-!   ! Change the mask of the holes and particles to perform all the 
-!   ! double excitations that starts from the active space in order 
-!   ! to introduce the Coulomb hole in the active space
-!   ! These are the 1h2p excitations that have the i_hole_osoci hole in common
-!   ! and the 2p if there is more than one electron in the active space
-!   do k = 1, N_int
-!    zero_bitmask(k,1) = 0_bit_kind
-!    zero_bitmask(k,2) = 0_bit_kind
-!   enddo
-!   ! hole is possible only in the orbital i_hole_osoci 
-!   call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int)
-!   call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int)
-!   ! and in the active space
-!   do k = 1, n_act_orb
-!    call set_bit_to_integer(list_act(k),zero_bitmask(1,1),N_int)
-!    call set_bit_to_integer(list_act(k),zero_bitmask(1,2),N_int)
-!   enddo
-!   call set_bitmask_hole_as_input(zero_bitmask)
-
-!   call set_bitmask_particl_as_input(reunion_of_bitmask)
-
-!   call all_1h2p
-!   call diagonalize_CI_SC2
-!   call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
-
-!   ! Change the mask of the holes and particles to perform all the 
-!   ! double excitations that from the orbital i_hole_osoci
-!   do k = 1, N_int
-!    zero_bitmask(k,1) = 0_bit_kind
-!    zero_bitmask(k,2) = 0_bit_kind
-!   enddo
-!   ! hole is possible only in the orbital i_hole_osoci 
-!   call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int)
-!   call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int)
-!   call set_bitmask_hole_as_input(zero_bitmask)
-
-!   call set_bitmask_particl_as_input(reunion_of_bitmask)
-
-!   call set_psi_det_to_generators
-!   call all_2h2p
-!   call diagonalize_CI_SC2
     double precision :: hkl
     call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
     hkl = dressing_matrix(1,1)
@@ -136,7 +96,10 @@ subroutine FOBOCI_lmct_mlct_old_thr
     do k = 1, N_det_generators
      write(*,'(100(F12.5,X))')dressing_matrix(k,:)
     enddo
-!   call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
+    deallocate(dressing_matrix)
+   else 
+    if(.not.do_it_perturbative)cycle
+    if(.not. is_ok_perturbative)cycle
    endif
    call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci)
 
@@ -145,7 +108,6 @@ subroutine FOBOCI_lmct_mlct_old_thr
     norm_total(k) += norm_tmp(k)
    enddo
    call update_density_matrix_osoci
-   deallocate(dressing_matrix)
  enddo
 
  if(.True.)then
@@ -159,10 +121,10 @@ subroutine FOBOCI_lmct_mlct_old_thr
 
     print*,'--------------------------'
     ! First set the current generators to the one of restart
-    call set_generators_to_generators_restart
-    call set_psi_det_to_generators
     call check_symetry(i_particl_osoci,thr,test_sym)
     if(.not.test_sym)cycle
+    call set_generators_to_generators_restart
+    call set_psi_det_to_generators
     print*,'i_particl_osoci= ',i_particl_osoci
     ! Initialize the bitmask to the restart ones
     call initialize_bitmask_to_restart_ones
@@ -178,11 +140,10 @@ subroutine FOBOCI_lmct_mlct_old_thr
     call set_bitmask_particl_as_input(reunion_of_bitmask)
     call set_bitmask_hole_as_input(reunion_of_bitmask)
 !!  ! so all the mono excitation on the new generators 
-    call is_a_good_candidate(threshold_mlct,is_ok,verbose)
+    call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
     print*,'is_ok = ',is_ok
-    if(.not.is_ok)cycle
+    if(is_ok)then
       allocate(dressing_matrix(N_det_generators,N_det_generators))
-    if(.not.do_it_perturbative)then
       dressing_matrix = 0.d0
       do k = 1, N_det_generators
        do l = 1, N_det_generators
@@ -190,12 +151,22 @@ subroutine FOBOCI_lmct_mlct_old_thr
          dressing_matrix(k,l) = hkl
        enddo
       enddo
- !   call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix)
+      call all_single(e_pt2)
- !   call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
+      call make_s2_eigenfunction_first_order
-     call all_single
+      threshold_davidson = 1.d-6
-!    if(dressing_2h2p)then
+      soft_touch threshold_davidson davidson_criterion
-!     call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_particl_osoci,lmct)
+     
-!    endif
+      call diagonalize_ci
+      deallocate(dressing_matrix)
+    else
+     if(exit_loop)then
+      call set_generators_to_generators_restart
+      call set_psi_det_to_generators
+      exit
+     else 
+      if(.not.do_it_perturbative)cycle
+      if(.not. is_ok_perturbative)cycle
+     endif
     endif
     call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
     do k = 1, N_states
@@ -203,7 +174,6 @@ subroutine FOBOCI_lmct_mlct_old_thr
      norm_total(k) += norm_tmp(k)
     enddo
     call update_density_matrix_osoci
-   deallocate(dressing_matrix)
   enddo
  endif
 
@@ -230,7 +200,7 @@ subroutine FOBOCI_mlct_old
  double precision :: norm_tmp,norm_total
  logical :: test_sym
  double precision :: thr
- logical :: verbose,is_ok
+ logical :: verbose,is_ok,exit_loop
  verbose = .False.
  thr = 1.d-12
  allocate(unpaired_bitmask(N_int,2))
@@ -270,7 +240,7 @@ subroutine FOBOCI_mlct_old
    call set_bitmask_particl_as_input(reunion_of_bitmask)
    call set_bitmask_hole_as_input(reunion_of_bitmask)
 !  ! so all the mono excitation on the new generators 
-   call is_a_good_candidate(threshold_mlct,is_ok,verbose)
+   call is_a_good_candidate(threshold_mlct,is_ok,verbose,exit_loop)
    print*,'is_ok = ',is_ok
    is_ok =.True.
    if(.not.is_ok)cycle
@@ -304,7 +274,7 @@ subroutine FOBOCI_lmct_old
  double precision :: norm_tmp,norm_total
  logical :: test_sym
  double precision :: thr
- logical :: verbose,is_ok
+ logical :: verbose,is_ok,exit_loop
  verbose = .False.
  thr = 1.d-12
  allocate(unpaired_bitmask(N_int,2))
@@ -342,7 +312,7 @@ subroutine FOBOCI_lmct_old
    call set_generators_to_psi_det
    call set_bitmask_particl_as_input(reunion_of_bitmask)
    call set_bitmask_hole_as_input(reunion_of_bitmask)
-   call is_a_good_candidate(threshold_lmct,is_ok,verbose)
+   call is_a_good_candidate(threshold_lmct,is_ok,verbose,exit_loop)
    print*,'is_ok = ',is_ok
    if(.not.is_ok)cycle
 !  ! so all the mono excitation on the new generators 
@@ -365,3 +335,303 @@ subroutine FOBOCI_lmct_old
    enddo
    print*,'accu = ',accu
 end
+
+subroutine FOBOCI_lmct_mlct_old_thr_restart(iter)
+  use bitmasks
+ implicit none
+ integer, intent(in) :: iter
+ integer :: i,j,k,l
+ integer(bit_kind),allocatable :: unpaired_bitmask(:,:)
+ integer, allocatable :: occ(:,:)
+ integer       :: n_occ_alpha, n_occ_beta
+ double precision :: norm_tmp(N_states),norm_total(N_states)
+ logical :: test_sym
+ double precision :: thr,hij
+ double precision, allocatable :: dressing_matrix(:,:)
+ logical :: verbose,is_ok,is_ok_perturbative
+ verbose = .True.
+ thr = 1.d-12
+ allocate(unpaired_bitmask(N_int,2))
+ allocate (occ(N_int*bit_kind_size,2))
+ do i = 1, N_int
+  unpaired_bitmask(i,1) = unpaired_alpha_electrons(i)
+  unpaired_bitmask(i,2) = unpaired_alpha_electrons(i)
+ enddo
+ norm_total = 0.d0
+ call initialize_density_matrix_osoci
+ call bitstring_to_list(inact_bitmask(1,1), occ(1,1), n_occ_beta, N_int)
+ print*,''
+ print*,''
+ print*,'mulliken spin population analysis'
+ accu =0.d0
+ do i = 1, nucl_num
+  accu += mulliken_spin_densities(i)
+  print*,i,nucl_charge(i),mulliken_spin_densities(i)
+ enddo
+ print*,''
+ print*,''
+ print*,'DOING FIRST LMCT !!'
+ print*,'Threshold_lmct = ',threshold_lmct
+ integer(bit_kind) , allocatable :: zero_bitmask(:,:)
+ integer(bit_kind) , allocatable :: psi_singles(:,:,:)
+ logical :: lmct
+ double precision, allocatable :: psi_singles_coef(:,:)
+ logical :: exit_loop
+ allocate( zero_bitmask(N_int,2) )
+ if(iter.ne.1)then
+   do i = 1, n_inact_orb
+    lmct = .True.
+    integer :: i_hole_osoci
+    i_hole_osoci = list_inact(i)
+    print*,'--------------------------'
+    ! First set the current generators to the one of restart
+    call check_symetry(i_hole_osoci,thr,test_sym)
+    if(.not.test_sym)cycle
+    call set_generators_to_generators_restart
+    call set_psi_det_to_generators
+    print*,'i_hole_osoci = ',i_hole_osoci
+    call create_restart_and_1h(i_hole_osoci)
+    call set_generators_to_psi_det
+    print*,'Passed set generators'
+    call set_bitmask_particl_as_input(reunion_of_bitmask)
+    call set_bitmask_hole_as_input(reunion_of_bitmask)
+    double precision :: e_pt2
+    call is_a_good_candidate(threshold_lmct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
+    print*,'is_ok = ',is_ok
+    if(is_ok)then
+     allocate(dressing_matrix(N_det_generators,N_det_generators))
+     dressing_matrix = 0.d0
+      do k = 1, N_det_generators
+       do l = 1, N_det_generators
+         call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
+         dressing_matrix(k,l) = hkl
+       enddo
+      enddo
+      hkl = dressing_matrix(1,1)
+      do k = 1, N_det_generators
+        dressing_matrix(k,k) = dressing_matrix(k,k) - hkl
+      enddo
+      print*,'Naked matrix'
+      do k = 1, N_det_generators
+       write(*,'(100(F12.5,X))')dressing_matrix(k,:)
+      enddo
+     
+      ! Do all the single excitations on top of the CAS and 1h determinants
+      call set_bitmask_particl_as_input(reunion_of_bitmask)
+      call set_bitmask_hole_as_input(reunion_of_bitmask)
+      call all_single(e_pt2)
+      call make_s2_eigenfunction_first_order
+      threshold_davidson = 1.d-6
+      soft_touch threshold_davidson davidson_criterion
+      call diagonalize_ci
+     double precision :: hkl
+     call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
+     hkl = dressing_matrix(1,1)
+     do k = 1, N_det_generators
+       dressing_matrix(k,k) = dressing_matrix(k,k) - hkl
+     enddo
+     print*,'Dressed matrix'
+     do k = 1, N_det_generators
+      write(*,'(100(F12.5,X))')dressing_matrix(k,:)
+     enddo
+     deallocate(dressing_matrix)
+    else 
+     if(.not.do_it_perturbative)cycle
+     if(.not. is_ok_perturbative)cycle
+    endif
+    call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci)
+ 
+    do k = 1, N_states
+     print*,'norm_tmp = ',norm_tmp(k)
+     norm_total(k) += norm_tmp(k)
+    enddo
+    call update_density_matrix_osoci
+  enddo
+ else 
+  double precision :: array_dm(mo_tot_num)
+  call read_dm_from_lmct(array_dm)
+  call update_density_matrix_beta_osoci_read(array_dm)
+ endif
+
+ if(iter.ne.1)then
+  if(.True.)then
+   print*,''
+   print*,'DOING THEN THE MLCT !!'
+   print*,'Threshold_mlct = ',threshold_mlct
+    lmct = .False.
+    do i = 1, n_virt_orb
+     integer :: i_particl_osoci
+     i_particl_osoci = list_virt(i)
+ 
+     print*,'--------------------------'
+     ! First set the current generators to the one of restart
+     call check_symetry(i_particl_osoci,thr,test_sym)
+     if(.not.test_sym)cycle
+     call set_generators_to_generators_restart
+     call set_psi_det_to_generators
+     print*,'i_particl_osoci= ',i_particl_osoci
+     ! Initialize the bitmask to the restart ones
+     call initialize_bitmask_to_restart_ones
+     ! Impose that only the hole i_hole_osoci can be done
+     call modify_bitmasks_for_particl(i_particl_osoci)
+     call print_generators_bitmasks_holes
+     ! Impose that only the active part can be reached 
+     call set_bitmask_hole_as_input(unpaired_bitmask)
+!!!  call all_single_h_core
+     call create_restart_and_1p(i_particl_osoci)
+!!!  ! Update the generators 
+     call set_generators_to_psi_det
+     call set_bitmask_particl_as_input(reunion_of_bitmask)
+     call set_bitmask_hole_as_input(reunion_of_bitmask)
+!!!  ! so all the mono excitation on the new generators 
+     call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
+     print*,'is_ok = ',is_ok
+     if(is_ok)then
+       allocate(dressing_matrix(N_det_generators,N_det_generators))
+       dressing_matrix = 0.d0
+       do k = 1, N_det_generators
+        do l = 1, N_det_generators
+          call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
+          dressing_matrix(k,l) = hkl
+        enddo
+       enddo
+       call all_single(e_pt2)
+       call make_s2_eigenfunction_first_order
+       threshold_davidson = 1.d-6
+       soft_touch threshold_davidson davidson_criterion
+      
+       call diagonalize_ci
+       deallocate(dressing_matrix)
+     else
+      if(exit_loop)then
+       call set_generators_to_generators_restart
+       call set_psi_det_to_generators
+       exit
+      else 
+       if(.not.do_it_perturbative)cycle
+       if(.not. is_ok_perturbative)cycle
+      endif
+     endif
+     call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
+     do k = 1, N_states
+      print*,'norm_tmp = ',norm_tmp(k)
+      norm_total(k) += norm_tmp(k)
+     enddo
+     call update_density_matrix_osoci
+   enddo
+  endif
+ else 
+  integer :: norb
+  call read_dm_from_mlct(array_dm,norb)
+  call update_density_matrix_alpha_osoci_read(array_dm)
+    do i = norb+1, n_virt_orb
+     i_particl_osoci = list_virt(i)
+ 
+     print*,'--------------------------'
+     ! First set the current generators to the one of restart
+     call check_symetry(i_particl_osoci,thr,test_sym)
+     if(.not.test_sym)cycle
+     call set_generators_to_generators_restart
+     call set_psi_det_to_generators
+     print*,'i_particl_osoci= ',i_particl_osoci
+     ! Initialize the bitmask to the restart ones
+     call initialize_bitmask_to_restart_ones
+     ! Impose that only the hole i_hole_osoci can be done
+     call modify_bitmasks_for_particl(i_particl_osoci)
+     call print_generators_bitmasks_holes
+     ! Impose that only the active part can be reached 
+     call set_bitmask_hole_as_input(unpaired_bitmask)
+!!!  call all_single_h_core
+     call create_restart_and_1p(i_particl_osoci)
+!!!  ! Update the generators 
+     call set_generators_to_psi_det
+     call set_bitmask_particl_as_input(reunion_of_bitmask)
+     call set_bitmask_hole_as_input(reunion_of_bitmask)
+!!!  ! so all the mono excitation on the new generators 
+     call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
+     print*,'is_ok = ',is_ok
+     if(is_ok)then
+       allocate(dressing_matrix(N_det_generators,N_det_generators))
+       dressing_matrix = 0.d0
+       do k = 1, N_det_generators
+        do l = 1, N_det_generators
+          call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
+          dressing_matrix(k,l) = hkl
+        enddo
+       enddo
+       call all_single(e_pt2)
+       call make_s2_eigenfunction_first_order
+       threshold_davidson = 1.d-6
+       soft_touch threshold_davidson davidson_criterion
+      
+       call diagonalize_ci
+       deallocate(dressing_matrix)
+     else
+      if(exit_loop)then
+       call set_generators_to_generators_restart
+       call set_psi_det_to_generators
+       exit
+      else 
+       if(.not.do_it_perturbative)cycle
+       if(.not. is_ok_perturbative)cycle
+      endif
+     endif
+     call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
+     do k = 1, N_states
+      print*,'norm_tmp = ',norm_tmp(k)
+      norm_total(k) += norm_tmp(k)
+     enddo
+     call update_density_matrix_osoci
+   enddo
+ endif
+
+   print*,'norm_total = ',norm_total
+   norm_total = norm_generators_restart
+   norm_total = 1.d0/norm_total
+!  call rescale_density_matrix_osoci(norm_total)
+   double precision :: accu
+   accu = 0.d0
+   do i = 1, mo_tot_num
+    accu += one_body_dm_mo_alpha_osoci(i,i) + one_body_dm_mo_beta_osoci(i,i)
+   enddo
+   print*,'accu = ',accu
+end
+
+subroutine read_dm_from_lmct(array)
+ implicit none
+ integer :: i,iunit ,getUnitAndOpen
+ double precision :: stuff
+ double precision, intent(out) :: array(mo_tot_num)
+ character*(128) :: input
+ input=trim("fort.33")
+ iunit= getUnitAndOpen(input,'r')
+ print*, iunit
+ array = 0.d0
+ do i = 1, n_inact_orb
+  read(iunit,*) stuff
+  print*, list_inact(i),stuff
+  array(list_inact(i)) =  stuff
+ enddo
+end
+
+subroutine read_dm_from_mlct(array,norb)
+ implicit none
+ integer :: i,iunit ,getUnitAndOpen
+ double precision :: stuff
+ double precision, intent(out) :: array(mo_tot_num)
+ character*(128) :: input
+ input=trim("fort.35")
+ iunit= getUnitAndOpen(input,'r')
+ integer,intent(out) :: norb
+ read(iunit,*)norb
+ print*, iunit
+ input=trim("fort.34")
+ iunit= getUnitAndOpen(input,'r')
+ array = 0.d0
+ print*, 'norb = ',norb
+ do i = 1, norb
+  read(iunit,*) stuff
+  print*, list_virt(i),stuff
+  array(list_virt(i)) =  stuff
+ enddo
+end

plugins/FOBOCI/generators_restart_save.irp.f

@@ -9,6 +9,7 @@ BEGIN_PROVIDER [ integer, N_det_generators_restart ]
  integer :: i
  integer, save :: ifirst = 0
  double precision :: norm
+ print*, ' Providing N_det_generators_restart'
  if(ifirst == 0)then
   call ezfio_get_determinants_n_det(N_det_generators_restart)
   ifirst = 1
@@ -30,6 +31,7 @@ END_PROVIDER
  integer                        :: i, k
  integer, save :: ifirst = 0
  double precision, allocatable  :: psi_coef_read(:,:)
+ print*, ' Providing psi_det_generators_restart'
  if(ifirst == 0)then
   call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart)
    do k = 1, N_int

plugins/FOBOCI/hcc_1h1p.irp.f

@@ -1,82 +0,0 @@
-program test_sc2
- implicit none
- read_wf = .True.
- touch read_wf
- call routine
-
-
-end
-
-subroutine routine
-  implicit none
-  double precision, allocatable :: energies(:),diag_H_elements(:)
-  double precision, allocatable :: H_matrix(:,:)
-  allocate(energies(N_states),diag_H_elements(N_det))
-  call diagonalize_CI
-  call test_hcc
-  call test_mulliken
-  allocate(H_matrix(N_det,N_det))
-  stop 'SC2_1h1p_full is not in the git!'
-!  call SC2_1h1p_full(psi_det,psi_coef,energies, &
-!        H_matrix,size(psi_coef,1),N_det,N_states_diag,N_int,threshold_convergence_SC2)
-  deallocate(H_matrix)
-  integer :: i,j
-  double precision :: accu,coef_hf
-! coef_hf = 1.d0/psi_coef(1,1)
-! do i = 1, N_det
-!  psi_coef(i,1) *= coef_hf
-! enddo
-  touch psi_coef
-  call pouet
-end
-
-subroutine pouet
-  implicit none
-  double precision :: accu,coef_hf
-! provide one_body_dm_mo_alpha one_body_dm_mo_beta
-! call density_matrix_1h1p(psi_det,psi_coef,one_body_dm_mo_alpha,one_body_dm_mo_beta,accu,size(psi_coef,1),N_det,N_states_diag,N_int)
-! touch one_body_dm_mo_alpha one_body_dm_mo_beta 
-  call test_hcc
-  call test_mulliken
-! call save_wavefunction
-
-end
-
-subroutine test_hcc
- implicit none
- double precision :: accu
- integer :: i,j
- print*,'Z               AU           GAUSS              MHZ             cm^-1'
- do i = 1, nucl_num
-  write(*,'(I2,X,F3.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i)
- enddo
-
-end
-
-subroutine test_mulliken
- double precision :: accu
- integer :: i
- integer :: j
- accu= 0.d0
- do i = 1, nucl_num
-  print*,i,nucl_charge(i),mulliken_spin_densities(i)
-  accu += mulliken_spin_densities(i)
- enddo
- print*,'Sum of Mulliken SD = ',accu
-!print*,'AO SPIN POPULATIONS'
- accu = 0.d0
-!do i = 1, ao_num
-! accu += spin_gross_orbital_product(i)
-! write(*,'(X,I3,X,A4,X,I2,X,A4,X,F10.7)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),trim(l_to_charater(ao_l(i))),spin_gross_orbital_product(i)
-!enddo
-!print*,'sum = ',accu
-!accu = 0.d0
-!print*,'Angular momentum analysis'
-!do i = 0,  ao_l_max
-! accu += spin_population_angular_momentum(i)
-! print*,' ',trim(l_to_charater(i)),spin_population_angular_momentum(i)
-!print*,'sum = ',accu
-!enddo
-
-end
-

plugins/FOBOCI/routines_foboci.irp.f

@@ -212,12 +212,50 @@ subroutine update_density_matrix_osoci
  integer :: iorb,jorb
  do i = 1, mo_tot_num
   do j = 1, mo_tot_num
-   one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
+   one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
-   one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
+   one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
   enddo
  enddo
 
 
+end
+
+subroutine update_density_matrix_beta_osoci_read(array)
+ implicit none
+ BEGIN_DOC
+ ! one_body_dm_mo_alpha_osoci += Delta rho alpha
+ ! one_body_dm_mo_beta_osoci  += Delta rho beta
+ END_DOC
+ integer :: i,j
+ integer :: iorb,jorb
+ double precision :: array(mo_tot_num)
+ do i = 1, mo_tot_num
+   j = list_act(1)
+   one_body_dm_mo_beta_osoci(i,j) += array(i)
+   one_body_dm_mo_beta_osoci(j,i) += array(i)
+   one_body_dm_mo_beta_osoci(i,i) += array(i) * array(i)
+ enddo
+
+
+end
+
+subroutine update_density_matrix_alpha_osoci_read(array)
+ implicit none
+ BEGIN_DOC
+ ! one_body_dm_mo_alpha_osoci += Delta rho alpha
+ ! one_body_dm_mo_beta_osoci  += Delta rho beta
+ END_DOC
+ integer :: i,j
+ integer :: iorb,jorb
+ double precision :: array(mo_tot_num)
+ do i = 1, mo_tot_num
+   j = list_act(1)
+   one_body_dm_mo_alpha_osoci(i,j) += array(i)
+   one_body_dm_mo_alpha_osoci(j,i) += array(i)
+   one_body_dm_mo_alpha_osoci(i,i) += array(i) * array(i)
+ enddo
+
+
 end
 
 
@@ -387,14 +425,14 @@ subroutine save_osoci_natural_mos
   print*,'ACTIVE ORBITAL  ',iorb
   do j = 1, n_inact_orb
    jorb = list_inact(j)
-   if(dabs(tmp(iorb,jorb)).gt.threshold_lmct)then
+   if(dabs(tmp(iorb,jorb)).gt.0.0001d0)then
     print*,'INACTIVE  '
     print*,'DM ',iorb,jorb,(tmp(iorb,jorb))
    endif
   enddo
   do j = 1, n_virt_orb
    jorb = list_virt(j)
-   if(dabs(tmp(iorb,jorb)).gt.threshold_mlct)then
+   if(dabs(tmp(iorb,jorb)).gt.0.0001d0)then
     print*,'VIRT      '
     print*,'DM ',iorb,jorb,(tmp(iorb,jorb))
    endif
@@ -412,6 +450,10 @@ subroutine save_osoci_natural_mos
  label = "Natural"
  
  call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1)
+!if(disk_access_ao_integrals == "None" .or. disk_access_ao_integrals == "Write" )then
+! disk_access_ao_integrals = "Read"
+! touch disk_access_ao_integrals
+!endif
 !soft_touch mo_coef
  deallocate(tmp,occ)
 
@@ -588,14 +630,14 @@ end
    integer :: i
    double precision :: accu_tot,accu_sd
    print*,'touched the one_body_dm_mo_beta'
-   one_body_dm_mo_alpha = one_body_dm_mo_alpha_osoci
+   one_body_dm_mo_alpha_average = one_body_dm_mo_alpha_osoci
-   one_body_dm_mo_beta = one_body_dm_mo_beta_osoci
+   one_body_dm_mo_beta_average = one_body_dm_mo_beta_osoci
    touch one_body_dm_mo_alpha  one_body_dm_mo_beta 
    accu_tot = 0.d0
    accu_sd  = 0.d0
    do i = 1, mo_tot_num
-    accu_tot += one_body_dm_mo_alpha(i,i) + one_body_dm_mo_beta(i,i)
+    accu_tot += one_body_dm_mo_alpha_average(i,i) + one_body_dm_mo_beta_average(i,i)
-    accu_sd  += one_body_dm_mo_alpha(i,i) - one_body_dm_mo_beta(i,i)
+    accu_sd  += one_body_dm_mo_alpha_average(i,i) - one_body_dm_mo_beta_average(i,i)
    enddo
    print*,'accu_tot = ',accu_tot
    print*,'accu_sdt = ',accu_sd 

plugins/Full_CI/H_apply.irp.f

@@ -7,16 +7,17 @@ s.set_selection_pt2("epstein_nesbet_2x2")
 #s.unset_openmp()
 print s
 
-#s = H_apply("FCI_PT2")
+s = H_apply("FCI_PT2")
-#s.set_perturbation("epstein_nesbet_2x2")
-#s.unset_openmp()
-#print s
-
-s = H_apply_zmq("FCI_PT2")
 s.set_perturbation("epstein_nesbet_2x2")
 s.unset_openmp()
 print s
 
+s = H_apply("FCI_PT2_new")
+s.set_perturbation("decontracted")
+s.unset_openmp()
+print s
+
+
 s = H_apply("FCI_no_skip")
 s.set_selection_pt2("epstein_nesbet_2x2")
 s.unset_skip()

plugins/Full_CI/full_ci.irp.f

@@ -92,8 +92,9 @@ 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 = threshold_generators_pt2
-    threshold_generators = 0.999d0
+    threshold_selectors = threshold_selectors_pt2
+    SOFT_TOUCH threshold_generators threshold_selectors
     call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag,  N_st)
  
     print *,  'Final step'

plugins/Full_CI/full_ci_no_skip.irp.f

@@ -73,9 +73,11 @@ program full_ci
    call diagonalize_CI
    if(do_pt2_end)then
     print*,'Last iteration only to compute the PT2'
+    threshold_generators = threshold_generators_pt2
+    threshold_selectors = threshold_selectors_pt2
+    SOFT_TOUCH threshold_generators threshold_selectors
+    
 !   print*,'The thres'
-    threshold_selectors = 1.d0
-    threshold_generators = 0.999d0
     call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag,  N_st)
  
     print *,  'Final step'

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

plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES

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

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
+

plugins/Full_CI_ZMQ/fci_zmq.irp.f

@@ -48,14 +48,14 @@ program fci_zmq
     call diagonalize_CI
     call save_wavefunction
     
-    if (N_det > N_det_max) then
+!    if (N_det > N_det_max) then
-      psi_det = psi_det_sorted
+!        psi_det = psi_det_sorted
-      psi_coef = psi_coef_sorted
+!        psi_coef = psi_coef_sorted
-      N_det = N_det_max
+!        N_det = N_det_max
-      soft_touch N_det psi_det psi_coef
+!        soft_touch N_det psi_det psi_coef
-      call diagonalize_CI
+!        call diagonalize_CI
-      call save_wavefunction
+!        call save_wavefunction
-    endif
+!    endif
     
     print *,  'N_det          = ', N_det
     print *,  'N_states       = ', N_states
@@ -79,13 +79,14 @@ 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 = 1.d0
+    threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
-    threshold_generators = 0.9999d0
+    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'
@@ -98,7 +99,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
@@ -121,27 +122,29 @@ subroutine ZMQ_selection(N_in, pt2)
   double precision, intent(out)  :: pt2(N_states)
   
   
+  if (.True.) then
+    PROVIDE pt2_e0_denominator
     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_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
+  do i= 1, N_det_generators,step
-    i_generator_start = max(i-step+1,1)
+    i_generator_start = i
-    i_generator_max = i
+    i_generator_max = min(i+step-1,N_det_generators)
     write(task,*) i_generator_start, i_generator_max, 1, N
     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)
+  !$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)
@@ -153,6 +156,9 @@ subroutine ZMQ_selection(N_in, pt2)
   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
 
@@ -161,7 +167,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)

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
 

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)

plugins/Full_CI_ZMQ/selection_single.irp.f

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

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)

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(static,10)
+ 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
+

plugins/MRCC_Utils/davidson.irp.f

@@ -94,7 +94,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
   double precision, allocatable  :: overlap(:,:)
   double precision               :: u_dot_v, u_dot_u
   
-  integer, allocatable           :: kl_pairs(:,:)
   integer                        :: k_pairs, kl
   
   integer                        :: iter2
@@ -144,7 +143,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
   sze_8 = align_double(sze)
 
   allocate(                                                          &
-      kl_pairs(2,N_st_diag*(N_st_diag+1)/2),                         &
       W(sze_8,N_st_diag,davidson_sze_max),                           &
       U(sze_8,N_st_diag,davidson_sze_max),                           &
       R(sze_8,N_st_diag),                                            &
@@ -209,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))
@@ -330,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, &
@@ -351,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)//' ================ ================'
@@ -360,7 +338,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
   call write_time(iunit)
 
   deallocate (                                                       &
-      kl_pairs,                                                      &
       W, residual_norm,                                              &
       U, overlap,                                                    &
       R, c,                                                          &
@@ -573,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
@@ -646,14 +623,12 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
   integer                        :: i,j,k,l,m
   logical                        :: converged
   
-  double precision, allocatable  :: overlap(:,:)
   double precision               :: u_dot_v, u_dot_u
   
-  integer, allocatable           :: kl_pairs(:,:)
   integer                        :: k_pairs, kl
   
   integer                        :: iter2
-  double precision, allocatable  :: W(:,:),  U(:,:), R(:,:), 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
@@ -661,10 +636,10 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
   character*(16384)              :: write_buffer
   double precision               :: to_print(3,N_st)
   double precision               :: cpu, wall
-  integer                        :: shift, shift2
+  integer                        :: shift, shift2, itermax
   include 'constants.include.F'
   
-  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, S, y, h, lambda
+  !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'
   endif
@@ -703,29 +678,29 @@ 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
+  itermax = min(davidson_sze_max, sze/N_st_diag)
-
-  if (s2_eig) then
-    delta = 1.d0
-  else
-    delta = 0.d0
-  endif
-
   allocate(                                                          &
-      kl_pairs(2,N_st_diag*(N_st_diag+1)/2),                         &
+      W(sze_8,N_st_diag*itermax),                                    &
-      W(sze_8,N_st_diag*davidson_sze_max),                           &
+      U(sze_8,N_st_diag*itermax),                                    &
-      U(sze_8,N_st_diag*davidson_sze_max),                           &
+      S(sze_8,N_st_diag*itermax),                                    &
-      R(sze_8,N_st_diag),                                            &
+      h(N_st_diag*itermax,N_st_diag*itermax),                        &
-      S(sze_8,N_st_diag*davidson_sze_max),                           &
+      y(N_st_diag*itermax,N_st_diag*itermax),                        &
-      h(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),      &
+      s_(N_st_diag*itermax,N_st_diag*itermax),                       &
-      y(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),      &
+      s_tmp(N_st_diag*itermax,N_st_diag*itermax),                    &
-      s_(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),     &
-      s_tmp(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),  &
       residual_norm(N_st_diag),                                      &
-      overlap(N_st_diag,N_st_diag),                                  &
+      c(N_st_diag*itermax),                                          &
-      c(N_st_diag*davidson_sze_max),                                 &
+      s2(N_st_diag*itermax),                                         &
-      s2(N_st_diag*davidson_sze_max),                                &
+      overlap(N_st_diag*itermax,N_st_diag*itermax),                  &
-      lambda(N_st_diag*davidson_sze_max))
+      lambda(N_st_diag*itermax))
+
+  h  = 0.d0
+  s_ = 0.d0
+  s_tmp = 0.d0
+  U = 0.d0
+  W = 0.d0
+  S = 0.d0
+  y = 0.d0
+
 
   ASSERT (N_st > 0)
   ASSERT (N_st_diag >= N_st)
@@ -738,24 +713,17 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
   
   converged = .False.
   
-  do k=1,N_st
+  double precision               :: r1, r2
-    call normalize(u_in(1,k),sze)
-  enddo
-
   do k=N_st+1,N_st_diag
       do i=1,sze
-        double precision               :: r1, r2
         call random_number(r1)
         call random_number(r2)
-        u_in(i,k) = dsqrt(-2.d0*dlog(r1))*dcos(dtwo_pi*r2)
+        r1 = dsqrt(-2.d0*dlog(r1))
+        r2 = dtwo_pi*r2
+        u_in(i,k) = r1*dcos(r2)
       enddo
-    
+  enddo
-    ! Gram-Schmidt
+  do k=1,N_st_diag
-    ! ------------
-    call dgemv('T',sze,k-1,1.d0,u_in,size(u_in,1),                   &
-        u_in(1,k),1,0.d0,c,1)
-    call dgemv('N',sze,k-1,-1.d0,u_in,size(u_in,1),                  &
-        c,1,1.d0,u_in(1,k),1)
       call normalize(u_in(1,k),sze)
   enddo
 
@@ -773,11 +741,11 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
       shift  = N_st_diag*(iter-1)
       shift2 = N_st_diag*iter
 
+      call ortho_qr(U,size(U,1),sze,shift2)
 
       ! Compute |W_k> = \sum_i |i><i|H|u_k>
       ! -----------------------------------------
        
-       
       call H_S2_u_0_mrcc_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,&
         istate,N_st_diag,sze_8)
       
@@ -786,26 +754,13 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
       ! -------------------------------------------
 
 
-!      do l=1,N_st_diag
+      call dgemm('T','N', shift2, shift2, sze,            &
-!        do k=1,N_st_diag
+          1.d0, U, size(U,1), W, size(W,1),                &
-!          do iter2=1,iter-1
+          0.d0, h, size(h,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', shift2, N_st_diag, sze,            &
+      call dgemm('T','N', shift2, shift2, sze,            &
-          1.d0, U, size(U,1), W(1,shift+1), size(W,1),                &
+          1.d0, U, size(U,1), S, size(S,1),                &
-          0.d0, h(1,shift+1), size(h,1))
+          0.d0, s_, size(s_,1))
-
-      call dgemm('T','N', shift2, N_st_diag, sze,            &
-          1.d0, U, size(U,1), S(1,shift+1), size(S,1),                &
-          0.d0, s_(1,shift+1), size(s_,1))
 
       ! Diagonalize h
       ! -------------
@@ -829,7 +784,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
     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.3d0)
+          state_ok(k) = (dabs(s2(k)-expected_s2) < 1.d0)
         enddo
         do k=1,shift2
           if (.not. state_ok(k)) then
@@ -848,25 +803,44 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
       endif
 
 
+!      ! Compute overlap with U_in
+!      ! -------------------------
+!      
+!      integer :: coord(2), order(N_st_diag)
+!      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
+!        coord = maxloc(overlap)
+!        order( coord(2) )  = coord(1)
+!        overlap(coord(1),coord(2)) = -1.d0
+!      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
+
+
       ! Express eigenvectors of h in the determinant basis
       ! --------------------------------------------------
       
-!      do k=1,N_st_diag
-!        do i=1,sze
-!          U(i,shift2+k) = 0.d0
-!          W(i,shift2+k) = 0.d0
-!          S(i,shift2+k) = 0.d0
-!        enddo
-!        do l=1,N_st_diag*iter
-!          do i=1,sze
-!            U(i,shift2+k) = U(i,shift2+k) + U(i,l)*y(l,k)
-!            W(i,shift2+k) = W(i,shift2+k) + W(i,l)*y(l,k)
-!            S(i,shift2+k) = S(i,shift2+k) + S(i,l)*y(l,k)
-!          enddo
-!        enddo
-!      enddo
-!
-!
       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,                    &
@@ -877,80 +851,36 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
       ! Compute residual vector
       ! -----------------------
 
-!      do k=1,N_st_diag
-!        print *,  s2(k)
-!        s2(k) = u_dot_v(U(1,shift2+k),  S(1,shift2+k), sze) + S_z2_Sz
-!        print *,  s2(k)
-!        print *,  ''
-!        pause
-!      enddo
       do k=1,N_st_diag
         do i=1,sze
-          R(i,k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
+          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)
+              * (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 (k <= N_st) then
-          residual_norm(k) = u_dot_u(R(1,k),sze)
+          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)
-          if (residual_norm(k) > 1.e9) then
-            stop 'Davidson failed'
-          endif
         endif
       enddo
       
-      write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))')  iter, to_print(:,1:N_st)
+      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
 
-      ! Davidson step
-      ! -------------
-      
-      do k=1,N_st_diag
-        do i=1,sze
-          U(i,shift2+k) =  - R(i,k)/max(H_jj(i) - lambda(k),1.d-2) 
-        enddo
-      enddo
-      
-      ! Gram-Schmidt
-      ! ------------
-      
-      do k=1,N_st_diag
-
-!        do l=1,N_st_diag*iter
-!            c(1) = u_dot_v(U(1,shift2+k),U(1,l),sze)
-!            do i=1,sze
-!              U(i,k,iter+1) = U(i,shift2+k) - c(1) * U(i,l)
-!            enddo
-!        enddo
-!
-        call dgemv('T',sze,N_st_diag*iter,1.d0,U,size(U,1),  &
-              U(1,shift2+k),1,0.d0,c,1)
-        call dgemv('N',sze,N_st_diag*iter,-1.d0,U,size(U,1), &
-              c,1,1.d0,U(1,shift2+k),1)
-!
-!        do l=1,k-1
-!          c(1) = u_dot_v(U(1,shift2+k),U(1,shift2+l),sze)
-!          do i=1,sze
-!            U(i,k,iter+1) = U(i,shift2+k) - c(1) * U(i,shift2+l)
-!          enddo
-!        enddo
-!
-        call dgemv('T',sze,k-1,1.d0,U(1,shift2+1),size(U,1),   &
-            U(1,shift2+k),1,0.d0,c,1)
-        call dgemv('N',sze,k-1,-1.d0,U(1,shift2+1),size(U,1),        &
-            c,1,1.d0,U(1,shift2+k),1)
-
-        call normalize( U(1,shift2+k), sze )
-      enddo
-
     enddo
 
     if (.not.converged) then
-      iter = davidson_sze_max-1
+      iter = itermax-1
     endif
 
     ! Re-contract to u_in
@@ -960,15 +890,6 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
       energies(k) = lambda(k)
     enddo
 
-!    do k=1,N_st_diag
-!      do i=1,sze
-!        do l=1,iter*N_st_diag
-!            u_in(i,k) += U(i,l)*y(l,k)
-!          enddo
-!        enddo
-!      enddo
-!    enddo
-
     call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0,      &
         U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1))
 
@@ -983,10 +904,9 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
   call write_time(iunit)
 
   deallocate (                                                       &
-      kl_pairs,                                                      &
       W, residual_norm,                                              &
-      U, overlap,                                                    &
+      U,                                                             &
-      R, c, S,                                                       &
+      c, S,                                                       &
       h,                                                             &
       y, s_, s_tmp,                                                  &
       lambda                                                         &
@@ -1056,7 +976,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
   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
@@ -1098,8 +1018,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 END DO
-  !$OMP DO SCHEDULE(dynamic)
+  !$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)
@@ -1122,7 +1042,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

plugins/MRCC_Utils/mrcc_dummy.irp.f

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

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_ij, (N_states,N_det_non_ref,N_det_ref) ]
-&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ]
+!&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ]
- implicit none
+! implicit none
- BEGIN_DOC
+! BEGIN_DOC
- ! Dressing matrix in N_det basis
+! ! Dressing matrix in N_det basis
- END_DOC
+! END_DOC
- integer :: i,j,m
+! integer :: i,j,m
- delta_ij = 0.d0
+! delta_ij = 0.d0
- delta_ii = 0.d0
+! delta_ii = 0.d0
- call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref)
+! call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref)
-
+!
-END_PROVIDER
+!END_PROVIDER
              
 
 BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ]
@@ -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,30 @@ END_PROVIDER
    
    if (diag_algorithm == "Davidson") then
      
-!     call davidson_diag_mrcc(psi_det,CI_eigenvectors_dressed,CI_electronic_energy_dressed,&
+     allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), &
-!          size(CI_eigenvectors_dressed,1),N_det,N_states,N_states_diag,N_int,output_determinants,mrcc_state)
+     eigenvalues(size(CI_electronic_energy_dressed,1)))
-
+     do mrcc_state=1,N_states
-     call davidson_diag_mrcc_HS2(psi_det,CI_eigenvectors_dressed,&
+      do j=1,min(N_states,N_det)
-          size(CI_eigenvectors_dressed,1), &
+        do i=1,N_det
-          CI_electronic_energy_dressed,N_det,N_states,N_states_diag,N_int, &
+          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)
+      if (mrcc_state == 1) then
+        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
+      endif
+     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,207 +627,54 @@ 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
+  integer                        :: N, INFO, r1, r2
-  double precision , allocatable :: AtB(:), AtA_val(:), A_val(:,:), x(:), x_new(:), A_val_mwen(:)
+  double precision , allocatable :: AtB(:), x(:), x_new(:), A_val_mwen(:,:), t(:)
-  double precision               :: t, norm, cx, res
+  double precision               :: norm, cx, res
-  integer, allocatable           :: A_ind(:,:), lref(:), AtA_ind(:), A_ind_mwen(:), col_shortcut(:), N_col(:)
+  integer, allocatable           :: lref(:), A_ind_mwen(:)
   double precision               :: phase
   
   
-  integer, allocatable :: pathTo(:), active_hh_idx(:), active_pp_idx(:)
+  double precision, allocatable :: rho_mrcc_init(:)
-  logical, allocatable :: active(:)
-  double precision, allocatable :: rho_mrcc_init(:,:)
-  integer :: nactive
-  
-  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))
-        
-
-  
-  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
   
+  print *, "TI", hh_nex, N_det_non_ref
 
-    !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, A_ind, A_val, x, N_det_ref, nex, N_det_non_ref)&
+  allocate(rho_mrcc_init(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)&
+  allocate(x_new(hh_nex))
-        !$OMP shared(col_shortcut, N_col, AtB, AtA_size, AtA_val, AtA_ind, s, nactive, active_pp_idx)
+  allocate(x(hh_nex), AtB(hh_nex))
-    allocate(A_val_mwen(nex), A_ind_mwen(nex))
-    
-    !$OMP DO schedule(dynamic, 100)
-    do at_roww = 1, nactive ! 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)
-      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 PARALLEL
-    
-    print *, "ATA SIZE", ata_size
   x = 0d0
         
 
-    do a_coll = 1, nactive
+  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, n_exc_active ! hh_nex
+      at_row = active_pp_idx(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
+    end do
+    !$OMP END DO
+   
+    !$OMP END PARALLEL
+
+    X(:) = 0d0
+    
+    
+    do a_coll = 1, n_exc_active
       a_col = active_pp_idx(a_coll)
       X(a_col) = AtB(a_col)
     end do
@@ -822,12 +682,11 @@ END_PROVIDER
     rho_mrcc_init = 0d0
     
     allocate(lref(N_det_ref))
-    !$OMP PARALLEL DO default(shared) schedule(static, 1)            &
-        !$OMP private(lref, hh, pp, II, myMask, myDet, ok, ind, phase)
     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
@@ -837,43 +696,43 @@ 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 PARALLEL DO
+    deallocate(lref)
 
     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)
+      !$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
+        cx = 0.d0
-        do i=col_shortcut(a_coll), col_shortcut(a_coll) + N_col(a_coll) - 1
+        do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1
-          cx = cx + x(AtA_ind(i)) * AtA_val(i)
+          cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i)
         end do
         x_new(a_col) = AtB(a_col) + cx * factor
       end do
@@ -881,22 +740,19 @@ END_PROVIDER
 
       !$OMP END PARALLEL
       
+      
       res = 0.d0
-      
+      do a_coll=1,n_exc_active
-      
-      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)
+          i = active_excitation_to_determinants_idx(j,a_coll)
           if (i==0) exit
-            rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col)
+          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
-        factor = 1.d0
+      if (res > resold) then
-      else
         factor = -factor * 0.5d0
       endif
       resold = res
@@ -908,8 +764,6 @@ END_PROVIDER
       if(res < 1d-9) exit
     end do
     
-    
-    
     norm = 0.d0
     do i=1,N_det_non_ref
       norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s)
@@ -1070,6 +924,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)
@@ -1081,7 +938,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
@@ -1119,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
 
@@ -1179,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
@@ -1247,6 +1120,7 @@ end function
       end if
     end do
   end do
+  hh_nex = hh_shortcut(hh_shortcut(0)+1)-1
 END_PROVIDER
 
 

plugins/MRPT/MRPT_Utils.main.irp.f

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

plugins/MRPT/NEEDED_CHILDREN_MODULES

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

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.

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<uQWmmvd, -.-:=!'
+  print *, '   "{Z jC]QW|=3Zv)Bi3BmXv3  =   _7'
+  print *, '    ]h[Z6)WQ;)jZs]C;|$BZv+, : ./  '
+  print *, '    -#sJX%$Wmm#ev]hinW#Xi:` c ;   '
+  print *, '     #X#X23###1}vI$WWmX1>|,)nr"   '
+  print *, '     4XZ#Xov1v}=)vnXAX1nnv;1n"    '
+  print *, '     ]XX#ZXoovvvivnnnlvvo2*i7     '
+  print *, '     "23Z#1S2oo2XXSnnnoSo2>v"     '
+  print *, '      miX#L -~`""!!1}oSoe|i7      '
+  print *, '      4cn#m,        v221=|v[      '
+  print *, '      ]hI3Zma,;..__wXSe=+vo       '
+  print *, '      ]Zov*XSUXXZXZXSe||vo2       '
+  print *, '      ]Z#><iiii|i||||==vn2(       '
+  print *, '      ]Z#i<ii||+|=||=:{no2[       '
+  print *, '      ]ZUsiiiiivi|=||=vo22[       '
+  print *, '      ]XZvlliiIi|i=|+|vooo        '
+  print *, '      =v1llli||||=|||||lii(       '
+  print *, '      ]iillii||||||||=>=|<        '
+  print *, '      -ziiiii||||||+||==+>        '
+  print *, '       -%|+++||=|=+|=|==/         '
+  print *, '        -a>====+|====-:-          '
+  print *, '          "~,- --   /-            '
+  print *, '            -.     )>             '
+  print *, '           .~      +-             '
+  print *, '           . .... : .             '
+  print *, '            -------~              '
+  print *, ''
+end

plugins/MRPT/print_1h2p.irp.f

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

plugins/Perturbation/EZFIO.cfg

@@ -17,3 +17,16 @@ doc: The selection process stops when the energy ratio variational/(variational+
      is equal to var_pt2_ratio
 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.
+

plugins/Perturbation/NEEDED_CHILDREN_MODULES

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

plugins/Perturbation/pt2_equations.irp.f

@@ -45,6 +45,37 @@ subroutine pt2_epstein_nesbet ($arguments)
   
 end
 
+
+subroutine pt2_decontracted ($arguments)
+  use bitmasks
+  implicit none
+  $declarations
+  
+  BEGIN_DOC
+  END_DOC
+  
+  integer                        :: i,j
+  double precision               :: diag_H_mat_elem_fock, h
+  double precision               :: i_H_psi_array(N_st)
+  double precision               :: coef_pert
+  PROVIDE  selection_criterion
+
+  ASSERT (Nint == N_int)
+  ASSERT (Nint > 0)
+  !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array)
+  call i_H_psi_pert_new_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array,coef_pert)
+  H_pert_diag = 0.d0
+  
+  
+  c_pert(1) = coef_pert
+  e_2_pert(1) = coef_pert * i_H_psi_array(1)
+! print*,coef_pert,i_H_psi_array(1)
+  
+end
+
+
+
+
 subroutine pt2_epstein_nesbet_2x2 ($arguments)
   use bitmasks
   implicit none
@@ -67,8 +98,8 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments)
   ASSERT (Nint == N_int)
   ASSERT (Nint > 0)
 
-  !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array)
+   call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array)
-  call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array)
+  !call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array)
   
   h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint)
   do i =1,N_st
@@ -85,6 +116,75 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments)
         c_pert(i) = 0.d0
       endif
       H_pert_diag(i) = h*c_pert(i)*c_pert(i)
+!     print*, 'N_det,N_det_selectors = ',N_det,N_det_selectors
+!     print*, 'threshold_selectors',threshold_selectors
+!     print*, delta_e,i_H_psi_array(1)
+!     double precision :: hij,accu
+!     accu = 0.d0
+!     do j = 1, N_det
+!       call i_H_j(det_pert,psi_selectors(1,1,j),N_int,hij)
+!       print*, 'psi_selectors_coef(j,1 = ',psi_selectors_coef(j,1),psi_coef(j,1)
+!       call debug_det(psi_det(1,1,i),N_int)
+!       call debug_det(psi_selectors(1,1,i),N_int)
+!       accu += psi_selectors_coef(j,1) * hij
+!     enddo
+!     print*, 'accu,ihpsi0',accu,i_H_psi_array(1)
+!     stop
+    else
+      e_2_pert(i) = 0.d0
+      c_pert(i) = 0.d0
+      H_pert_diag(i) = 0.d0
+    endif
+  enddo
+! if( e_2_pert(1) .ne. 0.d0)then
+! print*,' e_2_pert(1) ', e_2_pert(1)
+! endif
+
+end
+
+
+
+subroutine pt2_epstein_nesbet_2x2_no_ci_diag($arguments)
+  use bitmasks
+  implicit none
+  $declarations
+  
+  BEGIN_DOC
+  ! compute the Epstein-Nesbet 2x2 diagonalization coefficient and energetic contribution
+  !
+  ! for the various N_st states.
+  !
+  ! e_2_pert(i) = 0.5 * (( <det_pert|H|det_pert> -  E(i) )  - sqrt( ( <det_pert|H|det_pert> -  E(i)) ^2 + 4 <psi(i)|H|det_pert>^2  )
+  !
+  ! c_pert(i) = e_2_pert(i)/ <psi(i)|H|det_pert>
+  !
+  END_DOC
+  
+  integer                        :: i,j
+  double precision               :: diag_H_mat_elem_fock,delta_e, h
+  double precision               :: i_H_psi_array(N_st)
+  ASSERT (Nint == N_int)
+  ASSERT (Nint > 0)
+  PROVIDE psi_energy
+
+   call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array)
+  !call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array)
+  
+  h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint)
+  do i =1,N_st
+    if (i_H_psi_array(i) /= 0.d0) then
+      delta_e = h - psi_energy(i)
+      if (delta_e > 0.d0) then
+        e_2_pert(i) = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * i_H_psi_array(i) * i_H_psi_array(i)))
+      else
+        e_2_pert(i) = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * i_H_psi_array(i) * i_H_psi_array(i)))
+      endif
+      if (dabs(i_H_psi_array(i)) > 1.d-6) then
+        c_pert(i) = e_2_pert(i)/i_H_psi_array(i)
+      else
+        c_pert(i) = 0.d0
+      endif
+      H_pert_diag(i) = h*c_pert(i)*c_pert(i)
     else
       e_2_pert(i) = 0.d0
       c_pert(i) = 0.d0
@@ -94,6 +194,8 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments)
 
 end
 
+
+
 subroutine pt2_moller_plesset ($arguments)
   use bitmasks
   implicit none
@@ -144,6 +246,11 @@ subroutine pt2_moller_plesset ($arguments)
   endif
   do i =1,N_st
     H_pert_diag(i) = h
+!   if(dabs(i_H_psi_array(i)).gt.1.d-8)then
+!   print*, i_H_psi_array(i)
+!    call debug_det(det_pert,N_int)
+!    print*, h1,p1,h2,p2,s1,s2
+!   endif
     c_pert(i) = i_H_psi_array(i) *delta_e
     e_2_pert(i) = c_pert(i) * i_H_psi_array(i)
   enddo

plugins/Perturbation/pt2_new.irp.f

@@ -0,0 +1,71 @@
+subroutine i_H_psi_pert_new_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,coef_pert)
+  use bitmasks
+  implicit none
+  integer, intent(in)            :: Nint, Ndet,Ndet_max,Nstate,idx_key(Ndet), N_minilist
+  integer(bit_kind), intent(in)  :: keys(Nint,2,Ndet)
+  integer(bit_kind), intent(in)  :: key(Nint,2)
+  double precision, intent(in)   :: coef(Ndet_max,Nstate)
+  double precision, intent(out)  :: i_H_psi_array(Nstate)
+  double precision, intent(out)  :: coef_pert
+
+  integer                        :: idx(0:Ndet)
+  
+  integer                        :: i, ii,j, i_in_key, i_in_coef
+  double precision               :: phase
+  integer                        :: exc(0:2,2,2)
+  double precision               :: hij
+  double precision :: delta_e_final
+  double precision :: hjj
+  BEGIN_DOC
+! Computes <i|H|Psi> = \sum_J c_J <i|H|J>.
+!
+! Uses filter_connected_i_H_psi0 to get all the |J> to which |i>
+! is connected. The |J> are searched in short pre-computed lists.
+  END_DOC
+  
+  ASSERT (Nint > 0)
+  ASSERT (N_int == Nint)
+  ASSERT (Nstate > 0)
+  ASSERT (Ndet > 0)
+  ASSERT (Ndet_max >= Ndet)
+  i_H_psi_array = 0.d0
+  coef_pert = 0.d0
+  
+  call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx)
+  double precision :: coef_array(Nstate)
+  if (Nstate == 1) then
+
+    do ii=1,idx(0)
+      i_in_key = idx(ii)
+      i_in_coef = idx_key(idx(ii))
+      !DIR$ FORCEINLINE
+      call i_H_j(keys(1,1,i_in_key),key,Nint,hij)
+      i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij
+      do i = 1, Nstate
+       coef_array(i) = coef(i_in_coef,i)
+      enddo
+      call get_delta_e_dyall(keys(1,1,i_in_key),key,coef_array,hij,delta_e_final)
+       
+      coef_pert +=  coef(i_in_coef,1)*hij / delta_e_final
+    enddo
+    if     (coef_pert * i_H_psi_array(1) > 0.d0)then
+      print*, coef_pert * i_H_psi_array(1)
+    endif
+
+  else
+
+    do ii=1,idx(0)
+      i_in_key = idx(ii)
+      i_in_coef = idx_key(idx(ii))
+      !DIR$ FORCEINLINE
+      call i_H_j(keys(1,1,i_in_key),key,Nint,hij)
+      i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij
+      do j = 1, Nstate
+        i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij
+      enddo
+    enddo
+
+  endif
+
+end
+

plugins/Properties/EZFIO.cfg

@@ -3,3 +3,10 @@ type: double precision
 doc: z point on which the integrated delta rho is calculated
 interface: ezfio,provider,ocaml
 default: 3.9
+
+[threshld_two_bod_dm]
+type: double precision
+doc: threshold for the values of the alpha/beta two body dm evaluation
+interface: ezfio,provider,ocaml
+default: 0.000001
+

plugins/Properties/NEEDED_CHILDREN_MODULES

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

plugins/Properties/delta_rho.irp.f

@@ -3,9 +3,9 @@
 &BEGIN_PROVIDER [double precision, z_max]
 &BEGIN_PROVIDER [double precision, delta_z]
  implicit none
- z_min = -20.d0
+ z_min = 0.d0
- z_max = 20.d0
+ z_max = 10.d0
- delta_z = 0.1d0
+ delta_z = 0.005d0
  N_z_pts = (z_max - z_min)/delta_z
  print*,'N_z_pts = ',N_z_pts
 

plugins/Properties/give_mos_at_r.irp.f

@@ -0,0 +1,35 @@
+subroutine give_all_act_mos_at_r(r,mos_array)
+ implicit none
+ double precision, intent(in) :: r(3)
+ double precision, intent(out) :: mos_array(n_act_orb)
+ double precision :: aos_array(ao_num),accu
+ integer :: i,j,iorb
+!print*,'n_act_orb = ',n_act_orb
+ call give_all_aos_at_r(r,aos_array)
+ do i = 1, n_act_orb
+  iorb = list_act(i)
+  accu = 0.d0
+  do j = 1, ao_num
+   accu += mo_coef(j,iorb) * aos_array(j)
+  enddo
+  mos_array(i) = accu
+ enddo
+end
+
+subroutine give_all_core_mos_at_r(r,mos_array)
+ implicit none
+ double precision, intent(in) :: r(3)
+ double precision, intent(out) :: mos_array(n_core_orb)
+ double precision :: aos_array(ao_num),accu
+ integer :: i,j,iorb
+ call give_all_aos_at_r(r,aos_array)
+ do i = 1, n_core_orb
+  iorb = list_core(i)
+  accu = 0.d0
+  do j = 1, ao_num
+   accu += mo_coef(j,iorb) * aos_array(j)
+  enddo
+  mos_array(i) = accu
+ enddo
+end
+

plugins/Properties/hyperfine_constants.irp.f

@@ -102,6 +102,11 @@ END_PROVIDER
  conversion_factor_gauss_hcc(3) = 619.9027742370165d0
  conversion_factor_cm_1_hcc(3) = 579.4924475562677d0
 
+ ! boron 
+ conversion_factor_mhz_hcc(5) = 1434.3655101868d0
+ conversion_factor_gauss_hcc(5) = 511.817264334d0   
+ conversion_factor_cm_1_hcc(5) = 478.4528336953d0     
+
  ! carbon
  conversion_factor_mhz_hcc(6) = 1124.18303629792945d0
  conversion_factor_gauss_hcc(6) = 401.136570647523058d0
@@ -117,6 +122,11 @@ END_PROVIDER
  conversion_factor_gauss_hcc(8) = -216.30574771560407d0
  conversion_factor_cm_1_hcc(8) = -202.20517197179822d0
 
+ ! Phosphore
+ conversion_factor_mhz_hcc(15) = 1811.0967763744873d0
+ conversion_factor_gauss_hcc(15) = 646.2445276897648d0
+ conversion_factor_cm_1_hcc(15) = 604.1170297381395d0
+ 
 END_PROVIDER 
 
  BEGIN_PROVIDER [double precision, iso_hcc_mhz, (nucl_num)]
@@ -141,7 +151,7 @@ subroutine print_hcc
  integer :: i,j
  print*,'Z               AU           GAUSS              MHZ             cm^-1'
  do i = 1, nucl_num
-  write(*,'(I2,X,F3.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i)
+  write(*,'(I2,X,F4.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i)
  enddo
 
 end

plugins/Properties/iunit_two_bod.irp.f

@@ -0,0 +1,45 @@
+BEGIN_PROVIDER [integer, i_unit_x_two_body_dm_ab]
+ implicit none
+ integer :: getUnitAndOpen
+ character*(128) :: file_name
+ file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_x')
+ i_unit_x_two_body_dm_ab = getUnitAndOpen(file_name,'w')
+
+END_PROVIDER 
+
+BEGIN_PROVIDER [integer, i_unit_y_two_body_dm_ab]
+ implicit none
+ integer :: getUnitAndOpen
+ character*(128) :: file_name
+ file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_y')
+ i_unit_y_two_body_dm_ab = getUnitAndOpen(file_name,'w')
+
+END_PROVIDER 
+
+BEGIN_PROVIDER [integer, i_unit_z_two_body_extra_diag_dm_ab]
+ implicit none
+ integer :: getUnitAndOpen
+ character*(128) :: file_name
+ file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_extra_diag')
+ i_unit_z_two_body_extra_diag_dm_ab = getUnitAndOpen(file_name,'w')
+
+END_PROVIDER 
+
+BEGIN_PROVIDER [integer, i_unit_z_two_body_diag_dm_ab]
+ implicit none
+ integer :: getUnitAndOpen
+ character*(128) :: file_name
+ file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_diag')
+ i_unit_z_two_body_diag_dm_ab = getUnitAndOpen(file_name,'w')
+
+END_PROVIDER 
+
+BEGIN_PROVIDER [integer, i_unit_z_two_body_total_dm_ab]
+ implicit none
+ integer :: getUnitAndOpen
+ character*(128) :: file_name
+ file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_total')
+ i_unit_z_two_body_total_dm_ab = getUnitAndOpen(file_name,'w')
+
+END_PROVIDER 
+

plugins/Properties/mulliken.irp.f

@@ -14,13 +14,16 @@ BEGIN_PROVIDER [double precision, spin_population, (ao_num_align,ao_num)]
  enddo
 END_PROVIDER
 
-BEGIN_PROVIDER [double precision, spin_population_angular_momentum, (0:ao_l_max)]
+ BEGIN_PROVIDER [double precision, spin_population_angular_momentum, (0:ao_l_max)]
+&BEGIN_PROVIDER [double precision, spin_population_angular_momentum_per_atom, (0:ao_l_max,nucl_num)]
  implicit none
  integer :: i
  double precision :: accu
  spin_population_angular_momentum = 0.d0
+ spin_population_angular_momentum_per_atom = 0.d0
  do i = 1,  ao_num
   spin_population_angular_momentum(ao_l(i)) += spin_gross_orbital_product(i)
+  spin_population_angular_momentum_per_atom(ao_l(i),ao_nucl(i)) += spin_gross_orbital_product(i)
  enddo
 
 END_PROVIDER 
@@ -133,6 +136,16 @@ subroutine print_mulliken_sd
   print*,' ',trim(l_to_charater(i)),spin_population_angular_momentum(i)
  print*,'sum = ',accu
  enddo
+ print*,'Angular momentum analysis per atom'
+ print*,'Angular momentum analysis'
+ do j = 1,nucl_num
+  accu = 0.d0
+  do i = 0,  ao_l_max
+   accu += spin_population_angular_momentum_per_atom(i,j)
+   write(*,'(XX,I3,XX,A4,X,A4,X,F10.7)')j,trim(element_name(int(nucl_charge(j)))),trim(l_to_charater(i)),spin_population_angular_momentum_per_atom(i,j)
+   print*,'sum = ',accu
+  enddo
+ enddo
 
 end
 

plugins/Properties/print_spin_density.irp.f

@@ -0,0 +1,36 @@
+program print_sd
+ implicit none
+ read_wf = .True.
+ touch read_wf
+ call routine
+
+end
+
+subroutine routine
+ implicit none
+ integer :: i,j,k
+ double precision :: z
+ double precision :: r(3),accu,accu_alpha,accu_beta,tmp
+ double precision, allocatable :: aos_array(:)
+ allocate(aos_array(ao_num))
+ r = 0.d0
+ r(1) = z_min
+ do i = 1, N_z_pts
+  call give_all_aos_at_r(r,aos_array)
+  accu = 0.d0
+  accu_alpha = 0.d0
+  accu_beta  = 0.d0
+  do j = 1, ao_num
+   do k = 1, ao_num
+    tmp =  aos_array(k) * aos_array(j)
+    accu += one_body_spin_density_ao(k,j) * tmp 
+    accu_alpha += one_body_dm_ao_alpha(k,j) * tmp 
+    accu_beta  += one_body_dm_ao_beta(k,j) * tmp
+   enddo
+  enddo
+  r(1) += delta_z
+  write(33,'(100(f16.10,X))')r(1),accu,accu_alpha,accu_beta
+ enddo
+ 
+
+end

plugins/Properties/provide_deltarho.irp.f

@@ -0,0 +1,11 @@
+program pouet
+ implicit none
+ read_wf = .True.
+ touch read_wf
+ call routine
+end
+
+subroutine routine
+ implicit none
+ provide  integrated_delta_rho_all_points
+end

plugins/Properties/test_two_body_dm.irp.f

@@ -0,0 +1,105 @@
+program test_two_bod
+ implicit none
+ read_wf = .True.
+ touch read_wf
+ call routine
+end
+subroutine routine
+ implicit none
+ integer :: i,j,k,l
+ integer :: h1,p1,h2,p2,s1,s2
+ double precision :: accu,get_two_body_dm_ab_map_element,get_mo_bielec_integral
+ accu = 0.d0
+
+ ! Diag part of the core two body dm 
+ do i = 1, n_core_orb
+  h1 = list_core(i)
+  do j = 1, n_core_orb
+   h2 = list_core(j)
+   accu += two_body_dm_ab_diag_core(j,i) * mo_bielec_integral_jj(h1,h2)
+  enddo
+ enddo
+
+ ! Diag part of the active two body dm
+ do i = 1, n_act_orb
+  h1 = list_act(i)
+  do j = 1, n_act_orb
+   h2 = list_act(j)
+   accu += two_body_dm_ab_diag_act(j,i) * mo_bielec_integral_jj(h1,h2)
+  enddo
+ enddo
+
+ ! Diag part of the active <-> core two body dm
+ do i = 1, n_act_orb
+  h1 = list_act(i)
+  do j = 1, n_core_orb
+   h2 = list_core(j)
+   accu += two_body_dm_diag_core_act(j,i) * mo_bielec_integral_jj(h1,h2)
+  enddo
+ enddo
+ print*,'BI ELECTRONIC   =  ',accu
+
+ double precision :: accu_extra_diag
+ accu_extra_diag = 0.d0
+ ! purely active part of the two body dm 
+ do l = 1, n_act_orb  ! p2 
+  p2 = list_act(l)
+  do k = 1, n_act_orb  ! h2 
+   h2 = list_act(k)
+   do j = 1, n_act_orb  ! p1 
+    p1 = list_act(j)
+    do i = 1,n_act_orb   ! h1 
+     h1 = list_act(i)
+     accu_extra_diag += two_body_dm_ab_big_array_act(i,j,k,l) * get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map)
+    enddo
+   enddo
+  enddo
+ enddo
+ 
+ ! core <-> active part of the two body dm  
+ do l = 1, n_act_orb  ! p1 
+  p1 = list_act(l)
+  do k = 1, n_act_orb  ! h1 
+   h1 = list_act(k)
+    do i = 1,n_core_orb ! h2 
+     h2 = list_core(i)
+     accu_extra_diag += two_body_dm_ab_big_array_core_act(i,k,l) * get_mo_bielec_integral(h1,h2,p1,h2,mo_integrals_map)
+    enddo
+  enddo
+ enddo
+
+ print*,'extra_diag = ',accu_extra_diag
+ double precision :: average_mono
+ call get_average(mo_mono_elec_integral,one_body_dm_mo,average_mono)
+ print*,'BI ELECTRONIC   =  ',accu+accu_extra_diag
+ print*,'MONO ELECTRONIC =  ',average_mono
+ print*,'Total elec      =  ',accu+average_mono + accu_extra_diag
+ print*,'Total           =  ',accu+average_mono+nuclear_repulsion +accu_extra_diag
+ double precision :: e_0,hij
+ call u_0_H_u_0(e_0,psi_coef,n_det,psi_det,N_int)
+ print*,'<Psi| H |Psi>   =  ',e_0 + nuclear_repulsion
+ integer :: degree
+ integer                        :: exc(0:2,2,2)
+ double precision               :: phase
+ integer :: n_elements
+ n_elements = 0
+ accu = 0.d0
+ do i = 1, N_det
+  do j = i+1, N_det
+   call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int)
+   if(degree.gt.2)cycle
+!  if(degree.ne.1)cycle
+   call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   if(s1.eq.s2)cycle
+   n_elements += 1
+   call i_H_j(psi_det(1,1,i),psi_det(1,1,j),N_int,hij)
+   accu += 2.d0 * hij * psi_coef(i,1) * psi_coef(j,1)
+  enddo
+ enddo
+ print*,'n_elements  = ',n_elements
+ print*,'<Psi| extra diag   ',accu
+ print*,'dm                 ',accu_extra_diag
+ 
+
+end

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

plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES

@@ -0,0 +1 @@
+

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.

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 <i|H|psi> for perturbation.
+  END_DOC
+  integer                        :: i, k, l, m
+  logical                        :: good
+
+  do i=1,N_det_generators
+    do k=1,N_int
+      psi_selectors(k,1,i) = psi_det_generators(k,1,i)
+      psi_selectors(k,2,i) = psi_det_generators(k,2,i)
+    enddo
+  enddo
+  do k=1,N_states
+    do i=1,N_det_selectors
+      psi_selectors_coef(i,k) = psi_coef_generators(i,k)
+    enddo
+  enddo
+
+  m=N_det_generators
+
+  do i=1,N_det
+    do l=1,n_cas_bitmask
+      good = .True.
+      do k=1,N_int
+        good = good .and. (                                         &
+            iand(not(cas_bitmask(k,1,l)), psi_det_sorted(k,1,i)) ==         &
+            iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. (   &
+            iand(not(cas_bitmask(k,2,l)), psi_det_sorted(k,2,i)) ==         &
+            iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) )
+      enddo
+      if (good) then
+        exit
+      endif
+    enddo
+    if (.not.good) then
+      m = m+1
+      do k=1,N_int
+        psi_selectors(k,1,m) = psi_det_sorted(k,1,i)
+        psi_selectors(k,2,m) = psi_det_sorted(k,2,i)
+      enddo
+      psi_selectors_coef(m,:) = psi_coef_sorted(i,:)
+    endif
+  enddo
+  if (N_det /= m) then
+    print *,  N_det, m
+    stop 'N_det /= m'
+  endif
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ]
+  implicit none
+  BEGIN_DOC
+  ! Transposed psi_selectors
+  END_DOC
+  integer                        :: i,k
+
+  do i=1,N_det_selectors
+    do k=1,N_states
+      psi_selectors_coef_transp(k,i) = psi_selectors_coef(i,k) 
+    enddo
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, psi_selectors_diag_h_mat, (psi_selectors_size) ]
+  implicit none
+  BEGIN_DOC
+  ! Diagonal elements of the H matrix for each selectors 
+  END_DOC
+  integer                        :: i
+  double precision :: diag_H_mat_elem
+  do i = 1, N_det_selectors
+   psi_selectors_diag_h_mat(i) = diag_H_mat_elem(psi_selectors(1,1,i),N_int)
+  enddo
+END_PROVIDER
+
+

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

plugins/Selectors_full/e_corr_selectors.irp.f

@@ -56,7 +56,7 @@ END_PROVIDER
    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))
+!  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

plugins/Selectors_full/selectors.irp.f

@@ -14,13 +14,13 @@ 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
       norm = norm + psi_average_norm_contrib_sorted(i)
       if (norm > threshold_selectors) then
-        N_det_selectors = i-1
+        N_det_selectors = i
         exit
       endif
     enddo

plugins/Selectors_no_sorted/selectors.irp.f

@@ -40,6 +40,7 @@ END_PROVIDER
   do k=1,N_states
     do i=1,N_det_selectors
       psi_selectors_coef(i,k) = psi_coef(i,k)
+!     print*, 'psi_selectors_coef(i,k) == ',psi_selectors_coef(i,k)
     enddo
   enddo
 END_PROVIDER

plugins/loc_cele/NEEDED_CHILDREN_MODULES

@@ -1 +1 @@
-MO_Basis
+MO_Basis  Integrals_Bielec Bitmask

plugins/loc_cele/loc_cele.irp.f

@@ -92,7 +92,7 @@
 
 
 
-      nrot(1) = 64  ! number of orbitals to be localized
+      nrot(1) = 2   ! number of orbitals to be localized
 
 
       integer :: index_rot(1000,1)
@@ -101,261 +101,73 @@
        cmoref = 0.d0
        irot = 0
 
-! H2 molecule for the mixed localization
+       irot(1,1) = 11
-      do i=1,64
+       irot(2,1) = 12
-       irot(i,1) = i+2
+       cmoref(15,1,1)   = 1.d0   ! 
-      enddo
+       cmoref(14,2,1)   = 1.d0   ! 
 
-      do i=1,17
+! ESATRIENE with 3 bonding and anti bonding orbitals 
-       cmoref(i+1,i,1)=1.d0
+! First bonding orbital for esa
-      enddo
-       cmoref(19,19-1,1)=1.d0
-       cmoref(20,19-1,1)=-1.d0
-       cmoref(19,20-1,1)=-1.d0
-       cmoref(20,20-1,1)=-1.d0
-       cmoref(21,20-1,1)=2.d0
-       cmoref(22,21-1,1)=1.d0
-       cmoref(23,22-1,1)=1.d0
-       cmoref(24,23-1,1)=1.d0
-
-
-       cmoref(25,24-1,1)=1.d0
-       cmoref(26,24-1,1)=-1.d0
-       cmoref(25,25-1,1)=-1.d0
-       cmoref(26,25-1,1)=-1.d0
-       cmoref(27,25-1,1)=2.d0
-       cmoref(28,26-1,1)=1.d0
-       cmoref(29,27-1,1)=1.d0
-       cmoref(30,28-1,1)=1.d0
-      
-       cmoref(31,29-1,1)=1.d0
-       cmoref(32,29-1,1)=-1.d0
-       cmoref(31,30-1,1)=-1.d0
-       cmoref(32,30-1,1)=-1.d0
-       cmoref(33,30-1,1)=2.d0
-       cmoref(34,31-1,1)=1.d0
-       cmoref(35,32-1,1)=1.d0
-       cmoref(36,33-1,1)=1.d0
-
-       do i=33,49
-        cmoref(i+5,i,1)= 1.d0
-       enddo
-
-       cmoref(55,52-2,1)=1.d0
-       cmoref(56,52-2,1)=-1.d0
-       cmoref(55,53-2,1)=-1.d0
-       cmoref(56,53-2,1)=-1.d0
-       cmoref(57,53-2,1)=2.d0
-       cmoref(58,54-2,1)=1.d0
-       cmoref(59,55-2,1)=1.d0
-       cmoref(60,56-2,1)=1.d0
-
-       cmoref(61,57-2,1)=1.d0
-       cmoref(62,57-2,1)=-1.d0
-       cmoref(61,58-2,1)=-1.d0
-       cmoref(62,58-2,1)=-1.d0
-       cmoref(63,58-2,1)=2.d0
-       cmoref(64,59-2,1)=1.d0
-       cmoref(65,60-2,1)=1.d0
-       cmoref(66,61-2,1)=1.d0
-
-       cmoref(67,62-2,1)=1.d0
-       cmoref(68,62-2,1)=-1.d0
-       cmoref(67,63-2,1)=-1.d0
-       cmoref(68,63-2,1)=-1.d0
-       cmoref(69,63-2,1)=2.d0
-       cmoref(70,64-2,1)=1.d0
-       cmoref(71,65-2,1)=1.d0
-       cmoref(72,66-2,1)=1.d0
-! H2 molecule
-!      do i=1,66
-!       irot(i,1) = i
-!      enddo
-!
-!      do i=1,18
-!       cmoref(i,i,1)=1.d0
-!      enddo
-!       cmoref(19,19,1)=1.d0
-!       cmoref(20,19,1)=-1.d0
-!       cmoref(19,20,1)=-1.d0
-!       cmoref(20,20,1)=-1.d0
-!       cmoref(21,20,1)=2.d0
-!       cmoref(22,21,1)=1.d0
-!       cmoref(23,22,1)=1.d0
-!       cmoref(24,23,1)=1.d0
-!
-!
-!       cmoref(25,24,1)=1.d0
-!       cmoref(26,24,1)=-1.d0
-!       cmoref(25,25,1)=-1.d0
-!       cmoref(26,25,1)=-1.d0
-!       cmoref(27,25,1)=2.d0
-!       cmoref(28,26,1)=1.d0
-!       cmoref(29,27,1)=1.d0
-!       cmoref(30,28,1)=1.d0
-!      
-!       cmoref(31,29,1)=1.d0
-!       cmoref(32,29,1)=-1.d0
-!       cmoref(31,30,1)=-1.d0
-!       cmoref(32,30,1)=-1.d0
-!       cmoref(33,30,1)=2.d0
-!       cmoref(34,31,1)=1.d0
-!       cmoref(35,32,1)=1.d0
-!       cmoref(36,33,1)=1.d0
-!
-!       do i=34,51
-!        cmoref(i+3,i,1)= 1.d0
-!       enddo
-!
-!       cmoref(55,52,1)=1.d0
-!       cmoref(56,52,1)=-1.d0
-!       cmoref(55,53,1)=-1.d0
-!       cmoref(56,53,1)=-1.d0
-!       cmoref(57,53,1)=2.d0
-!       cmoref(58,54,1)=1.d0
-!       cmoref(59,55,1)=1.d0
-!       cmoref(60,56,1)=1.d0
-!
-!       cmoref(61,57,1)=1.d0
-!       cmoref(62,57,1)=-1.d0
-!       cmoref(61,58,1)=-1.d0
-!       cmoref(62,58,1)=-1.d0
-!       cmoref(63,58,1)=2.d0
-!       cmoref(64,59,1)=1.d0
-!       cmoref(65,60,1)=1.d0
-!       cmoref(66,61,1)=1.d0
-!
-!       cmoref(67,62,1)=1.d0
-!       cmoref(68,62,1)=-1.d0
-!       cmoref(67,63,1)=-1.d0
-!       cmoref(68,63,1)=-1.d0
-!       cmoref(69,63,1)=2.d0
-!       cmoref(70,64,1)=1.d0
-!       cmoref(71,65,1)=1.d0
-!       cmoref(72,66,1)=1.d0
-! H atom
-!      do i=1,33
-!       irot(i,1) = i
-!      enddo
-!
-!      do i=1,18
-!       cmoref(i,i,1)=1.d0
-!      enddo
-!       cmoref(19,19,1)=1.d0
-!       cmoref(20,19,1)=-1.d0
-!       cmoref(19,20,1)=-1.d0
-!       cmoref(20,20,1)=-1.d0
-!       cmoref(21,20,1)=2.d0
-!       cmoref(22,21,1)=1.d0
-!       cmoref(23,22,1)=1.d0
-!       cmoref(24,23,1)=1.d0
-
-
-!       cmoref(25,24,1)=1.d0
-!       cmoref(26,24,1)=-1.d0
-!       cmoref(25,25,1)=-1.d0
-!       cmoref(26,25,1)=-1.d0
-!       cmoref(27,25,1)=2.d0
-!       cmoref(28,26,1)=1.d0
-!       cmoref(29,27,1)=1.d0
-!       cmoref(30,28,1)=1.d0
-!      
-!       cmoref(31,29,1)=1.d0
-!       cmoref(32,29,1)=-1.d0
-!       cmoref(31,30,1)=-1.d0
-!       cmoref(32,30,1)=-1.d0
-!       cmoref(33,30,1)=2.d0
-!       cmoref(34,31,1)=1.d0
-!       cmoref(35,32,1)=1.d0
-!       cmoref(36,33,1)=1.d0
- 
-       ! Definition of the index of the MO to be rotated
-!      irot(2,1) = 21  ! the first mo to be rotated is the 21 th MO 
-!      irot(3,1) = 22  ! etc....
-!      irot(4,1) = 23  ! 
-!      irot(5,1) = 24  ! 
-!      irot(6,1) = 25  ! 
-
-!N2
-!       irot(1,1) = 5
-!       irot(2,1) = 6
-!       irot(3,1) = 7
-!       irot(4,1) = 8
-!       irot(5,1) = 9
-!       irot(6,1) = 10
-!
-!       cmoref(5,1,1) = 1.d0   ! 
-!       cmoref(6,2,1) = 1.d0   ! 
-!       cmoref(7,3,1) = 1.d0   ! 
-!       cmoref(40,4,1) = 1.d0   ! 
-!       cmoref(41,5,1) = 1.d0   ! 
-!       cmoref(42,6,1) =  1.d0   ! 
-!END N2
-
-!HEXATRIENE
-!       irot(1,1) = 20
-!       irot(2,1) = 21
-!       irot(3,1) = 22
-!       irot(4,1) = 23
-!       irot(5,1) = 24
-!       irot(6,1) = 25
-!
 !      cmoref(7,1,1)   = 1.d0   ! 
 !      cmoref(26,1,1)  = 1.d0   ! 
+! Second bonding orbital for esa
 !      cmoref(45,2,1)  = 1.d0   ! 
 !      cmoref(64,2,1)  = 1.d0   ! 
+! Third bonding orbital for esa
 !      cmoref(83,3,1)  = 1.d0   ! 
 !      cmoref(102,3,1) = 1.d0   ! 
+
+! First anti bonding orbital for esa
 !      cmoref(7,4,1)   = 1.d0   ! 
 !      cmoref(26,4,1)  = -1.d0   ! 
+! Second anti bonding orbital for esa
 !      cmoref(45,5,1)  = 1.d0   ! 
 !      cmoref(64,5,1)  = -1.d0   ! 
+! Third anti bonding orbital for esa
 !      cmoref(83,6,1)  = 1.d0   ! 
 !      cmoref(102,6,1) = -1.d0   ! 
-!END HEXATRIENE
 
-!!!!H2                                 H2 CAS
+! ESATRIENE with 2 bonding and anti bonding orbitals 
-!        irot(1,1) = 1
+! AND 2 radical orbitals
-!        irot(2,1) = 2
+! First radical orbital 
-!        
+!      cmoref(7,1,1)   = 1.d0   ! 
-!        cmoref(1,1,1) = 1.d0
+! First bonding orbital 
-!        cmoref(37,2,1) = 1.d0  
+!      cmoref(26,2,1)  = 1.d0   ! 
-!END H2
+!      cmoref(45,2,1)  = 1.d0   ! 
-!!!!  LOCALIZATION ON THE BASIS FUNCTIONS
+! Second bonding orbital 
-!        do i = 1, nrot(1)
+!      cmoref(64,3,1)  = 1.d0   ! 
-!          irot(i,1) = i 
+!      cmoref(83,3,1)  = 1.d0   ! 
-!          cmoref(i,i,1) = 1.d0
+! Second radical orbital for esa
-!        enddo
+!      cmoref(102,4,1) = 1.d0   ! 
+
+! First anti bonding orbital for esa
+!      cmoref(26,5,1)  = 1.d0   ! 
+!      cmoref(45,5,1)  =-1.d0   ! 
+! Second anti bonding orbital for esa
+!      cmoref(64,6,1)  = 1.d0   ! 
+!      cmoref(83,6,1)  =-1.d0   ! 
+
+! ESATRIENE with 1 central bonding and anti bonding orbitals 
+! AND 4 radical orbitals
+! First radical orbital 
+       cmoref(7,1,1)   = 1.d0   ! 
+! Second radical orbital 
+       cmoref(26,2,1)  = 1.d0   ! 
+! First bonding orbital 
+       cmoref(45,3,1)  = 1.d0   ! 
+       cmoref(64,3,1)  = 1.d0   ! 
+! Third radical orbital for esa
+       cmoref(83,4,1)  = 1.d0   ! 
+! Fourth radical orbital for esa
+       cmoref(102,5,1) = 1.d0   ! 
+! First anti bonding orbital 
+       cmoref(45,6,1)  = 1.d0   ! 
+       cmoref(64,6,1)  =-1.d0   ! 
 
-!END BASISLOC
 
-!       do i = 1, nrot(1)
-!        irot(i,1) = 4+i 
-!       enddo
        do i = 1, nrot(1)
         print*,'irot(i,1) = ',irot(i,1)
        enddo
-!       pause
- 
-       ! you define the guess vectors that you want 
-       ! the new MO to be close to
-       ! cmore(i,j,1) = < AO_i | guess_vector_MO(j) >
-       ! i goes from 1 to ao_num 
-       ! j goes from 1 to nrot(1) 
-
-       ! Here you must go to the GAMESS output file 
-       ! where the AOs are listed and explicited 
-       ! From the basis of this knowledge you can build your 
-       ! own guess vectors for the MOs
-       ! The new MOs are provided in output 
-       ! in the same order than the guess MOs 
-!      do i = 1, nrot(1)
-!       j = 5+(i-1)*15
-!       cmoref(j,i,1)    = 0.2d0
-!       cmoref(j+3,i,1)  = 0.12d0
-!       print*,'j = ',j
-!      enddo
-!      pause
 
 
 

plugins/loc_cele/loc_exchange_int.irp.f

@@ -0,0 +1,110 @@
+program loc_int
+ implicit none
+ integer :: i,j,k,l,iorb,jorb
+ double precision :: exchange_int(mo_tot_num)
+ integer :: iorder(mo_tot_num)
+ integer :: indices(mo_tot_num,2)
+ logical :: list_core_inact_check(mo_tot_num)
+ integer :: n_rot
+ indices = 0
+ list_core_inact_check = .True. 
+ n_rot = 0
+ do i = 1, n_core_inact_orb
+  iorb = list_core_inact(i)
+  exchange_int = 0.d0
+  iorder = 0
+  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
+   exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
+  enddo
+  n_rot += 1
+  call dsort(exchange_int,iorder,mo_tot_num)
+  indices(n_rot,1) = iorb
+  indices(n_rot,2) = iorder(1)
+  list_core_inact_check(iorder(1)) = .False.
+  print*,indices(n_rot,1),indices(n_rot,2)
+  print*,''
+  print*,''
+ enddo
+  print*,'****************************'
+  print*,'-+++++++++++++++++++++++++'
+ do i = 1, n_rot
+  iorb = indices(i,1) 
+  jorb = indices(i,2) 
+  print*,iorb,jorb
+  call mix_mo_jk(iorb,jorb)
+ enddo
+
+ indices = 0
+ list_core_inact_check = .True. 
+ n_rot = 0
+ do i = 1, n_act_orb
+  iorb = list_act(i)
+  exchange_int = 0.d0
+  iorder = 0
+  print*,''
+  if(list_core_inact_check(iorb) .eqv. .False.)cycle
+  do j = i+1, n_act_orb
+   jorb = list_act(j)
+   iorder(jorb) = jorb
+   exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
+  enddo
+  n_rot += 1
+  call dsort(exchange_int,iorder,mo_tot_num)
+  indices(n_rot,1) = iorb
+  indices(n_rot,2) = iorder(1)
+  list_core_inact_check(iorder(1)) = .False.
+  print*,indices(n_rot,1),indices(n_rot,2)
+  print*,''
+  print*,''
+ enddo
+  print*,'****************************'
+  print*,'-+++++++++++++++++++++++++'
+ do i = 1, n_rot
+  iorb = indices(i,1) 
+  jorb = indices(i,2) 
+  print*,iorb,jorb
+  call mix_mo_jk(iorb,jorb)
+ enddo
+
+ indices = 0
+ list_core_inact_check = .True. 
+ n_rot = 0
+ do i = 1, n_virt_orb
+  iorb = list_virt(i)
+  exchange_int = 0.d0
+  iorder = 0
+  print*,''
+  if(list_core_inact_check(iorb) .eqv. .False.)cycle
+  do j = i+1, n_virt_orb
+   jorb = list_virt(j)
+   iorder(jorb) = jorb
+   exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
+  enddo
+  n_rot += 1
+  call dsort(exchange_int,iorder,mo_tot_num)
+  indices(n_rot,1) = iorb
+  indices(n_rot,2) = iorder(1)
+  list_core_inact_check(iorder(1)) = .False.
+  print*,indices(n_rot,1),indices(n_rot,2)
+  print*,''
+  print*,''
+ enddo
+  print*,'****************************'
+  print*,'-+++++++++++++++++++++++++'
+ do i = 1, n_rot
+  iorb = indices(i,1) 
+  jorb = indices(i,2) 
+  print*,iorb,jorb
+  call mix_mo_jk(iorb,jorb)
+ enddo
+
+
+
+ call save_mos
+ 
+
+end

plugins/loc_cele/loc_exchange_int_act.irp.f

@@ -0,0 +1,45 @@
+program loc_int
+ implicit none
+ integer :: i,j,k,l,iorb,jorb
+ double precision :: exchange_int(mo_tot_num)
+ integer :: iorder(mo_tot_num)
+ integer :: indices(mo_tot_num,2)
+ logical :: list_core_inact_check(mo_tot_num)
+ integer :: n_rot
+
+ indices = 0
+ list_core_inact_check = .True. 
+ n_rot = 0
+ do i = 1, n_act_orb
+  iorb = list_act(i)
+  exchange_int = 0.d0
+  iorder = 0
+  print*,''
+  if(list_core_inact_check(iorb) .eqv. .False.)cycle
+  do j = i+1, n_act_orb
+   jorb = list_act(j)
+   iorder(jorb) = jorb
+   exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
+  enddo
+  n_rot += 1
+  call dsort(exchange_int,iorder,mo_tot_num)
+  indices(n_rot,1) = iorb
+  indices(n_rot,2) = iorder(1)
+  list_core_inact_check(iorder(1)) = .False.
+  print*,indices(n_rot,1),indices(n_rot,2)
+  print*,''
+  print*,''
+ enddo
+  print*,'****************************'
+  print*,'-+++++++++++++++++++++++++'
+ do i = 1, n_rot
+  iorb = indices(i,1) 
+  jorb = indices(i,2) 
+  print*,iorb,jorb
+  call mix_mo_jk(iorb,jorb)
+ enddo
+
+ call save_mos
+ 
+
+end

plugins/loc_cele/loc_exchange_int_inact.irp.f

@@ -0,0 +1,45 @@
+program loc_int
+ implicit none
+ integer :: i,j,k,l,iorb,jorb
+ double precision :: exchange_int(mo_tot_num)
+ integer :: iorder(mo_tot_num)
+ integer :: indices(mo_tot_num,2)
+ logical :: list_core_inact_check(mo_tot_num)
+ integer :: n_rot
+ indices = 0
+ list_core_inact_check = .True. 
+ n_rot = 0
+ do i = 1, n_core_inact_orb
+  iorb = list_core_inact(i)
+  exchange_int = 0.d0
+  iorder = 0
+  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
+   exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
+  enddo
+  n_rot += 1
+  call dsort(exchange_int,iorder,mo_tot_num)
+  indices(n_rot,1) = iorb
+  indices(n_rot,2) = iorder(1)
+  list_core_inact_check(iorder(1)) = .False.
+  print*,indices(n_rot,1),indices(n_rot,2)
+  print*,''
+  print*,''
+ enddo
+  print*,'****************************'
+  print*,'-+++++++++++++++++++++++++'
+ do i = 1, n_rot
+  iorb = indices(i,1) 
+  jorb = indices(i,2) 
+  print*,iorb,jorb
+  call mix_mo_jk(iorb,jorb)
+ enddo
+
+
+ call save_mos
+ 
+
+end

plugins/loc_cele/loc_exchange_int_virt.irp.f

@@ -0,0 +1,47 @@
+program loc_int
+ implicit none
+ integer :: i,j,k,l,iorb,jorb
+ double precision :: exchange_int(mo_tot_num)
+ integer :: iorder(mo_tot_num)
+ integer :: indices(mo_tot_num,2)
+ logical :: list_core_inact_check(mo_tot_num)
+ integer :: n_rot
+
+ indices = 0
+ list_core_inact_check = .True. 
+ n_rot = 0
+ do i = 1, n_virt_orb
+  iorb = list_virt(i)
+  exchange_int = 0.d0
+  iorder = 0
+  print*,''
+  if(list_core_inact_check(iorb) .eqv. .False.)cycle
+  do j = i+1, n_virt_orb
+   jorb = list_virt(j)
+   iorder(jorb) = jorb
+   exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb)
+  enddo
+  n_rot += 1
+  call dsort(exchange_int,iorder,mo_tot_num)
+  indices(n_rot,1) = iorb
+  indices(n_rot,2) = iorder(1)
+  list_core_inact_check(iorder(1)) = .False.
+  print*,indices(n_rot,1),indices(n_rot,2)
+  print*,''
+  print*,''
+ enddo
+  print*,'****************************'
+  print*,'-+++++++++++++++++++++++++'
+ do i = 1, n_rot
+  iorb = indices(i,1) 
+  jorb = indices(i,2) 
+  print*,iorb,jorb
+  call mix_mo_jk(iorb,jorb)
+ enddo
+
+
+
+ call save_mos
+ 
+
+end

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

plugins/mrcepa0/dressing.irp.f

@@ -321,39 +321,49 @@ end
   
   !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc
   
-  do i_state = 1, N_states
   if(mrmode == 3) then
     do i = 1, N_det_ref
+      do i_state = 1, N_states
         delta_ii(i_state,i)= delta_ii_mrcc(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_mrcc(i_state,j,i)
+        enddo
       end do
     end do
-!       
+    !
-!       do i = 1, N_det_ref
+    !       do i = 1, N_det_ref
-!         delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state)
+    !         delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state)
-!         do j = 1, N_det_non_ref
+    !         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)
+    !           delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state)
-!         end do
+    !         end do
-!       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)
+      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)
+        enddo
       end do
     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)
+      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)
+        enddo
       end do
     end do
   else
     stop "invalid mrmode"
   end if
-  end do
 END_PROVIDER
 
 

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
+    TOUCH psi_coef 
+  endif
   call run(N_states,energy)
   if(do_pt2_end)then
     call run_pt2(N_states,energy)

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)

plugins/mrcepa0/mrcepa0_general.irp.f

@@ -10,12 +10,12 @@ 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
@@ -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
@@ -54,8 +53,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 +65,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 +138,8 @@ subroutine run_pt2_old(N_st,energy)
   
   print * ,'Computing the remaining contribution'
 
-  threshold_selectors = 1.d0 
+  threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
-  threshold_generators = 0.999d0 
+  threshold_generators = max(threshold_generators,threshold_generators_pt2)
 
   N_det_generators = N_det_non_ref + N_det_ref
   N_det_selectors = N_det_non_ref + N_det_ref

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)

scripts/generate_h_apply.py

@@ -18,6 +18,14 @@ filter1h
 filter1p
 only_2p_single
 only_2p_double
+only_2h_single
+only_2h_double
+only_1h_single
+only_1h_double
+only_1p_single
+only_1p_double
+only_2h1p_single
+only_2h1p_double
 filter_only_1h1p_single
 filter_only_1h1p_double
 filter_only_1h2p_single
@@ -198,14 +206,55 @@ class H_apply(object):
      if (is_a_1p(hole)) cycle
     """
 
+  def filter_only_2h(self):
+    self["only_2h_single"] = """
+!    ! DIR$ FORCEINLINE
+     if (is_a_2h(hole).eqv. .False.) cycle
+    """
+    self["only_2h_double"] = """
+!    ! DIR$ FORCEINLINE
+     if ( is_a_2h(key).eqv. .False. )cycle
+    """
+
+  def filter_only_1h(self):
+    self["only_1h_single"] = """
+!    ! DIR$ FORCEINLINE
+     if (is_a_1h(hole) .eqv. .False.) cycle
+    """
+    self["only_1h_double"] = """
+!    ! DIR$ FORCEINLINE
+     if (is_a_1h(key) .eqv. .False.) cycle
+    """
+
+  def filter_only_1p(self):
+    self["only_1p_single"] = """
+!    ! DIR$ FORCEINLINE
+     if ( is_a_1p(hole) .eqv. .False.) cycle
+    """
+    self["only_1p_double"] = """
+!    ! DIR$ FORCEINLINE
+     if ( is_a_1p(key) .eqv. .False.) cycle
+    """
+
+  def filter_only_2h1p(self):
+    self["only_2h1p_single"] = """
+!    ! DIR$ FORCEINLINE
+     if ( is_a_2h1p(hole) .eqv. .False.) cycle
+    """
+    self["only_2h1p_double"] = """
+!    ! DIR$ FORCEINLINE
+     if (is_a_2h1p(key) .eqv. .False.) cycle
+    """
+
+
   def filter_only_2p(self):
     self["only_2p_single"] = """
 !    ! DIR$ FORCEINLINE
-     if (.not. is_a_2p(hole)) cycle
+     if (is_a_2p(hole).eqv. .False.) cycle
     """
     self["only_2p_double"] = """
 !    ! DIR$ FORCEINLINE
-     if (.not. is_a_2p(key)) cycle
+     if (is_a_2p(key).eqv. .False.) cycle
     """
 
 
@@ -224,7 +273,7 @@ class H_apply(object):
 !    ! DIR$ FORCEINLINE
      if (is_a_two_holes_two_particles(hole).eqv..False.) cycle
     """
-    self["filter_only_1h1p_double"] = """
+    self["filter_only_2h2p_double"] = """
 !    ! DIR$ FORCEINLINE
      if (is_a_two_holes_two_particles(key).eqv..False.) cycle
     """
@@ -373,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')

src/AO_Basis/aos.irp.f

@@ -17,7 +17,7 @@ END_PROVIDER
  call ezfio_get_ao_basis_ao_prim_num_max(ao_prim_num_max)
  integer :: align_double
  ao_prim_num_max_align = align_double(ao_prim_num_max)
- END_PROVIDER
+END_PROVIDER
 
  BEGIN_PROVIDER [ double precision, ao_coef_normalized, (ao_num_align,ao_prim_num_max) ]
 &BEGIN_PROVIDER [ double precision, ao_coef_normalization_factor, (ao_num) ]
@@ -145,6 +145,7 @@ END_PROVIDER
 
  BEGIN_PROVIDER [ integer, ao_l, (ao_num) ]
 &BEGIN_PROVIDER [ integer, ao_l_max  ]
+&BEGIN_PROVIDER [ character*(128), ao_l_char, (ao_num) ]
  implicit none
  BEGIN_DOC
 ! ao_l = l value of the AO: a+b+c in x^a y^b z^c
@@ -152,6 +153,7 @@ END_PROVIDER
  integer :: i
  do i=1,ao_num
    ao_l(i) = ao_power(i,1) + ao_power(i,2) + ao_power(i,3) 
+   ao_l_char(i) = l_to_charater(ao_l(i))
  enddo
  ao_l_max = maxval(ao_l)
 END_PROVIDER
@@ -179,20 +181,6 @@ integer function ao_power_index(nx,ny,nz)
   ao_power_index = ((l-nx)*(l-nx+1))/2 + nz + 1
 end
 
- BEGIN_PROVIDER [ integer, ao_l, (ao_num) ]
-&BEGIN_PROVIDER [ integer, ao_l_max ]
-&BEGIN_PROVIDER [ character*(128), ao_l_char, (ao_num) ]
- implicit none
- BEGIN_DOC
-! ao_l = l value of the AO: a+b+c in x^a y^b z^c
- END_DOC
- integer :: i
- do i=1,ao_num
-   ao_l(i) = ao_power(i,1) + ao_power(i,2) + ao_power(i,3)
-   ao_l_char(i) = l_to_charater(ao_l(i))
- enddo
- ao_l_max = maxval(ao_l)
-END_PROVIDER
 
 BEGIN_PROVIDER [ character*(128), l_to_charater, (0:4)]
  BEGIN_DOC

src/Bitmask/bitmask_cas_routines.irp.f

@@ -1,107 +1,113 @@
+use bitmasks
 integer function number_of_holes(key_in)
- ! function that returns the number of holes in the inact space 
+ BEGIN_DOC
+ ! Function that returns the number of holes in the inact space 
+ END_DOC
  implicit none
  integer(bit_kind), intent(in) :: key_in(N_int,2)
  integer :: i
  number_of_holes = 0
+
  if(N_int == 1)then
     number_of_holes = number_of_holes  & 
-   + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )
  else if(N_int == 2)then
     number_of_holes = number_of_holes  & 
-   + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
-   + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) 
  else if(N_int == 3)then
     number_of_holes = number_of_holes  & 
-   + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
-   + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& 
-   + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) 
  else if(N_int == 4)then
     number_of_holes = number_of_holes  & 
-   + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
-   + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& 
-   + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )&
-   + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) 
  else if(N_int == 5)then
     number_of_holes = number_of_holes  & 
-   + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
-   + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& 
-   + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )&
-   + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )& 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )& 
-   + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) 
  else if(N_int == 6)then
     number_of_holes = number_of_holes  & 
-   + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
-   + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& 
-   + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )&
-   + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )&
-   + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )&
-   + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) ) 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) ) 
  else if(N_int == 7)then
     number_of_holes = number_of_holes  & 
-   + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
-   + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& 
-   + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )&
-   + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )&
-   + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )&
-   + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) )&
-   + popcnt( xor( iand(inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), inact_bitmask(7,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), reunion_of_core_inact_bitmask(7,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), inact_bitmask(7,2)) ) 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), reunion_of_core_inact_bitmask(7,2)) ) 
  else if(N_int == 8)then
     number_of_holes = number_of_holes  & 
-   + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )&
-   + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& 
-   + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )&
-   + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )&
-   + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )&
-   + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) )&
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) )&
-   + popcnt( xor( iand(inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), inact_bitmask(8,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), reunion_of_core_inact_bitmask(8,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), inact_bitmask(8,2)) ) 
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), reunion_of_core_inact_bitmask(8,2)) ) 
  else
    do i = 1, N_int
     number_of_holes = number_of_holes  & 
-   + popcnt( xor( iand(inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), inact_bitmask(i,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(i,2), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1)))), inact_bitmask(i,2)) )
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) )
    enddo
  endif
 end
 
 
 integer function number_of_particles(key_in)
+ BEGIN_DOC
  ! function that returns the number of particles in the virtual space 
+ END_DOC
  implicit none
  integer(bit_kind), intent(in) :: key_in(N_int,2)
  integer :: i
@@ -204,11 +210,13 @@ integer function number_of_particles(key_in)
 end
 
 logical function is_a_two_holes_two_particles(key_in)
+ BEGIN_DOC
  ! logical function that returns True if the determinant 'key_in' 
  ! belongs to the 2h-2p excitation class of the DDCI space 
  ! this is calculated using the CAS_bitmask that defines the active 
  ! orbital space, the inact_bitmasl that defines the inactive oribital space  
  ! and the virt_bitmask that defines the virtual orbital space 
+ END_DOC
  implicit none
  integer(bit_kind), intent(in) :: key_in(N_int,2)
  integer :: i,i_diff
@@ -221,163 +229,163 @@ logical function is_a_two_holes_two_particles(key_in)
  i_diff = 0
  if(N_int == 1)then
    i_diff = i_diff  &
-    + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )  &
     + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & 
     + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) 
  else if(N_int == 2)then
    i_diff = i_diff  &
-    + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )  &
     + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & 
     + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )  &
     + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & 
     + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) 
 
  else if(N_int == 3)then
    i_diff = i_diff  &
-    + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )  &
     + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & 
     + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )  &
     + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & 
     + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )  &
     + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & 
     + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) 
  else if(N_int == 4)then
    i_diff = i_diff  &
-    + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )  &
     + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & 
     + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )  &
     + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & 
     + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )  &
     + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & 
     + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )  &
     + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & 
     + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) 
  else if(N_int == 5)then
    i_diff = i_diff  &
-    + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )  &
     + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & 
     + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )  &
     + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & 
     + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )  &
     + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & 
     + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )  &
     + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & 
     + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )  &
     + popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) & 
     + popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) 
  else if(N_int == 6)then
    i_diff = i_diff  &
-    + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )  &
     + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & 
     + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )  &
     + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & 
     + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )  &
     + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & 
     + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )  &
     + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & 
     + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )  &
     + popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) & 
     + popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) )  &
     + popcnt( iand( iand( xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1))), virt_bitmask(6,1) ), virt_bitmask(6,1)) ) & 
     + popcnt( iand( iand( xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1))), virt_bitmask(6,2) ), virt_bitmask(6,2)) ) 
  else if(N_int == 7)then
    i_diff = i_diff  &
-    + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )  &
     + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & 
     + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )  &
     + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & 
     + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )  &
     + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & 
     + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )  &
     + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & 
     + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )  &
     + popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) & 
     + popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) )  &
     + popcnt( iand( iand( xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1))), virt_bitmask(6,1) ), virt_bitmask(6,1)) ) & 
     + popcnt( iand( iand( xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1))), virt_bitmask(6,2) ), virt_bitmask(6,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), inact_bitmask(7,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), reunion_of_core_inact_bitmask(7,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), inact_bitmask(7,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), reunion_of_core_inact_bitmask(7,2)) )  &
     + popcnt( iand( iand( xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1))), virt_bitmask(7,1) ), virt_bitmask(7,1)) ) & 
     + popcnt( iand( iand( xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1))), virt_bitmask(7,2) ), virt_bitmask(7,2)) ) 
  else if(N_int == 8)then
    i_diff = i_diff  &
-    + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )  &
     + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & 
     + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )  &
     + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & 
     + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )  &
     + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & 
     + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )  &
     + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & 
     + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )  &
     + popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) & 
     + popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) )  &
     + popcnt( iand( iand( xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1))), virt_bitmask(6,1) ), virt_bitmask(6,1)) ) & 
     + popcnt( iand( iand( xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1))), virt_bitmask(6,2) ), virt_bitmask(6,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), inact_bitmask(7,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), reunion_of_core_inact_bitmask(7,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), inact_bitmask(7,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), reunion_of_core_inact_bitmask(7,2)) )  &
     + popcnt( iand( iand( xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1))), virt_bitmask(7,1) ), virt_bitmask(7,1)) ) & 
     + popcnt( iand( iand( xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1))), virt_bitmask(7,2) ), virt_bitmask(7,2)) ) &
-    + popcnt( xor( iand(inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), inact_bitmask(8,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), reunion_of_core_inact_bitmask(8,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), inact_bitmask(8,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), reunion_of_core_inact_bitmask(8,2)) )  &
     + popcnt( iand( iand( xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1))), virt_bitmask(8,1) ), virt_bitmask(8,1)) ) & 
     + popcnt( iand( iand( xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1))), virt_bitmask(8,2) ), virt_bitmask(8,2)) ) 
 
@@ -385,8 +393,8 @@ logical function is_a_two_holes_two_particles(key_in)
 
   do i = 1, N_int 
    i_diff = i_diff  &
-    + popcnt( xor( iand(inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), inact_bitmask(i,1)) )  &   
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) )  &   
-    + popcnt( xor( iand(inact_bitmask(i,2), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1)))), inact_bitmask(i,2)) )  &
+    + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,2), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1)))), reunion_of_core_inact_bitmask(i,2)) )  &
     + popcnt( iand( iand( xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1))), virt_bitmask(i,1) ), virt_bitmask(i,1)) ) & 
     + popcnt( iand( iand( xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1))), virt_bitmask(i,2) ), virt_bitmask(i,2)) ) 
   enddo
@@ -398,7 +406,9 @@ logical function is_a_two_holes_two_particles(key_in)
 
 
 integer function number_of_holes_verbose(key_in)
+ BEGIN_DOC
  ! function that returns the number of holes in the inact space 
+ END_DOC
  implicit none
  integer(bit_kind), intent(in) :: key_in(N_int,2)
  integer :: i
@@ -410,23 +420,25 @@ integer function number_of_holes_verbose(key_in)
    key_tmp(1,1) = xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))
    key_tmp(1,2) = xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,1,1)))
    call debug_det(key_tmp,N_int)
-   key_tmp(1,1) = iand(key_tmp(1,1),inact_bitmask(1,1))
+   key_tmp(1,1) = iand(key_tmp(1,1),reunion_of_core_inact_bitmask(1,1))
-   key_tmp(1,2) = iand(key_tmp(1,2),inact_bitmask(1,2))
+   key_tmp(1,2) = iand(key_tmp(1,2),reunion_of_core_inact_bitmask(1,2))
    call debug_det(key_tmp,N_int)
-   key_tmp(1,1) = xor(key_tmp(1,1),inact_bitmask(1,1))
+   key_tmp(1,1) = xor(key_tmp(1,1),reunion_of_core_inact_bitmask(1,1))
-   key_tmp(1,2) = xor(key_tmp(1,2),inact_bitmask(1,2))
+   key_tmp(1,2) = xor(key_tmp(1,2),reunion_of_core_inact_bitmask(1,2))
    call debug_det(key_tmp,N_int)
 !  number_of_holes_verbose = number_of_holes_verbose + popcnt(key_tmp(1,1))   &
 !                                                    + popcnt(key_tmp(1,2))
    number_of_holes_verbose = number_of_holes_verbose & 
-   + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )&   
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )&   
-   + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )
+   + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )
   print*,'----------------------'
 end
 
 
 integer function number_of_particles_verbose(key_in)
+ BEGIN_DOC
  ! function that returns the number of particles in the inact space 
+ END_DOC
  implicit none
  integer(bit_kind), intent(in) :: key_in(N_int,2)
  integer :: i
@@ -473,6 +485,17 @@ logical function is_a_1h2p(key_in)
 
 end
 
+logical function is_a_2h1p(key_in)
+ implicit none
+ integer(bit_kind), intent(in) :: key_in(N_int,2)
+ integer :: number_of_particles, number_of_holes
+ is_a_2h1p = .False.
+ if(number_of_holes(key_in).eq.2 .and. number_of_particles(key_in).eq.1)then
+  is_a_2h1p = .True.
+ endif
+
+end
+
 logical function is_a_1h(key_in)
  implicit none
  integer(bit_kind), intent(in) :: key_in(N_int,2)
@@ -506,3 +529,34 @@ logical function is_a_2p(key_in)
 
 end
 
+logical function is_a_2h(key_in)
+ implicit none
+ integer(bit_kind), intent(in) :: key_in(N_int,2)
+ integer :: number_of_particles, number_of_holes
+ is_a_2h = .False.
+ if(number_of_holes(key_in).eq.2 .and. number_of_particles(key_in).eq.0)then
+  is_a_2h = .True.
+ endif
+
+end
+
+logical function is_i_in_virtual(i)
+ implicit none
+ integer,intent(in) :: i
+ integer(bit_kind) :: key(N_int)
+ integer :: k,j
+ integer :: accu
+ is_i_in_virtual = .False.
+ key= 0_bit_kind
+ k = ishft(i-1,-bit_kind_shift)+1
+ j = i-ishft(k-1,bit_kind_shift)-1
+ key(k) = ibset(key(k),j)
+ accu = 0
+ do k = 1, N_int
+  accu += popcnt(iand(key(k),virt_bitmask(k,1)))
+ enddo
+ if(accu .ne. 0)then
+  is_i_in_virtual = .True.
+ endif
+ 
+end

src/Bitmask/bitmasks.irp.f

@@ -37,6 +37,30 @@ BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ]
   enddo
 END_PROVIDER
 
+ BEGIN_PROVIDER [ integer(bit_kind), core_inact_act_bitmask_4, (N_int,4) ]
+  implicit none
+  integer :: i
+  do i=1,N_int
+      core_inact_act_bitmask_4(i,1) = reunion_of_core_inact_act_bitmask(i,1)
+      core_inact_act_bitmask_4(i,2) = reunion_of_core_inact_act_bitmask(i,1)
+      core_inact_act_bitmask_4(i,3) = reunion_of_core_inact_act_bitmask(i,1)
+      core_inact_act_bitmask_4(i,4) = reunion_of_core_inact_act_bitmask(i,1)
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask_4, (N_int,4) ]
+  implicit none
+  integer :: i
+  do i=1,N_int
+      virt_bitmask_4(i,1) = virt_bitmask(i,1)
+      virt_bitmask_4(i,2) = virt_bitmask(i,1)
+      virt_bitmask_4(i,3) = virt_bitmask(i,1)
+      virt_bitmask_4(i,4) = virt_bitmask(i,1)
+  enddo
+END_PROVIDER
+
+
+
  
 BEGIN_PROVIDER [ integer(bit_kind), HF_bitmask, (N_int,2)]
   implicit none
@@ -369,11 +393,19 @@ END_PROVIDER
 
   BEGIN_PROVIDER [ integer, list_inact, (n_inact_orb)]
  &BEGIN_PROVIDER [ integer, list_virt, (n_virt_orb)]
+ &BEGIN_PROVIDER [ integer, list_inact_reverse, (mo_tot_num)]
+ &BEGIN_PROVIDER [ integer, list_virt_reverse, (mo_tot_num)]
  BEGIN_DOC
  ! list_inact : List of the inactive orbitals which are supposed to be doubly excited 
  ! in post CAS methods
  ! list_virt  : List of vritual orbitals which are supposed to be recieve electrons 
  ! in post CAS methods
+ ! list_inact_reverse : reverse list of inactive orbitals 
+ ! list_inact_reverse(i) = 0 ::> not an inactive 
+ ! list_inact_reverse(i) = k ::> IS the kth inactive 
+ ! list_virt_reverse : reverse list of virtual orbitals 
+ ! list_virt_reverse(i) = 0 ::> not an virtual 
+ ! list_virt_reverse(i) = k ::> IS the kth virtual 
  END_DOC
  implicit none
  integer :: occ_inact(N_int*bit_kind_size)
@@ -381,25 +413,58 @@ END_PROVIDER
  occ_inact = 0
  call bitstring_to_list(inact_bitmask(1,1), occ_inact(1), itest, N_int)
  ASSERT(itest==n_inact_orb)
+ list_inact_reverse = 0
  do i = 1, n_inact_orb
   list_inact(i) = occ_inact(i)
+  list_inact_reverse(occ_inact(i)) = i
  enddo
  
+
  occ_inact = 0
  call bitstring_to_list(virt_bitmask(1,1), occ_inact(1), itest, N_int)
  ASSERT(itest==n_virt_orb)
+ list_virt_reverse = 0
  do i = 1, n_virt_orb
   list_virt(i) = occ_inact(i)
+  list_virt_reverse(occ_inact(i)) = i
  enddo
 
  END_PROVIDER 
 
+
+ BEGIN_PROVIDER [ integer, list_core_inact, (n_core_inact_orb)]
+&BEGIN_PROVIDER [ integer, list_core_inact_reverse, (mo_tot_num)]
+
+ implicit none
+ integer :: occ_inact(N_int*bit_kind_size)
+ integer :: itest,i
+ occ_inact = 0
+
+ call bitstring_to_list(reunion_of_core_inact_bitmask(1,1), occ_inact(1), itest, N_int)
+
+ list_core_inact_reverse = 0
+ do i = 1, n_core_inact_orb
+  list_core_inact(i) = occ_inact(i)
+  list_core_inact_reverse(occ_inact(i)) = i
+ enddo
+
+ END_PROVIDER 
+
+ BEGIN_PROVIDER [ integer, n_core_inact_orb ]
+ implicit none
+ integer :: i
+ n_core_inact_orb = 0
+ do i = 1, N_int
+  n_core_inact_orb += popcnt(reunion_of_core_inact_bitmask(i,1))
+ enddo
+ ENd_PROVIDER
+
  BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)]
  implicit none
  BEGIN_DOC
- ! Reunion of the inactive, active and virtual bitmasks
+ ! Reunion of the core and inactive and virtual bitmasks
  END_DOC
- integer :: i,j
+ integer :: i
  do i = 1, N_int
   reunion_of_core_inact_bitmask(i,1) = ior(core_bitmask(i,1),inact_bitmask(i,1))
   reunion_of_core_inact_bitmask(i,2) = ior(core_bitmask(i,2),inact_bitmask(i,2))
@@ -407,6 +472,36 @@ END_PROVIDER
  END_PROVIDER
 
 
+ BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask, (N_int,2)]
+&BEGIN_PROVIDER [ integer, n_core_inact_act_orb ]
+ implicit none
+ BEGIN_DOC
+ ! Reunion of the core, inactive and active bitmasks
+ END_DOC
+ integer :: i,j
+
+ n_core_inact_act_orb = 0
+ do i = 1, N_int
+  reunion_of_core_inact_act_bitmask(i,1) = ior(reunion_of_core_inact_bitmask(i,1),cas_bitmask(i,1,1))
+  reunion_of_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),cas_bitmask(i,1,1))
+  n_core_inact_act_orb +=popcnt(reunion_of_core_inact_act_bitmask(i,1))
+ enddo
+ END_PROVIDER
+ BEGIN_PROVIDER [ integer, list_core_inact_act, (n_core_inact_act_orb)]
+&BEGIN_PROVIDER [ integer, list_core_inact_act_reverse, (mo_tot_num)]
+  implicit none
+ integer :: occ_inact(N_int*bit_kind_size)
+ integer :: itest,i
+ occ_inact = 0
+ call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), occ_inact(1), itest, N_int)
+ list_inact_reverse = 0
+ do i = 1, n_core_inact_act_orb
+  list_core_inact_act(i) = occ_inact(i)
+  list_core_inact_act_reverse(occ_inact(i)) = i
+ enddo
+END_PROVIDER
+
+
 
 
  BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask, (N_int,2)]
@@ -423,6 +518,7 @@ END_PROVIDER
 
 
  BEGIN_PROVIDER [ integer(bit_kind), inact_virt_bitmask, (N_int,2)]
+&BEGIN_PROVIDER [ integer(bit_kind), core_inact_virt_bitmask, (N_int,2)]
  implicit none
  BEGIN_DOC
  ! Reunion of the inactive and virtual bitmasks
@@ -431,10 +527,13 @@ END_PROVIDER
  do i = 1, N_int
   inact_virt_bitmask(i,1) = ior(inact_bitmask(i,1),virt_bitmask(i,1))
   inact_virt_bitmask(i,2) = ior(inact_bitmask(i,2),virt_bitmask(i,2)) 
+  core_inact_virt_bitmask(i,1) = ior(core_bitmask(i,1),inact_virt_bitmask(i,1))
+  core_inact_virt_bitmask(i,2) = ior(core_bitmask(i,2),inact_virt_bitmask(i,2)) 
  enddo
  END_PROVIDER
 
  BEGIN_PROVIDER [integer, list_core, (n_core_orb)]
+&BEGIN_PROVIDER [integer, list_core_reverse, (mo_tot_num)]
  BEGIN_DOC
  ! List of the core orbitals that are never excited in post CAS method
  END_DOC
@@ -444,8 +543,10 @@ END_PROVIDER
  occ_core = 0
  call bitstring_to_list(core_bitmask(1,1), occ_core(1), itest, N_int)
  ASSERT(itest==n_core_orb)
+ list_core_reverse = 0
  do i = 1, n_core_orb
   list_core(i) = occ_core(i)
+  list_core_reverse(occ_core(i)) = i
  enddo
  END_PROVIDER
 
@@ -458,8 +559,8 @@ END_PROVIDER
  integer :: i,j
  n_core_orb = 0
  do i = 1, N_int
-  core_bitmask(i,1) = xor(closed_shell_ref_bitmask(i,1),reunion_of_cas_inact_bitmask(i,1))
+  core_bitmask(i,1) = xor(full_ijkl_bitmask(i),ior(reunion_of_cas_inact_bitmask(i,1),virt_bitmask(i,1)))
-  core_bitmask(i,2) = xor(closed_shell_ref_bitmask(i,2),reunion_of_cas_inact_bitmask(i,2))
+  core_bitmask(i,2) = xor(full_ijkl_bitmask(i),ior(reunion_of_cas_inact_bitmask(i,2),virt_bitmask(i,1)))
   n_core_orb += popcnt(core_bitmask(i,1))
  enddo
  print*,'n_core_orb = ',n_core_orb
@@ -497,11 +598,17 @@ BEGIN_PROVIDER [ integer, n_act_orb]
  do i = 1, N_int
   n_act_orb += popcnt(cas_bitmask(i,1,1))
  enddo
+ print*,'n_act_orb = ',n_act_orb
 END_PROVIDER
 
-BEGIN_PROVIDER [integer, list_act, (n_act_orb)]
+ BEGIN_PROVIDER [integer, list_act, (n_act_orb)]
+&BEGIN_PROVIDER [integer, list_act_reverse, (mo_tot_num)]
  BEGIN_DOC
- ! list of active orbitals
+ ! list_act(i) = index of the ith active orbital
+ ! 
+ ! list_act_reverse : reverse list of active orbitals 
+ ! list_act_reverse(i) = 0 ::> not an active 
+ ! list_act_reverse(i) = k ::> IS the kth active orbital
  END_DOC
  implicit none
  integer :: occ_act(N_int*bit_kind_size)
@@ -509,10 +616,11 @@ BEGIN_PROVIDER [integer, list_act, (n_act_orb)]
  occ_act = 0
  call bitstring_to_list(cas_bitmask(1,1,1), occ_act(1), itest, N_int)
  ASSERT(itest==n_act_orb)
+ list_act_reverse = 0
  do i = 1, n_act_orb
   list_act(i) = occ_act(i)
+  list_act_reverse(occ_act(i)) = i
  enddo
-
 END_PROVIDER
 
  BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)]
@@ -538,3 +646,18 @@ END_PROVIDER
  END_PROVIDER
 
  
+ BEGIN_PROVIDER [integer, n_core_orb_allocate]
+ implicit none
+ n_core_orb_allocate = max(n_core_orb,1)
+ END_PROVIDER 
+
+ BEGIN_PROVIDER [integer, n_inact_orb_allocate]
+ implicit none
+ n_inact_orb_allocate = max(n_inact_orb,1)
+ END_PROVIDER 
+
+ BEGIN_PROVIDER [integer, n_virt_orb_allocate]
+ implicit none
+ n_virt_orb_allocate = max(n_virt_orb,1)
+ END_PROVIDER 
+

src/Davidson/EZFIO.cfg

@@ -6,7 +6,12 @@ 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

src/Davidson/diagonalization.irp.f

@@ -324,8 +324,17 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia
   double precision               :: cpu, wall
   include 'constants.include.F'
   
+
   !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, y, h, lambda
 
+  if(store_full_H_mat) then
+   stop  'TODO : put S^2 in stor_full_H_mat'
+  endif
+
+  if(store_full_H_mat.and.sze.le.n_det_max_stored)then
+   provide H_matrix_all_dets
+  endif
+
   PROVIDE nuclear_repulsion
 
   call write_time(iunit)
@@ -418,6 +427,13 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia
       ! -----------------------------------------
       
       call H_u_0_nstates(W(1,1,iter),U(1,1,iter),H_jj,sze,dets_in,Nint,N_st_diag,sze_8)
+!      do k=1,N_st
+!          if(store_full_H_mat.and.sze.le.n_det_max_stored)then
+!           call H_u_0_stored(W(1,k,iter),U(1,k,iter),H_matrix_all_dets,sze)
+!          else
+!           call H_u_0(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint)
+!          endif
+!      enddo
       
       
       ! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>