Merge branch 'dev-stable' into torus

plugins/local/bi_ort_ints/bi_ort_ints.irp.f

@@ -17,12 +17,15 @@ program bi_ort_ints
 ! call test_3e
 ! call test_5idx
 ! call test_5idx2
-  call test_4idx()
+!  call test_4idx()
   !call test_4idx_n4()
   !call test_4idx2()
   !call test_5idx2
   !call test_5idx
 
+  call test_mos_in_r()
+  call test_int2_grad1_u12_bimo_t()
+
 end
 
 subroutine test_5idx2
@@ -472,4 +475,94 @@ subroutine test_4idx()
   return
 end
 
+! ---
+
+subroutine test_mos_in_r()
+
+  implicit none
+
+  integer          :: i, j
+  double precision :: err_tot, nrm_tot, err_loc, acc_thr
+
+  PROVIDE mos_l_in_r_array_transp_old mos_r_in_r_array_transp_old
+  PROVIDE mos_l_in_r_array_transp mos_r_in_r_array_transp
+
+  acc_thr = 1d-13
+
+  err_tot = 0.d0
+  nrm_tot = 0.d0
+  do i = 1, mo_num
+    do j = 1, n_points_final_grid
+      err_loc = dabs(mos_l_in_r_array_transp_old(j,i) - mos_l_in_r_array_transp(j,i))
+      if(err_loc > acc_thr) then
+        print*, " error on", j, i
+        print*, " old res", mos_l_in_r_array_transp_old(j,i)
+        print*, " new res", mos_l_in_r_array_transp    (j,i)
+        stop
+      endif
+      err_tot = err_tot + err_loc
+      nrm_tot = nrm_tot + dabs(mos_l_in_r_array_transp_old(j,i))
+    enddo
+  enddo
+  print *, ' absolute accuracy on mos_l_in_r_array_transp (%) =', 100.d0 * err_tot / nrm_tot
+
+  err_tot = 0.d0
+  nrm_tot = 0.d0
+  do i = 1, mo_num
+    do j = 1, n_points_final_grid
+      err_loc = dabs(mos_r_in_r_array_transp_old(j,i) - mos_r_in_r_array_transp(j,i))
+      if(err_loc > acc_thr) then
+        print*, " error on", j, i
+        print*, " old res", mos_r_in_r_array_transp_old(j,i)
+        print*, " new res", mos_r_in_r_array_transp    (j,i)
+        stop
+      endif
+      err_tot = err_tot + err_loc
+      nrm_tot = nrm_tot + dabs(mos_r_in_r_array_transp_old(j,i))
+    enddo
+  enddo
+  print *, ' absolute accuracy on mos_r_in_r_array_transp (%) =', 100.d0 * err_tot / nrm_tot
+
+  return
+end
+
+! ---
+
+subroutine test_int2_grad1_u12_bimo_t()
+
+  implicit none
+  integer          :: i, j, ipoint, m
+  double precision :: err_tot, nrm_tot, err_loc, acc_thr
+
+  PROVIDE int2_grad1_u12_bimo_t_old
+  PROVIDE int2_grad1_u12_bimo_t
+
+  acc_thr = 1d-13
+
+  err_tot = 0.d0
+  nrm_tot = 0.d0
+  do i = 1, mo_num
+    do j = 1, mo_num
+      do m = 1, 3
+        do ipoint = 1, n_points_final_grid
+          err_loc = dabs(int2_grad1_u12_bimo_t_old(ipoint,m,j,i) - int2_grad1_u12_bimo_t(ipoint,m,j,i))
+          if(err_loc > acc_thr) then
+            print*, " error on", ipoint, m, j, i
+            print*, " old res", int2_grad1_u12_bimo_t_old(ipoint,m,j,i)
+            print*, " new res", int2_grad1_u12_bimo_t    (ipoint,m,j,i)
+            stop
+          endif
+          err_tot = err_tot + err_loc
+          nrm_tot = nrm_tot + dabs(int2_grad1_u12_bimo_t_old(ipoint,m,j,i))
+        enddo
+      enddo
+    enddo
+  enddo
+  print *, ' absolute accuracy on int2_grad1_u12_bimo_t (%) =', 100.d0 * err_tot / nrm_tot
+
+  return
+end
+
+! ---
+
 

plugins/local/bi_ort_ints/no_dressing.irp.f

@@ -710,6 +710,8 @@ BEGIN_PROVIDER [double precision, noL_0e]
 
   endif
 
+  print*, " noL_0e =", noL_0e
+
 END_PROVIDER
 
 ! ---

plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f

@@ -1,360 +1,54 @@
 
 ! ---
 
-! TODO :: optimization : transform into a DGEMM
-
-BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu, (mo_num, mo_num, n_points_final_grid)]
-
-  BEGIN_DOC
-  !
-  ! mo_v_ki_bi_ortho_erf_rk_cst_mu(k,i,ip) = int dr chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1 )/(2|r - R_ip|) on the BI-ORTHO MO basis 
-  ! 
-  ! where phi_k(r) is a LEFT MOs and phi_i(r) is a RIGHT MO
-  !
-  ! R_ip = the "ip"-th point of the DFT Grid
-  !
-  END_DOC
-
-  implicit none
-  integer :: ipoint
- !$OMP PARALLEL         &
- !$OMP DEFAULT (NONE)   &
- !$OMP PRIVATE (ipoint) & 
- !$OMP SHARED (n_points_final_grid,v_ij_erf_rk_cst_mu,mo_v_ki_bi_ortho_erf_rk_cst_mu)
- !$OMP DO SCHEDULE (dynamic)
-  do ipoint = 1, n_points_final_grid
-    call ao_to_mo_bi_ortho( v_ij_erf_rk_cst_mu            (1,1,ipoint), size(v_ij_erf_rk_cst_mu,             1) &
-                          , mo_v_ki_bi_ortho_erf_rk_cst_mu(1,1,ipoint), size(mo_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
-  enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
-  mo_v_ki_bi_ortho_erf_rk_cst_mu = mo_v_ki_bi_ortho_erf_rk_cst_mu * 0.5d0
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu_transp, (n_points_final_grid, mo_num, mo_num)]
-
-  BEGIN_DOC
-  !
-  ! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/(2|r - R|) on the BI-ORTHO MO basis
-  !
-  END_DOC
-
-  implicit none
-  integer :: ipoint, i, j
-
-  do i = 1, mo_num
-    do j = 1, mo_num
-      do ipoint = 1, n_points_final_grid
-        mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,j,i) = mo_v_ki_bi_ortho_erf_rk_cst_mu(j,i,ipoint)
-      enddo
-    enddo
-  enddo
-
-  !FREE mo_v_ki_bi_ortho_erf_rk_cst_mu
-
-END_PROVIDER 
-
-! ---
-
-! TODO :: optimization : transform into a DGEMM
-
-BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu, (mo_num, mo_num, 3, n_points_final_grid)]
-
-  BEGIN_DOC
-  !
-  ! mo_x_v_ki_bi_ortho_erf_rk_cst_mu(k,i,m,ip) = int dr x(m) * chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1)/2|r - R_ip| on the BI-ORTHO MO basis 
-  !
-  ! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => x(m) = x, m=2 => x(m) = y, m=3 => x(m) = z,
-  !
-  ! R_ip = the "ip"-th point of the DFT Grid
-  !
-  END_DOC
-
-  implicit none
-  integer :: ipoint
-
- !$OMP PARALLEL         &
- !$OMP DEFAULT (NONE)   &
- !$OMP PRIVATE (ipoint) & 
- !$OMP SHARED (n_points_final_grid,x_v_ij_erf_rk_cst_mu_transp,mo_x_v_ki_bi_ortho_erf_rk_cst_mu)
- !$OMP DO SCHEDULE (dynamic)
-  do ipoint = 1, n_points_final_grid
-
-    call ao_to_mo_bi_ortho( x_v_ij_erf_rk_cst_mu_transp     (1,1,1,ipoint), size(x_v_ij_erf_rk_cst_mu_transp,      1) &
-                          , mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,1,ipoint), size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
-    call ao_to_mo_bi_ortho( x_v_ij_erf_rk_cst_mu_transp     (1,1,2,ipoint), size(x_v_ij_erf_rk_cst_mu_transp,      1) &
-                          , mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,2,ipoint), size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
-    call ao_to_mo_bi_ortho( x_v_ij_erf_rk_cst_mu_transp     (1,1,3,ipoint), size(x_v_ij_erf_rk_cst_mu_transp,      1) &
-                          , mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,3,ipoint), size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
-
-  enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
-  mo_x_v_ki_bi_ortho_erf_rk_cst_mu = 0.5d0 * mo_x_v_ki_bi_ortho_erf_rk_cst_mu
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3, n_points_final_grid)]
-
-  implicit none
-  integer          :: i, j, ipoint
-  double precision :: wall0, wall1
-
-  !print *, ' providing int2_grad1_u12_ao_transp ...'
-  !call wall_time(wall0)
-
-  if(test_cycle_tc) then
-
-    PROVIDE int2_grad1_u12_ao_test
-
-    do ipoint = 1, n_points_final_grid
-      do i = 1, ao_num
-        do j = 1, ao_num
-          int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,1)
-          int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,2)
-          int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,3)
-        enddo
-      enddo
-    enddo
-
-    FREE int2_grad1_u12_ao_test
-
-  else
-
-    PROVIDE int2_grad1_u12_ao
-
-    do ipoint = 1, n_points_final_grid
-      do i = 1, ao_num
-        do j = 1, ao_num
-          int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao(j,i,ipoint,1)
-          int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao(j,i,ipoint,2)
-          int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao(j,i,ipoint,3)
-        enddo
-      enddo
-    enddo
-
-  endif
-
-  !call wall_time(wall1)
-  !print *, ' wall time for int2_grad1_u12_ao_transp (min) = ', (wall1 - wall0) / 60.d0
-  !call print_memory_usage()
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
-
-  implicit none
-  integer          :: ipoint
-  double precision :: wall0, wall1
-
-  PROVIDE mo_l_coef mo_r_coef
-  PROVIDE int2_grad1_u12_ao_transp
-
-  !print *, ' providing int2_grad1_u12_bimo_transp ...'
-  !call wall_time(wall0)
-
-  !$OMP PARALLEL         &
-  !$OMP DEFAULT (NONE)   &
-  !$OMP PRIVATE (ipoint) & 
-  !$OMP SHARED (n_points_final_grid,int2_grad1_u12_ao_transp,int2_grad1_u12_bimo_transp)
-  !$OMP DO SCHEDULE (dynamic)
-  do ipoint = 1, n_points_final_grid
-    call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp  (1,1,1,ipoint), size(int2_grad1_u12_ao_transp  , 1) &
-                          , int2_grad1_u12_bimo_transp(1,1,1,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
-    call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp  (1,1,2,ipoint), size(int2_grad1_u12_ao_transp  , 1) &
-                          , int2_grad1_u12_bimo_transp(1,1,2,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
-    call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp  (1,1,3,ipoint), size(int2_grad1_u12_ao_transp  , 1) &
-                          , int2_grad1_u12_bimo_transp(1,1,3,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
-  enddo
-  !$OMP END DO
-  !$OMP END PARALLEL
-
-  !FREE int2_grad1_u12_ao_transp
-
-  !call wall_time(wall1)
-  !print *, ' wall time for int2_grad1_u12_bimo_transp (min) =', (wall1 - wall0) / 60.d0
-  !call print_memory_usage()
-
-END_PROVIDER 
-
-! ---
-
 BEGIN_PROVIDER [double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, 3, mo_num, mo_num)]
 
   implicit none
-  integer          :: i, j, ipoint
+  integer                       :: i, j, ipoint
-  double precision :: wall0, wall1
+  double precision              :: tt1, tt2
-
+  double precision, allocatable :: tmp(:,:,:,:)
-  !call wall_time(wall0)
-  !print *, ' providing int2_grad1_u12_bimo_t ...'
 
   PROVIDE mo_l_coef mo_r_coef
-  PROVIDE int2_grad1_u12_bimo_transp
+  PROVIDE int2_grad1_u12_ao
 
+  call wall_time(tt1)
+
+  allocate(tmp(mo_num,mo_num,n_points_final_grid,3))
+
+  !$OMP PARALLEL         &
+  !$OMP DEFAULT (NONE)   &
+  !$OMP PRIVATE (ipoint) & 
+  !$OMP SHARED (ao_num, mo_num, n_points_final_grid, int2_grad1_u12_ao, tmp)
+  !$OMP DO SCHEDULE (dynamic)
+  do ipoint = 1, n_points_final_grid
+    call ao_to_mo_bi_ortho(int2_grad1_u12_ao(1,1,ipoint,1), ao_num, tmp(1,1,ipoint,1), mo_num)
+    call ao_to_mo_bi_ortho(int2_grad1_u12_ao(1,1,ipoint,2), ao_num, tmp(1,1,ipoint,2), mo_num)
+    call ao_to_mo_bi_ortho(int2_grad1_u12_ao(1,1,ipoint,3), ao_num, tmp(1,1,ipoint,3), mo_num)
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  !$OMP PARALLEL               &
+  !$OMP DEFAULT (NONE)         &
+  !$OMP PRIVATE (i, j, ipoint) & 
+  !$OMP SHARED (mo_num, n_points_final_grid, tmp, int2_grad1_u12_bimo_t)
+  !$OMP DO COLLAPSE(2) SCHEDULE (dynamic)
   do ipoint = 1, n_points_final_grid
     do i = 1, mo_num
       do j = 1, mo_num
-        int2_grad1_u12_bimo_t(ipoint,1,j,i) = int2_grad1_u12_bimo_transp(j,i,1,ipoint)
+        int2_grad1_u12_bimo_t(ipoint,1,j,i) = tmp(j,i,ipoint,1)
-        int2_grad1_u12_bimo_t(ipoint,2,j,i) = int2_grad1_u12_bimo_transp(j,i,2,ipoint)
+        int2_grad1_u12_bimo_t(ipoint,2,j,i) = tmp(j,i,ipoint,2)
-        int2_grad1_u12_bimo_t(ipoint,3,j,i) = int2_grad1_u12_bimo_transp(j,i,3,ipoint)
+        int2_grad1_u12_bimo_t(ipoint,3,j,i) = tmp(j,i,ipoint,3)
       enddo                                  
     enddo
   enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
 
-  FREE int2_grad1_u12_bimo_transp
+  deallocate(tmp)
 
-  !call wall_time(wall1)
+  call wall_time(tt2)
-  !print *, ' wall time for int2_grad1_u12_bimo_t (min) =', (wall1 - wall0) / 60.d0
+  write(*,"(A,2X,F15.7)") ' wall time for int2_grad1_u12_bimo_t (sec) = ', (tt2 - tt1)
-  !call print_memory_usage()
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, ao_num, ao_num)]
-
-  implicit none
-  integer          :: i, j, ipoint
-  double precision :: wall0, wall1
-
-  !call wall_time(wall0)
-  !print *, ' providing int2_grad1_u12_ao_t ...'
-
-  PROVIDE int2_grad1_u12_ao
-
-  do ipoint = 1, n_points_final_grid
-    do i = 1, ao_num
-      do j = 1, ao_num
-        int2_grad1_u12_ao_t(ipoint,1,j,i) = int2_grad1_u12_ao(j,i,ipoint,1)
-        int2_grad1_u12_ao_t(ipoint,2,j,i) = int2_grad1_u12_ao(j,i,ipoint,2)
-        int2_grad1_u12_ao_t(ipoint,3,j,i) = int2_grad1_u12_ao(j,i,ipoint,3)
-      enddo                                  
-    enddo
-  enddo
-
-  !call wall_time(wall1)
-  !print *, ' wall time for int2_grad1_u12_ao_t (min) =', (wall1 - wall0) / 60.d0
-  !call print_memory_usage()
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp, (n_points_final_grid, 3, mo_num, mo_num)]
-
-  implicit none
-  integer :: i, j, ipoint
-
-  do i = 1, mo_num
-    do j = 1, mo_num
-      do ipoint = 1, n_points_final_grid
-        mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,1,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,1,ipoint)
-        mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,2,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,2,ipoint)
-        mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,3,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,3,ipoint)
-      enddo
-    enddo
-  enddo
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid, 3, mo_num, mo_num)]
-
-  BEGIN_DOC
-  !
-  ! x_W_ki_bi_ortho_erf_rk(ip,m,k,i) = \int dr chi_k(r) \frac{(1 - erf(mu |r-R_ip|))}{2|r-R_ip|} (x(m)-R_ip(m)) phi_i(r) ON THE BI-ORTHO MO BASIS 
-  !
-  ! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => X(m) = x, m=2 => X(m) = y, m=3 => X(m) = z,
-  !
-  ! R_ip = the "ip"-th point of the DFT Grid
-  END_DOC
- 
-  implicit none
-  include 'constants.include.F'
- 
-  integer          :: ipoint, m, i, k
-  double precision :: xyz
-  double precision :: wall0, wall1
- 
-  !print*, ' providing x_W_ki_bi_ortho_erf_rk ...'
-  !call wall_time(wall0)
-
- !$OMP PARALLEL                   &
- !$OMP DEFAULT (NONE)             &
- !$OMP PRIVATE (ipoint,m,i,k,xyz) & 
- !$OMP SHARED (x_W_ki_bi_ortho_erf_rk,n_points_final_grid,mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_num,final_grid_points) 
- !$OMP DO SCHEDULE (dynamic)
-  do i = 1, mo_num
-    do k = 1, mo_num
-      do m = 1, 3
-        do ipoint = 1, n_points_final_grid
-          xyz = final_grid_points(m,ipoint)
-          x_W_ki_bi_ortho_erf_rk(ipoint,m,k,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,m,k,i) - xyz * mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,k,i)
-        enddo
-      enddo
-    enddo
-  enddo
-
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu_transp 
- ! FREE mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp
-
-  !call wall_time(wall1)
-  !print *, ' time to provide x_W_ki_bi_ortho_erf_rk = ', wall1 - wall0
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk_diag, (n_points_final_grid, 3, mo_num)]
-  BEGIN_DOC
-  ! x_W_ki_bi_ortho_erf_rk_diag(ip,m,i) = \int dr chi_i(r) (1 - erf(mu |r-R_ip|)) (x(m)-X(m)_ip) phi_i(r) ON THE BI-ORTHO MO BASIS 
-!
-! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => X(m) = x, m=2 => X(m) = y, m=3 => X(m) = z,
-!
-! R_ip = the "ip"-th point of the DFT Grid
-  END_DOC
-
-  implicit none
-  include 'constants.include.F'
- 
-  integer          :: ipoint, m, i
-  double precision :: xyz
-  double precision :: wall0, wall1
- 
-  !print*,'providing x_W_ki_bi_ortho_erf_rk_diag ...'
-  !call wall_time(wall0)
-
- !$OMP PARALLEL                 &
- !$OMP DEFAULT (NONE)           &
- !$OMP PRIVATE (ipoint,m,i,xyz) & 
- !$OMP SHARED (x_W_ki_bi_ortho_erf_rk_diag,n_points_final_grid,mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_num,final_grid_points) 
- !$OMP DO SCHEDULE (dynamic)
-  do i = 1, mo_num
-    do m = 1, 3
-      do ipoint = 1, n_points_final_grid
-        xyz = final_grid_points(m,ipoint)
-        x_W_ki_bi_ortho_erf_rk_diag(ipoint,m,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,m,i,i) - xyz * mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,i,i)
-      enddo
-    enddo
-  enddo
-
- !$OMP END DO
- !$OMP END PARALLEL
-
-  !call wall_time(wall1)
-  !print*,'time to provide x_W_ki_bi_ortho_erf_rk_diag = ',wall1 - wall0
 
 END_PROVIDER 
 

plugins/local/bi_ort_ints/semi_num_ints_mo_old.irp.f

@@ -0,0 +1,362 @@
+
+! ---
+
+! TODO :: optimization : transform into a DGEMM
+
+BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu, (mo_num, mo_num, n_points_final_grid)]
+
+  BEGIN_DOC
+  !
+  ! mo_v_ki_bi_ortho_erf_rk_cst_mu(k,i,ip) = int dr chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1 )/(2|r - R_ip|) on the BI-ORTHO MO basis 
+  ! 
+  ! where phi_k(r) is a LEFT MOs and phi_i(r) is a RIGHT MO
+  !
+  ! R_ip = the "ip"-th point of the DFT Grid
+  !
+  END_DOC
+
+  implicit none
+  integer :: ipoint
+ !$OMP PARALLEL         &
+ !$OMP DEFAULT (NONE)   &
+ !$OMP PRIVATE (ipoint) & 
+ !$OMP SHARED (n_points_final_grid,v_ij_erf_rk_cst_mu,mo_v_ki_bi_ortho_erf_rk_cst_mu)
+ !$OMP DO SCHEDULE (dynamic)
+  do ipoint = 1, n_points_final_grid
+    call ao_to_mo_bi_ortho( v_ij_erf_rk_cst_mu            (1,1,ipoint), size(v_ij_erf_rk_cst_mu,             1) &
+                          , mo_v_ki_bi_ortho_erf_rk_cst_mu(1,1,ipoint), size(mo_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
+  enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+  mo_v_ki_bi_ortho_erf_rk_cst_mu = mo_v_ki_bi_ortho_erf_rk_cst_mu * 0.5d0
+
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu_transp, (n_points_final_grid, mo_num, mo_num)]
+
+  BEGIN_DOC
+  !
+  ! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/(2|r - R|) on the BI-ORTHO MO basis
+  !
+  END_DOC
+
+  implicit none
+  integer :: ipoint, i, j
+
+  do i = 1, mo_num
+    do j = 1, mo_num
+      do ipoint = 1, n_points_final_grid
+        mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,j,i) = mo_v_ki_bi_ortho_erf_rk_cst_mu(j,i,ipoint)
+      enddo
+    enddo
+  enddo
+
+  !FREE mo_v_ki_bi_ortho_erf_rk_cst_mu
+
+END_PROVIDER 
+
+! ---
+
+! TODO :: optimization : transform into a DGEMM
+
+BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu, (mo_num, mo_num, 3, n_points_final_grid)]
+
+  BEGIN_DOC
+  !
+  ! mo_x_v_ki_bi_ortho_erf_rk_cst_mu(k,i,m,ip) = int dr x(m) * chi_k(r) phi_i(r) (erf(mu |r - R_ip|) - 1)/2|r - R_ip| on the BI-ORTHO MO basis 
+  !
+  ! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => x(m) = x, m=2 => x(m) = y, m=3 => x(m) = z,
+  !
+  ! R_ip = the "ip"-th point of the DFT Grid
+  !
+  END_DOC
+
+  implicit none
+  integer :: ipoint
+
+ !$OMP PARALLEL         &
+ !$OMP DEFAULT (NONE)   &
+ !$OMP PRIVATE (ipoint) & 
+ !$OMP SHARED (n_points_final_grid,x_v_ij_erf_rk_cst_mu_transp,mo_x_v_ki_bi_ortho_erf_rk_cst_mu)
+ !$OMP DO SCHEDULE (dynamic)
+  do ipoint = 1, n_points_final_grid
+
+    call ao_to_mo_bi_ortho( x_v_ij_erf_rk_cst_mu_transp     (1,1,1,ipoint), size(x_v_ij_erf_rk_cst_mu_transp,      1) &
+                          , mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,1,ipoint), size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
+    call ao_to_mo_bi_ortho( x_v_ij_erf_rk_cst_mu_transp     (1,1,2,ipoint), size(x_v_ij_erf_rk_cst_mu_transp,      1) &
+                          , mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,2,ipoint), size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
+    call ao_to_mo_bi_ortho( x_v_ij_erf_rk_cst_mu_transp     (1,1,3,ipoint), size(x_v_ij_erf_rk_cst_mu_transp,      1) &
+                          , mo_x_v_ki_bi_ortho_erf_rk_cst_mu(1,1,3,ipoint), size(mo_x_v_ki_bi_ortho_erf_rk_cst_mu, 1) )
+
+  enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+  mo_x_v_ki_bi_ortho_erf_rk_cst_mu = 0.5d0 * mo_x_v_ki_bi_ortho_erf_rk_cst_mu
+
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3, n_points_final_grid)]
+
+  implicit none
+  integer          :: i, j, ipoint
+  double precision :: wall0, wall1
+
+  !print *, ' providing int2_grad1_u12_ao_transp ...'
+  !call wall_time(wall0)
+
+  if(test_cycle_tc) then
+
+    PROVIDE int2_grad1_u12_ao_test
+
+    do ipoint = 1, n_points_final_grid
+      do i = 1, ao_num
+        do j = 1, ao_num
+          int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,1)
+          int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,2)
+          int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,3)
+        enddo
+      enddo
+    enddo
+
+    FREE int2_grad1_u12_ao_test
+
+  else
+
+    PROVIDE int2_grad1_u12_ao
+
+    do ipoint = 1, n_points_final_grid
+      do i = 1, ao_num
+        do j = 1, ao_num
+          int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao(j,i,ipoint,1)
+          int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao(j,i,ipoint,2)
+          int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao(j,i,ipoint,3)
+        enddo
+      enddo
+    enddo
+
+  endif
+
+  !call wall_time(wall1)
+  !print *, ' wall time for int2_grad1_u12_ao_transp (min) = ', (wall1 - wall0) / 60.d0
+  !call print_memory_usage()
+
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
+
+  implicit none
+  integer          :: ipoint
+  double precision :: wall0, wall1
+
+  PROVIDE mo_l_coef mo_r_coef
+  PROVIDE int2_grad1_u12_ao_transp
+
+  !print *, ' providing int2_grad1_u12_bimo_transp ...'
+  !call wall_time(wall0)
+
+  !$OMP PARALLEL         &
+  !$OMP DEFAULT (NONE)   &
+  !$OMP PRIVATE (ipoint) & 
+  !$OMP SHARED (n_points_final_grid,int2_grad1_u12_ao_transp,int2_grad1_u12_bimo_transp)
+  !$OMP DO SCHEDULE (dynamic)
+  do ipoint = 1, n_points_final_grid
+    call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp  (1,1,1,ipoint), size(int2_grad1_u12_ao_transp  , 1) &
+                          , int2_grad1_u12_bimo_transp(1,1,1,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
+    call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp  (1,1,2,ipoint), size(int2_grad1_u12_ao_transp  , 1) &
+                          , int2_grad1_u12_bimo_transp(1,1,2,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
+    call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp  (1,1,3,ipoint), size(int2_grad1_u12_ao_transp  , 1) &
+                          , int2_grad1_u12_bimo_transp(1,1,3,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  !FREE int2_grad1_u12_ao_transp
+
+  !call wall_time(wall1)
+  !print *, ' wall time for int2_grad1_u12_bimo_transp (min) =', (wall1 - wall0) / 60.d0
+  !call print_memory_usage()
+
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [double precision, int2_grad1_u12_bimo_t_old, (n_points_final_grid, 3, mo_num, mo_num)]
+
+  implicit none
+  integer          :: i, j, ipoint
+  double precision :: wall0, wall1
+
+  !call wall_time(wall0)
+  !print *, ' providing int2_grad1_u12_bimo_t_old ...'
+
+  PROVIDE mo_l_coef mo_r_coef
+  PROVIDE int2_grad1_u12_bimo_transp
+
+  do ipoint = 1, n_points_final_grid
+    do i = 1, mo_num
+      do j = 1, mo_num
+        int2_grad1_u12_bimo_t_old(ipoint,1,j,i) = int2_grad1_u12_bimo_transp(j,i,1,ipoint)
+        int2_grad1_u12_bimo_t_old(ipoint,2,j,i) = int2_grad1_u12_bimo_transp(j,i,2,ipoint)
+        int2_grad1_u12_bimo_t_old(ipoint,3,j,i) = int2_grad1_u12_bimo_transp(j,i,3,ipoint)
+      enddo                                  
+    enddo
+  enddo
+
+  FREE int2_grad1_u12_bimo_transp
+
+  !call wall_time(wall1)
+  !print *, ' wall time for int2_grad1_u12_bimo_t_old (min) =', (wall1 - wall0) / 60.d0
+  !call print_memory_usage()
+
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, ao_num, ao_num)]
+
+  implicit none
+  integer          :: i, j, ipoint
+  double precision :: wall0, wall1
+
+  !call wall_time(wall0)
+  !print *, ' providing int2_grad1_u12_ao_t ...'
+
+  PROVIDE int2_grad1_u12_ao
+
+  do ipoint = 1, n_points_final_grid
+    do i = 1, ao_num
+      do j = 1, ao_num
+        int2_grad1_u12_ao_t(ipoint,1,j,i) = int2_grad1_u12_ao(j,i,ipoint,1)
+        int2_grad1_u12_ao_t(ipoint,2,j,i) = int2_grad1_u12_ao(j,i,ipoint,2)
+        int2_grad1_u12_ao_t(ipoint,3,j,i) = int2_grad1_u12_ao(j,i,ipoint,3)
+      enddo                                  
+    enddo
+  enddo
+
+  !call wall_time(wall1)
+  !print *, ' wall time for int2_grad1_u12_ao_t (min) =', (wall1 - wall0) / 60.d0
+  !call print_memory_usage()
+
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [ double precision, mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp, (n_points_final_grid, 3, mo_num, mo_num)]
+
+  implicit none
+  integer :: i, j, ipoint
+
+  do i = 1, mo_num
+    do j = 1, mo_num
+      do ipoint = 1, n_points_final_grid
+        mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,1,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,1,ipoint)
+        mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,2,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,2,ipoint)
+        mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,3,j,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu(j,i,3,ipoint)
+      enddo
+    enddo
+  enddo
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid, 3, mo_num, mo_num)]
+
+  BEGIN_DOC
+  !
+  ! x_W_ki_bi_ortho_erf_rk(ip,m,k,i) = \int dr chi_k(r) \frac{(1 - erf(mu |r-R_ip|))}{2|r-R_ip|} (x(m)-R_ip(m)) phi_i(r) ON THE BI-ORTHO MO BASIS 
+  !
+  ! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => X(m) = x, m=2 => X(m) = y, m=3 => X(m) = z,
+  !
+  ! R_ip = the "ip"-th point of the DFT Grid
+  END_DOC
+ 
+  implicit none
+  include 'constants.include.F'
+ 
+  integer          :: ipoint, m, i, k
+  double precision :: xyz
+  double precision :: wall0, wall1
+ 
+  !print*, ' providing x_W_ki_bi_ortho_erf_rk ...'
+  !call wall_time(wall0)
+
+ !$OMP PARALLEL                   &
+ !$OMP DEFAULT (NONE)             &
+ !$OMP PRIVATE (ipoint,m,i,k,xyz) & 
+ !$OMP SHARED (x_W_ki_bi_ortho_erf_rk,n_points_final_grid,mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_num,final_grid_points) 
+ !$OMP DO SCHEDULE (dynamic)
+  do i = 1, mo_num
+    do k = 1, mo_num
+      do m = 1, 3
+        do ipoint = 1, n_points_final_grid
+          xyz = final_grid_points(m,ipoint)
+          x_W_ki_bi_ortho_erf_rk(ipoint,m,k,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,m,k,i) - xyz * mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,k,i)
+        enddo
+      enddo
+    enddo
+  enddo
+
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ ! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu_transp 
+ ! FREE mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp
+
+  !call wall_time(wall1)
+  !print *, ' time to provide x_W_ki_bi_ortho_erf_rk = ', wall1 - wall0
+
+END_PROVIDER 
+
+! ---
+
+BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk_diag, (n_points_final_grid, 3, mo_num)]
+  BEGIN_DOC
+  ! x_W_ki_bi_ortho_erf_rk_diag(ip,m,i) = \int dr chi_i(r) (1 - erf(mu |r-R_ip|)) (x(m)-X(m)_ip) phi_i(r) ON THE BI-ORTHO MO BASIS 
+!
+! where chi_k(r)/phi_i(r) are left/right MOs, m=1 => X(m) = x, m=2 => X(m) = y, m=3 => X(m) = z,
+!
+! R_ip = the "ip"-th point of the DFT Grid
+  END_DOC
+
+  implicit none
+  include 'constants.include.F'
+ 
+  integer          :: ipoint, m, i
+  double precision :: xyz
+  double precision :: wall0, wall1
+ 
+  !print*,'providing x_W_ki_bi_ortho_erf_rk_diag ...'
+  !call wall_time(wall0)
+
+ !$OMP PARALLEL                 &
+ !$OMP DEFAULT (NONE)           &
+ !$OMP PRIVATE (ipoint,m,i,xyz) & 
+ !$OMP SHARED (x_W_ki_bi_ortho_erf_rk_diag,n_points_final_grid,mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_v_ki_bi_ortho_erf_rk_cst_mu_transp,mo_num,final_grid_points) 
+ !$OMP DO SCHEDULE (dynamic)
+  do i = 1, mo_num
+    do m = 1, 3
+      do ipoint = 1, n_points_final_grid
+        xyz = final_grid_points(m,ipoint)
+        x_W_ki_bi_ortho_erf_rk_diag(ipoint,m,i) = mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,m,i,i) - xyz * mo_v_ki_bi_ortho_erf_rk_cst_mu_transp(ipoint,i,i)
+      enddo
+    enddo
+  enddo
+
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+  !call wall_time(wall1)
+  !print*,'time to provide x_W_ki_bi_ortho_erf_rk_diag = ',wall1 - wall0
+
+END_PROVIDER 
+
+! ---
+

plugins/local/bi_ortho_mos/bi_ort_mos_in_r.irp.f

@@ -1,135 +1,70 @@
 
-! TODO: left & right MO without duplicate AO calculation
+ BEGIN_PROVIDER[double precision, mos_l_in_r_array_transp, (n_points_final_grid, mo_num)]
-
+&BEGIN_PROVIDER[double precision, mos_r_in_r_array_transp, (n_points_final_grid, mo_num)]
-! ---
-
-BEGIN_PROVIDER[double precision, mos_r_in_r_array, (mo_num, n_points_final_grid)]
 
   BEGIN_DOC
-  ! mos_in_r_array(i,j) = value of the ith RIGHT mo on the jth grid point
+  !
+  ! mos_l_in_r_array_transp(i,j) = value of the jth left-mo  on the ith grid point
+  ! mos_r_in_r_array_transp(i,j) = value of the jth right-mo on the ith grid point
+  !
   END_DOC
 
   implicit none
-  integer          :: i, j
-  double precision :: mos_array(mo_num), r(3)
 
- !$OMP PARALLEL DO &
+  integer                       :: i
- !$OMP DEFAULT (NONE)  &
+  double precision              :: tt0, tt1, tt2, tt3
- !$OMP PRIVATE (i, j, r, mos_array) & 
+  double precision              :: r(3)
- !$OMP SHARED (mos_r_in_r_array, n_points_final_grid, mo_num, final_grid_points)
+  double precision, allocatable :: aos_r(:,:)
+
+  call wall_time(tt0)
+
+  allocate(aos_r(ao_num,n_points_final_grid))
+
+  ! provide everything required before OpenMP
+  r(1) = final_grid_points(1,1)
+  r(2) = final_grid_points(2,1)
+  r(3) = final_grid_points(3,1)
+  call give_all_aos_at_r(r, aos_r(1,1))
+
+
+  call wall_time(tt2)
+
+  !$OMP PARALLEL       &
+  !$OMP DEFAULT (NONE) &
+  !$OMP PRIVATE (i, r) & 
+  !$OMP SHARED(n_points_final_grid, final_grid_points, aos_r)
+  !$OMP DO
   do i = 1, n_points_final_grid
     r(1) = final_grid_points(1,i)
     r(2) = final_grid_points(2,i)
     r(3) = final_grid_points(3,i)
-    call give_all_mos_r_at_r(r, mos_array)
+    call give_all_aos_at_r(r, aos_r(1,i))
-    do j = 1, mo_num
-      mos_r_in_r_array(j,i) = mos_array(j)
-    enddo
   enddo
- !$OMP END PARALLEL DO
+  !$OMP END DO
- 
+  !$OMP END PARALLEL
-END_PROVIDER
 
-! ---
+  call wall_time(tt3)
+  write(*,"(A,2X,F15.7)") ' wall time for AOs on r (sec) = ', (tt3 - tt2)
 
-BEGIN_PROVIDER[double precision, mos_r_in_r_array_transp, (n_points_final_grid, mo_num)]
 
-  BEGIN_DOC
+  call dgemm("T", "N", n_points_final_grid, mo_num, ao_num, &
-  ! mos_r_in_r_array_transp(i,j) = value of the jth mo on the ith grid point
+             1.d0,                                          &
-  END_DOC
+             aos_r(1,1), ao_num,                            &
+             mo_l_coef(1,1), ao_num,                        &
+             0.d0,                                          &
+             mos_l_in_r_array_transp(1,1), n_points_final_grid)
 
-  implicit none
+  call dgemm("T", "N", n_points_final_grid, mo_num, ao_num, &
-  integer :: i,j
+             1.d0,                                          &
+             aos_r(1,1), ao_num,                            &
+             mo_r_coef(1,1), ao_num,                        &
+             0.d0,                                          &
+             mos_r_in_r_array_transp(1,1), n_points_final_grid)
 
-  do i = 1, n_points_final_grid
+  deallocate(aos_r)
-    do j = 1, mo_num
+
-      mos_r_in_r_array_transp(i,j) = mos_r_in_r_array(j,i) 
+  call wall_time(tt1)
-    enddo
+  write(*,"(A,2X,F15.7)") ' wall time for mos_l_in_r_array_transp & mos_r_in_r_array_transp (sec) = ', (tt1 - tt0)
-  enddo
-
-END_PROVIDER
-
-! ---
-
-subroutine give_all_mos_r_at_r(r, mos_r_array)
-
-  BEGIN_DOC
-  ! mos_r_array(i) = ith RIGHT MO function evaluated at "r"
-  END_DOC
-
-  implicit none
-  double precision, intent(in)  :: r(3)
-  double precision, intent(out) :: mos_r_array(mo_num)
-  double precision              :: aos_array(ao_num)
-
-  call give_all_aos_at_r(r, aos_array)
-  call dgemv('N', mo_num, ao_num, 1.d0, mo_r_coef_transp, mo_num, aos_array, 1, 0.d0, mos_r_array, 1)
-
-end subroutine give_all_mos_r_at_r
-
-! ---
-
-BEGIN_PROVIDER[double precision, mos_l_in_r_array, (mo_num, n_points_final_grid)]
-
-  BEGIN_DOC
-  ! mos_in_r_array(i,j) = value of the ith LEFT mo on the jth grid point
-  END_DOC
-
-  implicit none
-  integer          :: i, j
-  double precision :: mos_array(mo_num), r(3)
-
- !$OMP PARALLEL DO &
- !$OMP DEFAULT (NONE)  &
- !$OMP PRIVATE (i,r,mos_array,j) & 
- !$OMP SHARED(mos_l_in_r_array,n_points_final_grid,mo_num,final_grid_points)
-  do i = 1, n_points_final_grid
-    r(1) = final_grid_points(1,i)
-    r(2) = final_grid_points(2,i)
-    r(3) = final_grid_points(3,i)
-    call give_all_mos_l_at_r(r, mos_array)
-    do j = 1, mo_num
-      mos_l_in_r_array(j,i) = mos_array(j)
-    enddo
-  enddo
- !$OMP END PARALLEL DO
- 
-END_PROVIDER
-
-! ---
-
-subroutine give_all_mos_l_at_r(r, mos_l_array)
-
-  BEGIN_DOC
-  ! mos_l_array(i) = ith LEFT MO function evaluated at "r"
-  END_DOC
-
-  implicit none
-  double precision, intent(in)  :: r(3)
-  double precision, intent(out) :: mos_l_array(mo_num)
-  double precision              :: aos_array(ao_num)
-
-  call give_all_aos_at_r(r, aos_array)
-  call dgemv('N', mo_num, ao_num, 1.d0, mo_l_coef_transp, mo_num, aos_array, 1, 0.d0, mos_l_array, 1)
-
-end subroutine give_all_mos_l_at_r
-
-! ---
-
-BEGIN_PROVIDER[double precision, mos_l_in_r_array_transp, (n_points_final_grid,mo_num)]
-
-  BEGIN_DOC
-  ! mos_l_in_r_array_transp(i,j) = value of the jth mo on the ith grid point
-  END_DOC
-
-  implicit none
-  integer :: i, j
-
-  do i = 1, n_points_final_grid
-    do j = 1, mo_num
-      mos_l_in_r_array_transp(i,j) = mos_l_in_r_array(j,i) 
-    enddo
-  enddo
 
 END_PROVIDER
 

plugins/local/bi_ortho_mos/bi_ort_mos_in_r_old.irp.f

@@ -0,0 +1,137 @@
+
+! TODO: left & right MO without duplicate AO calculation
+
+! ---
+
+BEGIN_PROVIDER[double precision, mos_r_in_r_array, (mo_num, n_points_final_grid)]
+
+  BEGIN_DOC
+  ! mos_in_r_array(i,j) = value of the ith RIGHT mo on the jth grid point
+  END_DOC
+
+  implicit none
+  integer          :: i, j
+  double precision :: mos_array(mo_num), r(3)
+
+ !$OMP PARALLEL DO &
+ !$OMP DEFAULT (NONE)  &
+ !$OMP PRIVATE (i, j, r, mos_array) & 
+ !$OMP SHARED (mos_r_in_r_array, n_points_final_grid, mo_num, final_grid_points)
+  do i = 1, n_points_final_grid
+    r(1) = final_grid_points(1,i)
+    r(2) = final_grid_points(2,i)
+    r(3) = final_grid_points(3,i)
+    call give_all_mos_r_at_r(r, mos_array)
+    do j = 1, mo_num
+      mos_r_in_r_array(j,i) = mos_array(j)
+    enddo
+  enddo
+ !$OMP END PARALLEL DO
+ 
+END_PROVIDER
+
+! ---
+
+BEGIN_PROVIDER[double precision, mos_r_in_r_array_transp_old, (n_points_final_grid, mo_num)]
+
+  BEGIN_DOC
+  ! mos_r_in_r_array_transp_old(i,j) = value of the jth mo on the ith grid point
+  END_DOC
+
+  implicit none
+  integer :: i,j
+
+  do i = 1, n_points_final_grid
+    do j = 1, mo_num
+      mos_r_in_r_array_transp_old(i,j) = mos_r_in_r_array(j,i) 
+    enddo
+  enddo
+
+END_PROVIDER
+
+! ---
+
+subroutine give_all_mos_r_at_r(r, mos_r_array)
+
+  BEGIN_DOC
+  ! mos_r_array(i) = ith RIGHT MO function evaluated at "r"
+  END_DOC
+
+  implicit none
+  double precision, intent(in)  :: r(3)
+  double precision, intent(out) :: mos_r_array(mo_num)
+  double precision              :: aos_array(ao_num)
+
+  call give_all_aos_at_r(r, aos_array)
+  call dgemv('N', mo_num, ao_num, 1.d0, mo_r_coef_transp, mo_num, aos_array, 1, 0.d0, mos_r_array, 1)
+
+end subroutine give_all_mos_r_at_r
+
+! ---
+
+BEGIN_PROVIDER[double precision, mos_l_in_r_array, (mo_num, n_points_final_grid)]
+
+  BEGIN_DOC
+  ! mos_in_r_array(i,j) = value of the ith LEFT mo on the jth grid point
+  END_DOC
+
+  implicit none
+  integer          :: i, j
+  double precision :: mos_array(mo_num), r(3)
+
+ !$OMP PARALLEL DO &
+ !$OMP DEFAULT (NONE)  &
+ !$OMP PRIVATE (i,r,mos_array,j) & 
+ !$OMP SHARED(mos_l_in_r_array,n_points_final_grid,mo_num,final_grid_points)
+  do i = 1, n_points_final_grid
+    r(1) = final_grid_points(1,i)
+    r(2) = final_grid_points(2,i)
+    r(3) = final_grid_points(3,i)
+    call give_all_mos_l_at_r(r, mos_array)
+    do j = 1, mo_num
+      mos_l_in_r_array(j,i) = mos_array(j)
+    enddo
+  enddo
+ !$OMP END PARALLEL DO
+ 
+END_PROVIDER
+
+! ---
+
+subroutine give_all_mos_l_at_r(r, mos_l_array)
+
+  BEGIN_DOC
+  ! mos_l_array(i) = ith LEFT MO function evaluated at "r"
+  END_DOC
+
+  implicit none
+  double precision, intent(in)  :: r(3)
+  double precision, intent(out) :: mos_l_array(mo_num)
+  double precision              :: aos_array(ao_num)
+
+  call give_all_aos_at_r(r, aos_array)
+  call dgemv('N', mo_num, ao_num, 1.d0, mo_l_coef_transp, mo_num, aos_array, 1, 0.d0, mos_l_array, 1)
+
+end subroutine give_all_mos_l_at_r
+
+! ---
+
+BEGIN_PROVIDER[double precision, mos_l_in_r_array_transp_old, (n_points_final_grid,mo_num)]
+
+  BEGIN_DOC
+  ! mos_l_in_r_array_transp_old(i,j) = value of the jth mo on the ith grid point
+  END_DOC
+
+  implicit none
+  integer :: i, j
+
+  do i = 1, n_points_final_grid
+    do j = 1, mo_num
+      mos_l_in_r_array_transp_old(i,j) = mos_l_in_r_array(j,i) 
+    enddo
+  enddo
+
+END_PROVIDER
+
+! ---
+

plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f

@@ -155,6 +155,7 @@ subroutine run_stochastic_cipsi
   call pt2_alloc(pt2_data_err, N_states)
   call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection
   call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm)
+  call print_summary_tc(psi_energy_with_nucl_rep, pt2_data, pt2_data_err, N_det, N_configuration, N_states, psi_s2)
   call pt2_dealloc(pt2_data)
   call pt2_dealloc(pt2_data_err)
 

plugins/local/jastrow/EZFIO.cfg

@@ -1,7 +1,25 @@
+[log_jpsi]
+type: logical
+doc: If |true|, the Jpsi is taken as log(1+psi_cor)
+interface: ezfio,provider,ocaml
+default: False
+
+
+[mu_of_r_tc]
+type: character*(32)
+doc: type of the mu(r): [ Standard | Erfmu | Erfmugauss ]
+interface: ezfio,provider,ocaml
+default: Standard
+
+[mu_of_r_av]
+type: logical
+doc: If |true|, take the second formula for mu(r)
+interface: ezfio,provider,ocaml
+default: False
 
 [j2e_type]
 type: character*(32)
-doc: type of the 2e-Jastrow: [ None | Mu | Mu_Nu | Mur | Boys | Boys_Handy | Qmckl ]
+doc: type of the 2e-Jastrow: [ None | Mu | Mugauss | Mu_Nu | Mur | Murgauss | Bump | Boys | Boys_Handy | Qmckl ]
 interface: ezfio,provider,ocaml
 default: Mu
 

plugins/local/jastrow/bh_param.irp.f

@@ -232,6 +232,14 @@
 
   ! ---
 
+  do i_nucl = 1, nucl_num
+    do p = 1, jBH_size
+      if(jBH_m(p,i_nucl) .eq. jBH_n(p,i_nucl)) then
+        jBH_c(p,i_nucl) = 0.5d0 * jBH_c(p,i_nucl)
+      endif
+    enddo
+  enddo
+
   print *, ' parameters for Boys-Handy Jastrow'
   print *, ' nb of terms per nucleus = ', jBH_size
 

plugins/local/non_h_ints_mu/NEED

@@ -4,3 +4,4 @@ jastrow
 ao_tc_eff_map
 bi_ortho_mos
 trexio
+mu_of_r

plugins/local/non_h_ints_mu/deb_deriv_mu.irp.f

@@ -0,0 +1,28 @@
+program test_j_mu_of_r
+ implicit none
+ double precision :: x,mu_min,dmu,mu_max, mu, mu_p, mu_m
+ double precision :: j_simple,j_p, j_m,numeric_d_mu,d_dx_mu
+ double precision :: accu
+ integer :: npt,i
+ npt = 1000
+ mu_min = 0.3d0
+ mu_max = 10.d0
+ dmu = (mu_max - mu_min)/dble(npt)
+ x = 0.7d0
+ mu = mu_min
+ do i = 1, npt
+  call get_deriv_mu_j12(x,mu,d_dx_mu)
+  mu_p = mu + dmu
+  mu_m = mu - dmu
+  j_p = j_simple(x,mu_p)
+  j_m = j_simple(x,mu_m)
+  numeric_d_mu = 0.5d0 * (j_p - j_m)/dmu
+  print*,mu
+  print*,numeric_d_mu,d_dx_mu,dabs(d_dx_mu-numeric_d_mu)
+  accu += dabs(d_dx_mu-numeric_d_mu)
+  mu += dmu
+ enddo
+ accu *= dmu
+ print*,'accu = ',accu
+end
+

plugins/local/non_h_ints_mu/deb_j_bump.irp.f

@@ -0,0 +1,98 @@
+program test_j_mu_of_r
+ implicit none
+! call routine_test_mu_of_r
+ call routine_test_mu_of_r_tot
+end
+
+subroutine routine_test_mu_of_r_tot
+ implicit none
+ integer :: ipoint,k 
+ double precision :: r2(3), weight, dr, r1(3), r1bis(3)
+ double precision :: accu_grad(3)
+ double precision :: jast,grad_jast_mu_r1(3),j_bump
+ double precision :: jast_p,jast_m,num_grad_jast_mu_r1(3)
+
+ dr = 0.00001d0
+ r2 = 0.d0
+ r2(1) =  0.5d0
+ r2(2) = -0.1d0
+ r2(3) =  1.0d0
+ accu_grad = 0.d0
+  do ipoint = 1, n_points_final_grid
+   r1(1:3) = final_grid_points(1:3,ipoint)
+   weight = final_weight_at_r_vector(ipoint)
+!   call grad_j_sum_mu_of_r(r1,r2,jast,grad_jast_mu_r1)
+   call get_grad_j_bump_mu_of_r(r1,r2,grad_jast_mu_r1)
+   double precision :: norm,error
+   norm = 0.D0
+   do k = 1, 3
+    r1bis= r1
+    r1bis(k) += dr
+    jast_p = j_bump(r1bis,r2,a_boys)
+
+    r1bis= r1
+    r1bis(k) -= dr
+    jast_m = j_bump(r1bis,r2,a_boys)
+
+    num_grad_jast_mu_r1(k) = (jast_p - jast_m)/(2.d0* dr)
+    norm += num_grad_jast_mu_r1(k)*num_grad_jast_mu_r1(k)
+   enddo
+   error = 0.d0
+   do k = 1, 3
+    error += dabs(grad_jast_mu_r1(k) - num_grad_jast_mu_r1(k))
+   enddo
+   error *= 0.33333333d0
+   norm = dsqrt(norm)
+   if(norm.gt.1.d-05)then
+    if(dabs(error/norm).gt.dr)then
+     print*,'/////'
+     print*,error,norm
+     print*,grad_jast_mu_r1
+     print*,num_grad_jast_mu_r1
+    endif
+   endif
+   do k = 1,3
+    accu_grad(k) += weight * dabs(grad_jast_mu_r1(k) - num_grad_jast_mu_r1(k))
+   enddo
+  enddo
+ print*,'accu_grad = '
+ print*, accu_grad
+
+end
+
+subroutine routine_test_mu_of_r
+ implicit none
+ integer :: ipoint,k 
+ double precision :: weight, dr, r1(3), r1bis(3),accu_grad(3),num_grad_mu_r1(3)
+ double precision :: mu_r1,dm_r1, mu_der_r1(3), grad_dm_r1(3)
+ double precision :: mu_der_rp(3), grad_dm_rp(3),mu_rp
+ double precision :: mu_der_rm(3), grad_dm_rm(3),mu_rm
+
+ dr = 0.0001d0
+ accu_grad = 0.d0
+  do ipoint = 1, n_points_final_grid
+   r1(1:3) = final_grid_points(1:3,ipoint)
+   weight = final_weight_at_r_vector(ipoint)
+   call grad_mu_of_r_mean_field(r1,mu_r1,dm_r1, mu_der_r1, grad_dm_r1) 
+   do k = 1, 3
+    r1bis= r1
+    r1bis(k) += dr
+    call grad_mu_of_r_mean_field(r1bis,mu_rp, dm_r1, mu_der_rp, grad_dm_r1) 
+
+    r1bis= r1
+    r1bis(k) -= dr
+    call grad_mu_of_r_mean_field(r1bis,mu_rm, dm_r1, mu_der_rm, grad_dm_r1) 
+    num_grad_mu_r1(k) = (mu_rp - mu_rm)/(2.d0* dr)
+!    print*,jast_mu_r1_p,jast_mu_r1_m
+   enddo
+   print*,'/////'
+   print*,mu_der_r1
+   print*,num_grad_mu_r1
+   do k = 1,3
+    accu_grad(k) += weight * dabs(mu_der_r1(k) - num_grad_mu_r1(k))
+   enddo
+  enddo
+ print*,'accu_grad = '
+ print*, accu_grad
+
+end

plugins/local/non_h_ints_mu/deb_j_gauss.irp.f

@@ -0,0 +1,62 @@
+program test_j_mu_of_r
+ implicit none
+! call routine_test_mu_of_r
+ call routine_test_mu_of_r_tot
+end
+
+subroutine routine_test_mu_of_r_tot
+ implicit none
+ integer :: ipoint,k 
+ double precision :: r2(3), weight, dr, r1(3), r1bis(3)
+ double precision :: accu_grad(3)
+ double precision :: jast,grad_jast(3),j_bump,j12_mu
+ double precision :: jast_p,jast_m,num_grad_jast(3)
+
+ dr = 0.00001d0
+ r2 = 0.d0
+ r2(1) =  0.5d0
+ r2(2) = -0.1d0
+ r2(3) =  1.0d0
+ accu_grad = 0.d0
+  do ipoint = 1, n_points_final_grid
+   r1(1:3) = final_grid_points(1:3,ipoint)
+   weight = final_weight_at_r_vector(ipoint)
+   call grad1_j12_mu(r1, r2, grad_jast)
+   grad_jast = - grad_jast
+   double precision :: norm,error
+   norm = 0.D0
+   do k = 1, 3
+    r1bis= r1
+    r1bis(k) += dr
+    jast_p = j12_mu(r1bis, r2)
+
+    r1bis= r1
+    r1bis(k) -= dr
+    jast_m = j12_mu(r1bis, r2)
+
+    num_grad_jast(k) = (jast_p - jast_m)/(2.d0* dr)
+    norm += num_grad_jast(k)*num_grad_jast(k)
+   enddo
+   error = 0.d0
+   do k = 1, 3
+    error += dabs(grad_jast(k) - num_grad_jast(k))
+   enddo
+   error *= 0.33333333d0
+   norm = dsqrt(norm)
+   if(norm.gt.1.d-05)then
+    if(dabs(error/norm).gt.dr)then
+     print*,'/////'
+     print*,error,norm
+     print*,grad_jast
+     print*,num_grad_jast
+    endif
+   endif
+   do k = 1,3
+    accu_grad(k) += weight * dabs(grad_jast(k) - num_grad_jast(k))
+   enddo
+  enddo
+ print*,'accu_grad = '
+ print*, accu_grad
+
+end
+

plugins/local/non_h_ints_mu/deb_j_mu_of_r.irp.f

@@ -0,0 +1,97 @@
+program test_j_mu_of_r
+ implicit none
+! call routine_test_mu_of_r
+ call routine_test_mu_of_r_tot
+end
+
+subroutine routine_test_mu_of_r_tot
+ implicit none
+ integer :: ipoint,k 
+ double precision :: r2(3), weight, dr, r1(3), r1bis(3)
+ double precision :: accu_grad(3)
+ double precision :: jast,grad_jast_mu_r1(3)
+ double precision :: jast_p,jast_m,num_grad_jast_mu_r1(3)
+
+ dr = 0.000001d0
+ r2 = 0.d0
+ r2(1) =  0.5d0
+ r2(2) = -0.1d0
+ r2(3) =  1.0d0
+ accu_grad = 0.d0
+  do ipoint = 1, n_points_final_grid
+   r1(1:3) = final_grid_points(1:3,ipoint)
+   weight = final_weight_at_r_vector(ipoint)
+   call grad_j_sum_mu_of_r(r1,r2,jast,grad_jast_mu_r1)
+   double precision :: norm,error
+   norm = 0.D0
+   do k = 1, 3
+    r1bis= r1
+    r1bis(k) += dr
+    call get_j_sum_mu_of_r(r1bis,r2,jast_p)
+
+    r1bis= r1
+    r1bis(k) -= dr
+    call get_j_sum_mu_of_r(r1bis,r2,jast_m)
+
+    num_grad_jast_mu_r1(k) = (jast_p - jast_m)/(2.d0* dr)
+    norm += num_grad_jast_mu_r1(k)*num_grad_jast_mu_r1(k)
+   enddo
+   error = 0.d0
+   do k = 1, 3
+    error += dabs(grad_jast_mu_r1(k) - num_grad_jast_mu_r1(k))
+   enddo
+   error *= 0.33333333d0
+   norm = dsqrt(norm)
+   if(norm.gt.1.d-05)then
+    if(dabs(error/norm).gt.10.d0*dr)then
+     print*,'/////'
+     print*,error,norm,dabs(error/norm)
+     print*,grad_jast_mu_r1
+     print*,num_grad_jast_mu_r1
+    endif
+   endif
+   do k = 1,3
+    accu_grad(k) += weight * dabs(grad_jast_mu_r1(k) - num_grad_jast_mu_r1(k))
+   enddo
+  enddo
+ print*,'accu_grad = '
+ print*, accu_grad
+
+end
+
+subroutine routine_test_mu_of_r
+ implicit none
+ integer :: ipoint,k 
+ double precision :: weight, dr, r1(3), r1bis(3),accu_grad(3),num_grad_mu_r1(3)
+ double precision :: mu_r1,dm_r1, mu_der_r1(3), grad_dm_r1(3)
+ double precision :: mu_der_rp(3), grad_dm_rp(3),mu_rp
+ double precision :: mu_der_rm(3), grad_dm_rm(3),mu_rm
+
+ dr = 0.0001d0
+ accu_grad = 0.d0
+  do ipoint = 1, n_points_final_grid
+   r1(1:3) = final_grid_points(1:3,ipoint)
+   weight = final_weight_at_r_vector(ipoint)
+   call grad_mu_of_r_mean_field(r1,mu_r1,dm_r1, mu_der_r1, grad_dm_r1) 
+   do k = 1, 3
+    r1bis= r1
+    r1bis(k) += dr
+    call grad_mu_of_r_mean_field(r1bis,mu_rp, dm_r1, mu_der_rp, grad_dm_r1) 
+
+    r1bis= r1
+    r1bis(k) -= dr
+    call grad_mu_of_r_mean_field(r1bis,mu_rm, dm_r1, mu_der_rm, grad_dm_r1) 
+    num_grad_mu_r1(k) = (mu_rp - mu_rm)/(2.d0* dr)
+!    print*,jast_mu_r1_p,jast_mu_r1_m
+   enddo
+   print*,'/////'
+   print*,mu_der_r1
+   print*,num_grad_mu_r1
+   do k = 1,3
+    accu_grad(k) += weight * dabs(mu_der_r1(k) - num_grad_mu_r1(k))
+   enddo
+  enddo
+ print*,'accu_grad = '
+ print*, accu_grad
+
+end

plugins/local/non_h_ints_mu/deb_j_psi.irp.f

@@ -0,0 +1,131 @@
+program test_j_mu_of_r
+ implicit none
+ call routine_deb_j_psi
+! call routine_deb_denom
+end
+
+subroutine routine_deb_j_psi
+ implicit none
+ integer :: ipoint,k 
+ double precision :: r2(3), weight, dr, r1(3), r1bis(3)
+ double precision :: accu_grad(3)
+ double precision :: jast,grad_jast(3),j_bump,jastrow_psi,grad_jast_bis(3)
+ double precision :: jast_p,jast_m,num_grad_jast(3)
+
+ dr = 0.00001d0
+ r2 = 0.d0
+ r2(1) =  0.5d0
+ r2(2) = -0.1d0
+ r2(3) =  1.0d0
+ accu_grad = 0.d0
+  do ipoint = 1, n_points_final_grid
+   r1(1:3) = final_grid_points(1:3,ipoint)
+   weight = final_weight_at_r_vector(ipoint)
+   call get_grad_r1_jastrow_psi(r1,r2,grad_jast,jast)
+!   grad_jast = - grad_jast
+   double precision :: norm,error
+   norm = 0.D0
+   do k = 1, 3
+    r1bis= r1
+    r1bis(k) += dr
+    call get_grad_r1_jastrow_psi(r1bis,r2,grad_jast_bis,jast_p)
+
+    r1bis= r1
+    r1bis(k) -= dr
+    call get_grad_r1_jastrow_psi(r1bis,r2,grad_jast_bis,jast_m)
+
+    num_grad_jast(k) = (jast_p - jast_m)/(2.d0* dr)
+    norm += num_grad_jast(k)*num_grad_jast(k)
+   enddo
+   error = 0.d0
+   do k = 1, 3
+    error += dabs(grad_jast(k) - num_grad_jast(k))
+   enddo
+   error *= 0.33333333d0
+   norm = dsqrt(norm)
+   if(norm.gt.1.d-05)then
+    if(dabs(error/norm).gt.dr)then
+     print*,'/////'
+     print*,error,norm
+     print*,grad_jast
+     print*,num_grad_jast
+    endif
+   endif
+   do k = 1,3
+    accu_grad(k) += weight * dabs(grad_jast(k) - num_grad_jast(k))
+   enddo
+  enddo
+ print*,'accu_grad = '
+ print*, accu_grad
+
+end
+
+
+subroutine routine_deb_denom
+ implicit none
+ integer :: ipoint,k,i,j
+ double precision :: r2(3), weight, dr, r1(3), r1bis(3)
+ double precision :: accu_grad(3)
+ double precision :: jast,grad_jast(3),j_bump,jastrow_psi,grad_jast_bis(3)
+ double precision :: jast_p,jast_m,num_grad_jast(3)
+
+ dr = 0.00001d0
+ r2 = 0.d0
+ r2(1) =  0.5d0
+ r2(2) = -0.1d0
+ r2(3) =  1.0d0
+ double precision, allocatable :: mos_array_r1(:), mos_array_r2(:)
+ double precision, allocatable :: mos_grad_array_r1(:,:),mos_grad_array_r2(:,:)
+ allocate(mos_array_r1(mo_num), mos_array_r2(mo_num))
+ allocate(mos_grad_array_r1(3,mo_num), mos_grad_array_r2(3,mo_num))
+ do i = 1, 1
+  do j = 1, 1
+   accu_grad = 0.d0
+   call give_all_mos_and_grad_at_r(r2,mos_array_r2,mos_grad_array_r2)
+    do ipoint = 1, n_points_final_grid
+     r1(1:3) = final_grid_points(1:3,ipoint)
+     weight = final_weight_at_r_vector(ipoint)
+     call give_all_mos_and_grad_at_r(r1,mos_array_r1,mos_grad_array_r1)
+     call denom_jpsi(i,j,a_boys, mos_array_r1,mos_grad_array_r1,mos_array_r2,jast, grad_jast)
+     double precision :: norm,error
+     norm = 0.D0
+     do k = 1, 3
+      r1bis= r1
+      r1bis(k) += dr
+      call give_all_mos_and_grad_at_r(r1bis,mos_array_r1,mos_grad_array_r1)
+      call denom_jpsi(i,j,a_boys, mos_array_r1,mos_grad_array_r1,mos_array_r2,jast_p, grad_jast_bis)
+  
+      r1bis= r1
+      r1bis(k) -= dr
+      call give_all_mos_and_grad_at_r(r1bis,mos_array_r1,mos_grad_array_r1)
+      call denom_jpsi(i,j,a_boys, mos_array_r1,mos_grad_array_r1,mos_array_r2,jast_m, grad_jast_bis)
+  
+      num_grad_jast(k) = (jast_p - jast_m)/(2.d0* dr)
+      norm += num_grad_jast(k)*num_grad_jast(k)
+     enddo
+     error = 0.d0
+     do k = 1, 3
+      error += dabs(grad_jast(k) - num_grad_jast(k))
+     enddo
+     error *= 0.33333333d0
+     norm = dsqrt(norm)
+     if(norm.gt.1.d-05)then
+      if(dabs(error/norm).gt.dr)then
+       print*,'/////'
+       print*,error,norm
+       print*,grad_jast
+       print*,num_grad_jast
+      endif
+     endif
+     do k = 1,3
+      accu_grad(k) += weight * dabs(grad_jast(k) - num_grad_jast(k))
+     enddo
+    enddo
+   print*,'i,j = ',i,j
+   print*,'accu_grad = '
+   print*, accu_grad
+  enddo
+ enddo
+
+end
+

plugins/local/non_h_ints_mu/j_bump.irp.f

@@ -0,0 +1,90 @@
+double precision function wigner_radius(rho)
+ implicit none
+ include 'constants.include.F'
+ double precision, intent(in) :: rho
+ wigner_radius = 4.d0 * pi * rho * 0.333333333333d0
+ wigner_radius = wigner_radius**(-0.3333333d0)
+end
+
+double precision function j_bump(r1,r2,a)
+ implicit none
+ include 'constants.include.F'
+ double precision, intent(in) :: r1(3),r2(3),a
+ double precision :: inv_a,factor,x_scaled,scalar
+ double precision :: r12
+ r12   = (r1(1) - r2(1))*(r1(1) - r2(1))
+ r12  += (r1(2) - r2(2))*(r1(2) - r2(2))
+ r12  += (r1(3) - r2(3))*(r1(3) - r2(3))
+ r12 = dsqrt(r12)
+ inv_a = 1.d0/a
+ x_scaled = r12*inv_a*inv_sq_pi
+ x_scaled*= x_scaled
+ j_bump = 0.5d0 * (r12-a) * dexp(-x_scaled)
+end
+
+subroutine get_grad_j_bump(x,a,grad)
+ implicit none
+ BEGIN_DOC
+ ! gradient of the Jastrow with a bump
+ !
+ ! j(x,a) = 1/2 * (x-a)* exp[-(x/(a*sqrt(pi)))^2]
+ !
+ ! d/dx j(x,a) = 1/(2 pi a^2) * exp[-(x/(a*sqrt(pi)))^2] * (pi a^2 + 2 a x - 2x^2)
+ END_DOC
+  include 'constants.include.F'
+ double precision, intent(in)  :: x,a
+ double precision, intent(out) :: grad
+ double precision :: inv_a,factor,x_scaled,scalar
+ inv_a = 1.d0/a
+ factor = 0.5d0*inv_pi*inv_a*inv_a 
+ x_scaled = x*inv_a*inv_sq_pi
+ x_scaled*= x_scaled
+ grad = factor * dexp(-x_scaled) * (pi*a*a + 2.d0 * a*x - 2.d0*x*x)
+end
+
+subroutine get_d_da_j_bump(x,a,d_da)
+ implicit none
+ BEGIN_DOC
+ ! Derivative with respect by to the parameter "a" of the Jastrow with a bump
+ !
+ ! j(x,a) = 1/2 * (x-a)* exp[-(x/(a*sqrt(pi)))^2]
+ !
+ ! d/da j(x,a) = - 1/(pi*a^3) * exp[-(x/(a*sqrt(pi)))^2] * (-2 x^3 + 2 a x^2 + pi a^x3)
+ END_DOC
+ include 'constants.include.F'
+ double precision, intent(in)  :: x,a
+ double precision, intent(out) :: d_da
+ double precision :: factor, inv_a,x_scaled,scalar
+ inv_a = 1.d0/a
+ factor = inv_a*inv_a*inv_a*inv_pi
+ x_scaled = x*inv_a*inv_sq_pi
+ x_scaled*= x_scaled
+ d_da = factor * dexp(-x_scaled) * (-2.d0 * x*x*x + 2.d0*x*x*a+pi*a*a*a)
+end
+
+subroutine get_grad_j_bump_mu_of_r(r1,r2,grad_j_bump)
+ implicit none
+ BEGIN_DOC
+ ! d/dx1 j(x,a(r1,r2)) where j(x,a) is the Jastrow with a bump
+ !
+ ! j(x,a) = 1/2 * (x-a)* exp[-(x/(a*sqrt(pi)))^2]
+ !
+ ! a(r1,r2) = [rho(r1) a(r1) + rho(r2) a(r2)]/[rho(r1) + rho(r2)]
+ !
+ ! d/dx1 j(x,a) = d/dx1 j(x,a(r1,r2))
+ END_DOC
+ double precision, intent(in) :: r1(3),r2(3)
+ double precision, intent(out):: grad_j_bump(3)
+ double precision :: r12,r12_vec(3),grad_scal,inv_r12
+ r12_vec = r1 - r2
+ r12   = (r1(1) - r2(1))*(r1(1) - r2(1))
+ r12  += (r1(2) - r2(2))*(r1(2) - r2(2))
+ r12  += (r1(3) - r2(3))*(r1(3) - r2(3))
+ r12 = dsqrt(r12)
+ call get_grad_j_bump(r12,a_boys,grad_scal)
+ if(r12.lt.1.d-10)then
+  grad_j_bump = 0.d0
+ else 
+  grad_j_bump = grad_scal * r12_vec/r12
+ endif
+end

plugins/local/non_h_ints_mu/jast_deriv.irp.f

@@ -31,7 +31,7 @@
   grad1_u12_squared_num = 0.d0
 
   if( ((j2e_type .eq. "Mu") .and. (env_type .eq. "None")) .or. &
-       (j2e_type .eq. "Mur") ) then
+       (j2e_type .eq. "Mur").or.(j2e_type .eq. "Mugauss") .or. (j2e_type .eq. "Murgauss")) then
 
     !$OMP PARALLEL                                                                                    &
     !$OMP DEFAULT (NONE)                                                                              &

plugins/local/non_h_ints_mu/jast_deriv_mu_of_r.irp.f

@@ -0,0 +1,306 @@
+subroutine get_j_sum_mu_of_r(r1,r2,jast)
+ implicit none
+ double precision, intent(in) :: r1(3),r2(3)
+ double precision, intent(out):: jast
+ double precision :: mu_r1, dm_r1, grad_mu_r1(3), grad_dm_r1(3), j_mu_r1
+ double precision :: mu_r2, dm_r2, grad_mu_r2(3), grad_dm_r2(3), j_mu_r2
+ double precision :: j12_mu_input,mu_tot,r12,j_simple
+ jast = 0.d0
+ if(murho_type==0)then
+! J(r1,r2) = [rho(r1) * j(mu(r1),r12) + rho(r2) * j(mu(r2),r12)] / [rho(r1) + rho(r2)]
+  call grad_mu_of_r_mean_field(r1,mu_r1, dm_r1, grad_mu_r1, grad_dm_r1) 
+  call grad_mu_of_r_mean_field(r2,mu_r2, dm_r2, grad_mu_r2, grad_dm_r2) 
+  j_mu_r1 = j12_mu_input(r1, r2, mu_r1)
+  j_mu_r2 = j12_mu_input(r1, r2, mu_r2)
+  if(dm_r1 + dm_r2.lt.1.d-7)return
+  jast = (dm_r1 * j_mu_r1 + dm_r2 * j_mu_r2) / (dm_r1 + dm_r2)
+ else if(murho_type==1)then
+! J(r1,r2) = j(0.5 * (mu(r1)+mu(r2)),r12), MU(r1,r2) = 0.5 *(mu(r1)+mu(r2))
+  call grad_mu_of_r_mean_field(r1,mu_r1, dm_r1, grad_mu_r1, grad_dm_r1) 
+  call grad_mu_of_r_mean_field(r2,mu_r2, dm_r2, grad_mu_r2, grad_dm_r2) 
+  mu_tot = 0.5d0 * (mu_r1 + mu_r2)
+  jast = j12_mu_input(r1, r2, mu_tot)
+ else if(murho_type==2)then
+! MU(r1,r2) = (rho(1) * mu(r1)+ rho(2) * mu(r2))/(rho(1)+rho(2))
+! J(r1,r2) = j(MU(r1,r2),r12)
+  call grad_mu_of_r_mean_field(r1,mu_r1, dm_r1, grad_mu_r1, grad_dm_r1) 
+  call grad_mu_of_r_mean_field(r2,mu_r2, dm_r2, grad_mu_r2, grad_dm_r2) 
+  double precision :: mu_tmp, dm_tot, dm_tot_inv
+  dm_tot = dm_r1**a_boys + dm_r2**a_boys  ! rho(1)**alpha+rho(2)**alpha
+  if(dm_tot.lt.1.d-12)then
+   dm_tot_inv = 1.d+12
+  else
+   dm_tot_inv = 1.d0/dm_tot
+  endif
+  mu_tmp = dm_r1**a_boys * mu_r1 + dm_r2**a_boys * mu_r2 !rho(1)**alpha * mu(r1)+ rho(2)**alpha * mu(r2)
+  mu_tot = nu_erf * mu_tmp*dm_tot_inv ! 
+  r12  = (r1(1) - r2(1)) * (r1(1) - r2(1))
+  r12 += (r1(2) - r2(2)) * (r1(2) - r2(2))
+  r12 += (r1(3) - r2(3)) * (r1(3) - r2(3))
+  r12 = dsqrt(r12)
+  jast = j_simple(r12,mu_tot)
+ endif
+
+end
+
+subroutine grad_j_sum_mu_of_r(r1,r2,jast,grad_jast)
+ implicit none
+  include 'constants.include.F'
+ BEGIN_DOC
+ END_DOC
+ double precision, intent(in) :: r1(3),r2(3)
+ double precision, intent(out):: jast, grad_jast(3)
+ jast = 0.d0
+ grad_jast = 0.d0
+ double precision :: num, denom, grad_num(3), grad_denom(3)
+ double precision :: j_r1, grad_j_r1(3),j_r2, grad_j_r2(3)
+ double precision :: dm_r1, grad_dm_r1(3), grad_jmu_r2(3)
+ double precision :: dm_r2, grad_dm_r2(3),mu_r2, grad_mu_r2(3),mu_r1
+ double precision :: j12_mu_input,r12,grad_mu_r1(3),grad_jmu_r1(3)
+ double precision :: mu_tot,dx,dy,dz,r12_vec(3),d_dmu_j,d_dr12_j
+
+ 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.gt.1.d-10)then
+  r12_vec(1) = dx
+  r12_vec(2) = dy
+  r12_vec(3) = dz
+  r12_vec *= 1.d0/r12
+  ! r12_vec = grad_r1 (r12)
+ else
+  r12 = 1.d-10
+  r12_vec = 0.d0
+ endif
+
+ if(murho_type==0)then
+! J(r1,r2) = [rho(r1) * j(mu(r1),r12) + rho(r2) * j(mu(r2),r12)] / [rho(r1) + rho(r2)]
+! 
+!          = num(r1,r2) / denom(r1,r2)
+!
+! d/dx1 J(r1,r2) = [denom(r1,r2) X d/dx1 num(r1,r2) - num(r1,r2) X d/dx1 denom(r1,r2) ] / denom(r1,r2)^2
+!
+! d/dx1 num(r1,r2) =  j(mu(r1),r12)*d/dx1 rho(r1) + rho(r1) * d/dx1 j(mu(r1),r12) 
+!                   + rho(r2) d/dx1 j(mu(r2),r12)
+! d/dx1 denom(r1,r2) = d/dx1 rho(r1)
+  call grad_j_mu_of_r_1(r1,r2,j_r1, grad_j_r1,dm_r1, grad_dm_r1)
+  call grad_mu_of_r_mean_field(r2,mu_r2, dm_r2, grad_mu_r2, grad_dm_r2) 
+  j_r2 = j12_mu_input(r1, r2, mu_r2) ! j(mu(r2),r1,r2)
+  num = dm_r1 * j_r1 + dm_r2 * j_r2
+  denom = dm_r1 + dm_r2
+  if(denom.lt.1.d-7)return
+  jast = num / denom
+ 
+  grad_denom = grad_dm_r1
+  call grad_j12_mu_input(r1, r2, mu_r2, grad_jmu_r2,r12)
+  grad_num =  j_r1 * grad_dm_r1 + dm_r1 * grad_j_r1 + dm_r2 * grad_jmu_r2
+  grad_jast = (grad_num * denom - num * grad_denom)/(denom*denom)
+ else if(murho_type==1)then
+! J(r1,r2) = j(0.5 * (mu(r1)+mu(r2)),r12), MU(r1,r2) = 0.5 *(mu(r1)+mu(r2))
+!
+! d/dx1 J(r1,r2) = d/dx1 j(MU(r1,r2),r12)|MU=cst 
+!                + d/dMU [j(MU,r12)]
+!                x d/d(mu(r1)) MU(r1,r2)
+!                x d/dx1 mu(r1)
+!                = 0.5 * (1 - erf(MU(r1,r2) *r12))/r12 * (x1 - x2) == grad_jmu_r1
+!                + e^{-(r12*MU(r1,r2))^2}/(2 sqrt(pi) * MU(r1,r2)^2) 
+!                x 0.5 
+!                x d/dx1 mu(r1)
+ call grad_mu_of_r_mean_field(r1,mu_r1, dm_r1, grad_mu_r1, grad_dm_r1)
+ call grad_mu_of_r_mean_field(r2,mu_r2, dm_r2, grad_mu_r2, grad_dm_r2)
+ mu_tot = 0.5d0 * (mu_r1 + mu_r2)
+ call grad_j12_mu_input(r1, r2, mu_tot, grad_jmu_r1,r12)
+ grad_jast = grad_jmu_r1
+ grad_jast+= dexp(-r12*mu_tot*r12*mu_tot) * inv_sq_pi_2 /(mu_tot* mu_tot) * 0.5d0 * grad_mu_r1
+ else if(murho_type==2)then
+! MU(r1,r2) = beta * (rho(1)**alpha * mu(r1)+ rho(2)**alpha * mu(r2))/(rho(1)**alpha+rho(2)**alpha)
+! J(r1,r2) = j(MU(r1,r2),r12)
+!
+! d/dx1 J(r1,r2) = d/dx1 j(MU(r1,r2),r12)|MU=cst 
+!                + d/dMU [j(MU,r12)] 
+!                x d/d(mu(r1)) MU(r1,r2)
+!                x d/dx1 mu(r1)
+!                = 0.5 * (1 - erf(MU(r1,r2) *r12))/r12 * (x1 - x2) == grad_jmu_r1
+!                + 0.5 e^{-(r12*MU(r1,r2))^2}/(2 sqrt(pi) * MU(r1,r2)^2) 
+!                x d/dx1 MU(r1,r2)
+! with d/dx1 MU(r1,r2) = beta * {[mu(1) d/dx1 [rho(1)**alpha] + rho(1)**alpha * d/dx1 mu(1)](rho(1)**alpha+rho(2)**alpha) 
+!                       - MU(1,2) d/dx1 [rho(1)]**alpha}/(rho(1)**alpha+rho(2)**alpha)^2
+! d/dx1 [rho(1)]**alpha = alpha [rho(1)]**(alpha-1) d/dx1 rho(1)
+!                        
+ call grad_mu_of_r_mean_field(r1,mu_r1, dm_r1, grad_mu_r1, grad_dm_r1)
+ call grad_mu_of_r_mean_field(r2,mu_r2, dm_r2, grad_mu_r2, grad_dm_r2)
+ double precision :: dm_tot,dm_tot_inv,grad_mu_tot(3),mu_tmp,grad_dm_r1_alpha(3),d_dx_j
+ dm_tot = dm_r1**a_boys + dm_r2**a_boys  ! rho(1)**alpha+rho(2)**alpha
+ grad_dm_r1_alpha = a_boys * dm_r1**(a_boys-1) * grad_dm_r1
+ if(dm_tot.lt.1.d-12)then
+  dm_tot_inv = 1.d+12
+ else
+  dm_tot_inv = 1.d0/dm_tot
+ endif
+ mu_tmp = dm_r1**a_boys * mu_r1 + dm_r2**a_boys * mu_r2 !rho(1)**alpha * mu(r1)+ rho(2)**alpha * mu(r2)
+ mu_tot = nu_erf * mu_tmp*dm_tot_inv ! 
+ grad_mu_tot = ( mu_r1 * grad_dm_r1_alpha + dm_r1**a_boys * grad_mu_r1 ) * dm_tot & 
+              -  mu_tmp * grad_dm_r1_alpha
+ grad_mu_tot *= dm_tot_inv * dm_tot_inv * nu_erf
+ call get_deriv_r12_j12(r12,mu_tot,d_dr12_j) ! d/dr12 j(MU(r1,r2,r12)
+ ! d/dx1 j(MU(r1,r2),r12) | MU(r1,r2) = cst
+ ! d/dr12 j(MU(r1,r2,r12) x d/dx1 r12
+ grad_jmu_r1 = d_dr12_j * r12_vec 
+! call grad_j12_mu_input(r1, r2, mu_tot, grad_jmu_r1,r12)
+ grad_jast = grad_jmu_r1
+ ! d/dMU j(MU(r1,r2),r12)
+ call get_deriv_mu_j12(r12,mu_tot,d_dmu_j)
+ grad_jast+= d_dmu_j * grad_mu_tot
+ else if(murho_type==-1)then
+! J(r1,r2) = 0.5 * [j(mu(r1),r12) + j(mu(r2),r12)] 
+!
+! d/dx1 J(r1,r2)  = 0.5 * (d/dx1 j(mu(r1),r12) + d/dx1 j(mu(r2),r12))
+  call grad_j_mu_of_r_1(r1,r2,j_r1, grad_j_r1,dm_r1, grad_dm_r1)
+  call grad_mu_of_r_mean_field(r2,mu_r2, dm_r2, grad_mu_r2, grad_dm_r2) 
+  j_r2 = j12_mu_input(r1, r2, mu_r2) ! j(mu(r2),r1,r2)
+  call grad_j12_mu_input(r1, r2, mu_r2, grad_jmu_r2,r12)
+  jast = 0.5d0 * (j_r1 + j_r2)
+  grad_jast = 0.5d0 * (grad_j_r1 + grad_jmu_r2)
+  
+ endif
+
+end
+
+subroutine grad_j_mu_of_r_1(r1,r2,jast, grad_jast, dm_r1, grad_dm_r1)
+ implicit none
+  include 'constants.include.F'
+ BEGIN_DOC
+! grad_r1 of j(mu(r1),r12)
+  !
+  !
+  ! d/dx1 j(mu(r1),r12) = exp(-(mu(r1)*r12)**2) /(2 *sqrt(pi) * mu(r1)**2 ) d/dx1 mu(r1) 
+  !                     + d/dx1 j(mu(r1),r12) 
+  !
+  ! with 
+  !
+  !           j(mu,r12) = 1/2 r12 (1 - erf(mu r12)) - 1/2 (sqrt(pi) * mu) e^{-(mu*r12)^2}
+  !
+  ! and d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2)
+  !
+  !     d/d mu j(mu,r12) = e^{-(r12*mu)^2}/(2 sqrt(pi) * mu^2)
+  !
+  ! here mu(r1) is obtained by MU MEAN FIELD 
+ END_DOC
+ double precision, intent(in) :: r1(3),r2(3)
+ double precision, intent(out):: jast, grad_jast(3),dm_r1, grad_dm_r1(3)
+ double precision :: dx, dy, dz,  r12, mu_der(3)
+ double precision :: mu_tmp, tmp, grad(3), mu_val
+ jast = 0.d0
+ grad = 0.d0
+
+ dx  = r1(1) - r2(1)
+ dy  = r1(2) - r2(2)
+ dz  = r1(3) - r2(3)
+ r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+ ! get mu(r1) == mu_val and its gradient d/dx1 mu(r1) == mu_der 
+ call grad_mu_of_r_mean_field(r1,mu_val, dm_r1, mu_der, grad_dm_r1) 
+ mu_tmp  = mu_val * r12
+ ! evalulation of the jastrow j(mu(r1),r12)
+ jast = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_val
+
+ ! tmp = exp(-(mu(r1)*r12)**2) /(2 *sqrt(pi) * mu(r1)**2 )
+ tmp     = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
+ ! grad = 
+ 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 ! d/dx1 j(mu(r1),r12) 
+ grad(1) = grad(1) + tmp * dx
+ grad(2) = grad(2) + tmp * dy
+ grad(3) = grad(3) + tmp * dz
+
+ grad_jast = grad 
+end
+
+! ---
+
+double precision function j12_mu_input(r1, r2, mu)
+
+  BEGIN_DOC
+  ! j(mu,r12) = 1/2 r12 (1 - erf(mu r12)) - 1/2 (sqrt(pi) * mu) e^{-(mu*r12)^2}
+  END_DOC
+  include 'constants.include.F'
+
+  implicit none
+  double precision, intent(in) :: r1(3), r2(3), mu
+  double precision             :: mu_tmp, r12
+
+    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 * r12
+
+    j12_mu_input = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu
+
+end
+
+subroutine grad_j12_mu_input(r1, r2, mu, grad_jmu,r12)
+ implicit none
+ BEGIN_DOC
+ ! grad_jmu = d/dx1 j(mu,r12) assuming mu=cst(r1)
+ !
+ !          = 0.5/r_12 * (x_1 - x_2) * [1 - erf(mu*r12)]
+ END_DOC
+ double precision, intent(in) :: r1(3), r2(3), mu
+ double precision, intent(out):: grad_jmu(3),r12
+ double precision             :: mu_tmp, dx, dy, dz, grad(3), tmp
+ grad_jmu = 0.d0
+ 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
+ mu_tmp  = mu * r12
+ tmp     = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12 ! d/dx1 j(mu(r1),r12) 
+ grad(1) = tmp * dx
+ grad(2) = tmp * dy
+ grad(3) = tmp * dz
+
+ grad_jmu = grad 
+end
+
+subroutine j12_and_grad_j12_mu_input(r1, r2, mu, jmu, grad_jmu)
+ implicit none
+ include 'constants.include.F'
+ BEGIN_DOC
+ ! jmu = j(mu,r12) 
+ ! grad_jmu = d/dx1 j(mu,r12) assuming mu=cst(r1)
+ !
+ !          = 0.5/r_12 * (x_1 - x_2) * [1 - erf(mu*r12)]
+ END_DOC
+ double precision, intent(in) :: r1(3), r2(3), mu
+ double precision, intent(out):: grad_jmu(3), jmu
+ double precision             :: mu_tmp, r12, dx, dy, dz, grad(3), tmp
+ double precision :: erfc_mur12,inv_mu
+ inv_mu = 1.d0/mu
+
+ grad_jmu = 0.d0 ! initialization when r12 --> 0
+ jmu = - inv_sq_pi_2 * inv_mu ! initialization when r12 --> 0
+
+ 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
+ erfc_mur12 = (1.d0 - derf(mu_tmp))
+ mu_tmp  = mu * r12
+ tmp     = 0.5d0 * erfc_mur12  / r12 ! d/dx1 j(mu(r1),r12) 
+ grad(1) = tmp * dx
+ grad(2) = tmp * dy
+ grad(3) = tmp * dz
+
+ grad_jmu = grad 
+
+ jmu= 0.5d0 * r12 * erfc_mur12 - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) * inv_mu
+
+
+end

plugins/local/non_h_ints_mu/jast_deriv_utils.irp.f

@@ -1,8 +1,73 @@
+subroutine get_deriv_r12_j12(x,mu,d_dx_j)
+ implicit none
+  include 'constants.include.F'
+ BEGIN_DOC
+ ! d/dr12 j(mu,r12)
+ END_DOC
+ double precision, intent(in)  :: x,mu
+ double precision, intent(out) :: d_dx_j
+ 
+ d_dx_j = 0.d0
+ if(x .lt. 1d-10) return
+ if(j2e_type .eq. "Mu" .or. j2e_type .eq. "Mur") then
+  d_dx_j = 0.5d0 * (1.d0 - derf(mu * x))
+ else if(j2e_type .eq. "Mugauss" .or. j2e_type .eq. "Murgauss" ) then
+  double precision :: x_tmp
+  x_tmp = mu * x
+  ! gradient of j(mu,x)
+  d_dx_j = 0.5d0 * (1.d0 - derf(x_tmp))
+
+  ! gradient of gaussian additional term
+  x_tmp *= alpha_mu_gauss
+  x_tmp *= x_tmp 
+  d_dx_j += -0.5d0 * mu * c_mu_gauss * x * dexp(-x_tmp)
+ else
+   print *, ' Error in get_deriv_r12_j12: Unknown j2e_type = ', j2e_type
+   stop
+ endif
+end
+
+
+subroutine get_deriv_mu_j12(x,mu,d_d_mu)
+ implicit none
+ BEGIN_DOC
+ ! d/dmu j(mu,r12)
+ END_DOC
+  include 'constants.include.F'
+ double precision, intent(in)  :: x,mu
+ double precision, intent(out) :: d_d_mu
+ double precision :: x_tmp,inv_mu_2,inv_alpha_2
+ 
+ d_d_mu = 0.d0
+ if(x .lt. 1d-10) return
+ x_tmp = x*mu
+ if(mu.lt.1.d-10) return
+ inv_mu_2 = mu*mu
+ inv_mu_2 = 1.d0/inv_mu_2
+ if(j2e_type .eq. "Mu" .or. j2e_type .eq. "Mur") then
+  ! e^{-(r12*mu)^2}/(2 sqrt(pi) * mu^2)
+  d_d_mu = dexp(-x_tmp*x_tmp) * inv_sq_pi_2 * inv_mu_2
+ else if(j2e_type .eq. "Mugauss"  .or. j2e_type .eq. "Murgauss" ) then
+  d_d_mu  = dexp(-x_tmp*x_tmp) * inv_sq_pi_2 * inv_mu_2
+  inv_alpha_2 = 1.d0/alpha_mu_gauss
+  inv_alpha_2 *= inv_alpha_2
+  x_tmp *= alpha_mu_gauss
+  x_tmp *= x_tmp
+  d_d_mu += -0.25d0 * c_mu_gauss*inv_alpha_2*dexp(-x_tmp) * (1.d0 + 2.d0 * x_tmp) * inv_mu_2
+ else
+   print *, ' Error in get_deriv_r12_j12: Unknown j2e_type = ', j2e_type
+   stop
+ endif
+end
+
 
 ! ---
 
 double precision function j12_mu(r1, r2)
 
+  BEGIN_DOC
+  ! j(mu,r12) = 1/2 r12 (1 - erf(mu r12)) - 1/2 (sqrt(pi) * mu) e^{-(mu*r12)^2}
+  END_DOC
   include 'constants.include.F'
 
   implicit none
@@ -18,6 +83,18 @@ double precision function j12_mu(r1, r2)
 
     j12_mu = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
 
+  else if(j2e_type .eq. "Mugauss") 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)) )
+    double precision :: r12_tmp
+    r12_tmp = mu_erf * r12
+
+    j12_mu = 0.5d0 * r12 * (1.d0 - derf(r12_tmp)) - inv_sq_pi_2 * dexp(-r12_tmp*r12_tmp) / mu_erf
+    r12_tmp *= alpha_mu_gauss
+    j12_mu += 0.25d0 * c_mu_gauss / (alpha_mu_gauss*alpha_mu_gauss*mu_erf) * dexp(-r12_tmp*r12_tmp)
+
   else
 
     print *, ' Error in j12_mu: Unknown j2e_type = ', j2e_type
@@ -57,7 +134,7 @@ subroutine grad1_j12_mu(r1, r2, grad)
 
   grad = 0.d0
 
-  if(j2e_type .eq. "Mu") then
+  if(j2e_type .eq. "Mu".or.j2e_type .eq. "Mugauss") then
 
     dx = r1(1) - r2(1)
     dy = r1(2) - r2(2)
@@ -66,31 +143,42 @@ subroutine grad1_j12_mu(r1, r2, grad)
     r12 = dsqrt(dx * dx + dy * dy + dz * dz)
     if(r12 .lt. 1d-10) return
 
-    tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
+    call get_deriv_r12_j12(r12,mu_erf,tmp)
+!    tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
 
     grad(1) = tmp * dx
     grad(2) = tmp * dy
     grad(3) = tmp * dz
+    grad *= 1.d0/r12
 
-  elseif(j2e_type .eq. "Mur") then
+  elseif(j2e_type .eq. "Mur" .or. j2e_type .eq. "Murgauss") then
+   double precision :: jast
+   call grad_j_sum_mu_of_r(r1,r2,jast,grad)
+ 
+  elseif(j2e_type .eq. "Bump") then
+   double precision ::grad_jast(3)
+   call get_grad_j_bump_mu_of_r(r1,r2,grad_jast)
+     dx = r1(1) - r2(1)
+     dy = r1(2) - r2(2)
+     dz = r1(3) - r2(3)
 
-    dx  = r1(1) - r2(1)
+     r12 = dsqrt(dx * dx + dy * dy + dz * dz)
-    dy  = r1(2) - r2(2)
+     if(r12 .lt. 1d-10) then
-    dz  = r1(3) - r2(3)
+       grad(1) = 0.d0
-    r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+       grad(2) = 0.d0
+       grad(3) = 0.d0
+       return
+     endif                                                                                                                                                                            
 
-    call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
+     tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
-    mu_tmp  = mu_val * r12
+
-    tmp     = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
+     grad(1) = 0.5d0 * tmp * dx
-    grad(1) = tmp * mu_der(1)
+     grad(2) = 0.5d0 * tmp * dy
-    grad(2) = tmp * mu_der(2)
+     grad(3) = 0.5d0 * tmp * dz
-    grad(3) = tmp * mu_der(3)
+     grad(1) += 0.5d0 * grad_jast(1)
+     grad(2) += 0.5d0 * grad_jast(2)
+     grad(3) += 0.5d0 * grad_jast(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
 
@@ -369,7 +457,18 @@ end
 ! ---
 
 subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
-
+ BEGIN_DOC
+! various flavours of mu(r1,r2) 
+! depends on essentially the density and other related quantities 
+!
+! change the variable "murho_type" to change type
+!
+!  murho_type == -1 :: mu(r1,r2) = (rho(r1) mu_mf(r1) + rho(r2) mu_mf(r2))/[rho(r1)+rho(r2)]
+!
+!             ==  0 :: mu(r1,r2) = (sqrt(rho(r1)) mu_mf(r1) + sqrt(rho(r2)) mu_mf(r2))/[sqrt(rho(r1))+sqrt(rho(r2))]
+!             
+!             == -2 :: mu(r1,r2) = 0.5(mu_mf(r1) + mu_mf(r2))
+ END_DOC
   implicit none
   double precision, intent(in)  :: r1(3), r2(3)
   double precision, intent(out) :: mu_val, mu_der(3)
@@ -379,11 +478,50 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der)
   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
+  double precision :: mu_mf_r1, dm_r1, grad_mu_mf_r1(3), grad_dm_r1(3)
+  double precision :: mu_mf_r2, dm_r2, grad_mu_mf_r2(3), grad_dm_r2(3)
+
+  double precision :: num, denom, grad_denom(3), grad_num(3)
+  double precision :: dsqrt_dm_r1
 
   PROVIDE murho_type
   PROVIDE mu_r_ct mu_erf
 
-  if(murho_type .eq. 1) then
+  if(murho_type .eq. 0) then 
+   call grad_mu_of_r_mean_field(r1,mu_mf_r1, dm_r1, grad_mu_mf_r1, grad_dm_r1)
+   call grad_mu_of_r_mean_field(r2,mu_mf_r2, dm_r2, grad_mu_mf_r2, grad_dm_r2)
+   dsqrt_dm_r1 = dsqrt(dm_r1)
+   denom = (dsqrt_dm_r1 + dsqrt(dm_r2) )
+   if(denom.lt.1.d-7)then
+    mu_val = 1.d+10
+    mu_der = 0.d0
+    return
+   endif
+   num = (dsqrt(dm_r1) * mu_mf_r1 + dsqrt(dm_r2) * mu_mf_r2) 
+   mu_val = num / denom
+   grad_denom = grad_dm_r1/dsqrt_dm_r1
+   grad_num = dsqrt(dm_r1) * grad_mu_mf_r1 + mu_mf_r1 * grad_dm_r1
+   mu_der = (grad_num * denom - num * grad_denom)/(denom*denom)
+  else if(murho_type .eq. -1) then
+   call grad_mu_of_r_mean_field(r1,mu_mf_r1, dm_r1, grad_mu_mf_r1, grad_dm_r1)
+   call grad_mu_of_r_mean_field(r2,mu_mf_r2, dm_r2, grad_mu_mf_r2, grad_dm_r2)
+   denom = (dm_r1 + dm_r2 )
+   if(denom.lt.1.d-7)then
+    mu_val = 1.d+10
+    mu_der = 0.d0
+    return
+   endif
+   num = (dm_r1 * mu_mf_r1 + dm_r2 * mu_mf_r2) 
+   mu_val = num / denom
+   grad_denom = grad_dm_r1
+   grad_num = dm_r1 * grad_mu_mf_r1 + mu_mf_r1 * grad_dm_r1
+   mu_der = (grad_num * denom - num * grad_denom)/(denom*denom)
+  else if(murho_type .eq. -2) then
+   call grad_mu_of_r_mean_field(r1,mu_mf_r1, dm_r1, grad_mu_mf_r1, grad_dm_r1)
+   call grad_mu_of_r_mean_field(r2,mu_mf_r2, dm_r2, grad_mu_mf_r2, grad_dm_r2)
+   mu_val = 0.5d0 * (mu_mf_r1 + mu_mf_r2) 
+   mu_der = 0.5d0 * grad_mu_mf_r1
+  else if(murho_type .eq. 1) then
 
     !
     ! r = 0.5 (r1 + r2)

plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f

@@ -33,8 +33,12 @@ subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res)
   r1(2) = final_grid_points(2,ipoint)
   r1(3) = final_grid_points(3,ipoint)
 
-  if( (j2e_type .eq. "Mu")  .or. &
+  if( (j2e_type .eq. "Mu")        .or. &
-      (j2e_type .eq. "Mur") .or. &
+      (j2e_type .eq. "Mur")       .or. &
+      (j2e_type .eq. "Jpsi")   .or. &
+      (j2e_type .eq. "Mugauss")   .or. &
+      (j2e_type .eq. "Murgauss")  .or. &
+      (j2e_type .eq. "Bump")      .or. &
       (j2e_type .eq. "Boys") ) then
 
     if(env_type .eq. "None") then
@@ -206,7 +210,43 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
       gradz(jpoint) = tmp * dz
     enddo
 
-  elseif(j2e_type .eq. "Mur") then
+  else if(j2e_type .eq. "Mugauss") then
+
+    !  d/dx1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12 - mu*c*r12*exp(-(mu*alpha*r12)^2] * (x1 - x2)
+
+    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
+
+      double precision :: r12_tmp
+      r12_tmp = mu_erf * r12
+      ! gradient of j(mu,r12)
+      tmp = 0.5d0 * (1.d0 - derf(r12_tmp)) / r12
+      ! gradient of gaussian additional term
+      r12_tmp *= alpha_mu_gauss
+      r12_tmp *= r12_tmp 
+      tmp += -0.5d0 * mu_erf * c_mu_gauss * r12 * dexp(-r12_tmp)/r12
+
+      gradx(jpoint) = tmp * dx
+      grady(jpoint) = tmp * dy
+      gradz(jpoint) = tmp * dz
+    enddo
+
+  elseif(j2e_type .eq. "Mur".or.j2e_type .eq. "Murgauss") then
 
     ! 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)
@@ -216,31 +256,46 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
       r2(1) = final_grid_points_extra(1,jpoint)
       r2(2) = final_grid_points_extra(2,jpoint)
       r2(3) = final_grid_points_extra(3,jpoint)
+      double precision :: jast, grad_jast(3)
+      call grad_j_sum_mu_of_r(r1,r2,jast,grad_jast)
+      gradx(jpoint) = grad_jast(1)
+      grady(jpoint) = grad_jast(2)
+      gradz(jpoint) = grad_jast(3)
+    enddo
+  elseif(j2e_type .eq. "Bump") then
+
+    ! d/dx1 jbump(r1,r2)
+
+    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)
+      call get_grad_j_bump_mu_of_r(r1,r2,grad_jast)
+
+      dx = r1(1) - r2(1)
+      dy = r1(2) - r2(2)
+      dz = r1(3) - r2(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)
-      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
+        gradx(jpoint) = 0.d0 
-        grady(jpoint) = 0.d0
+        grady(jpoint) = 0.d0 
-        gradz(jpoint) = 0.d0
+        gradz(jpoint) = 0.d0 
         cycle
       endif
 
-      tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12
+      tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
 
-      gradx(jpoint) = gradx(jpoint) + tmp * dx
+      gradx(jpoint) = 0.5d0 * tmp * dx
-      grady(jpoint) = grady(jpoint) + tmp * dy
+      grady(jpoint) = 0.5d0 * tmp * dy
-      gradz(jpoint) = gradz(jpoint) + tmp * dz
+      gradz(jpoint) = 0.5d0 * tmp * dz
+      gradx(jpoint) += 0.5d0 * grad_jast(1)
+      grady(jpoint) += 0.5d0 * grad_jast(2)
+      gradz(jpoint) += 0.5d0 * grad_jast(3)
+!      gradx(jpoint) =  grad_jast(1)
+!      grady(jpoint) =  grad_jast(2)
+!      gradz(jpoint) =  grad_jast(3)
     enddo
 
   elseif(j2e_type .eq. "Boys") then
@@ -335,9 +390,6 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
           npA = jBH_n(p,i_nucl)
           opA = jBH_o(p,i_nucl)
           tmp = jBH_c(p,i_nucl)
-          if(mpA .eq. npA) then
-            tmp = tmp * 0.5d0
-          endif
 
           tmp1 = double_p(mpA) * f1A_power(mpA-1) * f2A_power(npA) + double_p(npA) * f1A_power(npA-1) * f2A_power(mpA)
           tmp1 = tmp1 * g12_power(opA) * tmp
@@ -366,6 +418,17 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
       enddo ! i_nucl
     enddo ! jpoint
 
+  elseif(j2e_type .eq. "Jpsi") then
+   double precision :: grad_j_psi_r1(3),jast_psi
+   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)
+     call get_grad_r1_jastrow_psi(r1,r2,grad_j_psi_r1,jast_psi)
+     gradx(jpoint) = grad_j_psi_r1(1)
+     grady(jpoint) = grad_j_psi_r1(2)
+     gradz(jpoint) = grad_j_psi_r1(3)
+   enddo
   else
 
     print *, ' Error in grad1_j12_r1_seq: Unknown j2e_type = ', j2e_type
@@ -669,8 +732,12 @@ subroutine get_grad1_u12_2e_r1_seq(ipoint, n_grid2, resx, resy, resz)
   r1(2) = final_grid_points(2,ipoint)
   r1(3) = final_grid_points(3,ipoint)
 
-  if( (j2e_type .eq. "Mu")  .or. &
+  if( (j2e_type .eq. "Mu")        .or. &
-      (j2e_type .eq. "Mur") .or. &
+      (j2e_type .eq. "Mugauss")   .or. &
+      (j2e_type .eq. "Mur")       .or. &
+      (j2e_type .eq. "Jpsi")       .or. &
+      (j2e_type .eq. "Murgauss")  .or. &
+      (j2e_type .eq. "Bump")      .or. &
       (j2e_type .eq. "Boys") ) then
 
     if(env_type .eq. "None") then
@@ -787,8 +854,11 @@ subroutine get_u12_2e_r1_seq(ipoint, n_grid2, res)
   r1(2) = final_grid_points(2,ipoint)
   r1(3) = final_grid_points(3,ipoint)
 
-  if( (j2e_type .eq. "Mu")  .or. &
+  if( (j2e_type .eq. "Mu")        .or. &
-      (j2e_type .eq. "Mur") .or. &
+      (j2e_type .eq. "Mur")       .or. &
+      (j2e_type .eq. "Mugauss")  .or. &
+      (j2e_type .eq. "Murgauss")  .or. &
+      (j2e_type .eq. "Mugauss")   .or. &
       (j2e_type .eq. "Boys") ) then
 
     if(env_type .eq. "None") then

plugins/local/non_h_ints_mu/jastrow_psi.irp.f

@@ -0,0 +1,124 @@
+BEGIN_PROVIDER [ double precision, c_ij_ab_jastrow, (mo_num, mo_num, elec_alpha_num, elec_beta_num)]
+ implicit none
+ integer :: iunit, getUnitAndOpen
+ c_ij_ab_jastrow = 0.d0
+ iunit = getUnitAndOpen(trim(ezfio_work_dir)//'c_ij_ab', 'R')                                                     
+ read(iunit) c_ij_ab_jastrow
+ close(iunit)
+ print*,'c_ij_ab_jastrow = '
+ integer :: i,j,a,b
+ do i = 1, elec_beta_num ! r2
+  do j = 1, elec_alpha_num ! r1
+   do a = elec_beta_num+1, mo_num ! r2
+    do b = elec_alpha_num+1, mo_num ! r1 
+!     print*,b,a,j,i
+     print*,c_ij_ab_jastrow(b,a,j,i),b,a,j,i
+     if(dabs(c_ij_ab_jastrow(b,a,j,i)).lt.1.d-12)then
+      c_ij_ab_jastrow(b,a,j,i) = 0.d0
+     endif
+    enddo
+   enddo
+  enddo
+ enddo
+END_PROVIDER 
+
+double precision function jastrow_psi(r1,r2)
+ implicit none
+ double precision, intent(in) :: r1(3), r2(3)
+ integer :: i,j,a,b
+ double precision, allocatable :: mos_array_r1(:), mos_array_r2(:)
+ allocate(mos_array_r1(mo_num), mos_array_r2(mo_num))
+ call give_all_mos_at_r(r1,mos_array_r1)
+ call give_all_mos_at_r(r2,mos_array_r2)
+ double precision :: eps,coef, numerator,denominator
+ double precision :: phi_i_phi_j
+ eps = a_boys
+ jastrow_psi= 0.d0
+ do i = 1, elec_beta_num ! r1
+  do j = 1, elec_alpha_num ! r2
+   phi_i_phi_j = mos_array_r1(i) * mos_array_r2(j) + eps
+   denominator = 1.d0/phi_i_phi_j
+   do a = elec_beta_num+1, mo_num ! r1
+    do b = elec_alpha_num+1, mo_num ! r2 
+     coef = c_ij_ab_jastrow(b,a,j,i)
+     numerator = mos_array_r2(b) * mos_array_r1(a)
+     jastrow_psi += coef * numerator*denominator
+    enddo
+   enddo
+  enddo
+ enddo
+end
+
+subroutine get_grad_r1_jastrow_psi(r1,r2,grad_j_psi_r1,jast)
+ implicit none
+ double precision, intent(in) :: r1(3), r2(3)
+ double precision, intent(out):: grad_j_psi_r1(3),jast
+ integer :: i,j,a,b
+ double precision, allocatable :: mos_array_r1(:), mos_array_r2(:)
+ double precision, allocatable :: mos_grad_array_r1(:,:),mos_grad_array_r2(:,:)
+ double precision :: num_j, denom_j, num_j_grad(3), denom_j_grad(3),delta,coef
+ double precision :: inv_denom_j
+ allocate(mos_array_r1(mo_num), mos_array_r2(mo_num))
+ allocate(mos_grad_array_r1(3,mo_num), mos_grad_array_r2(3,mo_num))
+ delta = a_boys
+ call give_all_mos_and_grad_at_r(r1,mos_array_r1,mos_grad_array_r1)
+ call give_all_mos_and_grad_at_r(r2,mos_array_r2,mos_grad_array_r2)
+ grad_j_psi_r1 = 0.d0
+ jast = 0.d0
+ do i = 1, elec_beta_num ! r1
+  do j = 1, elec_alpha_num ! r2
+   call denom_jpsi(i,j,delta,mos_array_r1,mos_grad_array_r1,mos_array_r2,denom_j, denom_j_grad)
+   inv_denom_j = 1.d0/denom_j
+   do a = elec_beta_num+1, mo_num ! r1
+    do b = elec_alpha_num+1, mo_num ! r2 
+     call numerator_psi(a,b,mos_array_r1,mos_grad_array_r1,mos_array_r2,num_j, num_j_grad)
+     coef = c_ij_ab_jastrow(b,a,j,i)
+     jast += coef * num_j * inv_denom_j
+     grad_j_psi_r1 += coef * (num_j_grad * denom_j - num_j * denom_j_grad) * inv_denom_j * inv_denom_j
+    enddo
+   enddo
+  enddo
+ enddo
+ if(jast.lt.-1.d0.or.dabs(jast).gt.1.d0)then
+  print*,'pb ! '
+  print*,jast
+  print*,dsqrt(r1(1)**2+r1(2)**2+r1(3)**2),dsqrt(r2(1)**2+r2(2)**2+r2(3)**2)
+  print*,r1
+!  print*,mos_array_r1(1:2)
+  print*,r2
+!  print*,mos_array_r2(1:2)
+  stop
+ endif
+ if(log_jpsi)then
+  grad_j_psi_r1 = grad_j_psi_r1/(1.d0 + jast)
+ endif
+
+end
+
+
+subroutine denom_jpsi(i,j,delta,mos_array_r1,mos_grad_array_r1,mos_array_r2,denom, grad_denom)
+ implicit none
+ integer, intent(in)           :: i,j
+ double precision, intent(in)  :: mos_array_r1(mo_num),mos_grad_array_r1(3,mo_num),mos_array_r2(mo_num),delta
+ double precision, intent(out) :: denom, grad_denom(3)
+ double precision :: coef,phi_i_phi_j,inv_phi_i_phi_j,inv_phi_i_phi_j_2
+ phi_i_phi_j = mos_array_r1(i) * mos_array_r2(j)
+ if(phi_i_phi_j /= 0.d0)then
+  inv_phi_i_phi_j   = 1.d0/phi_i_phi_j
+  inv_phi_i_phi_j_2 = 1.d0/(phi_i_phi_j * phi_i_phi_j)
+ else
+  inv_phi_i_phi_j   = huge(1.0)
+  inv_phi_i_phi_j_2 = huge(1.d0)
+ endif
+ denom         = phi_i_phi_j + delta * inv_phi_i_phi_j
+ grad_denom(:) = (1.d0 - delta*inv_phi_i_phi_j_2) * mos_array_r2(j) * mos_grad_array_r1(:,i)
+end
+
+subroutine numerator_psi(a,b,mos_array_r1,mos_grad_array_r1,mos_array_r2,num, grad_num)
+ implicit none
+ integer, intent(in)           :: a,b
+ double precision, intent(in)  :: mos_array_r1(mo_num),mos_grad_array_r1(3,mo_num),mos_array_r2(mo_num)
+ double precision, intent(out) :: num, grad_num(3)
+ num = mos_array_r1(a) * mos_array_r2(b)
+ grad_num(:) = mos_array_r2(b) * mos_grad_array_r1(:,a)
+end

plugins/local/non_h_ints_mu/mu_of_r.irp.f

@@ -0,0 +1,43 @@
+
+subroutine grad_mu_of_r_mean_field(r,mu_mf, dm, grad_mu_mf, grad_dm)
+ implicit none
+ BEGIN_DOC
+ ! returns the value and gradients of the mu(r) mean field, together with the HF density and its gradients. 
+ END_DOC
+ include 'constants.include.F'
+ double precision, intent(in) :: r(3)
+ double precision, intent(out):: grad_mu_mf(3), grad_dm(3)
+ double precision, intent(out):: mu_mf, dm
+ double precision :: grad_f_mf_ab(3), grad_two_bod_dens(3),grad_dm_a(3), grad_dm_b(3)
+ double precision :: f_mf_ab,two_bod_dens, dm_a, dm_b
+ 
+ double precision :: dist
+ call get_grad_f_mf_ab(r,grad_f_mf_ab, grad_two_bod_dens,f_mf_ab,two_bod_dens, dm_a, dm_b,grad_dm_a, grad_dm_b)
+ 
+ dm = dm_a + dm_b
+ grad_dm(1:3) = grad_dm_a(1:3) + grad_dm_b(1:3)
+
+ if(dabs(two_bod_dens).lt.1.d-10)then
+  mu_mf = 1.d+10
+  grad_mu_mf = 0.d0
+ else
+  if(mu_of_r_tc=="Erfmu")then
+   mu_mf           = 0.3333333333d0 * sqpi * (f_mf_ab/two_bod_dens + 0.25d0)
+   grad_mu_mf(1:3) = 0.3333333333d0 * sqpi * (grad_f_mf_ab(1:3) * two_bod_dens - f_mf_ab * grad_two_bod_dens(1:3))& 
+                                    /(two_bod_dens*two_bod_dens)
+  else if(mu_of_r_tc=="Standard")then
+   mu_mf = 0.5d0 * sqpi * f_mf_ab/two_bod_dens
+   grad_mu_mf(1:3) = 0.5d0 * sqpi * (grad_f_mf_ab(1:3) * two_bod_dens - f_mf_ab * grad_two_bod_dens(1:3))& 
+                                    /(two_bod_dens*two_bod_dens)
+  else if(mu_of_r_tc=="Erfmugauss")then
+   mu_mf = (f_mf_ab/two_bod_dens + 0.25d0)/c_mu_gauss_tot 
+   grad_mu_mf(1:3) = 1.d0/c_mu_gauss_tot* (grad_f_mf_ab(1:3) * two_bod_dens - f_mf_ab * grad_two_bod_dens(1:3))& 
+                                    /(two_bod_dens*two_bod_dens)
+  else 
+   print*,'Wrong value for mu_of_r_tc !'
+   stop
+  endif
+ endif 
+
+end
+

plugins/local/non_h_ints_mu/mu_of_r_mean_field.irp.f

@@ -57,6 +57,9 @@ end
 
 subroutine get_grad_f_mf_ab(r,grad_f_mf_ab, grad_two_bod_dens,f_mf_ab,two_bod_dens, dm_a, dm_b,grad_dm_a, grad_dm_b)
  implicit none
+ BEGIN_DOC
+ ! gradient of mu(r) mean field, together with the gradient of the one- and two-body HF density. 
+ END_DOC
  double precision, intent(in)  :: r(3)
  double precision, intent(out) :: f_mf_ab, two_bod_dens
  double precision, intent(out) :: grad_two_bod_dens(3), grad_f_mf_ab(3)
@@ -146,26 +149,18 @@ subroutine mu_of_r_mean_field(r,mu_mf, dm)
  endif
 end
 
-subroutine grad_mu_of_r_mean_field(r,mu_mf, dm, grad_mu_mf, grad_dm)
+subroutine mu_of_r_mean_field_tc(r,mu_mf, dm)
  implicit none
- include 'constants.include.F'
+  include 'constants.include.F'
  double precision, intent(in) :: r(3)
- double precision, intent(out):: grad_mu_mf(3), grad_dm(3)
  double precision, intent(out):: mu_mf, dm
- double precision :: grad_f_mf_ab(3), grad_two_bod_dens(3),grad_dm_a(3), grad_dm_b(3)
  double precision :: f_mf_ab,two_bod_dens, dm_a, dm_b
- call get_grad_f_mf_ab(r,grad_f_mf_ab, grad_two_bod_dens,f_mf_ab,two_bod_dens, dm_a, dm_b,grad_dm_a, grad_dm_b)
+ call get_f_mf_ab(r,f_mf_ab,two_bod_dens, dm_a, dm_b)
-
  dm = dm_a + dm_b
- grad_dm(1:3) = grad_dm_a(1:3) + grad_dm_b(1:3)
-
  if(dabs(two_bod_dens).lt.1.d-10)then
   mu_mf = 1.d+10
-  grad_mu_mf = 0.d0
  else
-  mu_mf = 0.5d0 * sqpi * f_mf_ab/two_bod_dens
+  mu_mf = 0.3333333333d0 * sqpi * (f_mf_ab/two_bod_dens + 0.25d0)
-  grad_mu_mf(1:3) = 0.5d0 * sqpi * (grad_f_mf_ab(1:3) * two_bod_dens - f_mf_ab * grad_two_bod_dens(1:3))& 
+ endif
-                                   /(two_bod_dens*two_bod_dens)
- endif 
-
 end
+

plugins/local/non_h_ints_mu/plot_j_gauss.irp.f

@@ -0,0 +1,59 @@
+program plot_j_gauss
+ implicit none
+ double precision :: xmin, xmax, x, dx
+ double precision :: mu_min, mu_max, mu, d_mu
+ double precision :: pot_j_gauss,j_mu_simple,j_gauss_simple,pot_j_mu
+ double precision, allocatable :: mu_tab(:),j_mu(:),j_mu_gauss(:)
+ double precision, allocatable :: w_mu(:), w_mu_gauss(:)
+
+ character*(128) :: output
+ integer :: getUnitAndOpen
+ integer :: i_unit_output_wee_gauss,i_unit_output_wee_mu
+ integer :: i_unit_output_j_gauss,i_unit_output_j_mu
+ output=trim(ezfio_filename)//'.w_ee_mu_gauss'
+ i_unit_output_wee_gauss = getUnitAndOpen(output,'w')
+ output=trim(ezfio_filename)//'.w_ee_mu'
+ i_unit_output_wee_mu = getUnitAndOpen(output,'w')
+ output=trim(ezfio_filename)//'.j_mu_gauss'
+ i_unit_output_j_gauss = getUnitAndOpen(output,'w')
+ output=trim(ezfio_filename)//'.j_mu'
+ i_unit_output_j_mu = getUnitAndOpen(output,'w')
+
+ integer :: npt, i, j, n_mu
+ n_mu = 3
+ allocate(mu_tab(n_mu),j_mu(n_mu),j_mu_gauss(n_mu),w_mu(n_mu), w_mu_gauss(n_mu))
+ mu_min = 0.5d0
+ mu_max = 2.d0
+ d_mu = (mu_max - mu_min)/dble(n_mu)
+ mu = mu_min
+ do i = 1, n_mu
+  mu_tab(i) = mu
+  print*,'mu = ',mu
+  mu += d_mu
+ enddo
+ mu_tab(1) = 0.9d0
+ mu_tab(2) = 0.95d0
+ mu_tab(3) = 1.d0
+
+ xmin = 0.01d0
+ xmax = 10.d0
+ npt = 1000
+ dx = (xmax - xmin)/dble(npt)
+ x = xmin
+ do i = 1, npt
+  do j = 1, n_mu
+   mu = mu_tab(j)
+   w_mu_gauss(j) = pot_j_gauss(x,mu)
+   w_mu(j) = pot_j_mu(x,mu)
+   j_mu(j) = j_mu_simple(x,mu)
+   j_mu_gauss(j) = j_gauss_simple(x,mu) + j_mu(j)
+  enddo
+  write(i_unit_output_wee_gauss,'(100(F16.10,X))')x,w_mu_gauss(:)
+  write(i_unit_output_wee_mu,'(100(F16.10,X))')x,w_mu(:)
+  write(i_unit_output_j_gauss,'(100(F16.10,X))')x,j_mu_gauss(:)
+  write(i_unit_output_j_mu,'(100(F16.10,X))')x,j_mu(:)
+  x += dx
+ enddo
+
+
+end

plugins/local/non_h_ints_mu/plot_mo.irp.f

@@ -0,0 +1,19 @@
+program plot_mo
+ implicit none
+ integer :: i,npt
+ double precision :: xmin,xmax,dx,r(3)
+ double precision,allocatable :: mos_array(:)
+ allocate(mos_array(mo_num))
+ npt = 10000
+ xmin =0.d0
+ xmax =10.d0
+ dx=(xmax-xmin)/dble(npt)
+ r=0.d0
+ r(1) = xmin
+ do i = 1, npt
+  call give_all_mos_at_r(r,mos_array)
+  write(33,'(100(F16.10,X))')r(1),mos_array(1),mos_array(2),mos_array(3)
+  r(1) += dx
+ enddo
+
+end

plugins/local/non_h_ints_mu/plot_mu_of_r.irp.f

@@ -16,15 +16,16 @@ subroutine routine_print
  integer :: ipoint,nx,i
  double precision :: xmax,xmin,r(3),dx,sigma
  double precision :: mu_val, mu_der(3),dm_a,dm_b,grad,grad_dm_a(3), grad_dm_b(3)
- xmax =  5.D0
+ xmax =  3.9D0
- xmin = -5.D0
+ xmin = -3.9D0
  nx = 10000
  dx = (xmax - xmin)/dble(nx)
  r = 0.d0
  r(1) = xmin
  do ipoint = 1, nx
-  call mu_r_val_and_grad(r, r, mu_val, mu_der)
+!  call mu_r_val_and_grad(r, r, mu_val, mu_der)
-  call density_and_grad_alpha_beta(r,dm_a,dm_b, grad_dm_a, grad_dm_b)
+  call grad_mu_of_r_mean_field(r,mu_val, dm_a, mu_der, grad_dm_a)
+!  call density_and_grad_alpha_beta(r,dm_a,dm_b, grad_dm_a, grad_dm_b)
   sigma = 0.d0
   do i = 1,3
    sigma += grad_dm_a(i)**2
@@ -32,7 +33,8 @@ subroutine routine_print
   sigma=dsqrt(sigma)
   grad = mu_der(1)**2 + mu_der(2)**2 + mu_der(3)**2 
   grad = dsqrt(grad)
-  write(i_unit_output,'(100(F16.7,X))')r(1),mu_val,dm_a+dm_b,grad,sigma/dm_a
+  print*,r(1),mu_val
+  write(i_unit_output,'(100(F16.7,X))')r(1),mu_val,dm_a,grad,sigma/dm_a
   r(1) += dx
  enddo
 end

plugins/local/non_h_ints_mu/pot_j_gauss.irp.f

@@ -0,0 +1,146 @@
+double precision function j_simple(x,mu)
+ implicit none
+ double precision, intent(in) :: x,mu
+ double precision :: j_mu_simple,j_gauss_simple
+ if(j2e_type .eq. "Mu".or.j2e_type .eq. "Mur") then
+  j_simple = j_mu_simple(x,mu)
+ else if(j2e_type .eq. "Mugauss".or.j2e_type .eq. "Murgauss") then
+  j_simple = j_gauss_simple(x,mu) + j_mu_simple(x,mu)
+ endif
+end
+
+
+double precision function j_mu_simple(x,mu)
+ implicit none
+ double precision, intent(in):: x,mu
+ include 'constants.include.F'
+ BEGIN_DOC
+! j_mu(mu,x) = 0.5 x (1 - erf(mu x)) - 1/[2 sqrt(pi)mu] exp(-(x*mu)^2)
+ END_DOC
+ j_mu_simple = 0.5d0 * x * (1.D0 - derf(mu*x)) - 0.5d0 * inv_sq_pi/mu *  dexp(-x*mu*x*mu)
+
+end
+
+double precision function j_gauss_simple(x,mu)
+ implicit none
+ double precision, intent(in):: x,mu
+ include 'constants.include.F'
+ BEGIN_DOC
+! j_mu(mu,x) = c/[4 alpha^2 mu] exp(-(alpha * mu * x)^2)
+!      with c = 27/(8 sqrt(pi)), alpha=3/2
+ END_DOC
+ double precision :: x_tmp
+ x_tmp = alpha_mu_gauss * mu * x
+ j_gauss_simple = 0.25d0 * c_mu_gauss / (alpha_mu_gauss*alpha_mu_gauss*mu) * dexp(-x_tmp*x_tmp)
+
+end
+
+double precision function j_mu_deriv(x,mu)
+ implicit none
+ BEGIN_DOC
+! d/dx j_mu(mu,x) = d/dx 0.5 x (1 - erf(mu x)) - 1/[2 sqrt(pi)mu] exp(-(x*mu)^2)
+!              = 0.5*(1 - erf(mu x))
+ END_DOC
+ include 'constants.include.F'
+ double precision, intent(in) :: x,mu
+ j_mu_deriv = 0.5d0 * (1.d0 - derf(mu*x))
+end
+
+double precision function j_mu_deriv_2(x,mu)
+ implicit none
+ BEGIN_DOC
+! d^2/dx^2 j_mu(mu,x) = d^2/dx^2 0.5 x (1 - erf(mu x)) - 1/[2 sqrt(pi)mu] exp(-(x*mu)^2)
+!                  = -mu/sqrt(pi) * exp(-(mu x)^2)
+ END_DOC
+ include 'constants.include.F'
+ double precision, intent(in) :: x,mu
+ j_mu_deriv_2 = - mu * inv_sq_pi * dexp(-x*mu*x*mu)
+end
+
+double precision function j_gauss_deriv(x,mu)
+ implicit none
+ include 'constants.include.F'
+ double precision, intent(in) :: x,mu
+ BEGIN_DOC
+! d/dx j_gauss(mu,x) = d/dx c/[4 alpha^2 mu] exp(-(alpha * mu * x)^2)
+!      with c = 27/(8 sqrt(pi)), alpha=3/2
+!                    = -0.5 * mu *  c * x * exp(-(alpha * mu * x)^2)
+ END_DOC
+ double precision :: x_tmp
+ x_tmp = alpha_mu_gauss * mu * x
+ j_gauss_deriv = -0.5d0 * mu * c_mu_gauss * x * exp(-x_tmp*x_tmp)
+end
+
+double precision function j_gauss_deriv_2(x,mu)
+ implicit none
+ include 'constants.include.F'
+ double precision, intent(in) :: x,mu
+ BEGIN_DOC
+! d/dx j_gauss(mu,x) = d/dx c/[4 alpha^2 mu] exp(-(alpha * mu * x)^2)
+!      with c = 27/(8 sqrt(pi)), alpha=3/2
+!                    = 0.5 * mu *  c * exp(-(alpha * mu * x)^2) * (2 (alpha*mu*x)^2 - 1)
+ END_DOC
+ double precision :: x_tmp
+ x_tmp = alpha_mu_gauss * mu * x
+ x_tmp = x_tmp * x_tmp
+ j_gauss_deriv_2 = 0.5d0 * mu * c_mu_gauss * exp(-x_tmp) * (2.d0*x_tmp - 1.d0)
+end
+
+double precision function j_erf_gauss_deriv(x,mu)
+ implicit none
+ double precision, intent(in) :: x,mu
+ BEGIN_DOC
+! d/dx (j_gauss(mu,x)+j_mu(mu,x)) 
+ END_DOC
+ double precision :: j_gauss_deriv,j_mu_deriv
+ j_erf_gauss_deriv = j_gauss_deriv(x,mu)+j_mu_deriv(x,mu)
+end
+
+double precision function j_erf_gauss_deriv_2(x,mu)
+ implicit none
+ double precision, intent(in) :: x,mu
+ BEGIN_DOC
+! d^2/dx^2 (j_gauss(mu,x)+j_mu(mu,x)) 
+ END_DOC
+ double precision :: j_gauss_deriv_2,j_mu_deriv_2
+ j_erf_gauss_deriv_2 = j_gauss_deriv_2(x,mu)+j_mu_deriv_2(x,mu)
+end
+
+
+double precision function pot_j_gauss(x,mu)
+ implicit none
+ double precision, intent(in) :: x,mu
+ BEGIN_DOC
+ ! effective scalar potential associated with the erf_gauss correlation factor
+ ! 
+ ! 1/x( 1 - 2 * d/dx j_erf_gauss(x,mu)) - d^2/dx^2 j_erf_gauss(x,mu)) - d/dx d/dx (j_erf_gauss(x,mu))^2
+ END_DOC
+ double precision :: j_erf_gauss_deriv_2,j_erf_gauss_deriv
+ double precision :: deriv_1, deriv_2
+ pot_j_gauss = 0.d0
+ if(x.ne.0.d0)then
+  deriv_1 = j_erf_gauss_deriv(x,mu)
+  deriv_2 = j_erf_gauss_deriv_2(x,mu)
+  pot_j_gauss = 1.d0/x * (1.d0 - 2.d0 * deriv_1) - deriv_1 * deriv_1 - deriv_2
+ endif
+
+end
+
+double precision function pot_j_mu(x,mu)
+ implicit none
+ double precision, intent(in) :: x,mu
+ BEGIN_DOC
+ ! effective scalar potential associated with the correlation factor
+ ! 
+ ! 1/x( 1 - 2 * d/dx j_erf(x,mu)) - d^2/dx^2 j_erf(x,mu)) - d/dx d/dx (j_erf(x,mu))^2
+ END_DOC
+ double precision :: j_mu_deriv_2,j_mu_deriv
+ double precision :: deriv_1, deriv_2
+ pot_j_mu = 0.d0
+ if(x.ne.0.d0)then
+  deriv_1 = j_mu_deriv(x,mu)
+  deriv_2 = j_mu_deriv_2(x,mu)
+  pot_j_mu= 1.d0/x * (1.d0 - 2.d0 * deriv_1) - deriv_1 * deriv_1 - deriv_2
+ endif
+
+end

plugins/local/non_h_ints_mu/print_jastrow_psi.irp.f

@@ -0,0 +1,15 @@
+program print_j_psi
+ implicit none
+ integer :: i,j,a,b
+ do i = 1, elec_beta_num ! r2
+  do j = 1, elec_alpha_num ! r1
+   do a = elec_beta_num+1, mo_num ! r2
+    do b = elec_alpha_num+1, mo_num ! r1 
+     print*,b,a,j,i
+     print*,c_ij_ab_jastrow(b,a,j,i)
+    enddo
+   enddo
+  enddo
+ enddo
+
+end

plugins/local/non_h_ints_mu/tc_integ.irp.f

@@ -127,8 +127,8 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_f
         ! TODO combine 1shot & int2_grad1_u12_ao_num
         PROVIDE int2_grad1_u12_ao_num
         int2_grad1_u12_ao = int2_grad1_u12_ao_num
-        !PROVIDE int2_grad1_u12_ao_num_1shot
+!         PROVIDE int2_grad1_u12_ao_num_1shot
-        !int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot
+!         int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot
       endif
 
     elseif(tc_integ_type .eq. "semi-analytic") then
@@ -204,7 +204,7 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_f
     print*, ' Writing int2_grad1_u12_ao in ', trim(ezfio_filename) // '/work/int2_grad1_u12_ao'
 
     open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="write")
-    call ezfio_set_work_empty(.False.)
+      call ezfio_set_work_empty(.False.)
       write(11) int2_grad1_u12_ao
     close(11)
     call ezfio_set_tc_keywords_io_tc_integ('Read')

plugins/local/non_h_ints_mu/test_mu_of_r_tc.irp.f

@@ -0,0 +1,157 @@
+program test_mu_of_r_tc
+  implicit none
+  BEGIN_DOC
+! TODO
+  END_DOC
+  ! You specify that you want to avoid any contribution from 
+  ! orbitals coming from core 
+ call test_grad_f_mean_field
+ call test_grad_mu_mf
+ call plot_mu_of_r_mf
+end
+
+
+subroutine test_grad_f_mean_field
+ implicit none
+ integer :: i_point,k
+ double precision :: weight,r(3)
+ double precision :: grad_f_mf_ab(3), grad_two_bod_dens(3)
+ double precision :: grad_dm_a(3), grad_dm_b(3)
+ double precision :: f_mf_ab,two_bod_dens, dm_a, dm_b
+
+ double precision :: num_grad_f_mf_ab(3), num_grad_two_bod_dens(3)
+ double precision :: num_grad_dm_a(3), num_grad_dm_b(3)
+ double precision :: f_mf_ab_p,f_mf_ab_m
+ double precision :: two_bod_dens_p, two_bod_dens_m
+ double precision :: dm_a_p, dm_a_m
+ double precision :: dm_b_p, dm_b_m
+ double precision :: rbis(3), dr
+ double precision :: accu_grad_f_mf_ab(3),accu_grad_two_bod_dens(3)
+ double precision :: accu_grad_dm_a(3),accu_grad_dm_b(3)
+ double precision :: accu_f_mf_ab, accu_two_bod_dens, accu_dm_a, accu_dm_b
+ dr = 0.00001d0
+ accu_f_mf_ab = 0.d0 
+ accu_two_bod_dens = 0.d0 
+ accu_dm_a = 0.d0 
+ accu_dm_b = 0.d0
+
+ accu_grad_f_mf_ab = 0.d0
+ accu_grad_two_bod_dens = 0.d0
+ accu_grad_dm_a = 0.d0
+ accu_grad_dm_b = 0.d0
+ do i_point = 1, n_points_final_grid
+  r(1:3)   = final_grid_points(1:3,i_point)
+  weight = final_weight_at_r_vector(i_point)
+  call get_grad_f_mf_ab(r,grad_f_mf_ab, grad_two_bod_dens,f_mf_ab,two_bod_dens, dm_a, dm_b,grad_dm_a, grad_dm_b)
+  call get_f_mf_ab(r,f_mf_ab_p,two_bod_dens_p, dm_a_p, dm_b_p)
+  accu_f_mf_ab += weight * dabs(f_mf_ab - f_mf_ab_p)
+  accu_two_bod_dens += weight * dabs(two_bod_dens - two_bod_dens_p)
+  accu_dm_a += weight*dabs(dm_a - dm_a_p)
+  accu_dm_b += weight*dabs(dm_b - dm_b_p)
+  do k = 1, 3
+   rbis = r
+   rbis(k) += dr
+   call get_f_mf_ab(rbis,f_mf_ab_p,two_bod_dens_p, dm_a_p, dm_b_p)
+   rbis = r
+   rbis(k) -= dr
+   call get_f_mf_ab(rbis,f_mf_ab_m,two_bod_dens_m, dm_a_m, dm_b_m)
+   num_grad_f_mf_ab(k) = (f_mf_ab_p - f_mf_ab_m)/(2.d0*dr)
+   num_grad_two_bod_dens(k) = (two_bod_dens_p - two_bod_dens_m)/(2.d0*dr)
+   num_grad_dm_a(k) = (dm_a_p - dm_a_m)/(2.d0*dr)
+   num_grad_dm_b(k) = (dm_b_p - dm_b_m)/(2.d0*dr)
+  enddo
+  do k = 1, 3
+   accu_grad_f_mf_ab(k) += weight * dabs(grad_f_mf_ab(k) - num_grad_f_mf_ab(k))
+   accu_grad_two_bod_dens(k) += weight * dabs(grad_two_bod_dens(k) - num_grad_two_bod_dens(k))
+   accu_grad_dm_a(k) += weight * dabs(grad_dm_a(k) - num_grad_dm_a(k))
+   accu_grad_dm_b(k) += weight * dabs(grad_dm_b(k) - num_grad_dm_b(k))
+  enddo
+ enddo
+ print*,'accu_f_mf_ab = ',accu_f_mf_ab
+ print*,'accu_two_bod_dens = ',accu_two_bod_dens
+ print*,'accu_dm_a = ',accu_dm_a
+ print*,'accu_dm_b = ',accu_dm_b
+ print*,'accu_grad_f_mf_ab = '
+ print*,accu_grad_f_mf_ab
+ print*,'accu_grad_two_bod_dens = '
+ print*,accu_grad_two_bod_dens
+ print*,'accu_dm_a = '
+ print*,accu_grad_dm_a
+ print*,'accu_dm_b = '
+ print*,accu_grad_dm_b
+
+end
+
+subroutine test_grad_mu_mf
+ implicit none
+ integer :: i_point,k
+ double precision :: weight,r(3),rbis(3)
+ double precision :: mu_mf, dm,grad_mu_mf(3), grad_dm(3)
+ double precision :: mu_mf_p, mu_mf_m, dm_m, dm_p, num_grad_mu_mf(3),dr, num_grad_dm(3)
+ double precision :: accu_mu, accu_dm, accu_grad_dm(3), accu_grad_mu_mf(3)
+ dr = 0.00001d0
+ accu_grad_mu_mf = 0.d0
+ accu_mu = 0.d0
+ accu_grad_dm = 0.d0
+ accu_dm = 0.d0
+ do i_point = 1, n_points_final_grid
+  r(1:3)   = final_grid_points(1:3,i_point)
+  weight = final_weight_at_r_vector(i_point)
+  call grad_mu_of_r_mean_field(r,mu_mf, dm, grad_mu_mf, grad_dm)
+  call mu_of_r_mean_field(r,mu_mf_p, dm_p)
+  accu_mu += weight*dabs(mu_mf_p - mu_mf)
+  accu_dm += weight*dabs(dm_p - dm)
+  do k = 1, 3
+   rbis = r
+   rbis(k) += dr
+   call mu_of_r_mean_field(rbis,mu_mf_p, dm_p)
+   rbis = r
+   rbis(k) -= dr
+   call mu_of_r_mean_field(rbis,mu_mf_m, dm_m)
+
+   num_grad_mu_mf(k) = (mu_mf_p - mu_mf_m)/(2.d0*dr)
+   num_grad_dm(k) = (dm_p - dm_m)/(2.d0*dr)
+  enddo
+  do k = 1, 3
+   accu_grad_dm(k)+= weight *dabs(num_grad_dm(k) - grad_dm(k))
+   accu_grad_mu_mf(k)+= weight *dabs(num_grad_mu_mf(k) - grad_mu_mf(k))
+  enddo
+ enddo
+ print*,'accu_mu = ',accu_mu
+ print*,'accu_dm = ',accu_dm
+ print*,'accu_grad_dm = '
+ print*, accu_grad_dm
+ print*,'accu_grad_mu_mf = '
+ print*, accu_grad_mu_mf
+
+end
+
+subroutine plot_mu_of_r_mf
+ implicit none
+  include 'constants.include.F'
+ integer :: ipoint,npoint
+ double precision :: dx,r(3),xmax,xmin
+ double precision :: accu_mu,accu_nelec,mu_mf, dm,mu_mf_tc
+ character*(128) :: output
+ integer :: i_unit_output,getUnitAndOpen
+ output=trim(ezfio_filename)//'.mu_mf'
+ i_unit_output = getUnitAndOpen(output,'w')
+ xmax = 5.D0
+ xmin = 0.d0
+ npoint = 10000
+ dx = (xmax - xmin)/dble(npoint)
+ r = 0.d0
+ r(1) = xmin
+ accu_mu = 0.d0
+ accu_nelec = 0.d0
+ do ipoint = 1, npoint
+  call mu_of_r_mean_field(r,mu_mf, dm)
+  call mu_of_r_mean_field_tc(r,mu_mf_tc, dm)
+  write(i_unit_output,'(100(F16.10,X))')r(1),mu_mf,mu_mf_tc,dm
+  accu_mu    += mu_mf * dm * r(1)**2*dx*4.D0*pi
+  accu_nelec +=         dm * r(1)**2*dx*4.D0*pi
+  r(1) += dx
+ enddo
+ print*,'nelec      = ',accu_nelec
+ print*,'mu average = ',accu_mu/accu_nelec
+end

plugins/local/non_h_ints_mu/total_tc_int.irp.f

@@ -118,7 +118,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
       !$OMP END PARALLEL
       call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0                 &
                 , int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
-                , 0.d0, ao_two_e_tc_tot, ao_num*ao_num)
+                , 0.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
       deallocate(c_mat)
     endif
   

plugins/local/slater_tc/slater_tc_opt.irp.f

@@ -129,9 +129,9 @@ subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree,
 
   endif
 
-  if(degree==0) then
+! if(degree==0) then
-    htot += nuclear_repulsion
+!   htot += nuclear_repulsion
-  endif
+! endif
 
 end
 

plugins/local/tc_bi_ortho/tc_utils.irp.f

@@ -8,9 +8,13 @@ subroutine write_tc_energy()
   double precision              :: E_1e, E_2e, E_3e
   double precision, allocatable :: E_TC_tmp(:), E_1e_tmp(:), E_2e_tmp(:), E_3e_tmp(:)
 
+  call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
+
   ! GS 
   ! ---
 
+  call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
+
   allocate(E_TC_tmp(N_det), E_1e_tmp(N_det), E_2e_tmp(N_det), E_3e_tmp(N_det))
 
   !$OMP PARALLEL                                                                &

plugins/local/tc_int/EZFIO.cfg

@@ -0,0 +1,36 @@
+[nxBlocks]
+type: integer
+doc: nb of x blocks in the Grid
+interface: ezfio,provider,ocaml
+default: 10
+
+[nyBlocks]
+type: integer
+doc: nb of y blocks in the Grid
+interface: ezfio,provider,ocaml
+default: 1
+
+[nzBlocks]
+type: integer
+doc: nb of z blocks in the Grid
+interface: ezfio,provider,ocaml
+default: 1
+
+[blockxSize]
+type: integer
+doc: size of x blocks
+interface: ezfio,provider,ocaml
+default: 32
+
+[blockySize]
+type: integer
+doc: size of y blocks
+interface: ezfio,provider,ocaml
+default: 1
+
+[blockzSize]
+type: integer
+doc: size of z blocks
+interface: ezfio,provider,ocaml
+default: 1
+

plugins/local/tc_int/LIB

@@ -0,0 +1 @@
+-lcutcint

plugins/local/tc_int/NEED

@@ -4,3 +4,4 @@ jastrow
 qmckl
 becke_numerical_grid
 dft_utils_in_r
+bi_ortho_mos

plugins/local/tc_int/compute_int_2e_ao_cpu.irp.f

@@ -0,0 +1,233 @@
+
+! ---
+
+program compute_int_2e_ao_cpu
+
+  implicit none
+
+  print *, ' j2e_type = ', j2e_type
+  print *, ' j1e_type = ', j1e_type
+  print *, ' env_type = ', env_type
+
+  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
+
+  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_grid, 'radial  external grid over')
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+  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')
+
+  call main()
+
+end
+
+! ---
+
+subroutine main()
+
+  use cutc_module
+
+  implicit none
+
+  integer                       :: m
+  integer                       :: i, j, k, l
+  integer                       :: ipoint, jpoint
+
+  double precision              :: weight1, ao_i_r, ao_k_r
+
+  double precision              :: time0, time1
+  double precision              :: wall_time0, wall_time1
+  double precision              :: wall_ttime0, wall_ttime1
+  double precision              :: tt1, tt2
+
+  double precision, allocatable :: rn(:,:), aos_data1(:,:,:), aos_data2(:,:,:)
+  double precision, allocatable :: grad1_u12(:,:,:), int_fct_long_range(:,:,:), c_mat(:,:,:)
+  double precision, allocatable :: int2_grad1_u12_ao(:,:,:,:)
+  double precision, allocatable :: int_2e_ao(:,:,:,:)
+
+
+  call wall_time(time0)
+  print*, ' start compute_int_2e_ao_cpu'
+
+
+  ! ---
+
+  allocate(rn(3,nucl_num))
+  allocate(aos_data1(n_points_final_grid,ao_num,4))
+  allocate(aos_data2(n_points_extra_final_grid,ao_num,4))
+
+  do k = 1, nucl_num
+    rn(1,k) = nucl_coord(k,1)
+    rn(2,k) = nucl_coord(k,2)
+    rn(3,k) = nucl_coord(k,3)
+  enddo
+
+  do k = 1, ao_num
+    do ipoint = 1, n_points_final_grid
+      aos_data1(ipoint,k,1) = aos_in_r_array(k,ipoint)
+      aos_data1(ipoint,k,2) = aos_grad_in_r_array(k,ipoint,1)
+      aos_data1(ipoint,k,3) = aos_grad_in_r_array(k,ipoint,2)
+      aos_data1(ipoint,k,4) = aos_grad_in_r_array(k,ipoint,3)
+    enddo
+  enddo
+
+  do k = 1, ao_num
+    do ipoint = 1, n_points_extra_final_grid
+      aos_data2(ipoint,k,1) = aos_in_r_array_extra(k,ipoint)
+      aos_data2(ipoint,k,2) = aos_grad_in_r_array_extra(k,ipoint,1)
+      aos_data2(ipoint,k,3) = aos_grad_in_r_array_extra(k,ipoint,2)
+      aos_data2(ipoint,k,4) = aos_grad_in_r_array_extra(k,ipoint,3)
+    enddo
+  enddo
+
+
+  allocate(int_fct_long_range(n_points_extra_final_grid,ao_num,ao_num))
+  allocate(grad1_u12(n_points_extra_final_grid,n_points_final_grid,4))
+  allocate(c_mat(n_points_final_grid,ao_num,ao_num))
+  allocate(int2_grad1_u12_ao(ao_num,ao_num,n_points_final_grid,4))
+  allocate(int_2e_ao(ao_num,ao_num,ao_num,ao_num))
+
+  call wall_time(wall_time0)
+
+  call wall_time(wall_ttime0)
+  !$OMP PARALLEL               &
+  !$OMP DEFAULT (NONE)         &
+  !$OMP PRIVATE (j, i, jpoint) &
+  !$OMP SHARED (int_fct_long_range, 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
+        int_fct_long_range(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
+  call wall_time(wall_ttime1)
+  write(*,"(A,2X,F15.7)") ' wall time for int_long_range (sec) = ', (wall_ttime1 - wall_ttime0)
+
+
+  call wall_time(wall_ttime0)
+  !$OMP PARALLEL         &
+  !$OMP DEFAULT (NONE)   &
+  !$OMP PRIVATE (ipoint) &
+  !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, grad1_u12)
+  !$OMP DO
+  do ipoint = 1, n_points_final_grid
+    call get_grad1_u12_for_tc(ipoint, n_points_extra_final_grid, grad1_u12(1,ipoint,1) &
+                                                               , grad1_u12(1,ipoint,2) &
+                                                               , grad1_u12(1,ipoint,3) &
+                                                               , grad1_u12(1,ipoint,4) )
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+  call wall_time(wall_ttime1)
+  write(*,"(A,2X,F15.7)") ' wall time for tc_int_bh (sec) = ', (wall_ttime1 - wall_ttime0)
+
+
+  call wall_time(wall_ttime0)
+  do m = 1, 4
+    call dgemm("T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, 1.d0                      &
+              , int_fct_long_range(1,1,1), n_points_extra_final_grid, grad1_u12(1,1,m), n_points_extra_final_grid &
+              , 0.d0, int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num)
+  enddo
+  call wall_time(wall_ttime1)
+  write(*,"(A,2X,F15.7)") ' wall time for DGEMM of integ over r2 (sec) = ', (wall_ttime1 - wall_ttime0)
+
+
+  call wall_time(wall_ttime0)
+  !$OMP PARALLEL               &
+  !$OMP DEFAULT (NONE)         &
+  !$OMP PRIVATE (i, k, ipoint) &
+  !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector)
+  !$OMP DO SCHEDULE (static)
+  do i = 1, ao_num
+    do k = 1, ao_num
+      do ipoint = 1, n_points_final_grid
+        c_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k)
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+  call wall_time(wall_ttime1)
+  write(*,"(A,2X,F15.7)") ' wall time of Hermitian part (sec) = ', (wall_ttime1 - wall_ttime0)
+
+
+  call wall_time(wall_ttime0)
+  call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0            &
+            , int2_grad1_u12_ao(1,1,1,4), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
+            , 0.d0, int_2e_ao(1,1,1,1), ao_num*ao_num)
+  call wall_time(wall_ttime1)
+  write(*,"(A,2X,F15.7)") ' wall time for DGEMM of Hermitian part (sec) = ', (wall_ttime1 - wall_ttime0)
+
+
+  tt1 = 0.d0
+  tt2 = 0.d0
+  do m = 1, 3
+
+    call wall_time(wall_ttime0)
+    !$OMP PARALLEL                                                              &
+    !$OMP DEFAULT (NONE)                                                        &
+    !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r)                       &
+    !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, c_mat, &
+    !$OMP         ao_num, n_points_final_grid, final_weight_at_r_vector, m)
+    !$OMP DO SCHEDULE (static)
+    do i = 1, ao_num
+      do k = 1, ao_num
+        do ipoint = 1, n_points_final_grid
+
+          weight1 = final_weight_at_r_vector(ipoint)
+          ao_i_r  = aos_in_r_array_transp(ipoint,i)
+          ao_k_r  = aos_in_r_array_transp(ipoint,k)
+
+          c_mat(ipoint,k,i) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,m) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,m))
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+    call wall_time(wall_ttime1)
+    tt1 += wall_ttime1 - wall_ttime0
+
+    call wall_time(wall_ttime0)
+    call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -0.5d0          &
+              , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
+              , 1.d0, int_2e_ao(1,1,1,1), ao_num*ao_num)
+    call wall_time(wall_ttime1)
+    tt2 += wall_ttime1 - wall_ttime0
+  enddo
+  write(*,"(A,2X,F15.7)") ' wall time of non-Hermitian part (sec) = ', tt1
+  write(*,"(A,2X,F15.7)") ' wall time for DGEMM of non Hermitian part (sec) = ', tt2
+
+
+  call wall_time(wall_ttime0)
+  call sum_A_At(int_2e_ao(1,1,1,1), ao_num*ao_num)
+  call wall_time(wall_ttime1)
+  write(*,"(A,2X,F15.7)") ' wall time of A + A.T (sec) = ', wall_ttime1 - wall_ttime0
+
+
+  call wall_time(wall_time1)
+  write(*,"(A,2X,F15.7)") ' wall time on cpu (sec) = ', (wall_time1 - wall_time0)
+
+
+  deallocate(int_fct_long_range, grad1_u12, c_mat)
+  deallocate(int_2e_ao, int2_grad1_u12_ao)
+  deallocate(rn, aos_data1, aos_data2)
+
+  call wall_time(time1)
+  write(*,"(A,2X,F15.7)") ' wall time for compute_int_2e_ao_cpu (sec) = ', (time1 - time0)
+
+  return
+end

plugins/local/tc_int/compute_int_2e_ao_gpu.irp.f

@@ -0,0 +1,117 @@
+
+! ---
+
+program compute_int_2e_ao_gpu
+
+  implicit none
+
+  print *, ' j2e_type = ', j2e_type
+  print *, ' j1e_type = ', j1e_type
+  print *, ' env_type = ', env_type
+
+  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
+
+  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_grid, 'radial  external grid over')
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+  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')
+
+  call main()
+
+end
+
+! ---
+
+subroutine main()
+
+  use cutc_module
+
+  implicit none
+
+  integer                       :: i, j, k, l
+  integer                       :: ipoint
+
+  double precision              :: time0, time1
+
+  double precision, allocatable :: rn(:,:), aos_data1(:,:,:), aos_data2(:,:,:)
+  double precision, allocatable :: int2_grad1_u12_ao_gpu(:,:,:,:)
+  double precision, allocatable :: int_2e_ao_gpu(:,:,:,:)
+
+
+  call wall_time(time0)
+  print*, ' start compute_int_2e_ao_gpu'
+
+
+  ! ---
+
+  allocate(rn(3,nucl_num))
+  allocate(aos_data1(n_points_final_grid,ao_num,4))
+  allocate(aos_data2(n_points_extra_final_grid,ao_num,4))
+
+  do k = 1, nucl_num
+    rn(1,k) = nucl_coord(k,1)
+    rn(2,k) = nucl_coord(k,2)
+    rn(3,k) = nucl_coord(k,3)
+  enddo
+
+  do k = 1, ao_num
+    do ipoint = 1, n_points_final_grid
+      aos_data1(ipoint,k,1) = aos_in_r_array(k,ipoint)
+      aos_data1(ipoint,k,2) = aos_grad_in_r_array(k,ipoint,1)
+      aos_data1(ipoint,k,3) = aos_grad_in_r_array(k,ipoint,2)
+      aos_data1(ipoint,k,4) = aos_grad_in_r_array(k,ipoint,3)
+    enddo
+  enddo
+
+  do k = 1, ao_num
+    do ipoint = 1, n_points_extra_final_grid
+      aos_data2(ipoint,k,1) = aos_in_r_array_extra(k,ipoint)
+      aos_data2(ipoint,k,2) = aos_grad_in_r_array_extra(k,ipoint,1)
+      aos_data2(ipoint,k,3) = aos_grad_in_r_array_extra(k,ipoint,2)
+      aos_data2(ipoint,k,4) = aos_grad_in_r_array_extra(k,ipoint,3)
+    enddo
+  enddo
+
+  ! ---
+
+  integer :: nB
+  integer :: sB
+
+  PROVIDE nxBlocks nyBlocks nzBlocks
+  PROVIDE blockxSize blockySize blockzSize
+
+  sB = 32
+  nB = (n_points_final_grid + sB - 1) / sB
+
+  call ezfio_set_tc_int_blockxSize(sB)
+  call ezfio_set_tc_int_nxBlocks(nB)
+
+  allocate(int2_grad1_u12_ao_gpu(ao_num,ao_num,n_points_final_grid,3))
+  allocate(int_2e_ao_gpu(ao_num,ao_num,ao_num,ao_num))
+
+  call cutc_int(nxBlocks, nyBlocks, nzBlocks, blockxSize, blockySize, blockzSize,           &
+                n_points_final_grid, n_points_extra_final_grid, ao_num, nucl_num, jBH_size, &
+                final_grid_points, final_weight_at_r_vector,                                &
+                final_grid_points_extra, final_weight_at_r_vector_extra,                    &
+                rn, aos_data1, aos_data2, jBH_c, jBH_m, jBH_n, jBH_o,                       &
+                int2_grad1_u12_ao_gpu, int_2e_ao_gpu)
+
+  deallocate(int_2e_ao_gpu, int2_grad1_u12_ao_gpu)
+  deallocate(rn, aos_data1, aos_data2)
+
+  call wall_time(time1)
+  write(*,"(A,2X,F15.7)") ' wall time for compute_int_2e_ao_gpu (sec) = ', (time1 - time0)
+
+  return
+end

plugins/local/tc_int/compute_no_cpu.irp.f

@@ -0,0 +1,143 @@
+
+! ---
+
+program compute_no_cpu
+
+  implicit none
+
+  print *, ' j2e_type = ', j2e_type
+  print *, ' j1e_type = ', j1e_type
+  print *, ' env_type = ', env_type
+
+  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
+
+  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_grid, 'radial  external grid over')
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+  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')
+
+  call main()
+    
+end
+
+! ---
+
+subroutine main()
+
+  use cutc_module
+
+  implicit none
+
+  integer                       :: i, j, k, l, ipoint
+  double precision              :: time0, time1
+  double precision              :: tt0, tt1
+  double precision              :: acc_thr, err_tot, nrm_tot, err_loc
+  double precision              :: noL_0e
+  double precision, allocatable :: int2_grad1_u12_ao(:,:,:,:)
+  double precision, allocatable :: tmp(:,:,:,:)
+  double precision, allocatable :: int2_grad1_u12_bimo_t(:,:,:,:)
+  double precision, allocatable :: noL_1e    (:,:)
+  double precision, allocatable :: noL_2e    (:,:,:,:)
+
+  PROVIDE mo_l_coef mo_r_coef
+  PROVIDE mos_l_in_r_array_transp mos_r_in_r_array_transp
+
+
+  call wall_time(time0)
+  print*, ' start compute_no_cpu'
+
+
+
+  allocate(int2_grad1_u12_ao(ao_num,ao_num,n_points_final_grid,3))
+  print*, ' Reading int2_grad1_u12_ao from ', trim(ezfio_filename) // '/work/int2_grad1_u12_ao'
+  call wall_time(tt0)
+  open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="read")
+    read(11) int2_grad1_u12_ao
+  close(11)
+  call wall_time(tt1)
+  write(*,"(A,2X,F15.7)") ' wall time for reading (sec) = ', (tt1 - tt0)
+
+  allocate(tmp(mo_num,mo_num,n_points_final_grid,3))
+  allocate(int2_grad1_u12_bimo_t(n_points_final_grid,3,mo_num,mo_num))
+
+  call wall_time(tt0)
+  !$OMP PARALLEL         &
+  !$OMP DEFAULT (NONE)   &
+  !$OMP PRIVATE (ipoint) & 
+  !$OMP SHARED (ao_num, mo_num, n_points_final_grid, int2_grad1_u12_ao, tmp)
+  !$OMP DO SCHEDULE (dynamic)
+  do ipoint = 1, n_points_final_grid
+    call ao_to_mo_bi_ortho(int2_grad1_u12_ao(1,1,ipoint,1), ao_num, tmp(1,1,ipoint,1), mo_num)
+    call ao_to_mo_bi_ortho(int2_grad1_u12_ao(1,1,ipoint,2), ao_num, tmp(1,1,ipoint,2), mo_num)
+    call ao_to_mo_bi_ortho(int2_grad1_u12_ao(1,1,ipoint,3), ao_num, tmp(1,1,ipoint,3), mo_num)
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  deallocate(int2_grad1_u12_ao)
+
+  !$OMP PARALLEL               &
+  !$OMP DEFAULT (NONE)         &
+  !$OMP PRIVATE (i, j, ipoint) & 
+  !$OMP SHARED (mo_num, n_points_final_grid, tmp, int2_grad1_u12_bimo_t)
+  !$OMP DO COLLAPSE(2) SCHEDULE (dynamic)
+  do ipoint = 1, n_points_final_grid
+    do i = 1, mo_num
+      do j = 1, mo_num
+        int2_grad1_u12_bimo_t(ipoint,1,j,i) = tmp(j,i,ipoint,1)
+        int2_grad1_u12_bimo_t(ipoint,2,j,i) = tmp(j,i,ipoint,2)
+        int2_grad1_u12_bimo_t(ipoint,3,j,i) = tmp(j,i,ipoint,3)
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+  call wall_time(tt1)
+  write(*,"(A,2X,F15.7)") ' wall time for 3e-tensor (sec) = ', (tt1 - tt0)
+
+  deallocate(tmp)
+
+  allocate(noL_2e(mo_num,mo_num,mo_num,mo_num))
+  allocate(noL_1e(mo_num,mo_num))
+
+  call provide_no_2e(n_points_final_grid, mo_num, elec_alpha_num, elec_beta_num, &
+                     final_weight_at_r_vector(1),                                &
+                     mos_l_in_r_array_transp(1,1), mos_r_in_r_array_transp(1,1), &
+                     int2_grad1_u12_bimo_t(1,1,1,1), noL_2e(1,1,1,1))
+
+  call provide_no_1e(n_points_final_grid, mo_num, elec_alpha_num, elec_beta_num, &
+                     final_weight_at_r_vector(1),                                &
+                     mos_l_in_r_array_transp(1,1), mos_r_in_r_array_transp(1,1), &
+                     int2_grad1_u12_bimo_t(1,1,1,1), noL_1e(1,1))
+
+  call provide_no_0e(n_points_final_grid, mo_num, elec_alpha_num, elec_beta_num, &
+                     final_weight_at_r_vector(1),                                &
+                     mos_l_in_r_array_transp(1,1), mos_r_in_r_array_transp(1,1), &
+                     int2_grad1_u12_bimo_t(1,1,1,1), noL_0e)
+
+  deallocate(int2_grad1_u12_bimo_t)
+  deallocate(noL_2e)
+  deallocate(noL_1e)
+
+
+  call wall_time(time1)
+  write(*,"(A,2X,F15.7)") ' wall time for compute_no_cpu (sec) = ', (time1 - time0)
+
+  return
+
+end
+
+! ---
+
+

plugins/local/tc_int/compute_no_gpu.irp.f

@@ -0,0 +1,132 @@
+
+! ---
+
+program compute_no_gpu
+
+  implicit none
+
+  print *, ' j2e_type = ', j2e_type
+  print *, ' j1e_type = ', j1e_type
+  print *, ' env_type = ', env_type
+
+  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
+
+  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_grid, 'radial  external grid over')
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+  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')
+
+  call main()
+    
+end
+
+! ---
+
+subroutine main()
+
+  use cutc_module
+
+  implicit none
+
+  integer                       :: i, j, k, l, ipoint
+  double precision              :: time0, time1
+  double precision              :: tt0, tt1
+  double precision              :: acc_thr, err_tot, nrm_tot, err_loc
+  double precision              :: noL_0e_gpu(1)
+  double precision, allocatable :: int2_grad1_u12_ao(:,:,:,:)
+  double precision, allocatable :: tmp(:,:,:,:)
+  double precision, allocatable :: int2_grad1_u12_bimo_t(:,:,:,:)
+  double precision, allocatable :: noL_1e_gpu(:,:)
+  double precision, allocatable :: noL_2e_gpu(:,:,:,:)
+
+  PROVIDE mo_l_coef mo_r_coef
+  PROVIDE mos_l_in_r_array_transp mos_r_in_r_array_transp
+
+
+  call wall_time(time0)
+  print*, ' start compute_no_gpu'
+
+
+
+  allocate(int2_grad1_u12_ao(ao_num,ao_num,n_points_final_grid,3))
+  print*, ' Reading int2_grad1_u12_ao from ', trim(ezfio_filename) // '/work/int2_grad1_u12_ao'
+  call wall_time(tt0)
+  open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="read")
+    read(11) int2_grad1_u12_ao
+  close(11)
+  call wall_time(tt1)
+  write(*,"(A,2X,F15.7)") ' wall time for reading (sec) = ', (tt1 - tt0)
+
+  allocate(tmp(mo_num,mo_num,n_points_final_grid,3))
+  allocate(int2_grad1_u12_bimo_t(n_points_final_grid,3,mo_num,mo_num))
+
+  call wall_time(tt0)
+  !$OMP PARALLEL         &
+  !$OMP DEFAULT (NONE)   &
+  !$OMP PRIVATE (ipoint) & 
+  !$OMP SHARED (ao_num, mo_num, n_points_final_grid, int2_grad1_u12_ao, tmp)
+  !$OMP DO SCHEDULE (dynamic)
+  do ipoint = 1, n_points_final_grid
+    call ao_to_mo_bi_ortho(int2_grad1_u12_ao(1,1,ipoint,1), ao_num, tmp(1,1,ipoint,1), mo_num)
+    call ao_to_mo_bi_ortho(int2_grad1_u12_ao(1,1,ipoint,2), ao_num, tmp(1,1,ipoint,2), mo_num)
+    call ao_to_mo_bi_ortho(int2_grad1_u12_ao(1,1,ipoint,3), ao_num, tmp(1,1,ipoint,3), mo_num)
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  deallocate(int2_grad1_u12_ao)
+
+  !$OMP PARALLEL               &
+  !$OMP DEFAULT (NONE)         &
+  !$OMP PRIVATE (i, j, ipoint) & 
+  !$OMP SHARED (mo_num, n_points_final_grid, tmp, int2_grad1_u12_bimo_t)
+  !$OMP DO COLLAPSE(2) SCHEDULE (dynamic)
+  do ipoint = 1, n_points_final_grid
+    do i = 1, mo_num
+      do j = 1, mo_num
+        int2_grad1_u12_bimo_t(ipoint,1,j,i) = tmp(j,i,ipoint,1)
+        int2_grad1_u12_bimo_t(ipoint,2,j,i) = tmp(j,i,ipoint,2)
+        int2_grad1_u12_bimo_t(ipoint,3,j,i) = tmp(j,i,ipoint,3)
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+  call wall_time(tt1)
+  write(*,"(A,2X,F15.7)") ' wall time for 3e-tensor (sec) = ', (tt1 - tt0)
+
+  deallocate(tmp)
+
+  allocate(noL_2e_gpu(mo_num,mo_num,mo_num,mo_num))
+  allocate(noL_1e_gpu(mo_num,mo_num))
+
+  call cutc_no(n_points_final_grid, mo_num, elec_alpha_num, elec_beta_num, &
+               final_weight_at_r_vector(1),                                &
+               mos_l_in_r_array_transp(1,1), mos_r_in_r_array_transp(1,1), &
+               int2_grad1_u12_bimo_t(1,1,1,1), noL_2e_gpu(1,1,1,1), noL_1e_gpu(1,1), noL_0e_gpu(1))
+
+  deallocate(int2_grad1_u12_bimo_t)
+  deallocate(noL_2e_gpu)
+  deallocate(noL_1e_gpu)
+
+  call wall_time(time1)
+  write(*,"(A,2X,F15.7)") ' wall time for compute_no_gpu (sec) = ', (time1 - time0)
+
+  return
+
+end
+
+! ---
+
+

plugins/local/tc_int/compute_tc_int.irp.f

@@ -2,7 +2,7 @@
 ! ---
 
 subroutine provide_int2_grad1_u12_ao()
-  use gpu
+
   BEGIN_DOC
   !
   ! int2_grad1_u12_ao(i,j,ipoint,1) = \int dr2         [\grad1 u(r1,r2)]_x1 \chi_i(r2) \chi_j(r2)
@@ -35,8 +35,8 @@ subroutine provide_int2_grad1_u12_ao()
   double precision              :: weight1, ao_k_r, ao_i_r
   double precision              :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq
   double precision              :: time0, time1, time2, tc1, tc2, tc
-  type(gpu_double4)             :: int2_grad1_u12_ao
+  double precision, allocatable :: int2_grad1_u12_ao(:,:,:,:)
-  type(gpu_double3)             :: tmp_grad1_u12, tmp_grad1_u12p, tmp
+  double precision, allocatable :: tmp_grad1_u12(:,:,:), tmp(:,:,:)
   double precision, allocatable :: c_mat(:,:,:), tc_int_2e_ao(:,:,:,:)
 
   double precision, external    :: get_ao_two_e_integral
@@ -52,7 +52,6 @@ subroutine provide_int2_grad1_u12_ao()
 
   call total_memory(mem)
   mem      = max(1.d0, qp_max_mem - mem)
-  mem = 6
   n_double = mem * 1.d8
   n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid))
   n_rest   = int(mod(n_points_final_grid, n_blocks))
@@ -66,9 +65,9 @@ subroutine provide_int2_grad1_u12_ao()
   ! ---
   ! ---
 
-  call gpu_allocate(int2_grad1_u12_ao, ao_num,ao_num,n_points_final_grid,4)
+  allocate(int2_grad1_u12_ao(ao_num,ao_num,n_points_final_grid,4))
 
-  call gpu_allocate(tmp,n_points_extra_final_grid,ao_num,ao_num)
+  allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
   !$OMP PARALLEL               &
   !$OMP DEFAULT (NONE)         &
   !$OMP PRIVATE (j, i, jpoint) &
@@ -77,23 +76,17 @@ subroutine provide_int2_grad1_u12_ao()
   do j = 1, ao_num
     do i = 1, ao_num
       do jpoint = 1, n_points_extra_final_grid
-        tmp%f(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)
+        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
 
-  call gpu_allocate(tmp_grad1_u12,n_points_extra_final_grid,n_blocks,4)
+  allocate(tmp_grad1_u12(n_points_extra_final_grid,n_blocks,4))
-  call gpu_allocate(tmp_grad1_u12p,n_points_extra_final_grid,n_blocks,4)
 
   tc = 0.d0
 
-  type(gpu_stream) :: stream(4)
-  do i=1,4
-    call gpu_stream_create(stream(i))
-  enddo
-
   do i_pass = 1, n_pass
     ii = (i_pass-1)*n_blocks + 1
 
@@ -102,25 +95,22 @@ subroutine provide_int2_grad1_u12_ao()
     !$OMP PARALLEL                   &
     !$OMP DEFAULT (NONE)             &
     !$OMP PRIVATE (i_blocks, ipoint) &
-    !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12)
+    !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, tmp_grad1_u12)
     !$OMP DO
     do i_blocks = 1, n_blocks
       ipoint = ii - 1 + i_blocks ! r1
-      call get_grad1_u12_for_tc(ipoint, n_points_extra_final_grid, tmp_grad1_u12%f(1,i_blocks,1), tmp_grad1_u12%f(1,i_blocks,2), &
+      call get_grad1_u12_for_tc(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1), tmp_grad1_u12(1,i_blocks,2), &
-        tmp_grad1_u12%f(1,i_blocks,3), tmp_grad1_u12%f(1,i_blocks,4))
+        tmp_grad1_u12(1,i_blocks,3), tmp_grad1_u12(1,i_blocks,4))
     enddo
     !$OMP END DO
     !$OMP END PARALLEL
     call wall_time(tc2)
     tc = tc + tc2 - tc1
 
-    call gpu_synchronize()
-    call gpu_copy(tmp_grad1_u12,tmp_grad1_u12p)
     do m = 1, 4
-      call gpu_set_stream(blas_handle, stream(m))
+      call dgemm("T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, 1.d0                      &
-      call gpu_dgemm(blas_handle, "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 &
-                , tmp%f(1,1,1), n_points_extra_final_grid, tmp_grad1_u12p%f(1,1,m), n_points_extra_final_grid &
+                , 0.d0, int2_grad1_u12_ao(1,1,ii,m), ao_num*ao_num)
-                , 0.d0, int2_grad1_u12_ao%f(1,1,ii,m), ao_num*ao_num)
     enddo
   enddo
 
@@ -132,12 +122,12 @@ subroutine provide_int2_grad1_u12_ao()
     !$OMP PARALLEL                 &
     !$OMP DEFAULT (NONE)           &
     !$OMP PRIVATE (i_rest, ipoint) &
-    !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12)
+    !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, tmp_grad1_u12)
     !$OMP DO
     do i_rest = 1, n_rest
       ipoint = ii - 1 + i_rest ! r1
-      call get_grad1_u12_for_tc(ipoint, n_points_extra_final_grid, tmp_grad1_u12%f(1,i_rest,1), tmp_grad1_u12%f(1,i_rest,2), &
+      call get_grad1_u12_for_tc(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1), tmp_grad1_u12(1,i_rest,2), &
-        tmp_grad1_u12%f(1,i_rest,3), tmp_grad1_u12%f(1,i_rest,4))
+        tmp_grad1_u12(1,i_rest,3), tmp_grad1_u12(1,i_rest,4))
     enddo
     !$OMP END DO
     !$OMP END PARALLEL
@@ -145,42 +135,33 @@ subroutine provide_int2_grad1_u12_ao()
     tc = tc + tc2 - tc1
 
     do m = 1, 4
-      call gpu_set_stream(blas_handle, stream(m))
+      call dgemm("T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, 1.d0                        &
-      call gpu_dgemm(blas_handle, "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 &
-                , tmp%f(1,1,1), n_points_extra_final_grid, tmp_grad1_u12%f(1,1,m), n_points_extra_final_grid &
+                , 0.d0, int2_grad1_u12_ao(1,1,ii,m), ao_num*ao_num)
-                , 0.d0, int2_grad1_u12_ao%f(1,1,ii,m), ao_num*ao_num)
     enddo
 
   endif
-  call gpu_synchronize()
+  deallocate(tmp_grad1_u12)
-  call gpu_deallocate(tmp_grad1_u12)
-  call gpu_deallocate(tmp_grad1_u12p)
 
-  do i=1,4
+  deallocate(tmp)
-    call gpu_stream_destroy(stream(i))
-  enddo
-
-
-  call gpu_deallocate(tmp)
 
 
   call wall_time(time1)
   print*, ' wall time for int2_grad1_u12_ao (min) = ', (time1-time0) / 60.d0
   print*, ' wall time Jastrow derivatives   (min) = ', tc / 60.d0
+
   call print_memory_usage()
 
-!TODO
-stop
   ! ---
   ! ---
   ! ---
 
 
+  allocate(c_mat(n_points_final_grid,ao_num,ao_num))
   allocate(tc_int_2e_ao(ao_num,ao_num,ao_num,ao_num))
 
   call wall_time(time1)
 
-  allocate(c_mat(n_points_final_grid,ao_num,ao_num))
   !$OMP PARALLEL               &
   !$OMP DEFAULT (NONE)         &
   !$OMP PRIVATE (i, k, ipoint) &
@@ -196,19 +177,18 @@ stop
   !$OMP END DO
   !$OMP END PARALLEL
   call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0            &
-            , int2_grad1_u12_ao%f(1,1,1,4), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
+            , int2_grad1_u12_ao(1,1,1,4), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
             , 0.d0, tc_int_2e_ao(1,1,1,1), ao_num*ao_num)
-  deallocate(c_mat)
 
   call wall_time(time2)
   print*, ' wall time of Hermitian part of tc_int_2e_ao (min) ', (time2 - time1) / 60.d0
+
   call print_memory_usage()
 
   ! ---
 
   call wall_time(time1)
 
-  allocate(c_mat(n_points_final_grid,ao_num,ao_num))
   do m = 1, 3
     !$OMP PARALLEL                                                              &
     !$OMP DEFAULT (NONE)                                                        &
@@ -220,7 +200,7 @@ stop
       do k = 1, ao_num
         do ipoint = 1, n_points_final_grid
 
-          weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
+          weight1 = final_weight_at_r_vector(ipoint)
           ao_i_r  = aos_in_r_array_transp(ipoint,i)
           ao_k_r  = aos_in_r_array_transp(ipoint,k)
 
@@ -231,14 +211,16 @@ stop
     !$OMP END DO
     !$OMP END PARALLEL
 
-    call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0           &
+    call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -0.5d0          &
-              , int2_grad1_u12_ao%f(1,1,1,m), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
+              , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
               , 1.d0, tc_int_2e_ao(1,1,1,1), ao_num*ao_num)
   enddo
-  deallocate(c_mat)
 
   call wall_time(time2)
   print*, ' wall time of non-Hermitian part of tc_int_2e_ao (min) ', (time2 - time1) / 60.d0
+
+  deallocate(c_mat)
+
   call print_memory_usage()
 
   ! ---
@@ -249,13 +231,18 @@ stop
 
   call wall_time(time2)
   print*, ' lower- and upper-triangle of tc_int_2e_ao (min) ', (time2 - time1) / 60.d0
+
   call print_memory_usage()
 
   ! ---
 
+  double precision :: tmp_omp
+
   call wall_time(time1)
 
   PROVIDE ao_integrals_map
+  tmp_omp = get_ao_two_e_integral(1, 1, 1, 1, ao_integrals_map)
+
   !$OMP PARALLEL DEFAULT(NONE)                         &
   !$OMP SHARED(ao_num, tc_int_2e_ao, ao_integrals_map) &
   !$OMP PRIVATE(i, j, k, l)
@@ -281,9 +268,10 @@ stop
 
   print*, ' Writing int2_grad1_u12_ao in ', trim(ezfio_filename) // '/work/int2_grad1_u12_ao'
   open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="write")
-  call ezfio_set_work_empty(.False.)
+    call ezfio_set_work_empty(.False.)
-    write(11) int2_grad1_u12_ao%f(:,:,:,1:3)
+    write(11) int2_grad1_u12_ao(:,:,:,1:3)
   close(11)
+  deallocate(int2_grad1_u12_ao)
 
   print*, ' Saving tc_int_2e_ao in ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot'
   open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="write")
@@ -295,7 +283,6 @@ stop
 
   ! ----
 
-  call gpu_deallocate(int2_grad1_u12_ao)
   deallocate(tc_int_2e_ao)
 
   call wall_time(time2)

plugins/local/tc_int/compute_tc_int_gpu.irp.f

@@ -0,0 +1,315 @@
+
+! ---
+
+subroutine provide_int2_grad1_u12_ao_gpu()
+
+  use gpu
+
+  BEGIN_DOC
+  !
+  ! int2_grad1_u12_ao(i,j,ipoint,1) = \int dr2         [\grad1 u(r1,r2)]_x1 \chi_i(r2) \chi_j(r2)
+  ! int2_grad1_u12_ao(i,j,ipoint,2) = \int dr2         [\grad1 u(r1,r2)]_y1 \chi_i(r2) \chi_j(r2)
+  ! int2_grad1_u12_ao(i,j,ipoint,3) = \int dr2         [\grad1 u(r1,r2)]_z1 \chi_i(r2) \chi_j(r2)
+  ! int2_grad1_u12_ao(i,j,ipoint,4) = \int dr2 [-(1/2) [\grad1 u(r1,r2)]^2] \chi_i(r2) \chi_j(r2)
+  !
+  !
+  ! tc_int_2e_ao(k,i,l,j) = (ki|V^TC(r_12)|lj)
+  !                       = <lk| V^TC(r_12) |ji> where V^TC(r_12) is the total TC operator
+  !                       = tc_grad_and_lapl_ao(k,i,l,j) + tc_grad_square_ao(k,i,l,j) + ao_two_e_coul(k,i,l,j)
+  ! where:
+  !
+  ! tc_grad_and_lapl_ao(k,i,l,j) = < k l | -1/2 \Delta_1 u(r1,r2) - \grad_1 u(r1,r2) . \grad_1 | ij >
+  !                              = -1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2      \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2)
+  !                              =  1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 (-1) \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2)
+  !
+  ! tc_grad_square_ao(k,i,l,j) = -1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_2 u(r1,r2)|^2 | ij>
+  !
+  ! ao_two_e_coul(k,i,l,j) = < l k | 1/r12 | j i > = ( k i | 1/r12 | l j )
+  !
+  END_DOC
+
+  implicit none
+
+  integer                       :: i, j, k, l, m, ipoint, jpoint
+  integer                       :: n_blocks, n_rest, n_pass
+  integer                       :: i_blocks, i_rest, i_pass, ii
+  double precision              :: mem, n_double
+  double precision              :: weight1, ao_k_r, ao_i_r
+  double precision              :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq
+  double precision              :: time0, time1, time2, tc1, tc2, tc
+  type(gpu_double4)             :: int2_grad1_u12_ao
+  type(gpu_double3)             :: tmp_grad1_u12, tmp_grad1_u12p, tmp
+  double precision, allocatable :: c_mat(:,:,:), tc_int_2e_ao(:,:,:,:)
+
+  double precision, external    :: get_ao_two_e_integral
+
+
+  PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
+  PROVIDE final_weight_at_r_vector aos_grad_in_r_array_transp_bis final_weight_at_r_vector aos_in_r_array_transp
+
+
+
+  print*, ' start provide_int2_grad1_u12_ao ...'
+  call wall_time(time0)
+
+  call total_memory(mem)
+  mem      = max(1.d0, qp_max_mem - mem)
+  mem = 6
+  n_double = mem * 1.d8
+  n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 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')
+
+  ! ---
+  ! ---
+  ! ---
+
+  call gpu_allocate(int2_grad1_u12_ao, ao_num,ao_num,n_points_final_grid,4)
+
+  call gpu_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%f(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
+
+  call gpu_allocate(tmp_grad1_u12,n_points_extra_final_grid,n_blocks,4)
+  call gpu_allocate(tmp_grad1_u12p,n_points_extra_final_grid,n_blocks,4)
+
+  tc = 0.d0
+
+  type(gpu_stream) :: stream(4)
+  do i=1,4
+    call gpu_stream_create(stream(i))
+  enddo
+
+  do i_pass = 1, n_pass
+    ii = (i_pass-1)*n_blocks + 1
+
+    call wall_time(tc1)
+
+    !$OMP PARALLEL                   &
+    !$OMP DEFAULT (NONE)             &
+    !$OMP PRIVATE (i_blocks, ipoint) &
+    !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12)
+    !$OMP DO
+    do i_blocks = 1, n_blocks
+      ipoint = ii - 1 + i_blocks ! r1
+      call get_grad1_u12_for_tc(ipoint, n_points_extra_final_grid, tmp_grad1_u12%f(1,i_blocks,1), tmp_grad1_u12%f(1,i_blocks,2), &
+        tmp_grad1_u12%f(1,i_blocks,3), tmp_grad1_u12%f(1,i_blocks,4))
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+    call wall_time(tc2)
+    tc = tc + tc2 - tc1
+
+    call gpu_synchronize()
+    call gpu_copy(tmp_grad1_u12,tmp_grad1_u12p)
+    do m = 1, 4
+      call gpu_set_stream(blas_handle, stream(m))
+      call gpu_dgemm(blas_handle, "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, 1.d0                     &
+                , tmp%f(1,1,1), n_points_extra_final_grid, tmp_grad1_u12p%f(1,1,m), n_points_extra_final_grid &
+                , 0.d0, int2_grad1_u12_ao%f(1,1,ii,m), ao_num*ao_num)
+    enddo
+  enddo
+
+  if(n_rest .gt. 0) then
+
+    ii = n_pass*n_blocks + 1
+
+    call wall_time(tc1)
+    !$OMP PARALLEL                 &
+    !$OMP DEFAULT (NONE)           &
+    !$OMP PRIVATE (i_rest, ipoint) &
+    !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12)
+    !$OMP DO
+    do i_rest = 1, n_rest
+      ipoint = ii - 1 + i_rest ! r1
+      call get_grad1_u12_for_tc(ipoint, n_points_extra_final_grid, tmp_grad1_u12%f(1,i_rest,1), tmp_grad1_u12%f(1,i_rest,2), &
+        tmp_grad1_u12%f(1,i_rest,3), tmp_grad1_u12%f(1,i_rest,4))
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+    call wall_time(tc2)
+    tc = tc + tc2 - tc1
+
+    do m = 1, 4
+      call gpu_set_stream(blas_handle, stream(m))
+      call gpu_dgemm(blas_handle, "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, 1.d0                       &
+                , tmp%f(1,1,1), n_points_extra_final_grid, tmp_grad1_u12%f(1,1,m), n_points_extra_final_grid &
+                , 0.d0, int2_grad1_u12_ao%f(1,1,ii,m), ao_num*ao_num)
+    enddo
+
+  endif
+  call gpu_synchronize()
+  call gpu_deallocate(tmp_grad1_u12)
+  call gpu_deallocate(tmp_grad1_u12p)
+
+  do i=1,4
+    call gpu_stream_destroy(stream(i))
+  enddo
+
+
+  call gpu_deallocate(tmp)
+
+
+  call wall_time(time1)
+  print*, ' wall time for int2_grad1_u12_ao (min) = ', (time1-time0) / 60.d0
+  print*, ' wall time Jastrow derivatives   (min) = ', tc / 60.d0
+  call print_memory_usage()
+
+!TODO
+stop
+  ! ---
+  ! ---
+  ! ---
+
+
+  allocate(c_mat(n_points_final_grid,ao_num,ao_num))
+  allocate(tc_int_2e_ao(ao_num,ao_num,ao_num,ao_num))
+
+  call wall_time(time1)
+
+  !$OMP PARALLEL               &
+  !$OMP DEFAULT (NONE)         &
+  !$OMP PRIVATE (i, k, ipoint) &
+  !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector)
+  !$OMP DO SCHEDULE (static)
+  do i = 1, ao_num
+    do k = 1, ao_num
+      do ipoint = 1, n_points_final_grid
+        c_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k)
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+  call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0            &
+            , int2_grad1_u12_ao%f(1,1,1,4), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
+            , 0.d0, tc_int_2e_ao(1,1,1,1), ao_num*ao_num)
+
+  call wall_time(time2)
+  print*, ' wall time of Hermitian part of tc_int_2e_ao (min) ', (time2 - time1) / 60.d0
+  call print_memory_usage()
+
+  ! ---
+
+  call wall_time(time1)
+
+  do m = 1, 3
+    !$OMP PARALLEL                                                              &
+    !$OMP DEFAULT (NONE)                                                        &
+    !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r)                       &
+    !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, c_mat, &
+    !$OMP         ao_num, n_points_final_grid, final_weight_at_r_vector, m)
+    !$OMP DO SCHEDULE (static)
+    do i = 1, ao_num
+      do k = 1, ao_num
+        do ipoint = 1, n_points_final_grid
+
+          weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
+          ao_i_r  = aos_in_r_array_transp(ipoint,i)
+          ao_k_r  = aos_in_r_array_transp(ipoint,k)
+
+          c_mat(ipoint,k,i) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,m) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,m))
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+    call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0           &
+              , int2_grad1_u12_ao%f(1,1,1,m), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
+              , 1.d0, tc_int_2e_ao(1,1,1,1), ao_num*ao_num)
+  enddo
+
+  call wall_time(time2)
+  print*, ' wall time of non-Hermitian part of tc_int_2e_ao (min) ', (time2 - time1) / 60.d0
+  call print_memory_usage()
+
+  deallocate(c_mat)
+
+  ! ---
+
+  call wall_time(time1)
+
+  call sum_A_At(tc_int_2e_ao(1,1,1,1), ao_num*ao_num)
+
+  call wall_time(time2)
+  print*, ' lower- and upper-triangle of tc_int_2e_ao (min) ', (time2 - time1) / 60.d0
+  call print_memory_usage()
+
+  ! ---
+
+  call wall_time(time1)
+
+  PROVIDE ao_integrals_map
+  !$OMP PARALLEL DEFAULT(NONE)                         &
+  !$OMP SHARED(ao_num, tc_int_2e_ao, ao_integrals_map) &
+  !$OMP PRIVATE(i, j, k, l)
+  !$OMP DO COLLAPSE(3)
+  do j = 1, ao_num
+    do l = 1, ao_num
+      do i = 1, ao_num
+        do k = 1, ao_num
+          !                                               < 1:i, 2:j | 1:k, 2:l >
+          tc_int_2e_ao(k,i,l,j) = tc_int_2e_ao(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  call wall_time(time2)
+  print*, ' wall time of Coulomb part of tc_int_2e_ao (min) ', (time2 - time1) / 60.d0
+  call print_memory_usage()
+
+  ! ---
+
+  print*, ' Writing int2_grad1_u12_ao in ', trim(ezfio_filename) // '/work/int2_grad1_u12_ao'
+  open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="write")
+  call ezfio_set_work_empty(.False.)
+    write(11) int2_grad1_u12_ao%f(:,:,:,1:3)
+  close(11)
+
+  print*, ' Saving tc_int_2e_ao in ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot'
+  open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="write")
+  call ezfio_set_work_empty(.False.)
+  do i = 1, ao_num
+    write(11) tc_int_2e_ao(:,:,:,i)
+  enddo
+  close(11)
+
+  ! ----
+
+  call gpu_deallocate(int2_grad1_u12_ao)
+  deallocate(tc_int_2e_ao)
+
+  call wall_time(time2)
+  print*, ' wall time for tc_int_2e_ao (min) = ', (time2-time1) / 60.d0
+  call print_memory_usage()
+
+  ! ---
+
+  call wall_time(time1)
+  print*, ' wall time for TC-integrals (min) = ', (time1-time0) / 60.d0
+
+  return
+end
+
+! ---
+

plugins/local/tc_int/cutc_module.F90

@@ -0,0 +1,70 @@
+
+module cutc_module
+
+  use, intrinsic :: iso_c_binding
+
+  implicit none
+
+  interface
+
+    ! ---
+
+    subroutine cutc_int(nxBlocks, nyBlocks, nzBlocks,           &
+                        blockxSize, blockySize, blockzSize,     &
+                        n_grid1, n_grid2, n_ao, n_nuc, size_bh, &
+                        r1, wr1, r2, wr2, rn,                   &
+                        aos_data1, aos_data2,                   &
+                        c_bh, m_bh, n_bh, o_bh,                 &
+                        int2_grad1_u12_ao, int_2e_ao) bind(C, name = "cutc_int")
+
+      import c_int, c_double, c_ptr
+      integer(c_int), intent(in), value :: nxBlocks, blockxSize
+      integer(c_int), intent(in), value :: nyBlocks, blockySize
+      integer(c_int), intent(in), value :: nzBlocks, blockzSize
+      integer(c_int), intent(in), value :: n_grid1, n_grid2
+      integer(c_int), intent(in), value :: n_ao
+      integer(c_int), intent(in), value :: n_nuc
+      integer(c_int), intent(in), value :: size_bh
+      real(c_double), intent(in)        :: r1(3,n_grid1), wr1(n_grid1)
+      real(c_double), intent(in)        :: r2(3,n_grid2), wr2(n_grid2)
+      real(c_double), intent(in)        :: rn(3,n_nuc)
+      real(c_double), intent(in)        :: aos_data1(n_grid1,n_ao,4)
+      real(c_double), intent(in)        :: aos_data2(n_grid2,n_ao,4)
+      real(c_double), intent(in)        :: c_bh(size_bh,n_nuc)
+      integer(c_int), intent(in)        :: m_bh(size_bh,n_nuc)
+      integer(c_int), intent(in)        :: n_bh(size_bh,n_nuc)
+      integer(c_int), intent(in)        :: o_bh(size_bh,n_nuc)
+      real(c_double), intent(out)       :: int2_grad1_u12_ao(n_ao,n_ao,n_grid1,3)
+      real(c_double), intent(out)       :: int_2e_ao(n_ao,n_ao,n_ao,n_ao)
+
+    end subroutine cutc_int
+
+    ! ---
+
+    subroutine cutc_no(n_grid1, n_mo, ne_a, ne_b,                   &
+                       wr1, mos_l_in_r, mos_r_in_r, int2_grad1_u12, &
+                       no_2e, no_1e, no_0e) bind(C, name = "cutc_no")
+
+      import c_int, c_double, c_ptr
+
+      integer(c_int), intent(in), value :: n_grid1
+      integer(c_int), intent(in), value :: n_mo
+      integer(c_int), intent(in), value :: ne_a
+      integer(c_int), intent(in), value :: ne_b
+      real(c_double), intent(in)        :: wr1(n_grid1)
+      real(c_double), intent(in)        :: mos_l_in_r(n_grid1,n_mo)
+      real(c_double), intent(in)        :: mos_r_in_r(n_grid1,n_mo)
+      real(c_double), intent(in)        :: int2_grad1_u12(n_grid1,3,n_mo,n_mo)
+      real(c_double), intent(out)       :: no_2e(n_mo,n_mo,n_mo,n_mo)
+      real(c_double), intent(out)       :: no_1e(n_mo,n_mo)
+      real(c_double), intent(out)       :: no_0e(1)
+
+    end subroutine cutc_no
+
+    ! ---
+
+  end interface
+
+end module cutc_module
+
+

plugins/local/tc_int/deb_int_2e_ao_gpu.irp.f

@@ -0,0 +1,311 @@
+
+! ---
+
+program deb_int_2e_ao_gpu
+
+  implicit none
+
+  print *, ' j2e_type = ', j2e_type
+  print *, ' j1e_type = ', j1e_type
+  print *, ' env_type = ', env_type
+
+  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
+
+  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_grid, 'radial  external grid over')
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+  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')
+
+  call main()
+
+end
+
+! ---
+
+subroutine main()
+
+  use cutc_module
+
+  implicit none
+
+  integer                       :: m
+  integer                       :: i, j, k, l
+  integer                       :: ipoint, jpoint
+
+  double precision              :: weight1, ao_i_r, ao_k_r
+
+  double precision              :: acc_thr, err_tot, nrm_tot, err_loc
+
+  double precision              :: time0, time1
+  double precision              :: wall_time0, wall_time1
+  double precision              :: wall_ttime0, wall_ttime1
+  double precision              :: tt1, tt2
+
+  double precision, allocatable :: rn(:,:), aos_data1(:,:,:), aos_data2(:,:,:)
+  double precision, allocatable :: grad1_u12(:,:,:), int_fct_long_range(:,:,:), c_mat(:,:,:)
+  double precision, allocatable :: int2_grad1_u12_ao(:,:,:,:)
+  double precision, allocatable :: int2_grad1_u12_ao_gpu(:,:,:,:)
+  double precision, allocatable :: int_2e_ao(:,:,:,:)
+  double precision, allocatable :: int_2e_ao_gpu(:,:,:,:)
+
+
+  call wall_time(time0)
+  print*, ' start deb_int_2e_ao_gpu'
+
+
+  ! ---
+
+  allocate(rn(3,nucl_num))
+  allocate(aos_data1(n_points_final_grid,ao_num,4))
+  allocate(aos_data2(n_points_extra_final_grid,ao_num,4))
+
+  do k = 1, nucl_num
+    rn(1,k) = nucl_coord(k,1)
+    rn(2,k) = nucl_coord(k,2)
+    rn(3,k) = nucl_coord(k,3)
+  enddo
+
+  do k = 1, ao_num
+    do ipoint = 1, n_points_final_grid
+      aos_data1(ipoint,k,1) = aos_in_r_array(k,ipoint)
+      aos_data1(ipoint,k,2) = aos_grad_in_r_array(k,ipoint,1)
+      aos_data1(ipoint,k,3) = aos_grad_in_r_array(k,ipoint,2)
+      aos_data1(ipoint,k,4) = aos_grad_in_r_array(k,ipoint,3)
+    enddo
+  enddo
+
+  do k = 1, ao_num
+    do ipoint = 1, n_points_extra_final_grid
+      aos_data2(ipoint,k,1) = aos_in_r_array_extra(k,ipoint)
+      aos_data2(ipoint,k,2) = aos_grad_in_r_array_extra(k,ipoint,1)
+      aos_data2(ipoint,k,3) = aos_grad_in_r_array_extra(k,ipoint,2)
+      aos_data2(ipoint,k,4) = aos_grad_in_r_array_extra(k,ipoint,3)
+    enddo
+  enddo
+
+  ! ---
+
+  integer :: nB
+  integer :: sB
+
+  PROVIDE nxBlocks nyBlocks nzBlocks
+  PROVIDE blockxSize blockySize blockzSize
+
+  sB = 32
+  nB = (n_points_final_grid + sB - 1) / sB
+
+  call ezfio_set_tc_int_blockxSize(sB)
+  call ezfio_set_tc_int_nxBlocks(nB)
+
+  allocate(int2_grad1_u12_ao_gpu(ao_num,ao_num,n_points_final_grid,3))
+  allocate(int_2e_ao_gpu(ao_num,ao_num,ao_num,ao_num))
+
+  call cutc_int(nxBlocks, nyBlocks, nzBlocks, blockxSize, blockySize, blockzSize,           &
+                n_points_final_grid, n_points_extra_final_grid, ao_num, nucl_num, jBH_size, &
+                final_grid_points, final_weight_at_r_vector,                                &
+                final_grid_points_extra, final_weight_at_r_vector_extra,                    &
+                rn, aos_data1, aos_data2, jBH_c, jBH_m, jBH_n, jBH_o,                       &
+                int2_grad1_u12_ao_gpu, int_2e_ao_gpu)
+
+  ! ---
+
+  allocate(int_fct_long_range(n_points_extra_final_grid,ao_num,ao_num))
+  allocate(grad1_u12(n_points_extra_final_grid,n_points_final_grid,4))
+  allocate(c_mat(n_points_final_grid,ao_num,ao_num))
+  allocate(int2_grad1_u12_ao(ao_num,ao_num,n_points_final_grid,4))
+  allocate(int_2e_ao(ao_num,ao_num,ao_num,ao_num))
+
+  call wall_time(wall_time0)
+
+  call wall_time(wall_ttime0)
+  !$OMP PARALLEL               &
+  !$OMP DEFAULT (NONE)         &
+  !$OMP PRIVATE (j, i, jpoint) &
+  !$OMP SHARED (int_fct_long_range, 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
+        int_fct_long_range(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
+  call wall_time(wall_ttime1)
+  write(*,"(A,2X,F15.7)") ' wall time for int_long_range (sec) = ', (wall_ttime1 - wall_ttime0)
+
+
+  call wall_time(wall_ttime0)
+  !$OMP PARALLEL         &
+  !$OMP DEFAULT (NONE)   &
+  !$OMP PRIVATE (ipoint) &
+  !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, grad1_u12)
+  !$OMP DO
+  do ipoint = 1, n_points_final_grid
+    call get_grad1_u12_for_tc(ipoint, n_points_extra_final_grid, grad1_u12(1,ipoint,1) &
+                                                               , grad1_u12(1,ipoint,2) &
+                                                               , grad1_u12(1,ipoint,3) &
+                                                               , grad1_u12(1,ipoint,4) )
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+  call wall_time(wall_ttime1)
+  write(*,"(A,2X,F15.7)") ' wall time for tc_int_bh (sec) = ', (wall_ttime1 - wall_ttime0)
+
+
+  call wall_time(wall_ttime0)
+  do m = 1, 4
+    call dgemm("T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, 1.d0                      &
+              , int_fct_long_range(1,1,1), n_points_extra_final_grid, grad1_u12(1,1,m), n_points_extra_final_grid &
+              , 0.d0, int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num)
+  enddo
+  call wall_time(wall_ttime1)
+  write(*,"(A,2X,F15.7)") ' wall time for DGEMM of integ over r2 (sec) = ', (wall_ttime1 - wall_ttime0)
+
+
+  call wall_time(wall_ttime0)
+  !$OMP PARALLEL               &
+  !$OMP DEFAULT (NONE)         &
+  !$OMP PRIVATE (i, k, ipoint) &
+  !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector)
+  !$OMP DO SCHEDULE (static)
+  do i = 1, ao_num
+    do k = 1, ao_num
+      do ipoint = 1, n_points_final_grid
+        c_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k)
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+  call wall_time(wall_ttime1)
+  write(*,"(A,2X,F15.7)") ' wall time of Hermitian part (sec) = ', (wall_ttime1 - wall_ttime0)
+
+
+  call wall_time(wall_ttime0)
+  call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0            &
+            , int2_grad1_u12_ao(1,1,1,4), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
+            , 0.d0, int_2e_ao(1,1,1,1), ao_num*ao_num)
+  call wall_time(wall_ttime1)
+  write(*,"(A,2X,F15.7)") ' wall time for DGEMM of Hermitian part (sec) = ', (wall_ttime1 - wall_ttime0)
+
+
+  tt1 = 0.d0
+  tt2 = 0.d0
+  do m = 1, 3
+
+    call wall_time(wall_ttime0)
+    !$OMP PARALLEL                                                              &
+    !$OMP DEFAULT (NONE)                                                        &
+    !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r)                       &
+    !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, c_mat, &
+    !$OMP         ao_num, n_points_final_grid, final_weight_at_r_vector, m)
+    !$OMP DO SCHEDULE (static)
+    do i = 1, ao_num
+      do k = 1, ao_num
+        do ipoint = 1, n_points_final_grid
+
+          weight1 = final_weight_at_r_vector(ipoint)
+          ao_i_r  = aos_in_r_array_transp(ipoint,i)
+          ao_k_r  = aos_in_r_array_transp(ipoint,k)
+
+          c_mat(ipoint,k,i) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,m) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,m))
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+    call wall_time(wall_ttime1)
+    tt1 += wall_ttime1 - wall_ttime0
+
+    call wall_time(wall_ttime0)
+    call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -0.5d0          &
+              , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
+              , 1.d0, int_2e_ao(1,1,1,1), ao_num*ao_num)
+    call wall_time(wall_ttime1)
+    tt2 += wall_ttime1 - wall_ttime0
+  enddo
+  write(*,"(A,2X,F15.7)") ' wall time of non-Hermitian part (sec) = ', tt1
+  write(*,"(A,2X,F15.7)") ' wall time for DGEMM of non Hermitian part (sec) = ', tt2
+
+
+  call wall_time(wall_ttime0)
+  call sum_A_At(int_2e_ao(1,1,1,1), ao_num*ao_num)
+  call wall_time(wall_ttime1)
+  write(*,"(A,2X,F15.7)") ' wall time of A + A.T (sec) = ', wall_ttime1 - wall_ttime0
+
+
+  call wall_time(wall_time1)
+  write(*,"(A,2X,F15.7)") ' wall time on cpu (sec) = ', (wall_time1 - wall_time0)
+
+  ! ---
+
+  acc_thr = 1d-12
+
+  err_tot = 0.d0
+  nrm_tot = 0.d0
+  do m = 1, 3
+    do ipoint = 1, n_points_final_grid
+      do j = 1, ao_num
+        do i = 1, ao_num
+          err_loc = dabs(int2_grad1_u12_ao(i,j,ipoint,m) - int2_grad1_u12_ao_gpu(i,j,ipoint,m))
+          if(err_loc > acc_thr) then
+            print*, " error on", i, j, ipoint, m
+            print*, " CPU res", int2_grad1_u12_ao    (i,j,ipoint,m)
+            print*, " GPU res", int2_grad1_u12_ao_gpu(i,j,ipoint,m)
+            stop
+          endif
+          err_tot = err_tot + err_loc
+          nrm_tot = nrm_tot + dabs(int2_grad1_u12_ao(i,j,ipoint,m))
+        enddo
+      enddo
+    enddo
+  enddo
+  print *, ' absolute accuracy on int2_grad1_u12_ao (%) =', 100.d0 * err_tot / nrm_tot
+
+
+  err_tot = 0.d0
+  nrm_tot = 0.d0
+  do i = 1, ao_num
+    do j = 1, ao_num
+      do k = 1, ao_num
+        do l = 1, ao_num
+          err_loc = dabs(int_2e_ao(l,k,j,i) - int_2e_ao_gpu(l,k,j,i))
+          if(err_loc > acc_thr) then
+            print*, " error on", l, k, j, i
+            print*, " CPU res", int_2e_ao    (l,k,j,i)
+            print*, " GPU res", int_2e_ao_gpu(l,k,j,i)
+            stop
+          endif
+          err_tot = err_tot + err_loc
+          nrm_tot = nrm_tot + dabs(int_2e_ao(l,k,j,i))
+        enddo
+      enddo
+    enddo
+  enddo
+  print *, ' absolute accuracy on int_2e_ao (%) =', 100.d0 * err_tot / nrm_tot
+
+  ! ---
+
+  deallocate(int_fct_long_range, grad1_u12, c_mat)
+  deallocate(int_2e_ao, int2_grad1_u12_ao)
+  deallocate(int_2e_ao_gpu, int2_grad1_u12_ao_gpu)
+  deallocate(rn, aos_data1, aos_data2)
+
+  call wall_time(time1)
+  write(*,"(A,2X,F15.7)") ' wall time for deb_int_2e_ao_gpu (sec) = ', (time1 - time0)
+
+  return
+end

plugins/local/tc_int/deb_no_gpu.irp.f

@@ -0,0 +1,218 @@
+
+! ---
+
+program deb_no_gpu
+
+  implicit none
+
+  print *, ' j2e_type = ', j2e_type
+  print *, ' j1e_type = ', j1e_type
+  print *, ' env_type = ', env_type
+
+  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
+
+  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_grid, 'radial  external grid over')
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+  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')
+
+  call main()
+    
+end
+
+! ---
+
+subroutine main()
+
+  use cutc_module
+
+  implicit none
+
+  integer                       :: i, j, k, l, ipoint
+  double precision              :: time0, time1
+  double precision              :: tt0, tt1
+  double precision              :: acc_thr, err_tot, nrm_tot, err_loc
+  double precision              :: noL_0e
+  double precision              :: noL_0e_gpu(1)
+  double precision, allocatable :: int2_grad1_u12_ao(:,:,:,:)
+  double precision, allocatable :: tmp(:,:,:,:)
+  double precision, allocatable :: int2_grad1_u12_bimo_t(:,:,:,:)
+  double precision, allocatable :: noL_1e    (:,:)
+  double precision, allocatable :: noL_1e_gpu(:,:)
+  double precision, allocatable :: noL_2e    (:,:,:,:)
+  double precision, allocatable :: noL_2e_gpu(:,:,:,:)
+
+
+  PROVIDE mo_l_coef mo_r_coef
+  PROVIDE mos_l_in_r_array_transp mos_r_in_r_array_transp
+
+
+  call wall_time(time0)
+  print*, ' start deb_no_gpu'
+
+
+
+  allocate(int2_grad1_u12_ao(ao_num,ao_num,n_points_final_grid,3))
+  print*, ' Reading int2_grad1_u12_ao from ', trim(ezfio_filename) // '/work/int2_grad1_u12_ao'
+  call wall_time(tt0)
+  open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="read")
+    read(11) int2_grad1_u12_ao
+  close(11)
+  call wall_time(tt1)
+  write(*,"(A,2X,F15.7)") ' wall time for reading (sec) = ', (tt1 - tt0)
+
+  allocate(tmp(mo_num,mo_num,n_points_final_grid,3))
+  allocate(int2_grad1_u12_bimo_t(n_points_final_grid,3,mo_num,mo_num))
+
+  call wall_time(tt0)
+  !$OMP PARALLEL         &
+  !$OMP DEFAULT (NONE)   &
+  !$OMP PRIVATE (ipoint) & 
+  !$OMP SHARED (ao_num, mo_num, n_points_final_grid, int2_grad1_u12_ao, tmp)
+  !$OMP DO SCHEDULE (dynamic)
+  do ipoint = 1, n_points_final_grid
+    call ao_to_mo_bi_ortho(int2_grad1_u12_ao(1,1,ipoint,1), ao_num, tmp(1,1,ipoint,1), mo_num)
+    call ao_to_mo_bi_ortho(int2_grad1_u12_ao(1,1,ipoint,2), ao_num, tmp(1,1,ipoint,2), mo_num)
+    call ao_to_mo_bi_ortho(int2_grad1_u12_ao(1,1,ipoint,3), ao_num, tmp(1,1,ipoint,3), mo_num)
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  deallocate(int2_grad1_u12_ao)
+
+  !$OMP PARALLEL               &
+  !$OMP DEFAULT (NONE)         &
+  !$OMP PRIVATE (i, j, ipoint) & 
+  !$OMP SHARED (mo_num, n_points_final_grid, tmp, int2_grad1_u12_bimo_t)
+  !$OMP DO COLLAPSE(2) SCHEDULE (dynamic)
+  do ipoint = 1, n_points_final_grid
+    do i = 1, mo_num
+      do j = 1, mo_num
+        int2_grad1_u12_bimo_t(ipoint,1,j,i) = tmp(j,i,ipoint,1)
+        int2_grad1_u12_bimo_t(ipoint,2,j,i) = tmp(j,i,ipoint,2)
+        int2_grad1_u12_bimo_t(ipoint,3,j,i) = tmp(j,i,ipoint,3)
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+  call wall_time(tt1)
+  write(*,"(A,2X,F15.7)") ' wall time for 3e-tensor (sec) = ', (tt1 - tt0)
+
+  deallocate(tmp)
+
+  ! ---
+
+  allocate(noL_2e_gpu(mo_num,mo_num,mo_num,mo_num))
+  allocate(noL_1e_gpu(mo_num,mo_num))
+
+  call cutc_no(n_points_final_grid, mo_num, elec_alpha_num, elec_beta_num, &
+               final_weight_at_r_vector(1),                                &
+               mos_l_in_r_array_transp(1,1), mos_r_in_r_array_transp(1,1), &
+               int2_grad1_u12_bimo_t(1,1,1,1), noL_2e_gpu(1,1,1,1), noL_1e_gpu(1,1), noL_0e_gpu(1))
+
+  ! ---
+
+  allocate(noL_2e(mo_num,mo_num,mo_num,mo_num))
+  allocate(noL_1e(mo_num,mo_num))
+
+  call provide_no_2e(n_points_final_grid, mo_num, elec_alpha_num, elec_beta_num, &
+                     final_weight_at_r_vector(1),                                &
+                     mos_l_in_r_array_transp(1,1), mos_r_in_r_array_transp(1,1), &
+                     int2_grad1_u12_bimo_t(1,1,1,1), noL_2e(1,1,1,1))
+
+  call provide_no_1e(n_points_final_grid, mo_num, elec_alpha_num, elec_beta_num, &
+                     final_weight_at_r_vector(1),                                &
+                     mos_l_in_r_array_transp(1,1), mos_r_in_r_array_transp(1,1), &
+                     int2_grad1_u12_bimo_t(1,1,1,1), noL_1e(1,1))
+
+  call provide_no_0e(n_points_final_grid, mo_num, elec_alpha_num, elec_beta_num, &
+                     final_weight_at_r_vector(1),                                &
+                     mos_l_in_r_array_transp(1,1), mos_r_in_r_array_transp(1,1), &
+                     int2_grad1_u12_bimo_t(1,1,1,1), noL_0e)
+
+  ! ---
+
+  deallocate(int2_grad1_u12_bimo_t)
+
+  acc_thr = 1d-12
+
+  ! ---
+
+  err_tot = 0.d0
+  nrm_tot = 0.d0
+  do i = 1, mo_num
+    do j = 1, mo_num
+      do k = 1, mo_num
+        do l = 1, mo_num
+          err_loc = dabs(noL_2e(l,k,j,i) - noL_2e_gpu(l,k,j,i))
+          if(err_loc > acc_thr) then
+            print*, " error on", l, k, j, i
+            print*, " CPU res", noL_2e    (l,k,j,i)
+            print*, " GPU res", noL_2e_gpu(l,k,j,i)
+            stop
+          endif
+          err_tot = err_tot + err_loc
+          nrm_tot = nrm_tot + dabs(noL_2e(l,k,j,i))
+        enddo
+      enddo
+    enddo
+  enddo
+  print *, ' absolute accuracy on noL_2e (%) =', 100.d0 * err_tot / nrm_tot
+
+  deallocate(noL_2e)
+  deallocate(noL_2e_gpu)
+
+  ! ---
+
+  err_tot = 0.d0
+  nrm_tot = 0.d0
+  do k = 1, mo_num
+    do l = 1, mo_num
+      err_loc = dabs(noL_1e(l,k) - noL_1e_gpu(l,k))
+      if(err_loc > acc_thr) then
+        print*, " error on", l, k
+        print*, " CPU res", noL_1e    (l,k)
+        print*, " GPU res", noL_1e_gpu(l,k)
+        stop
+      endif
+      err_tot = err_tot + err_loc
+      nrm_tot = nrm_tot + dabs(noL_1e(l,k))
+    enddo
+  enddo
+  print *, ' absolute accuracy on noL_1e (%) =', 100.d0 * err_tot / nrm_tot
+
+  deallocate(noL_1e)
+  deallocate(noL_1e_gpu)
+
+  ! ---
+
+  print *, 'noL_0e CPU = ', noL_0e
+  print *, 'noL_0e GPU = ', noL_0e_gpu(1)
+
+  err_tot = dabs(noL_0e - noL_0e_gpu(1))
+  nrm_tot = dabs(noL_0e)
+  print *, ' absolute accuracy on noL_0e (%) =', 100.d0 * err_tot / nrm_tot
+
+
+  call wall_time(time1)
+  write(*,"(A,2X,F15.7)") ' wall time for deb_no_gpu (sec) = ', (time1 - time0)
+
+  return
+
+end
+
+! ---
+
+

plugins/local/tc_int/install

@@ -0,0 +1,18 @@
+#!/bin/bash
+
+# Check if the QP_ROOT environment variable is set.
+if [[ -z ${QP_ROOT} ]]
+then
+  print "The QP_ROOT environment variable is not set."
+  print "Please reload the quantum_package.rc file."
+  exit -1
+fi
+
+git clone https://github.com/AbdAmmar/CuTC
+cd CuTC
+source config/env.rc 
+make
+cd ..
+
+ln -s ${PWD}/CuTC/build/libcutcint.so ${QP_ROOT}/lib
+

plugins/local/tc_int/jast_grad_full.irp.f

@@ -58,7 +58,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
   integer                       :: jpoint, i_nucl, p, mpA, npA, opA
   double precision              :: r2(3)
   double precision              :: dx, dy, dz, r12, tmp
-  double precision              :: rn(3), f1A, grad1_f1A(3), f2A, grad2_f2A(3), g12, grad1_g12(3)
+  double precision              :: rn(3), f1A, grad1_f1A(3), f2A, g12, grad1_g12(3)
   double precision              :: tmp1, tmp2, dist
   integer                       :: powmax1, powmax, powmax2
   double precision, allocatable :: f1A_power(:), f2A_power(:), double_p(:), g12_power(:)
@@ -91,35 +91,29 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
     grady(jpoint) = 0.d0
     gradz(jpoint) = 0.d0
 
-    call jBH_elem_fct_grad_alpha1(r1, r2, g12, grad1_g12)
+    dist = (r1(1) - r2(1)) * (r1(1) - r2(1)) &
-
+         + (r1(2) - r2(2)) * (r1(2) - r2(2)) &
-!    dist =   (r1(1) - r2(1)) * (r1(1) - r2(1)) &
+         + (r1(3) - r2(3)) * (r1(3) - r2(3))
-!           + (r1(2) - r2(2)) * (r1(2) - r2(2)) &
+    if(dist .ge. 1d-15) then
-!           + (r1(3) - r2(3)) * (r1(3) - r2(3))
+      dist = dsqrt(dist)
-!
+      tmp1 = 1.d0 / (1.d0 + dist)
-!    if(dist .ge. 1d-15) then
+      g12 = dist * tmp1
-!      dist = dsqrt( dist )
+      tmp2 = tmp1 * tmp1 / dist
-!
+      grad1_g12(1) = tmp2 * (r1(1) - r2(1))
-!      tmp1 = 1.d0 / (1.d0 + dist)
+      grad1_g12(2) = tmp2 * (r1(2) - r2(2))
-!
+      grad1_g12(3) = tmp2 * (r1(3) - r2(3))
-!      g12 = dist * tmp1
+      do p = 1, powmax2
-!      tmp2 = tmp1 * tmp1 / dist
+        g12_power(p) = g12_power(p-1) * g12
-!      grad1_g12(1) = tmp2 * (r1(1) - r2(1))
+      enddo
-!      grad1_g12(2) = tmp2 * (r1(2) - r2(2))
+    else
-!      grad1_g12(3) = tmp2 * (r1(3) - r2(3))
+      grad1_g12(1) = 0.d0
-!
+      grad1_g12(2) = 0.d0
-!    else
+      grad1_g12(3) = 0.d0
-!
+      g12 = 0.d0
-!      grad1_g12(1) = 0.d0
+      do p = 1, powmax2
-!      grad1_g12(2) = 0.d0
+        g12_power(p) = 0.d0
-!      grad1_g12(3) = 0.d0
+      enddo
-!      g12 = 0.d0
+    endif
-!
-!    endif
-!
-    do p = 1, powmax2
-      g12_power(p) = g12_power(p-1) * g12
-    enddo
 
     do i_nucl = 1, nucl_num
 
@@ -127,71 +121,54 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
       rn(2) = nucl_coord(i_nucl,2)
       rn(3) = nucl_coord(i_nucl,3)
 
-        call jBH_elem_fct_grad_alpha1(r1, rn, f1A, grad1_f1A)
+      dist = (r1(1) - rn(1)) * (r1(1) - rn(1)) &
-!      dist =   (r1(1) - rn(1)) * (r1(1) - rn(1)) &
+           + (r1(2) - rn(2)) * (r1(2) - rn(2)) &
-!             + (r1(2) - rn(2)) * (r1(2) - rn(2)) &
+           + (r1(3) - rn(3)) * (r1(3) - rn(3))
-!             + (r1(3) - rn(3)) * (r1(3) - rn(3))
+      if (dist > 1.d-15) then
-!      if (dist > 1.d-15) then
+        dist = dsqrt(dist)
-!        dist = dsqrt( dist )
+        tmp1 = 1.d0 / (1.d0 + dist)
-!
+        f1A = dist * tmp1
-!        tmp1 = 1.d0 / (1.d0 + dist)
+        tmp2 = tmp1 * tmp1 / dist
-!
+        grad1_f1A(1) = tmp2 * (r1(1) - rn(1))
-!        f1A = dist * tmp1
+        grad1_f1A(2) = tmp2 * (r1(2) - rn(2))
-!        tmp2 = tmp1 * tmp1 / dist
+        grad1_f1A(3) = tmp2 * (r1(3) - rn(3))
-!        grad1_f1A(1) = tmp2 * (r1(1) - rn(1))
+        do p = 1, powmax1
-!        grad1_f1A(2) = tmp2 * (r1(2) - rn(2))
+          f1A_power(p) = f1A_power(p-1) * f1A
-!        grad1_f1A(3) = tmp2 * (r1(3) - rn(3))
+        enddo
-!
+      else
-!      else
+        grad1_f1A(1) = 0.d0
-!
+        grad1_f1A(2) = 0.d0
-!        grad1_f1A(1) = 0.d0
+        grad1_f1A(3) = 0.d0
-!        grad1_f1A(2) = 0.d0
+        f1A = 0.d0
-!        grad1_f1A(3) = 0.d0
+        do p = 1, powmax1
-!        f1A = 0.d0
+          f1A_power(p) = 0.d0
-!
+        enddo
-!      endif
+      endif
 
-        call jBH_elem_fct_grad_alpha1(r2, rn, f2A, grad2_f2A)
+      dist = (r2(1) - rn(1)) * (r2(1) - rn(1)) &
-!      dist =   (r2(1) - rn(1)) * (r2(1) - rn(1)) &
+           + (r2(2) - rn(2)) * (r2(2) - rn(2)) &
-!             + (r2(2) - rn(2)) * (r2(2) - rn(2)) &
+           + (r2(3) - rn(3)) * (r2(3) - rn(3))
-!             + (r2(3) - rn(3)) * (r2(3) - rn(3))
+      if (dist > 1.d-15) then
-!
+        dist = dsqrt(dist)
-!      if (dist > 1.d-15) then
+        f2A = dist / (1.d0 + dist)
-!        dist = dsqrt( dist )
+        do p = 1, powmax1
-!
+          f2A_power(p) = f2A_power(p-1) * f2A
-!        tmp1 = 1.d0 / (1.d0 + dist)
+        enddo
-!
+      else
-!        f2A = dist * tmp1
+        f2A = 0.d0
-!        tmp2 = tmp1 * tmp1 / dist
+        do p = 1, powmax1
-!        grad2_f2A(1) = tmp2 * (r2(1) - rn(1))
+          f2A_power(p) = 0.d0
-!        grad2_f2A(2) = tmp2 * (r2(2) - rn(2))
+        enddo
-!        grad2_f2A(3) = tmp2 * (r2(3) - rn(3))
+      endif
-!
-!      else
-!
-!        grad2_f2A(1) = 0.d0
-!        grad2_f2A(2) = 0.d0
-!        grad2_f2A(3) = 0.d0
-!        f2A = 0.d0
-!
-!      endif
-
-      ! Compute powers of f1A and f2A
-      do p = 1, powmax1
-        f1A_power(p) = f1A_power(p-1) * f1A
-        f2A_power(p) = f2A_power(p-1) * f2A
-      enddo
 
       do p = 1, jBH_size
+
+        tmp = jBH_c(p,i_nucl)
+        if (dabs(tmp) <= 1.d-10) cycle
+
         mpA = jBH_m(p,i_nucl)
         npA = jBH_n(p,i_nucl)
         opA = jBH_o(p,i_nucl)
-        tmp = jBH_c(p,i_nucl)
-!        if (dabs(tmp) <= 1.d-10) cycle
-!
-        if(mpA .eq. npA) then
-          tmp = tmp * 0.5d0
-        endif
 
         tmp1 = double_p(mpA) * f1A_power(mpA-1) * f2A_power(npA) + double_p(npA) * f1A_power(npA-1) * f2A_power(mpA)
         tmp1 = tmp1 * g12_power(opA) * tmp
@@ -207,39 +184,5 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
   return
 end
 
-subroutine jBH_elem_fct_grad_alpha1(r1, r2, fct, grad1_fct)
-
-  implicit none
-  double precision, intent(in)  :: r1(3), r2(3)
-  double precision, intent(out) :: fct, grad1_fct(3)
-  double precision              :: dist, tmp1, tmp2
-
-  dist =   (r1(1) - r2(1)) * (r1(1) - r2(1)) &
-         + (r1(2) - r2(2)) * (r1(2) - r2(2)) &
-         + (r1(3) - r2(3)) * (r1(3) - r2(3))
-
-
-  if(dist .ge. 1d-15) then
-    dist = dsqrt( dist )
-
-    tmp1 = 1.d0 / (1.d0 + dist)
-
-    fct = dist * tmp1
-    tmp2 = tmp1 * tmp1 / dist
-    grad1_fct(1) = tmp2 * (r1(1) - r2(1))
-    grad1_fct(2) = tmp2 * (r1(2) - r2(2))
-    grad1_fct(3) = tmp2 * (r1(3) - r2(3))
-
-  else
-
-    grad1_fct(1) = 0.d0
-    grad1_fct(2) = 0.d0
-    grad1_fct(3) = 0.d0
-    fct = 0.d0
-
-  endif
-
-  return
-end
-
 ! ---
+

plugins/local/tc_int/jast_utils_bh.irp.f

@@ -1,43 +0,0 @@
-
-! ---
-
-
-
-subroutine jBH_elem_fct_grad(alpha, r1, r2, fct, grad1_fct)
-
-  implicit none
-  double precision, intent(in)  :: alpha, r1(3), r2(3)
-  double precision, intent(out) :: fct, grad1_fct(3)
-  double precision              :: dist, tmp1, tmp2, dist_inv
-
-  dist =   (r1(1) - r2(1)) * (r1(1) - r2(1)) &
-         + (r1(2) - r2(2)) * (r1(2) - r2(2)) &
-         + (r1(3) - r2(3)) * (r1(3) - r2(3))
-
-
-  if(dist .ge. 1d-15) then
-    dist_inv = 1.d0/dsqrt( dist )
-    dist = dist_inv * dist
-
-    tmp1 = 1.d0 / (1.d0 + alpha * dist)
-
-    fct = alpha * dist * tmp1
-    tmp2 = alpha * tmp1 * tmp1 * dist_inv
-    grad1_fct(1) = tmp2 * (r1(1) - r2(1))
-    grad1_fct(2) = tmp2 * (r1(2) - r2(2))
-    grad1_fct(3) = tmp2 * (r1(3) - r2(3))
-
-  else
-
-    grad1_fct(1) = 0.d0
-    grad1_fct(2) = 0.d0
-    grad1_fct(3) = 0.d0
-    fct = 0.d0
-
-  endif
-
-  return
-end
-
-! ---
-

plugins/local/tc_int/no_0e.irp.f

@@ -0,0 +1,407 @@
+
+! ---
+
+subroutine provide_no_0e(n_grid, n_mo, ne_a, ne_b, wr1, mos_l_in_r, mos_r_in_r, int2_grad1_u12, noL_0e)
+
+  implicit none
+
+  integer,          intent(in)  :: n_grid, n_mo
+  integer,          intent(in)  :: ne_a, ne_b
+  double precision, intent(in)  :: wr1(n_grid)
+  double precision, intent(in)  :: mos_l_in_r(n_grid,n_mo)
+  double precision, intent(in)  :: mos_r_in_r(n_grid,n_mo)
+  double precision, intent(in)  :: int2_grad1_u12(n_grid,3,n_mo,n_mo)
+  double precision, intent(out) :: noL_0e
+
+  integer                       :: i, j, k, ipoint
+  double precision              :: t0, t1
+  double precision, allocatable :: tmp(:)
+  double precision, allocatable :: tmpL(:,:), tmpR(:,:)
+  double precision, allocatable :: tmpM(:,:), tmpS(:), tmpO(:), tmpJ(:,:)
+  double precision, allocatable :: tmpM_priv(:,:), tmpS_priv(:), tmpO_priv(:), tmpJ_priv(:,:)
+
+
+  call wall_time(t0)
+
+
+  if(ne_a .eq. ne_b) then
+
+    allocate(tmp(ne_b))
+    allocate(tmpL(n_grid,3), tmpR(n_grid,3))
+
+    !$OMP PARALLEL                            &
+    !$OMP DEFAULT(NONE)                       &
+    !$OMP PRIVATE(j, i, ipoint, tmpL, tmpR)   &
+    !$OMP SHARED(ne_b, n_grid,                & 
+    !$OMP        mos_l_in_r, mos_r_in_r, wr1, &
+    !$OMP        int2_grad1_u12, tmp)
+
+    !$OMP DO
+    do j = 1, ne_b
+
+      tmpL = 0.d0
+      tmpR = 0.d0
+      do i = 1, ne_b
+        do ipoint = 1, n_grid
+
+          tmpL(ipoint,1) = tmpL(ipoint,1) + int2_grad1_u12(ipoint,1,j,i) * mos_l_in_r(ipoint,i)
+          tmpL(ipoint,2) = tmpL(ipoint,2) + int2_grad1_u12(ipoint,2,j,i) * mos_l_in_r(ipoint,i)
+          tmpL(ipoint,3) = tmpL(ipoint,3) + int2_grad1_u12(ipoint,3,j,i) * mos_l_in_r(ipoint,i)
+
+          tmpR(ipoint,1) = tmpR(ipoint,1) + int2_grad1_u12(ipoint,1,i,j) * mos_r_in_r(ipoint,i)
+          tmpR(ipoint,2) = tmpR(ipoint,2) + int2_grad1_u12(ipoint,2,i,j) * mos_r_in_r(ipoint,i)
+          tmpR(ipoint,3) = tmpR(ipoint,3) + int2_grad1_u12(ipoint,3,i,j) * mos_r_in_r(ipoint,i)
+        enddo
+      enddo
+
+      tmp(j) = 0.d0
+      do ipoint = 1, n_grid
+        tmp(j) = tmp(j) + wr1(ipoint) * (tmpL(ipoint,1)*tmpR(ipoint,1) + tmpL(ipoint,2)*tmpR(ipoint,2) + tmpL(ipoint,3)*tmpR(ipoint,3))
+      enddo
+    enddo ! j
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+    noL_0e = -2.d0 * sum(tmp)
+
+    deallocate(tmp)
+    deallocate(tmpL, tmpR)
+
+    ! ---
+
+    allocate(tmpO(n_grid), tmpJ(n_grid,3))
+    tmpO = 0.d0
+    tmpJ = 0.d0
+
+    !$OMP PARALLEL                                 &
+    !$OMP DEFAULT(NONE)                            &
+    !$OMP PRIVATE(i, ipoint, tmpO_priv, tmpJ_priv) &
+    !$OMP SHARED(ne_b, n_grid,                     &
+    !$OMP        mos_l_in_r, mos_r_in_r,           &
+    !$OMP        int2_grad1_u12, tmpO, tmpJ)
+
+    allocate(tmpO_priv(n_grid), tmpJ_priv(n_grid,3))
+    tmpO_priv = 0.d0
+    tmpJ_priv = 0.d0
+  
+    !$OMP DO 
+    do i = 1, ne_b
+      do ipoint = 1, n_grid
+        tmpO_priv(ipoint)   = tmpO_priv(ipoint)   + mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,i)
+        tmpJ_priv(ipoint,1) = tmpJ_priv(ipoint,1) + int2_grad1_u12(ipoint,1,i,i)
+        tmpJ_priv(ipoint,2) = tmpJ_priv(ipoint,2) + int2_grad1_u12(ipoint,2,i,i)
+        tmpJ_priv(ipoint,3) = tmpJ_priv(ipoint,3) + int2_grad1_u12(ipoint,3,i,i)
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+
+    !$OMP CRITICAL
+    tmpO = tmpO + tmpO_priv
+    tmpJ = tmpJ + tmpJ_priv
+    !$OMP END CRITICAL
+
+    deallocate(tmpO_priv, tmpJ_priv)
+    !$OMP END PARALLEL
+
+    allocate(tmpM(n_grid,3), tmpS(n_grid))
+    tmpM = 0.d0
+    tmpS = 0.d0
+
+    !$OMP PARALLEL                                    &
+    !$OMP DEFAULT(NONE)                               &
+    !$OMP PRIVATE(i, j, ipoint, tmpM_priv, tmpS_priv) &
+    !$OMP SHARED(ne_b, n_grid,                        &
+    !$OMP        mos_l_in_r, mos_r_in_r,              &
+    !$OMP        int2_grad1_u12, tmpM, tmpS)
+
+    allocate(tmpM_priv(n_grid,3), tmpS_priv(n_grid))
+    tmpM_priv = 0.d0
+    tmpS_priv = 0.d0
+  
+    !$OMP DO COLLAPSE(2)
+    do i = 1, ne_b
+      do j = 1, ne_b
+        do ipoint = 1, n_grid
+
+          tmpM_priv(ipoint,1) = tmpM_priv(ipoint,1) + int2_grad1_u12(ipoint,1,j,i) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,j)
+          tmpM_priv(ipoint,2) = tmpM_priv(ipoint,2) + int2_grad1_u12(ipoint,2,j,i) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,j)
+          tmpM_priv(ipoint,3) = tmpM_priv(ipoint,3) + int2_grad1_u12(ipoint,3,j,i) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,j)
+
+          tmpS_priv(ipoint) = tmpS_priv(ipoint) + int2_grad1_u12(ipoint,1,i,j) * int2_grad1_u12(ipoint,1,j,i) &
+                                                + int2_grad1_u12(ipoint,2,i,j) * int2_grad1_u12(ipoint,2,j,i) &
+                                                + int2_grad1_u12(ipoint,3,i,j) * int2_grad1_u12(ipoint,3,j,i)
+        enddo
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+
+    !$OMP CRITICAL
+    tmpM = tmpM + tmpM_priv
+    tmpS = tmpS + tmpS_priv
+    !$OMP END CRITICAL
+
+    deallocate(tmpM_priv, tmpS_priv)
+    !$OMP END PARALLEL
+
+    allocate(tmp(n_grid))
+
+    do ipoint = 1, n_grid
+
+      tmpS(ipoint) = 2.d0 * (tmpJ(ipoint,1)*tmpJ(ipoint,1) + tmpJ(ipoint,2)*tmpJ(ipoint,2) + tmpJ(ipoint,3)*tmpJ(ipoint,3)) - tmpS(ipoint)
+
+      tmp(ipoint) = wr1(ipoint) * ( tmpO(ipoint) * tmpS(ipoint) - 2.d0 * ( tmpJ(ipoint,1) * tmpM(ipoint,1) &
+                                                                         + tmpJ(ipoint,2) * tmpM(ipoint,2) &
+                                                                         + tmpJ(ipoint,3) * tmpM(ipoint,3) ) )
+    enddo
+
+    noL_0e = noL_0e - 2.d0 * (sum(tmp))
+
+    deallocate(tmp)
+
+  else
+
+    allocate(tmp(ne_a))
+    allocate(tmpL(n_grid,3), tmpR(n_grid,3))
+
+    !$OMP PARALLEL                          &
+    !$OMP DEFAULT(NONE)                     &
+    !$OMP PRIVATE(j, i, ipoint, tmpL, tmpR) &
+    !$OMP SHARED(ne_b, ne_a, n_grid,        &
+    !$OMP        mos_l_in_r, mos_r_in_r,    &
+    !$OMP        int2_grad1_u12, tmp, wr1)
+
+    !$OMP DO
+    do j = 1, ne_b
+
+      tmpL = 0.d0
+      tmpR = 0.d0
+      do i = ne_b+1, ne_a
+        do ipoint = 1, n_grid
+
+          tmpL(ipoint,1) = tmpL(ipoint,1) + 0.5d0 * int2_grad1_u12(ipoint,1,j,i) * mos_l_in_r(ipoint,i)
+          tmpL(ipoint,2) = tmpL(ipoint,2) + 0.5d0 * int2_grad1_u12(ipoint,2,j,i) * mos_l_in_r(ipoint,i)
+          tmpL(ipoint,3) = tmpL(ipoint,3) + 0.5d0 * int2_grad1_u12(ipoint,3,j,i) * mos_l_in_r(ipoint,i)
+
+          tmpR(ipoint,1) = tmpR(ipoint,1) + 0.5d0 * int2_grad1_u12(ipoint,1,i,j) * mos_r_in_r(ipoint,i)
+          tmpR(ipoint,2) = tmpR(ipoint,2) + 0.5d0 * int2_grad1_u12(ipoint,2,i,j) * mos_r_in_r(ipoint,i)
+          tmpR(ipoint,3) = tmpR(ipoint,3) + 0.5d0 * int2_grad1_u12(ipoint,3,i,j) * mos_r_in_r(ipoint,i)
+        enddo
+      enddo
+
+      tmp(j) = 0.d0
+      do ipoint = 1, n_grid
+        tmp(j) = tmp(j) + wr1(ipoint) * (tmpL(ipoint,1)*tmpR(ipoint,1) + tmpL(ipoint,2)*tmpR(ipoint,2) + tmpL(ipoint,3)*tmpR(ipoint,3))
+      enddo
+
+      do i = 1, ne_b
+        do ipoint = 1, n_grid
+
+          tmpL(ipoint,1) = tmpL(ipoint,1) + int2_grad1_u12(ipoint,1,j,i) * mos_l_in_r(ipoint,i)
+          tmpL(ipoint,2) = tmpL(ipoint,2) + int2_grad1_u12(ipoint,2,j,i) * mos_l_in_r(ipoint,i)
+          tmpL(ipoint,3) = tmpL(ipoint,3) + int2_grad1_u12(ipoint,3,j,i) * mos_l_in_r(ipoint,i)
+
+          tmpR(ipoint,1) = tmpR(ipoint,1) + int2_grad1_u12(ipoint,1,i,j) * mos_r_in_r(ipoint,i)
+          tmpR(ipoint,2) = tmpR(ipoint,2) + int2_grad1_u12(ipoint,2,i,j) * mos_r_in_r(ipoint,i)
+          tmpR(ipoint,3) = tmpR(ipoint,3) + int2_grad1_u12(ipoint,3,i,j) * mos_r_in_r(ipoint,i)
+        enddo
+      enddo
+
+      do ipoint = 1, n_grid
+        tmp(j) = tmp(j) + wr1(ipoint) * (tmpL(ipoint,1)*tmpR(ipoint,1) + tmpL(ipoint,2)*tmpR(ipoint,2) + tmpL(ipoint,3)*tmpR(ipoint,3))
+      enddo
+    enddo ! j
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+    ! ---
+
+    !$OMP PARALLEL                          &
+    !$OMP DEFAULT(NONE)                     &
+    !$OMP PRIVATE(j, i, ipoint, tmpL, tmpR) &
+    !$OMP SHARED(ne_b, ne_a, n_grid,        &
+    !$OMP        mos_l_in_r, mos_r_in_r,    &
+    !$OMP        int2_grad1_u12, tmp, wr1)
+
+    !$OMP DO
+    do j = ne_b+1, ne_a
+
+      tmpL = 0.d0
+      tmpR = 0.d0
+      do i = 1, ne_a
+        do ipoint = 1, n_grid
+          tmpL(ipoint,1) = tmpL(ipoint,1) + int2_grad1_u12(ipoint,1,j,i) * mos_l_in_r(ipoint,i)
+          tmpL(ipoint,2) = tmpL(ipoint,2) + int2_grad1_u12(ipoint,2,j,i) * mos_l_in_r(ipoint,i)
+          tmpL(ipoint,3) = tmpL(ipoint,3) + int2_grad1_u12(ipoint,3,j,i) * mos_l_in_r(ipoint,i)
+
+          tmpR(ipoint,1) = tmpR(ipoint,1) + int2_grad1_u12(ipoint,1,i,j) * mos_r_in_r(ipoint,i)
+          tmpR(ipoint,2) = tmpR(ipoint,2) + int2_grad1_u12(ipoint,2,i,j) * mos_r_in_r(ipoint,i)
+          tmpR(ipoint,3) = tmpR(ipoint,3) + int2_grad1_u12(ipoint,3,i,j) * mos_r_in_r(ipoint,i)
+        enddo
+      enddo
+
+      tmp(j) = 0.d0
+      do ipoint = 1, n_grid
+        tmp(j) = tmp(j) + 0.5d0 * wr1(ipoint) * (tmpL(ipoint,1)*tmpR(ipoint,1) + tmpL(ipoint,2)*tmpR(ipoint,2) + tmpL(ipoint,3)*tmpR(ipoint,3))
+      enddo
+    enddo ! j
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+    noL_0e = -2.d0 * sum(tmp)
+
+    deallocate(tmp)
+    deallocate(tmpL, tmpR)
+
+    ! ---
+
+    allocate(tmpO(n_grid), tmpJ(n_grid,3))
+    tmpO = 0.d0
+    tmpJ = 0.d0
+
+    !$OMP PARALLEL                                 &
+    !$OMP DEFAULT(NONE)                            &
+    !$OMP PRIVATE(i, ipoint, tmpO_priv, tmpJ_priv) &
+    !$OMP SHARED(ne_b, ne_a, n_grid,               &
+    !$OMP        mos_l_in_r, mos_r_in_r,           &
+    !$OMP        int2_grad1_u12, tmpO, tmpJ)
+
+    allocate(tmpO_priv(n_grid), tmpJ_priv(n_grid,3))
+    tmpO_priv = 0.d0
+    tmpJ_priv = 0.d0
+  
+    !$OMP DO 
+    do i = 1, ne_b
+      do ipoint = 1, n_grid
+        tmpO_priv(ipoint)   = tmpO_priv(ipoint)   + mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,i)
+        tmpJ_priv(ipoint,1) = tmpJ_priv(ipoint,1) + int2_grad1_u12(ipoint,1,i,i)
+        tmpJ_priv(ipoint,2) = tmpJ_priv(ipoint,2) + int2_grad1_u12(ipoint,2,i,i)
+        tmpJ_priv(ipoint,3) = tmpJ_priv(ipoint,3) + int2_grad1_u12(ipoint,3,i,i)
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+
+    !$OMP DO 
+    do i = ne_b+1, ne_a
+      do ipoint = 1, n_grid
+        tmpO_priv(ipoint)   = tmpO_priv(ipoint)   + 0.5d0 * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,i)
+        tmpJ_priv(ipoint,1) = tmpJ_priv(ipoint,1) + 0.5d0 * int2_grad1_u12(ipoint,1,i,i)
+        tmpJ_priv(ipoint,2) = tmpJ_priv(ipoint,2) + 0.5d0 * int2_grad1_u12(ipoint,2,i,i)
+        tmpJ_priv(ipoint,3) = tmpJ_priv(ipoint,3) + 0.5d0 * int2_grad1_u12(ipoint,3,i,i)
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+
+    !$OMP CRITICAL
+    tmpO = tmpO + tmpO_priv
+    tmpJ = tmpJ + tmpJ_priv
+    !$OMP END CRITICAL
+
+    deallocate(tmpO_priv, tmpJ_priv)
+    !$OMP END PARALLEL
+
+    ! ---
+
+    allocate(tmpM(n_grid,3), tmpS(n_grid))
+    tmpM = 0.d0
+    tmpS = 0.d0
+
+    !$OMP PARALLEL                                    &
+    !$OMP DEFAULT(NONE)                               &
+    !$OMP PRIVATE(i, j, ipoint, tmpM_priv, tmpS_priv) &
+    !$OMP SHARED(ne_b, ne_a, n_grid,                  &
+    !$OMP        mos_l_in_r, mos_r_in_r,              &
+    !$OMP        int2_grad1_u12, tmpM, tmpS)
+
+    allocate(tmpM_priv(n_grid,3), tmpS_priv(n_grid))
+    tmpM_priv = 0.d0
+    tmpS_priv = 0.d0
+  
+    !$OMP DO COLLAPSE(2)
+    do i = 1, ne_b
+      do j = 1, ne_b
+        do ipoint = 1, n_grid
+
+          tmpM_priv(ipoint,1) = tmpM_priv(ipoint,1) + int2_grad1_u12(ipoint,1,j,i) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,j)
+          tmpM_priv(ipoint,2) = tmpM_priv(ipoint,2) + int2_grad1_u12(ipoint,2,j,i) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,j)
+          tmpM_priv(ipoint,3) = tmpM_priv(ipoint,3) + int2_grad1_u12(ipoint,3,j,i) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,j)
+
+          tmpS_priv(ipoint)   = tmpS_priv(ipoint)   + int2_grad1_u12(ipoint,1,i,j) * int2_grad1_u12(ipoint,1,j,i) &
+                                                      + int2_grad1_u12(ipoint,2,i,j) * int2_grad1_u12(ipoint,2,j,i) &
+                                                      + int2_grad1_u12(ipoint,3,i,j) * int2_grad1_u12(ipoint,3,j,i)
+        enddo
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+
+    !$OMP DO COLLAPSE(2)
+    do i = ne_b+1, ne_a
+      do j = 1, ne_b
+        do ipoint = 1, n_grid
+
+          tmpM_priv(ipoint,1) = tmpM_priv(ipoint,1) + 0.5d0 * int2_grad1_u12(ipoint,1,j,i) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,j)
+          tmpM_priv(ipoint,2) = tmpM_priv(ipoint,2) + 0.5d0 * int2_grad1_u12(ipoint,2,j,i) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,j)
+          tmpM_priv(ipoint,3) = tmpM_priv(ipoint,3) + 0.5d0 * int2_grad1_u12(ipoint,3,j,i) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,j)
+
+          tmpM_priv(ipoint,1) = tmpM_priv(ipoint,1) + 0.5d0 * int2_grad1_u12(ipoint,1,i,j) * mos_l_in_r(ipoint,j) * mos_r_in_r(ipoint,i)
+          tmpM_priv(ipoint,2) = tmpM_priv(ipoint,2) + 0.5d0 * int2_grad1_u12(ipoint,2,i,j) * mos_l_in_r(ipoint,j) * mos_r_in_r(ipoint,i)
+          tmpM_priv(ipoint,3) = tmpM_priv(ipoint,3) + 0.5d0 * int2_grad1_u12(ipoint,3,i,j) * mos_l_in_r(ipoint,j) * mos_r_in_r(ipoint,i)
+
+          tmpS_priv(ipoint) = tmpS_priv(ipoint) + int2_grad1_u12(ipoint,1,i,j) * int2_grad1_u12(ipoint,1,j,i) &
+                                                + int2_grad1_u12(ipoint,2,i,j) * int2_grad1_u12(ipoint,2,j,i) &
+                                                + int2_grad1_u12(ipoint,3,i,j) * int2_grad1_u12(ipoint,3,j,i)
+        enddo
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+
+    !$OMP DO COLLAPSE(2)
+    do i = ne_b+1, ne_a
+      do j = ne_b+1, ne_a
+        do ipoint = 1, n_grid
+
+          tmpM_priv(ipoint,1) = tmpM_priv(ipoint,1) + 0.5d0 * int2_grad1_u12(ipoint,1,j,i) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,j)
+          tmpM_priv(ipoint,2) = tmpM_priv(ipoint,2) + 0.5d0 * int2_grad1_u12(ipoint,2,j,i) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,j)
+          tmpM_priv(ipoint,3) = tmpM_priv(ipoint,3) + 0.5d0 * int2_grad1_u12(ipoint,3,j,i) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,j)
+
+          tmpS_priv(ipoint) = tmpS_priv(ipoint) + 0.5d0 * int2_grad1_u12(ipoint,1,i,j) * int2_grad1_u12(ipoint,1,j,i) &
+                                                + 0.5d0 * int2_grad1_u12(ipoint,2,i,j) * int2_grad1_u12(ipoint,2,j,i) &
+                                                + 0.5d0 * int2_grad1_u12(ipoint,3,i,j) * int2_grad1_u12(ipoint,3,j,i)
+        enddo
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+
+    !$OMP CRITICAL
+    tmpM = tmpM + tmpM_priv
+    tmpS = tmpS + tmpS_priv
+    !$OMP END CRITICAL
+
+    deallocate(tmpM_priv, tmpS_priv)
+    !$OMP END PARALLEL
+
+    allocate(tmp(n_grid))
+
+    do ipoint = 1, n_grid
+
+      tmpS(ipoint) = 2.d0 * (tmpJ(ipoint,1)*tmpJ(ipoint,1) + tmpJ(ipoint,2)*tmpJ(ipoint,2) + tmpJ(ipoint,3)*tmpJ(ipoint,3)) - tmpS(ipoint)
+
+      tmp(ipoint) = wr1(ipoint) * ( tmpO(ipoint) * tmpS(ipoint) - 2.d0 * ( tmpJ(ipoint,1) * tmpM(ipoint,1) &
+                                                                         + tmpJ(ipoint,2) * tmpM(ipoint,2) &
+                                                                         + tmpJ(ipoint,3) * tmpM(ipoint,3) ) )
+    enddo
+
+    noL_0e = noL_0e - 2.d0 * (sum(tmp))
+
+    deallocate(tmp)
+
+  endif
+
+
+  call wall_time(t1)
+  write(*,"(A,2X,F15.7)") ' wall time for noL_0e (sec) = ', (t1 - t0)
+
+  return
+end
+
+! ---
+

plugins/local/tc_int/no_2e.irp.f

@@ -0,0 +1,605 @@
+
+! ---
+
+subroutine provide_no_2e(n_grid, n_mo, ne_a, ne_b, wr1, mos_l_in_r, mos_r_in_r, int2_grad1_u12, noL_2e)
+
+  implicit none
+
+  integer,          intent(in)  :: n_grid, n_mo
+  integer,          intent(in)  :: ne_a, ne_b
+  double precision, intent(in)  :: wr1(n_grid)
+  double precision, intent(in)  :: mos_l_in_r(n_grid,n_mo)
+  double precision, intent(in)  :: mos_r_in_r(n_grid,n_mo)
+  double precision, intent(in)  :: int2_grad1_u12(n_grid,3,n_mo,n_mo)
+  double precision, intent(out) :: noL_2e(n_mo,n_mo,n_mo,n_mo)
+
+  integer                       :: p, q, s, t, i, ipoint
+  double precision              :: t0, t1
+  double precision, allocatable :: tmpO(:), tmpJ(:,:)
+  double precision, allocatable :: tmpA(:,:,:), tmpB(:,:,:)
+  double precision, allocatable :: tmpC(:,:,:,:), tmpD(:,:,:,:)
+  double precision, allocatable :: tmpE(:,:,:,:)
+
+
+  call wall_time(t0)
+
+  if(ne_a .eq. ne_b) then
+
+    allocate(tmpO(n_grid), tmpJ(n_grid,3))
+    allocate(tmpA(n_grid,3,n_mo), tmpB(n_grid,3,n_mo))
+    allocate(tmpC(n_grid,4,n_mo,n_mo), tmpD(n_grid,4,n_mo,n_mo))
+    allocate(tmpE(n_mo,n_mo,n_mo,n_mo))
+
+    tmpO = 0.d0
+    tmpJ = 0.d0
+    do i = 1, ne_b
+      do ipoint = 1, n_grid
+        tmpO(ipoint)   = tmpO(ipoint)   + wr1(ipoint) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,i)
+        tmpJ(ipoint,1) = tmpJ(ipoint,1) + wr1(ipoint) * int2_grad1_u12(ipoint,1,i,i)
+        tmpJ(ipoint,2) = tmpJ(ipoint,2) + wr1(ipoint) * int2_grad1_u12(ipoint,2,i,i)
+        tmpJ(ipoint,3) = tmpJ(ipoint,3) + wr1(ipoint) * int2_grad1_u12(ipoint,3,i,i)
+      enddo
+    enddo
+
+    !$OMP PARALLEL                       &
+    !$OMP DEFAULT(NONE)                  &
+    !$OMP PRIVATE(p, i, ipoint)          &
+    !$OMP SHARED(n_mo, ne_b, n_grid,     &
+    !$OMP        wr1,                    &
+    !$OMP        mos_l_in_r, mos_r_in_r, &
+    !$OMP        int2_grad1_u12,         &
+    !$OMP        tmpA, tmpB)
+  
+    !$OMP DO
+    do p = 1, n_mo
+
+      tmpA(:,:,p) = 0.d0
+      tmpB(:,:,p) = 0.d0
+      do i = 1, ne_b
+        do ipoint = 1, n_grid
+          tmpA(ipoint,1,p) = tmpA(ipoint,1,p) + wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,1,p,i)
+          tmpA(ipoint,2,p) = tmpA(ipoint,2,p) + wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,2,p,i)
+          tmpA(ipoint,3,p) = tmpA(ipoint,3,p) + wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,3,p,i)
+          tmpB(ipoint,1,p) = tmpB(ipoint,1,p) + wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,1,i,p)
+          tmpB(ipoint,2,p) = tmpB(ipoint,2,p) + wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,2,i,p)
+          tmpB(ipoint,3,p) = tmpB(ipoint,3,p) + wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,3,i,p)
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+
+    !$OMP PARALLEL                       &
+    !$OMP DEFAULT(NONE)                  &
+    !$OMP PRIVATE(p, s, i, ipoint)       &
+    !$OMP SHARED(n_mo, ne_b, n_grid,     & 
+    !$OMP        wr1,                    &
+    !$OMP        mos_l_in_r, mos_r_in_r, &
+    !$OMP        int2_grad1_u12,         &
+    !$OMP        tmpA, tmpB, tmpO, tmpJ, tmpC, tmpD)
+  
+    !$OMP DO COLLAPSE(2)
+    do s = 1, n_mo
+      do p = 1, n_mo
+
+        do ipoint = 1, n_grid
+
+          tmpC(ipoint,1,p,s) = mos_r_in_r(ipoint,s) * tmpA(ipoint,1,p)     &
+                             + mos_l_in_r(ipoint,p) * tmpB(ipoint,1,s)     &
+                             - tmpO(ipoint) * int2_grad1_u12(ipoint,1,p,s) &
+                             - 2.d0 * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s) * tmpJ(ipoint,1)
+          tmpC(ipoint,2,p,s) = mos_r_in_r(ipoint,s) * tmpA(ipoint,2,p)     &
+                             + mos_l_in_r(ipoint,p) * tmpB(ipoint,2,s)     &
+                             - tmpO(ipoint) * int2_grad1_u12(ipoint,2,p,s) &
+                             - 2.d0 * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s) * tmpJ(ipoint,2)
+          tmpC(ipoint,3,p,s) = mos_r_in_r(ipoint,s) * tmpA(ipoint,3,p)     &
+                             + mos_l_in_r(ipoint,p) * tmpB(ipoint,3,s)     &
+                             - tmpO(ipoint) * int2_grad1_u12(ipoint,3,p,s) &
+                             - 2.d0 * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s) * tmpJ(ipoint,3)
+
+          tmpD(ipoint,1,p,s) = int2_grad1_u12(ipoint,1,p,s)
+          tmpD(ipoint,2,p,s) = int2_grad1_u12(ipoint,2,p,s)
+          tmpD(ipoint,3,p,s) = int2_grad1_u12(ipoint,3,p,s)
+          tmpD(ipoint,4,p,s) = wr1(ipoint) * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s)
+
+        enddo ! ipoint
+
+        tmpC(:,4,p,s) = 0.d0
+        do i = 1, ne_b
+          do ipoint = 1, n_grid
+            tmpC(ipoint,4,p,s) += int2_grad1_u12(ipoint,1,p,i) * int2_grad1_u12(ipoint,1,i,s) &
+                                + int2_grad1_u12(ipoint,2,p,i) * int2_grad1_u12(ipoint,2,i,s) &
+                                + int2_grad1_u12(ipoint,3,p,i) * int2_grad1_u12(ipoint,3,i,s)
+          enddo ! ipoint
+        enddo ! i
+
+      enddo ! p
+    enddo ! s
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+    deallocate(tmpO, tmpJ, tmpA, tmpB)
+
+
+    call dgemm( 'T', 'N', n_mo*n_mo, n_mo*n_mo, 4*n_grid, 0.5d0  &
+              , tmpC(1,1,1,1), 4*n_grid, tmpD(1,1,1,1), 4*n_grid &
+              , 0.d0, tmpE(1,1,1,1), n_mo*n_mo)
+
+    deallocate(tmpC, tmpD)
+
+    call sum_a_at(tmpE, n_mo*n_mo)
+
+    !$OMP PARALLEL            &
+    !$OMP DEFAULT(NONE)       &
+    !$OMP PRIVATE(t, s, q, p) &
+    !$OMP SHARED(n_mo, tmpE, noL_2e)
+  
+    !$OMP DO COLLAPSE(3)
+    do t = 1, n_mo
+      do s = 1, n_mo
+        do q = 1, n_mo
+          do p = 1, n_mo
+            noL_2e(p,q,s,t) = tmpE(p,s,q,t)
+          enddo
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+  
+    deallocate(tmpE)
+
+  else
+
+    allocate(tmpO(n_grid), tmpJ(n_grid,3))
+    allocate(tmpA(n_grid,3,n_mo), tmpB(n_grid,3,n_mo))
+    allocate(tmpC(n_grid,4,n_mo,n_mo), tmpD(n_grid,4,n_mo,n_mo))
+    allocate(tmpE(n_mo,n_mo,n_mo,n_mo))
+
+    tmpO = 0.d0
+    tmpJ = 0.d0
+    do i = 1, ne_b
+      do ipoint = 1, n_grid
+        tmpO(ipoint)   = tmpO(ipoint)   + wr1(ipoint) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,i)
+        tmpJ(ipoint,1) = tmpJ(ipoint,1) + wr1(ipoint) * int2_grad1_u12(ipoint,1,i,i)
+        tmpJ(ipoint,2) = tmpJ(ipoint,2) + wr1(ipoint) * int2_grad1_u12(ipoint,2,i,i)
+        tmpJ(ipoint,3) = tmpJ(ipoint,3) + wr1(ipoint) * int2_grad1_u12(ipoint,3,i,i)
+      enddo
+    enddo
+    do i = ne_b+1, ne_a
+      do ipoint = 1, n_grid
+        tmpO(ipoint)   = tmpO(ipoint)   + 0.5d0 * wr1(ipoint) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,i)
+        tmpJ(ipoint,1) = tmpJ(ipoint,1) + 0.5d0 * wr1(ipoint) * int2_grad1_u12(ipoint,1,i,i)
+        tmpJ(ipoint,2) = tmpJ(ipoint,2) + 0.5d0 * wr1(ipoint) * int2_grad1_u12(ipoint,2,i,i)
+        tmpJ(ipoint,3) = tmpJ(ipoint,3) + 0.5d0 * wr1(ipoint) * int2_grad1_u12(ipoint,3,i,i)
+      enddo
+    enddo
+
+    !$OMP PARALLEL                         &
+    !$OMP DEFAULT(NONE)                    &
+    !$OMP PRIVATE(p, i, ipoint)            &
+    !$OMP SHARED(n_mo, ne_a, ne_b, n_grid, &
+    !$OMP        wr1,                      &
+    !$OMP        mos_l_in_r, mos_r_in_r,   &
+    !$OMP        int2_grad1_u12,           &
+    !$OMP        tmpA, tmpB)
+  
+    !$OMP DO
+    do p = 1, n_mo
+
+      tmpA(:,:,p) = 0.d0
+      tmpB(:,:,p) = 0.d0
+      do i = 1, ne_b
+        do ipoint = 1, n_grid
+          tmpA(ipoint,1,p) = tmpA(ipoint,1,p) + wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,1,p,i)
+          tmpA(ipoint,2,p) = tmpA(ipoint,2,p) + wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,2,p,i)
+          tmpA(ipoint,3,p) = tmpA(ipoint,3,p) + wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,3,p,i)
+          tmpB(ipoint,1,p) = tmpB(ipoint,1,p) + wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,1,i,p)
+          tmpB(ipoint,2,p) = tmpB(ipoint,2,p) + wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,2,i,p)
+          tmpB(ipoint,3,p) = tmpB(ipoint,3,p) + wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,3,i,p)
+        enddo
+      enddo
+      do i = ne_b+1, ne_a
+        do ipoint = 1, n_grid
+          tmpA(ipoint,1,p) = tmpA(ipoint,1,p) + 0.5d0 * wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,1,p,i)
+          tmpA(ipoint,2,p) = tmpA(ipoint,2,p) + 0.5d0 * wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,2,p,i)
+          tmpA(ipoint,3,p) = tmpA(ipoint,3,p) + 0.5d0 * wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,3,p,i)
+          tmpB(ipoint,1,p) = tmpB(ipoint,1,p) + 0.5d0 * wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,1,i,p)
+          tmpB(ipoint,2,p) = tmpB(ipoint,2,p) + 0.5d0 * wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,2,i,p)
+          tmpB(ipoint,3,p) = tmpB(ipoint,3,p) + 0.5d0 * wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,3,i,p)
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+
+    !$OMP PARALLEL                         &
+    !$OMP DEFAULT(NONE)                    &
+    !$OMP PRIVATE(p, s, i, ipoint)         &
+    !$OMP SHARED(n_mo, ne_a, ne_b, n_grid, &
+    !$OMP        wr1,                      &
+    !$OMP        mos_l_in_r, mos_r_in_r,   &
+    !$OMP        int2_grad1_u12,           &
+    !$OMP        tmpA, tmpB, tmpO, tmpJ, tmpC, tmpD)
+  
+    !$OMP DO COLLAPSE(2)
+    do s = 1, n_mo
+      do p = 1, n_mo
+
+        do ipoint = 1, n_grid
+
+          tmpC(ipoint,1,p,s) = mos_r_in_r(ipoint,s) * tmpA(ipoint,1,p)     &
+                             + mos_l_in_r(ipoint,p) * tmpB(ipoint,1,s)     &
+                             - tmpO(ipoint) * int2_grad1_u12(ipoint,1,p,s) &
+                             - 2.d0 * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s) * tmpJ(ipoint,1)
+          tmpC(ipoint,2,p,s) = mos_r_in_r(ipoint,s) * tmpA(ipoint,2,p)     &
+                             + mos_l_in_r(ipoint,p) * tmpB(ipoint,2,s)     &
+                             - tmpO(ipoint) * int2_grad1_u12(ipoint,2,p,s) &
+                             - 2.d0 * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s) * tmpJ(ipoint,2)
+          tmpC(ipoint,3,p,s) = mos_r_in_r(ipoint,s) * tmpA(ipoint,3,p)     &
+                             + mos_l_in_r(ipoint,p) * tmpB(ipoint,3,s)     &
+                             - tmpO(ipoint) * int2_grad1_u12(ipoint,3,p,s) &
+                             - 2.d0 * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s) * tmpJ(ipoint,3)
+
+          tmpD(ipoint,1,p,s) = int2_grad1_u12(ipoint,1,p,s)
+          tmpD(ipoint,2,p,s) = int2_grad1_u12(ipoint,2,p,s)
+          tmpD(ipoint,3,p,s) = int2_grad1_u12(ipoint,3,p,s)
+          tmpD(ipoint,4,p,s) = wr1(ipoint) * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s)
+
+        enddo ! ipoint
+
+        tmpC(:,4,p,s) = 0.d0
+        do i = 1, ne_b
+          do ipoint = 1, n_grid
+            tmpC(ipoint,4,p,s) += int2_grad1_u12(ipoint,1,p,i) * int2_grad1_u12(ipoint,1,i,s) &
+                                + int2_grad1_u12(ipoint,2,p,i) * int2_grad1_u12(ipoint,2,i,s) &
+                                + int2_grad1_u12(ipoint,3,p,i) * int2_grad1_u12(ipoint,3,i,s)
+          enddo ! ipoint
+        enddo ! i
+        do i = ne_b+1, ne_a
+          do ipoint = 1, n_grid
+            tmpC(ipoint,4,p,s) += 0.5d0 * int2_grad1_u12(ipoint,1,p,i) * int2_grad1_u12(ipoint,1,i,s) &
+                                + 0.5d0 * int2_grad1_u12(ipoint,2,p,i) * int2_grad1_u12(ipoint,2,i,s) &
+                                + 0.5d0 * int2_grad1_u12(ipoint,3,p,i) * int2_grad1_u12(ipoint,3,i,s)
+          enddo ! ipoint
+        enddo ! i
+
+      enddo ! p
+    enddo ! s
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+    deallocate(tmpO, tmpJ, tmpA, tmpB)
+
+
+    call dgemm( 'T', 'N', n_mo*n_mo, n_mo*n_mo, 4*n_grid, 0.5d0  &
+              , tmpC(1,1,1,1), 4*n_grid, tmpD(1,1,1,1), 4*n_grid &
+              , 0.d0, tmpE(1,1,1,1), n_mo*n_mo)
+
+    deallocate(tmpC, tmpD)
+
+    call sum_a_at(tmpE, n_mo*n_mo)
+
+    !$OMP PARALLEL            &
+    !$OMP DEFAULT(NONE)       &
+    !$OMP PRIVATE(t, s, q, p) &
+    !$OMP SHARED(n_mo, tmpE, noL_2e)
+  
+    !$OMP DO COLLAPSE(3)
+    do t = 1, n_mo
+      do s = 1, n_mo
+        do q = 1, n_mo
+          do p = 1, n_mo
+            noL_2e(p,q,s,t) = tmpE(p,s,q,t)
+          enddo
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+  
+    deallocate(tmpE)
+
+  endif
+
+  call wall_time(t1)
+  write(*,"(A,2X,F15.7)") ' wall time for noL_2e (sec) = ', (t1 - t0)
+
+  return
+end
+
+! ---
+
+subroutine provide_no_2e_tmp(n_grid, n_mo, ne_a, ne_b, wr1, mos_l_in_r, mos_r_in_r, int2_grad1_u12, &
+                             tmpO, tmpJ, tmpA, tmpB, tmpC, tmpD, tmpE, noL_2e)
+
+  implicit none
+
+  integer,          intent(in)  :: n_grid, n_mo
+  integer,          intent(in)  :: ne_a, ne_b
+  double precision, intent(in)  :: wr1(n_grid)
+  double precision, intent(in)  :: mos_l_in_r(n_grid,n_mo)
+  double precision, intent(in)  :: mos_r_in_r(n_grid,n_mo)
+  double precision, intent(in)  :: int2_grad1_u12(n_grid,3,n_mo,n_mo)
+  double precision, intent(out) :: tmpO(n_grid), tmpJ(n_grid,3)
+  double precision, intent(out) :: tmpA(n_grid,3,n_mo), tmpB(n_grid,3,n_mo)
+  double precision, intent(out) :: tmpC(n_grid,4,n_mo,n_mo), tmpD(n_grid,4,n_mo,n_mo)
+  double precision, intent(out) :: tmpE(n_mo,n_mo,n_mo,n_mo)
+  double precision, intent(out) :: noL_2e(n_mo,n_mo,n_mo,n_mo)
+
+  integer                       :: p, q, s, t, i, ipoint
+  double precision              :: t0, t1
+
+
+  call wall_time(t0)
+
+  if(ne_a .eq. ne_b) then
+
+    tmpO = 0.d0
+    tmpJ = 0.d0
+    do i = 1, ne_b
+      do ipoint = 1, n_grid
+        tmpO(ipoint)   = tmpO(ipoint)   + wr1(ipoint) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,i)
+        tmpJ(ipoint,1) = tmpJ(ipoint,1) + wr1(ipoint) * int2_grad1_u12(ipoint,1,i,i)
+        tmpJ(ipoint,2) = tmpJ(ipoint,2) + wr1(ipoint) * int2_grad1_u12(ipoint,2,i,i)
+        tmpJ(ipoint,3) = tmpJ(ipoint,3) + wr1(ipoint) * int2_grad1_u12(ipoint,3,i,i)
+      enddo
+    enddo
+
+    !$OMP PARALLEL                       &
+    !$OMP DEFAULT(NONE)                  &
+    !$OMP PRIVATE(p, i, ipoint)          &
+    !$OMP SHARED(n_mo, ne_b, n_grid,     &
+    !$OMP        wr1,                    &
+    !$OMP        mos_l_in_r, mos_r_in_r, &
+    !$OMP        int2_grad1_u12,         &
+    !$OMP        tmpA, tmpB)
+  
+    !$OMP DO
+    do p = 1, n_mo
+
+      tmpA(:,:,p) = 0.d0
+      tmpB(:,:,p) = 0.d0
+      do i = 1, ne_b
+        do ipoint = 1, n_grid
+          tmpA(ipoint,1,p) = tmpA(ipoint,1,p) + wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,1,p,i)
+          tmpA(ipoint,2,p) = tmpA(ipoint,2,p) + wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,2,p,i)
+          tmpA(ipoint,3,p) = tmpA(ipoint,3,p) + wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,3,p,i)
+          tmpB(ipoint,1,p) = tmpB(ipoint,1,p) + wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,1,i,p)
+          tmpB(ipoint,2,p) = tmpB(ipoint,2,p) + wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,2,i,p)
+          tmpB(ipoint,3,p) = tmpB(ipoint,3,p) + wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,3,i,p)
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+
+    !$OMP PARALLEL                       &
+    !$OMP DEFAULT(NONE)                  &
+    !$OMP PRIVATE(p, s, i, ipoint)       &
+    !$OMP SHARED(n_mo, ne_b, n_grid,     & 
+    !$OMP        wr1,                    &
+    !$OMP        mos_l_in_r, mos_r_in_r, &
+    !$OMP        int2_grad1_u12,         &
+    !$OMP        tmpA, tmpB, tmpO, tmpJ, tmpC, tmpD)
+  
+    !$OMP DO COLLAPSE(2)
+    do s = 1, n_mo
+      do p = 1, n_mo
+
+        do ipoint = 1, n_grid
+
+          tmpC(ipoint,1,p,s) = mos_r_in_r(ipoint,s) * tmpA(ipoint,1,p)     &
+                             + mos_l_in_r(ipoint,p) * tmpB(ipoint,1,s)     &
+                             - tmpO(ipoint) * int2_grad1_u12(ipoint,1,p,s) &
+                             - 2.d0 * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s) * tmpJ(ipoint,1)
+          tmpC(ipoint,2,p,s) = mos_r_in_r(ipoint,s) * tmpA(ipoint,2,p)     &
+                             + mos_l_in_r(ipoint,p) * tmpB(ipoint,2,s)     &
+                             - tmpO(ipoint) * int2_grad1_u12(ipoint,2,p,s) &
+                             - 2.d0 * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s) * tmpJ(ipoint,2)
+          tmpC(ipoint,3,p,s) = mos_r_in_r(ipoint,s) * tmpA(ipoint,3,p)     &
+                             + mos_l_in_r(ipoint,p) * tmpB(ipoint,3,s)     &
+                             - tmpO(ipoint) * int2_grad1_u12(ipoint,3,p,s) &
+                             - 2.d0 * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s) * tmpJ(ipoint,3)
+
+          tmpD(ipoint,1,p,s) = int2_grad1_u12(ipoint,1,p,s)
+          tmpD(ipoint,2,p,s) = int2_grad1_u12(ipoint,2,p,s)
+          tmpD(ipoint,3,p,s) = int2_grad1_u12(ipoint,3,p,s)
+          tmpD(ipoint,4,p,s) = wr1(ipoint) * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s)
+
+        enddo ! ipoint
+
+        tmpC(:,4,p,s) = 0.d0
+        do i = 1, ne_b
+          do ipoint = 1, n_grid
+            tmpC(ipoint,4,p,s) += int2_grad1_u12(ipoint,1,p,i) * int2_grad1_u12(ipoint,1,i,s) &
+                                + int2_grad1_u12(ipoint,2,p,i) * int2_grad1_u12(ipoint,2,i,s) &
+                                + int2_grad1_u12(ipoint,3,p,i) * int2_grad1_u12(ipoint,3,i,s)
+          enddo ! ipoint
+        enddo ! i
+
+      enddo ! p
+    enddo ! s
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+
+    call dgemm( 'T', 'N', n_mo*n_mo, n_mo*n_mo, 4*n_grid, 0.5d0  &
+              , tmpC(1,1,1,1), 4*n_grid, tmpD(1,1,1,1), 4*n_grid &
+              , 0.d0, tmpE(1,1,1,1), n_mo*n_mo)
+
+    call sum_a_at(tmpE, n_mo*n_mo)
+
+    !$OMP PARALLEL            &
+    !$OMP DEFAULT(NONE)       &
+    !$OMP PRIVATE(t, s, q, p) &
+    !$OMP SHARED(n_mo, tmpE, noL_2e)
+  
+    !$OMP DO COLLAPSE(3)
+    do t = 1, n_mo
+      do s = 1, n_mo
+        do q = 1, n_mo
+          do p = 1, n_mo
+            noL_2e(p,q,s,t) = tmpE(p,s,q,t)
+          enddo
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+  
+  else
+
+    tmpO = 0.d0
+    tmpJ = 0.d0
+    do i = 1, ne_b
+      do ipoint = 1, n_grid
+        tmpO(ipoint)   = tmpO(ipoint)   + wr1(ipoint) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,i)
+        tmpJ(ipoint,1) = tmpJ(ipoint,1) + wr1(ipoint) * int2_grad1_u12(ipoint,1,i,i)
+        tmpJ(ipoint,2) = tmpJ(ipoint,2) + wr1(ipoint) * int2_grad1_u12(ipoint,2,i,i)
+        tmpJ(ipoint,3) = tmpJ(ipoint,3) + wr1(ipoint) * int2_grad1_u12(ipoint,3,i,i)
+      enddo
+    enddo
+    do i = ne_b+1, ne_a
+      do ipoint = 1, n_grid
+        tmpO(ipoint)   = tmpO(ipoint)   + 0.5d0 * wr1(ipoint) * mos_l_in_r(ipoint,i) * mos_r_in_r(ipoint,i)
+        tmpJ(ipoint,1) = tmpJ(ipoint,1) + 0.5d0 * wr1(ipoint) * int2_grad1_u12(ipoint,1,i,i)
+        tmpJ(ipoint,2) = tmpJ(ipoint,2) + 0.5d0 * wr1(ipoint) * int2_grad1_u12(ipoint,2,i,i)
+        tmpJ(ipoint,3) = tmpJ(ipoint,3) + 0.5d0 * wr1(ipoint) * int2_grad1_u12(ipoint,3,i,i)
+      enddo
+    enddo
+
+    !$OMP PARALLEL                         &
+    !$OMP DEFAULT(NONE)                    &
+    !$OMP PRIVATE(p, i, ipoint)            &
+    !$OMP SHARED(n_mo, ne_a, ne_b, n_grid, &
+    !$OMP        wr1,                      &
+    !$OMP        mos_l_in_r, mos_r_in_r,   &
+    !$OMP        int2_grad1_u12,           &
+    !$OMP        tmpA, tmpB)
+  
+    !$OMP DO
+    do p = 1, n_mo
+
+      tmpA(:,:,p) = 0.d0
+      tmpB(:,:,p) = 0.d0
+      do i = 1, ne_b
+        do ipoint = 1, n_grid
+          tmpA(ipoint,1,p) = tmpA(ipoint,1,p) + wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,1,p,i)
+          tmpA(ipoint,2,p) = tmpA(ipoint,2,p) + wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,2,p,i)
+          tmpA(ipoint,3,p) = tmpA(ipoint,3,p) + wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,3,p,i)
+          tmpB(ipoint,1,p) = tmpB(ipoint,1,p) + wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,1,i,p)
+          tmpB(ipoint,2,p) = tmpB(ipoint,2,p) + wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,2,i,p)
+          tmpB(ipoint,3,p) = tmpB(ipoint,3,p) + wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,3,i,p)
+        enddo
+      enddo
+      do i = ne_b+1, ne_a
+        do ipoint = 1, n_grid
+          tmpA(ipoint,1,p) = tmpA(ipoint,1,p) + 0.5d0 * wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,1,p,i)
+          tmpA(ipoint,2,p) = tmpA(ipoint,2,p) + 0.5d0 * wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,2,p,i)
+          tmpA(ipoint,3,p) = tmpA(ipoint,3,p) + 0.5d0 * wr1(ipoint) * mos_l_in_r(ipoint,i) * int2_grad1_u12(ipoint,3,p,i)
+          tmpB(ipoint,1,p) = tmpB(ipoint,1,p) + 0.5d0 * wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,1,i,p)
+          tmpB(ipoint,2,p) = tmpB(ipoint,2,p) + 0.5d0 * wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,2,i,p)
+          tmpB(ipoint,3,p) = tmpB(ipoint,3,p) + 0.5d0 * wr1(ipoint) * mos_r_in_r(ipoint,i) * int2_grad1_u12(ipoint,3,i,p)
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+
+    !$OMP PARALLEL                         &
+    !$OMP DEFAULT(NONE)                    &
+    !$OMP PRIVATE(p, s, i, ipoint)         &
+    !$OMP SHARED(n_mo, ne_a, ne_b, n_grid, &
+    !$OMP        wr1,                      &
+    !$OMP        mos_l_in_r, mos_r_in_r,   &
+    !$OMP        int2_grad1_u12,           &
+    !$OMP        tmpA, tmpB, tmpO, tmpJ, tmpC, tmpD)
+  
+    !$OMP DO COLLAPSE(2)
+    do s = 1, n_mo
+      do p = 1, n_mo
+
+        do ipoint = 1, n_grid
+
+          tmpC(ipoint,1,p,s) = mos_r_in_r(ipoint,s) * tmpA(ipoint,1,p)     &
+                             + mos_l_in_r(ipoint,p) * tmpB(ipoint,1,s)     &
+                             - tmpO(ipoint) * int2_grad1_u12(ipoint,1,p,s) &
+                             - 2.d0 * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s) * tmpJ(ipoint,1)
+          tmpC(ipoint,2,p,s) = mos_r_in_r(ipoint,s) * tmpA(ipoint,2,p)     &
+                             + mos_l_in_r(ipoint,p) * tmpB(ipoint,2,s)     &
+                             - tmpO(ipoint) * int2_grad1_u12(ipoint,2,p,s) &
+                             - 2.d0 * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s) * tmpJ(ipoint,2)
+          tmpC(ipoint,3,p,s) = mos_r_in_r(ipoint,s) * tmpA(ipoint,3,p)     &
+                             + mos_l_in_r(ipoint,p) * tmpB(ipoint,3,s)     &
+                             - tmpO(ipoint) * int2_grad1_u12(ipoint,3,p,s) &
+                             - 2.d0 * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s) * tmpJ(ipoint,3)
+
+          tmpD(ipoint,1,p,s) = int2_grad1_u12(ipoint,1,p,s)
+          tmpD(ipoint,2,p,s) = int2_grad1_u12(ipoint,2,p,s)
+          tmpD(ipoint,3,p,s) = int2_grad1_u12(ipoint,3,p,s)
+          tmpD(ipoint,4,p,s) = wr1(ipoint) * mos_l_in_r(ipoint,p) * mos_r_in_r(ipoint,s)
+
+        enddo ! ipoint
+
+        tmpC(:,4,p,s) = 0.d0
+        do i = 1, ne_b
+          do ipoint = 1, n_grid
+            tmpC(ipoint,4,p,s) += int2_grad1_u12(ipoint,1,p,i) * int2_grad1_u12(ipoint,1,i,s) &
+                                + int2_grad1_u12(ipoint,2,p,i) * int2_grad1_u12(ipoint,2,i,s) &
+                                + int2_grad1_u12(ipoint,3,p,i) * int2_grad1_u12(ipoint,3,i,s)
+          enddo ! ipoint
+        enddo ! i
+        do i = ne_b+1, ne_a
+          do ipoint = 1, n_grid
+            tmpC(ipoint,4,p,s) += 0.5d0 * int2_grad1_u12(ipoint,1,p,i) * int2_grad1_u12(ipoint,1,i,s) &
+                                + 0.5d0 * int2_grad1_u12(ipoint,2,p,i) * int2_grad1_u12(ipoint,2,i,s) &
+                                + 0.5d0 * int2_grad1_u12(ipoint,3,p,i) * int2_grad1_u12(ipoint,3,i,s)
+          enddo ! ipoint
+        enddo ! i
+
+      enddo ! p
+    enddo ! s
+    !$OMP END DO
+    !$OMP END PARALLEL
+
+
+    call dgemm( 'T', 'N', n_mo*n_mo, n_mo*n_mo, 4*n_grid, 0.5d0  &
+              , tmpC(1,1,1,1), 4*n_grid, tmpD(1,1,1,1), 4*n_grid &
+              , 0.d0, tmpE(1,1,1,1), n_mo*n_mo)
+
+    call sum_a_at(tmpE, n_mo*n_mo)
+
+    !$OMP PARALLEL            &
+    !$OMP DEFAULT(NONE)       &
+    !$OMP PRIVATE(t, s, q, p) &
+    !$OMP SHARED(n_mo, tmpE, noL_2e)
+  
+    !$OMP DO COLLAPSE(3)
+    do t = 1, n_mo
+      do s = 1, n_mo
+        do q = 1, n_mo
+          do p = 1, n_mo
+            noL_2e(p,q,s,t) = tmpE(p,s,q,t)
+          enddo
+        enddo
+      enddo
+    enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
+  
+  endif
+
+  call wall_time(t1)
+  write(*,"(A,2X,F15.7)") ' wall time for noL_2e & tmp tensors (sec) = ', (t1 - t0)
+
+  return
+end
+
+! ---
+
+

plugins/local/tc_int/uninstall

@@ -0,0 +1,13 @@
+#!/bin/bash
+
+# Check if the QP_ROOT environment variable is set.
+if [[ -z ${QP_ROOT} ]]
+then
+  print "The QP_ROOT environment variable is not set."
+  print "Please reload the quantum_package.rc file."
+  exit -1
+fi
+
+rm -rf ${PWD}/CuTC
+rm -f ${QP_ROOT}/lib/libcutcint.so
+

plugins/local/tc_int/write_tc_int_cuda.irp.f

@@ -0,0 +1,194 @@
+! ---
+
+program write_tc_int_cuda
+
+  implicit none
+
+  print *, ' j2e_type = ', j2e_type
+  print *, ' j1e_type = ', j1e_type
+  print *, ' env_type = ', env_type
+
+  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
+
+  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_grid, 'radial  external grid over')
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+  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')
+
+  call main()
+
+end
+
+! ---
+
+subroutine main()
+
+  implicit none
+
+  PROVIDE io_tc_integ
+
+  print*, 'io_tc_integ = ', io_tc_integ
+
+  if(io_tc_integ .ne. "Write") then
+    print*, 'io_tc_integ != Write'
+    print*, io_tc_integ
+    stop
+  endif
+
+  call do_work_on_gpu()
+
+  call ezfio_set_tc_keywords_io_tc_integ('Read')
+
+end
+
+! ---
+
+subroutine do_work_on_gpu()
+
+  use cutc_module
+
+  implicit none
+
+  integer :: k, ipoint
+
+  double precision, allocatable :: rn(:,:), aos_data1(:,:,:), aos_data2(:,:,:)
+  double precision, allocatable :: int2_grad1_u12_ao(:,:,:,:)
+  double precision, allocatable :: int_2e_ao(:,:,:,:)
+
+  double precision :: time0, time1
+  double precision :: cuda_time0, cuda_time1
+
+  call wall_time(time0)
+  print*, ' start calculation of TC-integrals'
+
+  allocate(rn(3,nucl_num))
+  allocate(aos_data1(n_points_final_grid,ao_num,4))
+  allocate(aos_data2(n_points_extra_final_grid,ao_num,4))
+  allocate(int2_grad1_u12_ao(ao_num,ao_num,n_points_final_grid,3))
+  allocate(int_2e_ao(ao_num,ao_num,ao_num,ao_num))
+
+
+  do k = 1, nucl_num
+    rn(1,k) = nucl_coord(k,1)
+    rn(2,k) = nucl_coord(k,2)
+    rn(3,k) = nucl_coord(k,3)
+  enddo
+
+  do k = 1, ao_num
+    do ipoint = 1, n_points_final_grid
+      aos_data1(ipoint,k,1) = aos_in_r_array(k,ipoint)
+      aos_data1(ipoint,k,2) = aos_grad_in_r_array(k,ipoint,1)
+      aos_data1(ipoint,k,3) = aos_grad_in_r_array(k,ipoint,2)
+      aos_data1(ipoint,k,4) = aos_grad_in_r_array(k,ipoint,3)
+    enddo
+
+    do ipoint = 1, n_points_extra_final_grid
+      aos_data2(ipoint,k,1) = aos_in_r_array_extra(k,ipoint)
+      aos_data2(ipoint,k,2) = aos_grad_in_r_array_extra(k,ipoint,1)
+      aos_data2(ipoint,k,3) = aos_grad_in_r_array_extra(k,ipoint,2)
+      aos_data2(ipoint,k,4) = aos_grad_in_r_array_extra(k,ipoint,3)
+    enddo
+  enddo
+
+  ! ---
+
+  integer :: nB
+  integer :: sB
+
+  PROVIDE nxBlocks nyBlocks nzBlocks
+  PROVIDE blockxSize blockySize blockzSize
+
+  sB = 32
+  nB = (n_points_final_grid + sB - 1) / sB
+
+  call ezfio_set_tc_int_blockxSize(sB)
+  call ezfio_set_tc_int_nxBlocks(nB)
+
+
+
+  call wall_time(cuda_time0)
+  print*, ' start CUDA kernel'
+
+  call cutc_int(nxBlocks, nyBlocks, nzBlocks, blockxSize, blockySize, blockzSize,           &
+                n_points_final_grid, n_points_extra_final_grid, ao_num, nucl_num, jBH_size, &
+                final_grid_points, final_weight_at_r_vector,                                &
+                final_grid_points_extra, final_weight_at_r_vector_extra,                    &
+                rn, aos_data1, aos_data2, jBH_c, jBH_m, jBH_n, jBH_o,                       &
+                int2_grad1_u12_ao, int_2e_ao)
+
+  call wall_time(cuda_time1)
+  print*, ' wall time for CUDA kernel (min) = ', (cuda_time1-cuda_time0) / 60.d0
+
+  deallocate(aos_data1, aos_data2)
+
+  ! ---
+
+  integer :: i, j, l
+  double precision :: t1, t2
+  double precision :: tmp
+  double precision, external :: get_ao_two_e_integral
+
+  call wall_time(t1)
+
+  PROVIDE ao_integrals_map
+  tmp = get_ao_two_e_integral(1, 1, 1, 1, ao_integrals_map)
+
+  !$OMP PARALLEL DEFAULT(NONE)                      &
+  !$OMP SHARED(ao_num, int_2e_ao, ao_integrals_map) &
+  !$OMP PRIVATE(i, j, k, l)
+  !$OMP DO COLLAPSE(3)
+  do j = 1, ao_num
+    do l = 1, ao_num
+      do i = 1, ao_num
+        do k = 1, ao_num
+          !                                         < 1:i, 2:j | 1:k, 2:l >
+          int_2e_ao(k,i,l,j) = int_2e_ao(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  call wall_time(t2)
+  print*, ' wall time of Coulomb part of tc_int_2e_ao (min) ', (t2 - t1) / 60.d0
+
+  ! ---
+
+  print*, ' Writing int2_grad1_u12_ao in ', trim(ezfio_filename) // '/work/int2_grad1_u12_ao'
+  open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="write")
+    call ezfio_set_work_empty(.False.)
+    write(11) int2_grad1_u12_ao
+  close(11)
+  deallocate(int2_grad1_u12_ao)
+
+  print*, ' Saving tc_int_2e_ao in ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot'
+  open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="write")
+  call ezfio_set_work_empty(.False.)
+  do k = 1, ao_num
+    write(11) int_2e_ao(:,:,:,k)
+  enddo
+  close(11)
+  deallocate(int_2e_ao)
+
+  ! ----
+
+
+  call wall_time(time1)
+  print*, ' wall time for TC-integrals (min) = ', (time1-time0) / 60.d0
+
+  return
+end
+
+! ---

plugins/local/tc_int/write_tc_int_gpu.irp.f

@@ -0,0 +1,56 @@
+! ---
+
+program write_tc_int_gpu
+
+  implicit none
+
+  print *, ' j2e_type = ', j2e_type
+  print *, ' j1e_type = ', j1e_type
+  print *, ' env_type = ', env_type
+
+  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
+
+  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_grid, 'radial  external grid over')
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+  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')
+
+  call main()
+
+end
+
+! ---
+
+subroutine main()
+
+  implicit none
+
+  PROVIDE io_tc_integ
+
+  print*, 'io_tc_integ = ', io_tc_integ
+
+  if(io_tc_integ .ne. "Write") then
+    print*, 'io_tc_integ != Write'
+    print*, io_tc_integ
+    stop
+  endif
+
+  call provide_int2_grad1_u12_ao_gpu()
+
+  call ezfio_set_tc_keywords_io_tc_integ('Read')
+
+end
+
+! ---
+

plugins/local/tc_keywords/EZFIO.cfg

@@ -230,7 +230,7 @@ default: 70
 type: character*(32)
 doc: approach used to evaluate TC integrals [ analytic | numeric | semi-analytic ]
 interface: ezfio,ocaml,provider
-default: semi-analytic
+default: numeric
 
 [minimize_lr_angles]
 type: logical

plugins/local/tc_scf/tc_scf_energy.irp.f

@@ -28,7 +28,7 @@
     enddo
   enddo
 
-  if((three_body_h_tc .eq. .False.) .and. (.not. noL_standard)) then
+  if((three_body_h_tc .eqv. .False.) .and. (.not. noL_standard)) then
     TC_HF_three_e_energy = 0.d0
   else
     TC_HF_three_e_energy = noL_0e

scripts/qp_import_trexio.py

@@ -261,13 +261,10 @@ def write_ezfio(trexio_filename, filename):
     except:
         cartesian = True
 
-    if not cartesian:
-        raise TypeError('Only cartesian TREXIO files can be converted')
-
     ao_num = trexio.read_ao_num(trexio_file)
     ezfio.set_ao_basis_ao_num(ao_num)
 
-    if shell_num > 0:
+    if cartesian and shell_num > 0:
         ao_shell    = trexio.read_ao_shell(trexio_file)
         at = [ nucl_index[i]+1 for i in ao_shell ]
         ezfio.set_ao_basis_ao_nucl(at)
@@ -330,7 +327,7 @@ def write_ezfio(trexio_filename, filename):
         print("OK")
 
     else:
-        print("None")
+        print("None: integrals should be also imported using qp run import_trexio_integrals")
 
 
     #                _

src/ao_two_e_ints/cholesky.irp.f

@@ -73,7 +73,7 @@ END_PROVIDER
    integer, external              :: getUnitAndOpen
    integer                        :: iunit, ierr
 
-   ndim8 = ao_num*ao_num*1_8
+   ndim8 = ao_num*ao_num*1_8+1
    double precision :: wall0,wall1
 
    type(c_ptr)                    :: c_pointer(2)
@@ -143,19 +143,21 @@ END_PROVIDER
 
      if (do_direct_integrals) then
        !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i8) SCHEDULE(dynamic,21)
-       do i8=ndim8,1,-1
+       do i8=ndim8-1,1,-1
          D(i8) = ao_two_e_integral(addr1(i8), addr2(i8),              &
              addr1(i8), addr2(i8))
        enddo
        !$OMP END PARALLEL DO
      else
        !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i8) SCHEDULE(dynamic,21)
-       do i8=ndim8,1,-1
+       do i8=ndim8-1,1,-1
          D(i8) = get_ao_two_e_integral(addr1(i8), addr1(i8),          &
              addr2(i8), addr2(i8), ao_integrals_map)
        enddo
        !$OMP END PARALLEL DO
      endif
+     ! Just to guarentee termination 
+     D(ndim8) = 0.d0
 
      D_sorted(:) = -D(:)
      call dsort_noidx_big(D_sorted,ndim8)
@@ -203,6 +205,7 @@ END_PROVIDER
      do while ( (Dmax > tau).and.(np > 0) )
        ! a.
        i = i+1
+       
 
 
        block_size = max(N,24)
@@ -314,9 +317,10 @@ END_PROVIDER
        ! g.
 
        iblock = 0
+       
        do j=1,nq
 
-         if ( (Qmax <= Dmin).or.(N+j*1_8 > ndim8) ) exit
+         if ( (Qmax < Dmin).or.(N+j*1_8 > ndim8) ) exit
 
          ! i.
          rank = N+j

src/determinants/generate_cas_space.irp.f

@@ -33,7 +33,7 @@ subroutine generate_cas_space
   print *, 'CAS(', n_alpha_act+n_beta_act, ', ', n_act_orb, ')'
   print *, ''
 
-  n_det_alpha_unique = binom_int(n_act_orb, n_alpha_act)
+  n_det_alpha_unique = int(binom_int(n_act_orb, n_alpha_act),4)
   TOUCH n_det_alpha_unique
 
   n = n_alpha_act
@@ -56,7 +56,7 @@ subroutine generate_cas_space
     u = ior(t1,t2)
   enddo
 
-  n_det_beta_unique = binom_int(n_act_orb, n_beta_act)
+  n_det_beta_unique = int(binom_int(n_act_orb, n_beta_act),4)
   TOUCH n_det_beta_unique
 
   n = n_beta_act

src/dft_utils_in_r/ao_in_r.irp.f

@@ -52,35 +52,39 @@ END_PROVIDER
 
 BEGIN_PROVIDER[double precision, aos_grad_in_r_array, (ao_num,n_points_final_grid,3)]
 
- BEGIN_DOC
+  BEGIN_DOC
- ! aos_grad_in_r_array(i,j,k)          = value of the kth component of the gradient of ith ao on the jth grid point
+  !
- !
+  ! aos_grad_in_r_array(i,j,k) = value of the kth component of the gradient of ith ao on the jth grid point
- ! k = 1 : x, k= 2, y, k  3, z
+  !
- END_DOC
+  ! k = 1 : x, k= 2, y, k  3, z
+  !
+  END_DOC
 
- implicit none
+  implicit none
- integer :: i,j,m
+  integer          :: i, j, m
- double precision :: aos_array(ao_num), r(3)
+  double precision :: aos_array(ao_num), r(3)
- double precision :: aos_grad_array(3,ao_num)
+  double precision :: aos_grad_array(3,ao_num)
- !$OMP PARALLEL DO &
+
- !$OMP DEFAULT (NONE)  &
+  !$OMP PARALLEL DO                                &
- !$OMP PRIVATE (i,r,aos_array,aos_grad_array,j,m) & 
+  !$OMP DEFAULT (NONE)                             &
- !$OMP SHARED(aos_grad_in_r_array,n_points_final_grid,ao_num,final_grid_points)
+  !$OMP PRIVATE (i,j,m,r,aos_array,aos_grad_array) & 
- do i = 1, n_points_final_grid
+  !$OMP SHARED(aos_grad_in_r_array,n_points_final_grid,ao_num,final_grid_points)
-  r(1) = final_grid_points(1,i)
+  do i = 1, n_points_final_grid
-  r(2) = final_grid_points(2,i)
+    r(1) = final_grid_points(1,i)
-  r(3) = final_grid_points(3,i)
+    r(2) = final_grid_points(2,i)
-  call give_all_aos_and_grad_at_r(r,aos_array,aos_grad_array)
+    r(3) = final_grid_points(3,i)
-  do m = 1, 3
+    call give_all_aos_and_grad_at_r(r,aos_array,aos_grad_array)
-   do j = 1, ao_num
+    do m = 1, 3
-    aos_grad_in_r_array(j,i,m) = aos_grad_array(m,j)
+      do j = 1, ao_num
-   enddo
+        aos_grad_in_r_array(j,i,m) = aos_grad_array(m,j)
+      enddo
+    enddo
   enddo
- enddo
+  !$OMP END PARALLEL DO
- !$OMP END PARALLEL DO
 
+END_PROVIDER 
 
- END_PROVIDER 
+! ---
 
 
  BEGIN_PROVIDER[double precision, aos_grad_in_r_array_transp, (3,ao_num,n_points_final_grid)]
@@ -205,18 +209,53 @@ BEGIN_PROVIDER[double precision, aos_grad_in_r_array, (ao_num,n_points_final_gri
  END_PROVIDER
 
 
- BEGIN_PROVIDER[double precision, aos_in_r_array_extra_transp, (n_points_extra_final_grid,ao_num)]
+! ---
- implicit none
+
- BEGIN_DOC
+BEGIN_PROVIDER[double precision, aos_in_r_array_extra_transp, (n_points_extra_final_grid,ao_num)]
- ! aos_in_r_array_extra_transp(i,j) = value of the jth ao on the ith grid point
+
- END_DOC
+  BEGIN_DOC
- integer :: i,j
+  ! aos_in_r_array_extra_transp(i,j) = value of the jth ao on the ith grid point
- double precision :: aos_array(ao_num), r(3)
+  END_DOC
- do i = 1, n_points_extra_final_grid
+ 
-  do j = 1, ao_num
+  implicit none
-   aos_in_r_array_extra_transp(i,j) = aos_in_r_array_extra(j,i)
+  integer          :: i, j
+  double precision :: aos_array(ao_num), r(3)
+
+  do i = 1, n_points_extra_final_grid
+    do j = 1, ao_num
+      aos_in_r_array_extra_transp(i,j) = aos_in_r_array_extra(j,i)
+    enddo
   enddo
- enddo
 
- END_PROVIDER
+END_PROVIDER
+
+! ---
+
+BEGIN_PROVIDER[double precision, aos_grad_in_r_array_extra, (ao_num,n_points_extra_final_grid,3)]
+
+  implicit none
+  integer          :: i, j, m
+  double precision :: aos_array(ao_num), r(3)
+  double precision :: aos_grad_array(3,ao_num)
+
+  !$OMP PARALLEL DO                                &
+  !$OMP DEFAULT (NONE)                             &
+  !$OMP PRIVATE (i,j,m,r,aos_array,aos_grad_array) & 
+  !$OMP SHARED(aos_grad_in_r_array_extra,n_points_extra_final_grid,ao_num,final_grid_points_extra)
+  do i = 1, n_points_extra_final_grid
+    r(1) = final_grid_points_extra(1,i)
+    r(2) = final_grid_points_extra(2,i)
+    r(3) = final_grid_points_extra(3,i)
+    call give_all_aos_and_grad_at_r(r, aos_array, aos_grad_array)
+    do m = 1, 3
+      do j = 1, ao_num
+        aos_grad_in_r_array_extra(j,i,m) = aos_grad_array(m,j)
+      enddo
+    enddo
+  enddo
+  !$OMP END PARALLEL DO
+
+END_PROVIDER 
+
+! ---
 

src/gpu/gpu_module.F90

@@ -143,7 +143,7 @@ module gpu
       b, ldb, c, ldc) bind(C, name='gpu_dgeam')
       import
       type(c_ptr), value, intent(in)        :: handle
-      character(c_char), intent(in), value  :: transa, transb
+      character(c_char), intent(in)         :: transa, transb
       integer(c_int64_t), intent(in), value :: m, n, lda, ldb, ldc
       real(c_double), intent(in)            :: alpha, beta
       type(c_ptr), value :: a, b, c
@@ -153,7 +153,7 @@ module gpu
       b, ldb, c, ldc) bind(C, name='gpu_sgeam')
       import
       type(c_ptr), value, intent(in)        :: handle
-      character(c_char), intent(in), value  :: transa, transb
+      character(c_char), intent(in)         :: transa, transb
       integer(c_int64_t), intent(in), value :: m, n, lda, ldb, ldc
       real(c_float), intent(in)             :: alpha, beta
       real(c_float) :: a, b, c
@@ -194,7 +194,7 @@ module gpu
       b, ldb, beta, c, ldc) bind(C, name='gpu_sgemm')
       import
       type(c_ptr), value, intent(in)        :: handle
-      character(c_char), intent(in), value  :: transa, transb
+      character(c_char), intent(in)         :: transa, transb
       integer(c_int64_t), intent(in), value :: m, n, k, lda, ldb, ldc
       real(c_float), intent(in)             :: alpha, beta
       real(c_float) :: a, b, c

src/mol_properties/print_properties.irp.f

@@ -100,7 +100,7 @@ subroutine print_transition_dipole_moment
       dip_str = d_x**2 + d_y**2 + d_z**2
       d = multi_s_dipole_moment(istate,jstate)
       f = 2d0/3d0 * d * d * dabs(ci_energy_no_diag(istate) - ci_energy_no_diag(jstate))
-      write(*,'(I4,I4,A4,I3,6(F12.6))') (istate-1), (jstate-1), '  ->', (istate-1), d_x, d_y, d_z, d, dip_str, f
+      write(*,'(I4,I4,A4,I3,6(F12.6))') (jstate -1) * (2*N_states-jstate)/2 + istate - jstate, (jstate-1), '  ->', (istate-1), d_x, d_y, d_z, d, dip_str, f
     enddo
   enddo
 
@@ -117,7 +117,7 @@ subroutine print_transition_dipole_moment
       dip_str = d_x**2 + d_y**2 + d_z**2
       f = 2d0/3d0 * d * d * dabs(ci_energy_no_diag(istate) - ci_energy_no_diag(jstate))
       d = multi_s_dipole_moment(istate,jstate) * au_to_D
-      write(*,'(I4,I4,A4,I3,6(F12.6))') (istate-1), (jstate-1), '  ->', (istate-1), d_x, d_y, d_z, d, dip_str, f
+      write(*,'(I4,I4,A4,I3,6(F12.6))') (jstate -1) * (2*N_states-jstate)/2 + istate - jstate, (jstate-1), '  ->', (istate-1), d_x, d_y, d_z, d, dip_str, f
     enddo
   enddo
   print*,'=============================================='
@@ -181,10 +181,9 @@ subroutine print_oscillator_strength
       ! Mixed gauge
       f_m = 2d0/3d0 * d * v
 
-      write(*,'(A19,I3,A9,F10.6,A5,F7.1,A10,F9.6,A6,F9.6,A6,F9.6,A8,F7.3)') '   #  Transition n.', (istate-1), ': Excit.=', dabs((ci_energy_no_diag(istate) - ci_energy_no_diag(jstate)))*ha_to_ev, &
+      write(*,'(A19,I3,A9,F10.6,A5,F7.1,A10,F9.6,A6,F9.6,A6,F9.6,A8,F7.3)') '   #  Transition n.', (jstate -1) * (2*N_states-jstate)/2 + istate - jstate, ': Excit.=', dabs((ci_energy_no_diag(istate) - ci_energy_no_diag(jstate)))*ha_to_ev, &
       ' eV ( ',dabs((ci_energy_no_diag(istate) - ci_energy_no_diag(jstate)))*Ha_to_nm,' nm), f_l=',f_l, ', f_v=', f_v, ', f_m=', f_m, ', <S^2>=', s2_values(istate)
       !write(*,'(I4,I4,A4,I3,A6,F6.1,A6,F6.1)') (istate-1), (jstate-1), '  ->', (istate-1), ', %T1=', percent_exc(2,istate), ', %T2=',percent_exc(3,istate)
-  
     enddo
   enddo
 

src/mu_of_r/test_proj_op.irp.f

@@ -12,15 +12,12 @@ program projected_operators
   mu_of_r_potential = "cas_full"
   touch mu_of_r_potential 
   print*,'Using Valence Only functions'
-!  call test_f_HF_valence_ab
+  call test_f_HF_valence_ab
-!  call routine_full_mos
+  call routine_full_mos
-!   call test_f_ii_valence_ab
+  call test_f_ii_valence_ab
-!   call test_f_ia_valence_ab
+  call test_f_ia_valence_ab
-!  call test_f_ii_ia_aa_valence_ab
+  call test_f_ii_ia_aa_valence_ab
-! call test
+  call test
-!  call test_f_mean_field
-! call test_grad_f_mean_field
- call test_grad_mu_mf
 end
 
 
@@ -39,138 +36,3 @@ subroutine test
 
 end
 
-subroutine test_f_mean_field
- implicit none
- integer :: i_point
- double precision :: weight,r(3)
- double precision :: ref_f, new_f, accu_f
- double precision :: ref_two_dens, new_two_dens, accu_two_dens, dm_a, dm_b
- accu_f = 0.d0
- accu_two_dens = 0.d0
- do i_point = 1, n_points_final_grid
-  r(1:3)   = final_grid_points(1:3,i_point)
-  weight = final_weight_at_r_vector(i_point)
-  call get_f_mf_ab(r,new_f,new_two_dens, dm_a, dm_b)
-  call f_HF_valence_ab(r,r,ref_f,ref_two_dens)
-  accu_f += weight * dabs(new_f- ref_f)
-  accu_two_dens += weight * dabs(new_two_dens - ref_two_dens)
- enddo
- print*,'accu_f        = ',accu_f
- print*,'accu_two_dens = ',accu_two_dens
-
-end
-
-subroutine test_grad_f_mean_field
- implicit none
- integer :: i_point,k
- double precision :: weight,r(3)
- double precision :: grad_f_mf_ab(3), grad_two_bod_dens(3)
- double precision :: grad_dm_a(3), grad_dm_b(3)
- double precision :: f_mf_ab,two_bod_dens, dm_a, dm_b
-
- double precision :: num_grad_f_mf_ab(3), num_grad_two_bod_dens(3)
- double precision :: num_grad_dm_a(3), num_grad_dm_b(3)
- double precision :: f_mf_ab_p,f_mf_ab_m
- double precision :: two_bod_dens_p, two_bod_dens_m
- double precision :: dm_a_p, dm_a_m
- double precision :: dm_b_p, dm_b_m
- double precision :: rbis(3), dr
- double precision :: accu_grad_f_mf_ab(3),accu_grad_two_bod_dens(3)
- double precision :: accu_grad_dm_a(3),accu_grad_dm_b(3)
- double precision :: accu_f_mf_ab, accu_two_bod_dens, accu_dm_a, accu_dm_b
- dr = 0.00001d0
- accu_f_mf_ab = 0.d0 
- accu_two_bod_dens = 0.d0 
- accu_dm_a = 0.d0 
- accu_dm_b = 0.d0
-
- accu_grad_f_mf_ab = 0.d0
- accu_grad_two_bod_dens = 0.d0
- accu_grad_dm_a = 0.d0
- accu_grad_dm_b = 0.d0
- do i_point = 1, n_points_final_grid
-  r(1:3)   = final_grid_points(1:3,i_point)
-  weight = final_weight_at_r_vector(i_point)
-  call get_grad_f_mf_ab(r,grad_f_mf_ab, grad_two_bod_dens,f_mf_ab,two_bod_dens, dm_a, dm_b,grad_dm_a, grad_dm_b)
-  call get_f_mf_ab(r,f_mf_ab_p,two_bod_dens_p, dm_a_p, dm_b_p)
-  accu_f_mf_ab += weight * dabs(f_mf_ab - f_mf_ab_p)
-  accu_two_bod_dens += weight * dabs(two_bod_dens - two_bod_dens_p)
-  accu_dm_a += weight*dabs(dm_a - dm_a_p)
-  accu_dm_b += weight*dabs(dm_b - dm_b_p)
-  do k = 1, 3
-   rbis = r
-   rbis(k) += dr
-   call get_f_mf_ab(rbis,f_mf_ab_p,two_bod_dens_p, dm_a_p, dm_b_p)
-   rbis = r
-   rbis(k) -= dr
-   call get_f_mf_ab(rbis,f_mf_ab_m,two_bod_dens_m, dm_a_m, dm_b_m)
-   num_grad_f_mf_ab(k) = (f_mf_ab_p - f_mf_ab_m)/(2.d0*dr)
-   num_grad_two_bod_dens(k) = (two_bod_dens_p - two_bod_dens_m)/(2.d0*dr)
-   num_grad_dm_a(k) = (dm_a_p - dm_a_m)/(2.d0*dr)
-   num_grad_dm_b(k) = (dm_b_p - dm_b_m)/(2.d0*dr)
-  enddo
-  do k = 1, 3
-   accu_grad_f_mf_ab(k) += weight * dabs(grad_f_mf_ab(k) - num_grad_f_mf_ab(k))
-   accu_grad_two_bod_dens(k) += weight * dabs(grad_two_bod_dens(k) - num_grad_two_bod_dens(k))
-   accu_grad_dm_a(k) += weight * dabs(grad_dm_a(k) - num_grad_dm_a(k))
-   accu_grad_dm_b(k) += weight * dabs(grad_dm_b(k) - num_grad_dm_b(k))
-  enddo
- enddo
- print*,'accu_f_mf_ab = ',accu_f_mf_ab
- print*,'accu_two_bod_dens = ',accu_two_bod_dens
- print*,'accu_dm_a = ',accu_dm_a
- print*,'accu_dm_b = ',accu_dm_b
- print*,'accu_grad_f_mf_ab = '
- print*,accu_grad_f_mf_ab
- print*,'accu_grad_two_bod_dens = '
- print*,accu_grad_two_bod_dens
- print*,'accu_dm_a = '
- print*,accu_grad_dm_a
- print*,'accu_dm_b = '
- print*,accu_grad_dm_b
-
-end
-
-subroutine test_grad_mu_mf
- implicit none
- integer :: i_point,k
- double precision :: weight,r(3),rbis(3)
- double precision :: mu_mf, dm,grad_mu_mf(3), grad_dm(3)
- double precision :: mu_mf_p, mu_mf_m, dm_m, dm_p, num_grad_mu_mf(3),dr, num_grad_dm(3)
- double precision :: accu_mu, accu_dm, accu_grad_dm(3), accu_grad_mu_mf(3)
- dr = 0.00001d0
- accu_grad_mu_mf = 0.d0
- accu_mu = 0.d0
- accu_grad_dm = 0.d0
- accu_dm = 0.d0
- do i_point = 1, n_points_final_grid
-  r(1:3)   = final_grid_points(1:3,i_point)
-  weight = final_weight_at_r_vector(i_point)
-  call grad_mu_of_r_mean_field(r,mu_mf, dm, grad_mu_mf, grad_dm)
-  call mu_of_r_mean_field(r,mu_mf_p, dm_p)
-  accu_mu += weight*dabs(mu_mf_p - mu_mf)
-  accu_dm += weight*dabs(dm_p - dm)
-  do k = 1, 3
-   rbis = r
-   rbis(k) += dr
-   call mu_of_r_mean_field(rbis,mu_mf_p, dm_p)
-   rbis = r
-   rbis(k) -= dr
-   call mu_of_r_mean_field(rbis,mu_mf_m, dm_m)
-
-   num_grad_mu_mf(k) = (mu_mf_p - mu_mf_m)/(2.d0*dr)
-   num_grad_dm(k) = (dm_p - dm_m)/(2.d0*dr)
-  enddo
-  do k = 1, 3
-   accu_grad_dm(k)+= weight *dabs(num_grad_dm(k) - grad_dm(k))
-   accu_grad_mu_mf(k)+= weight *dabs(num_grad_mu_mf(k) - grad_mu_mf(k))
-  enddo
- enddo
- print*,'accu_mu = ',accu_mu
- print*,'accu_dm = ',accu_dm
- print*,'accu_grad_dm = '
- print*, accu_grad_dm
- print*,'accu_grad_mu_mf = '
- print*, accu_grad_mu_mf
-
-end

src/scf_utils/EZFIO.cfg

@@ -45,6 +45,12 @@ type: double precision
 doc: Calculated HF energy
 interface: ezfio
 
+[do_mom]
+type: logical
+doc: If true, this will run a MOM calculation. The overlap will be computed at each step with respect to the initial MOs. After an initial Hartree-Fock calculation, the guess can be created by swapping molecular orbitals through the qp run swap_mos command. 
+interface: ezfio,provider,ocaml
+default: False
+
 [frozen_orb_scf]
 type: logical
 doc: If true, leave untouched all the orbitals defined as core and optimize all the orbitals defined as active with qp_set_mo_class

src/scf_utils/reorder_mo_max_overlap.irp.f

@@ -0,0 +1,96 @@
+ subroutine reorder_mo_max_overlap
+  implicit none
+   BEGIN_DOC
+   ! routines that compute the projection of each MO of the current `mo_coef` on the space spanned by the occupied orbitals of `mo_coef_begin_iteration`
+   END_DOC
+   integer :: i,j,k,l
+   double precision, allocatable :: overlap(:,:)
+   double precision, allocatable :: proj(:)
+   integer, allocatable :: iorder(:)
+   double precision, allocatable :: mo_coef_tmp(:,:)
+   double precision, allocatable :: tmp(:,:)
+   allocate(overlap(mo_num,mo_num),proj(mo_num),iorder(mo_num),mo_coef_tmp(ao_num,mo_num),tmp(mo_num,ao_num))
+   
+   overlap(:,:) = 0d0
+   mo_coef_tmp(:,:) = 0d0
+   proj(:) = 0d0
+   iorder(:) = 0d0
+   tmp(:,:) = 0d0
+   
+   ! These matrix products compute the overlap bewteen the initial and the current MOs
+   call dgemm('T','N', mo_num, ao_num, ao_num, 1.d0, &
+        mo_coef_begin_iteration, size(mo_coef_begin_iteration,1), &
+        ao_overlap, size(ao_overlap,1), 0.d0, &
+        tmp, size(tmp,1))
+
+   call dgemm('N','N', mo_num, mo_num, ao_num, 1.d0, &
+        tmp, size(tmp,1), &
+        mo_coef, size(mo_coef, 1), 0.d0, &
+        overlap, size(overlap,1) )
+   
+   
+   ! for each orbital compute the best overlap
+   do i = 1, mo_num
+      iorder(i) = i ! initialize the iorder list as we need it to sort later
+      do j = 1, elec_alpha_num
+         proj(i) += overlap(j,i)*overlap(j,i) ! compute the projection of current orbital i on the occupied space of the initial orbitals
+      enddo
+      proj(i) = dsqrt(proj(i))
+   enddo
+   ! sort the list of projection to find the mos with the largest overlap
+   call dsort(proj(:),iorder(:),mo_num)
+   ! reorder orbitals according to projection
+   do i=1,mo_num
+      mo_coef_tmp(:,i) = mo_coef(:,iorder(mo_num+1-i)) 
+   enddo
+
+   ! update the orbitals
+   mo_coef(:,:) =  mo_coef_tmp(:,:)
+   
+   ! if the determinant is open-shell we need to make sure that the singly occupied orbital correspond to the initial ones
+   if (elec_alpha_num > elec_beta_num) then
+      double precision, allocatable :: overlap_alpha(:,:)
+      double precision, allocatable :: proj_alpha(:)
+      integer, allocatable :: iorder_alpha(:)
+      allocate(overlap_alpha(mo_num,elec_alpha_num),proj_alpha(elec_alpha_num),iorder_alpha(elec_alpha_num))
+      overlap_alpha(:,:) = 0d0
+      mo_coef_tmp(:,:) = 0d0
+      proj_alpha(:) = 0d0
+      iorder_alpha(:) = 0d0
+      tmp(:,:) = 0d0 
+      ! These matrix products compute the overlap bewteen the initial and the current MOs
+      call dgemm('T','N', mo_num, ao_num, ao_num, 1.d0, &
+           mo_coef_begin_iteration, size(mo_coef_begin_iteration,1), &
+           ao_overlap, size(ao_overlap,1), 0.d0, &
+           tmp, size(tmp,1))
+
+      call dgemm('N','N', mo_num, elec_alpha_num, ao_num, 1.d0, &
+           tmp, size(tmp,1), &
+           mo_coef, size(mo_coef, 1), 0.d0, &
+           overlap_alpha, size(overlap_alpha,1) )
+
+      do i = 1, elec_alpha_num
+         iorder_alpha(i) = i ! initialize the iorder list as we need it to sort later
+         do j = 1, elec_beta_num
+            proj_alpha(i) += overlap_alpha(j,i)*overlap_alpha(j,i) ! compute the projection of current orbital i on the beta occupied space of the initial orbitals
+         enddo
+         proj_alpha(i) = dsqrt(proj_alpha(i))
+      enddo
+      
+      ! sort the list of projection to find the mos with the largest overlap
+      call dsort(proj_alpha(:),iorder_alpha(:),elec_alpha_num)
+      ! reorder orbitals according to projection
+      do i=1,elec_alpha_num
+         mo_coef_tmp(:,i) = mo_coef(:,iorder_alpha(elec_alpha_num+1-i)) 
+      enddo
+      do i=1,elec_alpha_num
+         mo_coef(:,i) = mo_coef_tmp(:,i) 
+      enddo
+
+      deallocate(overlap_alpha, proj_alpha, iorder_alpha)
+   endif
+   
+   deallocate(overlap, proj, iorder, mo_coef_tmp, tmp)
+
+ end
+

src/scf_utils/roothaan_hall_scf.irp.f

@@ -51,6 +51,11 @@ END_DOC
 !
   PROVIDE FPS_SPF_matrix_AO Fock_matrix_AO 
 
+  ! Initialize MO to run IMOM
+  if(do_mom)then
+     call initialize_mo_coef_begin_iteration
+  endif
+  
   converged = .False.
   do while ( .not.converged .and. (iteration_SCF < n_it_SCF_max) )
 
@@ -88,16 +93,17 @@ END_DOC
       Fock_matrix_AO_beta  = Fock_matrix_AO*0.5d0
       TOUCH Fock_matrix_AO_alpha Fock_matrix_AO_beta
 
-    endif
+   endif
-
     MO_coef = eigenvectors_Fock_matrix_MO
+    if(do_mom)then
+       call reorder_mo_max_overlap
+    endif
     if(frozen_orb_scf)then
-     call reorder_core_orb
+      call reorder_core_orb
-     call initialize_mo_coef_begin_iteration
+      call initialize_mo_coef_begin_iteration
     endif
 
     TOUCH MO_coef
-
 !   Calculate error vectors
 
     max_error_DIIS = maxval(Abs(FPS_SPF_Matrix_MO))
@@ -106,41 +112,46 @@ END_DOC
 
     energy_SCF = SCF_energy
     Delta_Energy_SCF = energy_SCF - energy_SCF_previous
-    if ( (SCF_algorithm == 'DIIS').and.(Delta_Energy_SCF > 0.d0) ) then
+    if ( (SCF_algorithm == 'DIIS').and.(Delta_Energy_SCF > 0.d0).and.(.not.do_mom) ) then
       Fock_matrix_AO(1:ao_num,1:ao_num) = Fock_matrix_DIIS (1:ao_num,1:ao_num,index_dim_DIIS)
       Fock_matrix_AO_alpha = Fock_matrix_AO*0.5d0
       Fock_matrix_AO_beta  = Fock_matrix_AO*0.5d0
       TOUCH Fock_matrix_AO_alpha Fock_matrix_AO_beta
     endif
 
-    double precision :: level_shift_save
+    if (.not.do_mom) then
-    level_shift_save = level_shift
+       double precision :: level_shift_save
-    mo_coef_save(1:ao_num,1:mo_num) = mo_coef(1:ao_num,1:mo_num)
+       level_shift_save = level_shift
-    do while (Delta_energy_SCF > 0.d0)
+       mo_coef_save(1:ao_num,1:mo_num) = mo_coef(1:ao_num,1:mo_num)
-      mo_coef(1:ao_num,1:mo_num) = mo_coef_save
+       do while (Delta_energy_SCF > 0.d0)
-      if (level_shift <= .1d0) then
+          mo_coef(1:ao_num,1:mo_num) = mo_coef_save
-        level_shift = 1.d0
+          if (level_shift <= .1d0) then
-      else
+             level_shift = 1.d0
-        level_shift = level_shift * 3.0d0
+          else
-      endif
+             level_shift = level_shift * 3.0d0
-      TOUCH mo_coef level_shift
+          endif
-      mo_coef(1:ao_num,1:mo_num) = eigenvectors_Fock_matrix_MO(1:ao_num,1:mo_num)
+          TOUCH mo_coef level_shift
-      if(frozen_orb_scf)then
+          mo_coef(1:ao_num,1:mo_num) = eigenvectors_Fock_matrix_MO(1:ao_num,1:mo_num)
-        call reorder_core_orb
+          if(do_mom)then
-        call initialize_mo_coef_begin_iteration
+             call reorder_mo_max_overlap
-      endif
+          endif
-      TOUCH mo_coef
+          if(frozen_orb_scf)then
-      Delta_Energy_SCF = SCF_energy - energy_SCF_previous
+             call reorder_core_orb
-      energy_SCF = SCF_energy
+             call initialize_mo_coef_begin_iteration
-      if (level_shift-level_shift_save > 40.d0) then
+          endif
-        level_shift = level_shift_save * 4.d0
+          TOUCH mo_coef
-        SOFT_TOUCH level_shift
+          Delta_Energy_SCF = SCF_energy - energy_SCF_previous
-        exit
+          energy_SCF = SCF_energy
-      endif
+          if (level_shift-level_shift_save > 40.d0) then
-      dim_DIIS=0
+             level_shift = level_shift_save * 4.d0
-    enddo
+             SOFT_TOUCH level_shift
-    level_shift = level_shift * 0.5d0
+             exit
-    SOFT_TOUCH level_shift
+          endif
+          dim_DIIS=0
+       enddo
+       level_shift = level_shift * 0.5d0
+       SOFT_TOUCH level_shift
+    endif
     energy_SCF_previous = energy_SCF
 
     converged = ( (max_error_DIIS <= threshold_DIIS_nonzero) .and. &
@@ -205,7 +216,7 @@ END_DOC
 
   if(.not.frozen_orb_scf)then
    call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1), &
-      size(Fock_matrix_mo,2),mo_label,1,.true.)
+        size(Fock_matrix_mo,2),mo_label,1,.true.)
    call restore_symmetry(ao_num, mo_num, mo_coef, size(mo_coef,1), 1.d-10)
    call orthonormalize_mos
   endif
@@ -228,6 +239,9 @@ END_DOC
     i = j+1
   enddo
 
+  if(do_mom)then
+     call reorder_mo_max_overlap
+  endif
 
   call save_mos
 

src/utils/constants.include.F

@@ -9,6 +9,9 @@ double precision, parameter :: pi_5_2 =  34.9868366552d0
 double precision, parameter :: dfour_pi =  4.d0*dacos(-1.d0)
 double precision, parameter :: dtwo_pi =  2.d0*dacos(-1.d0)
 double precision, parameter :: inv_sq_pi =  1.d0/dsqrt(dacos(-1.d0))
+double precision, parameter :: c_mu_gauss =  27.d0/(8.d0*dsqrt(dacos(-1.d0)))
+double precision, parameter :: c_mu_gauss_tot =  1.5d0*27.d0/(8.d0*dsqrt(dacos(-1.d0)))+3.d0/dsqrt(dacos(-1.d0))
+double precision, parameter :: alpha_mu_gauss =  1.5d0
 double precision, parameter :: inv_sq_pi_2 = 0.5d0/dsqrt(dacos(-1.d0))
 double precision, parameter :: thresh = 1.d-15
 double precision, parameter :: cx_lda = -0.73855876638202234d0