Merge branch 'dev-stable-tc-scf' into dev-stable

src/ao_many_one_e_ints/ao_erf_gauss.irp.f

@@ -1245,3 +1245,157 @@ end subroutine NAI_pol_x2_mult_erf_ao
 
 ! ---
 
+subroutine NAI_pol_012_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_center, ints)
+
+  BEGIN_DOC
+  !
+  ! Computes the following integral :
+  !
+  ! ints(1) = $\int_{-\infty}^{infty} dr x^0 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  !
+  ! ints(2) = $\int_{-\infty}^{infty} dr x^1 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  ! ints(3) = $\int_{-\infty}^{infty} dr y^1 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  ! ints(4) = $\int_{-\infty}^{infty} dr z^1 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  !
+  ! ints(5) = $\int_{-\infty}^{infty} dr x^2 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  ! ints(6) = $\int_{-\infty}^{infty} dr y^2 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  ! ints(7) = $\int_{-\infty}^{infty} dr z^2 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  !
+  END_DOC
+
+  include 'utils/constants.include.F'
+
+  implicit none
+
+  integer,          intent(in)  :: i_ao, j_ao
+  double precision, intent(in)  :: beta, B_center(3), mu_in, C_center(3)
+  double precision, intent(out) :: ints(7)
+
+  integer                       :: i, j, power_Ai(3), power_Aj(3), n_pt_in, m
+  integer                       :: power_A1(3), power_A2(3)
+  double precision              :: Ai_center(3), Aj_center(3), alphai, alphaj, coef, coefi
+  double precision              :: integral0, integral1, integral2
+
+  double precision, external    :: NAI_pol_mult_erf_with1s
+
+  ASSERT(beta .ge. 0.d0)
+  if(beta .lt. 1d-10) then
+    call NAI_pol_012_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
+    return
+  endif
+
+  ints = 0.d0
+
+  power_Ai(1:3) = ao_power(i_ao,1:3)
+  power_Aj(1:3) = ao_power(j_ao,1:3)
+
+  Ai_center(1:3) = nucl_coord(ao_nucl(i_ao),1:3)
+  Aj_center(1:3) = nucl_coord(ao_nucl(j_ao),1:3)
+
+  n_pt_in = n_pt_max_integrals
+
+  do i = 1, ao_prim_num(i_ao)
+    alphai = ao_expo_ordered_transp           (i,i_ao)
+    coefi  = ao_coef_normalized_ordered_transp(i,i_ao)
+
+    do j = 1, ao_prim_num(j_ao)
+      alphaj = ao_expo_ordered_transp                   (j,j_ao)
+      coef   = coefi * ao_coef_normalized_ordered_transp(j,j_ao)
+
+      integral0 = NAI_pol_mult_erf_with1s(Ai_center, Aj_center, power_Ai, power_Aj, alphai, alphaj, beta, B_center, C_center, n_pt_in, mu_in)
+      ints(1)  += coef * integral0
+
+      do m = 1, 3
+
+        power_A1     = power_Ai
+        power_A1(m) += 1
+        integral1    = NAI_pol_mult_erf_with1s(Ai_center, Aj_center, power_A1, power_Aj, alphai, alphaj, beta, B_center, C_center, n_pt_in, mu_in)
+        ints(1+m)   += coef * (integral1 + Ai_center(m)*integral0)
+
+        power_A2     = power_Ai
+        power_A2(m) += 2
+        integral2    = NAI_pol_mult_erf_with1s(Ai_center, Aj_center, power_A2, power_Aj, alphai, alphaj, beta, B_center, C_center, n_pt_in, mu_in)
+        ints(4+m)   += coef * (integral2 + Ai_center(m) * (2.d0*integral1 + Ai_center(m)*integral0))
+      enddo
+    enddo
+  enddo
+
+end subroutine NAI_pol_012_mult_erf_ao_with1s
+
+! ---
+
+subroutine NAI_pol_012_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
+
+  BEGIN_DOC
+  !
+  ! Computes the following integral :
+  !
+  ! int(1) = $\int_{-\infty}^{infty} dr x^0 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  !
+  ! int(2) = $\int_{-\infty}^{infty} dr x^1 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  ! int(3) = $\int_{-\infty}^{infty} dr y^1 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  ! int(4) = $\int_{-\infty}^{infty} dr z^1 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  !
+  ! int(5) = $\int_{-\infty}^{infty} dr x^2 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  ! int(6) = $\int_{-\infty}^{infty} dr y^2 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  ! int(7) = $\int_{-\infty}^{infty} dr z^2 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
+  !
+  END_DOC
+
+  include 'utils/constants.include.F'
+
+  implicit none
+
+  integer,          intent(in)  :: i_ao, j_ao
+  double precision, intent(in)  :: mu_in, C_center(3)
+  double precision, intent(out) :: ints(7)
+
+  integer                       :: i, j, num_A, num_B, power_A(3), power_B(3), n_pt_in, m
+  integer                       :: power_A1(3), power_A2(3)
+  double precision              :: A_center(3), B_center(3), alpha, beta, coef
+  double precision              :: integral0, integral1, integral2
+
+  double precision              :: NAI_pol_mult_erf
+
+  ints = 0.d0
+
+  num_A         = ao_nucl(i_ao)
+  power_A(1:3)  = ao_power(i_ao,1:3)
+  A_center(1:3) = nucl_coord(num_A,1:3)
+  num_B         = ao_nucl(j_ao)
+  power_B(1:3)  = ao_power(j_ao,1:3)
+  B_center(1:3) = nucl_coord(num_B,1:3)
+
+  n_pt_in = n_pt_max_integrals
+
+  do i = 1, ao_prim_num(i_ao)
+    alpha = ao_expo_ordered_transp(i,i_ao)
+
+    do j = 1, ao_prim_num(j_ao)
+      beta = ao_expo_ordered_transp(j,j_ao)
+      coef = ao_coef_normalized_ordered_transp(j,j_ao) * ao_coef_normalized_ordered_transp(i,i_ao)
+
+      integral0 = NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in, mu_in)
+      ints(1)  += coef * integral0
+
+      do m = 1, 3
+
+        power_A1 = power_A
+        power_A1(m) += 1
+        integral1 = NAI_pol_mult_erf(A_center, B_center, power_A1, power_B, alpha, beta, C_center, n_pt_in, mu_in)
+
+        ints(1+m) += coef * (integral1 + A_center(m)*integral0)
+
+        power_A2 = power_A
+        power_A2(m) += 2
+        integral2 = NAI_pol_mult_erf(A_center, B_center, power_A2, power_B, alpha, beta, C_center, n_pt_in, mu_in)
+
+        ints(4+m) += coef * (integral2 + A_center(m) * (2.d0*integral1 + A_center(m)*integral0))
+      enddo
+    enddo
+  enddo
+
+end subroutine NAI_pol_012_mult_erf_ao
+
+! ---
+

src/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f

@@ -299,15 +299,12 @@ END_PROVIDER
 
 ! ---
 
-BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_points_final_grid)]
+BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_points_final_grid)]
 
   BEGIN_DOC
   !
   ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12)
   !
-  ! TODO
-  ! one subroutine for all integrals
-  !
   END_DOC
 
   include 'constants.include.F'
@@ -325,7 +322,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin
   double precision, external :: overlap_gauss_r12_ao_with1s
   double precision, external :: NAI_pol_mult_erf_ao_with1s
 
-  print*, ' providing v_ij_u_cst_mu_j1b_an ...'
+  print*, ' providing v_ij_u_cst_mu_j1b_an_old ...'
   call wall_time(wall0)
 
   provide mu_erf final_grid_points j1b_pen
@@ -333,7 +330,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin
 
   ct = inv_sq_pi_2 / mu_erf
 
-  v_ij_u_cst_mu_j1b_an = 0.d0
+  v_ij_u_cst_mu_j1b_an_old = 0.d0
 
   !$OMP PARALLEL DEFAULT (NONE)                                      &
   !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center,        &
@@ -342,7 +339,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin
   !$OMP SHARED  (n_points_final_grid, ao_num, List_all_comb_b2_size, & 
   !$OMP          final_grid_points, mu_erf, ct,                      &
   !$OMP          List_all_comb_b2_coef, List_all_comb_b2_expo,       & 
-  !$OMP          List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an)
+  !$OMP          List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an_old)
   !$OMP DO
   do ipoint = 1, n_points_final_grid
 
@@ -413,6 +410,125 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin
 
         ! ---
 
+        v_ij_u_cst_mu_j1b_an_old(j,i,ipoint) = tmp
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  do ipoint = 1, n_points_final_grid
+    do i = 2, ao_num
+      do j = 1, i-1
+        v_ij_u_cst_mu_j1b_an_old(j,i,ipoint) = v_ij_u_cst_mu_j1b_an_old(i,j,ipoint)
+      enddo
+    enddo
+  enddo
+ 
+  call wall_time(wall1)
+  print*, ' wall time for v_ij_u_cst_mu_j1b_an_old', wall1 - wall0
+
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_points_final_grid)]
+
+  BEGIN_DOC
+  !
+  ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12)
+  !
+  END_DOC
+
+  include 'constants.include.F'
+
+  implicit none
+  integer                    :: i, j, ipoint, i_1s
+  double precision           :: r(3), r1_2
+  double precision           :: int_o
+  double precision           :: int_c(7), int_e(7)
+  double precision           :: coef, beta, B_center(3)
+  double precision           :: tmp, ct
+  double precision           :: wall0, wall1
+
+  double precision, external :: overlap_gauss_r12_ao_with1s
+  double precision, external :: NAI_pol_mult_erf_ao_with1s
+
+  print*, ' providing v_ij_u_cst_mu_j1b_an ...'
+  call wall_time(wall0)
+
+  provide mu_erf final_grid_points j1b_pen
+  PROVIDE List_all_comb_b2_size List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent
+
+  ct = inv_sq_pi_2 / mu_erf
+
+  v_ij_u_cst_mu_j1b_an = 0.d0
+
+  !$OMP PARALLEL DEFAULT (NONE)                                      &
+  !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center,        &
+  !$OMP          r1_2, tmp, int_c, int_e, int_o)                     &
+  !$OMP SHARED  (n_points_final_grid, ao_num, List_all_comb_b2_size, & 
+  !$OMP          final_grid_points, mu_erf, ct,                      &
+  !$OMP          List_all_comb_b2_coef, List_all_comb_b2_expo,       & 
+  !$OMP          List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an)
+  !$OMP DO
+  do ipoint = 1, n_points_final_grid
+
+    r(1) = final_grid_points(1,ipoint)
+    r(2) = final_grid_points(2,ipoint)
+    r(3) = final_grid_points(3,ipoint)
+    r1_2 = 0.5d0 * (r(1)*r(1) + r(2)*r(2) + r(3)*r(3))
+
+    do i = 1, ao_num
+      do j = i, ao_num
+
+        ! ---
+
+        coef        = List_all_comb_b2_coef  (1)
+        beta        = List_all_comb_b2_expo  (1)
+        B_center(1) = List_all_comb_b2_cent(1,1)
+        B_center(2) = List_all_comb_b2_cent(2,1)
+        B_center(3) = List_all_comb_b2_cent(3,1)
+
+        call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center,  1.d+9, r, int_c)
+        call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e)
+
+        int_o = overlap_gauss_r12_ao_with1s(B_center, beta, r, mu_erf*mu_erf, i, j)
+
+        tmp = coef                                                                                         &
+            * ( r1_2 * (int_c(1) - int_e(1))                                                               &
+              - r(1) * (int_c(2) - int_e(2)) - r(2) * (int_c(3) - int_e(3)) - r(3) * (int_c(4) - int_e(4)) &
+              + 0.5d0 * (int_c(5) + int_c(6) + int_c(7) - int_e(5) - int_e(6) - int_e(7))                  &
+              - ct * int_o                                                                                 &
+              )
+
+        ! ---
+
+        do i_1s = 2, List_all_comb_b2_size
+
+          coef        = List_all_comb_b2_coef  (i_1s)
+          if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
+          beta        = List_all_comb_b2_expo  (i_1s)
+          B_center(1) = List_all_comb_b2_cent(1,i_1s)
+          B_center(2) = List_all_comb_b2_cent(2,i_1s)
+          B_center(3) = List_all_comb_b2_cent(3,i_1s)
+
+          call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center,  1.d+9, r, int_c)
+          call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e)
+
+          int_o = overlap_gauss_r12_ao_with1s(B_center, beta, r, mu_erf*mu_erf, i, j)
+
+          tmp = tmp + coef                                                                                   &
+              * ( r1_2 * (int_c(1) - int_e(1))                                                               &
+                - r(1) * (int_c(2) - int_e(2)) - r(2) * (int_c(3) - int_e(3)) - r(3) * (int_c(4) - int_e(4)) &
+                + 0.5d0 * (int_c(5) + int_c(6) + int_c(7) - int_e(5) - int_e(6) - int_e(7))                  &
+                - ct * int_o                                                                                 &
+                )
+
+        enddo
+
+        ! ---
+
         v_ij_u_cst_mu_j1b_an(j,i,ipoint) = tmp
       enddo
     enddo
@@ -434,4 +550,3 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin
 END_PROVIDER 
 
 ! ---
-

src/becke_numerical_grid/EZFIO.cfg

@@ -33,6 +33,10 @@ doc: Number of angular grid points given from input. Warning, this number cannot
 interface: ezfio,provider,ocaml
 default: 1202
 
+[n_points_extra_final_grid]
+type: integer
+doc: Total number of extra_grid points 
+interface: ezfio
 
 [extra_grid_type_sgn]
 type: integer

src/becke_numerical_grid/extra_grid_vector.irp.f

@@ -25,7 +25,8 @@ BEGIN_PROVIDER [integer, n_points_extra_final_grid]
 
   print*, ' n_points_extra_final_grid = ', n_points_extra_final_grid
   print*, ' n max point               = ', n_points_extra_integration_angular*(n_points_extra_radial_grid*nucl_num - 1)
-!  call ezfio_set_becke_numerical_grid_n_points_extra_final_grid(n_points_extra_final_grid)
+  call ezfio_set_becke_numerical_grid_n_points_extra_final_grid(n_points_extra_final_grid)
+
 END_PROVIDER
 
 ! ---
@@ -34,7 +35,7 @@ END_PROVIDER
 &BEGIN_PROVIDER [double precision, final_weight_at_r_vector_extra, (n_points_extra_final_grid)]
 &BEGIN_PROVIDER [integer, index_final_points_extra, (3,n_points_extra_final_grid)]
 &BEGIN_PROVIDER [integer, index_final_points_extra_reverse, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)]
-  implicit none
+
   BEGIN_DOC
   !  final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point
   !
@@ -44,8 +45,11 @@ END_PROVIDER
   !
   ! index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
   END_DOC
+
+  implicit none
   integer                        :: i,j,k,l,i_count
   double precision               :: r(3)
+
   i_count = 0
   do j = 1, nucl_num
     do i = 1, n_points_extra_radial_grid -1
@@ -67,3 +71,5 @@ END_PROVIDER
   enddo
 
 END_PROVIDER
+
+

src/becke_numerical_grid/grid_becke.irp.f

@@ -37,6 +37,9 @@
     n_points_integration_angular = my_n_pt_a_grid
   endif
 
+  print*, " n_points_radial_grid         = ", n_points_radial_grid
+  print*, " n_points_integration_angular = ", n_points_integration_angular
+
 END_PROVIDER
 
 ! ---

src/bi_ort_ints/bi_ort_ints.irp.f

@@ -18,10 +18,11 @@ program bi_ort_ints
 ! call test_5idx
 ! call test_5idx2
   call test_4idx()
-  call test_4idx_n4()
+  !call test_4idx_n4()
   !call test_4idx2()
   !call test_5idx2
   !call test_5idx
+
 end
 
 subroutine test_5idx2
@@ -340,7 +341,7 @@ subroutine test_4idx()
 
   implicit none
   integer          :: i, j, k, l
-  double precision :: accu, contrib, new, ref, thr
+  double precision :: accu, contrib, new, ref, thr, norm
 
   thr = 1d-10
 
@@ -348,6 +349,7 @@ subroutine test_4idx()
   PROVIDE three_e_4_idx_direct_bi_ort 
 
   accu = 0.d0
+  norm = 0.d0
   do i = 1, mo_num
     do j = 1, mo_num
       do k = 1, mo_num
@@ -356,7 +358,6 @@ subroutine test_4idx()
           new = three_e_4_idx_direct_bi_ort    (l,k,j,i)
           ref = three_e_4_idx_direct_bi_ort_old(l,k,j,i)
           contrib = dabs(new - ref)
-          accu += contrib
           if(contrib .gt. thr) then
             print*, ' problem in three_e_4_idx_direct_bi_ort'
             print*, l, k, j, i
@@ -364,11 +365,14 @@ subroutine test_4idx()
             stop
           endif
 
+          accu += contrib
+          norm += dabs(ref)
         enddo
       enddo
     enddo
   enddo
-  print*, ' accu on three_e_4_idx_direct_bi_ort = ', accu / dble(mo_num)**4
+
+  print*, ' accu on three_e_4_idx_direct_bi_ort (%) = ', 100.d0 * accu / norm
 
   ! ---
 
@@ -376,6 +380,7 @@ subroutine test_4idx()
   PROVIDE three_e_4_idx_exch13_bi_ort 
 
   accu = 0.d0
+  norm = 0.d0
   do i = 1, mo_num
     do j = 1, mo_num
       do k = 1, mo_num
@@ -384,7 +389,6 @@ subroutine test_4idx()
           new = three_e_4_idx_exch13_bi_ort   (l,k,j,i)
           ref = three_e_4_idx_exch13_bi_ort_old(l,k,j,i)
           contrib = dabs(new - ref)
-          accu += contrib
           if(contrib .gt. thr) then
             print*, ' problem in three_e_4_idx_exch13_bi_ort'
             print*, l, k, j, i
@@ -392,11 +396,14 @@ subroutine test_4idx()
             stop
           endif
 
+          accu += contrib
+          norm += dabs(ref)
         enddo
       enddo
     enddo
   enddo
-  print*, ' accu on three_e_4_idx_exch13_bi_ort = ', accu / dble(mo_num)**4
+
+  print*, ' accu on three_e_4_idx_exch13_bi_ort (%) = ', 100.d0 * accu / norm
 
   ! ---
 
@@ -404,6 +411,7 @@ subroutine test_4idx()
   PROVIDE three_e_4_idx_cycle_1_bi_ort
 
   accu = 0.d0
+  norm = 0.d0
   do i = 1, mo_num
     do j = 1, mo_num
       do k = 1, mo_num
@@ -412,7 +420,6 @@ subroutine test_4idx()
           new = three_e_4_idx_cycle_1_bi_ort    (l,k,j,i)
           ref = three_e_4_idx_cycle_1_bi_ort_old(l,k,j,i)
           contrib = dabs(new - ref)
-          accu += contrib
           if(contrib .gt. thr) then
             print*, ' problem in three_e_4_idx_cycle_1_bi_ort'
             print*, l, k, j, i
@@ -420,11 +427,14 @@ subroutine test_4idx()
             stop
           endif
 
+          accu += contrib
+          norm += dabs(ref)
         enddo
       enddo
     enddo
   enddo
-  print*, ' accu on three_e_4_idx_cycle_1_bi_ort = ', accu / dble(mo_num)**4
+
+  print*, ' accu on three_e_4_idx_cycle_1_bi_ort (%) = ', 100.d0 * accu / norm
 
   ! ---
 
@@ -432,6 +442,7 @@ subroutine test_4idx()
   PROVIDE three_e_4_idx_exch23_bi_ort
 
   accu = 0.d0
+  norm = 0.d0
   do i = 1, mo_num
     do j = 1, mo_num
       do k = 1, mo_num
@@ -440,7 +451,6 @@ subroutine test_4idx()
           new = three_e_4_idx_exch23_bi_ort    (l,k,j,i)
           ref = three_e_4_idx_exch23_bi_ort_old(l,k,j,i)
           contrib = dabs(new - ref)
-          accu += contrib
           if(contrib .gt. thr) then
             print*, ' problem in three_e_4_idx_exch23_bi_ort'
             print*, l, k, j, i
@@ -448,13 +458,18 @@ subroutine test_4idx()
             stop
           endif
 
+          accu += contrib
+          norm += dabs(ref)
         enddo
       enddo
     enddo
   enddo
-  print*, ' accu on three_e_4_idx_exch23_bi_ort = ', accu / dble(mo_num)**4
+
+  print*, ' accu on three_e_4_idx_exch23_bi_ort (%) = ', 100.d0 * accu / norm
 
   ! ---
 
   return
 end
+
+

src/bi_ort_ints/no_dressing_naive.irp.f

@@ -0,0 +1,518 @@
+
+! ---
+
+BEGIN_PROVIDER [double precision, noL_0e_naive]
+
+  implicit none
+  integer                       :: ii, jj, kk
+  integer                       :: i, j, k
+  double precision              :: sigma_i, sigma_j, sigma_k
+  double precision              :: I_ijk_ijk, I_ijk_kij, I_ijk_jki, I_ijk_jik, I_ijk_kji, I_ijk_ikj
+  double precision              :: t0, t1
+  double precision, allocatable :: tmp(:)
+
+  print*, " Providing noL_0e_naive ..."
+  call wall_time(t0)
+
+  allocate(tmp(elec_num))
+
+  !$OMP PARALLEL                                                 &
+  !$OMP DEFAULT (NONE)                                           &
+  !$OMP PRIVATE (ii, i, sigma_i, jj, j, sigma_j, kk, k, sigma_k, &
+  !$OMP          I_ijk_ijk, I_ijk_kij, I_ijk_jki, I_ijk_jik,     &
+  !$OMP          I_ijk_kji, I_ijk_ikj)                           &
+  !$OMP SHARED (elec_beta_num, elec_num, tmp)
+  !$OMP DO
+
+  do ii = 1, elec_num
+
+    if(ii .le. elec_beta_num) then
+      i       = ii 
+      sigma_i = -1.d0
+    else
+      i       = ii - elec_beta_num
+      sigma_i = +1.d0
+    endif
+
+    tmp(ii) = 0.d0
+
+    do jj = 1, elec_num
+
+      if(jj .le. elec_beta_num) then
+        j       = jj
+        sigma_j = -1.d0
+      else
+        j       = jj - elec_beta_num
+        sigma_j = +1.d0
+      endif
+
+      do kk = 1, elec_num
+
+        if(kk .le. elec_beta_num) then
+          k       = kk
+          sigma_k = -1.d0
+        else
+          k       = kk - elec_beta_num
+          sigma_k = +1.d0
+        endif
+
+        call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
+                                              , i, sigma_i, j, sigma_j, k, sigma_k &
+                                              , I_ijk_ijk)
+
+        call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
+                                              , k, sigma_k, i, sigma_i, j, sigma_j &
+                                              , I_ijk_kij)
+
+        call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
+                                              , j, sigma_j, k, sigma_k, i, sigma_i &
+                                              , I_ijk_jki)
+
+        call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
+                                              , j, sigma_j, i, sigma_i, k, sigma_k &
+                                              , I_ijk_jik)
+
+        call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
+                                              , k, sigma_k, j, sigma_j, i, sigma_i &
+                                              , I_ijk_kji)
+
+        call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
+                                              , i, sigma_i, k, sigma_k, j, sigma_j &
+                                              , I_ijk_ikj)
+
+
+        tmp(ii) = tmp(ii) + I_ijk_ijk + I_ijk_kij + I_ijk_jki - I_ijk_jik - I_ijk_kji - I_ijk_ikj
+        !       = tmp(ii) + I_ijk_ijk + 2.d0 * I_ijk_kij - 3.d0 * I_ijk_jik
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  noL_0e_naive = -1.d0 * (-sum(tmp)) / 6.d0
+
+  deallocate(tmp)
+
+  call wall_time(t1)
+  print*, " Wall time for noL_0e_naive (min) = ", (t1 - t0)/60.d0
+
+  print*, " noL_0e_naive = ", noL_0e_naive
+  
+END_PROVIDER
+
+! ---
+
+BEGIN_PROVIDER [double precision, noL_1e_naive, (mo_num, mo_num)]
+
+  BEGIN_DOC
+  ! 
+  ! < p | H(1) | s > is dressed with noL_1e_naive(p,s)
+  !
+  END_DOC
+
+  implicit none
+  integer          :: ii, jj
+  integer          :: i, j, p, s
+  double precision :: sigma_i, sigma_j, sigma_p, sigma_s
+  double precision :: I_pij_sji, I_pij_sij, I_pij_jis, I_pij_ijs, I_pij_isj, I_pij_jsi
+  double precision :: t0, t1
+
+  print*, " Providing noL_1e_naive ..."
+  call wall_time(t0)
+
+  ! ----
+  ! up-up part
+
+  sigma_p = +1.d0
+  sigma_s = +1.d0
+
+  !$OMP PARALLEL                                   &
+  !$OMP DEFAULT (NONE)                             &
+  !$OMP PRIVATE (ii, i, sigma_i, jj, j, sigma_j,   &
+  !$OMP          I_pij_sji, I_pij_sij, I_pij_jis,  & 
+  !$OMP          I_pij_ijs, I_pij_isj, I_pij_jsi ) &
+  !$OMP SHARED (mo_num, elec_beta_num, elec_num,   &
+  !$OMP         sigma_p, sigma_s, noL_1e_naive)
+
+  !$OMP DO COLLAPSE (2)
+
+  do s = 1, mo_num
+    do p = 1, mo_num
+
+      noL_1e_naive(p,s) = 0.d0
+      do ii = 1, elec_num
+        if(ii .le. elec_beta_num) then
+          i       = ii 
+          sigma_i = -1.d0
+        else
+          i       = ii - elec_beta_num
+          sigma_i = +1.d0
+        endif
+
+        do jj = 1, elec_num
+          if(jj .le. elec_beta_num) then
+            j       = jj
+            sigma_j = -1.d0
+          else
+            j       = jj - elec_beta_num
+            sigma_j = +1d0
+          endif
+
+          call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
+                                                , s, sigma_s, j, sigma_j, i, sigma_i &
+                                                , I_pij_sji)
+  
+          call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
+                                                , s, sigma_s, i, sigma_i, j, sigma_j &
+                                                , I_pij_sij)
+  
+          call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
+                                                , j, sigma_j, i, sigma_i, s, sigma_s &
+                                                , I_pij_jis)
+  
+          call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
+                                                , i, sigma_i, j, sigma_j, s, sigma_s &
+                                                , I_pij_ijs)
+  
+          call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
+                                                , i, sigma_i, s, sigma_s, j, sigma_j &
+                                                , I_pij_isj)
+  
+          call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
+                                                , j, sigma_j, s, sigma_s, i, sigma_i &
+                                                , I_pij_jsi)
+
+          ! x (-1) because integrals are over -L
+          ! x 0.5  because we consider 0.5 (up + down)
+          noL_1e_naive(p,s) = noL_1e_naive(p,s) + 0.25d0 * (I_pij_sji - I_pij_sij + I_pij_jis - I_pij_ijs + I_pij_isj - I_pij_jsi)
+        enddo ! j
+      enddo ! i
+    enddo ! s
+  enddo ! p
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+
+  ! ----
+  ! down-down part
+
+  sigma_p = -1.d0
+  sigma_s = -1.d0
+
+  !$OMP PARALLEL                                   &
+  !$OMP DEFAULT (NONE)                             &
+  !$OMP PRIVATE (ii, i, sigma_i, jj, j, sigma_j,   &
+  !$OMP          I_pij_sji, I_pij_sij, I_pij_jis,  & 
+  !$OMP          I_pij_ijs, I_pij_isj, I_pij_jsi ) &
+  !$OMP SHARED (mo_num, elec_beta_num, elec_num,   &
+  !$OMP         sigma_p, sigma_s, noL_1e_naive)
+
+  !$OMP DO COLLAPSE (2)
+
+  do s = 1, mo_num
+    do p = 1, mo_num
+
+      do ii = 1, elec_num
+        if(ii .le. elec_beta_num) then
+          i       = ii 
+          sigma_i = -1.d0
+        else
+          i       = ii - elec_beta_num
+          sigma_i = +1.d0
+        endif
+
+        do jj = 1, elec_num
+          if(jj .le. elec_beta_num) then
+            j       = jj
+            sigma_j = -1.d0
+          else
+            j       = jj - elec_beta_num
+            sigma_j = +1d0
+          endif
+
+          call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
+                                                , s, sigma_s, j, sigma_j, i, sigma_i &
+                                                , I_pij_sji)
+  
+          call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
+                                                , s, sigma_s, i, sigma_i, j, sigma_j &
+                                                , I_pij_sij)
+  
+          call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
+                                                , j, sigma_j, i, sigma_i, s, sigma_s &
+                                                , I_pij_jis)
+  
+          call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
+                                                , i, sigma_i, j, sigma_j, s, sigma_s &
+                                                , I_pij_ijs)
+  
+          call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
+                                                , i, sigma_i, s, sigma_s, j, sigma_j &
+                                                , I_pij_isj)
+  
+          call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
+                                                , j, sigma_j, s, sigma_s, i, sigma_i &
+                                                , I_pij_jsi)
+
+          ! x (-1) because integrals are over -L
+          ! x 0.5  because we consider 0.5 (up + down)
+          noL_1e_naive(p,s) = noL_1e_naive(p,s) + 0.25d0 * (I_pij_sji - I_pij_sij + I_pij_jis - I_pij_ijs + I_pij_isj - I_pij_jsi)
+        enddo ! j
+      enddo ! i
+    enddo ! s
+  enddo ! p
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  ! ---
+
+  call wall_time(t1)
+  print*, " Wall time for noL_1e_naive (min) = ", (t1 - t0)/60.d0
+
+END_PROVIDER
+
+! ---
+
+BEGIN_PROVIDER [double precision, noL_2e_naive, (mo_num, mo_num, mo_num, mo_num)]
+
+  BEGIN_DOC
+  ! 
+  ! < p q | H(2) | s t > is dressed with noL_2e_naive(p,q,s,t)
+  !
+  END_DOC
+
+  implicit none
+  integer          :: ii
+  integer          :: i, p, q, s, t
+  double precision :: sigma_i, sigma_p, sigma_q, sigma_s, sigma_t
+  double precision :: I_ipq_ist, I_ipq_sit, I_ipq_tsi
+  double precision :: t0, t1
+
+  print*, " Providing noL_2e_naive ..."
+  call wall_time(t0)
+
+  ! ----
+  ! up-up & up-up part
+
+  sigma_p = +1.d0
+  sigma_s = +1.d0
+  sigma_q = +1.d0
+  sigma_t = +1.d0
+
+  !$OMP PARALLEL                                    &
+  !$OMP DEFAULT (NONE)                              &
+  !$OMP PRIVATE (ii, i, sigma_i, p, q, s, t,        &
+  !$OMP          I_ipq_ist, I_ipq_sit, I_ipq_tsi)   &
+  !$OMP SHARED (mo_num, elec_beta_num, elec_num,    &
+  !$OMP         sigma_p, sigma_q, sigma_s, sigma_t, &
+  !$OMP         noL_2e_naive)
+
+  !$OMP DO COLLAPSE (4)
+  do t = 1, mo_num
+    do s = 1, mo_num
+      do q = 1, mo_num
+        do p = 1, mo_num
+
+          noL_2e_naive(p,q,s,t) = 0.d0
+          do ii = 1, elec_num
+            if(ii .le. elec_beta_num) then
+              i       = ii 
+              sigma_i = -1.d0
+            else
+              i       = ii - elec_beta_num
+              sigma_i = +1.d0
+            endif
+
+            call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
+                                                  , i, sigma_i, s, sigma_s, t, sigma_t &
+                                                  , I_ipq_ist)
+
+            call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
+                                                  , s, sigma_s, i, sigma_i, t, sigma_t &
+                                                  , I_ipq_sit)
+
+            call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
+                                                  , t, sigma_t, s, sigma_s, i, sigma_i &
+                                                  , I_ipq_tsi)
+
+            ! x (-1) because integrals are over -L
+            ! x 0.25  because we consider 0.25 (up-up + up-down + down-up + down-down)
+            noL_2e_naive(p,q,s,t) = noL_2e_naive(p,q,s,t) + 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
+          enddo ! i
+        enddo ! p
+      enddo ! q
+    enddo ! s
+  enddo ! t
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  ! ----
+  ! up-up & down-down part
+
+  sigma_p = +1.d0
+  sigma_s = +1.d0
+  sigma_q = -1.d0
+  sigma_t = -1.d0
+
+  !$OMP PARALLEL                                    &
+  !$OMP DEFAULT (NONE)                              &
+  !$OMP PRIVATE (ii, i, sigma_i, p, q, s, t,        &
+  !$OMP          I_ipq_ist, I_ipq_sit, I_ipq_tsi)   &
+  !$OMP SHARED (mo_num, elec_beta_num, elec_num,    &
+  !$OMP         sigma_p, sigma_q, sigma_s, sigma_t, &
+  !$OMP         noL_2e_naive)
+
+  !$OMP DO COLLAPSE (4)
+  do t = 1, mo_num
+    do s = 1, mo_num
+      do q = 1, mo_num
+        do p = 1, mo_num
+
+          do ii = 1, elec_num
+            if(ii .le. elec_beta_num) then
+              i       = ii 
+              sigma_i = -1.d0
+            else
+              i       = ii - elec_beta_num
+              sigma_i = +1.d0
+            endif
+
+            call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
+                                                  , i, sigma_i, s, sigma_s, t, sigma_t &
+                                                  , I_ipq_ist)
+
+            call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
+                                                  , s, sigma_s, i, sigma_i, t, sigma_t &
+                                                  , I_ipq_sit)
+
+            call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
+                                                  , t, sigma_t, s, sigma_s, i, sigma_i &
+                                                  , I_ipq_tsi)
+
+            ! x (-1) because integrals are over -L
+            ! x 0.25  because we consider 0.25 (up-up + up-down + down-up + down-down)
+            noL_2e_naive(p,q,s,t) = noL_2e_naive(p,q,s,t) + 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
+          enddo ! i
+        enddo ! p
+      enddo ! q
+    enddo ! s
+  enddo ! t
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  ! ----
+  ! down-down & up-up part
+
+  sigma_p = -1.d0
+  sigma_s = -1.d0
+  sigma_q = +1.d0
+  sigma_t = +1.d0
+
+  !$OMP PARALLEL                                    &
+  !$OMP DEFAULT (NONE)                              &
+  !$OMP PRIVATE (ii, i, sigma_i, p, q, s, t,        &
+  !$OMP          I_ipq_ist, I_ipq_sit, I_ipq_tsi)   &
+  !$OMP SHARED (mo_num, elec_beta_num, elec_num,    &
+  !$OMP         sigma_p, sigma_q, sigma_s, sigma_t, &
+  !$OMP         noL_2e_naive)
+
+  !$OMP DO COLLAPSE (4)
+  do t = 1, mo_num
+    do s = 1, mo_num
+      do q = 1, mo_num
+        do p = 1, mo_num
+
+          do ii = 1, elec_num
+            if(ii .le. elec_beta_num) then
+              i       = ii 
+              sigma_i = -1.d0
+            else
+              i       = ii - elec_beta_num
+              sigma_i = +1.d0
+            endif
+
+            call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
+                                                  , i, sigma_i, s, sigma_s, t, sigma_t &
+                                                  , I_ipq_ist)
+
+            call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
+                                                  , s, sigma_s, i, sigma_i, t, sigma_t &
+                                                  , I_ipq_sit)
+
+            call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
+                                                  , t, sigma_t, s, sigma_s, i, sigma_i &
+                                                  , I_ipq_tsi)
+
+            ! x (-1) because integrals are over -L
+            ! x 0.25  because we consider 0.25 (up-up + up-down + down-up + down-down)
+            noL_2e_naive(p,q,s,t) = noL_2e_naive(p,q,s,t) + 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
+          enddo ! i
+        enddo ! p
+      enddo ! q
+    enddo ! s
+  enddo ! t
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  ! ----
+  ! down-down & down-down part
+
+  sigma_p = -1.d0
+  sigma_s = -1.d0
+  sigma_q = -1.d0
+  sigma_t = -1.d0
+
+  !$OMP PARALLEL                                    &
+  !$OMP DEFAULT (NONE)                              &
+  !$OMP PRIVATE (ii, i, sigma_i, p, q, s, t,        &
+  !$OMP          I_ipq_ist, I_ipq_sit, I_ipq_tsi)   &
+  !$OMP SHARED (mo_num, elec_beta_num, elec_num,    &
+  !$OMP         sigma_p, sigma_q, sigma_s, sigma_t, &
+  !$OMP         noL_2e_naive)
+
+  !$OMP DO COLLAPSE (4)
+  do t = 1, mo_num
+    do s = 1, mo_num
+      do q = 1, mo_num
+        do p = 1, mo_num
+
+          do ii = 1, elec_num
+            if(ii .le. elec_beta_num) then
+              i       = ii 
+              sigma_i = -1.d0
+            else
+              i       = ii - elec_beta_num
+              sigma_i = +1.d0
+            endif
+
+            call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
+                                                  , i, sigma_i, s, sigma_s, t, sigma_t &
+                                                  , I_ipq_ist)
+
+            call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
+                                                  , s, sigma_s, i, sigma_i, t, sigma_t &
+                                                  , I_ipq_sit)
+
+            call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
+                                                  , t, sigma_t, s, sigma_s, i, sigma_i &
+                                                  , I_ipq_tsi)
+
+            ! x (-1) because integrals are over -L
+            ! x 0.25  because we consider 0.25 (up-up + up-down + down-up + down-down)
+            noL_2e_naive(p,q,s,t) = noL_2e_naive(p,q,s,t) + 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
+          enddo ! i
+        enddo ! p
+      enddo ! q
+    enddo ! s
+  enddo ! t
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  call wall_time(t1)
+  print*, " Wall time for noL_2e_naive (min) = ", (t1 - t0)/60.d0
+
+END_PROVIDER
+
+! ---
+
+

src/bi_ort_ints/no_dressing_v0.irp.f

@@ -0,0 +1,336 @@
+
+! ---
+
+BEGIN_PROVIDER [double precision, noL_0e]
+
+  implicit none
+  integer                       :: i, j, k
+  double precision              :: I_ijk_ijk, I_ijk_kij, I_ijk_jik, I_ijk_jki, I_ijk_ikj, I_ijk_kji
+  double precision              :: t0, t1
+  double precision, allocatable :: tmp(:)
+
+  call wall_time(t0)
+  print*, " Providing noL_0e ..."
+
+  if(elec_alpha_num .eq. elec_beta_num) then
+
+    allocate(tmp(elec_beta_num))
+
+    !$OMP PARALLEL                                 &
+    !$OMP DEFAULT (NONE)                           &
+    !$OMP PRIVATE (i, j, k,                        &
+    !$OMP         I_ijk_ijk, I_ijk_kij, I_ijk_jik) &
+    !$OMP SHARED (elec_beta_num, tmp)
+
+    !$OMP DO
+    do i = 1, elec_beta_num
+
+      tmp(i) = 0.d0
+      do j = 1, elec_beta_num
+        do k = 1, elec_beta_num
+
+          call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk)
+          call give_integrals_3_body_bi_ort(i, j, k, k, i, j, I_ijk_kij)
+          call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik)
+
+          tmp(i) = tmp(i) + 4.d0 * (2.d0 * I_ijk_ijk + I_ijk_kij - 3.d0 * I_ijk_jik)
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+    noL_0e = -1.d0 * (-sum(tmp)) / 6.d0
+
+    deallocate(tmp)
+
+  else
+
+    allocate(tmp(elec_alpha_num))
+
+    !$OMP PARALLEL                                 &
+    !$OMP DEFAULT (NONE)                           &
+    !$OMP PRIVATE (i, j, k,                        &
+    !$OMP         I_ijk_ijk, I_ijk_kij, I_ijk_jik, &
+    !$OMP         I_ijk_jki, I_ijk_ikj, I_ijk_kji) &
+    !$OMP SHARED (elec_beta_num, elec_alpha_num, tmp)
+
+    !$OMP DO
+    do i = 1, elec_beta_num
+
+      tmp(i) = 0.d0
+      do j = 1, elec_beta_num
+        do k = 1, elec_beta_num
+
+          call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk)
+          call give_integrals_3_body_bi_ort(i, j, k, k, i, j, I_ijk_kij)
+          call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik)
+
+          tmp(i) = tmp(i) + 4.d0 * (2.d0 * I_ijk_ijk + I_ijk_kij - 3.d0 * I_ijk_jik)
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+
+    !$OMP DO
+    do i = elec_beta_num+1, elec_alpha_num
+
+      tmp(i) = 0.d0
+      do j = elec_beta_num+1, elec_alpha_num
+        do k = elec_beta_num+1, elec_alpha_num
+
+          call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk)
+          call give_integrals_3_body_bi_ort(i, j, k, k, i, j, I_ijk_kij)
+          call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik)
+
+          tmp(i) = tmp(i) + I_ijk_ijk + 2.d0 * I_ijk_kij - 3.d0 * I_ijk_jik
+        enddo ! k
+      enddo ! j
+
+      do j = 1, elec_beta_num
+        do k = 1, elec_beta_num
+
+          call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk)
+          call give_integrals_3_body_bi_ort(i, j, k, j, k, i, I_ijk_jki)
+          call give_integrals_3_body_bi_ort(i, j, k, i, k, j, I_ijk_ikj)
+          call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik)
+          call give_integrals_3_body_bi_ort(i, j, k, k, j, i, I_ijk_kji)
+
+          tmp(i) = tmp(i) + 6.d0 * (2.d0 * I_ijk_ijk + I_ijk_jki - I_ijk_ikj - I_ijk_jik - I_ijk_kji)
+        enddo ! k
+
+        do k = elec_beta_num+1, elec_alpha_num
+
+          call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk)
+          call give_integrals_3_body_bi_ort(i, j, k, j, k, i, I_ijk_jki)
+          call give_integrals_3_body_bi_ort(i, j, k, i, k, j, I_ijk_ikj)
+          call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik)
+          call give_integrals_3_body_bi_ort(i, j, k, k, j, i, I_ijk_kji)
+
+          tmp(i) = tmp(i) + 3.d0 * (2.d0 * I_ijk_ijk + 2.d0 * I_ijk_jki - I_ijk_ikj - I_ijk_jik - 2.d0 * I_ijk_kji)
+        enddo ! k
+      enddo ! j
+    enddo ! i
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+    noL_0e = -1.d0 * (-sum(tmp)) / 6.d0
+
+    deallocate(tmp)
+
+  endif
+
+  call wall_time(t1)
+  print*, " Wall time for noL_0e (min) = ", (t1 - t0)/60.d0
+
+  print*, " noL_0e = ", noL_0e
+
+END_PROVIDER
+
+! ---
+
+BEGIN_PROVIDER [double precision, noL_1e, (mo_num, mo_num)]
+
+  BEGIN_DOC
+  !
+  ! x (-1) because integrals are over -L
+  !
+  END_DOC
+
+  implicit none
+  integer          :: p, s, i, j
+  double precision :: I_pij_sij, I_pij_isj, I_pij_ijs, I_pij_sji, I_pij_jsi, I_pij_jis
+  double precision :: t0, t1
+
+  call wall_time(t0)
+  print*, " Providing noL_1e ..."
+
+  if(elec_alpha_num .eq. elec_beta_num) then
+
+    !$OMP PARALLEL                                 &
+    !$OMP DEFAULT (NONE)                           &
+    !$OMP PRIVATE (p, s, i, j,                     &
+    !$OMP         I_pij_sij, I_pij_isj, I_pij_ijs, &
+    !$OMP         I_pij_sji)                       &
+    !$OMP SHARED (mo_num, elec_beta_num, noL_1e)
+
+    !$OMP DO COLLAPSE(2)
+    do s = 1, mo_num
+      do p = 1, mo_num
+  
+        noL_1e(p,s) = 0.d0
+        do i = 1, elec_beta_num
+          do j = 1, elec_beta_num
+
+            call give_integrals_3_body_bi_ort(p, i, j, s, i, j, I_pij_sij)
+            call give_integrals_3_body_bi_ort(p, i, j, i, s, j, I_pij_isj)
+            call give_integrals_3_body_bi_ort(p, i, j, i, j, s, I_pij_ijs)
+            call give_integrals_3_body_bi_ort(p, i, j, s, j, i, I_pij_sji)
+          
+            noL_1e(p,s) = noL_1e(p,s) - (2.d0*I_pij_sij - 2.d0*I_pij_isj + I_pij_ijs - I_pij_sji)
+          enddo
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+  else
+
+    !$OMP PARALLEL                                 &
+    !$OMP DEFAULT (NONE)                           &
+    !$OMP PRIVATE (p, s, i, j,                     &
+    !$OMP         I_pij_sij, I_pij_isj, I_pij_ijs, &
+    !$OMP         I_pij_sji, I_pij_jsi, I_pij_jis) &
+    !$OMP SHARED (mo_num, elec_beta_num, elec_alpha_num, noL_1e)
+
+    !$OMP DO COLLAPSE(2)
+    do s = 1, mo_num
+      do p = 1, mo_num
+  
+        noL_1e(p,s) = 0.d0
+        do i = 1, elec_beta_num
+          do j = 1, elec_beta_num
+
+            call give_integrals_3_body_bi_ort(p, i, j, s, i, j, I_pij_sij)
+            call give_integrals_3_body_bi_ort(p, i, j, i, s, j, I_pij_isj)
+            call give_integrals_3_body_bi_ort(p, i, j, i, j, s, I_pij_ijs)
+            call give_integrals_3_body_bi_ort(p, i, j, s, j, i, I_pij_sji)
+          
+            noL_1e(p,s) = noL_1e(p,s) - (2.d0*I_pij_sij - 2.d0*I_pij_isj + I_pij_ijs - I_pij_sji)
+          enddo ! j
+        enddo ! i
+
+        do i = elec_beta_num+1, elec_alpha_num
+          do j = 1, elec_beta_num
+
+            call give_integrals_3_body_bi_ort(p, i, j, s, j, i, I_pij_sji)
+            call give_integrals_3_body_bi_ort(p, i, j, j, s, i, I_pij_jsi)
+            call give_integrals_3_body_bi_ort(p, i, j, j, i, s, I_pij_jis)
+            call give_integrals_3_body_bi_ort(p, i, j, s, i, j, I_pij_sij)
+            call give_integrals_3_body_bi_ort(p, i, j, i, s, j, I_pij_isj)
+            call give_integrals_3_body_bi_ort(p, i, j, i, j, s, I_pij_ijs)
+          
+            noL_1e(p,s) = noL_1e(p,s) + 0.5d0 * (2.d0*I_pij_sji - I_pij_jsi + 2.d0*I_pij_jis - 4.d0*I_pij_sij + 2.d0*I_pij_isj - I_pij_ijs)
+          enddo ! j
+
+          do j = elec_beta_num+1, elec_alpha_num
+
+            call give_integrals_3_body_bi_ort(p, i, j, s, i, j, I_pij_sij)
+            call give_integrals_3_body_bi_ort(p, i, j, i, s, j, I_pij_isj)
+            call give_integrals_3_body_bi_ort(p, i, j, i, j, s, I_pij_ijs)
+            call give_integrals_3_body_bi_ort(p, i, j, s, j, i, I_pij_sji)
+          
+            noL_1e(p,s) = noL_1e(p,s) - 0.5d0 * (I_pij_sij - I_pij_isj + I_pij_ijs - I_pij_sji)
+          enddo ! j
+        enddo ! i
+
+      enddo ! p
+    enddo ! s
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+  endif
+
+  call wall_time(t1)
+  print*, " Wall time for noL_1e (min) = ", (t1 - t0)/60.d0
+
+END_PROVIDER
+
+! ---
+
+BEGIN_PROVIDER [double precision, noL_2e, (mo_num, mo_num, mo_num, mo_num)]
+
+  BEGIN_DOC
+  !
+  ! x (-1) because integrals are over -L
+  !
+  END_DOC
+
+  implicit none
+  integer          :: p, q, s, t, i
+  double precision :: I_ipq_sit, I_ipq_tsi, I_ipq_ist
+  double precision :: t0, t1
+
+  call wall_time(t0)
+  print*, " Providing noL_2e ..."
+
+  if(elec_alpha_num .eq. elec_beta_num) then
+
+    !$OMP PARALLEL                                  &
+    !$OMP DEFAULT (NONE)                            &
+    !$OMP PRIVATE (p, q, s, t, i,                   &
+    !$OMP          I_ipq_sit, I_ipq_tsi, I_ipq_ist) &
+    !$OMP SHARED (mo_num, elec_beta_num, noL_2e)
+
+    !$OMP DO COLLAPSE(4)
+    do t = 1, mo_num
+      do s = 1, mo_num
+        do q = 1, mo_num
+          do p = 1, mo_num
+  
+            noL_2e(p,q,s,t) = 0.d0
+            do i = 1, elec_beta_num
+
+              call give_integrals_3_body_bi_ort(i, p, q, s, i, t, I_ipq_sit)
+              call give_integrals_3_body_bi_ort(i, p, q, t, s, i, I_ipq_tsi)
+              call give_integrals_3_body_bi_ort(i, p, q, i, s, t, I_ipq_ist)
+          
+              noL_2e(p,q,s,t) = noL_2e(p,q,s,t) - 0.5d0 * (I_ipq_sit + I_ipq_tsi - 2.d0*I_ipq_ist)
+            enddo
+          enddo
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+  else
+
+    !$OMP PARALLEL                                  &
+    !$OMP DEFAULT (NONE)                            &
+    !$OMP PRIVATE (p, q, s, t, i,                   &
+    !$OMP          I_ipq_sit, I_ipq_tsi, I_ipq_ist) &
+    !$OMP SHARED (mo_num, elec_beta_num, elec_alpha_num, noL_2e)
+
+    !$OMP DO COLLAPSE(4)
+    do t = 1, mo_num
+      do s = 1, mo_num
+        do q = 1, mo_num
+          do p = 1, mo_num
+  
+            noL_2e(p,q,s,t) = 0.d0
+            do i = 1, elec_beta_num
+
+              call give_integrals_3_body_bi_ort(i, p, q, s, i, t, I_ipq_sit)
+              call give_integrals_3_body_bi_ort(i, p, q, t, s, i, I_ipq_tsi)
+              call give_integrals_3_body_bi_ort(i, p, q, i, s, t, I_ipq_ist)
+            
+              noL_2e(p,q,s,t) = noL_2e(p,q,s,t) - 0.5d0 * (I_ipq_sit + I_ipq_tsi - 2.d0*I_ipq_ist)
+            enddo ! i
+
+            do i = elec_beta_num+1, elec_alpha_num
+
+              call give_integrals_3_body_bi_ort(i, p, q, s, i, t, I_ipq_sit)
+              call give_integrals_3_body_bi_ort(i, p, q, t, s, i, I_ipq_tsi)
+              call give_integrals_3_body_bi_ort(i, p, q, i, s, t, I_ipq_ist)
+            
+              noL_2e(p,q,s,t) = noL_2e(p,q,s,t) - 0.25d0 * (I_ipq_sit + I_ipq_tsi - 2.d0*I_ipq_ist)
+            enddo ! i
+
+          enddo ! p
+        enddo ! q
+      enddo ! s
+    enddo ! t
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+  endif
+
+  call wall_time(t1)
+  print*, " Wall time for noL_2e (min) = ", (t1 - t0)/60.d0
+
+END_PROVIDER
+
+! ---
+

src/bi_ort_ints/one_e_bi_ort.irp.f

@@ -41,6 +41,11 @@ BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)]
  
   call ao_to_mo_bi_ortho(ao_one_e_integrals_tc_tot, ao_num, mo_bi_ortho_tc_one_e, mo_num)
 
+  if(noL_standard) then
+    PROVIDE noL_1e
+    mo_bi_ortho_tc_one_e = mo_bi_ortho_tc_one_e + noL_1e
+  endif
+
 END_PROVIDER 
 
 ! ---

src/bi_ort_ints/three_body_ijmk.irp.f

@@ -64,22 +64,37 @@
   !$OMP END DO
   !$OMP END PARALLEL
 
+
+
+
+
+  ! loops approach to break the O(N^4) scaling in memory
+
+  call set_multiple_levels_omp(.false.)
+
+  !$OMP PARALLEL                                                            &
+  !$OMP DEFAULT (NONE)                                                      &
+  !$OMP PRIVATE (n, ipoint, tmp_loc_1, tmp_loc_2, tmp_2d, tmp1, tmp2)       &
+  !$OMP SHARED (mo_num, n_points_final_grid, i, k,                          &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp,           &
+  !$OMP         int2_grad1_u12_bimo_t, final_weight_at_r_vector,            &
+  !$OMP         tmp_aux_1, tmp_aux_2,                                       &
+  !$OMP         three_e_4_idx_direct_bi_ort, three_e_4_idx_exch13_bi_ort,   &
+  !$OMP         three_e_4_idx_exch23_bi_ort, three_e_4_idx_cycle_1_bi_ort)
+
   allocate(tmp_2d(mo_num,mo_num))
   allocate(tmp1(n_points_final_grid,4,mo_num))
   allocate(tmp2(n_points_final_grid,4,mo_num))
 
-  ! loops approach to break the O(N^4) scaling in memory
+  !$OMP DO
   do k = 1, mo_num
+
+    ! ---
+
     do i = 1, mo_num
 
-    !$OMP PARALLEL                                                  &
+      ! ---
-    !$OMP DEFAULT (NONE)                                            &
+
-    !$OMP PRIVATE (n, ipoint, tmp_loc_1, tmp_loc_2)                 &
-    !$OMP SHARED (mo_num, n_points_final_grid, i, k,                &
-    !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
-    !$OMP         int2_grad1_u12_bimo_t, final_weight_at_r_vector,  &
-    !$OMP         tmp_aux_2, tmp1)
-    !$OMP DO
       do n = 1, mo_num
         do ipoint = 1, n_points_final_grid
 
@@ -95,31 +110,19 @@
 
         enddo
       enddo
-    !$OMP END DO
-    !$OMP END PARALLEL
 
       call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0                       &
                 , tmp_aux_1(1,1,1), 4*n_points_final_grid, tmp1(1,1,1), 4*n_points_final_grid &
                 , 0.d0, tmp_2d(1,1), mo_num)
 
-    !$OMP PARALLEL DO PRIVATE(j,m)
       do j = 1, mo_num
         do m = 1, mo_num
           three_e_4_idx_direct_bi_ort(m,j,k,i) = -tmp_2d(m,j)
         enddo
       enddo
-    !$OMP END PARALLEL DO
 
+      ! ---
 
-
-    !$OMP PARALLEL                                                  &
-    !$OMP DEFAULT (NONE)                                            &
-    !$OMP PRIVATE (n, ipoint, tmp_loc_1, tmp_loc_2)                 &
-    !$OMP SHARED (mo_num, n_points_final_grid, i, k,                &
-    !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
-    !$OMP         int2_grad1_u12_bimo_t, final_weight_at_r_vector,  &
-    !$OMP         tmp1, tmp2)
-    !$OMP DO
       do n = 1, mo_num
         do ipoint = 1, n_points_final_grid
       
@@ -139,45 +142,39 @@
           tmp2(ipoint,4,n) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,n)
         enddo
       enddo
-    !$OMP END DO
+
-    !$OMP END PARALLEL
+      ! ---
 
       call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0                       &
                 , tmp1(1,1,1), 4*n_points_final_grid, tmp_aux_1(1,1,1), 4*n_points_final_grid &
                 , 0.d0, tmp_2d(1,1), mo_num)
 
-    !$OMP PARALLEL DO PRIVATE(j,m)
       do j = 1, mo_num
         do m = 1, mo_num
           three_e_4_idx_exch13_bi_ort(m,j,k,i) = -tmp_2d(m,j)
         enddo
       enddo
-    !$OMP END PARALLEL DO
+
+      ! ---
 
       call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0                  &
                 , tmp1(1,1,1), 4*n_points_final_grid, tmp2(1,1,1), 4*n_points_final_grid &
                 , 0.d0, tmp_2d(1,1), mo_num)
 
-    !$OMP PARALLEL DO PRIVATE(j,m)
       do j = 1, mo_num
         do m = 1, mo_num
           three_e_4_idx_cycle_1_bi_ort(m,i,k,j) = -tmp_2d(m,j)
         enddo
       enddo
-    !$OMP END PARALLEL DO
+
+      ! ---
 
     enddo ! i
 
+    ! ---
+
     do j = 1, mo_num
 
-      !$OMP PARALLEL                                                  &
-      !$OMP DEFAULT (NONE)                                            &
-      !$OMP PRIVATE (n, ipoint, tmp_loc_1, tmp_loc_2)                 &
-      !$OMP SHARED (mo_num, n_points_final_grid, j, k,                &
-      !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
-      !$OMP         int2_grad1_u12_bimo_t, final_weight_at_r_vector,  &
-      !$OMP         tmp1, tmp2)
-      !$OMP DO
       do n = 1, mo_num
         do ipoint = 1, n_points_final_grid
 
@@ -197,31 +194,33 @@
           tmp2(ipoint,4,n) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,n)
         enddo
       enddo
-      !$OMP END DO
-      !$OMP END PARALLEL
 
       call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0                  &
                 , tmp1(1,1,1), 4*n_points_final_grid, tmp2(1,1,1), 4*n_points_final_grid &
                 , 0.d0, tmp_2d(1,1), mo_num)
 
-      !$OMP PARALLEL DO PRIVATE(i,m)
       do i = 1, mo_num
         do m = 1, mo_num
           three_e_4_idx_exch23_bi_ort(m,j,k,i) = -tmp_2d(m,i)
         enddo
       enddo
-      !$OMP END PARALLEL DO
 
     enddo ! j
+
+    ! ---
+
   enddo !k
+  !$OMP END DO
 
   deallocate(tmp_2d)
   deallocate(tmp1)
   deallocate(tmp2)
+
+  !$OMP END PARALLEL
+
   deallocate(tmp_aux_1)
   deallocate(tmp_aux_2)
 
-
   call wall_time(wall1)
   print *, ' wall time for three_e_4_idx_bi_ort', wall1 - wall0
   call print_memory_usage()

src/bi_ort_ints/three_body_ints_bi_ort.irp.f

@@ -68,6 +68,60 @@ END_PROVIDER
 
 ! ---
 
+subroutine give_integrals_3_body_bi_ort_spin( n, sigma_n, l, sigma_l, k, sigma_k &
+                                            , m, sigma_m, j, sigma_j, i, sigma_i &
+                                            , integral)
+
+  BEGIN_DOC
+  !
+  ! < n l k | -L | m j i > with a BI-ORTHONORMAL SPIN-ORBITALS
+  !
+  END_DOC
+
+  implicit none
+  integer,          intent(in)  :: n, l, k, m, j, i
+  double precision, intent(in)  :: sigma_n, sigma_l, sigma_k, sigma_m, sigma_j, sigma_i
+  double precision, intent(out) :: integral
+  integer                       :: ipoint
+  double precision              :: weight, tmp
+  logical, external             :: is_same_spin
+
+  integral = 0.d0
+
+  if( is_same_spin(sigma_n, sigma_m) .and. &
+      is_same_spin(sigma_l, sigma_j) .and. &
+      is_same_spin(sigma_k, sigma_i) ) then
+
+    PROVIDE mo_l_coef mo_r_coef
+    PROVIDE int2_grad1_u12_bimo_t
+
+    do ipoint = 1, n_points_final_grid
+
+      tmp =     mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
+                * ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,l,j)    &
+                  + int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,l,j)    &
+                  + int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,l,j) )
+
+      tmp = tmp + mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
+                * ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,k,i)    &
+                  + int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,k,i)    &
+                  + int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
+
+      tmp = tmp + mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
+                * ( int2_grad1_u12_bimo_t(ipoint,1,l,j) * int2_grad1_u12_bimo_t(ipoint,1,k,i)    &
+                  + int2_grad1_u12_bimo_t(ipoint,2,l,j) * int2_grad1_u12_bimo_t(ipoint,2,k,i)    &
+                  + int2_grad1_u12_bimo_t(ipoint,3,l,j) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
+
+      integral = integral + tmp * final_weight_at_r_vector(ipoint)
+    enddo
+
+  endif
+
+  return
+end subroutine give_integrals_3_body_bi_ort_spin
+
+! ---
+
 subroutine give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral)
 
   BEGIN_DOC

src/bi_ort_ints/total_twoe_pot.irp.f

@@ -256,6 +256,12 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num,
 
   FREE mo_bi_ortho_tc_two_e_chemist
 
+  if(noL_standard) then
+    PROVIDE noL_2e
+    mo_bi_ortho_tc_two_e = mo_bi_ortho_tc_two_e + noL_2e
+    FREE noL_2e
+  endif
+
 END_PROVIDER 
 
 ! ---

src/bi_ortho_mos/bi_density.irp.f

@@ -15,7 +15,6 @@ BEGIN_PROVIDER [double precision, TCSCF_bi_ort_dm_ao_alpha, (ao_num, ao_num) ]
 
   call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0               &
             , mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
-            !, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
             , 0.d0, TCSCF_bi_ort_dm_ao_alpha, size(TCSCF_bi_ort_dm_ao_alpha, 1) )
 
 END_PROVIDER
@@ -36,7 +35,6 @@ BEGIN_PROVIDER [ double precision, TCSCF_bi_ort_dm_ao_beta, (ao_num, ao_num) ]
 
   call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0                &
             , mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
-            !, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
             , 0.d0, TCSCF_bi_ort_dm_ao_beta, size(TCSCF_bi_ort_dm_ao_beta, 1) )
 
 END_PROVIDER

src/non_h_ints_mu/NEED

@@ -1,2 +1,3 @@
+qmckl
 ao_tc_eff_map
 bi_ortho_mos

src/non_h_ints_mu/debug_fit.irp.f

@@ -13,17 +13,27 @@ program debug_fit
 
   PROVIDE mu_erf j1b_pen
 
+  if(j1b_type .ge. 100) then
+    my_extra_grid_becke  = .True.
+    PROVIDE tc_grid2_a tc_grid2_r
+    my_n_pt_r_extra_grid = tc_grid2_r
+    my_n_pt_a_extra_grid = tc_grid2_a
+    touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
+  endif
+
   !call test_j1b_nucl()
   !call test_grad_j1b_nucl()
   !call test_lapl_j1b_nucl()
 
   !call test_list_b2()
-  call test_list_b3()
+  !call test_list_b3()
 
   !call test_fit_u()
   !call test_fit_u2()
   !call test_fit_ugradu()
 
+  call test_grad1_u12_withsq_num()
+
 end
 
 ! ---
@@ -643,4 +653,69 @@ end subroutine test_fit_u2
 
 ! ---
 
+subroutine test_grad1_u12_withsq_num()
+
+  implicit none
+  integer                       :: ipoint, jpoint, m
+  double precision              :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
+  double precision, allocatable :: tmp_grad1_u12_squared(:,:), tmp_grad1_u12(:,:,:)
+
+  print*, ' test_grad1_u12_withsq_num ...'
+
+  PROVIDE grad1_u12_num grad1_u12_squared_num
+
+  allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_points_final_grid))
+  allocate(tmp_grad1_u12(n_points_extra_final_grid,n_points_final_grid,3))
+
+  eps_ij  = 1d-7
+  acc_tot = 0.d0
+  normalz = 0.d0
+
+  do ipoint = 1, n_points_final_grid
+
+    call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,ipoint,1) &
+                                                                                           , tmp_grad1_u12(1,ipoint,2) &
+                                                                                           , tmp_grad1_u12(1,ipoint,3) &
+                                                                                           , tmp_grad1_u12_squared(1,ipoint))
+    do jpoint = 1, n_points_extra_final_grid
+
+      i_exc  = grad1_u12_squared_num(jpoint,ipoint) 
+      i_num  = tmp_grad1_u12_squared(jpoint,ipoint)
+      acc_ij = dabs(i_exc - i_num)
+      if(acc_ij .gt. eps_ij) then
+        print *, ' problem in grad1_u12_squared_num on', ipoint, jpoint
+        print *, ' analyt = ', i_exc
+        print *, ' numeri = ', i_num
+        print *, ' diff   = ', acc_ij
+        stop
+      endif
+      acc_tot += acc_ij
+      normalz += dabs(i_num)
+
+      do m = 1, 3
+        i_exc  = grad1_u12_num(jpoint,ipoint,m) 
+        i_num  = tmp_grad1_u12(jpoint,ipoint,m)
+        acc_ij = dabs(i_exc - i_num)
+        if(acc_ij .gt. eps_ij) then
+          print *, ' problem in grad1_u12_num on', ipoint, jpoint, m
+          print *, ' analyt = ', i_exc
+          print *, ' numeri = ', i_num
+          print *, ' diff   = ', acc_ij
+          stop
+        endif
+        acc_tot += acc_ij
+        normalz += dabs(i_num)
+      enddo
+    enddo
+  enddo
+
+  !print*, ' acc_tot = ', acc_tot
+  !print*, ' normalz = ', normalz
+  print*, ' accuracy (%) = ', 100.d0 * acc_tot / normalz
+
+  return
+end subroutine test_grad1_u12_withsq_num
+
+! ---
+
 

src/non_h_ints_mu/grad_squared.irp.f

@@ -425,7 +425,6 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
 
       ! an additional term is added here directly instead of 
       ! being added in int2_grad1_u12_square_ao for performance
-      ! note that the factor
 
       PROVIDE int2_u2_j1b2
 
@@ -465,25 +464,8 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
     ! ---
 
     deallocate(b_mat)
-
     call sum_A_At(tc_grad_square_ao(1,1,1,1), ao_num*ao_num)
 
-   !!$OMP PARALLEL             &
-   !!$OMP DEFAULT (NONE)       &
-   !!$OMP PRIVATE (i, j, k, l) &
-   !!$OMP SHARED (ac_mat, tc_grad_square_ao, ao_num)
-   !!$OMP DO SCHEDULE (static)
-   ! do j = 1, ao_num
-   !   do l = 1, ao_num
-   !     do i = 1, ao_num
-   !       do k = 1, ao_num
-   !         tc_grad_square_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
-   !       enddo
-   !     enddo
-   !   enddo
-   ! enddo
-   !!$OMP END DO
-   !!$OMP END PARALLEL
   endif
 
   if(write_tc_integ.and.mpi_master) then

src/non_h_ints_mu/grad_squared_manu.irp.f

@@ -67,72 +67,6 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao_test, (ao_num, ao_num, ao_nu
     deallocate(tmp, b_mat)
 
     call sum_A_At(tc_grad_square_ao_test(1,1,1,1), ao_num*ao_num)
-    !do i = 1, ao_num
-    !  do j = 1, ao_num
-    !    do k = i, ao_num
-
-    !      do l = max(j,k), ao_num
-    !        tc_grad_square_ao_test(i,j,k,l) = 0.5d0 * (tc_grad_square_ao_test(i,j,k,l) + tc_grad_square_ao_test(k,l,i,j))
-    !        tc_grad_square_ao_test(k,l,i,j) = tc_grad_square_ao_test(i,j,k,l)
-    !      end do
-
-    !      !if (j.eq.k) then
-    !      !  do l = j+1, ao_num
-    !      !    tc_grad_square_ao_test(i,j,k,l) = 0.5d0 * (tc_grad_square_ao_test(i,j,k,l) + tc_grad_square_ao_test(k,l,i,j))
-    !      !    tc_grad_square_ao_test(k,l,i,j) = tc_grad_square_ao_test(i,j,k,l)
-    !      !  end do
-    !      !else
-    !      !  do l = j, ao_num
-    !      !    tc_grad_square_ao_test(i,j,k,l) = 0.5d0 * (tc_grad_square_ao_test(i,j,k,l) + tc_grad_square_ao_test(k,l,i,j))
-    !      !    tc_grad_square_ao_test(k,l,i,j) = tc_grad_square_ao_test(i,j,k,l)
-    !      !  enddo
-    !      !endif
-
-    !    enddo
-    !  enddo
-    !enddo
-    !tc_grad_square_ao_test = 2.d0 * tc_grad_square_ao_test
-  ! !$OMP PARALLEL             &
-  ! !$OMP DEFAULT (NONE)       &
-  ! !$OMP PRIVATE (i, j, k, l) &
-  ! !$OMP SHARED (tc_grad_square_ao_test, ao_num)
-  ! !$OMP DO SCHEDULE (static)
-  !  integer :: ii
-  !  ii = 0
-  !  do j = 1, ao_num
-  !    do l = 1, ao_num
-  !      do i = 1, ao_num
-  !        do k = 1, ao_num
-  !          if((i.lt.j) .and. (k.lt.l)) cycle
-  !          ii = ii + 1
-  !          tc_grad_square_ao_test(k,i,l,j) = tc_grad_square_ao_test(k,i,l,j) + tc_grad_square_ao_test(l,j,k,i)
-  !        enddo
-  !      enddo
-  !    enddo
-  !  enddo
-  !  print *, ' ii =', ii
-  ! !$OMP END DO
-  ! !$OMP END PARALLEL
-
-  ! !$OMP PARALLEL             &
-  ! !$OMP DEFAULT (NONE)       &
-  ! !$OMP PRIVATE (i, j, k, l) &
-  ! !$OMP SHARED (tc_grad_square_ao_test, ao_num)
-  ! !$OMP DO SCHEDULE (static)
-  !  do j = 1, ao_num
-  !    do l = 1, ao_num
-  !      do i = 1, j-1
-  !        do k = 1, l-1
-  !          ii = ii + 1
-  !          tc_grad_square_ao_test(k,i,l,j) = tc_grad_square_ao_test(l,j,k,i)
-  !        enddo
-  !      enddo
-  !    enddo
-  !  enddo
-  !  print *, ' ii =', ii
-  !  print *, ao_num * ao_num * ao_num * ao_num
-  ! !$OMP END DO
-  ! !$OMP END PARALLEL
 
   endif
 

src/non_h_ints_mu/jast_deriv.irp.f

@@ -24,15 +24,20 @@
   double precision           :: v1b_r1, v1b_r2, u2b_r12
   double precision           :: grad1_v1b(3), grad1_u2b(3)
   double precision           :: dx, dy, dz
+  double precision           :: time0, time1
   double precision, external :: j12_mu, j1b_nucl
 
   PROVIDE j1b_type
   PROVIDE final_grid_points_extra
 
+  print*, ' providing grad1_u12_num & grad1_u12_squared_num ...'
+  call wall_time(time0)
+
   grad1_u12_num         = 0.d0
   grad1_u12_squared_num = 0.d0
 
-  if(j1b_type .eq. 100) then
+  if( (j1b_type .eq. 100) .or. &
+      (j1b_type .ge. 200) .and. (j1b_type .lt. 300) ) then
 
     !$OMP PARALLEL                                                                                    &
     !$OMP DEFAULT (NONE)                                                                              &
@@ -111,41 +116,93 @@
     !$OMP END DO
     !$OMP END PARALLEL
 
-  elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then
+  elseif (j1b_type .eq. 1000) then
+
+    double precision :: f
+    f = 1.d0 / dble(elec_num - 1)
+
+    double precision, allocatable :: rij(:,:,:)
+    allocate( rij(3, 2, n_points_extra_final_grid) )
+
+    use qmckl
+    integer(qmckl_exit_code) :: rc
+
+    integer*8 :: npoints
+    npoints = n_points_extra_final_grid
+
+    double precision, allocatable :: gl(:,:,:)
+    allocate( gl(2,4,n_points_extra_final_grid) )
 
-    !$OMP PARALLEL                                                                   &
-    !$OMP DEFAULT (NONE)                                                             &
-    !$OMP PRIVATE (ipoint, jpoint, r1, r2, grad1_u2b, dx, dy, dz)                    &
-    !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, &
-    !$OMP         final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num)
-    !$OMP DO SCHEDULE (static)
     do ipoint = 1, n_points_final_grid  ! r1
 
-      r1(1) = final_grid_points(1,ipoint)
+      do jpoint = 1, n_points_extra_final_grid ! r2 
-      r1(2) = final_grid_points(2,ipoint)
+        rij(1:3, 1, jpoint) = final_grid_points      (1:3, ipoint)
-      r1(3) = final_grid_points(3,ipoint)
+        rij(1:3, 2, jpoint) = final_grid_points_extra(1:3, jpoint)
+      enddo
+
+
+      rc = qmckl_set_electron_coord(qmckl_ctx_jastrow, 'N', npoints, rij, npoints*6_8)
+      if (rc /= QMCKL_SUCCESS) then
+        print *, irp_here, 'qmckl error in set_electron_coord'
+        stop -1
+      endif
+
+
+      ! ---
+      ! e-e term
+
+      rc = qmckl_get_jastrow_champ_factor_ee_gl(qmckl_ctx_jastrow, gl, 8_8*npoints)
+      if (rc /= QMCKL_SUCCESS) then
+        print *, irp_here, 'qmckl error in fact_ee_gl'
+        stop -1
+      endif
 
       do jpoint = 1, n_points_extra_final_grid ! r2 
+        grad1_u12_num(jpoint,ipoint,1) = gl(1,1,jpoint)
+        grad1_u12_num(jpoint,ipoint,2) = gl(1,2,jpoint)
+        grad1_u12_num(jpoint,ipoint,3) = gl(1,3,jpoint)
+      enddo
 
-        r2(1) = final_grid_points_extra(1,jpoint)
+    ! ---
-        r2(2) = final_grid_points_extra(2,jpoint)
+    ! e-e-n term
-        r2(3) = final_grid_points_extra(3,jpoint)
 
-        call grad1_j12_mu(r1, r2, grad1_u2b)
+!    rc = qmckl_get_jastrow_champ_factor_een_gl(qmckl_ctx_jastrow, gl, 8_8*npoints)
+!    if (rc /= QMCKL_SUCCESS) then
+!      print *, irp_here, 'qmckl error in fact_een_gl'
+!      stop -1
+!    endif
+!
+!    do jpoint = 1, n_points_extra_final_grid ! r2 
+!        grad1_u12_num(jpoint,ipoint,1) = grad1_u12_num(jpoint,ipoint,1) + gl(1,1,jpoint)
+!        grad1_u12_num(jpoint,ipoint,2) = grad1_u12_num(jpoint,ipoint,2) + gl(1,2,jpoint)
+!        grad1_u12_num(jpoint,ipoint,3) = grad1_u12_num(jpoint,ipoint,3) + gl(1,3,jpoint)
+!    enddo
 
-        dx = grad1_u2b(1)
+      ! ---
-        dy = grad1_u2b(2)
+      ! e-n term
-        dz = grad1_u2b(3)
 
-        grad1_u12_num(jpoint,ipoint,1) = dx 
+      rc = qmckl_get_jastrow_champ_factor_en_gl(qmckl_ctx_jastrow, gl, 8_8*npoints)
-        grad1_u12_num(jpoint,ipoint,2) = dy 
+      if (rc /= QMCKL_SUCCESS) then
-        grad1_u12_num(jpoint,ipoint,3) = dz 
+        print *, irp_here, 'qmckl error in fact_en_gl'
+        stop -1
+      endif
 
+      do jpoint = 1, n_points_extra_final_grid ! r2 
+        grad1_u12_num(jpoint,ipoint,1) = grad1_u12_num(jpoint,ipoint,1) + f * gl(1,1,jpoint)
+        grad1_u12_num(jpoint,ipoint,2) = grad1_u12_num(jpoint,ipoint,2) + f * gl(1,2,jpoint)
+        grad1_u12_num(jpoint,ipoint,3) = grad1_u12_num(jpoint,ipoint,3) + f * gl(1,3,jpoint)
+      enddo
+
+      do jpoint = 1, n_points_extra_final_grid ! r2 
+        dx = grad1_u12_num(jpoint,ipoint,1) 
+        dy = grad1_u12_num(jpoint,ipoint,2) 
+        dz = grad1_u12_num(jpoint,ipoint,3) 
         grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz
       enddo
+
     enddo
-    !$OMP END DO
+
-    !$OMP END PARALLEL
+    deallocate(gl, rij)
 
   else
 
@@ -154,700 +211,10 @@
 
   endif
 
+  call wall_time(time1)
+  print*, ' Wall time for grad1_u12_num & grad1_u12_squared_num (min) =', (time1-time0)/60.d0 
+
 END_PROVIDER
 
 ! ---
 
-double precision function j12_mu(r1, r2)
-
-  include 'constants.include.F'
-
-  implicit none
-  double precision, intent(in) :: r1(3), r2(3)
-  double precision             :: mu_tmp, r12
-
-  if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
-
-    r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
-               + (r1(2) - r2(2)) * (r1(2) - r2(2)) &
-               + (r1(3) - r2(3)) * (r1(3) - r2(3)) )
-    mu_tmp = mu_erf * r12
-
-    j12_mu = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
-
-  else
-
-    print *, ' j1b_type = ', j1b_type, 'not implemented for j12_mu'
-    stop
-
-  endif
-
-  return
-end function j12_mu
-
-! ---
-
-subroutine grad1_j12_mu(r1, r2, grad)
-
-  BEGIN_DOC
-!  gradient of j(mu(r1,r2),r12) form of jastrow. 
-!
-! if mu(r1,r2) = cst ---> j1b_type < 200 and 
-!
-!  d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2)
-!
-! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and 
-!
-! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 )   d/dx1 mu(r1,r2) 
-!
-!                          + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2)
-  END_DOC
-  include 'constants.include.F'
-
-  implicit none
-  double precision, intent(in)  :: r1(3), r2(3)
-  double precision, intent(out) :: grad(3)
-  double precision              :: dx, dy, dz, r12, tmp
-
-  grad = 0.d0
-
-  if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
-
-    dx = r1(1) - r2(1)
-    dy = r1(2) - r2(2)
-    dz = r1(3) - r2(3)
-
-    r12 = dsqrt(dx * dx + dy * dy + dz * dz)
-    if(r12 .lt. 1d-10) return
-
-    tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
-
-    grad(1) = tmp * dx
-    grad(2) = tmp * dy
-    grad(3) = tmp * dz
-
-  elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then
-
-    double precision :: mu_val, mu_tmp, mu_der(3)
-
-    dx  = r1(1) - r2(1)
-    dy  = r1(2) - r2(2)
-    dz  = r1(3) - r2(3)
-    r12 = dsqrt(dx * dx + dy * dy + dz * dz)
-
-    call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
-    mu_tmp  = mu_val * r12
-    tmp     = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
-    grad(1) = tmp * mu_der(1)
-    grad(2) = tmp * mu_der(2)
-    grad(3) = tmp * mu_der(3)
-
-    if(r12 .lt. 1d-10) return
-    tmp     = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12
-    grad(1) = grad(1) + tmp * dx
-    grad(2) = grad(2) + tmp * dy
-    grad(3) = grad(3) + tmp * dz
-
-  else
-
-    print *, ' j1b_type = ', j1b_type, 'not implemented yet'
-    stop
-
-  endif
-
-  return
-end subroutine grad1_j12_mu
-
-! ---
-
-double precision function j1b_nucl(r)
-
-  implicit none
-  double precision, intent(in) :: r(3)
-  integer                      :: i
-  double precision             :: a, d, e, x, y, z
-
-  if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
-
-    j1b_nucl = 1.d0
-    do i = 1, nucl_num
-      a = j1b_pen(i)
-      d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
-          + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
-          + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
-      j1b_nucl = j1b_nucl - dexp(-a*dsqrt(d))
-    enddo
-
-  elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
-
-    j1b_nucl = 1.d0
-    do i = 1, nucl_num
-      a = j1b_pen(i)
-      d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
-          + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
-          + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
-      e = 1.d0 - dexp(-a*d)
-      j1b_nucl = j1b_nucl * e
-    enddo
-
-  elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
-
-    j1b_nucl = 1.d0
-    do i = 1, nucl_num
-      a = j1b_pen(i)
-      d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
-          + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
-          + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
-      j1b_nucl = j1b_nucl - j1b_pen_coef(i) * dexp(-a*d)
-    enddo
-
-  elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
-
-    j1b_nucl = 1.d0
-    do i = 1, nucl_num
-      a = j1b_pen(i)
-      x = r(1) - nucl_coord(i,1)
-      y = r(2) - nucl_coord(i,2)
-      z = r(3) - nucl_coord(i,3)
-      d = x*x + y*y + z*z
-      j1b_nucl = j1b_nucl - dexp(-a*d*d)
-    enddo
-
-  else
-
-    print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl'
-    stop
-
-  endif
-
-  return
-end function j1b_nucl
-
-! ---
-
-double precision function j1b_nucl_square(r)
-
-  implicit none
-  double precision, intent(in) :: r(3)
-  integer                      :: i
-  double precision             :: a, d, e, x, y, z
-
-  if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
-
-    j1b_nucl_square = 1.d0
-    do i = 1, nucl_num
-      a = j1b_pen(i)
-      d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
-          + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
-          + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
-      j1b_nucl_square = j1b_nucl_square - dexp(-a*dsqrt(d))
-    enddo
-    j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
-
-  elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
-
-    j1b_nucl_square = 1.d0
-    do i = 1, nucl_num
-      a = j1b_pen(i)
-      d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
-          + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
-          + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
-      e = 1.d0 - dexp(-a*d)
-      j1b_nucl_square = j1b_nucl_square * e
-    enddo
-    j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
-
-  elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
-
-    j1b_nucl_square = 1.d0
-    do i = 1, nucl_num
-      a = j1b_pen(i)
-      d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
-          + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
-          + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
-      j1b_nucl_square = j1b_nucl_square - j1b_pen_coef(i) * dexp(-a*d)
-    enddo
-    j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
-
-  elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
-
-    j1b_nucl_square = 1.d0
-    do i = 1, nucl_num
-      a = j1b_pen(i)
-      x = r(1) - nucl_coord(i,1)
-      y = r(2) - nucl_coord(i,2)
-      z = r(3) - nucl_coord(i,3)
-      d = x*x + y*y + z*z
-      j1b_nucl_square = j1b_nucl_square - dexp(-a*d*d)
-    enddo
-    j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
-
-  else
-
-    print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl_square'
-    stop
-
-  endif
-
-  return
-end function j1b_nucl_square
-
-! ---
-
-subroutine grad1_j1b_nucl(r, grad)
-
-  implicit none
-  double precision, intent(in)  :: r(3)
-  double precision, intent(out) :: grad(3)
-  integer                       :: ipoint, i, j, phase
-  double precision              :: x, y, z, dx, dy, dz
-  double precision              :: a, d, e
-  double precision              :: fact_x, fact_y, fact_z
-  double precision              :: ax_der, ay_der, az_der, a_expo
-
-  if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
-
-    fact_x = 0.d0
-    fact_y = 0.d0
-    fact_z = 0.d0
-    do i = 1, nucl_num
-      a = j1b_pen(i)
-      x = r(1) - nucl_coord(i,1)
-      y = r(2) - nucl_coord(i,2)
-      z = r(3) - nucl_coord(i,3)
-      d = dsqrt(x*x + y*y + z*z)
-      e = a * dexp(-a*d) / d
-
-      fact_x += e * x
-      fact_y += e * y
-      fact_z += e * z
-    enddo
-
-    grad(1) = fact_x
-    grad(2) = fact_y
-    grad(3) = fact_z
-
-  elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
-
-    x = r(1)
-    y = r(2)
-    z = r(3)
-
-    fact_x = 0.d0
-    fact_y = 0.d0
-    fact_z = 0.d0
-    do i = 1, List_all_comb_b2_size
-
-      phase  = 0
-      a_expo = 0.d0
-      ax_der = 0.d0
-      ay_der = 0.d0
-      az_der = 0.d0
-      do j = 1, nucl_num
-        a  = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
-        dx = x - nucl_coord(j,1)
-        dy = y - nucl_coord(j,2)
-        dz = z - nucl_coord(j,3)
-
-        phase  += List_all_comb_b2(j,i)
-        a_expo += a * (dx*dx + dy*dy + dz*dz)
-        ax_der += a * dx
-        ay_der += a * dy
-        az_der += a * dz
-      enddo
-      e = -2.d0 * (-1.d0)**dble(phase) * dexp(-a_expo)
-
-      fact_x += e * ax_der
-      fact_y += e * ay_der
-      fact_z += e * az_der
-    enddo
-
-    grad(1) = fact_x
-    grad(2) = fact_y
-    grad(3) = fact_z
-
-  elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
-
-    fact_x = 0.d0
-    fact_y = 0.d0
-    fact_z = 0.d0
-    do i = 1, nucl_num
-      a = j1b_pen(i)
-      x = r(1) - nucl_coord(i,1)
-      y = r(2) - nucl_coord(i,2)
-      z = r(3) - nucl_coord(i,3)
-      d = x*x + y*y + z*z
-      e = a * j1b_pen_coef(i) * dexp(-a*d)
-
-      fact_x += e * x
-      fact_y += e * y
-      fact_z += e * z
-    enddo
-
-    grad(1) = 2.d0 * fact_x
-    grad(2) = 2.d0 * fact_y
-    grad(3) = 2.d0 * fact_z
-
-  elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
-
-    fact_x = 0.d0
-    fact_y = 0.d0
-    fact_z = 0.d0
-    do i = 1, nucl_num
-      a = j1b_pen(i)
-      x = r(1) - nucl_coord(i,1)
-      y = r(2) - nucl_coord(i,2)
-      z = r(3) - nucl_coord(i,3)
-      d = x*x + y*y + z*z
-      e = a * d * dexp(-a*d*d)
-
-      fact_x += e * x
-      fact_y += e * y
-      fact_z += e * z
-    enddo
-
-    grad(1) = 4.d0 * fact_x
-    grad(2) = 4.d0 * fact_y
-    grad(3) = 4.d0 * fact_z
-
-  else
-
-    print *, ' j1b_type = ', j1b_type, 'not implemented for grad1_j1b_nucl'
-    stop
-
-  endif
-
-  return
-end subroutine grad1_j1b_nucl
-
-! ---
-
-subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
-
-  implicit none
-  double precision, intent(in)  :: r1(3), r2(3)
-  double precision, intent(out) :: mu_val, mu_der(3)
-  double precision              :: r(3)
-  double precision              :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1)
-  double precision              :: dm_tot, tmp1, tmp2, tmp3
-  double precision :: rho1, grad_rho1(3),rho2,rho_tot,inv_rho_tot
-  double precision :: f_rho1, f_rho2, d_drho_f_rho1
-  double precision :: d_dx1_f_rho1(3),d_dx_rho_f_rho(3),nume
-
-  if(j1b_type .eq. 200) then
-
-    !
-    ! r = 0.5 (r1 + r2)
-    !
-    ! mu[rho(r)] = alpha sqrt(rho) + mu0 exp(-rho)
-    !
-    ! d mu[rho(r)] / dx1 = 0.5 d mu[rho(r)] / dx
-    ! d mu[rho(r)] / dx  = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx)
-    !
-
-    PROVIDE mu_r_ct mu_erf
-
-    r(1) = 0.5d0 * (r1(1) + r2(1))
-    r(2) = 0.5d0 * (r1(2) + r2(2))
-    r(3) = 0.5d0 * (r1(3) + r2(3))
-
-    call density_and_grad_alpha_beta(r, dm_a, dm_b, grad_dm_a, grad_dm_b)
-
-    dm_tot = dm_a(1) + dm_b(1)
-    tmp1   = dsqrt(dm_tot)
-    tmp2   = mu_erf * dexp(-dm_tot)
-
-    mu_val = mu_r_ct * tmp1 + tmp2
-
-    mu_der = 0.d0
-    if(dm_tot .lt. 1d-7) return
-
-    tmp3      = 0.25d0 * mu_r_ct / tmp1 - 0.5d0 * tmp2
-    mu_der(1) = tmp3 * (grad_dm_a(1,1) + grad_dm_b(1,1))
-    mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1))
-    mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1))
-
-  elseif(j1b_type .eq. 201) then
-
-    !
-    ! r = 0.5 (r1 + r2)
-    !
-    ! mu[rho(r)] = alpha rho + mu0 exp(-rho)
-    !
-    ! d mu[rho(r)] / dx1 = 0.5 d mu[rho(r)] / dx
-    ! d mu[rho(r)] / dx  = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx)
-    !
-
-    PROVIDE mu_r_ct mu_erf
-
-    r(1) = 0.5d0 * (r1(1) + r2(1))
-    r(2) = 0.5d0 * (r1(2) + r2(2))
-    r(3) = 0.5d0 * (r1(3) + r2(3))
-
-    call density_and_grad_alpha_beta(r, dm_a, dm_b, grad_dm_a, grad_dm_b)
-
-    dm_tot = dm_a(1) + dm_b(1)
-    tmp2   = mu_erf * dexp(-dm_tot)
-
-    mu_val = mu_r_ct * dm_tot + tmp2
-
-    tmp3      = 0.5d0 * (mu_r_ct - tmp2)
-    mu_der(1) = tmp3 * (grad_dm_a(1,1) + grad_dm_b(1,1))
-    mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1))
-    mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1))
-
-  elseif(j1b_type .eq. 202) then
-
-    ! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO
-    !
-    ! RHO = rho(r1) + rho(r2)
-    !
-    ! f[rho] = alpha rho^beta + mu0 exp(-rho)
-    !
-    ! d/dx1 mu(r1,r2) = 1/RHO^2 * {RHO * d/dx1 (rho(r1) f[rho(r1)]) 
-    !                              - d/dx1 rho(r1) * [rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]] }
-    !
-    ! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) - mu0 exp(-rho(r1))] (d rho(r1) / dx1)
-    !
-    ! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
-     
-    !!!!!!!!! rho1,rho2,rho1+rho2
-    call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
-    rho_tot = rho1 + rho2
-    if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
-    inv_rho_tot = 1.d0/rho_tot
-    ! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf * exp(-rho)
-    call get_all_f_rho(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
-    d_dx1_f_rho1(1:3)   = d_drho_f_rho1 * grad_rho1(1:3)
-    d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
-    nume   = rho1 * f_rho1 + rho2 * f_rho2
-    mu_val = nume * inv_rho_tot
-    mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume)
-  elseif(j1b_type .eq. 203) then
-
-    ! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO
-    !
-    ! RHO = rho(r1) + rho(r2)
-    !
-    ! f[rho] = alpha rho^beta + mu0 
-    !
-    ! d/dx1 mu(r1,r2) = 1/RHO^2 * {RHO * d/dx1 (rho(r1) f[rho(r1)]) 
-    !                              - d/dx1 rho(r1) * [rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]] }
-    !
-    ! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) ] (d rho(r1) / dx1)
-    !
-    ! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
-     
-    !!!!!!!!! rho1,rho2,rho1+rho2
-    call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
-    rho_tot = rho1 + rho2
-    if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
-    inv_rho_tot = 1.d0/rho_tot
-    ! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf 
-    call get_all_f_rho_simple(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
-    d_dx1_f_rho1(1:3)   = d_drho_f_rho1 * grad_rho1(1:3)
-    d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
-    nume   = rho1 * f_rho1 + rho2 * f_rho2
-    mu_val = nume * inv_rho_tot
-    mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume)
-  elseif(j1b_type .eq. 204) then
-
-    ! mu(r1,r2) = 1/2 * (f[rho(r1)] + f[rho(r2)]} 
-    !
-    ! f[rho] = alpha rho^beta + mu0 
-    !
-    ! d/dx1 mu(r1,r2) = 1/2 * d/dx1 (rho(r1) f[rho(r1)])
-    !                   
-    ! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) ] (d rho(r1) / dx1)
-    !
-    ! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
-     
-    !!!!!!!!! rho1,rho2,rho1+rho2
-    call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
-    rho_tot = rho1 + rho2
-    if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
-    inv_rho_tot = 1.d0/rho_tot
-    ! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf 
-    call get_all_f_rho_simple(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
-    d_dx1_f_rho1(1:3)   = d_drho_f_rho1 * grad_rho1(1:3)
-    d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
-    mu_val = 0.5d0 * ( f_rho1 + f_rho2)
-    mu_der(1:3) = d_dx_rho_f_rho(1:3) 
-  else
-    print *, ' j1b_type = ', j1b_type, 'not implemented yet'
-    stop
-
-  endif
-
-  return
-end subroutine mu_r_val_and_grad
-
-! ---
-
-subroutine grad1_j1b_nucl_square_num(r1, grad)
-
-  implicit none
-  double precision, intent(in)  :: r1(3)
-  double precision, intent(out) :: grad(3)
-  double precision              :: r(3), eps, tmp_eps, vp, vm
-  double precision, external    :: j1b_nucl_square
-
-  eps     = 1d-5
-  tmp_eps = 0.5d0 / eps
-
-  r(1:3) = r1(1:3)
-
-  r(1) = r(1) + eps
-  vp   = j1b_nucl_square(r)
-  r(1) = r(1) - 2.d0 * eps
-  vm   = j1b_nucl_square(r)
-  r(1) = r(1) + eps
-  grad(1) = tmp_eps * (vp - vm)
-
-  r(2) = r(2) + eps
-  vp   = j1b_nucl_square(r)
-  r(2) = r(2) - 2.d0 * eps
-  vm   = j1b_nucl_square(r)
-  r(2) = r(2) + eps
-  grad(2) = tmp_eps * (vp - vm)
-
-  r(3) = r(3) + eps
-  vp   = j1b_nucl_square(r)
-  r(3) = r(3) - 2.d0 * eps
-  vm   = j1b_nucl_square(r)
-  r(3) = r(3) + eps
-  grad(3) = tmp_eps * (vp - vm)
-  
-  return
-end subroutine grad1_j1b_nucl_square_num
-
-! ---
-
-subroutine grad1_j12_mu_square_num(r1, r2, grad)
-
-  include 'constants.include.F'
-
-  implicit none
-  double precision, intent(in)  :: r1(3), r2(3)
-  double precision, intent(out) :: grad(3)
-  double precision              :: r(3)
-  double precision              :: eps, tmp_eps, vp, vm
-  double precision, external    :: j12_mu_square
-
-  eps     = 1d-5
-  tmp_eps = 0.5d0 / eps
-
-  r(1:3) = r1(1:3)
-
-  r(1)    = r(1) + eps
-  vp      = j12_mu_square(r, r2)
-  r(1)    = r(1) - 2.d0 * eps
-  vm      = j12_mu_square(r, r2)
-  r(1)    = r(1) + eps
-  grad(1) = tmp_eps * (vp - vm)
-
-  r(2)    = r(2) + eps
-  vp      = j12_mu_square(r, r2)
-  r(2)    = r(2) - 2.d0 * eps
-  vm      = j12_mu_square(r, r2)
-  r(2)    = r(2) + eps
-  grad(2) = tmp_eps * (vp - vm)
-
-  r(3)    = r(3) + eps
-  vp      = j12_mu_square(r, r2)
-  r(3)    = r(3) - 2.d0 * eps
-  vm      = j12_mu_square(r, r2)
-  r(3)    = r(3) + eps
-  grad(3) = tmp_eps * (vp - vm)
-
-  return
-end subroutine grad1_j12_mu_square_num
-
-! ---
-
-double precision function j12_mu_square(r1, r2)
-
-  implicit none
-  double precision, intent(in) :: r1(3), r2(3)
-  double precision, external   :: j12_mu
-
-  j12_mu_square = j12_mu(r1, r2) * j12_mu(r1, r2)
-
-  return
-end function j12_mu_square
-
-! ---
-
-subroutine f_mu_and_deriv_mu(rho,alpha,mu0,beta,f_mu,d_drho_f_mu)
- implicit none
- BEGIN_DOC
-! function giving mu as a function of rho
-!
-! f_mu = alpha * rho**beta + mu0 * exp(-rho)
-!
-! and its derivative with respect to rho d_drho_f_mu
- END_DOC
- double precision, intent(in)  :: rho,alpha,mu0,beta
- double precision, intent(out) :: f_mu,d_drho_f_mu
- f_mu = alpha * (rho)**beta + mu0 * dexp(-rho)
- d_drho_f_mu = alpha * beta * rho**(beta-1.d0) - mu0 * dexp(-rho)
-
-end
-
-
-subroutine get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
- implicit none
- BEGIN_DOC
-! returns the density in r1,r2 and grad_rho at r1
- END_DOC
- double precision, intent(in) :: r1(3),r2(3)
- double precision, intent(out):: grad_rho1(3),rho1,rho2
- double precision              :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1)
- call density_and_grad_alpha_beta(r1, dm_a, dm_b, grad_dm_a, grad_dm_b)
- rho1 = dm_a(1) + dm_b(1)
- grad_rho1(1:3) = grad_dm_a(1:3,1) + grad_dm_b(1:3,1)
- call density_and_grad_alpha_beta(r2, dm_a, dm_b, grad_dm_a, grad_dm_b)
- rho2 = dm_a(1) + dm_b(1)
-end
-
-subroutine get_all_f_rho(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2)
- implicit none
- BEGIN_DOC
-! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
- END_DOC
- double precision, intent(in) :: rho1,rho2,alpha,mu0,beta
- double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2
- double precision :: tmp
- call f_mu_and_deriv_mu(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1)
- call f_mu_and_deriv_mu(rho2,alpha,mu0,beta,f_rho2,tmp)
-end
-
-
-subroutine get_all_f_rho_simple(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2)
- implicit none
- BEGIN_DOC
-! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
- END_DOC
- double precision, intent(in) :: rho1,rho2,alpha,mu0,beta
- double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2
- double precision :: tmp
- call f_mu_and_deriv_mu_simple(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1)
- call f_mu_and_deriv_mu_simple(rho2,alpha,mu0,beta,f_rho2,tmp)
-end
-
-subroutine f_mu_and_deriv_mu_simple(rho,alpha,mu0,beta,f_mu,d_drho_f_mu)
- implicit none
- BEGIN_DOC
-! function giving mu as a function of rho
-!
-! f_mu = alpha * rho**beta + mu0 
-!
-! and its derivative with respect to rho d_drho_f_mu
- END_DOC
- double precision, intent(in)  :: rho,alpha,mu0,beta
- double precision, intent(out) :: f_mu,d_drho_f_mu
- f_mu = alpha * (rho)**beta + mu0 
- d_drho_f_mu = alpha * beta * rho**(beta-1.d0) 
-
-end
-

src/non_h_ints_mu/jast_deriv_utils.irp.f

@@ -0,0 +1,700 @@
+
+! ---
+
+double precision function j12_mu(r1, r2)
+
+  include 'constants.include.F'
+
+  implicit none
+  double precision, intent(in) :: r1(3), r2(3)
+  double precision             :: mu_tmp, r12
+
+  if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
+
+    r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
+               + (r1(2) - r2(2)) * (r1(2) - r2(2)) &
+               + (r1(3) - r2(3)) * (r1(3) - r2(3)) )
+    mu_tmp = mu_erf * r12
+
+    j12_mu = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
+
+  else
+
+    print *, ' j1b_type = ', j1b_type, 'not implemented for j12_mu'
+    stop
+
+  endif
+
+  return
+end function j12_mu
+
+! ---
+
+subroutine grad1_j12_mu(r1, r2, grad)
+
+  BEGIN_DOC
+  !
+  !  gradient of j(mu(r1,r2),r12) form of jastrow. 
+  !
+  ! if mu(r1,r2) = cst ---> j1b_type < 200 and 
+  !
+  !  d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2)
+  !
+  ! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and 
+  !
+  ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2) 
+  !                        + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2)
+  !
+  END_DOC
+
+  include 'constants.include.F'
+
+  implicit none
+  double precision, intent(in)  :: r1(3), r2(3)
+  double precision, intent(out) :: grad(3)
+  double precision              :: dx, dy, dz, r12, tmp
+
+  grad = 0.d0
+
+  if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
+
+    dx = r1(1) - r2(1)
+    dy = r1(2) - r2(2)
+    dz = r1(3) - r2(3)
+
+    r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+    if(r12 .lt. 1d-10) return
+
+    tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
+
+    grad(1) = tmp * dx
+    grad(2) = tmp * dy
+    grad(3) = tmp * dz
+
+  elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then
+
+    double precision :: mu_val, mu_tmp, mu_der(3)
+
+    dx  = r1(1) - r2(1)
+    dy  = r1(2) - r2(2)
+    dz  = r1(3) - r2(3)
+    r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+
+    call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
+    mu_tmp  = mu_val * r12
+    tmp     = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
+    grad(1) = tmp * mu_der(1)
+    grad(2) = tmp * mu_der(2)
+    grad(3) = tmp * mu_der(3)
+
+    if(r12 .lt. 1d-10) return
+    tmp     = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12
+    grad(1) = grad(1) + tmp * dx
+    grad(2) = grad(2) + tmp * dy
+    grad(3) = grad(3) + tmp * dz
+
+  else
+
+    print *, ' j1b_type = ', j1b_type, 'not implemented yet'
+    stop
+
+  endif
+
+  return
+end subroutine grad1_j12_mu
+
+! ---
+
+double precision function j1b_nucl(r)
+
+  implicit none
+  double precision, intent(in) :: r(3)
+  integer                      :: i
+  double precision             :: a, d, e, x, y, z
+
+  if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
+
+    j1b_nucl = 1.d0
+    do i = 1, nucl_num
+      a = j1b_pen(i)
+      d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+          + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+          + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
+      j1b_nucl = j1b_nucl - dexp(-a*dsqrt(d))
+    enddo
+
+  elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
+
+    j1b_nucl = 1.d0
+    do i = 1, nucl_num
+      a = j1b_pen(i)
+      d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+          + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+          + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
+      e = 1.d0 - dexp(-a*d)
+      j1b_nucl = j1b_nucl * e
+    enddo
+
+  elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
+
+    j1b_nucl = 1.d0
+    do i = 1, nucl_num
+      a = j1b_pen(i)
+      d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+          + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+          + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
+      j1b_nucl = j1b_nucl - j1b_pen_coef(i) * dexp(-a*d)
+    enddo
+
+  elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
+
+    j1b_nucl = 1.d0
+    do i = 1, nucl_num
+      a = j1b_pen(i)
+      x = r(1) - nucl_coord(i,1)
+      y = r(2) - nucl_coord(i,2)
+      z = r(3) - nucl_coord(i,3)
+      d = x*x + y*y + z*z
+      j1b_nucl = j1b_nucl - dexp(-a*d*d)
+    enddo
+
+  else
+
+    print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl'
+    stop
+
+  endif
+
+  return
+end function j1b_nucl
+
+! ---
+
+double precision function j1b_nucl_square(r)
+
+  implicit none
+  double precision, intent(in) :: r(3)
+  integer                      :: i
+  double precision             :: a, d, e, x, y, z
+
+  if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
+
+    j1b_nucl_square = 1.d0
+    do i = 1, nucl_num
+      a = j1b_pen(i)
+      d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+          + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+          + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
+      j1b_nucl_square = j1b_nucl_square - dexp(-a*dsqrt(d))
+    enddo
+    j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
+
+  elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
+
+    j1b_nucl_square = 1.d0
+    do i = 1, nucl_num
+      a = j1b_pen(i)
+      d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+          + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+          + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
+      e = 1.d0 - dexp(-a*d)
+      j1b_nucl_square = j1b_nucl_square * e
+    enddo
+    j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
+
+  elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
+
+    j1b_nucl_square = 1.d0
+    do i = 1, nucl_num
+      a = j1b_pen(i)
+      d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+          + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+          + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
+      j1b_nucl_square = j1b_nucl_square - j1b_pen_coef(i) * dexp(-a*d)
+    enddo
+    j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
+
+  elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
+
+    j1b_nucl_square = 1.d0
+    do i = 1, nucl_num
+      a = j1b_pen(i)
+      x = r(1) - nucl_coord(i,1)
+      y = r(2) - nucl_coord(i,2)
+      z = r(3) - nucl_coord(i,3)
+      d = x*x + y*y + z*z
+      j1b_nucl_square = j1b_nucl_square - dexp(-a*d*d)
+    enddo
+    j1b_nucl_square = j1b_nucl_square * j1b_nucl_square
+
+  else
+
+    print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl_square'
+    stop
+
+  endif
+
+  return
+end function j1b_nucl_square
+
+! ---
+
+subroutine grad1_j1b_nucl(r, grad)
+
+  implicit none
+  double precision, intent(in)  :: r(3)
+  double precision, intent(out) :: grad(3)
+  integer                       :: ipoint, i, j, phase
+  double precision              :: x, y, z, dx, dy, dz
+  double precision              :: a, d, e
+  double precision              :: fact_x, fact_y, fact_z
+  double precision              :: ax_der, ay_der, az_der, a_expo
+
+  if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
+
+    fact_x = 0.d0
+    fact_y = 0.d0
+    fact_z = 0.d0
+    do i = 1, nucl_num
+      a = j1b_pen(i)
+      x = r(1) - nucl_coord(i,1)
+      y = r(2) - nucl_coord(i,2)
+      z = r(3) - nucl_coord(i,3)
+      d = dsqrt(x*x + y*y + z*z)
+      e = a * dexp(-a*d) / d
+
+      fact_x += e * x
+      fact_y += e * y
+      fact_z += e * z
+    enddo
+
+    grad(1) = fact_x
+    grad(2) = fact_y
+    grad(3) = fact_z
+
+  elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
+
+    x = r(1)
+    y = r(2)
+    z = r(3)
+
+    fact_x = 0.d0
+    fact_y = 0.d0
+    fact_z = 0.d0
+    do i = 1, List_all_comb_b2_size
+
+      phase  = 0
+      a_expo = 0.d0
+      ax_der = 0.d0
+      ay_der = 0.d0
+      az_der = 0.d0
+      do j = 1, nucl_num
+        a  = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
+        dx = x - nucl_coord(j,1)
+        dy = y - nucl_coord(j,2)
+        dz = z - nucl_coord(j,3)
+
+        phase  += List_all_comb_b2(j,i)
+        a_expo += a * (dx*dx + dy*dy + dz*dz)
+        ax_der += a * dx
+        ay_der += a * dy
+        az_der += a * dz
+      enddo
+      e = -2.d0 * (-1.d0)**dble(phase) * dexp(-a_expo)
+
+      fact_x += e * ax_der
+      fact_y += e * ay_der
+      fact_z += e * az_der
+    enddo
+
+    grad(1) = fact_x
+    grad(2) = fact_y
+    grad(3) = fact_z
+
+  elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
+
+    fact_x = 0.d0
+    fact_y = 0.d0
+    fact_z = 0.d0
+    do i = 1, nucl_num
+      a = j1b_pen(i)
+      x = r(1) - nucl_coord(i,1)
+      y = r(2) - nucl_coord(i,2)
+      z = r(3) - nucl_coord(i,3)
+      d = x*x + y*y + z*z
+      e = a * j1b_pen_coef(i) * dexp(-a*d)
+
+      fact_x += e * x
+      fact_y += e * y
+      fact_z += e * z
+    enddo
+
+    grad(1) = 2.d0 * fact_x
+    grad(2) = 2.d0 * fact_y
+    grad(3) = 2.d0 * fact_z
+
+  elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
+
+    fact_x = 0.d0
+    fact_y = 0.d0
+    fact_z = 0.d0
+    do i = 1, nucl_num
+      a = j1b_pen(i)
+      x = r(1) - nucl_coord(i,1)
+      y = r(2) - nucl_coord(i,2)
+      z = r(3) - nucl_coord(i,3)
+      d = x*x + y*y + z*z
+      e = a * d * dexp(-a*d*d)
+
+      fact_x += e * x
+      fact_y += e * y
+      fact_z += e * z
+    enddo
+
+    grad(1) = 4.d0 * fact_x
+    grad(2) = 4.d0 * fact_y
+    grad(3) = 4.d0 * fact_z
+
+  else
+
+    print *, ' j1b_type = ', j1b_type, 'not implemented for grad1_j1b_nucl'
+    stop
+
+  endif
+
+  return
+end subroutine grad1_j1b_nucl
+
+! ---
+
+subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
+
+  implicit none
+  double precision, intent(in)  :: r1(3), r2(3)
+  double precision, intent(out) :: mu_val, mu_der(3)
+  double precision              :: r(3)
+  double precision              :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1)
+  double precision              :: dm_tot, tmp1, tmp2, tmp3
+  double precision :: rho1, grad_rho1(3),rho2,rho_tot,inv_rho_tot
+  double precision :: f_rho1, f_rho2, d_drho_f_rho1
+  double precision :: d_dx1_f_rho1(3),d_dx_rho_f_rho(3),nume
+
+  if(j1b_type .eq. 200) then
+
+    !
+    ! r = 0.5 (r1 + r2)
+    !
+    ! mu[rho(r)] = alpha sqrt(rho) + mu0 exp(-rho)
+    !
+    ! d mu[rho(r)] / dx1 = 0.5 d mu[rho(r)] / dx
+    ! d mu[rho(r)] / dx  = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx)
+    !
+
+    PROVIDE mu_r_ct mu_erf
+
+    r(1) = 0.5d0 * (r1(1) + r2(1))
+    r(2) = 0.5d0 * (r1(2) + r2(2))
+    r(3) = 0.5d0 * (r1(3) + r2(3))
+
+    call density_and_grad_alpha_beta(r, dm_a, dm_b, grad_dm_a, grad_dm_b)
+
+    dm_tot = dm_a(1) + dm_b(1)
+    tmp1   = dsqrt(dm_tot)
+    tmp2   = mu_erf * dexp(-dm_tot)
+
+    mu_val = mu_r_ct * tmp1 + tmp2
+
+    mu_der = 0.d0
+    if(dm_tot .lt. 1d-7) return
+
+    tmp3      = 0.25d0 * mu_r_ct / tmp1 - 0.5d0 * tmp2
+    mu_der(1) = tmp3 * (grad_dm_a(1,1) + grad_dm_b(1,1))
+    mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1))
+    mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1))
+
+  elseif(j1b_type .eq. 201) then
+
+    !
+    ! r = 0.5 (r1 + r2)
+    !
+    ! mu[rho(r)] = alpha rho + mu0 exp(-rho)
+    !
+    ! d mu[rho(r)] / dx1 = 0.5 d mu[rho(r)] / dx
+    ! d mu[rho(r)] / dx  = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx)
+    !
+
+    PROVIDE mu_r_ct mu_erf
+
+    r(1) = 0.5d0 * (r1(1) + r2(1))
+    r(2) = 0.5d0 * (r1(2) + r2(2))
+    r(3) = 0.5d0 * (r1(3) + r2(3))
+
+    call density_and_grad_alpha_beta(r, dm_a, dm_b, grad_dm_a, grad_dm_b)
+
+    dm_tot = dm_a(1) + dm_b(1)
+    tmp2   = mu_erf * dexp(-dm_tot)
+
+    mu_val = mu_r_ct * dm_tot + tmp2
+
+    tmp3      = 0.5d0 * (mu_r_ct - tmp2)
+    mu_der(1) = tmp3 * (grad_dm_a(1,1) + grad_dm_b(1,1))
+    mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1))
+    mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1))
+
+  elseif(j1b_type .eq. 202) then
+
+    ! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO
+    !
+    ! RHO = rho(r1) + rho(r2)
+    !
+    ! f[rho] = alpha rho^beta + mu0 exp(-rho)
+    !
+    ! d/dx1 mu(r1,r2) = 1/RHO^2 * {RHO * d/dx1 (rho(r1) f[rho(r1)]) 
+    !                              - d/dx1 rho(r1) * [rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]] }
+    !
+    ! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) - mu0 exp(-rho(r1))] (d rho(r1) / dx1)
+    !
+    ! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
+     
+    !!!!!!!!! rho1,rho2,rho1+rho2
+    call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
+    rho_tot = rho1 + rho2
+    if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
+    inv_rho_tot = 1.d0/rho_tot
+    ! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf * exp(-rho)
+    call get_all_f_rho(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
+    d_dx1_f_rho1(1:3)   = d_drho_f_rho1 * grad_rho1(1:3)
+    d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
+    nume   = rho1 * f_rho1 + rho2 * f_rho2
+    mu_val = nume * inv_rho_tot
+    mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume)
+  elseif(j1b_type .eq. 203) then
+
+    ! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO
+    !
+    ! RHO = rho(r1) + rho(r2)
+    !
+    ! f[rho] = alpha rho^beta + mu0 
+    !
+    ! d/dx1 mu(r1,r2) = 1/RHO^2 * {RHO * d/dx1 (rho(r1) f[rho(r1)]) 
+    !                              - d/dx1 rho(r1) * [rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]] }
+    !
+    ! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) ] (d rho(r1) / dx1)
+    !
+    ! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
+     
+    !!!!!!!!! rho1,rho2,rho1+rho2
+    call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
+    rho_tot = rho1 + rho2
+    if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
+    inv_rho_tot = 1.d0/rho_tot
+    ! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf 
+    call get_all_f_rho_simple(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
+    d_dx1_f_rho1(1:3)   = d_drho_f_rho1 * grad_rho1(1:3)
+    d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
+    nume   = rho1 * f_rho1 + rho2 * f_rho2
+    mu_val = nume * inv_rho_tot
+    mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume)
+  elseif(j1b_type .eq. 204) then
+
+    ! mu(r1,r2) = 1/2 * (f[rho(r1)] + f[rho(r2)]} 
+    !
+    ! f[rho] = alpha rho^beta + mu0 
+    !
+    ! d/dx1 mu(r1,r2) = 1/2 * d/dx1 (rho(r1) f[rho(r1)])
+    !                   
+    ! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) ] (d rho(r1) / dx1)
+    !
+    ! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1)
+     
+    !!!!!!!!! rho1,rho2,rho1+rho2
+    call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
+    rho_tot = rho1 + rho2
+    if(rho_tot.lt.1.d-10)rho_tot = 1.d-10
+    inv_rho_tot = 1.d0/rho_tot
+    ! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf 
+    call get_all_f_rho_simple(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2)
+    d_dx1_f_rho1(1:3)   = d_drho_f_rho1 * grad_rho1(1:3)
+    d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3)
+    mu_val = 0.5d0 * ( f_rho1 + f_rho2)
+    mu_der(1:3) = d_dx_rho_f_rho(1:3) 
+  else
+    print *, ' j1b_type = ', j1b_type, 'not implemented yet'
+    stop
+
+  endif
+
+  return
+end subroutine mu_r_val_and_grad
+
+! ---
+
+subroutine grad1_j1b_nucl_square_num(r1, grad)
+
+  implicit none
+  double precision, intent(in)  :: r1(3)
+  double precision, intent(out) :: grad(3)
+  double precision              :: r(3), eps, tmp_eps, vp, vm
+  double precision, external    :: j1b_nucl_square
+
+  eps     = 1d-5
+  tmp_eps = 0.5d0 / eps
+
+  r(1:3) = r1(1:3)
+
+  r(1) = r(1) + eps
+  vp   = j1b_nucl_square(r)
+  r(1) = r(1) - 2.d0 * eps
+  vm   = j1b_nucl_square(r)
+  r(1) = r(1) + eps
+  grad(1) = tmp_eps * (vp - vm)
+
+  r(2) = r(2) + eps
+  vp   = j1b_nucl_square(r)
+  r(2) = r(2) - 2.d0 * eps
+  vm   = j1b_nucl_square(r)
+  r(2) = r(2) + eps
+  grad(2) = tmp_eps * (vp - vm)
+
+  r(3) = r(3) + eps
+  vp   = j1b_nucl_square(r)
+  r(3) = r(3) - 2.d0 * eps
+  vm   = j1b_nucl_square(r)
+  r(3) = r(3) + eps
+  grad(3) = tmp_eps * (vp - vm)
+  
+  return
+end subroutine grad1_j1b_nucl_square_num
+
+! ---
+
+subroutine grad1_j12_mu_square_num(r1, r2, grad)
+
+  include 'constants.include.F'
+
+  implicit none
+  double precision, intent(in)  :: r1(3), r2(3)
+  double precision, intent(out) :: grad(3)
+  double precision              :: r(3)
+  double precision              :: eps, tmp_eps, vp, vm
+  double precision, external    :: j12_mu_square
+
+  eps     = 1d-5
+  tmp_eps = 0.5d0 / eps
+
+  r(1:3) = r1(1:3)
+
+  r(1)    = r(1) + eps
+  vp      = j12_mu_square(r, r2)
+  r(1)    = r(1) - 2.d0 * eps
+  vm      = j12_mu_square(r, r2)
+  r(1)    = r(1) + eps
+  grad(1) = tmp_eps * (vp - vm)
+
+  r(2)    = r(2) + eps
+  vp      = j12_mu_square(r, r2)
+  r(2)    = r(2) - 2.d0 * eps
+  vm      = j12_mu_square(r, r2)
+  r(2)    = r(2) + eps
+  grad(2) = tmp_eps * (vp - vm)
+
+  r(3)    = r(3) + eps
+  vp      = j12_mu_square(r, r2)
+  r(3)    = r(3) - 2.d0 * eps
+  vm      = j12_mu_square(r, r2)
+  r(3)    = r(3) + eps
+  grad(3) = tmp_eps * (vp - vm)
+
+  return
+end subroutine grad1_j12_mu_square_num
+
+! ---
+
+double precision function j12_mu_square(r1, r2)
+
+  implicit none
+  double precision, intent(in) :: r1(3), r2(3)
+  double precision, external   :: j12_mu
+
+  j12_mu_square = j12_mu(r1, r2) * j12_mu(r1, r2)
+
+  return
+end function j12_mu_square
+
+! ---
+
+subroutine f_mu_and_deriv_mu(rho,alpha,mu0,beta,f_mu,d_drho_f_mu)
+ implicit none
+ BEGIN_DOC
+! function giving mu as a function of rho
+!
+! f_mu = alpha * rho**beta + mu0 * exp(-rho)
+!
+! and its derivative with respect to rho d_drho_f_mu
+ END_DOC
+ double precision, intent(in)  :: rho,alpha,mu0,beta
+ double precision, intent(out) :: f_mu,d_drho_f_mu
+ f_mu = alpha * (rho)**beta + mu0 * dexp(-rho)
+ d_drho_f_mu = alpha * beta * rho**(beta-1.d0) - mu0 * dexp(-rho)
+
+end
+
+
+subroutine get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1)
+ implicit none
+ BEGIN_DOC
+! returns the density in r1,r2 and grad_rho at r1
+ END_DOC
+ double precision, intent(in) :: r1(3),r2(3)
+ double precision, intent(out):: grad_rho1(3),rho1,rho2
+ double precision              :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1)
+ call density_and_grad_alpha_beta(r1, dm_a, dm_b, grad_dm_a, grad_dm_b)
+ rho1 = dm_a(1) + dm_b(1)
+ grad_rho1(1:3) = grad_dm_a(1:3,1) + grad_dm_b(1:3,1)
+ call density_and_grad_alpha_beta(r2, dm_a, dm_b, grad_dm_a, grad_dm_b)
+ rho2 = dm_a(1) + dm_b(1)
+end
+
+subroutine get_all_f_rho(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2)
+ implicit none
+ BEGIN_DOC
+! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
+ END_DOC
+ double precision, intent(in) :: rho1,rho2,alpha,mu0,beta
+ double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2
+ double precision :: tmp
+ call f_mu_and_deriv_mu(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1)
+ call f_mu_and_deriv_mu(rho2,alpha,mu0,beta,f_rho2,tmp)
+end
+
+
+subroutine get_all_f_rho_simple(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2)
+ implicit none
+ BEGIN_DOC
+! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1))
+ END_DOC
+ double precision, intent(in) :: rho1,rho2,alpha,mu0,beta
+ double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2
+ double precision :: tmp
+ call f_mu_and_deriv_mu_simple(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1)
+ call f_mu_and_deriv_mu_simple(rho2,alpha,mu0,beta,f_rho2,tmp)
+end
+
+subroutine f_mu_and_deriv_mu_simple(rho,alpha,mu0,beta,f_mu,d_drho_f_mu)
+ implicit none
+ BEGIN_DOC
+! function giving mu as a function of rho
+!
+! f_mu = alpha * rho**beta + mu0 
+!
+! and its derivative with respect to rho d_drho_f_mu
+ END_DOC
+ double precision, intent(in)  :: rho,alpha,mu0,beta
+ double precision, intent(out) :: f_mu,d_drho_f_mu
+ f_mu = alpha * (rho)**beta + mu0 
+ d_drho_f_mu = alpha * beta * rho**(beta-1.d0) 
+
+end
+
+! ---
+

src/non_h_ints_mu/jast_deriv_utils_vect.irp.f

@@ -0,0 +1,332 @@
+
+! ---
+
+subroutine get_grad1_u12_withsq_r1_seq(r1, n_grid2, resx, resy, resz, res)
+
+  BEGIN_DOC
+  ! 
+  ! grad_1 u(r1,r2)
+  !
+  ! this will be integrated numerically over r2:
+  !   we use grid for r1 and extra_grid for r2
+  !
+  ! for 99 < j1b_type < 199
+  !
+  !   u(r1,r2)        = j12_mu(r12) x v(r1) x v(r2)
+  !   grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2)
+  !
+  END_DOC
+
+  implicit none
+  integer,          intent(in)  :: n_grid2
+  double precision, intent(in)  :: r1(3)
+  double precision, intent(out) :: resx(n_grid2), resy(n_grid2), resz(n_grid2), res(n_grid2)
+
+  integer                       :: jpoint
+  double precision              :: v1b_r1
+  double precision              :: grad1_v1b(3)
+  double precision, allocatable :: v1b_r2(:)
+  double precision, allocatable :: u2b_r12(:)
+  double precision, allocatable :: gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:)
+  double precision, external    :: j1b_nucl
+
+  PROVIDE j1b_type
+  PROVIDE final_grid_points_extra
+
+  if( (j1b_type .eq. 100) .or. &
+      (j1b_type .ge. 200) .and. (j1b_type .lt. 300) ) then
+
+    call grad1_j12_mu_r1_seq(r1, n_grid2, resx, resy, resz)
+    do jpoint = 1, n_points_extra_final_grid
+      res(jpoint) = resx(jpoint) * resx(jpoint) &
+                  + resy(jpoint) * resy(jpoint) &
+                  + resz(jpoint) * resz(jpoint)
+    enddo
+
+  elseif((j1b_type .gt. 100) .and. (j1b_type .lt. 200)) then
+
+    allocate(v1b_r2(n_grid2))
+    allocate(u2b_r12(n_grid2))
+    allocate(gradx1_u2b(n_grid2))
+    allocate(grady1_u2b(n_grid2))
+    allocate(gradz1_u2b(n_grid2))
+
+    v1b_r1 = j1b_nucl(r1)
+    call grad1_j1b_nucl(r1, grad1_v1b)
+
+    call j1b_nucl_r1_seq(n_grid2, v1b_r2)
+    call j12_mu_r1_seq(r1, n_grid2, u2b_r12)
+    call grad1_j12_mu_r1_seq(r1, n_grid2, gradx1_u2b, grady1_u2b, gradz1_u2b)
+
+    do jpoint = 1, n_points_extra_final_grid
+      resx(jpoint) = (gradx1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(1)) * v1b_r2(jpoint)
+      resy(jpoint) = (grady1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(2)) * v1b_r2(jpoint)
+      resz(jpoint) = (gradz1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(3)) * v1b_r2(jpoint)
+      res (jpoint) = resx(jpoint) * resx(jpoint) &
+                   + resy(jpoint) * resy(jpoint) &
+                   + resz(jpoint) * resz(jpoint)
+    enddo
+
+    deallocate(v1b_r2, u2b_r12, gradx1_u2b, grady1_u2b, gradz1_u2b)
+
+  else
+
+    print *, ' j1b_type = ', j1b_type, 'not implemented yet'
+    stop
+
+  endif
+
+  return
+end subroutine get_grad1_u12_withsq_r1_seq
+
+! ---
+
+subroutine grad1_j12_mu_r1_seq(r1, n_grid2, gradx, grady, gradz)
+
+  BEGIN_DOC
+  !
+  !  gradient of j(mu(r1,r2),r12) form of jastrow. 
+  !
+  ! if mu(r1,r2) = cst ---> j1b_type < 200 and 
+  !
+  !  d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2)
+  !
+  ! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and 
+  !
+  ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2) 
+  !                        + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2)
+  !
+  END_DOC
+
+  include 'constants.include.F'
+
+  implicit none
+  integer         , intent(in)  :: n_grid2
+  double precision, intent(in)  :: r1(3)
+  double precision, intent(out) :: gradx(n_grid2)
+  double precision, intent(out) :: grady(n_grid2)
+  double precision, intent(out) :: gradz(n_grid2)
+
+  integer                       :: jpoint
+  double precision              :: r2(3)
+  double precision              :: dx, dy, dz, r12, tmp
+
+  if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
+
+    do jpoint = 1, n_points_extra_final_grid ! r2 
+
+      r2(1) = final_grid_points_extra(1,jpoint)
+      r2(2) = final_grid_points_extra(2,jpoint)
+      r2(3) = final_grid_points_extra(3,jpoint)
+
+      dx = r1(1) - r2(1)
+      dy = r1(2) - r2(2)
+      dz = r1(3) - r2(3)
+
+      r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+      if(r12 .lt. 1d-10) then
+        gradx(jpoint) = 0.d0 
+        grady(jpoint) = 0.d0 
+        gradz(jpoint) = 0.d0 
+        cycle
+      endif
+
+      tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
+
+      gradx(jpoint) = tmp * dx
+      grady(jpoint) = tmp * dy
+      gradz(jpoint) = tmp * dz
+    enddo
+
+  elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then
+
+    double precision :: mu_val, mu_tmp, mu_der(3)
+
+    do jpoint = 1, n_points_extra_final_grid ! r2 
+
+      r2(1) = final_grid_points_extra(1,jpoint)
+      r2(2) = final_grid_points_extra(2,jpoint)
+      r2(3) = final_grid_points_extra(3,jpoint)
+
+      dx  = r1(1) - r2(1)
+      dy  = r1(2) - r2(2)
+      dz  = r1(3) - r2(3)
+      r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+
+      call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
+      mu_tmp  = mu_val * r12
+      tmp     = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
+      gradx(jpoint) = tmp * mu_der(1)
+      grady(jpoint) = tmp * mu_der(2)
+      gradz(jpoint) = tmp * mu_der(3)
+
+      if(r12 .lt. 1d-10) then
+        gradx(jpoint) = 0.d0
+        grady(jpoint) = 0.d0
+        gradz(jpoint) = 0.d0
+        cycle
+      endif
+
+      tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12
+
+      gradx(jpoint) = gradx(jpoint) + tmp * dx
+      grady(jpoint) = grady(jpoint) + tmp * dy
+      gradz(jpoint) = gradz(jpoint) + tmp * dz
+    enddo
+
+  else
+
+    print *, ' j1b_type = ', j1b_type, 'not implemented yet'
+    stop
+
+  endif
+
+  return
+end subroutine grad1_j12_mu_r1_seq
+
+! ---
+
+subroutine j12_mu_r1_seq(r1, n_grid2, res)
+
+  include 'constants.include.F'
+
+  implicit none
+  integer,          intent(in)  :: n_grid2
+  double precision, intent(in)  :: r1(3)
+  double precision, intent(out) :: res(n_grid2)
+
+  integer                       :: jpoint
+  double precision              :: r2(3)
+  double precision              :: mu_tmp, r12
+
+  PROVIDE final_grid_points_extra
+
+  if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then
+
+    do jpoint = 1, n_points_extra_final_grid ! r2 
+
+      r2(1) = final_grid_points_extra(1,jpoint)
+      r2(2) = final_grid_points_extra(2,jpoint)
+      r2(3) = final_grid_points_extra(3,jpoint)
+
+      r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
+                 + (r1(2) - r2(2)) * (r1(2) - r2(2)) &
+                 + (r1(3) - r2(3)) * (r1(3) - r2(3)) )
+      mu_tmp = mu_erf * r12
+
+      res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
+    enddo
+
+  else
+
+    print *, ' j1b_type = ', j1b_type, 'not implemented for j12_mu_r1_seq'
+    stop
+
+  endif
+
+  return
+end subroutine j12_mu_r1_seq
+
+! ---
+
+subroutine j1b_nucl_r1_seq(n_grid2, res)
+
+  ! TODO
+  ! change loops order
+
+  implicit none
+  integer,          intent(in)  :: n_grid2
+  double precision, intent(out) :: res(n_grid2)
+
+  double precision               :: r(3)
+  integer                        :: i, jpoint
+  double precision               :: a, d, e, x, y, z
+
+  if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then
+
+    res = 1.d0
+
+    do jpoint = 1, n_points_extra_final_grid ! r2 
+      r(1) = final_grid_points_extra(1,jpoint)
+      r(2) = final_grid_points_extra(2,jpoint)
+      r(3) = final_grid_points_extra(3,jpoint)
+
+      do i = 1, nucl_num
+        a = j1b_pen(i)
+        d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+            + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+            + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
+
+        res(jpoint) -= dexp(-a*dsqrt(d))
+      enddo
+    enddo
+
+  elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
+
+    res = 1.d0
+
+    do jpoint = 1, n_points_extra_final_grid ! r2 
+      r(1) = final_grid_points_extra(1,jpoint)
+      r(2) = final_grid_points_extra(2,jpoint)
+      r(3) = final_grid_points_extra(3,jpoint)
+
+      do i = 1, nucl_num
+        a = j1b_pen(i)
+        d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+            + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+            + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
+        e = 1.d0 - dexp(-a*d)
+
+        res(jpoint) *= e
+      enddo
+    enddo
+
+  elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
+
+    res = 1.d0
+
+    do jpoint = 1, n_points_extra_final_grid ! r2 
+      r(1) = final_grid_points_extra(1,jpoint)
+      r(2) = final_grid_points_extra(2,jpoint)
+      r(3) = final_grid_points_extra(3,jpoint)
+
+      do i = 1, nucl_num
+        a = j1b_pen(i)
+        d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) &
+            + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) &
+            + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) )
+        res(jpoint) -= j1b_pen_coef(i) * dexp(-a*d)
+      enddo
+    enddo
+
+  elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then
+
+    res = 1.d0
+
+    do jpoint = 1, n_points_extra_final_grid ! r2 
+      r(1) = final_grid_points_extra(1,jpoint)
+      r(2) = final_grid_points_extra(2,jpoint)
+      r(3) = final_grid_points_extra(3,jpoint)
+
+      do i = 1, nucl_num
+        a = j1b_pen(i)
+        x = r(1) - nucl_coord(i,1)
+        y = r(2) - nucl_coord(i,2)
+        z = r(3) - nucl_coord(i,3)
+        d = x*x + y*y + z*z
+        res(jpoint) -= dexp(-a*d*d)
+      enddo
+    enddo
+
+  else
+
+    print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl_r1_seq'
+    stop
+
+  endif
+
+  return
+end subroutine j1b_nucl_r1_seq
+
+! ---
+

src/non_h_ints_mu/new_grad_tc.irp.f

@@ -149,22 +149,6 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num,
     deallocate(b_mat)
 
     call sum_A_At(tc_grad_and_lapl_ao(1,1,1,1), ao_num*ao_num)
-  ! !$OMP PARALLEL             &
-  ! !$OMP DEFAULT (NONE)       &
-  ! !$OMP PRIVATE (i, j, k, l) & 
-  ! !$OMP SHARED (ac_mat, tc_grad_and_lapl_ao, ao_num)
-  ! !$OMP DO SCHEDULE (static)
-  !  do j = 1, ao_num
-  !    do l = 1, ao_num
-  !      do i = 1, ao_num
-  !        do k = 1, ao_num
-  !          tc_grad_and_lapl_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
-  !        enddo
-  !      enddo
-  !    enddo
-  !  enddo
-  ! !$OMP END DO
-  ! !$OMP END PARALLEL
 
   endif
 

src/non_h_ints_mu/qmckl.irp.f

@@ -0,0 +1,102 @@
+BEGIN_PROVIDER [ integer*8, qmckl_ctx_jastrow ]
+  use qmckl
+  implicit none
+  BEGIN_DOC
+  ! Context for the QMCKL library
+  END_DOC
+  integer(qmckl_exit_code) :: rc
+
+  qmckl_ctx_jastrow = qmckl_context_create()
+
+  rc = qmckl_set_nucleus_num(qmckl_ctx_jastrow, nucl_num*1_8)
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+  rc = qmckl_set_nucleus_charge(qmckl_ctx_jastrow, nucl_charge, nucl_num*1_8)
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+  rc = qmckl_set_nucleus_coord(qmckl_ctx_jastrow, 'T', nucl_coord, nucl_num*3_8)
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+  rc = qmckl_set_electron_num(qmckl_ctx_jastrow, 1_8, 1_8)
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+
+  ! Jastrow parameters
+  rc =  qmckl_set_jastrow_champ_type_nucl_num     (qmckl_ctx_jastrow, 2_8)
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+  rc =  qmckl_set_jastrow_champ_type_nucl_vector  (qmckl_ctx_jastrow, (/0_8,1_8,1_8/), 1_8*nucl_num)
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+  rc =  qmckl_set_jastrow_champ_rescale_factor_ee (qmckl_ctx_jastrow, 0.6d0)
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+  rc =  qmckl_set_jastrow_champ_rescale_factor_en (qmckl_ctx_jastrow, (/0.6d0, 0.6d0 /), 2_8 )
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+  rc =  qmckl_set_jastrow_champ_aord_num          (qmckl_ctx_jastrow, 5_8)
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+  rc =  qmckl_set_jastrow_champ_bord_num          (qmckl_ctx_jastrow, 5_8)
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+  rc =  qmckl_set_jastrow_champ_cord_num          (qmckl_ctx_jastrow, 0_8)
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+!  double precision :: a_vector(12) = dble(&
+!           (/ 0.00000000,  0.00000000, -0.71168405, -0.44415699, -0.13865109,  0.07002267 , &
+!              0.00000000,  0.00000000, -0.11379992,  0.04542846,  0.01696997, -0.01809299 /) )
+
+!  double precision :: b_vector(6) = dble(&
+!           (/  0.00000000,  0.65603311,  0.14581988,  0.03138163,  0.00153156, -0.00447302 /) )
+
+!  double precision :: c_vector(46) = &
+!           (/ 1.06384279d0, -1.44303973d0, -0.92409833d0,  0.11845356d0, -0.02980776d0, &
+!              1.07048863d0,  0.06009623d0, -0.01854872d0, -0.00915398d0,  0.01324198d0, &
+!             -0.00504959d0, -0.01202497d0, -0.00531644d0,  0.15101629d0, -0.00723831d0, &
+!             -0.00384182d0, -0.00295036d0, -0.00114583d0,  0.00158107d0, -0.00078107d0, &
+!             -0.00080000d0, -0.14140576d0, -0.00237271d0, -0.03006706d0,  0.01537009d0, &
+!             -0.02327226d0,  0.16502789d0, -0.01458259d0, -0.09946065d0,  0.00850029d0, &
+!             -0.02969361d0, -0.01159547d0,  0.00516313d0,  0.00405247d0, -0.02200886d0, &
+!              0.03376709d0,  0.01277767d0, -0.01523013d0, -0.00739224d0, -0.00463953d0, &
+!              0.00003174d0, -0.01421128d0,  0.00808140d0,  0.00612988d0, -0.00610632d0, &
+!              0.01926215d0 /)
+
+!     a_vector = 0.d0
+!     b_vector = 0.d0
+!     c_vector = 0.d0
+
+   double precision :: a_vector(12) = dble(&
+            (/ 0.00000000 , 0.00000000, -0.45105821, -0.23519218, -0.03825391,  0.10072866, &
+               0.00000000 , 0.00000000, -0.06930592, -0.02909224, -0.00134650,  0.01477242 /) )
+
+   double precision :: b_vector(6) = dble(&
+            (/  0.00000000,  0.00000000,  0.29217862, -0.00450671, -0.02925982, -0.01381532 /) )
+
+   double precision :: c_vector(46)
+   c_vector = 0.d0
+
+  rc =  qmckl_set_jastrow_champ_a_vector(qmckl_ctx_jastrow, a_vector, 12_8)
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+  rc =  qmckl_set_jastrow_champ_b_vector(qmckl_ctx_jastrow, b_vector, 6_8)
+  rc = qmckl_check(qmckl_ctx_jastrow, rc)
+  if (rc /= QMCKL_SUCCESS) stop -1
+
+! rc =  qmckl_set_jastrow_champ_c_vector(qmckl_ctx_jastrow, c_vector, 46_8)
+! rc = qmckl_check(qmckl_ctx_jastrow, rc)
+! if (rc /= QMCKL_SUCCESS) stop -1
+
+END_PROVIDER

src/non_h_ints_mu/tc_integ_an.irp.f

@@ -1,10 +1,11 @@
 
-! ---
-
 BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_final_grid, 3)]
 
   BEGIN_DOC
   !
+  ! TODO
+  ! combine with int2_grad1_u12_square_ao to avoid repeated calculation ?
+  !
   ! int2_grad1_u12_ao(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) 
   !
   ! where r1 = r(ipoint)
@@ -105,62 +106,12 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_f
 
     elseif(j1b_type .ge. 100) then
   
-      PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
+!     PROVIDE int2_grad1_u12_ao_num
-      PROVIDE grad1_u12_num
+!     int2_grad1_u12_ao = int2_grad1_u12_ao_num
 
-      double precision, allocatable :: tmp(:,:,:)
+      PROVIDE int2_grad1_u12_ao_num_1shot
-      allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
+      int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot
-      tmp = 0.d0
-      !$OMP PARALLEL               &
-      !$OMP DEFAULT (NONE)         &
-      !$OMP PRIVATE (j, i, jpoint) &
-      !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
-      !$OMP DO SCHEDULE (static)
-      do j = 1, ao_num
-        do i = 1, ao_num
-          do jpoint = 1, n_points_extra_final_grid
-            tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
-          enddo
-        enddo
-      enddo
-      !$OMP END DO
-      !$OMP END PARALLEL
 
-      int2_grad1_u12_ao = 0.d0
-      do m = 1, 3
-        !call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, +1.d0         &
-        ! this work also because of the symmetry in K(1,2) and sign compensation in L(1,2,3)
-        call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -1.d0         &
-                  , tmp(1,1,1), n_points_extra_final_grid, grad1_u12_num(1,1,m), n_points_extra_final_grid &
-                  , 0.d0, int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num) 
-      enddo
-
-      !! these dgemm are equivalent to
-      !!$OMP PARALLEL                                                           &
-      !!$OMP DEFAULT (NONE)                                                     &
-      !!$OMP PRIVATE (j, i, ipoint, jpoint, w)                                  &
-      !!$OMP SHARED (int2_grad1_u12_ao, ao_num, n_points_final_grid,            &
-      !!$OMP         n_points_extra_final_grid, final_weight_at_r_vector_extra, &
-      !!$OMP         aos_in_r_array_extra_transp, grad1_u12_num, tmp)
-      !!$OMP DO SCHEDULE (static)
-      !do ipoint = 1, n_points_final_grid
-      !  do j = 1, ao_num
-      !    do i = 1, ao_num
-      !      do jpoint = 1, n_points_extra_final_grid
-      !        w = -tmp(jpoint,i,j)
-      !        !w = tmp(jpoint,i,j) this work also because of the symmetry in K(1,2)
-      !        !                    and sign compensation in L(1,2,3)
-      !        int2_grad1_u12_ao(i,j,ipoint,1) += w * grad1_u12_num(jpoint,ipoint,1)
-      !        int2_grad1_u12_ao(i,j,ipoint,2) += w * grad1_u12_num(jpoint,ipoint,2)
-      !        int2_grad1_u12_ao(i,j,ipoint,3) += w * grad1_u12_num(jpoint,ipoint,3)
-      !      enddo
-      !    enddo
-      !  enddo
-      !enddo
-      !!$OMP END DO
-      !!$OMP END PARALLEL
-
-      deallocate(tmp)
     else
 
       print *, ' j1b_type = ', j1b_type, 'not implemented yet'
@@ -274,54 +225,11 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_p
 
   elseif(j1b_type .ge. 100) then
 
-    PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
+ !  PROVIDE int2_grad1_u12_square_ao_num
-    PROVIDE grad1_u12_squared_num
+ !  int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num
 
-    double precision, allocatable :: tmp(:,:,:)
+    PROVIDE int2_grad1_u12_square_ao_num_1shot
-    allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
+    int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot
-    tmp = 0.d0
-    !$OMP PARALLEL               &
-    !$OMP DEFAULT (NONE)         &
-    !$OMP PRIVATE (j, i, jpoint) &
-    !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
-    !$OMP DO SCHEDULE (static)
-    do j = 1, ao_num
-      do i = 1, ao_num
-        do jpoint = 1, n_points_extra_final_grid
-          tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
-        enddo
-      enddo
-    enddo
-    !$OMP END DO
-    !$OMP END PARALLEL
-
-    int2_grad1_u12_square_ao = 0.d0
-    call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -0.5d0              &
-              , tmp(1,1,1), n_points_extra_final_grid, grad1_u12_squared_num(1,1), n_points_extra_final_grid &
-              , 0.d0, int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num) 
-
-    !! this dgemm is equivalen to
-    !!$OMP PARALLEL                                                           &
-    !!$OMP DEFAULT (NONE)                                                     &
-    !!$OMP PRIVATE (i, j, ipoint, jpoint, w)                                  &
-    !!$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid,     &
-    !!$OMP         n_points_extra_final_grid, final_weight_at_r_vector_extra, &
-    !!$OMP         aos_in_r_array_extra_transp, grad1_u12_squared_num, tmp)
-    !!$OMP DO SCHEDULE (static)
-    !do ipoint = 1, n_points_final_grid
-    !  do j = 1, ao_num
-    !    do i = 1, ao_num
-    !      do jpoint = 1, n_points_extra_final_grid
-    !        w = -0.5d0 * tmp(jpoint,i,j)
-    !        int2_grad1_u12_square_ao(i,j,ipoint) += w * grad1_u12_squared_num(jpoint,ipoint)
-    !      enddo
-    !    enddo
-    !  enddo
-    !enddo
-    !!$OMP END DO
-    !!$OMP END PARALLEL
-
-    deallocate(tmp)
 
   else
 

src/non_h_ints_mu/tc_integ_num.irp.f

@@ -0,0 +1,201 @@
+
+ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_num       , (ao_num,ao_num,n_points_final_grid,3)]
+&BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao_num, (ao_num,ao_num,n_points_final_grid)  ]
+
+  BEGIN_DOC
+  !
+  ! int2_grad1_u12_ao_num(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) 
+  !
+  ! int2_grad1_u12_square_ao_num = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2
+  !
+  END_DOC
+
+  implicit none
+  integer                       :: ipoint, i, j, m, jpoint
+  integer                       :: n_blocks, n_rest, n_pass
+  integer                       :: i_blocks, i_rest, i_pass, ii
+  double precision              :: time0, time1
+  double precision              :: mem, n_double
+  double precision, allocatable :: tmp(:,:,:)
+  double precision, allocatable :: tmp_grad1_u12(:,:,:), tmp_grad1_u12_squared(:,:)
+
+  ! TODO
+  ! tmp_grad1_u12_squared get be obtained from tmp_grad1_u12 
+
+  print*, ' providing int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num ...'
+  call wall_time(time0)
+
+  PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
+
+  allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
+  !$OMP PARALLEL               &
+  !$OMP DEFAULT (NONE)         &
+  !$OMP PRIVATE (j, i, jpoint) &
+  !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
+  !$OMP DO SCHEDULE (static)
+  do j = 1, ao_num
+    do i = 1, ao_num
+      do jpoint = 1, n_points_extra_final_grid
+        tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  ! n_points_final_grid = n_blocks * n_pass + n_rest
+  call total_memory(mem)
+  mem      = max(1.d0, qp_max_mem - mem)
+  n_double = mem * 1.d8
+  n_blocks = min(n_double / (n_points_extra_final_grid * 4), 1.d0*n_points_final_grid)
+  n_rest   = int(mod(n_points_final_grid, n_blocks))
+  n_pass   = int((n_points_final_grid - n_rest) / n_blocks)
+
+  call write_int(6, n_pass, 'Number of passes')
+  call write_int(6, n_blocks, 'Size of the blocks')
+  call write_int(6, n_rest, 'Size of the last block')
+
+  
+  allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_blocks))
+  allocate(tmp_grad1_u12(n_points_extra_final_grid,n_blocks,3))
+  
+  do i_pass = 1, n_pass
+    ii = (i_pass-1)*n_blocks + 1
+  
+    !$OMP PARALLEL                                         &
+    !$OMP DEFAULT (NONE)                                   &
+    !$OMP PRIVATE (i_blocks, ipoint)                       &
+    !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, &
+    !$OMP         final_grid_points, tmp_grad1_u12,        &
+    !$OMP         tmp_grad1_u12_squared)
+    !$OMP DO 
+    do i_blocks = 1, n_blocks
+      ipoint = ii - 1 + i_blocks ! r1
+      call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1) &
+                                                                                             , tmp_grad1_u12(1,i_blocks,2) &
+                                                                                             , tmp_grad1_u12(1,i_blocks,3) &
+                                                                                             , tmp_grad1_u12_squared(1,i_blocks))
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+    do m = 1, 3
+      call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, 1.d0                     &
+                , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid &
+                , 0.d0, int2_grad1_u12_ao_num(1,1,ii,m), ao_num*ao_num) 
+    enddo
+    call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, -0.5d0                         &
+              , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid &
+              , 0.d0, int2_grad1_u12_square_ao_num(1,1,ii), ao_num*ao_num) 
+  enddo
+  
+  deallocate(tmp_grad1_u12, tmp_grad1_u12_squared)
+  
+  if(n_rest .gt. 0) then
+  
+    allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_rest))
+    allocate(tmp_grad1_u12(n_points_extra_final_grid,n_rest,3))
+  
+    ii = n_pass*n_blocks + 1
+
+    !$OMP PARALLEL                                       &
+    !$OMP DEFAULT (NONE)                                 &
+    !$OMP PRIVATE (i_rest, ipoint)                       &
+    !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, &
+    !$OMP         final_grid_points, tmp_grad1_u12,      &
+    !$OMP         tmp_grad1_u12_squared)
+    !$OMP DO 
+    do i_rest = 1, n_rest
+      ipoint = ii - 1 + i_rest ! r1
+      call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1) &
+                                                                                             , tmp_grad1_u12(1,i_rest,2) &
+                                                                                             , tmp_grad1_u12(1,i_rest,3) &
+                                                                                             , tmp_grad1_u12_squared(1,i_rest))
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+  
+    do m = 1, 3
+      call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, 1.d0                       &
+                , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid &
+                , 0.d0, int2_grad1_u12_ao_num(1,1,ii,m), ao_num*ao_num) 
+    enddo
+    call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, -0.5d0                           &
+              , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid &
+              , 0.d0, int2_grad1_u12_square_ao_num(1,1,ii), ao_num*ao_num) 
+
+    deallocate(tmp_grad1_u12, tmp_grad1_u12_squared)
+  endif
+
+  deallocate(tmp)
+
+  call wall_time(time1)
+  print*, ' wall time for int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num =', time1-time0 
+  call print_memory_usage()
+
+END_PROVIDER
+
+! ---
+
+ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_num_1shot       , (ao_num,ao_num,n_points_final_grid,3)]
+&BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao_num_1shot, (ao_num,ao_num,n_points_final_grid)  ]
+
+  BEGIN_DOC
+  !
+  ! int2_grad1_u12_ao_num_1shot(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) 
+  !
+  ! int2_grad1_u12_square_ao_num_1shot = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2
+  !
+  END_DOC
+
+  implicit none
+  integer                       :: ipoint, i, j, m, jpoint
+  double precision              :: time0, time1
+  double precision, allocatable :: tmp(:,:,:)
+
+  print*, ' providing int2_grad1_u12_ao_num_1shot & int2_grad1_u12_square_ao_num_1shot ...'
+  call wall_time(time0)
+
+  PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
+  PROVIDE grad1_u12_num grad1_u12_squared_num
+
+  allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
+  !$OMP PARALLEL               &
+  !$OMP DEFAULT (NONE)         &
+  !$OMP PRIVATE (j, i, jpoint) &
+  !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
+  !$OMP DO SCHEDULE (static)
+  do j = 1, ao_num
+    do i = 1, ao_num
+      do jpoint = 1, n_points_extra_final_grid
+        tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  do m = 1, 3
+    !call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -1.d0         &
+    ! this work also because of the symmetry in K(1,2) and sign compensation in L(1,2,3)
+    call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, +1.d0         &
+              , tmp(1,1,1), n_points_extra_final_grid, grad1_u12_num(1,1,m), n_points_extra_final_grid &
+              , 0.d0, int2_grad1_u12_ao_num_1shot(1,1,1,m), ao_num*ao_num) 
+  enddo
+  FREE grad1_u12_num
+
+  call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -0.5d0              &
+            , tmp(1,1,1), n_points_extra_final_grid, grad1_u12_squared_num(1,1), n_points_extra_final_grid &
+            , 0.d0, int2_grad1_u12_square_ao_num_1shot(1,1,1), ao_num*ao_num) 
+  FREE grad1_u12_squared_num
+
+  deallocate(tmp)
+
+  call wall_time(time1)
+  print*, ' wall time for int2_grad1_u12_ao_num_1shot & int2_grad1_u12_square_ao_num_1shot =', time1-time0 
+  call print_memory_usage()
+
+END_PROVIDER
+
+! ---
+

src/non_h_ints_mu/test_non_h_ints.irp.f

@@ -11,10 +11,24 @@ program test_non_h
   my_n_pt_a_grid = tc_grid1_a
   touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
 
+  if(j1b_type .ge. 100) then
+    my_extra_grid_becke  = .True.
+    PROVIDE tc_grid2_a tc_grid2_r
+    my_n_pt_r_extra_grid = tc_grid2_r
+    my_n_pt_a_extra_grid = tc_grid2_a
+    touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
+  endif
+
+
   !call routine_grad_squared()
   !call routine_fit()
   
-  call test_ipp()
+  !call test_ipp()
+  
+  !call test_v_ij_u_cst_mu_j1b_an()
+
+  call test_int2_grad1_u12_square_ao()
+  call test_int2_grad1_u12_ao()
 end
 
 ! ---
@@ -545,9 +559,129 @@ end subroutine grad1_aos_ik_grad1_esquare
 
 ! ---
 
+subroutine test_v_ij_u_cst_mu_j1b_an()
 
+  implicit none
+  integer          :: i, j, ipoint
+  double precision :: I_old, I_new
+  double precision :: norm, accu, thr, diff
 
+  PROVIDE v_ij_u_cst_mu_j1b_an_old v_ij_u_cst_mu_j1b_an
 
+  thr  = 1d-12
+  norm = 0.d0
+  accu = 0.d0
+  do ipoint = 1, n_points_final_grid
+    do i = 1, ao_num
+      do j = 1, ao_num
 
+        I_old = v_ij_u_cst_mu_j1b_an_old(j,i,ipoint)
+        I_new = v_ij_u_cst_mu_j1b_an    (j,i,ipoint)
 
+        diff = dabs(I_new-I_old)
+        if(diff .gt. thr) then
+          print *, ' problem on:', j, i, ipoint
+          print *, ' old value :', I_old
+          print *, ' new value :', I_new
+          stop
+        endif
+
+        accu += diff
+        norm += dabs(I_old)
+      enddo
+    enddo
+  enddo
+
+  print*, ' accuracy(%) = ', 100.d0 * accu / norm
+
+  return
+end subroutine test_v_ij_u_cst_mu_j1b_an
+
+! ---
+
+subroutine test_int2_grad1_u12_square_ao()
+
+  implicit none
+  integer          :: i, j, ipoint
+  double precision :: I_old, I_new
+  double precision :: norm, accu, thr, diff
+
+  PROVIDE int2_grad1_u12_square_ao
+  PROVIDE int2_grad1_u12_square_ao_num_1shot
+
+  thr  = 1d-8
+  norm = 0.d0
+  accu = 0.d0
+  do ipoint = 1, n_points_final_grid
+    do i = 1, ao_num
+      do j = 1, ao_num
+
+        I_old = int2_grad1_u12_square_ao_num_1shot(j,i,ipoint)
+        I_new = int2_grad1_u12_square_ao          (j,i,ipoint)
+        !I_new = int2_grad1_u12_square_ao_num      (j,i,ipoint)
+
+        diff = dabs(I_new-I_old)
+        if(diff .gt. thr) then
+          print *, ' problem on:', j, i, ipoint
+          print *, ' old value :', I_old
+          print *, ' new value :', I_new
+          !stop
+        endif
+
+        accu += diff
+        norm += dabs(I_old)
+      enddo
+    enddo
+  enddo
+
+  print*, ' accuracy(%) = ', 100.d0 * accu / norm
+
+  return
+end subroutine test_int2_grad1_u12_square_ao
+
+! ---
+
+subroutine test_int2_grad1_u12_ao()
+
+  implicit none
+  integer          :: i, j, ipoint, m
+  double precision :: I_old, I_new
+  double precision :: norm, accu, thr, diff
+
+  PROVIDE int2_grad1_u12_ao
+  PROVIDE int2_grad1_u12_ao_num_1shot
+
+  thr  = 1d-8
+  norm = 0.d0
+  accu = 0.d0
+  do ipoint = 1, n_points_final_grid
+    do i = 1, ao_num
+      do j = 1, ao_num
+
+        do m = 1, 3
+          I_old = int2_grad1_u12_ao_num_1shot(j,i,ipoint,m)
+          I_new = int2_grad1_u12_ao          (j,i,ipoint,m)
+          !I_new = int2_grad1_u12_ao_num      (j,i,ipoint,m)
+
+          diff = dabs(I_new-I_old)
+          if(diff .gt. thr) then
+            print *, ' problem on:', j, i, ipoint, m
+            print *, ' old value :', I_old
+            print *, ' new value :', I_new
+            !stop
+          endif
+
+          accu += diff
+          norm += dabs(I_old)
+        enddo
+      enddo
+    enddo
+  enddo
+
+  print*, ' accuracy(%) = ', 100.d0 * accu / norm
+
+  return
+end subroutine test_int2_grad1_u12_ao
+
+! ---
 

src/non_h_ints_mu/total_tc_int.irp.f

@@ -1,7 +1,4 @@
 
-! TODO
-! remove ao_two_e_coul and use map directly
-
 ! ---
 
 BEGIN_PROVIDER [double precision, ao_vartc_int_chemist, (ao_num, ao_num, ao_num, ao_num)]
@@ -58,12 +55,13 @@ BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao
   integer          :: i, j, k, l
   double precision :: wall1, wall0
 
+  PROVIDE j1b_type
+
   print *, ' providing ao_tc_int_chemist ...'
   call wall_time(wall0)
   
   if(test_cycle_tc) then
 
-    PROVIDE j1b_type
     if(j1b_type .ne. 3) then
       print*, ' TC integrals with cycle can not be used for j1b_type =', j1b_type
       stop
@@ -89,6 +87,11 @@ BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao
 
   FREE tc_grad_square_ao tc_grad_and_lapl_ao ao_two_e_coul
 
+  if(j1b_type .ge. 100) then
+    FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num
+  endif
+
+
   call wall_time(wall1)
   print *, ' wall time for ao_tc_int_chemist ', wall1 - wall0
   call print_memory_usage()
@@ -160,24 +163,26 @@ BEGIN_PROVIDER [double precision, ao_two_e_coul, (ao_num, ao_num, ao_num, ao_num
   END_DOC
 
   integer                    :: i, j, k, l
-  double precision           :: integral
   double precision, external :: get_ao_two_e_integral
 
   PROVIDE ao_integrals_map
 
+  !$OMP PARALLEL DEFAULT(NONE)                          &
+  !$OMP SHARED(ao_num, ao_two_e_coul, ao_integrals_map) &
+  !$OMP PRIVATE(i, j, k, l)
+  !$OMP DO
   do j = 1, ao_num
     do l = 1, ao_num
       do i = 1, ao_num
         do k = 1, ao_num
-
           !  < 1:k, 2:l | 1:i, 2:j > 
-          integral = get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
+          ao_two_e_coul(k,i,l,j) = get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
-
-          ao_two_e_coul(k,i,l,j) = integral
         enddo
       enddo
     enddo
   enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
 
 END_PROVIDER 
 

src/qmckl/README.md

@@ -0,0 +1,4 @@
+#QMCkl
+
+Info related to the QMCkl library.
+

src/qmckl/qmckl.F90

@@ -0,0 +1 @@
+#include <qmckl_f.F90>

src/tc_bi_ortho/normal_ordered_old.irp.f

@@ -26,7 +26,7 @@ BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_old, (mo_num, mo_num,
 
   if(read_tc_norm_ord) then
 
-    open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth_old', action="read")
+    open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth', action="read")
       read(11) normal_two_body_bi_orth_old
     close(11)
 
@@ -103,7 +103,7 @@ BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_old, (mo_num, mo_num,
   endif
 
   if(write_tc_norm_ord.and.mpi_master) then
-    open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth_old', action="write")
+    open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth', action="write")
       call ezfio_set_work_empty(.False.)
       write(11) normal_two_body_bi_orth_old
       close(11)

src/tc_bi_ortho/slater_tc_opt.irp.f

@@ -37,7 +37,9 @@ end
 ! ---
 
 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
@@ -85,7 +87,7 @@ subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree,
   hmono  = 0.d0
   htwoe  = 0.d0
   htot   = 0.d0
-  hthree = 0.D0
+  hthree = 0.d0
 
   call get_excitation_degree(key_i, key_j, degree, Nint)
   if(.not.pure_three_body_h_tc)then

src/tc_bi_ortho/slater_tc_opt_diag.irp.f

@@ -29,6 +29,11 @@
 
   ref_tc_energy_tot = ref_tc_energy_1e + ref_tc_energy_2e + ref_tc_energy_3e + nuclear_repulsion
 
+  if(noL_standard) then
+    PROVIDE noL_0e
+    ref_tc_energy_tot += noL_0e
+  endif
+
 END_PROVIDER 
 
 ! ---
@@ -107,6 +112,11 @@ subroutine diag_htilde_mu_mat_fock_bi_ortho(Nint, det_in, hmono, htwoe, hthree,
 
   htot = hmono + htwoe + hthree + nuclear_repulsion
 
+  if(noL_standard) then
+    PROVIDE noL_0e
+    htot += noL_0e
+  endif
+
 end
 
 ! ---

src/tc_bi_ortho/test_tc_bi_ortho.irp.f

@@ -17,8 +17,11 @@ program tc_bi_ortho
   my_n_pt_a_grid = tc_grid1_a
   touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
 
-  read_wf = .True.
+  call write_int(6, my_n_pt_r_grid, 'radial  external grid over')
-  touch read_wf
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+!  read_wf = .True.
+!  touch read_wf
 
 ! call test_h_u0
 ! call test_slater_tc_opt
@@ -27,10 +30,17 @@ program tc_bi_ortho
 ! call timing_single
 ! call timing_double
 
-  call test_no()
   !call test_no_aba()
   !call test_no_aab()
   !call test_no_aaa()
+
+  !call test_no()
+  !call test_no_v0()
+
+  call test_no_0()
+  call test_no_1()
+  call test_no_2()
+
 end
 
 subroutine test_h_u0
@@ -268,29 +278,30 @@ end
 
 ! ---
 
-subroutine test_no()
+subroutine test_no_v0()
 
   implicit none
   integer          :: i, j, k, l
-  double precision :: accu, contrib, new, ref, thr
+  double precision :: accu, contrib, new, ref, thr, norm
 
-  print*, ' testing normal_two_body_bi_orth ...'
+  print*, ' test_no_v0 ...'
 
   thr = 1d-8
 
-  PROVIDE normal_two_body_bi_orth_old
+  PROVIDE normal_two_body_bi_orth_v0
   PROVIDE normal_two_body_bi_orth
 
   accu = 0.d0
+  norm = 0.d0
   do i = 1, mo_num
     do j = 1, mo_num
       do k = 1, mo_num
         do l = 1, mo_num
 
           new = normal_two_body_bi_orth   (l,k,j,i)
-          ref = normal_two_body_bi_orth_old(l,k,j,i)
+          ref = normal_two_body_bi_orth_v0(l,k,j,i)
+
           contrib = dabs(new - ref)
-          accu += contrib
           if(contrib .gt. thr) then
             print*, ' problem on normal_two_body_bi_orth'
             print*, l, k, j, i
@@ -298,14 +309,63 @@ subroutine test_no()
             stop
           endif
 
+          accu += contrib
+          norm += dabs(ref)
         enddo
       enddo
     enddo
   enddo
-  print*, ' accu on normal_two_body_bi_orth = ', accu / dble(mo_num)**4
+
+  print*, ' accu (%) = ', 100.d0*accu/norm
 
   return
-end
+end subroutine test_no_0
+
+! ---
+
+
+subroutine test_no()
+
+  implicit none
+  integer          :: i, j, k, l
+  double precision :: accu, contrib, new, ref, thr, norm
+
+  print*, ' test_no ...'
+
+  thr = 1d-8
+
+  PROVIDE normal_two_body_bi_orth_old
+  PROVIDE normal_two_body_bi_orth
+
+  accu = 0.d0
+  norm = 0.d0
+  do i = 1, mo_num
+    do j = 1, mo_num
+      do k = 1, mo_num
+        do l = 1, mo_num
+
+          new = normal_two_body_bi_orth    (l,k,j,i)
+          ref = normal_two_body_bi_orth_old(l,k,j,i)
+
+          contrib = dabs(new - ref)
+          if(contrib .gt. thr) then
+            print*, ' problem on normal_two_body_bi_orth'
+            print*, l, k, j, i
+            print*, ref, new, contrib
+            stop
+          endif
+
+          accu += contrib
+          norm += dabs(ref)
+        enddo
+      enddo
+    enddo
+  enddo
+
+  print*, ' accu (%) = ', 100.d0*accu/norm
+
+  return
+end subroutine test_no
 
 ! ---
 
@@ -313,7 +373,7 @@ subroutine test_no_aba()
 
   implicit none
   integer          :: i, j, k, l
-  double precision :: accu, contrib, new, ref, thr
+  double precision :: accu, contrib, new, ref, thr, norm
 
   print*, ' testing no_aba_contraction ...'
 
@@ -323,6 +383,7 @@ subroutine test_no_aba()
   PROVIDE no_aba_contraction
 
   accu = 0.d0
+  norm = 0.d0
   do i = 1, mo_num
     do j = 1, mo_num
       do k = 1, mo_num
@@ -331,7 +392,6 @@ subroutine test_no_aba()
           new = no_aba_contraction   (l,k,j,i)
           ref = no_aba_contraction_v0(l,k,j,i)
           contrib = dabs(new - ref)
-          accu += contrib
           if(contrib .gt. thr) then
             print*, ' problem on no_aba_contraction'
             print*, l, k, j, i
@@ -339,11 +399,14 @@ subroutine test_no_aba()
             stop
           endif
 
+          accu += contrib
+          norm += dabs(ref)
         enddo
       enddo
     enddo
   enddo
-  print*, ' accu on no_aba_contraction = ', accu / dble(mo_num)**4
+
+  print*, ' accu (%) = ', 100.d0*accu/norm
 
   return
 end
@@ -355,7 +418,7 @@ subroutine test_no_aab()
 
   implicit none
   integer          :: i, j, k, l
-  double precision :: accu, contrib, new, ref, thr
+  double precision :: accu, contrib, new, ref, thr, norm
 
   print*, ' testing no_aab_contraction ...'
 
@@ -365,6 +428,7 @@ subroutine test_no_aab()
   PROVIDE no_aab_contraction
 
   accu = 0.d0
+  norm = 0.d0
   do i = 1, mo_num
     do j = 1, mo_num
       do k = 1, mo_num
@@ -373,7 +437,6 @@ subroutine test_no_aab()
           new = no_aab_contraction   (l,k,j,i)
           ref = no_aab_contraction_v0(l,k,j,i)
           contrib = dabs(new - ref)
-          accu += contrib
           if(contrib .gt. thr) then
             print*, ' problem on no_aab_contraction'
             print*, l, k, j, i
@@ -381,11 +444,14 @@ subroutine test_no_aab()
             stop
           endif
 
+          accu += contrib
+          norm += dabs(ref)
         enddo
       enddo
     enddo
   enddo
-  print*, ' accu on no_aab_contraction = ', accu / dble(mo_num)**4
+
+  print*, ' accu (%) = ', 100.d0*accu/norm
 
   return
 end
@@ -396,7 +462,7 @@ subroutine test_no_aaa()
 
   implicit none
   integer          :: i, j, k, l
-  double precision :: accu, contrib, new, ref, thr
+  double precision :: accu, contrib, new, ref, thr, norm
 
   print*, ' testing no_aaa_contraction ...'
 
@@ -406,6 +472,7 @@ subroutine test_no_aaa()
   PROVIDE no_aaa_contraction
 
   accu = 0.d0
+  norm = 0.d0
   do i = 1, mo_num
     do j = 1, mo_num
       do k = 1, mo_num
@@ -414,7 +481,6 @@ subroutine test_no_aaa()
           new = no_aaa_contraction   (l,k,j,i)
           ref = no_aaa_contraction_v0(l,k,j,i)
           contrib = dabs(new - ref)
-          accu += contrib
           if(contrib .gt. thr) then
             print*, ' problem on no_aaa_contraction'
             print*, l, k, j, i
@@ -422,13 +488,122 @@ subroutine test_no_aaa()
             stop
           endif
 
+          accu += contrib
+          norm += dabs(ref)
         enddo
       enddo
     enddo
   enddo
-  print*, ' accu on no_aaa_contraction = ', accu / dble(mo_num)**4
+
+  print*, ' accu (%) = ', 100.d0*accu/norm
 
   return
 end
 
 ! ---
+
+subroutine test_no_0()
+
+  implicit none
+  double precision :: accu, norm
+
+  print*, ' testing no_0 ...'
+
+  PROVIDE noL_0e_naive
+  PROVIDE noL_0e
+
+  accu = dabs(noL_0e_naive - noL_0e)
+  norm = dabs(noL_0e_naive)
+
+  print*, ' accu (%) = ', 100.d0*accu/norm
+
+  return
+end
+
+! ---
+
+subroutine test_no_1()
+
+  implicit none
+  integer          :: i, j
+  double precision :: accu, contrib, new, ref, thr, norm
+
+  print*, ' testing no_1 ...'
+
+  PROVIDE noL_1e_naive
+  PROVIDE noL_1e
+
+  thr = 1d-8
+
+  accu = 0.d0
+  norm = 0.d0
+  do i = 1, mo_num
+    do j = 1, mo_num
+
+      new = noL_1e      (j,i)
+      ref = noL_1e_naive(j,i)
+      contrib = dabs(new - ref)
+      if(contrib .gt. thr) then
+        print*, ' problem on no_aaa_contraction'
+        print*, j, i
+        print*, ref, new, contrib
+        stop
+      endif
+
+      accu += contrib
+      norm += dabs(ref)
+    enddo
+  enddo
+
+  print*, ' accu (%) = ', 100.d0*accu/norm
+
+  return
+end
+
+! ---
+
+subroutine test_no_2()
+
+  implicit none
+  integer          :: i, j, k, l
+  double precision :: accu, contrib, new, ref, thr, norm
+
+  print*, ' testing no_2 ...'
+
+  PROVIDE noL_2e_naive
+  PROVIDE noL_2e
+
+  thr = 1d-8
+
+  accu = 0.d0
+  norm = 0.d0
+  do i = 1, mo_num
+    do j = 1, mo_num
+      do k = 1, mo_num
+        do l = 1, mo_num
+
+          new = noL_2e      (l,k,j,i)
+          ref = noL_2e_naive(l,k,j,i)
+          contrib = dabs(new - ref)
+          if(contrib .gt. thr) then
+            print*, ' problem on no_aaa_contraction'
+            print*, l, k, j, i
+            print*, ref, new, contrib
+            stop
+          endif
+          
+          accu += contrib
+          norm += dabs(ref)
+        enddo
+      enddo
+    enddo
+  enddo
+
+  print*, ' accu (%) = ', 100.d0*accu/norm
+
+  return
+end
+
+! ---
+
+

src/tc_keywords/EZFIO.cfg

@@ -46,6 +46,12 @@ doc: If |true|, contracted double excitation three-body terms are included
 interface: ezfio,provider,ocaml
 default: False
 
+[noL_standard]
+type: logical
+doc: If |true|, standard normal-ordering for L
+interface: ezfio,provider,ocaml
+default: False
+
 [core_tc_op]
 type: logical
 doc: If |true|, takes the usual Hamiltonian for core orbitals (assumed to be doubly occupied)
@@ -110,13 +116,13 @@ default: False
 type: Threshold
 doc: Threshold on the convergence of the Hartree Fock energy.
 interface: ezfio,provider,ocaml
-default: 1.e-10
+default: 1.e-8
 
 [n_it_tcscf_max]
 type: Strictly_positive_int
 doc: Maximum number of SCF iterations
 interface: ezfio,provider,ocaml
-default: 100
+default: 50
 
 [selection_tc]
 type: integer
@@ -280,4 +286,15 @@ doc: size of radial grid over r1
 interface: ezfio,provider,ocaml
 default: 30
 
+[tc_grid2_a]
+type: integer
+doc: size of angular grid over r2
+interface: ezfio,provider,ocaml
+default: 194
+
+[tc_grid2_r]
+type: integer
+doc: size of radial grid over r2
+interface: ezfio,provider,ocaml
+default: 50
 

src/tc_scf/fock_3e_bi_ortho_cs.irp.f

@@ -0,0 +1,280 @@
+
+! ---
+
+BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
+
+  implicit none
+  integer                       :: a, b, i, j, ipoint
+  double precision              :: ti, tf
+  double precision              :: loc_1, loc_2, loc_3
+  double precision, allocatable :: Okappa(:), Jkappa(:,:)
+  double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
+  double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:)
+  double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
+
+  PROVIDE mo_l_coef mo_r_coef
+
+  !print *, ' PROVIDING fock_3e_uhf_mo_cs ...'
+  !call wall_time(ti)
+
+  ! ---
+
+  allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
+  Jkappa = 0.d0
+  Okappa = 0.d0
+
+  !$OMP PARALLEL                                                  &
+  !$OMP DEFAULT (NONE)                                            &
+  !$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2)               &
+  !$OMP SHARED (n_points_final_grid, elec_beta_num,               &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+  !$OMP         int2_grad1_u12_bimo_t, Okappa, Jkappa)
+
+  allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
+  tmp_omp_d2 = 0.d0
+  tmp_omp_d1 = 0.d0
+
+  !$OMP DO
+  do i = 1, elec_beta_num
+    do ipoint = 1, n_points_final_grid
+      tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
+      tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
+      tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
+      tmp_omp_d1(ipoint)   += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
+    enddo
+  enddo
+  !$OMP END DO NOWAIT
+
+  !$OMP CRITICAL
+  do ipoint = 1, n_points_final_grid
+    Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1) 
+    Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2) 
+    Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3) 
+    Okappa(ipoint)   += tmp_omp_d1(ipoint)   
+  enddo
+  !$OMP END CRITICAL
+
+  deallocate(tmp_omp_d2, tmp_omp_d1)
+
+  !$OMP END PARALLEL
+
+  ! ---
+
+  allocate(tmp_1(n_points_final_grid,4))
+
+  do ipoint = 1, n_points_final_grid
+
+    loc_1 = 2.d0 * Okappa(ipoint) 
+
+    tmp_1(ipoint,1) = loc_1 * Jkappa(ipoint,1)
+    tmp_1(ipoint,2) = loc_1 * Jkappa(ipoint,2)
+    tmp_1(ipoint,3) = loc_1 * Jkappa(ipoint,3)
+
+    tmp_1(ipoint,4) = Okappa(ipoint)
+  enddo
+
+
+  !$OMP PARALLEL                                                  &
+  !$OMP DEFAULT (NONE)                                            &
+  !$OMP PRIVATE (ipoint, i, j, loc_1, tmp_omp_d2)                 &
+  !$OMP SHARED (n_points_final_grid, elec_beta_num,               &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+  !$OMP         int2_grad1_u12_bimo_t, tmp_1)
+
+  allocate(tmp_omp_d2(n_points_final_grid,3))
+  tmp_omp_d2 = 0.d0
+
+  !$OMP DO COLLAPSE(2)
+  do i = 1, elec_beta_num
+    do j = 1, elec_beta_num
+      do ipoint = 1, n_points_final_grid
+
+        loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) 
+
+        tmp_omp_d2(ipoint,1) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j) 
+        tmp_omp_d2(ipoint,2) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j) 
+        tmp_omp_d2(ipoint,3) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j) 
+      enddo
+    enddo
+  enddo
+  !$OMP END DO NOWAIT
+
+  !$OMP CRITICAL
+  do ipoint = 1, n_points_final_grid
+    tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1) 
+    tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2) 
+    tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3) 
+  enddo
+  !$OMP END CRITICAL
+
+  deallocate(tmp_omp_d2)
+  !$OMP END PARALLEL
+
+  ! ---
+
+  allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
+
+  !$OMP PARALLEL                                                  &
+  !$OMP DEFAULT (NONE)                                            &
+  !$OMP PRIVATE (ipoint, a, b)                                    &
+  !$OMP SHARED (n_points_final_grid, mo_num,                      &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+  !$OMP         int2_grad1_u12_bimo_t, final_weight_at_r_vector,  &
+  !$OMP         tmp_2)
+  !$OMP DO COLLAPSE(2)
+  do a = 1, mo_num
+    do b = 1, mo_num
+      do ipoint = 1, n_points_final_grid
+        tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
+        tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
+        tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  !$OMP PARALLEL                                                 &
+  !$OMP DEFAULT (NONE)                                           &
+  !$OMP PRIVATE (ipoint, a, b, i)                                &
+  !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num,      &
+  !$OMP         final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+  !$OMP         tmp_2)
+  !$OMP DO COLLAPSE(2)
+  do a = 1, mo_num
+    do b = 1, mo_num
+      tmp_2(:,4,b,a) = 0.d0
+      do i = 1, elec_beta_num
+        do ipoint = 1, n_points_final_grid
+          tmp_2(ipoint,4,b,a) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+                                                                    + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+                                                                    + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  ! ---
+
+  call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, -2.d0 &
+            , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2)  &
+            , tmp_1(1,1), 1                                    &
+            , 0.d0, fock_3e_uhf_mo_cs(1,1), 1)
+
+  deallocate(tmp_1, tmp_2)
+
+  ! ---
+
+  allocate(tmp_3(n_points_final_grid,5,mo_num), tmp_4(n_points_final_grid,5,mo_num))
+
+  !$OMP PARALLEL                                                  &
+  !$OMP DEFAULT (NONE)                                            &
+  !$OMP PRIVATE (ipoint, b, loc_1, loc_2)                         &
+  !$OMP SHARED (n_points_final_grid, mo_num,                      &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+  !$OMP         final_weight_at_r_vector, Jkappa, tmp_3, tmp_4)
+  !$OMP DO
+  do b = 1, mo_num
+    tmp_3(:,:,b) = 0.d0
+    tmp_4(:,:,b) = 0.d0
+    do ipoint = 1, n_points_final_grid
+      tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
+
+      tmp_4(ipoint,1,b) = -2.d0 * mos_r_in_r_array_transp(ipoint,b) * ( Jkappa(ipoint,1) * Jkappa(ipoint,1) &
+                                                                      + Jkappa(ipoint,2) * Jkappa(ipoint,2) &
+                                                                      + Jkappa(ipoint,3) * Jkappa(ipoint,3) )
+      tmp_4(ipoint,5,b) = mos_r_in_r_array_transp(ipoint,b)
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  !$OMP PARALLEL                                                  &
+  !$OMP DEFAULT (NONE)                                            &
+  !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2)                      &
+  !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num,       &
+  !$OMP         final_weight_at_r_vector, int2_grad1_u12_bimo_t,  &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+  !$OMP         Jkappa, tmp_3, tmp_4)
+  !$OMP DO
+  do b = 1, mo_num
+    do i = 1, elec_beta_num
+      do ipoint = 1, n_points_final_grid
+
+        loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+        loc_2 = mos_r_in_r_array_transp(ipoint,i)
+
+        tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
+        tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
+        tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
+        tmp_3(ipoint,5,b) += 2.d0 * loc_1 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
+                                            + Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
+                                            + Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
+                                                                                                       
+        tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
+        tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
+        tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
+        tmp_4(ipoint,1,b) += 2.d0 * loc_2 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+                                            + Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+                                            + Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  !$OMP PARALLEL                                                  &
+  !$OMP DEFAULT (NONE)                                            &
+  !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3)            &
+  !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num,       &
+  !$OMP         final_weight_at_r_vector, int2_grad1_u12_bimo_t,  &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+  !$OMP         tmp_3, tmp_4)
+  !$OMP DO
+  do b = 1, mo_num
+    do i = 1, elec_beta_num
+      do j = 1, elec_beta_num
+        do ipoint = 1, n_points_final_grid
+
+          loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
+          loc_2 = mos_r_in_r_array_transp(ipoint,b)
+          loc_3 = mos_r_in_r_array_transp(ipoint,i)
+
+          tmp_3(ipoint,5,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
+                                       + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
+                                       + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
+
+          tmp_4(ipoint,1,b) += ( loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i)   &
+                                         + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i)   &
+                                         + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) ) &
+                               - loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b)   &
+                                         + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b)   &
+                                         + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) ) )
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  ! ---
+
+  call dgemm( 'T', 'N', mo_num, mo_num, 5*n_points_final_grid, 1.d0 &
+            , tmp_3(1,1,1), 5*n_points_final_grid                   &
+            , tmp_4(1,1,1), 5*n_points_final_grid                   &
+            , 1.d0, fock_3e_uhf_mo_cs(1,1), mo_num)
+
+  deallocate(tmp_3, tmp_4)
+  deallocate(Jkappa, Okappa)
+
+  ! ---
+
+  !call wall_time(tf)
+  !print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti
+
+END_PROVIDER 
+
+! ---
+

src/tc_scf/fock_3e_bi_ortho_os.irp.f

@@ -0,0 +1,536 @@
+
+! ---
+
+ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a_os, (mo_num, mo_num)]
+&BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b_os, (mo_num, mo_num)]
+
+  BEGIN_DOC
+  !
+  ! Open Shell part of the Fock matrix from three-electron terms 
+  !
+  ! WARNING :: non hermitian if bi-ortho MOS used 
+  !
+  END_DOC
+
+  implicit none
+  integer                       :: a, b, i, j, ipoint
+  double precision              :: loc_1, loc_2, loc_3, loc_4
+  double precision              :: ti, tf
+  double precision, allocatable :: Okappa(:), Jkappa(:,:), Obarkappa(:), Jbarkappa(:,:)
+  double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
+  double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:)
+  double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
+
+  PROVIDE mo_l_coef mo_r_coef
+
+  !print *, ' Providing fock_3e_uhf_mo_a_os and fock_3e_uhf_mo_b_os ...'
+  !call wall_time(ti)
+
+  ! ---
+
+  allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
+  allocate(Jbarkappa(n_points_final_grid,3), Obarkappa(n_points_final_grid))
+  Jkappa    = 0.d0
+  Okappa    = 0.d0
+  Jbarkappa = 0.d0
+  Obarkappa = 0.d0
+
+  !$OMP PARALLEL                                                    &
+  !$OMP DEFAULT (NONE)                                              &
+  !$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2)                 &
+  !$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp,   &
+  !$OMP         int2_grad1_u12_bimo_t, Okappa, Jkappa, Obarkappa, Jbarkappa)
+
+  allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
+
+  tmp_omp_d2 = 0.d0
+  tmp_omp_d1 = 0.d0
+  !$OMP DO
+  do i = 1, elec_beta_num
+    do ipoint = 1, n_points_final_grid
+      tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
+      tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
+      tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
+      tmp_omp_d1(ipoint)   += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
+    enddo
+  enddo
+  !$OMP END DO NOWAIT
+  !$OMP CRITICAL
+  do ipoint = 1, n_points_final_grid
+    Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1) 
+    Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2) 
+    Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3) 
+    Okappa(ipoint)   += tmp_omp_d1(ipoint)   
+  enddo
+  !$OMP END CRITICAL
+
+  tmp_omp_d2 = 0.d0
+  tmp_omp_d1 = 0.d0
+  !$OMP DO
+  do i = elec_beta_num+1, elec_alpha_num
+    do ipoint = 1, n_points_final_grid
+      tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
+      tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
+      tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
+      tmp_omp_d1(ipoint)   += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
+    enddo
+  enddo
+  !$OMP END DO NOWAIT
+  !$OMP CRITICAL
+  do ipoint = 1, n_points_final_grid
+    Jbarkappa(ipoint,1) += tmp_omp_d2(ipoint,1) 
+    Jbarkappa(ipoint,2) += tmp_omp_d2(ipoint,2) 
+    Jbarkappa(ipoint,3) += tmp_omp_d2(ipoint,3) 
+    Obarkappa(ipoint)   += tmp_omp_d1(ipoint)   
+  enddo
+  !$OMP END CRITICAL
+
+  deallocate(tmp_omp_d2, tmp_omp_d1)
+  !$OMP END PARALLEL
+
+  ! ---
+
+  allocate(tmp_1(n_points_final_grid,4))
+
+  do ipoint = 1, n_points_final_grid
+
+    loc_1 = -2.d0 * Okappa   (ipoint) 
+    loc_2 = -2.d0 * Obarkappa(ipoint) 
+    loc_3 =         Obarkappa(ipoint) 
+
+    tmp_1(ipoint,1) = (loc_1 - loc_3) * Jbarkappa(ipoint,1) + loc_2 * Jkappa(ipoint,1)
+    tmp_1(ipoint,2) = (loc_1 - loc_3) * Jbarkappa(ipoint,2) + loc_2 * Jkappa(ipoint,2)
+    tmp_1(ipoint,3) = (loc_1 - loc_3) * Jbarkappa(ipoint,3) + loc_2 * Jkappa(ipoint,3)
+
+    tmp_1(ipoint,4) = Obarkappa(ipoint)
+  enddo
+
+
+  !$OMP PARALLEL                                                    &
+  !$OMP DEFAULT (NONE)                                              &
+  !$OMP PRIVATE (ipoint, i, j, loc_1, loc_2, tmp_omp_d2)            &
+  !$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp,   &
+  !$OMP         int2_grad1_u12_bimo_t, tmp_1)
+
+  allocate(tmp_omp_d2(n_points_final_grid,3))
+
+  tmp_omp_d2 = 0.d0
+  !$OMP DO COLLAPSE(2)
+  do i = 1, elec_beta_num
+    do j = elec_beta_num+1, elec_alpha_num
+      do ipoint = 1, n_points_final_grid
+
+        loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) 
+        loc_2 = mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) 
+
+        tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,1,j,i) 
+        tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,2,j,i) 
+        tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,3,j,i) 
+      enddo
+    enddo
+  enddo
+  !$OMP END DO NOWAIT
+  !$OMP CRITICAL
+  do ipoint = 1, n_points_final_grid
+    tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1) 
+    tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2) 
+    tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3) 
+  enddo
+  !$OMP END CRITICAL
+
+  tmp_omp_d2 = 0.d0
+  !$OMP DO COLLAPSE(2)
+  do i = elec_beta_num+1, elec_alpha_num
+    do j = elec_beta_num+1, elec_alpha_num
+      do ipoint = 1, n_points_final_grid
+
+        loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) 
+
+        tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
+        tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
+        tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
+      enddo
+    enddo
+  enddo
+  !$OMP END DO NOWAIT
+  !$OMP CRITICAL
+  do ipoint = 1, n_points_final_grid
+    tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1) 
+    tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2) 
+    tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3) 
+  enddo
+  !$OMP END CRITICAL
+
+  deallocate(tmp_omp_d2)
+  !$OMP END PARALLEL
+
+  ! ---
+
+  allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
+
+  !$OMP PARALLEL                                                  &
+  !$OMP DEFAULT (NONE)                                            &
+  !$OMP PRIVATE (ipoint, a, b)                                    &
+  !$OMP SHARED (n_points_final_grid, mo_num,                      &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+  !$OMP         int2_grad1_u12_bimo_t, final_weight_at_r_vector,  &
+  !$OMP         tmp_2)
+  !$OMP DO COLLAPSE(2)
+  do a = 1, mo_num
+    do b = 1, mo_num
+      do ipoint = 1, n_points_final_grid
+        tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
+        tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
+        tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  !$OMP PARALLEL                                                            &
+  !$OMP DEFAULT (NONE)                                                      &
+  !$OMP PRIVATE (ipoint, a, b, i)                                           &
+  !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+  !$OMP         final_weight_at_r_vector, int2_grad1_u12_bimo_t,            &
+  !$OMP         tmp_2)
+  !$OMP DO COLLAPSE(2)
+  do a = 1, mo_num
+    do b = 1, mo_num
+
+      tmp_2(:,4,b,a) = 0.d0
+      do i = 1, elec_beta_num
+        do ipoint = 1, n_points_final_grid
+          tmp_2(ipoint,4,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+                                                                    + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+                                                                    + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  ! ---
+
+  call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, 1.d0 &
+            , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
+            , tmp_1(1,1), 1                                   &
+            , 0.d0, fock_3e_uhf_mo_b_os(1,1), 1)
+
+  deallocate(tmp_1, tmp_2)
+
+  ! ---
+
+  allocate(tmp_3(n_points_final_grid,2,mo_num), tmp_4(n_points_final_grid,2,mo_num))
+
+  !$OMP PARALLEL                                                  &
+  !$OMP DEFAULT (NONE)                                            &
+  !$OMP PRIVATE (ipoint, b, loc_1, loc_2)                         &
+  !$OMP SHARED (n_points_final_grid, mo_num,                      &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+  !$OMP         final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
+  !$OMP DO
+  do b = 1, mo_num
+    tmp_3(:,:,b) = 0.d0
+    tmp_4(:,:,b) = 0.d0
+    do ipoint = 1, n_points_final_grid
+
+      tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
+
+      loc_1 = -2.0d0 * mos_r_in_r_array_transp(ipoint,b)
+
+      tmp_4(ipoint,1,b) = loc_1 * ( Jbarkappa(ipoint,1) * (Jkappa(ipoint,1) + 0.25d0 * Jbarkappa(ipoint,1)) &
+                                  + Jbarkappa(ipoint,2) * (Jkappa(ipoint,2) + 0.25d0 * Jbarkappa(ipoint,2)) &
+                                  + Jbarkappa(ipoint,3) * (Jkappa(ipoint,3) + 0.25d0 * Jbarkappa(ipoint,3)) )
+
+      tmp_4(ipoint,2,b) = mos_r_in_r_array_transp(ipoint,b)
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  !$OMP PARALLEL                                                            &
+  !$OMP DEFAULT (NONE)                                                      &
+  !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4)                  &
+  !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+  !$OMP         final_weight_at_r_vector, int2_grad1_u12_bimo_t,            &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp,           &
+  !$OMP         Jkappa, Jbarkappa, tmp_3, tmp_4)
+  !$OMP DO
+  do b = 1, mo_num
+
+    do i = 1, elec_beta_num
+      do ipoint = 1, n_points_final_grid
+
+        loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+        loc_2 = mos_r_in_r_array_transp(ipoint,i)
+
+        tmp_3(ipoint,2,b) += loc_1 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
+                                     + Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
+                                     + Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
+                                                                                                       
+        tmp_4(ipoint,1,b) += loc_2 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+                                     + Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+                                     + Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  !$OMP PARALLEL                                                            &
+  !$OMP DEFAULT (NONE)                                                      &
+  !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3)                      &
+  !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+  !$OMP         final_weight_at_r_vector, int2_grad1_u12_bimo_t,            &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp,           &
+  !$OMP         tmp_3, tmp_4)
+  !$OMP DO
+  do b = 1, mo_num
+    do i = 1, elec_beta_num
+      do j = elec_beta_num+1, elec_alpha_num
+        do ipoint = 1, n_points_final_grid
+
+          loc_2 = mos_r_in_r_array_transp(ipoint,b)
+
+          tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+                                       + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+                                       + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
+        enddo
+      enddo
+    enddo
+
+    do i = elec_beta_num+1, elec_alpha_num
+      do j = elec_beta_num+1, elec_alpha_num
+        do ipoint = 1, n_points_final_grid
+
+          loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
+
+          tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+                                       + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+                                       + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  ! ---
+
+  call dgemm( 'T', 'N', mo_num, mo_num, 2*n_points_final_grid, 1.d0 &
+            , tmp_3(1,1,1), 2*n_points_final_grid                   &
+            , tmp_4(1,1,1), 2*n_points_final_grid                   &
+            , 1.d0, fock_3e_uhf_mo_b_os(1,1), mo_num)
+
+  deallocate(tmp_3, tmp_4)
+
+
+
+
+  ! ---
+
+  fock_3e_uhf_mo_a_os = fock_3e_uhf_mo_b_os
+
+  allocate(tmp_1(n_points_final_grid,1))
+
+  do ipoint = 1, n_points_final_grid
+    tmp_1(ipoint,1) = Obarkappa(ipoint) + 2.d0 * Okappa(ipoint) 
+  enddo
+
+  allocate(tmp_2(n_points_final_grid,1,mo_num,mo_num))
+
+  !$OMP PARALLEL                                                            &
+  !$OMP DEFAULT (NONE)                                                      &
+  !$OMP PRIVATE (ipoint, a, b, i)                                           &
+  !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+  !$OMP         final_weight_at_r_vector, int2_grad1_u12_bimo_t,            &
+  !$OMP         tmp_2)
+  !$OMP DO COLLAPSE(2)
+  do a = 1, mo_num
+    do b = 1, mo_num
+
+      tmp_2(:,1,b,a) = 0.d0
+      do i = elec_beta_num+1, elec_alpha_num
+        do ipoint = 1, n_points_final_grid
+          tmp_2(ipoint,1,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+                                                                    + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+                                                                    + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  call dgemv( 'T', n_points_final_grid, mo_num*mo_num, 1.d0   &
+            , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
+            , tmp_1(1,1), 1                                   &
+            , 1.d0, fock_3e_uhf_mo_a_os(1,1), 1)
+
+  deallocate(tmp_1, tmp_2)
+
+  ! ---
+
+  allocate(tmp_3(n_points_final_grid,8,mo_num), tmp_4(n_points_final_grid,8,mo_num))
+
+  !$OMP PARALLEL                                                  &
+  !$OMP DEFAULT (NONE)                                            &
+  !$OMP PRIVATE (ipoint, b)                                       &
+  !$OMP SHARED (n_points_final_grid, mo_num,                      &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+  !$OMP         final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
+  !$OMP DO
+  do b = 1, mo_num
+    tmp_3(:,:,b) = 0.d0
+    tmp_4(:,:,b) = 0.d0
+    do ipoint = 1, n_points_final_grid
+
+      tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
+
+      tmp_4(ipoint,8,b) = mos_r_in_r_array_transp(ipoint,b)
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  !$OMP PARALLEL                                                            &
+  !$OMP DEFAULT (NONE)                                                      &
+  !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4)                  &
+  !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+  !$OMP         final_weight_at_r_vector, int2_grad1_u12_bimo_t,            &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp,           &
+  !$OMP         Jkappa, Jbarkappa, tmp_3, tmp_4)
+  !$OMP DO
+  do b = 1, mo_num
+    do i = 1, elec_beta_num
+      do ipoint = 1, n_points_final_grid
+
+        loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+        loc_2 = mos_r_in_r_array_transp(ipoint,i)
+
+        tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
+        tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
+        tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
+
+        tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
+        tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
+        tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
+      enddo
+    enddo
+
+    do i = elec_beta_num+1, elec_alpha_num
+      do ipoint = 1, n_points_final_grid
+
+        loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+        loc_3 = 2.d0 * loc_1
+        loc_2 = mos_r_in_r_array_transp(ipoint,i)
+        loc_4 = 2.d0 * loc_2
+
+        tmp_3(ipoint,5,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
+        tmp_3(ipoint,6,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
+        tmp_3(ipoint,7,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
+
+        tmp_3(ipoint,8,b) += loc_3 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
+                                     + (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
+                                     + (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
+                                                                                                       
+        tmp_4(ipoint,1,b) += loc_4 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+                                     + (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+                                     + (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
+
+        tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
+        tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
+        tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
+
+        tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
+        tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
+        tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  !$OMP PARALLEL                                                            &
+  !$OMP DEFAULT (NONE)                                                      &
+  !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3)                      &
+  !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+  !$OMP         final_weight_at_r_vector, int2_grad1_u12_bimo_t,            &
+  !$OMP         mos_l_in_r_array_transp, mos_r_in_r_array_transp,           &
+  !$OMP         tmp_3, tmp_4)
+  !$OMP DO
+  do b = 1, mo_num
+
+    do i = 1, elec_beta_num
+      do j = elec_beta_num+1, elec_alpha_num
+        do ipoint = 1, n_points_final_grid
+
+          loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
+          loc_2 = mos_r_in_r_array_transp(ipoint,b)
+          loc_3 = mos_r_in_r_array_transp(ipoint,i)
+
+          tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
+                                       + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
+                                       + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
+
+          tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
+                                       + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
+                                       + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
+
+          loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+          loc_3 = mos_r_in_r_array_transp(ipoint,j)
+
+          tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+                                       + int2_grad1_u12_bimo_t(ipoint,2,b,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+                                       + int2_grad1_u12_bimo_t(ipoint,3,b,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
+
+          tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,j,i) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+                                       + int2_grad1_u12_bimo_t(ipoint,2,j,i) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+                                       + int2_grad1_u12_bimo_t(ipoint,3,j,i) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
+        enddo
+      enddo
+    enddo
+
+    do i = elec_beta_num+1, elec_alpha_num
+      do j = elec_beta_num+1, elec_alpha_num
+        do ipoint = 1, n_points_final_grid
+
+          loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
+          loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
+          loc_3 = mos_r_in_r_array_transp(ipoint,i)
+
+          tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
+                                       + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
+                                       + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
+
+          tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
+                                       + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
+                                       + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  ! ---
+
+  call dgemm( 'T', 'N', mo_num, mo_num, 8*n_points_final_grid, 1.d0 &
+            , tmp_3(1,1,1), 8*n_points_final_grid                   &
+            , tmp_4(1,1,1), 8*n_points_final_grid                   &
+            , 1.d0, fock_3e_uhf_mo_a_os(1,1), mo_num)
+
+  deallocate(tmp_3, tmp_4)
+  deallocate(Jkappa, Okappa)
+
+  !call wall_time(tf)
+  !print *, ' Wall time for fock_3e_uhf_mo_a_os and fock_3e_uhf_mo_b_os =', tf - ti
+
+END_PROVIDER 
+
+! ---
+

src/tc_scf/fock_3e_bi_ortho_uhf.irp.f

@@ -1,194 +1,35 @@
 
 ! ---
 
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
-
-  implicit none
-  integer                       :: a, b, i, j
-  double precision              :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
-  double precision              :: ti, tf
-  double precision, allocatable :: tmp(:,:)
-
-  PROVIDE mo_l_coef mo_r_coef
-  call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
-
-  !print *, ' PROVIDING fock_3e_uhf_mo_cs ...'
-  !call wall_time(ti)
-
-  fock_3e_uhf_mo_cs = 0.d0
-
-  !$OMP PARALLEL DEFAULT (NONE)                                                                     &
-  !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
-  !$OMP SHARED  (mo_num, elec_beta_num, fock_3e_uhf_mo_cs)
-
-  allocate(tmp(mo_num,mo_num))
-  tmp = 0.d0
-
-  !$OMP DO
-  do a = 1, mo_num
-    do b = 1, mo_num
-   
-      do j = 1, elec_beta_num
-        do i = 1, elec_beta_num
-
-          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
-          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
-          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
-          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
-          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
-          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
-          tmp(b,a) -= 0.5d0 * ( 4.d0 * I_bij_aij &
-                              +        I_bij_ija &
-                              +        I_bij_jai &
-                              - 2.d0 * I_bij_aji &
-                              - 2.d0 * I_bij_iaj &
-                              - 2.d0 * I_bij_jia )
-
-        enddo
-      enddo
-    enddo
-  enddo
-  !$OMP END DO NOWAIT
-
-  !$OMP CRITICAL
-  do a = 1, mo_num
-    do b = 1, mo_num
-      fock_3e_uhf_mo_cs(b,a) += tmp(b,a)
-    enddo
-  enddo
-  !$OMP END CRITICAL
-
-  deallocate(tmp)
-  !$OMP END PARALLEL
-
-  !call wall_time(tf)
-  !print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti
-
-END_PROVIDER 
-
-! ---
-
 BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
 
   BEGIN_DOC
   !
-  ! ALPHA part of the Fock matrix from three-electron terms 
+  ! Fock matrix alpha from three-electron terms 
   !
   ! WARNING :: non hermitian if bi-ortho MOS used 
   !
   END_DOC
 
   implicit none
-  integer                       :: a, b, i, j, o
-  double precision              :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
   double precision :: ti, tf
-  double precision, allocatable :: tmp(:,:)
 
   PROVIDE mo_l_coef mo_r_coef
-  PROVIDE fock_3e_uhf_mo_cs
 
   !print *, ' Providing fock_3e_uhf_mo_a ...'
   !call wall_time(ti)
 
-  o = elec_beta_num + 1
+  ! CLOSED-SHELL PART
-  call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
+  PROVIDE fock_3e_uhf_mo_cs
-
   fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs
 
-  !$OMP PARALLEL DEFAULT (NONE)                                                                     &
+  if(elec_alpha_num .ne. elec_beta_num) then
-  !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
-  !$OMP SHARED  (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_a)
 
-  allocate(tmp(mo_num,mo_num))
+    ! OPEN-SHELL PART
-  tmp = 0.d0
+    PROVIDE fock_3e_uhf_mo_a_os
 
-  !$OMP DO
+    fock_3e_uhf_mo_a += fock_3e_uhf_mo_a_os
-  do a = 1, mo_num
+  endif
-    do b = 1, mo_num
-
-      ! ---
-
-      do j = o, elec_alpha_num
-        do i = 1, elec_beta_num
-
-          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
-          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
-          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
-          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
-          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
-          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
-          tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
-                              +        I_bij_ija &
-                              +        I_bij_jai &
-                              -        I_bij_aji &
-                              -        I_bij_iaj &
-                              - 2.d0 * I_bij_jia )
-
-        enddo
-      enddo
-
-      ! ---
-
-      do j = 1, elec_beta_num
-        do i = o, elec_alpha_num
-
-          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
-          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
-          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
-          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
-          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
-          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
-          tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
-                              +        I_bij_ija &
-                              +        I_bij_jai &
-                              -        I_bij_aji &
-                              - 2.d0 * I_bij_iaj &
-                              -        I_bij_jia )
-
-        enddo
-      enddo
-
-      ! ---
-
-      do j = o, elec_alpha_num
-        do i = o, elec_alpha_num
-
-          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
-          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
-          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
-          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
-          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
-          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
-          tmp(b,a) -= 0.5d0 * ( I_bij_aij &
-                              + I_bij_ija &
-                              + I_bij_jai &
-                              - I_bij_aji &
-                              - I_bij_iaj &
-                              - I_bij_jia )
-
-        enddo
-      enddo
-
-      ! ---
-
-    enddo
-  enddo
-  !$OMP END DO NOWAIT
-
-  !$OMP CRITICAL
-  do a = 1, mo_num
-    do b = 1, mo_num
-      fock_3e_uhf_mo_a(b,a) += tmp(b,a)
-    enddo
-  enddo
-  !$OMP END CRITICAL
-
-  deallocate(tmp)
-  !$OMP END PARALLEL
 
   !call wall_time(tf)
   !print *, ' Wall time for fock_3e_uhf_mo_a =', tf - ti
@@ -200,285 +41,35 @@ END_PROVIDER
 BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
 
   BEGIN_DOC
-  ! BETA part of the Fock matrix from three-electron terms 
+  !
+  ! Fock matrix beta from three-electron terms 
   !
   ! WARNING :: non hermitian if bi-ortho MOS used 
+  !
   END_DOC
 
   implicit none
-  integer                       :: a, b, i, j, o
-  double precision              :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
   double precision :: ti, tf
-  double precision, allocatable :: tmp(:,:)
 
   PROVIDE mo_l_coef mo_r_coef
 
-  !print *, ' PROVIDING fock_3e_uhf_mo_b ...'
+  !print *, ' Providing and fock_3e_uhf_mo_b ...'
   !call wall_time(ti)
 
-  o = elec_beta_num + 1
+  ! CLOSED-SHELL PART
-  call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
+  PROVIDE fock_3e_uhf_mo_cs
-
   fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs
 
-  !$OMP PARALLEL DEFAULT (NONE)                                                                     &
+  if(elec_alpha_num .ne. elec_beta_num) then
-  !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
-  !$OMP SHARED  (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_b)
 
-  allocate(tmp(mo_num,mo_num))
+    ! OPEN-SHELL PART
-  tmp = 0.d0
+    PROVIDE fock_3e_uhf_mo_b_os
 
-  !$OMP DO
+    fock_3e_uhf_mo_b += fock_3e_uhf_mo_b_os
-  do a = 1, mo_num
+  endif
-    do b = 1, mo_num
-
-      ! ---
-
-      do j = o, elec_alpha_num
-        do i = 1, elec_beta_num
-
-          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
-          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
-          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
-          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
-          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
-          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
-          tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
-                              -        I_bij_aji &
-                              -        I_bij_iaj )
-
-        enddo
-      enddo
-
-      ! ---
-
-      do j = 1, elec_beta_num
-        do i = o, elec_alpha_num
-
-          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
-          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
-          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
-          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
-          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
-          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
-          tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
-                              -        I_bij_aji &
-                              -        I_bij_jia )
-
-        enddo
-      enddo
-
-      ! ---
-
-      do j = o, elec_alpha_num
-        do i = o, elec_alpha_num
-
-          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
-          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
-          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
-          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
-          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
-          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
-          tmp(b,a) -= 0.5d0 * ( I_bij_aij &
-                              - I_bij_aji )
-
-        enddo
-      enddo
-
-      ! ---
-
-    enddo
-  enddo
-  !$OMP END DO NOWAIT
-
-  !$OMP CRITICAL
-  do a = 1, mo_num
-    do b = 1, mo_num
-      fock_3e_uhf_mo_b(b,a) += tmp(b,a)
-    enddo
-  enddo
-  !$OMP END CRITICAL
-
-  deallocate(tmp)
-  !$OMP END PARALLEL
 
   !call wall_time(tf)
-  !print *, ' total Wall time for fock_3e_uhf_mo_b =', tf - ti
+  !print *, ' Wall time for fock_3e_uhf_mo_b =', tf - ti
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)]
-
-  BEGIN_DOC
-  !
-  ! Equations (B6) and (B7)
-  !
-  ! g <--> gamma
-  ! d <--> delta
-  ! e <--> eta
-  ! k <--> kappa
-  !
-  END_DOC
-
-  implicit none
-  integer                       :: g, d, e, k, mu, nu
-  double precision              :: dm_ge_a, dm_ge_b, dm_ge
-  double precision              :: dm_dk_a, dm_dk_b, dm_dk
-  double precision              :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
-  double precision              :: ti, tf
-  double precision, allocatable :: f_tmp(:,:)
-
-  print *, ' PROVIDING fock_3e_uhf_ao_a ...'
-  call wall_time(ti)
-
-  fock_3e_uhf_ao_a = 0.d0
-
-  !$OMP PARALLEL DEFAULT (NONE)                                                                &
-  !$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp,  &
-  !$OMP          i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
-  !$OMP SHARED  (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_a)
-
-  allocate(f_tmp(ao_num,ao_num))
-  f_tmp = 0.d0
-
-  !$OMP DO
-  do g = 1, ao_num
-    do e = 1, ao_num
-      dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
-      dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
-      dm_ge   = dm_ge_a + dm_ge_b
-      do d = 1, ao_num
-        do k = 1, ao_num
-          dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
-          dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
-          dm_dk   = dm_dk_a + dm_dk_b
-          do mu = 1, ao_num
-            do nu = 1, ao_num
-              call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
-              call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
-              call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
-              call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
-              call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
-              call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
-              f_tmp(mu,nu) -= 0.5d0 * ( dm_ge   * dm_dk   * i_mugd_nuek &
-                                      + dm_ge_a * dm_dk_a * i_mugd_eknu &
-                                      + dm_ge_a * dm_dk_a * i_mugd_knue &
-                                      - dm_ge_a * dm_dk   * i_mugd_enuk &
-                                      - dm_ge   * dm_dk_a * i_mugd_kenu &
-                                      - dm_ge_a * dm_dk_a * i_mugd_nuke &
-                                      - dm_ge_b * dm_dk_b * i_mugd_nuke )
-            enddo
-          enddo
-        enddo
-      enddo
-    enddo
-  enddo
-  !$OMP END DO NOWAIT
-
-  !$OMP CRITICAL
-  do mu = 1, ao_num
-    do nu = 1, ao_num
-      fock_3e_uhf_ao_a(mu,nu) += f_tmp(mu,nu)
-    enddo
-  enddo
-  !$OMP END CRITICAL
-
-  deallocate(f_tmp)
-  !$OMP END PARALLEL
-
-  call wall_time(tf)
-  print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)]
-
-  BEGIN_DOC
-  !
-  ! Equations (B6) and (B7)
-  !
-  ! g <--> gamma
-  ! d <--> delta
-  ! e <--> eta
-  ! k <--> kappa
-  !
-  END_DOC
-
-  implicit none
-  integer                       :: g, d, e, k, mu, nu
-  double precision              :: dm_ge_a, dm_ge_b, dm_ge
-  double precision              :: dm_dk_a, dm_dk_b, dm_dk
-  double precision              :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
-  double precision              :: ti, tf
-  double precision, allocatable :: f_tmp(:,:)
-
-  print *, ' PROVIDING fock_3e_uhf_ao_b ...'
-  call wall_time(ti)
-
-  fock_3e_uhf_ao_b = 0.d0
-
-  !$OMP PARALLEL DEFAULT (NONE)                                                                &
-  !$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp,  &
-  !$OMP          i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
-  !$OMP SHARED  (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_b)
-
-  allocate(f_tmp(ao_num,ao_num))
-  f_tmp = 0.d0
-
-  !$OMP DO
-  do g = 1, ao_num
-    do e = 1, ao_num
-      dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
-      dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
-      dm_ge   = dm_ge_a + dm_ge_b
-      do d = 1, ao_num
-        do k = 1, ao_num
-          dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
-          dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
-          dm_dk   = dm_dk_a + dm_dk_b
-          do mu = 1, ao_num
-            do nu = 1, ao_num
-              call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
-              call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
-              call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
-              call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
-              call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
-              call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
-              f_tmp(mu,nu) -= 0.5d0 * ( dm_ge   * dm_dk   * i_mugd_nuek &
-                                      + dm_ge_b * dm_dk_b * i_mugd_eknu &
-                                      + dm_ge_b * dm_dk_b * i_mugd_knue &
-                                      - dm_ge_b * dm_dk   * i_mugd_enuk &
-                                      - dm_ge   * dm_dk_b * i_mugd_kenu &
-                                      - dm_ge_b * dm_dk_b * i_mugd_nuke &
-                                      - dm_ge_a * dm_dk_a * i_mugd_nuke )
-            enddo
-          enddo
-        enddo
-      enddo
-    enddo
-  enddo
-  !$OMP END DO NOWAIT
-
-  !$OMP CRITICAL
-  do mu = 1, ao_num
-    do nu = 1, ao_num
-      fock_3e_uhf_ao_b(mu,nu) += f_tmp(mu,nu)
-    enddo
-  enddo
-  !$OMP END CRITICAL
-
-  deallocate(f_tmp)
-  !$OMP END PARALLEL
-
-  call wall_time(tf)
-  print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti
 
 END_PROVIDER 
 

src/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f

@@ -0,0 +1,490 @@
+
+! ---
+
+BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs_old, (mo_num, mo_num)]
+
+  implicit none
+  integer                       :: a, b, i, j
+  double precision              :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
+  double precision              :: ti, tf
+  double precision, allocatable :: tmp(:,:)
+
+  PROVIDE mo_l_coef mo_r_coef
+  call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
+
+  !print *, ' PROVIDING fock_3e_uhf_mo_cs_old ...'
+  !call wall_time(ti)
+
+  fock_3e_uhf_mo_cs_old = 0.d0
+
+  !$OMP PARALLEL DEFAULT (NONE)                                                                     &
+  !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
+  !$OMP SHARED  (mo_num, elec_beta_num, fock_3e_uhf_mo_cs_old)
+
+  allocate(tmp(mo_num,mo_num))
+  tmp = 0.d0
+
+  !$OMP DO
+  do a = 1, mo_num
+    do b = 1, mo_num
+   
+      do j = 1, elec_beta_num
+        do i = 1, elec_beta_num
+
+          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
+          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
+          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
+          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
+          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
+          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
+
+          tmp(b,a) -= 0.5d0 * ( 4.d0 * I_bij_aij &
+                              +        I_bij_ija &
+                              +        I_bij_jai &
+                              - 2.d0 * I_bij_aji &
+                              - 2.d0 * I_bij_iaj &
+                              - 2.d0 * I_bij_jia )
+
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END DO NOWAIT
+
+  !$OMP CRITICAL
+  do a = 1, mo_num
+    do b = 1, mo_num
+      fock_3e_uhf_mo_cs_old(b,a) += tmp(b,a)
+    enddo
+  enddo
+  !$OMP END CRITICAL
+
+  deallocate(tmp)
+  !$OMP END PARALLEL
+
+  !call wall_time(tf)
+  !print *, ' total Wall time for fock_3e_uhf_mo_cs_old =', tf - ti
+
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a_old, (mo_num, mo_num)]
+
+  BEGIN_DOC
+  !
+  ! ALPHA part of the Fock matrix from three-electron terms 
+  !
+  ! WARNING :: non hermitian if bi-ortho MOS used 
+  !
+  END_DOC
+
+  implicit none
+  integer                       :: a, b, i, j, o
+  double precision              :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
+  double precision              :: ti, tf
+  double precision, allocatable :: tmp(:,:)
+
+  PROVIDE mo_l_coef mo_r_coef
+  PROVIDE fock_3e_uhf_mo_cs
+
+  !print *, ' Providing fock_3e_uhf_mo_a_old ...'
+  !call wall_time(ti)
+
+  o = elec_beta_num + 1
+  call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
+
+  PROVIDE fock_3e_uhf_mo_cs_old
+  fock_3e_uhf_mo_a_old = fock_3e_uhf_mo_cs_old
+
+  !$OMP PARALLEL DEFAULT (NONE)                                                                     &
+  !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
+  !$OMP SHARED  (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_a_old)
+
+  allocate(tmp(mo_num,mo_num))
+  tmp = 0.d0
+
+  !$OMP DO
+  do a = 1, mo_num
+    do b = 1, mo_num
+
+      ! ---
+
+      do j = o, elec_alpha_num
+        do i = 1, elec_beta_num
+
+          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
+          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
+          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
+          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
+          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
+          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
+
+          tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
+                              +        I_bij_ija &
+                              +        I_bij_jai &
+                              -        I_bij_aji &
+                              -        I_bij_iaj &
+                              - 2.d0 * I_bij_jia )
+
+        enddo
+      enddo
+
+      ! ---
+
+      do j = 1, elec_beta_num
+        do i = o, elec_alpha_num
+
+          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
+          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
+          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
+          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
+          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
+          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
+
+          tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
+                              +        I_bij_ija &
+                              +        I_bij_jai &
+                              -        I_bij_aji &
+                              - 2.d0 * I_bij_iaj &
+                              -        I_bij_jia )
+
+        enddo
+      enddo
+
+      ! ---
+
+      do j = o, elec_alpha_num
+        do i = o, elec_alpha_num
+
+          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
+          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
+          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
+          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
+          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
+          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
+
+          tmp(b,a) -= 0.5d0 * ( I_bij_aij &
+                              + I_bij_ija &
+                              + I_bij_jai &
+                              - I_bij_aji &
+                              - I_bij_iaj &
+                              - I_bij_jia )
+
+        enddo
+      enddo
+
+      ! ---
+
+    enddo
+  enddo
+  !$OMP END DO NOWAIT
+
+  !$OMP CRITICAL
+  do a = 1, mo_num
+    do b = 1, mo_num
+      fock_3e_uhf_mo_a_old(b,a) += tmp(b,a)
+    enddo
+  enddo
+  !$OMP END CRITICAL
+
+  deallocate(tmp)
+  !$OMP END PARALLEL
+
+  !call wall_time(tf)
+  !print *, ' Wall time for fock_3e_uhf_mo_a_old =', tf - ti
+
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b_old, (mo_num, mo_num)]
+
+  BEGIN_DOC
+  !
+  ! BETA part of the Fock matrix from three-electron terms 
+  !
+  ! WARNING :: non hermitian if bi-ortho MOS used 
+  !
+  END_DOC
+
+  implicit none
+  integer                       :: a, b, i, j, o
+  double precision              :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
+  double precision              :: ti, tf
+  double precision, allocatable :: tmp(:,:)
+
+  PROVIDE mo_l_coef mo_r_coef
+
+  !print *, ' PROVIDING fock_3e_uhf_mo_b_old ...'
+  !call wall_time(ti)
+
+  o = elec_beta_num + 1
+  call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
+
+  PROVIDE fock_3e_uhf_mo_cs_old
+  fock_3e_uhf_mo_b_old = fock_3e_uhf_mo_cs_old
+
+  !$OMP PARALLEL DEFAULT (NONE)                                                                     &
+  !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
+  !$OMP SHARED  (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_b_old)
+
+  allocate(tmp(mo_num,mo_num))
+  tmp = 0.d0
+
+  !$OMP DO
+  do a = 1, mo_num
+    do b = 1, mo_num
+
+      ! ---
+
+      do j = o, elec_alpha_num
+        do i = 1, elec_beta_num
+
+          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
+          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
+          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
+          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
+          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
+          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
+
+          tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
+                              -        I_bij_aji &
+                              -        I_bij_iaj )
+
+        enddo
+      enddo
+
+      ! ---
+
+      do j = 1, elec_beta_num
+        do i = o, elec_alpha_num
+
+          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
+          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
+          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
+          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
+          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
+          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
+
+          tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
+                              -        I_bij_aji &
+                              -        I_bij_jia )
+
+        enddo
+      enddo
+
+      ! ---
+
+      do j = o, elec_alpha_num
+        do i = o, elec_alpha_num
+
+          call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
+          call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
+          call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
+          call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
+          call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
+          call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
+
+          tmp(b,a) -= 0.5d0 * ( I_bij_aij &
+                              - I_bij_aji )
+
+        enddo
+      enddo
+
+      ! ---
+
+    enddo
+  enddo
+  !$OMP END DO NOWAIT
+
+  !$OMP CRITICAL
+  do a = 1, mo_num
+    do b = 1, mo_num
+      fock_3e_uhf_mo_b_old(b,a) += tmp(b,a)
+    enddo
+  enddo
+  !$OMP END CRITICAL
+
+  deallocate(tmp)
+  !$OMP END PARALLEL
+
+  !call wall_time(tf)
+  !print *, ' total Wall time for fock_3e_uhf_mo_b_old =', tf - ti
+
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)]
+
+  BEGIN_DOC
+  !
+  ! Equations (B6) and (B7)
+  !
+  ! g <--> gamma
+  ! d <--> delta
+  ! e <--> eta
+  ! k <--> kappa
+  !
+  END_DOC
+
+  implicit none
+  integer                       :: g, d, e, k, mu, nu
+  double precision              :: dm_ge_a, dm_ge_b, dm_ge
+  double precision              :: dm_dk_a, dm_dk_b, dm_dk
+  double precision              :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
+  double precision              :: ti, tf
+  double precision, allocatable :: f_tmp(:,:)
+
+  !print *, ' PROVIDING fock_3e_uhf_ao_a ...'
+  !call wall_time(ti)
+
+  fock_3e_uhf_ao_a = 0.d0
+
+  !$OMP PARALLEL DEFAULT (NONE)                                                                &
+  !$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp,  &
+  !$OMP          i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
+  !$OMP SHARED  (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_a)
+
+  allocate(f_tmp(ao_num,ao_num))
+  f_tmp = 0.d0
+
+  !$OMP DO
+  do g = 1, ao_num
+    do e = 1, ao_num
+      dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
+      dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
+      dm_ge   = dm_ge_a + dm_ge_b
+      do d = 1, ao_num
+        do k = 1, ao_num
+          dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
+          dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
+          dm_dk   = dm_dk_a + dm_dk_b
+          do mu = 1, ao_num
+            do nu = 1, ao_num
+              call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
+              call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
+              call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
+              call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
+              call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
+              call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
+              f_tmp(mu,nu) -= 0.5d0 * ( dm_ge   * dm_dk   * i_mugd_nuek &
+                                      + dm_ge_a * dm_dk_a * i_mugd_eknu &
+                                      + dm_ge_a * dm_dk_a * i_mugd_knue &
+                                      - dm_ge_a * dm_dk   * i_mugd_enuk &
+                                      - dm_ge   * dm_dk_a * i_mugd_kenu &
+                                      - dm_ge_a * dm_dk_a * i_mugd_nuke &
+                                      - dm_ge_b * dm_dk_b * i_mugd_nuke )
+            enddo
+          enddo
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END DO NOWAIT
+
+  !$OMP CRITICAL
+  do mu = 1, ao_num
+    do nu = 1, ao_num
+      fock_3e_uhf_ao_a(mu,nu) += f_tmp(mu,nu)
+    enddo
+  enddo
+  !$OMP END CRITICAL
+
+  deallocate(f_tmp)
+  !$OMP END PARALLEL
+
+  !call wall_time(tf)
+  !print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti
+
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)]
+
+  BEGIN_DOC
+  !
+  ! Equations (B6) and (B7)
+  !
+  ! g <--> gamma
+  ! d <--> delta
+  ! e <--> eta
+  ! k <--> kappa
+  !
+  END_DOC
+
+  implicit none
+  integer                       :: g, d, e, k, mu, nu
+  double precision              :: dm_ge_a, dm_ge_b, dm_ge
+  double precision              :: dm_dk_a, dm_dk_b, dm_dk
+  double precision              :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
+  double precision              :: ti, tf
+  double precision, allocatable :: f_tmp(:,:)
+
+  !print *, ' PROVIDING fock_3e_uhf_ao_b ...'
+  !call wall_time(ti)
+
+  fock_3e_uhf_ao_b = 0.d0
+
+  !$OMP PARALLEL DEFAULT (NONE)                                                                &
+  !$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp,  &
+  !$OMP          i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
+  !$OMP SHARED  (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_b)
+
+  allocate(f_tmp(ao_num,ao_num))
+  f_tmp = 0.d0
+
+  !$OMP DO
+  do g = 1, ao_num
+    do e = 1, ao_num
+      dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
+      dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
+      dm_ge   = dm_ge_a + dm_ge_b
+      do d = 1, ao_num
+        do k = 1, ao_num
+          dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
+          dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
+          dm_dk   = dm_dk_a + dm_dk_b
+          do mu = 1, ao_num
+            do nu = 1, ao_num
+              call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
+              call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
+              call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
+              call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
+              call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
+              call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
+              f_tmp(mu,nu) -= 0.5d0 * ( dm_ge   * dm_dk   * i_mugd_nuek &
+                                      + dm_ge_b * dm_dk_b * i_mugd_eknu &
+                                      + dm_ge_b * dm_dk_b * i_mugd_knue &
+                                      - dm_ge_b * dm_dk   * i_mugd_enuk &
+                                      - dm_ge   * dm_dk_b * i_mugd_kenu &
+                                      - dm_ge_b * dm_dk_b * i_mugd_nuke &
+                                      - dm_ge_a * dm_dk_a * i_mugd_nuke )
+            enddo
+          enddo
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END DO NOWAIT
+
+  !$OMP CRITICAL
+  do mu = 1, ao_num
+    do nu = 1, ao_num
+      fock_3e_uhf_ao_b(mu,nu) += f_tmp(mu,nu)
+    enddo
+  enddo
+  !$OMP END CRITICAL
+
+  deallocate(f_tmp)
+  !$OMP END PARALLEL
+
+  !call wall_time(tf)
+  !print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti
+
+END_PROVIDER 
+
+! ---
+

src/tc_scf/fock_tc.irp.f

@@ -190,30 +190,14 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ]
 
   if(bi_ortho) then
 
-    !allocate(tmp(ao_num,ao_num))
-    !tmp = Fock_matrix_tc_ao_alpha
-    !if(three_body_h_tc) then
-    !  tmp += fock_3e_uhf_ao_a
-    !endif
-    !call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1))
-    !deallocate(tmp)
-
     PROVIDE mo_l_coef mo_r_coef
 
-    !call wall_time(tt0)
     call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
                           , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
-    !call wall_time(tt1)
-    !print*, ' 2-e term:', tt1-tt0
 
     if(three_body_h_tc) then
-      !call wall_time(tt0)
+      PROVIDE fock_3e_uhf_mo_a
-      PROVIDE fock_a_tot_3e_bi_orth
+      Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a
-      Fock_matrix_tc_mo_alpha += fock_a_tot_3e_bi_orth
-!      PROVIDE fock_3e_uhf_mo_a
-!      Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a
-      !call wall_time(tt1)
-      !print*, ' 3-e term:', tt1-tt0
     endif
 
   else
@@ -243,11 +227,10 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ]
 
     call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
                           , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
+
     if(three_body_h_tc) then
-       PROVIDE fock_b_tot_3e_bi_orth
+      PROVIDE fock_3e_uhf_mo_b
-       Fock_matrix_tc_mo_beta += fock_b_tot_3e_bi_orth
+      Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b
-!      PROVIDE fock_3e_uhf_mo_b
-!      Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b
     endif
 
   else

src/tc_scf/tc_scf.irp.f

@@ -13,19 +13,32 @@ program tc_scf
   print *, ' starting ...'
 
   my_grid_becke  = .True.
-
   PROVIDE tc_grid1_a tc_grid1_r
   my_n_pt_r_grid = tc_grid1_r
   my_n_pt_a_grid = tc_grid1_a
-
   touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
 
+  call write_int(6, my_n_pt_r_grid, 'radial  external grid over')
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+
   PROVIDE mu_erf 
   print *, ' mu = ', mu_erf
   PROVIDE j1b_type
   print *, ' j1b_type = ', j1b_type
   print *, j1b_pen
 
+  if(j1b_type .ge. 100) then
+    my_extra_grid_becke  = .True.
+    PROVIDE tc_grid2_a tc_grid2_r
+    my_n_pt_r_extra_grid = tc_grid2_r
+    my_n_pt_a_extra_grid = tc_grid2_a
+    touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
+
+    call write_int(6, my_n_pt_r_extra_grid, 'radial  internal grid over')
+    call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
+  endif
+
   !call create_guess()
   !call orthonormalize_mos()
 

src/tc_scf/tc_scf_dm.irp.f

@@ -3,16 +3,24 @@
 BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num)]
 
   BEGIN_DOC
+  !
   ! TC-SCF transition density matrix on the AO basis for BETA electrons 
+  !
   END_DOC
+
   implicit none
 
   if(bi_ortho) then
+
     PROVIDE mo_l_coef mo_r_coef
     TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta
+
   else
+
     TCSCF_density_matrix_ao_beta = SCF_density_matrix_ao_beta
+
   endif
+
 END_PROVIDER 
 
 ! ---
@@ -20,27 +28,41 @@ END_PROVIDER
 BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num)]
 
   BEGIN_DOC
+  !
   ! TC-SCF transition density matrix on the AO basis for ALPHA electrons 
+  !
   END_DOC
+
   implicit none
 
   if(bi_ortho) then
+
     PROVIDE mo_l_coef mo_r_coef
     TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha
+
   else
+
     TCSCF_density_matrix_ao_alpha = SCF_density_matrix_ao_alpha
+
   endif
+
 END_PROVIDER 
 
 
 ! ---
 
 BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_tot, (ao_num, ao_num)]
-  implicit none
+
   BEGIN_DOC
+  !
   ! TC-SCF transition density matrix on the AO basis for ALPHA+BETA electrons 
+  !
   END_DOC
+
+  implicit none
+
   TCSCF_density_matrix_ao_tot = TCSCF_density_matrix_ao_beta + TCSCF_density_matrix_ao_alpha
+
 END_PROVIDER 
 
 

src/tc_scf/test_int.irp.f

@@ -54,7 +54,12 @@ program test_ints
 !!PROVIDE TC_HF_energy VARTC_HF_energy
 !!print *, '    TC_HF_energy = ',    TC_HF_energy
 !!print *, ' VARTC_HF_energy = ', VARTC_HF_energy
- call test_old_ints
+! call test_old_ints
+
+  call test_fock_3e_uhf_mo_cs()
+  call test_fock_3e_uhf_mo_a()
+  call test_fock_3e_uhf_mo_b()
+
 end
 
 ! ---
@@ -1096,3 +1101,130 @@ subroutine test_int2_grad1_u12_ao_test
  print*,'accu_abs   = ',accu_abs/dble(ao_num)**4
  print*,'accu_relat = ',accu_relat/dble(ao_num)**4
 end
+
+! ---
+
+subroutine test_fock_3e_uhf_mo_cs()
+
+  implicit none
+  integer          :: i, j
+  double precision :: I_old, I_new
+  double precision :: diff_tot, diff, thr_ih, norm
+
+!  double precision :: t0, t1
+!  print*, ' Providing fock_a_tot_3e_bi_orth ...'
+!  call wall_time(t0)
+!  PROVIDE fock_a_tot_3e_bi_orth
+!  call wall_time(t1)
+!  print*, ' Wall time for fock_a_tot_3e_bi_orth =', t1 - t0 
+
+  PROVIDE fock_3e_uhf_mo_cs fock_3e_uhf_mo_cs_old
+
+  thr_ih   = 1d-8
+  norm     = 0.d0
+  diff_tot = 0.d0
+
+  do i = 1, mo_num
+    do j = 1, mo_num
+
+      I_old = fock_3e_uhf_mo_cs_old(j,i)
+      I_new = fock_3e_uhf_mo_cs    (j,i)
+
+      diff = dabs(I_old - I_new)
+      if(diff .gt. thr_ih) then
+        print *, ' problem in fock_3e_uhf_mo_cs on ', j, i
+        print *, ' old value = ', I_old
+        print *, ' new value = ', I_new
+        !stop
+      endif
+
+      norm     += dabs(I_old)
+      diff_tot += diff
+    enddo
+  enddo
+
+  print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
+
+  return
+end subroutine test_fock_3e_uhf_mo_cs
+
+! ---
+
+subroutine test_fock_3e_uhf_mo_a()
+
+  implicit none
+  integer          :: i, j
+  double precision :: I_old, I_new
+  double precision :: diff_tot, diff, thr_ih, norm
+
+  PROVIDE fock_3e_uhf_mo_a fock_3e_uhf_mo_a_old
+
+  thr_ih   = 1d-8
+  norm     = 0.d0
+  diff_tot = 0.d0
+
+  do i = 1, mo_num
+    do j = 1, mo_num
+
+      I_old = fock_3e_uhf_mo_a_old(j,i)
+      I_new = fock_3e_uhf_mo_a    (j,i)
+
+      diff = dabs(I_old - I_new)
+      if(diff .gt. thr_ih) then
+        print *, ' problem in fock_3e_uhf_mo_a on ', j, i
+        print *, ' old value = ', I_old
+        print *, ' new value = ', I_new
+        !stop
+      endif
+
+      norm     += dabs(I_old)
+      diff_tot += diff
+    enddo
+  enddo
+
+  print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
+
+  return
+end subroutine test_fock_3e_uhf_mo_a
+
+! ---
+
+subroutine test_fock_3e_uhf_mo_b()
+
+  implicit none
+  integer          :: i, j
+  double precision :: I_old, I_new
+  double precision :: diff_tot, diff, thr_ih, norm
+
+  PROVIDE fock_3e_uhf_mo_b fock_3e_uhf_mo_b_old
+
+  thr_ih   = 1d-8
+  norm     = 0.d0
+  diff_tot = 0.d0
+
+  do i = 1, mo_num
+    do j = 1, mo_num
+
+      I_old = fock_3e_uhf_mo_b_old(j,i)
+      I_new = fock_3e_uhf_mo_b    (j,i)
+
+      diff = dabs(I_old - I_new)
+      if(diff .gt. thr_ih) then
+        print *, ' problem in fock_3e_uhf_mo_b on ', j, i
+        print *, ' old value = ', I_old
+        print *, ' new value = ', I_new
+        !stop
+      endif
+
+      norm     += dabs(I_old)
+      diff_tot += diff
+    enddo
+  enddo
+
+  print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
+
+  return
+end subroutine test_fock_3e_uhf_mo_b
+
+! ---
+

src/utils/util.irp.f

@@ -556,3 +556,28 @@ subroutine sub_A_At(A, N)
  !$OMP END PARALLEL
 
 end
+
+! ---
+
+logical function is_same_spin(sigma_1, sigma_2)
+
+  BEGIN_DOC
+  !
+  ! true if sgn(sigma_1) = sgn(sigma_2)
+  !
+  END_DOC
+
+  implicit none
+  double precision, intent(in) :: sigma_1, sigma_2
+
+  if((sigma_1 * sigma_2) .gt. 0.d0) then
+    is_same_spin = .true.
+  else
+    is_same_spin = .false.
+  endif
+
+end function is_same_spin
+
+! ---
+
+