normal order V2 FROZEN CORE

src/becke_numerical_grid/grid_becke.irp.f

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

src/becke_numerical_grid/grid_becke_vector.irp.f

@@ -20,8 +20,8 @@ BEGIN_PROVIDER [integer, n_points_final_grid]
     enddo
   enddo
 
-  print*,' n_points_final_grid = ', n_points_final_grid
+  !print*,' n_points_final_grid = ', n_points_final_grid
-  print*,' n max point         = ', n_points_integration_angular*(n_points_radial_grid*nucl_num - 1)
+  !print*,' n max point         = ', n_points_integration_angular*(n_points_radial_grid*nucl_num - 1)
   call ezfio_set_becke_numerical_grid_n_points_final_grid(n_points_final_grid)
 
 END_PROVIDER

src/non_h_ints_mu/tc_integ_an.irp.f

@@ -108,7 +108,6 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_f
   
       PROVIDE int2_grad1_u12_ao_num
       int2_grad1_u12_ao = int2_grad1_u12_ao_num
-      FREE int2_grad1_u12_ao_num
 
     else
 
@@ -225,7 +224,6 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_p
 
     PROVIDE int2_grad1_u12_square_ao_num
     int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num
-    FREE int2_grad1_u12_square_ao_num
 
   else
 

src/non_h_ints_mu/tc_integ_num.irp.f

@@ -15,6 +15,7 @@
   integer                       :: n_blocks, n_rest, n_pass
   integer                       :: i_blocks, i_rest, i_pass, ii
   double precision              :: time0, time1
+  double precision              :: mem, n_double
   double precision, allocatable :: tmp(:,:,:)
   double precision, allocatable :: tmp_grad1_u12(:,:,:), tmp_grad1_u12_squared(:,:)
 
@@ -41,31 +42,33 @@
   enddo
   !$OMP END DO
   !$OMP END PARALLEL
-  
+
   ! n_points_final_grid = n_blocks * n_pass + n_rest
-  n_blocks = 4
+  call total_memory(mem)
+  mem      = max(1.d0, qp_max_mem - mem)
+  n_double = mem * 1.d8
+  n_blocks = min(n_double / (n_points_extra_final_grid * 4), 1.d0*n_points_final_grid)
   n_rest   = int(mod(n_points_final_grid, n_blocks))
   n_pass   = int((n_points_final_grid - n_rest) / n_blocks)
-  
+
-  if(n_pass .le. 1) then
+  call write_int(6, n_pass, 'Number of passes')
-    print*, ' blocks are to large or grid is very small !'
+  call write_int(6, n_blocks, 'Size of the blocks')
-    stop
+  call write_int(6, n_rest, 'Size of the last block')
-  endif
+
   
   allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_blocks))
   allocate(tmp_grad1_u12(n_points_extra_final_grid,n_blocks,3))
   
-  !$OMP PARALLEL                                                     &
-  !$OMP DEFAULT (NONE)                                               &
-  !$OMP PRIVATE (i_pass, i_blocks, ipoint, ii, m, tmp_grad1_u12,     &
-  !$OMP          tmp_grad1_u12_squared)                              &
-  !$OMP SHARED (n_pass, n_blocks, n_points_extra_final_grid, ao_num, &
-  !$OMP         final_grid_points, tmp, int2_grad1_u12_ao_num,       &
-  !$OMP         int2_grad1_u12_square_ao_num)
-  !$OMP DO 
   do i_pass = 1, n_pass
     ii = (i_pass-1)*n_blocks + 1
   
+    !$OMP PARALLEL                                         &
+    !$OMP DEFAULT (NONE)                                   &
+    !$OMP PRIVATE (i_blocks, ipoint)                       &
+    !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, &
+    !$OMP         final_grid_points, tmp_grad1_u12,        &
+    !$OMP         tmp_grad1_u12_squared)
+    !$OMP DO 
     do i_blocks = 1, n_blocks
       ipoint = ii - 1 + i_blocks ! r1
       call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1) &
@@ -73,6 +76,8 @@
                                                                                              , tmp_grad1_u12(1,i_blocks,3) &
                                                                                              , tmp_grad1_u12_squared(1,i_blocks))
     enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
 
     do m = 1, 3
       call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, 1.d0                     &
@@ -83,19 +88,23 @@
               , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid &
               , 0.d0, int2_grad1_u12_square_ao_num(1,1,ii), ao_num*ao_num) 
   enddo
-  !$OMP END DO
-  !$OMP END PARALLEL
   
   deallocate(tmp_grad1_u12, tmp_grad1_u12_squared)
   
-  ! TODO
+  if(n_rest .gt. 0) then
-  ! OPENMP 
-  if(n_rest .ne. 0) then
   
     allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_rest))
     allocate(tmp_grad1_u12(n_points_extra_final_grid,n_rest,3))
   
     ii = n_pass*n_blocks + 1
+
+    !$OMP PARALLEL                                       &
+    !$OMP DEFAULT (NONE)                                 &
+    !$OMP PRIVATE (i_rest, ipoint)                       &
+    !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, &
+    !$OMP         final_grid_points, tmp_grad1_u12,      &
+    !$OMP         tmp_grad1_u12_squared)
+    !$OMP DO 
     do i_rest = 1, n_rest
       ipoint = ii - 1 + i_rest ! r1
       call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1) &
@@ -103,6 +112,8 @@
                                                                                              , tmp_grad1_u12(1,i_rest,3) &
                                                                                              , tmp_grad1_u12_squared(1,i_rest))
     enddo
+    !$OMP END DO
+    !$OMP END PARALLEL
   
     do m = 1, 3
       call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, 1.d0                       &

src/non_h_ints_mu/total_tc_int.irp.f

@@ -55,12 +55,13 @@ BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao
   integer          :: i, j, k, l
   double precision :: wall1, wall0
 
+  PROVIDE j1b_type
+
   print *, ' providing ao_tc_int_chemist ...'
   call wall_time(wall0)
   
   if(test_cycle_tc) then
 
-    PROVIDE j1b_type
     if(j1b_type .ne. 3) then
       print*, ' TC integrals with cycle can not be used for j1b_type =', j1b_type
       stop
@@ -86,6 +87,11 @@ BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao
 
   FREE tc_grad_square_ao tc_grad_and_lapl_ao ao_two_e_coul
 
+  if(j1b_type .ge. 100) then
+    FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num
+  endif
+
+
   call wall_time(wall1)
   print *, ' wall time for ao_tc_int_chemist ', wall1 - wall0
   call print_memory_usage()

src/tc_bi_ortho/normal_ordered_old.irp.f

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

src/tc_bi_ortho/test_tc_bi_ortho.irp.f

@@ -11,14 +11,17 @@ program tc_bi_ortho
 
   print *, 'Hello world'
 
-  my_grid_becke = .True.
+  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
 
-  read_wf = .True.
+  call write_int(6, my_n_pt_r_grid, 'radial  external grid over')
-  touch read_wf
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+!  read_wf = .True.
+!  touch read_wf
 
 ! call test_h_u0
 ! call test_slater_tc_opt
@@ -27,10 +30,12 @@ program tc_bi_ortho
 ! call timing_single
 ! call timing_double
 
-  call test_no()
   !call test_no_aba()
   !call test_no_aab()
   !call test_no_aaa()
+
+  call test_no()
+
 end
 
 subroutine test_h_u0
@@ -272,9 +277,9 @@ subroutine test_no()
 
   implicit none
   integer          :: i, j, k, l
-  double precision :: accu, contrib, new, ref, thr
+  double precision :: accu, contrib, new, ref, thr, norm
 
-  print*, ' testing normal_two_body_bi_orth ...'
+  print*, ' test_no ...'
 
   thr = 1d-8
 
@@ -282,6 +287,7 @@ subroutine test_no()
   PROVIDE normal_two_body_bi_orth
 
   accu = 0.d0
+  norm = 0.d0
   do i = 1, mo_num
     do j = 1, mo_num
       do k = 1, mo_num
@@ -289,8 +295,8 @@ subroutine test_no()
 
           new = normal_two_body_bi_orth    (l,k,j,i)
           ref = normal_two_body_bi_orth_old(l,k,j,i)
+
           contrib = dabs(new - ref)
-          accu += contrib
           if(contrib .gt. thr) then
             print*, ' problem on normal_two_body_bi_orth'
             print*, l, k, j, i
@@ -298,14 +304,17 @@ subroutine test_no()
             stop
           endif
 
+          accu += contrib
+          norm += dabs(ref)
         enddo
       enddo
     enddo
   enddo
-  print*, ' accu on normal_two_body_bi_orth = ', accu / dble(mo_num)**4
 
- return
+  print*, ' accu (%) = ', 100.d0*accu/norm
-end
+
+  return
+end subroutine test_no
 
 ! ---
 
@@ -313,7 +322,7 @@ subroutine test_no_aba()
 
   implicit none
   integer          :: i, j, k, l
-  double precision :: accu, contrib, new, ref, thr
+  double precision :: accu, contrib, new, ref, thr, norm
 
   print*, ' testing no_aba_contraction ...'
 
@@ -323,6 +332,7 @@ subroutine test_no_aba()
   PROVIDE no_aba_contraction
 
   accu = 0.d0
+  norm = 0.d0
   do i = 1, mo_num
     do j = 1, mo_num
       do k = 1, mo_num
@@ -331,7 +341,6 @@ subroutine test_no_aba()
           new = no_aba_contraction   (l,k,j,i)
           ref = no_aba_contraction_v0(l,k,j,i)
           contrib = dabs(new - ref)
-          accu += contrib
           if(contrib .gt. thr) then
             print*, ' problem on no_aba_contraction'
             print*, l, k, j, i
@@ -339,13 +348,16 @@ subroutine test_no_aba()
             stop
           endif
 
+          accu += contrib
+          norm += dabs(ref)
         enddo
       enddo
     enddo
   enddo
-  print*, ' accu on no_aba_contraction = ', accu / dble(mo_num)**4
 
- return
+  print*, ' accu (%) = ', 100.d0*accu/norm
+
+  return
 end
 
 ! ---
@@ -355,7 +367,7 @@ subroutine test_no_aab()
 
   implicit none
   integer          :: i, j, k, l
-  double precision :: accu, contrib, new, ref, thr
+  double precision :: accu, contrib, new, ref, thr, norm
 
   print*, ' testing no_aab_contraction ...'
 
@@ -365,6 +377,7 @@ subroutine test_no_aab()
   PROVIDE no_aab_contraction
 
   accu = 0.d0
+  norm = 0.d0
   do i = 1, mo_num
     do j = 1, mo_num
       do k = 1, mo_num
@@ -373,7 +386,6 @@ subroutine test_no_aab()
           new = no_aab_contraction   (l,k,j,i)
           ref = no_aab_contraction_v0(l,k,j,i)
           contrib = dabs(new - ref)
-          accu += contrib
           if(contrib .gt. thr) then
             print*, ' problem on no_aab_contraction'
             print*, l, k, j, i
@@ -381,13 +393,16 @@ subroutine test_no_aab()
             stop
           endif
 
+          accu += contrib
+          norm += dabs(ref)
         enddo
       enddo
     enddo
   enddo
-  print*, ' accu on no_aab_contraction = ', accu / dble(mo_num)**4
 
- return
+  print*, ' accu (%) = ', 100.d0*accu/norm
+
+  return
 end
 
 ! ---
@@ -396,7 +411,7 @@ subroutine test_no_aaa()
 
   implicit none
   integer          :: i, j, k, l
-  double precision :: accu, contrib, new, ref, thr
+  double precision :: accu, contrib, new, ref, thr, norm
 
   print*, ' testing no_aaa_contraction ...'
 
@@ -406,6 +421,7 @@ subroutine test_no_aaa()
   PROVIDE no_aaa_contraction
 
   accu = 0.d0
+  norm = 0.d0
   do i = 1, mo_num
     do j = 1, mo_num
       do k = 1, mo_num
@@ -414,7 +430,6 @@ subroutine test_no_aaa()
           new = no_aaa_contraction   (l,k,j,i)
           ref = no_aaa_contraction_v0(l,k,j,i)
           contrib = dabs(new - ref)
-          accu += contrib
           if(contrib .gt. thr) then
             print*, ' problem on no_aaa_contraction'
             print*, l, k, j, i
@@ -422,13 +437,17 @@ subroutine test_no_aaa()
             stop
           endif
 
+          accu += contrib
+          norm += dabs(ref)
         enddo
       enddo
     enddo
   enddo
-  print*, ' accu on no_aaa_contraction = ', accu / dble(mo_num)**4
 
- return
+  print*, ' accu (%) = ', 100.d0*accu/norm
+
+  return
 end
 
 ! ---
+

src/tc_keywords/EZFIO.cfg

@@ -110,13 +110,13 @@ default: False
 type: Threshold
 doc: Threshold on the convergence of the Hartree Fock energy.
 interface: ezfio,provider,ocaml
-default: 1.e-10
+default: 1.e-8
 
 [n_it_tcscf_max]
 type: Strictly_positive_int
 doc: Maximum number of SCF iterations
 interface: ezfio,provider,ocaml
-default: 100
+default: 50
 
 [selection_tc]
 type: integer
@@ -278,11 +278,11 @@ default: 30
 type: integer
 doc: size of angular grid over r2
 interface: ezfio,provider,ocaml
-default: 50
+default: 194
 
 [tc_grid2_r]
 type: integer
 doc: size of radial grid over r2
 interface: ezfio,provider,ocaml
-default: 30
+default: 50
 

src/tc_scf/tc_scf.irp.f

@@ -18,6 +18,10 @@ program tc_scf
   my_n_pt_a_grid = tc_grid1_a
   touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
 
+  call write_int(6, my_n_pt_r_grid, 'radial  external grid over')
+  call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+
   PROVIDE mu_erf 
   print *, ' mu = ', mu_erf
   PROVIDE j1b_type
@@ -30,6 +34,9 @@ program tc_scf
     my_n_pt_r_extra_grid = tc_grid2_r
     my_n_pt_a_extra_grid = tc_grid2_a
     touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
+
+    call write_int(6, my_n_pt_r_extra_grid, 'radial  internal grid over')
+    call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
   endif
 
   !call create_guess()