LCPQ
/
qp2
mirror of https://github.com/QuantumPackage/qp2.git
9
1
Fork 0
Code Releases Activity

normal order V2 FROZEN CORE

This commit is contained in:
AbdAmmar 2023-09-06 19:21:14 +02:00
parent 1f56b5d0f4
commit 7076fcd202
10 changed files with 419 additions and 1325 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/becke_numerical_grid/grid_becke.irp.f
View File

@ -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
! ---

4
src/becke_numerical_grid/grid_becke_vector.irp.f
View File

@ -20,8 +20,8 @@ BEGIN_PROVIDER [integer, n_points_final_grid]
enddo
enddo
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_points_final_grid = ', n_points_final_grid
!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

2
src/non_h_ints_mu/tc_integ_an.irp.f
View File

@ -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

51
src/non_h_ints_mu/tc_integ_num.irp.f
View File

@ -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
print*, ' blocks are to large or grid is very small !'
stop
endif
call write_int(6, n_pass, 'Number of passes')
call write_int(6, n_blocks, 'Size of the blocks')
call write_int(6, n_rest, 'Size of the last block')
allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_blocks))
allocate(tmp_grad1_u12(n_points_extra_final_grid,n_blocks,3))
!$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
! OPENMP
if(n_rest .ne. 0) then
if(n_rest .gt. 0) then
allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_rest))
allocate(tmp_grad1_u12(n_points_extra_final_grid,n_rest,3))
ii = n_pass*n_blocks + 1
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i_rest, ipoint) &
!$OMP SHARED (n_rest, n_points_extra_final_grid, ii, &
!$OMP final_grid_points, tmp_grad1_u12, &
!$OMP tmp_grad1_u12_squared)
!$OMP DO
do i_rest = 1, n_rest
ipoint = ii - 1 + i_rest ! r1
call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1) &
@ -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 &

8
src/non_h_ints_mu/total_tc_int.irp.f
View File

@ -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()

1594
src/tc_bi_ortho/normal_ordered.irp.f
View File

File diff suppressed because it is too large Load Diff

4
src/tc_bi_ortho/normal_ordered_old.irp.f
View File

@ -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)

63
src/tc_bi_ortho/test_tc_bi_ortho.irp.f
View File

@ -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.
touch read_wf
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')
! 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
end
print*, ' accu (%) = ', 100.d0*accu/norm
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
! ---

8
src/tc_keywords/EZFIO.cfg
View File

@ -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

7
src/tc_scf/tc_scf.irp.f
View File

@ -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()