Merge branch 'dev-stable-tc-scf' of https://github.com/AbdAmmar/qp2 into dev-stable-tc-scf

src/tc_bi_ortho/print_tc_dump.irp.f

@@ -10,7 +10,10 @@ program tc_bi_ortho
   my_n_pt_a_grid = 50
   touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
 
+  call ERI_dump()
   call KMat_tilde_dump()
+  call LMat_tilde_dump()
+
 end
 
 ! ---
@@ -18,7 +21,7 @@ end
 subroutine KMat_tilde_dump()
 
   implicit none
-  integer                       :: i, j, k, l
+  integer :: i, j, k, l
 
   PROVIDE mo_bi_ortho_tc_two_e_chemist
 
@@ -42,3 +45,91 @@ subroutine KMat_tilde_dump()
 end subroutine KMat_tilde_dump
 
 ! ---
+
+subroutine ERI_dump()
+
+  implicit none
+  integer                       :: i, j, k, l
+  double precision, allocatable :: a1(:,:,:,:), a2(:,:,:,:)
+
+  PROVIDE mo_r_coef mo_l_coef
+
+  allocate(a2(ao_num,ao_num,ao_num,mo_num))
+
+  call dgemm( 'T', 'N', ao_num*ao_num*ao_num, mo_num, ao_num, 1.d0   &
+            , ao_two_e_coul(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
+            , 0.d0 , a2(1,1,1,1), ao_num*ao_num*ao_num)
+
+  allocate(a1(ao_num,ao_num,mo_num,mo_num))
+
+  call dgemm( 'T', 'N', ao_num*ao_num*mo_num, mo_num, ao_num, 1.d0 &
+            , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num          &
+            , 0.d0, a1(1,1,1,1), ao_num*ao_num*mo_num)
+
+  deallocate(a2)
+  allocate(a2(ao_num,mo_num,mo_num,mo_num))
+
+  call dgemm( 'T', 'N', ao_num*mo_num*mo_num, mo_num, ao_num, 1.d0 &
+            , a1(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num          &
+            , 0.d0, a2(1,1,1,1), ao_num*mo_num*mo_num)
+
+  deallocate(a1)
+  allocate(a1(mo_num,mo_num,mo_num,mo_num))
+
+  call dgemm( 'T', 'N', mo_num*mo_num*mo_num, mo_num, ao_num, 1.d0 &
+            , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num          &
+            , 0.d0, a1(1,1,1,1), mo_num*mo_num*mo_num)
+
+  deallocate(a2)
+
+  open(33, file='ERI.dat', action='write')  
+    do l = 1, mo_num
+      do k = 1, mo_num
+        do j = 1, mo_num
+          do i = 1, mo_num
+            write(33, '(4(I4, 2X), 4X, E15.7)') i, j, k, l, a1(i,j,k,l)
+          enddo
+        enddo
+      enddo
+    enddo
+  close(33)
+
+  deallocate(a1)
+
+  return
+end subroutine ERI_dump
+
+! ---
+
+subroutine LMat_tilde_dump()
+
+  implicit none
+  integer          :: i, j, k, l, m, n
+  double precision :: integral
+
+  PROVIDE mo_bi_ortho_tc_two_e_chemist
+
+  print *, ' Lmat_tilde in phys notation'
+
+  open(33, file='Lmat_tilde.dat', action='write')  
+    do n = 1, mo_num
+      do m = 1, mo_num
+        do l = 1, mo_num
+          do k = 1, mo_num
+            do j = 1, mo_num
+              do i = 1, mo_num
+                ! < i j k | -L | l m n > with a BI-ORTHONORMAL MOLECULAR ORBITALS
+                call give_integrals_3_body_bi_ort(i, j, k, l, m, n, integral)
+                write(33, '(6(I4, 2X), 4X, E15.7)') i, j, k, l, m, n, integral
+              enddo
+            enddo
+          enddo
+        enddo
+      enddo
+    enddo
+  close(33)
+
+  return
+end subroutine LMat_tilde_dump
+
+! ---

src/tc_bi_ortho/print_tc_energy.irp.f

@@ -1,19 +1,31 @@
 program print_tc_energy
-  implicit none
+
   BEGIN_DOC
-! TODO : Put the documentation of the program here
+  ! TODO : Put the documentation of the program here
   END_DOC
+
+  implicit none
+
   print *, 'Hello world'
   my_grid_becke = .True.
-  my_n_pt_r_grid = 30
-  my_n_pt_a_grid = 50
+  !my_n_pt_r_grid = 30
+  !my_n_pt_a_grid = 50
+
+  my_n_pt_r_grid = 100
+  my_n_pt_a_grid = 170
+
+  !my_n_pt_r_grid = 100
+  !my_n_pt_a_grid = 266
+
   read_wf = .True.
   touch read_wf
 
   PROVIDE j1b_type
   print*, 'j1b_type = ', j1b_type
 
-  touch  my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
- call write_tc_energy
+  touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+
+  call write_tc_energy()
+
 end
 

src/tc_bi_ortho/slater_tc_slow.irp.f

@@ -55,7 +55,7 @@ subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree,
   hmono  = 0.d0
   htwoe  = 0.d0
   htot   = 0.d0
-  hthree = 0.D0
+  hthree = 0.d0
 
   call get_excitation_degree(key_i, key_j, degree, Nint)
   if(degree.gt.2) return

src/tc_keywords/j1b_pen.irp.f

@@ -91,7 +91,7 @@
   print *, ' parameters for nuclei jastrow'
   print *, ' i, Z, j1b_pen, j1b_pen_coef'
   do i = 1, nucl_num
-    print *, i, nucl_charge(i), j1b_pen(i), j1b_pen_coef(i)
+    write(*,"(I4, 2x, 3(E15.7, 2X))"), i, nucl_charge(i), j1b_pen(i), j1b_pen_coef(i)
   enddo
 
 END_PROVIDER

src/tc_scf/fock_three_hermit.irp.f

@@ -78,6 +78,7 @@ end
 
 ! ---
 
+! TODO DGEMM
 BEGIN_PROVIDER [double precision, diag_three_elem_hf]
 
   implicit none
@@ -106,7 +107,7 @@ BEGIN_PROVIDER [double precision, diag_three_elem_hf]
       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)   
+            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