added tc_bi_ortho

src/dav_general_mat/dav_diag_dressed_ext_rout_nonsym_B1space.irp.f

@@ -0,0 +1,500 @@
+
+! ---
+
+subroutine davidson_general_diag_dressed_ext_rout_nonsym_b1space(u_in, H_jj, Dress_jj,energies, sze, N_st, N_st_diag_in, converged, hcalc)
+
+  use mmap_module
+
+  BEGIN_DOC
+  ! Generic modified-Davidson diagonalization 
+  !
+  ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson
+  !
+  ! u_in : guess coefficients on the various states. Overwritten on exit by right eigenvectors
+  !
+  ! sze : Number of determinants
+  !
+  ! N_st : Number of eigenstates
+  !
+  ! N_st_diag_in : Number of states in which H is diagonalized. Assumed > N_st
+  !
+  ! Initial guess vectors are not necessarily orthonormal
+  !
+  ! hcalc subroutine to compute W = H U (see routine hcalc_template for template of input/output)
+  END_DOC
+
+  implicit none
+
+  integer,           intent(in)   :: sze, N_st, N_st_diag_in
+  double precision,  intent(in)   :: H_jj(sze),Dress_jj(sze)
+  logical,          intent(inout) :: converged
+  double precision, intent(inout) :: u_in(sze,N_st_diag_in)
+  double precision, intent(out)   :: energies(N_st)
+  external                           hcalc
+
+  character*(16384)               :: write_buffer
+  integer                         :: iter, N_st_diag
+  integer                         :: i, j, k, l, m
+  integer                         :: iter2, itertot
+  logical                         :: disk_based
+  integer                         :: shift, shift2, itermax
+  integer                         :: nproc_target
+  integer                         :: order(N_st_diag_in)
+  double precision                :: to_print(2,N_st)
+  double precision                :: r1, r2, alpha
+  double precision                :: cpu, wall
+  double precision                :: cmax
+  double precision                :: energy_shift(N_st_diag_in*davidson_sze_max)
+  double precision, allocatable   :: U(:,:)
+  double precision, allocatable   :: y(:,:), h(:,:), lambda(:)
+  double precision, allocatable   :: residual_norm(:)
+
+  double precision                :: lambda_tmp
+  integer,          allocatable   :: i_omax(:)
+  double precision, allocatable   :: U_tmp(:), overlap(:)
+
+  double precision, allocatable :: W(:,:)
+  !double precision, pointer       :: W(:,:)
+  double precision, external      :: u_dot_v, u_dot_u
+
+
+  include 'constants.include.F'
+
+  N_st_diag = N_st_diag_in 
+!  print*,'trial vector'
+   do i = 1, sze
+    if(isnan(u_in(i,1)))then
+     print*,'pb in input vector of davidson_general_ext_rout_nonsym_b1space'
+     print*,i,u_in(i,1)
+     stop
+    else if (dabs(u_in(i,1)).lt.1.d-16)then
+     u_in(i,1) = 0.d0
+    endif
+   enddo
+
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, y, h, lambda
+  if(N_st_diag*3 > sze) then
+    print *,  'error in Davidson :'
+    print *,  'Increase n_det_max_full to ', N_st_diag*3
+    stop -1
+  endif
+
+  itermax = max(2, min(davidson_sze_max, sze/N_st_diag)) + 1
+
+  provide threshold_nonsym_davidson 
+  call write_time(6)
+  write(6,'(A)') ''
+  write(6,'(A)') 'Davidson Diagonalization'
+  write(6,'(A)') '------------------------'
+  write(6,'(A)') ''
+
+
+  ! Find max number of cores to fit in memory
+  ! -----------------------------------------
+
+  nproc_target = nproc
+  double precision :: rss
+  integer :: maxab
+  maxab = sze 
+
+  m=1
+  disk_based = .False.
+  call resident_memory(rss)
+  do
+    r1 = 8.d0 *                                   &! bytes
+         ( dble(sze)*(N_st_diag*itermax)          &! U
+         + 1.d0*dble(sze*m)*(N_st_diag*itermax)   &! W
+         + 2.d0*(N_st_diag*itermax)**2            &! h,y
+         + 2.d0*(N_st_diag*itermax)               &! s2,lambda
+         + 1.d0*(N_st_diag)                       &! residual_norm
+                                                   ! In H_S2_u_0_nstates_zmq
+         + 3.d0*(N_st_diag*N_det)                 &! u_t, v_t, s_t on collector
+         + 3.d0*(N_st_diag*N_det)                 &! u_t, v_t, s_t on slave
+         + 0.5d0*maxab                            &! idx0 in H_S2_u_0_nstates_openmp_work_*
+         + nproc_target *                         &! In OMP section
+           ( 1.d0*(N_int*maxab)                   &! buffer
+           + 3.5d0*(maxab) )                      &! singles_a, singles_b, doubles, idx
+         ) / 1024.d0**3
+
+    if(nproc_target == 0) then
+      call check_mem(r1, irp_here)
+      nproc_target = 1
+      exit
+    endif
+
+    if(r1+rss < qp_max_mem) then
+      exit
+    endif
+
+    if(itermax > 4) then
+      itermax = itermax - 1
+    else if (m==1.and.disk_based_davidson) then
+      m = 0
+      disk_based = .True.
+      itermax = 6
+    else
+      nproc_target = nproc_target - 1
+    endif
+
+  enddo
+
+  nthreads_davidson = nproc_target
+  TOUCH nthreads_davidson
+
+  call write_int(6, N_st, 'Number of states')
+  call write_int(6, N_st_diag, 'Number of states in diagonalization')
+  call write_int(6, sze, 'Number of basis functions')
+  call write_int(6, nproc_target, 'Number of threads for diagonalization')
+  call write_double(6, r1, 'Memory(Gb)')
+  if(disk_based) then
+    print *, 'Using swap space to reduce RAM'
+  endif
+
+  !---------------
+
+  write(6,'(A)') ''
+  write_buffer = '====='
+  do i=1,N_st
+    write_buffer = trim(write_buffer)//' ================  ==========='
+  enddo
+  write(6,'(A)') write_buffer(1:6+41*N_st)
+  write_buffer = 'Iter'
+  do i=1,N_st
+    write_buffer = trim(write_buffer)//'       Energy         Residual '
+  enddo
+  write(6,'(A)') write_buffer(1:6+41*N_st)
+  write_buffer = '====='
+  do i=1,N_st
+    write_buffer = trim(write_buffer)//' ================  ==========='
+  enddo
+  write(6,'(A)') write_buffer(1:6+41*N_st)
+
+  ! ---
+
+
+  allocate( W(sze,N_st_diag*itermax) )
+
+  allocate(                                                          &
+      ! Large
+      U(sze,N_st_diag*itermax),                                      &
+      ! Small
+      h(N_st_diag*itermax,N_st_diag*itermax),                        &
+      y(N_st_diag*itermax,N_st_diag*itermax),                        &
+      lambda(N_st_diag*itermax),                                     & 
+      residual_norm(N_st_diag),                                      &
+      i_omax(N_st)                                                   &
+  )
+
+  U = 0.d0
+  h = 0.d0
+  y = 0.d0
+  lambda = 0.d0
+  residual_norm = 0.d0
+
+
+  ASSERT (N_st > 0)
+  ASSERT (N_st_diag >= N_st)
+  ASSERT (sze > 0)
+
+  ! Davidson iterations
+  ! ===================
+
+  converged = .False.
+
+  ! Initialize from N_st to N_st_diag with gaussian random numbers
+  ! to be sure to have overlap with any eigenvectors
+  do k = N_st+1, N_st_diag
+    u_in(k,k) = 10.d0
+    do i = 1, sze
+      call random_number(r1)
+      call random_number(r2)
+      r1 = dsqrt(-2.d0*dlog(r1))
+      r2 = dtwo_pi*r2
+      u_in(i,k) = r1*dcos(r2)
+    enddo
+  enddo
+  ! Normalize all states 
+  do k = 1, N_st_diag
+    call normalize(u_in(1,k), sze)
+  enddo
+
+  ! Copy from the guess input "u_in" to the working vectors "U"
+  do k = 1, N_st_diag
+    do i = 1, sze
+      U(i,k) = u_in(i,k)
+    enddo
+  enddo
+
+  ! ---
+
+  itertot = 0
+
+  do while (.not.converged)
+
+    itertot = itertot + 1
+    if(itertot == 8) then
+      exit
+    endif
+
+    do iter = 1, itermax-1
+
+      shift  = N_st_diag * (iter-1)
+      shift2 = N_st_diag * iter
+
+      if( (iter > 1) .or. (itertot == 1) ) then
+
+        ! Gram-Schmidt to orthogonalize all new guess with the previous vectors 
+        call ortho_qr(U, size(U, 1), sze, shift2)
+        call ortho_qr(U, size(U, 1), sze, shift2)
+
+        ! W = H U
+        call hcalc(W(1,shift+1), U(1,shift+1), N_st_diag, sze)
+        call dress_calc(W(1,shift+1), Dress_jj, U(1,shift+1), N_st_diag, sze)
+
+      else
+
+        ! Already computed in update below
+        continue
+      endif
+
+      ! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>
+      ! -------------------------------------------
+      call dgemm( 'T', 'N', shift2, shift2, sze, 1.d0 &
+                , U, size(U, 1), W, size(W, 1)        &
+                , 0.d0, h, size(h, 1) )
+
+
+      ! Diagonalize h y = lambda y
+      ! ---------------------------
+      call diag_nonsym_right(shift2, h(1,1), size(h, 1), y(1,1), size(y, 1), lambda(1), size(lambda, 1))
+
+
+      ! Express eigenvectors of h in the determinant basis:
+      ! ---------------------------------------------------
+
+      ! y(:,k) = rk
+      ! U(:,k) = Bk 
+      ! U(:,shift2+k) = Rk = Bk x rk
+      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) )
+
+      do k = 1, N_st_diag
+        call normalize(U(1,shift2+k), sze)
+      enddo
+
+      ! ---
+      ! select the max overlap
+
+      !
+      ! start test ------------------------------------------------------------------------
+      !
+      !double precision, allocatable :: Utest(:,:), Otest(:)
+      !allocate( Utest(sze,shift2), Otest(shift2) )
+
+      !call dgemm( 'N', 'N', sze, shift2, shift2, 1.d0 &
+      !          , U, size(U, 1), y, size(y, 1), 0.d0, Utest(1,1), size(Utest, 1) )
+      !do k = 1, shift2
+      !  call normalize(Utest(1,k), sze)
+      !enddo
+      !do j = 1, sze
+      !  write(455, '(100(1X, F16.10))') (Utest(j,k), k=1,shift2)
+      !enddo
+
+      !do k = 1, shift2 
+      !  Otest(k) = 0.d0
+      !  do i = 1, sze
+      !    Otest(k) += Utest(i,k) * u_in(i,1)
+      !  enddo
+      !  Otest(k) = dabs(Otest(k))
+      !  print *, ' Otest =', k, Otest(k), lambda(k)
+      !enddo
+     
+      !deallocate(Utest, Otest)
+      !
+      ! end test ------------------------------------------------------------------------
+      !
+
+      ! TODO 
+      ! state_following is more efficient
+      do l = 1, N_st
+
+        allocate( overlap(N_st_diag) )
+
+        do k = 1, N_st_diag
+          overlap(k) = 0.d0
+          do i = 1, sze
+            overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,l)
+          enddo
+          overlap(k) = dabs(overlap(k))
+          !print *, ' overlap =', k, overlap(k)
+        enddo
+
+        lambda_tmp = 0.d0 
+        do k = 1, N_st_diag
+          if(overlap(k) .gt. lambda_tmp) then 
+            i_omax(l)  = k
+            lambda_tmp = overlap(k)
+          endif
+        enddo
+
+        deallocate(overlap)
+
+        if(lambda_tmp .lt. 0.7d0) then
+          print *, ' very small overlap ...', l, i_omax(l)
+          print *, ' max overlap = ', lambda_tmp
+          stop
+        endif
+
+        if(i_omax(l) .ne. l) then
+          print *, ' !!! WARNONG !!!'
+          print *, ' index of state', l, i_omax(l)
+        endif
+      enddo
+
+      ! y(:,k) = rk
+      ! W(:,k) = H x Bk 
+      ! W(:,shift2+k) = H x Bk x rk
+      !               = Wk
+      call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
+                , W, size(W, 1), y, size(y, 1)           &
+                , 0.d0, W(1,shift2+1), size(W, 1) )
+
+      ! ---
+
+      ! Compute residual vector and davidson step
+      ! -----------------------------------------
+
+      !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k)
+      do k = 1, N_st_diag
+        do i = 1, sze
+          U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2)
+        enddo
+        if(k <= N_st) then
+          l = k
+          residual_norm(k) = u_dot_u(U(1,shift2+l), sze)
+          to_print(1,k)    = lambda(l) 
+          to_print(2,k)    = residual_norm(l)
+        endif
+      enddo
+      !$OMP END PARALLEL DO
+      !residual_norm(1) = u_dot_u(U(1,shift2+1), sze)
+      !to_print(1,1) = lambda(1) 
+      !to_print(2,1) = residual_norm(1)
+
+
+      if( (itertot > 1) .and. (iter == 1) ) then
+        !don't print 
+        continue
+      else
+        write(*, '(1X, I3, 1X, 100(1X, F16.10, 1X, F16.10, 1X, F16.10))') iter-1, to_print(1:2,1:N_st)
+      endif
+
+      ! Check convergence
+      if(iter > 1) then
+        converged = dabs(maxval(residual_norm(1:N_st))) < threshold_nonsym_davidson
+      endif   
+      
+      do k = 1, N_st
+        if(residual_norm(k) > 1.e8) then
+          print *, 'Davidson failed'
+          stop -1
+        endif
+      enddo
+      if(converged) then
+        exit
+      endif
+
+      logical, external :: qp_stop
+      if(qp_stop()) then
+        converged = .True.
+        exit
+      endif
+
+    enddo ! loop over iter
+
+
+    ! Re-contract U and update W
+    ! --------------------------------
+
+    call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0  &
+              , W, size(W, 1), y, size(y, 1)            &
+              , 0.d0, u_in, size(u_in, 1) )
+    do k = 1, N_st_diag
+      do i = 1, sze
+        W(i,k) = u_in(i,k)
+      enddo
+    enddo
+
+    call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
+              , U, size(U, 1), y, size(y, 1)           &
+              , 0.d0, u_in, size(u_in, 1) )
+    do k = 1, N_st_diag
+      do i = 1, sze
+        U(i,k) = u_in(i,k)
+      enddo
+    enddo
+
+    call ortho_qr(U, size(U, 1), sze, N_st_diag)
+    call ortho_qr(U, size(U, 1), sze, N_st_diag)
+    do j = 1, N_st_diag
+      k = 1
+      do while( (k < sze) .and. (U(k,j) == 0.d0) )
+        k = k+1
+      enddo
+      if(U(k,j) * u_in(k,j) < 0.d0) then
+        do i = 1, sze
+          W(i,j) = -W(i,j)
+        enddo
+      endif
+    enddo
+
+  enddo ! loop over while
+
+  ! ---
+
+  do k = 1, N_st
+    energies(k) = lambda(k)
+  enddo
+  write_buffer = '====='
+  do i = 1, N_st
+    write_buffer = trim(write_buffer)//' ================  ==========='
+  enddo
+  write(6,'(A)') trim(write_buffer)
+  write(6,'(A)') ''
+  call write_time(6)
+
+  deallocate(W)
+  deallocate(U, h, y, lambda, residual_norm, i_omax)
+
+  FREE nthreads_davidson
+
+end subroutine davidson_general_ext_rout_nonsym_b1space
+
+! ---
+
+subroutine dress_calc(v,dress,u,N_st,sze)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Routine that computed the action of the diagonal dressing dress
+  !
+  ! WARNING :: v is not initialiazed !!!
+  END_DOC
+  integer, intent(in)              :: N_st,sze
+  double precision, intent(in)     :: u(sze,N_st),dress(sze)
+  double precision, intent(inout)  :: v(sze,N_st)
+  integer :: i,istate
+  
+  do istate = 1, N_st
+   do i = 1, sze
+    v(i,istate) += dress(i) * u(i,istate)
+   enddo
+  enddo
+end
+
+
+
+
+
+

src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f

@@ -0,0 +1,473 @@
+
+! ---
+
+subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N_st, N_st_diag_in, converged, hcalc)
+
+  use mmap_module
+
+  BEGIN_DOC
+  ! Generic modified-Davidson diagonalization 
+  !
+  ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson
+  !
+  ! u_in : guess coefficients on the various states. Overwritten on exit by right eigenvectors
+  !
+  ! sze : Number of determinants
+  !
+  ! N_st : Number of eigenstates
+  !
+  ! N_st_diag_in : Number of states in which H is diagonalized. Assumed > N_st
+  !
+  ! Initial guess vectors are not necessarily orthonormal
+  !
+  ! hcalc subroutine to compute W = H U (see routine hcalc_template for template of input/output)
+  END_DOC
+
+  implicit none
+
+  integer,           intent(in)   :: sze, N_st, N_st_diag_in
+  double precision,  intent(in)   :: H_jj(sze)
+  logical,          intent(inout) :: converged
+  double precision, intent(inout) :: u_in(sze,N_st_diag_in)
+  double precision, intent(out)   :: energies(N_st)
+  external                           hcalc
+
+  character*(16384)               :: write_buffer
+  integer                         :: iter, N_st_diag
+  integer                         :: i, j, k, l, m
+  integer                         :: iter2, itertot
+  logical                         :: disk_based
+  integer                         :: shift, shift2, itermax
+  integer                         :: nproc_target
+  integer                         :: order(N_st_diag_in)
+  double precision                :: to_print(2,N_st)
+  double precision                :: r1, r2, alpha
+  double precision                :: cpu, wall
+  double precision                :: cmax
+  double precision                :: energy_shift(N_st_diag_in*davidson_sze_max)
+  double precision, allocatable   :: U(:,:)
+  double precision, allocatable   :: y(:,:), h(:,:), lambda(:)
+  double precision, allocatable   :: residual_norm(:)
+
+  double precision                :: lambda_tmp
+  integer,          allocatable   :: i_omax(:)
+  double precision, allocatable   :: U_tmp(:), overlap(:)
+
+  double precision, allocatable :: W(:,:)
+  !double precision, pointer       :: W(:,:)
+  double precision, external      :: u_dot_v, u_dot_u
+
+
+  include 'constants.include.F'
+
+  N_st_diag = N_st_diag_in 
+!  print*,'trial vector'
+   do i = 1, sze
+    if(isnan(u_in(i,1)))then
+     print*,'pb in input vector of davidson_general_ext_rout_nonsym_b1space'
+     print*,i,u_in(i,1)
+     stop
+    else if (dabs(u_in(i,1)).lt.1.d-16)then
+     u_in(i,1) = 0.d0
+    endif
+   enddo
+
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, y, h, lambda
+  if(N_st_diag*3 > sze) then
+    print *,  'error in Davidson :'
+    print *,  'Increase n_det_max_full to ', N_st_diag*3
+    stop -1
+  endif
+
+  itermax = max(2, min(davidson_sze_max, sze/N_st_diag)) + 1
+
+  provide threshold_nonsym_davidson 
+  call write_time(6)
+  write(6,'(A)') ''
+  write(6,'(A)') 'Davidson Diagonalization'
+  write(6,'(A)') '------------------------'
+  write(6,'(A)') ''
+
+
+  ! Find max number of cores to fit in memory
+  ! -----------------------------------------
+
+  nproc_target = nproc
+  double precision :: rss
+  integer :: maxab
+  maxab = sze 
+
+  m=1
+  disk_based = .False.
+  call resident_memory(rss)
+  do
+    r1 = 8.d0 *                                   &! bytes
+         ( dble(sze)*(N_st_diag*itermax)          &! U
+         + 1.d0*dble(sze*m)*(N_st_diag*itermax)   &! W
+         + 2.d0*(N_st_diag*itermax)**2            &! h,y
+         + 2.d0*(N_st_diag*itermax)               &! s2,lambda
+         + 1.d0*(N_st_diag)                       &! residual_norm
+                                                   ! In H_S2_u_0_nstates_zmq
+         + 3.d0*(N_st_diag*N_det)                 &! u_t, v_t, s_t on collector
+         + 3.d0*(N_st_diag*N_det)                 &! u_t, v_t, s_t on slave
+         + 0.5d0*maxab                            &! idx0 in H_S2_u_0_nstates_openmp_work_*
+         + nproc_target *                         &! In OMP section
+           ( 1.d0*(N_int*maxab)                   &! buffer
+           + 3.5d0*(maxab) )                      &! singles_a, singles_b, doubles, idx
+         ) / 1024.d0**3
+
+    if(nproc_target == 0) then
+      call check_mem(r1, irp_here)
+      nproc_target = 1
+      exit
+    endif
+
+    if(r1+rss < qp_max_mem) then
+      exit
+    endif
+
+    if(itermax > 4) then
+      itermax = itermax - 1
+!    else if (m==1.and.disk_based_davidson) then
+!      m = 0
+!      disk_based = .True.
+!      itermax = 6
+    else
+      nproc_target = nproc_target - 1
+    endif
+
+  enddo
+
+  nthreads_davidson = nproc_target
+  TOUCH nthreads_davidson
+
+  call write_int(6, N_st, 'Number of states')
+  call write_int(6, N_st_diag, 'Number of states in diagonalization')
+  call write_int(6, sze, 'Number of basis functions')
+  call write_int(6, nproc_target, 'Number of threads for diagonalization')
+  call write_double(6, r1, 'Memory(Gb)')
+  if(disk_based) then
+    print *, 'Using swap space to reduce RAM'
+  endif
+
+  !---------------
+
+  write(6,'(A)') ''
+  write_buffer = '====='
+  do i=1,N_st
+    write_buffer = trim(write_buffer)//' ================  ==========='
+  enddo
+  write(6,'(A)') write_buffer(1:6+41*N_st)
+  write_buffer = 'Iter'
+  do i=1,N_st
+    write_buffer = trim(write_buffer)//'       Energy         Residual '
+  enddo
+  write(6,'(A)') write_buffer(1:6+41*N_st)
+  write_buffer = '====='
+  do i=1,N_st
+    write_buffer = trim(write_buffer)//' ================  ==========='
+  enddo
+  write(6,'(A)') write_buffer(1:6+41*N_st)
+
+  ! ---
+
+
+  allocate( W(sze,N_st_diag*itermax) )
+
+  allocate(                                                          &
+      ! Large
+      U(sze,N_st_diag*itermax),                                      &
+      ! Small
+      h(N_st_diag*itermax,N_st_diag*itermax),                        &
+      y(N_st_diag*itermax,N_st_diag*itermax),                        &
+      lambda(N_st_diag*itermax),                                     & 
+      residual_norm(N_st_diag),                                      &
+      i_omax(N_st)                                                   &
+  )
+
+  U = 0.d0
+  h = 0.d0
+  y = 0.d0
+  lambda = 0.d0
+  residual_norm = 0.d0
+
+
+  ASSERT (N_st > 0)
+  ASSERT (N_st_diag >= N_st)
+  ASSERT (sze > 0)
+
+  ! Davidson iterations
+  ! ===================
+
+  converged = .False.
+
+  ! Initialize from N_st to N_st_diag with gaussian random numbers
+  ! to be sure to have overlap with any eigenvectors
+  do k = N_st+1, N_st_diag
+    u_in(k,k) = 10.d0
+    do i = 1, sze
+      call random_number(r1)
+      call random_number(r2)
+      r1 = dsqrt(-2.d0*dlog(r1))
+      r2 = dtwo_pi*r2
+      u_in(i,k) = r1*dcos(r2)
+    enddo
+  enddo
+  ! Normalize all states 
+  do k = 1, N_st_diag
+    call normalize(u_in(1,k), sze)
+  enddo
+
+  ! Copy from the guess input "u_in" to the working vectors "U"
+  do k = 1, N_st_diag
+    do i = 1, sze
+      U(i,k) = u_in(i,k)
+    enddo
+  enddo
+
+  ! ---
+
+  itertot = 0
+
+  do while (.not.converged)
+
+    itertot = itertot + 1
+    if(itertot == 8) then
+      exit
+    endif
+
+    do iter = 1, itermax-1
+
+      shift  = N_st_diag * (iter-1)
+      shift2 = N_st_diag * iter
+
+      if( (iter > 1) .or. (itertot == 1) ) then
+
+        ! Gram-Schmidt to orthogonalize all new guess with the previous vectors 
+        call ortho_qr(U, size(U, 1), sze, shift2)
+        call ortho_qr(U, size(U, 1), sze, shift2)
+
+        ! W = H U
+        call hcalc(W(1,shift+1), U(1,shift+1), N_st_diag, sze)
+
+      else
+
+        ! Already computed in update below
+        continue
+      endif
+
+      ! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>
+      ! -------------------------------------------
+      call dgemm( 'T', 'N', shift2, shift2, sze, 1.d0 &
+                , U, size(U, 1), W, size(W, 1)        &
+                , 0.d0, h, size(h, 1) )
+
+
+      ! Diagonalize h y = lambda y
+      ! ---------------------------
+      call diag_nonsym_right(shift2, h(1,1), size(h, 1), y(1,1), size(y, 1), lambda(1), size(lambda, 1))
+
+
+      ! Express eigenvectors of h in the determinant basis:
+      ! ---------------------------------------------------
+
+      ! y(:,k) = rk
+      ! U(:,k) = Bk 
+      ! U(:,shift2+k) = Rk = Bk x rk
+      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) )
+
+      do k = 1, N_st_diag
+        call normalize(U(1,shift2+k), sze)
+      enddo
+
+      ! ---
+      ! select the max overlap
+
+      !
+      ! start test ------------------------------------------------------------------------
+      !
+      !double precision, allocatable :: Utest(:,:), Otest(:)
+      !allocate( Utest(sze,shift2), Otest(shift2) )
+
+      !call dgemm( 'N', 'N', sze, shift2, shift2, 1.d0 &
+      !          , U, size(U, 1), y, size(y, 1), 0.d0, Utest(1,1), size(Utest, 1) )
+      !do k = 1, shift2
+      !  call normalize(Utest(1,k), sze)
+      !enddo
+      !do j = 1, sze
+      !  write(455, '(100(1X, F16.10))') (Utest(j,k), k=1,shift2)
+      !enddo
+
+      !do k = 1, shift2 
+      !  Otest(k) = 0.d0
+      !  do i = 1, sze
+      !    Otest(k) += Utest(i,k) * u_in(i,1)
+      !  enddo
+      !  Otest(k) = dabs(Otest(k))
+      !  print *, ' Otest =', k, Otest(k), lambda(k)
+      !enddo
+     
+      !deallocate(Utest, Otest)
+      !
+      ! end test ------------------------------------------------------------------------
+      !
+
+      ! TODO 
+      ! state_following is more efficient
+      do l = 1, N_st
+
+        allocate( overlap(N_st_diag) )
+
+        do k = 1, N_st_diag
+          overlap(k) = 0.d0
+          do i = 1, sze
+            overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,l)
+          enddo
+          overlap(k) = dabs(overlap(k))
+          !print *, ' overlap =', k, overlap(k)
+        enddo
+
+        lambda_tmp = 0.d0 
+        do k = 1, N_st_diag
+          if(overlap(k) .gt. lambda_tmp) then 
+            i_omax(l)  = k
+            lambda_tmp = overlap(k)
+          endif
+        enddo
+
+        deallocate(overlap)
+
+        if(lambda_tmp .lt. 0.7d0) then
+          print *, ' very small overlap ...', l, i_omax(l)
+          print *, ' max overlap = ', lambda_tmp
+          stop
+        endif
+
+        if(i_omax(l) .ne. l) then
+          print *, ' !!! WARNONG !!!'
+          print *, ' index of state', l, i_omax(l)
+        endif
+      enddo
+
+      ! y(:,k) = rk
+      ! W(:,k) = H x Bk 
+      ! W(:,shift2+k) = H x Bk x rk
+      !               = Wk
+      call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
+                , W, size(W, 1), y, size(y, 1)           &
+                , 0.d0, W(1,shift2+1), size(W, 1) )
+
+      ! ---
+
+      ! Compute residual vector and davidson step
+      ! -----------------------------------------
+
+      !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k)
+      do k = 1, N_st_diag
+        do i = 1, sze
+          U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2)
+        enddo
+        if(k <= N_st) then
+          l = k
+          residual_norm(k) = u_dot_u(U(1,shift2+l), sze)
+          to_print(1,k)    = lambda(l) 
+          to_print(2,k)    = residual_norm(l)
+        endif
+      enddo
+      !$OMP END PARALLEL DO
+      !residual_norm(1) = u_dot_u(U(1,shift2+1), sze)
+      !to_print(1,1) = lambda(1) 
+      !to_print(2,1) = residual_norm(1)
+
+
+      if( (itertot > 1) .and. (iter == 1) ) then
+        !don't print 
+        continue
+      else
+        write(*, '(1X, I3, 1X, 100(1X, F16.10, 1X, F16.10, 1X, F16.10))') iter-1, to_print(1:2,1:N_st)
+      endif
+
+      ! Check convergence
+      if(iter > 1) then
+        converged = dabs(maxval(residual_norm(1:N_st))) < threshold_nonsym_davidson
+      endif   
+      
+      do k = 1, N_st
+        if(residual_norm(k) > 1.e8) then
+          print *, 'Davidson failed'
+          stop -1
+        endif
+      enddo
+      if(converged) then
+        exit
+      endif
+
+      logical, external :: qp_stop
+      if(qp_stop()) then
+        converged = .True.
+        exit
+      endif
+
+    enddo ! loop over iter
+
+
+    ! Re-contract U and update W
+    ! --------------------------------
+
+    call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0  &
+              , W, size(W, 1), y, size(y, 1)            &
+              , 0.d0, u_in, size(u_in, 1) )
+    do k = 1, N_st_diag
+      do i = 1, sze
+        W(i,k) = u_in(i,k)
+      enddo
+    enddo
+
+    call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
+              , U, size(U, 1), y, size(y, 1)           &
+              , 0.d0, u_in, size(u_in, 1) )
+    do k = 1, N_st_diag
+      do i = 1, sze
+        U(i,k) = u_in(i,k)
+      enddo
+    enddo
+
+    call ortho_qr(U, size(U, 1), sze, N_st_diag)
+    call ortho_qr(U, size(U, 1), sze, N_st_diag)
+    do j = 1, N_st_diag
+      k = 1
+      do while( (k < sze) .and. (U(k,j) == 0.d0) )
+        k = k+1
+      enddo
+      if(U(k,j) * u_in(k,j) < 0.d0) then
+        do i = 1, sze
+          W(i,j) = -W(i,j)
+        enddo
+      endif
+    enddo
+
+  enddo ! loop over while
+
+  ! ---
+
+  do k = 1, N_st
+    energies(k) = lambda(k)
+  enddo
+  write_buffer = '====='
+  do i = 1, N_st
+    write_buffer = trim(write_buffer)//' ================  ==========='
+  enddo
+  write(6,'(A)') trim(write_buffer)
+  write(6,'(A)') ''
+  call write_time(6)
+
+  deallocate(W)
+  deallocate(U, h, y, lambda, residual_norm, i_omax)
+
+  FREE nthreads_davidson
+
+end subroutine davidson_general_ext_rout_nonsym_b1space
+
+! ---

src/davidson/EZFIO.cfg

@@ -4,6 +4,12 @@ doc: Thresholds of Davidson's algorithm if threshold_davidson_from_pt2 is false.
 interface: ezfio,provider,ocaml
 default: 1.e-10
 
+[threshold_nonsym_davidson]
+type: Threshold
+doc: Thresholds of non-symetric Davidson's algorithm
+interface: ezfio,provider,ocaml
+default: 1.e-10
+
 [threshold_davidson_from_pt2]
 type: logical
 doc: Thresholds of Davidson's algorithm is set to E(rPT2)*threshold_davidson_from_pt2

src/determinants/determinants.irp.f

@@ -589,6 +589,67 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef)
   endif
 end
 
+subroutine save_wavefunction_general_unormalized(ndet,nstates,psidet,dim_psicoef,psicoef)
+  implicit none
+  BEGIN_DOC
+  !  Save the wave function into the |EZFIO| file
+  END_DOC
+  use bitmasks
+  include 'constants.include.F'
+  integer, intent(in)            :: ndet,nstates,dim_psicoef
+  integer(bit_kind), intent(in)  :: psidet(N_int,2,ndet)
+  double precision, intent(in)   :: psicoef(dim_psicoef,nstates)
+  integer*8, allocatable         :: psi_det_save(:,:,:)
+  double precision, allocatable  :: psi_coef_save(:,:)
+
+  double precision               :: accu_norm
+  integer                        :: i,j,k, ndet_qp_edit
+
+  if (mpi_master) then
+    ndet_qp_edit = min(ndet,N_det_qp_edit)
+
+    call ezfio_set_determinants_N_int(N_int)
+    call ezfio_set_determinants_bit_kind(bit_kind)
+    call ezfio_set_determinants_N_det(ndet)
+    call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit)
+    call ezfio_set_determinants_n_states(nstates)
+    call ezfio_set_determinants_mo_label(mo_label)
+
+    allocate (psi_det_save(N_int,2,ndet))
+    do i=1,ndet
+      do j=1,2
+        do k=1,N_int
+          psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8)
+        enddo
+      enddo
+    enddo
+    call ezfio_set_determinants_psi_det(psi_det_save)
+    call ezfio_set_determinants_psi_det_qp_edit(psi_det_save)
+    deallocate (psi_det_save)
+
+    allocate (psi_coef_save(ndet,nstates))
+    do k=1,nstates
+      do i=1,ndet
+        psi_coef_save(i,k) = psicoef(i,k)
+      enddo
+    enddo
+
+    call ezfio_set_determinants_psi_coef(psi_coef_save)
+    deallocate (psi_coef_save)
+
+    allocate (psi_coef_save(ndet_qp_edit,nstates))
+    do k=1,nstates
+      do i=1,ndet_qp_edit
+        psi_coef_save(i,k) = psicoef(i,k)
+      enddo
+    enddo
+
+    call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save)
+    deallocate (psi_coef_save)
+
+    call write_int(6,ndet,'Saved determinants')
+  endif
+end
 
 
 subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,index_det_save)

src/tc_bi_ortho/EZFIO.cfg

@@ -0,0 +1,11 @@
+[psi_l_coef_bi_ortho]
+interface: ezfio
+doc: Coefficients for the left wave function
+type: double precision
+size: (determinants.n_det,determinants.n_states)
+
+[psi_r_coef_bi_ortho]
+interface: ezfio
+doc: Coefficients for the right wave function
+type: double precision
+size: (determinants.n_det,determinants.n_states)

src/tc_bi_ortho/NEED

@@ -0,0 +1,6 @@
+bi_ort_ints
+bi_ortho_mos
+tc_keywords
+non_hermit_dav
+dav_general_mat
+tc_scf

src/tc_bi_ortho/compute_deltamu_right.irp.f

@@ -0,0 +1,53 @@
+program compute_deltamu_right
+
+  implicit none
+
+  my_grid_becke = .True.
+  my_n_pt_r_grid = 30
+  my_n_pt_a_grid = 50
+  touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+
+  read_wf = .True.
+  touch read_wf
+
+  PROVIDE N_int 
+  call delta_right()
+
+end
+
+! ---
+
+subroutine delta_right()
+
+  implicit none
+  integer                       :: k
+  double precision, allocatable :: delta(:,:) 
+
+  print *, j1b_type
+  print *, j1b_pen
+  print *, mu_erf
+
+  allocate( delta(N_det,N_states) )
+  delta = 0.d0
+
+  do k = 1, N_states
+  !do k = 1, 1
+
+    ! get < I_left | H_mu - H | psi_right > 
+    !call get_h_bitc_right(psi_det, psi_r_coef_bi_ortho(:,k), N_det, N_int, delta(:,k))
+    call get_delta_bitc_right(psi_det, psi_r_coef_bi_ortho(:,k), N_det, N_int, delta(:,k))
+
+    ! order as QMCCHEM
+    call dset_order(delta(:,k), psi_bilinear_matrix_order, N_det)
+
+  enddo
+
+!  call ezfio_set_dmc_dress_dmc_delta_h(delta)
+
+  deallocate(delta)
+
+  return
+end subroutine delta_right
+
+! ---
+

src/tc_bi_ortho/dressing_vectors_lr.irp.f

@@ -0,0 +1,155 @@
+
+! ---
+
+subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
+  
+  BEGIN_DOC
+  !
+  ! delta(I) = < I_left | H_TC - H | Psi_right >
+  !
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+
+  integer,           intent(in)  :: ndet, Nint
+  double precision,  intent(in)  :: psicoef(ndet)
+  integer(bit_kind), intent(in)  :: psidet(Nint,2,ndet)
+  double precision, intent(out)  :: delta(ndet)
+
+  integer                        :: i, j
+  double precision               :: h_mono, h_twoe, h_tot
+  double precision               :: htc_mono, htc_twoe, htc_three, htc_tot
+  double precision               :: delta_mat
+
+  print *, ' get_delta_bitc_right ...'
+
+  i = 1
+  j = 1
+  call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
+  call hmat_bi_ortho         (psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
+
+  delta = 0.d0
+ !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8)   &
+ !$OMP SHARED(delta, ndet, psidet, psicoef, Nint)      &
+ !$OMP PRIVATE(i, j, delta_mat, h_mono, h_twoe, h_tot, &
+ !$OMP        htc_mono, htc_twoe, htc_three, htc_tot)
+  do i = 1, ndet
+    do j = 1, ndet
+
+      ! < I | Htilde | J >
+      call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
+      ! < I | H | J >
+      call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
+
+      delta_mat = htc_tot - h_tot
+
+      delta(i) = delta(i) + psicoef(j) * delta_mat
+    enddo
+  enddo
+ !$OMP END PARALLEL DO
+
+end subroutine get_delta_bitc_right
+
+! ---
+
+subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
+  
+  BEGIN_DOC
+  !
+  ! delta(I) = < I_left | H_TC | Psi_right >
+  !
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+
+  integer,           intent(in)  :: ndet, Nint
+  double precision,  intent(in)  :: psicoef(ndet)
+  integer(bit_kind), intent(in)  :: psidet(Nint,2,ndet)
+  double precision, intent(out)  :: delta(ndet)
+
+  integer                        :: i, j
+  double precision               :: htc_mono, htc_twoe, htc_three, htc_tot
+
+  print *, ' get_htc_bitc_right ...'
+
+  i = 1
+  j = 1
+  call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
+
+  delta = 0.d0
+ !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8)   &
+ !$OMP SHARED(delta, ndet, psidet, psicoef, Nint)      &
+ !$OMP PRIVATE(i, j, htc_mono, htc_twoe, htc_three, htc_tot)
+  do i = 1, ndet
+    do j = 1, ndet
+
+      ! < I | Htilde | J >
+      call htilde_mu_mat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
+
+      delta(i) = delta(i) + psicoef(j) * htc_tot
+    enddo
+  enddo
+ !$OMP END PARALLEL DO
+
+end subroutine get_htc_bitc_right
+
+! ---
+
+subroutine get_h_bitc_right(psidet, psicoef, ndet, Nint, delta)
+  
+  BEGIN_DOC
+  !
+  ! delta(I) = < I_left | H | Psi_right >
+  !
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+
+  integer,           intent(in)  :: ndet, Nint
+  double precision,  intent(in)  :: psicoef(ndet)
+  integer(bit_kind), intent(in)  :: psidet(Nint,2,ndet)
+  double precision, intent(out)  :: delta(ndet)
+
+  integer                        :: i, j
+  double precision               :: h_mono, h_twoe, h_tot
+
+  print *, ' get_h_bitc_right ...'
+
+  i = 1
+  j = 1
+  call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
+
+  !double precision :: norm
+  !norm = 0.d0
+  !do i = 1, ndet
+  !  norm += psicoef(i) * psicoef(i)
+  !enddo
+  !print*, ' norm = ', norm
+ 
+  call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
+
+  delta = 0.d0
+! !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
+! !$OMP SHARED(delta, ndet, psidet, psicoef, Nint)    &
+! !$OMP PRIVATE(i, j, h_mono, h_twoe, h_tot)
+  do i = 1, ndet
+    do j = 1, ndet
+
+      ! < I | H | J >
+      call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
+
+      delta(i) = delta(i) + psicoef(j) * h_tot
+    enddo
+  enddo
+! !$OMP END PARALLEL DO
+
+end subroutine get_h_bitc_right
+
+! ---
+

src/tc_bi_ortho/e_corr_bi_ortho.irp.f

@@ -0,0 +1,104 @@
+  use bitmasks ! you need to include the bitmasks_module.f90 features
+ BEGIN_PROVIDER [ double precision, e_tilde_00]
+ implicit none
+ double precision :: hmono,htwoe,hthree,htot
+ call htilde_mu_mat_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot)
+ e_tilde_00 = htot
+ END_PROVIDER 
+
+ BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth]
+&BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth_single]
+&BEGIN_PROVIDER [ double precision, e_pt2_tc_bi_orth_double]
+ implicit none 
+ integer :: i,degree
+ double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e
+ e_pt2_tc_bi_orth = 0.d0
+ e_pt2_tc_bi_orth_single = 0.d0
+ e_pt2_tc_bi_orth_double = 0.d0
+ do i = 1, N_det
+  call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
+  if(degree == 1 .or. degree == 2)then
+   call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
+   call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
+   delta_e = e_tilde_00 - e_i0
+   coef_pt1 = htilde_ij / delta_e
+   call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
+   e_pt2_tc_bi_orth += coef_pt1 * htilde_ij
+   if(degree == 1)then
+    e_pt2_tc_bi_orth_single += coef_pt1 * htilde_ij
+   else 
+!    print*,'coef_pt1, e_pt2',coef_pt1,coef_pt1 * htilde_ij
+    e_pt2_tc_bi_orth_double += coef_pt1 * htilde_ij
+   endif
+  endif
+ enddo
+ END_PROVIDER 
+
+ BEGIN_PROVIDER [ double precision, e_tilde_bi_orth_00]
+ implicit none
+ double precision :: hmono,htwoe,hthree,htilde_ij
+ call htilde_mu_mat_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00)
+ e_tilde_bi_orth_00 += nuclear_repulsion
+ END_PROVIDER 
+
+ BEGIN_PROVIDER [ double precision, e_corr_bi_orth ]
+&BEGIN_PROVIDER [ double precision, e_corr_bi_orth_proj ]
+&BEGIN_PROVIDER [ double precision, e_corr_single_bi_orth ]
+&BEGIN_PROVIDER [ double precision, e_corr_double_bi_orth ]
+ implicit none 
+ integer :: i,degree
+ double precision :: hmono,htwoe,hthree,htilde_ij
+ 
+ e_corr_bi_orth = 0.d0
+ e_corr_single_bi_orth = 0.d0
+ e_corr_double_bi_orth = 0.d0
+ do i = 1, N_det
+  call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
+  call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
+  if(degree == 1)then
+   e_corr_single_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
+  else if(degree == 2)then
+   e_corr_double_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
+!   print*,'coef_wf , e_cor',reigvec_tc_bi_orth(i,1)/reigvec_tc_bi_orth(1,1), reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)
+  endif
+ enddo
+ e_corr_bi_orth_proj = e_corr_single_bi_orth + e_corr_double_bi_orth
+ e_corr_bi_orth = eigval_right_tc_bi_orth(1) - e_tilde_bi_orth_00
+ END_PROVIDER 
+
+ BEGIN_PROVIDER [ double precision, e_tc_left_right ]
+ implicit none
+ integer :: i,j
+ double precision :: hmono,htwoe,hthree,htilde_ij,accu
+ e_tc_left_right = 0.d0
+ accu = 0.d0
+ do i = 1, N_det
+  accu += reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(i,1)
+  do j = 1, N_det
+   call htilde_mu_mat_bi_ortho(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
+   e_tc_left_right += htilde_ij * reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(j,1)
+  enddo
+ enddo
+ e_tc_left_right *= 1.d0/accu 
+ e_tc_left_right += nuclear_repulsion
+
+ END_PROVIDER 
+
+
+BEGIN_PROVIDER [ double precision, coef_pt1_bi_ortho, (N_det)]
+ implicit none
+ integer :: i,degree
+ double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e
+ do i = 1, N_det
+  call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
+  if(degree==0)then
+   coef_pt1_bi_ortho(i) = 1.d0
+  else
+   call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
+   call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
+   delta_e = e_tilde_00 - e_i0
+   coef_pt1 = htilde_ij / delta_e
+   coef_pt1_bi_ortho(i)= coef_pt1
+  endif
+ enddo
+END_PROVIDER

src/tc_bi_ortho/h_biortho.irp.f

@@ -0,0 +1,243 @@
+
+! --
+
+subroutine hmat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, htot)
+
+  BEGIN_DOC
+  !
+  ! < key_j | H | key_i > where | key_j > is developed on the LEFT basis and | key_i > is developed on the RIGHT basis
+  ! 
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+
+  integer,           intent(in) :: Nint
+  integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
+  double precision, intent(out) :: hmono, htwoe, htot
+
+  integer                       :: degree 
+
+  hmono = 0.d0
+  htwoe = 0.d0
+  htot  = 0.d0
+
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+  if(degree .gt. 2) return
+
+  if(degree == 0) then
+
+    call diag_hmat_bi_ortho(Nint, key_i, hmono, htwoe)
+    htot = htot + nuclear_repulsion
+
+  else if (degree == 1) then
+
+    call single_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
+
+  else if(degree == 2) then
+
+    call double_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
+
+  endif
+
+  htot += hmono + htwoe
+
+  return
+end subroutine hmat_bi_ortho
+
+! ---
+
+subroutine diag_hmat_bi_ortho(Nint, key_i, hmono, htwoe)
+
+  use bitmasks
+
+  implicit none
+
+  integer,           intent(in) :: Nint
+  integer(bit_kind), intent(in) :: key_i(Nint,2)
+  double precision, intent(out) :: hmono, htwoe
+
+  integer                        :: occ(Nint*bit_kind_size,2)
+  integer                        :: Ne(2), i, j, ii, jj, ispin, jspin
+
+  hmono = 0.d0
+  htwoe = 0.d0
+
+  call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+
+  do ispin = 1, 2 
+    do i = 1, Ne(ispin)
+      ii = occ(i,ispin) 
+      hmono += mo_bi_ortho_one_e(ii,ii)
+    enddo
+  enddo
+
+  ! alpha/beta two-body
+  ispin = 1
+  jspin = 2 
+  do i = 1, Ne(ispin) ! electron 1
+    ii = occ(i,ispin) 
+    do j = 1, Ne(jspin) ! electron 2 
+      jj = occ(j,jspin) 
+      htwoe += mo_bi_ortho_coul_e(jj,ii,jj,ii) 
+    enddo
+  enddo
+ 
+  ! alpha/alpha two-body
+  do i = 1, Ne(ispin)
+    ii = occ(i,ispin) 
+    do j = i+1, Ne(ispin)
+      jj = occ(j,ispin) 
+      htwoe += mo_bi_ortho_coul_e(ii,jj,ii,jj) - mo_bi_ortho_coul_e(ii,jj,jj,ii)
+    enddo
+  enddo
+ 
+  ! beta/beta two-body
+  do i = 1, Ne(jspin)
+    ii = occ(i,jspin) 
+    do j = i+1, Ne(jspin)
+      jj = occ(j,jspin) 
+      htwoe += mo_bi_ortho_coul_e(ii,jj,ii,jj) - mo_bi_ortho_coul_e(ii,jj,jj,ii)
+    enddo
+  enddo
+
+  return
+end subroutine diag_hmat_bi_ortho
+
+! ---
+
+subroutine single_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
+
+  BEGIN_DOC
+  !
+  ! < key_j | H | key_i > for single excitation 
+  ! 
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+
+  integer,           intent(in) :: Nint
+  integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
+  double precision, intent(out) :: hmono, htwoe
+
+  integer                       :: occ(Nint*bit_kind_size,2)
+  integer                       :: Ne(2), i, j, ii, ispin, jspin
+  integer                       :: degree,exc(0:2,2,2)
+  integer                       :: h1, p1, h2, p2, s1, s2
+  integer                       :: other_spin(2)
+  double precision              :: phase
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  hmono = 0.d0
+  htwoe = 0.d0
+
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+  if(degree .ne. 1) then
+    return
+  endif
+
+  call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+
+  call get_single_excitation(key_i, key_j, exc, phase, Nint)
+  call decode_exc(exc, 1, h1, p1, h2, p2, s1, s2)
+
+  hmono = mo_bi_ortho_one_e(p1,h1) * phase
+
+  ! alpha/beta two-body 
+  ispin = other_spin(s1)
+  if(s1 == 1) then
+
+    ! single alpha 
+    do i = 1, Ne(ispin) ! electron 2 
+      ii = occ(i,ispin) 
+      htwoe += mo_bi_ortho_coul_e(ii,p1,ii,h1) 
+    enddo
+
+  else
+
+    ! single beta 
+    do i = 1, Ne(ispin) ! electron 1 
+      ii = occ(i,ispin) 
+      htwoe += mo_bi_ortho_coul_e(p1,ii,h1,ii) 
+    enddo
+
+  endif
+
+  ! same spin two-body 
+  do i = 1, Ne(s1)
+    ii = occ(i,s1) 
+    ! ( h1 p1 |ii ii ) - ( h1 ii | p1 ii )
+    htwoe += mo_bi_ortho_coul_e(ii,p1,ii,h1) - mo_bi_ortho_coul_e(p1,ii,ii,h1) 
+  enddo
+   
+  htwoe *= phase
+
+end subroutine single_hmat_bi_ortho
+
+! ---
+
+subroutine double_hmat_bi_ortho(Nint, key_j, key_i, hmono, htwoe)
+
+  BEGIN_DOC
+  !
+  ! < key_j | H | key_i> for double excitation
+  ! 
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+
+  integer,           intent(in) :: Nint 
+  integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
+  double precision, intent(out) :: hmono, htwoe
+
+  integer                       :: occ(Nint*bit_kind_size,2)
+  integer                       :: Ne(2), i, j, ii, ispin, jspin
+  integer                       :: degree,exc(0:2,2,2)
+  integer                       :: h1, p1, h2, p2, s1, s2
+  integer                       :: other_spin(2)
+  double precision              :: phase
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+
+  hmono = 0.d0
+  htwoe = 0.d0
+
+  if(degree .ne. 2) then
+    return
+  endif
+
+  call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+
+  call get_double_excitation(key_i, key_j, exc, phase, Nint)
+  call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
+
+  if(s1 .ne. s2) then
+
+    htwoe = mo_bi_ortho_coul_e(p2,p1,h2,h1) 
+
+  else
+
+    ! same spin two-body 
+
+    !                    direct terms                 exchange terms 
+    htwoe = mo_bi_ortho_coul_e(p2,p1,h2,h1) - mo_bi_ortho_coul_e(p1,p2,h2,h1) 
+
+  endif
+
+  htwoe *= phase
+
+end subroutine double_hmat_bi_ortho
+
+! ---
+
+

src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f

@@ -0,0 +1,92 @@
+subroutine htc_bi_ortho_calc_tdav(v, u, N_st, sze)
+
+  use bitmasks
+
+  BEGIN_DOC
+    ! Application of H_TC on a vector 
+    !
+    ! v(i,istate) = \sum_j u(j,istate) H_TC(i,j), with: 
+    !   H_TC(i,j) = < Di | H_TC | Dj > 
+    !
+  END_DOC
+
+  implicit none
+
+  integer, intent(in)             :: N_st, sze
+  double precision, intent(in)    :: u(sze,N_st)
+  double precision, intent(inout) :: v(sze,N_st)
+
+  integer                         :: i, j, istate
+  double precision                :: htot
+
+  PROVIDE N_int 
+  PROVIDE psi_det
+
+
+ ! TODO : transform it with the bi-linear representation in terms of alpha-beta. 
+
+  i = 1
+  j = 1
+  call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
+
+  v = 0.d0
+ !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
+ !$OMP SHARED(N_st, sze, N_int, psi_det, u, v)       &
+ !$OMP PRIVATE(istate, i, j, htot)
+  do istate = 1, N_st
+    do i = 1, sze
+      do j = 1, sze
+        call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
+        v(i,istate) = v(i,istate) + htot * u(j,istate)
+      enddo
+    enddo 
+  enddo
+ !$OMP END PARALLEL DO
+
+end 
+
+subroutine htcdag_bi_ortho_calc_tdav(v, u, N_st, sze)
+
+  use bitmasks
+
+  BEGIN_DOC
+    ! Application of (H_TC)^dagger on a vector 
+    !
+    ! v(i,istate) = \sum_j u(j,istate) H_TC(j,i), with: 
+    !   H_TC(i,j) = < Di | H_TC | Dj > 
+    !
+  END_DOC
+
+  implicit none
+
+  integer, intent(in)             :: N_st, sze
+  double precision, intent(in)    :: u(sze,N_st)
+  double precision, intent(inout) :: v(sze,N_st)
+
+  integer                         :: i, j, istate
+  double precision                :: htot
+
+  PROVIDE N_int
+  PROVIDE psi_det
+
+  i = 1
+  j = 1
+  call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,j), N_int, htot)
+
+  v = 0.d0
+
+ !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
+ !$OMP SHARED(N_st, sze, N_int, psi_det, u, v)       &
+ !$OMP PRIVATE(istate, i, j, htot)
+  do istate = 1, N_st
+    do i = 1, sze
+      do j = 1, sze
+        call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
+        v(i,istate) = v(i,istate) + htot * u(j,istate)
+      enddo
+    enddo
+  enddo
+ !$OMP END PARALLEL DO
+
+end 
+

src/tc_bi_ortho/normal_ordered.irp.f

@@ -0,0 +1,319 @@
+BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth, (mo_num, mo_num, mo_num, mo_num)]
+
+  BEGIN_DOC 
+  ! Normal ordering of the three body interaction on the HF density
+  END_DOC 
+
+  use bitmasks ! you need to include the bitmasks_module.f90 features
+
+  implicit none
+
+  integer :: i,h1,p1,h2,p2
+  integer :: hh1,hh2,pp1,pp2
+  integer                        :: Ne(2)
+  integer,           allocatable :: occ(:,:)
+  integer(bit_kind), allocatable :: key_i_core(:,:)
+  double precision :: hthree_aba,hthree_aaa,hthree_aab
+  double precision :: wall0,wall1
+ 
+  PROVIDE N_int
+
+  allocate( occ(N_int*bit_kind_size,2) )
+  allocate( key_i_core(N_int,2) )
+
+  if(core_tc_op) then
+    do i = 1, N_int
+      key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1))
+      key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2))
+    enddo
+    call bitstring_to_list_ab(key_i_core,occ,Ne,N_int)
+  else
+    call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
+  endif
+
+  normal_two_body_bi_orth = 0.d0
+  print*,'Providing normal_two_body_bi_orth ...'
+  call wall_time(wall0)
+
+ !$OMP PARALLEL                                                                         &
+ !$OMP DEFAULT (NONE)                                                                   &
+ !$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, hthree_aba, hthree_aab, hthree_aaa) & 
+ !$OMP SHARED (N_int, n_act_orb, list_act, Ne, occ, normal_two_body_bi_orth)
+ !$OMP DO SCHEDULE (static) 
+  do hh1 = 1, n_act_orb
+    h1 = list_act(hh1) 
+    do pp1 = 1, n_act_orb
+      p1 = list_act(pp1)
+      do hh2 = 1, n_act_orb
+        h2 = list_act(hh2) 
+        do pp2 = 1, n_act_orb
+          p2 = list_act(pp2)
+          ! opposite spin double excitations 
+          call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aba)
+          ! same spin double excitations with opposite spin contributions 
+          if(h1<h2.and.p1.gt.p2)then
+           call give_aab_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aab) ! exchange h1<->h2
+           ! same spin double excitations with same spin contributions 
+           if(Ne(2).ge.3)then
+             call give_aaa_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aaa) ! exchange h1<->h2
+           else
+             hthree_aaa = 0.d0
+           endif
+          else
+           call give_aab_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aab)
+           if(Ne(2).ge.3)then
+             call give_aaa_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aaa)
+           else
+             hthree_aaa = 0.d0
+           endif
+          endif
+          normal_two_body_bi_orth(p2,h2,p1,h1) = 0.5d0*(hthree_aba + hthree_aab + hthree_aaa)
+        enddo
+      enddo
+    enddo
+  enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+  call wall_time(wall1)
+  print*,'Wall time for normal_two_body_bi_orth ',wall1-wall0
+
+  deallocate( occ )
+  deallocate( key_i_core )
+
+END_PROVIDER 
+
+
+
+subroutine give_aba_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree)
+
+  use bitmasks ! you need to include the bitmasks_module.f90 features
+
+  implicit none
+  integer, intent(in)           :: Nint, h1, h2, p1, p2
+  integer, intent(in)           :: Ne(2), occ(Nint*bit_kind_size,2)
+  double precision, intent(out) :: hthree
+  integer                       :: ii, i
+  double precision              :: int_direct, int_exc_12, int_exc_13, integral
+
+  !!!! double alpha/beta
+  hthree = 0.d0
+  do ii = 1, Ne(2) ! purely closed shell part 
+    i = occ(ii,2)
+    call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral)
+    int_direct = -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral)
+    int_exc_13 = -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p2, i,p1,i,h2,h1,integral)
+    int_exc_12 = -1.d0 * integral
+    hthree += 2.d0 * int_direct - 1.d0 * ( int_exc_13 + int_exc_12)
+  enddo
+  do ii = Ne(2) + 1, Ne(1) ! purely open-shell part 
+   i = occ(ii,1)
+    call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral)
+    int_direct = -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral)
+    int_exc_13 = -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p2, i,p1,i,h2,h1,integral)
+    int_exc_12 = -1.d0 * integral
+    hthree += 1.d0 * int_direct - 0.5d0* ( int_exc_13 + int_exc_12)
+  enddo
+
+end subroutine give_aba_contraction
+
+
+
+BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_ab, (mo_num, mo_num, mo_num, mo_num)]
+
+  BEGIN_DOC
+  ! Normal ordered two-body sector of the three-body terms for opposite spin double excitations 
+  END_DOC
+
+  use bitmasks ! you need to include the bitmasks_module.f90 features
+
+  implicit none
+  integer                        :: h1, p1, h2, p2, i
+  integer                        :: hh1, hh2, pp1, pp2
+  integer                        :: Ne(2)
+  integer,           allocatable :: occ(:,:)
+  integer(bit_kind), allocatable :: key_i_core(:,:)
+  double precision               :: hthree
+
+  PROVIDE N_int
+
+  allocate( key_i_core(N_int,2) )
+  allocate( occ(N_int*bit_kind_size,2) )
+
+  if(core_tc_op)then
+   do i = 1, N_int
+    key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1))
+    key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2))
+   enddo
+   call bitstring_to_list_ab(key_i_core,occ,Ne,N_int)
+  else
+   call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
+  endif
+  normal_two_body_bi_orth_ab = 0.d0
+  do hh1 = 1, n_act_orb
+   h1 = list_act(hh1) 
+   do pp1 = 1, n_act_orb
+    p1 = list_act(pp1)
+    do hh2 = 1, n_act_orb
+     h2 = list_act(hh2) 
+     do pp2 = 1, n_act_orb
+      p2 = list_act(pp2)
+      call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree)
+      normal_two_body_bi_orth_ab(p2,h2,p1,h1) = hthree    
+     enddo
+    enddo
+   enddo
+  enddo
+
+  deallocate( key_i_core )
+  deallocate( occ )
+
+END_PROVIDER 
+
+
+
+BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_aa_bb, (n_act_orb, n_act_orb, n_act_orb, n_act_orb)]
+
+  BEGIN_DOC
+  ! Normal ordered two-body sector of the three-body terms for same spin double excitations 
+  END_DOC
+
+  use bitmasks ! you need to include the bitmasks_module.f90 features
+
+  implicit none
+  integer                        :: i,ii,j,h1,p1,h2,p2
+  integer                        :: hh1,hh2,pp1,pp2
+  integer                        :: Ne(2)
+  integer,           allocatable :: occ(:,:)
+  integer(bit_kind), allocatable :: key_i_core(:,:)
+  double precision               :: hthree_aab, hthree_aaa
+
+  PROVIDE N_int
+
+  allocate( key_i_core(N_int,2) )
+  allocate( occ(N_int*bit_kind_size,2) )
+
+  if(core_tc_op)then
+    do i = 1, N_int
+      key_i_core(i,1) = xor(ref_bitmask(i,1),core_bitmask(i,1))
+      key_i_core(i,2) = xor(ref_bitmask(i,2),core_bitmask(i,2))
+    enddo
+    call bitstring_to_list_ab(key_i_core, occ, Ne, N_int)
+  else
+    call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int)
+  endif
+
+  normal_two_body_bi_orth_aa_bb = 0.d0
+  do hh1 = 1, n_act_orb
+    h1 = list_act(hh1) 
+    do pp1 = 1 , n_act_orb
+      p1 = list_act(pp1)
+      do hh2 = 1, n_act_orb
+        h2 = list_act(hh2) 
+        do pp2 = 1 , n_act_orb
+          p2 = list_act(pp2)
+          if(h1<h2.and.p1.gt.p2)then
+           call give_aab_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aab) ! exchange h1<->h2
+           if(Ne(2).ge.3)then
+             call give_aaa_contraction(N_int, h2, h1, p1, p2, Ne, occ, hthree_aaa) ! exchange h1<->h2
+           else
+             hthree_aaa = 0.d0
+           endif
+          else
+           call give_aab_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aab)
+           if(Ne(2).ge.3)then
+             call give_aaa_contraction(N_int, h1, h2, p1, p2, Ne, occ, hthree_aaa)
+           else
+             hthree_aaa = 0.d0
+           endif
+          endif
+          normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1) = hthree_aab + hthree_aaa
+        enddo
+      enddo
+    enddo
+  enddo
+
+  deallocate( key_i_core )
+  deallocate( occ )
+
+END_PROVIDER 
+
+
+
+subroutine give_aaa_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree)
+
+  use bitmasks ! you need to include the bitmasks_module.f90 features
+
+  implicit none
+  integer, intent(in)           :: Nint, h1, h2, p1, p2
+  integer, intent(in)           :: Ne(2), occ(Nint*bit_kind_size,2)
+  double precision, intent(out) :: hthree
+  integer                       :: ii,i
+  double precision              :: int_direct,int_exc_12,int_exc_13,int_exc_23
+  double precision              :: integral,int_exc_l,int_exc_ll
+
+  hthree = 0.d0
+  do ii = 1, Ne(2) ! purely closed shell part 
+    i = occ(ii,2)
+    call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral)
+    int_direct = -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p2,p1,i ,i,h2,h1,integral)
+    int_exc_l = -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p1,i ,p2,i,h2,h1,integral)
+    int_exc_ll= -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p2,i ,p1,i,h2,h1,integral)
+    int_exc_12= -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral)
+    int_exc_13= -1.d0 * integral
+    call give_integrals_3_body_bi_ort(i ,p1,p2,i,h2,h1,integral)
+    int_exc_23= -1.d0 * integral
+
+    hthree +=  1.d0 * int_direct + int_exc_l + int_exc_ll -( int_exc_12+ int_exc_13+ int_exc_23  )
+  enddo
+  do ii = Ne(2)+1,Ne(1) ! purely open-shell part 
+    i = occ(ii,1)
+    call give_integrals_3_body_bi_ort(i ,p2,p1,i,h2,h1,integral)
+    int_direct = -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p2,p1,i ,i,h2,h1,integral)
+    int_exc_l = -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p1,i ,p2,i,h2,h1,integral)
+    int_exc_ll= -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p2,i ,p1,i,h2,h1,integral)
+    int_exc_12= -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p1,p2, i,i,h2,h1,integral)
+    int_exc_13= -1.d0 * integral
+    call give_integrals_3_body_bi_ort(i ,p1,p2,i,h2,h1,integral)
+    int_exc_23= -1.d0 * integral
+
+    hthree +=  1.d0 * int_direct + 0.5d0 * (int_exc_l + int_exc_ll -( int_exc_12+ int_exc_13+ int_exc_23  ))
+  enddo
+
+end subroutine give_aaa_contraction
+
+
+
+subroutine give_aab_contraction(Nint, h1, h2, p1, p2, Ne, occ, hthree)
+  implicit none
+  use bitmasks ! you need to include the bitmasks_module.f90 features
+  integer, intent(in)           :: Nint, h1, h2, p1, p2
+  integer, intent(in)           :: Ne(2), occ(Nint*bit_kind_size,2)
+  double precision, intent(out) :: hthree
+  integer                       :: ii, i
+  double precision              :: int_direct, int_exc_12, int_exc_13, int_exc_23
+  double precision              :: integral, int_exc_l, int_exc_ll
+
+  hthree = 0.d0
+  do ii = 1, Ne(2) ! purely closed shell part 
+    i = occ(ii,2)
+    call give_integrals_3_body_bi_ort(p2,p1,i,h2,h1,i,integral)
+    int_direct = -1.d0 * integral
+    call give_integrals_3_body_bi_ort(p1,p2,i,h2,h1,i,integral)
+    int_exc_23= -1.d0 * integral
+    hthree  +=  1.d0 * int_direct - int_exc_23
+  enddo
+
+end subroutine give_aab_contraction

src/tc_bi_ortho/print_he_tc_energy.irp.f

@@ -0,0 +1,142 @@
+
+! ---
+
+program print_he_tc_energy
+
+  implicit none
+
+  call print_overlap()
+
+  call print_energy1()
+
+end 
+
+! ---
+
+subroutine print_overlap()
+
+  implicit none
+  integer          :: i, j, k, l
+  double precision :: S_ij
+
+  print *, ' ao_overlap:'
+  do i = 1, ao_num
+    do j = 1, ao_num
+      print *, j, i, ao_overlap(j,i)
+    enddo
+  enddo
+
+  print *, ' mo_overlap:'
+  do i = 1, mo_num
+    do j = 1, mo_num
+
+      S_ij = 0.d0
+      do k = 1, ao_num
+        do l = 1, ao_num
+          S_ij += mo_l_coef(k,i) * ao_overlap(k,l) * mo_r_coef(l,j)
+        enddo
+      enddo
+      
+      print *, i, j, S_ij
+    enddo
+  enddo
+
+end subroutine print_overlap
+
+! ---
+
+subroutine print_energy1()
+
+  implicit none
+  integer                    :: i, j, k, l
+  double precision           :: e, n, e_tmp, n_tmp, e_ns
+  double precision, external :: ao_two_e_integral
+
+  e = 0.d0
+  n = 0.d0
+
+  ! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+  ! < phi_1 phi_1 | h1 | phi_1 phi_1 > 
+
+  e_tmp = 0.d0
+  n_tmp = 0.d0
+  do i = 1, ao_num
+    do j = 1, ao_num
+      e_tmp += mo_l_coef(i,1) * ao_one_e_integrals(i,j) * mo_r_coef(j,1)
+      n_tmp += mo_l_coef(i,1) * ao_overlap(i,j)         * mo_r_coef(j,1)
+    enddo
+  enddo
+
+  e += e_tmp * n_tmp
+
+  ! ---
+
+  ! < phi_1 phi_1 | h2 | phi_1 phi_1 > 
+
+  e_tmp = 0.d0
+  n_tmp = 0.d0
+  do i = 1, ao_num
+    do j = 1, ao_num
+      n_tmp += mo_l_coef(i,1) * ao_overlap(i,j)         * mo_r_coef(j,1)
+      e_tmp += mo_l_coef(i,1) * ao_one_e_integrals(i,j) * mo_r_coef(j,1)
+    enddo
+  enddo
+
+  e += e_tmp * n_tmp
+
+  ! ---
+
+  ! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+  ! ---
+
+  e_ns = 0.d0
+
+  do i = 1, ao_num
+    do j = 1, ao_num
+      do k = 1, ao_num
+        do l = 1, ao_num
+
+          ! ao_two_e_tc_tot(i,j,k,l) = <k i| V^TC(r_12) |l j>
+          e += mo_l_coef(i,1) * mo_l_coef(k,1) * ao_two_e_tc_tot(i,j,k,l) * mo_r_coef(j,1) * mo_r_coef(l,1)
+
+          e_ns += mo_l_coef(i,1) * mo_l_coef(k,1) * ao_non_hermit_term_chemist(i,j,k,l) * mo_r_coef(j,1) * mo_r_coef(l,1)
+        enddo
+      enddo
+    enddo
+  enddo
+
+  ! ---
+
+  ! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+  ! ---
+
+  ! < phi_1 phi_1 | phi_1 phi_1 >
+  e_tmp = 0.d0
+  n_tmp = 0.d0
+  do i = 1, ao_num
+    do j = 1, ao_num
+      e_tmp += mo_l_coef(i,1) * ao_overlap(i,j) * mo_r_coef(j,1)
+      n_tmp += mo_l_coef(i,1) * ao_overlap(i,j) * mo_r_coef(j,1)
+    enddo
+  enddo
+
+  n += e_tmp * n_tmp
+
+  ! ---
+
+  ! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
+
+  e    = e    / n 
+  e_ns = e_ns / n
+
+  print *, ' tc      energy = ', e
+  print *, ' non-sym energy = ', e_ns
+
+end subroutine print_energy1
+
+! ---
+
+

src/tc_bi_ortho/print_tc_wf.irp.f

@@ -0,0 +1,104 @@
+program print_tc_bi_ortho
+  implicit none
+  BEGIN_DOC
+! TODO : Put the documentation of the program here
+  END_DOC
+  print *, 'Hello world'
+  my_grid_becke = .True.
+  my_n_pt_r_grid = 30
+  my_n_pt_a_grid = 50
+  read_wf = .True.
+  touch read_wf
+  touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+!  if(three_body_h_tc)then
+!   call provide_all_three_ints_bi_ortho
+!  endif
+!  call routine
+ call write_l_r_wf
+end
+
+subroutine write_l_r_wf
+ implicit none
+ character*(128) :: output
+ integer :: i_unit_output,getUnitAndOpen                                                                                 
+ output=trim(ezfio_filename)//'.tc_wf'
+ i_unit_output = getUnitAndOpen(output,'w')
+ integer :: i
+ print*,'Writing the left-right wf'
+ do i = 1, N_det
+  write(i_unit_output,*)i,psi_l_coef_sorted_bi_ortho_left(i),psi_r_coef_sorted_bi_ortho_right(i)
+ enddo
+
+
+end
+
+subroutine routine
+ implicit none
+ integer :: i,degree
+ integer          :: exc(0:2,2,2),h1,p1,s1,h2,p2,s2
+ double precision :: hmono,htwoe,hthree,htilde_ij,coef_pt1,e_i0,delta_e,e_pt2
+ double precision :: contrib_pt,e_corr,coef,contrib,phase
+ double precision :: accu_positive,accu_positive_pt, accu_positive_core,accu_positive_core_pt
+ e_pt2 = 0.d0
+ accu_positive = 0.D0
+ accu_positive_pt = 0.D0
+ accu_positive_core = 0.d0
+ accu_positive_core_pt = 0.d0
+ 
+ do i = 1, N_det
+  call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
+   if(degree == 1 .or. degree == 2)then
+    call htilde_mu_mat_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
+    call htilde_mu_mat_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
+    delta_e = e_tilde_00 - e_i0
+    coef_pt1 = htilde_ij / delta_e
+ 
+    call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
+    contrib_pt = coef_pt1 * htilde_ij
+    e_pt2 += contrib_pt
+ 
+    coef = psi_r_coef_bi_ortho(i,1)/psi_r_coef_bi_ortho(1,1)
+    contrib = coef * htilde_ij
+    e_corr += contrib
+    call get_excitation(HF_bitmask,psi_det(1,1,i),exc,degree,phase,N_int)
+    call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+    print*,'*********'
+    if(degree==1)then
+     print*,'s1',s1
+     print*,'h1,p1 = ',h1,p1
+    else if(degree ==2)then
+     print*,'s1',s1
+     print*,'h1,p1 = ',h1,p1
+     print*,'s2',s2
+     print*,'h2,p2 = ',h2,p2
+    endif
+    print*,'coef_pt1 = ',coef_pt1
+    print*,'coef     = ',coef
+    print*,'contrib_pt ',contrib_pt
+    print*,'contrib  = ',contrib
+    if(contrib.gt.0.d0)then
+     accu_positive    += contrib
+     if(h1==1.or.h2==1)then
+      accu_positive_core += contrib
+     endif
+     if(dabs(contrib).gt.1.d-5)then
+      print*,'Found a positive contribution to correlation energy !!'
+     endif
+    endif
+    if(contrib_pt.gt.0.d0)then
+     accu_positive_pt += contrib_pt
+     if(h2==1.or.h1==1)then
+      accu_positive_core_pt += contrib_pt
+     endif
+    endif
+   endif
+ enddo
+ print*,''
+ print*,''
+ print*,'Total correlation energy            = ',e_corr
+ print*,'Total correlation energy PT         = ',e_pt2
+ print*,'Positive contribution to ecorr      = ',accu_positive
+ print*,'Positive contribution to ecorr PT   = ',accu_positive_pt
+ print*,'Pure core contribution              = ',accu_positive_core
+ print*,'Pure core contribution PT           = ',accu_positive_core_pt
+end

src/tc_bi_ortho/psi_det_tc_sorted.irp.f

@@ -0,0 +1,157 @@
+use bitmasks
+
+BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_tc, (psi_det_size) ]                                                                
+  implicit none
+  BEGIN_DOC
+  ! Contribution of determinants to the state-averaged density.
+  END_DOC
+  integer                        :: i,j,k
+  double precision               :: f
+    
+  psi_average_norm_contrib_tc(:) = 0.d0
+  do k=1,N_states
+    do i=1,N_det
+      psi_average_norm_contrib_tc(i) = psi_average_norm_contrib_tc(i) +    &
+          dabs(psi_l_coef_bi_ortho(i,k)*psi_r_coef_bi_ortho(i,k))*state_average_weight(k)
+    enddo
+  enddo
+  f = 1.d0/sum(psi_average_norm_contrib_tc(1:N_det))
+  do i=1,N_det
+    psi_average_norm_contrib_tc(i) = psi_average_norm_contrib_tc(i)*f
+  enddo
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc, (N_int,2,psi_det_size) ]
+&BEGIN_PROVIDER [ double precision, psi_coef_sorted_tc, (psi_det_size,N_states) ]
+&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted_tc, (psi_det_size) ]
+&BEGIN_PROVIDER [ integer, psi_det_sorted_tc_order, (psi_det_size) ]
+   implicit none
+   BEGIN_DOC
+   ! Wave function sorted by determinants contribution to the norm (state-averaged)
+   !
+   ! psi_det_sorted_tc_order(i) -> k : index in psi_det
+   END_DOC
+   integer                        :: i,j,k
+   integer, allocatable           :: iorder(:)
+   allocate ( iorder(N_det) )
+   do i=1,N_det
+     psi_average_norm_contrib_sorted_tc(i) = -psi_average_norm_contrib_tc(i)
+     iorder(i) = i
+   enddo
+   call dsort(psi_average_norm_contrib_sorted_tc,iorder,N_det)
+   do i=1,N_det
+     do j=1,N_int
+       psi_det_sorted_tc(j,1,i) = psi_det(j,1,iorder(i))
+       psi_det_sorted_tc(j,2,i) = psi_det(j,2,iorder(i))
+     enddo
+    psi_average_norm_contrib_sorted_tc(i) = -psi_average_norm_contrib_sorted_tc(i)
+    psi_det_sorted_tc_order(iorder(i)) = i
+   enddo
+   double precision :: accu
+   do k=1,N_states
+    accu = 0.d0
+    do i=1,N_det
+     psi_coef_sorted_tc(i,k) = dsqrt(dabs(psi_l_coef_bi_ortho(iorder(i),k)*psi_r_coef_bi_ortho(iorder(i),k)))
+     accu += psi_coef_sorted_tc(i,k)**2
+    enddo
+    accu = 1.d0/dsqrt(accu)
+    do i=1,N_det
+     psi_coef_sorted_tc(i,k) *= accu
+    enddo
+   enddo
+
+   psi_det_sorted_tc(:,:,N_det+1:psi_det_size) = 0_bit_kind
+   psi_coef_sorted_tc(N_det+1:psi_det_size,:) = 0.d0
+   psi_average_norm_contrib_sorted_tc(N_det+1:psi_det_size) = 0.d0
+   psi_det_sorted_tc_order(N_det+1:psi_det_size) = 0
+
+   deallocate(iorder)
+
+END_PROVIDER
+
+ BEGIN_PROVIDER [double precision, psi_r_coef_sorted_bi_ortho, (psi_det_size, N_states)]
+&BEGIN_PROVIDER [double precision, psi_l_coef_sorted_bi_ortho, (psi_det_size, N_states)]
+ BEGIN_DOC
+ ! psi_r_coef_sorted_bi_ortho : right coefficients corresponding to psi_det_sorted_tc
+ ! psi_l_coef_sorted_bi_ortho : left  coefficients corresponding to psi_det_sorted_tc
+ END_DOC
+   implicit none
+   integer                       :: i, j, k
+   psi_r_coef_sorted_bi_ortho = 0.d0
+   psi_l_coef_sorted_bi_ortho = 0.d0
+   do i = 1, N_det
+    psi_r_coef_sorted_bi_ortho(i,1) = psi_r_coef_bi_ortho(psi_det_sorted_tc_order(i),1)
+    psi_l_coef_sorted_bi_ortho(i,1) = psi_l_coef_bi_ortho(psi_det_sorted_tc_order(i),1)
+   enddo
+
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_bit, (N_int,2,psi_det_size) ]
+&BEGIN_PROVIDER [ double precision, psi_coef_sorted_tc_bit, (psi_det_size,N_states) ]
+   implicit none
+   BEGIN_DOC
+   ! Determinants on which we apply $\langle i|H|psi \rangle$ for perturbation.
+   ! They are sorted by determinants interpreted as integers. Useful
+   ! to accelerate the search of a random determinant in the wave
+   ! function.
+   END_DOC
+
+   call sort_dets_by_det_search_key(N_det, psi_det, psi_coef, size(psi_coef,1),       &
+       psi_det_sorted_tc_bit, psi_coef_sorted_tc_bit, N_states)
+
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_right, (N_int,2,N_det) ]
+&BEGIN_PROVIDER [double precision, psi_r_coef_sorted_bi_ortho_right, (N_det)]
+ implicit none
+ BEGIN_DOC
+ ! psi_det_sorted_tc_right : Slater determinants sorted by decreasing value of |right- coefficients|
+ ! 
+ ! psi_r_coef_sorted_bi_ortho_right : right wave function according to psi_det_sorted_tc_right
+ END_DOC
+ integer, allocatable           :: iorder(:)
+ double precision, allocatable :: coef(:)
+ integer :: i,j
+ allocate ( iorder(N_det) , coef(N_det))
+ do i=1,N_det
+   coef(i) = -dabs(psi_r_coef_bi_ortho(i,1)/psi_r_coef_bi_ortho(1,1))
+   iorder(i) = i
+ enddo
+ call dsort(coef,iorder,N_det)
+ do i=1,N_det
+   do j=1,N_int
+     psi_det_sorted_tc_right(j,1,i) = psi_det(j,1,iorder(i))
+     psi_det_sorted_tc_right(j,2,i) = psi_det(j,2,iorder(i))
+   enddo
+  psi_r_coef_sorted_bi_ortho_right(i) = psi_r_coef_bi_ortho(iorder(i),1)/psi_r_coef_bi_ortho(iorder(1),1)
+ enddo
+END_PROVIDER 
+
+ BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_tc_left, (N_int,2,N_det) ]
+&BEGIN_PROVIDER [double precision, psi_l_coef_sorted_bi_ortho_left, (N_det)]
+ implicit none
+ BEGIN_DOC
+ ! psi_det_sorted_tc_left : Slater determinants sorted by decreasing value of |LEFTt- coefficients|
+ ! 
+ ! psi_r_coef_sorted_bi_ortho_left : LEFT wave function according to psi_det_sorted_tc_left
+ END_DOC
+ integer, allocatable           :: iorder(:)
+ double precision, allocatable :: coef(:)
+ integer :: i,j
+ allocate ( iorder(N_det) , coef(N_det))
+ do i=1,N_det
+   coef(i) = -dabs(psi_l_coef_bi_ortho(i,1)/psi_r_coef_bi_ortho(1,1))
+   iorder(i) = i
+ enddo
+ call dsort(coef,iorder,N_det)
+ do i=1,N_det
+   do j=1,N_int
+     psi_det_sorted_tc_left(j,1,i) = psi_det(j,1,iorder(i))
+     psi_det_sorted_tc_left(j,2,i) = psi_det(j,2,iorder(i))
+   enddo
+  psi_l_coef_sorted_bi_ortho_left(i) = psi_l_coef_bi_ortho(iorder(i),1)/psi_l_coef_bi_ortho(iorder(1),1)
+ enddo
+END_PROVIDER 

src/tc_bi_ortho/psi_left_qmc.irp.f

@@ -0,0 +1,44 @@
+
+! ---
+
+BEGIN_PROVIDER  [ double precision, psi_bitcleft_bilinear_matrix_values, (N_det,N_states) ]
+
+  BEGIN_DOC
+  ! Sparse coefficient matrix if the wave function is expressed in a bilinear form :
+  !  $D_\alpha^\dagger.C.D_\beta$
+  !
+  ! Rows are $\alpha$ determinants and columns are $\beta$.
+  !
+  ! Order refers to psi_det
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer :: k, l
+
+  if(N_det .eq. 1) then
+
+    do l = 1, N_states
+      psi_bitcleft_bilinear_matrix_values(1,l) = 1.d0
+    enddo
+
+  else
+
+    do l = 1, N_states
+      do k = 1, N_det
+        psi_bitcleft_bilinear_matrix_values(k,l) = psi_l_coef_bi_ortho(k,l)
+      enddo
+    enddo
+
+    PROVIDE psi_bilinear_matrix_order
+    do l = 1, N_states
+      call dset_order(psi_bitcleft_bilinear_matrix_values(1,l), psi_bilinear_matrix_order, N_det)
+    enddo
+
+  endif
+
+END_PROVIDER
+
+! ---
+

src/tc_bi_ortho/psi_r_l_prov.irp.f

@@ -0,0 +1,234 @@
+use bitmasks
+
+BEGIN_PROVIDER [ double precision, psi_l_coef_bi_ortho, (psi_det_size,N_states) ]
+  implicit none
+  BEGIN_DOC
+  ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file
+  ! is empty.
+  END_DOC
+
+  integer                        :: i,k, N_int2
+  logical                        :: exists
+  character*(64)                 :: label
+
+  PROVIDE read_wf N_det mo_label ezfio_filename nproc
+  psi_l_coef_bi_ortho = 0.d0
+  do i=1,min(N_states,N_det)
+    psi_l_coef_bi_ortho(i,i) = 1.d0
+  enddo
+
+  if (mpi_master) then
+    if (read_wf) then
+      call ezfio_has_tc_bi_ortho_psi_l_coef_bi_ortho(exists)
+!      if (exists) then
+!        call ezfio_has_tc_bi_ortho_mo_label(exists)
+!        if (exists) then
+!          call ezfio_get_tc_bi_ortho_mo_label(label)
+!          exists = (label == mo_label)
+!        endif
+!      endif
+
+      if (exists) then
+
+        double precision, allocatable  :: psi_l_coef_bi_ortho_read(:,:)
+        allocate (psi_l_coef_bi_ortho_read(N_det,N_states))
+        print *,  'Read psi_l_coef_bi_ortho', N_det, N_states
+        call ezfio_get_tc_bi_ortho_psi_l_coef_bi_ortho(psi_l_coef_bi_ortho_read)
+        do k=1,N_states
+          do i=1,N_det
+            psi_l_coef_bi_ortho(i,k) = psi_l_coef_bi_ortho_read(i,k)
+          enddo
+        enddo
+        deallocate(psi_l_coef_bi_ortho_read)
+
+      else
+
+        print*, 'psi_l_coef_bi_ortho are psi_coef'
+        do k=1,N_states
+          do i=1,N_det
+            psi_l_coef_bi_ortho(i,k) = psi_coef(i,k)
+          enddo
+        enddo
+
+      endif
+    endif
+  endif
+  IRP_IF MPI_DEBUG
+    print *,  irp_here, mpi_rank
+    call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+  IRP_ENDIF
+  IRP_IF MPI
+    include 'mpif.h'
+    integer                        :: ierr
+    call     MPI_BCAST( psi_l_coef_bi_ortho, size(psi_l_coef_bi_ortho), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+    if (ierr /= MPI_SUCCESS) then
+      stop 'Unable to read psi_l_coef_bi_ortho with MPI'
+    endif
+  IRP_ENDIF
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ double precision, psi_r_coef_bi_ortho, (psi_det_size,N_states) ]
+  implicit none
+  BEGIN_DOC
+  ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file
+  ! is empty.
+  END_DOC
+
+  integer                        :: i,k, N_int2
+  logical                        :: exists
+  character*(64)                 :: label
+
+  PROVIDE read_wf N_det mo_label ezfio_filename nproc
+  psi_r_coef_bi_ortho = 0.d0
+  do i=1,min(N_states,N_det)
+    psi_r_coef_bi_ortho(i,i) = 1.d0
+  enddo
+
+  if (mpi_master) then
+    if (read_wf) then
+      call ezfio_has_tc_bi_ortho_psi_r_coef_bi_ortho(exists)
+!      if (exists) then
+!        call ezfio_has_tc_bi_ortho_mo_label(exists)
+!        if (exists) then
+!          call ezfio_get_tc_bi_ortho_mo_label(label)
+!          exists = (label == mo_label)
+!        endif
+!      endif
+
+      if (exists) then
+
+        double precision, allocatable  :: psi_r_coef_bi_ortho_read(:,:)
+        allocate (psi_r_coef_bi_ortho_read(N_det,N_states))
+        print *,  'Read psi_r_coef_bi_ortho', N_det, N_states
+        call ezfio_get_tc_bi_ortho_psi_r_coef_bi_ortho(psi_r_coef_bi_ortho_read)
+        do k=1,N_states
+          do i=1,N_det
+            psi_r_coef_bi_ortho(i,k) = psi_r_coef_bi_ortho_read(i,k)
+          enddo
+        enddo
+        deallocate(psi_r_coef_bi_ortho_read)
+
+      else
+
+        print*, 'psi_r_coef_bi_ortho are psi_coef'
+        do k=1,N_states
+          do i=1,N_det
+            psi_r_coef_bi_ortho(i,k) = psi_coef(i,k)
+          enddo
+        enddo
+
+      endif
+    endif
+  endif
+  IRP_IF MPI_DEBUG
+    print *,  irp_here, mpi_rank
+    call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+  IRP_ENDIF
+  IRP_IF MPI
+    include 'mpif.h'
+    integer                        :: ierr
+    call     MPI_BCAST( psi_r_coef_bi_ortho, size(psi_r_coef_bi_ortho), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+    if (ierr /= MPI_SUCCESS) then
+      stop 'Unable to read psi_r_coef_bi_ortho with MPI'
+    endif
+  IRP_ENDIF
+END_PROVIDER
+
+
+subroutine save_tc_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psilcoef,psircoef)
+  implicit none
+  BEGIN_DOC
+  !  Save the wave function into the |EZFIO| file
+  END_DOC
+  use bitmasks
+  include 'constants.include.F'
+  integer, intent(in)            :: ndet,nstates,dim_psicoef
+  integer(bit_kind), intent(in)  :: psidet(N_int,2,ndet)
+  double precision, intent(in)   :: psilcoef(dim_psicoef,nstates)
+  double precision, intent(in)   :: psircoef(dim_psicoef,nstates)
+  integer*8, allocatable         :: psi_det_save(:,:,:)
+  double precision, allocatable  :: psil_coef_save(:,:)
+  double precision, allocatable  :: psir_coef_save(:,:)
+
+  double precision               :: accu_norm
+  integer                        :: i,j,k, ndet_qp_edit
+
+  if (mpi_master) then
+    ndet_qp_edit = min(ndet,N_det_qp_edit)
+
+    call ezfio_set_determinants_N_int(N_int)
+    call ezfio_set_determinants_bit_kind(bit_kind)
+    call ezfio_set_determinants_N_det(ndet)
+    call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit)
+    call ezfio_set_determinants_n_states(nstates)
+    call ezfio_set_determinants_mo_label(mo_label)
+
+    allocate (psi_det_save(N_int,2,ndet))
+    do i=1,ndet
+      do j=1,2
+        do k=1,N_int
+          psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8)
+        enddo
+      enddo
+    enddo
+    call ezfio_set_determinants_psi_det(psi_det_save)
+    call ezfio_set_determinants_psi_det_qp_edit(psi_det_save)
+    deallocate (psi_det_save)
+
+    allocate (psil_coef_save(ndet,nstates),psir_coef_save(ndet,nstates))
+    do k=1,nstates
+      do i=1,ndet
+        psil_coef_save(i,k) = psilcoef(i,k)
+        psir_coef_save(i,k) = psircoef(i,k)
+      enddo
+    enddo
+
+    call ezfio_set_tc_bi_ortho_psi_l_coef_bi_ortho(psil_coef_save)
+    call ezfio_set_tc_bi_ortho_psi_r_coef_bi_ortho(psir_coef_save)
+    deallocate (psil_coef_save,psir_coef_save)
+
+!    allocate (psi_coef_save(ndet_qp_edit,nstates))
+!    do k=1,nstates
+!      do i=1,ndet_qp_edit
+!        psi_coef_save(i,k) = psicoef(i,k)
+!      enddo
+!    enddo
+!
+!    call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save)
+!    deallocate (psi_coef_save)
+
+    call write_int(6,ndet,'Saved determinantsi and psi_r/psi_l coef')
+  endif
+end
+
+subroutine save_tc_bi_ortho_wavefunction
+ implicit none
+ call save_tc_wavefunction_general(N_det,N_states,psi_det,size(psi_l_coef_bi_ortho, 1),psi_l_coef_bi_ortho,psi_r_coef_bi_ortho)
+ call routine_save_right_bi_ortho
+end
+
+subroutine routine_save_right_bi_ortho
+ implicit none
+ double precision, allocatable :: coef_tmp(:,:)
+ integer :: i
+ allocate(coef_tmp(N_det, N_states))
+ do i = 1, N_det
+  coef_tmp(i,1:N_states) = psi_r_coef_bi_ortho(i,1:N_states)
+ enddo
+ call save_wavefunction_general_unormalized(N_det,N_states,psi_det,size(coef_tmp,1),coef_tmp(1,1))
+end                     
+
+subroutine routine_save_left_right_bi_ortho
+ implicit none
+ double precision, allocatable :: coef_tmp(:,:)
+ integer :: i,n_states_tmp
+ n_states_tmp = 2
+ allocate(coef_tmp(N_det, n_states_tmp))
+ do i = 1, N_det
+  coef_tmp(i,1) = psi_r_coef_bi_ortho(i,1)
+  coef_tmp(i,2) = psi_l_coef_bi_ortho(i,1)
+ enddo
+ call save_wavefunction_general_unormalized(N_det,n_states_tmp,psi_det,size(coef_tmp,1),coef_tmp(1,1))
+end
+

src/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f

@@ -0,0 +1,76 @@
+program save_bitcpsileft_for_qmcchem
+
+  integer          :: iunit
+  logical          :: exists
+  double precision :: e_ref
+
+  print *, ' '
+  print *, ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+  print *, '  call save_for_qmcchem before  '
+  print *, ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+  print *, ' '
+
+  call write_lr_spindeterminants()
+
+  e_ref = 0.d0
+  iunit = 13
+  open(unit=iunit, file=trim(ezfio_filename)//'/simulation/e_ref', action='write')
+
+    call ezfio_has_fci_energy_pt2(exists)
+    if(.not.exists) then
+
+      call ezfio_has_fci_energy(exists)
+      if(.not.exists) then
+
+        call ezfio_has_cisd_energy(exists)
+        if(.not.exists) then
+
+          call ezfio_has_tc_scf_bitc_energy(exists)
+          if(exists) then
+            call ezfio_get_tc_scf_bitc_energy(e_ref)
+          endif
+
+        else
+          call ezfio_get_cisd_energy(e_ref)
+        endif
+
+      else
+        call ezfio_get_fci_energy(e_ref)
+      endif
+
+      else
+        call ezfio_get_fci_energy_pt2(e_ref)
+    endif
+
+    write(iunit,*) e_ref
+
+  close(iunit)
+
+end
+
+! --
+
+subroutine write_lr_spindeterminants()
+
+  use bitmasks
+
+  implicit none
+
+  integer                       :: k, l
+  double precision, allocatable :: buffer(:,:)
+
+  PROVIDE psi_bitcleft_bilinear_matrix_values
+
+  allocate(buffer(N_det,N_states))
+  do l = 1, N_states
+    do k = 1, N_det
+      buffer(k,l) = psi_bitcleft_bilinear_matrix_values(k,l)
+    enddo
+  enddo
+  call ezfio_set_spindeterminants_psi_left_coef_matrix_values(buffer)
+  deallocate(buffer)
+
+end subroutine write_lr_spindeterminants
+
+! ---
+

src/tc_bi_ortho/save_lr_bi_ortho_states.irp.f

@@ -0,0 +1,15 @@
+program tc_bi_ortho
+  implicit none
+  BEGIN_DOC
+! TODO : Put the documentation of the program here
+  END_DOC
+  print *, 'Hello world'
+  my_grid_becke = .True.
+  my_n_pt_r_grid = 30
+  my_n_pt_a_grid = 50
+  read_wf = .True.
+  touch read_wf
+  touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+  call routine_save_left_right_bi_ortho
+! call test
+end

src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f

@@ -0,0 +1,35 @@
+ program tc_natorb_bi_ortho
+   implicit none
+   BEGIN_DOC
+ ! TODO : Put the documentation of the program here
+   END_DOC
+   print *, 'Hello world'
+   my_grid_becke = .True.
+   my_n_pt_r_grid = 30
+   my_n_pt_a_grid = 50
+   read_wf = .True.
+   touch read_wf
+   touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+   call print_energy_and_mos
+   call save_tc_natorb
+!   call minimize_tc_orb_angles
+ end
+ 
+ subroutine save_tc_natorb 
+  implicit none
+  print*,'Saving the natorbs '
+  provide natorb_tc_leigvec_ao natorb_tc_reigvec_ao
+  call ezfio_set_bi_ortho_mos_mo_l_coef(natorb_tc_leigvec_ao)
+  call ezfio_set_bi_ortho_mos_mo_r_coef(natorb_tc_reigvec_ao)
+  call save_ref_determinant_nstates_1
+  call ezfio_set_determinants_read_wf(.False.)
+ end
+ 
+ subroutine save_ref_determinant_nstates_1
+   implicit none
+   use bitmasks
+   double precision               :: buffer(1,N_states)
+   buffer = 0.d0
+   buffer(1,1) = 1.d0
+   call save_wavefunction_general(1,1,ref_bitmask,1,buffer)
+ end

src/tc_bi_ortho/select_dets_bi_ortho.irp.f

@@ -0,0 +1,61 @@
+program tc_bi_ortho
+  implicit none
+  BEGIN_DOC
+! TODO : Put the documentation of the program here
+  END_DOC
+  print *, 'Hello world'
+  my_grid_becke = .True.
+  my_n_pt_r_grid = 30
+  my_n_pt_a_grid = 50
+  read_wf = .True.
+  touch read_wf
+  touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+
+  !!!!!!!!!!!!!!! WARNING NO 3-BODY
+  !!!!!!!!!!!!!!! WARNING NO 3-BODY
+  three_body_h_tc = .False.
+  touch three_body_h_tc 
+  !!!!!!!!!!!!!!! WARNING NO 3-BODY
+  !!!!!!!!!!!!!!! WARNING NO 3-BODY
+
+  call routine_test
+! call test
+end
+
+subroutine routine_test
+ implicit none
+ use bitmasks ! you need to include the bitmasks_module.f90 features
+ integer :: i,n_good,degree
+ integer(bit_kind), allocatable :: dets(:,:,:)
+ integer, allocatable :: iorder(:)
+ double precision, allocatable :: coef(:),coef_new(:,:)
+ double precision :: thr
+ allocate(coef(N_det), iorder(N_det))
+ do i = 1, N_det
+  iorder(i) = i
+  call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
+  if(degree==1)then
+   coef(i) = -0.5d0
+  else
+   coef(i) = -dabs(coef_pt1_bi_ortho(i))
+  endif
+ enddo
+ call dsort(coef,iorder,N_det)
+ !thr = save_threshold
+ thr = 1d-15
+ n_good = 0
+ do i = 1, N_det
+  if(dabs(coef(i)).gt.thr)then
+   n_good += 1
+  endif
+ enddo
+ print*,'n_good = ',n_good
+ allocate(dets(N_int,2,n_good),coef_new(n_good,n_states))
+ do i = 1, n_good
+  dets(:,:,i) = psi_det(:,:,iorder(i))
+  coef_new(i,:) = psi_coef(iorder(i),:)
+ enddo
+ call save_wavefunction_general(n_good,n_states,dets,n_good,coef_new)
+
+
+end

src/tc_bi_ortho/slater_tc.irp.f

@@ -0,0 +1,376 @@
+
+! ---
+
+subroutine htilde_mu_mat_bi_ortho_tot(key_j, key_i, Nint, htot)
+
+  BEGIN_DOC
+  ! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
+  !!
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer, intent(in)           :: Nint
+  integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
+  double precision, intent(out) :: htot
+  double precision              :: hmono, htwoe, hthree
+  integer :: degree
+
+  call get_excitation_degree(key_j, key_i, degree, Nint)
+  if(degree.gt.2)then
+    htot = 0.d0
+  else
+    call htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
+  endif
+
+end subroutine htilde_mu_mat_bi_ortho_tot
+
+! --
+
+subroutine htilde_mu_mat_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
+
+  BEGIN_DOC
+  !
+  ! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
+  !!
+  ! Returns the detail of the matrix element in terms of single, two and three electron contribution. 
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  !
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in) :: Nint
+  integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
+  double precision, intent(out) :: hmono, htwoe, hthree, htot
+  integer                       :: degree 
+
+  hmono  = 0.d0
+  htwoe  = 0.d0
+  htot   = 0.d0
+  hthree = 0.D0
+
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+  if(degree.gt.2) return
+
+  if(degree == 0)then
+    call diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot)
+  else if (degree == 1)then
+    call single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
+  else if(degree == 2)then
+    call double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
+  endif
+
+  if(three_body_h_tc) then
+    if(degree == 2) then
+      if(.not.double_normal_ord) then
+        call double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
+      endif
+    else if(degree == 1) then
+      call single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
+    else if(degree == 0) then
+      call diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
+    endif
+  endif
+
+  htot = hmono + htwoe + hthree
+  if(degree==0) then
+    htot += nuclear_repulsion
+  endif
+ 
+end
+
+! ---
+
+subroutine diag_htilde_mu_mat_bi_ortho(Nint, key_i, hmono, htwoe, htot)
+
+  BEGIN_DOC
+  !  diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS 
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in)  :: Nint
+  integer(bit_kind), intent(in)  :: key_i(Nint,2)
+  double precision, intent(out)  :: hmono,htwoe,htot
+  integer                        :: occ(Nint*bit_kind_size,2)
+  integer                        :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
+  double precision               :: get_mo_two_e_integral_tc_int
+  integer(bit_kind)              :: key_i_core(Nint,2)
+
+!  PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e
+!
+!  PROVIDE mo_integrals_erf_map core_energy nuclear_repulsion core_bitmask
+!  PROVIDE core_fock_operator
+!
+!  PROVIDE j1b_gauss
+
+!  if(core_tc_op)then
+!   print*,'core_tc_op not already taken into account for bi ortho'
+!   print*,'stopping ...'
+!   stop
+!   do i = 1, Nint
+!    key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
+!    key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
+!   enddo
+!   call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
+!   hmono = core_energy - nuclear_repulsion
+!  else
+   call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+   hmono = 0.d0
+!  endif
+  htwoe= 0.d0
+  htot = 0.d0
+
+  do ispin = 1, 2 
+   do i = 1, Ne(ispin) ! 
+    ii = occ(i,ispin) 
+    hmono += mo_bi_ortho_tc_one_e(ii,ii)
+
+!    if(j1b_gauss .eq. 1) then
+!      print*,'j1b not implemented for bi ortho TC'
+!      print*,'stopping  ....'
+!      stop
+!      !hmono += mo_j1b_gauss_hermI  (ii,ii) &
+!      !       + mo_j1b_gauss_hermII (ii,ii) &
+!      !       + mo_j1b_gauss_nonherm(ii,ii)
+!    endif
+
+!    if(core_tc_op)then
+!   print*,'core_tc_op not already taken into account for bi ortho'
+!   print*,'stopping ...'
+!   stop
+!     hmono += core_fock_operator(ii,ii) ! add the usual Coulomb - Exchange from the core 
+!    endif
+   enddo
+  enddo
+
+
+   ! alpha/beta two-body
+   ispin = 1
+   jspin = 2 
+   do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1))
+    ii = occ(i,ispin) 
+    do j = 1, Ne(jspin) ! electron 2 
+     jj = occ(j,jspin) 
+     htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii) 
+    enddo
+   enddo
+ 
+   ! alpha/alpha two-body
+   do i = 1, Ne(ispin)
+    ii = occ(i,ispin) 
+    do j = i+1, Ne(ispin)
+     jj = occ(j,ispin) 
+     htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
+    enddo
+   enddo
+ 
+   ! beta/beta two-body
+   do i = 1, Ne(jspin)
+    ii = occ(i,jspin) 
+    do j = i+1, Ne(jspin)
+     jj = occ(j,jspin) 
+     htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
+    enddo
+   enddo
+  htot = hmono + htwoe 
+
+end
+
+
+
+subroutine double_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
+
+  BEGIN_DOC
+  ! <key_j | H_tilde | key_i> for double excitation  ONLY FOR ONE- AND TWO-BODY TERMS 
+  !!
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in) :: Nint 
+  integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
+  double precision, intent(out) :: hmono, htwoe, htot
+  integer                       :: occ(Nint*bit_kind_size,2)
+  integer                       :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
+  integer                       :: degree,exc(0:2,2,2)
+  integer                       :: h1, p1, h2, p2, s1, s2
+  integer                       :: other_spin(2)
+  integer(bit_kind)             :: key_i_core(Nint,2)
+  double precision              :: get_mo_two_e_integral_tc_int,phase
+
+!  PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+
+  hmono = 0.d0
+  htwoe= 0.d0
+  htot = 0.d0
+
+  if(degree.ne.2)then
+   return
+  endif
+
+!  if(core_tc_op)then
+!   print*,'core_tc_op not already taken into account for bi ortho'
+!   print*,'stopping ...'
+!   stop
+!   do i = 1, Nint
+!    key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
+!    key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
+!   enddo
+!   call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
+!  else
+   call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+!  endif
+  call get_double_excitation(key_i, key_j, exc, phase, Nint)
+  call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
+
+  if(s1.ne.s2)then
+   ! opposite spin two-body 
+!   key_j, key_i
+    htwoe  = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) 
+    if(double_normal_ord.and.+Ne(1).gt.2)then
+     htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ???
+    endif
+  else
+   ! same spin two-body 
+   ! direct terms 
+   htwoe  = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)  
+   ! exchange terms 
+   htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1) 
+   if(double_normal_ord.and.+Ne(1).gt.2)then
+    htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ???
+    htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ???
+   endif
+  endif
+  htwoe *= phase
+  htot =  htwoe 
+
+end
+
+
+subroutine single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
+
+  BEGIN_DOC
+  ! <key_j | H_tilde | key_i> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS 
+  !!
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in) :: Nint
+  integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
+  double precision, intent(out) :: hmono, htwoe, htot
+  integer                       :: occ(Nint*bit_kind_size,2)
+  integer                       :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
+  integer                       :: degree,exc(0:2,2,2)
+  integer                       :: h1, p1, h2, p2, s1, s2
+  double precision              :: get_mo_two_e_integral_tc_int, phase
+  double precision              :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13
+  integer                       :: other_spin(2)
+  integer(bit_kind)             :: key_j_core(Nint,2), key_i_core(Nint,2)
+
+!  PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e
+!
+!  PROVIDE core_bitmask core_fock_operator mo_integrals_erf_map
+
+!  PROVIDE j1b_gauss
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  hmono = 0.d0
+  htwoe= 0.d0
+  htot = 0.d0
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+  if(degree.ne.1)then
+   return
+  endif
+!  if(core_tc_op)then
+!   print*,'core_tc_op not already taken into account for bi ortho'
+!   print*,'stopping ...'
+!   stop
+!   do i = 1, Nint
+!    key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
+!    key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
+!    key_j_core(i,1) = xor(key_j(i,1),core_bitmask(i,1))
+!    key_j_core(i,2) = xor(key_j(i,2),core_bitmask(i,2))
+!   enddo
+!   call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
+!  else
+   call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+!  endif
+
+  call get_single_excitation(key_i, key_j, exc, phase, Nint)
+  call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
+!  if(h1==14.and.p1==2)then
+!   print*,'h1,p1 old = ',h1,p1
+!  endif
+
+  hmono = mo_bi_ortho_tc_one_e(p1,h1) * phase
+
+!  if(j1b_gauss .eq. 1) then
+!     print*,'j1b not implemented for bi ortho TC'
+!     print*,'stopping  ....'
+!     stop
+!    !hmono += ( mo_j1b_gauss_hermI  (h1,p1) &
+!    !         + mo_j1b_gauss_hermII (h1,p1) &
+!    !         + mo_j1b_gauss_nonherm(h1,p1) ) * phase
+!  endif
+
+!  if(core_tc_op)then
+!   print*,'core_tc_op not already taken into account for bi ortho'
+!   print*,'stopping ...'
+!   stop
+!   hmono += phase * core_fock_operator(h1,p1)
+!  endif
+  
+   ! alpha/beta two-body 
+   ispin = other_spin(s1)
+   if(s1==1)then
+    ! single alpha 
+    do i = 1, Ne(ispin) ! electron 2 
+     ii = occ(i,ispin) 
+     htwoe += mo_bi_ortho_tc_two_e(ii,p1,ii,h1) 
+    enddo
+   else
+    ! single beta 
+    do i = 1, Ne(ispin) ! electron 1 
+     ii = occ(i,ispin) 
+     htwoe += mo_bi_ortho_tc_two_e(p1,ii,h1,ii) 
+    enddo
+   endif
+!   ! same spin two-body 
+   do i = 1, Ne(s1)
+    ii = occ(i,s1) 
+    ! (h1p1|ii ii) - (h1 ii| p1 ii)
+    htwoe += mo_bi_ortho_tc_two_e(ii,p1,ii,h1) - mo_bi_ortho_tc_two_e(p1,ii,ii,h1) 
+   enddo
+   
+  htwoe  *= phase
+  htot = hmono + htwoe 
+
+end
+
+

src/tc_bi_ortho/slater_tc_3e.irp.f

@@ -0,0 +1,288 @@
+subroutine provide_all_three_ints_bi_ortho
+ implicit none
+ BEGIN_DOC
+! routine that provides all necessary three-electron integrals 
+ END_DOC
+ if(three_body_h_tc)then
+  PROVIDE three_e_3_idx_direct_bi_ort three_e_3_idx_cycle_1_bi_ort three_e_3_idx_cycle_2_bi_ort
+  PROVIDE three_e_3_idx_exch23_bi_ort three_e_3_idx_exch13_bi_ort three_e_3_idx_exch12_bi_ort
+  PROVIDE three_e_4_idx_direct_bi_ort three_e_4_idx_cycle_1_bi_ort three_e_4_idx_cycle_2_bi_ort
+  PROVIDE three_e_4_idx_exch23_bi_ort three_e_4_idx_exch13_bi_ort three_e_4_idx_exch12_bi_ort
+ endif
+if(.not.double_normal_ord)then
+  PROVIDE three_e_5_idx_direct_bi_ort three_e_5_idx_cycle_1_bi_ort three_e_5_idx_cycle_2_bi_ort
+  PROVIDE three_e_5_idx_exch23_bi_ort three_e_5_idx_exch13_bi_ort three_e_5_idx_exch12_bi_ort
+else
+ PROVIDE normal_two_body_bi_orth
+endif
+end
+
+subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
+
+  BEGIN_DOC
+  !  diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in) :: Nint
+  integer(bit_kind), intent(in) :: key_i(Nint,2)
+  double precision, intent(out) :: hthree
+  integer                       :: occ(Nint*bit_kind_size,2)
+  integer                       :: Ne(2),i,j,ii,jj,ispin,jspin,m,mm
+  integer(bit_kind)             :: key_i_core(Nint,2)
+  double precision              :: direct_int, exchange_int
+  double precision              :: sym_3_e_int_from_6_idx_tensor
+  double precision              :: three_e_diag_parrallel_spin
+
+  if(core_tc_op)then
+   do i = 1, Nint
+    key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
+    key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
+   enddo
+   call bitstring_to_list_ab(key_i_core,occ,Ne,Nint)
+  else
+   call bitstring_to_list_ab(key_i,occ,Ne,Nint)
+  endif
+  hthree = 0.d0
+
+  if(Ne(1)+Ne(2).ge.3)then
+!!  ! alpha/alpha/beta three-body
+   do i = 1, Ne(1)
+    ii = occ(i,1) 
+    do j = i+1, Ne(1)
+     jj = occ(j,1) 
+     do m = 1, Ne(2)
+      mm = occ(m,2) 
+!      direct_int = three_body_ints_bi_ort(mm,jj,ii,mm,jj,ii) USES THE 6-IDX TENSOR 
+!      exchange_int = three_body_ints_bi_ort(mm,jj,ii,mm,ii,jj) USES THE 6-IDX TENSOR 
+      direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii) ! USES 3-IDX TENSOR 
+      exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii) ! USES 3-IDX TENSOR 
+      hthree += direct_int - exchange_int
+     enddo
+    enddo
+   enddo
+  
+   ! beta/beta/alpha three-body
+   do i = 1, Ne(2)
+    ii = occ(i,2) 
+    do j = i+1, Ne(2)
+     jj = occ(j,2) 
+     do m = 1, Ne(1)
+      mm = occ(m,1) 
+      direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii) 
+      exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii)
+      hthree += direct_int - exchange_int
+     enddo
+    enddo
+   enddo
+
+   ! alpha/alpha/alpha three-body
+   do i = 1, Ne(1)
+    ii = occ(i,1) ! 1
+    do j = i+1, Ne(1)
+     jj = occ(j,1) ! 2 
+     do m = j+1, Ne(1)
+      mm = occ(m,1) ! 3 
+!      ref =  sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) USES THE 6 IDX TENSOR 
+      hthree += three_e_diag_parrallel_spin(mm,jj,ii) ! USES ONLY 3-IDX TENSORS
+     enddo
+    enddo
+   enddo
+
+   ! beta/beta/beta three-body
+   do i = 1, Ne(2)
+    ii = occ(i,2) ! 1
+    do j = i+1, Ne(2)
+     jj = occ(j,2) ! 2
+     do m = j+1, Ne(2)
+      mm = occ(m,2) ! 3
+!      ref =  sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) USES THE 6 IDX TENSOR 
+      hthree += three_e_diag_parrallel_spin(mm,jj,ii) ! USES ONLY 3-IDX TENSORS
+     enddo
+    enddo
+   enddo
+  endif
+
+end
+
+
+subroutine single_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
+
+  BEGIN_DOC
+  ! <key_j | H_tilde | key_i> for single excitation ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
+  !!
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in) :: Nint
+  integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
+  double precision, intent(out) :: hthree
+  integer                       :: occ(Nint*bit_kind_size,2)
+  integer                       :: Ne(2),i,j,ii,jj,ispin,jspin,k,kk
+  integer                       :: degree,exc(0:2,2,2)
+  integer                       :: h1, p1, h2, p2, s1, s2
+  double precision              :: direct_int,phase,exchange_int,three_e_single_parrallel_spin 
+  double precision              :: sym_3_e_int_from_6_idx_tensor
+  integer                       :: other_spin(2)
+  integer(bit_kind)             :: key_j_core(Nint,2),key_i_core(Nint,2)
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+
+  hthree = 0.d0
+  call get_excitation_degree(key_i,key_j,degree,Nint)
+  if(degree.ne.1)then
+   return
+  endif
+  if(core_tc_op)then
+   do i = 1, Nint
+    key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
+    key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
+    key_j_core(i,1) = xor(key_j(i,1),core_bitmask(i,1))
+    key_j_core(i,2) = xor(key_j(i,2),core_bitmask(i,2))
+   enddo
+   call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
+  else
+   call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+  endif
+
+  call get_single_excitation(key_i, key_j, exc, phase, Nint)
+  call decode_exc(exc, 1, h1, p1, h2, p2, s1, s2)
+
+   ! alpha/alpha/beta three-body
+!   print*,'IN SLAT RULES'
+   if(Ne(1)+Ne(2).ge.3)then
+     ! hole of spin s1 :: contribution from purely other spin 
+     ispin = other_spin(s1) ! ispin is the other spin than s1
+     do i = 1, Ne(ispin)  ! i is the orbitals of the other spin than s1  
+      ii = occ(i,ispin)  
+      do j = i+1, Ne(ispin) ! j has the same spin than s1 
+       jj = occ(j,ispin) 
+       !   is == ispin  in :::   s1 is is  s1 is is      s1 is is s1 is is
+       !                       < h1 j  i | p1 j  i > - < h1 j  i | p1 i j >
+       !                                                   
+       direct_int   = three_e_4_idx_direct_bi_ort(jj,ii,p1,h1)  
+       exchange_int = three_e_4_idx_exch23_bi_ort(jj,ii,p1,h1) 
+       hthree += direct_int - exchange_int
+      enddo
+     enddo
+  
+     ! hole of spin s1 :: contribution from mixed other spin / same spin
+     do i = 1, Ne(ispin) ! other spin 
+      ii = occ(i,ispin)  ! other spin 
+      do j = 1, Ne(s1)   ! same spin 
+       jj = occ(j,s1)    ! same spin 
+       direct_int   = three_e_4_idx_direct_bi_ort(jj,ii,p1,h1)
+       exchange_int = three_e_4_idx_exch13_bi_ort(jj,ii,p1,h1)
+       !              < h1 j  i | p1 j i > - < h1 j i | j p1 i >
+       hthree += direct_int - exchange_int
+      enddo
+     enddo
+!
+     ! hole of spin s1 :: PURE SAME SPIN CONTRIBUTIONS !!!
+     do i = 1, Ne(s1)
+      ii = occ(i,s1)
+      do j = i+1, Ne(s1)
+       jj = occ(j,s1)
+!       ref = sym_3_e_int_from_6_idx_tensor(jj,ii,p1,jj,ii,h1) 
+       hthree += three_e_single_parrallel_spin(jj,ii,p1,h1) ! USES THE 4-IDX TENSOR 
+      enddo
+     enddo
+   endif
+  hthree  *= phase
+
+end
+
+! ---
+
+subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
+
+  BEGIN_DOC
+  ! <key_j | H_tilde | key_i> for double excitation ONLY FOR THREE-BODY TERMS  WITH BI ORTHONORMAL ORBITALS
+  !!
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in) :: Nint
+  integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
+  double precision, intent(out) :: hthree
+  integer                       :: occ(Nint*bit_kind_size,2)
+  integer                       :: Ne(2),i,j,ii,jj,ispin,jspin,m,mm
+  integer                       :: degree,exc(0:2,2,2)
+  integer                       :: h1, p1, h2, p2, s1, s2
+  double precision              :: phase
+  integer                       :: other_spin(2)
+  integer(bit_kind)             :: key_i_core(Nint,2)
+  double precision              :: direct_int,exchange_int,sym_3_e_int_from_6_idx_tensor
+  double precision              :: three_e_double_parrallel_spin
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+
+  hthree = 0.d0
+
+  if(degree.ne.2)then
+   return
+  endif
+
+  if(core_tc_op) then
+   do i = 1, Nint
+    key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1))
+    key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2))
+   enddo
+   call bitstring_to_list_ab(key_i_core, occ, Ne, Nint)
+  else
+   call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+  endif
+  call get_double_excitation(key_i, key_j, exc, phase, Nint)
+  call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
+
+    
+    if(Ne(1)+Ne(2).ge.3)then
+     if(s1==s2)then ! same spin excitation 
+      ispin = other_spin(s1)
+      do m = 1, Ne(ispin) ! direct(other_spin) - exchange(s1)
+       mm = occ(m,ispin)
+       direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) 
+       exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1)
+       hthree += direct_int - exchange_int
+      enddo
+      do m = 1, Ne(s1) ! pure contribution from s1 
+       mm = occ(m,s1)
+       hthree += three_e_double_parrallel_spin(mm,p2,h2,p1,h1)
+      enddo 
+     else ! different spin excitation 
+       do m = 1, Ne(s1)
+        mm = occ(m,s1) ! 
+        direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) 
+        exchange_int = three_e_5_idx_exch13_bi_ort(mm,p2,h2,p1,h1)
+        hthree += direct_int - exchange_int
+       enddo
+       do m = 1, Ne(s2)
+        mm = occ(m,s2) ! 
+        direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
+        exchange_int = three_e_5_idx_exch23_bi_ort(mm,p2,h2,p1,h1)
+        hthree += direct_int - exchange_int
+       enddo
+     endif
+    endif
+  hthree  *= phase
+ end
+
+! ---
+

src/tc_bi_ortho/slater_tc_opt.irp.f

@@ -0,0 +1,105 @@
+subroutine htilde_mu_mat_opt_bi_ortho_tot(key_j, key_i, Nint, htot)
+ implicit none
+  BEGIN_DOC
+  !
+  ! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
+  !!
+  ! Returns the total matrix element 
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  !
+  END_DOC
+
+  use bitmasks
+ integer,           intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
+ double precision, intent(out) :: htot
+ double precision :: hmono, htwoe, hthree
+ call htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
+end
+subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
+  BEGIN_DOC
+  !
+  ! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
+  !!
+  ! Returns the detail of the matrix element in terms of single, two and three electron contribution. 
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  !
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in) :: Nint
+  integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
+  double precision, intent(out) :: hmono, htwoe, hthree, htot
+  integer                       :: degree 
+
+  hmono  = 0.d0
+  htwoe  = 0.d0
+  htot   = 0.d0
+  hthree = 0.D0
+
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+  if(degree.gt.2) return
+
+  if(degree == 0)then
+    call diag_htilde_mu_mat_fock_bi_ortho  (Nint, key_i, hmono, htwoe, hthree, htot)
+  else if (degree == 1)then
+    call single_htilde_mu_mat_fock_bi_ortho(Nint,key_j, key_i , hmono, htwoe, hthree, htot)
+  else if(degree == 2)then
+    call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
+  endif
+
+  if(degree==0) then
+    htot += nuclear_repulsion
+  endif
+ 
+end
+
+! ---
+
+subroutine htilde_mu_mat_opt_bi_ortho_no_3e(key_j, key_i, Nint, htot)
+
+  BEGIN_DOC
+  !
+  ! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
+  !!
+  ! Returns the detail of the matrix element WITHOUT ANY CONTRIBUTION FROM THE THREE ELECTRON TERMS 
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  !
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in) :: Nint
+  integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
+  double precision, intent(out) :: htot
+  integer                       :: degree 
+
+  htot   = 0.d0
+
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+  if(degree.gt.2) return
+
+  if(degree == 0)then
+    call diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_i,htot)
+  else if (degree == 1)then
+    call single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint,key_j, key_i , htot)
+  else if(degree == 2)then
+    call double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
+  endif
+
+  if(degree==0) then
+    htot += nuclear_repulsion
+  endif
+ 
+end
+
+! ---

src/tc_bi_ortho/slater_tc_opt_diag.irp.f

@@ -0,0 +1,473 @@
+ BEGIN_PROVIDER [ double precision, ref_tc_energy_tot]
+&BEGIN_PROVIDER [ double precision, ref_tc_energy_1e]
+&BEGIN_PROVIDER [ double precision, ref_tc_energy_2e]
+&BEGIN_PROVIDER [ double precision, ref_tc_energy_3e]
+ implicit none
+ BEGIN_DOC
+! Various component of the TC energy for the reference "HF" Slater determinant
+ END_DOC 
+ double precision :: hmono, htwoe, htot, hthree
+ call diag_htilde_mu_mat_bi_ortho(N_int,HF_bitmask , hmono, htwoe, htot)
+ ref_tc_energy_1e = hmono
+ ref_tc_energy_2e = htwoe 
+ if(three_body_h_tc)then
+  call diag_htilde_three_body_ints_bi_ort(N_int, HF_bitmask, hthree)
+  ref_tc_energy_3e = hthree
+ else
+  ref_tc_energy_3e = 0.d0
+ endif
+ ref_tc_energy_tot = ref_tc_energy_1e + ref_tc_energy_2e + ref_tc_energy_3e
+ END_PROVIDER 
+
+subroutine diag_htilde_mu_mat_fock_bi_ortho(Nint, det_in, hmono, htwoe, hthree, htot)
+  implicit none
+  BEGIN_DOC
+  ! Computes $\langle i|H|i \rangle$.
+  END_DOC
+  integer,intent(in)             :: Nint
+  integer(bit_kind),intent(in)   :: det_in(Nint,2)
+  double precision, intent(out)  :: hmono,htwoe,htot,hthree
+
+  integer(bit_kind)              :: hole(Nint,2)
+  integer(bit_kind)              :: particle(Nint,2)
+  integer                        :: i, nexc(2), ispin
+  integer                        :: occ_particle(Nint*bit_kind_size,2)
+  integer                        :: occ_hole(Nint*bit_kind_size,2)
+  integer(bit_kind)              :: det_tmp(Nint,2)
+  integer                        :: na, nb
+
+  ASSERT (Nint > 0)
+  ASSERT (sum(popcnt(det_in(:,1))) == elec_alpha_num)
+  ASSERT (sum(popcnt(det_in(:,2))) == elec_beta_num)
+
+
+  nexc(1) = 0
+  nexc(2) = 0
+  do i=1,Nint
+    hole(i,1)     = xor(det_in(i,1),ref_bitmask(i,1))
+    hole(i,2)     = xor(det_in(i,2),ref_bitmask(i,2))
+    particle(i,1) = iand(hole(i,1),det_in(i,1))
+    particle(i,2) = iand(hole(i,2),det_in(i,2))
+    hole(i,1)     = iand(hole(i,1),ref_bitmask(i,1))
+    hole(i,2)     = iand(hole(i,2),ref_bitmask(i,2))
+    nexc(1)       = nexc(1) + popcnt(hole(i,1))
+    nexc(2)       = nexc(2) + popcnt(hole(i,2))
+  enddo
+
+  if (nexc(1)+nexc(2) == 0) then
+    hmono = ref_tc_energy_1e
+    htwoe = ref_tc_energy_2e
+    hthree= ref_tc_energy_3e
+    htot = ref_tc_energy_tot
+    return
+  endif
+
+  !call debug_det(det_in,Nint)
+  integer                        :: tmp(2)
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(particle, occ_particle, tmp, Nint)
+  ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
+  ASSERT (tmp(2) == nexc(2)) ! Number of particle beta 
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(hole, occ_hole, tmp, Nint)
+  ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
+  ASSERT (tmp(2) == nexc(2)) ! Number of holes beta 
+
+  
+  det_tmp = ref_bitmask
+  hmono = ref_tc_energy_1e
+  htwoe = ref_tc_energy_2e 
+  hthree= ref_tc_energy_3e
+  do ispin=1,2
+    na = elec_num_tab(ispin)
+    nb = elec_num_tab(iand(ispin,1)+1)
+    do i=1,nexc(ispin)
+      !DIR$ FORCEINLINE
+      call ac_tc_operator( occ_particle(i,ispin), ispin, det_tmp, hmono,htwoe,hthree, Nint,na,nb)
+      !DIR$ FORCEINLINE
+      call a_tc_operator ( occ_hole    (i,ispin), ispin, det_tmp, hmono,htwoe,hthree, Nint,na,nb)
+    enddo
+  enddo
+  htot = hmono+htwoe+hthree
+end
+
+subroutine ac_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Routine that computes one- and two-body energy corresponding 
+  ! 
+  ! to the ADDITION of an electron in an orbital 'iorb' of spin 'ispin' 
+  ! 
+  ! onto a determinant 'key'.
+  !
+  ! in output, the determinant key is changed by the ADDITION of that electron 
+  !
+  ! and the quantities hmono,htwoe,hthree are INCREMENTED 
+  END_DOC
+  integer, intent(in)            :: iorb, ispin, Nint
+  integer, intent(inout)         :: na, nb
+  integer(bit_kind), intent(inout) :: key(Nint,2)
+  double precision, intent(inout) :: hmono,htwoe,hthree
+
+  integer                        :: occ(Nint*bit_kind_size,2)
+  integer                        :: other_spin
+  integer                        :: k,l,i,jj,mm,j,m
+  double precision ::  direct_int, exchange_int
+  
+
+  if (iorb < 1) then
+    print *,  irp_here, ': iorb < 1'
+    print *,  iorb, mo_num
+    stop -1
+  endif
+  if (iorb > mo_num) then
+    print *,  irp_here, ': iorb > mo_num'
+    print *,  iorb, mo_num
+    stop -1
+  endif
+
+  ASSERT (ispin > 0)
+  ASSERT (ispin < 3)
+  ASSERT (Nint > 0)
+
+  integer                        :: tmp(2)
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(key, occ, tmp, Nint)
+  ASSERT (tmp(1) == elec_alpha_num)
+  ASSERT (tmp(2) == elec_beta_num)
+
+  k = shiftr(iorb-1,bit_kind_shift)+1
+  ASSERT (k >0)
+  l = iorb - shiftl(k-1,bit_kind_shift)-1
+  ASSERT (l >= 0)
+  key(k,ispin) = ibset(key(k,ispin),l)
+  other_spin = iand(ispin,1)+1
+
+  hmono = hmono + mo_bi_ortho_tc_one_e(iorb,iorb)
+
+  ! Same spin
+  do i=1,na
+    htwoe = htwoe + mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
+  enddo
+
+  ! Opposite spin
+  do i=1,nb
+    htwoe = htwoe + mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
+  enddo
+
+  if(three_body_h_tc)then
+   !!!!! 3-e part 
+   !! same-spin/same-spin
+   do j = 1, na
+    jj = occ(j,ispin)
+    do m = j+1, na
+     mm = occ(m,ispin)
+     hthree += three_e_diag_parrallel_spin_prov(mm,jj,iorb)
+    enddo
+   enddo
+   !! same-spin/oposite-spin
+   do j = 1, na
+    jj = occ(j,ispin)
+    do m = 1, nb
+     mm = occ(m,other_spin)
+     direct_int   = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR 
+     exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR 
+     hthree += direct_int - exchange_int
+    enddo
+   enddo
+   !! oposite-spin/opposite-spin
+    do j = 1, nb
+     jj = occ(j,other_spin) 
+     do m = j+1, nb 
+      mm = occ(m,other_spin) 
+      direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR 
+      exchange_int = three_e_3_idx_exch23_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR 
+      hthree += direct_int - exchange_int
+     enddo
+    enddo
+  endif
+
+  na = na+1
+end
+
+subroutine a_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Routine that computes one- and two-body energy corresponding 
+  ! 
+  ! to the REMOVAL of an electron in an orbital 'iorb' of spin 'ispin' 
+  ! 
+  ! onto a determinant 'key'.
+  !
+  ! in output, the determinant key is changed by the REMOVAL of that electron 
+  !
+  ! and the quantities hmono,htwoe,hthree are INCREMENTED 
+  END_DOC
+  integer, intent(in)            :: iorb, ispin, Nint
+  integer, intent(inout)         :: na, nb
+  integer(bit_kind), intent(inout) :: key(Nint,2)
+  double precision, intent(inout) :: hmono,htwoe,hthree
+  
+  double precision  :: direct_int, exchange_int
+  integer                        :: occ(Nint*bit_kind_size,2)
+  integer                        :: other_spin
+  integer                        :: k,l,i,jj,mm,j,m
+  integer                        :: tmp(2)
+
+  ASSERT (iorb > 0)
+  ASSERT (ispin > 0)
+  ASSERT (ispin < 3)
+  ASSERT (Nint > 0)
+
+  k = shiftr(iorb-1,bit_kind_shift)+1
+  ASSERT (k>0)
+  l = iorb - shiftl(k-1,bit_kind_shift)-1
+  key(k,ispin) = ibclr(key(k,ispin),l)
+  other_spin = iand(ispin,1)+1
+
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(key, occ, tmp, Nint)
+  na = na-1
+
+  hmono = hmono - mo_bi_ortho_tc_one_e(iorb,iorb)
+
+  ! Same spin
+  do i=1,na
+    htwoe= htwoe- mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
+  enddo
+
+  ! Opposite spin
+  do i=1,nb
+    htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
+  enddo
+
+  if(three_body_h_tc)then
+   !!!!! 3-e part 
+   !! same-spin/same-spin
+   do j = 1, na
+    jj = occ(j,ispin)
+    do m = j+1, na
+     mm = occ(m,ispin)
+     hthree -= three_e_diag_parrallel_spin_prov(mm,jj,iorb)
+    enddo
+   enddo
+   !! same-spin/oposite-spin
+   do j = 1, na
+    jj = occ(j,ispin)
+    do m = 1, nb
+     mm = occ(m,other_spin)
+     direct_int   = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR 
+     exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR 
+     hthree -= (direct_int - exchange_int)
+    enddo
+   enddo
+   !! oposite-spin/opposite-spin
+    do j = 1, nb
+     jj = occ(j,other_spin) 
+     do m = j+1, nb 
+      mm = occ(m,other_spin) 
+      direct_int   = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR 
+      exchange_int = three_e_3_idx_exch23_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR 
+      hthree -= (direct_int - exchange_int)
+     enddo
+    enddo
+  endif
+
+end
+
+
+subroutine diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, det_in,htot)
+  implicit none
+  BEGIN_DOC
+  ! Computes $\langle i|H|i \rangle$. WITHOUT ANY CONTRIBUTIONS FROM 3E TERMS
+  END_DOC
+  integer,intent(in)             :: Nint
+  integer(bit_kind),intent(in)   :: det_in(Nint,2)
+  double precision, intent(out)  :: htot
+  double precision :: hmono,htwoe
+
+  integer(bit_kind)              :: hole(Nint,2)
+  integer(bit_kind)              :: particle(Nint,2)
+  integer                        :: i, nexc(2), ispin
+  integer                        :: occ_particle(Nint*bit_kind_size,2)
+  integer                        :: occ_hole(Nint*bit_kind_size,2)
+  integer(bit_kind)              :: det_tmp(Nint,2)
+  integer                        :: na, nb
+
+  ASSERT (Nint > 0)
+  ASSERT (sum(popcnt(det_in(:,1))) == elec_alpha_num)
+  ASSERT (sum(popcnt(det_in(:,2))) == elec_beta_num)
+
+
+  nexc(1) = 0
+  nexc(2) = 0
+  do i=1,Nint
+    hole(i,1)     = xor(det_in(i,1),ref_bitmask(i,1))
+    hole(i,2)     = xor(det_in(i,2),ref_bitmask(i,2))
+    particle(i,1) = iand(hole(i,1),det_in(i,1))
+    particle(i,2) = iand(hole(i,2),det_in(i,2))
+    hole(i,1)     = iand(hole(i,1),ref_bitmask(i,1))
+    hole(i,2)     = iand(hole(i,2),ref_bitmask(i,2))
+    nexc(1)       = nexc(1) + popcnt(hole(i,1))
+    nexc(2)       = nexc(2) + popcnt(hole(i,2))
+  enddo
+
+  if (nexc(1)+nexc(2) == 0) then
+    hmono = ref_tc_energy_1e
+    htwoe = ref_tc_energy_2e
+    htot = ref_tc_energy_tot
+    return
+  endif
+
+  !call debug_det(det_in,Nint)
+  integer                        :: tmp(2)
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(particle, occ_particle, tmp, Nint)
+  ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
+  ASSERT (tmp(2) == nexc(2)) ! Number of particle beta 
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(hole, occ_hole, tmp, Nint)
+  ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
+  ASSERT (tmp(2) == nexc(2)) ! Number of holes beta 
+
+  
+  det_tmp = ref_bitmask
+  hmono = ref_tc_energy_1e
+  htwoe = ref_tc_energy_2e 
+  do ispin=1,2
+    na = elec_num_tab(ispin)
+    nb = elec_num_tab(iand(ispin,1)+1)
+    do i=1,nexc(ispin)
+      !DIR$ FORCEINLINE
+      call ac_tc_operator_no_3e( occ_particle(i,ispin), ispin, det_tmp, hmono,htwoe, Nint,na,nb)
+      !DIR$ FORCEINLINE
+      call a_tc_operator_no_3e ( occ_hole    (i,ispin), ispin, det_tmp, hmono,htwoe, Nint,na,nb)
+    enddo
+  enddo
+  htot = hmono+htwoe
+end
+
+subroutine ac_tc_operator_no_3e(iorb,ispin,key,hmono,htwoe,Nint,na,nb)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Routine that computes one- and two-body energy corresponding 
+  ! 
+  ! to the ADDITION of an electron in an orbital 'iorb' of spin 'ispin' 
+  ! 
+  ! onto a determinant 'key'.
+  !
+  ! in output, the determinant key is changed by the ADDITION of that electron 
+  !
+  ! and the quantities hmono,htwoe are INCREMENTED 
+  END_DOC
+  integer, intent(in)            :: iorb, ispin, Nint
+  integer, intent(inout)         :: na, nb
+  integer(bit_kind), intent(inout) :: key(Nint,2)
+  double precision, intent(inout) :: hmono,htwoe
+
+  integer                        :: occ(Nint*bit_kind_size,2)
+  integer                        :: other_spin
+  integer                        :: k,l,i,jj,mm,j,m
+  double precision ::  direct_int, exchange_int
+  
+
+  if (iorb < 1) then
+    print *,  irp_here, ': iorb < 1'
+    print *,  iorb, mo_num
+    stop -1
+  endif
+  if (iorb > mo_num) then
+    print *,  irp_here, ': iorb > mo_num'
+    print *,  iorb, mo_num
+    stop -1
+  endif
+
+  ASSERT (ispin > 0)
+  ASSERT (ispin < 3)
+  ASSERT (Nint > 0)
+
+  integer                        :: tmp(2)
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(key, occ, tmp, Nint)
+  ASSERT (tmp(1) == elec_alpha_num)
+  ASSERT (tmp(2) == elec_beta_num)
+
+  k = shiftr(iorb-1,bit_kind_shift)+1
+  ASSERT (k >0)
+  l = iorb - shiftl(k-1,bit_kind_shift)-1
+  ASSERT (l >= 0)
+  key(k,ispin) = ibset(key(k,ispin),l)
+  other_spin = iand(ispin,1)+1
+
+  hmono = hmono + mo_bi_ortho_tc_one_e(iorb,iorb)
+
+  ! Same spin
+  do i=1,na
+    htwoe = htwoe + mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
+  enddo
+
+  ! Opposite spin
+  do i=1,nb
+    htwoe = htwoe + mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
+  enddo
+
+  na = na+1
+end
+
+subroutine a_tc_operator_no_3e(iorb,ispin,key,hmono,htwoe,Nint,na,nb)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Routine that computes one- and two-body energy corresponding 
+  ! 
+  ! to the REMOVAL of an electron in an orbital 'iorb' of spin 'ispin' 
+  ! 
+  ! onto a determinant 'key'.
+  !
+  ! in output, the determinant key is changed by the REMOVAL of that electron 
+  !
+  ! and the quantities hmono,htwoe are INCREMENTED 
+  END_DOC
+  integer, intent(in)            :: iorb, ispin, Nint
+  integer, intent(inout)         :: na, nb
+  integer(bit_kind), intent(inout) :: key(Nint,2)
+  double precision, intent(inout) :: hmono,htwoe
+  
+  double precision  :: direct_int, exchange_int
+  integer                        :: occ(Nint*bit_kind_size,2)
+  integer                        :: other_spin
+  integer                        :: k,l,i,jj,mm,j,m
+  integer                        :: tmp(2)
+
+  ASSERT (iorb > 0)
+  ASSERT (ispin > 0)
+  ASSERT (ispin < 3)
+  ASSERT (Nint > 0)
+
+  k = shiftr(iorb-1,bit_kind_shift)+1
+  ASSERT (k>0)
+  l = iorb - shiftl(k-1,bit_kind_shift)-1
+  key(k,ispin) = ibclr(key(k,ispin),l)
+  other_spin = iand(ispin,1)+1
+
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(key, occ, tmp, Nint)
+  na = na-1
+
+  hmono = hmono - mo_bi_ortho_tc_one_e(iorb,iorb)
+
+  ! Same spin
+  do i=1,na
+    htwoe= htwoe- mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
+  enddo
+
+  ! Opposite spin
+  do i=1,nb
+    htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
+  enddo
+
+end
+

src/tc_bi_ortho/slater_tc_opt_double.irp.f

@@ -0,0 +1,476 @@
+
+subroutine double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
+
+  BEGIN_DOC
+  ! <key_j | H_tilde | key_i> for double excitation  ONLY FOR ONE- AND TWO-BODY TERMS 
+  !!
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in) :: Nint 
+  integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
+  double precision, intent(out) :: hmono, htwoe, hthree, htot
+  integer                       :: occ(Nint*bit_kind_size,2)
+  integer                       :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
+  integer                       :: degree,exc(0:2,2,2)
+  integer                       :: h1, p1, h2, p2, s1, s2
+  double precision              :: get_mo_two_e_integral_tc_int,phase
+
+
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+
+  hmono  = 0.d0
+  htwoe  = 0.d0
+  hthree = 0.d0
+  htot   = 0.d0
+
+  if(degree.ne.2)then
+   return
+  endif
+  integer :: degree_i,degree_j
+  call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int)
+  call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int)
+  call get_double_excitation(key_i, key_j, exc, phase, Nint)
+  call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
+
+  if(s1.ne.s2)then
+   ! opposite spin two-body 
+    htwoe  = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) 
+    if(three_body_h_tc)then
+     if(.not.double_normal_ord)then
+      if(degree_i>degree_j)then
+       call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
+      else
+       call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
+      endif
+     elseif(double_normal_ord.and.elec_num+elec_num.gt.2)then
+      htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ???
+     endif
+    endif
+  else
+   ! same spin two-body 
+   ! direct terms 
+   htwoe  = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)  
+   ! exchange terms 
+   htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1) 
+   if(three_body_h_tc)then
+    if(.not.double_normal_ord)then
+     if(degree_i>degree_j)then
+      call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
+     else
+      call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
+     endif
+    elseif(double_normal_ord.and.elec_num+elec_num.gt.2)then
+      htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ???
+      htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ???
+    endif
+   endif
+  endif
+  hthree *= phase
+  htwoe  *= phase
+  htot    =  htwoe + hthree
+
+end
+
+
+
+subroutine three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
+ implicit none
+ integer(bit_kind), intent(in) :: key_i(N_int,2)
+ integer, intent(in) :: h1,h2,p1,p2,s1,s2
+ double precision, intent(out) :: hthree
+ integer :: nexc(2),i,ispin,na,nb
+ integer(bit_kind) :: hole(N_int,2)
+ integer(bit_kind) :: particle(N_int,2)
+ integer :: occ_hole(N_int*bit_kind_size,2)
+ integer :: occ_particle(N_int*bit_kind_size,2)
+ integer :: n_occ_ab_hole(2),n_occ_ab_particle(2)
+ integer(bit_kind)              :: det_tmp(N_int,2)
+ integer :: ipart, ihole
+ double precision :: direct_int, exchange_int
+
+  nexc(1) = 0
+  nexc(2) = 0
+  !! Get all the holes and particles of key_i with respect to the ROHF determinant
+  do i=1,N_int
+    hole(i,1)     = xor(key_i(i,1),ref_bitmask(i,1))
+    hole(i,2)     = xor(key_i(i,2),ref_bitmask(i,2))
+    particle(i,1) = iand(hole(i,1),key_i(i,1))
+    particle(i,2) = iand(hole(i,2),key_i(i,2))
+    hole(i,1)     = iand(hole(i,1),ref_bitmask(i,1))
+    hole(i,2)     = iand(hole(i,2),ref_bitmask(i,2))
+    nexc(1)       = nexc(1) + popcnt(hole(i,1))
+    nexc(2)       = nexc(2) + popcnt(hole(i,2))
+  enddo
+  integer                        :: tmp(2)
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(particle, occ_particle, tmp, N_int)
+  ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
+  ASSERT (tmp(2) == nexc(2)) ! Number of particle beta 
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(hole, occ_hole, tmp, N_int)
+  ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
+  ASSERT (tmp(2) == nexc(2)) ! Number of holes beta 
+  if(s1==s2.and.s1==1)then
+   !!!!!!!!!!!!!!!!!!!!!!!!!! alpha/alpha double exc
+   hthree = eff_2_e_from_3_e_aa(p2,p1,h2,h1) 
+   if(nexc(1)+nexc(2) ==0)return !! if you're on the reference determinant 
+    !!!!!!!! the matrix element is already exact 
+    !!!!!!!! else you need to take care of holes and particles 
+    !!!!!!!!!!!!! Holes and particles !!!!!!!!!!!!!!!!!!!!!!!
+    ispin = 1 ! i==alpha ==> pure same spin terms
+    do i = 1, nexc(ispin) ! number of couple of holes/particles 
+     ipart=occ_particle(i,ispin)
+     hthree += three_e_double_parrallel_spin_prov(ipart,p2,h2,p1,h1)
+     ihole=occ_hole(i,ispin)
+     hthree -= three_e_double_parrallel_spin_prov(ihole,p2,h2,p1,h1)
+    enddo
+    ispin = 2 ! i==beta ==> alpha/alpha/beta terms
+    do i = 1, nexc(ispin) ! number of couple of holes/particles 
+     ! exchange between (h1,p1) and (h2,p2)
+     ipart=occ_particle(i,ispin)
+     direct_int  = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1)
+     exchange_int = three_e_5_idx_exch12_bi_ort(ipart,p2,h2,p1,h1)
+     hthree += direct_int - exchange_int
+     ihole=occ_hole(i,ispin)
+     direct_int  = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1)
+     exchange_int = three_e_5_idx_exch12_bi_ort(ihole,p2,h2,p1,h1)
+     hthree -= direct_int - exchange_int
+    enddo
+   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  elseif(s1==s2.and.s1==2)then 
+   !!!!!!!!!!!!!!!!!!!!!!!!!! beta/beta double exc
+   hthree = eff_2_e_from_3_e_bb(p2,p1,h2,h1)
+   if(nexc(1)+nexc(2) ==0)return !! if you're on the reference determinant 
+   !!!!!!!! the matrix element is already exact 
+   !!!!!!!! else you need to take care of holes and particles 
+   !!!!!!!!!!!!! Holes and particles !!!!!!!!!!!!!!!!!!!!!!!
+   ispin = 2 ! i==beta  ==> pure same spin terms
+   do i = 1, nexc(ispin) ! number of couple of holes/particles 
+    ipart=occ_particle(i,ispin)
+    hthree += three_e_double_parrallel_spin_prov(ipart,p2,h2,p1,h1)
+    ihole=occ_hole(i,ispin)
+    hthree -= three_e_double_parrallel_spin_prov(ihole,p2,h2,p1,h1)
+   enddo
+   ispin = 1 ! i==alpha==> beta/beta/alpha terms
+   do i = 1, nexc(ispin) ! number of couple of holes/particles 
+    ! exchange between (h1,p1) and (h2,p2)
+    ipart=occ_particle(i,ispin)
+    direct_int  = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1)
+    exchange_int = three_e_5_idx_exch12_bi_ort(ipart,p2,h2,p1,h1)
+    hthree += direct_int - exchange_int
+    ihole=occ_hole(i,ispin)
+    direct_int  = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1)
+    exchange_int = three_e_5_idx_exch12_bi_ort(ihole,p2,h2,p1,h1)
+    hthree -= direct_int - exchange_int
+   enddo
+  else                         ! (h1,p1) == alpha/(h2,p2) == beta 
+   hthree = eff_2_e_from_3_e_ab(p2,p1,h2,h1)
+   if(nexc(1)+nexc(2) ==0)return !! if you're on the reference determinant 
+   !!!!!!!! the matrix element is already exact 
+   !!!!!!!! else you need to take care of holes and particles 
+   !!!!!!!!!!!!! Holes and particles !!!!!!!!!!!!!!!!!!!!!!!
+   ispin = 1 ! i==alpha ==> alpha/beta/alpha terms 
+   do i = 1, nexc(ispin) ! number of couple of holes/particles 
+    ! exchange between (h1,p1) and i
+    ipart=occ_particle(i,ispin)
+    direct_int  = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1)
+    exchange_int = three_e_5_idx_exch13_bi_ort(ipart,p2,h2,p1,h1)
+    hthree += direct_int - exchange_int
+    ihole=occ_hole(i,ispin)
+    direct_int  = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1)
+    exchange_int = three_e_5_idx_exch13_bi_ort(ihole,p2,h2,p1,h1)
+    hthree -= direct_int - exchange_int
+   enddo
+   ispin = 2 ! i==beta  ==> alpha/beta/beta  terms 
+   do i = 1, nexc(ispin) ! number of couple of holes/particles 
+    ! exchange between (h2,p2) and i
+    ipart=occ_particle(i,ispin)
+    direct_int  = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1)
+    exchange_int = three_e_5_idx_exch23_bi_ort(ipart,p2,h2,p1,h1)
+    hthree += direct_int - exchange_int
+    ihole=occ_hole(i,ispin)
+    direct_int  = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1)
+    exchange_int = three_e_5_idx_exch23_bi_ort(ihole,p2,h2,p1,h1)
+    hthree -= direct_int - exchange_int
+   enddo
+  endif
+end
+
+
+BEGIN_PROVIDER [ double precision, eff_2_e_from_3_e_ab, (mo_num, mo_num, mo_num, mo_num)]
+ implicit none
+ BEGIN_DOC
+! eff_2_e_from_3_e_ab(p2,p1,h2,h1) = Effective Two-electron operator for alpha/beta double excitations 
+!
+! from contraction with HF density = a^{dagger}_p1_alpha a^{dagger}_p2_beta a_h2_beta a_h1_alpha
+ END_DOC
+ integer :: i,h1,p1,h2,p2
+ integer :: hh1,hh2,pp1,pp2,m,mm
+ integer                        :: Ne(2)
+ integer,           allocatable :: occ(:,:)
+ double precision :: contrib
+ allocate( occ(N_int*bit_kind_size,2) )
+ call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
+ call give_contrib_for_abab(1,1,1,1,occ,Ne,contrib)
+ eff_2_e_from_3_e_ab = 0.d0
+ !$OMP PARALLEL                                                                         &
+ !$OMP DEFAULT (NONE)                                                                   &
+ !$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, contrib) & 
+ !$OMP SHARED (n_act_orb, list_act, Ne,occ, eff_2_e_from_3_e_ab)
+ !$OMP DO SCHEDULE (static) 
+  do hh1 = 1, n_act_orb !! alpha 
+    h1 = list_act(hh1) 
+    do hh2 = 1, n_act_orb !! beta 
+      h2 = list_act(hh2) 
+      do pp1 = 1, n_act_orb !! alpha
+        p1 = list_act(pp1)
+        do pp2 = 1, n_act_orb !! beta 
+          p2 = list_act(pp2)
+          call give_contrib_for_abab(h1,h2,p1,p2,occ,Ne,contrib)
+          eff_2_e_from_3_e_ab(p2,p1,h2,h1) = contrib
+        enddo
+      enddo
+    enddo
+  enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+END_PROVIDER 
+
+subroutine give_contrib_for_abab(h1,h2,p1,p2,occ,Ne,contrib)
+ implicit none
+ BEGIN_DOC 
+! gives the contribution for a double excitation (h1,p1)_alpha (h2,p2)_beta
+!
+! on top of a determinant whose occupied orbitals is in (occ, Ne)
+ END_DOC
+ integer, intent(in) :: h1,h2,p1,p2,occ(N_int*bit_kind_size,2),Ne(2)
+ double precision, intent(out) :: contrib
+ integer :: mm,m 
+ double precision :: direct_int, exchange_int
+ !! h1,p1 == alpha 
+ !! h2,p2 == beta
+ contrib = 0.d0
+ do mm = 1, Ne(1) !! alpha 
+   m = occ(mm,1)
+   direct_int   = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) 
+   ! exchange between (h1,p1) and m
+   exchange_int = three_e_5_idx_exch13_bi_ort(mm,p2,h2,p1,h1)
+   contrib += direct_int - exchange_int
+ enddo
+
+ do mm = 1, Ne(2) !! beta
+   m = occ(mm,2)
+   direct_int   = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) 
+   ! exchange between (h2,p2) and m
+   exchange_int = three_e_5_idx_exch23_bi_ort(mm,p2,h2,p1,h1)
+   contrib += direct_int - exchange_int
+ enddo
+end
+
+BEGIN_PROVIDER [ double precision, eff_2_e_from_3_e_aa, (mo_num, mo_num, mo_num, mo_num)]
+ implicit none
+ BEGIN_DOC
+! eff_2_e_from_3_e_ab(p2,p1,h2,h1) = Effective Two-electron operator for alpha/alpha double excitations 
+!
+! from contractionelec_alpha_num with HF density = a^{dagger}_p1_alpha a^{dagger}_p2_alpha a_h2_alpha a_h1_alpha
+!
+! WARNING :: to be coherent with the phase convention used in the Hamiltonian matrix elements, you must fulfill 
+!
+! ||||    h2>h1, p2>p1   ||||
+ END_DOC
+ integer :: i,h1,p1,h2,p2
+ integer :: hh1,hh2,pp1,pp2,m,mm
+ integer                        :: Ne(2)
+ integer,           allocatable :: occ(:,:)
+ double precision :: contrib
+ allocate( occ(N_int*bit_kind_size,2) )
+ call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
+ call give_contrib_for_aaaa(1 ,1 ,1 ,1 ,occ,Ne,contrib)
+ eff_2_e_from_3_e_aa = 100000000.d0
+ !$OMP PARALLEL                                                                         &
+ !$OMP DEFAULT (NONE)                                                                   &
+ !$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, contrib) & 
+ !$OMP SHARED (n_act_orb, list_act, Ne,occ, eff_2_e_from_3_e_aa)
+ !$OMP DO SCHEDULE (static) 
+  do hh1 = 1, n_act_orb !! alpha 
+    h1 = list_act(hh1) 
+    do hh2 = hh1+1, n_act_orb !! alpha
+      h2 = list_act(hh2) 
+      do pp1 = 1, n_act_orb !! alpha
+        p1 = list_act(pp1)
+        do pp2 = pp1+1, n_act_orb !! alpha
+          p2 = list_act(pp2)
+          call give_contrib_for_aaaa(h1,h2,p1,p2,occ,Ne,contrib)
+          eff_2_e_from_3_e_aa(p2,p1,h2,h1) = contrib
+        enddo
+      enddo
+    enddo
+  enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+END_PROVIDER 
+
+subroutine give_contrib_for_aaaa(h1,h2,p1,p2,occ,Ne,contrib)
+ implicit none
+ BEGIN_DOC 
+! gives the contribution for a double excitation (h1,p1)_alpha (h2,p2)_alpha
+!
+! on top of a determinant whose occupied orbitals is in (occ, Ne)
+ END_DOC
+ integer, intent(in) :: h1,h2,p1,p2,occ(N_int*bit_kind_size,2),Ne(2)
+ double precision, intent(out) :: contrib
+ integer :: mm,m 
+ double precision :: direct_int, exchange_int
+ !! h1,p1 == alpha 
+ !! h2,p2 == alpha
+ contrib = 0.d0
+ do mm = 1, Ne(1) !! alpha ==> pure parallele spin contribution
+   m = occ(mm,1)
+   contrib += three_e_double_parrallel_spin_prov(m,p2,h2,p1,h1)
+ enddo
+
+ do mm = 1, Ne(2) !! beta
+   m = occ(mm,2)
+   direct_int   = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) 
+   ! exchange between (h1,p1) and (h2,p2)
+   exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1)
+   contrib += direct_int - exchange_int
+ enddo
+end
+
+
+BEGIN_PROVIDER [ double precision, eff_2_e_from_3_e_bb, (mo_num, mo_num, mo_num, mo_num)]
+ implicit none
+ BEGIN_DOC
+! eff_2_e_from_3_e_ab(p2,p1,h2,h1) = Effective Two-electron operator for beta/beta double excitations 
+!
+! from contractionelec_beta_num with HF density = a^{dagger}_p1_beta a^{dagger}_p2_beta a_h2_beta a_h1_beta
+!
+! WARNING :: to be coherent with the phase convention used in the Hamiltonian matrix elements, you must fulfill 
+!
+! ||||    h2>h1, p2>p1   ||||
+ END_DOC
+ integer :: i,h1,p1,h2,p2
+ integer :: hh1,hh2,pp1,pp2,m,mm
+ integer                        :: Ne(2)
+ integer,           allocatable :: occ(:,:)
+ double precision :: contrib
+ allocate( occ(N_int*bit_kind_size,2) )
+ call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
+ call give_contrib_for_bbbb(1,1 ,1 ,1 ,occ,Ne,contrib)
+ eff_2_e_from_3_e_bb = 100000000.d0
+ !$OMP PARALLEL                                                                         &
+ !$OMP DEFAULT (NONE)                                                                   &
+ !$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, contrib) & 
+ !$OMP SHARED (n_act_orb, list_act, Ne,occ, eff_2_e_from_3_e_bb)
+ !$OMP DO SCHEDULE (static) 
+  do hh1 = 1, n_act_orb !! beta 
+    h1 = list_act(hh1) 
+    do hh2 = hh1+1, n_act_orb !! beta
+      h2 = list_act(hh2) 
+      do pp1 = 1, n_act_orb !! beta
+        p1 = list_act(pp1)
+        do pp2 = pp1+1, n_act_orb !! beta
+          p2 = list_act(pp2)
+          call give_contrib_for_bbbb(h1,h2,p1,p2,occ,Ne,contrib)
+          eff_2_e_from_3_e_bb(p2,p1,h2,h1) = contrib
+        enddo
+      enddo
+    enddo
+  enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+END_PROVIDER 
+
+subroutine give_contrib_for_bbbb(h1,h2,p1,p2,occ,Ne,contrib)
+ implicit none
+ BEGIN_DOC 
+! gives the contribution for a double excitation (h1,p1)_beta (h2,p2)_beta
+!
+! on top of a determinant whose occupied orbitals is in (occ, Ne)
+ END_DOC
+ integer, intent(in) :: h1,h2,p1,p2,occ(N_int*bit_kind_size,2),Ne(2)
+ double precision, intent(out) :: contrib
+ integer :: mm,m 
+ double precision :: direct_int, exchange_int
+ !! h1,p1 == beta
+ !! h2,p2 == beta
+ contrib = 0.d0
+ do mm = 1, Ne(2) !! beta ==> pure parallele spin contribution
+   m = occ(mm,1)
+   contrib += three_e_double_parrallel_spin_prov(m,p2,h2,p1,h1)
+ enddo
+
+ do mm = 1, Ne(1) !! alpha
+   m = occ(mm,1)
+   direct_int   = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1) 
+   ! exchange between (h1,p1) and (h2,p2)
+   exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1)
+   contrib += direct_int - exchange_int
+ enddo
+end
+
+
+subroutine double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
+
+  BEGIN_DOC
+  ! <key_j | H_tilde | key_i> for double excitation  ONLY FOR ONE- AND TWO-BODY TERMS 
+  !!
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in) :: Nint 
+  integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
+  double precision, intent(out) :: htot
+  double precision :: hmono, htwoe
+  integer                       :: occ(Nint*bit_kind_size,2)
+  integer                       :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
+  integer                       :: degree,exc(0:2,2,2)
+  integer                       :: h1, p1, h2, p2, s1, s2
+  double precision              :: get_mo_two_e_integral_tc_int,phase
+
+
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+
+  hmono  = 0.d0
+  htwoe  = 0.d0
+  htot   = 0.d0
+
+  if(degree.ne.2)then
+   return
+  endif
+  integer :: degree_i,degree_j
+  call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int)
+  call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int)
+  call get_double_excitation(key_i, key_j, exc, phase, Nint)
+  call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
+
+  if(s1.ne.s2)then
+   ! opposite spin two-body 
+    htwoe  = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) 
+  else
+   ! same spin two-body 
+   ! direct terms 
+   htwoe  = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)  
+   ! exchange terms 
+   htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1) 
+  endif
+  htwoe  *= phase
+  htot    =  htwoe 
+
+end
+

src/tc_bi_ortho/slater_tc_opt_single.irp.f

@@ -0,0 +1,572 @@
+
+
+subroutine  single_htilde_mu_mat_fock_bi_ortho (Nint, key_j, key_i, hmono, htwoe, hthree, htot)
+  BEGIN_DOC
+  ! <key_j | H_tilde | key_i> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS 
+  !!
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in) :: Nint
+  integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
+  double precision, intent(out) :: hmono, htwoe, hthree, htot
+  integer                       :: occ(Nint*bit_kind_size,2)
+  integer                       :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
+  integer                       :: degree,exc(0:2,2,2)
+  integer                       :: h1, p1, h2, p2, s1, s2
+  double precision              :: get_mo_two_e_integral_tc_int, phase
+  double precision              :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13
+  integer                       :: other_spin(2)
+  integer(bit_kind)             :: key_j_core(Nint,2), key_i_core(Nint,2)
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  hmono  = 0.d0
+  htwoe  = 0.d0
+  hthree = 0.d0
+  htot   = 0.d0
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+  if(degree.ne.1)then
+   return
+  endif
+  call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+
+  call get_single_excitation(key_i, key_j, exc, phase, Nint)
+  call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
+  call get_single_excitation_from_fock_tc(key_i,key_j,h1,p1,s1,phase,hmono,htwoe,hthree,htot)
+end
+
+
+subroutine get_single_excitation_from_fock_tc(key_i,key_j,h,p,spin,phase,hmono,htwoe,hthree,htot)
+ use bitmasks
+ implicit none
+ integer,intent(in) :: h,p,spin
+ double precision, intent(in)  :: phase
+ integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2)
+ double precision, intent(out) :: hmono,htwoe,hthree,htot
+ integer(bit_kind) :: differences(N_int,2)
+ integer(bit_kind) :: hole(N_int,2)
+ integer(bit_kind) :: partcl(N_int,2)
+ integer :: occ_hole(N_int*bit_kind_size,2)
+ integer :: occ_partcl(N_int*bit_kind_size,2)
+ integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
+ integer :: i0,i
+ double precision :: buffer_c(mo_num),buffer_x(mo_num)
+ do i=1, mo_num
+   buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
+   buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
+ enddo
+ do i = 1, N_int
+  differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1))
+  differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2))
+  hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
+  hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
+  partcl(i,1) = iand(differences(i,1),key_i(i,1))
+  partcl(i,2) = iand(differences(i,2),key_i(i,2))
+ enddo
+ call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
+ call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
+ hmono = mo_bi_ortho_tc_one_e(p,h)
+ htwoe = fock_op_2_e_tc_closed_shell(p,h)
+ ! holes :: direct terms
+ do i0 = 1, n_occ_ab_hole(1)
+  i = occ_hole(i0,1)
+  htwoe -= buffer_c(i)
+ enddo
+ do i0 = 1, n_occ_ab_hole(2)
+  i = occ_hole(i0,2)
+  htwoe -= buffer_c(i)
+ enddo
+
+ ! holes :: exchange terms
+ do i0 = 1, n_occ_ab_hole(spin)
+  i = occ_hole(i0,spin)
+  htwoe += buffer_x(i)
+ enddo
+
+ ! particles :: direct terms
+ do i0 = 1, n_occ_ab_partcl(1)
+  i = occ_partcl(i0,1)
+  htwoe += buffer_c(i)
+ enddo
+ do i0 = 1, n_occ_ab_partcl(2)
+  i = occ_partcl(i0,2)
+  htwoe += buffer_c(i)
+ enddo
+
+ ! particles :: exchange terms
+ do i0 = 1, n_occ_ab_partcl(spin)
+  i = occ_partcl(i0,spin)
+  htwoe -= buffer_x(i)
+ enddo
+ hthree = 0.d0
+ if (three_body_h_tc)then
+  call three_comp_fock_elem(key_i,h,p,spin,hthree)
+ endif
+
+
+ htwoe = htwoe * phase
+ hmono = hmono * phase
+ hthree = hthree * phase
+ htot  = htwoe + hmono + hthree
+
+end
+
+subroutine three_comp_fock_elem(key_i,h_fock,p_fock,ispin_fock,hthree)
+ implicit none
+ integer,intent(in) :: h_fock,p_fock,ispin_fock
+ integer(bit_kind), intent(in) :: key_i(N_int,2)
+ double precision, intent(out) :: hthree
+ integer :: nexc(2),i,ispin,na,nb
+ integer(bit_kind) :: hole(N_int,2)
+ integer(bit_kind) :: particle(N_int,2)
+ integer :: occ_hole(N_int*bit_kind_size,2)
+ integer :: occ_particle(N_int*bit_kind_size,2)
+ integer :: n_occ_ab_hole(2),n_occ_ab_particle(2)
+ integer(bit_kind)              :: det_tmp(N_int,2)
+
+
+  nexc(1) = 0
+  nexc(2) = 0
+  !! Get all the holes and particles of key_i with respect to the ROHF determinant
+  do i=1,N_int
+    hole(i,1)     = xor(key_i(i,1),ref_bitmask(i,1))
+    hole(i,2)     = xor(key_i(i,2),ref_bitmask(i,2))
+    particle(i,1) = iand(hole(i,1),key_i(i,1))
+    particle(i,2) = iand(hole(i,2),key_i(i,2))
+    hole(i,1)     = iand(hole(i,1),ref_bitmask(i,1))
+    hole(i,2)     = iand(hole(i,2),ref_bitmask(i,2))
+    nexc(1)       = nexc(1) + popcnt(hole(i,1))
+    nexc(2)       = nexc(2) + popcnt(hole(i,2))
+  enddo
+  integer                        :: tmp(2)
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(particle, occ_particle, tmp, N_int)
+  ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
+  ASSERT (tmp(2) == nexc(2)) ! Number of particle beta 
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(hole, occ_hole, tmp, N_int)
+  ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
+  ASSERT (tmp(2) == nexc(2)) ! Number of holes beta 
+
+  !! Initialize the matrix element with the reference ROHF Slater determinant Fock element
+  if(ispin_fock==1)then
+   hthree = fock_a_tot_3e_bi_orth(p_fock,h_fock) 
+  else 
+   hthree = fock_b_tot_3e_bi_orth(p_fock,h_fock) 
+  endif
+  det_tmp = ref_bitmask
+  do ispin=1,2
+    na = elec_num_tab(ispin)
+    nb = elec_num_tab(iand(ispin,1)+1)
+    do i=1,nexc(ispin)
+      !DIR$ FORCEINLINE
+      call fock_ac_tc_operator( occ_particle(i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, N_int,na,nb)
+      !DIR$ FORCEINLINE
+      call fock_a_tc_operator ( occ_hole    (i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, N_int,na,nb)
+    enddo
+  enddo
+end
+
+subroutine fock_ac_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,Nint,na,nb)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Routine that computes the contribution to the three-electron part of the Fock operator 
+  !
+  ! a^dagger_{p_fock} a_{h_fock} of spin ispin_fock
+  ! 
+  ! on top of a determinant 'key' on which you ADD an electron of spin ispin in orbital iorb
+  ! 
+  ! in output, the determinant key is changed by the ADDITION of that electron 
+  !
+  ! the output hthree is INCREMENTED
+  END_DOC
+  integer, intent(in)              :: iorb, ispin, Nint, h_fock,p_fock, ispin_fock
+  integer, intent(inout)           :: na, nb
+  integer(bit_kind), intent(inout) :: key(Nint,2)
+  double precision, intent(inout)  :: hthree
+
+  integer                        :: occ(Nint*bit_kind_size,2)
+  integer                        :: other_spin
+  integer                        :: k,l,i,jj,j
+  double precision :: direct_int, exchange_int
+  
+
+  if (iorb < 1) then
+    print *,  irp_here, ': iorb < 1'
+    print *,  iorb, mo_num
+    stop -1
+  endif
+  if (iorb > mo_num) then
+    print *,  irp_here, ': iorb > mo_num'
+    print *,  iorb, mo_num
+    stop -1
+  endif
+
+  ASSERT (ispin > 0)
+  ASSERT (ispin < 3)
+  ASSERT (Nint > 0)
+
+  integer                        :: tmp(2)
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(key, occ, tmp, Nint)
+  ASSERT (tmp(1) == elec_alpha_num)
+  ASSERT (tmp(2) == elec_beta_num)
+
+  k = shiftr(iorb-1,bit_kind_shift)+1
+  ASSERT (k >0)
+  l = iorb - shiftl(k-1,bit_kind_shift)-1
+  ASSERT (l >= 0)
+  key(k,ispin) = ibset(key(k,ispin),l)
+  other_spin = iand(ispin,1)+1
+
+
+  !! spin of other electrons == ispin 
+  if(ispin == ispin_fock)then
+   !! in what follows :: jj == other electrons in the determinant 
+   !!                 :: iorb == electron that has been added of spin ispin
+   !!                 :: p_fock, h_fock == hole particle of spin ispin_fock
+   !! jj = ispin = ispin_fock >> pure parallel spin
+   do j = 1, na
+    jj = occ(j,ispin)
+    hthree += three_e_single_parrallel_spin_prov(jj,iorb,p_fock,h_fock)
+   enddo
+   !! spin of jj == other spin than ispin AND ispin_fock
+   !! exchange between the iorb and (h_fock, p_fock)
+   do j = 1, nb
+    jj = occ(j,other_spin) 
+    direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR 
+    exchange_int = three_e_4_idx_exch12_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR 
+    hthree += direct_int - exchange_int
+   enddo
+  else !! ispin NE to ispin_fock
+   !! jj = ispin BUT NON EQUAL TO ispin_fock 
+   !! exchange between the jj and iorb
+   do j = 1, na
+    jj = occ(j,ispin)
+    direct_int   = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR 
+    exchange_int = three_e_4_idx_exch23_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR 
+    hthree += direct_int - exchange_int
+   enddo
+   !! jj = other_spin than ispin BUT jj == ispin_fock
+   !! exchange between jj and (h_fock,p_fock)
+   do j = 1, nb
+    jj = occ(j,other_spin) 
+    direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR 
+    exchange_int = three_e_4_idx_exch13_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR 
+    hthree += direct_int - exchange_int
+   enddo
+  endif
+
+  na = na+1
+end
+
+subroutine fock_a_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,Nint,na,nb)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Routine that computes the contribution to the three-electron part of the Fock operator 
+  !
+  ! a^dagger_{p_fock} a_{h_fock} of spin ispin_fock
+  ! 
+  ! on top of a determinant 'key' on which you REMOVE an electron of spin ispin in orbital iorb
+  ! 
+  ! in output, the determinant key is changed by the REMOVAL of that electron 
+  !
+  ! the output hthree is INCREMENTED
+  END_DOC
+  integer, intent(in)            :: iorb, ispin, Nint, h_fock,p_fock, ispin_fock
+  integer, intent(inout)         :: na, nb
+  integer(bit_kind), intent(inout) :: key(Nint,2)
+  double precision, intent(inout) :: hthree
+  
+  double precision  :: direct_int, exchange_int
+  integer                        :: occ(Nint*bit_kind_size,2)
+  integer                        :: other_spin
+  integer                        :: k,l,i,jj,mm,j,m
+  integer                        :: tmp(2)
+
+  ASSERT (iorb > 0)
+  ASSERT (ispin > 0)
+  ASSERT (ispin < 3)
+  ASSERT (Nint > 0)
+
+  k = shiftr(iorb-1,bit_kind_shift)+1
+  ASSERT (k>0)
+  l = iorb - shiftl(k-1,bit_kind_shift)-1
+  key(k,ispin) = ibclr(key(k,ispin),l)
+  other_spin = iand(ispin,1)+1
+
+  !DIR$ FORCEINLINE
+  call bitstring_to_list_ab(key, occ, tmp, Nint)
+  na = na-1
+  !! spin of other electrons == ispin 
+  if(ispin == ispin_fock)then
+   !! in what follows :: jj == other electrons in the determinant 
+   !!                 :: iorb == electron that has been added of spin ispin
+   !!                 :: p_fock, h_fock == hole particle of spin ispin_fock
+   !! jj = ispin = ispin_fock >> pure parallel spin
+   do j = 1, na
+    jj = occ(j,ispin)
+    hthree -= three_e_single_parrallel_spin_prov(jj,iorb,p_fock,h_fock)
+   enddo
+   !! spin of jj == other spin than ispin AND ispin_fock
+   !! exchange between the iorb and (h_fock, p_fock)
+   do j = 1, nb
+    jj = occ(j,other_spin) 
+    direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR 
+    exchange_int = three_e_4_idx_exch12_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR 
+    hthree -= direct_int - exchange_int
+   enddo
+  else !! ispin NE to ispin_fock
+   !! jj = ispin BUT NON EQUAL TO ispin_fock 
+   !! exchange between the jj and iorb
+   do j = 1, na
+    jj = occ(j,ispin)
+    direct_int   = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR 
+    exchange_int = three_e_4_idx_exch23_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR 
+    hthree -= direct_int - exchange_int
+   enddo
+   !! jj = other_spin than ispin BUT jj == ispin_fock
+   !! exchange between jj and (h_fock,p_fock)
+   do j = 1, nb
+    jj = occ(j,other_spin) 
+    direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR 
+    exchange_int = three_e_4_idx_exch13_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR 
+    hthree -= direct_int - exchange_int
+   enddo
+  endif
+
+end
+
+
+BEGIN_PROVIDER [double precision, fock_op_2_e_tc_closed_shell, (mo_num, mo_num) ]
+ implicit none
+ BEGIN_DOC
+! Closed-shell part of the Fock operator for the TC operator
+ END_DOC
+ integer :: h0,p0,h,p,k0,k,i
+ integer :: n_occ_ab(2)
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab_virt(2)
+ integer :: occ_virt(N_int*bit_kind_size,2)
+ integer(bit_kind) :: key_test(N_int)
+ integer(bit_kind) :: key_virt(N_int,2)
+ double precision :: accu
+
+ fock_op_2_e_tc_closed_shell = -1000.d0
+ call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int)
+ do i = 1, N_int
+  key_virt(i,1) = full_ijkl_bitmask(i)
+  key_virt(i,2) = full_ijkl_bitmask(i)
+  key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask(i,1))
+  key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask(i,2))
+ enddo
+ call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
+ ! docc ---> virt single excitations
+ do h0 = 1,  n_occ_ab(1)
+  h=occ(h0,1)
+  do p0 = 1, n_occ_ab_virt(1)
+   p = occ_virt(p0,1)
+   accu = 0.d0
+   do k0 = 1, n_occ_ab(1)
+    k = occ(k0,1)
+    accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+   enddo
+   fock_op_2_e_tc_closed_shell(p,h) = accu 
+  enddo
+ enddo
+
+ do h0 = 1, n_occ_ab_virt(1)
+  h = occ_virt(h0,1)
+  do p0 = 1,  n_occ_ab(1)
+   p=occ(p0,1)
+   accu = 0.d0
+   do k0 = 1, n_occ_ab(1)
+    k = occ(k0,1)
+    accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+   enddo
+   fock_op_2_e_tc_closed_shell(p,h) = accu 
+  enddo
+ enddo
+
+ ! virt ---> virt single excitations
+ do h0 = 1,  n_occ_ab_virt(1)
+  h=occ_virt(h0,1)
+  do p0 = 1, n_occ_ab_virt(1)
+   p = occ_virt(p0,1)
+   accu = 0.d0
+   do k0 = 1, n_occ_ab(1)
+    k = occ(k0,1)
+    accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+   enddo
+   fock_op_2_e_tc_closed_shell(p,h) = accu 
+  enddo
+ enddo
+
+ do h0 = 1, n_occ_ab_virt(1)
+  h = occ_virt(h0,1)
+  do p0 = 1,  n_occ_ab_virt(1)
+   p=occ_virt(p0,1)
+   accu = 0.d0
+   do k0 = 1, n_occ_ab(1)
+    k = occ(k0,1)
+    accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+   enddo
+   fock_op_2_e_tc_closed_shell(p,h) = accu 
+  enddo
+ enddo
+
+
+ ! docc ---> docc single excitations
+ do h0 = 1,  n_occ_ab(1)
+  h=occ(h0,1)
+  do p0 = 1, n_occ_ab(1)
+   p = occ(p0,1)
+   accu = 0.d0
+   do k0 = 1, n_occ_ab(1)
+    k = occ(k0,1)
+    accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+   enddo
+   fock_op_2_e_tc_closed_shell(p,h) = accu 
+  enddo
+ enddo
+
+ do h0 = 1, n_occ_ab(1)
+  h = occ(h0,1)
+  do p0 = 1,  n_occ_ab(1)
+   p=occ(p0,1)
+   accu = 0.d0
+   do k0 = 1, n_occ_ab(1)
+    k = occ(k0,1)
+    accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+   enddo
+   fock_op_2_e_tc_closed_shell(p,h) = accu 
+  enddo
+ enddo
+
+! do i = 1, mo_num
+!  write(*,'(100(F10.5,X))')fock_op_2_e_tc_closed_shell(:,i)
+! enddo
+
+END_PROVIDER
+
+
+subroutine  single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
+  BEGIN_DOC
+  ! <key_j | H_tilde | key_i> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS 
+  !!
+  !! WARNING !!
+  ! 
+  ! Non hermitian !!
+  END_DOC
+
+  use bitmasks
+
+  implicit none
+  integer,           intent(in) :: Nint
+  integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
+  double precision, intent(out) ::  htot
+  double precision :: hmono, htwoe
+  integer                       :: occ(Nint*bit_kind_size,2)
+  integer                       :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
+  integer                       :: degree,exc(0:2,2,2)
+  integer                       :: h1, p1, h2, p2, s1, s2
+  double precision              :: get_mo_two_e_integral_tc_int, phase
+  double precision              :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13
+  integer                       :: other_spin(2)
+  integer(bit_kind)             :: key_j_core(Nint,2), key_i_core(Nint,2)
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  hmono  = 0.d0
+  htwoe  = 0.d0
+  htot   = 0.d0
+  call get_excitation_degree(key_i, key_j, degree, Nint)
+  if(degree.ne.1)then
+   return
+  endif
+  call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+
+  call get_single_excitation(key_i, key_j, exc, phase, Nint)
+  call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
+  call get_single_excitation_from_fock_tc_no_3e(key_i,key_j,h1,p1,s1,phase,hmono,htwoe,htot)
+end
+
+
+subroutine get_single_excitation_from_fock_tc_no_3e(key_i,key_j,h,p,spin,phase,hmono,htwoe,htot)
+ use bitmasks
+ implicit none
+ integer,intent(in) :: h,p,spin
+ double precision, intent(in)  :: phase
+ integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2)
+ double precision, intent(out) :: hmono,htwoe,htot
+ integer(bit_kind) :: differences(N_int,2)
+ integer(bit_kind) :: hole(N_int,2)
+ integer(bit_kind) :: partcl(N_int,2)
+ integer :: occ_hole(N_int*bit_kind_size,2)
+ integer :: occ_partcl(N_int*bit_kind_size,2)
+ integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
+ integer :: i0,i
+ double precision :: buffer_c(mo_num),buffer_x(mo_num)
+ do i=1, mo_num
+   buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
+   buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
+ enddo
+ do i = 1, N_int
+  differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1))
+  differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2))
+  hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
+  hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
+  partcl(i,1) = iand(differences(i,1),key_i(i,1))
+  partcl(i,2) = iand(differences(i,2),key_i(i,2))
+ enddo
+ call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
+ call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
+ hmono = mo_bi_ortho_tc_one_e(p,h)
+ htwoe = fock_op_2_e_tc_closed_shell(p,h)
+ ! holes :: direct terms
+ do i0 = 1, n_occ_ab_hole(1)
+  i = occ_hole(i0,1)
+  htwoe -= buffer_c(i)
+ enddo
+ do i0 = 1, n_occ_ab_hole(2)
+  i = occ_hole(i0,2)
+  htwoe -= buffer_c(i)
+ enddo
+
+ ! holes :: exchange terms
+ do i0 = 1, n_occ_ab_hole(spin)
+  i = occ_hole(i0,spin)
+  htwoe += buffer_x(i)
+ enddo
+
+ ! particles :: direct terms
+ do i0 = 1, n_occ_ab_partcl(1)
+  i = occ_partcl(i0,1)
+  htwoe += buffer_c(i)
+ enddo
+ do i0 = 1, n_occ_ab_partcl(2)
+  i = occ_partcl(i0,2)
+  htwoe += buffer_c(i)
+ enddo
+
+ ! particles :: exchange terms
+ do i0 = 1, n_occ_ab_partcl(spin)
+  i = occ_partcl(i0,spin)
+  htwoe -= buffer_x(i)
+ enddo
+ htwoe = htwoe * phase
+ hmono = hmono * phase
+ htot  = htwoe + hmono 
+
+end
+

src/tc_bi_ortho/symmetrized_3_e_int.irp.f

@@ -0,0 +1,111 @@
+subroutine give_all_perm_for_three_e(n,l,k,m,j,i,idx_list,phase)
+ implicit none
+ BEGIN_DOC
+ ! returns all the list of permutting indices for the antimmetrization of 
+ !
+ ! (k^dagger l^dagger n^dagger m j i)  <nlk|L|mji>   when all indices have the same spins
+ !
+ ! idx_list(:,i) == list of the 6 indices corresponding the permutation "i"
+ !
+ ! phase(i) == phase of the permutation "i" 
+ !
+ ! there are in total 6 permutations with different indices
+ END_DOC
+ integer, intent(in)  :: n,l,k,m,j,i
+ integer, intent(out) :: idx_list(6,6) 
+ double precision :: phase(6)
+ integer :: list(6)
+ !!! CYCLIC PERMUTATIONS 
+ phase(1:3) = 1.d0
+ !!! IDENTITY PERMUTATION 
+ list = (/n,l,k,m,j,i/)
+ idx_list(:,1) = list(:)
+ !!! FIRST CYCLIC PERMUTATION 
+ list = (/n,l,k,j,i,m/)
+ idx_list(:,2) = list(:)
+ !!! FIRST CYCLIC PERMUTATION 
+ list = (/n,l,k,i,m,j/)
+ idx_list(:,3) = list(:)
+
+ !!! NON CYCLIC PERMUTATIONS 
+ phase(1:3) = -1.d0
+ !!! PARTICLE 1 is FIXED
+ list = (/n,l,k,j,m,i/)
+ idx_list(:,4) = list(:)
+ !!! PARTICLE 2 is FIXED
+ list = (/n,l,k,i,j,m/)
+ idx_list(:,5) = list(:)
+ !!! PARTICLE 3 is FIXED
+ list = (/n,l,k,m,i,j/)
+ idx_list(:,6) = list(:)
+
+end
+
+double precision function sym_3_e_int_from_6_idx_tensor(n,l,k,m,j,i)
+ implicit none
+ BEGIN_DOC
+ ! returns all good combinations of permutations of integrals with the good signs 
+ !
+ ! for a given (k^dagger l^dagger n^dagger m j i)  <nlk|L|mji> when all indices have the same spins
+ END_DOC
+ integer, intent(in)  :: n,l,k,m,j,i
+ sym_3_e_int_from_6_idx_tensor = three_body_ints_bi_ort(n,l,k,m,j,i) & ! direct 
+                               + three_body_ints_bi_ort(n,l,k,j,i,m) & ! 1st cyclic permutation  
+                               + three_body_ints_bi_ort(n,l,k,i,m,j) & ! 2nd cyclic permutation  
+                               - three_body_ints_bi_ort(n,l,k,j,m,i) & ! elec 1 is kept fixed 
+                               - three_body_ints_bi_ort(n,l,k,i,j,m) & ! elec 2 is kept fixed
+                               - three_body_ints_bi_ort(n,l,k,m,i,j)   ! elec 3 is kept fixed
+
+end
+
+double precision function direct_sym_3_e_int(n,l,k,m,j,i)
+ implicit none
+ BEGIN_DOC
+ ! returns all good combinations of permutations of integrals with the good signs 
+ !
+ ! for a given (k^dagger l^dagger n^dagger m j i)  <nlk|L|mji> when all indices have the same spins
+ END_DOC
+ integer, intent(in)  :: n,l,k,m,j,i
+ double precision :: integral
+ direct_sym_3_e_int = 0.d0
+ call give_integrals_3_body_bi_ort(n,l,k,m,j,i,integral)   ! direct 
+ direct_sym_3_e_int += integral
+ call give_integrals_3_body_bi_ort(n,l,k,j,i,m,integral)   ! 1st cyclic permutation  
+ direct_sym_3_e_int += integral
+ call give_integrals_3_body_bi_ort(n,l,k,i,m,j,integral)   ! 2nd cyclic permutation  
+ direct_sym_3_e_int += integral
+ call give_integrals_3_body_bi_ort(n,l,k,j,m,i,integral)   ! elec 1 is kept fixed 
+ direct_sym_3_e_int += -integral
+ call give_integrals_3_body_bi_ort(n,l,k,i,j,m,integral)   ! elec 2 is kept fixed
+ direct_sym_3_e_int += -integral
+ call give_integrals_3_body_bi_ort(n,l,k,m,i,j,integral)   ! elec 3 is kept fixed
+ direct_sym_3_e_int += -integral
+
+end
+
+double precision function three_e_diag_parrallel_spin(m,j,i)
+ implicit none
+ integer, intent(in) :: i,j,m
+  three_e_diag_parrallel_spin = three_e_3_idx_direct_bi_ort(m,j,i)  ! direct
+  three_e_diag_parrallel_spin += three_e_3_idx_cycle_1_bi_ort(m,j,i) + three_e_3_idx_cycle_2_bi_ort(m,j,i) & ! two cyclic permutations 
+  - three_e_3_idx_exch23_bi_ort(m,j,i) - three_e_3_idx_exch13_bi_ort(m,j,i)  & ! two first exchange 
+  - three_e_3_idx_exch12_bi_ort(m,j,i) ! last exchange 
+end
+
+double precision function three_e_single_parrallel_spin(m,j,k,i)
+ implicit none
+ integer, intent(in) :: i,k,j,m
+  three_e_single_parrallel_spin = three_e_4_idx_direct_bi_ort(m,j,k,i)  ! direct
+  three_e_single_parrallel_spin += three_e_4_idx_cycle_1_bi_ort(m,j,k,i) + three_e_4_idx_cycle_2_bi_ort(m,j,k,i) & ! two cyclic permutations 
+  - three_e_4_idx_exch23_bi_ort(m,j,k,i) - three_e_4_idx_exch13_bi_ort(m,j,k,i)  & ! two first exchange 
+  - three_e_4_idx_exch12_bi_ort(m,j,k,i) ! last exchange 
+end
+
+double precision function three_e_double_parrallel_spin(m,l,j,k,i)
+ implicit none
+ integer, intent(in) :: i,k,j,m,l
+  three_e_double_parrallel_spin = three_e_5_idx_direct_bi_ort(m,l,j,k,i)  ! direct
+  three_e_double_parrallel_spin += three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) + three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) & ! two cyclic permutations 
+  - three_e_5_idx_exch23_bi_ort(m,l,j,k,i) - three_e_5_idx_exch13_bi_ort(m,l,j,k,i)  & ! two first exchange 
+  - three_e_5_idx_exch12_bi_ort(m,l,j,k,i) ! last exchange 
+end

src/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f

@@ -0,0 +1,140 @@
+
+BEGIN_PROVIDER [ double precision, three_e_diag_parrallel_spin_prov, (mo_num, mo_num, mo_num)]
+
+  BEGIN_DOC
+  !
+  ! matrix element of the -L  three-body operator ON A BI ORTHONORMAL BASIS 
+  !
+  ! three_e_diag_parrallel_spin_prov(m,j,i) = All combinations of the form <mji|-L|mji> for same spin matrix elements  
+  ! 
+  ! notice the -1 sign: in this way three_e_diag_parrallel_spin_prov can be directly used to compute Slater rules with a + sign
+  !
+  END_DOC
+
+  implicit none
+  integer          :: i, j, m
+  double precision :: integral, wall1, wall0, three_e_diag_parrallel_spin
+
+  three_e_diag_parrallel_spin_prov = 0.d0
+  print *, ' Providing the three_e_diag_parrallel_spin_prov ...'
+
+ integral = three_e_diag_parrallel_spin(1,1,1) ! to provide all stuffs
+  call wall_time(wall0)
+ !$OMP PARALLEL                 &
+ !$OMP DEFAULT (NONE)           &
+ !$OMP PRIVATE (i,j,m,integral) & 
+ !$OMP SHARED (mo_num,three_e_diag_parrallel_spin_prov)
+ !$OMP DO SCHEDULE (dynamic)
+  do i = 1, mo_num
+    do j = 1, mo_num
+      do m = j, mo_num
+        three_e_diag_parrallel_spin_prov(m,j,i) =  three_e_diag_parrallel_spin(m,j,i)
+      enddo
+    enddo
+  enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+  do i = 1, mo_num
+    do j = 1, mo_num
+      do m = 1, j
+        three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin_prov(j,m,i)
+      enddo
+    enddo
+  enddo
+
+  call wall_time(wall1)
+  print *, ' wall time for three_e_diag_parrallel_spin_prov', wall1 - wall0
+
+END_PROVIDER 
+
+BEGIN_PROVIDER [ double precision, three_e_single_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num)]
+
+  BEGIN_DOC
+  !
+  ! matrix element of the -L  three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
+  !
+  ! three_e_single_parrallel_spin_prov(m,j,k,i) = All combination of <mjk|-L|mji> for same spin matrix elements 
+  !
+  ! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
+  !
+  END_DOC
+
+ implicit none
+ integer          :: i, j, k, m
+ double precision :: integral, wall1, wall0, three_e_single_parrallel_spin
+
+  three_e_single_parrallel_spin_prov = 0.d0
+  print *, ' Providing the three_e_single_parrallel_spin_prov ...'
+
+  integral = three_e_single_parrallel_spin(1,1,1,1)
+  call wall_time(wall0)
+ !$OMP PARALLEL                   &
+ !$OMP DEFAULT (NONE)             &
+ !$OMP PRIVATE (i,j,k,m,integral) & 
+ !$OMP SHARED (mo_num,three_e_single_parrallel_spin_prov)
+ !$OMP DO SCHEDULE (dynamic)
+  do i = 1, mo_num
+    do k = 1, mo_num
+      do j = 1, mo_num
+        do m = 1, mo_num
+          three_e_single_parrallel_spin_prov(m,j,k,i) = three_e_single_parrallel_spin(m,j,k,i)
+        enddo
+      enddo
+    enddo
+  enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+  call wall_time(wall1)
+  print *, ' wall time for three_e_single_parrallel_spin_prov', wall1 - wall0
+
+END_PROVIDER 
+
+
+! ---
+
+BEGIN_PROVIDER [ double precision, three_e_double_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num, mo_num)]
+
+  BEGIN_DOC
+  !
+  ! matrix element of the -L  three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
+  !
+  ! three_e_double_parrallel_spin_prov(m,l,j,k,i) = <mlk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
+  !
+  ! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
+  END_DOC
+
+  implicit none
+  integer          :: i, j, k, m, l
+  double precision :: integral, wall1, wall0, three_e_double_parrallel_spin
+
+  three_e_double_parrallel_spin_prov = 0.d0
+  print *, ' Providing the three_e_double_parrallel_spin_prov ...'
+  call wall_time(wall0)
+
+ integral = three_e_double_parrallel_spin(1,1,1,1,1)
+ !$OMP PARALLEL                     &
+ !$OMP DEFAULT (NONE)               &
+ !$OMP PRIVATE (i,j,k,m,l,integral) & 
+ !$OMP SHARED (mo_num,three_e_double_parrallel_spin_prov)
+ !$OMP DO SCHEDULE (dynamic)
+  do i = 1, mo_num
+    do k = 1, mo_num
+      do j = 1, mo_num
+        do l = 1, mo_num
+          do m = 1, mo_num
+            three_e_double_parrallel_spin_prov(m,l,j,k,i) = three_e_double_parrallel_spin(m,l,j,k,i)
+          enddo
+        enddo
+      enddo
+    enddo
+  enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+  call wall_time(wall1)
+  print *, ' wall time for three_e_double_parrallel_spin_prov', wall1 - wall0
+
+END_PROVIDER 
+

src/tc_bi_ortho/tc_bi_ortho.irp.f

@@ -0,0 +1,61 @@
+program tc_bi_ortho
+  implicit none
+  BEGIN_DOC
+! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together with the energy. Saves the left-right wave functions at the end. 
+  END_DOC
+  print *, 'Hello world'
+  my_grid_becke = .True.
+  my_n_pt_r_grid = 30
+  my_n_pt_a_grid = 50
+  read_wf = .True.
+  touch read_wf
+  touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+  call routine_diag
+! call test
+end
+
+subroutine test
+ implicit none
+ integer :: i,j 
+ double precision :: hmono,htwoe,hthree,htot
+ use bitmasks
+
+ print*,'test'
+! call htilde_mu_mat_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot)
+ call double_htilde_mu_mat_bi_ortho(N_int,psi_det(1,1,1), psi_det(1,1,2), hmono, htwoe, htot)
+ print*,hmono, htwoe,  htot
+
+end
+
+subroutine routine_diag
+ implicit none
+! provide eigval_right_tc_bi_orth
+  provide overlap_bi_ortho
+!  provide htilde_matrix_elmt_bi_ortho
+ integer ::i,j
+ print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1)
+ print*,'e_tc_left_right         = ',e_tc_left_right
+ print*,'e_tilde_bi_orth_00      = ',e_tilde_bi_orth_00
+ print*,'e_pt2_tc_bi_orth        = ',e_pt2_tc_bi_orth
+ print*,'e_pt2_tc_bi_orth_single = ',e_pt2_tc_bi_orth_single
+ print*,'e_pt2_tc_bi_orth_double = ',e_pt2_tc_bi_orth_double
+ print*,'***'
+ print*,'e_corr_bi_orth          = ',e_corr_bi_orth
+ print*,'e_corr_bi_orth_proj     = ',e_corr_bi_orth_proj
+ print*,'e_corr_single_bi_orth   = ',e_corr_single_bi_orth
+ print*,'e_corr_double_bi_orth   = ',e_corr_double_bi_orth
+ print*,'Left/right eigenvectors'
+ do i = 1,N_det
+  write(*,'(I5,X,(100(F12.7,X)))')i,leigvec_tc_bi_orth(i,1),reigvec_tc_bi_orth(i,1)
+ enddo
+ do j=1,N_states
+   do i=1,N_det
+     psi_l_coef_bi_ortho(i,j) = leigvec_tc_bi_orth(i,j)
+     psi_r_coef_bi_ortho(i,j) = reigvec_tc_bi_orth(i,j)
+   enddo
+ enddo
+ SOFT_TOUCH psi_l_coef_bi_ortho psi_r_coef_bi_ortho
+ call save_tc_bi_ortho_wavefunction
+! call routine_save_left_right_bi_ortho
+end
+

src/tc_bi_ortho/tc_bi_ortho_prop.irp.f

@@ -0,0 +1,24 @@
+program tc_bi_ortho_prop
+  implicit none
+  BEGIN_DOC
+! TODO : Put the documentation of the program here
+  END_DOC
+  print *, 'Hello world'
+  my_grid_becke = .True.
+  my_n_pt_r_grid = 30
+  my_n_pt_a_grid = 50
+  read_wf = .True.
+  touch read_wf
+  touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+!  call routine_diag
+ call test
+end
+
+subroutine test
+ implicit none
+ integer :: i
+ print*,'TC Dipole components'
+ do i= 1, 3
+  print*,tc_bi_ortho_dipole(i,1)
+ enddo
+end

src/tc_bi_ortho/tc_cisd_sc2.irp.f

@@ -0,0 +1,24 @@
+program tc_bi_ortho
+  implicit none
+  BEGIN_DOC
+! TODO : Put the documentation of the program here
+  END_DOC
+  print *, 'Hello world'
+  my_grid_becke = .True.
+  my_n_pt_r_grid = 30
+  my_n_pt_a_grid = 50
+  read_wf = .True.
+  touch read_wf
+  touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+
+  call test
+end
+
+subroutine test
+ implicit none
+! double precision, allocatable :: dressing_dets(:),e_corr_dets(:)
+! allocate(dressing_dets(N_det),e_corr_dets(N_det))
+! e_corr_dets = 0.d0
+! call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets)
+  provide eigval_tc_cisd_sc2_bi_ortho
+end

src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f

@@ -0,0 +1,145 @@
+ BEGIN_PROVIDER [ double precision, reigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)]
+&BEGIN_PROVIDER [ double precision, leigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)]
+&BEGIN_PROVIDER [ double precision, eigval_tc_cisd_sc2_bi_ortho, (N_states)]
+ implicit none
+ integer :: it,n_real,degree,i,istate
+ double precision :: e_before, e_current,thr, hmono,htwoe,hthree,accu
+ double precision, allocatable :: e_corr_dets(:),h0j(:), h_sc2(:,:), dressing_dets(:)
+ double precision, allocatable :: leigvec_tc_bi_orth_tmp(:,:),reigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:)
+ allocate(leigvec_tc_bi_orth_tmp(N_det,N_det),reigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det))
+ allocate(e_corr_dets(N_det),h0j(N_det),h_sc2(N_det,N_det),dressing_dets(N_det))
+ allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),eigval_tmp(N_states))
+ dressing_dets = 0.d0
+ do i = 1, N_det
+  call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
+  call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
+  if(degree == 1 .or. degree == 2)then
+   call htilde_mu_mat_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i))
+  endif
+ enddo
+ reigvec_tc_bi_orth_tmp = 0.d0
+ do i = 1, N_det 
+  reigvec_tc_bi_orth_tmp(i,1) = psi_r_coef_bi_ortho(i,1) 
+ enddo
+ vec_tmp = 0.d0
+ do istate = 1, N_states
+  vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate)
+ enddo
+ do istate = N_states+1, n_states_diag
+  vec_tmp(istate,istate) = 1.d0
+ enddo
+ print*,'Diagonalizing the TC CISD '
+ call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav)
+ do i = 1, N_det 
+  e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
+ enddo
+ E_before = eigval_tmp(1)
+ print*,'Starting from ',E_before
+
+ e_current = 10.d0
+ thr = 1.d-5
+ it = 0
+ dressing_dets = 0.d0
+  double precision, allocatable :: H_jj(:),vec_tmp(:,:),eigval_tmp(:)
+  external                         htc_bi_ortho_calc_tdav
+  external                         htcdag_bi_ortho_calc_tdav
+  logical                       :: converged
+ do while (dabs(E_before-E_current).gt.thr)
+  it += 1
+  E_before = E_current
+!  h_sc2 = htilde_matrix_elmt_bi_ortho
+  call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets)
+  do i = 1, N_det
+!   print*,'dressing_dets(i) = ',dressing_dets(i)
+   h_sc2(i,i) += dressing_dets(i)
+  enddo
+  print*,'********************'
+  print*,'iteration       ',it
+!  call non_hrmt_real_diag(N_det,h_sc2,& 
+!       leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,& 
+!       n_real,eigval_right_tmp)
+!  print*,'eigval_right_tmp(1)',eigval_right_tmp(1)
+  vec_tmp = 0.d0
+  do istate = 1, N_states
+   vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate)
+  enddo
+  do istate = N_states+1, n_states_diag
+   vec_tmp(istate,istate) = 1.d0
+  enddo
+  call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav)
+  print*,'outside Davidson'
+  print*,'eigval_tmp(1) = ',eigval_tmp(1)
+  do i = 1, N_det 
+   reigvec_tc_bi_orth_tmp(i,1) = vec_tmp(i,1)
+   e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1)
+  enddo
+!  E_current = eigval_right_tmp(1)
+  E_current = eigval_tmp(1)
+  print*,'it, E(SC)^2 = ',it,E_current
+ enddo
+ eigval_tc_cisd_sc2_bi_ortho(1:N_states) = eigval_right_tmp(1:N_states)
+ reigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = reigvec_tc_bi_orth_tmp(1:N_det,1:N_states)
+ leigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = leigvec_tc_bi_orth_tmp(1:N_det,1:N_states)
+ 
+END_PROVIDER 
+
+subroutine get_cisd_sc2_dressing(dets,e_corr_dets,ndet,dressing_dets)
+ implicit none
+  use bitmasks
+ integer, intent(in) :: ndet
+ integer(bit_kind), intent(in)  :: dets(N_int,2,ndet)
+ double precision, intent(in)   :: e_corr_dets(ndet)
+ double precision, intent(out) :: dressing_dets(ndet)
+ integer, allocatable  :: degree(:),hole(:,:),part(:,:),spin(:,:)
+ integer(bit_kind), allocatable :: hole_part(:,:,:)
+ integer :: i,j,k, exc(0:2,2,2),h1,p1,h2,p2,s1,s2
+ integer(bit_kind) :: xorvec(2,N_int)
+
+ double precision :: phase
+ dressing_dets = 0.d0
+ allocate(degree(ndet),hole(2,ndet),part(2,ndet), spin(2,ndet),hole_part(N_int,2,ndet))
+ do i = 2, ndet
+  call get_excitation_degree(HF_bitmask,dets(1,1,i),degree(i),N_int)
+  do j = 1, N_int
+   hole_part(j,1,i) = xor( HF_bitmask(j,1), dets(j,1,i))
+   hole_part(j,2,i) = xor( HF_bitmask(j,2), dets(j,2,i))
+  enddo
+  if(degree(i) == 1)then
+   call get_single_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int)
+  else if(degree(i) == 2)then
+   call get_double_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int)
+  endif
+  call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+  hole(1,i) = h1
+  hole(2,i) = h2
+  part(1,i) = p1
+  part(2,i) = p2
+  spin(1,i) = s1
+  spin(2,i) = s2
+ enddo
+ 
+ integer :: same
+ if(elec_alpha_num+elec_beta_num<3)return
+ do i = 2, ndet
+  do j = i+1, ndet
+   same = 0
+   if(degree(i) == degree(j) .and. degree(i)==1)cycle
+   do k = 1, N_int
+    xorvec(k,1) = iand(hole_part(k,1,i),hole_part(k,1,j))
+    xorvec(k,2) = iand(hole_part(k,2,i),hole_part(k,2,j))
+    same += popcnt(xorvec(k,1)) + popcnt(xorvec(k,2)) 
+   enddo
+!   print*,'i,j',i,j
+!   call debug_det(dets(1,1,i),N_int) 
+!   call debug_det(hole_part(1,1,i),N_int) 
+!   call debug_det(dets(1,1,j),N_int) 
+!   call debug_det(hole_part(1,1,j),N_int) 
+!   print*,'same = ',same
+   if(same.eq.0)then
+    dressing_dets(i) += e_corr_dets(j)  
+    dressing_dets(j) += e_corr_dets(i)  
+   endif
+  enddo
+ enddo
+ 
+end

src/tc_bi_ortho/tc_h_eigvectors.irp.f

@@ -0,0 +1,183 @@
+  use bitmasks
+
+ BEGIN_PROVIDER [ integer, index_HF_psi_det]                                                                                                            
+ implicit none
+ integer :: i,degree
+ do i = 1, N_det
+   call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
+   if(degree == 0)then
+    index_HF_psi_det = i
+    exit
+   endif
+ enddo
+ END_PROVIDER
+
+
+
+ BEGIN_PROVIDER [double precision, eigval_right_tc_bi_orth, (N_states)]
+&BEGIN_PROVIDER [double precision, eigval_left_tc_bi_orth, (N_states)]
+&BEGIN_PROVIDER [double precision, reigvec_tc_bi_orth, (N_det,N_states)]
+&BEGIN_PROVIDER [double precision, leigvec_tc_bi_orth, (N_det,N_states)]
+&BEGIN_PROVIDER [double precision, norm_ground_left_right_bi_orth ]
+
+  BEGIN_DOC
+  ! eigenvalues, right and left eigenvectors of the transcorrelated Hamiltonian on the BI-ORTHO basis 
+  END_DOC
+
+  implicit none
+  integer                       :: i, idx_dress, j, istate
+  logical                       :: converged, dagger
+  integer                       :: n_real_tc_bi_orth_eigval_right,igood_r,igood_l
+  double precision, allocatable :: reigvec_tc_bi_orth_tmp(:,:),leigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:)
+
+  PROVIDE N_det N_int
+
+   if(n_det.le.N_det_max_full)then
+    allocate(reigvec_tc_bi_orth_tmp(N_det,N_det),leigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det))
+    call non_hrmt_real_diag(N_det,htilde_matrix_elmt_bi_ortho,& 
+         leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,& 
+         n_real_tc_bi_orth_eigval_right,eigval_right_tmp)
+    double precision, allocatable :: coef_hf_r(:),coef_hf_l(:)
+    integer, allocatable :: iorder(:)
+    allocate(coef_hf_r(N_det),coef_hf_l(N_det),iorder(N_det))
+    do i = 1,N_det
+     iorder(i) = i
+     coef_hf_r(i) = -dabs(reigvec_tc_bi_orth_tmp(index_HF_psi_det,i))
+    enddo
+    call dsort(coef_hf_r,iorder,N_det)
+    igood_r = iorder(1)
+    print*,'igood_r, coef_hf_r = ',igood_r,coef_hf_r(1)
+    do i = 1,N_det
+     iorder(i) = i
+     coef_hf_l(i) = -dabs(leigvec_tc_bi_orth_tmp(index_HF_psi_det,i))
+    enddo
+    call dsort(coef_hf_l,iorder,N_det)
+    igood_l = iorder(1)
+    print*,'igood_l, coef_hf_l = ',igood_l,coef_hf_l(1)
+
+    if(igood_r.ne.igood_l.and.igood_r.ne.1)then
+     print *,''
+     print *,'Warning, the left and right eigenvectors are "not the same" '
+     print *,'Warning, the ground state is not dominated by HF...'
+     print *,'State with largest RIGHT coefficient of HF ',igood_r
+     print *,'coef of HF in RIGHT eigenvector = ',reigvec_tc_bi_orth_tmp(index_HF_psi_det,igood_r)
+     print *,'State with largest LEFT  coefficient of HF ',igood_l
+     print *,'coef of HF in LEFT  eigenvector = ',leigvec_tc_bi_orth_tmp(index_HF_psi_det,igood_l)
+    endif
+    if(state_following_tc)then
+     print *,'Following the states with the largest coef on HF'
+     print *,'igood_r,igood_l',igood_r,igood_l
+     i= igood_r
+     eigval_right_tc_bi_orth(1) = eigval_right_tmp(i)
+     do j = 1, N_det
+       reigvec_tc_bi_orth(j,1) = reigvec_tc_bi_orth_tmp(j,i)
+!       print*,reigvec_tc_bi_orth(j,1)
+     enddo
+     i= igood_l
+     eigval_left_tc_bi_orth(1)  = eigval_right_tmp(i)
+     do j = 1, N_det
+       leigvec_tc_bi_orth(j,1) = leigvec_tc_bi_orth_tmp(j,i)
+     enddo
+    else 
+     do i = 1, N_states
+       eigval_right_tc_bi_orth(i) = eigval_right_tmp(i)
+       eigval_left_tc_bi_orth(i)  = eigval_right_tmp(i)
+       do j = 1, N_det
+         reigvec_tc_bi_orth(j,i) = reigvec_tc_bi_orth_tmp(j,i)
+         leigvec_tc_bi_orth(j,i) = leigvec_tc_bi_orth_tmp(j,i)
+       enddo
+     enddo
+    endif
+   else 
+    double precision, allocatable :: H_jj(:),vec_tmp(:,:)
+    external                         htc_bi_ortho_calc_tdav
+    external                         htcdag_bi_ortho_calc_tdav
+    external                         H_tc_u_0_opt
+    external                         H_tc_dagger_u_0_opt
+    allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag))
+    do i = 1, N_det
+      call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
+    enddo
+ !!!! Preparing the left-eigenvector
+    print*,'Computing the left-eigenvector '
+    vec_tmp = 0.d0
+    do istate = 1, N_states
+     vec_tmp(1:N_det,istate) = psi_l_coef_bi_ortho(1:N_det,istate)
+    enddo
+    do istate = N_states+1, n_states_diag
+     vec_tmp(istate,istate) = 1.d0
+    enddo
+!    call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, converged, htcdag_bi_ortho_calc_tdav)
+    call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, converged, H_tc_dagger_u_0_opt)
+    do istate = 1, N_states
+     leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
+    enddo
+
+    print*,'Computing the right-eigenvector '
+ !!!! Preparing the right-eigenvector
+    vec_tmp = 0.d0
+    do istate = 1, N_states
+     vec_tmp(1:N_det,istate) = psi_r_coef_bi_ortho(1:N_det,istate)
+    enddo
+    do istate = N_states+1, n_states_diag
+     vec_tmp(istate,istate) = 1.d0
+    enddo
+!    call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav)
+    call davidson_general_ext_rout_nonsym_b1space(vec_tmp, H_jj, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, converged, H_tc_u_0_opt)
+    do istate = 1, N_states
+     reigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
+    enddo
+
+    deallocate(H_jj)
+   endif
+  call bi_normalize(leigvec_tc_bi_orth,reigvec_tc_bi_orth,size(reigvec_tc_bi_orth,1),N_det,N_states)
+   print*,'leigvec_tc_bi_orth(1,1),reigvec_tc_bi_orth(1,1) = ',leigvec_tc_bi_orth(1,1),reigvec_tc_bi_orth(1,1)
+   norm_ground_left_right_bi_orth = 0.d0
+   do j = 1, N_det
+    norm_ground_left_right_bi_orth += leigvec_tc_bi_orth(j,1) * reigvec_tc_bi_orth(j,1)
+   enddo
+   print*,'norm l/r = ',norm_ground_left_right_bi_orth
+
+END_PROVIDER 
+
+
+
+subroutine bi_normalize(u_l,u_r,n,ld,nstates)
+  !!!! Normalization of the scalar product of the left/right eigenvectors
+  double precision, intent(inout) :: u_l(ld,nstates), u_r(ld,nstates)
+  integer, intent(in) :: n,ld,nstates
+  integer :: i
+  double precision  :: accu, tmp 
+  do i = 1, nstates
+   !!!! Normalization of right eigenvectors |Phi>
+   accu = 0.d0
+   do j = 1, n
+    accu += u_r(j,i) * u_r(j,i)
+   enddo
+   accu = 1.d0/dsqrt(accu)
+   print*,'accu_r = ',accu
+   do j = 1, n
+    u_r(j,i) *= accu 
+   enddo
+   tmp = u_r(1,i) / dabs(u_r(1,i))
+   do j = 1, n
+    u_r(j,i) *= tmp
+   enddo
+   !!!! Adaptation of the norm of the left eigenvector such that <chi|Phi> = 1
+   accu = 0.d0
+   do j = 1, n
+    accu += u_l(j,i) * u_r(j,i)
+!    print*,j, u_l(j,i) , u_r(j,i)
+   enddo
+   if(accu.gt.0.d0)then
+    accu = 1.d0/dsqrt(accu)
+   else
+    accu = 1.d0/dsqrt(-accu)
+   endif
+   tmp = (u_l(1,i) * u_r(1,i) )/dabs(u_l(1,i) * u_r(1,i))
+   do j = 1, n
+    u_l(j,i) *= accu * tmp
+    u_r(j,i) *= accu 
+   enddo
+  enddo
+end

src/tc_bi_ortho/tc_hmat.irp.f

@@ -0,0 +1,45 @@
+
+ BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)]
+
+  BEGIN_DOC
+  ! htilde_matrix_elmt_bi_ortho(j,i) = <J| H^tilde |I> 
+  !
+  ! WARNING !!!!!!!!! IT IS NOT HERMITIAN !!!!!!!!!
+  END_DOC
+ 
+  implicit none
+  integer          :: i, j
+  double precision :: hmono,htwoe,hthree,htot
+
+  PROVIDE N_int
+ !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hmono, htwoe, hthree, htot) &
+ !$OMP SHARED (N_det, psi_det, N_int,htilde_matrix_elmt_bi_ortho)
+    do i = 1, N_det
+      do j = 1, N_det
+        ! < J | Htilde | I >
+        call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+
+        !print *, ' hmono  = ', hmono
+        !print *, ' htwoe  = ', htwoe
+        !print *, ' hthree = ', hthree
+        htilde_matrix_elmt_bi_ortho(j,i) = htot
+      enddo
+    enddo
+ !$OMP END PARALLEL DO
+! print*,'htilde_matrix_elmt_bi_ortho = '
+! do i = 1, min(100,N_det)
+!  write(*,'(100(F16.10,X))')htilde_matrix_elmt_bi_ortho(1:min(100,N_det),i)
+! enddo
+
+
+END_PROVIDER 
+
+ BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho_tranp, (N_det,N_det)]
+ implicit none
+ integer ::i,j
+  do i = 1, N_det
+    do j = 1, N_det
+      htilde_matrix_elmt_bi_ortho_tranp(j,i) = htilde_matrix_elmt_bi_ortho(i,j)
+    enddo
+  enddo
+END_PROVIDER 

src/tc_bi_ortho/tc_natorb.irp.f

@@ -0,0 +1,218 @@
+
+! ---
+
+ BEGIN_PROVIDER [ double precision, natorb_tc_reigvec_mo, (mo_num, mo_num)]
+&BEGIN_PROVIDER [ double precision, natorb_tc_leigvec_mo, (mo_num, mo_num)]
+&BEGIN_PROVIDER [ double precision, natorb_tc_eigval, (mo_num)]
+
+  BEGIN_DOC
+  !
+  ! natorb_tc_reigvec_mo : RIGHT eigenvectors of the ground state transition matrix (equivalent of natural orbitals)
+  ! natorb_tc_leigvec_mo : LEFT  eigenvectors of the ground state transition matrix (equivalent of natural orbitals)
+  ! natorb_tc_eigval     : eigenvalues of the ground state transition matrix (equivalent of the occupation numbers). WARNINING :: can be negative !!
+  !
+  END_DOC
+
+  implicit none
+  integer                       :: i, j, k
+  double precision              :: thr_d, thr_nd, thr_deg, accu
+  double precision              :: accu_d, accu_nd
+  double precision, allocatable :: dm_tmp(:,:), fock_diag(:)
+
+  allocate(dm_tmp(mo_num,mo_num), fock_diag(mo_num))
+
+  dm_tmp(:,:) = -tc_transition_matrix(:,:,1,1)
+
+  print *, ' dm_tmp'
+  do i = 1, mo_num
+    fock_diag(i) = fock_matrix_tc_mo_tot(i,i)
+    write(*, '(100(F16.10,X))') -dm_tmp(:,i)
+  enddo
+
+  thr_d   = 1.d-6
+  thr_nd  = 1.d-6
+  thr_deg = 1.d-3
+  call diag_mat_per_fock_degen( fock_diag, dm_tmp, mo_num, thr_d, thr_nd, thr_deg & 
+                              , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo, natorb_tc_eigval)
+!   call non_hrmt_bieig( mo_num, dm_tmp&
+!                      , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo& 
+!                      , mo_num, natorb_tc_eigval )
+
+  accu = 0.d0
+  do i = 1, mo_num
+    print*,'natorb_tc_eigval(i) = ',-natorb_tc_eigval(i)
+    accu += -natorb_tc_eigval(i)
+  enddo
+  print *, ' accu = ', accu
+
+  dm_tmp = 0.d0
+  do i = 1, mo_num
+    accu = 0.d0
+    do k = 1, mo_num
+      accu += natorb_tc_reigvec_mo(k,i) * natorb_tc_leigvec_mo(k,i)
+    enddo
+    accu = 1.d0/dsqrt(dabs(accu))
+    natorb_tc_reigvec_mo(:,i) *= accu
+    natorb_tc_leigvec_mo(:,i) *= accu
+    do j = 1, mo_num
+      do k = 1, mo_num
+        dm_tmp(j,i) += natorb_tc_reigvec_mo(k,i) * natorb_tc_leigvec_mo(k,j)
+      enddo
+    enddo
+  enddo
+
+  accu_d  = 0.d0
+  accu_nd = 0.d0
+  do i = 1, mo_num
+    accu_d += dm_tmp(i,i)
+    !write(*,'(100(F16.10,X))')dm_tmp(:,i)
+    do j = 1, mo_num
+      if(i==j)cycle
+      accu_nd += dabs(dm_tmp(j,i))
+    enddo
+  enddo
+  print *, ' Trace of the overlap between TC natural orbitals     ', accu_d
+  print *, ' L1 norm of extra diagonal elements of overlap matrix ', accu_nd
+
+  deallocate(dm_tmp, fock_diag)
+ 
+END_PROVIDER 
+
+! ---
+ 
+ BEGIN_PROVIDER [ double precision, fock_diag_sorted_r_natorb, (mo_num, mo_num)]
+&BEGIN_PROVIDER [ double precision, fock_diag_sorted_l_natorb, (mo_num, mo_num)]
+&BEGIN_PROVIDER [ double precision, fock_diag_sorted_v_natorb, (mo_num)]
+
+  implicit none
+  integer                       :: i,j,k
+  integer,          allocatable :: iorder(:)
+  double precision, allocatable :: fock_diag(:)
+
+  print *, ' Diagonal elements of the Fock matrix before '
+
+  do i = 1, mo_num
+   write(*,*) i, Fock_matrix_tc_mo_tot(i,i)
+  enddo
+
+  allocate(fock_diag(mo_num))
+  fock_diag = 0.d0
+  do i = 1, mo_num
+    fock_diag(i) = 0.d0
+    do j = 1, mo_num
+      do k = 1, mo_num
+        fock_diag(i) += natorb_tc_leigvec_mo(k,i) * Fock_matrix_tc_mo_tot(k,j) * natorb_tc_reigvec_mo(j,i) 
+      enddo
+    enddo
+  enddo
+
+  allocate(iorder(mo_num))
+  do i = 1, mo_num
+   iorder(i) = i
+  enddo 
+  call dsort(fock_diag, iorder, mo_num)
+
+  print *, ' Diagonal elements of the Fock matrix after '
+  do i = 1, mo_num
+   write(*,*) i, fock_diag(i)
+  enddo
+  deallocate(fock_diag)
+
+  do i = 1, mo_num 
+    fock_diag_sorted_v_natorb(i) = natorb_tc_eigval(iorder(i))
+    do j = 1, mo_num
+      fock_diag_sorted_r_natorb(j,i) = natorb_tc_reigvec_mo(j,iorder(i))
+      fock_diag_sorted_l_natorb(j,i) = natorb_tc_leigvec_mo(j,iorder(i))
+    enddo
+  enddo
+  deallocate(iorder)
+ 
+END_PROVIDER 
+ 
+! --- 
+ 
+ BEGIN_PROVIDER [ double precision, natorb_tc_reigvec_ao, (ao_num, mo_num)]
+&BEGIN_PROVIDER [ double precision, natorb_tc_leigvec_ao, (ao_num, mo_num)]
+&BEGIN_PROVIDER [ double precision, overlap_natorb_tc_eigvec_ao, (mo_num, mo_num) ]
+ 
+  BEGIN_DOC
+  ! EIGENVECTORS OF FOCK MATRIX ON THE AO BASIS and their OVERLAP
+  !
+  ! THE OVERLAP SHOULD BE THE SAME AS overlap_natorb_tc_eigvec_mo
+  END_DOC
+ 
+  implicit none
+  integer                       :: i, j, k, q, p
+  double precision              :: accu, accu_d
+  double precision, allocatable :: tmp(:,:)
+ 
+ 
+ !  ! MO_R x R
+   call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0          &
+             , mo_r_coef, size(mo_r_coef, 1)                   &
+             , fock_diag_sorted_r_natorb, size(fock_diag_sorted_r_natorb, 1) &
+             , 0.d0, natorb_tc_reigvec_ao, size(natorb_tc_reigvec_ao, 1) )
+ !
+   ! MO_L x L
+   call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0          &
+             , mo_l_coef, size(mo_l_coef, 1)                   &
+             , fock_diag_sorted_l_natorb, size(fock_diag_sorted_l_natorb, 1) &
+             , 0.d0, natorb_tc_leigvec_ao, size(natorb_tc_leigvec_ao, 1) )
+ 
+ 
+   allocate( tmp(mo_num,ao_num) )
+ 
+   ! tmp <-- L.T x S_ao
+   call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0                                           &
+             , natorb_tc_leigvec_ao, size(natorb_tc_leigvec_ao, 1), ao_overlap, size(ao_overlap, 1) &
+             , 0.d0, tmp, size(tmp, 1) )
+ 
+   ! S <-- tmp x R
+   call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0                             &
+             , tmp, size(tmp, 1), natorb_tc_reigvec_ao, size(natorb_tc_reigvec_ao, 1) &
+             , 0.d0, overlap_natorb_tc_eigvec_ao, size(overlap_natorb_tc_eigvec_ao, 1) )
+ 
+   deallocate( tmp )
+ 
+   ! ---
+   double precision :: norm
+   do i = 1, mo_num
+    norm = 1.d0/dsqrt(dabs(overlap_natorb_tc_eigvec_ao(i,i)))
+    do j = 1, mo_num
+     natorb_tc_reigvec_ao(j,i) *= norm
+     natorb_tc_leigvec_ao(j,i) *= norm
+    enddo
+   enddo
+ 
+   allocate( tmp(mo_num,ao_num) )
+ 
+   ! tmp <-- L.T x S_ao
+   call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0                                           &
+             , natorb_tc_leigvec_ao, size(natorb_tc_leigvec_ao, 1), ao_overlap, size(ao_overlap, 1) &
+             , 0.d0, tmp, size(tmp, 1) )
+ 
+   ! S <-- tmp x R
+   call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0                             &
+             , tmp, size(tmp, 1), natorb_tc_reigvec_ao, size(natorb_tc_reigvec_ao, 1) &
+             , 0.d0, overlap_natorb_tc_eigvec_ao, size(overlap_natorb_tc_eigvec_ao, 1) )
+ 
+ 
+ 
+   deallocate( tmp )
+ 
+   accu_d = 0.d0
+   accu = 0.d0
+   do i = 1, mo_num
+     accu_d += overlap_natorb_tc_eigvec_ao(i,i)
+     do j = 1, mo_num
+       if(i==j)cycle
+       accu += dabs(overlap_natorb_tc_eigvec_ao(j,i))
+     enddo
+   enddo
+   print*,'Trace of the overlap_natorb_tc_eigvec_ao           = ',accu_d
+   print*,'mo_num                                             = ',mo_num
+   print*,'L1 norm of extra diagonal elements of overlap matrix ',accu
+   accu = accu / dble(mo_num**2)
+ 
+ END_PROVIDER
+

src/tc_bi_ortho/tc_prop.irp.f

@@ -0,0 +1,80 @@
+
+BEGIN_PROVIDER [ double precision, tc_transition_matrix, (mo_num, mo_num,N_states,N_states) ]
+ implicit none
+ BEGIN_DOC
+ ! tc_transition_matrix(p,h,istate,jstate) = <Chi_istate| a^\dagger_p a_h |Phi_jstate>
+ !
+ ! where <Chi_istate| and |Phi_jstate> are the left/right eigenvectors on a bi-ortho basis
+ END_DOC
+ integer :: i,j,istate,jstate,m,n,p,h
+ double precision :: phase
+ integer, allocatable           :: occ(:,:)
+ integer                        :: n_occ_ab(2),degree,exc(0:2,2,2)
+ allocate(occ(N_int*bit_kind_size,2))
+ tc_transition_matrix = 0.d0
+ do istate = 1, N_states
+  do jstate = 1, N_states
+   do i = 1, N_det
+    do j = 1, N_det
+     call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int)
+     if(degree.gt.1)then
+      cycle
+     else if (degree == 0)then
+      call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int)
+      do p = 1, n_occ_ab(1) ! browsing the alpha electrons
+       m = occ(p,1)
+       tc_transition_matrix(m,m,istate,jstate)+= psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,jstate)
+      enddo
+      do p = 1, n_occ_ab(2) ! browsing the beta electrons
+       m = occ(p,1)
+       tc_transition_matrix(m,m,istate,jstate)+= psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,jstate)
+      enddo
+     else
+      call get_single_excitation(psi_det(1,1,j),psi_det(1,1,i),exc,phase,N_int)
+      if (exc(0,1,1) == 1) then
+        ! Single alpha
+        h = exc(1,1,1) ! hole in psi_det(1,1,j) 
+        p = exc(1,2,1) ! particle in psi_det(1,1,j) 
+      else
+        ! Single beta
+        h = exc(1,1,2) ! hole in psi_det(1,1,j) 
+        p = exc(1,2,2) ! particle in psi_det(1,1,j) 
+      endif
+      tc_transition_matrix(p,h,istate,jstate)+= phase * psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,jstate)
+     endif
+    enddo
+   enddo
+  enddo
+ enddo
+ END_PROVIDER
+
+
+ BEGIN_PROVIDER [double precision, tc_bi_ortho_dipole, (3,N_states)]
+ implicit none
+ integer :: i,j,istate,m
+ double precision :: nuclei_part(3)
+ tc_bi_ortho_dipole = 0.d0
+ do istate = 1, N_states
+  do i = 1, mo_num
+   do j = 1, mo_num
+    tc_bi_ortho_dipole(1,istate) += -(tc_transition_matrix(j,i,istate,istate)) *  mo_bi_orth_bipole_x(j,i)
+    tc_bi_ortho_dipole(2,istate) += -(tc_transition_matrix(j,i,istate,istate)) *  mo_bi_orth_bipole_y(j,i)
+    tc_bi_ortho_dipole(3,istate) += -(tc_transition_matrix(j,i,istate,istate)) *  mo_bi_orth_bipole_z(j,i)
+   enddo
+  enddo
+ enddo
+
+ nuclei_part = 0.d0
+ do m = 1, 3
+  do i = 1,nucl_num
+   nuclei_part(m) += nucl_charge(i) * nucl_coord(i,m)
+  enddo
+ enddo
+!
+ do istate = 1, N_states
+  do m = 1, 3
+    tc_bi_ortho_dipole(m,istate) += nuclei_part(m)
+  enddo
+ enddo
+ END_PROVIDER
+

src/tc_bi_ortho/tc_som.irp.f

@@ -0,0 +1,70 @@
+! ---
+
+program tc_som
+
+  BEGIN_DOC
+  ! TODO : Put the documentation of the program here
+  END_DOC
+
+  implicit none
+
+  print *, ' starting ...'
+  print *, ' do not forget to do tc-scf first'
+
+  my_grid_becke  = .True.
+  my_n_pt_r_grid = 30
+  my_n_pt_a_grid = 50
+!  my_n_pt_r_grid = 10 ! small grid for quick debug
+!  my_n_pt_a_grid = 26 ! small grid for quick debug
+  touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+
+  PROVIDE mu_erf 
+  print *, ' mu = ', mu_erf
+  PROVIDE j1b_type
+  print *, ' j1b_type = ', j1b_type
+  print *, j1b_pen
+
+  read_wf = .true.
+  touch read_wf
+
+  call main()
+
+end
+
+! ---
+
+subroutine main()
+
+  implicit none
+  integer          :: i, i_HF, degree
+  double precision :: hmono_1, htwoe_1, hthree_1, htot_1
+  double precision :: hmono_2, htwoe_2, hthree_2, htot_2
+  double precision :: U_SOM
+
+  PROVIDE N_int N_det
+
+  do i = 1, N_det
+    call get_excitation_degree(HF_bitmask, psi_det(1,1,i), degree, N_int)
+    if(degree == 0) then
+      i_HF = i
+      exit
+    endif
+  enddo
+  print *, ' HF determinants:', i_HF
+  print *, '          N_det :', N_det
+
+  U_SOM = 0.d0 
+  do i = 1, N_det
+    if(i == i_HF) cycle
+    call htilde_mu_mat_bi_ortho(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1)
+    call htilde_mu_mat_bi_ortho(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
+    U_SOM += htot_1 * htot_2
+  enddo
+  U_SOM = 0.5d0 * U_SOM
+  print *, ' U_SOM = ', U_SOM
+  
+  return
+end subroutine main
+
+! ---
+

src/tc_bi_ortho/test_natorb.irp.f

@@ -0,0 +1,51 @@
+program test_natorb
+  implicit none
+  BEGIN_DOC
+! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together with the energy. Saves the left-right wave functions at the end. 
+  END_DOC
+  print *, 'Hello world'
+  my_grid_becke = .True.
+  my_n_pt_r_grid = 30
+  my_n_pt_a_grid = 50
+  read_wf = .True.
+  touch read_wf
+  touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+ call routine
+! call test
+
+end
+
+subroutine routine
+ implicit none
+ double precision, allocatable :: fock_diag(:),eigval(:),leigvec(:,:),reigvec(:,:),mat_ref(:,:)
+ allocate(eigval(mo_num),leigvec(mo_num,mo_num),reigvec(mo_num,mo_num),fock_diag(mo_num),mat_ref(mo_num, mo_num))
+ double precision, allocatable :: eigval_ref(:),leigvec_ref(:,:),reigvec_ref(:,:)
+ allocate(eigval_ref(mo_num),leigvec_ref(mo_num,mo_num),reigvec_ref(mo_num,mo_num))
+ 
+ double precision :: thr_deg
+ integer :: i,n_real,j
+ print*,'fock_matrix'
+ do i = 1, mo_num
+  fock_diag(i) = Fock_matrix_mo(i,i)
+  print*,i,fock_diag(i)
+ enddo
+ thr_deg = 1.d-6
+ mat_ref = -one_e_dm_mo
+ print*,'diagonalization by block'
+ call diag_mat_per_fock_degen(fock_diag,mat_ref,mo_num,thr_deg,leigvec,reigvec,eigval)
+ call non_hrmt_bieig( mo_num, mat_ref&
+                     , leigvec_ref, reigvec_ref& 
+                     , n_real, eigval_ref)
+ print*,'TEST ***********************************'
+ double precision :: accu_l, accu_r
+ do i = 1, mo_num
+  accu_l = 0.d0
+  accu_r = 0.d0
+  do j = 1, mo_num
+   accu_r += reigvec_ref(j,i) * reigvec(j,i)
+   accu_l += leigvec_ref(j,i) * leigvec(j,i)
+  enddo
+  print*,i
+  write(*,'(I3,X,100(F16.10,X))')i,eigval(i),eigval_ref(i),accu_l,accu_r
+ enddo
+end

src/tc_bi_ortho/test_normal_order.irp.f

@@ -0,0 +1,131 @@
+program test_normal_order
+  implicit none
+  BEGIN_DOC
+! TODO : Put the documentation of the program here
+  END_DOC
+  print *, 'Hello world'
+  my_grid_becke = .True.
+  my_n_pt_r_grid = 30
+  my_n_pt_a_grid = 50
+  read_wf = .True.
+  touch read_wf
+  touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+  call provide_all_three_ints_bi_ortho
+  call test
+end
+
+subroutine test
+ implicit none
+  use bitmasks ! you need to include the bitmasks_module.f90 features
+ integer :: h1,h2,p1,p2,s1,s2,i_ok,degree,Ne(2)
+ integer                        :: exc(0:2,2,2)
+ integer(bit_kind), allocatable :: det_i(:,:)
+ double precision :: hmono,htwoe,hthree,htilde_ij,accu,phase,normal
+ integer,           allocatable :: occ(:,:)
+ allocate( occ(N_int*bit_kind_size,2) )
+ call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int)
+ allocate(det_i(N_int,2))
+ s1 = 1 
+ s2 = 2
+ accu = 0.d0
+ do h1 = 1, elec_beta_num
+  do p1 = elec_alpha_num+1, mo_num
+   do h2 = 1, elec_beta_num
+    do p2 = elec_beta_num+1, mo_num
+     det_i = ref_bitmask
+     call do_single_excitation(det_i,h1,p1,s1,i_ok)
+     call do_single_excitation(det_i,h2,p2,s2,i_ok)
+     call htilde_mu_mat_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
+     call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
+     call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
+     hthree *= phase
+!    !normal = normal_two_body_bi_orth_ab(p2,h2,p1,h1)
+     call three_comp_two_e_elem(det_i,h1,h2,p1,p2,s1,s2,normal)
+!     normal = eff_2_e_from_3_e_ab(p2,p1,h2,h1)
+     accu += dabs(hthree-normal)
+    enddo
+   enddo
+  enddo
+ enddo
+print*,'accu opposite spin = ',accu
+stop
+
+!    p2=6
+!    p1=5
+!    h2=2
+!    h1=1
+
+s1 = 1 
+s2 = 1
+accu = 0.d0
+do h1 = 1, elec_alpha_num
+ do p1 = elec_alpha_num+1, mo_num
+  do p2 = p1+1, mo_num
+   do h2 = h1+1, elec_alpha_num
+    det_i = ref_bitmask
+    call do_single_excitation(det_i,h1,p1,s1,i_ok)
+    if(i_ok.ne.1)cycle
+    call do_single_excitation(det_i,h2,p2,s2,i_ok)
+    if(i_ok.ne.1)cycle
+    call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
+    call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
+    call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
+    integer :: hh1, pp1, hh2, pp2, ss1, ss2
+    call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
+    hthree *= phase
+!    normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
+     normal = eff_2_e_from_3_e_aa(p2,p1,h2,h1)
+    if(dabs(hthree).lt.1.d-10)cycle
+    if(dabs(hthree-normal).gt.1.d-10)then
+     print*,pp2,pp1,hh2,hh1
+     print*,p2,p1,h2,h1
+     print*,hthree,normal,dabs(hthree-normal)
+     stop
+    endif
+!     print*,hthree,normal,dabs(hthree-normal)
+    accu += dabs(hthree-normal)
+   enddo
+  enddo
+ enddo
+enddo
+print*,'accu same spin alpha = ',accu
+
+
+s1 = 2 
+s2 = 2
+accu = 0.d0
+do h1 = 1, elec_beta_num
+ do p1 = elec_beta_num+1, mo_num
+  do p2 = p1+1, mo_num
+   do h2 = h1+1, elec_beta_num
+    det_i = ref_bitmask
+    call do_single_excitation(det_i,h1,p1,s1,i_ok)
+    if(i_ok.ne.1)cycle
+    call do_single_excitation(det_i,h2,p2,s2,i_ok)
+    if(i_ok.ne.1)cycle
+    call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
+    call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
+    call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
+    call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
+    hthree *= phase
+!    normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
+     normal = eff_2_e_from_3_e_bb(p2,p1,h2,h1)
+    if(dabs(hthree).lt.1.d-10)cycle
+    if(dabs(hthree-normal).gt.1.d-10)then
+     print*,pp2,pp1,hh2,hh1
+     print*,p2,p1,h2,h1
+     print*,hthree,normal,dabs(hthree-normal)
+     stop
+    endif
+!     print*,hthree,normal,dabs(hthree-normal)
+    accu += dabs(hthree-normal)
+   enddo
+  enddo
+ enddo
+enddo
+print*,'accu same spin beta  = ',accu
+
+
+end
+
+

src/tc_bi_ortho/test_tc_bi_ortho.irp.f

@@ -0,0 +1,254 @@
+program tc_bi_ortho
+  implicit none
+  BEGIN_DOC
+! TODO : Put the documentation of the program here
+  END_DOC
+  print *, 'Hello world'
+  my_grid_becke = .True.
+  my_n_pt_r_grid = 30
+  my_n_pt_a_grid = 50
+  read_wf = .True.
+  touch read_wf
+  touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+
+ call test_h_u0
+! call test_slater_tc_opt
+! call timing_tot
+! call timing_diag
+! call timing_single
+! call timing_double
+end
+
+subroutine test_h_u0
+ implicit none
+ double precision, allocatable :: v_0_ref(:),v_0_new(:),u_0(:), v_0_ref_dagger(:)
+ double precision :: accu 
+ logical :: do_right
+ integer :: i
+ allocate(v_0_new(N_det),v_0_ref(N_det),u_0(N_det),v_0_ref_dagger(N_det))
+ do_right = .True.
+ do i = 1, N_det
+  u_0(i) = psi_r_coef_bi_ortho(i,1)
+ enddo
+ call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right)
+ call htc_bi_ortho_calc_tdav (v_0_ref,u_0,N_states,N_det)
+ print*,'difference right '
+ accu = 0.d0
+ do i = 1, N_det
+  print*,dabs(v_0_new(i) - v_0_ref(i)),v_0_new(i) , v_0_ref(i)
+  accu += dabs(v_0_new(i) - v_0_ref(i))
+ enddo
+ print*,'accu = ',accu
+ do_right = .False.
+ v_0_new = 0.d0
+ call H_tc_u_0_nstates_openmp(v_0_new,u_0,N_states,N_det, do_right)
+ call htcdag_bi_ortho_calc_tdav(v_0_ref_dagger,u_0,N_states,N_det, do_right)
+ print*,'difference left'
+ accu = 0.d0
+ do i = 1, N_det
+  print*,dabs(v_0_new(i) - v_0_ref_dagger(i)),v_0_new(i) , v_0_ref_dagger(i)
+  accu += dabs(v_0_new(i) - v_0_ref_dagger(i))
+ enddo
+ print*,'accu = ',accu
+end
+
+subroutine test_slater_tc_opt
+ implicit none
+ integer :: i,j,degree
+ double precision :: hmono, htwoe, htot, hthree 
+ double precision :: hnewmono, hnewtwoe, hnewthree, hnewtot
+ double precision :: accu_d ,i_count, accu
+ accu = 0.d0
+ accu_d = 0.d0
+ i_count = 0.d0
+ do i = 1, N_det
+  do j = 1,N_det
+   call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+   call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hnewmono, hnewtwoe, hnewthree, hnewtot)
+   if(dabs(htot).gt.1.d-15)then
+     i_count += 1.D0
+     accu += dabs(htot-hnewtot) 
+     if(dabs(htot-hnewtot).gt.1.d-8.or.dabs(htot-hnewtot).gt.dabs(htot))then
+      call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
+      print*,j,i,degree
+      call debug_det(psi_det(1,1,i),N_int)
+      call debug_det(psi_det(1,1,j),N_int)
+      print*,htot,hnewtot,dabs(htot-hnewtot)
+      print*,hthree,hnewthree,dabs(hthree-hnewthree)
+      stop
+     endif
+   endif
+  enddo
+ enddo
+ print*,'accu   = ',accu/i_count
+
+end
+
+subroutine timing_tot
+ implicit none
+ integer :: i,j
+ double precision :: wall0, wall1
+ double precision, allocatable :: mat_old(:,:),mat_new(:,:)
+ double precision :: hmono, htwoe, hthree, htot, i_count
+ integer :: degree 
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot)
+ call wall_time(wall0)
+ i_count = 0.d0
+ do i = 1, N_det
+  do j = 1, N_det
+!   call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
+   i_count += 1.d0
+   call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+  enddo
+ enddo
+ call wall_time(wall1)
+ print*,'i_count = ',i_count
+ print*,'time for old hij for total   = ',wall1 - wall0
+
+ call wall_time(wall0)
+ i_count = 0.d0
+ do i = 1, N_det
+  do j = 1, N_det
+!   call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
+   i_count += 1.d0
+   call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+  enddo
+ enddo
+ call wall_time(wall1)
+ print*,'i_count = ',i_count
+ print*,'time for new hij for total   = ',wall1 - wall0
+ call i_H_j(psi_det(1,1,1), psi_det(1,1,2),N_int,htot)
+ call wall_time(wall0)
+ i_count = 0.d0
+ do i = 1, N_det
+  do j = 1, N_det
+   call i_H_j(psi_det(1,1,j), psi_det(1,1,i),N_int,htot)
+   i_count += 1.d0
+  enddo
+ enddo
+ call wall_time(wall1)
+ print*,'i_count = ',i_count
+ print*,'time for new hij STANDARD    = ',wall1 - wall0
+
+end
+
+subroutine timing_diag
+ implicit none
+ integer :: i,j
+ double precision :: wall0, wall1
+ double precision, allocatable :: mat_old(:,:),mat_new(:,:)
+ double precision :: hmono, htwoe, hthree, htot, i_count
+ integer :: degree 
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
+ call wall_time(wall0)
+ i_count = 0.d0
+ do i = 1, N_det
+  do j = i,i 
+   i_count += 1.d0
+   call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+  enddo
+ enddo
+ call wall_time(wall1)
+ print*,'i_count = ',i_count
+ print*,'time for old hij for diagonal= ',wall1 - wall0
+
+ call wall_time(wall0)
+ i_count = 0.d0
+ do i = 1, N_det
+  do j = i,i
+   i_count += 1.d0
+   call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+  enddo
+ enddo
+ call wall_time(wall1)
+ print*,'i_count = ',i_count
+ print*,'time for new hij for diagonal= ',wall1 - wall0
+
+end
+
+subroutine timing_single
+ implicit none
+ integer :: i,j
+ double precision :: wall0, wall1,accu
+ double precision, allocatable :: mat_old(:,:),mat_new(:,:)
+ double precision :: hmono, htwoe, hthree, htot, i_count
+ integer :: degree 
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
+ i_count = 0.d0
+ accu = 0.d0
+ do i = 1, N_det
+  do j = 1, N_det
+   call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
+   if(degree.ne.1)cycle
+   i_count += 1.d0
+   call wall_time(wall0)
+   call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+   call wall_time(wall1)
+   accu += wall1 - wall0
+  enddo
+ enddo
+ print*,'i_count = ',i_count
+ print*,'time for old hij for singles = ',accu
+
+ i_count = 0.d0
+ accu = 0.d0
+ do i = 1, N_det
+  do j = 1, N_det
+   call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
+   if(degree.ne.1)cycle
+   i_count += 1.d0
+   call wall_time(wall0)
+   call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+   call wall_time(wall1)
+   accu += wall1 - wall0
+  enddo
+ enddo
+ print*,'i_count = ',i_count
+ print*,'time for new hij for singles = ',accu
+
+end
+
+subroutine timing_double
+ implicit none
+ integer :: i,j
+ double precision :: wall0, wall1,accu
+ double precision, allocatable :: mat_old(:,:),mat_new(:,:)
+ double precision :: hmono, htwoe, hthree, htot, i_count
+ integer :: degree 
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
+ i_count = 0.d0
+ accu = 0.d0
+ do i = 1, N_det
+  do j = 1, N_det
+   call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
+   if(degree.ne.2)cycle
+   i_count += 1.d0
+   call wall_time(wall0)
+   call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+   call wall_time(wall1)
+   accu += wall1 - wall0
+  enddo
+ enddo
+ print*,'i_count = ',i_count
+ print*,'time for old hij for doubles = ',accu
+
+ i_count = 0.d0
+ accu = 0.d0
+ do i = 1, N_det
+  do j = 1, N_det
+   call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
+   if(degree.ne.2)cycle
+   i_count += 1.d0
+   call wall_time(wall0)
+   call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+   call wall_time(wall1)
+   accu += wall1 - wall0
+  enddo
+ enddo
+ call wall_time(wall1)
+ print*,'i_count = ',i_count
+ print*,'time for new hij for doubles = ',accu
+
+end
+

src/tc_bi_ortho/test_tc_fock.irp.f

@@ -0,0 +1,194 @@
+program test_tc_fock
+ implicit none
+  BEGIN_DOC
+! TODO : Put the documentation of the program here
+  END_DOC
+  print *, 'Hello world'
+  my_grid_becke = .True.
+  my_n_pt_r_grid = 30
+  my_n_pt_a_grid = 50
+  read_wf = .True.
+  touch read_wf
+  touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+
+  !call routine_1
+  !call routine_2
+!  call routine_3()
+
+! call test_3e
+ call routine_tot
+end
+
+! ---
+
+subroutine test_3e
+ implicit none
+ double precision :: integral_aaa,integral_aab,integral_abb,integral_bbb,accu
+ double precision ::  hmono, htwoe, hthree, htot
+ call htilde_mu_mat_bi_ortho(ref_bitmask, ref_bitmask, N_int, hmono, htwoe, hthree, htot)
+! call diag_htilde_three_body_ints_bi_ort(N_int, ref_bitmask, hthree)
+ print*,'hmono = ',hmono
+ print*,'htwoe = ',htwoe
+ print*,'hthree= ',hthree
+ print*,'htot  = ',htot
+ print*,''
+ print*,''
+ print*,'TC_one= ',tc_hf_one_e_energy
+ print*,'TC_two= ',TC_HF_two_e_energy
+ print*,'TC_3e = ',diag_three_elem_hf
+ print*,'TC_tot= ',TC_HF_energy
+ print*,''
+ print*,''
+ call give_aaa_contrib(integral_aaa)
+ print*,'integral_aaa = ',integral_aaa
+ call give_aab_contrib(integral_aab)
+ print*,'integral_aab = ',integral_aab
+ call give_abb_contrib(integral_abb)
+ print*,'integral_abb = ',integral_abb
+ call give_bbb_contrib(integral_bbb)
+ print*,'integral_bbb = ',integral_bbb
+ accu = integral_aaa + integral_aab + integral_abb + integral_bbb
+ print*,'accu = ',accu
+ print*,'delta = ',hthree - accu
+
+end
+
+subroutine routine_3()
+
+  use bitmasks ! you need to include the bitmasks_module.f90 features
+
+  implicit none
+  integer                        :: i, a, i_ok, s1
+  double precision               :: hmono, htwoe, hthree, htilde_ij
+  double precision               :: err_ai, err_tot, ref, new
+  integer(bit_kind), allocatable :: det_i(:,:)
+
+  allocate(det_i(N_int,2))
+
+  err_tot = 0.d0
+ 
+  do s1 = 1, 2
+
+   det_i = ref_bitmask
+   call debug_det(det_i, N_int)
+   print*, ' HF det'
+   call debug_det(det_i, N_int)
+ 
+   do i = 1, elec_num_tab(s1)
+     do a = elec_num_tab(s1)+1, mo_num ! virtual 
+ 
+ 
+       det_i = ref_bitmask
+       call do_single_excitation(det_i, i, a, s1, i_ok)
+       if(i_ok == -1) then
+        print*, 'PB !!'
+        print*, i, a
+        stop
+       endif
+       print*, ' excited det'
+       call debug_det(det_i, N_int)
+ 
+       call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
+       if(dabs(hthree).lt.1.d-10)cycle
+       ref = hthree 
+       if(s1 == 1)then
+        new = fock_a_tot_3e_bi_orth(a,i)
+       else if(s1 == 2)then
+        new = fock_b_tot_3e_bi_orth(a,i)
+       endif
+       err_ai = dabs(dabs(ref) - dabs(new))
+       if(err_ai .gt. 1d-7) then
+         print*,'s1 = ',s1
+         print*, ' warning on', i, a
+         print*, ref,new,err_ai
+       endif
+       print*, ref,new,err_ai
+       err_tot += err_ai
+ 
+       write(22, *) htilde_ij
+     enddo
+   enddo
+  enddo
+
+  print *, ' err_tot = ', err_tot
+
+  deallocate(det_i)
+
+end subroutine routine_3
+
+! ---
+subroutine routine_tot()
+
+  use bitmasks ! you need to include the bitmasks_module.f90 features
+
+  implicit none
+  integer                        :: i, a, i_ok, s1,other_spin(2)
+  double precision               :: hmono, htwoe, hthree, htilde_ij
+  double precision               :: err_ai, err_tot, ref, new
+  integer(bit_kind), allocatable :: det_i(:,:)
+
+  allocate(det_i(N_int,2))
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  err_tot = 0.d0
+ 
+!  do s1 = 1, 2
+   s1 = 2
+   det_i = ref_bitmask
+   call debug_det(det_i, N_int)
+   print*, ' HF det'
+   call debug_det(det_i, N_int)
+ 
+!   do i = 1, elec_num_tab(s1)
+!     do a = elec_num_tab(s1)+1, mo_num ! virtual 
+   do i = 1, elec_beta_num
+     do a = elec_beta_num+1, elec_alpha_num! virtual 
+!   do i = elec_beta_num+1, elec_alpha_num
+!     do a = elec_alpha_num+1, mo_num! virtual 
+       print*,i,a 
+ 
+       det_i = ref_bitmask
+       call do_single_excitation(det_i, i, a, s1, i_ok)
+       if(i_ok == -1) then
+        print*, 'PB !!'
+        print*, i, a
+        stop
+       endif
+ 
+       call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
+       print*,htilde_ij
+       if(dabs(htilde_ij).lt.1.d-10)cycle
+       print*, ' excited det'
+       call debug_det(det_i, N_int)
+
+       if(s1 == 1)then
+        new = Fock_matrix_tc_mo_alpha(a,i)
+       else
+        new = Fock_matrix_tc_mo_beta(a,i)
+       endif
+       ref = htilde_ij
+!       if(s1 == 1)then
+!        new = fock_a_tot_3e_bi_orth(a,i)
+!       else if(s1 == 2)then
+!        new = fock_b_tot_3e_bi_orth(a,i)
+!       endif
+       err_ai = dabs(dabs(ref) - dabs(new))
+       if(err_ai .gt. 1d-7) then
+         print*,'s1 = ',s1
+         print*, ' warning on', i, a
+         print*, ref,new,err_ai
+       endif
+       print*, ref,new,err_ai
+       err_tot += err_ai
+ 
+       write(22, *) htilde_ij
+     enddo
+   enddo
+!  enddo
+
+  print *, ' err_tot = ', err_tot
+
+  deallocate(det_i)
+
+end subroutine routine_3

src/tc_bi_ortho/u0_h_u0.irp.f

@@ -0,0 +1,770 @@
+subroutine u_0_H_tc_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze, do_right)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Computes $E_0 = \frac{\langle u_0 | H_TC | u_0 \rangle}{\langle u_0 | u_0 \rangle}$
+  !
+  ! n : number of determinants
+  !
+  ! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi>
+  END_DOC
+  integer, intent(in)             :: n,Nint, N_st, sze
+  logical, intent(in)             :: do_right 
+  double precision, intent(out)   :: e_0(N_st)
+  double precision, intent(inout) :: u_0(sze,N_st)
+  integer(bit_kind),intent(in)    :: keys_tmp(Nint,2,n)
+
+  double precision, allocatable   :: v_0(:,:), u_1(:,:)
+  double precision                :: u_dot_u,u_dot_v,diag_H_mat_elem
+  integer                         :: i,j, istate
+
+  allocate (v_0(n,N_st),u_1(n,N_st))
+  u_1(:,:) = 0.d0
+  u_1(1:n,1:N_st) = u_0(1:n,1:N_st)
+  call H_tc_u_0_nstates_openmp(v_0,u_1,N_st,n, do_right)
+  u_0(1:n,1:N_st) = u_1(1:n,1:N_st)
+  deallocate(u_1)
+  double precision :: norm
+  !$OMP PARALLEL DO PRIVATE(i,norm) DEFAULT(SHARED)
+  do i=1,N_st
+    norm = u_dot_u(u_0(1,i),n)
+    if (norm /= 0.d0) then
+      e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n) / dsqrt(norm)
+    else
+      e_0(i) = 0.d0
+    endif
+  enddo
+  !$OMP END PARALLEL DO
+  deallocate (v_0)
+end
+
+
+subroutine H_tc_u_0_opt(v_0,u_0,N_st,sze)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Computes $v_0 = H | u_0\rangle$.
+  !
+  ! Assumes that the determinants are in psi_det
+  !
+  ! istart, iend, ishift, istep are used in ZMQ parallelization.
+  END_DOC
+  integer, intent(in)            :: N_st,sze
+  double precision, intent(inout)  :: v_0(sze,N_st), u_0(sze,N_st)
+  logical           :: do_right 
+  do_right = .True.
+  call H_tc_u_0_nstates_openmp(v_0,u_0,N_st,sze, do_right)
+end
+
+subroutine H_tc_dagger_u_0_opt(v_0,u_0,N_st,sze)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Computes $v_0 = H | u_0\rangle$.
+  !
+  ! Assumes that the determinants are in psi_det
+  !
+  ! istart, iend, ishift, istep are used in ZMQ parallelization.
+  END_DOC
+  integer, intent(in)            :: N_st,sze
+  double precision, intent(inout)  :: v_0(sze,N_st), u_0(sze,N_st)
+  logical           :: do_right 
+  do_right = .False.
+  call H_tc_u_0_nstates_openmp(v_0,u_0,N_st,sze, do_right)
+end
+
+
+subroutine H_tc_u_0_nstates_openmp(v_0,u_0,N_st,sze, do_right)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Computes $v_0 = H | u_0\rangle$.
+  !
+  ! Assumes that the determinants are in psi_det
+  !
+  ! istart, iend, ishift, istep are used in ZMQ parallelization.
+  !
+  ! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi>
+  END_DOC
+  integer, intent(in)            :: N_st,sze
+  double precision, intent(inout)  :: v_0(sze,N_st), u_0(sze,N_st)
+  logical, intent(in)             :: do_right 
+  integer :: k
+  double precision, allocatable  :: u_t(:,:), v_t(:,:)
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
+  allocate(u_t(N_st,N_det),v_t(N_st,N_det))
+  provide mo_bi_ortho_tc_one_e mo_bi_ortho_tc_two_e 
+  provide ref_tc_energy_tot fock_op_2_e_tc_closed_shell 
+  provide eff_2_e_from_3_e_ab eff_2_e_from_3_e_aa eff_2_e_from_3_e_bb
+  do k=1,N_st
+    call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
+  enddo
+  v_t = 0.d0
+  call dtranspose(                                                   &
+      u_0,                                                           &
+      size(u_0, 1),                                                  &
+      u_t,                                                           &
+      size(u_t, 1),                                                  &
+      N_det, N_st)
+
+  call H_tc_u_0_nstates_openmp_work(v_t,u_t,N_st,sze,1,N_det,0,1, do_right)
+  deallocate(u_t)
+
+  call dtranspose(                                                   &
+      v_t,                                                           &
+      size(v_t, 1),                                                  &
+      v_0,                                                           &
+      size(v_0, 1),                                                  &
+      N_st, N_det)
+  deallocate(v_t)
+
+  do k=1,N_st
+    call dset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
+    call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
+  enddo
+
+end
+
+
+subroutine H_tc_u_0_nstates_openmp_work(v_t,u_t,N_st,sze,istart,iend,ishift,istep, do_right)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Computes $v_t = H | u_t\rangle$ 
+  !
+  ! Default should be 1,N_det,0,1
+  !
+  ! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi>
+  END_DOC
+  integer, intent(in)            :: N_st,sze,istart,iend,ishift,istep
+  double precision, intent(in)   :: u_t(N_st,N_det)
+  logical, intent(in)             :: do_right 
+  double precision, intent(out)  :: v_t(N_st,sze)
+
+
+  PROVIDE ref_bitmask_energy N_int
+
+  select case (N_int)
+    case (1)
+      call H_tc_u_0_nstates_openmp_work_1(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right)
+    case (2)
+      call H_tc_u_0_nstates_openmp_work_2(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right)
+    case (3)
+      call H_tc_u_0_nstates_openmp_work_3(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right)
+    case (4)
+      call H_tc_u_0_nstates_openmp_work_4(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right)
+    case default
+      call H_tc_u_0_nstates_openmp_work_N_int(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right)
+  end select
+end
+BEGIN_TEMPLATE
+
+subroutine H_tc_u_0_nstates_openmp_work_$N_int(v_t,u_t,N_st,sze,istart,iend,ishift,istep,do_right)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Computes $v_t = H | u_t \\rangle$ 
+  !
+  ! Default should be 1,N_det,0,1
+  !
+  ! if do_right == True then you compute H_TC |Psi>, else H_TC^T |Psi>
+  END_DOC
+  integer, intent(in)            :: N_st,sze,istart,iend,ishift,istep
+  double precision, intent(in)   :: u_t(N_st,N_det)
+  logical, intent(in)             :: do_right 
+  double precision, intent(out)  :: v_t(N_st,sze)
+
+  double precision               :: hij
+  integer                        :: i,j,k,l,kk
+  integer                        :: k_a, k_b, l_a, l_b, m_a, m_b
+  integer                        :: istate
+  integer                        :: krow, kcol, krow_b, kcol_b
+  integer                        :: lrow, lcol
+  integer                        :: mrow, mcol
+  integer(bit_kind)              :: spindet($N_int)
+  integer(bit_kind)              :: tmp_det($N_int,2)
+  integer(bit_kind)              :: tmp_det2($N_int,2)
+  integer(bit_kind)              :: tmp_det3($N_int,2)
+  integer(bit_kind), allocatable :: buffer(:,:)
+  integer                        :: n_doubles
+  integer, allocatable           :: doubles(:)
+  integer, allocatable           :: singles_a(:)
+  integer, allocatable           :: singles_b(:)
+  integer, allocatable           :: idx(:), idx0(:)
+  integer                        :: maxab, n_singles_a, n_singles_b, kcol_prev
+  integer*8                      :: k8
+  logical                        :: compute_singles
+  integer*8                      :: last_found, left, right, right_max
+  double precision               :: rss, mem, ratio
+  double precision, allocatable  :: utl(:,:)
+  integer, parameter             :: block_size=128
+  logical                        :: u_is_sparse
+
+!  call resident_memory(rss)
+!  mem = dble(singles_beta_csc_size) / 1024.d0**3
+!
+!  compute_singles = (mem+rss > qp_max_mem)
+!
+!  if (.not.compute_singles) then
+!    provide singles_beta_csc
+!  endif
+compute_singles=.True.
+
+
+  maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
+  allocate(idx0(maxab))
+
+  do i=1,maxab
+    idx0(i) = i
+  enddo
+
+  ! Prepare the array of all alpha single excitations
+  ! -------------------------------------------------
+
+  PROVIDE N_int nthreads_davidson
+  !$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads_davidson)        &
+      !$OMP   SHARED(psi_bilinear_matrix_rows, N_det,                &
+      !$OMP          psi_bilinear_matrix_columns,                    &
+      !$OMP          psi_det_alpha_unique, psi_det_beta_unique,      &
+      !$OMP          n_det_alpha_unique, n_det_beta_unique, N_int,   &
+      !$OMP          psi_bilinear_matrix_transp_rows,                &
+      !$OMP          psi_bilinear_matrix_transp_columns,             &
+      !$OMP          psi_bilinear_matrix_transp_order, N_st,         &
+      !$OMP          psi_bilinear_matrix_order_transp_reverse,       &
+      !$OMP          psi_bilinear_matrix_columns_loc,                &
+      !$OMP          psi_bilinear_matrix_transp_rows_loc,            &
+      !$OMP          istart, iend, istep, irp_here, v_t,             &
+      !$OMP          ishift, idx0, u_t, maxab, compute_singles,      &
+      !$OMP          singles_alpha_csc,singles_alpha_csc_idx,        &
+      !$OMP          singles_beta_csc,singles_beta_csc_idx)          &
+      !$OMP   PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,     &
+      !$OMP          lcol, lrow, l_a, l_b, utl, kk, u_is_sparse,     &
+      !$OMP          buffer, doubles, n_doubles, umax,               &
+      !$OMP          tmp_det2, hij, idx, l, kcol_prev,hmono, htwoe, hthree,          &
+      !$OMP          singles_a, n_singles_a, singles_b, ratio,       &
+      !$OMP          n_singles_b, k8, last_found,left,right,right_max)
+
+  ! Alpha/Beta double excitations
+  ! =============================
+
+  allocate( buffer($N_int,maxab),                                     &
+      singles_a(maxab),                                              &
+      singles_b(maxab),                                              &
+      doubles(maxab),                                                &
+      idx(maxab), utl(N_st,block_size))
+
+  kcol_prev=-1
+
+  ! Check if u has multiple zeros
+  kk=1 ! Avoid division by zero
+  !$OMP DO
+  do k=1,N_det
+    umax = 0.d0
+    do l=1,N_st
+      umax = max(umax, dabs(u_t(l,k)))
+    enddo
+    if (umax < 1.d-20) then
+      !$OMP ATOMIC
+      kk = kk+1
+    endif
+  enddo
+  !$OMP END DO
+  u_is_sparse = N_det / kk < 20  ! 5%
+
+  ASSERT (iend <= N_det)
+  ASSERT (istart > 0)
+  ASSERT (istep  > 0)
+
+  !$OMP DO SCHEDULE(guided,64)
+  do k_a=istart+ishift,iend,istep    ! Loop over all determinants (/!\ not in psidet order)
+
+    krow = psi_bilinear_matrix_rows(k_a)       ! Index of alpha part of determinant k_a
+    ASSERT (krow <= N_det_alpha_unique)
+
+    kcol = psi_bilinear_matrix_columns(k_a)    ! Index of beta part of determinant k_a
+    ASSERT (kcol <= N_det_beta_unique)
+
+    tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+
+    if (kcol /= kcol_prev) then
+      tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+      if (compute_singles) then
+        call get_all_spin_singles_$N_int(                              &
+            psi_det_beta_unique, idx0,                                 &
+            tmp_det(1,2), N_det_beta_unique,                           &
+            singles_b, n_singles_b)
+      else
+        n_singles_b = 0
+        !DIR$ LOOP COUNT avg(1000)
+        do k8=singles_beta_csc_idx(kcol),singles_beta_csc_idx(kcol+1)-1
+          n_singles_b = n_singles_b+1
+          singles_b(n_singles_b) = singles_beta_csc(k8)
+        enddo
+      endif
+    endif
+    kcol_prev = kcol
+
+    ! -> Here, tmp_det is determinant k_a
+
+    ! Loop over singly excited beta columns
+    ! -------------------------------------
+
+    !DIR$ LOOP COUNT avg(1000)
+    do i=1,n_singles_b
+      lcol = singles_b(i)
+
+      tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
+
+      ! tmp_det2 is a single excitation of tmp_det in the beta spin
+      ! the alpha part is not defined yet
+
+!---
+!      if (compute_singles) then
+
+        l_a = psi_bilinear_matrix_columns_loc(lcol)
+        ASSERT (l_a <= N_det)
+        ! rows  : | 1 2 3 4 | 1 3 4 6 | .... |  1  2  4  5 |
+        ! cols  : | 1 1 1 1 | 2 2 2 2 | .... |  8  8  8  8 |
+        ! index : | 1 2 3 4 | 5 6 7 8 | .... | 58 59 60 61 |
+        !                     ^                          ^
+        !                     |                          |
+        !                     l_a                       N_det
+        ! l_a is the index in the big vector os size Ndet of the position of the first element of column lcol
+
+        ! Below we identify all the determinants with the same beta part
+
+        !DIR$ UNROLL(8)
+        !DIR$ LOOP COUNT avg(50000)
+        do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
+          lrow = psi_bilinear_matrix_rows(l_a)
+          ASSERT (lrow <= N_det_alpha_unique)
+
+          buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)  ! hot spot
+
+          ASSERT (l_a <= N_det)
+          idx(j) = l_a
+          l_a = l_a+1
+        enddo
+        j = j-1
+
+        ! Get all single excitations from tmp_det(1,1) to buffer(1,?)
+
+        call get_all_spin_singles_$N_int(                              &
+            buffer, idx, tmp_det(1,1), j,                              &
+            singles_a, n_singles_a )
+
+      ! Loop over alpha singles
+      ! -----------------------
+
+      double precision :: umax
+
+      !DIR$ LOOP COUNT avg(1000)
+      do k = 1,n_singles_a,block_size
+        umax = 0.d0
+        ! Prefetch u_t(:,l_a)
+        if (u_is_sparse) then
+          do kk=0,block_size-1
+            if (k+kk > n_singles_a) exit
+            l_a = singles_a(k+kk)
+            ASSERT (l_a <= N_det)
+
+            do l=1,N_st
+              utl(l,kk+1) = u_t(l,l_a)
+              umax = max(umax, dabs(utl(l,kk+1)))
+            enddo
+          enddo
+        else
+          do kk=0,block_size-1
+            if (k+kk > n_singles_a) exit
+            l_a = singles_a(k+kk)
+            ASSERT (l_a <= N_det)
+            utl(:,kk+1) = u_t(:,l_a)
+          enddo
+          umax = 1.d0
+        endif
+        if (umax < 1.d-20) cycle
+
+        do kk=0,block_size-1
+          if (k+kk > n_singles_a) exit
+          l_a = singles_a(k+kk)
+          lrow = psi_bilinear_matrix_rows(l_a)
+          ASSERT (lrow <= N_det_alpha_unique)
+
+          tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
+!        call i_H_j( tmp_det, tmp_det2, $N_int, hij) ! double alpha-beta
+          if(do_right)then
+           call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij)
+          else
+           call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij)
+          endif
+          !DIR$ LOOP COUNT AVG(4)
+          do l=1,N_st
+            v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
+          enddo
+        enddo
+      enddo
+
+    enddo
+
+  enddo
+  !$OMP END DO
+
+  !$OMP DO SCHEDULE(guided,64)
+  do k_a=istart+ishift,iend,istep
+
+
+    ! Single and double alpha excitations
+    ! ===================================
+
+
+    ! Initial determinant is at k_a in alpha-major representation
+    ! -----------------------------------------------------------------------
+
+    krow = psi_bilinear_matrix_rows(k_a)
+    ASSERT (krow <= N_det_alpha_unique)
+
+    kcol = psi_bilinear_matrix_columns(k_a)
+    ASSERT (kcol <= N_det_beta_unique)
+
+    tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+    tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+
+    ! Initial determinant is at k_b in beta-major representation
+    ! ----------------------------------------------------------------------
+
+    k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
+    ASSERT (k_b <= N_det)
+
+    spindet(1:$N_int) = tmp_det(1:$N_int,1)
+
+    ! Loop inside the beta column to gather all the connected alphas
+    lcol = psi_bilinear_matrix_columns(k_a)
+    l_a = psi_bilinear_matrix_columns_loc(lcol)
+
+    !DIR$ LOOP COUNT avg(200000)
+    do i=1,N_det_alpha_unique
+      if (l_a > N_det) exit
+      lcol = psi_bilinear_matrix_columns(l_a)
+      if (lcol /= kcol) exit
+      lrow = psi_bilinear_matrix_rows(l_a)
+      ASSERT (lrow <= N_det_alpha_unique)
+
+      buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) ! Hot spot
+      idx(i) = l_a
+      l_a = l_a+1
+    enddo
+    i = i-1
+
+    call get_all_spin_singles_and_doubles_$N_int(                    &
+        buffer, idx, spindet, i,                                     &
+        singles_a, doubles, n_singles_a, n_doubles )
+
+    ! Compute Hij for all alpha singles
+    ! ----------------------------------
+
+    tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+    !DIR$ LOOP COUNT avg(1000)
+    do i=1,n_singles_a,block_size
+      umax = 0.d0
+      ! Prefetch u_t(:,l_a)
+      if (u_is_sparse) then
+        do kk=0,block_size-1
+          if (i+kk > n_singles_a) exit
+          l_a = singles_a(i+kk)
+          ASSERT (l_a <= N_det)
+
+          do l=1,N_st
+            utl(l,kk+1) = u_t(l,l_a)
+            umax = max(umax, dabs(utl(l,kk+1)))
+          enddo
+        enddo
+      else
+        do kk=0,block_size-1
+          if (i+kk > n_singles_a) exit
+          l_a = singles_a(i+kk)
+          ASSERT (l_a <= N_det)
+          utl(:,kk+1) = u_t(:,l_a)
+        enddo
+        umax = 1.d0
+      endif
+      if (umax < 1.d-20) cycle
+
+      do kk=0,block_size-1
+        if (i+kk > n_singles_a) exit
+        l_a = singles_a(i+kk)
+        lrow = psi_bilinear_matrix_rows(l_a)
+        ASSERT (lrow <= N_det_alpha_unique)
+
+        tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
+!        call i_h_j_single_spin( tmp_det, tmp_det2, $N_int, 1, hij)
+         if(do_right)then
+          call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij)
+         else
+          call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij)
+         endif
+
+        !DIR$ LOOP COUNT AVG(4)
+        do l=1,N_st
+          v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
+        enddo
+      enddo
+    enddo
+
+
+    ! Compute Hij for all alpha doubles
+    ! ----------------------------------
+
+    !DIR$ LOOP COUNT avg(50000)
+    do i=1,n_doubles,block_size
+      umax = 0.d0
+      ! Prefetch u_t(:,l_a)
+      if (u_is_sparse) then
+        do kk=0,block_size-1
+          if (i+kk > n_doubles) exit
+          l_a = doubles(i+kk)
+          ASSERT (l_a <= N_det)
+
+          do l=1,N_st
+            utl(l,kk+1) = u_t(l,l_a)
+            umax = max(umax, dabs(utl(l,kk+1)))
+          enddo
+        enddo
+      else
+        do kk=0,block_size-1
+          if (i+kk > n_doubles) exit
+          l_a = doubles(i+kk)
+          ASSERT (l_a <= N_det)
+          utl(:,kk+1) = u_t(:,l_a)
+        enddo
+        umax = 1.d0
+      endif
+      if (umax < 1.d-20) cycle
+
+      do kk=0,block_size-1
+        if (i+kk > n_doubles) exit
+        l_a = doubles(i+kk)
+        lrow = psi_bilinear_matrix_rows(l_a)
+        ASSERT (lrow <= N_det_alpha_unique)
+
+        tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow) 
+!        call i_H_j( tmp_det, tmp_det2, $N_int, hij)
+!        call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij)
+        if(do_right)then
+         call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij)
+        else
+         call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij)
+        endif
+
+        !DIR$ LOOP COUNT AVG(4)
+        do l=1,N_st
+          v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
+        enddo
+      enddo
+    enddo
+
+
+    ! Single and double beta excitations
+    ! ==================================
+
+
+    ! Initial determinant is at k_a in alpha-major representation
+    ! -----------------------------------------------------------------------
+
+    krow = psi_bilinear_matrix_rows(k_a)
+    kcol = psi_bilinear_matrix_columns(k_a)
+
+    tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+    tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+
+    spindet(1:$N_int) = tmp_det(1:$N_int,2)
+
+    ! Initial determinant is at k_b in beta-major representation
+    ! -----------------------------------------------------------------------
+
+    k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
+    ASSERT (k_b <= N_det)
+
+    ! Loop inside the alpha row to gather all the connected betas
+    lrow = psi_bilinear_matrix_transp_rows(k_b)
+    l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
+    !DIR$ LOOP COUNT avg(200000)
+    do i=1,N_det_beta_unique
+      if (l_b > N_det) exit
+      lrow = psi_bilinear_matrix_transp_rows(l_b)
+      if (lrow /= krow) exit
+      lcol = psi_bilinear_matrix_transp_columns(l_b)
+      ASSERT (lcol <= N_det_beta_unique)
+
+      buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
+      idx(i) = l_b
+      l_b = l_b+1
+    enddo
+    i = i-1
+
+    call get_all_spin_singles_and_doubles_$N_int(                    &
+        buffer, idx, spindet, i,                                     &
+        singles_b, doubles, n_singles_b, n_doubles )
+
+    ! Compute Hij for all beta singles
+    ! ----------------------------------
+
+    tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+    !DIR$ LOOP COUNT avg(1000)
+    do i=1,n_singles_b,block_size
+      umax = 0.d0
+      if (u_is_sparse) then
+        do kk=0,block_size-1
+          if (i+kk > n_singles_b) exit
+          l_b = singles_b(i+kk)
+          l_a = psi_bilinear_matrix_transp_order(l_b)
+          ASSERT (l_b <= N_det)
+          ASSERT (l_a <= N_det)
+
+          do l=1,N_st
+            utl(l,kk+1) = u_t(l,l_a)
+            umax = max(umax, dabs(utl(l,kk+1)))
+          enddo
+        enddo
+      else
+        do kk=0,block_size-1
+          if (i+kk > n_singles_b) exit
+          l_b = singles_b(i+kk)
+          l_a = psi_bilinear_matrix_transp_order(l_b)
+          ASSERT (l_b <= N_det)
+          ASSERT (l_a <= N_det)
+          utl(:,kk+1) = u_t(:,l_a)
+        enddo
+        umax = 1.d0
+      endif
+      if (umax < 1.d-20) cycle
+
+      do kk=0,block_size-1
+        if (i+kk > n_singles_b) exit
+        l_b = singles_b(i+kk)
+        l_a = psi_bilinear_matrix_transp_order(l_b)
+        lcol = psi_bilinear_matrix_transp_columns(l_b)
+        ASSERT (lcol <= N_det_beta_unique)
+
+        tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
+!        call i_H_j_single_spin( tmp_det, tmp_det2, $N_int, 2, hij)
+        if(do_right)then
+         call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij)
+        else
+         call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij)
+        endif
+        !DIR$ LOOP COUNT AVG(4)
+        do l=1,N_st
+          v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
+        enddo
+      enddo
+    enddo
+
+    ! Compute Hij for all beta doubles
+    ! ----------------------------------
+
+    !DIR$ LOOP COUNT avg(50000)
+    do i=1,n_doubles,block_size
+      umax = 0.d0
+      if (u_is_sparse) then
+        do kk=0,block_size-1
+          if (i+kk > n_doubles) exit
+          l_b = doubles(i+kk)
+          l_a = psi_bilinear_matrix_transp_order(l_b)
+          ASSERT (l_b <= N_det)
+          ASSERT (l_a <= N_det)
+          do l=1,N_st
+            utl(l,kk+1) = u_t(l,l_a)
+            umax = max(umax, dabs(utl(l,kk+1)))
+          enddo
+        enddo
+      else
+        do kk=0,block_size-1
+          if (i+kk > n_doubles) exit
+          l_b = doubles(i+kk)
+          l_a = psi_bilinear_matrix_transp_order(l_b)
+          ASSERT (l_b <= N_det)
+          ASSERT (l_a <= N_det)
+          utl(:,kk+1) = u_t(:,l_a)
+        enddo
+        umax = 1.d0
+      endif
+      if (umax < 1.d-20) cycle
+
+      do kk=0,block_size-1
+        if (i+kk > n_doubles) exit
+        l_b = doubles(i+kk)
+        l_a = psi_bilinear_matrix_transp_order(l_b)
+        lcol = psi_bilinear_matrix_transp_columns(l_b)
+        ASSERT (lcol <= N_det_beta_unique)
+
+        tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, lcol) 
+!        call i_H_j( tmp_det, tmp_det2, $N_int, hij)
+!        call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij)
+        if(do_right)then
+         call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij)
+        else
+         call htilde_mu_mat_opt_bi_ortho_tot(tmp_det2,tmp_det,$N_int,hij)
+        endif
+
+        !DIR$ LOOP COUNT AVG(4)
+        do l=1,N_st
+          v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
+        enddo
+      enddo
+    enddo
+
+
+    ! Diagonal contribution
+    ! =====================
+
+
+    ! Initial determinant is at k_a in alpha-major representation
+    ! -----------------------------------------------------------------------
+
+    if (u_is_sparse) then
+      umax = 0.d0
+      do l=1,N_st
+        umax = max(umax, dabs(u_t(l,k_a)))
+      enddo
+    else
+      umax = 1.d0
+    endif
+    if (umax < 1.d-20) cycle
+
+    krow = psi_bilinear_matrix_rows(k_a)
+    ASSERT (krow <= N_det_alpha_unique)
+
+    kcol = psi_bilinear_matrix_columns(k_a)
+    ASSERT (kcol <= N_det_beta_unique)
+
+    tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+    tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+
+    double precision, external :: diag_H_mat_elem
+    double precision :: hmono, htwoe, hthree
+
+!    hij = diag_H_mat_elem(tmp_det,$N_int)
+    call diag_htilde_mu_mat_fock_bi_ortho  ($N_int, tmp_det, hmono, htwoe, hthree, hij)
+    !DIR$ LOOP COUNT AVG(4)
+    do l=1,N_st
+      v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a)
+    enddo
+
+  end do
+  !$OMP END DO
+  deallocate(buffer, singles_a, singles_b, doubles, idx, utl)
+  !$OMP END PARALLEL
+
+end
+
+SUBST [ N_int ]
+
+1;;
+2;;
+3;;
+4;;
+N_int;;
+
+END_TEMPLATE
+
+

src/utils/linear_algebra.irp.f

@@ -1649,3 +1649,185 @@ subroutine restore_symmetry(m,n,A,LDA,thresh)
   enddo
 
 end
+
+subroutine diag_nonsym_right(n, A, A_ldim, V, V_ldim, energy, E_ldim)
+
+  implicit none
+
+  integer,          intent(in)  :: n, A_ldim, V_ldim, E_ldim
+  double precision, intent(in)  :: A(A_ldim,n)
+  double precision, intent(out) :: energy(E_ldim), V(V_ldim,n)
+
+  character*1                   :: JOBVL, JOBVR, BALANC, SENSE
+  integer                       :: i, j
+  integer                       :: ILO, IHI, lda, ldvl, ldvr, LWORK, INFO
+  double precision              :: ABNRM
+  integer,          allocatable :: iorder(:), IWORK(:)
+  double precision, allocatable :: WORK(:), SCALE_array(:), RCONDE(:), RCONDV(:)
+  double precision, allocatable :: Atmp(:,:), WR(:), WI(:), VL(:,:), VR(:,:), Vtmp(:)
+  double precision, allocatable :: energy_loc(:), V_loc(:,:)
+
+  allocate( Atmp(n,n), WR(n), WI(n), VL(1,1), VR(n,n) )
+  do i = 1, n
+    do j = 1, n
+      Atmp(j,i) = A(j,i)
+    enddo
+  enddo
+
+  JOBVL  = "N" ! computes the left  eigenvectors
+  JOBVR  = "V" ! computes the right eigenvectors
+  BALANC = "B" ! Diagonal scaling and Permutation for optimization
+  SENSE  = "V" ! Determines which reciprocal condition numbers are computed
+  lda  = n
+  ldvr = n
+  ldvl = 1
+
+  allocate( WORK(1), SCALE_array(n), RCONDE(n), RCONDV(n), IWORK(2*n-2) )
+
+  LWORK = -1 ! to ask for the optimal size of WORK
+  call dgeevx( BALANC, JOBVL, JOBVR, SENSE                  & ! CHARACTERS
+             , n, Atmp, lda                                 & ! MATRIX TO DIAGONALIZE
+             , WR, WI                                       & ! REAL AND IMAGINARY PART OF EIGENVALUES
+             , VL, ldvl, VR, ldvr                           & ! LEFT AND RIGHT EIGENVECTORS
+             , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & ! OUTPUTS OF OPTIMIZATION
+             , WORK, LWORK, IWORK, INFO )
+
+  if(INFO .ne. 0) then
+    print*, 'dgeevx failed !!', INFO
+    stop
+  endif
+
+  LWORK = max(int(work(1)), 1) ! this is the optimal size of WORK
+  deallocate(WORK)
+  allocate(WORK(LWORK))
+  call dgeevx( BALANC, JOBVL, JOBVR, SENSE                  &
+             , n, Atmp, lda                                 &
+             , WR, WI                                       &
+             , VL, ldvl, VR, ldvr                           &
+             , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV &
+             , WORK, LWORK, IWORK, INFO )
+  if(INFO .ne. 0) then
+    print*, 'dgeevx failed !!', INFO
+    stop
+  endif
+
+  deallocate( WORK, SCALE_array, RCONDE, RCONDV, IWORK )
+  deallocate( VL, Atmp )
+
+
+  allocate( energy_loc(n), V_loc(n,n) )
+  energy_loc = 0.d0
+  V_loc = 0.d0
+
+  i = 1
+  do while(i .le. n)
+
+!    print*, i, WR(i), WI(i)
+
+    if( dabs(WI(i)) .gt. 1e-7 ) then
+
+      print*, ' Found an imaginary component to eigenvalue'
+      print*, ' Re(i) + Im(i)', i, WR(i), WI(i)
+
+      energy_loc(i) = WR(i)
+      do j = 1, n
+        V_loc(j,i) = WR(i) * VR(j,i) - WI(i) * VR(j,i+1)
+      enddo
+      energy_loc(i+1) = WI(i)
+      do j = 1, n
+        V_loc(j,i+1) = WR(i) * VR(j,i+1) + WI(i) * VR(j,i)
+      enddo
+      i = i + 2
+
+    else
+
+      energy_loc(i) = WR(i)
+      do j = 1, n
+        V_loc(j,i) = VR(j,i)
+      enddo
+      i = i + 1
+
+    endif
+
+  enddo
+
+  deallocate(WR, WI, VR)
+
+
+  ! ordering
+!  do j = 1, n
+!    write(444, '(100(1X, F16.10))') (V_loc(j,i), i=1,5)
+!  enddo
+  allocate( iorder(n) )
+  do i = 1, n
+    iorder(i) = i
+  enddo
+  call dsort(energy_loc, iorder, n)
+  do i = 1, n
+    energy(i) = energy_loc(i)
+    do j = 1, n
+      V(j,i) = V_loc(j,iorder(i))
+    enddo
+  enddo
+  deallocate(iorder)
+!  do j = 1, n
+!    write(445, '(100(1X, F16.10))') (V_loc(j,i), i=1,5)
+!  enddo
+  deallocate(V_loc, energy_loc)
+
+end subroutine diag_nonsym_right
+
+! ---
+
+! Taken from GammCor thanks to Michal Hapka :-)
+
+
+subroutine pivoted_cholesky( A, rank, tol, ndim, U)
+!
+! A = U**T * U
+!
+! matrix A is destroyed inside this subroutine
+! Cholesky vectors are stored in U
+! dimension of U: U(1:rank, 1:n)
+! U is allocated inside this subroutine
+! rank is the number of Cholesky vectors depending on tol
+!
+integer :: ndim
+integer, intent(inout)                                        :: rank
+double precision, dimension(ndim, ndim), intent(inout)        :: A
+double precision, dimension(ndim, rank), intent(out)          :: U
+double precision, intent(in)                                  :: tol
+
+integer, dimension(:), allocatable          :: piv
+double precision, dimension(:), allocatable :: work
+character, parameter :: uplo = "U"
+integer :: N, LDA
+integer :: info
+integer :: k, l, rank0
+external :: dpstrf
+
+rank0 = rank
+N = size(A, dim=1)
+LDA = N
+allocate(piv(N))
+allocate(work(2*N))
+call dpstrf(uplo, N, A, LDA, piv, rank, tol, work, info)
+
+if (rank > rank0) then
+  print *, 'Bug: rank > rank0 in pivoted cholesky. Increase rank before calling'
+  stop
+end if
+
+do k = 1, N
+  A(k+1:, k) = 0.00D+0
+end do
+! TODO: It should be possible to use only one vector of size (1:rank) as a buffer
+! to do the swapping in-place
+U = 0.00D+0
+do k = 1, N
+  l = piv(k)
+  U(l, :) = A(1:rank, k)
+end do
+
+end subroutine pivoted_cholesky
+