merge with Abdallah

plugins/local/bi_ort_ints/no_dressing.irp.f

@@ -322,6 +322,12 @@ END_PROVIDER
 
 BEGIN_PROVIDER [double precision, noL_0e]
 
+  BEGIN_DOC
+  ! 
+  ! < Phi_left | L | Phi_right >
+  !
+  END_DOC 
+
   implicit none
   integer                       :: i, j, k, ipoint
   double precision              :: t0, t1
@@ -330,10 +336,6 @@ BEGIN_PROVIDER [double precision, noL_0e]
   double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
   double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
 
-
-  call wall_time(t0)
-  print*, " Providing noL_0e ..."
-
   if(elec_alpha_num .eq. elec_beta_num) then
 
     allocate(tmp(elec_beta_num))
@@ -708,11 +710,6 @@ BEGIN_PROVIDER [double precision, noL_0e]
 
   endif
 
-  call wall_time(t1)
-  print*, " Wall time for noL_0e (min) = ", (t1 - t0)/60.d0
-
-  print*, " noL_0e = ", noL_0e
-
 END_PROVIDER
 
 ! ---

plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f

@@ -123,7 +123,7 @@ subroutine give_integrals_3_body_bi_ort_spin( n, sigma_n, l, sigma_l, k, sigma_k
   endif
 
   return
-end subroutine give_integrals_3_body_bi_ort_spin
+end
 
 ! ---
 

plugins/local/non_h_ints_mu/jast_1e_utils.irp.f

@@ -132,6 +132,7 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
   double precision, allocatable :: A(:,:,:,:), b(:), A_tmp(:,:,:,:)
   double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
   double precision, allocatable :: u1e_tmp(:), tmp(:,:,:)
+  double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
   double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:)
 
 
@@ -176,18 +177,19 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
   ! --- --- ---
   ! get A
 
-  allocate(tmp(n_points_final_grid,ao_num,ao_num))
+  allocate(tmp1(n_points_final_grid,ao_num,ao_num), tmp2(n_points_final_grid,ao_num,ao_num))
   allocate(A(ao_num,ao_num,ao_num,ao_num))
 
   !$OMP PARALLEL               &
   !$OMP DEFAULT (NONE)         &
   !$OMP PRIVATE (i, j, ipoint) &
-  !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
+  !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
   !$OMP DO COLLAPSE(2)
   do j = 1, ao_num
     do i = 1, ao_num
       do ipoint = 1, n_points_final_grid
-        tmp(ipoint,i,j) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+        tmp1(ipoint,i,j) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+        tmp2(ipoint,i,j) =                                    aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
       enddo
     enddo
   enddo
@@ -195,7 +197,7 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
   !$OMP END PARALLEL
 
   call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0  &
-            , tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid  &
+            , tmp1(1,1,1), n_points_final_grid, tmp2(1,1,1), n_points_final_grid &
             , 0.d0, A(1,1,1,1), ao_num*ao_num)
 
   allocate(A_tmp(ao_num,ao_num,ao_num,ao_num))
@@ -207,13 +209,13 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
   allocate(b(ao_num*ao_num))
 
   do ipoint = 1, n_points_final_grid
-    u1e_tmp(ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * u1e_tmp(ipoint)
+    u1e_tmp(ipoint) = u1e_tmp(ipoint)
   enddo
 
-  call dgemv("T", n_points_final_grid, ao_num*ao_num, 1.d0, tmp(1,1,1), n_points_final_grid, u1e_tmp(1), 1, 0.d0, b(1), 1)
+  call dgemv("T", n_points_final_grid, ao_num*ao_num, 1.d0, tmp1(1,1,1), n_points_final_grid, u1e_tmp(1), 1, 0.d0, b(1), 1)
 
   deallocate(u1e_tmp)
-  deallocate(tmp)
+  deallocate(tmp1, tmp2)
 
   ! --- --- ---
   ! solve Ax = b

plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f

@@ -167,7 +167,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
   integer                       :: jpoint
   integer                       :: i_nucl, p, mpA, npA, opA
   double precision              :: r2(3)
-  double precision              :: dx, dy, dz, r12, tmp, r12_inv
+  double precision              :: dx, dy, dz, r12, tmp
   double precision              :: mu_val, mu_tmp, mu_der(3)
   double precision              :: rn(3), f1A, grad1_f1A(3), f2A, grad2_f2A(3), g12, grad1_g12(3)
   double precision              :: tmp1, tmp2
@@ -191,19 +191,15 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
       dy = r1(2) - r2(2)
       dz = r1(3) - r2(3)
 
-      r12 = dx * dx + dy * dy + dz * dz
+      r12 = dsqrt(dx * dx + dy * dy + dz * dz)
-
+      if(r12 .lt. 1d-10) then
-      if(r12 .lt. 1d-20) then
         gradx(jpoint) = 0.d0 
         grady(jpoint) = 0.d0 
         gradz(jpoint) = 0.d0 
         cycle
       endif
 
-      r12_inv = 1.d0/dsqrt(r12)
+      tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
-      r12 = r12*r12_inv
-
-      tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) * r12_inv
 
       gradx(jpoint) = tmp * dx
       grady(jpoint) = tmp * dy
@@ -224,29 +220,23 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
       dx  = r1(1) - r2(1)
       dy  = r1(2) - r2(2)
       dz  = r1(3) - r2(3)
+      r12 = dsqrt(dx * dx + dy * dy + dz * dz)
 
-      r12 = 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-20) then
+      if(r12 .lt. 1d-10) then
         gradx(jpoint) = 0.d0
         grady(jpoint) = 0.d0
         gradz(jpoint) = 0.d0
         cycle
       endif
 
-      r12_inv = 1.d0/dsqrt(r12)
+      tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12
-      r12 = r12*r12_inv
-
-      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)
-
-      tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) * r12_inv
 
       gradx(jpoint) = gradx(jpoint) + tmp * dx
       grady(jpoint) = grady(jpoint) + tmp * dy
@@ -273,8 +263,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
       dx  = r1(1) - r2(1)
       dy  = r1(2) - r2(2)
       dz  = r1(3) - r2(3)
-      r12 = dx * dx + dy * dy + dz * dz
+      r12 = dsqrt(dx * dx + dy * dy + dz * dz)
-
       if(r12 .lt. 1d-10) then
         gradx(jpoint) = 0.d0 
         grady(jpoint) = 0.d0 
@@ -282,8 +271,6 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
         cycle
       endif
 
-      r12 = dsqrt(r12)
-
       tmp = 1.d0 + a_boys * r12
       tmp = 0.5d0 / (r12 * tmp * tmp)
 
@@ -294,10 +281,13 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
 
   elseif(j2e_type .eq. "Boys_Handy") then
 
-    integer :: powmax
+    integer                       :: powmax1, powmax, powmax2
-    powmax = max(maxval(jBH_m),maxval(jBH_n))
-
     double precision, allocatable :: f1A_power(:), f2A_power(:), double_p(:), g12_power(:)
+
+    powmax1 = max(maxval(jBH_m), maxval(jBH_n))
+    powmax2 = maxval(jBH_o)
+    powmax  = max(powmax1, powmax2)
+
     allocate(f1A_power(-1:powmax), f2A_power(-1:powmax), g12_power(-1:powmax), double_p(0:powmax))
 
     do p = 0, powmax
@@ -321,7 +311,6 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
       gradx(jpoint) = 0.d0 
       grady(jpoint) = 0.d0 
       gradz(jpoint) = 0.d0 
-
       do i_nucl = 1, nucl_num 
 
         rn(1) = nucl_coord(i_nucl,1)
@@ -332,23 +321,15 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
         call jBH_elem_fct_grad(jBH_en(i_nucl), r2, rn, f2A, grad2_f2A)
         call jBH_elem_fct_grad(jBH_ee(i_nucl), r1, r2, g12, grad1_g12)
 
-
         ! Compute powers of f1A and f2A
-
+        do p = 1, powmax1
-        do p = 1, maxval(jBH_m(:,i_nucl))
           f1A_power(p) = f1A_power(p-1) * f1A
-        enddo
-
-        do p = 1, maxval(jBH_n(:,i_nucl))
           f2A_power(p) = f2A_power(p-1) * f2A
         enddo
-
+        do p = 1, powmax2
-        do p = 1, maxval(jBH_o(:,i_nucl))
           g12_power(p) = g12_power(p-1) * g12
         enddo
 
-
-
         do p = 1, jBH_size
           mpA = jBH_m(p,i_nucl)
           npA = jBH_n(p,i_nucl)
@@ -358,28 +339,23 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
             tmp = tmp * 0.5d0
           endif
 
-!TODO : Powers to optimize here
+          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)
+          tmp2 = double_p(opA) * g12_power(opA-1) * (f1A_power(mpA) * f2A_power(npA) + f1A_power(npA) * f2A_power(mpA))
 
           !tmp1 = 0.d0
           !if(mpA .gt. 0) then
-!            tmp1 = tmp1 + dble(mpA) * f1A**(mpA-1) * f2A**npA
+          !  tmp1 = tmp1 + dble(mpA) * f1A**dble(mpA-1) * f2A**dble(npA)
           !endif
           !if(npA .gt. 0) then
-!            tmp1 = tmp1 + dble(npA) * f1A**(npA-1) * f2A**mpA
+          !  tmp1 = tmp1 + dble(npA) * f1A**dble(npA-1) * f2A**dble(mpA)
           !endif
-!          tmp1 = tmp1 * g12**(opA)
+          !tmp1 = tmp1 * g12**dble(opA)
-!
           !tmp2 = 0.d0
           !if(opA .gt. 0) then
-!            tmp2 = tmp2 + dble(opA) * g12**(opA-1) * (f1A**(mpA) * f2A**(npA) + f1A**(npA) * f2A**(mpA))
+          !  tmp2 = tmp2 + dble(opA) * g12**dble(opA-1) * (f1A**dble(mpA) * f2A**dble(npA) + f1A**dble(npA) * f2A**dble(mpA))
           !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)
-
-          tmp2 = double_p(opA) * g12_power(opA-1) * (f1A_power(mpA) * f2A_power(npA) + f1A_power(npA) * f2A_power(mpA))
-
-
           gradx(jpoint) = gradx(jpoint) + tmp * (tmp1 * grad1_f1A(1) + tmp2 * grad1_g12(1))
           grady(jpoint) = grady(jpoint) + tmp * (tmp1 * grad1_f1A(2) + tmp2 * grad1_g12(2))
           gradz(jpoint) = gradz(jpoint) + tmp * (tmp1 * grad1_f1A(3) + tmp2 * grad1_g12(3))
@@ -418,7 +394,7 @@ subroutine grad1_jmu_r1_seq(mu, r1, n_grid2, gradx, grady, gradz)
 
   integer                       :: jpoint
   double precision              :: r2(3)
-  double precision              :: dx, dy, dz, r12, r12_inv, tmp
+  double precision              :: dx, dy, dz, r12, tmp
 
 
   do jpoint = 1, n_points_extra_final_grid ! r2 
@@ -431,19 +407,15 @@ subroutine grad1_jmu_r1_seq(mu, r1, n_grid2, gradx, grady, gradz)
     dy = r1(2) - r2(2)
     dz = r1(3) - r2(3)
 
-    r12 = dx * dx + dy * dy + dz * dz
+    r12 = dsqrt(dx * dx + dy * dy + dz * dz)
-
+    if(r12 .lt. 1d-10) then
-    if(r12 .lt. 1d-20) then
       gradx(jpoint) = 0.d0 
       grady(jpoint) = 0.d0 
       gradz(jpoint) = 0.d0 
       cycle
     endif
 
-    r12_inv = 1.d0 / dsqrt(r12)
+    tmp = 0.5d0 * (1.d0 - derf(mu * r12)) / r12
-    r12 = r12 * r12_inv
-
-    tmp = 0.5d0 * (1.d0 - derf(mu * r12)) * r12_inv
 
     gradx(jpoint) = tmp * dx
     grady(jpoint) = tmp * dy
@@ -467,7 +439,7 @@ subroutine j12_r1_seq(r1, n_grid2, res)
   integer                       :: jpoint
   double precision              :: r2(3)
   double precision              :: dx, dy, dz
-  double precision              :: mu_tmp, r12, mu_erf_inv
+  double precision              :: mu_tmp, r12
 
   PROVIDE final_grid_points_extra
 
@@ -475,7 +447,6 @@ subroutine j12_r1_seq(r1, n_grid2, res)
 
     PROVIDE mu_erf
 
-    mu_erf_inv = 1.d0 / mu_erf
     do jpoint = 1, n_points_extra_final_grid ! r2 
   
       r2(1) = final_grid_points_extra(1,jpoint)
@@ -489,7 +460,7 @@ subroutine j12_r1_seq(r1, n_grid2, res)
 
       mu_tmp = mu_erf * r12
   
-      res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) * mu_erf_inv
+      res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
     enddo
 
   elseif(j2e_type .eq. "Boys") then

plugins/local/non_h_ints_mu/tc_integ_num.irp.f

@@ -66,9 +66,7 @@
     !$OMP PARALLEL                   &
     !$OMP DEFAULT (NONE)             &
     !$OMP PRIVATE (i_blocks, ipoint) &
-    !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, &
+    !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12, tmp_grad1_u12_squared)
-    !$OMP         final_grid_points, tmp_grad1_u12,        &
-    !$OMP         tmp_grad1_u12_squared)
     !$OMP DO 
     do i_blocks = 1, n_blocks
       ipoint = ii - 1 + i_blocks ! r1
@@ -102,9 +100,7 @@
     !$OMP PARALLEL                 &
     !$OMP DEFAULT (NONE)           &
     !$OMP PRIVATE (i_rest, ipoint) &
-    !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, &
+    !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12, tmp_grad1_u12_squared)
-    !$OMP         final_grid_points, tmp_grad1_u12,      &
-    !$OMP         tmp_grad1_u12_squared)
     !$OMP DO 
     do i_rest = 1, n_rest
       ipoint = ii - 1 + i_rest ! r1

plugins/local/non_h_ints_mu/test_non_h_ints.irp.f

@@ -1125,6 +1125,7 @@ subroutine test_fit_coef_A1()
   double precision              :: accu, norm, diff
   double precision, allocatable :: A1(:,:)
   double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:)
+  double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
 
   ! ---
 
@@ -1165,16 +1166,17 @@ subroutine test_fit_coef_A1()
 
   call wall_time(t1)
 
-  allocate(tmp(ao_num,ao_num,n_points_final_grid))
+  allocate(tmp1(ao_num,ao_num,n_points_final_grid), tmp2(ao_num,ao_num,n_points_final_grid))
   !$OMP PARALLEL               &
   !$OMP DEFAULT (NONE)         &
   !$OMP PRIVATE (i, j, ipoint) &
-  !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
+  !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
   !$OMP DO COLLAPSE(2)
   do j = 1, ao_num
     do i = 1, ao_num
       do ipoint = 1, n_points_final_grid
-        tmp(i,j,ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+        tmp1(i,j,ipoint) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+        tmp2(i,j,ipoint) =                                    aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
       enddo
     enddo
   enddo
@@ -1184,9 +1186,9 @@ subroutine test_fit_coef_A1()
   allocate(A2(ao_num,ao_num,ao_num,ao_num))
 
   call dgemm( "N", "T", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
-            , tmp(1,1,1), ao_num*ao_num, tmp(1,1,1), ao_num*ao_num              &
+            , tmp1(1,1,1), ao_num*ao_num, tmp2(1,1,1), ao_num*ao_num            &
             , 0.d0, A2(1,1,1,1), ao_num*ao_num)
-  deallocate(tmp)
+  deallocate(tmp1, tmp2)
 
   call wall_time(t2)
   print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
@@ -1238,6 +1240,7 @@ subroutine test_fit_coef_inv()
   double precision, allocatable :: A1(:,:), A1_inv(:,:), A1_tmp(:,:)
   double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:), A2_inv(:,:,:,:)
   double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A2_tmp(:,:,:,:)
+  double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
 
   cutoff_svd = 5d-8
 
@@ -1286,16 +1289,17 @@ subroutine test_fit_coef_inv()
 
   call wall_time(t1)
 
-  allocate(tmp(n_points_final_grid,ao_num,ao_num))
+  allocate(tmp1(n_points_final_grid,ao_num,ao_num), tmp2(n_points_final_grid,ao_num,ao_num))
   !$OMP PARALLEL               &
   !$OMP DEFAULT (NONE)         &
   !$OMP PRIVATE (i, j, ipoint) &
-  !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
+  !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
   !$OMP DO COLLAPSE(2)
   do j = 1, ao_num
     do i = 1, ao_num
       do ipoint = 1, n_points_final_grid
-        tmp(ipoint,i,j) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+        tmp1(ipoint,i,j) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+        tmp2(ipoint,i,j) =                                    aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
       enddo
     enddo
   enddo
@@ -1305,10 +1309,10 @@ subroutine test_fit_coef_inv()
   allocate(A2(ao_num,ao_num,ao_num,ao_num))
 
   call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0  &
-            , tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid  &
+            , tmp1(1,1,1), n_points_final_grid, tmp2(1,1,1), n_points_final_grid &
             , 0.d0, A2(1,1,1,1), ao_num*ao_num)
 
-  deallocate(tmp)
+  deallocate(tmp1, tmp2)
 
   call wall_time(t2)
   print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0

plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f

@@ -273,60 +273,6 @@ end
 
 ! ---
 
-subroutine lapack_diag_non_sym_right(n, A, WR, WI, VR)
-
-  implicit none
-
-  integer,          intent(in)  :: n
-  double precision, intent(in)  :: A(n,n)
-  double precision, intent(out) :: WR(n), WI(n), VR(n,n)
-
-  integer                       :: i, lda, ldvl, ldvr, LWORK, INFO
-  double precision, allocatable :: Atmp(:,:), WORK(:), VL(:,:)
-
-  lda  = n
-  ldvl = 1
-  ldvr = n
-
-  allocate( Atmp(n,n), VL(1,1) )
-  Atmp(1:n,1:n) = A(1:n,1:n)
-
-  allocate(WORK(1))
-  LWORK = -1
-  call dgeev('N', 'V', n, Atmp, lda, WR, WI, VL, ldvl, VR, ldvr, WORK, LWORK, INFO)
-  if(INFO.gt.0)then
-    print*,'dgeev failed !!',INFO
-    stop
-  endif
-
-  LWORK = max(int(WORK(1)), 1) ! this is the optimal size of WORK 
-  deallocate(WORK)
-
-  allocate(WORK(LWORK))
-
-  ! Actual diagonalization 
-  call dgeev('N', 'V', n, Atmp, lda, WR, WI, VL, ldvl, VR, ldvr, WORK, LWORK, INFO)
-  if(INFO.ne.0) then
-    print*,'dgeev failed !!', INFO
-    stop
-  endif
-
-  deallocate(Atmp, WORK, VL)
-
-! print *, ' JOBL = F'
-! print *, ' eigenvalues'
-! do i = 1, n
-!   write(*, '(1000(F16.10,X))') WR(i), WI(i)
-! enddo
-! print *, ' right eigenvect' 
-! do i = 1, n
-!   write(*, '(1000(F16.10,X))') VR(:,i)
-! enddo
-
-end
-
-! ---
-
 subroutine non_hrmt_real_diag(n, A, leigvec, reigvec, n_real_eigv, eigval)
 
   BEGIN_DOC
@@ -1780,70 +1726,6 @@ end
 
 ! ---
 
-subroutine check_weighted_biorthog(n, m, W, Vl, Vr, thr_d, thr_nd, accu_d, accu_nd, S, stop_ifnot)
-
-  implicit none
-  
-  integer,          intent(in)  :: n, m
-  double precision, intent(in)  :: Vl(n,m), Vr(n,m), W(n,n)
-  double precision, intent(in)  :: thr_d, thr_nd
-  logical,          intent(in)  :: stop_ifnot
-  double precision, intent(out) :: accu_d, accu_nd, S(m,m)
-
-  integer                       :: i, j
-  double precision, allocatable :: SS(:,:), tmp(:,:)
-
-  print *, ' check weighted bi-orthogonality'
-
-  ! ---
-
-  allocate(tmp(m,n))
-  call dgemm( 'T', 'N', m, n, n, 1.d0        &
-            , Vl, size(Vl, 1), W, size(W, 1) &
-            , 0.d0, tmp, size(tmp, 1) )
-  call dgemm( 'N', 'N', m, m, n, 1.d0            &
-            , tmp, size(tmp, 1), Vr, size(Vr, 1) &
-            , 0.d0, S, size(S, 1) )
-  deallocate(tmp)
-
-  !print *, ' overlap matrix:'
-  !do i = 1, m
-  !  write(*,'(1000(F16.10,X))') S(i,:)
-  !enddo
-
-  accu_d  = 0.d0
-  accu_nd = 0.d0
-  do i = 1, m
-    do j = 1, m
-      if(i==j) then
-        accu_d = accu_d + dabs(S(i,i))
-      else
-        accu_nd = accu_nd + S(j,i) * S(j,i)
-      endif
-    enddo
-  enddo
-  accu_nd = dsqrt(accu_nd)
-
-  print *, ' accu_nd = ', accu_nd
-  print *, ' accu_d  = ', dabs(accu_d-dble(m))/dble(m)
-
-  ! ---
-
-  if( stop_ifnot .and. ((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d) ) then
-    print *, ' non bi-orthogonal vectors !'
-    print *, ' accu_nd = ', accu_nd
-    print *, ' accu_d  = ', dabs(accu_d-dble(m))/dble(m)
-    !print *, ' overlap matrix:'
-    !do i = 1, m
-    !  write(*,'(1000(F16.10,X))') S(i,:)
-    !enddo
-    stop
-  endif
-
-end
-
-! ---
-
 subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ifnot)
 
   implicit none

plugins/local/non_hermit_dav/new_routines.irp.f

@@ -1,670 +0,0 @@
-subroutine non_hrmt_diag_split_degen_bi_orthog(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
-  BEGIN_DOC
-  !
-  ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors 
-  !
-  ! of a non hermitian matrix A(n,n)
-  !
-  ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n" 
-  !
-  END_DOC
-
-  implicit none
-
-  integer,          intent(in)  :: n
-  double precision, intent(in)  :: A(n,n)
-  integer,          intent(out) :: n_real_eigv
-  double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
-  double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
-
-  integer                       :: i, j, n_degen,k , iteration
-  double precision              :: shift_current
-  double precision              :: r,thr,accu_d, accu_nd
-  integer,          allocatable :: iorder_origin(:),iorder(:)
-  double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
-  double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
-  double precision, allocatable :: im_part(:),re_part(:)
-  double precision :: accu,thr_cut, thr_norm=1d0
-
-
-  thr_cut = 1.d-15
-  print*,'Computing the left/right eigenvectors ...'
-  print*,'Using the degeneracy splitting algorithm'
- ! initialization
-  shift_current = 1.d-15
-  iteration = 0 
-  print*,'***** iteration = ',iteration
-
-
-  ! pre-processing the matrix :: sorting by diagonal elements
-  allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
-  allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
-!  print*,'Aw'
-  do i = 1, n
-   iorder_origin(i) = i
-   diag_elem(i) = A(i,i)
-!   write(*,'(100(F16.10,X))')A(:,i)
-  enddo
-  call dsort(diag_elem, iorder_origin, n)
-  do i = 1, n
-   do j = 1, n
-    A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
-   enddo
-  enddo
-
-  allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
-  allocate(im_part(n),iorder(n))
-  allocate( S(n,n) )
-
-
-  Aw = A_save
-  call cancel_small_elmts(aw,n,thr_cut)
-  call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
-  do i = 1, n
-   im_part(i) = -dabs(WI(i))
-   iorder(i) = i
-  enddo
-  call dsort(im_part, iorder, n)
-  n_real_eigv = 0
-  do i = 1, n
-    if(dabs(WI(i)).lt.1.d-20)then
-      n_real_eigv += 1
-    else
-!      print*,'Found an imaginary component to eigenvalue'
-!      print*,'Re(i) + Im(i)',WR(i),WI(i)
-    endif
-  enddo
-  if(n_real_eigv.ne.n)then
-   shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
-   print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
-   print*,'Splitting the degeneracies by ',shift_current
-  else
-   print*,'All eigenvalues are real !'
-  endif
-
-
-  do while(n_real_eigv.ne.n)
-   iteration += 1
-   print*,'***** iteration = ',iteration
-   if(shift_current.gt.1.d-3)then
-    print*,'shift_current > 1.d-3 !!'
-    print*,'Your matrix intrinsically contains complex eigenvalues'
-    stop
-   endif
-   Aw = A_save
-   call cancel_small_elmts(Aw,n,thr_cut)
-   call split_matrix_degen(Aw,n,shift_current)
-   call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
-   n_real_eigv = 0
-   do i = 1, n
-     if(dabs(WI(i)).lt.1.d-20)then
-       n_real_eigv+= 1
-     else
-!       print*,'Found an imaginary component to eigenvalue'
-!       print*,'Re(i) + Im(i)',WR(i),WI(i)
-     endif
-   enddo
-   if(n_real_eigv.ne.n)then
-    do i = 1, n
-     im_part(i) = -dabs(WI(i))
-     iorder(i) = i
-    enddo
-    call dsort(im_part, iorder, n)
-    shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
-    print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
-    print*,'Splitting the degeneracies by ',shift_current
-   else
-    print*,'All eigenvalues are real !'
-   endif
-  enddo
-  !!!!!!!!!!!!!!!! SORTING THE EIGENVALUES 
-  do i = 1, n
-   eigval(i) = WR(i)
-   iorder(i) = i
-  enddo
-  call dsort(eigval,iorder,n)
-  do i = 1, n
-!   print*,'eigval(i) = ',eigval(i)
-   reigvec_tmp(:,i) = VR(:,iorder(i))
-   leigvec_tmp(:,i) = Vl(:,iorder(i))
-  enddo
-
-!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
-  !                               check bi-orthogonality
-  call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-  print *, ' accu_nd bi-orthog = ', accu_nd
-  if(accu_nd .lt. thresh_biorthog_nondiag) then
-    print *, ' bi-orthogonality: ok'
-  else
-    print *, ' '
-    print *, ' bi-orthogonality: not imposed yet'
-    print *, ' '
-    print *, ' '
-    print *, ' orthog between degen eigenvect' 
-    print *, ' '
-    double precision, allocatable :: S_nh_inv_half(:,:)
-    allocate(S_nh_inv_half(n,n))
-    logical :: complex_root
-    deallocate(S_nh_inv_half)
-    call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp)
-    call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp)
-    call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-    if(accu_nd .lt. thresh_biorthog_nondiag) then
-      print *, ' bi-orthogonality: ok'
-    else 
-     print*,'New vectors not bi-orthonormals at ',accu_nd
-     call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S)
-     call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-     if(accu_nd .lt. thresh_biorthog_nondiag) then
-       print *, ' bi-orthogonality: ok'
-     else 
-      print*,'New vectors not bi-orthonormals at ',accu_nd
-      print*,'Must be a deep problem ...'
-      stop
-     endif
-    endif
-  endif
- 
-  !! EIGENVECTORS SORTED AND BI-ORTHONORMAL
-  do i = 1, n
-   do j = 1, n
-    VR(iorder_origin(j),i) = reigvec_tmp(j,i)
-    VL(iorder_origin(j),i) = leigvec_tmp(j,i)
-   enddo
-  enddo
-
-  !! RECOMPUTING THE EIGENVALUES 
-  eigval = 0.d0
-  do i = 1, n
-   iorder(i) = i
-   accu = 0.d0
-   do j = 1, n
-    accu += VL(j,i) * VR(j,i) 
-    do k = 1, n
-     eigval(i) +=  VL(j,i) * A(j,k) * VR(k,i) 
-    enddo
-   enddo
-   eigval(i) *= 1.d0/accu
-!   print*,'eigval(i) = ',eigval(i)
-  enddo
-  !! RESORT JUST TO BE SURE
-  call dsort(eigval, iorder, n)
-  do i = 1, n
-   do j = 1, n
-    reigvec(j,i) = VR(j,iorder(i))
-    leigvec(j,i) = VL(j,iorder(i))
-   enddo
-  enddo
-  print*,'Checking for final reigvec/leigvec'
-  shift_current = max(1.d-10,shift_current)
-  print*,'Thr for eigenvectors = ',shift_current
-  call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
-  call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-  print *, ' accu_nd bi-orthog = ', accu_nd
-  
-  if(accu_nd .lt. thresh_biorthog_nondiag) then
-    print *, ' bi-orthogonality: ok'
-  else 
-   print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
-   print*,'Eigenvectors are not bi orthonormal ..'
-   print*,'accu_nd = ',accu_nd
-   stop
-  endif
-
-end 
-
-
-
-subroutine non_hrmt_diag_split_degen_s_inv_half(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
-  BEGIN_DOC
-  !
-  ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors 
-  !
-  ! of a non hermitian matrix A(n,n)
-  !
-  ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n" 
-  !
-  END_DOC
-
-  implicit none
-
-  integer,          intent(in)  :: n
-  double precision, intent(in)  :: A(n,n)
-  integer,          intent(out) :: n_real_eigv
-  double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
-  double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
-
-  integer                       :: i, j, n_degen,k , iteration
-  double precision              :: shift_current
-  double precision              :: r,thr,accu_d, accu_nd
-  integer,          allocatable :: iorder_origin(:),iorder(:)
-  double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
-  double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
-  double precision, allocatable :: im_part(:),re_part(:)
-  double precision :: accu,thr_cut, thr_norm=1.d0
-  double precision, allocatable :: S_nh_inv_half(:,:)
-  logical :: complex_root
-
-
-  thr_cut = 1.d-15
-  print*,'Computing the left/right eigenvectors ...'
-  print*,'Using the degeneracy splitting algorithm'
- ! initialization
-  shift_current = 1.d-15
-  iteration = 0 
-  print*,'***** iteration = ',iteration
-
-
-  ! pre-processing the matrix :: sorting by diagonal elements
-  allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
-  allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
-!  print*,'Aw'
-  do i = 1, n
-   iorder_origin(i) = i
-   diag_elem(i) = A(i,i)
-!   write(*,'(100(F16.10,X))')A(:,i)
-  enddo
-  call dsort(diag_elem, iorder_origin, n)
-  do i = 1, n
-   do j = 1, n
-    A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
-   enddo
-  enddo
-
-  allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
-  allocate(im_part(n),iorder(n))
-  allocate( S(n,n) )
-  allocate(S_nh_inv_half(n,n))
-
-
-  Aw = A_save
-  call cancel_small_elmts(aw,n,thr_cut)
-  call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
-  do i = 1, n
-   im_part(i) = -dabs(WI(i))
-   iorder(i) = i
-  enddo
-  call dsort(im_part, iorder, n)
-  n_real_eigv = 0
-  do i = 1, n
-    if(dabs(WI(i)).lt.1.d-20)then
-      n_real_eigv += 1
-    else
-!      print*,'Found an imaginary component to eigenvalue'
-!      print*,'Re(i) + Im(i)',WR(i),WI(i)
-    endif
-  enddo
-  if(n_real_eigv.ne.n)then
-   shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
-   print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
-   print*,'Splitting the degeneracies by ',shift_current
-  else
-   print*,'All eigenvalues are real !'
-  endif
-
-
-  do while(n_real_eigv.ne.n)
-   iteration += 1
-   print*,'***** iteration = ',iteration
-   if(shift_current.gt.1.d-3)then
-    print*,'shift_current > 1.d-3 !!'
-    print*,'Your matrix intrinsically contains complex eigenvalues'
-    stop
-   endif
-   Aw = A_save
-!   thr_cut = shift_current
-   call cancel_small_elmts(Aw,n,thr_cut)
-   call split_matrix_degen(Aw,n,shift_current)
-   call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
-   n_real_eigv = 0
-   do i = 1, n
-     if(dabs(WI(i)).lt.1.d-20)then
-       n_real_eigv+= 1
-     else
-!       print*,'Found an imaginary component to eigenvalue'
-!       print*,'Re(i) + Im(i)',WR(i),WI(i)
-     endif
-   enddo
-   if(n_real_eigv.ne.n)then
-    do i = 1, n
-     im_part(i) = -dabs(WI(i))
-     iorder(i) = i
-    enddo
-    call dsort(im_part, iorder, n)
-    shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
-    print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
-    print*,'Splitting the degeneracies by ',shift_current
-   else
-    print*,'All eigenvalues are real !'
-   endif
-  enddo
-  !!!!!!!!!!!!!!!! SORTING THE EIGENVALUES 
-  do i = 1, n
-   eigval(i) = WR(i)
-   iorder(i) = i
-  enddo
-  call dsort(eigval,iorder,n)
-  do i = 1, n
-!   print*,'eigval(i) = ',eigval(i)
-   reigvec_tmp(:,i) = VR(:,iorder(i))
-   leigvec_tmp(:,i) = Vl(:,iorder(i))
-  enddo
-
-!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
-  !                               check bi-orthogonality
-  call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-  print *, ' accu_nd bi-orthog = ', accu_nd
-  if(accu_nd .lt. thresh_biorthog_nondiag) then
-    print *, ' bi-orthogonality: ok'
-  else
-    print *, ' '
-    print *, ' bi-orthogonality: not imposed yet'
-    if(complex_root) then 
-     print *, ' '
-     print *, ' '
-     print *, ' orthog between degen eigenvect' 
-     print *, ' '
-     ! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
-     call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp) ! orthogonalization of reigvec
-     call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp) ! orthogonalization of leigvec
-     call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S,  thresh_biorthog_diag, thresh_biorthog_nondiag, .false.) 
-
-     if(accu_nd .lt. thresh_biorthog_nondiag) then
-       print *, ' bi-orthogonality: ok'
-     else 
-      print*,'New vectors not bi-orthonormals at ', accu_nd
-      call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half, complex_root)
-      if(complex_root)then 
-       call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S) ! bi-orthonormalization using QR
-      else
-       print*,'S^{-1/2} exists !!'
-       call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization 
-      endif
-     endif
-    else ! the matrix S^{-1/2} exists
-     print*,'S^{-1/2} exists !!'
-     call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization 
-    endif
-    call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-    if(accu_nd .lt. thresh_biorthog_nondiag) then
-      print *, ' bi-orthogonality: ok'
-    else 
-     print*,'New vectors not bi-orthonormals at ',accu_nd
-     print*,'Must be a deep problem ...'
-     stop
-    endif
-  endif
- 
-  !! EIGENVECTORS SORTED AND BI-ORTHONORMAL
-  do i = 1, n
-   do j = 1, n
-    VR(iorder_origin(j),i) = reigvec_tmp(j,i)
-    VL(iorder_origin(j),i) = leigvec_tmp(j,i)
-   enddo
-  enddo
-
-  !! RECOMPUTING THE EIGENVALUES 
-  eigval = 0.d0
-  do i = 1, n
-   iorder(i) = i
-   accu = 0.d0
-   do j = 1, n
-    accu += VL(j,i) * VR(j,i) 
-    do k = 1, n
-     eigval(i) +=  VL(j,i) * A(j,k) * VR(k,i) 
-    enddo
-   enddo
-   eigval(i) *= 1.d0/accu
-!   print*,'eigval(i) = ',eigval(i)
-  enddo
-  !! RESORT JUST TO BE SURE
-  call dsort(eigval, iorder, n)
-  do i = 1, n
-   do j = 1, n
-    reigvec(j,i) = VR(j,iorder(i))
-    leigvec(j,i) = VL(j,iorder(i))
-   enddo
-  enddo
-  print*,'Checking for final reigvec/leigvec'
-  shift_current = max(1.d-10,shift_current)
-  print*,'Thr for eigenvectors = ',shift_current
-  call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
-  call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-  print *, ' accu_nd bi-orthog = ', accu_nd
-  
-  if(accu_nd .lt. thresh_biorthog_nondiag) then
-    print *, ' bi-orthogonality: ok'
-  else 
-   print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
-   print*,'Eigenvectors are not bi orthonormal ..'
-   print*,'accu_nd = ',accu_nd
-   stop
-  endif
-
-end 
-
-
-subroutine non_hrmt_fock_mat(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
-  BEGIN_DOC
-  !
-  ! routine returning the eigenvalues and left/right eigenvectors of the TC fock matrix 
-  !
-  END_DOC
-
-  implicit none
-
-  integer,          intent(in)  :: n
-  double precision, intent(in)  :: A(n,n)
-  integer,          intent(out) :: n_real_eigv
-  double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
-  double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
-
-  integer                       :: i, j, n_degen,k , iteration
-  double precision              :: shift_current
-  double precision              :: r,thr,accu_d, accu_nd
-  integer,          allocatable :: iorder_origin(:),iorder(:)
-  double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
-  double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
-  double precision, allocatable :: im_part(:),re_part(:)
-  double precision :: accu,thr_cut
-  double precision, allocatable :: S_nh_inv_half(:,:)
-  logical :: complex_root
-  double precision :: thr_norm=1d0
-
-
-  thr_cut = 1.d-15
-  print*,'Computing the left/right eigenvectors ...'
-  print*,'Using the degeneracy splitting algorithm'
- ! initialization
-  shift_current = 1.d-15
-  iteration = 0 
-  print*,'***** iteration = ',iteration
-
-
-  ! pre-processing the matrix :: sorting by diagonal elements
-  allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
-  allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
-!  print*,'Aw'
-  do i = 1, n
-   iorder_origin(i) = i
-   diag_elem(i) = A(i,i)
-!   write(*,'(100(F16.10,X))')A(:,i)
-  enddo
-  call dsort(diag_elem, iorder_origin, n)
-  do i = 1, n
-   do j = 1, n
-    A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
-   enddo
-  enddo
-
-  allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
-  allocate(im_part(n),iorder(n))
-  allocate( S(n,n) )
-  allocate(S_nh_inv_half(n,n))
-
-
-  Aw = A_save
-  call cancel_small_elmts(aw,n,thr_cut)
-  call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
-  do i = 1, n
-   im_part(i) = -dabs(WI(i))
-   iorder(i) = i
-  enddo
-  call dsort(im_part, iorder, n)
-  n_real_eigv = 0
-  do i = 1, n
-    if(dabs(WI(i)).lt.1.d-20)then
-      n_real_eigv += 1
-    else
-!      print*,'Found an imaginary component to eigenvalue'
-!      print*,'Re(i) + Im(i)',WR(i),WI(i)
-    endif
-  enddo
-  if(n_real_eigv.ne.n)then
-   shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
-   print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
-   print*,'Splitting the degeneracies by ',shift_current
-  else
-   print*,'All eigenvalues are real !'
-  endif
-
-
-  do while(n_real_eigv.ne.n)
-   iteration += 1
-   print*,'***** iteration = ',iteration
-   if(shift_current.gt.1.d-3)then
-    print*,'shift_current > 1.d-3 !!'
-    print*,'Your matrix intrinsically contains complex eigenvalues'
-    stop
-   endif
-   Aw = A_save
-!   thr_cut = shift_current
-   call cancel_small_elmts(Aw,n,thr_cut)
-   call split_matrix_degen(Aw,n,shift_current)
-   call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
-   n_real_eigv = 0
-   do i = 1, n
-     if(dabs(WI(i)).lt.1.d-20)then
-       n_real_eigv+= 1
-     else
-!       print*,'Found an imaginary component to eigenvalue'
-!       print*,'Re(i) + Im(i)',WR(i),WI(i)
-     endif
-   enddo
-   if(n_real_eigv.ne.n)then
-    do i = 1, n
-     im_part(i) = -dabs(WI(i))
-     iorder(i) = i
-    enddo
-    call dsort(im_part, iorder, n)
-    shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
-    print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
-    print*,'Splitting the degeneracies by ',shift_current
-   else
-    print*,'All eigenvalues are real !'
-   endif
-  enddo
-  !!!!!!!!!!!!!!!! SORTING THE EIGENVALUES 
-  do i = 1, n
-   eigval(i) = WR(i)
-   iorder(i) = i
-  enddo
-  call dsort(eigval,iorder,n)
-  do i = 1, n
-!   print*,'eigval(i) = ',eigval(i)
-   reigvec_tmp(:,i) = VR(:,iorder(i))
-   leigvec_tmp(:,i) = Vl(:,iorder(i))
-  enddo
-
-!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
-  !                               check bi-orthogonality
-  call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-  print *, ' accu_nd bi-orthog = ', accu_nd
-  if(accu_nd .lt. thresh_biorthog_nondiag) then
-    print *, ' bi-orthogonality: ok'
-  else
-    print *, ' '
-    print *, ' bi-orthogonality: not imposed yet'
-    print *, ' '
-    print *, ' '
-    print *, ' Using impose_unique_biorthog_degen_eigvec' 
-    print *, ' '
-    ! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
-    call impose_unique_biorthog_degen_eigvec(n, eigval, mo_coef, leigvec_tmp, reigvec_tmp)
-    call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-    print*,'accu_nd = ',accu_nd
-    if(accu_nd .lt. thresh_biorthog_nondiag) then
-      print *, ' bi-orthogonality: ok'
-    else 
-     print*,'New vectors not bi-orthonormals at ',accu_nd
-     call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half,complex_root)
-     if(complex_root)then 
-      print*,'S^{-1/2} does not exits, using QR bi-orthogonalization'
-      call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S) ! bi-orthonormalization using QR
-     else
-      print*,'S^{-1/2} exists !!'
-      call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization 
-     endif
-    endif
-    call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-    if(accu_nd .lt. thresh_biorthog_nondiag) then
-      print *, ' bi-orthogonality: ok'
-    else 
-     print*,'New vectors not bi-orthonormals at ',accu_nd
-     print*,'Must be a deep problem ...'
-     stop
-    endif
-  endif
- 
-  !! EIGENVECTORS SORTED AND BI-ORTHONORMAL
-  do i = 1, n
-   do j = 1, n
-    VR(iorder_origin(j),i) = reigvec_tmp(j,i)
-    VL(iorder_origin(j),i) = leigvec_tmp(j,i)
-   enddo
-  enddo
-
-  !! RECOMPUTING THE EIGENVALUES 
-  eigval = 0.d0
-  do i = 1, n
-   iorder(i) = i
-   accu = 0.d0
-   do j = 1, n
-    accu += VL(j,i) * VR(j,i) 
-    do k = 1, n
-     eigval(i) +=  VL(j,i) * A(j,k) * VR(k,i) 
-    enddo
-   enddo
-   eigval(i) *= 1.d0/accu
-!   print*,'eigval(i) = ',eigval(i)
-  enddo
-  !! RESORT JUST TO BE SURE
-  call dsort(eigval, iorder, n)
-  do i = 1, n
-   do j = 1, n
-    reigvec(j,i) = VR(j,iorder(i))
-    leigvec(j,i) = VL(j,iorder(i))
-   enddo
-  enddo
-  print*,'Checking for final reigvec/leigvec'
-  shift_current = max(1.d-10,shift_current)
-  print*,'Thr for eigenvectors = ',shift_current
-  call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
-  call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-  print *, ' accu_nd bi-orthog = ', accu_nd
-  
-  if(accu_nd .lt. thresh_biorthog_nondiag) then
-    print *, ' bi-orthogonality: ok'
-  else 
-   print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
-   print*,'Eigenvectors are not bi orthonormal ..'
-   print*,'accu_nd = ',accu_nd
-   stop
-  endif
-
-end 
-
-

plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f

@@ -183,11 +183,3 @@ BEGIN_PROVIDER [ double precision, x_W_ij_erf_rk, ( n_points_final_grid,3,mo_num
 
 END_PROVIDER 
 
-BEGIN_PROVIDER [ double precision, sqrt_weight_at_r, (n_points_final_grid)]
- implicit none
- integer :: ipoint
- do ipoint = 1, n_points_final_grid
-  sqrt_weight_at_r(ipoint) = dsqrt(final_weight_at_r_vector(ipoint))
- enddo
-END_PROVIDER 
-

plugins/local/slater_tc/NEED

@@ -5,3 +5,4 @@ bi_ortho_mos
 tc_keywords
 non_hermit_dav
 dav_general_mat
+tc_scf

plugins/local/slater_tc/tc_hmat.irp.f

@@ -22,6 +22,7 @@ BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)]
 
   if(noL_standard) then
     PROVIDE noL_0e
+    print*, "noL_0e =", noL_0e
     PROVIDE noL_1e
     PROVIDE noL_2e
   endif

plugins/local/tc_bi_ortho/EZFIO.cfg

@@ -9,3 +9,14 @@ interface: ezfio
 doc: Coefficients for the right wave function
 type: double precision
 size: (determinants.n_det,determinants.n_states)
+
+[tc_gs_energy]
+type: Threshold
+doc: TC GS Energy
+interface: ezfio
+
+[tc_gs_var]
+type: Threshold
+doc: TC GS VAR
+interface: ezfio
+

plugins/local/tc_bi_ortho/print_tc_energy.irp.f

@@ -6,7 +6,8 @@ program print_tc_energy
 
   implicit none
 
-  print *, 'Hello world'
+  read_wf = .True.
+  touch read_wf
 
   my_grid_becke  = .True.
   PROVIDE tc_grid1_a tc_grid1_r
@@ -14,9 +15,29 @@ program print_tc_energy
   my_n_pt_a_grid = tc_grid1_a
   touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
 
-  read_wf = .True.
+  call write_int(6, my_n_pt_r_grid, 'radial  external grid over')
-  touch read_wf
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
 
+  if(tc_integ_type .eq. "numeric") then
+    my_extra_grid_becke  = .True.
+    PROVIDE tc_grid2_a tc_grid2_r
+    my_n_pt_r_extra_grid = tc_grid2_r
+    my_n_pt_a_extra_grid = tc_grid2_a
+    touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
+
+    call write_int(6, my_n_pt_r_extra_grid, 'radial  internal grid over')
+    call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
+  endif
+
+  call main()
+
+end
+
+! ---
+
+subroutine main()
+
+  implicit none
 
   PROVIDE j2e_type
   PROVIDE j1e_type

plugins/local/tc_bi_ortho/print_tc_var.irp.f

@@ -6,7 +6,8 @@ program print_tc_var
 
   implicit none
 
-  print *, 'Hello world'
+  print *, ' TC VAR is available only for HF REF WF'
+  print *, ' DO NOT FORGET TO RUN A CISD CALCULATION BEF'
 
   my_grid_becke = .True.
   PROVIDE tc_grid1_a tc_grid1_r
@@ -17,7 +18,7 @@ program print_tc_var
   read_wf = .True.
   touch read_wf
 
-  call write_tc_var()
+  call write_tc_gs_var_HF()
 
 end
 

plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f

@@ -38,9 +38,9 @@ subroutine main()
         call ezfio_has_cisd_energy(exists)
         if(.not.exists) then
 
-          call ezfio_has_tc_scf_bitc_energy(exists)
+          call ezfio_has_tc_scf_tcscf_energy(exists)
           if(exists) then
-            call ezfio_get_tc_scf_bitc_energy(e_ref)
+            call ezfio_get_tc_scf_tcscf_energy(e_ref)
           endif
 
         else
@@ -59,7 +59,7 @@ subroutine main()
 
   close(iunit)
 
-end subroutine main
+end
 
 ! --
 
@@ -89,7 +89,7 @@ subroutine write_lr_spindeterminants()
   call ezfio_set_spindeterminants_psi_left_coef_matrix_values(buffer)
   deallocate(buffer)
 
-end subroutine write_lr_spindeterminants
+end
 
 ! ---
 

plugins/local/tc_bi_ortho/tc_utils.irp.f

@@ -6,8 +6,63 @@ subroutine write_tc_energy()
   double precision              :: hmono, htwoe, hthree, htot
   double precision              :: E_TC, O_TC
   double precision              :: E_1e, E_2e, E_3e
+  double precision, allocatable :: E_TC_tmp(:), E_1e_tmp(:), E_2e_tmp(:), E_3e_tmp(:)
 
-  do k = 1, n_states
+  ! GS 
+  ! ---
+
+  allocate(E_TC_tmp(N_det), E_1e_tmp(N_det), E_2e_tmp(N_det), E_3e_tmp(N_det))
+
+  !$OMP PARALLEL                                                                &
+  !$OMP DEFAULT (NONE)                                                          &
+  !$OMP PRIVATE(i, j, hmono, htwoe, hthree, htot)                               &
+  !$OMP SHARED(N_det, psi_det, N_int, psi_l_coef_bi_ortho, psi_r_coef_bi_ortho, &
+  !$OMP        E_TC_tmp, E_1e_tmp, E_2e_tmp, E_3e_tmp)
+  !$OMP DO
+  do i = 1, N_det
+    E_TC_tmp(i) = 0.d0
+    E_1e_tmp(i) = 0.d0
+    E_2e_tmp(i) = 0.d0
+    E_3e_tmp(i) = 0.d0
+    do j = 1, N_det
+      call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
+      E_TC_tmp(i) = E_TC_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * htot
+      E_1e_tmp(i) = E_1e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * hmono
+      E_2e_tmp(i) = E_2e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * htwoe
+      E_3e_tmp(i) = E_3e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * hthree
+    enddo
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  E_1e = 0.d0
+  E_2e = 0.d0
+  E_3e = 0.d0
+  E_TC = 0.d0
+  O_TC = 0.d0
+  do i = 1, N_det
+    E_1e = E_1e + E_1e_tmp(i)
+    E_2e = E_2e + E_2e_tmp(i)
+    E_3e = E_3e + E_3e_tmp(i)
+    E_TC = E_TC + E_TC_tmp(i)
+    O_TC = O_TC + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(i,1)
+  enddo
+
+  print *, ' state :', 1
+  print *, " E_TC = ", E_TC / O_TC
+  print *, " E_1e = ", E_1e / O_TC
+  print *, " E_2e = ", E_2e / O_TC
+  print *, " E_3e = ", E_3e / O_TC
+  print *, " O_TC = ", O_TC
+
+  call ezfio_set_tc_bi_ortho_tc_gs_energy(E_TC/O_TC)
+
+  ! ---
+
+  ! ES 
+  ! ---
+
+  do k = 2, n_states
 
     E_TC = 0.d0
     E_1e = 0.d0
@@ -37,6 +92,8 @@ subroutine write_tc_energy()
 
   enddo
 
+  deallocate(E_TC_tmp, E_1e_tmp, E_2e_tmp, E_3e_tmp)
+
 end
 
 ! ---
@@ -66,3 +123,25 @@ end
 
 ! ---
 
+subroutine write_tc_gs_var_HF()
+
+  implicit none
+  integer          :: i, j, k
+  double precision :: hmono, htwoe, hthree, htot
+  double precision :: SIGMA_TC
+
+  SIGMA_TC = 0.d0
+  do j = 2, N_det
+    call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
+    SIGMA_TC = SIGMA_TC + htot * htot
+  enddo
+
+  print *, " SIGMA_TC = ", SIGMA_TC
+
+  call ezfio_set_tc_bi_ortho_tc_gs_var(SIGMA_TC)
+
+end
+
+! ---
+
+

plugins/local/tc_bi_ortho/test_tc_fock.irp.f

@@ -24,44 +24,12 @@ program test_tc_fock
   !call routine_2
 !  call routine_3()
 
-! call test_3e
   call routine_tot
 
 end
 
 ! ---
 
-subroutine test_3e
- implicit none
- double precision :: integral_aaa,integral_aab,integral_abb,integral_bbb,accu
- double precision ::  hmono, htwoe, hthree, htot
- call htilde_mu_mat_bi_ortho_slow(ref_bitmask, ref_bitmask, N_int, hmono, htwoe, hthree, htot)
- print*,'hmono = ',hmono
- print*,'htwoe = ',htwoe
- print*,'hthree= ',hthree
- print*,'htot  = ',htot
- print*,''
- print*,''
- print*,'TC_one= ',tc_hf_one_e_energy
- print*,'TC_two= ',TC_HF_two_e_energy
- print*,'TC_3e = ',diag_three_elem_hf
- print*,'TC_tot= ',TC_HF_energy
- print*,''
- print*,''
- call give_aaa_contrib(integral_aaa)
- print*,'integral_aaa = ',integral_aaa
- call give_aab_contrib(integral_aab)
- print*,'integral_aab = ',integral_aab
- call give_abb_contrib(integral_abb)
- print*,'integral_abb = ',integral_abb
- call give_bbb_contrib(integral_bbb)
- print*,'integral_bbb = ',integral_bbb
- accu = integral_aaa + integral_aab + integral_abb + integral_bbb
- print*,'accu = ',accu
- print*,'delta = ',hthree - accu
-
-end
-
 subroutine routine_3()
 
   use bitmasks ! you need to include the bitmasks_module.f90 features
@@ -86,7 +54,6 @@ subroutine routine_3()
    do i = 1, elec_num_tab(s1)
      do a = elec_num_tab(s1)+1, mo_num ! virtual 
  
- 
        det_i = ref_bitmask
        call do_single_excitation(det_i, i, a, s1, i_ok)
        if(i_ok == -1) then

plugins/local/tc_keywords/EZFIO.cfg

@@ -100,30 +100,12 @@ doc: If |true|, the states are re-ordered to match the input states
 default: False
 interface: ezfio,provider,ocaml
 
-[bi_ortho]
-type: logical
-doc: If |true|, the MO basis is assumed to be bi-orthonormal
-interface: ezfio,provider,ocaml
-default: True
-
 [symmetric_fock_tc]
 type: logical
 doc: If |true|, using F+F^t as Fock TC
 interface: ezfio,provider,ocaml
 default: False
 
-[thresh_tcscf]
-type: Threshold
-doc: Threshold on the convergence of the Hartree Fock energy.
-interface: ezfio,provider,ocaml
-default: 1.e-8
-
-[n_it_tcscf_max]
-type: Strictly_positive_int
-doc: Maximum number of SCF iterations
-interface: ezfio,provider,ocaml
-default: 50
-
 [selection_tc]
 type: integer
 doc: if +1: only positive is selected, -1: only negative is selected, :0 both positive and negative
@@ -160,30 +142,6 @@ doc: If |true|, maximize the overlap between orthogonalized left- and right eige
 interface: ezfio,provider,ocaml
 default: False
 
-[max_dim_diis_tcscf]
-type: integer
-doc: Maximum size of the DIIS extrapolation procedure
-interface: ezfio,provider,ocaml
-default: 15
-
-[level_shift_tcscf]
-type: Positive_float
-doc: Energy shift on the virtual MOs to improve TCSCF convergence
-interface: ezfio,provider,ocaml
-default: 0.
-
-[tcscf_algorithm]
-type: character*(32)
-doc: Type of TCSCF algorithm used. Possible choices are [Simple | DIIS]
-interface: ezfio,provider,ocaml
-default: DIIS
-
-[im_thresh_tcscf]
-type: Threshold
-doc: Thresholds on the Imag part of energy
-interface: ezfio,provider,ocaml
-default: 1.e-7
-
 [test_cycle_tc]
 type: logical
 doc: If |true|, the integrals of the three-body jastrow are computed with cycles
@@ -304,3 +262,9 @@ doc: If |true|, more calc but less mem
 interface: ezfio,provider,ocaml
 default: False
 
+[im_thresh_tc]
+type: Threshold
+doc: Thresholds on the Imag part of TC energy
+interface: ezfio,provider,ocaml
+default: 1.e-7
+

plugins/local/tc_keywords/tc_keywords.irp.f

@@ -1,7 +0,0 @@
-program tc_keywords
-  implicit none
-  BEGIN_DOC
-! TODO : Put the documentation of the program here
-  END_DOC
-  print *, 'Hello world'
-end

plugins/local/tc_scf/EZFIO.cfg

@@ -1,6 +1,6 @@
-[bitc_energy]
+[tcscf_energy]
 type: Threshold
-doc: Energy bi-tc HF
+doc: TC-SCF ENERGY 
 interface: ezfio
 
 [converged_tcscf]
@@ -9,3 +9,33 @@ doc: If |true|, tc-scf has converged
 interface: ezfio,provider,ocaml
 default: False
 
+[max_dim_diis_tcscf]
+type: integer
+doc: Maximum size of the DIIS extrapolation procedure
+interface: ezfio,provider,ocaml
+default: 15
+
+[level_shift_tcscf]
+type: Positive_float
+doc: Energy shift on the virtual MOs to improve TCSCF convergence
+interface: ezfio,provider,ocaml
+default: 0.
+
+[thresh_tcscf]
+type: Threshold
+doc: Threshold on the convergence of the Hartree Fock energy.
+interface: ezfio,provider,ocaml
+default: 1.e-8
+
+[n_it_tcscf_max]
+type: Strictly_positive_int
+doc: Maximum number of SCF iterations
+interface: ezfio,provider,ocaml
+default: 50
+
+[tc_Brillouin_Right]
+type: logical
+doc: If |true|, impose only right-Brillouin condition
+interface: ezfio,provider,ocaml
+default: False
+

plugins/local/tc_scf/combine_lr_tcscf.irp.f

@@ -1,75 +0,0 @@
-
-! ---
-
-program combine_lr_tcscf
-
-  BEGIN_DOC
-  ! TODO : Put the documentation of the program here
-  END_DOC
-
-  implicit none
-
-  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
-
-  bi_ortho = .True.
-  touch bi_ortho
-
-  call comb_orbitals()
-
-end
-
-! ---
-
-subroutine comb_orbitals()
-
-  implicit none
-  integer                       :: i, m, n, nn, mm
-  double precision              :: accu_d, accu_nd
-  double precision, allocatable :: R(:,:), L(:,:), Rnew(:,:), tmp(:,:), S(:,:)
-
-  n  = ao_num
-  m  = mo_num
-  nn = elec_alpha_num
-  mm = m - nn
-
-  allocate(L(n,m), R(n,m), Rnew(n,m), S(m,m))
-  L = mo_l_coef
-  R = mo_r_coef
-
-  call check_weighted_biorthog(n, m, ao_overlap, L, R, accu_d, accu_nd, S, .true.)
-
-  allocate(tmp(n,nn))
-  do i = 1, nn 
-    tmp(1:n,i) = R(1:n,i)
-  enddo
-  call impose_weighted_orthog_svd(n, nn, ao_overlap, tmp)
-  do i = 1, nn
-    Rnew(1:n,i) = tmp(1:n,i)
-  enddo
-  deallocate(tmp)
-
-  allocate(tmp(n,mm))
-  do i = 1, mm
-    tmp(1:n,i) = L(1:n,i+nn)
-  enddo
-  call impose_weighted_orthog_svd(n, mm, ao_overlap, tmp)
-  do i = 1, mm
-    Rnew(1:n,i+nn) = tmp(1:n,i)
-  enddo
-  deallocate(tmp)
-
-  call check_weighted_biorthog(n, m, ao_overlap, Rnew, Rnew, accu_d, accu_nd, S, .true.)
-
-  mo_r_coef = Rnew
-  call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
-
-  deallocate(L, R, Rnew, S)
-
-end subroutine comb_orbitals
-
-! ---
-

plugins/local/tc_scf/diago_vartcfock.irp.f

@@ -1,96 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [ double precision, fock_vartc_eigvec_mo, (mo_num, mo_num)]
-
-  implicit none
-
-  integer                       :: i, j
-  integer                       :: liwork, lwork, n, info
-  integer,          allocatable :: iwork(:)
-  double precision, allocatable :: work(:), F(:,:), F_save(:,:)
-  double precision, allocatable :: diag(:)
-
-  PROVIDE mo_r_coef
-  PROVIDE Fock_matrix_vartc_mo_tot
-
-  allocate( F(mo_num,mo_num), F_save(mo_num,mo_num)  )
-  allocate (diag(mo_num) )
-
-  do j = 1, mo_num
-    do i = 1, mo_num
-      F(i,j) = Fock_matrix_vartc_mo_tot(i,j)
-    enddo
-  enddo
-
-  ! Insert level shift here
-  do i = elec_beta_num+1, elec_alpha_num
-    F(i,i) += 0.5d0 * level_shift_tcscf
-  enddo
-  do i = elec_alpha_num+1, mo_num
-    F(i,i) += level_shift_tcscf
-  enddo
-
-  n = mo_num
-  lwork = 1+6*n + 2*n*n
-  liwork = 3 + 5*n
-
-  allocate(work(lwork))
-  allocate(iwork(liwork) )
-
-  lwork = -1
-  liwork = -1
-
-  F_save = F
-  call dsyevd('V', 'U', mo_num, F, size(F, 1), diag, work, lwork, iwork, liwork, info)
-
-  if (info /= 0) then
-    print *,  irp_here//' DSYEVD failed : ', info
-    stop 1
-  endif
-  lwork = int(work(1))
-  liwork = iwork(1)
-  deallocate(iwork)
-  deallocate(work)
-
-  allocate(work(lwork))
-  allocate(iwork(liwork) )
-  call dsyevd('V', 'U', mo_num, F, size(F, 1), diag, work, lwork, iwork, liwork, info)
-  deallocate(iwork)
-
-  if (info /= 0) then
-    F = F_save
-    call dsyev('V', 'L', mo_num, F, size(F, 1), diag, work, lwork, info)
-
-    if (info /= 0) then
-      print *,  irp_here//' DSYEV failed : ', info
-      stop 1
-    endif
-  endif
-
-  do i = 1, mo_num
-    do j = 1, mo_num
-      fock_vartc_eigvec_mo(j,i) = F(j,i)
-    enddo
-  enddo
-
-  deallocate(work, F, F_save, diag)
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, fock_vartc_eigvec_ao, (ao_num, mo_num)]
-
-  implicit none
-
-  PROVIDE mo_r_coef
-
-  call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0                                             &
-            , mo_r_coef, size(mo_r_coef, 1), fock_vartc_eigvec_mo, size(fock_vartc_eigvec_mo, 1) &
-            , 0.d0, fock_vartc_eigvec_ao, size(fock_vartc_eigvec_ao, 1))
-
-END_PROVIDER
-
-! ---
-

plugins/local/tc_scf/diis_tcscf.irp.f

@@ -91,29 +91,15 @@ BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
   double precision, allocatable :: tmp(:,:)
   double precision, allocatable :: F(:,:)
 
-  !print *, ' Providing FQS_SQF_ao ...'
+  PROVIDE Fock_matrix_tc_ao_tot
-  !call wall_time(t0)
 
   allocate(F(ao_num,ao_num))
-  if(var_tc) then
-
-    do i = 1, ao_num
-      do j = 1, ao_num
-        F(j,i) = Fock_matrix_vartc_ao_tot(j,i)
-      enddo
-    enddo
-
-  else
-
-    PROVIDE Fock_matrix_tc_ao_tot
   do i = 1, ao_num
     do j = 1, ao_num
       F(j,i) = Fock_matrix_tc_ao_tot(j,i)
     enddo
   enddo
 
-  endif
-
   allocate(tmp(ao_num,ao_num))
 
   ! F x Q
@@ -140,9 +126,6 @@ BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
   deallocate(tmp)
   deallocate(F)
 
-  !call wall_time(t1)
-  !print *, ' Wall time for FQS_SQF_ao =', t1-t0
-
 END_PROVIDER
 
 ! ---
@@ -152,61 +135,13 @@ BEGIN_PROVIDER [double precision, FQS_SQF_mo, (mo_num, mo_num)]
   implicit none
   double precision :: t0, t1
 
-  !print*, ' Providing FQS_SQF_mo ...'
-  !call wall_time(t0)
-
   PROVIDE mo_r_coef mo_l_coef
   PROVIDE FQS_SQF_ao
 
   call ao_to_mo_bi_ortho( FQS_SQF_ao, size(FQS_SQF_ao, 1) &
                         , FQS_SQF_mo, size(FQS_SQF_mo, 1) )
 
-  !call wall_time(t1)
-  !print*, ' Wall time for FQS_SQF_mo =', t1-t0 
-
 END_PROVIDER
 
 ! ---
 
-! BEGIN_PROVIDER [ double precision, eigenval_Fock_tc_ao, (ao_num) ]
-!&BEGIN_PROVIDER [ double precision, eigenvec_Fock_tc_ao, (ao_num,ao_num) ]
-!
-!  BEGIN_DOC
-!  !
-!  ! Eigenvalues and eigenvectors of the Fock matrix over the ao basis
-!  !
-!  ! F' = X.T x F x X   where X = ao_overlap^(-1/2)
-!  ! 
-!  ! F'   x Cr' = Cr' x E ==> F   Cr = Cr x E with Cr = X x Cr'
-!  ! F'.T x Cl' = Cl' x E ==> F.T Cl = Cl x E with Cl = X x Cl'
-!  !
-!  END_DOC
-!
-!  implicit none
-!  double precision, allocatable :: tmp1(:,:), tmp2(:,:)
-!
-!  ! ---
-!  ! Fock matrix in orthogonal basis: F' = X.T x F x X
-!
-!  allocate(tmp1(ao_num,ao_num))
-!  call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0                                                 &
-!            , Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1), S_half_inv, size(S_half_inv, 1) &
-!            , 0.d0, tmp1, size(tmp1, 1) )
-!
-!  allocate(tmp2(ao_num,ao_num))
-!  call dgemm( 'T', 'N', ao_num, ao_num, ao_num, 1.d0               &
-!            , S_half_inv, size(S_half_inv, 1), tmp1, size(tmp1, 1) &
-!            , 0.d0, tmp2, size(tmp2, 1) )
-!
-!  ! ---
-!
-!  ! Diagonalize F' to obtain eigenvectors in orthogonal basis C' and eigenvalues
-!  ! TODO
-!
-!  ! Back-transform eigenvectors: C =X.C'
-!
-!END_PROVIDER
-
-! ---
-
-~                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    

plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f

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

plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f

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

plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f

@@ -1,77 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
-
-  BEGIN_DOC
-  !
-  ! Fock matrix alpha from three-electron terms 
-  !
-  ! WARNING :: non hermitian if bi-ortho MOS used 
-  !
-  END_DOC
-
-  implicit none
-  double precision :: ti, tf
-
-  PROVIDE mo_l_coef mo_r_coef
-
-  !print *, ' Providing fock_3e_uhf_mo_a ...'
-  !call wall_time(ti)
-
-  ! CLOSED-SHELL PART
-  PROVIDE fock_3e_uhf_mo_cs
-  fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs
-
-  if(elec_alpha_num .ne. elec_beta_num) then
-
-    ! OPEN-SHELL PART
-    PROVIDE fock_3e_uhf_mo_a_os
-
-    fock_3e_uhf_mo_a += fock_3e_uhf_mo_a_os
-  endif
-
-  !call wall_time(tf)
-  !print *, ' Wall time for fock_3e_uhf_mo_a (min) =', (tf - ti)/60.d0
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
-
-  BEGIN_DOC
-  !
-  ! Fock matrix beta from three-electron terms 
-  !
-  ! WARNING :: non hermitian if bi-ortho MOS used 
-  !
-  END_DOC
-
-  implicit none
-  double precision :: ti, tf
-
-  PROVIDE mo_l_coef mo_r_coef
-
-  !print *, ' Providing and fock_3e_uhf_mo_b ...'
-  !call wall_time(ti)
-
-  ! CLOSED-SHELL PART
-  PROVIDE fock_3e_uhf_mo_cs
-  fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs
-
-  if(elec_alpha_num .ne. elec_beta_num) then
-
-    ! OPEN-SHELL PART
-    PROVIDE fock_3e_uhf_mo_b_os
-
-    fock_3e_uhf_mo_b += fock_3e_uhf_mo_b_os
-  endif
-
-  !call wall_time(tf)
-  !print *, ' Wall time for fock_3e_uhf_mo_b =', tf - ti
-
-END_PROVIDER 
-
-! ---
-

plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f

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

plugins/local/tc_scf/fock_hermit.irp.f

@@ -1,107 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [ double precision, good_hermit_tc_fock_mat, (mo_num, mo_num)]
-
-  BEGIN_DOC
-! good_hermit_tc_fock_mat = Hermitian Upper triangular Fock matrix
-!
-! The converged eigenvectors of such matrix yield to orthonormal vectors satisfying the left Brillouin theorem
-  END_DOC
-  implicit none
-  integer :: i, j
-
-  good_hermit_tc_fock_mat = Fock_matrix_tc_mo_tot
-  do j = 1, mo_num
-    do i = 1, j-1
-      good_hermit_tc_fock_mat(i,j) = Fock_matrix_tc_mo_tot(j,i)
-    enddo
-  enddo
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, hermit_average_tc_fock_mat, (mo_num, mo_num)]
-
-  BEGIN_DOC
-! hermit_average_tc_fock_mat = (F + F^\dagger)/2
-  END_DOC
-  implicit none
-  integer :: i, j
-
-  hermit_average_tc_fock_mat = Fock_matrix_tc_mo_tot
-  do j = 1, mo_num
-    do i = 1, mo_num
-      hermit_average_tc_fock_mat(i,j) = 0.5d0 * (Fock_matrix_tc_mo_tot(j,i) + Fock_matrix_tc_mo_tot(i,j))
-    enddo
-  enddo
-
-END_PROVIDER
-
-
-! ---
-BEGIN_PROVIDER [ double precision, grad_hermit]
- implicit none
- BEGIN_DOC
- ! square of gradient of the energy
- END_DOC
- if(symmetric_fock_tc)then
-  grad_hermit = grad_hermit_average_tc_fock_mat
- else
-  grad_hermit = grad_good_hermit_tc_fock_mat
- endif
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, grad_good_hermit_tc_fock_mat]
-  implicit none
-  BEGIN_DOC
-  ! grad_good_hermit_tc_fock_mat = norm of gradients of the upper triangular TC fock
-  END_DOC
-  integer :: i, j
-  grad_good_hermit_tc_fock_mat = 0.d0
-  do i = 1, elec_alpha_num
-    do j = elec_alpha_num+1, mo_num
-      grad_good_hermit_tc_fock_mat += dabs(good_hermit_tc_fock_mat(i,j))
-    enddo
-  enddo
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, grad_hermit_average_tc_fock_mat]
-  implicit none
-  BEGIN_DOC
-  ! grad_hermit_average_tc_fock_mat = norm of gradients of the upper triangular TC fock
-  END_DOC
-  integer :: i, j
-  grad_hermit_average_tc_fock_mat = 0.d0
-  do i = 1, elec_alpha_num
-    do j = elec_alpha_num+1, mo_num
-      grad_hermit_average_tc_fock_mat += dabs(hermit_average_tc_fock_mat(i,j))
-    enddo
-  enddo
-END_PROVIDER
-
-
-! ---
-
-subroutine save_good_hermit_tc_eigvectors()
-
-  implicit none
-  integer        :: sign
-  character*(64) :: label
-  logical        :: output
-
-  sign = 1
-  label = "Canonical"
-  output = .False.
-
-  if(symmetric_fock_tc)then
-   call mo_as_eigvectors_of_mo_matrix(hermit_average_tc_fock_mat, mo_num, mo_num, label, sign, output)
-  else
-   call mo_as_eigvectors_of_mo_matrix(good_hermit_tc_fock_mat, mo_num, mo_num, label, sign, output)
-  endif
-end subroutine save_good_hermit_tc_eigvectors
-
-! ---
-

plugins/local/tc_scf/fock_tc_mo_tot.irp.f

@@ -1,4 +1,6 @@
 
+! ---
+
  BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_tot, (mo_num,mo_num) ]
 &BEGIN_PROVIDER [ double precision, Fock_matrix_tc_diag_mo_tot, (mo_num)]
 
@@ -23,9 +25,6 @@
   integer          :: i, j, n
   double precision :: t0, t1
 
-  !print*, ' Providing Fock_matrix_tc_mo_tot ...'
-  !call wall_time(t0)
-
   if(elec_alpha_num == elec_beta_num) then
 
     PROVIDE Fock_matrix_tc_mo_alpha
@@ -154,12 +153,25 @@
     enddo
   endif
 
-  if(.not.bi_ortho .and. three_body_h_tc)then
+  if(tc_Brillouin_Right) then
-    Fock_matrix_tc_mo_tot += fock_3_mat
-  endif
 
-  !call wall_time(t1)
+    double precision, allocatable :: tmp(:,:)
-  !print*, ' Wall time for Fock_matrix_tc_mo_tot =', t1-t0
+    allocate(tmp(mo_num,mo_num))
+
+    tmp = Fock_matrix_tc_mo_tot
+    do j = 1, mo_num
+      do i = 1, j-1
+        tmp(i,j) = Fock_matrix_tc_mo_tot(j,i)
+      enddo
+    enddo
+
+    Fock_matrix_tc_mo_tot = tmp
+    deallocate(tmp)
+
+  endif
 
 END_PROVIDER
 
+! ---
+
+

plugins/local/tc_scf/fock_three_hermit.irp.f

@@ -1,771 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [ double precision, fock_3_mat, (mo_num, mo_num)] 
-
-  implicit none
-  integer :: i,j
-  double precision :: contrib
-
-  fock_3_mat = 0.d0
-  if(.not.bi_ortho .and. three_body_h_tc) then
-
-    call give_fock_ia_three_e_total(1, 1, contrib)
-    !!  !$OMP PARALLEL                  &
-    !!  !$OMP DEFAULT (NONE)            &
-    !!  !$OMP PRIVATE (i,j,m,integral) & 
-    !!  !$OMP SHARED (mo_num,three_body_3_index)
-    !!  !$OMP DO SCHEDULE (guided) COLLAPSE(3)
-    do i = 1, mo_num
-      do j = 1, mo_num
-        call give_fock_ia_three_e_total(j,i,contrib)
-        fock_3_mat(j,i) = -contrib
-       enddo
-     enddo
-    !else if(bi_ortho.and.three_body_h_tc) then
-    !!  !$OMP END DO
-    !!  !$OMP END PARALLEL
-    !!  do i = 1, mo_num
-    !!   do j = 1, i-1
-    !!    mat_three(j,i) = mat_three(i,j)
-    !!   enddo
-    !!  enddo
-  endif
-
-END_PROVIDER 
-
-
-subroutine give_fock_ia_three_e_total(i,a,contrib)
- implicit none
- BEGIN_DOC
-! contrib is the TOTAL (same spins / opposite spins) contribution from the three body term to the Fock operator 
-!
- END_DOC
- integer, intent(in) :: i,a
- double precision, intent(out) :: contrib
- double precision :: int_1, int_2, int_3
- double precision :: mos_i, mos_a, w_ia
- double precision :: mos_ia, weight
-
- integer :: mm, ipoint,k,l
-
- int_1 = 0.d0
- int_2 = 0.d0
- int_3 = 0.d0
- do mm = 1, 3
-  do ipoint = 1, n_points_final_grid
-   weight = final_weight_at_r_vector(ipoint)                                                                          
-   mos_i  = mos_in_r_array_transp(ipoint,i) 
-   mos_a  = mos_in_r_array_transp(ipoint,a) 
-   mos_ia = mos_a * mos_i
-   w_ia   = x_W_ij_erf_rk(ipoint,mm,i,a) 
-     
-   int_1  += weight * fock_3_w_kk_sum(ipoint,mm) * (4.d0 * fock_3_rho_beta(ipoint) * w_ia               & 
-                                                  + 2.0d0 * mos_ia * fock_3_w_kk_sum(ipoint,mm)         & 
-                                                  - 2.0d0 * fock_3_w_ki_mos_k(ipoint,mm,i) * mos_a      & 
-                                                  - 2.0d0 * fock_3_w_ki_mos_k(ipoint,mm,a) * mos_i      )
-   int_2  += weight * (-1.d0) * ( 2.0d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * w_ia                     & 
-                                + 2.0d0 * fock_3_rho_beta(ipoint) * fock_3_w_ki_wk_a(ipoint,mm,i,a)   & 
-                                + 1.0d0 * mos_ia * fock_3_trace_w_tilde(ipoint,mm)                    )
-
-   int_3  += weight *   1.d0  * (fock_3_w_kl_wla_phi_k(ipoint,mm,i) * mos_a + fock_3_w_kl_wla_phi_k(ipoint,mm,a) * mos_i & 
-                                +fock_3_w_ki_mos_k(ipoint,mm,i)     * fock_3_w_ki_mos_k(ipoint,mm,a)                     )
-  enddo
- enddo
- contrib = int_1 + int_2 + int_3
-
-end
-
-! ---
-
-BEGIN_PROVIDER [double precision, diag_three_elem_hf]
-
-  implicit none
-  integer                       :: i, j, k, ipoint, mm
-  double precision              :: contrib, weight, four_third, one_third, two_third, exchange_int_231
-  double precision              :: integral_aaa, hthree, integral_aab, integral_abb, integral_bbb
-  double precision, allocatable :: tmp(:)
-  double precision, allocatable :: tmp_L(:,:), tmp_R(:,:)
-  double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
-  double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
-
-  PROVIDE mo_l_coef mo_r_coef
-
-  !print *, ' providing diag_three_elem_hf'
-
-  if(.not. three_body_h_tc) then
-
-   if(noL_standard) then
-      PROVIDE noL_0e
-      diag_three_elem_hf = noL_0e
-    else
-      diag_three_elem_hf = 0.d0
-    endif
-
-  else
-
-    if(.not. bi_ortho) then
-
-      ! ---
-
-      one_third  = 1.d0/3.d0
-      two_third  = 2.d0/3.d0
-      four_third = 4.d0/3.d0
-      diag_three_elem_hf = 0.d0
-      do i = 1, elec_beta_num
-        do j = 1, elec_beta_num
-          do k = 1, elec_beta_num
-            call give_integrals_3_body(k, j, i, j, i, k, exchange_int_231)   
-            diag_three_elem_hf += two_third * exchange_int_231
-          enddo
-        enddo
-      enddo
-      do mm = 1, 3
-        do ipoint = 1, n_points_final_grid
-          weight  = final_weight_at_r_vector(ipoint)                                                                          
-          contrib = 3.d0 * fock_3_w_kk_sum(ipoint,mm) * fock_3_rho_beta(ipoint) * fock_3_w_kk_sum(ipoint,mm) & 
-                  - 2.d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * fock_3_w_kk_sum(ipoint,mm)                     & 
-                  - 1.d0 * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm)
-          contrib *= four_third
-          contrib += -two_third  * fock_3_rho_beta(ipoint)    * fock_3_w_kl_w_kl(ipoint,mm) & 
-                     -four_third * fock_3_w_kk_sum(ipoint,mm) * fock_3_w_kl_mo_k_mo_l(ipoint,mm)
-          diag_three_elem_hf += weight * contrib
-       enddo
-      enddo
-
-      diag_three_elem_hf = - diag_three_elem_hf
-
-      ! ---
-
-    else
-
-      ! ------------
-      ! SLOW VERSION
-      ! ------------
-
-      !call give_aaa_contrib(integral_aaa)
-      !call give_aab_contrib(integral_aab)
-      !call give_abb_contrib(integral_abb)
-      !call give_bbb_contrib(integral_bbb)
-      !diag_three_elem_hf = integral_aaa + integral_aab + integral_abb + integral_bbb
-
-      ! ------------
-      ! ------------
-
-      PROVIDE int2_grad1_u12_bimo_t
-      PROVIDE mos_l_in_r_array_transp
-      PROVIDE mos_r_in_r_array_transp
-
-      if(elec_alpha_num .eq. elec_beta_num) then
-    
-        allocate(tmp(elec_beta_num))
-        allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
-    
-        !$OMP PARALLEL                                                 &
-        !$OMP DEFAULT(NONE)                                            &
-        !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R)                      &
-        !$OMP SHARED(elec_beta_num, n_points_final_grid,               & 
-        !$OMP        mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
-        !$OMP        int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-    
-        !$OMP DO
-        do j = 1, elec_beta_num
-    
-          tmp_L = 0.d0
-          tmp_R = 0.d0
-          do i = 1, elec_beta_num
-            do ipoint = 1, n_points_final_grid
-    
-              tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
-              tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
-              tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-    
-              tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
-              tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
-              tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
-            enddo
-          enddo
-    
-          tmp(j) = 0.d0
-          do ipoint = 1, n_points_final_grid
-            tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
-          enddo
-        enddo ! j
-        !$OMP END DO
-        !$OMP END PARALLEL
-    
-        diag_three_elem_hf = -2.d0 * sum(tmp)
-    
-        deallocate(tmp)
-        deallocate(tmp_L, tmp_R)
-    
-        ! ---
-    
-        allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
-        tmp_O = 0.d0
-        tmp_J = 0.d0
-    
-        !$OMP PARALLEL                                                  &
-        !$OMP DEFAULT(NONE)                                             &
-        !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv)                &
-        !$OMP SHARED(elec_beta_num, n_points_final_grid,                & 
-        !$OMP        mos_l_in_r_array_transp, mos_r_in_r_array_transp,  &
-        !$OMP        int2_grad1_u12_bimo_t, tmp_O, tmp_J)
-    
-        allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
-        tmp_O_priv = 0.d0
-        tmp_J_priv = 0.d0
-      
-        !$OMP DO 
-        do i = 1, elec_beta_num
-          do ipoint = 1, n_points_final_grid
-            tmp_O_priv(ipoint)   = tmp_O_priv(ipoint)   + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
-            tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
-            tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
-            tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
-          enddo
-        enddo
-        !$OMP END DO NOWAIT
-    
-        !$OMP CRITICAL
-        tmp_O = tmp_O + tmp_O_priv
-        tmp_J = tmp_J + tmp_J_priv
-        !$OMP END CRITICAL
-    
-        deallocate(tmp_O_priv, tmp_J_priv)
-        !$OMP END PARALLEL
-    
-        allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
-        tmp_M = 0.d0
-        tmp_S = 0.d0
-    
-        !$OMP PARALLEL                                                 &
-        !$OMP DEFAULT(NONE)                                            &
-        !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv)            &
-        !$OMP SHARED(elec_beta_num, n_points_final_grid,               & 
-        !$OMP        mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
-        !$OMP        int2_grad1_u12_bimo_t, tmp_M, tmp_S)
-    
-        allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
-        tmp_M_priv = 0.d0
-        tmp_S_priv = 0.d0
-      
-        !$OMP DO COLLAPSE(2)
-        do i = 1, elec_beta_num
-          do j = 1, elec_beta_num
-            do ipoint = 1, n_points_final_grid
-    
-              tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-              tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-              tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-    
-              tmp_S_priv(ipoint)   = tmp_S_priv(ipoint)   + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
-                                                          + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
-                                                          + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
-            enddo
-          enddo
-        enddo
-        !$OMP END DO NOWAIT
-    
-        !$OMP CRITICAL
-        tmp_M = tmp_M + tmp_M_priv
-        tmp_S = tmp_S + tmp_S_priv
-        !$OMP END CRITICAL
-    
-        deallocate(tmp_M_priv, tmp_S_priv)
-        !$OMP END PARALLEL
-    
-        allocate(tmp(n_points_final_grid))
-    
-        do ipoint = 1, n_points_final_grid
-    
-          tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
-    
-          tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint)              &
-                                                           - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
-                                                                    + tmp_J(ipoint,2) * tmp_M(ipoint,2) &
-                                                                    + tmp_J(ipoint,3) * tmp_M(ipoint,3)))
-        enddo
-    
-        diag_three_elem_hf = diag_three_elem_hf -2.d0 * (sum(tmp))
-    
-        deallocate(tmp)
-    
-      else
-    
-        allocate(tmp(elec_alpha_num))
-        allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
-    
-        !$OMP PARALLEL                                                   &
-        !$OMP DEFAULT(NONE)                                              &
-        !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R)                        &
-        !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & 
-        !$OMP        mos_l_in_r_array_transp, mos_r_in_r_array_transp,   &
-        !$OMP        int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-    
-        !$OMP DO
-        do j = 1, elec_beta_num
-    
-          tmp_L = 0.d0
-          tmp_R = 0.d0
-          do i = elec_beta_num+1, elec_alpha_num
-            do ipoint = 1, n_points_final_grid
-    
-              tmp_L(ipoint,1) = tmp_L(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
-              tmp_L(ipoint,2) = tmp_L(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
-              tmp_L(ipoint,3) = tmp_L(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-    
-              tmp_R(ipoint,1) = tmp_R(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
-              tmp_R(ipoint,2) = tmp_R(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
-              tmp_R(ipoint,3) = tmp_R(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
-            enddo
-          enddo
-    
-          tmp(j) = 0.d0
-          do ipoint = 1, n_points_final_grid
-            tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
-          enddo
-    
-          do i = 1, elec_beta_num
-            do ipoint = 1, n_points_final_grid
-    
-              tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
-              tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
-              tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-    
-              tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
-              tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
-              tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
-            enddo
-          enddo
-    
-          do ipoint = 1, n_points_final_grid
-            tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
-          enddo
-        enddo ! j
-        !$OMP END DO
-        !$OMP END PARALLEL
-    
-        ! ---
-    
-        !$OMP PARALLEL                                                   &
-        !$OMP DEFAULT(NONE)                                              &
-        !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R)                        &
-        !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & 
-        !$OMP        mos_l_in_r_array_transp, mos_r_in_r_array_transp,   &
-        !$OMP        int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-    
-        !$OMP DO
-        do j = elec_beta_num+1, elec_alpha_num
-    
-          tmp_L = 0.d0
-          tmp_R = 0.d0
-          do i = 1, elec_alpha_num
-            do ipoint = 1, n_points_final_grid
-              tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
-              tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
-              tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-    
-              tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
-              tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
-              tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
-            enddo
-          enddo
-    
-          tmp(j) = 0.d0
-          do ipoint = 1, n_points_final_grid
-            tmp(j) = tmp(j) + 0.5d0 * final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
-          enddo
-        enddo ! j
-        !$OMP END DO
-        !$OMP END PARALLEL
-    
-        diag_three_elem_hf = -2.d0 * sum(tmp)
-    
-        deallocate(tmp)
-        deallocate(tmp_L, tmp_R)
-    
-        ! ---
-    
-        allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
-        tmp_O = 0.d0
-        tmp_J = 0.d0
-    
-        !$OMP PARALLEL                                                   &
-        !$OMP DEFAULT(NONE)                                              &
-        !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv)                 &
-        !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & 
-        !$OMP        mos_l_in_r_array_transp, mos_r_in_r_array_transp,   &
-        !$OMP        int2_grad1_u12_bimo_t, tmp_O, tmp_J)
-    
-        allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
-        tmp_O_priv = 0.d0
-        tmp_J_priv = 0.d0
-      
-        !$OMP DO 
-        do i = 1, elec_beta_num
-          do ipoint = 1, n_points_final_grid
-            tmp_O_priv(ipoint)   = tmp_O_priv(ipoint)   + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
-            tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
-            tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
-            tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
-          enddo
-        enddo
-        !$OMP END DO NOWAIT
-    
-        !$OMP DO 
-        do i = elec_beta_num+1, elec_alpha_num
-          do ipoint = 1, n_points_final_grid
-            tmp_O_priv(ipoint)   = tmp_O_priv(ipoint)   + 0.5d0 * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
-            tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,i)
-            tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,i)
-            tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,i)
-          enddo
-        enddo
-        !$OMP END DO NOWAIT
-    
-        !$OMP CRITICAL
-        tmp_O = tmp_O + tmp_O_priv
-        tmp_J = tmp_J + tmp_J_priv
-        !$OMP END CRITICAL
-    
-        deallocate(tmp_O_priv, tmp_J_priv)
-        !$OMP END PARALLEL
-    
-        ! ---
-    
-        allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
-        tmp_M = 0.d0
-        tmp_S = 0.d0
-    
-        !$OMP PARALLEL                                                   &
-        !$OMP DEFAULT(NONE)                                              &
-        !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv)              &
-        !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & 
-        !$OMP        mos_l_in_r_array_transp, mos_r_in_r_array_transp,   &
-        !$OMP        int2_grad1_u12_bimo_t, tmp_M, tmp_S)
-    
-        allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
-        tmp_M_priv = 0.d0
-        tmp_S_priv = 0.d0
-      
-        !$OMP DO COLLAPSE(2)
-        do i = 1, elec_beta_num
-          do j = 1, elec_beta_num
-            do ipoint = 1, n_points_final_grid
-    
-              tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-              tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-              tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-    
-              tmp_S_priv(ipoint)   = tmp_S_priv(ipoint)   + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
-                                                          + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
-                                                          + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
-            enddo
-          enddo
-        enddo
-        !$OMP END DO NOWAIT
-    
-        !$OMP DO COLLAPSE(2)
-        do i = elec_beta_num+1, elec_alpha_num
-          do j = 1, elec_beta_num
-            do ipoint = 1, n_points_final_grid
-    
-              tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-              tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-              tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-    
-              tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
-              tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
-              tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
-    
-              tmp_S_priv(ipoint)   = tmp_S_priv(ipoint)   + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
-                                                          + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
-                                                          + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
-            enddo
-          enddo
-        enddo
-        !$OMP END DO NOWAIT
-    
-        !$OMP DO COLLAPSE(2)
-        do i = elec_beta_num+1, elec_alpha_num
-          do j = elec_beta_num+1, elec_alpha_num
-            do ipoint = 1, n_points_final_grid
-    
-              tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-              tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-              tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-    
-              tmp_S_priv(ipoint)   = tmp_S_priv(ipoint)   + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
-                                                          + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
-                                                          + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
-            enddo
-          enddo
-        enddo
-        !$OMP END DO NOWAIT
-    
-        !$OMP CRITICAL
-        tmp_M = tmp_M + tmp_M_priv
-        tmp_S = tmp_S + tmp_S_priv
-        !$OMP END CRITICAL
-    
-        deallocate(tmp_M_priv, tmp_S_priv)
-        !$OMP END PARALLEL
-    
-        allocate(tmp(n_points_final_grid))
-    
-        do ipoint = 1, n_points_final_grid
-    
-          tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
-    
-          tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint)              &
-                                                           - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
-                                                                    + tmp_J(ipoint,2) * tmp_M(ipoint,2) &
-                                                                    + tmp_J(ipoint,3) * tmp_M(ipoint,3)))
-        enddo
-    
-        diag_three_elem_hf = diag_three_elem_hf - 2.d0 * (sum(tmp))
-    
-        deallocate(tmp)
-    
-      endif
-
-
-    endif
-
-  endif
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, fock_3_mat_a_op_sh, (mo_num, mo_num)]
- implicit none 
- integer :: h,p,i,j
- double precision :: direct_int, exch_int, exchange_int_231, exchange_int_312
- double precision :: exchange_int_23, exchange_int_12, exchange_int_13 
-
- fock_3_mat_a_op_sh = 0.d0
- do h = 1, mo_num
-  do p = 1, mo_num
-   !F_a^{ab}(h,p) 
-   do i = 1, elec_beta_num ! beta 
-    do j = elec_beta_num+1, elec_alpha_num ! alpha
-     call  give_integrals_3_body(h,j,i,p,j,i,direct_int)    ! <hji|pji>
-     call  give_integrals_3_body(h,j,i,j,p,i,exch_int)   
-     fock_3_mat_a_op_sh(h,p) -= direct_int - exch_int
-    enddo
-   enddo
-   !F_a^{aa}(h,p)
-   do i = 1, elec_beta_num ! alpha 
-    do j = elec_beta_num+1, elec_alpha_num ! alpha
-       call  give_integrals_3_body(h,j,i,p,j,i,direct_int) 
-       call  give_integrals_3_body(h,j,i,i,p,j,exchange_int_231)
-       call  give_integrals_3_body(h,j,i,j,i,p,exchange_int_312) 
-       call  give_integrals_3_body(h,j,i,p,i,j,exchange_int_23) 
-       call  give_integrals_3_body(h,j,i,i,j,p,exchange_int_12)
-       call  give_integrals_3_body(h,j,i,j,p,i,exchange_int_13)  
-       fock_3_mat_a_op_sh(h,p) -= ( direct_int + exchange_int_231 + exchange_int_312 & 
-              -  exchange_int_23 & ! i <-> j
-              -  exchange_int_12 & ! p <-> j
-              -  exchange_int_13  )! p <-> i
-    enddo 
-   enddo
-  enddo
- enddo
-! symmetrized 
-! do p = 1, elec_beta_num
-!  do h = elec_alpha_num +1, mo_num
-!   fock_3_mat_a_op_sh(h,p) = fock_3_mat_a_op_sh(p,h)
-!  enddo
-! enddo
- 
-! do h = elec_beta_num+1, elec_alpha_num
-!  do p = elec_alpha_num +1, mo_num
-!   !F_a^{bb}(h,p) 
-!   do i = 1, elec_beta_num
-!    do j = i+1, elec_beta_num
-!     call  give_integrals_3_body(h,j,i,p,j,i,direct_int)   
-!     call  give_integrals_3_body(h,j,i,p,i,j,exch_int)   
-!     fock_3_mat_a_op_sh(h,p) -= direct_int - exch_int
-!    enddo
-!   enddo
-!  enddo
-! enddo
-
-END_PROVIDER 
-
-BEGIN_PROVIDER [ double precision, fock_3_mat_b_op_sh, (mo_num, mo_num)]
- implicit none 
- integer :: h,p,i,j
- double precision :: direct_int, exch_int
- fock_3_mat_b_op_sh = 0.d0
- do h = 1, elec_beta_num
-  do p = elec_alpha_num +1, mo_num
-   !F_b^{aa}(h,p) 
-   do i = 1, elec_beta_num
-    do j = elec_beta_num+1, elec_alpha_num
-     call  give_integrals_3_body(h,j,i,p,j,i,direct_int)   
-     call  give_integrals_3_body(h,j,i,p,i,j,exch_int)   
-     fock_3_mat_b_op_sh(h,p) += direct_int - exch_int
-    enddo
-   enddo
-
-   !F_b^{ab}(h,p) 
-   do i = elec_beta_num+1, elec_beta_num
-    do j = 1, elec_beta_num
-     call  give_integrals_3_body(h,j,i,p,j,i,direct_int)   
-     call  give_integrals_3_body(h,j,i,j,p,i,exch_int)   
-     fock_3_mat_b_op_sh(h,p) += direct_int - exch_int
-    enddo
-   enddo
- 
-  enddo
- enddo
-
-END_PROVIDER 
-
-
-BEGIN_PROVIDER [ double precision, fock_3_w_kk_sum, (n_points_final_grid,3)]
- implicit none
- integer :: mm, ipoint,k
- double precision :: w_kk
- fock_3_w_kk_sum = 0.d0
- do k = 1, elec_beta_num
-  do mm = 1, 3
-   do ipoint = 1, n_points_final_grid
-    w_kk   = x_W_ij_erf_rk(ipoint,mm,k,k) 
-    fock_3_w_kk_sum(ipoint,mm) += w_kk
-   enddo
-  enddo
- enddo
-END_PROVIDER 
-
-BEGIN_PROVIDER [ double precision, fock_3_w_ki_mos_k, (n_points_final_grid,3,mo_num)]
- implicit none
- integer :: mm, ipoint,k,i
- double precision :: w_ki, mo_k
- fock_3_w_ki_mos_k = 0.d0
- do i = 1, mo_num
-  do k = 1, elec_beta_num
-   do mm = 1, 3
-    do ipoint = 1, n_points_final_grid
-     w_ki   = x_W_ij_erf_rk(ipoint,mm,k,i) 
-     mo_k = mos_in_r_array(k,ipoint)
-     fock_3_w_ki_mos_k(ipoint,mm,i) += w_ki * mo_k
-    enddo
-   enddo
-  enddo
- enddo
-
-END_PROVIDER 
-
-BEGIN_PROVIDER [ double precision, fock_3_w_kl_w_kl, (n_points_final_grid,3)]
- implicit none
- integer :: k,j,ipoint,mm
- double precision :: w_kj
- fock_3_w_kl_w_kl = 0.d0
- do j = 1, elec_beta_num
-  do k = 1, elec_beta_num
-   do mm = 1, 3
-    do ipoint = 1, n_points_final_grid
-     w_kj   = x_W_ij_erf_rk(ipoint,mm,k,j) 
-     fock_3_w_kl_w_kl(ipoint,mm) += w_kj * w_kj
-    enddo
-   enddo
-  enddo
- enddo
-
-
-END_PROVIDER 
-
-BEGIN_PROVIDER [ double precision, fock_3_rho_beta, (n_points_final_grid)]
- implicit none
- integer :: ipoint,k
- fock_3_rho_beta = 0.d0
- do ipoint = 1, n_points_final_grid
-  do k = 1, elec_beta_num
-   fock_3_rho_beta(ipoint) += mos_in_r_array(k,ipoint) * mos_in_r_array(k,ipoint)
-  enddo
- enddo
-END_PROVIDER 
-
-BEGIN_PROVIDER [ double precision, fock_3_w_kl_mo_k_mo_l, (n_points_final_grid,3)]
- implicit none
- integer :: ipoint,k,l,mm
- double precision :: mos_k, mos_l, w_kl
- fock_3_w_kl_mo_k_mo_l = 0.d0
- do k = 1, elec_beta_num
-  do l = 1, elec_beta_num
-   do mm = 1, 3
-    do ipoint = 1, n_points_final_grid
-     mos_k  = mos_in_r_array_transp(ipoint,k) 
-     mos_l  = mos_in_r_array_transp(ipoint,l) 
-     w_kl   = x_W_ij_erf_rk(ipoint,mm,l,k)
-     fock_3_w_kl_mo_k_mo_l(ipoint,mm) += w_kl * mos_k * mos_l 
-    enddo
-   enddo
-  enddo
- enddo
-
-END_PROVIDER 
-
-BEGIN_PROVIDER [ double precision, fock_3_w_ki_wk_a, (n_points_final_grid,3,mo_num, mo_num)]
- implicit none
- integer :: ipoint,i,a,k,mm
- double precision :: w_ki,w_ka
- fock_3_w_ki_wk_a = 0.d0
- do i = 1, mo_num
-  do a = 1, mo_num
-   do mm = 1, 3
-    do ipoint = 1, n_points_final_grid
-     do k = 1, elec_beta_num
-      w_ki   = x_W_ij_erf_rk(ipoint,mm,k,i)
-      w_ka   = x_W_ij_erf_rk(ipoint,mm,k,a)
-      fock_3_w_ki_wk_a(ipoint,mm,a,i) += w_ki * w_ka
-     enddo
-    enddo
-   enddo
-  enddo
- enddo
-END_PROVIDER 
-
-BEGIN_PROVIDER [ double precision, fock_3_trace_w_tilde, (n_points_final_grid,3)]
- implicit none
- integer :: ipoint,k,mm
- fock_3_trace_w_tilde = 0.d0
- do k = 1, elec_beta_num
-   do mm = 1, 3
-    do ipoint = 1, n_points_final_grid
-     fock_3_trace_w_tilde(ipoint,mm) += fock_3_w_ki_wk_a(ipoint,mm,k,k)
-    enddo
-   enddo
- enddo
-
-END_PROVIDER 
-
-BEGIN_PROVIDER [ double precision, fock_3_w_kl_wla_phi_k, (n_points_final_grid,3,mo_num)]
- implicit none
- integer :: ipoint,a,k,mm,l
- double precision :: w_kl,w_la, mo_k
- fock_3_w_kl_wla_phi_k = 0.d0
- do a = 1, mo_num
-  do k = 1, elec_beta_num 
-   do l = 1, elec_beta_num
-    do mm = 1, 3
-     do ipoint = 1, n_points_final_grid
-      w_kl   = x_W_ij_erf_rk(ipoint,mm,l,k)
-      w_la   = x_W_ij_erf_rk(ipoint,mm,l,a)
-      mo_k  = mos_in_r_array_transp(ipoint,k) 
-      fock_3_w_kl_wla_phi_k(ipoint,mm,a) += w_kl * w_la * mo_k
-     enddo
-    enddo
-   enddo
-  enddo
- enddo
-END_PROVIDER 
-
-
-
-
-

plugins/local/tc_scf/fock_vartc.irp.f

@@ -1,287 +0,0 @@
-
-! ---
-
- BEGIN_PROVIDER [ double precision, two_e_vartc_integral_alpha, (ao_num, ao_num)]
-&BEGIN_PROVIDER [ double precision, two_e_vartc_integral_beta , (ao_num, ao_num)]
-
-  implicit none
-  integer                       :: i, j, k, l
-  double precision              :: density, density_a, density_b, I_coul, I_kjli
-  double precision              :: t0, t1
-  double precision, allocatable :: tmp_a(:,:), tmp_b(:,:)
-
-  two_e_vartc_integral_alpha = 0.d0
-  two_e_vartc_integral_beta  = 0.d0
-
- !$OMP PARALLEL DEFAULT (NONE)                                                                        &
- !$OMP PRIVATE (i, j, k, l, density_a, density_b, density, tmp_a, tmp_b, I_coul, I_kjli)              &
- !$OMP SHARED  (ao_num, TCSCF_density_matrix_ao_alpha, TCSCF_density_matrix_ao_beta, ao_two_e_tc_tot, &
- !$OMP         two_e_vartc_integral_alpha, two_e_vartc_integral_beta)
-
-  allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num))
-  tmp_a = 0.d0
-  tmp_b = 0.d0
-
- !$OMP DO
-  do j = 1, ao_num
-    do l = 1, ao_num
-      density_a = TCSCF_density_matrix_ao_alpha(l,j)
-      density_b = TCSCF_density_matrix_ao_beta (l,j)
-      density   = density_a + density_b                      
-      do i = 1, ao_num
-        do k = 1, ao_num
-
-          I_coul = density * ao_two_e_tc_tot(k,i,l,j)
-          I_kjli = ao_two_e_tc_tot(k,j,l,i)
-
-          tmp_a(k,i) += I_coul - density_a * I_kjli
-          tmp_b(k,i) += I_coul - density_b * I_kjli
-        enddo
-      enddo
-    enddo
-  enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
-  do i = 1, ao_num
-    do j = 1, ao_num
-      two_e_vartc_integral_alpha(j,i) += tmp_a(j,i)
-      two_e_vartc_integral_beta (j,i) += tmp_b(j,i)
-    enddo
-  enddo
- !$OMP END CRITICAL
-
-  deallocate(tmp_a, tmp_b)
- !$OMP END PARALLEL
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_ao_alpha, (ao_num, ao_num)]
-
-  implicit none
-
-  Fock_matrix_vartc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_vartc_integral_alpha 
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_ao_beta, (ao_num, ao_num)]
-
-  implicit none
-
-  Fock_matrix_vartc_ao_beta = ao_one_e_integrals_tc_tot + two_e_vartc_integral_beta 
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_mo_alpha, (mo_num, mo_num) ]
-
-  implicit none
-
-  call ao_to_mo_bi_ortho( Fock_matrix_vartc_ao_alpha, size(Fock_matrix_vartc_ao_alpha, 1) &
-                        , Fock_matrix_vartc_mo_alpha, size(Fock_matrix_vartc_mo_alpha, 1) )
-  if(three_body_h_tc) then
-    Fock_matrix_vartc_mo_alpha += fock_3e_uhf_mo_a
-  endif
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_mo_beta, (mo_num,mo_num) ]
-
-  implicit none
-
-  call ao_to_mo_bi_ortho( Fock_matrix_vartc_ao_beta, size(Fock_matrix_vartc_ao_beta, 1) &
-                        , Fock_matrix_vartc_mo_beta, size(Fock_matrix_vartc_mo_beta, 1) )
-  if(three_body_h_tc) then
-    Fock_matrix_vartc_mo_beta += fock_3e_uhf_mo_b
-  endif
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, grad_vartc]
-
-  implicit none
-  integer          :: i, k
-  double precision :: grad_left, grad_right
-
-  grad_left  = 0.d0
-  grad_right = 0.d0
-
-  do i = 1, elec_beta_num ! doc --> SOMO
-    do k = elec_beta_num+1, elec_alpha_num
-      grad_left  = max(grad_left , dabs(Fock_matrix_vartc_mo_tot(k,i)))
-      grad_right = max(grad_right, dabs(Fock_matrix_vartc_mo_tot(i,k)))
-    enddo
-  enddo
-
-  do i = 1, elec_beta_num ! doc --> virt 
-    do k = elec_alpha_num+1, mo_num
-      grad_left  = max(grad_left , dabs(Fock_matrix_vartc_mo_tot(k,i)))
-      grad_right = max(grad_right, dabs(Fock_matrix_vartc_mo_tot(i,k)))
-    enddo
-  enddo
-
-  do i = elec_beta_num+1, elec_alpha_num ! SOMO --> virt 
-    do k = elec_alpha_num+1, mo_num
-      grad_left  = max(grad_left , dabs(Fock_matrix_vartc_mo_tot(k,i)))
-      grad_right = max(grad_right, dabs(Fock_matrix_vartc_mo_tot(i,k)))
-    enddo
-  enddo
-
-  grad_vartc = grad_left + grad_right
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_ao_tot, (ao_num, ao_num) ]
-
-  implicit none
-
-  call mo_to_ao_bi_ortho( Fock_matrix_vartc_mo_tot, size(Fock_matrix_vartc_mo_tot, 1) &
-                        , Fock_matrix_vartc_ao_tot, size(Fock_matrix_vartc_ao_tot, 1) )
-
-END_PROVIDER
-
-! ---
-
- BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_mo_tot, (mo_num,mo_num) ]
-&BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_diag_mo_tot, (mo_num)]
-
-  implicit none
-  integer :: i, j, n
-
-  if(elec_alpha_num == elec_beta_num) then
-    Fock_matrix_vartc_mo_tot = Fock_matrix_vartc_mo_alpha
-  else
-
-    do j = 1, elec_beta_num
-      ! F-K
-      do i = 1, elec_beta_num !CC
-         Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
-            - (Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
-      enddo
-      ! F+K/2
-      do i = elec_beta_num+1, elec_alpha_num  !CA
-         Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
-             + 0.5d0*(Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
-      enddo
-      ! F
-      do i = elec_alpha_num+1, mo_num !CV
-         Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))
-      enddo
-    enddo
-
-    do j = elec_beta_num+1, elec_alpha_num
-      ! F+K/2
-      do i = 1, elec_beta_num !AC
-         Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
-             + 0.5d0*(Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
-      enddo
-      ! F
-      do i = elec_beta_num+1, elec_alpha_num !AA
-         Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))
-      enddo
-      ! F-K/2
-      do i = elec_alpha_num+1, mo_num !AV
-         Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
-             - 0.5d0*(Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
-      enddo
-    enddo
-    
-    do j = elec_alpha_num+1, mo_num
-      ! F
-      do i = 1, elec_beta_num !VC
-         Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))
-      enddo
-      ! F-K/2
-      do i = elec_beta_num+1, elec_alpha_num !VA
-         Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
-             - 0.5d0*(Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
-      enddo
-      ! F+K
-      do i = elec_alpha_num+1, mo_num !VV
-         Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j)) &
-             + (Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
-      enddo
-    enddo
-    if(three_body_h_tc)then
-      ! C-O
-      do j = 1, elec_beta_num
-        do i = elec_beta_num+1, elec_alpha_num
-          Fock_matrix_vartc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
-          Fock_matrix_vartc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
-        enddo
-      enddo
-      ! C-V
-      do j = 1, elec_beta_num
-        do i = elec_alpha_num+1, mo_num
-          Fock_matrix_vartc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
-          Fock_matrix_vartc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
-        enddo
-      enddo
-      ! O-V
-      do j = elec_beta_num+1, elec_alpha_num
-        do i = elec_alpha_num+1, mo_num
-          Fock_matrix_vartc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
-          Fock_matrix_vartc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
-        enddo
-      enddo
-    endif
-
-  endif
-
-  do i = 1, mo_num
-    Fock_matrix_vartc_diag_mo_tot(i) = Fock_matrix_vartc_mo_tot(i,i)
-  enddo
-
-  if(frozen_orb_scf)then
-    integer :: iorb, jorb
-    do i = 1, n_core_orb
-     iorb = list_core(i)
-     do j = 1, n_act_orb
-      jorb = list_act(j)
-      Fock_matrix_vartc_mo_tot(iorb,jorb) = 0.d0
-      Fock_matrix_vartc_mo_tot(jorb,iorb) = 0.d0
-     enddo
-    enddo
-  endif
-
-  if(no_oa_or_av_opt)then
-    do i = 1, n_act_orb
-      iorb = list_act(i)
-      do j = 1, n_inact_orb
-        jorb = list_inact(j)
-        Fock_matrix_vartc_mo_tot(iorb,jorb) = 0.d0
-        Fock_matrix_vartc_mo_tot(jorb,iorb) = 0.d0
-      enddo
-      do j = 1, n_virt_orb
-        jorb = list_virt(j)
-        Fock_matrix_vartc_mo_tot(iorb,jorb) = 0.d0
-        Fock_matrix_vartc_mo_tot(jorb,iorb) = 0.d0
-      enddo
-      do j = 1, n_core_orb
-        jorb = list_core(j)
-        Fock_matrix_vartc_mo_tot(iorb,jorb) = 0.d0
-        Fock_matrix_vartc_mo_tot(jorb,iorb) = 0.d0                                                                                                                 
-      enddo
-    enddo
-  endif
-
-  !call check_sym(Fock_matrix_vartc_mo_tot, mo_num)
-  !do i = 1, mo_num
-  !  write(*,'(100(F15.8, I4))') Fock_matrix_vartc_mo_tot(i,:)
-  !enddo
-
-END_PROVIDER
-
-! ---
-

plugins/local/tc_scf/integrals_in_r_stuff.irp.f

@@ -1,391 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [ double precision, tc_scf_dm_in_r, (n_points_final_grid) ]
-
-  implicit none
-  integer :: i, j
-
-  tc_scf_dm_in_r = 0.d0
-  do i = 1, n_points_final_grid
-    do j = 1, elec_beta_num
-      tc_scf_dm_in_r(i) += mos_r_in_r_array(j,i) * mos_l_in_r_array(j,i)
-    enddo
-  enddo
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, w_sum_in_r, (n_points_final_grid, 3)]
-
-  implicit none
-  integer :: ipoint, j, xi
-
-  w_sum_in_r = 0.d0
-  do j = 1, elec_beta_num
-    do xi = 1, 3
-      do ipoint = 1, n_points_final_grid
-        !w_sum_in_r(ipoint,xi) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,j)
-        w_sum_in_r(ipoint,xi) += x_W_ki_bi_ortho_erf_rk_diag(ipoint,xi,j)
-      enddo
-    enddo
-  enddo
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, ww_sum_in_r, (n_points_final_grid, 3)]
-
-  implicit none
-  integer          :: ipoint, j, xi
-  double precision :: tmp
-
-  ww_sum_in_r = 0.d0
-  do j = 1, elec_beta_num
-    do xi = 1, 3
-      do ipoint = 1, n_points_final_grid
-        tmp = x_W_ki_bi_ortho_erf_rk_diag(ipoint,xi,j)
-        ww_sum_in_r(ipoint,xi) += tmp * tmp
-      enddo
-    enddo
-  enddo
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, W1_r_in_r, (n_points_final_grid, 3, mo_num)]
-
-  implicit none
-  integer :: i, j, xi, ipoint
-
-  ! TODO: call lapack
-
-  W1_r_in_r = 0.d0
-  do i = 1, mo_num
-    do j = 1, elec_beta_num
-      do xi = 1, 3
-        do ipoint = 1, n_points_final_grid
-          W1_r_in_r(ipoint,xi,i) += mos_r_in_r_array_transp(ipoint,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,i)
-        enddo
-      enddo
-    enddo
-  enddo
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, W1_l_in_r, (n_points_final_grid, 3, mo_num)]
-
-  implicit none
-  integer :: i, j, xi, ipoint
-
-  ! TODO: call lapack
-
-  W1_l_in_r = 0.d0
-  do i = 1, mo_num
-    do j = 1, elec_beta_num
-      do xi = 1, 3
-        do ipoint = 1, n_points_final_grid
-          W1_l_in_r(ipoint,xi,i) += mos_l_in_r_array_transp(ipoint,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,i,j)
-        enddo
-      enddo
-    enddo
-  enddo
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, W1_in_r, (n_points_final_grid, 3)]
-
-  implicit none
-  integer :: j, xi, ipoint
-
-  ! TODO: call lapack
-
-  W1_in_r = 0.d0
-  do j = 1, elec_beta_num
-    do xi = 1, 3
-      do ipoint = 1, n_points_final_grid
-        W1_in_r(ipoint,xi) += W1_l_in_r(ipoint,xi,j) * mos_r_in_r_array_transp(ipoint,j)
-      enddo
-    enddo
-  enddo
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, W1_diag_in_r, (n_points_final_grid, 3)]
-
-  implicit none
-  integer :: j, xi, ipoint
-
-  ! TODO: call lapack
-
-  W1_diag_in_r = 0.d0
-  do j = 1, elec_beta_num
-    do xi = 1, 3
-      do ipoint = 1, n_points_final_grid
-        W1_diag_in_r(ipoint,xi) += mos_r_in_r_array_transp(ipoint,j) * mos_l_in_r_array_transp(ipoint,j) * x_W_ki_bi_ortho_erf_rk_diag(ipoint,xi,j)
-      enddo
-    enddo
-  enddo
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, v_sum_in_r, (n_points_final_grid, 3)]
-
-  implicit none
-  integer :: i, j, xi, ipoint
-
-  ! TODO: call lapack
-  v_sum_in_r = 0.d0
-  do i = 1, elec_beta_num
-    do j = 1, elec_beta_num
-      do xi = 1, 3
-        do ipoint = 1, n_points_final_grid
-          v_sum_in_r(ipoint,xi) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,i,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,i)
-        enddo
-      enddo
-    enddo
-  enddo
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, W1_W1_r_in_r, (n_points_final_grid, 3, mo_num)]
-
-  implicit none
-  integer :: i, m, xi, ipoint
-
-  ! TODO: call lapack
-
-  W1_W1_r_in_r = 0.d0
-  do i = 1, mo_num
-    do m = 1, elec_beta_num
-      do xi = 1, 3
-        do ipoint = 1, n_points_final_grid
-          W1_W1_r_in_r(ipoint,xi,i) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,m,i) * W1_r_in_r(ipoint,xi,m)
-        enddo
-      enddo
-    enddo
-  enddo
-
-END_PROVIDER 
-
-! ---
-
-BEGIN_PROVIDER [ double precision, W1_W1_l_in_r, (n_points_final_grid, 3, mo_num)]
-
-  implicit none
-  integer :: i, j, xi, ipoint
-
-  ! TODO: call lapack
-
-  W1_W1_l_in_r = 0.d0
-  do i = 1, mo_num
-    do j = 1, elec_beta_num
-      do xi = 1, 3
-        do ipoint = 1, n_points_final_grid
-          W1_W1_l_in_r(ipoint,xi,i) += x_W_ki_bi_ortho_erf_rk(ipoint,xi,i,j) * W1_l_in_r(ipoint,xi,j)
-        enddo
-      enddo
-    enddo
-  enddo
-
-END_PROVIDER 
-
-! ---
-
-subroutine direct_term_imj_bi_ortho(a, i, integral)
-
-  BEGIN_DOC
-  ! computes sum_(j,m = 1, elec_beta_num) < a m j | i m j > with bi ortho mos
-  END_DOC
-
-  implicit none
-  integer,          intent(in)  :: i, a
-  double precision, intent(out) :: integral
-
-  integer                       :: ipoint, xi
-  double precision              :: weight, tmp
-
-  integral = 0.d0
-  do xi = 1, 3
-    do ipoint = 1, n_points_final_grid
-      weight = final_weight_at_r_vector(ipoint)
-      !integral += ( mos_l_in_r_array(a,ipoint) * mos_r_in_r_array(i,ipoint) * w_sum_in_r(ipoint,xi) * w_sum_in_r(ipoint,xi) & 
-      !            + 2.d0 * tc_scf_dm_in_r(ipoint) * w_sum_in_r(ipoint,xi) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) ) * weight
-
-      tmp = w_sum_in_r(ipoint,xi)
-
-      integral += ( mos_l_in_r_array_transp(ipoint,a) * mos_r_in_r_array_transp(ipoint,i) * tmp * tmp & 
-                  + 2.d0 * tc_scf_dm_in_r(ipoint) * tmp * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i)       &
-                  ) * weight
-    enddo
-  enddo
-
-end 
-
-! ---
-
-subroutine exch_term_jmi_bi_ortho(a, i, integral)
-
-  BEGIN_DOC
-  ! computes sum_(j,m = 1, elec_beta_num) < a m j | j m i > with bi ortho mos
-  END_DOC
-
-  implicit none
-  integer,          intent(in)  :: i, a
-  double precision, intent(out) :: integral
-
-  integer                       :: ipoint, xi, j
-  double precision              :: weight, tmp
-
-  integral = 0.d0
-  do xi = 1, 3
-    do ipoint = 1, n_points_final_grid
-      weight = final_weight_at_r_vector(ipoint)
-        
-      tmp = 0.d0
-      do j = 1, elec_beta_num
-        tmp = tmp + x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,j) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,j,i) 
-      enddo
-
-      integral += ( mos_l_in_r_array_transp(ipoint,a) * W1_r_in_r(ipoint,xi,i) * w_sum_in_r(ipoint,xi) & 
-                  + tc_scf_dm_in_r(ipoint) * tmp                                                       &
-                  + mos_r_in_r_array_transp(ipoint,i) * W1_l_in_r(ipoint,xi,a) * w_sum_in_r(ipoint,xi) & 
-                  ) * weight
-
-    enddo
-  enddo
-
-end
-
-! ---
-
-subroutine exch_term_ijm_bi_ortho(a, i, integral)
-
-  BEGIN_DOC
-  ! computes sum_(j,m = 1, elec_beta_num) < a m j | i j m > with bi ortho mos
-  END_DOC
-
-  implicit none
-  integer,          intent(in)  :: i, a
-  double precision, intent(out) :: integral
-
-  integer                       :: ipoint, xi
-  double precision              :: weight
-
-  integral = 0.d0
-  do xi = 1, 3
-    do ipoint = 1, n_points_final_grid
-      weight = final_weight_at_r_vector(ipoint)
-        
-      integral += ( mos_l_in_r_array_transp(ipoint,a) * mos_r_in_r_array_transp(ipoint,i) * v_sum_in_r(ipoint,xi) & 
-                  + 2.d0 * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i) * W1_in_r(ipoint,xi)                             &
-                  ) * weight
-
-    enddo
-  enddo
-
-end
-
-! ---
-
-subroutine direct_term_ijj_bi_ortho(a, i, integral)
-
-  BEGIN_DOC
-  ! computes sum_(j = 1, elec_beta_num) < a j j | i j j > with bi ortho mos
-  END_DOC
-
-  implicit none
-  integer,          intent(in)  :: i, a
-  double precision, intent(out) :: integral
-
-  integer                       :: ipoint, xi
-  double precision              :: weight
-
-  integral = 0.d0
-  do xi = 1, 3
-    do ipoint = 1, n_points_final_grid
-      weight = final_weight_at_r_vector(ipoint)
-
-      integral += ( mos_l_in_r_array_transp(ipoint,a) * mos_r_in_r_array_transp(ipoint,i) * ww_sum_in_r(ipoint,xi) & 
-                  + 2.d0 * W1_diag_in_r(ipoint, xi) * x_W_ki_bi_ortho_erf_rk(ipoint,xi,a,i)                        &
-                  ) * weight
-    enddo
-  enddo
-
-end 
-
-! ---
-
-subroutine cyclic_term_jim_bi_ortho(a, i, integral)
-
-  BEGIN_DOC
-  ! computes sum_(j,m = 1, elec_beta_num) < a m j | j i m > with bi ortho mos
-  END_DOC
-
-  implicit none
-  integer,          intent(in)  :: i, a
-  double precision, intent(out) :: integral
-
-  integer                       :: ipoint, xi
-  double precision              :: weight
-
-  integral = 0.d0
-  do xi = 1, 3
-    do ipoint = 1, n_points_final_grid
-      weight = final_weight_at_r_vector(ipoint)
-        
-      integral += ( mos_l_in_r_array_transp(ipoint,a) * W1_W1_r_in_r(ipoint,xi,i)  & 
-                  + W1_W1_l_in_r(ipoint,xi,a) * mos_r_in_r_array_transp(ipoint,i)  &
-                  + W1_l_in_r(ipoint,xi,a) * W1_r_in_r(ipoint,xi,i)                &
-                  ) * weight
-
-    enddo
-  enddo
-
-end
-
-! ---
-
-subroutine cyclic_term_mji_bi_ortho(a, i, integral)
-
-  BEGIN_DOC
-  ! computes sum_(j,m = 1, elec_beta_num) < a m j | m j i > with bi ortho mos
-  END_DOC
-
-  implicit none
-  integer,          intent(in)  :: i, a
-  double precision, intent(out) :: integral
-
-  integer                       :: ipoint, xi
-  double precision              :: weight
-
-  integral = 0.d0
-  do xi = 1, 3
-    do ipoint = 1, n_points_final_grid
-      weight = final_weight_at_r_vector(ipoint)
-        
-      integral += ( mos_l_in_r_array_transp(ipoint,a) * W1_W1_r_in_r(ipoint,xi,i)  & 
-                  + W1_l_in_r(ipoint,xi,a) * W1_r_in_r(ipoint,xi,i)                &
-                  + W1_W1_l_in_r(ipoint,xi,a) * mos_r_in_r_array_transp(ipoint,i)  &
-                  ) * weight
-
-    enddo
-  enddo
-
-end
-
-! ---
-

plugins/local/tc_scf/jast_schmos_90.irp.f

@@ -1,318 +0,0 @@
- BEGIN_PROVIDER [integer ,  m_max_sm_7]
-&BEGIN_PROVIDER [integer ,  n_max_sm_7]
-&BEGIN_PROVIDER [integer ,  o_max_sm_7]
- implicit none
- BEGIN_DOC
-! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4) 
-! of Schmidt,Moskowitz, JCP, 93, 4172 (1990)  for the SM_7 version of Table IV
- END_DOC
- m_max_sm_7 = 4
- n_max_sm_7 = 0
- o_max_sm_7 = 4
-END_PROVIDER 
-
- BEGIN_PROVIDER [integer ,  m_max_sm_9]
-&BEGIN_PROVIDER [integer ,  n_max_sm_9]
-&BEGIN_PROVIDER [integer ,  o_max_sm_9]
- implicit none
- BEGIN_DOC
-! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4) 
-! of Schmidt,Moskowitz, JCP, 93, 4172 (1990)  for the SM_9 version of Table IV
- END_DOC
- m_max_sm_9 = 4
- n_max_sm_9 = 2
- o_max_sm_9 = 4
-END_PROVIDER 
-
-
- BEGIN_PROVIDER [integer ,  m_max_sm_17]
-&BEGIN_PROVIDER [integer ,  n_max_sm_17]
-&BEGIN_PROVIDER [integer ,  o_max_sm_17]
- implicit none
- BEGIN_DOC
-! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4) 
-! of Schmidt,Moskowitz, JCP, 93, 4172 (1990)  for the SM_17 version of Table IV
- END_DOC
- m_max_sm_17 = 6
- n_max_sm_17 = 2
- o_max_sm_17 = 6
-END_PROVIDER 
-
-
-BEGIN_PROVIDER [ double precision, c_mn_o_sm_7, (0:m_max_sm_7,0:n_max_sm_7,0:o_max_sm_7,2:10)]
- implicit none
- BEGIN_DOC
- !
- !c_mn_o_7(0:4,0:4,2:10) = coefficient for the SM_7 correlation factor as given is Table IV of 
- !                         Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- !                         the first index (0:4) is the "m"  integer for the 1e part 
- !                         the second index(0:0) is the "n"  integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_7
- !                         the third index (0:4) is the "o" integer for the 2e part
- !                         the fourth index (2:10) is the nuclear charge of the atom 
- END_DOC
- c_mn_o_sm_7 = 0.d0
- integer :: i
- do i = 2, 10 ! loop over nuclear charge
-  c_mn_o_sm_7(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
- enddo
- ! He atom 
- ! two electron terms 
- c_mn_o_sm_7(0,0,2,2) =  0.50516d0 
- c_mn_o_sm_7(0,0,3,2) = -0.19313d0 
- c_mn_o_sm_7(0,0,4,2) =  0.30276d0 
- ! one-electron terms 
- c_mn_o_sm_7(2,0,0,2) = -0.16995d0
- c_mn_o_sm_7(3,0,0,2) = -0.34505d0
- c_mn_o_sm_7(4,0,0,2) = -0.54777d0
- ! Ne atom 
- ! two electron terms 
- c_mn_o_sm_7(0,0,2,10) = -0.792d0
- c_mn_o_sm_7(0,0,3,10) =  1.05232d0 
- c_mn_o_sm_7(0,0,4,10) = -0.65615d0 
- ! one-electron terms 
- c_mn_o_sm_7(2,0,0,10) = -0.13312d0
- c_mn_o_sm_7(3,0,0,10) = -0.00131d0
- c_mn_o_sm_7(4,0,0,10) =  0.09083d0
-
-END_PROVIDER 
-
-BEGIN_PROVIDER [ double precision, c_mn_o_sm_9, (0:m_max_sm_9,0:n_max_sm_9,0:o_max_sm_9,2:10)]
- implicit none
- BEGIN_DOC
- !
- !c_mn_o_9(0:4,0:4,2:10) = coefficient for the SM_9 correlation factor as given is Table IV of 
- !                         Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- !                         the first index (0:4) is the "m"  integer for the 1e part 
- !                         the second index(0:0) is the "n"  integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_9
- !                         the third index (0:4) is the "o" integer for the 2e part
- !                         the fourth index (2:10) is the nuclear charge of the atom 
- END_DOC
- c_mn_o_sm_9 = 0.d0
- integer :: i
- do i = 2, 10 ! loop over nuclear charge
-  c_mn_o_sm_9(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
- enddo
- ! He atom 
- ! two electron terms 
- c_mn_o_sm_9(0,0,2,2) =  0.50516d0 
- c_mn_o_sm_9(0,0,3,2) = -0.19313d0 
- c_mn_o_sm_9(0,0,4,2) =  0.30276d0 
- ! one-electron terms 
- c_mn_o_sm_9(2,0,0,2) = -0.16995d0
- c_mn_o_sm_9(3,0,0,2) = -0.34505d0
- c_mn_o_sm_9(4,0,0,2) = -0.54777d0
- ! Ne atom 
- ! two electron terms 
- c_mn_o_sm_9(0,0,2,10) = -0.792d0
- c_mn_o_sm_9(0,0,3,10) =  1.05232d0 
- c_mn_o_sm_9(0,0,4,10) = -0.65615d0 
- ! one-electron terms 
- c_mn_o_sm_9(2,0,0,10) = -0.13312d0
- c_mn_o_sm_9(3,0,0,10) = -0.00131d0
- c_mn_o_sm_9(4,0,0,10) =  0.09083d0
-
-END_PROVIDER 
-
-BEGIN_PROVIDER [ double precision, c_mn_o_sm_17, (0:m_max_sm_17,0:n_max_sm_17,0:o_max_sm_17,2:10)]
- implicit none
- BEGIN_DOC
- !
- !c_mn_o_17(0:4,0:4,2:10) = coefficient for the SM_17 correlation factor as given is Table IV of 
- !                         Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- !                         the first index (0:4) is the "m"  integer for the 1e part 
- !                         the second index(0:0) is the "n"  integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_17
- !                         the third index (0:4) is the "o" integer for the 2e part
- !                         the fourth index (2:10) is the nuclear charge of the atom 
- END_DOC
- c_mn_o_sm_17 = 0.d0
- integer :: i
- do i = 2, 10 ! loop over nuclear charge
-  c_mn_o_sm_17(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
- enddo
- ! He atom 
- ! two electron terms 
- c_mn_o_sm_17(0,0,2,2) =  0.09239d0 
- c_mn_o_sm_17(0,0,3,2) = -0.38664d0 
- c_mn_o_sm_17(0,0,4,2) =  0.95764d0 
- ! one-electron terms 
- c_mn_o_sm_17(2,0,0,2) =  0.23208d0
- c_mn_o_sm_17(3,0,0,2) = -0.45032d0
- c_mn_o_sm_17(4,0,0,2) =  0.82777d0
- c_mn_o_sm_17(2,2,0,2) = -4.15388d0
- ! ee-n terms 
- c_mn_o_sm_17(2,0,2,2) =  0.80622d0
- c_mn_o_sm_17(2,2,2,2) = 10.19704d0
- c_mn_o_sm_17(4,0,2,2) = -4.96259d0
- c_mn_o_sm_17(2,0,4,2) = -1.35647d0
- c_mn_o_sm_17(4,2,2,2) = -5.90907d0
- c_mn_o_sm_17(6,0,2,2) =  0.90343d0
- c_mn_o_sm_17(4,0,4,2) =  5.50739d0
- c_mn_o_sm_17(2,2,4,2) = -0.03154d0
- c_mn_o_sm_17(2,0,6,2) = -1.1051860
-
-
- ! Ne atom 
- ! two electron terms 
- c_mn_o_sm_17(0,0,2,10) = -0.80909d0 
- c_mn_o_sm_17(0,0,3,10) = -0.00219d0 
- c_mn_o_sm_17(0,0,4,10) =  0.59188d0
- ! one-electron terms 
- c_mn_o_sm_17(2,0,0,10) = -0.00567d0
- c_mn_o_sm_17(3,0,0,10) =  0.14011d0
- c_mn_o_sm_17(4,0,0,10) = -0.05671d0
- c_mn_o_sm_17(2,2,0,10) = -3.33767d0
- ! ee-n terms 
- c_mn_o_sm_17(2,0,2,10) =  1.95067d0
- c_mn_o_sm_17(2,2,2,10) =  6.83340d0
- c_mn_o_sm_17(4,0,2,10) = -3.29231d0
- c_mn_o_sm_17(2,0,4,10) = -2.44998d0
- c_mn_o_sm_17(4,2,2,10) = -2.13029d0
- c_mn_o_sm_17(6,0,2,10) =  2.25768d0
- c_mn_o_sm_17(4,0,4,10) =  1.97951d0
- c_mn_o_sm_17(2,2,4,10) = -2.0924160
- c_mn_o_sm_17(2,0,6,10) =  0.35493d0
-
-END_PROVIDER 
-
- BEGIN_PROVIDER [ double precision, b_I_sm_90,(2:10)]
-&BEGIN_PROVIDER [ double precision, d_I_sm_90,(2:10)]
- implicit none
- BEGIN_DOC
-! "b_I" and "d_I" parameters of Eqs. (4) and (5) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- END_DOC
- b_I_sm_90 = 1.d0
- d_I_sm_90 = 1.d0
- 
-END_PROVIDER 
-
-subroutine get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- implicit none 
- double precision, intent(in) :: r1(3),r2(3),rI(3)
- integer, intent(in)          :: sm_j, i_charge 
- double precision, intent(out):: j_1e,j_2e,j_een,j_tot
- BEGIN_DOC
- ! Jastrow function as in Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the i_charge variable is the integer specifying the charge of the atom for the Jastrow 
- ! the sm_j integer variable represents the "quality" of the jastrow : sm_j = 7, 9, 17
- END_DOC 
- double precision :: r_inucl,r_jnucl,r_ij,b_I, d_I
- b_I = b_I_sm_90(i_charge)
- d_I = d_I_sm_90(i_charge)
- call get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
- call jastrow_func_sm_90(r_inucl,r_jnucl,r_ij,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
-end
-
-subroutine get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
- implicit none
- BEGIN_DOC
- ! rescaled variables of Eq. (5) and (6) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the "b_I" and "d_I" parameters are the same as in Eqs. (5) and (6) 
- END_DOC
- double precision, intent(in) :: r1(3),r2(3),rI(3)
- double precision, intent(in) :: b_I, d_I
- double precision, intent(out):: r_inucl,r_jnucl,r_ij
- double precision :: rin, rjn, rij
- integer :: i
- rin = 0.d0
- rjn = 0.d0
- rij = 0.d0
- do i = 1,3
-  rin += (r1(i) - rI(i)) * (r1(i) - rI(i))
-  rjn += (r2(i) - rI(i)) * (r2(i) - rI(i))
-  rij += (r2(i) - r1(i)) * (r2(i) - r1(i))
- enddo
- rin = dsqrt(rin)
- rjn = dsqrt(rjn)
- rij = dsqrt(rij)
- r_inucl = b_I * rin/(1.d0 + b_I * rin)
- r_jnucl = b_I * rjn/(1.d0 + b_I * rjn)
- r_ij    = d_I * rij/(1.d0 + b_I * rij)
-end
-
-subroutine jastrow_func_sm_90(r_inucl,r_jnucl,r_ij,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- implicit none
- BEGIN_DOC
- ! Jastrow function as in Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! Here the r_inucl, r_jnucl are the rescaled variables as defined in Eq. (5) with "b_I" 
- !          r_ij is the rescaled variable as defined in Eq. (6) with "d_I" 
- ! the i_charge variable is the integer specifying the charge of the atom for the Jastrow 
- ! the sm_j integer variable represents the "quality" of the jastrow : sm_j = 7, 9, 17
- !
- ! it returns the j_1e  : sum of terms with "o" = "n" = 0, "m" /= 0,
- !                j_2e  : sum of terms with "m" = "n" = 0, "o" /= 0,
- !                j_een : sum of terms with "m" /=0, "n" /= 0, "o" /= 0,
- !                j_tot : the total sum 
- END_DOC
- double precision, intent(in) :: r_inucl,r_jnucl,r_ij
- integer, intent(in)          :: sm_j,i_charge
- double precision, intent(out):: j_1e,j_2e,j_een,j_tot
- j_1e  = 0.D0
- j_2e  = 0.D0
- j_een = 0.D0
- double precision :: delta_mn,jastrow_sm_90_atomic
- integer :: m,n,o
-BEGIN_TEMPLATE
- ! pure 2e part 
- n = 0
- m = 0 
- if(sm_j == $X )then
-  do o = 1, o_max_sm_$X
-   if(dabs(c_mn_o_sm_$X(m,n,o,i_charge)).lt.1.d-10)cycle 
-   j_2e += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
-  enddo
-! else 
-!  print*,'sm_j = ',sm_j
-!  print*,'not implemented, stop'
-!  stop
- endif
- ! pure one-e part 
- o = 0 
- if(sm_j == $X)then
-  do n = 2, n_max_sm_$X
-   do m = 2, m_max_sm_$X
-    j_1e += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
-   enddo
-  enddo
-! else 
-!  print*,'sm_j = ',sm_j
-!  print*,'not implemented, stop'
-!  stop
- endif
- ! e-e-n part 
- if(sm_j == $X)then
-  do o = 1, o_max_sm_$X
-   do m = 2, m_max_sm_$X
-    do n = 2, n_max_sm_$X
-     j_een += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
-    enddo
-   enddo
-  enddo
- else 
-!  print*,'sm_j = ',sm_j
-!  print*,'not implemented, stop'
-!  stop
- endif
- j_tot = j_1e + j_2e + j_een
-SUBST [ X]
-  7 ;; 
-  9 ;; 
-  17 ;;
-END_TEMPLATE 
-end
-
-double precision function jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- implicit none
- BEGIN_DOC
-! contribution to the function of Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
-! for a given m,n,o and atom 
- END_DOC
- double precision, intent(in) :: r_inucl,r_jnucl,r_ij
- integer         , intent(in) :: m,n,o,i_charge
- double precision :: delta_mn 
- if(m==n)then
-  delta_mn = 0.5d0
- else
-  delta_mn = 1.D0
- endif
- jastrow_sm_90_atomic = delta_mn * (r_inucl**m * r_jnucl**n + r_jnucl**m * r_inucl**n)*r_ij**o
-end

plugins/local/tc_scf/plot_j_schMos.irp.f

@@ -1,69 +0,0 @@
-program plot_j
- implicit none
- double precision :: r1(3),rI(3),r2(3)
- double precision :: r12,dx,xmax, j_1e,j_2e,j_een,j_tot
- double precision :: j_mu_F_x_j
- integer :: i,nx,m,i_charge,sm_j
-
- character*(128) :: output
- integer :: i_unit_output_He_sm_7,i_unit_output_Ne_sm_7
- integer :: i_unit_output_He_sm_17,i_unit_output_Ne_sm_17
- integer :: getUnitAndOpen
- output='J_SM_7_He'
- i_unit_output_He_sm_7 = getUnitAndOpen(output,'w')
- output='J_SM_7_Ne'
- i_unit_output_Ne_sm_7 = getUnitAndOpen(output,'w')
-
- output='J_SM_17_He'
- i_unit_output_He_sm_17 = getUnitAndOpen(output,'w')
- output='J_SM_17_Ne'
- i_unit_output_Ne_sm_17 = getUnitAndOpen(output,'w')
-
- rI = 0.d0
- r1 = 0.d0
- r2 = 0.d0
- r1(1) = 1.5d0
- xmax = 20.d0
- r2(1) = -xmax*0.5d0
- nx = 1000
- dx = xmax/dble(nx)
- do i = 1, nx
-  r12 = 0.d0
-  do m = 1, 3
-   r12 += (r1(m) - r2(m))*(r1(m) - r2(m))
-  enddo
-  r12 = dsqrt(r12)
-  double precision :: jmu,env_nucl,jmu_env,jmu_scaled, jmu_scaled_env
-  double precision :: b_I,d_I,r_inucl,r_jnucl,r_ij
-  b_I = 1.D0
-  d_I = 1.D0
-  call get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
-  jmu=j_mu_F_x_j(r12)
-  jmu_scaled=j_mu_F_x_j(r_ij)
-  jmu_env = jmu * env_nucl(r1) * env_nucl(r2)
-!  jmu_scaled_env= jmu_scaled * (1.d0 - env_coef(1) * dexp(-env_expo(1)*r_inucl**2)) * (1.d0 - env_coef(1) * dexp(-env_expo(1)*r_jnucl**2))
-  jmu_scaled_env= jmu_scaled * env_nucl(r1) * env_nucl(r2)
-  ! He 
-  i_charge = 2
-  ! SM 7 Jastrow 
-  sm_j = 7
-  call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
-  write(i_unit_output_He_sm_7,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
-  ! SM 17 Jastrow 
-  sm_j = 17
-  call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
-  write(i_unit_output_He_sm_17,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
-  ! Ne 
-  i_charge = 10
-  ! SM 7 Jastrow 
-  sm_j = 7
-  call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
-  write(i_unit_output_Ne_sm_7,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
-  ! SM 17 Jastrow 
-  sm_j = 17
-  call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
-  write(i_unit_output_Ne_sm_17,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
-  r2(1) += dx
- enddo
- 
-end

plugins/local/tc_scf/print_fit_param.irp.f

@@ -1,59 +0,0 @@
-program print_fit_param
-
-  BEGIN_DOC
-! TODO : Put the documentation of the program here
-  END_DOC
-
-  implicit none
-
-  my_grid_becke  = .True.
-  PROVIDE tc_grid1_a tc_grid1_r
-  my_n_pt_r_grid = tc_grid1_r
-  my_n_pt_a_grid = tc_grid1_a
-  touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
-  !call create_guess
-  !call orthonormalize_mos
-
-  call main()
-
-end
-
-! ---
-
-subroutine main()
-
-  implicit none
-  integer :: i
-
-  mu_erf = 1.d0
-  touch mu_erf
-
-  print *, ' fit for (1 - erf(x))^2'
-  do i = 1, n_max_fit_slat
-    print*, expo_gauss_1_erf_x_2(i), coef_gauss_1_erf_x_2(i)
-  enddo
-
-  print *, ''
-  print *, ' fit for [x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)]'
-  do i = 1, n_max_fit_slat
-    print *, expo_gauss_j_mu_x(i), 2.d0 * coef_gauss_j_mu_x(i)
-  enddo
-
-  print *, ''
-  print *, ' fit for [x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)]^2'
-  do i = 1, n_max_fit_slat
-    print *, expo_gauss_j_mu_x_2(i), 4.d0 * coef_gauss_j_mu_x_2(i)
-  enddo
-
-  print *, ''
-  print *, ' fit for [x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)] x [1 - erf(mu * r12)]'
-  do i = 1, n_max_fit_slat
-    print *, expo_gauss_j_mu_1_erf(i), 4.d0 * coef_gauss_j_mu_1_erf(i)
-  enddo
-
-  return
-end subroutine main
-
-! ---
-

plugins/local/tc_scf/print_tcscf_energy.irp.f

@@ -1,55 +0,0 @@
-program print_tcscf_energy
-
-  BEGIN_DOC
-  ! TODO : Put the documentation of the program here
-  END_DOC
-
-  implicit none
-
-  print *, 'Hello world'
-  my_grid_becke = .True.
-  PROVIDE tc_grid1_a tc_grid1_r
-  my_n_pt_r_grid = tc_grid1_r
-  my_n_pt_a_grid = tc_grid1_a
-  touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
-  call main()
-
-end
-
-! ---
-
-subroutine main()
-
-  implicit none
-  double precision :: etc_tot, etc_1e, etc_2e, etc_3e
-
-  PROVIDE j2e_type mu_erf
-  PROVIDE j1e_type j1e_coef j1e_expo
-  PROVIDE env_type env_coef env_expo
-
-  print*, ' j2e_type = ', j2e_type
-  print*, ' j1e_type = ', j1e_type
-  print*, ' env_type = ', env_type
-
-  print*, ' mu_erf   = ', mu_erf
-
-  etc_tot = TC_HF_energy
-  etc_1e  = TC_HF_one_e_energy
-  etc_2e  = TC_HF_two_e_energy
-  etc_3e  = 0.d0
-  if(three_body_h_tc) then
-    !etc_3e = diag_three_elem_hf
-    etc_3e = tcscf_energy_3e_naive
-  endif
-
-  print *, " E_TC = ", etc_tot
-  print *, " E_1e = ", etc_1e
-  print *, " E_2e = ", etc_2e
-  print *, " E_3e = ", etc_3e
-
-  return
-end subroutine main
-
-! ---
-

plugins/local/tc_scf/rh_tcscf_diis.irp.f

@@ -61,7 +61,7 @@ subroutine rh_tcscf_diis()
   etc_tot = TC_HF_energy
   etc_1e  = TC_HF_one_e_energy
   etc_2e  = TC_HF_two_e_energy
-  etc_3e  = diag_three_elem_hf
+  etc_3e  = TC_HF_three_e_energy
   !tc_grad = grad_non_hermit
   er_DIIS = maxval(abs(FQS_SQF_mo))
   e_delta = dabs(etc_tot - e_save)
@@ -189,7 +189,7 @@ subroutine rh_tcscf_diis()
     etc_tot = TC_HF_energy
     etc_1e  = TC_HF_one_e_energy
     etc_2e  = TC_HF_two_e_energy
-    etc_3e  = diag_three_elem_hf
+    etc_3e  = TC_HF_three_e_energy
     !tc_grad  = grad_non_hermit
     er_DIIS  = maxval(abs(FQS_SQF_mo))
     e_delta  = dabs(etc_tot - e_save)
@@ -234,7 +234,7 @@ subroutine rh_tcscf_diis()
     call unlock_io
 
     if(er_delta .lt. 0.d0) then
-      call ezfio_set_tc_scf_bitc_energy(etc_tot)
+      call ezfio_set_tc_scf_tcscf_energy(etc_tot)
       call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
       call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
       write(json_unit, json_true_fmt) 'saved'
@@ -263,7 +263,7 @@ subroutine rh_tcscf_diis()
 
   deallocate(mo_r_coef_save, mo_l_coef_save, F_DIIS, E_DIIS)
 
-  call ezfio_set_tc_scf_bitc_energy(TC_HF_energy)
+  call ezfio_set_tc_scf_tcscf_energy(TC_HF_energy)
   call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
   call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
 

plugins/local/tc_scf/rh_tcscf_simple.irp.f

@@ -1,129 +0,0 @@
-! ---
-
-subroutine rh_tcscf_simple()
-
-  implicit none
-  integer                       :: i, j, it, dim_DIIS
-  double precision              :: t0, t1
-  double precision              :: e_save, e_delta, rho_delta
-  double precision              :: etc_tot, etc_1e, etc_2e, etc_3e, tc_grad
-  double precision              :: er_DIIS
-  double precision, allocatable :: rho_old(:,:), rho_new(:,:)
-
-  allocate(rho_old(ao_num,ao_num), rho_new(ao_num,ao_num))
-
-  it       = 0
-  e_save   = 0.d0
-  dim_DIIS = 0
-
-  ! ---
-
-  if(.not. bi_ortho) then
-   print *, ' grad_hermit = ', grad_hermit
-   call save_good_hermit_tc_eigvectors
-   TOUCH mo_coef 
-   call save_mos
-  endif
-
-  ! ---
-
-  if(bi_ortho) then
-
-    PROVIDE level_shift_tcscf
-    PROVIDE mo_l_coef mo_r_coef
-
-    write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)')              &
-      '====', '================', '================', '================', '================', '================' &
-            , '================', '================', '================', '====', '========'
-
-    write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)')              &
-      ' it ', '  SCF TC Energy ', '      E(1e)     ', '      E(2e)     ', '      E(3e)     ', '   energy diff  ' &
-            , '    gradient    ', '    DIIS error  ', '  level shift   ', 'DIIS', '  WT (m)'
-
-    write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)')              &
-      '====', '================', '================', '================', '================', '================' &
-            , '================', '================', '================', '====', '========'
-
-
-    ! first iteration (HF orbitals)
-    call wall_time(t0)
-
-    etc_tot = TC_HF_energy
-    etc_1e  = TC_HF_one_e_energy
-    etc_2e  = TC_HF_two_e_energy
-    etc_3e  = 0.d0
-    if(three_body_h_tc) then
-      etc_3e = diag_three_elem_hf
-    endif
-    tc_grad = grad_non_hermit
-    er_DIIS = maxval(abs(FQS_SQF_mo))
-    e_delta = dabs(etc_tot - e_save)
-    e_save  = etc_tot
-
-    call wall_time(t1)
-    write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)')  &
-      it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, tc_grad, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
-
-    do while(tc_grad .gt. dsqrt(thresh_tcscf))
-      call wall_time(t0)
-
-      it += 1
-      if(it > n_it_tcscf_max) then
-        print *, ' max of TCSCF iterations is reached ', n_it_TCSCF_max
-        stop
-      endif
-
-      mo_l_coef = fock_tc_leigvec_ao
-      mo_r_coef = fock_tc_reigvec_ao
-      call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
-      call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
-      TOUCH mo_l_coef mo_r_coef
-
-      etc_tot = TC_HF_energy
-      etc_1e  = TC_HF_one_e_energy
-      etc_2e  = TC_HF_two_e_energy
-      etc_3e  = 0.d0
-      if(three_body_h_tc) then
-        etc_3e = diag_three_elem_hf
-      endif
-      tc_grad = grad_non_hermit
-      er_DIIS = maxval(abs(FQS_SQF_mo))
-      e_delta = dabs(etc_tot - e_save)
-      e_save  = etc_tot
-
-      call ezfio_set_tc_scf_bitc_energy(etc_tot)
-
-      call wall_time(t1)
-      write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)')  &
-        it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, tc_grad, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
-    enddo
-
-  else
-
-   do while( (grad_hermit.gt.dsqrt(thresh_tcscf)) .and. (it.lt.n_it_tcscf_max) )
-      print*,'grad_hermit = ',grad_hermit
-      it += 1
-      print *, 'iteration = ', it
-      print *, '***'
-      print *, 'TC HF total energy = ', TC_HF_energy
-      print *, 'TC HF 1 e   energy = ', TC_HF_one_e_energy
-      print *, 'TC HF 2 e   energy = ', TC_HF_two_e_energy
-      print *, 'TC HF 3 body       = ', diag_three_elem_hf
-      print *, '***'
-      print *, ''
-      call save_good_hermit_tc_eigvectors
-      TOUCH mo_coef 
-      call save_mos
-    enddo
-
-  endif
-
-  print *, ' TCSCF Simple converged !'
-  !call print_energy_and_mos(good_angles)
-
-  deallocate(rho_old, rho_new)
-
-end
-
-! ---
-

plugins/local/tc_scf/rh_vartcscf_simple.irp.f

@@ -1,89 +0,0 @@
-! ---
-
-subroutine rh_vartcscf_simple()
-
-  implicit none
-  integer          :: i, j, it, dim_DIIS
-  double precision :: t0, t1
-  double precision :: e_save, e_delta, rho_delta
-  double precision :: etc_tot, etc_1e, etc_2e, etc_3e
-  double precision :: er_DIIS
-
-
-  it       = 0
-  e_save   = 0.d0
-  dim_DIIS = 0
-
-  ! ---
-
-  PROVIDE level_shift_tcscf
-  PROVIDE mo_r_coef
-
-  write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)')                      &
-    '====', '================', '================', '================', '================', '================' &
-          , '================', '================', '====', '========'
-  write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)')                      &
-    ' it ', '  SCF TC Energy ', '      E(1e)     ', '      E(2e)     ', '      E(3e)     ', '   energy diff  ' &
-          , '    DIIS error  ', '  level shift   ', 'DIIS', '  WT (m)'
-  write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)')                      &
-    '====', '================', '================', '================', '================', '================' &
-          , '================', '================', '====', '========'
-
-
-  ! first iteration (HF orbitals)
-  call wall_time(t0)
-
-  etc_tot = VARTC_HF_energy
-  etc_1e  = VARTC_HF_one_e_energy
-  etc_2e  = VARTC_HF_two_e_energy
-  etc_3e  = 0.d0
-  if(three_body_h_tc) then
-    etc_3e = diag_three_elem_hf
-  endif
-  er_DIIS = maxval(abs(FQS_SQF_mo))
-  e_delta = dabs(etc_tot - e_save)
-  e_save  = etc_tot
-
-  call wall_time(t1)
-  write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)')  &
-    it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
-
-  do while(er_DIIS .gt. dsqrt(thresh_tcscf))
-    call wall_time(t0)
-
-    it += 1
-    if(it > n_it_tcscf_max) then
-      print *, ' max of TCSCF iterations is reached ', n_it_TCSCF_max
-      stop
-    endif
-
-    mo_r_coef = fock_vartc_eigvec_ao
-    mo_l_coef = mo_r_coef
-    call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
-    call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
-    TOUCH mo_l_coef mo_r_coef
-
-    etc_tot = VARTC_HF_energy
-    etc_1e  = VARTC_HF_one_e_energy
-    etc_2e  = VARTC_HF_two_e_energy
-    etc_3e  = 0.d0
-    if(three_body_h_tc) then
-      etc_3e = diag_three_elem_hf
-    endif
-    er_DIIS = maxval(abs(FQS_SQF_mo))
-    e_delta = dabs(etc_tot - e_save)
-    e_save  = etc_tot
-
-    call ezfio_set_tc_scf_bitc_energy(etc_tot)
-
-    call wall_time(t1)
-    write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)')  &
-      it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
-  enddo
-
-  print *, ' VAR-TCSCF Simple converged !'
-
-end
-
-! ---
-

plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f

@@ -1,369 +0,0 @@
-
-! ---
-
-program rotate_tcscf_orbitals
-
-  BEGIN_DOC
-  ! TODO : Rotate the bi-orthonormal orbitals in order to minimize left-right angles when degenerate
-  END_DOC
-
-  implicit none
-
-  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
-
-  bi_ortho = .True.
-  touch bi_ortho
-
-  call minimize_tc_orb_angles()
-  !call maximize_overlap()
-
-end
-
-! ---
-
-subroutine maximize_overlap()
-
-  implicit none
-  integer                       :: i, m, n
-  double precision              :: accu_d, accu_nd
-  double precision, allocatable :: C(:,:), R(:,:), L(:,:), W(:,:), e(:)
-  double precision, allocatable :: S(:,:)
-
-  n = ao_num
-  m = mo_num
-
-  allocate(L(n,m), R(n,m), C(n,m), W(n,n), e(m))
-  L = mo_l_coef
-  R = mo_r_coef
-  C = mo_coef
-  W = ao_overlap
-
-  print*, ' fock matrix diag elements'
-  do i = 1, m
-    e(i) = Fock_matrix_tc_mo_tot(i,i)
-    print*, e(i)
-  enddo
-
-  ! ---
-   
-  print *, ' overlap before :'
-  print *, ' '
-
-  allocate(S(m,m)) 
-
-  call LTxSxR(n, m, L, W, R, S)
-  !print*, " L.T x R"
-  !do i = 1, m
-  !  write(*, '(100(F16.10,X))') S(i,i)
-  !enddo
-  call LTxSxR(n, m, L, W, C, S)
-  print*, " L.T x C"
-  do i = 1, m
-    write(*, '(100(F16.10,X))') S(i,:)
-  enddo
-  call LTxSxR(n, m, C, W, R, S)
-  print*, " C.T x R"
-  do i = 1, m
-    write(*, '(100(F16.10,X))') S(i,:)
-  enddo
-
-  deallocate(S)
-
-  ! ---
-
-  call rotate_degen_eigvec_to_maximize_overlap(n, m, e, C, W, L, R)
-
-  ! ---
-   
-  print *, ' overlap after :'
-  print *, ' '
-
-  allocate(S(m,m)) 
-
-  call LTxSxR(n, m, L, W, R, S)
-  !print*, " L.T x R"
-  !do i = 1, m
-  !  write(*, '(100(F16.10,X))') S(i,i)
-  !enddo
-  call LTxSxR(n, m, L, W, C, S)
-  print*, " L.T x C"
-  do i = 1, m
-    write(*, '(100(F16.10,X))') S(i,:)
-  enddo
-  call LTxSxR(n, m, C, W, R, S)
-  print*, " C.T x R"
-  do i = 1, m
-    write(*, '(100(F16.10,X))') S(i,:)
-  enddo
-
-  deallocate(S)
-
-  ! ---
-
-  mo_l_coef = L
-  mo_r_coef = R
-  call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
-  call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
-
-  ! ---
-
-  deallocate(L, R, C, W, e)
-
-end subroutine maximize_overlap
-
-! ---
-
-subroutine rotate_degen_eigvec_to_maximize_overlap(n, m, e0, C0, W0, L0, R0)
-
-  implicit none
-
-  integer,          intent(in)    :: n, m
-  double precision, intent(in)    :: e0(m), W0(n,n), C0(n,m)
-  double precision, intent(inout) :: L0(n,m), R0(n,m)
-
-
-  integer                         :: i, j, k, kk, mm, id1, tot_deg
-  double precision                :: ei, ej, de, de_thr
-  integer,          allocatable   :: deg_num(:)
-  double precision, allocatable   :: L(:,:), R(:,:), C(:,:), Lnew(:,:), Rnew(:,:), tmp(:,:)
-  !double precision, allocatable   :: S(:,:), Snew(:,:), T(:,:), Ttmp(:,:), Stmp(:,:)
-  double precision, allocatable   :: S(:,:), Snew(:,:), T(:,:), Ttmp(:,:), Stmp(:,:)
-  !real*8                          :: S(m,m), Snew(m,m), T(m,m)
-
-  id1 = 700
-  allocate(S(id1,id1), Snew(id1,id1), T(id1,id1))
-
-  ! ---
-
-  allocate( deg_num(m) )
-  do i = 1, m
-    deg_num(i) = 1
-  enddo
-
-  de_thr = thr_degen_tc
-
-  do i = 1, m-1
-    ei = e0(i)
-
-    ! already considered in degen vectors
-    if(deg_num(i).eq.0) cycle
-
-    do j = i+1, m
-      ej = e0(j)
-      de = dabs(ei - ej)
-
-      if(de .lt. de_thr) then
-        deg_num(i) = deg_num(i) + 1
-        deg_num(j) = 0
-      endif
-
-    enddo
-  enddo
-
-  tot_deg = 0
-  do i = 1, m
-    if(deg_num(i).gt.1) then
-      print *, ' degen on', i, deg_num(i)
-      tot_deg = tot_deg + 1
-    endif
-  enddo
-
-  if(tot_deg .eq. 0) then
-    print *, ' no degen'
-    return
-  endif
-
-  ! ---
-
-  do i = 1, m
-    mm = deg_num(i)
-
-    if(mm .gt. 1) then
-
-      allocate(L(n,mm), R(n,mm), C(n,mm))
-      do j = 1, mm
-        L(1:n,j) = L0(1:n,i+j-1)
-        R(1:n,j) = R0(1:n,i+j-1)
-        C(1:n,j) = C0(1:n,i+j-1)
-      enddo
-
-      ! ---
-
-      ! C.T x W0 x R
-      allocate(tmp(mm,n), Stmp(mm,mm))
-      call dgemm( 'T', 'N', mm, n, n, 1.d0       &
-                , C, size(C, 1), W0, size(W0, 1) &
-                , 0.d0, tmp, size(tmp, 1) )
-      call dgemm( 'N', 'N', mm, mm, n, 1.d0        &
-                , tmp, size(tmp, 1), R, size(R, 1) &
-                , 0.d0, Stmp, size(Stmp, 1) )
-      deallocate(C, tmp)
-
-      S = 0.d0
-      do k = 1, mm
-        do kk = 1, mm
-          S(kk,k) = Stmp(kk,k)
-        enddo
-      enddo
-      deallocate(Stmp)
-
-      !print*, " overlap bef"
-      !do k = 1, mm
-      !  write(*, '(100(F16.10,X))') (S(k,kk), kk=1, mm)
-      !enddo
-    
-      T    = 0.d0
-      Snew = 0.d0
-      call maxovl(mm, mm, S, T, Snew)
-
-      !print*, " overlap aft"
-      !do k = 1, mm
-      !  write(*, '(100(F16.10,X))') (Snew(k,kk), kk=1, mm)
-      !enddo
-
-      allocate(Ttmp(mm,mm))
-      Ttmp(1:mm,1:mm) = T(1:mm,1:mm)
-
-      allocate(Lnew(n,mm), Rnew(n,mm))
-      call dgemm( 'N', 'N', n, mm, mm, 1.d0               &
-                , R, size(R, 1), Ttmp(1,1), size(Ttmp, 1) &
-                , 0.d0, Rnew, size(Rnew, 1) )
-      call dgemm( 'N', 'N', n, mm, mm, 1.d0               &
-                , L, size(L, 1), Ttmp(1,1), size(Ttmp, 1) &
-                , 0.d0, Lnew, size(Lnew, 1) )
-
-      deallocate(L, R)
-      deallocate(Ttmp)
-
-      ! ---
-
-      do j = 1, mm
-        L0(1:n,i+j-1) = Lnew(1:n,j)
-        R0(1:n,i+j-1) = Rnew(1:n,j)
-      enddo
-      deallocate(Lnew, Rnew)
-
-    endif
-  enddo
-
-  deallocate(S, Snew, T)
-
-end subroutine rotate_degen_eigvec_to_maximize_overlap
-
-! ---
-
-subroutine fix_right_to_one()
-
-  implicit none
-  integer                       :: i, j, m, n, mm, tot_deg
-  double precision              :: accu_d, accu_nd
-  double precision              :: de_thr, ei, ej, de
-  integer,          allocatable :: deg_num(:)
-  double precision, allocatable :: R0(:,:), L0(:,:), W(:,:), e0(:)
-  double precision, allocatable :: R(:,:), L(:,:), S(:,:), Stmp(:,:), tmp(:,:)
-
-  n = ao_num
-  m = mo_num
-
-  allocate(L0(n,m), R0(n,m), W(n,n), e0(m))
-  L0 = mo_l_coef
-  R0 = mo_r_coef
-  W  = ao_overlap
-
-  print*, ' fock matrix diag elements'
-  do i = 1, m
-    e0(i) = Fock_matrix_tc_mo_tot(i,i)
-    print*, e0(i)
-  enddo
-
-  ! ---
-
-  allocate( deg_num(m) )
-  do i = 1, m
-    deg_num(i) = 1
-  enddo
-
-  de_thr = 1d-6
-
-  do i = 1, m-1
-    ei = e0(i)
-
-    ! already considered in degen vectors
-    if(deg_num(i).eq.0) cycle
-
-    do j = i+1, m
-      ej = e0(j)
-      de = dabs(ei - ej)
-
-      if(de .lt. de_thr) then
-        deg_num(i) = deg_num(i) + 1
-        deg_num(j) = 0
-      endif
-
-    enddo
-  enddo
-
-  deallocate(e0)
-
-  tot_deg = 0
-  do i = 1, m
-    if(deg_num(i).gt.1) then
-      print *, ' degen on', i, deg_num(i)
-      tot_deg = tot_deg + 1
-    endif
-  enddo
-
-  if(tot_deg .eq. 0) then
-    print *, ' no degen'
-    return
-  endif
-
-  ! ---
-
-  do i = 1, m
-    mm = deg_num(i)
-
-    if(mm .gt. 1) then
-
-      allocate(L(n,mm), R(n,mm))
-      do j = 1, mm
-        L(1:n,j) = L0(1:n,i+j-1)
-        R(1:n,j) = R0(1:n,i+j-1)
-      enddo
-
-      ! ---
-
-      call impose_weighted_orthog_svd(n, mm, W, R)
-      call impose_weighted_biorthog_qr(n, mm, thresh_biorthog_diag, thresh_biorthog_nondiag, R, W, L)
-
-      ! ---
-
-      do j = 1, mm
-        L0(1:n,i+j-1) = L(1:n,j)
-        R0(1:n,i+j-1) = R(1:n,j)
-      enddo
-      deallocate(L, R)
-
-    endif
-  enddo
-
-  call check_weighted_biorthog_binormalize(n, m, L0, W, R0, thresh_biorthog_diag, thresh_biorthog_nondiag, .true.)
-
-  deallocate(W, deg_num)
-
-  mo_l_coef = L0
-  mo_r_coef = R0
-  deallocate(L0, R0)
-
-  call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
-  call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
-  print *, ' orbitals are rotated '
-
-  return
-end subroutine fix_right_to_one
-
-! ---

plugins/local/tc_scf/tc_petermann_factor.irp.f

@@ -1,91 +0,0 @@
-
-! ---
-
-program tc_petermann_factor
-
-  BEGIN_DOC
-  ! TODO : Put the documentation of the program here
-  END_DOC
-
-  implicit none
-
-  my_grid_becke  = .True.
-  PROVIDE tc_grid1_a tc_grid1_r
-  my_n_pt_r_grid = tc_grid1_r
-  my_n_pt_a_grid = tc_grid1_a
-  touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
-  call main()
-
-end
-
-! ---
-
-subroutine main()
-
-  implicit none
-  integer                       :: i, j
-  double precision              :: Pf_diag_av
-  double precision, allocatable :: Sl(:,:), Sr(:,:), Pf(:,:)
-
-  allocate(Sl(mo_num,mo_num), Sr(mo_num,mo_num), Pf(mo_num,mo_num))
-
-
-  call LTxSxR(ao_num, mo_num, mo_l_coef, ao_overlap, mo_r_coef, Sl)
-  !call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0                       &
-  !          , mo_l_coef, size(mo_l_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
-  !          , 0.d0, Sl, size(Sl, 1) )
-
-  print *, ''
-  print *, ' left-right orthog matrix:'
-  do i = 1, mo_num
-    write(*,'(100(F8.4,X))') Sl(:,i)
-  enddo
-
-  call LTxSxR(ao_num, mo_num, mo_l_coef, ao_overlap, mo_l_coef, Sl)
-  !call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0                       &
-  !          , mo_l_coef, size(mo_l_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
-  !          , 0.d0, Sl, size(Sl, 1) )
-
-  print *, ''
-  print *, ' left-orthog matrix:'
-  do i = 1, mo_num
-    write(*,'(100(F8.4,X))') Sl(:,i)
-  enddo
-
-  call LTxSxR(ao_num, mo_num, mo_r_coef, ao_overlap, mo_r_coef, Sr)
-!  call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0                       &
-!            , mo_r_coef, size(mo_r_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
-!            , 0.d0, Sr, size(Sr, 1) )
-
-  print *, ''
-  print *, ' right-orthog matrix:'
-  do i = 1, mo_num
-    write(*,'(100(F8.4,X))') Sr(:,i)
-  enddo
-
-  print *, ''
-  print *, ' Petermann matrix:'
-  do i = 1, mo_num
-    do j = 1, mo_num
-      Pf(j,i) = Sl(j,i) * Sr(j,i)
-    enddo
-    write(*,'(100(F8.4,X))') Pf(:,i)
-  enddo
-
-  Pf_diag_av = 0.d0
-  do i = 1, mo_num
-    Pf_diag_av = Pf_diag_av + Pf(i,i)
-  enddo
-  Pf_diag_av = Pf_diag_av / dble(mo_num)
-
-  print *, ''
-  print *, ' mean of the diagonal Petermann factor = ', Pf_diag_av
-
-  deallocate(Sl, Sr, Pf)
-
-  return
-end subroutine
-
-! ---
-

plugins/local/tc_scf/tc_scf.irp.f

@@ -7,19 +7,6 @@ program tc_scf
   END_DOC
 
   implicit none
-  integer :: i
-  logical :: good_angles
-
-  PROVIDE j1e_type
-  PROVIDE j2e_type
-  PROVIDE tcscf_algorithm
-  PROVIDE var_tc
-
-  print *, ' TC-SCF with:'
-  print *, ' j1e_type = ', j1e_type
-  print *, ' j2e_type = ', j2e_type
-
-  write(json_unit,json_array_open_fmt) 'tc-scf'
 
   my_grid_becke  = .True.
   PROVIDE tc_grid1_a tc_grid1_r
@@ -30,7 +17,6 @@ program tc_scf
   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')
 
-
   if(tc_integ_type .eq. "numeric") then
     my_extra_grid_becke  = .True.
     PROVIDE tc_grid2_a tc_grid2_r
@@ -42,33 +28,27 @@ program tc_scf
     call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
   endif
 
-  !call create_guess()
+  call main()
-  !call orthonormalize_mos()
 
+end
 
-  if(var_tc) then
+! ---
 
-    print *, ' VAR-TC'
+subroutine main()
 
-    if(tcscf_algorithm == 'DIIS') then
+  implicit none
-      print*, ' NOT implemented yet'
-    elseif(tcscf_algorithm == 'Simple') then
-      call rh_vartcscf_simple()
-    else
-      print *, ' not implemented yet', tcscf_algorithm
-      stop
-    endif
 
-  else
+  integer :: i
+  logical :: good_angles
+
+  print *, ' TC-SCF with:'
+  print *, ' j2e_type = ', j2e_type
+  print *, ' j1e_type = ', j1e_type
+  print *, ' env_type = ', env_type
+
+  write(json_unit,json_array_open_fmt) 'tc-scf'
 
-    if(tcscf_algorithm == 'DIIS') then
   call rh_tcscf_diis()
-    elseif(tcscf_algorithm == 'Simple') then
-      call rh_tcscf_simple()
-    else
-      print *, ' not implemented yet', tcscf_algorithm
-      stop
-    endif
 
   PROVIDE Fock_matrix_tc_diag_mo_tot
   print*, ' Eigenvalues:' 
@@ -76,15 +56,11 @@ program tc_scf
     print*, i, Fock_matrix_tc_diag_mo_tot(i)
   enddo
 
-    ! TODO 
-    ! rotate angles in separate code only if necessary
   if(minimize_lr_angles) then
    call minimize_tc_orb_angles()
   endif
   call print_energy_and_mos(good_angles)
 
-  endif
-
   write(json_unit,json_array_close_fmtx)
   call json_close
 
@@ -119,7 +95,7 @@ subroutine create_guess()
     SOFT_TOUCH mo_label
   endif
 
-end subroutine create_guess
+end
 
 ! ---
 

plugins/local/tc_scf/tc_scf_dm.irp.f

@@ -10,17 +10,9 @@ BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num)
 
   implicit none
 
-  if(bi_ortho) then
-
   PROVIDE mo_l_coef mo_r_coef
   TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta
 
-  else
-
-    TCSCF_density_matrix_ao_beta = SCF_density_matrix_ao_beta
-
-  endif
-
 END_PROVIDER 
 
 ! ---
@@ -35,17 +27,9 @@ BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num
 
   implicit none
 
-  if(bi_ortho) then
-
   PROVIDE mo_l_coef mo_r_coef
   TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha
 
-  else
-
-    TCSCF_density_matrix_ao_alpha = SCF_density_matrix_ao_alpha
-
-  endif
-
 END_PROVIDER 
 
 

plugins/local/tc_scf/tc_scf_energy.irp.f

@@ -2,6 +2,7 @@
  BEGIN_PROVIDER [double precision, TC_HF_energy        ]
 &BEGIN_PROVIDER [double precision, TC_HF_one_e_energy  ]
 &BEGIN_PROVIDER [double precision, TC_HF_two_e_energy  ]
+&BEGIN_PROVIDER [double precision, TC_HF_three_e_energy]
 
   BEGIN_DOC
   ! TC Hartree-Fock energy containing the nuclear repulsion, and its one- and two-body components.
@@ -11,11 +12,8 @@
   integer          :: i, j
   double precision :: t0, t1
 
-  !print*, ' Providing TC energy ...'
-  !call wall_time(t0)
-
   PROVIDE mo_l_coef mo_r_coef
-  PROVIDE two_e_tc_non_hermit_integral_alpha two_e_tc_non_hermit_integral_beta
+  PROVIDE two_e_tc_integral_alpha two_e_tc_integral_beta
 
   TC_HF_energy = nuclear_repulsion
   TC_HF_one_e_energy = 0.d0
@@ -23,47 +21,20 @@
 
   do j = 1, ao_num
     do i = 1, ao_num
-      TC_HF_two_e_energy += 0.5d0 * ( two_e_tc_non_hermit_integral_alpha(i,j) * TCSCF_density_matrix_ao_alpha(i,j) &
+      TC_HF_two_e_energy += 0.5d0 * ( two_e_tc_integral_alpha(i,j) * TCSCF_density_matrix_ao_alpha(i,j) &
-                                    + two_e_tc_non_hermit_integral_beta (i,j) * TCSCF_density_matrix_ao_beta (i,j) )
+                                    + two_e_tc_integral_beta (i,j) * TCSCF_density_matrix_ao_beta (i,j) )
       TC_HF_one_e_energy += ao_one_e_integrals_tc_tot(i,j) &
                           * (TCSCF_density_matrix_ao_alpha(i,j) + TCSCF_density_matrix_ao_beta (i,j) )
     enddo
   enddo
 
-  TC_HF_energy += TC_HF_one_e_energy + TC_HF_two_e_energy
+  if((three_body_h_tc .eq. .False.) .and. (.not. noL_standard)) then
-  TC_HF_energy += diag_three_elem_hf
+    TC_HF_three_e_energy = 0.d0
+  else
+    TC_HF_three_e_energy = noL_0e
+  endif
 
-  !call wall_time(t1)
+  TC_HF_energy += TC_HF_one_e_energy + TC_HF_two_e_energy + TC_HF_three_e_energy
-  !print*, ' Wall time for TC energy=', t1-t0
-
-END_PROVIDER
-
-! ---
-
- BEGIN_PROVIDER [ double precision, VARTC_HF_energy]
-&BEGIN_PROVIDER [ double precision, VARTC_HF_one_e_energy]
-&BEGIN_PROVIDER [ double precision, VARTC_HF_two_e_energy]
-
-  implicit none
-  integer :: i, j
-
-  PROVIDE mo_r_coef
-
-  VARTC_HF_energy = nuclear_repulsion
-  VARTC_HF_one_e_energy = 0.d0
-  VARTC_HF_two_e_energy = 0.d0
-
-  do j = 1, ao_num
-    do i = 1, ao_num
-      VARTC_HF_two_e_energy += 0.5d0 * ( two_e_vartc_integral_alpha(i,j) * TCSCF_density_matrix_ao_alpha(i,j) &
-                                       + two_e_vartc_integral_beta (i,j) * TCSCF_density_matrix_ao_beta (i,j) )
-      VARTC_HF_one_e_energy += ao_one_e_integrals_tc_tot(i,j) &
-                             * (TCSCF_density_matrix_ao_alpha(i,j) + TCSCF_density_matrix_ao_beta (i,j) )
-    enddo
-  enddo
-
-  VARTC_HF_energy += VARTC_HF_one_e_energy + VARTC_HF_two_e_energy
-  VARTC_HF_energy += diag_three_elem_hf
 
 END_PROVIDER
 

plugins/local/tc_scf/tcscf_energy_naive.irp.f

@@ -1,80 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [double precision, tcscf_energy_3e_naive]
-
-  implicit none
-  integer          :: i, j, k
-  integer          :: neu, ned, D(elec_num)
-  integer          :: ii, jj, kk
-  integer          :: si, sj, sk
-  double precision :: I_ijk, I_jki, I_kij, I_jik, I_ikj, I_kji
-  double precision :: I_tot
-
-  PROVIDE mo_l_coef mo_r_coef
-
-  neu = elec_alpha_num
-  ned = elec_beta_num
-  if (neu > 0) D(1:neu) = [(2*i-1, i = 1, neu)]
-  if (ned > 0) D(neu+1:neu+ned) = [(2*i, i = 1, ned)]
-
-  !print*, "D = "
-  !do i = 1, elec_num
-  !  ii = (D(i) - 1) / 2 + 1
-  !  si = mod(D(i), 2)
-  !  print*, i, D(i), ii, si
-  !enddo
-
-  tcscf_energy_3e_naive = 0.d0
-
-  do i = 1, elec_num - 2
-    ii = (D(i) - 1) / 2 + 1
-    si = mod(D(i), 2)
-
-    do j = i + 1, elec_num - 1
-      jj = (D(j) - 1) / 2 + 1
-      sj = mod(D(j), 2)
-
-      do k = j + 1, elec_num
-        kk = (D(k) - 1) / 2 + 1
-        sk = mod(D(k), 2)
-
-        call give_integrals_3_body_bi_ort(ii, jj, kk, ii, jj, kk, I_ijk)
-        I_tot = I_ijk
-
-        if(sj==si .and. sk==sj) then
-          call give_integrals_3_body_bi_ort(ii, jj, kk, jj, kk, ii, I_jki)
-          I_tot += I_jki
-        endif
-
-        if(sk==si .and. si==sj) then
-          call give_integrals_3_body_bi_ort(ii, jj, kk, kk, ii, jj, I_kij)
-          I_tot += I_kij
-        endif
-
-        if(sj==si) then
-          call give_integrals_3_body_bi_ort(ii, jj, kk, jj, ii, kk, I_jik)
-          I_tot -= I_jik
-        endif
-
-        if(sk==sj) then
-          call give_integrals_3_body_bi_ort(ii, jj, kk, ii, kk, jj, I_ikj)
-          I_tot -= I_ikj
-        endif
-
-        if(sk==si) then
-          call give_integrals_3_body_bi_ort(ii, jj, kk, kk, jj, ii, I_kji)
-          I_tot -= I_kji
-        endif
-
-        tcscf_energy_3e_naive += I_tot
-      enddo
-    enddo
-  enddo
-
-  tcscf_energy_3e_naive = -tcscf_energy_3e_naive
-
-END_PROVIDER
-
-! ---
-

plugins/local/tc_scf/test_int.irp.f

@@ -1,970 +0,0 @@
-program test_ints
-
-  BEGIN_DOC
-  ! TODO : Put the documentation of the program here
-  END_DOC
-
-  implicit none
-
-  print *, ' starting test_ints ...'
-
-  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.
-  my_n_pt_r_extra_grid = 30
-  my_n_pt_a_extra_grid = 50 ! small extra_grid for quick debug
-  touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
-
-!! OK 
-! call routine_int2_u_grad1u_env2 
-! OK
-! call routine_v_ij_erf_rk_cst_mu_env
-! OK 
-! call routine_x_v_ij_erf_rk_cst_mu_env
-! OK
-! call routine_int2_u2_env2
-! OK
-! call routine_int2_u_grad1u_x_env2
-! OK 
-! call routine_int2_grad1u2_grad2u2_env2
-! call routine_int2_u_grad1u_env2
-! call test_int2_grad1_u12_ao_test
-! call routine_v_ij_u_cst_mu_env_test
-! call test_grid_points_ao
- !call test_int_gauss
-
-  !call test_fock_3e_uhf_ao()
-  !call test_fock_3e_uhf_mo()
-
-  !call test_two_e_tc_non_hermit_integral()
-
-!!PROVIDE TC_HF_energy VARTC_HF_energy
-!!print *, '    TC_HF_energy = ',    TC_HF_energy
-!!print *, ' VARTC_HF_energy = ', VARTC_HF_energy
-
-  call test_fock_3e_uhf_mo_cs()
-  call test_fock_3e_uhf_mo_a()
-  call test_fock_3e_uhf_mo_b()
-
-end
-
-! ---
-
-subroutine routine_test_env
- implicit none
- integer :: i,icount,j
- icount = 0
- do i = 1, List_env1s_square_size
-  if(dabs(List_env1s_square_coef(i)).gt.1.d-10)then
-   print*,''
-   print*,List_env1s_square_expo(i),List_env1s_square_coef(i)
-   print*,List_env1s_square_cent(1:3,i)
-   print*,''
-   icount += 1
-  endif
-  
- enddo
- print*,'List_env1s_square_coef,icount = ',List_env1s_square_size,icount
- do i = 1, ao_num
-  do j = 1, ao_num
-   do icount = 1, List_comb_thr_b3_size(j,i)
-    print*,'',j,i
-    print*,List_comb_thr_b3_expo(icount,j,i),List_comb_thr_b3_coef(icount,j,i)
-    print*,List_comb_thr_b3_cent(1:3,icount,j,i)
-    print*,''
-   enddo
-!   enddo
-  enddo
- enddo
- print*,'max_List_comb_thr_b3_size = ',max_List_comb_thr_b3_size,List_env1s_square_size
-
-end
-
-subroutine routine_int2_u_grad1u_env2
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
-  weight = final_weight_at_r_vector(ipoint)
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      array(j,i,l,k)     += int2_u_grad1u_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-      array_ref(j,i,l,k) += int2_u_grad1u_env2(j,i,ipoint)      * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-     enddo
-    enddo
-   enddo
-  enddo
- enddo
- accu_relat = 0.d0
- accu_abs   = 0.d0
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
-      accu_abs += contrib
-      if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
-       accu_relat += contrib/dabs(array_ref(j,i,l,k))
-      endif
-     enddo
-    enddo
-   enddo
-  enddo
- print*,'******'
- print*,'******'
- print*,'routine_int2_u_grad1u_env2'
- print*,'accu_abs   = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-  
-
-end
-
-subroutine routine_v_ij_erf_rk_cst_mu_env
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
-  weight = final_weight_at_r_vector(ipoint)
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      array(j,i,l,k)     += v_ij_erf_rk_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-      array_ref(j,i,l,k) += v_ij_erf_rk_cst_mu_env(j,i,ipoint)      * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-     enddo
-    enddo
-   enddo
-  enddo
- enddo
- accu_relat = 0.d0
- accu_abs   = 0.d0
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
-      accu_abs += contrib
-      if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
-       accu_relat += contrib/dabs(array_ref(j,i,l,k))
-      endif
-     enddo
-    enddo
-   enddo
-  enddo
- print*,'******'
- print*,'******'
- print*,'routine_v_ij_erf_rk_cst_mu_env'
- print*,'accu_abs   = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-  
-
-end
-
-
-subroutine routine_x_v_ij_erf_rk_cst_mu_env
- implicit none
- integer :: i,j,ipoint,k,l,m
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
-  weight = final_weight_at_r_vector(ipoint)
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      do m = 1, 3
-       array(j,i,l,k)     += x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
-       array_ref(j,i,l,k) += x_v_ij_erf_rk_cst_mu_env     (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
-      enddo
-     enddo
-    enddo
-   enddo
-  enddo
- enddo
- accu_relat = 0.d0
- accu_abs   = 0.d0
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
-      accu_abs += contrib
-      if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
-       accu_relat += contrib/dabs(array_ref(j,i,l,k))
-      endif
-     enddo
-    enddo
-   enddo
-  enddo
-
- print*,'******'
- print*,'******'
- print*,'routine_x_v_ij_erf_rk_cst_mu_env'
- print*,'accu_abs   = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-  
-
-end
-
-
-
-subroutine routine_v_ij_u_cst_mu_env_test
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
-  weight = final_weight_at_r_vector(ipoint)
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      array(j,i,l,k)     += v_ij_u_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-      array_ref(j,i,l,k) += v_ij_u_cst_mu_env_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-     enddo
-    enddo
-   enddo
-  enddo
- enddo
- accu_relat = 0.d0
- accu_abs   = 0.d0
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
-      accu_abs += contrib
-      if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
-       accu_relat += contrib/dabs(array_ref(j,i,l,k))
-      endif
-     enddo
-    enddo
-   enddo
-  enddo
- print*,'******'
- print*,'******'
- print*,'routine_v_ij_u_cst_mu_env_test'
- print*,'accu_abs   = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-end
-
-subroutine routine_int2_grad1u2_grad2u2_env2
- implicit none
- integer :: i,j,ipoint,k,l
- integer :: ii , jj
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- double precision, allocatable :: ints(:,:,:)
- allocate(ints(ao_num, ao_num, n_points_final_grid))
-! do ipoint = 1, n_points_final_grid
-!  do i = 1, ao_num
-!   do j = 1, ao_num
-!    read(33,*)ints(j,i,ipoint)
-!   enddo
-!  enddo
-! enddo
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
-  weight = final_weight_at_r_vector(ipoint)
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      array(j,i,l,k)     += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-!     !array(j,i,l,k)     += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-!      array_ref(j,i,l,k)     += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-!     !array(j,i,l,k) += ints(j,i,ipoint)      * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-!       array_ref(j,i,l,k) += int2_grad1u2_grad2u2_env2(j,i,ipoint)      * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-      array_ref(j,i,l,k) += ints(j,i,ipoint)      * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-!      if(dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint)).gt.1.d-6)then
-!       if(dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint) - int2_grad1u2_grad2u2_env2_test(j,i,ipoint)).gt.1.d-6)then
-!        print*,j,i,ipoint
-!        print*,int2_grad1u2_grad2u2_env2_test(j,i,ipoint) , int2_grad1u2_grad2u2_env2_test(j,i,ipoint), dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint) - int2_grad1u2_grad2u2_env2_test(j,i,ipoint))
-!        print*,int2_grad1u2_grad2u2_env2_test(i,j,ipoint) , int2_grad1u2_grad2u2_env2_test(i,j,ipoint), dabs(int2_grad1u2_grad2u2_env2_test(i,j,ipoint) - int2_grad1u2_grad2u2_env2_test(i,j,ipoint))
-!        stop
-!       endif
-!      endif
-     enddo
-    enddo
-   enddo
-  enddo
- enddo
- double precision :: e_ref, e_new
- accu_relat = 0.d0
- accu_abs   = 0.d0
- e_ref = 0.d0
- e_new = 0.d0
- do ii = 1, elec_alpha_num
-  do jj = ii, elec_alpha_num
-   do k = 1, ao_num
-    do l = 1, ao_num
-     do i = 1, ao_num
-      do j = 1, ao_num
-       e_ref += mo_coef(j,ii) * mo_coef(i,ii) * array_ref(j,i,l,k) * mo_coef(l,jj) * mo_coef(k,jj)
-       e_new += mo_coef(j,ii) * mo_coef(i,ii) * array(j,i,l,k) * mo_coef(l,jj) * mo_coef(k,jj)
-       contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
-       accu_abs += contrib
-!       if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
-!        accu_relat += contrib/dabs(array_ref(j,i,l,k))
-!       endif
-      enddo
-     enddo
-    enddo
-   enddo
-
-  enddo
- enddo
- print*,'e_ref = ',e_ref
- print*,'e_new = ',e_new
-! print*,'accu_abs   = ',accu_abs/dble(ao_num)**4
-! print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-  
-
-end
-
-subroutine routine_int2_u2_env2
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
-  weight = final_weight_at_r_vector(ipoint)
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      array(j,i,l,k)     += int2_u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-      array_ref(j,i,l,k) += int2_u2_env2(j,i,ipoint)      * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-     enddo
-    enddo
-   enddo
-  enddo
- enddo
- accu_relat = 0.d0
- accu_abs   = 0.d0
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
-      accu_abs += contrib
-      if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
-       accu_relat += contrib/dabs(array_ref(j,i,l,k))
-      endif
-     enddo
-    enddo
-   enddo
-  enddo
- print*,'******'
- print*,'******'
- print*,'routine_int2_u2_env2'
- print*,'accu_abs   = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-  
-
-end
-
-
-subroutine routine_int2_u_grad1u_x_env2
- implicit none
- integer :: i,j,ipoint,k,l,m
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
-  weight = final_weight_at_r_vector(ipoint)
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      do m = 1, 3
-       array(j,i,l,k)     += int2_u_grad1u_x_env2_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
-       array_ref(j,i,l,k) += int2_u_grad1u_x_env2     (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
-      enddo
-     enddo
-    enddo
-   enddo
-  enddo
- enddo
- accu_relat = 0.d0
- accu_abs   = 0.d0
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
-      accu_abs += contrib
-      if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
-       accu_relat += contrib/dabs(array_ref(j,i,l,k))
-      endif
-     enddo
-    enddo
-   enddo
-  enddo
- print*,'******'
- print*,'******'
- print*,'routine_int2_u_grad1u_x_env2'
- print*,'accu_abs   = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-  
-
-end
-
-subroutine routine_v_ij_u_cst_mu_env
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
-  weight = final_weight_at_r_vector(ipoint)
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      array(j,i,l,k)     += v_ij_u_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-      array_ref(j,i,l,k) += v_ij_u_cst_mu_env_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-     enddo
-    enddo
-   enddo
-  enddo
- enddo
- accu_relat = 0.d0
- accu_abs   = 0.d0
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
-      accu_abs += contrib
-      if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
-       accu_relat += contrib/dabs(array_ref(j,i,l,k))
-      endif
-     enddo
-    enddo
-   enddo
-  enddo
- print*,'******'
- print*,'******'
- print*,'routine_v_ij_u_cst_mu_env'
- print*,'accu_abs   = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-end
-
-! ---
-
-subroutine test_fock_3e_uhf_ao()
-
-  implicit none
-  integer                       :: i, j
-  double precision              :: diff_tot, diff_ij, thr_ih, norm
-  double precision, allocatable :: fock_3e_uhf_ao_a_mo(:,:), fock_3e_uhf_ao_b_mo(:,:)
-
-  thr_ih = 1d-7
-
-  PROVIDE fock_a_tot_3e_bi_orth fock_b_tot_3e_bi_orth
-  PROVIDE fock_3e_uhf_ao_a fock_3e_uhf_ao_b
-
-  ! ---
-
-  allocate(fock_3e_uhf_ao_a_mo(mo_num,mo_num))
-  call ao_to_mo_bi_ortho( fock_3e_uhf_ao_a   , size(fock_3e_uhf_ao_a   , 1) &
-                        , fock_3e_uhf_ao_a_mo, size(fock_3e_uhf_ao_a_mo, 1) )
-
-  norm     = 0.d0
-  diff_tot = 0.d0
-  do i = 1, mo_num
-    do j = 1, mo_num
-
-      diff_ij = dabs(fock_3e_uhf_ao_a_mo(j,i) - fock_a_tot_3e_bi_orth(j,i))
-      if(diff_ij .gt. thr_ih) then
-        print *, ' difference on ', j, i
-        print *, ' MANU : ', fock_a_tot_3e_bi_orth(j,i)
-        print *, ' UHF  : ', fock_3e_uhf_ao_a_mo  (j,i)
-        !stop
-      endif
-
-      norm     += dabs(fock_a_tot_3e_bi_orth(j,i))
-      diff_tot += diff_ij
-    enddo
-  enddo
-  print *, ' diff on F_a = ', diff_tot / norm
-  print *, ' '
-
-  deallocate(fock_3e_uhf_ao_a_mo)
-
-  ! ---
-
-  allocate(fock_3e_uhf_ao_b_mo(mo_num,mo_num))
-  call ao_to_mo_bi_ortho( fock_3e_uhf_ao_b   , size(fock_3e_uhf_ao_b   , 1) &
-                        , fock_3e_uhf_ao_b_mo, size(fock_3e_uhf_ao_b_mo, 1) )
-
-  norm     = 0.d0
-  diff_tot = 0.d0
-  do i = 1, mo_num
-    do j = 1, mo_num
-
-      diff_ij = dabs(fock_3e_uhf_ao_b_mo(j,i) - fock_b_tot_3e_bi_orth(j,i))
-      if(diff_ij .gt. thr_ih) then
-        print *, ' difference on ', j, i
-        print *, ' MANU : ', fock_b_tot_3e_bi_orth(j,i)
-        print *, ' UHF  : ', fock_3e_uhf_ao_b_mo  (j,i)
-        !stop
-      endif
-
-      norm     += dabs(fock_b_tot_3e_bi_orth(j,i))
-      diff_tot += diff_ij
-    enddo
-  enddo
-  print *, ' diff on F_b = ', diff_tot/norm
-  print *, ' '
-
-  deallocate(fock_3e_uhf_ao_b_mo)
-
-  ! ---
-
-end subroutine test_fock_3e_uhf_ao()
-
-! ---
-
-subroutine test_fock_3e_uhf_mo()
-
-  implicit none
-  integer          :: i, j
-  double precision :: diff_tot, diff_ij, thr_ih, norm
-
-  thr_ih = 1d-12
-
-  PROVIDE fock_a_tot_3e_bi_orth fock_b_tot_3e_bi_orth
-  PROVIDE fock_3e_uhf_mo_a fock_3e_uhf_mo_b
-
-  ! ---
-
-  norm     = 0.d0
-  diff_tot = 0.d0
-  do i = 1, mo_num
-    do j = 1, mo_num
-
-      diff_ij = dabs(fock_3e_uhf_mo_a(j,i) - fock_a_tot_3e_bi_orth(j,i))
-      if(diff_ij .gt. thr_ih) then
-        print *, ' difference on ', j, i
-        print *, ' MANU : ', fock_a_tot_3e_bi_orth(j,i)
-        print *, ' UHF  : ', fock_3e_uhf_mo_a     (j,i)
-        !stop
-      endif
-
-      norm     += dabs(fock_a_tot_3e_bi_orth(j,i))
-      diff_tot += diff_ij
-    enddo
-  enddo
-  print *, ' diff on F_a = ', diff_tot / norm
-  print *, '      norm_a = ', norm
-  print *, ' '
-
-  ! ---
-
-  norm     = 0.d0
-  diff_tot = 0.d0
-  do i = 1, mo_num
-    do j = 1, mo_num
-
-      diff_ij = dabs(fock_3e_uhf_mo_b(j,i) - fock_b_tot_3e_bi_orth(j,i))
-      if(diff_ij .gt. thr_ih) then
-        print *, ' difference on ', j, i
-        print *, ' MANU : ', fock_b_tot_3e_bi_orth(j,i)
-        print *, ' UHF  : ', fock_3e_uhf_mo_b     (j,i)
-        !stop
-      endif
-
-      norm     += dabs(fock_b_tot_3e_bi_orth(j,i))
-      diff_tot += diff_ij
-    enddo
-  enddo
-  print *, ' diff on F_b = ', diff_tot/norm
-  print *, '      norm_b = ', norm
-  print *, ' '
-
-  ! ---
-
-end
-
-! ---
-
-subroutine test_grid_points_ao
- implicit none
- integer :: i,j,ipoint,icount,icount_good, icount_bad,icount_full
- double precision :: thr
- thr = 1.d-10
-! print*,'max_n_pts_grid_ao_prod = ',max_n_pts_grid_ao_prod
-! print*,'n_pts_grid_ao_prod'
- do i = 1, ao_num
-  do j = i, ao_num
-  icount = 0
-  icount_good = 0
-  icount_bad = 0
-  icount_full = 0
-  do ipoint = 1, n_points_final_grid
-!   if(dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,1)) & 
-!    + dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,2)) &
-!    + dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,3)) )
-!   if(dabs(int2_u2_env2_test(j,i,ipoint)).gt.thr)then
-!    icount += 1
-!   endif
-   if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then
-    icount_full += 1
-   endif
-   if(dabs(v_ij_u_cst_mu_env_test(j,i,ipoint)).gt.thr)then
-    icount += 1
-    if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then
-    icount_good += 1
-    else
-    print*,j,i,ipoint
-    print*,dabs(v_ij_u_cst_mu_env_test(j,i,ipoint)), dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)),dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint))/dabs(v_ij_u_cst_mu_env_test(j,i,ipoint))
-    icount_bad  += 1
-    endif
-   endif
-!   if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr)then
-!   endif
-  enddo
-   print*,''
-   print*,j,i
-   print*,icount,icount_full, icount_bad!,n_pts_grid_ao_prod(j,i)
-   print*,dble(icount)/dble(n_points_final_grid),dble(icount_full)/dble(n_points_final_grid)
-!          dble(n_pts_grid_ao_prod(j,i))/dble(n_points_final_grid)
-!   if(icount.gt.n_pts_grid_ao_prod(j,i))then
-!    print*,'pb !!'
-!   endif
-  enddo
- enddo
-end
-
-subroutine test_int_gauss
- implicit none
- integer :: i,j
- print*,'center'
- do i = 1, ao_num
-  do j = i, ao_num
-   print*,j,i
-   print*,ao_prod_sigma(j,i),ao_overlap_abs_grid(j,i)
-   print*,ao_prod_center(1:3,j,i)
-  enddo
- enddo
- print*,''
- double precision :: weight, r(3),integral_1,pi,center(3),f_r,alpha,distance,integral_2
- center = 0.d0
- pi = dacos(-1.d0)
- integral_1 = 0.d0
- integral_2 = 0.d0
- alpha = 0.75d0
- do i = 1,  n_points_final_grid
-  ! you get x, y and z of the ith grid point
-  r(1) = final_grid_points(1,i)
-  r(2) = final_grid_points(2,i)
-  r(3) = final_grid_points(3,i)
-  weight = final_weight_at_r_vector(i)
-  distance = dsqrt( (r(1) - center(1))**2 +  (r(2) - center(2))**2 + (r(3) - center(3))**2 )
-  f_r = dexp(-alpha * distance*distance)
-  ! you add the contribution of the grid point to the integral
-  integral_1 += f_r * weight
-  integral_2 += f_r * distance * weight
- enddo
- print*,'integral_1      =',integral_1
- print*,'(pi/alpha)**1.5 =',(pi / alpha)**1.5
- print*,'integral_2      =',integral_2
- print*,'(pi/alpha)**1.5 =',2.d0*pi / (alpha)**2
-
-
-end
-
-! ---
-
-subroutine test_two_e_tc_non_hermit_integral()
-
-  implicit none
-  integer          :: i, j
-  double precision :: diff_tot, diff, thr_ih, norm
-
-  thr_ih = 1d-10
-
-  PROVIDE two_e_tc_non_hermit_integral_beta two_e_tc_non_hermit_integral_alpha
-  PROVIDE two_e_tc_non_hermit_integral_seq_beta two_e_tc_non_hermit_integral_seq_alpha
-
-  ! ---
-
-  norm     = 0.d0
-  diff_tot = 0.d0
-  do i = 1, ao_num
-    do j = 1, ao_num
-
-      diff = dabs(two_e_tc_non_hermit_integral_seq_alpha(j,i) - two_e_tc_non_hermit_integral_alpha(j,i))
-      if(diff .gt. thr_ih) then
-        print *, ' difference on ', j, i
-        print *, ' seq         : ', two_e_tc_non_hermit_integral_seq_alpha(j,i)
-        print *, ' //          : ', two_e_tc_non_hermit_integral_alpha    (j,i)
-        !stop
-      endif
-
-      norm     += dabs(two_e_tc_non_hermit_integral_seq_alpha(j,i))
-      diff_tot += diff
-    enddo
-  enddo
-
-  print *, ' diff tot a = ', diff_tot / norm
-  print *, '     norm a = ', norm
-  print *, ' '
-
-  ! ---
-
-  norm     = 0.d0
-  diff_tot = 0.d0
-  do i = 1, ao_num
-    do j = 1, ao_num
-
-      diff = dabs(two_e_tc_non_hermit_integral_seq_beta(j,i) - two_e_tc_non_hermit_integral_beta(j,i))
-      if(diff .gt. thr_ih) then
-        print *, ' difference on ', j, i
-        print *, ' seq         : ', two_e_tc_non_hermit_integral_seq_beta(j,i)
-        print *, ' //          : ', two_e_tc_non_hermit_integral_beta    (j,i)
-        !stop
-      endif
-
-      norm     += dabs(two_e_tc_non_hermit_integral_seq_beta(j,i))
-      diff_tot += diff
-    enddo
-  enddo
-
-  print *, ' diff tot b = ', diff_tot / norm
-  print *, '     norm b = ', norm
-  print *, ' '
-
-  ! ---
-
-  return
-
-end
-
-! ---
-
-subroutine test_int2_grad1_u12_ao_test
- implicit none
- integer :: i,j,ipoint,m,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do m = 1, 3
-  do ipoint = 1, n_points_final_grid
-   weight = final_weight_at_r_vector(ipoint)
-   do k = 1, ao_num
-    do l = 1, ao_num
-     do i = 1, ao_num
-      do j = 1, ao_num
-       array(j,i,l,k)     += int2_grad1_u12_ao_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
-       array_ref(j,i,l,k) += int2_grad1_u12_ao(j,i,ipoint,m)      * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
-      enddo
-     enddo
-    enddo
-   enddo
-  enddo
- enddo
-
- accu_relat = 0.d0
- accu_abs   = 0.d0
-  do k = 1, ao_num
-   do l = 1, ao_num
-    do i = 1, ao_num
-     do j = 1, ao_num
-      contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
-      accu_abs += contrib
-      if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
-       accu_relat += contrib/dabs(array_ref(j,i,l,k))
-      endif
-     enddo
-    enddo
-   enddo
-  enddo
- print*,'******'
- print*,'******'
- print*,'test_int2_grad1_u12_ao_test'
- print*,'accu_abs   = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-end
-
-! ---
-
-subroutine test_fock_3e_uhf_mo_cs()
-
-  implicit none
-  integer          :: i, j
-  double precision :: I_old, I_new
-  double precision :: diff_tot, diff, thr_ih, norm
-
-!  double precision :: t0, t1
-!  print*, ' Providing fock_a_tot_3e_bi_orth ...'
-!  call wall_time(t0)
-!  PROVIDE fock_a_tot_3e_bi_orth
-!  call wall_time(t1)
-!  print*, ' Wall time for fock_a_tot_3e_bi_orth =', t1 - t0 
-
-  PROVIDE fock_3e_uhf_mo_cs fock_3e_uhf_mo_cs_old
-
-  thr_ih   = 1d-8
-  norm     = 0.d0
-  diff_tot = 0.d0
-
-  do i = 1, mo_num
-    do j = 1, mo_num
-
-      I_old = fock_3e_uhf_mo_cs_old(j,i)
-      I_new = fock_3e_uhf_mo_cs    (j,i)
-
-      diff = dabs(I_old - I_new)
-      if(diff .gt. thr_ih) then
-        print *, ' problem in fock_3e_uhf_mo_cs on ', j, i
-        print *, ' old value = ', I_old
-        print *, ' new value = ', I_new
-        !stop
-      endif
-
-      norm     += dabs(I_old)
-      diff_tot += diff
-    enddo
-  enddo
-
-  print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
-
-  return
-end
-
-! ---
-
-subroutine test_fock_3e_uhf_mo_a()
-
-  implicit none
-  integer          :: i, j
-  double precision :: I_old, I_new
-  double precision :: diff_tot, diff, thr_ih, norm
-
-  PROVIDE fock_3e_uhf_mo_a fock_3e_uhf_mo_a_old
-
-  thr_ih   = 1d-8
-  norm     = 0.d0
-  diff_tot = 0.d0
-
-  do i = 1, mo_num
-    do j = 1, mo_num
-
-      I_old = fock_3e_uhf_mo_a_old(j,i)
-      I_new = fock_3e_uhf_mo_a    (j,i)
-
-      diff = dabs(I_old - I_new)
-      if(diff .gt. thr_ih) then
-        print *, ' problem in fock_3e_uhf_mo_a on ', j, i
-        print *, ' old value = ', I_old
-        print *, ' new value = ', I_new
-        !stop
-      endif
-
-      norm     += dabs(I_old)
-      diff_tot += diff
-    enddo
-  enddo
-
-  print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
-
-  return
-end
-
-! ---
-
-subroutine test_fock_3e_uhf_mo_b()
-
-  implicit none
-  integer          :: i, j
-  double precision :: I_old, I_new
-  double precision :: diff_tot, diff, thr_ih, norm
-
-  PROVIDE fock_3e_uhf_mo_b fock_3e_uhf_mo_b_old
-
-  thr_ih   = 1d-8
-  norm     = 0.d0
-  diff_tot = 0.d0
-
-  do i = 1, mo_num
-    do j = 1, mo_num
-
-      I_old = fock_3e_uhf_mo_b_old(j,i)
-      I_new = fock_3e_uhf_mo_b    (j,i)
-
-      diff = dabs(I_old - I_new)
-      if(diff .gt. thr_ih) then
-        print *, ' problem in fock_3e_uhf_mo_b on ', j, i
-        print *, ' old value = ', I_old
-        print *, ' new value = ', I_new
-        !stop
-      endif
-
-      norm     += dabs(I_old)
-      diff_tot += diff
-    enddo
-  enddo
-
-  print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
-
-  return
-end
-
-! ---
-

plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f

@@ -1,189 +0,0 @@
-
-subroutine contrib_3e_diag_sss(i, j, k, integral)
-
-  BEGIN_DOC
-  ! returns the pure same spin contribution to diagonal matrix element of 3e term
-  END_DOC
-
-  implicit none
-  integer,          intent(in)  :: i, j, k
-  double precision, intent(out) :: integral
-  double precision              :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
-
-  call give_integrals_3_body_bi_ort(i, k, j, i, k, j, direct_int )!!! < i k j | i k j >
-  call give_integrals_3_body_bi_ort(i, k, j, j, i, k, c_3_int)      ! < i k j | j i k >
-  call give_integrals_3_body_bi_ort(i, k, j, k, j, i, c_minus_3_int)! < i k j | k j i >
-  integral = direct_int + c_3_int + c_minus_3_int 
-
-  ! negative terms :: exchange contrib
-  call give_integrals_3_body_bi_ort(i, k, j, j, k, i, exch_13_int)!!! < i k j | j k i > : E_13 
-  call give_integrals_3_body_bi_ort(i, k, j, i, j, k, exch_23_int)!!! < i k j | i j k > : E_23
-  call give_integrals_3_body_bi_ort(i, k, j, k, i, j, exch_12_int)!!! < i k j | k i j > : E_12
-
-  integral += - exch_13_int - exch_23_int  - exch_12_int 
-  integral = -integral
-
-end
-
-! ---
-
-subroutine contrib_3e_diag_soo(i,j,k,integral)
- implicit none
- integer, intent(in) :: i,j,k
- BEGIN_DOC
- ! returns the pure same spin contribution to diagonal matrix element of 3e term
- END_DOC
- double precision, intent(out) :: integral
- double precision :: direct_int, exch_23_int
- call  give_integrals_3_body_bi_ort(i, k, j, i, k, j, direct_int) ! < i k j | i k j >
- call  give_integrals_3_body_bi_ort(i, k, j, i, j, k, exch_23_int)! < i k j | i j k > : E_23
- integral = direct_int - exch_23_int 
- integral = -integral
-end
-
-
-subroutine give_aaa_contrib_bis(integral_aaa)
- implicit none
- double precision, intent(out) :: integral_aaa
- double precision :: integral
- integer :: i,j,k
- integral_aaa = 0.d0
- do i = 1, elec_alpha_num
-  do j = i+1, elec_alpha_num
-   do k = j+1, elec_alpha_num
-    call contrib_3e_diag_sss(i,j,k,integral)
-    integral_aaa += integral
-   enddo
-  enddo
- enddo
-
-end
-
-! ---
-
-subroutine give_aaa_contrib(integral_aaa)
-
-  implicit none
-  integer                       :: i, j, k
-  double precision              :: integral
-  double precision, intent(out) :: integral_aaa
-
-  integral_aaa = 0.d0
-  do i = 1, elec_alpha_num
-    do j = 1, elec_alpha_num
-      do k = 1, elec_alpha_num
-        call contrib_3e_diag_sss(i, j, k, integral)
-        integral_aaa += integral
-      enddo
-    enddo
-  enddo
-  integral_aaa *= 1.d0/6.d0 
-
-  return
-end
-
-! ---
-
-subroutine give_aab_contrib(integral_aab)
- implicit none
- double precision, intent(out) :: integral_aab
- double precision :: integral
- integer :: i,j,k
- integral_aab = 0.d0
- do i = 1, elec_beta_num
-  do j = 1, elec_alpha_num
-   do k = 1, elec_alpha_num
-    call contrib_3e_diag_soo(i,j,k,integral)
-    integral_aab += integral
-   enddo
-  enddo
- enddo
- integral_aab *= 0.5d0
-end
-
-
-subroutine give_aab_contrib_bis(integral_aab)
- implicit none
- double precision, intent(out) :: integral_aab
- double precision :: integral
- integer :: i,j,k
- integral_aab = 0.d0
- do i = 1, elec_beta_num
-  do j = 1, elec_alpha_num
-   do k = j+1, elec_alpha_num
-    call contrib_3e_diag_soo(i,j,k,integral)
-    integral_aab += integral
-   enddo
-  enddo
- enddo
-end
-
-
-subroutine give_abb_contrib(integral_abb)
- implicit none
- double precision, intent(out) :: integral_abb
- double precision :: integral
- integer :: i,j,k
- integral_abb = 0.d0
- do i = 1, elec_alpha_num
-  do j = 1, elec_beta_num
-   do k = 1, elec_beta_num
-    call contrib_3e_diag_soo(i,j,k,integral)
-    integral_abb += integral
-   enddo
-  enddo
- enddo
- integral_abb *= 0.5d0
-end
-
-subroutine give_abb_contrib_bis(integral_abb)
- implicit none
- double precision, intent(out) :: integral_abb
- double precision :: integral
- integer :: i,j,k
- integral_abb = 0.d0
- do i = 1, elec_alpha_num
-  do j = 1, elec_beta_num
-   do k = j+1, elec_beta_num
-    call contrib_3e_diag_soo(i,j,k,integral)
-    integral_abb += integral
-   enddo
-  enddo
- enddo
-end
-
-subroutine give_bbb_contrib_bis(integral_bbb)
- implicit none
- double precision, intent(out) :: integral_bbb
- double precision :: integral
- integer :: i,j,k
- integral_bbb = 0.d0
- do i = 1, elec_beta_num
-  do j = i+1, elec_beta_num
-   do k = j+1, elec_beta_num
-    call contrib_3e_diag_sss(i,j,k,integral)
-    integral_bbb += integral
-   enddo
-  enddo
- enddo
-
-end
-
-subroutine give_bbb_contrib(integral_bbb)
- implicit none
- double precision, intent(out) :: integral_bbb
- double precision :: integral
- integer :: i,j,k
- integral_bbb = 0.d0
- do i = 1, elec_beta_num
-  do j = 1, elec_beta_num
-   do k = 1, elec_beta_num
-    call contrib_3e_diag_sss(i,j,k,integral)
-    integral_bbb += integral
-   enddo
-  enddo
- enddo
- integral_bbb *= 1.d0/6.d0 
-end
-
-

plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f

@@ -4,11 +4,9 @@ program write_ao_2e_tc_integ
 
   implicit none
 
-  PROVIDE j1e_type
-  PROVIDE j2e_type
-
-  print *, ' j1e_type = ', j1e_type
   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

src/becke_numerical_grid/extra_grid_vector.irp.f

@@ -70,17 +70,6 @@ END_PROVIDER
         index_final_points_extra(2,i_count) = i
         index_final_points_extra(3,i_count) = j
         index_final_points_extra_reverse(k,i,j) = i_count
-
-!        if(final_weight_at_r_vector_extra(i_count) .lt. 0.d0) then
-!          print *, ' !!! WARNING !!!'
-!          print *, ' negative weight !!!!'
-!          print *, i_count, final_weight_at_r_vector_extra(i_count)
-!          if(dabs(final_weight_at_r_vector_extra(i_count)) .lt. 1d-10) then
-!            final_weight_at_r_vector_extra(i_count) = 0.d0
-!          else
-!            stop
-!          endif
-!        endif
       enddo
     enddo
   enddo

src/becke_numerical_grid/grid_becke_vector.irp.f

@@ -67,17 +67,6 @@ END_PROVIDER
         index_final_points(2,i_count) = i
         index_final_points(3,i_count) = j
         index_final_points_reverse(k,i,j) = i_count
-
-!        if(final_weight_at_r_vector(i_count) .lt. 0.d0) then
-!          print *, ' !!! WARNING !!!'
-!          print *, ' negative weight !!!!'
-!          print *, i_count, final_weight_at_r_vector(i_count)
-!          if(dabs(final_weight_at_r_vector(i_count)) .lt. 1d-10) then
-!            final_weight_at_r_vector(i_count) = 0.d0
-!          else
-!            stop
-!          endif
-!        endif 
       enddo
     enddo
   enddo

src/mo_optimization/gradient_list_opt.irp.f

@@ -319,7 +319,7 @@ call omp_set_max_active_levels(4)
 ! \end{equation}
 
 ! We need a vector to use the gradient. Here the gradient is a
-! antisymetric matrix so we can transform it in a vector of length
+! antisymmetric matrix so we can transform it in a vector of length
 ! mo_num*(mo_num-1)/2.
 
 ! Here we do these two things at the same time.

src/mo_optimization/gradient_opt.irp.f

@@ -284,7 +284,7 @@ call omp_set_max_active_levels(4)
 ! \end{equation}
 
 ! We need a vector to use the gradient. Here the gradient is a
-! antisymetric matrix so we can transform it in a vector of length
+! antisymmetric matrix so we can transform it in a vector of length
 ! mo_num*(mo_num-1)/2.
 
 ! Here we do these two things at the same time.

src/utils/util.irp.f

@@ -576,7 +576,7 @@ logical function is_same_spin(sigma_1, sigma_2)
     is_same_spin = .false.
   endif
 
-end function is_same_spin
+end
 
 ! ---
    
@@ -596,7 +596,7 @@ function Kronecker_delta(i, j) result(delta)
     delta = 0.d0
   endif
 
-end function Kronecker_delta
+end
 
 ! ---
 
@@ -634,7 +634,81 @@ subroutine diagonalize_sym_matrix(N, A, e)
     print*,'Problem in diagonalize_sym_matrix (dsyev)!!'
   endif
 
-end subroutine diagonalize_sym_matrix
+end
+
+! ---
+
+
+subroutine give_degen(A, n, shift, list_degen, n_degen_list)
+
+  BEGIN_DOC
+  ! returns n_degen_list :: the number of degenerated SET of elements (i.e. with |A(i)-A(i+1)| below shift)
+  !
+  ! for each of these sets, list_degen(1,i) = first degenerate element of the set i, 
+  !
+  !                         list_degen(2,i) = last degenerate element of the set i.
+  END_DOC
+
+  implicit none
+
+  double precision, intent(in)  :: A(n)
+  double precision, intent(in)  :: shift
+  integer,          intent(in)  :: n
+  integer,          intent(out) :: list_degen(2,n), n_degen_list
+
+  integer                       :: i, j, n_degen, k
+  logical                       :: keep_on
+  double precision, allocatable :: Aw(:)
+
+  list_degen = -1
+  allocate(Aw(n))
+  Aw = A
+  i=1
+  k = 0
+  do while(i.lt.n)
+   if(dabs(Aw(i)-Aw(i+1)).lt.shift)then
+    k+=1
+    j=1
+    list_degen(1,k) = i
+    keep_on = .True.
+    do while(keep_on)
+     if(i+j.gt.n)then
+      keep_on = .False.
+      exit
+     endif
+     if(dabs(Aw(i)-Aw(i+j)).lt.shift)then
+      j+=1
+     else
+      keep_on=.False.
+      exit
+     endif
+    enddo
+    n_degen = j
+    list_degen(2,k) = list_degen(1,k)-1 + n_degen
+    j=0
+    keep_on = .True.
+    do while(keep_on)
+     if(i+j+1.gt.n)then
+      keep_on = .False.
+      exit
+     endif
+     if(dabs(Aw(i+j)-Aw(i+j+1)).lt.shift)then
+      Aw(i+j) += (j-n_degen/2) * shift
+      j+=1
+     else
+      keep_on = .False.
+      exit
+     endif
+    enddo
+    Aw(i+n_degen-1) += (n_degen-1-n_degen/2) * shift
+    i+=n_degen
+   else
+    i+=1
+   endif
+  enddo
+  n_degen_list = k
+
+end
 
 ! ---