From eaab1b80648bd2b4ec38aa17722a751fccf42ce0 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 7 Mar 2024 07:34:59 +0100 Subject: [PATCH 01/50] few modif for HHG --- .../multi_s_dipole_moment.irp.f | 23 ++++++++++++++++ src/utils/constants.include.F | 27 +++++++++++++++++++ 2 files changed, 50 insertions(+) diff --git a/src/mol_properties/multi_s_dipole_moment.irp.f b/src/mol_properties/multi_s_dipole_moment.irp.f index 913ae2f3..f21e08cd 100644 --- a/src/mol_properties/multi_s_dipole_moment.irp.f +++ b/src/mol_properties/multi_s_dipole_moment.irp.f @@ -91,3 +91,26 @@ BEGIN_PROVIDER [double precision, multi_s_dipole_moment, (N_states, N_states)] enddo END_PROVIDER + +! --- + + BEGIN_PROVIDER [double precision, multi_s_x_dipole_moment_eigenvec, (N_states, N_states)] +&BEGIN_PROVIDER [double precision, multi_s_y_dipole_moment_eigenvec, (N_states, N_states)] +&BEGIN_PROVIDER [double precision, multi_s_z_dipole_moment_eigenvec, (N_states, N_states)] +&BEGIN_PROVIDER [double precision, multi_s_x_dipole_moment_eigenval, (N_states)] +&BEGIN_PROVIDER [double precision, multi_s_y_dipole_moment_eigenval, (N_states)] +&BEGIN_PROVIDER [double precision, multi_s_z_dipole_moment_eigenval, (N_states)] + + implicit none + + PROVIDE multi_s_x_dipole_moment multi_s_y_dipole_moment multi_s_z_dipole_moment + + call lapack_diag(multi_s_x_dipole_moment_eigenval(1), multi_s_x_dipole_moment_eigenvec(1,1), multi_s_x_dipole_moment(1,1), N_states, N_states) + call lapack_diag(multi_s_y_dipole_moment_eigenval(1), multi_s_y_dipole_moment_eigenvec(1,1), multi_s_y_dipole_moment(1,1), N_states, N_states) + call lapack_diag(multi_s_z_dipole_moment_eigenval(1), multi_s_z_dipole_moment_eigenvec(1,1), multi_s_z_dipole_moment(1,1), N_states, N_states) + +END_PROVIDER + +! --- + + diff --git a/src/utils/constants.include.F b/src/utils/constants.include.F index 422eff95..7b01f888 100644 --- a/src/utils/constants.include.F +++ b/src/utils/constants.include.F @@ -18,3 +18,30 @@ double precision, parameter :: c_4_3 = 4.d0/3.d0 double precision, parameter :: c_1_3 = 1.d0/3.d0 double precision, parameter :: sq_op5 = dsqrt(0.5d0) double precision, parameter :: dlog_2pi = dlog(2.d0*dacos(-1.d0)) + +! physical constants and units conversion factors +double precision, parameter :: k_boltzman_si = 1.38066d-23 ! K k^-1 +double precision, parameter :: k_boltzman_au = 3.1667d-6 ! Hartree k^-1 +double precision, parameter :: k_boltzman_m1_au = 315795.26d0 ! Hartree^-1 k +double precision, parameter :: bohr_radius_si = 0.529177d-10 ! m +double precision, parameter :: bohr_radius_cm = 0.529177d-8 ! cm +double precision, parameter :: bohr_radius_angs = 0.529177d0 ! Angstrom +double precision, parameter :: electronmass_si = 9.10953d-31 ! Kg +double precision, parameter :: electronmass_uma = 5.4858d-4 ! uma +double precision, parameter :: electronvolt_si = 1.6021892d-19 ! J +double precision, parameter :: uma_si = 1.66057d-27 ! Kg +double precision, parameter :: debye_si = 3.33564d-30 ! coulomb meter +double precision, parameter :: debye_au = 0.393427228d0 ! e * Bohr +double precision, parameter :: angstrom_to_au = 1.889727d0 ! au +double precision, parameter :: au_to_ohmcmm1 = 46000.0d0 ! (ohm cm)^-1 +double precision, parameter :: au_to_kb = 294210.0d0 ! kbar +double precision, parameter :: au_to_eV = 27.211652d0 +double precision, parameter :: uma_to_au = 1822.89d0 +double precision, parameter :: au_to_terahertz = 2.4189d-5 +double precision, parameter :: au_to_sec = 2.4189d-17 +double precision, parameter :: au_to_fsec = 2.4189d-2 +double precision, parameter :: Wcm2 = 3.5d16 +double precision, parameter :: amconv = 1.66042d-24/9.1095d-28*0.5d0 ! mass conversion: a.m.u to a.u. (ry) +double precision, parameter :: uakbar = 147105.d0 ! pressure conversion from ry/(a.u)^3 to k + + From d405aea95785060f7550be7901c90d133b287a65 Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Mon, 11 Mar 2024 10:21:59 +0100 Subject: [PATCH 02/50] few mom opt --- .../local/bi_ort_ints/total_twoe_pot.irp.f | 99 +++++++++++++++---- .../local/non_h_ints_mu/total_tc_int.irp.f | 2 + src/tools/print_detweights.irp.f | 66 +++++++++++++ 3 files changed, 148 insertions(+), 19 deletions(-) create mode 100644 src/tools/print_detweights.irp.f diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f index 5e6a24e9..bf5cc36f 100644 --- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f +++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f @@ -40,38 +40,95 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, END_DOC implicit none - integer :: i, j, k, l, m, n, p, q + integer :: i, j, k, l, m, n, p, q, s, r + double precision :: t1, t2 double precision, allocatable :: a1(:,:,:,:), a2(:,:,:,:) + double precision, allocatable :: a_jkp(:,:,:), a_kpq(:,:,:), a_pqr(:,:,:) + + print *, ' PROVIDING mo_bi_ortho_tc_two_e_chemist ...' + call wall_time(t1) + call print_memory_usage() PROVIDE mo_r_coef mo_l_coef + PROVIDe ao_two_e_tc_tot - allocate(a2(ao_num,ao_num,ao_num,mo_num)) + if(ao_to_mo_tc_n3) then - call dgemm( 'T', 'N', ao_num*ao_num*ao_num, mo_num, ao_num, 1.d0 & - , ao_two_e_tc_tot(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) + print*, ' memory scale of TC ao -> mo: O(N3) ' - allocate(a1(ao_num,ao_num,mo_num,mo_num)) + allocate(a_jkp(ao_num,ao_num,mo_num)) + allocate(a_kpq(ao_num,mo_num,mo_num)) + allocate(a_pqr(mo_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) + do s = 1, mo_num + mo_bi_ortho_tc_two_e_chemist(:,:,:,s) = 0.d0 - deallocate(a2) - allocate(a2(ao_num,mo_num,mo_num,mo_num)) + do l = 1, ao_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) + call dgemm( 'T', 'N', ao_num*ao_num, mo_num, ao_num, 1.d0 & + , ao_two_e_tc_tot(1,1,1,l), ao_num, mo_l_coef(1,1), ao_num & + , 0.d0, a_jkp(1,1,1), ao_num*ao_num) + + call dgemm( 'T', 'N', ao_num*mo_num, mo_num, ao_num, 1.d0 & + , a_jkp(1,1,1), ao_num, mo_r_coef(1,1), ao_num & + , 0.d0, a_kpq(1,1,1), ao_num*mo_num) + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num, ao_num, 1.d0 & + , a_kpq(1,1,1), ao_num, mo_l_coef(1,1), ao_num & + , 0.d0, a_pqr(1,1,1), mo_num*mo_num) - deallocate(a1) + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(p, q, r) & + !$OMP SHARED(s, l, mo_num, mo_bi_ortho_tc_two_e_chemist, mo_r_coef, a_pqr) + !$OMP DO COLLAPSE(2) + do p = 1, mo_num + do q = 1, mo_num + do r = 1, mo_num + mo_bi_ortho_tc_two_e_chemist(p,q,r,s) = mo_bi_ortho_tc_two_e_chemist(p,q,r,s) + mo_r_coef(l,s) * a_pqr(p,q,r) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL - 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, mo_bi_ortho_tc_two_e_chemist(1,1,1,1), mo_num*mo_num*mo_num) + enddo ! l + enddo ! s - deallocate(a2) + deallocate(a_jkp, a_kpq, a_pqr) + else + + print*, ' memory scale of TC ao -> mo: O(N4) ' + + 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_tc_tot(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) + + 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, mo_bi_ortho_tc_two_e_chemist(1,1,1,1), mo_num*mo_num*mo_num) + + deallocate(a2) + + endif !allocate(a1(mo_num,ao_num,ao_num,ao_num)) !a1 = 0.d0 @@ -135,6 +192,10 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, !enddo !deallocate(a1) + call wall_time(t2) + print *, ' WALL TIME for PROVIDING mo_bi_ortho_tc_two_e_chemist (min)', (t2-t1)/60.d0 + call print_memory_usage() + END_PROVIDER ! --- diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f index 9d3cf565..ba078d9b 100644 --- a/plugins/local/non_h_ints_mu/total_tc_int.irp.f +++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f @@ -201,6 +201,8 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n !$OMP END DO !$OMP END PARALLEL + call clear_ao_map() + if(tc_integ_type .eq. "numeric") then FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num endif diff --git a/src/tools/print_detweights.irp.f b/src/tools/print_detweights.irp.f new file mode 100644 index 00000000..d5b0f2c9 --- /dev/null +++ b/src/tools/print_detweights.irp.f @@ -0,0 +1,66 @@ +program print_detweights + + implicit none + + read_wf = .True. + touch read_wf + + call main() + +end + +! --- + +subroutine main() + + implicit none + integer :: i + integer :: degree + integer :: ios + integer, allocatable :: deg(:), ii(:), deg_sorted(:) + double precision, allocatable :: c(:) + + PROVIDE N_int + PROVIDE N_det + PROVIDE psi_det + PROVIDe psi_coef + + allocate(deg(N_det), ii(N_det), deg_sorted(N_det), c(N_det)) + + do i = 1, N_det + + call debug_det(psi_det(1,1,i), N_int) + call get_excitation_degree(psi_det(1,1,i), psi_det(1,1,1), degree, N_int) + + ii (i) = i + deg(i) = degree + c (i) = dabs(psi_coef(i,1)) + enddo + + call dsort(c, ii, N_det) + + do i = 1, N_det + deg_sorted(i) = deg(ii(i)) + enddo + + print *, ' saving psi' + + ! Writing output in binary format + open(unit=10, file="coef.bin", status="replace", action="write", iostat=ios, form="unformatted") + + if(ios /= 0) then + print *, ' Error opening file!' + stop + endif + + write(10) N_det + write(10) deg_sorted + write(10) c + + close(10) + + deallocate(deg, ii, deg_sorted, c) + +end + + From 1dbde5643920054cc16f148c50d84fed01a88b13 Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Wed, 13 Mar 2024 07:04:54 +0100 Subject: [PATCH 03/50] O(N4) -> O(N3) transformations --- .../local/bi_ort_ints/total_twoe_pot.irp.f | 19 ++++++++++++++++--- plugins/local/tc_keywords/EZFIO.cfg | 7 +++++++ 2 files changed, 23 insertions(+), 3 deletions(-) diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f index bf5cc36f..79bfd336 100644 --- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f +++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f @@ -41,7 +41,7 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, implicit none integer :: i, j, k, l, m, n, p, q, s, r - double precision :: t1, t2 + double precision :: t1, t2, tt1, tt2 double precision, allocatable :: a1(:,:,:,:), a2(:,:,:,:) double precision, allocatable :: a_jkp(:,:,:), a_kpq(:,:,:), a_pqr(:,:,:) @@ -60,9 +60,11 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, allocate(a_kpq(ao_num,mo_num,mo_num)) allocate(a_pqr(mo_num,mo_num,mo_num)) - do s = 1, mo_num - mo_bi_ortho_tc_two_e_chemist(:,:,:,s) = 0.d0 + call wall_time(tt1) + do s = 1, mo_num + + mo_bi_ortho_tc_two_e_chemist(:,:,:,s) = 0.d0 do l = 1, ao_num call dgemm( 'T', 'N', ao_num*ao_num, mo_num, ao_num, 1.d0 & @@ -93,6 +95,17 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, !$OMP END PARALLEL enddo ! l + + if(s == 2) then + call wall_time(tt2) + print*, ' 1 / mo_num done in (min)', (tt2-tt1)/60.d0 + print*, ' estimated time required (min)', dble(mo_num-1)*(tt2-tt1)/60.d0 + elseif(s == 11) then + call wall_time(tt2) + print*, ' 10 / mo_num done in (min)', (tt2-tt1)/60.d0 + print*, ' estimated time required (min)', dble(mo_num-10)*(tt2-tt1)/600.d0 + endif + enddo ! s deallocate(a_jkp, a_kpq, a_pqr) diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg index 93ff790f..a8491660 100644 --- a/plugins/local/tc_keywords/EZFIO.cfg +++ b/plugins/local/tc_keywords/EZFIO.cfg @@ -280,3 +280,10 @@ doc: approach used to evaluate TC integrals [ analytic | numeric | semi-analytic interface: ezfio,ocaml,provider default: semi-analytic +[ao_to_mo_tc_n3] +type: logical +doc: If |true|, memory scale of TC ao -> mo: O(N3) +interface: ezfio,provider,ocaml +default: False + + From 83ed57312d9bc86dc2ec4cbc486491ded16d7053 Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Tue, 19 Mar 2024 17:23:41 +0100 Subject: [PATCH 04/50] few modif in ao tc integ --- .../local/bi_ort_ints/total_twoe_pot.irp.f | 25 +++++++++++++++++-- .../local/non_h_ints_mu/tc_integ_num.irp.f | 2 +- .../local/non_h_ints_mu/total_tc_int.irp.f | 3 ++- 3 files changed, 26 insertions(+), 4 deletions(-) diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f index 79bfd336..1e558038 100644 --- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f +++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f @@ -50,7 +50,7 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, call print_memory_usage() PROVIDE mo_r_coef mo_l_coef - PROVIDe ao_two_e_tc_tot + PROVIDE ao_two_e_tc_tot if(ao_to_mo_tc_n3) then @@ -103,9 +103,30 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, elseif(s == 11) then call wall_time(tt2) print*, ' 10 / mo_num done in (min)', (tt2-tt1)/60.d0 - print*, ' estimated time required (min)', dble(mo_num-10)*(tt2-tt1)/600.d0 + print*, ' estimated time required (min)', dble(mo_num-10)*(tt2-tt1)/(60.d0*10.d0) + elseif(s == 26) then + call wall_time(tt2) + print*, ' 25 / mo_num done in (min)', (tt2-tt1)/60.d0 + print*, ' estimated time required (min)', dble(mo_num-25)*(tt2-tt1)/(60.d0*25.d0) + elseif(s == 51) then + call wall_time(tt2) + print*, ' 50 / mo_num done in (min)', (tt2-tt1)/60.d0 + print*, ' estimated time required (min)', dble(mo_num-50)*(tt2-tt1)/(60.d0*50.d0) + elseif(s == 101) then + call wall_time(tt2) + print*, ' 100 / mo_num done in (min)', (tt2-tt1)/60.d0 + print*, ' estimated time required (min)', dble(mo_num-100)*(tt2-tt1)/(60.d0*100.d0) + elseif(s == 201) then + call wall_time(tt2) + print*, ' 200 / mo_num done in (min)', (tt2-tt1)/60.d0 + print*, ' estimated time required (min)', dble(mo_num-200)*(tt2-tt1)/(60.d0*200.d0) + elseif(s == 501) then + call wall_time(tt2) + print*, ' 500 / mo_num done in (min)', (tt2-tt1)/60.d0 + print*, ' estimated time required (min)', dble(mo_num-500)*(tt2-tt1)/(60.d0*500.d0) endif + enddo ! s deallocate(a_jkp, a_kpq, a_pqr) diff --git a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f index e5d75c3d..6d446037 100644 --- a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f +++ b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f @@ -131,7 +131,7 @@ deallocate(tmp) call wall_time(time1) - print*, ' wall time for int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num =', time1-time0 + print*, ' wall time for int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num = (min)', (time1-time0) / 60.d0 call print_memory_usage() END_PROVIDER diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f index ba078d9b..c7230dc3 100644 --- a/plugins/local/non_h_ints_mu/total_tc_int.irp.f +++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f @@ -201,7 +201,8 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n !$OMP END DO !$OMP END PARALLEL - call clear_ao_map() + !call clear_ao_map() + FREE ao_integrals_map if(tc_integ_type .eq. "numeric") then FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num From 7a3379a43ec7924d7836fe7750b818a4e5a67634 Mon Sep 17 00:00:00 2001 From: ydamour Date: Wed, 27 Mar 2024 16:56:05 +0100 Subject: [PATCH 05/50] bugfix davidson recontraction + update --- .../diagonalization_hs2_dressed.irp.f | 22 ++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/src/davidson/diagonalization_hs2_dressed.irp.f b/src/davidson/diagonalization_hs2_dressed.irp.f index 3513f215..fd967ecc 100644 --- a/src/davidson/diagonalization_hs2_dressed.irp.f +++ b/src/davidson/diagonalization_hs2_dressed.irp.f @@ -139,7 +139,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ integer :: iter2, itertot double precision, allocatable :: y(:,:), h(:,:), h_p(:,:), lambda(:), s2(:) real, allocatable :: y_s(:,:) - double precision, allocatable :: s_(:,:), s_tmp(:,:) + double precision, allocatable :: s_(:,:), s_tmp(:,:), prev_y(:,:) double precision :: diag_h_mat_elem double precision, allocatable :: residual_norm(:) character*(16384) :: write_buffer @@ -288,6 +288,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ h(N_st_diag*itermax,N_st_diag*itermax), & ! h_p(N_st_diag*itermax,N_st_diag*itermax), & y(N_st_diag*itermax,N_st_diag*itermax), & + prev_y(N_st_diag*itermax,N_st_diag*itermax), & s_(N_st_diag*itermax,N_st_diag*itermax), & s_tmp(N_st_diag*itermax,N_st_diag*itermax), & residual_norm(N_st_diag), & @@ -301,6 +302,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ s_ = 0.d0 s_tmp = 0.d0 + prev_y = 0.d0 + do i = 1, N_st_diag*itermax + prev_y(i,i) = 1d0 + enddo ASSERT (N_st > 0) ASSERT (N_st_diag >= N_st) @@ -479,6 +484,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ if (info > 0) then ! Numerical errors propagate. We need to reduce the number of iterations itermax = iter-1 + + ! eigenvectors of the previous iteration + y = prev_y + shift2 = shift2 - N_st_diag exit endif @@ -553,7 +562,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ do l = 1, N_st do k = 1, N_st_diag do i = 1, sze - overlp(k+j-1,l) += U(i,l) * U(i,shift2+k) + overlp(k+j-1,l) += u_in(i,l) * U(i,shift2+k) enddo enddo enddo @@ -576,7 +585,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ enddo ! Maximum overlap - if (dabs(overlp(k,l)) > omax .and. .not. used .and. state_ok(k)) then + if ((dabs(overlp(k,l)) > omax) .and. (.not. used) .and. state_ok(k)) then omax = dabs(overlp(k,l)) idx = k endif @@ -615,6 +624,9 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ endif enddo + ! Swapped eigenvectors + prev_y = y + ! if (state_following) then ! ! overlap = -1.d0 @@ -677,7 +689,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ do i=1,sze U(i,shift2+k) = & (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - /max(H_jj(i) - lambda (k),1.d-2) + /max(dabs(H_jj(i) - lambda (k)),1.d-2) * dsign(1d0,H_jj(i) - lambda (k)) enddo if (k <= N_st) then @@ -792,7 +804,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ residual_norm, & U, overlap, & h, y_s, S_d, & - y, s_, s_tmp, & + y, s_, s_tmp, prev_y, & lambda & ) FREE nthreads_davidson From 4e692558a653bd1ccc36a2e19551dea8201e2ab3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 2 Apr 2024 17:41:19 +0200 Subject: [PATCH 06/50] Changed total memory to resident memory in check --- src/utils/memory.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/memory.irp.f b/src/utils/memory.irp.f index ab85c21b..e69bf71e 100644 --- a/src/utils/memory.irp.f +++ b/src/utils/memory.irp.f @@ -107,7 +107,7 @@ subroutine check_mem(rss_in,routine) double precision, intent(in) :: rss_in character*(*) :: routine double precision :: mem - call total_memory(mem) + call resident_memory(mem) mem += rss_in if (mem > qp_max_mem) then call print_memory_usage() From d93b529b36ed27b611bcfb7196b7b51727d8be18 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 3 Apr 2024 11:49:55 +0200 Subject: [PATCH 07/50] Improve (T) --- src/ccsd/ccsd_t_space_orb_stoch.irp.f | 32 ++++++++++++++++----------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/src/ccsd/ccsd_t_space_orb_stoch.irp.f b/src/ccsd/ccsd_t_space_orb_stoch.irp.f index 13fa4f1a..293baa2d 100644 --- a/src/ccsd/ccsd_t_space_orb_stoch.irp.f +++ b/src/ccsd/ccsd_t_space_orb_stoch.irp.f @@ -181,8 +181,8 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ integer :: nbuckets nbuckets = 100 + double precision, allocatable :: ED(:) double precision, allocatable :: wsum(:) - allocate(wsum(nbuckets)) converged = .False. Ncomputed = 0_8 @@ -197,7 +197,8 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ iright = Nabc integer*8, allocatable :: bounds(:,:) - allocate (bounds(2,nbuckets)) + allocate(wsum(nbuckets), ED(nbuckets), bounds(2,nbuckets)) + ED(:) = 0.d0 do isample=1,nbuckets eta = 1.d0/dble(nbuckets) * dble(isample) ieta = binary_search(waccu,eta,Nabc) @@ -233,7 +234,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ enddo ! Deterministic part - if (imin < Nabc) then + if (imin <= Nabc) then ieta=imin sampled(ieta) = 0_8 a = abc(1,ieta) @@ -254,7 +255,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ ! Stochastic part call random_number(eta) do isample=1,nbuckets - if (imin >= bounds(2,isample)) then + if (imin > bounds(2,isample)) then cycle endif ieta = binary_search(waccu,(eta + dble(isample-1))/dble(nbuckets),Nabc)+1 @@ -280,7 +281,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ enddo call wall_time(t01) - if ((t01-t00 > 1.0d0).or.(imin >= Nabc)) then + if ((t01-t00 > 1.0d0).or.(imin > Nabc)) then !$OMP TASKWAIT call wall_time(t01) @@ -300,8 +301,11 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ do isample=1,nbuckets - if (imin >= bounds(2,isample)) then - energy_det = energy_det + sum(memo(bounds(1,isample):bounds(2,isample))) + if (imin > bounds(2,isample)) then + if (ED(isample) == 0.d0) then + ED(isample) = sum(memo(bounds(1,isample):bounds(2,isample))) + endif + energy_det = energy_det + ED(isample) scale = scale - wsum(isample) else exit @@ -310,12 +314,14 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ isample = min(isample,nbuckets) do ieta=bounds(1,isample), Nabc - w = dble(max(sampled(ieta),0_8)) - tmp = w * memo(ieta) * Pabc(ieta) - ET = ET + tmp - ET2 = ET2 + tmp * memo(ieta) * Pabc(ieta) - norm = norm + w + if (sampled(ieta) < 0_8) cycle + w = dble(sampled(ieta)) + tmp = w * memo(ieta) * Pabc(ieta) + ET = ET + tmp + ET2 = ET2 + tmp * memo(ieta) * Pabc(ieta) + norm = norm + w enddo + norm = norm/scale if (norm > 0.d0) then energy_stoch = ET / norm @@ -327,7 +333,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ print '('' '',F20.8, '' '', ES12.4,'' '', F8.2,'' '')', eccsd+energy, dsqrt(variance/(norm-1.d0)), 100.*real(Ncomputed)/real(Nabc) endif !$OMP END MASTER - if (imin >= Nabc) exit + if (imin > Nabc) exit enddo !$OMP END PARALLEL From e4ce9ef2193529ff1887d7ec62abb2233869f50f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 3 Apr 2024 15:32:56 +0200 Subject: [PATCH 08/50] Upgrade trexio version in configure --- configure | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/configure b/configure index e211cfd7..41c0123d 100755 --- a/configure +++ b/configure @@ -9,7 +9,7 @@ echo "QP_ROOT="$QP_ROOT unset CC unset CCXX -TREXIO_VERSION=2.3.2 +TREXIO_VERSION=2.4.2 # Force GCC instead of ICC for dependencies export CC=gcc @@ -219,7 +219,7 @@ EOF tar -zxf trexio-${VERSION}.tar.gz && rm trexio-${VERSION}.tar.gz cd trexio-${VERSION} ./configure --prefix=\${QP_ROOT} --without-hdf5 CFLAGS='-g' - make -j 8 && make -j 8 check && make -j 8 install + (make -j 8 || make) && make check && make -j 8 install tar -zxvf "\${QP_ROOT}"/external/qp2-dependencies/${ARCHITECTURE}/ninja.tar.gz mv ninja "\${QP_ROOT}"/bin/ EOF @@ -233,7 +233,7 @@ EOF tar -zxf trexio-${VERSION}.tar.gz && rm trexio-${VERSION}.tar.gz cd trexio-${VERSION} ./configure --prefix=\${QP_ROOT} CFLAGS="-g" - make -j 8 && make -j 8 check && make -j 8 install + (make -j 8 || make) && make check && make -j 8 install EOF elif [[ ${PACKAGE} = qmckl ]] ; then @@ -245,7 +245,7 @@ EOF tar -zxf qmckl-${VERSION}.tar.gz && rm qmckl-${VERSION}.tar.gz cd qmckl-${VERSION} ./configure --prefix=\${QP_ROOT} --enable-hpc --disable-doc CFLAGS='-g' - make && make -j 4 check && make install + (make -j 8 || make) && make check && make install EOF elif [[ ${PACKAGE} = qmckl-intel ]] ; then @@ -257,7 +257,7 @@ EOF tar -zxf qmckl-${VERSION}.tar.gz && rm qmckl-${VERSION}.tar.gz cd qmckl-${VERSION} ./configure --prefix=\${QP_ROOT} --enable-hpc --disable-doc --with-icc --with-ifort CFLAGS='-g' - make && make -j 4 check && make install + (make -j 8 || make) && make check && make install EOF From b22c835ec8d415c7cecfa76ab98ea6ed9f4903f2 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 3 Apr 2024 16:59:15 +0200 Subject: [PATCH 09/50] Add nthreads_pt2 to (T) --- src/ccsd/ccsd_t_space_orb_stoch.irp.f | 4 +++- src/{cipsi_utils => ezfio_files}/environment.irp.f | 0 2 files changed, 3 insertions(+), 1 deletion(-) rename src/{cipsi_utils => ezfio_files}/environment.irp.f (100%) diff --git a/src/ccsd/ccsd_t_space_orb_stoch.irp.f b/src/ccsd/ccsd_t_space_orb_stoch.irp.f index 293baa2d..618d50e4 100644 --- a/src/ccsd/ccsd_t_space_orb_stoch.irp.f +++ b/src/ccsd/ccsd_t_space_orb_stoch.irp.f @@ -110,6 +110,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ double precision :: eocc double precision :: norm integer :: isample + PROVIDE nthreads_pt2 ! Prepare table of triplets (a,b,c) @@ -216,11 +217,12 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ print '(A)', ' ======================= ============== ==========' + call set_multiple_levels_omp(.False.) call wall_time(t00) imin = 1_8 !$OMP PARALLEL & !$OMP PRIVATE(ieta,eta,a,b,c,kiter,isample) & - !$OMP DEFAULT(SHARED) + !$OMP DEFAULT(SHARED) NUM_THREADS(nthreads_pt2) do kiter=1,Nabc diff --git a/src/cipsi_utils/environment.irp.f b/src/ezfio_files/environment.irp.f similarity index 100% rename from src/cipsi_utils/environment.irp.f rename to src/ezfio_files/environment.irp.f From 0c8845f5f208e1c405a6aa5aba1ceb276ddbdcdf Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 4 Apr 2024 15:06:30 +0200 Subject: [PATCH 10/50] Fix qp_convert --- bin/qp_convert_output_to_ezfio | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/bin/qp_convert_output_to_ezfio b/bin/qp_convert_output_to_ezfio index 1b33f156..6f2d02d0 100755 --- a/bin/qp_convert_output_to_ezfio +++ b/bin/qp_convert_output_to_ezfio @@ -227,8 +227,8 @@ def write_ezfio(res, filename): shell_index += [nshell_tot] * len(b.prim) shell_num = len(ang_mom) - assert(shell_index[0] = 1) - assert(shell_index[-1] = shell_num) + assert(shell_index[0] == 1) + assert(shell_index[-1] == shell_num) # ~#~#~#~#~ # # W r i t e # From 43648cddb04771bf269e791d76cec68b742f27f1 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 Apr 2024 14:24:42 +0200 Subject: [PATCH 11/50] Fixed qp_plugins update --- bin/qp_plugins | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bin/qp_plugins b/bin/qp_plugins index e53b08e9..b1fbeec0 100755 --- a/bin/qp_plugins +++ b/bin/qp_plugins @@ -97,7 +97,7 @@ end def get_repositories(): l_result = [f for f in os.listdir(QP_PLUGINS) \ - if f not in [".gitignore", "local"] ] + if f not in [".gitignore", "local", "README.rst"] ] return sorted(l_result) From 6848470850c946da9a3b1b8af0d6037fd9d5de92 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 Apr 2024 14:25:32 +0200 Subject: [PATCH 12/50] Fix underflow in EZFIO --- src/mo_basis/utils.irp.f | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/mo_basis/utils.irp.f b/src/mo_basis/utils.irp.f index 5f664c41..987c394a 100644 --- a/src/mo_basis/utils.irp.f +++ b/src/mo_basis/utils.irp.f @@ -228,7 +228,11 @@ subroutine mo_as_svd_vectors_of_mo_matrix_eig(matrix,lda,m,n,eig,label) call dgemm('N','N',ao_num,m,m,1.d0,mo_coef_new,size(mo_coef_new,1),U,size(U,1),0.d0,mo_coef,size(mo_coef,1)) do i=1,m - eig(i) = D(i) + if (eig(i) > 1.d-20) then + eig(i) = D(i) + else + eig(i) = 0.d0 + endif enddo deallocate(A,mo_coef_new,U,Vt,D) From 8e0a9be9ad3a5e21b5b3c05c7e78e4a4fff8960e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 Apr 2024 14:25:45 +0200 Subject: [PATCH 13/50] Add metadata to TREXIO --- src/trexio/export_trexio_routines.irp.f | 54 ++++++++++++++++++++++++- 1 file changed, 53 insertions(+), 1 deletion(-) diff --git a/src/trexio/export_trexio_routines.irp.f b/src/trexio/export_trexio_routines.irp.f index 034b142e..63630243 100644 --- a/src/trexio/export_trexio_routines.irp.f +++ b/src/trexio/export_trexio_routines.irp.f @@ -59,7 +59,59 @@ subroutine export_trexio(update,full_path) enddo call ezfio_set_trexio_trexio_file(trexio_filename) - + + +! ------------------------------------------------------------------------------ + +! Metadata +! -------- + + integer :: code_num, author_num + character*(64) :: code(100), author(100), user + character*(64), parameter :: qp2_code = "QuantumPackage" + + call getenv("USER",user) + do k=1,N_states + rc = trexio_read_metadata_code_num(f(k), code_num) + if (rc == TREXIO_ATTR_MISSING) then + i = 1 + code(:) = "" + else + rc = trexio_read_metadata_code(f(k), code, 64) + do i=1, code_num + if (trim(code(i)) == trim(qp2_code)) then + exit + endif + enddo + endif + if (i == code_num+1) then + code(i) = qp2_code + rc = trexio_write_metadata_code_num(f(k), i) + call trexio_assert(rc, TREXIO_SUCCESS) + rc = trexio_write_metadata_code(f(k), code, 64) + call trexio_assert(rc, TREXIO_SUCCESS) + endif + + rc = trexio_read_metadata_author_num(f(k), author_num) + if (rc == TREXIO_ATTR_MISSING) then + i = 1 + author(:) = "" + else + rc = trexio_read_metadata_author(f(k), author, 64) + do i=1, author_num + if (trim(author(i)) == trim(user)) then + exit + endif + enddo + endif + if (i == author_num+1) then + author(i) = user + rc = trexio_write_metadata_author_num(f(k), i) + call trexio_assert(rc, TREXIO_SUCCESS) + rc = trexio_write_metadata_author(f(k), author, 64) + call trexio_assert(rc, TREXIO_SUCCESS) + endif + enddo ! ------------------------------------------------------------------------------ From 88cffcb26999f685b9c7ef78d61bb71961cf3d9d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 Apr 2024 17:51:48 +0200 Subject: [PATCH 14/50] Force MOs to be on axes. Nice for atoms --- src/ao_one_e_ints/ao_ortho_canonical.irp.f | 2 ++ src/scf_utils/diagonalize_fock.irp.f | 2 +- src/scf_utils/roothaan_hall_scf.irp.f | 26 +++++++++++++++++++--- 3 files changed, 26 insertions(+), 4 deletions(-) diff --git a/src/ao_one_e_ints/ao_ortho_canonical.irp.f b/src/ao_one_e_ints/ao_ortho_canonical.irp.f index 668b920d..eff7e7be 100644 --- a/src/ao_one_e_ints/ao_ortho_canonical.irp.f +++ b/src/ao_one_e_ints/ao_ortho_canonical.irp.f @@ -138,6 +138,8 @@ END_PROVIDER deallocate(S) endif + FREE ao_overlap + END_PROVIDER BEGIN_PROVIDER [double precision, ao_ortho_canonical_overlap, (ao_ortho_canonical_num,ao_ortho_canonical_num)] diff --git a/src/scf_utils/diagonalize_fock.irp.f b/src/scf_utils/diagonalize_fock.irp.f index 5188581a..b9042b29 100644 --- a/src/scf_utils/diagonalize_fock.irp.f +++ b/src/scf_utils/diagonalize_fock.irp.f @@ -47,7 +47,7 @@ BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num,mo_num) do j = 1, n_core_orb jorb = list_core(j) F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 + F(jorb,iorb) = 0.d0 enddo enddo endif diff --git a/src/scf_utils/roothaan_hall_scf.irp.f b/src/scf_utils/roothaan_hall_scf.irp.f index 730cb496..3f5c8549 100644 --- a/src/scf_utils/roothaan_hall_scf.irp.f +++ b/src/scf_utils/roothaan_hall_scf.irp.f @@ -13,9 +13,9 @@ END_DOC integer :: iteration_SCF,dim_DIIS,index_dim_DIIS logical :: converged - integer :: i,j + integer :: i,j,m logical, external :: qp_stop - double precision, allocatable :: mo_coef_save(:,:) + double precision, allocatable :: mo_coef_save(:,:), S(:,:) PROVIDE ao_md5 mo_occ level_shift @@ -208,9 +208,29 @@ END_DOC size(Fock_matrix_mo,2),mo_label,1,.true.) call restore_symmetry(ao_num, mo_num, mo_coef, size(mo_coef,1), 1.d-10) call orthonormalize_mos - call save_mos endif + + ! Identify degenerate MOs and force them on the axes + allocate(S(ao_num,ao_num)) + i=1 + do while (i1) then + call dgemm('N','T',ao_num,ao_num,m,1.d0,mo_coef(1,i),size(mo_coef,1),mo_coef(1,i),size(mo_coef,1),0.d0,S,size(S,1)) + call pivoted_cholesky( S, m, -1.d0, ao_num, mo_coef(1,i)) + endif + i = j+1 + enddo + + + call save_mos + call write_double(6, Energy_SCF, 'SCF energy') call write_time(6) From d872d60e70f8eedb3913f5566d4f35d198d4aad5 Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Sun, 7 Apr 2024 00:29:40 +0200 Subject: [PATCH 15/50] saving olympe2 modif --- plugins/local/bi_ortho_mos/overlap.irp.f | 8 +- .../lapack_diag_non_hermit.irp.f | 1 + plugins/local/tc_scf/minimize_tc_angles.irp.f | 2 +- plugins/local/tc_scf/routines_rotates.irp.f | 79 ++++++++++--------- src/tools/print_detweights.irp.f | 35 +++++++- src/utils/block_diag_degen.irp.f | 2 +- 6 files changed, 81 insertions(+), 46 deletions(-) diff --git a/plugins/local/bi_ortho_mos/overlap.irp.f b/plugins/local/bi_ortho_mos/overlap.irp.f index ff5d5c84..7f07929f 100644 --- a/plugins/local/bi_ortho_mos/overlap.irp.f +++ b/plugins/local/bi_ortho_mos/overlap.irp.f @@ -56,10 +56,10 @@ print*,'Average trace of overlap_bi_ortho is different from 1 by ', dabs(accu_d-1.d0) print*,'And bi orthogonality is off by an average of ',accu_nd print*,'****************' - print*,'Overlap matrix betwee mo_l_coef and mo_r_coef ' - do i = 1, mo_num - write(*,'(100(F16.10,X))')overlap_bi_ortho(i,:) - enddo + !print*,'Overlap matrix betwee mo_l_coef and mo_r_coef ' + !do i = 1, mo_num + ! write(*,'(100(F16.10,X))')overlap_bi_ortho(i,:) + !enddo endif print*,'Average trace of overlap_bi_ortho (should be 1.)' print*,'accu_d = ',accu_d diff --git a/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f index cb38347e..4d4bc047 100644 --- a/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f +++ b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f @@ -2144,6 +2144,7 @@ subroutine impose_biorthog_degen_eigvec(n, deg_num, e0, L0, R0) enddo !print*,' accu_nd after = ', accu_nd if(accu_nd .gt. 1d-12) then + print*, ' accu_nd =', accu_nd print*, ' your strategy for degenerates orbitals failed !' print*, m, 'deg on', i stop diff --git a/plugins/local/tc_scf/minimize_tc_angles.irp.f b/plugins/local/tc_scf/minimize_tc_angles.irp.f index c7752930..e5f6cf87 100644 --- a/plugins/local/tc_scf/minimize_tc_angles.irp.f +++ b/plugins/local/tc_scf/minimize_tc_angles.irp.f @@ -20,7 +20,7 @@ program minimize_tc_angles ! TODO ! check if rotations of orbitals affect the TC energy ! and refuse the step - call minimize_tc_orb_angles + call minimize_tc_orb_angles() end diff --git a/plugins/local/tc_scf/routines_rotates.irp.f b/plugins/local/tc_scf/routines_rotates.irp.f index c42e846e..2c5510f2 100644 --- a/plugins/local/tc_scf/routines_rotates.irp.f +++ b/plugins/local/tc_scf/routines_rotates.irp.f @@ -40,9 +40,6 @@ subroutine LTxSxR(n, m, L, S, R, C) end subroutine LTxR -! --- - - ! --- subroutine minimize_tc_orb_angles() @@ -103,7 +100,10 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles) double precision, allocatable :: stmp(:,:), T(:,:), Snew(:,:), smat2(:,:) double precision, allocatable :: mo_l_coef_tmp(:,:), mo_r_coef_tmp(:,:), mo_l_coef_new(:,:) - E_thr = 1d-04 + PROVIDE TC_HF_energy + PROVIDE mo_r_coef mo_l_coef + + E_thr = 1d-07 E_old = TC_HF_energy allocate(mo_l_coef_old(ao_num,mo_num), mo_r_coef_old(ao_num,mo_num)) mo_r_coef_old = mo_r_coef @@ -111,7 +111,7 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles) good_angles = .False. - allocate(mo_l_coef_good(ao_num, mo_num), mo_r_coef_good(ao_num,mo_num)) + allocate(mo_l_coef_good(ao_num,mo_num), mo_r_coef_good(ao_num,mo_num)) print *, ' ***************************************' print *, ' ***************************************' @@ -123,7 +123,7 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles) mo_r_coef_good = mo_r_coef mo_l_coef_good = mo_l_coef - allocate(mo_r_coef_new(ao_num, mo_num)) + allocate(mo_r_coef_new(ao_num,mo_num)) mo_r_coef_new = mo_r_coef do i = 1, mo_num norm = 1.d0/dsqrt(overlap_mo_r(i,i)) @@ -141,10 +141,11 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles) call build_s_matrix(ao_num, mo_num, mo_r_coef_new, mo_r_coef_new, ao_overlap, s_mat) ! call give_degen(fock_diag,mo_num,thr_deg,list_degen,n_degen_list) if(n_core_orb.ne.0)then - call give_degen_full_listcore(fock_diag, mo_num, list_core, n_core_orb, thr_deg, list_degen, n_degen_list) + call give_degen_full_listcore(fock_diag, mo_num, list_core, n_core_orb, thr_deg, list_degen, n_degen_list) else - call give_degen_full_list(fock_diag, mo_num, thr_deg, list_degen, n_degen_list) + call give_degen_full_list(fock_diag, mo_num, thr_deg, list_degen, n_degen_list) endif + print *, ' fock_matrix_mo' do i = 1, mo_num print *, i, fock_diag(i), angle_left_right(i) @@ -156,50 +157,52 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles) ! n_degen = ilast - ifirst +1 n_degen = list_degen(i,0) - if(n_degen .ge. 1000)n_degen = 1 ! convention for core orbitals + if(n_degen .ge. 1000) n_degen = 1 ! convention for core orbitals if(n_degen .eq. 1) cycle + print*, ' working on orbital', i + print*, ' multiplicity =', n_degen allocate(stmp(n_degen,n_degen), smat2(n_degen,n_degen)) allocate(mo_r_coef_tmp(ao_num,n_degen), mo_l_coef_tmp(ao_num,n_degen), mo_l_coef_new(ao_num,n_degen)) allocate(T(n_degen,n_degen), Snew(n_degen,n_degen)) print*,'Right orbitals before' - do j = 1, n_degen - write(*,'(100(F16.10,X))') mo_r_coef_new(1:ao_num,list_degen(i,j)) - enddo + do j = 1, n_degen + write(*,'(1000(F16.10,X))') mo_r_coef_new(1:ao_num,list_degen(i,j)) + enddo print*,'Left orbitals before' - do j = 1, n_degen - write(*,'(100(F16.10,X))')mo_l_coef(1:ao_num,list_degen(i,j)) - enddo + do j = 1, n_degen + write(*,'(1000(F16.10,X))') mo_l_coef(1:ao_num,list_degen(i,j)) + enddo if(angle_left_right(list_degen(i,1)).gt.80.d0.and.n_degen==2)then - integer :: i_list, j_list - i_list = list_degen(i,1) - j_list = list_degen(i,2) - print*,'Huge angle !!! == ',angle_left_right(list_degen(i,1)),angle_left_right(list_degen(i,2)) - print*,'i_list = ',i_list - print*,'i_list = ',j_list - print*,'Swapping left/right orbitals' - call print_strong_overlap(i_list, j_list) - mo_r_coef_tmp(1:ao_num,1) = mo_r_coef_new(1:ao_num,i_list) - mo_r_coef_tmp(1:ao_num,2) = mo_l_coef(1:ao_num,i_list) - mo_l_coef_tmp(1:ao_num,1) = mo_l_coef(1:ao_num,j_list) - mo_l_coef_tmp(1:ao_num,2) = mo_r_coef_new(1:ao_num,j_list) + integer :: i_list, j_list + i_list = list_degen(i,1) + j_list = list_degen(i,2) + print*,'Huge angle !!! == ',angle_left_right(list_degen(i,1)),angle_left_right(list_degen(i,2)) + print*,'i_list = ',i_list + print*,'i_list = ',j_list + print*,'Swapping left/right orbitals' + call print_strong_overlap(i_list, j_list) + mo_r_coef_tmp(1:ao_num,1) = mo_r_coef_new(1:ao_num,i_list) + mo_r_coef_tmp(1:ao_num,2) = mo_l_coef(1:ao_num,i_list) + mo_l_coef_tmp(1:ao_num,1) = mo_l_coef(1:ao_num,j_list) + mo_l_coef_tmp(1:ao_num,2) = mo_r_coef_new(1:ao_num,j_list) else - do j = 1, n_degen - print*,'i_list = ',list_degen(i,j) - mo_r_coef_tmp(1:ao_num,j) = mo_r_coef_new(1:ao_num,list_degen(i,j)) - mo_l_coef_tmp(1:ao_num,j) = mo_l_coef(1:ao_num,list_degen(i,j)) - enddo + do j = 1, n_degen + print*,'i_list = ',list_degen(i,j) + mo_r_coef_tmp(1:ao_num,j) = mo_r_coef_new(1:ao_num,list_degen(i,j)) + mo_l_coef_tmp(1:ao_num,j) = mo_l_coef(1:ao_num,list_degen(i,j)) + enddo endif print*,'Right orbitals ' - do j = 1, n_degen - write(*,'(100(F16.10,X))')mo_r_coef_tmp(1:ao_num,j) - enddo + do j = 1, n_degen + write(*,'(1000(F16.10,X))') mo_r_coef_tmp(1:ao_num,j) + enddo print*,'Left orbitals ' - do j = 1, n_degen - write(*,'(100(F16.10,X))')mo_l_coef_tmp(1:ao_num,j) - enddo + do j = 1, n_degen + write(*,'(100(F16.10,X))') mo_l_coef_tmp(1:ao_num,j) + enddo ! Orthogonalization of right functions print *, ' Orthogonalization of RIGHT functions' print *, ' ------------------------------------' diff --git a/src/tools/print_detweights.irp.f b/src/tools/print_detweights.irp.f index d5b0f2c9..5e5f2bb1 100644 --- a/src/tools/print_detweights.irp.f +++ b/src/tools/print_detweights.irp.f @@ -5,7 +5,8 @@ program print_detweights read_wf = .True. touch read_wf - call main() + call print_exc() + !call main() end @@ -41,6 +42,7 @@ subroutine main() do i = 1, N_det deg_sorted(i) = deg(ii(i)) + print *, deg_sorted(i), c(i) enddo print *, ' saving psi' @@ -52,7 +54,7 @@ subroutine main() print *, ' Error opening file!' stop endif - + write(10) N_det write(10) deg_sorted write(10) c @@ -63,4 +65,33 @@ subroutine main() end +! --- + +subroutine print_exc() + + implicit none + + integer :: i + integer, allocatable :: deg(:) + + PROVIDE N_int + PROVIDE N_det + PROVIDE psi_det + + allocate(deg(N_det)) + + do i = 1, N_det + call get_excitation_degree(psi_det(1,1,1), psi_det(1,1,i), deg(i), N_int) + enddo + + open(unit=10, file="exc.dat", action="write") + write(10,*) N_det + write(10,*) deg + close(10) + + deallocate(deg) + +end + + diff --git a/src/utils/block_diag_degen.irp.f b/src/utils/block_diag_degen.irp.f index 188bfa58..1a9ca8d6 100644 --- a/src/utils/block_diag_degen.irp.f +++ b/src/utils/block_diag_degen.irp.f @@ -191,7 +191,7 @@ subroutine give_degen_full_list(A, n, thr, list_degen, n_degen_list) list_degen(n_degen_list,1) = i icount = 1 do j = i+1, n - if(dabs(A(i)-A(j)).lt.thr.and.is_ok(j)) then + if(dabs(A(i)-A(j)).lt.thr .and. is_ok(j)) then is_ok(j) = .False. icount += 1 list_degen(n_degen_list,icount) = j From f8bff471222ac9cd2e6f23342f7d7a7aff5d62cd Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Thu, 28 Mar 2024 15:27:11 +0100 Subject: [PATCH 16/50] added loops --- .../local/non_h_ints_mu/total_tc_int.irp.f | 165 +++++++++++++----- 1 file changed, 121 insertions(+), 44 deletions(-) diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f index c7230dc3..72fd0f53 100644 --- a/plugins/local/non_h_ints_mu/total_tc_int.irp.f +++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f @@ -65,27 +65,59 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n PROVIDE int2_grad1_u12_square_ao - allocate(c_mat(n_points_final_grid,ao_num,ao_num)) + if(tc_save_mem) then - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, k, ipoint) & - !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector) - !$OMP DO SCHEDULE (static) - do i = 1, ao_num - do k = 1, ao_num - do ipoint = 1, n_points_final_grid - c_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k) + print*, ' LOOPS are used to evaluate Hermitian part of ao_two_e_tc_tot ...' + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, k, l, ipoint, ao_i_r, ao_k_r, weight1) & + !$OMP SHARED (ao_num, n_points_final_grid, ao_two_e_tc_tot, & + !$OMP aos_in_r_array_transp, final_weight_at_r_vector, int2_grad1_u12_square_ao) + !$OMP DO COLLAPSE(4) + do i = 1, ao_num + do k = 1, ao_num + do l = 1, ao_num + do j = 1, ao_num + ao_two_e_tc_tot(j,l,k,i) = 0.d0 + do ipoint = 1, n_points_final_grid + weight1 = final_weight_at_r_vector(ipoint) + ao_i_r = aos_in_r_array_transp(ipoint,i) + ao_k_r = aos_in_r_array_transp(ipoint,k) + ao_two_e_tc_tot(j,l,k,i) = ao_two_e_tc_tot(j,l,k,i) + int2_grad1_u12_square_ao(j,l,ipoint) * weight1 * ao_i_r * ao_k_r + enddo + enddo + enddo enddo enddo - enddo - !$OMP END DO - !$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL - call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & - , int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid & - , 0.d0, ao_two_e_tc_tot, ao_num*ao_num) + else + print*, ' DGEMM are used to evaluate Hermitian part of ao_two_e_tc_tot ...' + + allocate(c_mat(n_points_final_grid,ao_num,ao_num)) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, k, ipoint) & + !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid + c_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & + , int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid & + , 0.d0, ao_two_e_tc_tot, ao_num*ao_num) + deallocate(c_mat) + endif + FREE int2_grad1_u12_square_ao if( (tc_integ_type .eq. "semi-analytic") .and. & @@ -96,6 +128,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n ! an additional term is added here directly instead of ! being added in int2_grad1_u12_square_ao for performance + allocate(c_mat(n_points_final_grid,ao_num,ao_num)) PROVIDE int2_u2_env2 !$OMP PARALLEL & @@ -127,10 +160,13 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n , int2_u2_env2(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid & , 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num) + deallocate(c_mat) FREE int2_u2_env2 endif ! use_ipp - deallocate(c_mat) + call wall_time(time1) + print*, ' done with Hermitian part after (min) ', (time1 - time0) / 60.d0 + call print_memory_usage() ! --- @@ -138,38 +174,73 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n PROVIDE int2_grad1_u12_ao - allocate(b_mat(n_points_final_grid,ao_num,ao_num,3)) + if(tc_save_mem) then - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & - !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, & - !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector) - !$OMP DO SCHEDULE (static) - do i = 1, ao_num - do k = 1, ao_num - do ipoint = 1, n_points_final_grid + print*, ' LOOPS are used to evaluate non-Hermitian part of ao_two_e_tc_tot ...' - weight1 = 0.5d0 * final_weight_at_r_vector(ipoint) - ao_i_r = aos_in_r_array_transp(ipoint,i) - ao_k_r = aos_in_r_array_transp(ipoint,k) - - b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) - b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) - b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, k, l, ipoint, ao_i_r, ao_k_r, weight1) & + !$OMP SHARED (ao_num, n_points_final_grid, ao_two_e_tc_tot, & + !$OMP aos_in_r_array_transp, final_weight_at_r_vector, & + !$OMP int2_grad1_u12_ao, aos_grad_in_r_array_transp_bis) + !$OMP DO COLLAPSE(4) + do i = 1, ao_num + do k = 1, ao_num + do l = 1, ao_num + do j = 1, ao_num + do ipoint = 1, n_points_final_grid + weight1 = 0.5d0 * final_weight_at_r_vector(ipoint) + ao_i_r = aos_in_r_array_transp(ipoint,i) + ao_k_r = aos_in_r_array_transp(ipoint,k) + ao_two_e_tc_tot(j,l,k,i) = ao_two_e_tc_tot(j,l,k,i) & + + weight1 * int2_grad1_u12_ao(j,l,ipoint,1) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) & + + weight1 * int2_grad1_u12_ao(j,l,ipoint,2) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) & + + weight1 * int2_grad1_u12_ao(j,l,ipoint,3) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) + enddo + enddo + enddo enddo enddo - enddo - !$OMP END DO - !$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL - do m = 1, 3 - call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 & - , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid & - , 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num) - enddo - deallocate(b_mat) + else + print*, ' DGEMM are used to evaluate non-Hermitian part of ao_two_e_tc_tot ...' + + allocate(b_mat(n_points_final_grid,ao_num,ao_num,3)) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & + !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, & + !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid + + weight1 = 0.5d0 * final_weight_at_r_vector(ipoint) + ao_i_r = aos_in_r_array_transp(ipoint,i) + ao_k_r = aos_in_r_array_transp(ipoint,k) + + b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) + b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) + b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do m = 1, 3 + call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 & + , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid & + , 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num) + enddo + deallocate(b_mat) + + end if FREE int2_grad1_u12_ao if(tc_integ_type .eq. "semi-analytic") then @@ -178,16 +249,22 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n endif ! var_tc + call wall_time(time1) + print*, ' done with non-Hermitian part after (min) ', (time1 - time0) / 60.d0 + call print_memory_usage() + ! --- call sum_A_At(ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num) + ! --- + PROVIDE ao_integrals_map !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) & !$OMP PRIVATE(i, j, k, l) - !$OMP DO + !$OMP DO COLLAPSE(4) do j = 1, ao_num do l = 1, ao_num do i = 1, ao_num From 002aff90f5e6ecd7a4929eb48e75608d94f9e3a8 Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Thu, 28 Mar 2024 17:05:00 +0100 Subject: [PATCH 17/50] working on mem reduction --- .../local/non_h_ints_mu/total_tc_int.irp.f | 98 ++++++++++++------- plugins/local/tc_keywords/EZFIO.cfg | 6 ++ 2 files changed, 67 insertions(+), 37 deletions(-) diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f index 72fd0f53..b8379006 100644 --- a/plugins/local/non_h_ints_mu/total_tc_int.irp.f +++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f @@ -33,8 +33,10 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n double precision :: weight1, ao_k_r, ao_i_r double precision :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq double precision :: time0, time1 - double precision, allocatable :: b_mat(:,:,:,:), c_mat(:,:,:) + double precision, allocatable :: c_mat(:,:,:) + logical, external :: ao_two_e_integral_zero double precision, external :: get_ao_two_e_integral + double precision, external :: ao_two_e_integral PROVIDe tc_integ_type PROVIDE env_type @@ -194,9 +196,9 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n ao_i_r = aos_in_r_array_transp(ipoint,i) ao_k_r = aos_in_r_array_transp(ipoint,k) ao_two_e_tc_tot(j,l,k,i) = ao_two_e_tc_tot(j,l,k,i) & - + weight1 * int2_grad1_u12_ao(j,l,ipoint,1) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) & - + weight1 * int2_grad1_u12_ao(j,l,ipoint,2) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) & - + weight1 * int2_grad1_u12_ao(j,l,ipoint,3) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) + - weight1 * int2_grad1_u12_ao(j,l,ipoint,1) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) & + - weight1 * int2_grad1_u12_ao(j,l,ipoint,2) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) & + - weight1 * int2_grad1_u12_ao(j,l,ipoint,3) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) enddo enddo enddo @@ -209,39 +211,37 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n print*, ' DGEMM are used to evaluate non-Hermitian part of ao_two_e_tc_tot ...' - allocate(b_mat(n_points_final_grid,ao_num,ao_num,3)) - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & - !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, & - !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector) - !$OMP DO SCHEDULE (static) - do i = 1, ao_num - do k = 1, ao_num - do ipoint = 1, n_points_final_grid + allocate(c_mat(n_points_final_grid,ao_num,ao_num)) + do m = 1, 3 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & + !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, c_mat, & + !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector, m) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid - weight1 = 0.5d0 * final_weight_at_r_vector(ipoint) - ao_i_r = aos_in_r_array_transp(ipoint,i) - ao_k_r = aos_in_r_array_transp(ipoint,k) + weight1 = 0.5d0 * final_weight_at_r_vector(ipoint) + ao_i_r = aos_in_r_array_transp(ipoint,i) + ao_k_r = aos_in_r_array_transp(ipoint,k) - b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) - b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) - b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) + c_mat(ipoint,k,i) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,m) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,m)) + enddo enddo enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - do m = 1, 3 - call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 & - , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid & + !$OMP END DO + !$OMP END PARALLEL + + call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 & + , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid & , 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num) enddo - deallocate(b_mat) + deallocate(c_mat) end if - FREE int2_grad1_u12_ao + !FREE int2_grad1_u12_ao if(tc_integ_type .eq. "semi-analytic") then FREE int2_grad1_u2e_ao @@ -258,19 +258,26 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n call sum_A_At(ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num) ! --- + + logical :: integ_zero + double precision :: integ_val - PROVIDE ao_integrals_map + print*, ' adding ERI to ao_two_e_tc_tot ...' - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) & - !$OMP PRIVATE(i, j, k, l) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i, j, k, l, integ_zero, integ_val) & + !$OMP SHARED(ao_num, ao_two_e_tc_tot) !$OMP DO COLLAPSE(4) do j = 1, ao_num do l = 1, ao_num do i = 1, ao_num do k = 1, ao_num - ! < 1:i, 2:j | 1:k, 2:l > - ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map) + integ_zero = ao_two_e_integral_zero(i,j,k,l) + if(.not. integ_zero) then + ! i,k : r1 j,l : r2 + integ_val = ao_two_e_integral(i,k,j,l) + ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + integ_val + endif enddo enddo enddo @@ -278,8 +285,25 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n !$OMP END DO !$OMP END PARALLEL - !call clear_ao_map() - FREE ao_integrals_map + !PROVIDE ao_integrals_map + !!$OMP PARALLEL DEFAULT(NONE) & + !!$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) & + !!$OMP PRIVATE(i, j, k, l) + !!$OMP DO COLLAPSE(4) + !do j = 1, ao_num + ! do l = 1, ao_num + ! do i = 1, ao_num + ! do k = 1, ao_num + ! ! < 1:i, 2:j | 1:k, 2:l > + ! ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map) + ! enddo + ! enddo + ! enddo + !enddo + !!$OMP END DO + !!$OMP END PARALLEL + !!call clear_ao_map() + !FREE ao_integrals_map if(tc_integ_type .eq. "numeric") then FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg index a8491660..24362796 100644 --- a/plugins/local/tc_keywords/EZFIO.cfg +++ b/plugins/local/tc_keywords/EZFIO.cfg @@ -286,4 +286,10 @@ doc: If |true|, memory scale of TC ao -> mo: O(N3) interface: ezfio,provider,ocaml default: False +[tc_save_mem] +type: logical +doc: If |true|, use loops to save memory TC +interface: ezfio,provider,ocaml +default: False + From 1a36d974b0bd5cd0c06453a15c96a8492c4baecc Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Sun, 7 Apr 2024 00:33:09 +0200 Subject: [PATCH 18/50] saving lcpq-ampere --- .../local/bi_ort_ints/semi_num_ints_mo.irp.f | 68 ++++--- .../bi_ort_ints/three_body_ints_bi_ort.irp.f | 2 +- .../local/bi_ort_ints/total_twoe_pot.irp.f | 87 ++++----- plugins/local/non_h_ints_mu/tc_integ.irp.f | 175 ++++++++++++++++-- .../local/non_h_ints_mu/total_tc_int.irp.f | 93 +++++----- plugins/local/tc_keywords/EZFIO.cfg | 8 +- .../local/tc_scf/fock_3e_bi_ortho_cs.irp.f | 121 +++++++----- .../local/tc_scf/fock_3e_bi_ortho_uhf.irp.f | 2 +- plugins/local/tc_scf/fock_tc.irp.f | 2 +- .../local/tc_scf/write_ao_2e_tc_integ.irp.f | 58 ++++++ .../multi_s_dipole_moment.irp.f | 22 ++- 11 files changed, 442 insertions(+), 196 deletions(-) create mode 100644 plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f diff --git a/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f b/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f index 51f0cba4..77e4cb9b 100644 --- a/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f +++ b/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f @@ -107,8 +107,8 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3, integer :: i, j, ipoint double precision :: wall0, wall1 - print *, ' providing int2_grad1_u12_ao_transp ...' - call wall_time(wall0) + !print *, ' providing int2_grad1_u12_ao_transp ...' + !call wall_time(wall0) if(test_cycle_tc) then @@ -142,15 +142,15 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3, endif - call wall_time(wall1) - print *, ' wall time for int2_grad1_u12_ao_transp ', wall1 - wall0 - call print_memory_usage() + !call wall_time(wall1) + !print *, ' wall time for int2_grad1_u12_ao_transp (min) = ', (wall1 - wall0) / 60.d0 + !call print_memory_usage() END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)] +BEGIN_PROVIDER [double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)] implicit none integer :: ipoint @@ -159,7 +159,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, PROVIDE mo_l_coef mo_r_coef PROVIDE int2_grad1_u12_ao_transp - !print *, ' providing int2_grad1_u12_bimo_transp' + !print *, ' providing int2_grad1_u12_bimo_transp ...' !call wall_time(wall0) !$OMP PARALLEL & @@ -167,33 +167,35 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, !$OMP PRIVATE (ipoint) & !$OMP SHARED (n_points_final_grid,int2_grad1_u12_ao_transp,int2_grad1_u12_bimo_transp) !$OMP DO SCHEDULE (dynamic) - do ipoint = 1, n_points_final_grid - call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,1,ipoint), size(int2_grad1_u12_ao_transp , 1) & - , int2_grad1_u12_bimo_transp(1,1,1,ipoint), size(int2_grad1_u12_bimo_transp, 1) ) - call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,2,ipoint), size(int2_grad1_u12_ao_transp , 1) & - , int2_grad1_u12_bimo_transp(1,1,2,ipoint), size(int2_grad1_u12_bimo_transp, 1) ) - call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,3,ipoint), size(int2_grad1_u12_ao_transp , 1) & - , int2_grad1_u12_bimo_transp(1,1,3,ipoint), size(int2_grad1_u12_bimo_transp, 1) ) - enddo + do ipoint = 1, n_points_final_grid + call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,1,ipoint), size(int2_grad1_u12_ao_transp , 1) & + , int2_grad1_u12_bimo_transp(1,1,1,ipoint), size(int2_grad1_u12_bimo_transp, 1) ) + call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,2,ipoint), size(int2_grad1_u12_ao_transp , 1) & + , int2_grad1_u12_bimo_transp(1,1,2,ipoint), size(int2_grad1_u12_bimo_transp, 1) ) + call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,3,ipoint), size(int2_grad1_u12_ao_transp , 1) & + , int2_grad1_u12_bimo_transp(1,1,3,ipoint), size(int2_grad1_u12_bimo_transp, 1) ) + enddo !$OMP END DO !$OMP END PARALLEL + !FREE int2_grad1_u12_ao_transp + !call wall_time(wall1) - !print *, ' Wall time for providing int2_grad1_u12_bimo_transp',wall1 - wall0 + !print *, ' wall time for int2_grad1_u12_bimo_transp (min) =', (wall1 - wall0) / 60.d0 !call print_memory_usage() END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, 3, mo_num, mo_num)] +BEGIN_PROVIDER [double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, 3, mo_num, mo_num)] implicit none integer :: i, j, ipoint double precision :: wall0, wall1 !call wall_time(wall0) - !print *, ' Providing int2_grad1_u12_bimo_t ...' + !print *, ' providing int2_grad1_u12_bimo_t ...' PROVIDE mo_l_coef mo_r_coef PROVIDE int2_grad1_u12_bimo_transp @@ -211,17 +213,21 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, FREE int2_grad1_u12_bimo_transp !call wall_time(wall1) - !print *, ' wall time for int2_grad1_u12_bimo_t,', wall1 - wall0 + !print *, ' wall time for int2_grad1_u12_bimo_t (min) =', (wall1 - wall0) / 60.d0 !call print_memory_usage() END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, ao_num, ao_num)] +BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, ao_num, ao_num)] implicit none - integer :: i, j, ipoint + integer :: i, j, ipoint + double precision :: wall0, wall1 + + !call wall_time(wall0) + !print *, ' providing int2_grad1_u12_ao_t ...' PROVIDE int2_grad1_u12_ao @@ -235,6 +241,10 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, enddo enddo + !call wall_time(wall1) + !print *, ' wall time for int2_grad1_u12_ao_t (min) =', (wall1 - wall0) / 60.d0 + !call print_memory_usage() + END_PROVIDER ! --- @@ -275,8 +285,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid, double precision :: xyz double precision :: wall0, wall1 - print*, ' providing x_W_ki_bi_ortho_erf_rk ...' - call wall_time(wall0) + !print*, ' providing x_W_ki_bi_ortho_erf_rk ...' + !call wall_time(wall0) !$OMP PARALLEL & !$OMP DEFAULT (NONE) & @@ -300,8 +310,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid, ! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu_transp ! FREE mo_x_v_ki_bi_ortho_erf_rk_cst_mu_transp - call wall_time(wall1) - print *, ' time to provide x_W_ki_bi_ortho_erf_rk = ', wall1 - wall0 + !call wall_time(wall1) + !print *, ' time to provide x_W_ki_bi_ortho_erf_rk = ', wall1 - wall0 END_PROVIDER @@ -323,8 +333,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk_diag, (n_points_final_ double precision :: xyz double precision :: wall0, wall1 - print*,'providing x_W_ki_bi_ortho_erf_rk_diag ...' - call wall_time(wall0) + !print*,'providing x_W_ki_bi_ortho_erf_rk_diag ...' + !call wall_time(wall0) !$OMP PARALLEL & !$OMP DEFAULT (NONE) & @@ -343,8 +353,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk_diag, (n_points_final_ !$OMP END DO !$OMP END PARALLEL - call wall_time(wall1) - print*,'time to provide x_W_ki_bi_ortho_erf_rk_diag = ',wall1 - wall0 + !call wall_time(wall1) + !print*,'time to provide x_W_ki_bi_ortho_erf_rk_diag = ',wall1 - wall0 END_PROVIDER diff --git a/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f b/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f index 726e48ba..fd4a162f 100644 --- a/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f +++ b/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f @@ -168,7 +168,7 @@ subroutine give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral) integral = integral + tmp * final_weight_at_r_vector(ipoint) enddo -end subroutine give_integrals_3_body_bi_ort +end ! --- diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f index 1e558038..e34a7b7b 100644 --- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f +++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f @@ -16,10 +16,10 @@ double precision function bi_ortho_mo_ints(l, k, j, i) integer :: m, n, p, q bi_ortho_mo_ints = 0.d0 - do m = 1, ao_num - do p = 1, ao_num - do n = 1, ao_num - do q = 1, ao_num + do p = 1, ao_num + do m = 1, ao_num + do q = 1, ao_num + do n = 1, ao_num ! p1h1p2h2 l1 l2 r1 r2 bi_ortho_mo_ints += ao_two_e_tc_tot(n,q,m,p) * mo_l_coef(m,l) * mo_l_coef(n,k) * mo_r_coef(p,j) * mo_r_coef(q,i) enddo @@ -27,7 +27,7 @@ double precision function bi_ortho_mo_ints(l, k, j, i) enddo enddo -end function bi_ortho_mo_ints +end ! --- @@ -43,93 +43,68 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, integer :: i, j, k, l, m, n, p, q, s, r double precision :: t1, t2, tt1, tt2 double precision, allocatable :: a1(:,:,:,:), a2(:,:,:,:) - double precision, allocatable :: a_jkp(:,:,:), a_kpq(:,:,:), a_pqr(:,:,:) + double precision, allocatable :: a_jkp(:,:,:), a_kpq(:,:,:), ao_two_e_tc_tot_tmp(:,:,:) print *, ' PROVIDING mo_bi_ortho_tc_two_e_chemist ...' call wall_time(t1) call print_memory_usage() PROVIDE mo_r_coef mo_l_coef - PROVIDE ao_two_e_tc_tot if(ao_to_mo_tc_n3) then print*, ' memory scale of TC ao -> mo: O(N3) ' + if(.not.read_tc_integ) then + stop 'read_tc_integ needs to be set to true' + endif + allocate(a_jkp(ao_num,ao_num,mo_num)) allocate(a_kpq(ao_num,mo_num,mo_num)) - allocate(a_pqr(mo_num,mo_num,mo_num)) + allocate(ao_two_e_tc_tot_tmp(ao_num,ao_num,ao_num)) + + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="read") call wall_time(tt1) - do s = 1, mo_num + mo_bi_ortho_tc_two_e_chemist(:,:,:,:) = 0.d0 + do l = 1, ao_num + read(11) ao_two_e_tc_tot_tmp(:,:,:) - mo_bi_ortho_tc_two_e_chemist(:,:,:,s) = 0.d0 - do l = 1, ao_num + do s = 1, mo_num - call dgemm( 'T', 'N', ao_num*ao_num, mo_num, ao_num, 1.d0 & - , ao_two_e_tc_tot(1,1,1,l), ao_num, mo_l_coef(1,1), ao_num & + call dgemm( 'T', 'N', ao_num*ao_num, mo_num, ao_num, 1.d0 & + , ao_two_e_tc_tot_tmp(1,1,1), ao_num, mo_l_coef(1,1), ao_num & , 0.d0, a_jkp(1,1,1), ao_num*ao_num) - + call dgemm( 'T', 'N', ao_num*mo_num, mo_num, ao_num, 1.d0 & , a_jkp(1,1,1), ao_num, mo_r_coef(1,1), ao_num & , 0.d0, a_kpq(1,1,1), ao_num*mo_num) - - call dgemm( 'T', 'N', mo_num*mo_num, mo_num, ao_num, 1.d0 & - , a_kpq(1,1,1), ao_num, mo_l_coef(1,1), ao_num & - , 0.d0, a_pqr(1,1,1), mo_num*mo_num) - !$OMP PARALLEL & - !$OMP DEFAULT(NONE) & - !$OMP PRIVATE(p, q, r) & - !$OMP SHARED(s, l, mo_num, mo_bi_ortho_tc_two_e_chemist, mo_r_coef, a_pqr) - !$OMP DO COLLAPSE(2) - do p = 1, mo_num - do q = 1, mo_num - do r = 1, mo_num - mo_bi_ortho_tc_two_e_chemist(p,q,r,s) = mo_bi_ortho_tc_two_e_chemist(p,q,r,s) + mo_r_coef(l,s) * a_pqr(p,q,r) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL + call dgemm( 'T', 'N', mo_num*mo_num, mo_num, ao_num, mo_r_coef(l,s) & + , a_kpq(1,1,1), ao_num, mo_l_coef(1,1), ao_num & + , 1.d0, mo_bi_ortho_tc_two_e_chemist(1,1,1,s), mo_num*mo_num) - enddo ! l + enddo ! s - if(s == 2) then + if(l == 2) then call wall_time(tt2) print*, ' 1 / mo_num done in (min)', (tt2-tt1)/60.d0 print*, ' estimated time required (min)', dble(mo_num-1)*(tt2-tt1)/60.d0 - elseif(s == 11) then + elseif(l == 11) then call wall_time(tt2) print*, ' 10 / mo_num done in (min)', (tt2-tt1)/60.d0 print*, ' estimated time required (min)', dble(mo_num-10)*(tt2-tt1)/(60.d0*10.d0) - elseif(s == 26) then - call wall_time(tt2) - print*, ' 25 / mo_num done in (min)', (tt2-tt1)/60.d0 - print*, ' estimated time required (min)', dble(mo_num-25)*(tt2-tt1)/(60.d0*25.d0) - elseif(s == 51) then - call wall_time(tt2) - print*, ' 50 / mo_num done in (min)', (tt2-tt1)/60.d0 - print*, ' estimated time required (min)', dble(mo_num-50)*(tt2-tt1)/(60.d0*50.d0) - elseif(s == 101) then + elseif(l == 101) then call wall_time(tt2) print*, ' 100 / mo_num done in (min)', (tt2-tt1)/60.d0 print*, ' estimated time required (min)', dble(mo_num-100)*(tt2-tt1)/(60.d0*100.d0) - elseif(s == 201) then - call wall_time(tt2) - print*, ' 200 / mo_num done in (min)', (tt2-tt1)/60.d0 - print*, ' estimated time required (min)', dble(mo_num-200)*(tt2-tt1)/(60.d0*200.d0) - elseif(s == 501) then - call wall_time(tt2) - print*, ' 500 / mo_num done in (min)', (tt2-tt1)/60.d0 - print*, ' estimated time required (min)', dble(mo_num-500)*(tt2-tt1)/(60.d0*500.d0) endif + enddo ! l + close(11) - enddo ! s - - deallocate(a_jkp, a_kpq, a_pqr) + deallocate(a_jkp, a_kpq, ao_two_e_tc_tot_tmp) else @@ -141,6 +116,8 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, , ao_two_e_tc_tot(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) + FREE ao_two_e_tc_tot + 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 & diff --git a/plugins/local/non_h_ints_mu/tc_integ.irp.f b/plugins/local/non_h_ints_mu/tc_integ.irp.f index 775a9e4c..58e3db48 100644 --- a/plugins/local/non_h_ints_mu/tc_integ.irp.f +++ b/plugins/local/non_h_ints_mu/tc_integ.irp.f @@ -44,14 +44,92 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_f elseif(tc_integ_type .eq. "numeric") then print *, ' Numerical integration over r1 and r2 will be performed' - - ! TODO combine 1shot & int2_grad1_u12_ao_num - PROVIDE int2_grad1_u12_ao_num - int2_grad1_u12_ao = int2_grad1_u12_ao_num + if(tc_save_mem) then - !PROVIDE int2_grad1_u12_ao_num_1shot - !int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot + integer :: n_blocks, n_rest, n_pass + integer :: i_blocks, i_rest, i_pass, ii + double precision :: mem, n_double + double precision, allocatable :: tmp(:,:,:), xx(:) + double precision, allocatable :: tmp_grad1_u12(:,:,:) + + PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra + + allocate(tmp(n_points_extra_final_grid,ao_num,ao_num), xx(n_points_extra_final_grid)) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (j, i, jpoint) & + !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp) + !$OMP DO COLLAPSE(2) + do j = 1, ao_num + do i = 1, ao_num + do jpoint = 1, n_points_extra_final_grid + tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call total_memory(mem) + mem = max(1.d0, qp_max_mem - mem) + n_double = mem * 1.d8 + n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid)) + n_rest = int(mod(n_points_final_grid, n_blocks)) + n_pass = int((n_points_final_grid - n_rest) / n_blocks) + call write_int(6, n_pass, 'Number of passes') + call write_int(6, n_blocks, 'Size of the blocks') + call write_int(6, n_rest, 'Size of the last block') + allocate(tmp_grad1_u12(n_points_extra_final_grid,n_blocks,3)) + 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, final_grid_points, xx, tmp_grad1_u12) + !$OMP DO + do i_blocks = 1, n_blocks + ipoint = ii - 1 + i_blocks ! r1 + call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1), tmp_grad1_u12(1,i_blocks,2), tmp_grad1_u12(1,i_blocks,3), xx(1)) + 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 & + , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid & + , 0.d0, int2_grad1_u12_ao(1,1,ii,m), ao_num*ao_num) + enddo + enddo + deallocate(tmp_grad1_u12) + if(n_rest .gt. 0) then + 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, final_grid_points, xx, tmp_grad1_u12) + !$OMP DO + do i_rest = 1, n_rest + ipoint = ii - 1 + i_rest ! r1 + call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1), tmp_grad1_u12(1,i_rest,2), tmp_grad1_u12(1,i_rest,3), xx(1)) + 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 & + , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid & + , 0.d0, int2_grad1_u12_ao(1,1,ii,m), ao_num*ao_num) + enddo + deallocate(tmp_grad1_u12) + endif + deallocate(tmp,xx) + + else + ! TODO combine 1shot & int2_grad1_u12_ao_num + PROVIDE int2_grad1_u12_ao_num + int2_grad1_u12_ao = int2_grad1_u12_ao_num + !PROVIDE int2_grad1_u12_ao_num_1shot + !int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot + endif elseif(tc_integ_type .eq. "semi-analytic") then @@ -177,13 +255,88 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_p print *, ' Numerical integration over r1 and r2 will be performed' - ! TODO combine 1shot & int2_grad1_u12_square_ao_num + if(tc_save_mem) then - PROVIDE int2_grad1_u12_square_ao_num - int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num + integer :: n_blocks, n_rest, n_pass + integer :: i_blocks, i_rest, i_pass, ii + double precision :: mem, n_double + double precision, allocatable :: tmp(:,:,:), xx(:,:,:) + double precision, allocatable :: tmp_grad1_u12_squared(:,:) - !PROVIDE int2_grad1_u12_square_ao_num_1shot - !int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot + PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra + + allocate(tmp(n_points_extra_final_grid,ao_num,ao_num)) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (j, i, jpoint) & + !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp) + !$OMP DO COLLAPSE(2) + do j = 1, ao_num + do i = 1, ao_num + do jpoint = 1, n_points_extra_final_grid + tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + call total_memory(mem) + mem = max(1.d0, qp_max_mem - mem) + n_double = mem * 1.d8 + n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid)) + n_rest = int(mod(n_points_final_grid, n_blocks)) + n_pass = int((n_points_final_grid - n_rest) / n_blocks) + call write_int(6, n_pass, 'Number of passes') + call write_int(6, n_blocks, 'Size of the blocks') + call write_int(6, n_rest, 'Size of the last block') + allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_blocks), xx(n_points_extra_final_grid,n_blocks,3)) + 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, xx, final_grid_points, 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(ipoint, n_points_extra_final_grid, xx(1,i_blocks,1), xx(1,i_blocks,2), xx(1,i_blocks,3), tmp_grad1_u12_squared(1,i_blocks)) + enddo + !$OMP END DO + !$OMP END PARALLEL + call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, -0.5d0 & + , 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(1,1,ii), ao_num*ao_num) + enddo + deallocate(tmp_grad1_u12_squared, xx) + if(n_rest .gt. 0) then + ii = n_pass*n_blocks + 1 + allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_rest), xx(n_points_extra_final_grid,n_rest,3)) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i_rest, ipoint) & + !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, xx, final_grid_points, 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(ipoint, n_points_extra_final_grid, xx(1,i_rest,1), xx(1,i_rest,2), xx(1,i_rest,3), tmp_grad1_u12_squared(1,i_rest)) + enddo + !$OMP END DO + !$OMP END PARALLEL + call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, -0.5d0 & + , 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(1,1,ii), ao_num*ao_num) + deallocate(tmp_grad1_u12_squared, xx) + endif + deallocate(tmp) + + else + + ! TODO combine 1shot & int2_grad1_u12_square_ao_num + PROVIDE int2_grad1_u12_square_ao_num + int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num + !PROVIDE int2_grad1_u12_square_ao_num_1shot + !int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot + endif elseif(tc_integ_type .eq. "semi-analytic") then diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f index b8379006..a1bbd6e0 100644 --- a/plugins/local/non_h_ints_mu/total_tc_int.irp.f +++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f @@ -55,7 +55,9 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n print*, ' Reading ao_two_e_tc_tot from ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot' open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="read") - read(11) ao_two_e_tc_tot + do i = 1, ao_num + read(11) ao_two_e_tc_tot(:,:,:,i) + enddo close(11) else @@ -67,7 +69,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n PROVIDE int2_grad1_u12_square_ao - if(tc_save_mem) then + if(tc_save_mem_loops) then print*, ' LOOPS are used to evaluate Hermitian part of ao_two_e_tc_tot ...' @@ -176,7 +178,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n PROVIDE int2_grad1_u12_ao - if(tc_save_mem) then + if(tc_save_mem_loops) then print*, ' LOOPS are used to evaluate non-Hermitian part of ao_two_e_tc_tot ...' @@ -241,7 +243,6 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n deallocate(c_mat) end if - !FREE int2_grad1_u12_ao if(tc_integ_type .eq. "semi-analytic") then FREE int2_grad1_u2e_ao @@ -264,48 +265,52 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n print*, ' adding ERI to ao_two_e_tc_tot ...' - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i, j, k, l, integ_zero, integ_val) & - !$OMP SHARED(ao_num, ao_two_e_tc_tot) - !$OMP DO COLLAPSE(4) - do j = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do k = 1, ao_num - integ_zero = ao_two_e_integral_zero(i,j,k,l) - if(.not. integ_zero) then - ! i,k : r1 j,l : r2 - integ_val = ao_two_e_integral(i,k,j,l) - ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + integ_val - endif + if(tc_save_mem) then + print*, ' ao_integrals_map will not be used' + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i, j, k, l, integ_zero, integ_val) & + !$OMP SHARED(ao_num, ao_two_e_tc_tot) + !$OMP DO COLLAPSE(4) + do j = 1, ao_num + do l = 1, ao_num + do i = 1, ao_num + do k = 1, ao_num + integ_zero = ao_two_e_integral_zero(i,j,k,l) + if(.not. integ_zero) then + ! i,k : r1 j,l : r2 + integ_val = ao_two_e_integral(i,k,j,l) + ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + integ_val + endif + enddo enddo enddo enddo - enddo - !$OMP END DO - !$OMP END PARALLEL + !$OMP END DO + !$OMP END PARALLEL + else + print*, ' ao_integrals_map will be used' + PROVIDE ao_integrals_map + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) & + !$OMP PRIVATE(i, j, k, l) + !$OMP DO COLLAPSE(4) + do j = 1, ao_num + do l = 1, ao_num + do i = 1, ao_num + do k = 1, ao_num + ! < 1:i, 2:j | 1:k, 2:l > + ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + !call clear_ao_map() + FREE ao_integrals_map + endif - !PROVIDE ao_integrals_map - !!$OMP PARALLEL DEFAULT(NONE) & - !!$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) & - !!$OMP PRIVATE(i, j, k, l) - !!$OMP DO COLLAPSE(4) - !do j = 1, ao_num - ! do l = 1, ao_num - ! do i = 1, ao_num - ! do k = 1, ao_num - ! ! < 1:i, 2:j | 1:k, 2:l > - ! ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map) - ! enddo - ! enddo - ! enddo - !enddo - !!$OMP END DO - !!$OMP END PARALLEL - !!call clear_ao_map() - !FREE ao_integrals_map - - if(tc_integ_type .eq. "numeric") then + if((tc_integ_type .eq. "numeric") .and. (.not. tc_save_mem)) then FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num endif @@ -315,7 +320,9 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n print*, ' Saving ao_two_e_tc_tot in ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot' open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="write") call ezfio_set_work_empty(.False.) - write(11) ao_two_e_tc_tot + do i = 1, ao_num + write(11) ao_two_e_tc_tot(:,:,:,i) + enddo close(11) call ezfio_set_tc_keywords_io_tc_integ('Read') endif diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg index 24362796..70169189 100644 --- a/plugins/local/tc_keywords/EZFIO.cfg +++ b/plugins/local/tc_keywords/EZFIO.cfg @@ -286,10 +286,16 @@ doc: If |true|, memory scale of TC ao -> mo: O(N3) interface: ezfio,provider,ocaml default: False -[tc_save_mem] +[tc_save_mem_loops] type: logical doc: If |true|, use loops to save memory TC interface: ezfio,provider,ocaml default: False +[tc_save_mem] +type: logical +doc: If |true|, more calc but less mem +interface: ezfio,provider,ocaml +default: False + diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f index 0b883865..8fd5e5b6 100644 --- a/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f +++ b/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f @@ -9,7 +9,7 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)] 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(:,:,:,:) + double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:), tmp_22(:,:,:) double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:) PROVIDE mo_l_coef mo_r_coef @@ -63,17 +63,13 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)] 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) & @@ -112,58 +108,81 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)] ! --- - allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num)) + if(tc_save_mem) then - !$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, & - !$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 + 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_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) ) + 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 - enddo - !$OMP END DO - !$OMP END PARALLEL + !$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 - 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_1, tmp_2) + deallocate(tmp_1) ! --- @@ -272,7 +291,7 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)] ! --- !call wall_time(tf) - !print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti + !print *, ' total Wall time for fock_3e_uhf_mo_cs =', (tf - ti) / 60.d0 END_PROVIDER diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f index 63a1e162..47ee5b48 100644 --- a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f +++ b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f @@ -32,7 +32,7 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)] endif !call wall_time(tf) - !print *, ' Wall time for fock_3e_uhf_mo_a =', tf - ti + !print *, ' Wall time for fock_3e_uhf_mo_a (min) =', (tf - ti)/60.d0 END_PROVIDER diff --git a/plugins/local/tc_scf/fock_tc.irp.f b/plugins/local/tc_scf/fock_tc.irp.f index 282f9873..d3ddb8ad 100644 --- a/plugins/local/tc_scf/fock_tc.irp.f +++ b/plugins/local/tc_scf/fock_tc.irp.f @@ -175,7 +175,7 @@ END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ] +BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)] BEGIN_DOC ! Total alpha TC Fock matrix : h_c + Two-e^TC terms on the MO basis diff --git a/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f b/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f new file mode 100644 index 00000000..7ce57578 --- /dev/null +++ b/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f @@ -0,0 +1,58 @@ +! --- + +program write_ao_2e_tc_integ + + implicit none + + PROVIDE j1e_type + PROVIDE j2e_type + + print *, ' j1e_type = ', j1e_type + print *, ' j2e_type = ', j2e_type + + my_grid_becke = .True. + PROVIDE tc_grid1_a tc_grid1_r + my_n_pt_r_grid = tc_grid1_r + my_n_pt_a_grid = tc_grid1_a + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + 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 + 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 io_tc_integ + + print*, 'io_tc_integ = ', io_tc_integ + + if(io_tc_integ .ne. "Write") then + print*, 'io_tc_integ != Write' + print*, io_tc_integ + stop + endif + + PROVIDE ao_two_e_tc_tot + +end + +! --- + diff --git a/src/mol_properties/multi_s_dipole_moment.irp.f b/src/mol_properties/multi_s_dipole_moment.irp.f index f21e08cd..c7216a61 100644 --- a/src/mol_properties/multi_s_dipole_moment.irp.f +++ b/src/mol_properties/multi_s_dipole_moment.irp.f @@ -102,12 +102,28 @@ END_PROVIDER &BEGIN_PROVIDER [double precision, multi_s_z_dipole_moment_eigenval, (N_states)] implicit none + double precision, allocatable :: eigval(:), eigvec(:,:), A(:,:) PROVIDE multi_s_x_dipole_moment multi_s_y_dipole_moment multi_s_z_dipole_moment - call lapack_diag(multi_s_x_dipole_moment_eigenval(1), multi_s_x_dipole_moment_eigenvec(1,1), multi_s_x_dipole_moment(1,1), N_states, N_states) - call lapack_diag(multi_s_y_dipole_moment_eigenval(1), multi_s_y_dipole_moment_eigenvec(1,1), multi_s_y_dipole_moment(1,1), N_states, N_states) - call lapack_diag(multi_s_z_dipole_moment_eigenval(1), multi_s_z_dipole_moment_eigenvec(1,1), multi_s_z_dipole_moment(1,1), N_states, N_states) + allocate(A(N_states,N_states), eigvec(N_states,N_states), eigval(N_states)) + + A = multi_s_x_dipole_moment + call lapack_diag(eigval(1), eigvec(1,1), A(1,1), N_states, N_states) + multi_s_x_dipole_moment_eigenval = eigval + multi_s_x_dipole_moment_eigenvec = eigvec + + A = multi_s_y_dipole_moment + call lapack_diag(eigval(1), eigvec(1,1), A(1,1), N_states, N_states) + multi_s_y_dipole_moment_eigenval = eigval + multi_s_y_dipole_moment_eigenvec = eigvec + + A = multi_s_z_dipole_moment + call lapack_diag(eigval(1), eigvec(1,1), A(1,1), N_states, N_states) + multi_s_z_dipole_moment_eigenval = eigval + multi_s_z_dipole_moment_eigenvec = eigvec + + deallocate(A, eigvec, eigval) END_PROVIDER From e65d7913bfdf83159ffd50eb39c76e63dea221d5 Mon Sep 17 00:00:00 2001 From: AbdAmmar Date: Sun, 7 Apr 2024 00:43:32 +0200 Subject: [PATCH 19/50] saving lcpq --- bin/qp_convert_output_to_ezfio | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/bin/qp_convert_output_to_ezfio b/bin/qp_convert_output_to_ezfio index 1b33f156..6f2d02d0 100755 --- a/bin/qp_convert_output_to_ezfio +++ b/bin/qp_convert_output_to_ezfio @@ -227,8 +227,8 @@ def write_ezfio(res, filename): shell_index += [nshell_tot] * len(b.prim) shell_num = len(ang_mom) - assert(shell_index[0] = 1) - assert(shell_index[-1] = shell_num) + assert(shell_index[0] == 1) + assert(shell_index[-1] == shell_num) # ~#~#~#~#~ # # W r i t e # From 43b83ee8e9fc93de3675b36cc04592a81c9f33b4 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 9 Apr 2024 12:34:35 +0200 Subject: [PATCH 20/50] Better error message --- scripts/compilation/qp_create_ninja | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/scripts/compilation/qp_create_ninja b/scripts/compilation/qp_create_ninja index e67d896b..75b50c82 100755 --- a/scripts/compilation/qp_create_ninja +++ b/scripts/compilation/qp_create_ninja @@ -802,8 +802,12 @@ if __name__ == "__main__": pickle_path = os.path.join(QP_ROOT, "config", "qp_create_ninja.pickle") if arguments["update"]: + try: with open(pickle_path, 'rb') as handle: arguments = pickle.load(handle) + except FileNotFoundError: + print("\n-----\nError: Please run 'configure -c config/'\n-----\n") + raise elif arguments["create"]: From 4fe07d97b099d96c36192603f2af4f70938b7eb0 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 9 Apr 2024 12:41:53 +0200 Subject: [PATCH 21/50] Added MP2 program --- src/mp2/H_apply.irp.f | 15 +++++++++++++++ src/mp2/NEED | 6 ++++++ src/mp2/README.rst | 4 ++++ src/mp2/mp2.irp.f | 21 +++++++++++++++++++++ 4 files changed, 46 insertions(+) create mode 100644 src/mp2/H_apply.irp.f create mode 100644 src/mp2/NEED create mode 100644 src/mp2/README.rst create mode 100644 src/mp2/mp2.irp.f diff --git a/src/mp2/H_apply.irp.f b/src/mp2/H_apply.irp.f new file mode 100644 index 00000000..471dde50 --- /dev/null +++ b/src/mp2/H_apply.irp.f @@ -0,0 +1,15 @@ +use bitmasks +BEGIN_SHELL [ /usr/bin/env python3 ] +from generate_h_apply import * +from perturbation import perturbations + +s = H_apply("mp2") +s.set_perturbation("Moller_plesset") +#s.set_perturbation("epstein_nesbet") +print(s) + +s = H_apply("mp2_selection") +s.set_selection_pt2("Moller_Plesset") +print(s) +END_SHELL + diff --git a/src/mp2/NEED b/src/mp2/NEED new file mode 100644 index 00000000..6eaf5b93 --- /dev/null +++ b/src/mp2/NEED @@ -0,0 +1,6 @@ +generators_full +selectors_full +determinants +davidson +davidson_undressed +perturbation diff --git a/src/mp2/README.rst b/src/mp2/README.rst new file mode 100644 index 00000000..192a75f1 --- /dev/null +++ b/src/mp2/README.rst @@ -0,0 +1,4 @@ +=== +mp2 +=== + diff --git a/src/mp2/mp2.irp.f b/src/mp2/mp2.irp.f new file mode 100644 index 00000000..b8e0cc4a --- /dev/null +++ b/src/mp2/mp2.irp.f @@ -0,0 +1,21 @@ +program mp2 + call run +end + +subroutine run + implicit none + double precision, allocatable :: pt2(:), norm_pert(:) + double precision :: H_pert_diag, E_old + integer :: N_st, iter + PROVIDE Fock_matrix_diag_mo H_apply_buffer_allocated + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st)) + E_old = HF_energy + call H_apply_mp2(pt2, norm_pert, H_pert_diag, N_st) + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'MP2 = ', pt2 + print *, 'E = ', E_old + print *, 'E+MP2 = ', E_old+pt2 + deallocate(pt2,norm_pert) +end From e35e65ea2ce077434068fdc0e7b04aac4add2536 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 17 Apr 2024 11:40:00 +0200 Subject: [PATCH 22/50] Abs in CCSD --- Makefile | 2 +- src/ccsd/ccsd_t_space_orb_stoch.irp.f | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 0be38b3c..d9c9eb47 100644 --- a/Makefile +++ b/Makefile @@ -2,4 +2,4 @@ default: build.ninja bash -c "source quantum_package.rc ; ninja" build.ninja: - @bash -c ' echo '' ; echo xxxxxxxxxxxxxxxxxx ; echo "The QP is not configured yet. Please run the ./configure command" ; echo xxxxxxxxxxxxxxxxxx ; echo '' ; ./configure --help' | more + @bash -c ' echo '' ; echo xxxxxxxxxxxxxxxxxx ; echo "QP is not configured yet. Please run the ./configure command" ; echo xxxxxxxxxxxxxxxxxx ; echo '' ; ./configure --help' | more diff --git a/src/ccsd/ccsd_t_space_orb_stoch.irp.f b/src/ccsd/ccsd_t_space_orb_stoch.irp.f index 618d50e4..2aa134d1 100644 --- a/src/ccsd/ccsd_t_space_orb_stoch.irp.f +++ b/src/ccsd/ccsd_t_space_orb_stoch.irp.f @@ -125,7 +125,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ do b = a+1, nV do c = b+1, nV Nabc = Nabc + 1_8 - Pabc(Nabc) = -1.d0/(f_v(a) + f_v(b) + f_v(c)) + Pabc(Nabc) = 1.d0/(f_v(a) + f_v(b) + f_v(c)) abc(1,Nabc) = int(a,2) abc(2,Nabc) = int(b,2) abc(3,Nabc) = int(c,2) @@ -135,13 +135,13 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ abc(1,Nabc) = int(a,2) abc(2,Nabc) = int(b,2) abc(3,Nabc) = int(a,2) - Pabc(Nabc) = -1.d0/(2.d0*f_v(a) + f_v(b)) + Pabc(Nabc) = 1.d0/(2.d0*f_v(a) + f_v(b)) Nabc = Nabc + 1_8 abc(1,Nabc) = int(b,2) abc(2,Nabc) = int(a,2) abc(3,Nabc) = int(b,2) - Pabc(Nabc) = -1.d0/(f_v(a) + 2.d0*f_v(b)) + Pabc(Nabc) = 1.d0/(f_v(a) + 2.d0*f_v(b)) enddo enddo @@ -150,6 +150,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ enddo ! Sort triplets in decreasing Pabc + Pabc(:) = -dabs(Pabc(:)) call dsort_big(Pabc, iorder, Nabc) ! Normalize From cf479a80afc02dd1f9ff534937052afe5ae64cd9 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 17 Apr 2024 18:06:53 +0200 Subject: [PATCH 23/50] Avoid divergence in (T) --- src/ccsd/ccsd_t_space_orb_stoch.irp.f | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/ccsd/ccsd_t_space_orb_stoch.irp.f b/src/ccsd/ccsd_t_space_orb_stoch.irp.f index 2aa134d1..1093c59d 100644 --- a/src/ccsd/ccsd_t_space_orb_stoch.irp.f +++ b/src/ccsd/ccsd_t_space_orb_stoch.irp.f @@ -125,7 +125,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ do b = a+1, nV do c = b+1, nV Nabc = Nabc + 1_8 - Pabc(Nabc) = 1.d0/(f_v(a) + f_v(b) + f_v(c)) + Pabc(Nabc) = f_v(a) + f_v(b) + f_v(c) abc(1,Nabc) = int(a,2) abc(2,Nabc) = int(b,2) abc(3,Nabc) = int(c,2) @@ -135,13 +135,13 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ abc(1,Nabc) = int(a,2) abc(2,Nabc) = int(b,2) abc(3,Nabc) = int(a,2) - Pabc(Nabc) = 1.d0/(2.d0*f_v(a) + f_v(b)) + Pabc(Nabc) = 2.d0*f_v(a) + f_v(b) Nabc = Nabc + 1_8 abc(1,Nabc) = int(b,2) abc(2,Nabc) = int(a,2) abc(3,Nabc) = int(b,2) - Pabc(Nabc) = 1.d0/(f_v(a) + 2.d0*f_v(b)) + Pabc(Nabc) = f_v(a) + 2.d0*f_v(b) enddo enddo @@ -150,7 +150,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ enddo ! Sort triplets in decreasing Pabc - Pabc(:) = -dabs(Pabc(:)) + Pabc(:) = -1.d0/max(0.2d0,Pabc(:)) call dsort_big(Pabc, iorder, Nabc) ! Normalize @@ -165,7 +165,6 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ call i8set_order_big(abc, iorder, Nabc) - ! Cumulative distribution for sampling waccu(Nabc) = 0.d0 do i8=Nabc-1,1,-1 From 2c899e6dd71247ae26cd337ede2bb13ce9419489 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Sat, 20 Apr 2024 12:39:39 +0200 Subject: [PATCH 24/50] few modif in grids --- .../extra_grid_vector.irp.f | 23 +++++++++++++++++-- .../grid_becke_vector.irp.f | 6 ++++- 2 files changed, 26 insertions(+), 3 deletions(-) diff --git a/src/becke_numerical_grid/extra_grid_vector.irp.f b/src/becke_numerical_grid/extra_grid_vector.irp.f index ae167282..16a52dc6 100644 --- a/src/becke_numerical_grid/extra_grid_vector.irp.f +++ b/src/becke_numerical_grid/extra_grid_vector.irp.f @@ -47,8 +47,12 @@ END_PROVIDER END_DOC implicit none - integer :: i,j,k,l,i_count - double precision :: r(3) + integer :: i, j, k, l, i_count + double precision :: r(3) + double precision :: wall0, wall1 + + call wall_time(wall0) + print *, ' Providing extra_final_grid_points ...' i_count = 0 do j = 1, nucl_num @@ -66,10 +70,25 @@ 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 + call wall_time(wall1) + print *, ' wall time for extra_final_grid_points,', wall1 - wall0 + call print_memory_usage() + END_PROVIDER diff --git a/src/becke_numerical_grid/grid_becke_vector.irp.f b/src/becke_numerical_grid/grid_becke_vector.irp.f index 473096d0..c35918c3 100644 --- a/src/becke_numerical_grid/grid_becke_vector.irp.f +++ b/src/becke_numerical_grid/grid_becke_vector.irp.f @@ -72,7 +72,11 @@ END_PROVIDER print *, ' !!! WARNING !!!' print *, ' negative weight !!!!' print *, i_count, final_weight_at_r_vector(i_count) - stop + 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 From 4f293298c345c30470cab0c79b4de4b38f4fb851 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 22 Apr 2024 10:45:31 +0200 Subject: [PATCH 25/50] Updated irpf90 --- external/irpf90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/external/irpf90 b/external/irpf90 index 4ab1b175..76946321 160000 --- a/external/irpf90 +++ b/external/irpf90 @@ -1 +1 @@ -Subproject commit 4ab1b175fc7ed0d96c1912f13dc53579b24157a6 +Subproject commit 76946321d64b0be58933a6f37d6a0781b96dff86 From c8b91f980eb54b78fe127d87727abe493065b08b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 22 Apr 2024 10:58:42 +0200 Subject: [PATCH 26/50] Updated irpf90 --- external/irpf90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/external/irpf90 b/external/irpf90 index 76946321..451c93a5 160000 --- a/external/irpf90 +++ b/external/irpf90 @@ -1 +1 @@ -Subproject commit 76946321d64b0be58933a6f37d6a0781b96dff86 +Subproject commit 451c93a52c1ca3f78ce2f0e4add773d6e44e561a From ecfdaf9eea971db1f0ce8df598670a67a45dc86b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 22 Apr 2024 11:03:26 +0200 Subject: [PATCH 27/50] Updated irpf90 --- external/irpf90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/external/irpf90 b/external/irpf90 index 451c93a5..beac6153 160000 --- a/external/irpf90 +++ b/external/irpf90 @@ -1 +1 @@ -Subproject commit 451c93a52c1ca3f78ce2f0e4add773d6e44e561a +Subproject commit beac615343f421bd6c0571a408ba389a6d5a32ac From de288449f58a54893cf1647faa8b00116303e7bc Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 22 Apr 2024 13:45:51 +0200 Subject: [PATCH 28/50] Fix dos files in qp_create --- ocaml/Atom.ml | 13 +++++++++---- ocaml/Molecule.ml | 12 +++++++++++- ocaml/Point3d.ml | 4 +++- 3 files changed, 23 insertions(+), 6 deletions(-) diff --git a/ocaml/Atom.ml b/ocaml/Atom.ml index d02b20d8..49e788e8 100644 --- a/ocaml/Atom.ml +++ b/ocaml/Atom.ml @@ -22,10 +22,15 @@ let of_string ~units s = } | [ name; x; y; z ] -> let e = Element.of_string name in - { element = e ; - charge = Element.to_charge e; - coord = Point3d.of_string ~units (String.concat " " [x; y; z]) - } + begin + try + { element = e ; + charge = Element.to_charge e; + coord = Point3d.of_string ~units (String.concat " " [x; y; z]) + } + with + | err -> (Printf.eprintf "name = \"%s\"\nxyz = (%s,%s,%s)\n%!" name x y z ; raise err) + end | _ -> raise (AtomError s) diff --git a/ocaml/Molecule.ml b/ocaml/Molecule.ml index 603244c8..3771b6f9 100644 --- a/ocaml/Molecule.ml +++ b/ocaml/Molecule.ml @@ -142,13 +142,21 @@ let of_xyz_string result +let regexp_r = Str.regexp {| |} +let regexp_t = Str.regexp {| |} + let of_xyz_file ?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1)) ?(units=Units.Angstrom) filename = let lines = - match Io_ext.input_lines filename with + Io_ext.input_lines filename + |> List.map (fun s -> Str.global_replace regexp_r "" s) + |> List.map (fun s -> Str.global_replace regexp_t " " s) + in + let lines = + match lines with | natoms :: title :: rest -> let natoms = try @@ -173,6 +181,8 @@ let of_zmt_file ?(units=Units.Angstrom) filename = Io_ext.read_all filename + |> Str.global_replace regexp_r "" + |> Str.global_replace regexp_t " " |> Zmatrix.of_string |> Zmatrix.to_xyz_string |> of_xyz_string ~charge ~multiplicity ~units diff --git a/ocaml/Point3d.ml b/ocaml/Point3d.ml index 57b02bfe..4df375e4 100644 --- a/ocaml/Point3d.ml +++ b/ocaml/Point3d.ml @@ -24,7 +24,9 @@ let of_string ~units s = let l = s |> String_ext.split ~on:' ' |> List.filter (fun x -> x <> "") - |> list_map float_of_string + |> list_map (fun x -> + try float_of_string x with + | Failure msg -> (Printf.eprintf "Bad string: \"%s\"\n%!" x ; failwith msg) ) |> Array.of_list in { x = l.(0) *. f ; From f35bc230368a954e351c5e64dd3e9e19d5978023 Mon Sep 17 00:00:00 2001 From: eginer Date: Wed, 24 Apr 2024 14:48:23 +0200 Subject: [PATCH 29/50] Begining to make some cleaning in TC --- .../local/bi_ort_ints/total_twoe_pot.irp.f | 22 +++++++++++++++++++ plugins/local/mo_localization/README.md | 2 +- .../normal_ordered.irp.f | 0 .../normal_ordered_contractions.irp.f | 0 .../normal_ordered_old.irp.f | 0 .../normal_ordered_v0.irp.f | 0 .../h_biortho.irp.f | 0 .../h_mat_triple.irp.f | 0 .../h_tc_bi_ortho_psi.irp.f | 0 .../h_tc_s2_u0.irp.f | 0 .../slater_tc_3e_slow.irp.f | 0 .../slater_tc_opt.irp.f | 0 .../slater_tc_opt_diag.irp.f | 0 .../slater_tc_opt_double.irp.f | 0 .../slater_tc_opt_single.irp.f | 0 .../slater_tc_slow.irp.f | 0 .../{tc_bi_ortho => slater_tc}/tc_hmat.irp.f | 0 plugins/local/tc_bi_ortho/NEED | 6 +---- 18 files changed, 24 insertions(+), 6 deletions(-) rename plugins/local/{tc_bi_ortho => normal_order_old}/normal_ordered.irp.f (100%) rename plugins/local/{tc_bi_ortho => normal_order_old}/normal_ordered_contractions.irp.f (100%) rename plugins/local/{tc_bi_ortho => normal_order_old}/normal_ordered_old.irp.f (100%) rename plugins/local/{tc_bi_ortho => normal_order_old}/normal_ordered_v0.irp.f (100%) rename plugins/local/{tc_bi_ortho => slater_tc}/h_biortho.irp.f (100%) rename plugins/local/{tc_bi_ortho => slater_tc}/h_mat_triple.irp.f (100%) rename plugins/local/{tc_bi_ortho => slater_tc}/h_tc_bi_ortho_psi.irp.f (100%) rename plugins/local/{tc_bi_ortho => slater_tc}/h_tc_s2_u0.irp.f (100%) rename plugins/local/{tc_bi_ortho => slater_tc}/slater_tc_3e_slow.irp.f (100%) rename plugins/local/{tc_bi_ortho => slater_tc}/slater_tc_opt.irp.f (100%) rename plugins/local/{tc_bi_ortho => slater_tc}/slater_tc_opt_diag.irp.f (100%) rename plugins/local/{tc_bi_ortho => slater_tc}/slater_tc_opt_double.irp.f (100%) rename plugins/local/{tc_bi_ortho => slater_tc}/slater_tc_opt_single.irp.f (100%) rename plugins/local/{tc_bi_ortho => slater_tc}/slater_tc_slow.irp.f (100%) rename plugins/local/{tc_bi_ortho => slater_tc}/tc_hmat.irp.f (100%) diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f index 5e6a24e9..42a7ba62 100644 --- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f +++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f @@ -176,6 +176,28 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num, END_PROVIDER +BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_transp, (mo_num, mo_num, mo_num, mo_num)] + implicit none + BEGIN_DOC + ! + ! mo_bi_ortho_tc_two_e_transp(i,j,k,l) = = transpose of mo_bi_ortho_tc_two_e + ! + ! the potential V(r_12) contains ALL TWO-E CONTRIBUTION OF THE TC-HAMILTONIAN + ! + END_DOC + + integer :: i,j,k,l + do i = 1, mo_num + do j = 1, mo_num + do k = 1, mo_num + do l = 1, mo_num + mo_bi_ortho_tc_two_e_transp(i,j,k,l) = mo_bi_ortho_tc_two_e_transp(k,l,i,j) + enddo + enddo + enddo + enddo + +END_PROVIDER ! --- BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj, (mo_num,mo_num)] diff --git a/plugins/local/mo_localization/README.md b/plugins/local/mo_localization/README.md index c28a5ee1..512e36af 100644 --- a/plugins/local/mo_localization/README.md +++ b/plugins/local/mo_localization/README.md @@ -3,7 +3,7 @@ To localize the MOs: ``` qp run localization ``` -By default, the different otbital classes are automatically set by splitting +By default, the different orbital classes are automatically set by splitting the orbitales in the following classes: - Core -> Core - Active, doubly occupied -> Inactive diff --git a/plugins/local/tc_bi_ortho/normal_ordered.irp.f b/plugins/local/normal_order_old/normal_ordered.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/normal_ordered.irp.f rename to plugins/local/normal_order_old/normal_ordered.irp.f diff --git a/plugins/local/tc_bi_ortho/normal_ordered_contractions.irp.f b/plugins/local/normal_order_old/normal_ordered_contractions.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/normal_ordered_contractions.irp.f rename to plugins/local/normal_order_old/normal_ordered_contractions.irp.f diff --git a/plugins/local/tc_bi_ortho/normal_ordered_old.irp.f b/plugins/local/normal_order_old/normal_ordered_old.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/normal_ordered_old.irp.f rename to plugins/local/normal_order_old/normal_ordered_old.irp.f diff --git a/plugins/local/tc_bi_ortho/normal_ordered_v0.irp.f b/plugins/local/normal_order_old/normal_ordered_v0.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/normal_ordered_v0.irp.f rename to plugins/local/normal_order_old/normal_ordered_v0.irp.f diff --git a/plugins/local/tc_bi_ortho/h_biortho.irp.f b/plugins/local/slater_tc/h_biortho.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/h_biortho.irp.f rename to plugins/local/slater_tc/h_biortho.irp.f diff --git a/plugins/local/tc_bi_ortho/h_mat_triple.irp.f b/plugins/local/slater_tc/h_mat_triple.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/h_mat_triple.irp.f rename to plugins/local/slater_tc/h_mat_triple.irp.f diff --git a/plugins/local/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f b/plugins/local/slater_tc/h_tc_bi_ortho_psi.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f rename to plugins/local/slater_tc/h_tc_bi_ortho_psi.irp.f diff --git a/plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f b/plugins/local/slater_tc/h_tc_s2_u0.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f rename to plugins/local/slater_tc/h_tc_s2_u0.irp.f diff --git a/plugins/local/tc_bi_ortho/slater_tc_3e_slow.irp.f b/plugins/local/slater_tc/slater_tc_3e_slow.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/slater_tc_3e_slow.irp.f rename to plugins/local/slater_tc/slater_tc_3e_slow.irp.f diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt.irp.f b/plugins/local/slater_tc/slater_tc_opt.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/slater_tc_opt.irp.f rename to plugins/local/slater_tc/slater_tc_opt.irp.f diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f b/plugins/local/slater_tc/slater_tc_opt_diag.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f rename to plugins/local/slater_tc/slater_tc_opt_diag.irp.f diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt_double.irp.f b/plugins/local/slater_tc/slater_tc_opt_double.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/slater_tc_opt_double.irp.f rename to plugins/local/slater_tc/slater_tc_opt_double.irp.f diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f b/plugins/local/slater_tc/slater_tc_opt_single.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f rename to plugins/local/slater_tc/slater_tc_opt_single.irp.f diff --git a/plugins/local/tc_bi_ortho/slater_tc_slow.irp.f b/plugins/local/slater_tc/slater_tc_slow.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/slater_tc_slow.irp.f rename to plugins/local/slater_tc/slater_tc_slow.irp.f diff --git a/plugins/local/tc_bi_ortho/tc_hmat.irp.f b/plugins/local/slater_tc/tc_hmat.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/tc_hmat.irp.f rename to plugins/local/slater_tc/tc_hmat.irp.f diff --git a/plugins/local/tc_bi_ortho/NEED b/plugins/local/tc_bi_ortho/NEED index 9a0c20ef..01841e02 100644 --- a/plugins/local/tc_bi_ortho/NEED +++ b/plugins/local/tc_bi_ortho/NEED @@ -1,6 +1,2 @@ -bi_ort_ints -bi_ortho_mos -tc_keywords -non_hermit_dav -dav_general_mat tc_scf +slater_tc From 40ea886cf1f6fe18d2501f1964e4f69deb66d947 Mon Sep 17 00:00:00 2001 From: eginer Date: Wed, 1 May 2024 19:00:02 +0200 Subject: [PATCH 30/50] added NEED in local/slater_tc --- external/irpf90 | 2 +- plugins/local/slater_tc/NEED | 7 +++++++ plugins/local/slater_tc/slater_tc.irp.f | 7 +++++++ 3 files changed, 15 insertions(+), 1 deletion(-) create mode 100644 plugins/local/slater_tc/NEED create mode 100644 plugins/local/slater_tc/slater_tc.irp.f diff --git a/external/irpf90 b/external/irpf90 index beac6153..4ab1b175 160000 --- a/external/irpf90 +++ b/external/irpf90 @@ -1 +1 @@ -Subproject commit beac615343f421bd6c0571a408ba389a6d5a32ac +Subproject commit 4ab1b175fc7ed0d96c1912f13dc53579b24157a6 diff --git a/plugins/local/slater_tc/NEED b/plugins/local/slater_tc/NEED new file mode 100644 index 00000000..ef0aa3f7 --- /dev/null +++ b/plugins/local/slater_tc/NEED @@ -0,0 +1,7 @@ +determinants +normal_order_old +bi_ort_ints +bi_ortho_mos +tc_keywords +non_hermit_dav +dav_general_mat diff --git a/plugins/local/slater_tc/slater_tc.irp.f b/plugins/local/slater_tc/slater_tc.irp.f new file mode 100644 index 00000000..27ab47c5 --- /dev/null +++ b/plugins/local/slater_tc/slater_tc.irp.f @@ -0,0 +1,7 @@ +program slater_tc + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' +end From 0465a0f4397a53daa5a3a1c8374a5e34f5b61c67 Mon Sep 17 00:00:00 2001 From: eginer Date: Wed, 1 May 2024 19:03:21 +0200 Subject: [PATCH 31/50] added local/normal_order_old/NEED --- plugins/local/normal_order_old/NEED | 1 + plugins/local/normal_order_old/README.rst | 4 ++++ 2 files changed, 5 insertions(+) create mode 100644 plugins/local/normal_order_old/NEED create mode 100644 plugins/local/normal_order_old/README.rst diff --git a/plugins/local/normal_order_old/NEED b/plugins/local/normal_order_old/NEED new file mode 100644 index 00000000..8b137891 --- /dev/null +++ b/plugins/local/normal_order_old/NEED @@ -0,0 +1 @@ + diff --git a/plugins/local/normal_order_old/README.rst b/plugins/local/normal_order_old/README.rst new file mode 100644 index 00000000..a284fcfd --- /dev/null +++ b/plugins/local/normal_order_old/README.rst @@ -0,0 +1,4 @@ +================ +normal_order_old +================ + From c50018e8bdbd0e11da5af2ddfe4032c7d6e86df2 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 1 May 2024 20:25:01 +0200 Subject: [PATCH 32/50] TC SPRING CLEANING: BEGINNING --- .../bi_ort_ints/three_body_ints_bi_ort.irp.f | 2 +- .../local/non_h_ints_mu/jast_1e_utils.irp.f | 18 +- .../local/non_h_ints_mu/numerical_integ.irp.f | 6 +- .../local/non_h_ints_mu/tc_integ_num.irp.f | 20 +- .../local/non_h_ints_mu/test_non_h_ints.irp.f | 26 +- plugins/local/non_hermit_dav/biorthog.irp.f | 1069 +---------------- .../lapack_diag_non_hermit.irp.f | 118 -- .../local/non_hermit_dav/new_routines.irp.f | 670 ----------- .../mu_j_ints_usual_mos.irp.f | 8 - plugins/local/tc_bi_ortho/EZFIO.cfg | 11 + .../local/tc_bi_ortho/print_tc_energy.irp.f | 30 +- plugins/local/tc_bi_ortho/print_tc_var.irp.f | 5 +- .../save_bitcpsileft_for_qmcchem.irp.f | 8 +- plugins/local/tc_bi_ortho/tc_utils.irp.f | 89 +- plugins/local/tc_scf/EZFIO.cfg | 4 +- plugins/local/tc_scf/combine_lr_tcscf.irp.f | 75 -- plugins/local/tc_scf/diago_vartcfock.irp.f | 96 -- plugins/local/tc_scf/diis_tcscf.irp.f | 75 +- .../local/tc_scf/fock_3e_bi_ortho_cs.irp.f | 299 ----- .../local/tc_scf/fock_3e_bi_ortho_os.irp.f | 536 --------- .../local/tc_scf/fock_3e_bi_ortho_uhf.irp.f | 77 -- .../tc_scf/fock_3e_bi_ortho_uhf_old.irp.f | 490 -------- plugins/local/tc_scf/fock_tc.irp.f | 1000 +++++++++++++-- plugins/local/tc_scf/fock_tc_mo_tot.irp.f | 11 +- plugins/local/tc_scf/fock_vartc.irp.f | 287 ----- plugins/local/tc_scf/rh_tcscf_diis.irp.f | 4 +- plugins/local/tc_scf/rh_tcscf_simple.irp.f | 2 +- plugins/local/tc_scf/rh_vartcscf_simple.irp.f | 89 -- plugins/local/tc_scf/tc_scf.irp.f | 58 +- plugins/local/tc_scf/tc_scf_energy.irp.f | 41 +- plugins/local/tc_scf/test_int.irp.f | 970 --------------- .../extra_grid_vector.irp.f | 11 - .../grid_becke_vector.irp.f | 11 - src/utils/util.irp.f | 80 +- 34 files changed, 1188 insertions(+), 5108 deletions(-) delete mode 100644 plugins/local/non_hermit_dav/new_routines.irp.f delete mode 100644 plugins/local/tc_scf/combine_lr_tcscf.irp.f delete mode 100644 plugins/local/tc_scf/diago_vartcfock.irp.f delete mode 100644 plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f delete mode 100644 plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f delete mode 100644 plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f delete mode 100644 plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f delete mode 100644 plugins/local/tc_scf/fock_vartc.irp.f delete mode 100644 plugins/local/tc_scf/rh_vartcscf_simple.irp.f delete mode 100644 plugins/local/tc_scf/test_int.irp.f diff --git a/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f b/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f index fd4a162f..73e5a611 100644 --- a/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f +++ b/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 ! --- diff --git a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f index 9cfabf58..c6b2b0a0 100644 --- a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f +++ b/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,26 +177,27 @@ 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 !$OMP END DO !$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 & + call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & + , 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 diff --git a/plugins/local/non_h_ints_mu/numerical_integ.irp.f b/plugins/local/non_h_ints_mu/numerical_integ.irp.f index 5436b857..2737774a 100644 --- a/plugins/local/non_h_ints_mu/numerical_integ.irp.f +++ b/plugins/local/non_h_ints_mu/numerical_integ.irp.f @@ -179,7 +179,7 @@ double precision function num_v_ij_erf_rk_cst_mu_env(i, j, ipoint) dx = r1(1) - r2(1) dy = r1(2) - r2(2) dz = r1(3) - r2(3) - r12 = dsqrt( dx * dx + dy * dy + dz * dz ) + r12 = dsqrt(dx*dx + dy*dy + dz*dz) if(r12 .lt. 1d-10) cycle tmp1 = (derf(mu_erf * r12) - 1.d0) / r12 @@ -228,7 +228,7 @@ subroutine num_x_v_ij_erf_rk_cst_mu_env(i, j, ipoint, integ) dx = r1(1) - r2(1) dy = r1(2) - r2(2) dz = r1(3) - r2(3) - r12 = dsqrt( dx * dx + dy * dy + dz * dz ) + r12 = dsqrt(dx*dx + dy*dy + dz*dz) if(r12 .lt. 1d-10) cycle tmp1 = (derf(mu_erf * r12) - 1.d0) / r12 @@ -530,7 +530,7 @@ subroutine num_int2_u_grad1u_total_env2(i, j, ipoint, integ) dx = r1(1) - r2(1) dy = r1(2) - r2(2) dz = r1(3) - r2(3) - r12 = dsqrt( dx * dx + dy * dy + dz * dz ) + r12 = dsqrt(dx*dx + dy*dy + dz*dz) if(r12 .lt. 1d-10) cycle tmp0 = env_nucl(r2) diff --git a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f index 6d446037..9d9601c0 100644 --- a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f +++ b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f @@ -63,12 +63,10 @@ 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 PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i_blocks, ipoint) & + !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12, tmp_grad1_u12_squared) !$OMP DO do i_blocks = 1, n_blocks ipoint = ii - 1 + i_blocks ! r1 @@ -99,12 +97,10 @@ 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 PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i_rest, ipoint) & + !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12, tmp_grad1_u12_squared) !$OMP DO do i_rest = 1, n_rest ipoint = ii - 1 + i_rest ! r1 diff --git a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f index 464a1c1f..4c63dec4 100644 --- a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f +++ b/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 @@ -1304,11 +1308,11 @@ 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 & + call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & + , 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 diff --git a/plugins/local/non_hermit_dav/biorthog.irp.f b/plugins/local/non_hermit_dav/biorthog.irp.f index 2229e17d..b36b0130 100644 --- a/plugins/local/non_hermit_dav/biorthog.irp.f +++ b/plugins/local/non_hermit_dav/biorthog.irp.f @@ -1,254 +1,3 @@ -subroutine non_hrmt_diag_split_degen(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 - integer :: n_good - double precision :: shift,shift_current - double precision :: r,thr - integer, allocatable :: list_good(:), 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(:) - - - print*,'Computing the left/right eigenvectors ...' - print*,'Using the degeneracy splitting algorithm' - - - ! 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)) - do i = 1, n - iorder_origin(i) = i - diag_elem(i) = A(i,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 - - shift = 1.d-15 - shift_current = shift - iteration = 1 - logical :: good_ortho - good_ortho = .False. - do while(n_real_eigv.ne.n.or. .not.good_ortho) - if(shift.gt.1.d-3)then - print*,'shift > 1.d-3 !!' - print*,'Your matrix intrinsically contains complex eigenvalues' - stop - endif - print*,'***** iteration = ',iteration - print*,'shift = ',shift - allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n)) - Aw = A_save - do i = 1, n - do j = 1, n - if(dabs(Aw(j,i)).lt.shift)then - Aw(j,i) = 0.d0 - endif - enddo - enddo - call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR) - allocate(im_part(n),iorder(n)) - 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) - print*,'Largest imaginary part found in eigenvalues = ',im_part(1) - print*,'Splitting the degeneracies by ',shift_current - Aw = A_save - call split_matrix_degen(Aw,n,shift_current) - deallocate( im_part, iorder ) - call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR) - ! You track the real eigenvalues - n_good = 0 - do i = 1, n - if(dabs(WI(i)).lt.1.d-20)then - n_good += 1 - else - print*,'Found an imaginary component to eigenvalue' - print*,'Re(i) + Im(i)',WR(i),WI(i) - endif - enddo - allocate( list_good(n_good), iorder(n_good) ) - n_good = 0 - do i = 1, n - if(dabs(WI(i)).lt.1.d-20)then - n_good += 1 - list_good(n_good) = i - eigval(n_good) = WR(i) - endif - enddo - deallocate( WR, WI ) - - n_real_eigv = n_good - do i = 1, n_good - iorder(i) = i - enddo - - ! You sort the real eigenvalues - call dsort(eigval, iorder, n_good) - - reigvec(:,:) = 0.d0 - leigvec(:,:) = 0.d0 - do i = 1, n_real_eigv - do j = 1, n - reigvec_tmp(j,i) = VR(j,list_good(iorder(i))) - leigvec_tmp(j,i) = Vl(j,list_good(iorder(i))) - enddo - enddo - - if(n_real_eigv == n)then - allocate(S(n,n)) - call check_bi_ortho(reigvec_tmp,leigvec_tmp,n,S,accu_nd) - print*,'accu_nd = ',accu_nd - double precision :: accu_nd - good_ortho = accu_nd .lt. 1.d-10 - deallocate(S) - endif - - deallocate( list_good, iorder ) - deallocate( VL, VR, Aw) - shift *= 10.d0 - iteration += 1 - enddo - do i = 1, n - do j = 1, n - reigvec(iorder_origin(j),i) = reigvec_tmp(j,i) - leigvec(iorder_origin(j),i) = leigvec_tmp(j,i) - enddo - enddo - -end - -! --- - -subroutine non_hrmt_real_diag_new(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) - - integer :: i, j - integer :: n_good - double precision :: shift,shift_current - double precision :: r,thr - integer, allocatable :: list_good(:), iorder(:) - double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:) - double precision, allocatable :: Aw(:,:) - double precision, allocatable :: im_part(:) - - - print*,'Computing the left/right eigenvectors ...' - - ! Eigvalue(n) = WR(n) + i * WI(n) - shift = 1.d-10 - do while(n_real_eigv.ne.n.or.shift.gt.1.d-3) - allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n)) - Aw = A - call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR) - allocate(im_part(n), iorder(n)) - do i = 1, n - im_part(i) = -dabs(WI(i)) - iorder(i) = i - enddo - shift_current = max(10.d0 * dabs(im_part(1)),shift) - print*,'adding random number of magnitude ',shift_current - Aw = A - do i = 1, n - call RANDOM_NUMBER(r) - Aw(i,i) += shift_current * r - enddo - deallocate( im_part, iorder ) - call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR) - - ! You track the real eigenvalues - thr = 1.d-10 - n_good = 0 - do i = 1, n - if(dabs(WI(i)).lt.thr)then - n_good += 1 - else - print*,'Found an imaginary component to eigenvalue' - print*,'Re(i) + Im(i)',WR(i),WI(i) - endif - enddo - - allocate( list_good(n_good), iorder(n_good) ) - n_good = 0 - do i = 1, n - if(dabs(WI(i)).lt.thr)then - n_good += 1 - list_good(n_good) = i - eigval(n_good) = WR(i) - endif - enddo - - deallocate( WR, WI ) - - n_real_eigv = n_good - do i = 1, n_good - iorder(i) = i - enddo - - ! You sort the real eigenvalues - call dsort(eigval, iorder, n_good) - - reigvec(:,:) = 0.d0 - leigvec(:,:) = 0.d0 - do i = 1, n_real_eigv - do j = 1, n - reigvec(j,i) = VR(j,list_good(iorder(i))) - leigvec(j,i) = Vl(j,list_good(iorder(i))) - enddo - enddo - - deallocate( list_good, iorder ) - deallocate( VL, VR, Aw) - shift *= 10.d0 - enddo - if(shift.gt.1.d-3)then - print*,'shift > 1.d-3 !!' - print*,'Your matrix intrinsically contains complex eigenvalues' - endif - -end ! --- @@ -282,126 +31,20 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei allocate(phi_1_tilde(n),phi_2_tilde(n),chi_1_tilde(n),chi_2_tilde(n)) - - ! ------------------------------------------------------------------------------------- - ! - - !print *, ' ' - !print *, ' Computing the left/right eigenvectors ...' - !print *, ' ' - allocate(WR(n), WI(n), VL(n,n), VR(n,n)) - - !print *, ' fock matrix' - !do i = 1, n - ! write(*, '(1000(F16.10,X))') A(i,:) - !enddo - !thr_cut = 1.d-15 - !call cancel_small_elmts(A, n, thr_cut) - - !call lapack_diag_non_sym_right(n, A, WR, WI, VR) call lapack_diag_non_sym(n, A, WR, WI, VL, VR) - !call lapack_diag_non_sym_new(n, A, WR, WI, VL, VR) - - - - !print *, ' ' - !print *, ' eigenvalues' - i = 1 - do while(i .le. n) - !write(*, '(I3,X,1000(F16.10,X))')i, WR(i), WI(i) - if(.false.)then - if(WI(i).ne.0.d0)then - print*,'*****************' - print*,'WARNING ! IMAGINARY EIGENVALUES !!!' - write(*, '(1000(F16.10,X))') WR(i), WI(i+1) - ! phi = VR(:,i), psi = VR(:,i+1), |Phi_i> = phi + j psi , |Phi_i+1> = phi - j psi - ! chi = VL(:,i), xhi = VL(:,i+1), |Chi_i> = chi + j xhi , |Chi_i+1> = chi - j xhi - ! - accu_chi_phi = 0.d0 - accu_xhi_psi = 0.d0 - accu_chi_psi = 0.d0 - accu_xhi_phi = 0.d0 - double precision :: accu_chi_phi, accu_xhi_psi, accu_chi_psi, accu_xhi_phi - double precision :: mat_ovlp(2,2),eigval_tmp(2),eigvec(2,2),mat_ovlp_orig(2,2) - do j = 1, n - accu_chi_phi += VL(j,i) * VR(j,i) - accu_xhi_psi += VL(j,i+1) * VR(j,i+1) - accu_chi_psi += VL(j,i) * VR(j,i+1) - accu_xhi_phi += VL(j,i+1) * VR(j,i) - enddo - mat_ovlp_orig(1,1) = accu_chi_phi - mat_ovlp_orig(2,1) = accu_xhi_phi - mat_ovlp_orig(1,2) = accu_chi_psi - mat_ovlp_orig(2,2) = accu_xhi_psi - print*,'old overlap matrix ' - write(*,'(100(F16.10,X))')mat_ovlp_orig(1:2,1) - write(*,'(100(F16.10,X))')mat_ovlp_orig(1:2,2) - - - mat_ovlp(1,1) = accu_xhi_phi - mat_ovlp(2,1) = accu_chi_phi - mat_ovlp(1,2) = accu_xhi_psi - mat_ovlp(2,2) = accu_chi_psi - !print*,'accu_chi_phi = ',accu_chi_phi - !print*,'accu_xhi_psi = ',accu_xhi_psi - !print*,'accu_chi_psi = ',accu_chi_psi - !print*,'accu_xhi_phi = ',accu_xhi_phi - print*,'new overlap matrix ' - write(*,'(100(F16.10,X))')mat_ovlp(1:2,1) - write(*,'(100(F16.10,X))')mat_ovlp(1:2,2) - call lapack_diag(eigval_tmp,eigvec,mat_ovlp,2,2) - print*,'eigval_tmp(1) = ',eigval_tmp(1) - print*,'eigvec(1) = ',eigvec(1:2,1) - print*,'eigval_tmp(2) = ',eigval_tmp(2) - print*,'eigvec(2) = ',eigvec(1:2,2) - print*,'*****************' - phi_1_tilde = 0.d0 - phi_2_tilde = 0.d0 - chi_1_tilde = 0.d0 - chi_2_tilde = 0.d0 - do j = 1, n - phi_1_tilde(j) += VR(j,i) * eigvec(1,1) + VR(j,i+1) * eigvec(2,1) - phi_2_tilde(j) += VR(j,i) * eigvec(1,2) + VR(j,i+1) * eigvec(2,2) - chi_1_tilde(j) += VL(j,i+1) * eigvec(1,1) + VL(j,i) * eigvec(2,1) - chi_2_tilde(j) += VL(j,i+1) * eigvec(1,2) + VL(j,i) * eigvec(2,2) - enddo - VR(1:n,i) = phi_1_tilde(1:n) - VR(1:n,i+1) = phi_2_tilde(1:n) -! Vl(1:n,i) = -chi_1_tilde(1:n) -! Vl(1:n,i+1) = chi_2_tilde(1:n) - i+=1 - endif - endif - i+=1 - enddo - !print *, ' right eigenvect bef' - !do i = 1, n - ! write(*, '(1000(F16.10,X))') VR(:,i) - !enddo - !print *, ' left eigenvect bef' - !do i = 1, n - ! write(*, '(1000(F16.10,X))') VL(:,i) - !enddo thr_diag = 1d-06 thr_norm = 1d+10 - !call check_EIGVEC(n, n, A, WR, VL, VR, thr_diag, thr_norm, .false.) - - ! - ! ------------------------------------------------------------------------------------- ! --- - ! ------------------------------------------------------------------------------------- - ! track & sort the real eigenvalues + ! track & sort the real eigenvalues n_good = 0 - !thr = 100d0 thr = Im_thresh_tcscf do i = 1, n - !print*, 'Re(i) + Im(i)', WR(i), WI(i) if(dabs(WI(i)) .lt. thr) then n_good += 1 else @@ -410,11 +53,12 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei endif enddo - if(n_good.ne.n)then - print*,'there are some imaginary eigenvalues ' - thr_diag = 1d-03 - n_good = n + if(n_good.ne.n) then + print*,'there are some imaginary eigenvalues ' + thr_diag = 1d-03 + n_good = n endif + allocate(list_good(n_good), iorder(n_good)) n_good = 0 @@ -446,26 +90,9 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei ASSERT(n==n_real_eigv) - !print *, ' eigenvalues' - !do i = 1, n - ! write(*, '(1000(F16.10,X))') eigval(i) - !enddo - !print *, ' right eigenvect aft ord' - !do i = 1, n - ! write(*, '(1000(F16.10,X))') reigvec(:,i) - !enddo - !print *, ' left eigenvect aft ord' - !do i = 1, n - ! write(*, '(1000(F16.10,X))') leigvec(:,i) - !enddo - - ! - ! ------------------------------------------------------------------------------------- - ! --- - ! ------------------------------------------------------------------------------------- - ! check bi-orthogonality + ! check bi-orthogonality thr_diag = 10.d0 thr_norm = 1d+10 @@ -495,8 +122,6 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei print *, ' lapack vectors are not normalized neither bi-orthogonalized' - ! --- - allocate(deg_num(n)) call reorder_degen_eigvec(n, deg_num, eigval, leigvec, reigvec) call impose_biorthog_degen_eigvec(n, deg_num, eigval, leigvec, reigvec) @@ -508,700 +133,36 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei endif call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .true.) - !call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.) - deallocate(S) endif - ! - ! ------------------------------------------------------------------------------------- - return end ! --- -subroutine non_hrmt_bieig_random_diag(n, A, leigvec, reigvec, n_real_eigv, eigval) +subroutine check_bi_ortho(reigvec, leigvec, n, S, accu_nd) 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" + ! retunrs the overlap matrix S = Leigvec^T Reigvec ! + ! and the square root of the sum of the squared off-diagonal elements of S 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, intent(in) :: reigvec(n,n), leigvec(n,n) + double precision, intent(out) :: S(n,n), accu_nd - integer :: i, j - integer :: n_good - double precision :: thr - double precision :: accu_nd + integer :: i,j - integer, allocatable :: list_good(:), iorder(:) - double precision, allocatable :: Aw(:,:) - double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:) - double precision, allocatable :: S(:,:) - double precision :: r - - - ! ------------------------------------------------------------------------------------- - ! - - print *, 'Computing the left/right eigenvectors ...' - allocate( WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n) ) - - Aw(:,:) = A(:,:) - call lapack_diag_non_sym_new(n, Aw, WR, WI, VL, VR) - - thr = 1.d-12 - double precision, allocatable :: im_part(:) - n_good = 0 - do i = 1, n - if( dabs(WI(i)).lt.thr ) then - n_good += 1 - else - print*, 'Found an imaginary component to eigenvalue on i = ', i - print*, 'Re(i) + Im(i)', WR(i), WI(i) - endif - enddo - print*,'n_good = ',n_good - if(n_good .lt. n)then - print*,'Removing degeneracies to remove imaginary parts' - allocate(im_part(n),iorder(n)) - r = 0.d0 - do i = 1, n - im_part(i) = -dabs(WI(i)) - iorder(i) = i - enddo - call dsort(im_part,iorder,n) - thr = 10.d0 * dabs(im_part(1)) - print*,'adding random numbers on the diagonal of magnitude ',thr - Aw(:,:) = A(:,:) - do i = 1, n - call RANDOM_NUMBER(r) - print*,'r = ',r*thr - Aw(i,i) += thr * r - enddo - print*,'Rediagonalizing the matrix with random numbers' - call lapack_diag_non_sym_new(n, Aw, WR, WI, VL, VR) - deallocate(im_part,iorder) - endif - deallocate( Aw ) - - ! - ! ------------------------------------------------------------------------------------- - - ! --- - - ! ------------------------------------------------------------------------------------- - ! track & sort the real eigenvalues - - n_good = 0 - thr = 1.d-5 - do i = 1, n - if( dabs(WI(i)).lt.thr ) then - n_good += 1 - else - print*, 'Found an imaginary component to eigenvalue on i = ', i - print*, 'Re(i) + Im(i)', WR(i), WI(i) - endif - enddo - print*,'n_good = ',n_good - allocate( list_good(n_good), iorder(n_good) ) - - n_good = 0 - do i = 1, n - if( dabs(WI(i)).lt.thr ) then - n_good += 1 - list_good(n_good) = i - eigval(n_good) = WR(i) - endif - enddo - - deallocate( WR, WI ) - - n_real_eigv = n_good - do i = 1, n_good - iorder(i) = i - enddo - call dsort(eigval, iorder, n_good) - - reigvec(:,:) = 0.d0 - leigvec(:,:) = 0.d0 - do i = 1, n_real_eigv - do j = 1, n - reigvec(j,i) = VR(j,list_good(iorder(i))) - leigvec(j,i) = VL(j,list_good(iorder(i))) - enddo - enddo - - deallocate( list_good, iorder ) - deallocate( VL, VR ) - - ! - ! ------------------------------------------------------------------------------------- - - ! --- - - ! ------------------------------------------------------------------------------------- - ! check bi-orthogonality - - allocate( S(n_real_eigv,n_real_eigv) ) - - ! S = VL x VR - call dgemm( 'T', 'N', n_real_eigv, n_real_eigv, n, 1.d0 & - , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) & - , 0.d0, S, size(S, 1) ) - - accu_nd = 0.d0 - do i = 1, n_real_eigv - do j = 1, n_real_eigv - if(i==j) cycle - accu_nd = accu_nd + S(j,i) * S(j,i) - enddo - enddo - accu_nd = dsqrt(accu_nd) - - if(accu_nd .lt. thresh_biorthog_nondiag) then - ! L x R is already bi-orthogonal - - print *, ' L & T bi-orthogonality: ok' - deallocate( S ) - return - - else - ! impose bi-orthogonality - - print *, ' L & T bi-orthogonality: not imposed yet' - print *, ' accu_nd = ', accu_nd - call impose_biorthog_qr(n, n_real_eigv, thresh_biorthog_diag, thresh_biorthog_nondiag, leigvec, reigvec) - deallocate( S ) - - endif - - ! - ! ------------------------------------------------------------------------------------- - - return - -end - -! --- - -subroutine non_hrmt_real_im(n, A, leigvec, reigvec, n_real_eigv, eigval) - - BEGIN_DOC - ! - ! routine which returns the EIGENVALUES sorted the REAL part 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) - - integer :: i, j - integer :: n_bad - double precision :: thr - double precision :: accu_nd - - integer, allocatable :: iorder(:) - double precision, allocatable :: Aw(:,:) - double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:) - double precision, allocatable :: S(:,:) - double precision :: r - - ! ------------------------------------------------------------------------------------- - ! - - print *, 'Computing the left/right eigenvectors ...' - allocate( WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n), iorder(n)) - - Aw(:,:) = A(:,:) - do i = 1, n - call RANDOM_NUMBER(r) - Aw(i,i) += 10.d-10* r - enddo - call lapack_diag_non_sym(n, Aw, WR, WI, VL, VR) - - ! ------------------------------------------------------------------------------------- - ! track & sort the real eigenvalues - - i = 1 - thr = 1.d-15 - n_real_eigv = 0 - do while (i.le.n) -! print*,i,dabs(WI(i)) - if( dabs(WI(i)).gt.thr ) then - print*, 'Found an imaginary component to eigenvalue on i = ', i - print*, 'Re(i) , Im(i) ', WR(i), WI(i) - iorder(i) = i - eigval(i) = WR(i) - i+=1 - print*, 'Re(i+1),Im(i+1)',WR(i), WI(i) - iorder(i) = i - eigval(i) = WR(i) - i+=1 - else - n_real_eigv += 1 - iorder(i) = i - eigval(i) = WR(i) - i+=1 - endif - enddo - call dsort(eigval, iorder, n) - reigvec(:,:) = 0.d0 - leigvec(:,:) = 0.d0 - do i = 1, n - do j = 1, n - reigvec(j,i) = VR(j,iorder(i)) - leigvec(j,i) = VL(j,iorder(i)) - enddo - enddo - - deallocate( iorder ) - deallocate( VL, VR ) - - ! - ! ------------------------------------------------------------------------------------- - - ! --- - - ! ------------------------------------------------------------------------------------- - ! check bi-orthogonality - - allocate( S(n,n) ) - - ! S = VL x VR - call dgemm( 'T', 'N', n, n, n, 1.d0 & - , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) & - , 0.d0, S, size(S, 1) ) - - accu_nd = 0.d0 - do i = 1, n - do j = 1, n - if(i==j) cycle - accu_nd = accu_nd + S(j,i) * S(j,i) - enddo - enddo - accu_nd = dsqrt(accu_nd) - - deallocate( S ) - -end - -! --- - -subroutine non_hrmt_generalized_real_im(n, A, B, leigvec, reigvec, n_real_eigv, eigval) - - BEGIN_DOC - ! - ! routine which returns the EIGENVALUES sorted the REAL part and corresponding LEFT/RIGHT eigenvetors - ! for A R = lambda B R and A^\dagger L = lambda B^\dagger L - ! - ! 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),B(n,n) - integer, intent(out) :: n_real_eigv - double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n) - - integer :: i, j - integer :: n_bad - double precision :: thr - double precision :: accu_nd - - integer, allocatable :: iorder(:) - double precision, allocatable :: Aw(:,:),Bw(:,:) - double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:), beta(:) - double precision, allocatable :: S(:,:) - double precision :: r - - ! ------------------------------------------------------------------------------------- - ! - - print *, 'Computing the left/right eigenvectors ...' - allocate( WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n), Bw(n,n),iorder(n),beta(n)) - - Aw(:,:) = A(:,:) - Bw(:,:) = B(:,:) - call lapack_diag_general_non_sym(n,Aw,Bw,WR,beta,WI,VL,VR) - - ! ------------------------------------------------------------------------------------- - ! track & sort the real eigenvalues - - i = 1 - thr = 1.d-10 - n_real_eigv = 0 - do while (i.le.n) - if( dabs(WI(i)).gt.thr ) then - print*, 'Found an imaginary component to eigenvalue on i = ', i - print*, 'Re(i) , Im(i) ', WR(i), WI(i) - iorder(i) = i - eigval(i) = WR(i)/(beta(i) + 1.d-10) - i+=1 - print*, 'Re(i+1),Im(i+1)',WR(i), WI(i) - iorder(i) = i - eigval(i) = WR(i)/(beta(i) + 1.d-10) - i+=1 - else - n_real_eigv += 1 - iorder(i) = i - eigval(i) = WR(i)/(beta(i) + 1.d-10) - i+=1 - endif - enddo - call dsort(eigval, iorder, n) - reigvec(:,:) = 0.d0 - leigvec(:,:) = 0.d0 - do i = 1, n - do j = 1, n - reigvec(j,i) = VR(j,iorder(i)) - leigvec(j,i) = VL(j,iorder(i)) - enddo - enddo - - deallocate( iorder ) - deallocate( VL, VR ) - - ! - ! ------------------------------------------------------------------------------------- - - ! --- - - ! ------------------------------------------------------------------------------------- - ! check bi-orthogonality - - allocate( S(n,n) ) - - ! S = VL x VR - call dgemm( 'T', 'N', n, n, n, 1.d0 & - , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) & - , 0.d0, S, size(S, 1) ) - - accu_nd = 0.d0 - do i = 1, n - do j = 1, n - if(i==j) cycle - accu_nd = accu_nd + S(j,i) * S(j,i) - enddo - enddo - accu_nd = dsqrt(accu_nd) - - deallocate( S ) - -end - -! --- - -subroutine non_hrmt_bieig_fullvect(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) - - integer :: i, j - integer :: n_good - double precision :: thr - double precision :: accu_nd - - integer, allocatable :: iorder(:) - double precision, allocatable :: Aw(:,:) - double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:) - double precision, allocatable :: S(:,:) - double precision, allocatable :: eigval_sorted(:) - - - ! ------------------------------------------------------------------------------------- - ! - - print *, 'Computing the left/right eigenvectors ...' - - allocate( WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n) ) - Aw(:,:) = A(:,:) - - call lapack_diag_non_sym_new(n, Aw, WR, WI, VL, VR) - - deallocate( Aw ) - - ! - ! ------------------------------------------------------------------------------------- - - ! --- - - ! ------------------------------------------------------------------------------------- - ! track & sort the real eigenvalues - - allocate( eigval_sorted(n), iorder(n) ) - - n_good = 0 - thr = 1.d-10 - - do i = 1, n - - iorder(i) = i - eigval_sorted(i) = WR(i) - - if(dabs(WI(i)) .gt. thr) then - print*, ' Found an imaginary component to eigenvalue on i = ', i - print*, ' Re(i) + Im(i)', WR(i), WI(i) - else - n_good += 1 - endif - - enddo - - n_real_eigv = n_good - - call dsort(eigval_sorted, iorder, n) - - reigvec(:,:) = 0.d0 - leigvec(:,:) = 0.d0 - do i = 1, n - eigval(i) = WR(i) - do j = 1, n - reigvec(j,i) = VR(j,iorder(i)) - leigvec(j,i) = VL(j,iorder(i)) - enddo - enddo - - deallocate( eigval_sorted, iorder ) - deallocate( WR, WI ) - deallocate( VL, VR ) - - ! - ! ------------------------------------------------------------------------------------- - - ! --- - - ! ------------------------------------------------------------------------------------- - ! check bi-orthogonality - - allocate( S(n,n) ) - - ! S = VL x VR - call dgemm( 'T', 'N', n, n, n, 1.d0 & - , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) & - , 0.d0, S, size(S, 1) ) - - accu_nd = 0.d0 - do i = 1, n - do j = 1, n - if(i==j) cycle - accu_nd = accu_nd + S(j,i) * S(j,i) - enddo - enddo - accu_nd = dsqrt(accu_nd) - - if(accu_nd .lt. thresh_biorthog_nondiag) then - ! L x R is already bi-orthogonal - - !print *, ' L & T bi-orthogonality: ok' - deallocate( S ) - return - - else - ! impose bi-orthogonality - - !print *, ' L & T bi-orthogonality: not imposed yet' - !print *, ' accu_nd = ', accu_nd - call impose_biorthog_qr(n, n, thresh_biorthog_diag, thresh_biorthog_nondiag, leigvec, reigvec) - deallocate( S ) - - endif - - ! - ! ------------------------------------------------------------------------------------- - - return - -end - -! --- - - -subroutine split_matrix_degen(aw,n,shift) - implicit none - BEGIN_DOC - ! subroutines that splits the degeneracies of a matrix by adding a splitting of magnitude thr * n_degen/2 - ! - ! WARNING !! THE MATRIX IS ASSUMED TO BE PASSED WITH INCREASING DIAGONAL ELEMENTS - END_DOC - double precision,intent(inout) :: Aw(n,n) - double precision,intent(in) :: shift - integer, intent(in) :: n - integer :: i,j,n_degen - logical :: keep_on - i=1 - do while(i.lt.n) - if(dabs(Aw(i,i)-Aw(i+1,i+1)).lt.shift)then - j=1 - keep_on = .True. - do while(keep_on) - if(i+j.gt.n)then - keep_on = .False. - exit - endif - if(dabs(Aw(i,i)-Aw(i+j,i+j)).lt.shift)then - j+=1 - else - keep_on=.False. - exit - endif - enddo - n_degen = j - 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,i+j)-Aw(i+j+1,i+j+1)).lt.shift)then - Aw(i+j,i+j) += (j-n_degen/2) * shift - j+=1 - else - keep_on = .False. - exit - endif - enddo - Aw(i+n_degen-1,i+n_degen-1) += (n_degen-1-n_degen/2) * shift - i+=n_degen - else - i+=1 - endif - enddo - -end - -subroutine give_degen(a,n,shift,list_degen,n_degen_list) - implicit none - 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 - 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 - -subroutine cancel_small_elmts(aw,n,shift) - implicit none - BEGIN_DOC - ! subroutines that splits the degeneracies of a matrix by adding a splitting of magnitude thr * n_degen/2 - ! - ! WARNING !! THE MATRIX IS ASSUMED TO BE PASSED WITH INCREASING DIAGONAL ELEMENTS - END_DOC - double precision,intent(inout) :: Aw(n,n) - double precision,intent(in) :: shift - integer, intent(in) :: n - integer :: i,j - do i = 1, n - do j = 1, n - if(dabs(Aw(j,i)).lt.shift)then - Aw(j,i) = 0.d0 - endif - enddo - enddo -end - -subroutine check_bi_ortho(reigvec,leigvec,n,S,accu_nd) - implicit none - integer, intent(in) :: n - double precision,intent(in) :: reigvec(n,n),leigvec(n,n) - double precision, intent(out) :: S(n,n),accu_nd - BEGIN_DOC -! retunrs the overlap matrix S = Leigvec^T Reigvec -! -! and the square root of the sum of the squared off-diagonal elements of S - END_DOC - integer :: i,j ! S = VL x VR call dgemm( 'T', 'N', n, n, n, 1.d0 & , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) & , 0.d0, S, size(S, 1) ) + accu_nd = 0.d0 do i = 1, n do j = 1, n @@ -1213,3 +174,5 @@ subroutine check_bi_ortho(reigvec,leigvec,n,S,accu_nd) accu_nd = dsqrt(accu_nd) end + + diff --git a/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f index 4d4bc047..2c053ac8 100644 --- a/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f +++ b/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 diff --git a/plugins/local/non_hermit_dav/new_routines.irp.f b/plugins/local/non_hermit_dav/new_routines.irp.f deleted file mode 100644 index 8db044d3..00000000 --- a/plugins/local/non_hermit_dav/new_routines.irp.f +++ /dev/null @@ -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 - - diff --git a/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f b/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f index a3f1b6ef..cb7cdb22 100644 --- a/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f +++ b/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 - diff --git a/plugins/local/tc_bi_ortho/EZFIO.cfg b/plugins/local/tc_bi_ortho/EZFIO.cfg index a34d2134..67c780d7 100644 --- a/plugins/local/tc_bi_ortho/EZFIO.cfg +++ b/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 + diff --git a/plugins/local/tc_bi_ortho/print_tc_energy.irp.f b/plugins/local/tc_bi_ortho/print_tc_energy.irp.f index ef38cbcc..1fa0c6d9 100644 --- a/plugins/local/tc_bi_ortho/print_tc_energy.irp.f +++ b/plugins/local/tc_bi_ortho/print_tc_energy.irp.f @@ -6,18 +6,9 @@ program print_tc_energy 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 - read_wf = .True. touch read_wf - PROVIDE j2e_type PROVIDE j1e_type PROVIDE env_type @@ -26,6 +17,27 @@ program print_tc_energy print *, ' j1e_type = ', j1e_type print *, ' env_type = ', env_type + + my_grid_becke = .True. + PROVIDE tc_grid1_a tc_grid1_r + my_n_pt_r_grid = tc_grid1_r + my_n_pt_a_grid = tc_grid1_a + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + 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 + 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 write_tc_energy() end diff --git a/plugins/local/tc_bi_ortho/print_tc_var.irp.f b/plugins/local/tc_bi_ortho/print_tc_var.irp.f index bec34f18..6743cd11 100644 --- a/plugins/local/tc_bi_ortho/print_tc_var.irp.f +++ b/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 diff --git a/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f b/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f index efa4aa2c..ac90f737 100644 --- a/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f +++ b/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 ! --- diff --git a/plugins/local/tc_bi_ortho/tc_utils.irp.f b/plugins/local/tc_bi_ortho/tc_utils.irp.f index 53fe5884..43a6865e 100644 --- a/plugins/local/tc_bi_ortho/tc_utils.irp.f +++ b/plugins/local/tc_bi_ortho/tc_utils.irp.f @@ -2,12 +2,67 @@ subroutine write_tc_energy() implicit none - integer :: i, j, k - double precision :: hmono, htwoe, hthree, htot - double precision :: E_TC, O_TC - double precision :: E_1e, E_2e, E_3e + integer :: i, j, k + 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 + +! --- + + diff --git a/plugins/local/tc_scf/EZFIO.cfg b/plugins/local/tc_scf/EZFIO.cfg index 3dfa9a71..510c777c 100644 --- a/plugins/local/tc_scf/EZFIO.cfg +++ b/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] diff --git a/plugins/local/tc_scf/combine_lr_tcscf.irp.f b/plugins/local/tc_scf/combine_lr_tcscf.irp.f deleted file mode 100644 index a22614ba..00000000 --- a/plugins/local/tc_scf/combine_lr_tcscf.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/diago_vartcfock.irp.f b/plugins/local/tc_scf/diago_vartcfock.irp.f deleted file mode 100644 index 0c881dcb..00000000 --- a/plugins/local/tc_scf/diago_vartcfock.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/diis_tcscf.irp.f b/plugins/local/tc_scf/diis_tcscf.irp.f index 5d7d6b2e..ccc8eb15 100644 --- a/plugins/local/tc_scf/diis_tcscf.irp.f +++ b/plugins/local/tc_scf/diis_tcscf.irp.f @@ -91,28 +91,14 @@ BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)] double precision, allocatable :: tmp(:,:) double precision, allocatable :: F(:,:) - !print *, ' Providing FQS_SQF_ao ...' - !call wall_time(t0) + PROVIDE Fock_matrix_tc_ao_tot 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 + do i = 1, ao_num + do j = 1, ao_num + F(j,i) = Fock_matrix_tc_ao_tot(j,i) 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 + enddo allocate(tmp(ao_num,ao_num)) @@ -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 - -! --- - -~ diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f deleted file mode 100644 index 8fd5e5b6..00000000 --- a/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f deleted file mode 100644 index 4bbce720..00000000 --- a/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f deleted file mode 100644 index 47ee5b48..00000000 --- a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f deleted file mode 100644 index 3bf6bd85..00000000 --- a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/fock_tc.irp.f b/plugins/local/tc_scf/fock_tc.irp.f index d3ddb8ad..508f3cd7 100644 --- a/plugins/local/tc_scf/fock_tc.irp.f +++ b/plugins/local/tc_scf/fock_tc.irp.f @@ -1,78 +1,15 @@ + ! --- - BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_seq_alpha, (ao_num, ao_num)] -&BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_seq_beta , (ao_num, ao_num)] + BEGIN_PROVIDER [ double precision, two_e_tc_integral_alpha, (ao_num, ao_num)] +&BEGIN_PROVIDER [ double precision, two_e_tc_integral_beta , (ao_num, ao_num)] BEGIN_DOC ! - ! two_e_tc_non_hermit_integral_seq_alpha(k,i) = ON THE AO BASIS + ! two_e_tc_integral_alpha(k,i) = ON THE AO BASIS ! - ! where F^tc is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions - ! - ! works in SEQUENTIAL - END_DOC - - implicit none - integer :: i, j, k, l - double precision :: density, density_a, density_b - double precision :: t0, t1 - - PROVIDE ao_two_e_tc_tot - - !print*, ' providing two_e_tc_non_hermit_integral_seq ...' - !call wall_time(t0) - - two_e_tc_non_hermit_integral_seq_alpha = 0.d0 - two_e_tc_non_hermit_integral_seq_beta = 0.d0 - - do i = 1, ao_num - do k = 1, ao_num - 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 - - !! rho(l,j) * < k l| T | i j> - !two_e_tc_non_hermit_integral_seq_alpha(k,i) += density * ao_two_e_tc_tot(l,j,k,i) - !! rho(l,j) * < k l| T | i j> - !two_e_tc_non_hermit_integral_seq_beta (k,i) += density * ao_two_e_tc_tot(l,j,k,i) - !! rho_a(l,j) * < l k| T | i j> - !two_e_tc_non_hermit_integral_seq_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i) - !! rho_b(l,j) * < l k| T | i j> - !two_e_tc_non_hermit_integral_seq_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i) - - ! rho(l,j) * < k l| T | i j> - two_e_tc_non_hermit_integral_seq_alpha(k,i) += density * ao_two_e_tc_tot(k,i,l,j) - ! rho(l,j) * < k l| T | i j> - two_e_tc_non_hermit_integral_seq_beta (k,i) += density * ao_two_e_tc_tot(k,i,l,j) - ! rho_a(l,j) * < k l| T | j i> - two_e_tc_non_hermit_integral_seq_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i) - ! rho_b(l,j) * < k l| T | j i> - two_e_tc_non_hermit_integral_seq_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i) - - enddo - enddo - enddo - enddo - - !call wall_time(t1) - !print*, ' wall time for two_e_tc_non_hermit_integral_seq after = ', t1 - t0 - -END_PROVIDER - -! --- - - BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_alpha, (ao_num, ao_num)] -&BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_beta , (ao_num, ao_num)] - - BEGIN_DOC - ! - ! two_e_tc_non_hermit_integral_alpha(k,i) = ON THE AO BASIS - ! - ! where F^tc is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions + ! where F^tc_2e is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions ! END_DOC @@ -86,16 +23,13 @@ END_PROVIDER PROVIDE mo_l_coef mo_r_coef PROVIDE TCSCF_density_matrix_ao_alpha TCSCF_density_matrix_ao_beta - !print*, ' Providing two_e_tc_non_hermit_integral ...' - !call wall_time(t0) - - two_e_tc_non_hermit_integral_alpha = 0.d0 - two_e_tc_non_hermit_integral_beta = 0.d0 + two_e_tc_integral_alpha = 0.d0 + two_e_tc_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_tc_non_hermit_integral_alpha, two_e_tc_non_hermit_integral_beta) + !$OMP two_e_tc_integral_alpha, two_e_tc_integral_beta) allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num)) tmp_a = 0.d0 @@ -124,8 +58,8 @@ END_PROVIDER !$OMP CRITICAL do i = 1, ao_num do j = 1, ao_num - two_e_tc_non_hermit_integral_alpha(j,i) += tmp_a(j,i) - two_e_tc_non_hermit_integral_beta (j,i) += tmp_b(j,i) + two_e_tc_integral_alpha(j,i) += tmp_a(j,i) + two_e_tc_integral_beta (j,i) += tmp_b(j,i) enddo enddo !$OMP END CRITICAL @@ -133,9 +67,6 @@ END_PROVIDER deallocate(tmp_a, tmp_b) !$OMP END PARALLEL - !call wall_time(t1) - !print*, ' Wall time for two_e_tc_non_hermit_integral = ', t1 - t0 - END_PROVIDER ! --- @@ -149,13 +80,7 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_alpha, (ao_num, ao_num)] implicit none double precision :: t0, t1 - !print*, ' Providing Fock_matrix_tc_ao_alpha ...' - !call wall_time(t0) - - Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_alpha - - !call wall_time(t1) - !print*, ' Wall time for Fock_matrix_tc_ao_alpha =', t1-t0 + Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_tc_integral_alpha END_PROVIDER @@ -169,7 +94,7 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_beta, (ao_num, ao_num)] implicit none - Fock_matrix_tc_ao_beta = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_beta + Fock_matrix_tc_ao_beta = ao_one_e_integrals_tc_tot + two_e_tc_integral_beta END_PROVIDER @@ -185,9 +110,6 @@ BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)] double precision :: t0, t1, tt0, tt1 double precision, allocatable :: tmp(:,:) - !print*, ' Providing Fock_matrix_tc_mo_alpha ...' - !call wall_time(t0) - if(bi_ortho) then PROVIDE mo_l_coef mo_r_coef @@ -196,8 +118,8 @@ BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)] , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) ) if(three_body_h_tc) then - PROVIDE fock_3e_uhf_mo_a - Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a + PROVIDE fock_3e_mo_a + Fock_matrix_tc_mo_alpha += fock_3e_mo_a endif else @@ -207,9 +129,6 @@ BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)] endif - !call wall_time(t1) - !print*, ' Wall time for Fock_matrix_tc_mo_alpha =', t1-t0 - END_PROVIDER ! --- @@ -229,8 +148,8 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ] , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) ) if(three_body_h_tc) then - PROVIDE fock_3e_uhf_mo_b - Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b + PROVIDE fock_3e_mo_b + Fock_matrix_tc_mo_beta += fock_3e_mo_b endif else @@ -286,20 +205,895 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_tot, (ao_num, ao_num) ] implicit none double precision :: t0, t1 - !print*, ' Providing Fock_matrix_tc_ao_tot ...' - !call wall_time(t0) - PROVIDE mo_l_coef mo_r_coef PROVIDE Fock_matrix_tc_mo_tot call mo_to_ao_bi_ortho( Fock_matrix_tc_mo_tot, size(Fock_matrix_tc_mo_tot, 1) & , Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1) ) - !call wall_time(t1) - !print*, ' Wall time for Fock_matrix_tc_ao_tot =', t1-t0 - END_PROVIDER ! --- + +! --- + +BEGIN_PROVIDER [double precision, fock_3e_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 + + ! CLOSED-SHELL PART + PROVIDE fock_3e_mo_cs + fock_3e_mo_a = fock_3e_mo_cs + + if(elec_alpha_num .ne. elec_beta_num) then + + ! OPEN-SHELL PART + PROVIDE fock_3e_mo_a_os + + fock_3e_mo_a += fock_3e_mo_a_os + endif + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, fock_3e_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 + + ! CLOSED-SHELL PART + PROVIDE fock_3e_mo_cs + fock_3e_mo_b = fock_3e_mo_cs + + if(elec_alpha_num .ne. elec_beta_num) then + + ! OPEN-SHELL PART + PROVIDE fock_3e_mo_b_os + + fock_3e_mo_b += fock_3e_mo_b_os + endif + +END_PROVIDER + +! --- + + +! --- + + BEGIN_PROVIDER [double precision, fock_3e_mo_a_os, (mo_num, mo_num)] +&BEGIN_PROVIDER [double precision, fock_3e_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 + + ! --- + + 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_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_mo_b_os(1,1), mo_num) + + deallocate(tmp_3, tmp_4) + + ! --- + + fock_3e_mo_a_os = fock_3e_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_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_mo_a_os(1,1), mo_num) + + deallocate(tmp_3, tmp_4) + deallocate(Jkappa, Okappa) + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, fock_3e_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 + + ! --- + + 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_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_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_mo_cs(1,1), mo_num) + + deallocate(tmp_3, tmp_4) + deallocate(Jkappa, Okappa) + + ! --- + +END_PROVIDER + +! --- + diff --git a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f index eb8973ff..2df2421e 100644 --- a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f +++ b/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 @@ -158,8 +157,8 @@ Fock_matrix_tc_mo_tot += fock_3_mat endif - !call wall_time(t1) - !print*, ' Wall time for Fock_matrix_tc_mo_tot =', t1-t0 - END_PROVIDER +! --- + + diff --git a/plugins/local/tc_scf/fock_vartc.irp.f b/plugins/local/tc_scf/fock_vartc.irp.f deleted file mode 100644 index 2b4a57e5..00000000 --- a/plugins/local/tc_scf/fock_vartc.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/rh_tcscf_diis.irp.f b/plugins/local/tc_scf/rh_tcscf_diis.irp.f index 431b6e08..853c4ab5 100644 --- a/plugins/local/tc_scf/rh_tcscf_diis.irp.f +++ b/plugins/local/tc_scf/rh_tcscf_diis.irp.f @@ -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) diff --git a/plugins/local/tc_scf/rh_tcscf_simple.irp.f b/plugins/local/tc_scf/rh_tcscf_simple.irp.f index 0b79e8ea..2c2cf2c2 100644 --- a/plugins/local/tc_scf/rh_tcscf_simple.irp.f +++ b/plugins/local/tc_scf/rh_tcscf_simple.irp.f @@ -91,7 +91,7 @@ subroutine rh_tcscf_simple() e_delta = dabs(etc_tot - e_save) e_save = etc_tot - call ezfio_set_tc_scf_bitc_energy(etc_tot) + call ezfio_set_tc_scf_tcscf_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)') & diff --git a/plugins/local/tc_scf/rh_vartcscf_simple.irp.f b/plugins/local/tc_scf/rh_vartcscf_simple.irp.f deleted file mode 100644 index ecb0709e..00000000 --- a/plugins/local/tc_scf/rh_vartcscf_simple.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/tc_scf.irp.f b/plugins/local/tc_scf/tc_scf.irp.f index 768069d6..ee8e8dad 100644 --- a/plugins/local/tc_scf/tc_scf.irp.f +++ b/plugins/local/tc_scf/tc_scf.irp.f @@ -13,7 +13,6 @@ program tc_scf PROVIDE j1e_type PROVIDE j2e_type PROVIDE tcscf_algorithm - PROVIDE var_tc print *, ' TC-SCF with:' print *, ' j1e_type = ', j1e_type @@ -45,46 +44,29 @@ program tc_scf !call create_guess() !call orthonormalize_mos() - - if(var_tc) then - - print *, ' VAR-TC' - - if(tcscf_algorithm == 'DIIS') then - print*, ' NOT implemented yet' - elseif(tcscf_algorithm == 'Simple') then - call rh_vartcscf_simple() - else - print *, ' not implemented yet', tcscf_algorithm - stop - endif - + if(tcscf_algorithm == 'DIIS') then + call rh_tcscf_diis() + elseif(tcscf_algorithm == 'Simple') then + call rh_tcscf_simple() else - - 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:' - do i = 1, mo_num - 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) - + print *, ' not implemented yet', tcscf_algorithm + stop endif + PROVIDE Fock_matrix_tc_diag_mo_tot + print*, ' Eigenvalues:' + do i = 1, mo_num + 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) + + write(json_unit,json_array_close_fmtx) call json_close diff --git a/plugins/local/tc_scf/tc_scf_energy.irp.f b/plugins/local/tc_scf/tc_scf_energy.irp.f index 833b48aa..0266c605 100644 --- a/plugins/local/tc_scf/tc_scf_energy.irp.f +++ b/plugins/local/tc_scf/tc_scf_energy.irp.f @@ -11,11 +11,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,8 +20,8 @@ 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) & - + two_e_tc_non_hermit_integral_beta (i,j) * TCSCF_density_matrix_ao_beta (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_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 @@ -33,38 +30,6 @@ TC_HF_energy += TC_HF_one_e_energy + TC_HF_two_e_energy TC_HF_energy += diag_three_elem_hf - !call wall_time(t1) - !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 ! --- diff --git a/plugins/local/tc_scf/test_int.irp.f b/plugins/local/tc_scf/test_int.irp.f deleted file mode 100644 index e135fcd8..00000000 --- a/plugins/local/tc_scf/test_int.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/src/becke_numerical_grid/extra_grid_vector.irp.f b/src/becke_numerical_grid/extra_grid_vector.irp.f index 16a52dc6..e054e22c 100644 --- a/src/becke_numerical_grid/extra_grid_vector.irp.f +++ b/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 diff --git a/src/becke_numerical_grid/grid_becke_vector.irp.f b/src/becke_numerical_grid/grid_becke_vector.irp.f index c35918c3..9da8a099 100644 --- a/src/becke_numerical_grid/grid_becke_vector.irp.f +++ b/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 diff --git a/src/utils/util.irp.f b/src/utils/util.irp.f index 97cbde67..c67bbf03 100644 --- a/src/utils/util.irp.f +++ b/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 ! --- From da8eac81e01e9ee558351195aba1f964ed5fbc0b Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 1 May 2024 21:52:00 +0200 Subject: [PATCH 33/50] TC-SCF CLEANED --- plugins/local/bi_ort_ints/no_dressing.irp.f | 7 +- plugins/local/tc_scf/EZFIO.cfg | 36 + plugins/local/tc_scf/fock_hermit.irp.f | 107 --- plugins/local/tc_scf/fock_tc.irp.f | 40 +- plugins/local/tc_scf/fock_tc_mo_tot.irp.f | 19 +- plugins/local/tc_scf/fock_three_hermit.irp.f | 771 ------------------ .../local/tc_scf/integrals_in_r_stuff.irp.f | 391 --------- plugins/local/tc_scf/jast_schmos_90.irp.f | 318 -------- plugins/local/tc_scf/plot_j_schMos.irp.f | 69 -- plugins/local/tc_scf/print_fit_param.irp.f | 59 -- plugins/local/tc_scf/print_tcscf_energy.irp.f | 55 -- plugins/local/tc_scf/rh_tcscf_simple.irp.f | 129 --- .../local/tc_scf/rotate_tcscf_orbitals.irp.f | 369 --------- .../local/tc_scf/tc_petermann_factor.irp.f | 91 --- plugins/local/tc_scf/tc_scf.irp.f | 25 +- plugins/local/tc_scf/tc_scf_dm.irp.f | 24 +- plugins/local/tc_scf/tc_scf_energy.irp.f | 423 ++++++++++ plugins/local/tc_scf/tcscf_energy_naive.irp.f | 80 -- .../tc_scf/three_e_energy_bi_ortho.irp.f | 189 ----- .../local/tc_scf/write_ao_2e_tc_integ.irp.f | 6 +- 20 files changed, 502 insertions(+), 2706 deletions(-) delete mode 100644 plugins/local/tc_scf/fock_hermit.irp.f delete mode 100644 plugins/local/tc_scf/fock_three_hermit.irp.f delete mode 100644 plugins/local/tc_scf/integrals_in_r_stuff.irp.f delete mode 100644 plugins/local/tc_scf/jast_schmos_90.irp.f delete mode 100644 plugins/local/tc_scf/plot_j_schMos.irp.f delete mode 100644 plugins/local/tc_scf/print_fit_param.irp.f delete mode 100644 plugins/local/tc_scf/print_tcscf_energy.irp.f delete mode 100644 plugins/local/tc_scf/rh_tcscf_simple.irp.f delete mode 100644 plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f delete mode 100644 plugins/local/tc_scf/tc_petermann_factor.irp.f delete mode 100644 plugins/local/tc_scf/tcscf_energy_naive.irp.f delete mode 100644 plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f diff --git a/plugins/local/bi_ort_ints/no_dressing.irp.f b/plugins/local/bi_ort_ints/no_dressing.irp.f index bd225274..721ac0f8 100644 --- a/plugins/local/bi_ort_ints/no_dressing.irp.f +++ b/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,7 +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 ..." diff --git a/plugins/local/tc_scf/EZFIO.cfg b/plugins/local/tc_scf/EZFIO.cfg index 510c777c..6820a8b0 100644 --- a/plugins/local/tc_scf/EZFIO.cfg +++ b/plugins/local/tc_scf/EZFIO.cfg @@ -9,3 +9,39 @@ 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. + +[im_thresh_tcscf] +type: Threshold +doc: Thresholds on the Imag part of energy +interface: ezfio,provider,ocaml +default: 1.e-7 + +[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 + diff --git a/plugins/local/tc_scf/fock_hermit.irp.f b/plugins/local/tc_scf/fock_hermit.irp.f deleted file mode 100644 index 5a51b324..00000000 --- a/plugins/local/tc_scf/fock_hermit.irp.f +++ /dev/null @@ -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(symetric_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(symetric_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 - -! --- - diff --git a/plugins/local/tc_scf/fock_tc.irp.f b/plugins/local/tc_scf/fock_tc.irp.f index 508f3cd7..16bb5c87 100644 --- a/plugins/local/tc_scf/fock_tc.irp.f +++ b/plugins/local/tc_scf/fock_tc.irp.f @@ -110,23 +110,14 @@ BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)] double precision :: t0, t1, tt0, tt1 double precision, allocatable :: tmp(:,:) - if(bi_ortho) then + PROVIDE mo_l_coef mo_r_coef - PROVIDE mo_l_coef mo_r_coef - - call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) & - , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) ) - - if(three_body_h_tc) then - PROVIDE fock_3e_mo_a - Fock_matrix_tc_mo_alpha += fock_3e_mo_a - endif - - else - - call ao_to_mo( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) & - , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) ) + call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) & + , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) ) + if(three_body_h_tc) then + PROVIDE fock_3e_mo_a + Fock_matrix_tc_mo_alpha += fock_3e_mo_a endif END_PROVIDER @@ -142,21 +133,12 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ] implicit none double precision, allocatable :: tmp(:,:) - if(bi_ortho) then - - call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) & - , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) ) - - if(three_body_h_tc) then - PROVIDE fock_3e_mo_b - Fock_matrix_tc_mo_beta += fock_3e_mo_b - endif - - else - - call ao_to_mo( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) & - , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) ) + call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) & + , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) ) + if(three_body_h_tc) then + PROVIDE fock_3e_mo_b + Fock_matrix_tc_mo_beta += fock_3e_mo_b endif END_PROVIDER diff --git a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f index 2df2421e..fd490af6 100644 --- a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f +++ b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f @@ -132,7 +132,7 @@ enddo endif - if(no_oa_or_av_opt)then + if(no_oa_or_av_opt) then do i = 1, n_act_orb iorb = list_act(i) do j = 1, n_inact_orb @@ -153,8 +153,21 @@ enddo endif - if(.not.bi_ortho .and. three_body_h_tc)then - Fock_matrix_tc_mo_tot += fock_3_mat + if(tc_Brillouin_Right) then + + double precision, allocatable :: tmp(:,:) + 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 diff --git a/plugins/local/tc_scf/fock_three_hermit.irp.f b/plugins/local/tc_scf/fock_three_hermit.irp.f deleted file mode 100644 index 00d47fae..00000000 --- a/plugins/local/tc_scf/fock_three_hermit.irp.f +++ /dev/null @@ -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) ! - 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 - - - - - diff --git a/plugins/local/tc_scf/integrals_in_r_stuff.irp.f b/plugins/local/tc_scf/integrals_in_r_stuff.irp.f deleted file mode 100644 index 3ce85a97..00000000 --- a/plugins/local/tc_scf/integrals_in_r_stuff.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/jast_schmos_90.irp.f b/plugins/local/tc_scf/jast_schmos_90.irp.f deleted file mode 100644 index 5c5e625f..00000000 --- a/plugins/local/tc_scf/jast_schmos_90.irp.f +++ /dev/null @@ -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 diff --git a/plugins/local/tc_scf/plot_j_schMos.irp.f b/plugins/local/tc_scf/plot_j_schMos.irp.f deleted file mode 100644 index eda0dd25..00000000 --- a/plugins/local/tc_scf/plot_j_schMos.irp.f +++ /dev/null @@ -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 diff --git a/plugins/local/tc_scf/print_fit_param.irp.f b/plugins/local/tc_scf/print_fit_param.irp.f deleted file mode 100644 index e62f0dde..00000000 --- a/plugins/local/tc_scf/print_fit_param.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/print_tcscf_energy.irp.f b/plugins/local/tc_scf/print_tcscf_energy.irp.f deleted file mode 100644 index 6f9afd9a..00000000 --- a/plugins/local/tc_scf/print_tcscf_energy.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/rh_tcscf_simple.irp.f b/plugins/local/tc_scf/rh_tcscf_simple.irp.f deleted file mode 100644 index 2c2cf2c2..00000000 --- a/plugins/local/tc_scf/rh_tcscf_simple.irp.f +++ /dev/null @@ -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_tcscf_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 - -! --- - diff --git a/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f b/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f deleted file mode 100644 index 0f2663e5..00000000 --- a/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f +++ /dev/null @@ -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 - -! --- diff --git a/plugins/local/tc_scf/tc_petermann_factor.irp.f b/plugins/local/tc_scf/tc_petermann_factor.irp.f deleted file mode 100644 index 14fff898..00000000 --- a/plugins/local/tc_scf/tc_petermann_factor.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/tc_scf.irp.f b/plugins/local/tc_scf/tc_scf.irp.f index ee8e8dad..f099b90e 100644 --- a/plugins/local/tc_scf/tc_scf.irp.f +++ b/plugins/local/tc_scf/tc_scf.irp.f @@ -10,13 +10,10 @@ program tc_scf integer :: i logical :: good_angles - PROVIDE j1e_type - PROVIDE j2e_type - PROVIDE tcscf_algorithm - print *, ' TC-SCF with:' - print *, ' j1e_type = ', j1e_type print *, ' j2e_type = ', j2e_type + print *, ' j1e_type = ', j1e_type + print *, ' env_type = ', env_type write(json_unit,json_array_open_fmt) 'tc-scf' @@ -29,7 +26,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 @@ -41,17 +37,7 @@ program tc_scf call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over') endif - !call create_guess() - !call orthonormalize_mos() - - 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 + call rh_tcscf_diis() PROVIDE Fock_matrix_tc_diag_mo_tot print*, ' Eigenvalues:' @@ -59,14 +45,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 + if(minimize_lr_angles) then call minimize_tc_orb_angles() endif call print_energy_and_mos(good_angles) - write(json_unit,json_array_close_fmtx) call json_close diff --git a/plugins/local/tc_scf/tc_scf_dm.irp.f b/plugins/local/tc_scf/tc_scf_dm.irp.f index bf31a4a1..5d25fce2 100644 --- a/plugins/local/tc_scf/tc_scf_dm.irp.f +++ b/plugins/local/tc_scf/tc_scf_dm.irp.f @@ -10,16 +10,8 @@ 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 + PROVIDE mo_l_coef mo_r_coef + TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta END_PROVIDER @@ -35,16 +27,8 @@ 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 + PROVIDE mo_l_coef mo_r_coef + TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha END_PROVIDER diff --git a/plugins/local/tc_scf/tc_scf_energy.irp.f b/plugins/local/tc_scf/tc_scf_energy.irp.f index 0266c605..c9366195 100644 --- a/plugins/local/tc_scf/tc_scf_energy.irp.f +++ b/plugins/local/tc_scf/tc_scf_energy.irp.f @@ -34,3 +34,426 @@ END_PROVIDER ! --- +BEGIN_PROVIDER [double precision, diag_three_elem_hf] + + BEGIN_DOC + ! + ! < Phi_left | L | Phi_right > + ! + ! + ! if three_body_h_tc == false and noL_standard == true ==> do a normal ordering + ! + ! todo + ! this should be equivalent to + ! three_body_h_tc == true and noL_standard == false + ! + ! if three_body_h_tc == false and noL_standard == false ==> this is equal to 0 + ! + END_DOC + + 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 + + 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 + + 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 ! elec_alpha_num .neq. elec_beta_num + + 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 ! alpha/beta condition + + endif ! three_body_h_tc + +END_PROVIDER + +! --- + diff --git a/plugins/local/tc_scf/tcscf_energy_naive.irp.f b/plugins/local/tc_scf/tcscf_energy_naive.irp.f deleted file mode 100644 index 82bb8799..00000000 --- a/plugins/local/tc_scf/tcscf_energy_naive.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f b/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f deleted file mode 100644 index 0c9ebbd7..00000000 --- a/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f +++ /dev/null @@ -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 - - diff --git a/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f b/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f index 7ce57578..ec5167d1 100644 --- a/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f +++ b/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 From d43d960b1a15e7ddb9dcf1e871bf6e9a4e70983b Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 1 May 2024 21:52:00 +0200 Subject: [PATCH 34/50] TC-SCF CLEANED --- plugins/local/bi_ort_ints/no_dressing.irp.f | 7 +- plugins/local/non_hermit_dav/biorthog.irp.f | 2 +- plugins/local/slater_tc/NEED | 1 + .../symmetrized_3_e_int_prov.irp.f | 0 plugins/local/tc_bi_ortho/test_tc_fock.irp.f | 33 - plugins/local/tc_keywords/EZFIO.cfg | 48 +- plugins/local/tc_keywords/tc_keywords.irp.f | 7 - plugins/local/tc_scf/EZFIO.cfg | 30 + plugins/local/tc_scf/fock_hermit.irp.f | 107 --- plugins/local/tc_scf/fock_tc.irp.f | 40 +- plugins/local/tc_scf/fock_tc_mo_tot.irp.f | 19 +- plugins/local/tc_scf/fock_three_hermit.irp.f | 771 ------------------ .../local/tc_scf/integrals_in_r_stuff.irp.f | 391 --------- plugins/local/tc_scf/jast_schmos_90.irp.f | 318 -------- plugins/local/tc_scf/plot_j_schMos.irp.f | 69 -- plugins/local/tc_scf/print_fit_param.irp.f | 59 -- plugins/local/tc_scf/print_tcscf_energy.irp.f | 55 -- plugins/local/tc_scf/rh_tcscf_diis.irp.f | 4 +- plugins/local/tc_scf/rh_tcscf_simple.irp.f | 129 --- .../local/tc_scf/rotate_tcscf_orbitals.irp.f | 369 --------- .../local/tc_scf/tc_petermann_factor.irp.f | 91 --- plugins/local/tc_scf/tc_scf.irp.f | 25 +- plugins/local/tc_scf/tc_scf_dm.irp.f | 24 +- plugins/local/tc_scf/tc_scf_energy.irp.f | 16 +- plugins/local/tc_scf/tcscf_energy_naive.irp.f | 80 -- .../tc_scf/three_e_energy_bi_ortho.irp.f | 189 ----- .../local/tc_scf/write_ao_2e_tc_integ.irp.f | 6 +- 27 files changed, 94 insertions(+), 2796 deletions(-) rename plugins/local/{tc_bi_ortho => slater_tc}/symmetrized_3_e_int_prov.irp.f (100%) delete mode 100644 plugins/local/tc_keywords/tc_keywords.irp.f delete mode 100644 plugins/local/tc_scf/fock_hermit.irp.f delete mode 100644 plugins/local/tc_scf/fock_three_hermit.irp.f delete mode 100644 plugins/local/tc_scf/integrals_in_r_stuff.irp.f delete mode 100644 plugins/local/tc_scf/jast_schmos_90.irp.f delete mode 100644 plugins/local/tc_scf/plot_j_schMos.irp.f delete mode 100644 plugins/local/tc_scf/print_fit_param.irp.f delete mode 100644 plugins/local/tc_scf/print_tcscf_energy.irp.f delete mode 100644 plugins/local/tc_scf/rh_tcscf_simple.irp.f delete mode 100644 plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f delete mode 100644 plugins/local/tc_scf/tc_petermann_factor.irp.f delete mode 100644 plugins/local/tc_scf/tcscf_energy_naive.irp.f delete mode 100644 plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f diff --git a/plugins/local/bi_ort_ints/no_dressing.irp.f b/plugins/local/bi_ort_ints/no_dressing.irp.f index bd225274..721ac0f8 100644 --- a/plugins/local/bi_ort_ints/no_dressing.irp.f +++ b/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,7 +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 ..." diff --git a/plugins/local/non_hermit_dav/biorthog.irp.f b/plugins/local/non_hermit_dav/biorthog.irp.f index b36b0130..4b618228 100644 --- a/plugins/local/non_hermit_dav/biorthog.irp.f +++ b/plugins/local/non_hermit_dav/biorthog.irp.f @@ -43,7 +43,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei ! track & sort the real eigenvalues n_good = 0 - thr = Im_thresh_tcscf + thr = Im_thresh_tc do i = 1, n if(dabs(WI(i)) .lt. thr) then n_good += 1 diff --git a/plugins/local/slater_tc/NEED b/plugins/local/slater_tc/NEED index ef0aa3f7..a8669866 100644 --- a/plugins/local/slater_tc/NEED +++ b/plugins/local/slater_tc/NEED @@ -5,3 +5,4 @@ bi_ortho_mos tc_keywords non_hermit_dav dav_general_mat +tc_scf diff --git a/plugins/local/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f b/plugins/local/slater_tc/symmetrized_3_e_int_prov.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f rename to plugins/local/slater_tc/symmetrized_3_e_int_prov.irp.f diff --git a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f b/plugins/local/tc_bi_ortho/test_tc_fock.irp.f index f1a7cc0a..85f3ed97 100644 --- a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f +++ b/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 diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg index e4d9701a..33b9db57 100644 --- a/plugins/local/tc_keywords/EZFIO.cfg +++ b/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 - [symetric_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 + diff --git a/plugins/local/tc_keywords/tc_keywords.irp.f b/plugins/local/tc_keywords/tc_keywords.irp.f deleted file mode 100644 index 3bc68550..00000000 --- a/plugins/local/tc_keywords/tc_keywords.irp.f +++ /dev/null @@ -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 diff --git a/plugins/local/tc_scf/EZFIO.cfg b/plugins/local/tc_scf/EZFIO.cfg index 510c777c..e3d24338 100644 --- a/plugins/local/tc_scf/EZFIO.cfg +++ b/plugins/local/tc_scf/EZFIO.cfg @@ -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 + diff --git a/plugins/local/tc_scf/fock_hermit.irp.f b/plugins/local/tc_scf/fock_hermit.irp.f deleted file mode 100644 index 5a51b324..00000000 --- a/plugins/local/tc_scf/fock_hermit.irp.f +++ /dev/null @@ -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(symetric_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(symetric_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 - -! --- - diff --git a/plugins/local/tc_scf/fock_tc.irp.f b/plugins/local/tc_scf/fock_tc.irp.f index 508f3cd7..16bb5c87 100644 --- a/plugins/local/tc_scf/fock_tc.irp.f +++ b/plugins/local/tc_scf/fock_tc.irp.f @@ -110,23 +110,14 @@ BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)] double precision :: t0, t1, tt0, tt1 double precision, allocatable :: tmp(:,:) - if(bi_ortho) then + PROVIDE mo_l_coef mo_r_coef - PROVIDE mo_l_coef mo_r_coef - - call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) & - , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) ) - - if(three_body_h_tc) then - PROVIDE fock_3e_mo_a - Fock_matrix_tc_mo_alpha += fock_3e_mo_a - endif - - else - - call ao_to_mo( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) & - , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) ) + call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) & + , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) ) + if(three_body_h_tc) then + PROVIDE fock_3e_mo_a + Fock_matrix_tc_mo_alpha += fock_3e_mo_a endif END_PROVIDER @@ -142,21 +133,12 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ] implicit none double precision, allocatable :: tmp(:,:) - if(bi_ortho) then - - call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) & - , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) ) - - if(three_body_h_tc) then - PROVIDE fock_3e_mo_b - Fock_matrix_tc_mo_beta += fock_3e_mo_b - endif - - else - - call ao_to_mo( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) & - , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) ) + call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) & + , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) ) + if(three_body_h_tc) then + PROVIDE fock_3e_mo_b + Fock_matrix_tc_mo_beta += fock_3e_mo_b endif END_PROVIDER diff --git a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f index 2df2421e..fd490af6 100644 --- a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f +++ b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f @@ -132,7 +132,7 @@ enddo endif - if(no_oa_or_av_opt)then + if(no_oa_or_av_opt) then do i = 1, n_act_orb iorb = list_act(i) do j = 1, n_inact_orb @@ -153,8 +153,21 @@ enddo endif - if(.not.bi_ortho .and. three_body_h_tc)then - Fock_matrix_tc_mo_tot += fock_3_mat + if(tc_Brillouin_Right) then + + double precision, allocatable :: tmp(:,:) + 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 diff --git a/plugins/local/tc_scf/fock_three_hermit.irp.f b/plugins/local/tc_scf/fock_three_hermit.irp.f deleted file mode 100644 index 00d47fae..00000000 --- a/plugins/local/tc_scf/fock_three_hermit.irp.f +++ /dev/null @@ -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) ! - 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 - - - - - diff --git a/plugins/local/tc_scf/integrals_in_r_stuff.irp.f b/plugins/local/tc_scf/integrals_in_r_stuff.irp.f deleted file mode 100644 index 3ce85a97..00000000 --- a/plugins/local/tc_scf/integrals_in_r_stuff.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/jast_schmos_90.irp.f b/plugins/local/tc_scf/jast_schmos_90.irp.f deleted file mode 100644 index 5c5e625f..00000000 --- a/plugins/local/tc_scf/jast_schmos_90.irp.f +++ /dev/null @@ -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 diff --git a/plugins/local/tc_scf/plot_j_schMos.irp.f b/plugins/local/tc_scf/plot_j_schMos.irp.f deleted file mode 100644 index eda0dd25..00000000 --- a/plugins/local/tc_scf/plot_j_schMos.irp.f +++ /dev/null @@ -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 diff --git a/plugins/local/tc_scf/print_fit_param.irp.f b/plugins/local/tc_scf/print_fit_param.irp.f deleted file mode 100644 index e62f0dde..00000000 --- a/plugins/local/tc_scf/print_fit_param.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/print_tcscf_energy.irp.f b/plugins/local/tc_scf/print_tcscf_energy.irp.f deleted file mode 100644 index 6f9afd9a..00000000 --- a/plugins/local/tc_scf/print_tcscf_energy.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/rh_tcscf_diis.irp.f b/plugins/local/tc_scf/rh_tcscf_diis.irp.f index 853c4ab5..1cade02a 100644 --- a/plugins/local/tc_scf/rh_tcscf_diis.irp.f +++ b/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) diff --git a/plugins/local/tc_scf/rh_tcscf_simple.irp.f b/plugins/local/tc_scf/rh_tcscf_simple.irp.f deleted file mode 100644 index 2c2cf2c2..00000000 --- a/plugins/local/tc_scf/rh_tcscf_simple.irp.f +++ /dev/null @@ -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_tcscf_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 - -! --- - diff --git a/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f b/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f deleted file mode 100644 index 0f2663e5..00000000 --- a/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f +++ /dev/null @@ -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 - -! --- diff --git a/plugins/local/tc_scf/tc_petermann_factor.irp.f b/plugins/local/tc_scf/tc_petermann_factor.irp.f deleted file mode 100644 index 14fff898..00000000 --- a/plugins/local/tc_scf/tc_petermann_factor.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/tc_scf.irp.f b/plugins/local/tc_scf/tc_scf.irp.f index ee8e8dad..f099b90e 100644 --- a/plugins/local/tc_scf/tc_scf.irp.f +++ b/plugins/local/tc_scf/tc_scf.irp.f @@ -10,13 +10,10 @@ program tc_scf integer :: i logical :: good_angles - PROVIDE j1e_type - PROVIDE j2e_type - PROVIDE tcscf_algorithm - print *, ' TC-SCF with:' - print *, ' j1e_type = ', j1e_type print *, ' j2e_type = ', j2e_type + print *, ' j1e_type = ', j1e_type + print *, ' env_type = ', env_type write(json_unit,json_array_open_fmt) 'tc-scf' @@ -29,7 +26,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 @@ -41,17 +37,7 @@ program tc_scf call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over') endif - !call create_guess() - !call orthonormalize_mos() - - 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 + call rh_tcscf_diis() PROVIDE Fock_matrix_tc_diag_mo_tot print*, ' Eigenvalues:' @@ -59,14 +45,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 + if(minimize_lr_angles) then call minimize_tc_orb_angles() endif call print_energy_and_mos(good_angles) - write(json_unit,json_array_close_fmtx) call json_close diff --git a/plugins/local/tc_scf/tc_scf_dm.irp.f b/plugins/local/tc_scf/tc_scf_dm.irp.f index bf31a4a1..5d25fce2 100644 --- a/plugins/local/tc_scf/tc_scf_dm.irp.f +++ b/plugins/local/tc_scf/tc_scf_dm.irp.f @@ -10,16 +10,8 @@ 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 + PROVIDE mo_l_coef mo_r_coef + TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta END_PROVIDER @@ -35,16 +27,8 @@ 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 + PROVIDE mo_l_coef mo_r_coef + TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha END_PROVIDER diff --git a/plugins/local/tc_scf/tc_scf_energy.irp.f b/plugins/local/tc_scf/tc_scf_energy.irp.f index 0266c605..74ab9d05 100644 --- a/plugins/local/tc_scf/tc_scf_energy.irp.f +++ b/plugins/local/tc_scf/tc_scf_energy.irp.f @@ -1,7 +1,8 @@ - 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_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. @@ -27,8 +28,13 @@ enddo enddo - TC_HF_energy += TC_HF_one_e_energy + TC_HF_two_e_energy - TC_HF_energy += diag_three_elem_hf + if((three_body_h_tc .eq. .False.) .and. (.not. noL_standard)) then + TC_HF_three_e_energy = 0.d0 + else + TC_HF_three_e_energy = noL_0e + endif + + TC_HF_energy += TC_HF_one_e_energy + TC_HF_two_e_energy + TC_HF_three_e_energy END_PROVIDER diff --git a/plugins/local/tc_scf/tcscf_energy_naive.irp.f b/plugins/local/tc_scf/tcscf_energy_naive.irp.f deleted file mode 100644 index 82bb8799..00000000 --- a/plugins/local/tc_scf/tcscf_energy_naive.irp.f +++ /dev/null @@ -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 - -! --- - diff --git a/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f b/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f deleted file mode 100644 index 0c9ebbd7..00000000 --- a/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f +++ /dev/null @@ -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 - - diff --git a/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f b/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f index 7ce57578..ec5167d1 100644 --- a/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f +++ b/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 From 23acd603d01118e0f2ce59fb14568a64d9994335 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Wed, 1 May 2024 23:17:36 +0200 Subject: [PATCH 35/50] removed diag_three_elem_hf --- plugins/local/tc_scf/tc_scf_energy.irp.f | 423 ----------------------- 1 file changed, 423 deletions(-) diff --git a/plugins/local/tc_scf/tc_scf_energy.irp.f b/plugins/local/tc_scf/tc_scf_energy.irp.f index 14d618ae..74ab9d05 100644 --- a/plugins/local/tc_scf/tc_scf_energy.irp.f +++ b/plugins/local/tc_scf/tc_scf_energy.irp.f @@ -40,426 +40,3 @@ END_PROVIDER ! --- -BEGIN_PROVIDER [double precision, diag_three_elem_hf] - - BEGIN_DOC - ! - ! < Phi_left | L | Phi_right > - ! - ! - ! if three_body_h_tc == false and noL_standard == true ==> do a normal ordering - ! - ! todo - ! this should be equivalent to - ! three_body_h_tc == true and noL_standard == false - ! - ! if three_body_h_tc == false and noL_standard == false ==> this is equal to 0 - ! - END_DOC - - 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 - - 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 - - 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 ! elec_alpha_num .neq. elec_beta_num - - 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 ! alpha/beta condition - - endif ! three_body_h_tc - -END_PROVIDER - -! --- - From 1c2b737586eba60cfec15ce8c452bdff727c70b9 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 2 May 2024 16:05:13 +0200 Subject: [PATCH 36/50] Fixed Warning with nproc --- src/utils/util.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/util.irp.f b/src/utils/util.irp.f index 97cbde67..de01656b 100644 --- a/src/utils/util.irp.f +++ b/src/utils/util.irp.f @@ -327,12 +327,12 @@ subroutine wall_time(t) end BEGIN_PROVIDER [ integer, nproc ] + use omp_lib implicit none BEGIN_DOC ! Number of current OpenMP threads END_DOC - integer, external :: omp_get_num_threads nproc = 1 !$OMP PARALLEL !$OMP MASTER From 425e7e4ee0ac740220bb921ba7a607836b1acffe Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 2 May 2024 16:22:01 +0200 Subject: [PATCH 37/50] Changed symetric_fock_tc into symmetric_fock_tc --- plugins/local/tc_keywords/EZFIO.cfg | 2 +- plugins/local/tc_scf/fock_hermit.irp.f | 20 ++++++++++---------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg index bc691fc3..e0776136 100644 --- a/plugins/local/tc_keywords/EZFIO.cfg +++ b/plugins/local/tc_keywords/EZFIO.cfg @@ -106,7 +106,7 @@ doc: If |true|, the MO basis is assumed to be bi-orthonormal interface: ezfio,provider,ocaml default: True -[symetric_fock_tc] +[symmetric_fock_tc] type: logical doc: If |true|, using F+F^t as Fock TC interface: ezfio,provider,ocaml diff --git a/plugins/local/tc_scf/fock_hermit.irp.f b/plugins/local/tc_scf/fock_hermit.irp.f index 5a51b324..3460157e 100644 --- a/plugins/local/tc_scf/fock_hermit.irp.f +++ b/plugins/local/tc_scf/fock_hermit.irp.f @@ -4,7 +4,7 @@ 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 +! 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 @@ -14,11 +14,11 @@ BEGIN_PROVIDER [ double precision, good_hermit_tc_fock_mat, (mo_num, mo_num)] 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) + good_hermit_tc_fock_mat(i,j) = Fock_matrix_tc_mo_tot(j,i) enddo enddo -END_PROVIDER +END_PROVIDER BEGIN_PROVIDER [ double precision, hermit_average_tc_fock_mat, (mo_num, mo_num)] @@ -35,7 +35,7 @@ BEGIN_PROVIDER [ double precision, hermit_average_tc_fock_mat, (mo_num, mo_num)] enddo enddo -END_PROVIDER +END_PROVIDER ! --- @@ -44,13 +44,13 @@ BEGIN_PROVIDER [ double precision, grad_hermit] BEGIN_DOC ! square of gradient of the energy END_DOC - if(symetric_fock_tc)then + 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 +END_PROVIDER BEGIN_PROVIDER [ double precision, grad_good_hermit_tc_fock_mat] implicit none @@ -64,7 +64,7 @@ BEGIN_PROVIDER [ double precision, grad_good_hermit_tc_fock_mat] grad_good_hermit_tc_fock_mat += dabs(good_hermit_tc_fock_mat(i,j)) enddo enddo -END_PROVIDER +END_PROVIDER ! --- @@ -80,7 +80,7 @@ BEGIN_PROVIDER [ double precision, grad_hermit_average_tc_fock_mat] grad_hermit_average_tc_fock_mat += dabs(hermit_average_tc_fock_mat(i,j)) enddo enddo -END_PROVIDER +END_PROVIDER ! --- @@ -95,8 +95,8 @@ subroutine save_good_hermit_tc_eigvectors() sign = 1 label = "Canonical" output = .False. - - if(symetric_fock_tc)then + + 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) From bd8d45b99b7505e00533bd9e97ad1b43453fb037 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Thu, 2 May 2024 17:18:45 +0200 Subject: [PATCH 38/50] FIXED BUG IN OPTIM J_BH --- plugins/local/bi_ort_ints/no_dressing.irp.f | 8 - .../non_h_ints_mu/jast_deriv_utils_vect.irp.f | 183 ++++++++---------- plugins/local/slater_tc/tc_hmat.irp.f | 1 + .../local/tc_bi_ortho/print_tc_energy.irp.f | 27 ++- plugins/local/tc_scf/tc_scf.irp.f | 31 ++- 5 files changed, 117 insertions(+), 133 deletions(-) diff --git a/plugins/local/bi_ort_ints/no_dressing.irp.f b/plugins/local/bi_ort_ints/no_dressing.irp.f index 721ac0f8..fd2c6285 100644 --- a/plugins/local/bi_ort_ints/no_dressing.irp.f +++ b/plugins/local/bi_ort_ints/no_dressing.irp.f @@ -336,9 +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)) @@ -713,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 ! --- diff --git a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f index 33563102..db06e835 100644 --- a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f +++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f @@ -4,7 +4,7 @@ subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res) BEGIN_DOC - ! + ! ! grad_1 u(r1,r2) ! ! we use grid for r1 and extra_grid for r2 @@ -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 @@ -181,7 +181,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz) ! d/dy1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (y1 - y2) ! d/dz1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (z1 - z2) - do jpoint = 1, n_points_extra_final_grid ! r2 + do jpoint = 1, n_points_extra_final_grid ! r2 r2(1) = final_grid_points_extra(1,jpoint) r2(2) = final_grid_points_extra(2,jpoint) @@ -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 - - if(r12 .lt. 1d-20) then - gradx(jpoint) = 0.d0 - grady(jpoint) = 0.d0 - gradz(jpoint) = 0.d0 + r12 = dsqrt(dx * dx + dy * dy + dz * dz) + if(r12 .lt. 1d-10) then + gradx(jpoint) = 0.d0 + grady(jpoint) = 0.d0 + gradz(jpoint) = 0.d0 cycle endif - r12_inv = 1.d0/dsqrt(r12) - r12 = r12*r12_inv - - tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) * r12_inv + tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12 gradx(jpoint) = tmp * dx grady(jpoint) = tmp * dy @@ -212,10 +208,10 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz) elseif(j2e_type .eq. "Mur") then - ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2) + ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2) ! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2) - do jpoint = 1, n_points_extra_final_grid ! r2 + do jpoint = 1, n_points_extra_final_grid ! r2 r2(1) = final_grid_points_extra(1,jpoint) r2(2) = final_grid_points_extra(2,jpoint) @@ -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) - 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 + tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12 gradx(jpoint) = gradx(jpoint) + tmp * dx grady(jpoint) = grady(jpoint) + tmp * dy @@ -264,7 +254,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz) PROVIDE a_boys - do jpoint = 1, n_points_extra_final_grid ! r2 + do jpoint = 1, n_points_extra_final_grid ! r2 r2(1) = final_grid_points_extra(1,jpoint) r2(2) = final_grid_points_extra(2,jpoint) @@ -273,17 +263,14 @@ 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 - gradz(jpoint) = 0.d0 + gradx(jpoint) = 0.d0 + grady(jpoint) = 0.d0 + gradz(jpoint) = 0.d0 cycle endif - r12 = dsqrt(r12) - tmp = 1.d0 + a_boys * r12 tmp = 0.5d0 / (r12 * tmp * tmp) @@ -294,13 +281,16 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz) elseif(j2e_type .eq. "Boys_Handy") then - integer :: powmax - powmax = max(maxval(jBH_m),maxval(jBH_n)) - + integer :: powmax1, powmax, powmax2 double precision, allocatable :: f1A_power(:), f2A_power(:), double_p(:), g12_power(:) - allocate (f1A_power(-1:powmax), f2A_power(-1:powmax), g12_power(-1:powmax), double_p(0:powmax)) - do p=0,powmax + 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 double_p(p) = dble(p) enddo @@ -318,11 +308,10 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz) r2(2) = final_grid_points_extra(2,jpoint) r2(3) = final_grid_points_extra(3,jpoint) - gradx(jpoint) = 0.d0 - grady(jpoint) = 0.d0 - gradz(jpoint) = 0.d0 - - do i_nucl = 1, nucl_num + 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) rn(2) = nucl_coord(i_nucl,2) @@ -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, maxval(jBH_m(:,i_nucl)) + do p = 1, powmax1 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, maxval(jBH_o(:,i_nucl)) + do p = 1, powmax2 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,27 +339,22 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz) tmp = tmp * 0.5d0 endif -!TODO : Powers to optimize here - -! tmp1 = 0.d0 -! if(mpA .gt. 0) then -! tmp1 = tmp1 + dble(mpA) * f1A**(mpA-1) * f2A**npA -! endif -! if(npA .gt. 0) then -! tmp1 = tmp1 + dble(npA) * f1A**(npA-1) * f2A**mpA -! endif -! tmp1 = tmp1 * g12**(opA) -! -! tmp2 = 0.d0 -! if(opA .gt. 0) then -! tmp2 = tmp2 + dble(opA) * g12**(opA-1) * (f1A**(mpA) * f2A**(npA) + f1A**(npA) * f2A**(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)) + !tmp1 = 0.d0 + !if(mpA .gt. 0) then + ! tmp1 = tmp1 + dble(mpA) * f1A**dble(mpA-1) * f2A**dble(npA) + !endif + !if(npA .gt. 0) then + ! tmp1 = tmp1 + dble(npA) * f1A**dble(npA-1) * f2A**dble(mpA) + !endif + !tmp1 = tmp1 * g12**dble(opA) + !tmp2 = 0.d0 + !if(opA .gt. 0) then + ! tmp2 = tmp2 + dble(opA) * g12**dble(opA-1) * (f1A**dble(mpA) * f2A**dble(npA) + f1A**dble(npA) * f2A**dble(mpA)) + !endif 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)) @@ -418,10 +394,10 @@ 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 + do jpoint = 1, n_points_extra_final_grid ! r2 r2(1) = final_grid_points_extra(1,jpoint) r2(2) = final_grid_points_extra(2,jpoint) @@ -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 - - if(r12 .lt. 1d-20) then - gradx(jpoint) = 0.d0 - grady(jpoint) = 0.d0 - gradz(jpoint) = 0.d0 + r12 = dsqrt(dx * dx + dy * dy + dz * dz) + if(r12 .lt. 1d-10) then + gradx(jpoint) = 0.d0 + grady(jpoint) = 0.d0 + gradz(jpoint) = 0.d0 cycle endif - r12_inv = 1.d0 / dsqrt(r12) - r12 = r12 * r12_inv - - tmp = 0.5d0 * (1.d0 - derf(mu * r12)) * r12_inv + tmp = 0.5d0 * (1.d0 - derf(mu * r12)) / r12 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,21 +447,20 @@ 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 - + do jpoint = 1, n_points_extra_final_grid ! r2 + r2(1) = final_grid_points_extra(1,jpoint) r2(2) = final_grid_points_extra(2,jpoint) r2(3) = final_grid_points_extra(3,jpoint) - + dx = r1(1) - r2(1) dy = r1(2) - r2(2) dz = r1(3) - r2(3) r12 = dsqrt(dx * dx + dy * dy + dz * dz) 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 @@ -498,7 +469,7 @@ subroutine j12_r1_seq(r1, n_grid2, res) PROVIDE a_boys - do jpoint = 1, n_points_extra_final_grid ! r2 + do jpoint = 1, n_points_extra_final_grid ! r2 r2(1) = final_grid_points_extra(1,jpoint) r2(2) = final_grid_points_extra(2,jpoint) @@ -540,19 +511,19 @@ subroutine jmu_r1_seq(mu, r1, n_grid2, res) tmp1 = inv_sq_pi_2 / mu - do jpoint = 1, n_points_extra_final_grid ! r2 - + do jpoint = 1, n_points_extra_final_grid ! r2 + r2(1) = final_grid_points_extra(1,jpoint) r2(2) = final_grid_points_extra(2,jpoint) r2(3) = final_grid_points_extra(3,jpoint) - + dx = r1(1) - r2(1) dy = r1(2) - r2(2) dz = r1(3) - r2(3) r12 = dsqrt(dx * dx + dy * dy + dz * dz) tmp2 = mu * r12 - + res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(tmp2)) - tmp1 * dexp(-tmp2*tmp2) enddo @@ -579,7 +550,7 @@ subroutine env_nucl_r1_seq(n_grid2, res) res = 1.d0 - do jpoint = 1, n_points_extra_final_grid ! r2 + do jpoint = 1, n_points_extra_final_grid ! r2 r(1) = final_grid_points_extra(1,jpoint) r(2) = final_grid_points_extra(2,jpoint) r(3) = final_grid_points_extra(3,jpoint) @@ -598,7 +569,7 @@ subroutine env_nucl_r1_seq(n_grid2, res) res = 1.d0 - do jpoint = 1, n_points_extra_final_grid ! r2 + do jpoint = 1, n_points_extra_final_grid ! r2 r(1) = final_grid_points_extra(1,jpoint) r(2) = final_grid_points_extra(2,jpoint) r(3) = final_grid_points_extra(3,jpoint) @@ -618,7 +589,7 @@ subroutine env_nucl_r1_seq(n_grid2, res) res = 1.d0 - do jpoint = 1, n_points_extra_final_grid ! r2 + do jpoint = 1, n_points_extra_final_grid ! r2 r(1) = final_grid_points_extra(1,jpoint) r(2) = final_grid_points_extra(2,jpoint) r(3) = final_grid_points_extra(3,jpoint) @@ -636,7 +607,7 @@ subroutine env_nucl_r1_seq(n_grid2, res) res = 1.d0 - do jpoint = 1, n_points_extra_final_grid ! r2 + do jpoint = 1, n_points_extra_final_grid ! r2 r(1) = final_grid_points_extra(1,jpoint) r(2) = final_grid_points_extra(2,jpoint) r(3) = final_grid_points_extra(3,jpoint) @@ -666,7 +637,7 @@ end subroutine get_grad1_u12_2e_r1_seq(ipoint, n_grid2, resx, resy, resz) BEGIN_DOC - ! + ! ! grad_1 u_2e(r1,r2) ! ! we use grid for r1 and extra_grid for r2 @@ -786,7 +757,7 @@ end subroutine get_u12_2e_r1_seq(ipoint, n_grid2, res) BEGIN_DOC - ! + ! ! u_2e(r1,r2) ! ! we use grid for r1 and extra_grid for r2 @@ -909,7 +880,7 @@ subroutine jBH_elem_fct_grad(alpha, r1, r2, fct, grad1_fct) endif return -end +end ! --- diff --git a/plugins/local/slater_tc/tc_hmat.irp.f b/plugins/local/slater_tc/tc_hmat.irp.f index abec410d..cc780364 100644 --- a/plugins/local/slater_tc/tc_hmat.irp.f +++ b/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 diff --git a/plugins/local/tc_bi_ortho/print_tc_energy.irp.f b/plugins/local/tc_bi_ortho/print_tc_energy.irp.f index 1fa0c6d9..979d792b 100644 --- a/plugins/local/tc_bi_ortho/print_tc_energy.irp.f +++ b/plugins/local/tc_bi_ortho/print_tc_energy.irp.f @@ -9,15 +9,6 @@ program print_tc_energy read_wf = .True. touch read_wf - PROVIDE j2e_type - PROVIDE j1e_type - PROVIDE env_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 my_n_pt_r_grid = tc_grid1_r @@ -38,6 +29,24 @@ program print_tc_energy 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 + PROVIDE env_type + + print *, ' j2e_type = ', j2e_type + print *, ' j1e_type = ', j1e_type + print *, ' env_type = ', env_type + call write_tc_energy() end diff --git a/plugins/local/tc_scf/tc_scf.irp.f b/plugins/local/tc_scf/tc_scf.irp.f index f099b90e..83da03ec 100644 --- a/plugins/local/tc_scf/tc_scf.irp.f +++ b/plugins/local/tc_scf/tc_scf.irp.f @@ -7,15 +7,6 @@ program tc_scf END_DOC implicit none - 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' my_grid_becke = .True. PROVIDE tc_grid1_a tc_grid1_r @@ -37,6 +28,26 @@ program tc_scf call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over') endif + call main() + +end + +! --- + +subroutine main() + + implicit none + + 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' + call rh_tcscf_diis() PROVIDE Fock_matrix_tc_diag_mo_tot @@ -84,7 +95,7 @@ subroutine create_guess() SOFT_TOUCH mo_label endif -end subroutine create_guess +end ! --- From 13785b267c36319925ffa72ebe42399fa932ffae Mon Sep 17 00:00:00 2001 From: eginer Date: Fri, 3 May 2024 11:34:30 +0200 Subject: [PATCH 39/50] fixed a bug in src/scf_utils/roothaan_hall_scf.irp.f --- .../extra_grid_vector.irp.f | 20 +++++++++---------- .../grid_becke_vector.irp.f | 20 +++++++++---------- src/scf_utils/roothaan_hall_scf.irp.f | 2 +- 3 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/becke_numerical_grid/extra_grid_vector.irp.f b/src/becke_numerical_grid/extra_grid_vector.irp.f index 16a52dc6..44fc4435 100644 --- a/src/becke_numerical_grid/extra_grid_vector.irp.f +++ b/src/becke_numerical_grid/extra_grid_vector.irp.f @@ -71,16 +71,16 @@ END_PROVIDER 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 +! 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 diff --git a/src/becke_numerical_grid/grid_becke_vector.irp.f b/src/becke_numerical_grid/grid_becke_vector.irp.f index c35918c3..7097dbb3 100644 --- a/src/becke_numerical_grid/grid_becke_vector.irp.f +++ b/src/becke_numerical_grid/grid_becke_vector.irp.f @@ -68,16 +68,16 @@ END_PROVIDER 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 +! 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 diff --git a/src/scf_utils/roothaan_hall_scf.irp.f b/src/scf_utils/roothaan_hall_scf.irp.f index 3f5c8549..e0fe5319 100644 --- a/src/scf_utils/roothaan_hall_scf.irp.f +++ b/src/scf_utils/roothaan_hall_scf.irp.f @@ -217,7 +217,7 @@ END_DOC do while (i Date: Mon, 6 May 2024 17:47:48 +0200 Subject: [PATCH 40/50] updated get_fci_tc_conv.sh --- scripts/get_fci_tc_conv.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/get_fci_tc_conv.sh b/scripts/get_fci_tc_conv.sh index 643f3ac0..f0c99baf 100755 --- a/scripts/get_fci_tc_conv.sh +++ b/scripts/get_fci_tc_conv.sh @@ -1,2 +1,2 @@ file=$1 -grep "Ndet,E,E+PT2,E+RPT2,|PT2|=" $file | cut -d "=" -f 2 > ${file}.conv_fci_tc +grep "Ndet,E,E+PT2,pt2_minus,pt2_plus,pt2_abs=" $file | cut -d "=" -f 2 > ${file}.conv_fci_tc From b14325fef482bdf6cb471b40edf8fa46f2aeac65 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 6 May 2024 18:21:58 +0200 Subject: [PATCH 41/50] Introducing qmckl --- plugins/local/non_h_ints_mu/NEED | 1 + plugins/local/non_h_ints_mu/deb_aos.irp.f | 49 ++++++++-- plugins/local/non_h_ints_mu/qmckl.irp.f | 104 ++++++++++++++++++++++ 3 files changed, 148 insertions(+), 6 deletions(-) diff --git a/plugins/local/non_h_ints_mu/NEED b/plugins/local/non_h_ints_mu/NEED index 48c1c24b..5ca1d543 100644 --- a/plugins/local/non_h_ints_mu/NEED +++ b/plugins/local/non_h_ints_mu/NEED @@ -3,3 +3,4 @@ hamiltonian jastrow ao_tc_eff_map bi_ortho_mos +trexio diff --git a/plugins/local/non_h_ints_mu/deb_aos.irp.f b/plugins/local/non_h_ints_mu/deb_aos.irp.f index c9bc9c9a..86d011fb 100644 --- a/plugins/local/non_h_ints_mu/deb_aos.irp.f +++ b/plugins/local/non_h_ints_mu/deb_aos.irp.f @@ -34,21 +34,58 @@ subroutine print_aos() PROVIDE final_grid_points aos_in_r_array aos_grad_in_r_array aos_lapl_in_r_array - do ipoint = 1, n_points_final_grid - r(:) = final_grid_points(:,ipoint) - print*, r - enddo +! do ipoint = 1, n_points_final_grid +! r(:) = final_grid_points(:,ipoint) +! print*, r +! enddo +double precision :: accu_vgl(5) +double precision :: accu_vgl_nrm(5) do ipoint = 1, n_points_final_grid - r(:) = final_grid_points(:,ipoint) do i = 1, ao_num ao_val = aos_in_r_array (i,ipoint) ao_der(:) = aos_grad_in_r_array(i,ipoint,:) ao_lap = aos_lapl_in_r_array(1,i,ipoint) + aos_lapl_in_r_array(2,i,ipoint) + aos_lapl_in_r_array(3,i,ipoint) - write(*, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap + write(111, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap enddo enddo + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + ao_val = aos_in_r_array_qmckl (i,ipoint) + ao_der(:) = aos_grad_in_r_array_qmckl(i,ipoint,:) + ao_lap = aos_lapl_in_r_array_qmckl(i,ipoint) + write(222, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap + enddo + enddo + + accu_vgl = 0.d0 + accu_vgl_nrm = 0.d0 + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + ao_val = aos_in_r_array (i,ipoint) + ao_der(:) = aos_grad_in_r_array(i,ipoint,:) + ao_lap = aos_lapl_in_r_array(1,i,ipoint) + aos_lapl_in_r_array(2,i,ipoint) + aos_lapl_in_r_array(3,i,ipoint) + accu_vgl_nrm(1) += dabs(ao_val) + accu_vgl_nrm(2) += dabs(ao_der(1)) + accu_vgl_nrm(3) += dabs(ao_der(2)) + accu_vgl_nrm(4) += dabs(ao_der(3)) + accu_vgl_nrm(5) += dabs(ao_lap) + + ao_val -= aos_in_r_array_qmckl (i,ipoint) + ao_der(:) -= aos_grad_in_r_array_qmckl(i,ipoint,:) + ao_lap -= aos_lapl_in_r_array_qmckl(i,ipoint) + accu_vgl(1) += dabs(ao_val) + accu_vgl(2) += dabs(ao_der(1)) + accu_vgl(3) += dabs(ao_der(2)) + accu_vgl(4) += dabs(ao_der(3)) + accu_vgl(5) += dabs(ao_lap) + enddo + + enddo + accu_vgl(:) *= 1.d0 / accu_vgl_nrm(:) + print *, accu_vgl + return end diff --git a/plugins/local/non_h_ints_mu/qmckl.irp.f b/plugins/local/non_h_ints_mu/qmckl.irp.f index 1df80457..4d419e24 100644 --- a/plugins/local/non_h_ints_mu/qmckl.irp.f +++ b/plugins/local/non_h_ints_mu/qmckl.irp.f @@ -75,3 +75,107 @@ BEGIN_PROVIDER [ integer*8, qmckl_ctx_jastrow ] endif END_PROVIDER + + + BEGIN_PROVIDER [ double precision, aos_in_r_array_qmckl, (ao_num,n_points_final_grid)] +&BEGIN_PROVIDER [ double precision, aos_grad_in_r_array_qmckl, (ao_num,n_points_final_grid,3)] +&BEGIN_PROVIDER [ double precision, aos_lapl_in_r_array_qmckl, (ao_num, n_points_final_grid)] + implicit none + BEGIN_DOC + ! AOS computed with qmckl + END_DOC + use qmckl + + integer*8 :: qmckl_ctx + integer(qmckl_exit_code) :: rc + + qmckl_ctx = qmckl_context_create() + + rc = qmckl_trexio_read(qmckl_ctx, trexio_file, 1_8*len(trim(trexio_filename))) + if (rc /= QMCKL_SUCCESS) then + print *, irp_here, 'qmckl error in read_trexio' + rc = qmckl_check(qmckl_ctx, rc) + stop -1 + endif + + rc = qmckl_set_point(qmckl_ctx, 'N', n_points_final_grid*1_8, final_grid_points, n_points_final_grid*3_8) + if (rc /= QMCKL_SUCCESS) then + print *, irp_here, 'qmckl error in set_electron_point' + rc = qmckl_check(qmckl_ctx, rc) + stop -1 + endif + + double precision, allocatable :: vgl(:,:,:) + allocate( vgl(ao_num,5,n_points_final_grid)) + rc = qmckl_get_ao_basis_ao_vgl_inplace(qmckl_ctx, vgl, n_points_final_grid*ao_num*5_8) + if (rc /= QMCKL_SUCCESS) then + print *, irp_here, 'qmckl error in get_ao_vgl' + rc = qmckl_check(qmckl_ctx, rc) + stop -1 + endif + + integer :: i,k + do k=1,n_points_final_grid + do i=1,ao_num + aos_in_r_array_qmckl(i,k) = vgl(i,1,k) + aos_grad_in_r_array_qmckl(i,k,1) = vgl(i,2,k) + aos_grad_in_r_array_qmckl(i,k,2) = vgl(i,3,k) + aos_grad_in_r_array_qmckl(i,k,3) = vgl(i,4,k) + aos_lapl_in_r_array_qmckl(i,k) = vgl(i,5,k) + enddo + enddo + +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, mos_in_r_array_qmckl, (mo_num,n_points_final_grid)] +&BEGIN_PROVIDER [ double precision, mos_grad_in_r_array_qmckl, (mo_num,n_points_final_grid,3)] +&BEGIN_PROVIDER [ double precision, mos_lapl_in_r_array_qmckl, (mo_num, n_points_final_grid)] + implicit none + BEGIN_DOC + ! moS computed with qmckl + END_DOC + use qmckl + + integer*8 :: qmckl_ctx + integer(qmckl_exit_code) :: rc + + qmckl_ctx = qmckl_context_create() + + rc = qmckl_trexio_read(qmckl_ctx, trexio_file, 1_8*len(trim(trexio_filename))) + if (rc /= QMCKL_SUCCESS) then + print *, irp_here, 'qmckl error in read_trexio' + rc = qmckl_check(qmckl_ctx, rc) + stop -1 + endif + + rc = qmckl_set_point(qmckl_ctx, 'N', n_points_final_grid*1_8, final_grid_points, n_points_final_grid*3_8) + if (rc /= QMCKL_SUCCESS) then + print *, irp_here, 'qmckl error in set_electron_point' + rc = qmckl_check(qmckl_ctx, rc) + stop -1 + endif + + double precision, allocatable :: vgl(:,:,:) + allocate( vgl(mo_num,5,n_points_final_grid)) + rc = qmckl_get_mo_basis_mo_vgl_inplace(qmckl_ctx, vgl, n_points_final_grid*mo_num*5_8) + if (rc /= QMCKL_SUCCESS) then + print *, irp_here, 'qmckl error in get_mo_vgl' + rc = qmckl_check(qmckl_ctx, rc) + stop -1 + endif + + integer :: i,k + do k=1,n_points_final_grid + do i=1,mo_num + mos_in_r_array_qmckl(i,k) = vgl(i,1,k) + mos_grad_in_r_array_qmckl(i,k,1) = vgl(i,2,k) + mos_grad_in_r_array_qmckl(i,k,2) = vgl(i,3,k) + mos_grad_in_r_array_qmckl(i,k,3) = vgl(i,4,k) + mos_lapl_in_r_array_qmckl(i,k) = vgl(i,5,k) + enddo + enddo + +END_PROVIDER + + From 109a956f0d947665af7fbd3ed02d3569c49e592e Mon Sep 17 00:00:00 2001 From: eginer Date: Mon, 6 May 2024 18:30:05 +0200 Subject: [PATCH 42/50] does not compile but working on it --- plugins/local/slater_tc/h_mat_triple.irp.f | 391 ------------------ .../local/slater_tc/slater_tc_opt_diag.irp.f | 311 +++++++++++++- .../slater_tc/symmetrized_3_e_int_prov.irp.f | 140 ------- plugins/local/slater_tc_no_opt/.gitignore | 59 +++ plugins/local/slater_tc_no_opt/NEED | 8 + plugins/local/slater_tc_no_opt/README.rst | 4 + .../h_biortho.irp.f | 0 .../local/slater_tc_no_opt/h_mat_triple.irp.f | 193 +++++++++ .../h_tc_bi_ortho_psi.irp.f | 0 .../slater_tc_3e_slow.irp.f | 2 +- .../slater_tc_no_opt.irp.f} | 2 +- .../slater_tc_slow.irp.f | 73 +--- src/determinants/slater_rules_general.irp.f | 192 +++++++++ 13 files changed, 769 insertions(+), 606 deletions(-) delete mode 100644 plugins/local/slater_tc/h_mat_triple.irp.f delete mode 100644 plugins/local/slater_tc/symmetrized_3_e_int_prov.irp.f create mode 100644 plugins/local/slater_tc_no_opt/.gitignore create mode 100644 plugins/local/slater_tc_no_opt/NEED create mode 100644 plugins/local/slater_tc_no_opt/README.rst rename plugins/local/{slater_tc => slater_tc_no_opt}/h_biortho.irp.f (100%) create mode 100644 plugins/local/slater_tc_no_opt/h_mat_triple.irp.f rename plugins/local/{slater_tc => slater_tc_no_opt}/h_tc_bi_ortho_psi.irp.f (100%) rename plugins/local/{slater_tc => slater_tc_no_opt}/slater_tc_3e_slow.irp.f (99%) rename plugins/local/{slater_tc/slater_tc.irp.f => slater_tc_no_opt/slater_tc_no_opt.irp.f} (82%) rename plugins/local/{slater_tc => slater_tc_no_opt}/slater_tc_slow.irp.f (80%) create mode 100644 src/determinants/slater_rules_general.irp.f diff --git a/plugins/local/slater_tc/h_mat_triple.irp.f b/plugins/local/slater_tc/h_mat_triple.irp.f deleted file mode 100644 index 6f5697a2..00000000 --- a/plugins/local/slater_tc/h_mat_triple.irp.f +++ /dev/null @@ -1,391 +0,0 @@ -subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase) - use bitmasks - BEGIN_DOC -! returns the array, for each spin, of holes/particles between key_i and key_j -! -! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j> - END_DOC - include 'utils/constants.include.F' - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) - integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2) - double precision, intent(out) :: phase - integer :: ispin,k,i,pos - integer(bit_kind) :: key_hole, key_particle - integer(bit_kind) :: xorvec(N_int_max,2) - holes_array = -1 - particles_array = -1 - degree_array = 0 - do i = 1, N_int - xorvec(i,1) = xor( key_i(i,1), key_j(i,1)) - xorvec(i,2) = xor( key_i(i,2), key_j(i,2)) - degree_array(1) += popcnt(xorvec(i,1)) - degree_array(2) += popcnt(xorvec(i,2)) - enddo - degree_array(1) = shiftr(degree_array(1),1) - degree_array(2) = shiftr(degree_array(2),1) - - do ispin = 1, 2 - k = 1 - !!! GETTING THE HOLES - do i = 1, N_int - key_hole = iand(xorvec(i,ispin),key_i(i,ispin)) - do while(key_hole .ne.0_bit_kind) - pos = trailz(key_hole) - holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos - key_hole = ibclr(key_hole,pos) - k += 1 - if(k .gt.100)then - print*,'WARNING in get_excitation_general' - print*,'More than a 100-th excitation for spin ',ispin - print*,'stoping ...' - stop - endif - enddo - enddo - enddo - do ispin = 1, 2 - k = 1 - !!! GETTING THE PARTICLES - do i = 1, N_int - key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin)) - do while(key_particle .ne.0_bit_kind) - pos = trailz(key_particle) - particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos - key_particle = ibclr(key_particle,pos) - k += 1 - if(k .gt.100)then - print*,'WARNING in get_excitation_general ' - print*,'More than a 100-th excitation for spin ',ispin - print*,'stoping ...' - stop - endif - enddo - enddo - enddo - integer :: h,p, i_ok - integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:) - integer :: exc(0:2,2,2) - double precision :: phase_tmp - allocate(det_i(Nint,2),det_ip(N_int,2)) - det_i = key_i - phase = 1.d0 - do ispin = 1, 2 - do i = 1, degree_array(ispin) - h = holes_array(i,ispin) - p = particles_array(i,ispin) - det_ip = det_i - call do_single_excitation(det_ip,h,p,ispin,i_ok) - if(i_ok == -1)then - print*,'excitation was not possible ' - stop - endif - call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint) - phase *= phase_tmp - det_i = det_ip - enddo - enddo - -end - -subroutine get_holes_general(key_i, key_j,Nint, holes_array) - use bitmasks - BEGIN_DOC -! returns the array, per spin, of holes between key_i and key_j -! -! with the following convention: a_{hole}|key_i> --> |key_j> - END_DOC - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) - integer, intent(out) :: holes_array(100,2) - integer(bit_kind) :: key_hole - integer :: ispin,k,i,pos - holes_array = -1 - do ispin = 1, 2 - k = 1 - do i = 1, N_int - key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin)) - do while(key_hole .ne.0_bit_kind) - pos = trailz(key_hole) - holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos - key_hole = ibclr(key_hole,pos) - k += 1 - if(k .gt.100)then - print*,'WARNING in get_holes_general' - print*,'More than a 100-th excitation for spin ',ispin - print*,'stoping ...' - stop - endif - enddo - enddo - enddo -end - -subroutine get_particles_general(key_i, key_j,Nint,particles_array) - use bitmasks - BEGIN_DOC -! returns the array, per spin, of particles between key_i and key_j -! -! with the following convention: a^dagger_{particle}|key_i> --> |key_j> - END_DOC - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) - integer, intent(out) :: particles_array(100,2) - integer(bit_kind) :: key_particle - integer :: ispin,k,i,pos - particles_array = -1 - do ispin = 1, 2 - k = 1 - do i = 1, N_int - key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin)) - do while(key_particle .ne.0_bit_kind) - pos = trailz(key_particle) - particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos - key_particle = ibclr(key_particle,pos) - k += 1 - if(k .gt.100)then - print*,'WARNING in get_holes_general' - print*,'More than a 100-th excitation for spin ',ispin - print*,'Those are the two determinants' - call debug_det(key_i, N_int) - call debug_det(key_j, N_int) - print*,'stoping ...' - stop - endif - enddo - enddo - enddo -end - -subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase) - implicit none - integer, intent(in) :: degree(2), Nint - integer(bit_kind), intent(in) :: key_i(Nint,2) - integer, intent(in) :: holes_array(100,2),particles_array(100,2) - double precision, intent(out) :: phase - integer :: i,ispin,h,p, i_ok - integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:) - integer :: exc(0:2,2,2) - double precision :: phase_tmp - allocate(det_i(Nint,2),det_ip(N_int,2)) - det_i = key_i - phase = 1.d0 - do ispin = 1, 2 - do i = 1, degree(ispin) - h = holes_array(i,ispin) - p = particles_array(i,ispin) - det_ip = det_i - call do_single_excitation(det_ip,h,p,ispin,i_ok) - if(i_ok == -1)then - print*,'excitation was not possible ' - stop - endif - call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint) - phase *= phase_tmp - det_i = det_ip - enddo - enddo - -end - -subroutine H_tc_s2_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze) - BEGIN_DOC - ! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS - ! - ! Assumes that the determinants are in psi_det - ! - ! istart, iend, ishift, istep are used in ZMQ parallelization. - END_DOC - - use bitmasks - implicit none - - integer, intent(in) :: N_st,sze - double precision, intent(in) :: u_0(sze,N_st) - double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) - call H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze) - integer :: i,j,degree,ist - double precision :: hmono, htwoe, hthree, htot - do i = 1, N_det - do j = 1, N_det - call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) - if(degree .ne. 3)cycle - call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,i), psi_det(1,1,j), hmono, htwoe, hthree, htot) - do ist = 1, N_st - v_0(i,ist) += htot * u_0(j,ist) - enddo - enddo - enddo -end - -subroutine H_tc_s2_u_0_with_pure_three_omp(v_0, s_0, u_0, N_st, sze) - BEGIN_DOC - ! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS - ! - ! Assumes that the determinants are in psi_det - ! - ! istart, iend, ishift, istep are used in ZMQ parallelization. - END_DOC - - use bitmasks - implicit none - - integer, intent(in) :: N_st,sze - double precision, intent(in) :: u_0(sze,N_st) - double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) - call H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze) - integer :: i,j,degree,ist - double precision :: hmono, htwoe, hthree, htot - !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & - !$OMP SHARED(N_st, N_det, N_int, psi_det, u_0, v_0) & - !$OMP PRIVATE(ist, i, j, degree, hmono, htwoe, hthree,htot) - do i = 1, N_det - do j = 1, N_det - call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) - if(degree .ne. 3)cycle - call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,i), psi_det(1,1,j), hmono, htwoe, hthree, htot) - do ist = 1, N_st - v_0(i,ist) += htot * u_0(j,ist) - enddo - enddo - enddo - !$OMP END PARALLEL DO -end - -! --- - -subroutine H_tc_s2_dagger_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze) - BEGIN_DOC - ! Computes $v_0 = (H^TC)^dagger | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS - ! - ! Assumes that the determinants are in psi_det - ! - ! istart, iend, ishift, istep are used in ZMQ parallelization. - END_DOC - - use bitmasks - implicit none - - integer, intent(in) :: N_st,sze - double precision, intent(in) :: u_0(sze,N_st) - double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) - call H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze) - integer :: i,j,degree,ist - double precision :: hmono, htwoe, hthree, htot - do i = 1, N_det - do j = 1, N_det - call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) - if(degree .ne. 3)cycle - call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,j), psi_det(1,1,i), hmono, htwoe, hthree, htot) - do ist = 1, N_st - v_0(i,ist) += htot * u_0(j,ist) - enddo - enddo - enddo -end - -subroutine H_tc_s2_dagger_u_0_with_pure_three_omp(v_0, s_0, u_0, N_st, sze) - BEGIN_DOC - ! Computes $v_0 = (H^TC)^dagger | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS - ! - ! Assumes that the determinants are in psi_det - ! - ! istart, iend, ishift, istep are used in ZMQ parallelization. - END_DOC - - use bitmasks - implicit none - - integer, intent(in) :: N_st,sze - double precision, intent(in) :: u_0(sze,N_st) - double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) - call H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze) - integer :: i,j,degree,ist - double precision :: hmono, htwoe, hthree, htot - !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & - !$OMP SHARED(N_st, N_det, N_int, psi_det, u_0, v_0) & - !$OMP PRIVATE(ist, i, j, degree, hmono, htwoe, hthree,htot) - do i = 1, N_det - do j = 1, N_det - call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) - if(degree .ne. 3)cycle - call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,j), psi_det(1,1,i), hmono, htwoe, hthree, htot) - do ist = 1, N_st - v_0(i,ist) += htot * u_0(j,ist) - enddo - enddo - enddo - !$OMP END PARALLEL DO -end - -! --- -subroutine triple_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot) - use bitmasks - BEGIN_DOC -! for triple excitation -!! -!! WARNING !! -! -! Genuine triple excitations of the same spin are not yet implemented - END_DOC - implicit none - integer(bit_kind), intent(in) :: key_j(N_int,2),key_i(N_int,2) - integer, intent(in) :: Nint - double precision, intent(out) :: hmono, htwoe, hthree, htot - integer :: degree - integer :: h1, p1, h2, p2, s1, s2, h3, p3, s3 - integer :: holes_array(100,2),particles_array(100,2),degree_array(2) - double precision :: phase,sym_3_e_int_from_6_idx_tensor - - hmono = 0.d0 - htwoe = 0.d0 - hthree = 0.d0 - htot = 0.d0 - call get_excitation_general(key_j, key_i, Nint,degree_array,holes_array, particles_array,phase) - degree = degree_array(1) + degree_array(2) - if(degree .ne. 3)return - if(degree_array(1)==3.or.degree_array(2)==3)then - if(degree_array(1) == 3)then - h1 = holes_array(1,1) - h2 = holes_array(2,1) - h3 = holes_array(3,1) - p1 = particles_array(1,1) - p2 = particles_array(2,1) - p3 = particles_array(3,1) - else - h1 = holes_array(1,2) - h2 = holes_array(2,2) - h3 = holes_array(3,2) - p1 = particles_array(1,2) - p2 = particles_array(2,2) - p3 = particles_array(3,2) - endif - hthree = sym_3_e_int_from_6_idx_tensor(p3, p2, p1, h3, h2, h1) - else - if(degree_array(1) == 2.and.degree_array(2) == 1)then ! double alpha + single beta - h1 = holes_array(1,1) - h2 = holes_array(2,1) - h3 = holes_array(1,2) - p1 = particles_array(1,1) - p2 = particles_array(2,1) - p3 = particles_array(1,2) - else if(degree_array(2) == 2 .and. degree_array(1) == 1)then ! double beta + single alpha - h1 = holes_array(1,2) - h2 = holes_array(2,2) - h3 = holes_array(1,1) - p1 = particles_array(1,2) - p2 = particles_array(2,2) - p3 = particles_array(1,1) - else - print*,'PB !!' - stop - endif - hthree = three_body_ints_bi_ort(p3,p2,p1,h3,h2,h1) - three_body_ints_bi_ort(p3,p2,p1,h3,h1,h2) - endif - hthree *= phase - htot = hthree - end - diff --git a/plugins/local/slater_tc/slater_tc_opt_diag.irp.f b/plugins/local/slater_tc/slater_tc_opt_diag.irp.f index 78f9dc66..3c5a5d12 100644 --- a/plugins/local/slater_tc/slater_tc_opt_diag.irp.f +++ b/plugins/local/slater_tc/slater_tc_opt_diag.irp.f @@ -19,13 +19,13 @@ PROVIDE HF_bitmask PROVIDE mo_l_coef mo_r_coef - call diag_htilde_mu_mat_bi_ortho_slow(N_int, HF_bitmask, hmono, htwoe, htot) + call diag_htc_bi_orth_2e_brute(N_int, HF_bitmask, hmono, htwoe, htot) ref_tc_energy_1e = hmono ref_tc_energy_2e = htwoe if(three_body_h_tc) then - call diag_htilde_three_body_ints_bi_ort_slow(N_int, HF_bitmask, hthree) + call diag_htc_bi_orth_3e_brute(N_int, HF_bitmask, hthree) ref_tc_energy_3e = hthree else ref_tc_energy_3e = 0.d0 @@ -524,3 +524,310 @@ end ! --- +subroutine diag_htc_bi_orth_2e_brute(Nint, key_i, hmono, htwoe, htot) + + BEGIN_DOC + ! + ! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS + ! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + double precision, intent(out) :: hmono,htwoe,htot + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + double precision :: get_mo_two_e_integral_tc_int + integer(bit_kind) :: key_i_core(Nint,2) + + PROVIDE mo_bi_ortho_tc_two_e + + hmono = 0.d0 + htwoe = 0.d0 + htot = 0.d0 + + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + + do ispin = 1, 2 + do i = 1, Ne(ispin) + ii = occ(i,ispin) + hmono += mo_bi_ortho_tc_one_e(ii,ii) + enddo + enddo + + ! alpha/beta two-body + ispin = 1 + jspin = 2 + do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1)) + ii = occ(i,ispin) + do j = 1, Ne(jspin) ! electron 2 + jj = occ(j,jspin) + htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii) + enddo + enddo + + ! alpha/alpha two-body + do i = 1, Ne(ispin) + ii = occ(i,ispin) + do j = i+1, Ne(ispin) + jj = occ(j,ispin) + htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii) + enddo + enddo + + ! beta/beta two-body + do i = 1, Ne(jspin) + ii = occ(i,jspin) + do j = i+1, Ne(jspin) + jj = occ(j,jspin) + htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii) + enddo + enddo + + htot = hmono + htwoe + +end + +! --- + +subroutine diag_htc_bi_orth_3e_brute(Nint, key_i, hthree) + + BEGIN_DOC + ! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + double precision, intent(out) :: hthree + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2),i,j,ii,jj,ispin,jspin,m,mm + integer(bit_kind) :: key_i_core(Nint,2) + double precision :: direct_int, exchange_int, ref + double precision, external :: sym_3_e_int_from_6_idx_tensor + double precision, external :: three_e_diag_parrallel_spin + + PROVIDE mo_l_coef mo_r_coef + + if(core_tc_op) then + do i = 1, Nint + key_i_core(i,1) = xor(key_i(i,1), core_bitmask(i,1)) + key_i_core(i,2) = xor(key_i(i,2), core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core, occ, Ne, Nint) + else + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + endif + + hthree = 0.d0 + + if((Ne(1)+Ne(2)) .ge. 3) then + + ! alpha/alpha/beta three-body + do i = 1, Ne(1) + ii = occ(i,1) + do j = i+1, Ne(1) + jj = occ(j,1) + do m = 1, Ne(2) + mm = occ(m,2) + !direct_int = three_body_ints_bi_ort(mm,jj,ii,mm,jj,ii) !uses the 6-idx tensor + !exchange_int = three_body_ints_bi_ort(mm,jj,ii,mm,ii,jj) !uses the 6-idx tensor + direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii) !uses 3-idx tensor + exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii) !uses 3-idx tensor + hthree += direct_int - exchange_int + enddo + enddo + enddo + + ! beta/beta/alpha three-body + do i = 1, Ne(2) + ii = occ(i,2) + do j = i+1, Ne(2) + jj = occ(j,2) + do m = 1, Ne(1) + mm = occ(m,1) + !direct_int = three_body_ints_bi_ort(mm,jj,ii,mm,jj,ii) !uses the 6-idx tensor + !exchange_int = three_body_ints_bi_ort(mm,jj,ii,mm,ii,jj) !uses the 6-idx tensor + direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii) + exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii) + hthree += direct_int - exchange_int + enddo + enddo + enddo + + ! alpha/alpha/alpha three-body + do i = 1, Ne(1) + ii = occ(i,1) ! 1 + do j = i+1, Ne(1) + jj = occ(j,1) ! 2 + do m = j+1, Ne(1) + mm = occ(m,1) ! 3 + !hthree += sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) !uses the 6 idx tensor + hthree += three_e_diag_parrallel_spin(mm,jj,ii) !uses only 3-idx tensors + enddo + enddo + enddo + + ! beta/beta/beta three-body + do i = 1, Ne(2) + ii = occ(i,2) ! 1 + do j = i+1, Ne(2) + jj = occ(j,2) ! 2 + do m = j+1, Ne(2) + mm = occ(m,2) ! 3 + !hthree += sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) !uses the 6 idx tensor + hthree += three_e_diag_parrallel_spin(mm,jj,ii) !uses only 3-idx tensors + enddo + enddo + enddo + + endif + +end + + + +BEGIN_PROVIDER [ double precision, three_e_diag_parrallel_spin_prov, (mo_num, mo_num, mo_num)] + + BEGIN_DOC + ! + ! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS + ! + ! three_e_diag_parrallel_spin_prov(m,j,i) = All combinations of the form for same spin matrix elements + ! + ! notice the -1 sign: in this way three_e_diag_parrallel_spin_prov can be directly used to compute Slater rules with a + sign + ! + END_DOC + + implicit none + integer :: i, j, m + double precision :: integral, wall1, wall0, three_e_diag_parrallel_spin + + three_e_diag_parrallel_spin_prov = 0.d0 + print *, ' Providing the three_e_diag_parrallel_spin_prov ...' + + integral = three_e_diag_parrallel_spin(1,1,1) ! to provide all stuffs + call wall_time(wall0) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,m,integral) & + !$OMP SHARED (mo_num,three_e_diag_parrallel_spin_prov) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do j = 1, mo_num + do m = j, mo_num + three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin(m,j,i) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do i = 1, mo_num + do j = 1, mo_num + do m = 1, j + three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin_prov(j,m,i) + enddo + enddo + enddo + + call wall_time(wall1) + print *, ' wall time for three_e_diag_parrallel_spin_prov', wall1 - wall0 + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_e_single_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num)] + + BEGIN_DOC + ! + ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs + ! + ! three_e_single_parrallel_spin_prov(m,j,k,i) = All combination of for same spin matrix elements + ! + ! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + ! + END_DOC + + implicit none + integer :: i, j, k, m + double precision :: integral, wall1, wall0, three_e_single_parrallel_spin + + three_e_single_parrallel_spin_prov = 0.d0 + print *, ' Providing the three_e_single_parrallel_spin_prov ...' + + integral = three_e_single_parrallel_spin(1,1,1,1) + call wall_time(wall0) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,integral) & + !$OMP SHARED (mo_num,three_e_single_parrallel_spin_prov) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do m = 1, mo_num + three_e_single_parrallel_spin_prov(m,j,k,i) = three_e_single_parrallel_spin(m,j,k,i) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print *, ' wall time for three_e_single_parrallel_spin_prov', wall1 - wall0 + +END_PROVIDER + + +! --- + +BEGIN_PROVIDER [ double precision, three_e_double_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num, mo_num)] + + BEGIN_DOC + ! + ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs + ! + ! three_e_double_parrallel_spin_prov(m,l,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO + ! + ! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign + END_DOC + + implicit none + integer :: i, j, k, m, l + double precision :: integral, wall1, wall0, three_e_double_parrallel_spin + + three_e_double_parrallel_spin_prov = 0.d0 + print *, ' Providing the three_e_double_parrallel_spin_prov ...' + call wall_time(wall0) + + integral = three_e_double_parrallel_spin(1,1,1,1,1) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,m,l,integral) & + !$OMP SHARED (mo_num,three_e_double_parrallel_spin_prov) + !$OMP DO SCHEDULE (dynamic) + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do l = 1, mo_num + do m = 1, mo_num + three_e_double_parrallel_spin_prov(m,l,j,k,i) = three_e_double_parrallel_spin(m,l,j,k,i) + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print *, ' wall time for three_e_double_parrallel_spin_prov', wall1 - wall0 + +END_PROVIDER + diff --git a/plugins/local/slater_tc/symmetrized_3_e_int_prov.irp.f b/plugins/local/slater_tc/symmetrized_3_e_int_prov.irp.f deleted file mode 100644 index e8277a74..00000000 --- a/plugins/local/slater_tc/symmetrized_3_e_int_prov.irp.f +++ /dev/null @@ -1,140 +0,0 @@ - -BEGIN_PROVIDER [ double precision, three_e_diag_parrallel_spin_prov, (mo_num, mo_num, mo_num)] - - BEGIN_DOC - ! - ! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS - ! - ! three_e_diag_parrallel_spin_prov(m,j,i) = All combinations of the form for same spin matrix elements - ! - ! notice the -1 sign: in this way three_e_diag_parrallel_spin_prov can be directly used to compute Slater rules with a + sign - ! - END_DOC - - implicit none - integer :: i, j, m - double precision :: integral, wall1, wall0, three_e_diag_parrallel_spin - - three_e_diag_parrallel_spin_prov = 0.d0 - print *, ' Providing the three_e_diag_parrallel_spin_prov ...' - - integral = three_e_diag_parrallel_spin(1,1,1) ! to provide all stuffs - call wall_time(wall0) - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,m,integral) & - !$OMP SHARED (mo_num,three_e_diag_parrallel_spin_prov) - !$OMP DO SCHEDULE (dynamic) - do i = 1, mo_num - do j = 1, mo_num - do m = j, mo_num - three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin(m,j,i) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - do i = 1, mo_num - do j = 1, mo_num - do m = 1, j - three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin_prov(j,m,i) - enddo - enddo - enddo - - call wall_time(wall1) - print *, ' wall time for three_e_diag_parrallel_spin_prov', wall1 - wall0 - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_e_single_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num)] - - BEGIN_DOC - ! - ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs - ! - ! three_e_single_parrallel_spin_prov(m,j,k,i) = All combination of for same spin matrix elements - ! - ! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign - ! - END_DOC - - implicit none - integer :: i, j, k, m - double precision :: integral, wall1, wall0, three_e_single_parrallel_spin - - three_e_single_parrallel_spin_prov = 0.d0 - print *, ' Providing the three_e_single_parrallel_spin_prov ...' - - integral = three_e_single_parrallel_spin(1,1,1,1) - call wall_time(wall0) - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,k,m,integral) & - !$OMP SHARED (mo_num,three_e_single_parrallel_spin_prov) - !$OMP DO SCHEDULE (dynamic) - do i = 1, mo_num - do k = 1, mo_num - do j = 1, mo_num - do m = 1, mo_num - three_e_single_parrallel_spin_prov(m,j,k,i) = three_e_single_parrallel_spin(m,j,k,i) - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call wall_time(wall1) - print *, ' wall time for three_e_single_parrallel_spin_prov', wall1 - wall0 - -END_PROVIDER - - -! --- - -BEGIN_PROVIDER [ double precision, three_e_double_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num, mo_num)] - - BEGIN_DOC - ! - ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs - ! - ! three_e_double_parrallel_spin_prov(m,l,j,k,i) = ::: notice that i is the RIGHT MO and k is the LEFT MO - ! - ! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign - END_DOC - - implicit none - integer :: i, j, k, m, l - double precision :: integral, wall1, wall0, three_e_double_parrallel_spin - - three_e_double_parrallel_spin_prov = 0.d0 - print *, ' Providing the three_e_double_parrallel_spin_prov ...' - call wall_time(wall0) - - integral = three_e_double_parrallel_spin(1,1,1,1,1) - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,k,m,l,integral) & - !$OMP SHARED (mo_num,three_e_double_parrallel_spin_prov) - !$OMP DO SCHEDULE (dynamic) - do i = 1, mo_num - do k = 1, mo_num - do j = 1, mo_num - do l = 1, mo_num - do m = 1, mo_num - three_e_double_parrallel_spin_prov(m,l,j,k,i) = three_e_double_parrallel_spin(m,l,j,k,i) - enddo - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call wall_time(wall1) - print *, ' wall time for three_e_double_parrallel_spin_prov', wall1 - wall0 - -END_PROVIDER - diff --git a/plugins/local/slater_tc_no_opt/.gitignore b/plugins/local/slater_tc_no_opt/.gitignore new file mode 100644 index 00000000..1561915b --- /dev/null +++ b/plugins/local/slater_tc_no_opt/.gitignore @@ -0,0 +1,59 @@ +IRPF90_temp/ +IRPF90_man/ +build.ninja +irpf90.make +ezfio_interface.irp.f +irpf90_entities +tags +Makefile +ao_basis +ao_one_e_ints +ao_two_e_erf_ints +ao_two_e_ints +aux_quantities +becke_numerical_grid +bitmask +cis +cisd +cipsi +davidson +davidson_dressed +davidson_undressed +density_for_dft +determinants +dft_keywords +dft_utils_in_r +dft_utils_one_e +dft_utils_two_body +dressing +dummy +electrons +ezfio_files +fci +generators_cas +generators_full +hartree_fock +iterations +kohn_sham +kohn_sham_rs +mo_basis +mo_guess +mo_one_e_ints +mo_two_e_erf_ints +mo_two_e_ints +mpi +mrpt_utils +nuclei +perturbation +pseudo +psiref_cas +psiref_utils +scf_utils +selectors_cassd +selectors_full +selectors_utils +single_ref_method +slave +tools +utils +zmq diff --git a/plugins/local/slater_tc_no_opt/NEED b/plugins/local/slater_tc_no_opt/NEED new file mode 100644 index 00000000..a8669866 --- /dev/null +++ b/plugins/local/slater_tc_no_opt/NEED @@ -0,0 +1,8 @@ +determinants +normal_order_old +bi_ort_ints +bi_ortho_mos +tc_keywords +non_hermit_dav +dav_general_mat +tc_scf diff --git a/plugins/local/slater_tc_no_opt/README.rst b/plugins/local/slater_tc_no_opt/README.rst new file mode 100644 index 00000000..90679e4c --- /dev/null +++ b/plugins/local/slater_tc_no_opt/README.rst @@ -0,0 +1,4 @@ +================ +slater_tc_no_opt +================ + diff --git a/plugins/local/slater_tc/h_biortho.irp.f b/plugins/local/slater_tc_no_opt/h_biortho.irp.f similarity index 100% rename from plugins/local/slater_tc/h_biortho.irp.f rename to plugins/local/slater_tc_no_opt/h_biortho.irp.f diff --git a/plugins/local/slater_tc_no_opt/h_mat_triple.irp.f b/plugins/local/slater_tc_no_opt/h_mat_triple.irp.f new file mode 100644 index 00000000..e2c8f982 --- /dev/null +++ b/plugins/local/slater_tc_no_opt/h_mat_triple.irp.f @@ -0,0 +1,193 @@ +subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase) + use bitmasks + BEGIN_DOC +! returns the array, for each spin, of holes/particles between key_i and key_j +! +! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j> + END_DOC + include 'utils/constants.include.F' + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2) + double precision, intent(out) :: phase + integer :: ispin,k,i,pos + integer(bit_kind) :: key_hole, key_particle + integer(bit_kind) :: xorvec(N_int_max,2) + holes_array = -1 + particles_array = -1 + degree_array = 0 + do i = 1, N_int + xorvec(i,1) = xor( key_i(i,1), key_j(i,1)) + xorvec(i,2) = xor( key_i(i,2), key_j(i,2)) + degree_array(1) += popcnt(xorvec(i,1)) + degree_array(2) += popcnt(xorvec(i,2)) + enddo + degree_array(1) = shiftr(degree_array(1),1) + degree_array(2) = shiftr(degree_array(2),1) + + do ispin = 1, 2 + k = 1 + !!! GETTING THE HOLES + do i = 1, N_int + key_hole = iand(xorvec(i,ispin),key_i(i,ispin)) + do while(key_hole .ne.0_bit_kind) + pos = trailz(key_hole) + holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos + key_hole = ibclr(key_hole,pos) + k += 1 + if(k .gt.100)then + print*,'WARNING in get_excitation_general' + print*,'More than a 100-th excitation for spin ',ispin + print*,'stoping ...' + stop + endif + enddo + enddo + enddo + do ispin = 1, 2 + k = 1 + !!! GETTING THE PARTICLES + do i = 1, N_int + key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin)) + do while(key_particle .ne.0_bit_kind) + pos = trailz(key_particle) + particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos + key_particle = ibclr(key_particle,pos) + k += 1 + if(k .gt.100)then + print*,'WARNING in get_excitation_general ' + print*,'More than a 100-th excitation for spin ',ispin + print*,'stoping ...' + stop + endif + enddo + enddo + enddo + integer :: h,p, i_ok + integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:) + integer :: exc(0:2,2,2) + double precision :: phase_tmp + allocate(det_i(Nint,2),det_ip(N_int,2)) + det_i = key_i + phase = 1.d0 + do ispin = 1, 2 + do i = 1, degree_array(ispin) + h = holes_array(i,ispin) + p = particles_array(i,ispin) + det_ip = det_i + call do_single_excitation(det_ip,h,p,ispin,i_ok) + if(i_ok == -1)then + print*,'excitation was not possible ' + stop + endif + call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint) + phase *= phase_tmp + det_i = det_ip + enddo + enddo + +end + +subroutine get_holes_general(key_i, key_j,Nint, holes_array) + use bitmasks + BEGIN_DOC +! returns the array, per spin, of holes between key_i and key_j +! +! with the following convention: a_{hole}|key_i> --> |key_j> + END_DOC + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + integer, intent(out) :: holes_array(100,2) + integer(bit_kind) :: key_hole + integer :: ispin,k,i,pos + holes_array = -1 + do ispin = 1, 2 + k = 1 + do i = 1, N_int + key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin)) + do while(key_hole .ne.0_bit_kind) + pos = trailz(key_hole) + holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos + key_hole = ibclr(key_hole,pos) + k += 1 + if(k .gt.100)then + print*,'WARNING in get_holes_general' + print*,'More than a 100-th excitation for spin ',ispin + print*,'stoping ...' + stop + endif + enddo + enddo + enddo +end + +subroutine get_particles_general(key_i, key_j,Nint,particles_array) + use bitmasks + BEGIN_DOC +! returns the array, per spin, of particles between key_i and key_j +! +! with the following convention: a^dagger_{particle}|key_i> --> |key_j> + END_DOC + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + integer, intent(out) :: particles_array(100,2) + integer(bit_kind) :: key_particle + integer :: ispin,k,i,pos + particles_array = -1 + do ispin = 1, 2 + k = 1 + do i = 1, N_int + key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin)) + do while(key_particle .ne.0_bit_kind) + pos = trailz(key_particle) + particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos + key_particle = ibclr(key_particle,pos) + k += 1 + if(k .gt.100)then + print*,'WARNING in get_holes_general' + print*,'More than a 100-th excitation for spin ',ispin + print*,'Those are the two determinants' + call debug_det(key_i, N_int) + call debug_det(key_j, N_int) + print*,'stoping ...' + stop + endif + enddo + enddo + enddo +end + +subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase) + implicit none + integer, intent(in) :: degree(2), Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + integer, intent(in) :: holes_array(100,2),particles_array(100,2) + double precision, intent(out) :: phase + integer :: i,ispin,h,p, i_ok + integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:) + integer :: exc(0:2,2,2) + double precision :: phase_tmp + allocate(det_i(Nint,2),det_ip(N_int,2)) + det_i = key_i + phase = 1.d0 + do ispin = 1, 2 + do i = 1, degree(ispin) + h = holes_array(i,ispin) + p = particles_array(i,ispin) + det_ip = det_i + call do_single_excitation(det_ip,h,p,ispin,i_ok) + if(i_ok == -1)then + print*,'excitation was not possible ' + stop + endif + call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint) + phase *= phase_tmp + det_i = det_ip + enddo + enddo + +end + diff --git a/plugins/local/slater_tc/h_tc_bi_ortho_psi.irp.f b/plugins/local/slater_tc_no_opt/h_tc_bi_ortho_psi.irp.f similarity index 100% rename from plugins/local/slater_tc/h_tc_bi_ortho_psi.irp.f rename to plugins/local/slater_tc_no_opt/h_tc_bi_ortho_psi.irp.f diff --git a/plugins/local/slater_tc/slater_tc_3e_slow.irp.f b/plugins/local/slater_tc_no_opt/slater_tc_3e_slow.irp.f similarity index 99% rename from plugins/local/slater_tc/slater_tc_3e_slow.irp.f rename to plugins/local/slater_tc_no_opt/slater_tc_3e_slow.irp.f index cb33d343..f7919653 100644 --- a/plugins/local/slater_tc/slater_tc_3e_slow.irp.f +++ b/plugins/local/slater_tc_no_opt/slater_tc_3e_slow.irp.f @@ -1,7 +1,7 @@ ! --- -subroutine diag_htilde_three_body_ints_bi_ort_slow(Nint, key_i, hthree) +subroutine diag_htc_bi_orth_3e_brute(Nint, key_i, hthree) BEGIN_DOC ! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS diff --git a/plugins/local/slater_tc/slater_tc.irp.f b/plugins/local/slater_tc_no_opt/slater_tc_no_opt.irp.f similarity index 82% rename from plugins/local/slater_tc/slater_tc.irp.f rename to plugins/local/slater_tc_no_opt/slater_tc_no_opt.irp.f index 27ab47c5..0fcc587f 100644 --- a/plugins/local/slater_tc/slater_tc.irp.f +++ b/plugins/local/slater_tc_no_opt/slater_tc_no_opt.irp.f @@ -1,4 +1,4 @@ -program slater_tc +program slater_tc_no_opt implicit none BEGIN_DOC ! TODO : Put the documentation of the program here diff --git a/plugins/local/slater_tc/slater_tc_slow.irp.f b/plugins/local/slater_tc_no_opt/slater_tc_slow.irp.f similarity index 80% rename from plugins/local/slater_tc/slater_tc_slow.irp.f rename to plugins/local/slater_tc_no_opt/slater_tc_slow.irp.f index caf7d665..b06fd12f 100644 --- a/plugins/local/slater_tc/slater_tc_slow.irp.f +++ b/plugins/local/slater_tc_no_opt/slater_tc_slow.irp.f @@ -61,7 +61,7 @@ subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree, if(degree.gt.2) return if(degree == 0) then - call diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot) + call diag_htc_bi_orth_2e_brute(Nint, key_i, hmono, htwoe, htot) else if (degree == 1) then call single_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot) else if(degree == 2) then @@ -76,7 +76,7 @@ subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree, else if((degree == 1) .and. (elec_num .gt. 2) .and. three_e_4_idx_term) then call single_htilde_three_body_ints_bi_ort_slow(Nint, key_j, key_i, hthree) else if((degree == 0) .and. (elec_num .gt. 2) .and. three_e_3_idx_term) then - call diag_htilde_three_body_ints_bi_ort_slow(Nint, key_i, hthree) + call diag_htc_bi_orth_3e_brute(Nint, key_i, hthree) endif endif @@ -95,75 +95,6 @@ end ! --- -subroutine diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot) - - BEGIN_DOC - ! - ! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS - ! - END_DOC - - use bitmasks - - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2) - double precision, intent(out) :: hmono,htwoe,htot - integer :: occ(Nint*bit_kind_size,2) - integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk - double precision :: get_mo_two_e_integral_tc_int - integer(bit_kind) :: key_i_core(Nint,2) - - PROVIDE mo_bi_ortho_tc_two_e - - hmono = 0.d0 - htwoe = 0.d0 - htot = 0.d0 - - call bitstring_to_list_ab(key_i, occ, Ne, Nint) - - do ispin = 1, 2 - do i = 1, Ne(ispin) - ii = occ(i,ispin) - hmono += mo_bi_ortho_tc_one_e(ii,ii) - enddo - enddo - - ! alpha/beta two-body - ispin = 1 - jspin = 2 - do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1)) - ii = occ(i,ispin) - do j = 1, Ne(jspin) ! electron 2 - jj = occ(j,jspin) - htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii) - enddo - enddo - - ! alpha/alpha two-body - do i = 1, Ne(ispin) - ii = occ(i,ispin) - do j = i+1, Ne(ispin) - jj = occ(j,ispin) - htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii) - enddo - enddo - - ! beta/beta two-body - do i = 1, Ne(jspin) - ii = occ(i,jspin) - do j = i+1, Ne(jspin) - jj = occ(j,jspin) - htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii) - enddo - enddo - - htot = hmono + htwoe - -end - -! --- - subroutine double_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot) BEGIN_DOC diff --git a/src/determinants/slater_rules_general.irp.f b/src/determinants/slater_rules_general.irp.f new file mode 100644 index 00000000..e987c846 --- /dev/null +++ b/src/determinants/slater_rules_general.irp.f @@ -0,0 +1,192 @@ +subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase) + use bitmasks + BEGIN_DOC +! returns the array, for each spin, of holes/particles between key_i and key_j +! +! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j> + END_DOC + include 'utils/constants.include.F' + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2) + double precision, intent(out) :: phase + integer :: ispin,k,i,pos + integer(bit_kind) :: key_hole, key_particle + integer(bit_kind) :: xorvec(N_int_max,2) + holes_array = -1 + particles_array = -1 + degree_array = 0 + do i = 1, N_int + xorvec(i,1) = xor( key_i(i,1), key_j(i,1)) + xorvec(i,2) = xor( key_i(i,2), key_j(i,2)) + degree_array(1) += popcnt(xorvec(i,1)) + degree_array(2) += popcnt(xorvec(i,2)) + enddo + degree_array(1) = shiftr(degree_array(1),1) + degree_array(2) = shiftr(degree_array(2),1) + + do ispin = 1, 2 + k = 1 + !!! GETTING THE HOLES + do i = 1, N_int + key_hole = iand(xorvec(i,ispin),key_i(i,ispin)) + do while(key_hole .ne.0_bit_kind) + pos = trailz(key_hole) + holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos + key_hole = ibclr(key_hole,pos) + k += 1 + if(k .gt.100)then + print*,'WARNING in get_excitation_general' + print*,'More than a 100-th excitation for spin ',ispin + print*,'stoping ...' + stop + endif + enddo + enddo + enddo + do ispin = 1, 2 + k = 1 + !!! GETTING THE PARTICLES + do i = 1, N_int + key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin)) + do while(key_particle .ne.0_bit_kind) + pos = trailz(key_particle) + particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos + key_particle = ibclr(key_particle,pos) + k += 1 + if(k .gt.100)then + print*,'WARNING in get_excitation_general ' + print*,'More than a 100-th excitation for spin ',ispin + print*,'stoping ...' + stop + endif + enddo + enddo + enddo + integer :: h,p, i_ok + integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:) + integer :: exc(0:2,2,2) + double precision :: phase_tmp + allocate(det_i(Nint,2),det_ip(N_int,2)) + det_i = key_i + phase = 1.d0 + do ispin = 1, 2 + do i = 1, degree_array(ispin) + h = holes_array(i,ispin) + p = particles_array(i,ispin) + det_ip = det_i + call do_single_excitation(det_ip,h,p,ispin,i_ok) + if(i_ok == -1)then + print*,'excitation was not possible ' + stop + endif + call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint) + phase *= phase_tmp + det_i = det_ip + enddo + enddo + +end + +subroutine get_holes_general(key_i, key_j,Nint, holes_array) + use bitmasks + BEGIN_DOC +! returns the array, per spin, of holes between key_i and key_j +! +! with the following convention: a_{hole}|key_i> --> |key_j> + END_DOC + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + integer, intent(out) :: holes_array(100,2) + integer(bit_kind) :: key_hole + integer :: ispin,k,i,pos + holes_array = -1 + do ispin = 1, 2 + k = 1 + do i = 1, N_int + key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin)) + do while(key_hole .ne.0_bit_kind) + pos = trailz(key_hole) + holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos + key_hole = ibclr(key_hole,pos) + k += 1 + if(k .gt.100)then + print*,'WARNING in get_holes_general' + print*,'More than a 100-th excitation for spin ',ispin + print*,'stoping ...' + stop + endif + enddo + enddo + enddo +end + +subroutine get_particles_general(key_i, key_j,Nint,particles_array) + use bitmasks + BEGIN_DOC +! returns the array, per spin, of particles between key_i and key_j +! +! with the following convention: a^dagger_{particle}|key_i> --> |key_j> + END_DOC + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + integer, intent(out) :: particles_array(100,2) + integer(bit_kind) :: key_particle + integer :: ispin,k,i,pos + particles_array = -1 + do ispin = 1, 2 + k = 1 + do i = 1, N_int + key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin)) + do while(key_particle .ne.0_bit_kind) + pos = trailz(key_particle) + particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos + key_particle = ibclr(key_particle,pos) + k += 1 + if(k .gt.100)then + print*,'WARNING in get_holes_general' + print*,'More than a 100-th excitation for spin ',ispin + print*,'Those are the two determinants' + call debug_det(key_i, N_int) + call debug_det(key_j, N_int) + print*,'stoping ...' + stop + endif + enddo + enddo + enddo +end + +subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase) + implicit none + integer, intent(in) :: degree(2), Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + integer, intent(in) :: holes_array(100,2),particles_array(100,2) + double precision, intent(out) :: phase + integer :: i,ispin,h,p, i_ok + integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:) + integer :: exc(0:2,2,2) + double precision :: phase_tmp + allocate(det_i(Nint,2),det_ip(N_int,2)) + det_i = key_i + phase = 1.d0 + do ispin = 1, 2 + do i = 1, degree(ispin) + h = holes_array(i,ispin) + p = particles_array(i,ispin) + det_ip = det_i + call do_single_excitation(det_ip,h,p,ispin,i_ok) + if(i_ok == -1)then + print*,'excitation was not possible ' + stop + endif + call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint) + phase *= phase_tmp + det_i = det_ip + enddo + enddo + +end From b749796d931401f2c7e966e2c7eeedfff2f4477c Mon Sep 17 00:00:00 2001 From: eginer Date: Mon, 6 May 2024 18:33:29 +0200 Subject: [PATCH 43/50] still not compiling --- .../tc_bi_ortho/dressing_vectors_lr.irp.f | 8 ++++---- .../local/tc_bi_ortho/e_corr_bi_ortho.irp.f | 18 +++++++++--------- plugins/local/tc_bi_ortho/print_tc_wf.irp.f | 6 +++--- .../local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f | 2 +- plugins/local/tc_bi_ortho/tc_som.irp.f | 4 ++-- plugins/local/tc_bi_ortho/tc_utils.irp.f | 10 +++++----- .../local/tc_bi_ortho/test_normal_order.irp.f | 8 ++++---- .../local/tc_bi_ortho/test_tc_bi_ortho.irp.f | 10 +++++----- plugins/local/tc_bi_ortho/test_tc_fock.irp.f | 4 ++-- 9 files changed, 35 insertions(+), 35 deletions(-) diff --git a/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f b/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f index 0aff9980..135f9d17 100644 --- a/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f +++ b/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f @@ -27,7 +27,7 @@ subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta) i = 1 j = 1 - call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot) + call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot) call hmat_bi_ortho (psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot) delta = 0.d0 @@ -39,7 +39,7 @@ subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta) do j = 1, ndet ! < I |Htilde | J > - call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot) + call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot) ! < I |H | J > call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot) @@ -78,7 +78,7 @@ subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta) i = 1 j = 1 - call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot) + call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot) delta = 0.d0 !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & @@ -88,7 +88,7 @@ subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta) do j = 1, ndet ! < I |Htilde | J > - call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot) + call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot) delta(i) = delta(i) + psicoef(j) * htc_tot enddo diff --git a/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f index 6d5c3b21..4abdc25b 100644 --- a/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f +++ b/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f @@ -2,7 +2,7 @@ BEGIN_PROVIDER [ double precision, e_tilde_00] implicit none double precision :: hmono,htwoe,hthree,htot - call htilde_mu_mat_bi_ortho_slow(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot) + call htilde_mu_mat_opt_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot) e_tilde_00 = htot END_PROVIDER @@ -18,11 +18,11 @@ do i = 1, N_det call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) if(degree == 1 .or. degree == 2)then - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0) delta_e = e_tilde_00 - e_i0 coef_pt1 = htilde_ij / delta_e - call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_opt_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) e_pt2_tc_bi_orth += coef_pt1 * htilde_ij if(degree == 1)then e_pt2_tc_bi_orth_single += coef_pt1 * htilde_ij @@ -37,7 +37,7 @@ BEGIN_PROVIDER [ double precision, e_tilde_bi_orth_00] implicit none double precision :: hmono,htwoe,hthree,htilde_ij - call htilde_mu_mat_bi_ortho_slow(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00) + call htilde_mu_mat_opt_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00) e_tilde_bi_orth_00 += nuclear_repulsion END_PROVIDER @@ -57,7 +57,7 @@ e_corr_double_bi_orth = 0.d0 do i = 1, N_det call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) - call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_opt_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) if(degree == 1)then e_corr_single_bi_orth += reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1) e_corr_single_bi_orth_abs += dabs(reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1)) @@ -80,7 +80,7 @@ do i = 1, N_det accu += reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(i,1) do j = 1, N_det - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) e_tc_left_right += htilde_ij * reigvec_tc_bi_orth(i,1) * leigvec_tc_bi_orth(j,1) enddo enddo @@ -99,8 +99,8 @@ BEGIN_PROVIDER [ double precision, coef_pt1_bi_ortho, (N_det)] if(degree==0)then coef_pt1_bi_ortho(i) = 1.d0 else - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0) delta_e = e_tilde_00 - e_i0 coef_pt1 = htilde_ij / delta_e coef_pt1_bi_ortho(i)= coef_pt1 diff --git a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f b/plugins/local/tc_bi_ortho/print_tc_wf.irp.f index 2b88bc5b..ab5ce371 100644 --- a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f +++ b/plugins/local/tc_bi_ortho/print_tc_wf.irp.f @@ -61,12 +61,12 @@ subroutine routine do i = 1, N_det call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) if(degree == 1 .or. degree == 2)then - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0) delta_e = e_tilde_00 - e_i0 coef_pt1 = htilde_ij / delta_e - call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_opt_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij) contrib_pt = coef_pt1 * htilde_ij e_pt2 += contrib_pt diff --git a/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f b/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f index 4c3c0788..5cbf26d2 100644 --- a/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f +++ b/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f @@ -14,7 +14,7 @@ call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i)) call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) if(degree == 1 .or. degree == 2)then - call htilde_mu_mat_bi_ortho_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i)) + call htilde_mu_mat_opt_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i)) endif enddo reigvec_tc_bi_orth_tmp = 0.d0 diff --git a/plugins/local/tc_bi_ortho/tc_som.irp.f b/plugins/local/tc_bi_ortho/tc_som.irp.f index 1d11c81b..6bdcc1f0 100644 --- a/plugins/local/tc_bi_ortho/tc_som.irp.f +++ b/plugins/local/tc_bi_ortho/tc_som.irp.f @@ -49,8 +49,8 @@ subroutine main() U_SOM = 0.d0 do i = 1, N_det if(i == i_HF) cycle - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1) - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2) U_SOM += htot_1 * htot_2 enddo U_SOM = 0.5d0 * U_SOM diff --git a/plugins/local/tc_bi_ortho/tc_utils.irp.f b/plugins/local/tc_bi_ortho/tc_utils.irp.f index 43a6865e..2aa148a3 100644 --- a/plugins/local/tc_bi_ortho/tc_utils.irp.f +++ b/plugins/local/tc_bi_ortho/tc_utils.irp.f @@ -25,7 +25,7 @@ subroutine write_tc_energy() 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) + call htilde_mu_mat_opt_bi_ortho(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 @@ -70,7 +70,7 @@ subroutine write_tc_energy() E_3e = 0.d0 do i = 1, N_det 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) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot) E_TC = E_TC + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * htot E_1e = E_1e + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * hmono E_2e = E_2e + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * htwoe @@ -109,8 +109,8 @@ subroutine write_tc_var() SIGMA_TC = 0.d0 do j = 2, N_det - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot_1j) - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot_j1) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot_1j) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot_j1) SIGMA_TC = SIGMA_TC + htot_1j * htot_j1 enddo @@ -132,7 +132,7 @@ subroutine write_tc_gs_var_HF() 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) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot) SIGMA_TC = SIGMA_TC + htot * htot enddo diff --git a/plugins/local/tc_bi_ortho/test_normal_order.irp.f b/plugins/local/tc_bi_ortho/test_normal_order.irp.f index 0cf27396..7b4c558f 100644 --- a/plugins/local/tc_bi_ortho/test_normal_order.irp.f +++ b/plugins/local/tc_bi_ortho/test_normal_order.irp.f @@ -54,7 +54,7 @@ subroutine test if(i_ok.ne.1)cycle call do_single_excitation(det_i,h2,p2,s2,i_ok) if(i_ok.ne.1)cycle - call htilde_mu_mat_bi_ortho_slow(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij) + call htilde_mu_mat_opt_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij) call get_excitation_degree(ref_bitmask,det_i,degree,N_int) call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) hthree_tmp *= phase @@ -66,7 +66,7 @@ subroutine test if(i_ok.ne.1)cycle call do_single_excitation(det_i,h2,p2,s2,i_ok) if(i_ok.ne.1)cycle - call htilde_mu_mat_bi_ortho_slow(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij) + call htilde_mu_mat_opt_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij) call get_excitation_degree(ref_bitmask,det_i,degree,N_int) call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) hthree_tmp *= phase @@ -109,7 +109,7 @@ do h1 = 1, elec_alpha_num if(i_ok.ne.1)cycle call do_single_excitation(det_i,h2,p2,s2,i_ok) if(i_ok.ne.1)cycle - call htilde_mu_mat_bi_ortho_slow(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_opt_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) call get_excitation_degree(ref_bitmask,det_i,degree,N_int) call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) integer :: hh1, pp1, hh2, pp2, ss1, ss2 @@ -145,7 +145,7 @@ do h1 = 1, elec_beta_num if(i_ok.ne.1)cycle call do_single_excitation(det_i,h2,p2,s2,i_ok) if(i_ok.ne.1)cycle - call htilde_mu_mat_bi_ortho_slow(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) + call htilde_mu_mat_opt_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) call get_excitation_degree(ref_bitmask,det_i,degree,N_int) call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2) diff --git a/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f index 369efd15..559c0200 100644 --- a/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f +++ b/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f @@ -88,7 +88,7 @@ subroutine test_slater_tc_opt i_count = 0.d0 do i = 1, N_det do j = 1,N_det - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hnewmono, hnewtwoe, hnewthree, hnewtot) if(dabs(htot).gt.1.d-15)then i_count += 1.D0 @@ -124,7 +124,7 @@ subroutine timing_tot do j = 1, N_det ! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int) i_count += 1.d0 - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) enddo enddo call wall_time(wall1) @@ -171,7 +171,7 @@ subroutine timing_diag do i = 1, N_det do j = i,i i_count += 1.d0 - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) enddo enddo call wall_time(wall1) @@ -208,7 +208,7 @@ subroutine timing_single if(degree.ne.1)cycle i_count += 1.d0 call wall_time(wall0) - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) call wall_time(wall1) accu += wall1 - wall0 enddo @@ -250,7 +250,7 @@ subroutine timing_double if(degree.ne.2)cycle i_count += 1.d0 call wall_time(wall0) - call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) + call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot) call wall_time(wall1) accu += wall1 - wall0 enddo diff --git a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f b/plugins/local/tc_bi_ortho/test_tc_fock.irp.f index 85f3ed97..b33b2e93 100644 --- a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f +++ b/plugins/local/tc_bi_ortho/test_tc_fock.irp.f @@ -64,7 +64,7 @@ subroutine routine_3() print*, ' excited det' call debug_det(det_i, N_int) - call htilde_mu_mat_bi_ortho_slow(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij) + call htilde_mu_mat_opt_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij) if(dabs(hthree).lt.1.d-10)cycle ref = hthree if(s1 == 1)then @@ -130,7 +130,7 @@ subroutine routine_tot() stop endif - call htilde_mu_mat_bi_ortho_slow(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij) + call htilde_mu_mat_opt_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij) print*,htilde_ij ! if(dabs(htilde_ij).lt.1.d-10)cycle print*, ' excited det' From 366afb2933baba919db1ad85b7eee965ea56d0c6 Mon Sep 17 00:00:00 2001 From: eginer Date: Mon, 6 May 2024 18:53:20 +0200 Subject: [PATCH 44/50] compiling after some cleaning --- plugins/local/old_delta_tc_qmc/NEED | 1 + plugins/local/old_delta_tc_qmc/README.rst | 4 + .../compute_deltamu_right.irp.f | 0 .../dressing_vectors_lr.irp.f | 0 .../old_delta_tc_qmc/old_delta_tc_qmc.irp.f | 7 + plugins/local/slater_tc/h_mat_triple.irp.f | 198 ++++++++++++++++++ .../local/slater_tc_no_opt/h_mat_triple.irp.f | 193 ----------------- .../test_tc_bi_ortho.irp.f | 0 plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f | 129 ------------ plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f | 36 ---- .../local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f | 145 ------------- plugins/local/tc_bi_ortho/test_s2_tc.irp.f | 170 --------------- 12 files changed, 210 insertions(+), 673 deletions(-) create mode 100644 plugins/local/old_delta_tc_qmc/NEED create mode 100644 plugins/local/old_delta_tc_qmc/README.rst rename plugins/local/{tc_bi_ortho => old_delta_tc_qmc}/compute_deltamu_right.irp.f (100%) rename plugins/local/{tc_bi_ortho => old_delta_tc_qmc}/dressing_vectors_lr.irp.f (100%) create mode 100644 plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f create mode 100644 plugins/local/slater_tc/h_mat_triple.irp.f delete mode 100644 plugins/local/slater_tc_no_opt/h_mat_triple.irp.f rename plugins/local/{tc_bi_ortho => slater_tc_no_opt}/test_tc_bi_ortho.irp.f (100%) delete mode 100644 plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f delete mode 100644 plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f delete mode 100644 plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f delete mode 100644 plugins/local/tc_bi_ortho/test_s2_tc.irp.f diff --git a/plugins/local/old_delta_tc_qmc/NEED b/plugins/local/old_delta_tc_qmc/NEED new file mode 100644 index 00000000..8b137891 --- /dev/null +++ b/plugins/local/old_delta_tc_qmc/NEED @@ -0,0 +1 @@ + diff --git a/plugins/local/old_delta_tc_qmc/README.rst b/plugins/local/old_delta_tc_qmc/README.rst new file mode 100644 index 00000000..1d56f96c --- /dev/null +++ b/plugins/local/old_delta_tc_qmc/README.rst @@ -0,0 +1,4 @@ +================ +old_delta_tc_qmc +================ + diff --git a/plugins/local/tc_bi_ortho/compute_deltamu_right.irp.f b/plugins/local/old_delta_tc_qmc/compute_deltamu_right.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/compute_deltamu_right.irp.f rename to plugins/local/old_delta_tc_qmc/compute_deltamu_right.irp.f diff --git a/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f b/plugins/local/old_delta_tc_qmc/dressing_vectors_lr.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f rename to plugins/local/old_delta_tc_qmc/dressing_vectors_lr.irp.f diff --git a/plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f b/plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f new file mode 100644 index 00000000..5ff08bd6 --- /dev/null +++ b/plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f @@ -0,0 +1,7 @@ +program old_delta_tc_qmc + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + print *, 'Hello world' +end diff --git a/plugins/local/slater_tc/h_mat_triple.irp.f b/plugins/local/slater_tc/h_mat_triple.irp.f new file mode 100644 index 00000000..9cb4b60a --- /dev/null +++ b/plugins/local/slater_tc/h_mat_triple.irp.f @@ -0,0 +1,198 @@ +subroutine H_tc_s2_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze) + BEGIN_DOC + ! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + + use bitmasks + implicit none + + integer, intent(in) :: N_st,sze + double precision, intent(in) :: u_0(sze,N_st) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + call H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze) + integer :: i,j,degree,ist + double precision :: hmono, htwoe, hthree, htot + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if(degree .ne. 3)cycle + call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,i), psi_det(1,1,j), hmono, htwoe, hthree, htot) + do ist = 1, N_st + v_0(i,ist) += htot * u_0(j,ist) + enddo + enddo + enddo +end + +subroutine H_tc_s2_u_0_with_pure_three_omp(v_0, s_0, u_0, N_st, sze) + BEGIN_DOC + ! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + + use bitmasks + implicit none + + integer, intent(in) :: N_st,sze + double precision, intent(in) :: u_0(sze,N_st) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + call H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze) + integer :: i,j,degree,ist + double precision :: hmono, htwoe, hthree, htot + !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & + !$OMP SHARED(N_st, N_det, N_int, psi_det, u_0, v_0) & + !$OMP PRIVATE(ist, i, j, degree, hmono, htwoe, hthree,htot) + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if(degree .ne. 3)cycle + call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,i), psi_det(1,1,j), hmono, htwoe, hthree, htot) + do ist = 1, N_st + v_0(i,ist) += htot * u_0(j,ist) + enddo + enddo + enddo + !$OMP END PARALLEL DO +end + +! --- + +subroutine H_tc_s2_dagger_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze) + BEGIN_DOC + ! Computes $v_0 = (H^TC)^dagger | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + + use bitmasks + implicit none + + integer, intent(in) :: N_st,sze + double precision, intent(in) :: u_0(sze,N_st) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + call H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze) + integer :: i,j,degree,ist + double precision :: hmono, htwoe, hthree, htot + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if(degree .ne. 3)cycle + call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,j), psi_det(1,1,i), hmono, htwoe, hthree, htot) + do ist = 1, N_st + v_0(i,ist) += htot * u_0(j,ist) + enddo + enddo + enddo +end + +subroutine H_tc_s2_dagger_u_0_with_pure_three_omp(v_0, s_0, u_0, N_st, sze) + BEGIN_DOC + ! Computes $v_0 = (H^TC)^dagger | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + + use bitmasks + implicit none + + integer, intent(in) :: N_st,sze + double precision, intent(in) :: u_0(sze,N_st) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + call H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze) + integer :: i,j,degree,ist + double precision :: hmono, htwoe, hthree, htot + !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & + !$OMP SHARED(N_st, N_det, N_int, psi_det, u_0, v_0) & + !$OMP PRIVATE(ist, i, j, degree, hmono, htwoe, hthree,htot) + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if(degree .ne. 3)cycle + call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,j), psi_det(1,1,i), hmono, htwoe, hthree, htot) + do ist = 1, N_st + v_0(i,ist) += htot * u_0(j,ist) + enddo + enddo + enddo + !$OMP END PARALLEL DO +end + +! --- +subroutine triple_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot) + use bitmasks + BEGIN_DOC +! for triple excitation +!! +!! WARNING !! +! +! Genuine triple excitations of the same spin are not yet implemented + END_DOC + implicit none + integer(bit_kind), intent(in) :: key_j(N_int,2),key_i(N_int,2) + integer, intent(in) :: Nint + double precision, intent(out) :: hmono, htwoe, hthree, htot + integer :: degree + integer :: h1, p1, h2, p2, s1, s2, h3, p3, s3 + integer :: holes_array(100,2),particles_array(100,2),degree_array(2) + double precision :: phase,sym_3_e_int_from_6_idx_tensor + + hmono = 0.d0 + htwoe = 0.d0 + hthree = 0.d0 + htot = 0.d0 + call get_excitation_general(key_j, key_i, Nint,degree_array,holes_array, particles_array,phase) + degree = degree_array(1) + degree_array(2) + if(degree .ne. 3)return + if(degree_array(1)==3.or.degree_array(2)==3)then + if(degree_array(1) == 3)then + h1 = holes_array(1,1) + h2 = holes_array(2,1) + h3 = holes_array(3,1) + p1 = particles_array(1,1) + p2 = particles_array(2,1) + p3 = particles_array(3,1) + else + h1 = holes_array(1,2) + h2 = holes_array(2,2) + h3 = holes_array(3,2) + p1 = particles_array(1,2) + p2 = particles_array(2,2) + p3 = particles_array(3,2) + endif + hthree = sym_3_e_int_from_6_idx_tensor(p3, p2, p1, h3, h2, h1) + else + if(degree_array(1) == 2.and.degree_array(2) == 1)then ! double alpha + single beta + h1 = holes_array(1,1) + h2 = holes_array(2,1) + h3 = holes_array(1,2) + p1 = particles_array(1,1) + p2 = particles_array(2,1) + p3 = particles_array(1,2) + else if(degree_array(2) == 2 .and. degree_array(1) == 1)then ! double beta + single alpha + h1 = holes_array(1,2) + h2 = holes_array(2,2) + h3 = holes_array(1,1) + p1 = particles_array(1,2) + p2 = particles_array(2,2) + p3 = particles_array(1,1) + else + print*,'PB !!' + stop + endif + hthree = three_body_ints_bi_ort(p3,p2,p1,h3,h2,h1) - three_body_ints_bi_ort(p3,p2,p1,h3,h1,h2) + endif + hthree *= phase + htot = hthree + end + diff --git a/plugins/local/slater_tc_no_opt/h_mat_triple.irp.f b/plugins/local/slater_tc_no_opt/h_mat_triple.irp.f deleted file mode 100644 index e2c8f982..00000000 --- a/plugins/local/slater_tc_no_opt/h_mat_triple.irp.f +++ /dev/null @@ -1,193 +0,0 @@ -subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase) - use bitmasks - BEGIN_DOC -! returns the array, for each spin, of holes/particles between key_i and key_j -! -! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j> - END_DOC - include 'utils/constants.include.F' - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) - integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2) - double precision, intent(out) :: phase - integer :: ispin,k,i,pos - integer(bit_kind) :: key_hole, key_particle - integer(bit_kind) :: xorvec(N_int_max,2) - holes_array = -1 - particles_array = -1 - degree_array = 0 - do i = 1, N_int - xorvec(i,1) = xor( key_i(i,1), key_j(i,1)) - xorvec(i,2) = xor( key_i(i,2), key_j(i,2)) - degree_array(1) += popcnt(xorvec(i,1)) - degree_array(2) += popcnt(xorvec(i,2)) - enddo - degree_array(1) = shiftr(degree_array(1),1) - degree_array(2) = shiftr(degree_array(2),1) - - do ispin = 1, 2 - k = 1 - !!! GETTING THE HOLES - do i = 1, N_int - key_hole = iand(xorvec(i,ispin),key_i(i,ispin)) - do while(key_hole .ne.0_bit_kind) - pos = trailz(key_hole) - holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos - key_hole = ibclr(key_hole,pos) - k += 1 - if(k .gt.100)then - print*,'WARNING in get_excitation_general' - print*,'More than a 100-th excitation for spin ',ispin - print*,'stoping ...' - stop - endif - enddo - enddo - enddo - do ispin = 1, 2 - k = 1 - !!! GETTING THE PARTICLES - do i = 1, N_int - key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin)) - do while(key_particle .ne.0_bit_kind) - pos = trailz(key_particle) - particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos - key_particle = ibclr(key_particle,pos) - k += 1 - if(k .gt.100)then - print*,'WARNING in get_excitation_general ' - print*,'More than a 100-th excitation for spin ',ispin - print*,'stoping ...' - stop - endif - enddo - enddo - enddo - integer :: h,p, i_ok - integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:) - integer :: exc(0:2,2,2) - double precision :: phase_tmp - allocate(det_i(Nint,2),det_ip(N_int,2)) - det_i = key_i - phase = 1.d0 - do ispin = 1, 2 - do i = 1, degree_array(ispin) - h = holes_array(i,ispin) - p = particles_array(i,ispin) - det_ip = det_i - call do_single_excitation(det_ip,h,p,ispin,i_ok) - if(i_ok == -1)then - print*,'excitation was not possible ' - stop - endif - call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint) - phase *= phase_tmp - det_i = det_ip - enddo - enddo - -end - -subroutine get_holes_general(key_i, key_j,Nint, holes_array) - use bitmasks - BEGIN_DOC -! returns the array, per spin, of holes between key_i and key_j -! -! with the following convention: a_{hole}|key_i> --> |key_j> - END_DOC - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) - integer, intent(out) :: holes_array(100,2) - integer(bit_kind) :: key_hole - integer :: ispin,k,i,pos - holes_array = -1 - do ispin = 1, 2 - k = 1 - do i = 1, N_int - key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin)) - do while(key_hole .ne.0_bit_kind) - pos = trailz(key_hole) - holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos - key_hole = ibclr(key_hole,pos) - k += 1 - if(k .gt.100)then - print*,'WARNING in get_holes_general' - print*,'More than a 100-th excitation for spin ',ispin - print*,'stoping ...' - stop - endif - enddo - enddo - enddo -end - -subroutine get_particles_general(key_i, key_j,Nint,particles_array) - use bitmasks - BEGIN_DOC -! returns the array, per spin, of particles between key_i and key_j -! -! with the following convention: a^dagger_{particle}|key_i> --> |key_j> - END_DOC - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) - integer, intent(out) :: particles_array(100,2) - integer(bit_kind) :: key_particle - integer :: ispin,k,i,pos - particles_array = -1 - do ispin = 1, 2 - k = 1 - do i = 1, N_int - key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin)) - do while(key_particle .ne.0_bit_kind) - pos = trailz(key_particle) - particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos - key_particle = ibclr(key_particle,pos) - k += 1 - if(k .gt.100)then - print*,'WARNING in get_holes_general' - print*,'More than a 100-th excitation for spin ',ispin - print*,'Those are the two determinants' - call debug_det(key_i, N_int) - call debug_det(key_j, N_int) - print*,'stoping ...' - stop - endif - enddo - enddo - enddo -end - -subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase) - implicit none - integer, intent(in) :: degree(2), Nint - integer(bit_kind), intent(in) :: key_i(Nint,2) - integer, intent(in) :: holes_array(100,2),particles_array(100,2) - double precision, intent(out) :: phase - integer :: i,ispin,h,p, i_ok - integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:) - integer :: exc(0:2,2,2) - double precision :: phase_tmp - allocate(det_i(Nint,2),det_ip(N_int,2)) - det_i = key_i - phase = 1.d0 - do ispin = 1, 2 - do i = 1, degree(ispin) - h = holes_array(i,ispin) - p = particles_array(i,ispin) - det_ip = det_i - call do_single_excitation(det_ip,h,p,ispin,i_ok) - if(i_ok == -1)then - print*,'excitation was not possible ' - stop - endif - call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint) - phase *= phase_tmp - det_i = det_ip - enddo - enddo - -end - diff --git a/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f b/plugins/local/slater_tc_no_opt/test_tc_bi_ortho.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f rename to plugins/local/slater_tc_no_opt/test_tc_bi_ortho.irp.f diff --git a/plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f b/plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f deleted file mode 100644 index 8940a4f6..00000000 --- a/plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f +++ /dev/null @@ -1,129 +0,0 @@ -program pt2_tc_cisd - - BEGIN_DOC - ! - ! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together - ! with the energy. Saves the left-right wave functions at the end. - ! - 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 - - read_wf = .True. - touch read_wf - - print*, ' nb of states = ', N_states - print*, ' nb of det = ', N_det - call routine_diag() - - call routine -end - -subroutine routine - implicit none - integer :: i,h1,p1,h2,p2,s1,s2,degree - double precision :: h0i,hi0,e00,ei,delta_e - double precision :: norm,e_corr,coef,e_corr_pos,e_corr_neg,e_corr_abs - - integer :: exc(0:2,2,2) - double precision :: phase - double precision :: eh1,ep1,eh2,ep2 - - norm = 0.d0 - e_corr = 0.d0 - e_corr_abs = 0.d0 - e_corr_pos = 0.d0 - e_corr_neg = 0.d0 - call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,1), psi_det(1,1,1), N_int, e00) - do i = 2, N_det - call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,1), N_int, hi0) - call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,1), psi_det(1,1,i), N_int, h0i) - call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, ei) - call get_excitation_degree(psi_det(1,1,1), psi_det(1,1,i),degree,N_int) - call get_excitation(psi_det(1,1,1), psi_det(1,1,i),exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - eh1 = Fock_matrix_tc_diag_mo_tot(h1) - ep1 = Fock_matrix_tc_diag_mo_tot(p1) - delta_e = eh1 - ep1 - if (degree==2)then - eh2 = Fock_matrix_tc_diag_mo_tot(h2) - ep2 = Fock_matrix_tc_diag_mo_tot(p2) - delta_e += eh2 - ep2 - endif -! delta_e = e00 - ei - coef = hi0/delta_e - norm += coef*coef - e_corr = coef* h0i - if(e_corr.lt.0.d0)then - e_corr_neg += e_corr - elseif(e_corr.gt.0.d0)then - e_corr_pos += e_corr - endif - e_corr_abs += dabs(e_corr) - enddo - print*,'e_corr_abs = ',e_corr_abs - print*,'e_corr_pos = ',e_corr_pos - print*,'e_corr_neg = ',e_corr_neg - print*,'norm = ',dsqrt(norm) - -end - -subroutine routine_diag() - - implicit none - integer :: i, j, k - double precision :: dE - - ! provide eigval_right_tc_bi_orth - ! provide overlap_bi_ortho - ! provide htilde_matrix_elmt_bi_ortho - - if(N_states .eq. 1) then - - print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1) - print*,'e_tc_left_right = ',e_tc_left_right - print*,'e_tilde_bi_orth_00 = ',e_tilde_bi_orth_00 - print*,'e_pt2_tc_bi_orth = ',e_pt2_tc_bi_orth - print*,'e_pt2_tc_bi_orth_single = ',e_pt2_tc_bi_orth_single - print*,'e_pt2_tc_bi_orth_double = ',e_pt2_tc_bi_orth_double - print*,'***' - print*,'e_corr_bi_orth = ',e_corr_bi_orth - print*,'e_corr_bi_orth_proj = ',e_corr_bi_orth_proj - print*,'e_corr_bi_orth_proj_abs = ',e_corr_bi_orth_proj_abs - print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth - print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth - print*,'e_corr_single_bi_orth_abs = ',e_corr_single_bi_orth_abs - print*,'e_corr_double_bi_orth_abs = ',e_corr_double_bi_orth_abs - print*,'Left/right eigenvectors' - do i = 1,N_det - write(*,'(I5,X,(100(F12.7,X)))')i,leigvec_tc_bi_orth(i,1),reigvec_tc_bi_orth(i,1),leigvec_tc_bi_orth(i,1)*reigvec_tc_bi_orth(i,1) - enddo - - else - - print*,'eigval_right_tc_bi_orth : ' - do i = 1, N_states - print*, i, eigval_right_tc_bi_orth(i) - enddo - - print*,'' - print*,'******************************************************' - print*,'TC Excitation energies (au) (eV)' - do i = 2, N_states - dE = eigval_right_tc_bi_orth(i) - eigval_right_tc_bi_orth(1) - print*, i, dE, dE/0.0367502d0 - enddo - print*,'' - - endif - -end - - - diff --git a/plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f b/plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f deleted file mode 100644 index d4c8c55d..00000000 --- a/plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f +++ /dev/null @@ -1,36 +0,0 @@ - -! --- - -program tc_cisd_sc2 - - 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 - - read_wf = .True. - touch read_wf - - call test - -end - -! --- - -subroutine test() - implicit none -! double precision, allocatable :: dressing_dets(:),e_corr_dets(:) -! allocate(dressing_dets(N_det),e_corr_dets(N_det)) -! e_corr_dets = 0.d0 -! call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets) - provide eigval_tc_cisd_sc2_bi_ortho -end diff --git a/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f b/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f deleted file mode 100644 index 5cbf26d2..00000000 --- a/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f +++ /dev/null @@ -1,145 +0,0 @@ - BEGIN_PROVIDER [ double precision, reigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)] -&BEGIN_PROVIDER [ double precision, leigvec_tc_cisd_sc2_bi_ortho, (N_det,N_states)] -&BEGIN_PROVIDER [ double precision, eigval_tc_cisd_sc2_bi_ortho, (N_states)] - implicit none - integer :: it,n_real,degree,i,istate - double precision :: e_before, e_current,thr, hmono,htwoe,hthree,accu - double precision, allocatable :: e_corr_dets(:),h0j(:), h_sc2(:,:), dressing_dets(:) - double precision, allocatable :: leigvec_tc_bi_orth_tmp(:,:),reigvec_tc_bi_orth_tmp(:,:),eigval_right_tmp(:) - allocate(leigvec_tc_bi_orth_tmp(N_det,N_det),reigvec_tc_bi_orth_tmp(N_det,N_det),eigval_right_tmp(N_det)) - allocate(e_corr_dets(N_det),h0j(N_det),h_sc2(N_det,N_det),dressing_dets(N_det)) - allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),eigval_tmp(N_states)) - dressing_dets = 0.d0 - do i = 1, N_det - call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i)) - call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) - if(degree == 1 .or. degree == 2)then - call htilde_mu_mat_opt_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i)) - endif - enddo - reigvec_tc_bi_orth_tmp = 0.d0 - do i = 1, N_det - reigvec_tc_bi_orth_tmp(i,1) = psi_r_coef_bi_ortho(i,1) - enddo - vec_tmp = 0.d0 - do istate = 1, N_states - vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate) - enddo - do istate = N_states+1, n_states_diag - vec_tmp(istate,istate) = 1.d0 - enddo - print*,'Diagonalizing the TC CISD ' - call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow) - do i = 1, N_det - e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1) - enddo - E_before = eigval_tmp(1) - print*,'Starting from ',E_before - - e_current = 10.d0 - thr = 1.d-5 - it = 0 - dressing_dets = 0.d0 - double precision, allocatable :: H_jj(:),vec_tmp(:,:),eigval_tmp(:) - external htc_bi_ortho_calc_tdav_slow - external htcdag_bi_ortho_calc_tdav_slow - logical :: converged - do while (dabs(E_before-E_current).gt.thr) - it += 1 - E_before = E_current -! h_sc2 = htilde_matrix_elmt_bi_ortho - call get_cisd_sc2_dressing(psi_det,e_corr_dets,N_det,dressing_dets) - do i = 1, N_det -! print*,'dressing_dets(i) = ',dressing_dets(i) - h_sc2(i,i) += dressing_dets(i) - enddo - print*,'********************' - print*,'iteration ',it -! call non_hrmt_real_diag(N_det,h_sc2,& -! leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,& -! n_real,eigval_right_tmp) -! print*,'eigval_right_tmp(1)',eigval_right_tmp(1) - vec_tmp = 0.d0 - do istate = 1, N_states - vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate) - enddo - do istate = N_states+1, n_states_diag - vec_tmp(istate,istate) = 1.d0 - enddo - call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow) - print*,'outside Davidson' - print*,'eigval_tmp(1) = ',eigval_tmp(1) - do i = 1, N_det - reigvec_tc_bi_orth_tmp(i,1) = vec_tmp(i,1) - e_corr_dets(i) = reigvec_tc_bi_orth_tmp(i,1) * h0j(i)/reigvec_tc_bi_orth_tmp(1,1) - enddo -! E_current = eigval_right_tmp(1) - E_current = eigval_tmp(1) - print*,'it, E(SC)^2 = ',it,E_current - enddo - eigval_tc_cisd_sc2_bi_ortho(1:N_states) = eigval_right_tmp(1:N_states) - reigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = reigvec_tc_bi_orth_tmp(1:N_det,1:N_states) - leigvec_tc_cisd_sc2_bi_ortho(1:N_det,1:N_states) = leigvec_tc_bi_orth_tmp(1:N_det,1:N_states) - -END_PROVIDER - -subroutine get_cisd_sc2_dressing(dets,e_corr_dets,ndet,dressing_dets) - implicit none - use bitmasks - integer, intent(in) :: ndet - integer(bit_kind), intent(in) :: dets(N_int,2,ndet) - double precision, intent(in) :: e_corr_dets(ndet) - double precision, intent(out) :: dressing_dets(ndet) - integer, allocatable :: degree(:),hole(:,:),part(:,:),spin(:,:) - integer(bit_kind), allocatable :: hole_part(:,:,:) - integer :: i,j,k, exc(0:2,2,2),h1,p1,h2,p2,s1,s2 - integer(bit_kind) :: xorvec(2,N_int) - - double precision :: phase - dressing_dets = 0.d0 - allocate(degree(ndet),hole(2,ndet),part(2,ndet), spin(2,ndet),hole_part(N_int,2,ndet)) - do i = 2, ndet - call get_excitation_degree(HF_bitmask,dets(1,1,i),degree(i),N_int) - do j = 1, N_int - hole_part(j,1,i) = xor( HF_bitmask(j,1), dets(j,1,i)) - hole_part(j,2,i) = xor( HF_bitmask(j,2), dets(j,2,i)) - enddo - if(degree(i) == 1)then - call get_single_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int) - else if(degree(i) == 2)then - call get_double_excitation(HF_bitmask,psi_det(1,1,i),exc,phase,N_int) - endif - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - hole(1,i) = h1 - hole(2,i) = h2 - part(1,i) = p1 - part(2,i) = p2 - spin(1,i) = s1 - spin(2,i) = s2 - enddo - - integer :: same - if(elec_alpha_num+elec_beta_num<3)return - do i = 2, ndet - do j = i+1, ndet - same = 0 - if(degree(i) == degree(j) .and. degree(i)==1)cycle - do k = 1, N_int - xorvec(k,1) = iand(hole_part(k,1,i),hole_part(k,1,j)) - xorvec(k,2) = iand(hole_part(k,2,i),hole_part(k,2,j)) - same += popcnt(xorvec(k,1)) + popcnt(xorvec(k,2)) - enddo -! print*,'i,j',i,j -! call debug_det(dets(1,1,i),N_int) -! call debug_det(hole_part(1,1,i),N_int) -! call debug_det(dets(1,1,j),N_int) -! call debug_det(hole_part(1,1,j),N_int) -! print*,'same = ',same - if(same.eq.0)then - dressing_dets(i) += e_corr_dets(j) - dressing_dets(j) += e_corr_dets(i) - endif - enddo - enddo - -end diff --git a/plugins/local/tc_bi_ortho/test_s2_tc.irp.f b/plugins/local/tc_bi_ortho/test_s2_tc.irp.f deleted file mode 100644 index 7c70b119..00000000 --- a/plugins/local/tc_bi_ortho/test_s2_tc.irp.f +++ /dev/null @@ -1,170 +0,0 @@ - -! --- - -program test_tc - - 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 - - read_wf = .True. - touch read_wf - - call provide_all_three_ints_bi_ortho() - call routine_h_triple_left - call routine_h_triple_right -! call routine_test_s2_davidson - -end - -subroutine routine_h_triple_right - implicit none - logical :: do_right - integer :: sze ,i, N_st, j - double precision :: sij, accu_e, accu_s, accu_e_0, accu_s_0 - double precision, allocatable :: v_0_ref(:,:),u_0(:,:),s_0_ref(:,:) - double precision, allocatable :: v_0_new(:,:),s_0_new(:,:) - sze = N_det - N_st = 1 - allocate(v_0_ref(N_det,1),u_0(N_det,1),s_0_ref(N_det,1),s_0_new(N_det,1),v_0_new(N_det,1)) - print*,'Checking first the Right ' - do i = 1, sze - u_0(i,1) = psi_r_coef_bi_ortho(i,1) - enddo - double precision :: wall0,wall1 - call wall_time(wall0) - call H_tc_s2_u_0_with_pure_three_omp(v_0_ref,s_0_ref, u_0,N_st,sze) - call wall_time(wall1) - print*,'time for omp',wall1 - wall0 - call wall_time(wall0) - call H_tc_s2_u_0_with_pure_three(v_0_new, s_0_new, u_0, N_st, sze) - call wall_time(wall1) - print*,'time serial ',wall1 - wall0 - accu_e = 0.d0 - accu_s = 0.d0 - do i = 1, sze - accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1)) - accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1)) - enddo - print*,'accu_e = ',accu_e - print*,'accu_s = ',accu_s - -end - -subroutine routine_h_triple_left - implicit none - logical :: do_right - integer :: sze ,i, N_st, j - double precision :: sij, accu_e, accu_s, accu_e_0, accu_s_0 - double precision, allocatable :: v_0_ref(:,:),u_0(:,:),s_0_ref(:,:) - double precision, allocatable :: v_0_new(:,:),s_0_new(:,:) - sze = N_det - N_st = 1 - allocate(v_0_ref(N_det,1),u_0(N_det,1),s_0_ref(N_det,1),s_0_new(N_det,1),v_0_new(N_det,1)) - print*,'Checking the Left ' - do i = 1, sze - u_0(i,1) = psi_l_coef_bi_ortho(i,1) - enddo - double precision :: wall0,wall1 - call wall_time(wall0) - call H_tc_s2_dagger_u_0_with_pure_three_omp(v_0_ref,s_0_ref, u_0,N_st,sze) - call wall_time(wall1) - print*,'time for omp',wall1 - wall0 - call wall_time(wall0) - call H_tc_s2_dagger_u_0_with_pure_three(v_0_new, s_0_new, u_0, N_st, sze) - call wall_time(wall1) - print*,'time serial ',wall1 - wall0 - accu_e = 0.d0 - accu_s = 0.d0 - do i = 1, sze - accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1)) - accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1)) - enddo - print*,'accu_e = ',accu_e - print*,'accu_s = ',accu_s - -end - - -subroutine routine_test_s2_davidson - implicit none - double precision, allocatable :: H_jj(:),vec_tmp(:,:), energies(:) , s2(:) - integer :: i,istate - logical :: converged - external H_tc_s2_dagger_u_0_opt - external H_tc_s2_u_0_opt - allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),energies(n_states_diag), s2(n_states_diag)) - do i = 1, N_det - call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i)) - enddo - ! Preparing the left-eigenvector - print*,'Computing the left-eigenvector ' - vec_tmp = 0.d0 - do istate = 1, N_states - vec_tmp(1:N_det,istate) = psi_l_coef_bi_ortho(1:N_det,istate) - enddo - do istate = N_states+1, n_states_diag - vec_tmp(istate,istate) = 1.d0 - enddo - do istate = 1, N_states - leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate) - enddo - integer :: n_it_max - n_it_max = 1 - call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2, energies, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_dagger_u_0_opt) - double precision, allocatable :: v_0_new(:,:),s_0_new(:,:) - integer :: sze,N_st - logical :: do_right - sze = N_det - N_st = 1 - do_right = .False. - allocate(s_0_new(N_det,1),v_0_new(N_det,1)) - call H_tc_s2_u_0_nstates_openmp(v_0_new,s_0_new,vec_tmp,N_st,sze, do_right) - double precision :: accu_e_0, accu_s_0 - accu_e_0 = 0.d0 - accu_s_0 = 0.d0 - do i = 1, sze - accu_e_0 += v_0_new(i,1) * vec_tmp(i,1) - accu_s_0 += s_0_new(i,1) * vec_tmp(i,1) - enddo - print*,'energies = ',energies - print*,'s2 = ',s2 - print*,'accu_e_0',accu_e_0 - print*,'accu_s_0',accu_s_0 - - ! Preparing the right-eigenvector - print*,'Computing the right-eigenvector ' - vec_tmp = 0.d0 - do istate = 1, N_states - vec_tmp(1:N_det,istate) = psi_r_coef_bi_ortho(1:N_det,istate) - enddo - do istate = N_states+1, n_states_diag - vec_tmp(istate,istate) = 1.d0 - enddo - do istate = 1, N_states - leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate) - enddo - n_it_max = 1 - call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2, energies, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_u_0_opt) - sze = N_det - N_st = 1 - do_right = .True. - v_0_new = 0.d0 - s_0_new = 0.d0 - call H_tc_s2_u_0_nstates_openmp(v_0_new,s_0_new,vec_tmp,N_st,sze, do_right) - accu_e_0 = 0.d0 - accu_s_0 = 0.d0 - do i = 1, sze - accu_e_0 += v_0_new(i,1) * vec_tmp(i,1) - accu_s_0 += s_0_new(i,1) * vec_tmp(i,1) - enddo - print*,'energies = ',energies - print*,'s2 = ',s2 - print*,'accu_e_0',accu_e_0 - print*,'accu_s_0',accu_s_0 - -end From 2a8b9e544b8c9f47ce55dd8f0c4e7df5b0a67ea1 Mon Sep 17 00:00:00 2001 From: Abdallah Ammar Date: Tue, 7 May 2024 01:56:14 +0200 Subject: [PATCH 45/50] working on aos debug --- plugins/local/non_h_ints_mu/deb_aos.irp.f | 16 +- src/ao_basis/aos_in_r.irp.f | 508 ++++++++++++---------- 2 files changed, 285 insertions(+), 239 deletions(-) diff --git a/plugins/local/non_h_ints_mu/deb_aos.irp.f b/plugins/local/non_h_ints_mu/deb_aos.irp.f index c9bc9c9a..a84e1b91 100644 --- a/plugins/local/non_h_ints_mu/deb_aos.irp.f +++ b/plugins/local/non_h_ints_mu/deb_aos.irp.f @@ -31,12 +31,14 @@ subroutine print_aos() integer :: i, ipoint double precision :: r(3) double precision :: ao_val, ao_der(3), ao_lap + double precision :: mo_val, mo_der(3), mo_lap PROVIDE final_grid_points aos_in_r_array aos_grad_in_r_array aos_lapl_in_r_array + write(1000, *) n_points_final_grid do ipoint = 1, n_points_final_grid r(:) = final_grid_points(:,ipoint) - print*, r + write(1000, '(3(f15.7, 3X))') r enddo do ipoint = 1, n_points_final_grid @@ -45,7 +47,17 @@ subroutine print_aos() ao_val = aos_in_r_array (i,ipoint) ao_der(:) = aos_grad_in_r_array(i,ipoint,:) ao_lap = aos_lapl_in_r_array(1,i,ipoint) + aos_lapl_in_r_array(2,i,ipoint) + aos_lapl_in_r_array(3,i,ipoint) - write(*, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap + write(1010, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap + enddo + enddo + + do ipoint = 1, n_points_final_grid + r(:) = final_grid_points(:,ipoint) + do i = 1, mo_num + mo_val = mos_in_r_array (i,ipoint) + mo_der(:) = mos_grad_in_r_array(i,ipoint,:) + mo_lap = mos_lapl_in_r_array(i,ipoint,1) + mos_lapl_in_r_array(i,ipoint,2) + mos_lapl_in_r_array(i,ipoint,3) + write(2010, '(5(f15.7, 3X))') mo_val, mo_der, mo_lap enddo enddo diff --git a/src/ao_basis/aos_in_r.irp.f b/src/ao_basis/aos_in_r.irp.f index 1b1595a3..053c86a2 100644 --- a/src/ao_basis/aos_in_r.irp.f +++ b/src/ao_basis/aos_in_r.irp.f @@ -1,67 +1,76 @@ -double precision function ao_value(i,r) - implicit none - BEGIN_DOC -! Returns the value of the i-th ao at point $\textbf{r}$ - END_DOC - double precision, intent(in) :: r(3) - integer, intent(in) :: i - integer :: m,num_ao - double precision :: center_ao(3) - double precision :: beta - integer :: power_ao(3) - double precision :: accu,dx,dy,dz,r2 - num_ao = ao_nucl(i) - power_ao(1:3)= ao_power(i,1:3) - center_ao(1:3) = nucl_coord(num_ao,1:3) - dx = (r(1) - center_ao(1)) - dy = (r(2) - center_ao(2)) - dz = (r(3) - center_ao(3)) - r2 = dx*dx + dy*dy + dz*dz - dx = dx**power_ao(1) - dy = dy**power_ao(2) - dz = dz**power_ao(3) +! --- - accu = 0.d0 - do m=1,ao_prim_num(i) - beta = ao_expo_ordered_transp(m,i) - accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2) - enddo - ao_value = accu * dx * dy * dz +double precision function ao_value(i, r) + + BEGIN_DOC + ! Returns the value of the i-th ao at point $\textbf{r}$ + END_DOC + + implicit none + integer, intent(in) :: i + double precision, intent(in) :: r(3) + + integer :: m, num_ao + integer :: power_ao(3) + double precision :: center_ao(3) + double precision :: beta + double precision :: accu, dx, dy, dz, r2 + + num_ao = ao_nucl(i) + power_ao(1:3) = ao_power(i,1:3) + center_ao(1:3) = nucl_coord(num_ao,1:3) + dx = r(1) - center_ao(1) + dy = r(2) - center_ao(2) + dz = r(3) - center_ao(3) + r2 = dx*dx + dy*dy + dz*dz + dx = dx**power_ao(1) + dy = dy**power_ao(2) + dz = dz**power_ao(3) + + accu = 0.d0 + do m = 1, ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2) + enddo + ao_value = accu * dx * dy * dz end -double precision function primitive_value(i,j,r) - implicit none - BEGIN_DOC -! Returns the value of the j-th primitive of the i-th |AO| at point $\textbf{r} -! **without the coefficient** - END_DOC - double precision, intent(in) :: r(3) - integer, intent(in) :: i,j +double precision function primitive_value(i, j, r) - integer :: m,num_ao - double precision :: center_ao(3) - double precision :: beta - integer :: power_ao(3) - double precision :: accu,dx,dy,dz,r2 - num_ao = ao_nucl(i) - power_ao(1:3)= ao_power(i,1:3) - center_ao(1:3) = nucl_coord(num_ao,1:3) - dx = (r(1) - center_ao(1)) - dy = (r(2) - center_ao(2)) - dz = (r(3) - center_ao(3)) - r2 = dx*dx + dy*dy + dz*dz - dx = dx**power_ao(1) - dy = dy**power_ao(2) - dz = dz**power_ao(3) + BEGIN_DOC + ! Returns the value of the j-th primitive of the i-th |AO| at point $\textbf{r} + ! **without the coefficient** + END_DOC - accu = 0.d0 - m=j - beta = ao_expo_ordered_transp(m,i) - accu += dexp(-beta*r2) - primitive_value = accu * dx * dy * dz + implicit none + integer, intent(in) :: i, j + double precision, intent(in) :: r(3) + + integer :: m, num_ao + integer :: power_ao(3) + double precision :: center_ao(3) + double precision :: beta + double precision :: accu, dx, dy, dz, r2 + + num_ao = ao_nucl(i) + power_ao(1:3)= ao_power(i,1:3) + center_ao(1:3) = nucl_coord(num_ao,1:3) + dx = r(1) - center_ao(1) + dy = r(2) - center_ao(2) + dz = r(3) - center_ao(3) + r2 = dx*dx + dy*dy + dz*dz + dx = dx**power_ao(1) + dy = dy**power_ao(2) + dz = dz**power_ao(3) + + accu = 0.d0 + m = j + beta = ao_expo_ordered_transp(m,i) + accu += dexp(-beta*r2) + primitive_value = accu * dx * dy * dz end @@ -104,9 +113,9 @@ subroutine give_all_aos_at_r(r, tmp_array) dz2 = dz**p_ao(3) tmp_array(k) = 0.d0 - do l = 1,ao_prim_num(k) + do l = 1, ao_prim_num(k) beta = ao_expo_ordered_transp_per_nucl(l,j,i) - if(dabs(beta*r2).gt.40.d0) cycle + if(beta*r2.gt.50.d0) cycle tmp_array(k) += ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2) enddo @@ -120,207 +129,232 @@ end ! --- -subroutine give_all_aos_and_grad_at_r(r,aos_array,aos_grad_array) - implicit none - BEGIN_DOC -! input : r(1) ==> r(1) = x, r(2) = y, r(3) = z -! -! output : -! -! * aos_array(i) = ao(i) evaluated at ro -! * aos_grad_array(1,i) = gradient X of the ao(i) evaluated at $\textbf{r}$ -! - END_DOC - double precision, intent(in) :: r(3) - double precision, intent(out) :: aos_array(ao_num) - double precision, intent(out) :: aos_grad_array(3,ao_num) +subroutine give_all_aos_and_grad_at_r(r, aos_array, aos_grad_array) - integer :: power_ao(3) - integer :: i,j,k,l,m - double precision :: dx,dy,dz,r2 - double precision :: dx2,dy2,dz2 - double precision :: dx1,dy1,dz1 - double precision :: center_ao(3) - double precision :: beta,accu_1,accu_2,contrib - do i = 1, nucl_num - center_ao(1:3) = nucl_coord(i,1:3) - dx = (r(1) - center_ao(1)) - dy = (r(2) - center_ao(2)) - dz = (r(3) - center_ao(3)) - r2 = dx*dx + dy*dy + dz*dz - do j = 1,Nucl_N_Aos(i) - k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format - aos_array(k) = 0.d0 - aos_grad_array(1,k) = 0.d0 - aos_grad_array(2,k) = 0.d0 - aos_grad_array(3,k) = 0.d0 - power_ao(1:3)= ao_power_ordered_transp_per_nucl(1:3,j,i) - dx2 = dx**power_ao(1) - dy2 = dy**power_ao(2) - dz2 = dz**power_ao(3) - if(power_ao(1) .ne. 0)then - dx1 = dble(power_ao(1)) * dx**(power_ao(1)-1) - else - dx1 = 0.d0 - endif - if(power_ao(2) .ne. 0)then - dy1 = dble(power_ao(2)) * dy**(power_ao(2)-1) - else - dy1 = 0.d0 - endif - if(power_ao(3) .ne. 0)then - dz1 = dble(power_ao(3)) * dz**(power_ao(3)-1) - else - dz1 = 0.d0 - endif - accu_1 = 0.d0 - accu_2 = 0.d0 - do l = 1,ao_prim_num(k) - beta = ao_expo_ordered_transp_per_nucl(l,j,i) - contrib = 0.d0 - if(beta*r2.gt.50.d0)cycle - contrib = ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2) - accu_1 += contrib - accu_2 += contrib * beta - enddo - aos_array(k) = accu_1 * dx2 * dy2 * dz2 - aos_grad_array(1,k) = accu_1 * dx1 * dy2 * dz2- 2.d0 * dx2 * dx * dy2 * dz2 * accu_2 - aos_grad_array(2,k) = accu_1 * dx2 * dy1 * dz2- 2.d0 * dx2 * dy2 * dy * dz2 * accu_2 - aos_grad_array(3,k) = accu_1 * dx2 * dy2 * dz1- 2.d0 * dx2 * dy2 * dz2 * dz * accu_2 + BEGIN_DOC + ! + ! input : r(1) ==> r(1) = x, r(2) = y, r(3) = z + ! + ! output : + ! + ! * aos_array(i) = ao(i) evaluated at ro + ! * aos_grad_array(1,i) = gradient X of the ao(i) evaluated at $\textbf{r}$ + ! + END_DOC + + implicit none + double precision, intent(in) :: r(3) + double precision, intent(out) :: aos_array(ao_num) + double precision, intent(out) :: aos_grad_array(3,ao_num) + + integer :: power_ao(3) + integer :: i, j, k, l, m + double precision :: dx, dy, dz, r2 + double precision :: dx1, dy1, dz1 + double precision :: dx2, dy2, dz2 + double precision :: center_ao(3) + double precision :: beta, accu_1, accu_2, contrib + + do i = 1, nucl_num + + center_ao(1:3) = nucl_coord(i,1:3) + + dx = r(1) - center_ao(1) + dy = r(2) - center_ao(2) + dz = r(3) - center_ao(3) + r2 = dx*dx + dy*dy + dz*dz + + do j = 1, Nucl_N_Aos(i) + + k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format + + aos_array(k) = 0.d0 + aos_grad_array(1,k) = 0.d0 + aos_grad_array(2,k) = 0.d0 + aos_grad_array(3,k) = 0.d0 + + power_ao(1:3) = ao_power_ordered_transp_per_nucl(1:3,j,i) + dx2 = dx**power_ao(1) + dy2 = dy**power_ao(2) + dz2 = dz**power_ao(3) + + dx1 = 0.d0 + if(power_ao(1) .ne. 0) then + dx1 = dble(power_ao(1)) * dx**(power_ao(1)-1) + endif + + dy1 = 0.d0 + if(power_ao(2) .ne. 0) then + dy1 = dble(power_ao(2)) * dy**(power_ao(2)-1) + endif + + dz1 = 0.d0 + if(power_ao(3) .ne. 0) then + dz1 = dble(power_ao(3)) * dz**(power_ao(3)-1) + endif + + accu_1 = 0.d0 + accu_2 = 0.d0 + do l = 1, ao_prim_num(k) + beta = ao_expo_ordered_transp_per_nucl(l,j,i) + if(beta*r2.gt.50.d0) cycle + contrib = ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2) + accu_1 += contrib + accu_2 += contrib * beta + enddo + + aos_array(k) = accu_1 * dx2 * dy2 * dz2 + aos_grad_array(1,k) = accu_1 * dx1 * dy2 * dz2 - 2.d0 * dx2 * dx * dy2 * dz2 * accu_2 + aos_grad_array(2,k) = accu_1 * dx2 * dy1 * dz2 - 2.d0 * dx2 * dy2 * dy * dz2 * accu_2 + aos_grad_array(3,k) = accu_1 * dx2 * dy2 * dz1 - 2.d0 * dx2 * dy2 * dz2 * dz * accu_2 + enddo enddo - enddo + end +! --- -subroutine give_all_aos_and_grad_and_lapl_at_r(r,aos_array,aos_grad_array,aos_lapl_array) - implicit none - BEGIN_DOC -! input : r(1) ==> r(1) = x, r(2) = y, r(3) = z -! -! output : -! -! * aos_array(i) = ao(i) evaluated at $\textbf{r}$ -! * aos_grad_array(1,i) = $\nabla_x$ of the ao(i) evaluated at $\textbf{r}$ - END_DOC - double precision, intent(in) :: r(3) - double precision, intent(out) :: aos_array(ao_num) - double precision, intent(out) :: aos_grad_array(3,ao_num) - double precision, intent(out) :: aos_lapl_array(3,ao_num) +subroutine give_all_aos_and_grad_and_lapl_at_r(r, aos_array, aos_grad_array, aos_lapl_array) - integer :: power_ao(3) - integer :: i,j,k,l,m - double precision :: dx,dy,dz,r2 - double precision :: dx2,dy2,dz2 - double precision :: dx1,dy1,dz1 - double precision :: dx3,dy3,dz3 - double precision :: dx4,dy4,dz4 - double precision :: dx5,dy5,dz5 - double precision :: center_ao(3) - double precision :: beta,accu_1,accu_2,accu_3,contrib - do i = 1, nucl_num - center_ao(1:3) = nucl_coord(i,1:3) - dx = (r(1) - center_ao(1)) - dy = (r(2) - center_ao(2)) - dz = (r(3) - center_ao(3)) - r2 = dx*dx + dy*dy + dz*dz - do j = 1,Nucl_N_Aos(i) - k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format - aos_array(k) = 0.d0 - aos_grad_array(1,k) = 0.d0 - aos_grad_array(2,k) = 0.d0 - aos_grad_array(3,k) = 0.d0 + BEGIN_DOC + ! + ! input : r(1) ==> r(1) = x, r(2) = y, r(3) = z + ! + ! output : + ! + ! * aos_array(i) = ao(i) evaluated at $\textbf{r}$ + ! * aos_grad_array(1,i) = $\nabla_x$ of the ao(i) evaluated at $\textbf{r}$ + ! + END_DOC - aos_lapl_array(1,k) = 0.d0 - aos_lapl_array(2,k) = 0.d0 - aos_lapl_array(3,k) = 0.d0 + implicit none + double precision, intent(in) :: r(3) + double precision, intent(out) :: aos_array(ao_num) + double precision, intent(out) :: aos_grad_array(3,ao_num) + double precision, intent(out) :: aos_lapl_array(3,ao_num) - power_ao(1:3)= ao_power_ordered_transp_per_nucl(1:3,j,i) - dx2 = dx**power_ao(1) - dy2 = dy**power_ao(2) - dz2 = dz**power_ao(3) - if(power_ao(1) .ne. 0)then - dx1 = dble(power_ao(1)) * dx**(power_ao(1)-1) - else - dx1 = 0.d0 - endif - ! For the Laplacian - if(power_ao(1) .ge. 2)then - dx3 = dble(power_ao(1)) * dble((power_ao(1)-1)) * dx**(power_ao(1)-2) - else - dx3 = 0.d0 - endif - if(power_ao(1) .ge. 1)then - dx4 = dble((2 * power_ao(1) + 1)) * dx**(power_ao(1)) - else - dx4 = dble((power_ao(1) + 1)) * dx**(power_ao(1)) - endif + integer :: power_ao(3) + integer :: i, j, k, l, m + double precision :: dx, dy, dz, r2 + double precision :: dx1, dy1, dz1 + double precision :: dx2, dy2, dz2 + double precision :: dx3, dy3, dz3 + double precision :: dx4, dy4, dz4 + double precision :: dx5, dy5, dz5 + double precision :: center_ao(3) + double precision :: beta, accu_1, accu_2, accu_3, contrib - dx5 = dx**(power_ao(1)+2) + do i = 1, nucl_num - if(power_ao(2) .ne. 0)then - dy1 = dble(power_ao(2)) * dy**(power_ao(2)-1) - else - dy1 = 0.d0 - endif - ! For the Laplacian - if(power_ao(2) .ge. 2)then - dy3 = dble(power_ao(2)) * dble((power_ao(2)-1)) * dy**(power_ao(2)-2) - else - dy3 = 0.d0 - endif + center_ao(1:3) = nucl_coord(i,1:3) - if(power_ao(2) .ge. 1)then - dy4 = dble((2 * power_ao(2) + 1)) * dy**(power_ao(2)) - else - dy4 = dble((power_ao(2) + 1)) * dy**(power_ao(2)) - endif + dx = r(1) - center_ao(1) + dy = r(2) - center_ao(2) + dz = r(3) - center_ao(3) + r2 = dx*dx + dy*dy + dz*dz + + do j = 1, Nucl_N_Aos(i) - dy5 = dy**(power_ao(2)+2) + k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format + aos_array(k) = 0.d0 + aos_grad_array(1,k) = 0.d0 + aos_grad_array(2,k) = 0.d0 + aos_grad_array(3,k) = 0.d0 + aos_lapl_array(1,k) = 0.d0 + aos_lapl_array(2,k) = 0.d0 + aos_lapl_array(3,k) = 0.d0 + + power_ao(1:3)= ao_power_ordered_transp_per_nucl(1:3,j,i) + dx2 = dx**power_ao(1) + dy2 = dy**power_ao(2) + dz2 = dz**power_ao(3) - if(power_ao(3) .ne. 0)then - dz1 = dble(power_ao(3)) * dz**(power_ao(3)-1) - else - dz1 = 0.d0 - endif - ! For the Laplacian - if(power_ao(3) .ge. 2)then - dz3 = dble(power_ao(3)) * dble((power_ao(3)-1)) * dz**(power_ao(3)-2) - else - dz3 = 0.d0 - endif + ! --- - if(power_ao(3) .ge. 1)then - dz4 = dble((2 * power_ao(3) + 1)) * dz**(power_ao(3)) - else - dz4 = dble((power_ao(3) + 1)) * dz**(power_ao(3)) - endif + dx1 = 0.d0 + if(power_ao(1) .ne. 0) then + dx1 = dble(power_ao(1)) * dx**(power_ao(1)-1) + endif - dz5 = dz**(power_ao(3)+2) + dx3 = 0.d0 + if(power_ao(1) .ge. 2) then + dx3 = dble(power_ao(1)) * dble((power_ao(1)-1)) * dx**(power_ao(1)-2) + endif + if(power_ao(1) .ge. 1) then + dx4 = dble((2 * power_ao(1) + 1)) * dx**(power_ao(1)) + else + dx4 = dble((power_ao(1) + 1)) * dx**(power_ao(1)) + endif + + dx5 = dx**(power_ao(1)+2) + + ! --- + + dy1 = 0.d0 + if(power_ao(2) .ne. 0) then + dy1 = dble(power_ao(2)) * dy**(power_ao(2)-1) + endif - accu_1 = 0.d0 - accu_2 = 0.d0 - accu_3 = 0.d0 - do l = 1,ao_prim_num(k) - beta = ao_expo_ordered_transp_per_nucl(l,j,i) - contrib = ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2) - accu_1 += contrib - accu_2 += contrib * beta - accu_3 += contrib * beta**2 - enddo - aos_array(k) = accu_1 * dx2 * dy2 * dz2 + dy3 = 0.d0 + if(power_ao(2) .ge. 2) then + dy3 = dble(power_ao(2)) * dble((power_ao(2)-1)) * dy**(power_ao(2)-2) + endif + + if(power_ao(2) .ge. 1) then + dy4 = dble((2 * power_ao(2) + 1)) * dy**(power_ao(2)) + else + dy4 = dble((power_ao(2) + 1)) * dy**(power_ao(2)) + endif + + dy5 = dy**(power_ao(2)+2) - aos_grad_array(1,k) = accu_1 * dx1 * dy2 * dz2- 2.d0 * dx2 * dx * dy2 * dz2 * accu_2 - aos_grad_array(2,k) = accu_1 * dx2 * dy1 * dz2- 2.d0 * dx2 * dy2 * dy * dz2 * accu_2 - aos_grad_array(3,k) = accu_1 * dx2 * dy2 * dz1- 2.d0 * dx2 * dy2 * dz2 * dz * accu_2 + ! --- + + dz1 = 0.d0 + if(power_ao(3) .ne. 0) then + dz1 = dble(power_ao(3)) * dz**(power_ao(3)-1) + endif - aos_lapl_array(1,k) = accu_1 * dx3 * dy2 * dz2- 2.d0 * dx4 * dy2 * dz2* accu_2 +4.d0 * dx5 *dy2 * dz2* accu_3 - aos_lapl_array(2,k) = accu_1 * dx2 * dy3 * dz2- 2.d0 * dx2 * dy4 * dz2* accu_2 +4.d0 * dx2 *dy5 * dz2* accu_3 - aos_lapl_array(3,k) = accu_1 * dx2 * dy2 * dz3- 2.d0 * dx2 * dy2 * dz4* accu_2 +4.d0 * dx2 *dy2 * dz5* accu_3 + dz3 = 0.d0 + if(power_ao(3) .ge. 2) then + dz3 = dble(power_ao(3)) * dble((power_ao(3)-1)) * dz**(power_ao(3)-2) + endif + + if(power_ao(3) .ge. 1) then + dz4 = dble((2 * power_ao(3) + 1)) * dz**(power_ao(3)) + else + dz4 = dble((power_ao(3) + 1)) * dz**(power_ao(3)) + endif + + dz5 = dz**(power_ao(3)+2) + + ! --- + + accu_1 = 0.d0 + accu_2 = 0.d0 + accu_3 = 0.d0 + do l = 1,ao_prim_num(k) + beta = ao_expo_ordered_transp_per_nucl(l,j,i) + if(beta*r2.gt.50.d0) cycle + contrib = ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2) + accu_1 += contrib + accu_2 += contrib * beta + accu_3 += contrib * beta**2 + enddo + aos_array(k) = accu_1 * dx2 * dy2 * dz2 + aos_grad_array(1,k) = accu_1 * dx1 * dy2 * dz2 - 2.d0 * dx2 * dx * dy2 * dz2 * accu_2 + aos_grad_array(2,k) = accu_1 * dx2 * dy1 * dz2 - 2.d0 * dx2 * dy2 * dy * dz2 * accu_2 + aos_grad_array(3,k) = accu_1 * dx2 * dy2 * dz1 - 2.d0 * dx2 * dy2 * dz2 * dz * accu_2 + aos_lapl_array(1,k) = accu_1 * dx3 * dy2 * dz2 - 2.d0 * dx4 * dy2 * dz2 * accu_2 + 4.d0 * dx5 * dy2 * dz2 * accu_3 + aos_lapl_array(2,k) = accu_1 * dx2 * dy3 * dz2 - 2.d0 * dx2 * dy4 * dz2 * accu_2 + 4.d0 * dx2 * dy5 * dz2 * accu_3 + aos_lapl_array(3,k) = accu_1 * dx2 * dy2 * dz3 - 2.d0 * dx2 * dy2 * dz4 * accu_2 + 4.d0 * dx2 * dy2 * dz5 * accu_3 + enddo enddo - enddo + end +! --- From 17ae4d8fe2f103bac46205380ae0e6a33736de71 Mon Sep 17 00:00:00 2001 From: eginer Date: Tue, 7 May 2024 18:27:09 +0200 Subject: [PATCH 46/50] added tc_progs --- .../local/cipsi_tc_bi_ortho/selection.irp.f | 4 +- ..._bi_ortho.irp.f => diagonalize_tc_h.irp.f} | 0 plugins/local/tc_bi_ortho/test_natorb.irp.f | 64 ------- .../local/tc_bi_ortho/test_normal_order.irp.f | 173 ------------------ plugins/local/tc_bi_ortho/test_tc_fock.irp.f | 171 ----------------- plugins/local/tc_progs/NEED | 1 + .../print_he_tc_energy.irp.f | 0 .../print_tc_dump.irp.f | 0 .../print_tc_energy.irp.f | 0 .../print_tc_spin_dens.irp.f | 0 .../print_tc_var.irp.f | 0 .../print_tc_wf.irp.f | 0 .../save_bitcpsileft_for_qmcchem.irp.f | 0 .../save_tc_bi_ortho_nat.irp.f | 0 .../select_dets_bi_ortho.irp.f | 0 .../tc_bi_ortho_prop.irp.f | 0 .../{tc_bi_ortho => tc_progs}/tc_som.irp.f | 0 .../test_tc_two_rdm.irp.f | 0 18 files changed, 3 insertions(+), 410 deletions(-) rename plugins/local/tc_bi_ortho/{tc_bi_ortho.irp.f => diagonalize_tc_h.irp.f} (100%) delete mode 100644 plugins/local/tc_bi_ortho/test_natorb.irp.f delete mode 100644 plugins/local/tc_bi_ortho/test_normal_order.irp.f delete mode 100644 plugins/local/tc_bi_ortho/test_tc_fock.irp.f create mode 100644 plugins/local/tc_progs/NEED rename plugins/local/{tc_bi_ortho => tc_progs}/print_he_tc_energy.irp.f (100%) rename plugins/local/{tc_bi_ortho => tc_progs}/print_tc_dump.irp.f (100%) rename plugins/local/{tc_bi_ortho => tc_progs}/print_tc_energy.irp.f (100%) rename plugins/local/{tc_bi_ortho => tc_progs}/print_tc_spin_dens.irp.f (100%) rename plugins/local/{tc_bi_ortho => tc_progs}/print_tc_var.irp.f (100%) rename plugins/local/{tc_bi_ortho => tc_progs}/print_tc_wf.irp.f (100%) rename plugins/local/{tc_bi_ortho => tc_progs}/save_bitcpsileft_for_qmcchem.irp.f (100%) rename plugins/local/{tc_bi_ortho => tc_progs}/save_tc_bi_ortho_nat.irp.f (100%) rename plugins/local/{tc_bi_ortho => tc_progs}/select_dets_bi_ortho.irp.f (100%) rename plugins/local/{tc_bi_ortho => tc_progs}/tc_bi_ortho_prop.irp.f (100%) rename plugins/local/{tc_bi_ortho => tc_progs}/tc_som.irp.f (100%) rename plugins/local/{tc_bi_ortho => tc_progs}/test_tc_two_rdm.irp.f (100%) diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f index 12163e06..0b4345d5 100644 --- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f +++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f @@ -892,8 +892,8 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d psi_h_alpha = 0.d0 alpha_h_psi = 0.d0 do iii = 1, N_det_selectors - call htilde_mu_mat_bi_ortho_tot_slow(psi_selectors(1,1,iii), det, N_int, i_h_alpha) - call htilde_mu_mat_bi_ortho_tot_slow(det, psi_selectors(1,1,iii), N_int, alpha_h_i) + call htilde_mu_mat_opt_bi_ortho_tot(psi_selectors(1,1,iii), det, N_int, i_h_alpha) + call htilde_mu_mat_opt_bi_ortho_tot(det, psi_selectors(1,1,iii), N_int, alpha_h_i) call get_excitation_degree(psi_selectors(1,1,iii), det,degree,N_int) if(degree == 0)then print*,'problem !!!' diff --git a/plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/diagonalize_tc_h.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f rename to plugins/local/tc_bi_ortho/diagonalize_tc_h.irp.f diff --git a/plugins/local/tc_bi_ortho/test_natorb.irp.f b/plugins/local/tc_bi_ortho/test_natorb.irp.f deleted file mode 100644 index 5b8801f7..00000000 --- a/plugins/local/tc_bi_ortho/test_natorb.irp.f +++ /dev/null @@ -1,64 +0,0 @@ - -! --- - -program test_natorb - - BEGIN_DOC - ! TODO : Reads psi_det in the EZFIO folder and prints out the left- and right-eigenvectors together with the energy. Saves the left-right wave functions at the end. - 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 - - read_wf = .True. - touch read_wf - - call routine() - ! call test() - -end - -! --- - -subroutine routine() - - implicit none - double precision, allocatable :: fock_diag(:),eigval(:),leigvec(:,:),reigvec(:,:),mat_ref(:,:) - allocate(eigval(mo_num),leigvec(mo_num,mo_num),reigvec(mo_num,mo_num),fock_diag(mo_num),mat_ref(mo_num, mo_num)) - double precision, allocatable :: eigval_ref(:),leigvec_ref(:,:),reigvec_ref(:,:) - allocate(eigval_ref(mo_num),leigvec_ref(mo_num,mo_num),reigvec_ref(mo_num,mo_num)) - - double precision :: thr_deg - integer :: i,n_real,j - print*,'fock_matrix' - do i = 1, mo_num - fock_diag(i) = Fock_matrix_mo(i,i) - print*,i,fock_diag(i) - enddo - thr_deg = 1.d-6 - mat_ref = -one_e_dm_mo - print*,'diagonalization by block' - call diag_mat_per_fock_degen(fock_diag,mat_ref,mo_num,thr_deg,leigvec,reigvec,eigval) - call non_hrmt_bieig( mo_num, mat_ref& - , leigvec_ref, reigvec_ref& - , n_real, eigval_ref) - print*,'TEST ***********************************' - double precision :: accu_l, accu_r - do i = 1, mo_num - accu_l = 0.d0 - accu_r = 0.d0 - do j = 1, mo_num - accu_r += reigvec_ref(j,i) * reigvec(j,i) - accu_l += leigvec_ref(j,i) * leigvec(j,i) - enddo - print*,i - write(*,'(I3,X,100(F16.10,X))')i,eigval(i),eigval_ref(i),accu_l,accu_r - enddo -end diff --git a/plugins/local/tc_bi_ortho/test_normal_order.irp.f b/plugins/local/tc_bi_ortho/test_normal_order.irp.f deleted file mode 100644 index 7b4c558f..00000000 --- a/plugins/local/tc_bi_ortho/test_normal_order.irp.f +++ /dev/null @@ -1,173 +0,0 @@ - -! --- - -program test_normal_order - - 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 - - read_wf = .True. - touch read_wf - - call provide_all_three_ints_bi_ortho() - call test() - -end - -! --- - -subroutine test - implicit none - use bitmasks ! you need to include the bitmasks_module.f90 features - integer :: h1,h2,p1,p2,s1,s2,i_ok,degree,Ne(2) - integer :: exc(0:2,2,2) - integer(bit_kind), allocatable :: det_i(:,:) - double precision :: hmono,htwoe,hthree,htilde_ij,accu,phase,normal,hthree_tmp - integer, allocatable :: occ(:,:) - allocate( occ(N_int*bit_kind_size,2) ) - call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int) - allocate(det_i(N_int,2)) - s1 = 1 - s2 = 2 - accu = 0.d0 - do h1 = 1, elec_beta_num - do p1 = elec_alpha_num+1, mo_num - do h2 = 1, elec_beta_num - do p2 = elec_beta_num+1, mo_num - hthree = 0.d0 - - det_i = ref_bitmask - s1 = 1 - s2 = 2 - call do_single_excitation(det_i,h1,p1,s1,i_ok) - if(i_ok.ne.1)cycle - call do_single_excitation(det_i,h2,p2,s2,i_ok) - if(i_ok.ne.1)cycle - call htilde_mu_mat_opt_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij) - call get_excitation_degree(ref_bitmask,det_i,degree,N_int) - call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) - hthree_tmp *= phase - hthree += 0.5d0 * hthree_tmp - det_i = ref_bitmask - s1 = 2 - s2 = 1 - call do_single_excitation(det_i,h1,p1,s1,i_ok) - if(i_ok.ne.1)cycle - call do_single_excitation(det_i,h2,p2,s2,i_ok) - if(i_ok.ne.1)cycle - call htilde_mu_mat_opt_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij) - call get_excitation_degree(ref_bitmask,det_i,degree,N_int) - call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) - hthree_tmp *= phase - hthree += 0.5d0 * hthree_tmp - - -! normal = normal_two_body_bi_orth_ab(p2,h2,p1,h1) - call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, normal) - if(dabs(hthree).lt.1.d-10)cycle - if(dabs(hthree-normal).gt.1.d-10)then -! print*,pp2,pp1,hh2,hh1 - print*,p2,p1,h2,h1 - print*,hthree,normal,dabs(hthree-normal) - stop - endif -! call three_comp_two_e_elem(det_i,h1,h2,p1,p2,s1,s2,normal) -! normal = eff_2_e_from_3_e_ab(p2,p1,h2,h1) - accu += dabs(hthree-normal) - enddo - enddo - enddo - enddo -print*,'accu opposite spin = ',accu -stop - -! p2=6 -! p1=5 -! h2=2 -! h1=1 - -s1 = 1 -s2 = 1 -accu = 0.d0 -do h1 = 1, elec_alpha_num - do p1 = elec_alpha_num+1, mo_num - do p2 = p1+1, mo_num - do h2 = h1+1, elec_alpha_num - det_i = ref_bitmask - call do_single_excitation(det_i,h1,p1,s1,i_ok) - if(i_ok.ne.1)cycle - call do_single_excitation(det_i,h2,p2,s2,i_ok) - if(i_ok.ne.1)cycle - call htilde_mu_mat_opt_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) - call get_excitation_degree(ref_bitmask,det_i,degree,N_int) - call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) - integer :: hh1, pp1, hh2, pp2, ss1, ss2 - call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2) - hthree *= phase - normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1) -! normal = eff_2_e_from_3_e_aa(p2,p1,h2,h1) - if(dabs(hthree).lt.1.d-10)cycle - if(dabs(hthree-normal).gt.1.d-10)then - print*,pp2,pp1,hh2,hh1 - print*,p2,p1,h2,h1 - print*,hthree,normal,dabs(hthree-normal) - stop - endif -! print*,hthree,normal,dabs(hthree-normal) - accu += dabs(hthree-normal) - enddo - enddo - enddo -enddo -print*,'accu same spin alpha = ',accu - - -s1 = 2 -s2 = 2 -accu = 0.d0 -do h1 = 1, elec_beta_num - do p1 = elec_beta_num+1, mo_num - do p2 = p1+1, mo_num - do h2 = h1+1, elec_beta_num - det_i = ref_bitmask - call do_single_excitation(det_i,h1,p1,s1,i_ok) - if(i_ok.ne.1)cycle - call do_single_excitation(det_i,h2,p2,s2,i_ok) - if(i_ok.ne.1)cycle - call htilde_mu_mat_opt_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij) - call get_excitation_degree(ref_bitmask,det_i,degree,N_int) - call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int) - call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2) - hthree *= phase -! normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1) - normal = eff_2_e_from_3_e_bb(p2,p1,h2,h1) - if(dabs(hthree).lt.1.d-10)cycle - if(dabs(hthree-normal).gt.1.d-10)then - print*,pp2,pp1,hh2,hh1 - print*,p2,p1,h2,h1 - print*,hthree,normal,dabs(hthree-normal) - stop - endif -! print*,hthree,normal,dabs(hthree-normal) - accu += dabs(hthree-normal) - enddo - enddo - enddo -enddo -print*,'accu same spin beta = ',accu - - -end - - diff --git a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f b/plugins/local/tc_bi_ortho/test_tc_fock.irp.f deleted file mode 100644 index b33b2e93..00000000 --- a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f +++ /dev/null @@ -1,171 +0,0 @@ - -! --- - -program test_tc_fock - - 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 - - read_wf = .True. - touch read_wf - - !call routine_1 - !call routine_2 -! call routine_3() - - call routine_tot - -end - -! --- - -subroutine routine_3() - - use bitmasks ! you need to include the bitmasks_module.f90 features - - implicit none - integer :: i, a, i_ok, s1 - double precision :: hmono, htwoe, hthree, htilde_ij - double precision :: err_ai, err_tot, ref, new - integer(bit_kind), allocatable :: det_i(:,:) - - allocate(det_i(N_int,2)) - - err_tot = 0.d0 - - do s1 = 1, 2 - - det_i = ref_bitmask - call debug_det(det_i, N_int) - print*, ' HF det' - call debug_det(det_i, N_int) - - 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 - print*, 'PB !!' - print*, i, a - stop - endif - print*, ' excited det' - call debug_det(det_i, N_int) - - call htilde_mu_mat_opt_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij) - if(dabs(hthree).lt.1.d-10)cycle - ref = hthree - if(s1 == 1)then - new = fock_a_tot_3e_bi_orth(a,i) - else if(s1 == 2)then - new = fock_b_tot_3e_bi_orth(a,i) - endif - err_ai = dabs(dabs(ref) - dabs(new)) - if(err_ai .gt. 1d-7) then - print*,'s1 = ',s1 - print*, ' warning on', i, a - print*, ref,new,err_ai - endif - print*, ref,new,err_ai - err_tot += err_ai - - write(22, *) htilde_ij - enddo - enddo - enddo - - print *, ' err_tot = ', err_tot - - deallocate(det_i) - -end subroutine routine_3 - -! --- -subroutine routine_tot() - - use bitmasks ! you need to include the bitmasks_module.f90 features - - implicit none - integer :: i, a, i_ok, s1,other_spin(2) - double precision :: hmono, htwoe, hthree, htilde_ij - double precision :: err_ai, err_tot, ref, new - integer(bit_kind), allocatable :: det_i(:,:) - - allocate(det_i(N_int,2)) - other_spin(1) = 2 - other_spin(2) = 1 - - err_tot = 0.d0 - -! do s1 = 1, 2 - s1 = 2 - det_i = ref_bitmask - call debug_det(det_i, N_int) - print*, ' HF det' - call debug_det(det_i, N_int) - -! do i = 1, elec_num_tab(s1) -! do a = elec_num_tab(s1)+1, mo_num ! virtual - do i = 1, elec_beta_num - do a = elec_beta_num+1, mo_num! virtual - print*,i,a - - det_i = ref_bitmask - call do_single_excitation(det_i, i, a, s1, i_ok) - if(i_ok == -1) then - print*, 'PB !!' - print*, i, a - stop - endif - - call htilde_mu_mat_opt_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij) - print*,htilde_ij -! if(dabs(htilde_ij).lt.1.d-10)cycle - print*, ' excited det' - call debug_det(det_i, N_int) - - if(s1 == 1)then - new = Fock_matrix_tc_mo_alpha(a,i) - else - new = Fock_matrix_tc_mo_beta(a,i) - endif - ref = htilde_ij -! if(s1 == 1)then -! new = fock_a_tot_3e_bi_orth(a,i) -! else if(s1 == 2)then -! new = fock_b_tot_3e_bi_orth(a,i) -! endif - err_ai = dabs(dabs(ref) - dabs(new)) - if(err_ai .gt. 1d-7) then - print*,'---------' - print*,'s1 = ',s1 - print*, ' warning on', i, a - print*, ref,new,err_ai - print*,hmono, htwoe, hthree - print*,'---------' - endif - print*, ref,new,err_ai - err_tot += err_ai - - write(22, *) htilde_ij - enddo - enddo -! enddo - - print *, ' err_tot = ', err_tot - - deallocate(det_i) - -end subroutine routine_3 diff --git a/plugins/local/tc_progs/NEED b/plugins/local/tc_progs/NEED new file mode 100644 index 00000000..9deb3db4 --- /dev/null +++ b/plugins/local/tc_progs/NEED @@ -0,0 +1 @@ +tc_bi_ortho diff --git a/plugins/local/tc_bi_ortho/print_he_tc_energy.irp.f b/plugins/local/tc_progs/print_he_tc_energy.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/print_he_tc_energy.irp.f rename to plugins/local/tc_progs/print_he_tc_energy.irp.f diff --git a/plugins/local/tc_bi_ortho/print_tc_dump.irp.f b/plugins/local/tc_progs/print_tc_dump.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/print_tc_dump.irp.f rename to plugins/local/tc_progs/print_tc_dump.irp.f diff --git a/plugins/local/tc_bi_ortho/print_tc_energy.irp.f b/plugins/local/tc_progs/print_tc_energy.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/print_tc_energy.irp.f rename to plugins/local/tc_progs/print_tc_energy.irp.f diff --git a/plugins/local/tc_bi_ortho/print_tc_spin_dens.irp.f b/plugins/local/tc_progs/print_tc_spin_dens.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/print_tc_spin_dens.irp.f rename to plugins/local/tc_progs/print_tc_spin_dens.irp.f diff --git a/plugins/local/tc_bi_ortho/print_tc_var.irp.f b/plugins/local/tc_progs/print_tc_var.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/print_tc_var.irp.f rename to plugins/local/tc_progs/print_tc_var.irp.f diff --git a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f b/plugins/local/tc_progs/print_tc_wf.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/print_tc_wf.irp.f rename to plugins/local/tc_progs/print_tc_wf.irp.f diff --git a/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f b/plugins/local/tc_progs/save_bitcpsileft_for_qmcchem.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f rename to plugins/local/tc_progs/save_bitcpsileft_for_qmcchem.irp.f diff --git a/plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f b/plugins/local/tc_progs/save_tc_bi_ortho_nat.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f rename to plugins/local/tc_progs/save_tc_bi_ortho_nat.irp.f diff --git a/plugins/local/tc_bi_ortho/select_dets_bi_ortho.irp.f b/plugins/local/tc_progs/select_dets_bi_ortho.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/select_dets_bi_ortho.irp.f rename to plugins/local/tc_progs/select_dets_bi_ortho.irp.f diff --git a/plugins/local/tc_bi_ortho/tc_bi_ortho_prop.irp.f b/plugins/local/tc_progs/tc_bi_ortho_prop.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/tc_bi_ortho_prop.irp.f rename to plugins/local/tc_progs/tc_bi_ortho_prop.irp.f diff --git a/plugins/local/tc_bi_ortho/tc_som.irp.f b/plugins/local/tc_progs/tc_som.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/tc_som.irp.f rename to plugins/local/tc_progs/tc_som.irp.f diff --git a/plugins/local/tc_bi_ortho/test_tc_two_rdm.irp.f b/plugins/local/tc_progs/test_tc_two_rdm.irp.f similarity index 100% rename from plugins/local/tc_bi_ortho/test_tc_two_rdm.irp.f rename to plugins/local/tc_progs/test_tc_two_rdm.irp.f From b7787f5e6dce198bee06eb92f69b9904a7448bea Mon Sep 17 00:00:00 2001 From: eginer Date: Tue, 7 May 2024 19:43:05 +0200 Subject: [PATCH 47/50] trying to speed up the PT2 in TC by transposing the array of tc integrals --- .../local/bi_ort_ints/total_twoe_pot.irp.f | 8 +- .../cipsi_tc_bi_ortho/get_d0_transp.irp.f | 140 +++++++++++ .../local/cipsi_tc_bi_ortho/get_d2_good.irp.f | 3 - .../cipsi_tc_bi_ortho/get_d2_transp.irp.f | 235 ++++++++++++++++++ plugins/local/cipsi_tc_bi_ortho/pt2.irp.f | 1 + .../local/cipsi_tc_bi_ortho/selection.irp.f | 94 +------ .../cipsi_tc_bi_ortho/stochastic_cipsi.irp.f | 3 + plugins/local/fci_tc_bi/pt2_tc.irp.f | 2 + .../local/tc_bi_ortho/e_corr_bi_ortho.irp.f | 1 - plugins/local/tc_keywords/EZFIO.cfg | 11 +- 10 files changed, 404 insertions(+), 94 deletions(-) create mode 100644 plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f create mode 100644 plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f index 1e127fac..71269fdc 100644 --- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f +++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f @@ -259,15 +259,21 @@ BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_transp, (mo_num, mo_num, END_DOC integer :: i,j,k,l + print*,'Providing mo_bi_ortho_tc_two_e_transp' + double precision :: t0,t1 + call wall_time(t0) do i = 1, mo_num do j = 1, mo_num do k = 1, mo_num do l = 1, mo_num - mo_bi_ortho_tc_two_e_transp(i,j,k,l) = mo_bi_ortho_tc_two_e_transp(k,l,i,j) + mo_bi_ortho_tc_two_e_transp(i,j,k,l) = mo_bi_ortho_tc_two_e(k,l,i,j) enddo enddo enddo enddo + call wall_time(t1) + + print *, ' WALL TIME for PROVIDING mo_bi_ortho_tc_two_e_transp (min)', (t1-t0)/60.d0 END_PROVIDER ! --- diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f new file mode 100644 index 00000000..56238e13 --- /dev/null +++ b/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f @@ -0,0 +1,140 @@ +subroutine get_d0_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs) + !todo: indices/conjg should be okay for complex + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(bit_kind), intent(in) :: phasemask(N_int,2) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states,2) + double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num) + double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, k, s, h1, h2, p1, p2, puti, putj, mm + double precision :: phase + double precision :: hij,hji + double precision, external :: get_phase_bi + logical :: ok + + integer, parameter :: bant=1 + double precision, allocatable :: hij_cache1(:), hij_cache2(:) + allocate (hij_cache1(mo_num),hij_cache2(mo_num)) + double precision, allocatable :: hji_cache1(:), hji_cache2(:) + allocate (hji_cache1(mo_num),hji_cache2(mo_num)) +! print*,'in get_d0_new' +! call debug_det(gen,N_int) +! print*,'coefs',coefs(1,:) + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_num + if(bannedOrb(p1, 1)) cycle +! call get_mo_two_e_integrals_complex(p1,h2,h1,mo_num,hij_cache1,mo_integrals_map) + do mm = 1, mo_num + hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,p1,h2,h1) + hji_cache1(mm) = mo_bi_ortho_tc_two_e_transp(mm,p1,h2,h1) + enddo + !!!!!!!!!! + do p2=1, mo_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + ! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this +! call i_h_j_complex(det, gen, N_int, hij) + call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij) + else + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + hij = hij_cache1(p2) * phase + end if + if (hij == (0.d0,0.d0)) cycle + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,2) * hij ! HOTSPOT + enddo + end do + !!!!!!!!!! + do p2=1, mo_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + ! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this +! call i_h_j_complex(det, gen, N_int, hij) + call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji) + else + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + hji = hji_cache1(p2) * phase + end if + if (hji == (0.d0,0.d0)) cycle + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,1) * hji ! HOTSPOT + enddo + end do + end do + + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_num + if(bannedOrb(puti, sp)) cycle +! call get_mo_two_e_integrals_complex(puti,p2,p1,mo_num,hij_cache1,mo_integrals_map,mo_integrals_map_2) +! call get_mo_two_e_integrals_complex(puti,p1,p2,mo_num,hij_cache2,mo_integrals_map,mo_integrals_map_2) + do mm = 1, mo_num + hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,puti,p2,p1) + hij_cache2(mm) = mo_bi_ortho_tc_two_e(mm,puti,p1,p2) + hji_cache1(mm) = mo_bi_ortho_tc_two_e_transp(mm,puti,p2,p1) + hji_cache2(mm) = mo_bi_ortho_tc_two_e_transp(mm,puti,p1,p2) + enddo + !!!!!!!!!! + do putj=puti+1, mo_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, bant)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + !call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this +! call i_h_j_complex(det, gen, N_int, hij) + call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij) + if (hij == 0.d0) cycle + else +! hij = (mo_two_e_integral_complex(p1, p2, puti, putj) - mo_two_e_integral_complex(p2, p1, puti, putj)) +! hij = (mo_bi_ortho_tc_two_e(p1, p2, puti, putj) - mo_bi_ortho_tc_two_e(p2, p1, puti, putj)) + hij = (mo_bi_ortho_tc_two_e(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e(puti, putj, p2, p1)) + if (hij == 0.d0) cycle + hij = (hij) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int) + end if + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij + enddo + end do + + !!!!!!!!!! + do putj=puti+1, mo_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, bant)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji) + if (hji == 0.d0) cycle + else +! hji = (mo_bi_ortho_tc_two_e( p1, p2, puti, putj) - mo_bi_ortho_tc_two_e( p2, p1, puti, putj)) + hji = (mo_bi_ortho_tc_two_e_transp(puti, putj, p1, p2 ) - mo_bi_ortho_tc_two_e_transp( puti, putj, p2, p1)) + if (hji == 0.d0) cycle + hji = (hji) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int) + end if + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji + enddo + end do + end do + end if + + deallocate(hij_cache1,hij_cache2) +end + diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f index d01ed433..86922ae9 100644 --- a/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f +++ b/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f @@ -25,9 +25,6 @@ subroutine get_d2_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, integer :: bant bant = 1 -! print*, 'in get_d2_new' -! call debug_det(gen,N_int) -! print*,'coefs',coefs(1,:) tip = p(0,1) * p(0,2) ! number of alpha particles times number of beta particles diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f new file mode 100644 index 00000000..b2a7ea31 --- /dev/null +++ b/plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f @@ -0,0 +1,235 @@ + +subroutine get_d2_new_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs) + !todo: indices/conjg should be correct for complex + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(bit_kind), intent(in) :: phasemask(N_int,2) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + double precision, intent(in) :: coefs(N_states,2) + double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num) + double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi + + integer :: i, j, k, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: phase + double precision :: hij,hji + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + bant = 1 + + tip = p(0,1) * p(0,2) ! number of alpha particles times number of beta particles + + ma = sp !1:(alpha,alpha); 2:(b,b); 3:(a,b) + if(p(0,1) > p(0,2)) ma = 1 ! more alpha particles than beta particles + if(p(0,1) < p(0,2)) ma = 2 ! fewer alpha particles than beta particles + mi = mod(ma, 2) + 1 + + if(sp == 3) then ! if one alpha and one beta xhole + !(where xholes refer to the ionizations from the generator, not the holes occupied in the ionized generator) + if(ma == 2) bant = 2 ! if more beta particles than alpha particles + + if(tip == 3) then ! if 3 of one particle spin and 1 of the other particle spin + puti = p(1, mi) + if(bannedOrb(puti, mi)) return + h1 = h(1, ma) + h2 = h(2, ma) + + !! + do i = 1, 3 ! loop over all 3 combinations of 2 particles with spin ma + putj = p(i, ma) + if(banned(putj,puti,bant)) cycle + i1 = turn3(1,i) + i2 = turn3(2,i) + p1 = p(i1, ma) + p2 = p(i2, ma) + + ! |G> = |psi_{gen,i}> + ! |G'> = a_{x1} a_{x2} |G> + ! |alpha> = a_{puti}^{\dagger} a_{putj}^{\dagger} |G'> + ! |alpha> = t_{x1,x2}^{puti,putj} |G> + ! hij = + ! |alpha> = t_{p1,p2}^{h1,h2}|psi_{selectors,i}> + !todo: = ( - ) * phase + ! += dconjg(c_i) * + ! = ( - ) * phase + ! += * c_i + +!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!! + ! take the transpose of what's written above because later use the complex conjugate + +! hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e( h1, h2, p2, p1) +! hji = mo_bi_ortho_tc_two_e_transp(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e_transp( h1, h2, p2, p1) + hij = mo_bi_ortho_tc_two_e_transp(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e_transp( p1, p2, h2, h1) + hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e( p1, p2, h2, h1) + if (hij == 0.d0.or.hji==0.d0) cycle + + ! take conjugate to get contribution to instead of +! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + phase = get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + hij = hij * phase + hji = hji * phase + + if(ma == 1) then ! if particle spins are (alpha,alpha,alpha,beta), then puti is beta and putj is alpha + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,2) * hij + mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,1) * hji + enddo + else ! if particle spins are (beta,beta,beta,alpha), then puti is alpha and putj is beta + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji + enddo + end if + end do + else ! if 2 alpha and 2 beta particles + h1 = h(1,1) + h2 = h(1,2) + !! + do j = 1,2 ! loop over all 4 combinations of one alpha and one beta particle + putj = p(j, 2) + if(bannedOrb(putj, 2)) cycle + p2 = p(turn2(j), 2) + do i = 1,2 + puti = p(i, 1) + if(banned(puti,putj,bant) .or. bannedOrb(puti,1)) cycle + p1 = p(turn2(i), 1) + ! hij = +! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) +!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!! + ! take the transpose of what's written above because later use the complex conjugate +! hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2 ) +! hji = mo_bi_ortho_tc_two_e_transp(h1, h2, p1, p2 ) + hij = mo_bi_ortho_tc_two_e_transp(p1, p2 ,h1, h2 ) + hji = mo_bi_ortho_tc_two_e( p1, p2, h1, h2) + if (hij /= 0.d0.or.hji==0.d0) then + ! take conjugate to get contribution to instead of +! hij = dconjg(hij) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) + hij = hij * phase + hji = hji * phase + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji + enddo + endif + end do + end do + end if + + else ! if holes are (a,a) or (b,b) + if(tip == 0) then ! if particles are (a,a,a,a) or (b,b,b,b) + h1 = h(1, ma) + h2 = h(2, ma) + !! + do i=1,3 + puti = p(i, ma) + if(bannedOrb(puti,ma)) cycle + do j=i+1,4 + putj = p(j, ma) + if(bannedOrb(putj,ma)) cycle + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) +! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2) +!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!! + ! take the transpose of what's written above because later use the complex conjugate + hij = mo_bi_ortho_tc_two_e_transp(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e_transp(p1, p2, h2,h1 ) + hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p1, p2, h2,h1 ) + if (hij == 0.d0.or.hji == 0.d0) cycle + + ! take conjugate to get contribution to instead of +! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + phase = get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int) + hij = hij * phase + hji = hji * phase + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, putj) = mat_r(k, puti, putj) +coefs(k,2) * hij + mat_l(k, puti, putj) = mat_l(k, puti, putj) +coefs(k,1) * hji + enddo + end do + end do + else if(tip == 3) then ! if particles are (a,a,a,b) (ma=1,mi=2) or (a,b,b,b) (ma=2,mi=1) + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + !! + do i=1,3 + puti = p(turn3(1,i), ma) + if(bannedOrb(puti,ma)) cycle + putj = p(turn3(2,i), ma) + if(bannedOrb(putj,ma)) cycle + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + +! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) +!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!! + ! take the transpose of what's written above because later use the complex conjugate + hij = mo_bi_ortho_tc_two_e_transp(p1, p2 ,h1, h2) + hji = mo_bi_ortho_tc_two_e(p1, p2,h1, h2 ) + if (hij == 0.d0) cycle + + ! take conjugate to get contribution to instead of +! hij = dconjg(hij) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int) + phase = get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int) + hij = hij * phase + hji = hji * phase + if (puti < putj) then + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji + enddo + else + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,2) * hij + mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,1) * hji + enddo + endif + end do + else ! tip == 4 (a,a,b,b) + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + !! +! hij = (mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)) +!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!! + ! take the transpose of what's written above because later use the complex conjugate + hij = (mo_bi_ortho_tc_two_e_transp(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e_transp(p2,p1,h1, h2)) + hji = (mo_bi_ortho_tc_two_e(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e(p2,p1,h1, h2)) + if (hij /= 0.d0.or.hji==0.d0) then + ! take conjugate to get contribution to instead of +! hij = dconjg(hij) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int) + phase = get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int) + hij = hij * phase + hji = hji* phase + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij + mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji + enddo + end if + end if + end if + end if +end diff --git a/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f index 833cc0ea..ada19c6b 100644 --- a/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f +++ b/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f @@ -67,6 +67,7 @@ subroutine tc_pt2 call pt2_alloc(pt2_data_err, N_states) call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2) + call print_summary_tc(psi_energy_with_nucl_rep, pt2_data, pt2_data_err, N_det, N_configuration, N_states, psi_s2) end diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f index 0b4345d5..0f785ba2 100644 --- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f +++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f @@ -636,10 +636,7 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere negMask(i,2) = not(mask(i,2)) end do -! print*,'in selection ' do i = 1, N_sel -! call debug_det(det(1,1,i),N_int) -! print*,i,dabs(psi_selectors_coef_transp_tc(1,2,i) * psi_selectors_coef_transp_tc(1,1,i)) if(interesting(i) < 0) then stop 'prefetch interesting(i) and det(i)' endif @@ -691,11 +688,19 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere call get_mask_phase(psi_det_sorted_tc(1,1,interesting(i)), phasemask,N_int) if(nt == 4) then - call get_d2_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) + if(transpose_two_e_int)then + call get_d2_new_transp(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) + else + call get_d2_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) + endif elseif(nt == 3) then call get_d1_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) else + if(transpose_two_e_int)then + call get_d0_transp (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) + else call get_d0_new (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) + endif endif elseif(nt == 4) then call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) @@ -887,79 +892,11 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d call diag_htilde_mu_mat_fock_bi_ortho(N_int, det, hmono, htwoe, hthree, hii) do istate = 1,N_states delta_E = E0(istate) - Hii + E_shift - double precision :: alpha_h_psi_tmp, psi_h_alpha_tmp, error - if(debug_tc_pt2 == 1)then !! Using the old version - psi_h_alpha = 0.d0 - alpha_h_psi = 0.d0 - do iii = 1, N_det_selectors - call htilde_mu_mat_opt_bi_ortho_tot(psi_selectors(1,1,iii), det, N_int, i_h_alpha) - call htilde_mu_mat_opt_bi_ortho_tot(det, psi_selectors(1,1,iii), N_int, alpha_h_i) - call get_excitation_degree(psi_selectors(1,1,iii), det,degree,N_int) - if(degree == 0)then - print*,'problem !!!' - print*,'a determinant is already in the wave function !!' - print*,'it corresponds to the selector number ',iii - call debug_det(det,N_int) - stop - endif -! call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha) -! call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i) - psi_h_alpha += i_h_alpha * psi_selectors_coef_tc(iii,2,1) ! left function - alpha_h_psi += alpha_h_i * psi_selectors_coef_tc(iii,1,1) ! right function - enddo - else if(debug_tc_pt2 == 2)then !! debugging the new version -! psi_h_alpha_tmp = 0.d0 -! alpha_h_psi_tmp = 0.d0 -! do iii = 1, N_det_selectors ! old version -! call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha) -! call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i) -! psi_h_alpha_tmp += i_h_alpha * psi_selectors_coef_tc(iii,1,1) ! left function -! alpha_h_psi_tmp += alpha_h_i * psi_selectors_coef_tc(iii,2,1) ! right function -! enddo - psi_h_alpha_tmp = mat_l(istate, p1, p2) ! new version - alpha_h_psi_tmp = mat_r(istate, p1, p2) ! new version - psi_h_alpha = 0.d0 - alpha_h_psi = 0.d0 - do iii = 1, N_det ! old version - call htilde_mu_mat_opt_bi_ortho_no_3e(psi_det(1,1,iii), det, N_int, i_h_alpha) - call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_det(1,1,iii), N_int, alpha_h_i) - psi_h_alpha += i_h_alpha * psi_l_coef_bi_ortho(iii,1) ! left function - alpha_h_psi += alpha_h_i * psi_r_coef_bi_ortho(iii,1) ! right function - enddo - if(dabs(psi_h_alpha*alpha_h_psi/delta_E).gt.1.d-10)then - error = dabs(psi_h_alpha * alpha_h_psi - psi_h_alpha_tmp * alpha_h_psi_tmp)/dabs(psi_h_alpha * alpha_h_psi) - if(error.gt.1.d-2)then - call debug_det(det, N_int) - print*,'error =',error,psi_h_alpha * alpha_h_psi/delta_E,psi_h_alpha_tmp * alpha_h_psi_tmp/delta_E - print*,psi_h_alpha , alpha_h_psi - print*,psi_h_alpha_tmp , alpha_h_psi_tmp - print*,'selectors ' - do iii = 1, N_det_selectors ! old version - print*,'iii',iii,psi_selectors_coef_tc(iii,1,1),psi_selectors_coef_tc(iii,2,1) - call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha) - call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i) - print*,i_h_alpha,alpha_h_i - call debug_det(psi_selectors(1,1,iii),N_int) - enddo -! print*,'psi_det ' -! do iii = 1, N_det! old version -! print*,'iii',iii,psi_l_coef_bi_ortho(iii,1),psi_r_coef_bi_ortho(iii,1) -! call debug_det(psi_det(1,1,iii),N_int) -! enddo - stop - endif - endif - else - psi_h_alpha = mat_l(istate, p1, p2) - alpha_h_psi = mat_r(istate, p1, p2) - endif + psi_h_alpha = mat_l(istate, p1, p2) + alpha_h_psi = mat_r(istate, p1, p2) val = 4.d0 * psi_h_alpha * alpha_h_psi tmp = dsqrt(delta_E * delta_E + val) -! if (delta_E < 0.d0) then -! tmp = -tmp -! endif e_pert(istate) = 0.25 * val / delta_E -! e_pert(istate) = 0.5d0 * (tmp - delta_E) if(dsqrt(tmp).gt.1.d-4.and.dabs(psi_h_alpha).gt.1.d-4)then coef(istate) = e_pert(istate) / psi_h_alpha else @@ -976,15 +913,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if(e_pert(istate).gt.0.d0)e_pert(istate)=0.d0 endif -! if(selection_tc == 1 )then -! if(e_pert(istate).lt.0.d0)then -! e_pert(istate) = 0.d0 -! endif -! else if(selection_tc == -1)then -! if(e_pert(istate).gt.0.d0)then -! e_pert(istate) = 0.d0 -! endif -! endif enddo diff --git a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f index 99a8de7e..bb5a89a1 100644 --- a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f +++ b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f @@ -88,6 +88,9 @@ subroutine run_stochastic_cipsi call pt2_dealloc(pt2_data_err) call pt2_alloc(pt2_data, N_states) call pt2_alloc(pt2_data_err, N_states) + if(transpose_two_e_int)then + provide mo_bi_ortho_tc_two_e_transp + endif call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection ! stop diff --git a/plugins/local/fci_tc_bi/pt2_tc.irp.f b/plugins/local/fci_tc_bi/pt2_tc.irp.f index 390042bf..3c07e367 100644 --- a/plugins/local/fci_tc_bi/pt2_tc.irp.f +++ b/plugins/local/fci_tc_bi/pt2_tc.irp.f @@ -13,6 +13,8 @@ program tc_pt2_prog pruning = -1.d0 touch pruning + read_wf = .True. + touch read_wf ! pt2_relative_error = 0.01d0 ! touch pt2_relative_error diff --git a/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f index 4abdc25b..5a3971c5 100644 --- a/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f +++ b/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f @@ -27,7 +27,6 @@ if(degree == 1)then e_pt2_tc_bi_orth_single += coef_pt1 * htilde_ij else -! print*,'coef_pt1, e_pt2',coef_pt1,coef_pt1 * htilde_ij e_pt2_tc_bi_orth_double += coef_pt1 * htilde_ij endif endif diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg index 1e89eaa4..39968ec8 100644 --- a/plugins/local/tc_keywords/EZFIO.cfg +++ b/plugins/local/tc_keywords/EZFIO.cfg @@ -184,12 +184,6 @@ doc: Read/Write normal_two_body_bi_orth from/to disk [ Write | Read | None ] interface: ezfio,provider,ocaml default: None -[debug_tc_pt2] -type: integer -doc: If :: 1 then you compute the TC-PT2 the old way, :: 2 then you check with the new version but without three-body -interface: ezfio,provider,ocaml -default: -1 - [only_spin_tc_right] type: logical doc: If |true|, only the right part of WF is used to compute spin dens @@ -268,3 +262,8 @@ doc: Thresholds on the Imag part of TC energy interface: ezfio,provider,ocaml default: 1.e-7 +[transpose_two_e_int] +type: logical +doc: If |true|, you duplicate the two-electron TC integrals with the transpose matrix. Acceleates the PT2. +interface: ezfio,provider,ocaml +default: False From 18fd70f1b88ee4a412a351a92a98f4b1ef1ee3d0 Mon Sep 17 00:00:00 2001 From: eginer Date: Tue, 7 May 2024 20:18:24 +0200 Subject: [PATCH 48/50] added get_d1_transp.irp.f --- .../cipsi_tc_bi_ortho/get_d1_transp.irp.f | 350 ++++++++++++++++++ .../local/cipsi_tc_bi_ortho/selection.irp.f | 6 +- 2 files changed, 355 insertions(+), 1 deletion(-) create mode 100644 plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f new file mode 100644 index 00000000..3c6cbf60 --- /dev/null +++ b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f @@ -0,0 +1,350 @@ +subroutine get_d1_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs) + !todo: indices should be okay for complex? + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(bit_kind), intent(in) :: phasemask(N_int,2) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states,2) + double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num) + double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + double precision, external :: get_phase_bi + double precision, external :: mo_two_e_integral_complex + logical :: ok + + logical, allocatable :: lbanned(:,:) + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j + integer :: hfix, pfix, h1, h2, p1, p2, ib, k, l, mm + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + double precision, allocatable :: hij_cache(:,:) + double precision :: hij, tmp_rowij(N_states, mo_num), tmp_rowij2(N_states, mo_num),phase + double precision, allocatable :: hji_cache(:,:) + double precision :: hji, tmp_rowji(N_states, mo_num), tmp_rowji2(N_states, mo_num) +! PROVIDE mo_integrals_map N_int +! print*,'in get_d1_new' +! call debug_det(gen,N_int) +! print*,'coefs',coefs(1,:) + + allocate (lbanned(mo_num, 2)) + allocate (hij_cache(mo_num,2)) + allocate (hji_cache(mo_num,2)) + lbanned = bannedOrb + + do i=1, p(0,1) + lbanned(p(i,1), 1) = .true. + end do + do i=1, p(0,2) + lbanned(p(i,2), 2) = .true. + end do + + ma = 1 + if(p(0,2) >= 2) ma = 2 + mi = turn2(ma) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then +! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2) +! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2) + do mm = 1, mo_num + hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2) + hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1) + hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,p2) + hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,p1) + enddo + !! + tmp_rowij = 0.d0 + tmp_rowji = 0.d0 + do putj=1, hfix-1 + if(lbanned(putj, ma)) cycle + if(banned(putj, puti,bant)) cycle + hij = hij_cache(putj,1) - hij_cache(putj,2) + hji = hji_cache(putj,1) - hji_cache(putj,2) + if (hij /= 0.d0.and.hji/=0.d0) then + phase = get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) + hij = hij * phase + hji = hji * phase + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,2) + tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,1) + enddo + endif + end do + do putj=hfix+1, mo_num + if(lbanned(putj, ma)) cycle + if(banned(putj, puti,bant)) cycle + hij = hij_cache(putj,2) - hij_cache(putj,1) + hji = hji_cache(putj,2) - hji_cache(putj,1) + if (hij /= 0.d0.and.hji/=0.d0) then + phase = get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) + hij = hij * phase + hji = hji * phase + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,2) + tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,1) + enddo + endif + end do + + if(ma == 1) then + mat_r(1:N_states,1:mo_num,puti) = mat_r(1:N_states,1:mo_num,puti) + tmp_rowij(1:N_states,1:mo_num) + mat_l(1:N_states,1:mo_num,puti) = mat_l(1:N_states,1:mo_num,puti) + tmp_rowji(1:N_states,1:mo_num) + else + do l=1,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k,puti,l) = mat_r(k,puti,l) + tmp_rowij(k,l) + mat_l(k,puti,l) = mat_l(k,puti,l) + tmp_rowji(k,l) + enddo + enddo + end if + + end if + + !MOVE MI + pfix = p(1,mi) + tmp_rowij = 0.d0 + tmp_rowij2 = 0.d0 + tmp_rowji = 0.d0 + tmp_rowji2 = 0.d0 +! call get_mo_two_e_integrals_complex(hfix,pfix,p1,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2) +! call get_mo_two_e_integrals_complex(hfix,pfix,p2,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2) + do mm = 1, mo_num + hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p1) + hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p2) + hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,pfix,p1) + hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,pfix,p2) + enddo + putj = p1 + !! + do puti=1,mo_num !HOT + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = hij_cache(puti,2) + hji = hji_cache(puti,2) + if (hij /= 0.d0.and.hji/=0.d0) then + phase = get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int) + hij = hij * phase + hji = hji * phase + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,2) + tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,1) + enddo + endif + end if +! + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = hij_cache(puti,1) + hji = hji_cache(puti,1) + if (hij /= 0.d0.and.hji/=0.d0) then + phase = get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int) + hij = hij * phase + hji = hji * phase + do k=1,N_states + tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,2) + tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,1) + enddo + endif + end if + end do + + if(mi == 1) then + mat_r(:,:,p1) = mat_r(:,:,p1) + tmp_rowij(:,:) + mat_r(:,:,p2) = mat_r(:,:,p2) + tmp_rowij2(:,:) + mat_l(:,:,p1) = mat_l(:,:,p1) + tmp_rowji(:,:) + mat_l(:,:,p2) = mat_l(:,:,p2) + tmp_rowji2(:,:) + else + do l=1,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij(k,l) + mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij2(k,l) + mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji(k,l) + mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji2(k,l) + enddo + enddo + end if + + else ! sp /= 3 + + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) +! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2) +! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2) + do mm = 1, mo_num + hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2) + hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1) + hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,p2) + hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,p1) + enddo + !! + tmp_rowij = 0.d0 + tmp_rowji = 0.d0 + do putj=1,hfix-1 + if(banned(putj,puti,1)) cycle + if(lbanned(putj,ma)) cycle + hij = hij_cache(putj,1) - hij_cache(putj,2) + hji = hji_cache(putj,1) - hji_cache(putj,2) + if (hij /= 0.d0.and.hji/=0.d0) then + phase = get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int) + hij = hij * phase + hji = hji * phase + tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,2) + tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,1) + endif + end do + do putj=hfix+1,mo_num + if(banned(putj,puti,1)) cycle + if(lbanned(putj,ma)) cycle + hij = hij_cache(putj,2) - hij_cache(putj,1) + hji = hji_cache(putj,2) - hji_cache(putj,1) + if (hij /= 0.d0.and.hji/=0.d0) then + phase = get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int) + hij = hij * phase + hji = hji * phase + tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,2) + tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,1) + endif + end do + + mat_r(:, :puti-1, puti) = mat_r(:, :puti-1, puti) + tmp_rowij(:,:puti-1) + mat_l(:, :puti-1, puti) = mat_l(:, :puti-1, puti) + tmp_rowji(:,:puti-1) + do l=puti,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k, puti, l) = mat_r(k, puti,l) + tmp_rowij(k,l) + mat_l(k, puti, l) = mat_l(k, puti,l) + tmp_rowji(k,l) + enddo + enddo + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_rowij = 0.d0 + tmp_rowij2 = 0.d0 + tmp_rowji = 0.d0 + tmp_rowji2 = 0.d0 +! call get_mo_two_e_integrals_complex(hfix,p1,pfix,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2) +! call get_mo_two_e_integrals_complex(hfix,p2,pfix,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2) + do mm = 1, mo_num + hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,pfix) + hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,pfix) + hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,pfix) + hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,pfix) + enddo + putj = p2 + !! + do puti=1,mo_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = hij_cache(puti,1) + hji = hji_cache(puti,1) + if (hij /= 0.d0.and.hji/=0.d0) then + phase = get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int) + hij = hij * phase + hji = hji * phase + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,2) + tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,1) + enddo + endif + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = hij_cache(puti,2) + hji = hji_cache(puti,2) + if (hij /= 0.d0.and.hji/=0.d0) then + phase = get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int) + hij = hij * phase + hji = hji * phase + do k=1,N_states + tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,2) + tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,1) + enddo + endif + end if + end do + mat_r(:,:p2-1,p2) = mat_r(:,:p2-1,p2) + tmp_rowij(:,:p2-1) + mat_l(:,:p2-1,p2) = mat_l(:,:p2-1,p2) + tmp_rowji(:,:p2-1) + do l=p2,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij(k,l) + mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji(k,l) + enddo + enddo + mat_r(:,:p1-1,p1) = mat_r(:,:p1-1,p1) + tmp_rowij2(:,:p1-1) + mat_l(:,:p1-1,p1) = mat_l(:,:p1-1,p1) + tmp_rowji2(:,:p1-1) + do l=p1,mo_num + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij2(k,l) + mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji2(k,l) + enddo + enddo + end if + end if + deallocate(lbanned,hij_cache, hji_cache) + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + ! gen is a selector; mask is ionized generator; det is alpha + ! hij is contribution to +! call i_h_j_complex(gen, det, N_int, hij) + call htilde_mu_mat_opt_bi_ortho_no_3e(det, gen, N_int, hij) + call htilde_mu_mat_opt_bi_ortho_no_3e(gen, det, N_int, hji) + !DIR$ LOOP COUNT AVG(4) + do k=1,N_states + ! take conjugate to get contribution to instead of +! mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * dconjg(hij) + mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,2) * hij + mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,1) * hji + enddo + end do + end do +end + diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f index 0f785ba2..17d34f43 100644 --- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f +++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f @@ -694,7 +694,11 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere call get_d2_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) endif elseif(nt == 3) then - call get_d1_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) + if(transpose_two_e_int)then + call get_d1_transp(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) + else + call get_d1_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) + endif else if(transpose_two_e_int)then call get_d0_transp (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i))) From 687259c25feb8ec568b31b89b760d2e08d07ad3a Mon Sep 17 00:00:00 2001 From: eginer Date: Tue, 7 May 2024 20:32:48 +0200 Subject: [PATCH 49/50] working on the matrix elements both --- .../local/bi_ort_ints/total_twoe_pot.irp.f | 20 +++ plugins/local/slater_tc/slater_tc_opt.irp.f | 42 ++++++ .../slater_tc/slater_tc_opt_double.irp.f | 60 ++++++++ .../slater_tc/slater_tc_opt_single.irp.f | 142 ++++++++++++++++++ 4 files changed, 264 insertions(+) diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f index 71269fdc..e27fdb7f 100644 --- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f +++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f @@ -332,3 +332,23 @@ END_PROVIDER ! --- + BEGIN_PROVIDER [double precision, tc_2e_3idx_coulomb_integrals_transp , (mo_num,mo_num,mo_num)] +&BEGIN_PROVIDER [double precision, tc_2e_3idx_exchange_integrals_transp, (mo_num,mo_num,mo_num)] + + BEGIN_DOC + ! tc_2e_3idx_coulomb_integrals_transp (j,k,i) = + ! tc_2e_3idx_exchange_integrals_transp(j,k,i) = + END_DOC + implicit none + integer :: i, j, k + + do i = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + tc_2e_3idx_coulomb_integrals_transp(j, k,i) = mo_bi_ortho_tc_two_e_transp(j ,k ,j ,i ) + tc_2e_3idx_exchange_integrals_transp(j,k,i) = mo_bi_ortho_tc_two_e_transp(k ,j ,j ,i ) + enddo + enddo + enddo + +END_PROVIDER diff --git a/plugins/local/slater_tc/slater_tc_opt.irp.f b/plugins/local/slater_tc/slater_tc_opt.irp.f index 59efc943..9ed2b389 100644 --- a/plugins/local/slater_tc/slater_tc_opt.irp.f +++ b/plugins/local/slater_tc/slater_tc_opt.irp.f @@ -181,3 +181,45 @@ end ! --- +subroutine htilde_mu_mat_opt_bi_ortho_no_3e_both(key_j, key_i, Nint, htot) + + BEGIN_DOC + ! + ! where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis + !! + ! Returns the detail of the matrix element WITHOUT ANY CONTRIBUTION FROM THE THREE ELECTRON TERMS + !! WARNING !! + ! + ! Non hermitian !! + ! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: htot + integer :: degree + + htot = 0.d0 + + call get_excitation_degree(key_i, key_j, degree, Nint) + if(degree.gt.2) return + + if(degree == 0) then + call diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_i,htot) + else if (degree == 1) then + call single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint,key_j, key_i , htot) + else if(degree == 2) then + call double_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, htot) + endif + + if(degree==0) then + htot += nuclear_repulsion + endif + +end + +! --- + diff --git a/plugins/local/slater_tc/slater_tc_opt_double.irp.f b/plugins/local/slater_tc/slater_tc_opt_double.irp.f index 4067473c..181ae11d 100644 --- a/plugins/local/slater_tc/slater_tc_opt_double.irp.f +++ b/plugins/local/slater_tc/slater_tc_opt_double.irp.f @@ -505,3 +505,63 @@ subroutine double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot) end +subroutine double_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hji,hij) + + BEGIN_DOC + ! and for double excitation ONLY FOR ONE- AND TWO-BODY TERMS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2) + double precision, intent(out) :: hji,hij + double precision :: hmono, htwoe_ji, htwoe_ij + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + double precision :: get_mo_two_e_integral_tc_int,phase + + + call get_excitation_degree(key_i, key_j, degree, Nint) + + hmono = 0.d0 + htwoe_ji = 0.d0 + htwoe_ij = 0.d0 + hji = 0.d0 + hij = 0.d0 + + if(degree.ne.2)then + return + endif + integer :: degree_i,degree_j + call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int) + call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int) + call get_double_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2) + + if(s1.ne.s2)then + ! opposite spin two-body + htwoe_ji = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) + htwoe_ij = mo_bi_ortho_tc_two_e_transp(p2,p1,h2,h1) + else + ! same spin two-body + ! direct terms + htwoe_ji = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) + htwoe_ij = mo_bi_ortho_tc_two_e_transp(p2,p1,h2,h1) + ! exchange terms + htwoe_ji -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1) + htwoe_ij -= mo_bi_ortho_tc_two_e_transp(p1,p2,h2,h1) + endif + htwoe_ji *= phase + hji = htwoe_ji + htwoe_ij *= phase + hij = htwoe_ij + +end diff --git a/plugins/local/slater_tc/slater_tc_opt_single.irp.f b/plugins/local/slater_tc/slater_tc_opt_single.irp.f index e57cb05c..3f4e17e2 100644 --- a/plugins/local/slater_tc/slater_tc_opt_single.irp.f +++ b/plugins/local/slater_tc/slater_tc_opt_single.irp.f @@ -618,3 +618,145 @@ subroutine get_single_excitation_from_fock_tc_no_3e(Nint, key_i, key_j, h, p, sp end + +subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hji,hij) + + BEGIN_DOC + ! and for single excitation ONLY FOR ONE- AND TWO-BODY TERMS + !! + !! WARNING !! + ! + ! Non hermitian !! + END_DOC + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2) + double precision, intent(out) :: hji,hij + + double precision :: hmono, htwoe + integer :: occ(Nint*bit_kind_size,2) + integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk + integer :: degree,exc(0:2,2,2) + integer :: h1, p1, h2, p2, s1, s2 + double precision :: get_mo_two_e_integral_tc_int, phase + double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13 + integer :: other_spin(2) + integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2) + + other_spin(1) = 2 + other_spin(2) = 1 + + hmono = 0.d0 + htwoe = 0.d0 + hji = 0.d0 + hji = 0.d0 + call get_excitation_degree(key_i, key_j, degree, Nint) + if(degree.ne.1)then + return + endif + call bitstring_to_list_ab(key_i, occ, Ne, Nint) + + call get_single_excitation(key_i, key_j, exc, phase, Nint) + call decode_exc(exc,1,h1,p1,h2,p2,s1,s2) + call get_single_excitation_from_fock_tc_no_3e_both(Nint, key_i, key_j, h1, p1, s1, phase, hmono, htwoe, hji,hij) + +end + +! --- + +subroutine get_single_excitation_from_fock_tc_no_3e_both(Nint, key_i, key_j, h, p, spin, phase, hji,hij) + + use bitmasks + + implicit none + integer, intent(in) :: Nint + integer, intent(in) :: h, p, spin + double precision, intent(in) :: phase + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hji,hij + double precision :: hmono_ji,htwoe_ji + double precision :: hmono_ij,htwoe_ij + + integer(bit_kind) :: differences(Nint,2) + integer(bit_kind) :: hole(Nint,2) + integer(bit_kind) :: partcl(Nint,2) + integer :: occ_hole(Nint*bit_kind_size,2) + integer :: occ_partcl(Nint*bit_kind_size,2) + integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2) + integer :: i0,i + double precision :: buffer_c_ji(mo_num), buffer_x_ji(mo_num) + double precision :: buffer_c_ij(mo_num), buffer_x_ij(mo_num) + + do i = 1, mo_num + buffer_c_ji(i) = tc_2e_3idx_coulomb_integrals(i,p,h) + buffer_x_ji(i) = tc_2e_3idx_exchange_integrals(i,p,h) + buffer_c_ij(i) = tc_2e_3idx_coulomb_integrals_transp(i,p,h) + buffer_x_ij(i) = tc_2e_3idx_exchange_integrals_transp(i,p,h) + enddo + + do i = 1, Nint + differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1)) + differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2)) + hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1)) + hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2)) + partcl(i,1) = iand(differences(i,1),key_i(i,1)) + partcl(i,2) = iand(differences(i,2),key_i(i,2)) + enddo + + call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, Nint) + call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, Nint) + hmono_ji = mo_bi_ortho_tc_one_e(p,h) + htwoe_ji = fock_op_2_e_tc_closed_shell(p,h) + hmono_ij = mo_bi_ortho_tc_one_e(h,p) + htwoe_ij = fock_op_2_e_tc_closed_shell(h,p) + + ! holes :: direct terms + do i0 = 1, n_occ_ab_hole(1) + i = occ_hole(i0,1) + htwoe_ji -= buffer_c_ji(i) + htwoe_ij -= buffer_c_ij(i) + enddo + do i0 = 1, n_occ_ab_hole(2) + i = occ_hole(i0,2) + htwoe_ji -= buffer_c_ji(i) + htwoe_ij -= buffer_c_ij(i) + enddo + + ! holes :: exchange terms + do i0 = 1, n_occ_ab_hole(spin) + i = occ_hole(i0,spin) + htwoe_ji += buffer_x_ji(i) + htwoe_ij += buffer_x_ij(i) + enddo + + ! particles :: direct terms + do i0 = 1, n_occ_ab_partcl(1) + i = occ_partcl(i0,1) + htwoe_ji += buffer_c_ji(i) + htwoe_ij += buffer_c_ij(i) + enddo + do i0 = 1, n_occ_ab_partcl(2) + i = occ_partcl(i0,2) + htwoe_ji += buffer_c_ji(i) + htwoe_ij += buffer_c_ij(i) + enddo + + ! particles :: exchange terms + do i0 = 1, n_occ_ab_partcl(spin) + i = occ_partcl(i0,spin) + htwoe_ji -= buffer_x_ji(i) + htwoe_ij -= buffer_x_ij(i) + enddo + htwoe_ji = htwoe_ji * phase + hmono_ji = hmono_ji * phase + hji = htwoe_ji + hmono_ji + + htwoe_ij = htwoe_ij * phase + hmono_ij = hmono_ij * phase + hij = htwoe_ij + hmono_ij + +end + From 42fdb3c4350c0452a7169614ff9dba4e0e381f62 Mon Sep 17 00:00:00 2001 From: eginer Date: Tue, 7 May 2024 20:52:10 +0200 Subject: [PATCH 50/50] it works with new routines for pt2 tc --- .../cipsi_tc_bi_ortho/get_d0_transp.irp.f | 54 ++++--------------- .../cipsi_tc_bi_ortho/get_d1_transp.irp.f | 4 +- plugins/local/slater_tc/slater_tc_opt.irp.f | 17 +++--- .../slater_tc/slater_tc_opt_single.irp.f | 4 +- 4 files changed, 25 insertions(+), 54 deletions(-) diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f index 56238e13..f149e7c6 100644 --- a/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f +++ b/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f @@ -45,33 +45,16 @@ subroutine get_d0_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) ! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this ! call i_h_j_complex(det, gen, N_int, hij) - call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij) + call htilde_mu_mat_opt_bi_ortho_no_3e_both(det,gen,N_int, hij,hji) else phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) hij = hij_cache1(p2) * phase + hji = hji_cache1(p2) * phase end if - if (hij == (0.d0,0.d0)) cycle + if (hij == 0.d0.or.hji == 0.d0) cycle !DIR$ LOOP COUNT AVG(4) do k=1,N_states mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,2) * hij ! HOTSPOT - enddo - end do - !!!!!!!!!! - do p2=1, mo_num - if(bannedOrb(p2,2)) cycle - if(banned(p1, p2, bant)) cycle ! rentable? - if(p1 == h1 .or. p2 == h2) then - call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) - ! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this -! call i_h_j_complex(det, gen, N_int, hij) - call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji) - else - phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int) - hji = hji_cache1(p2) * phase - end if - if (hji == (0.d0,0.d0)) cycle - !DIR$ LOOP COUNT AVG(4) - do k=1,N_states mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,1) * hji ! HOTSPOT enddo end do @@ -98,40 +81,25 @@ subroutine get_d0_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) !call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this ! call i_h_j_complex(det, gen, N_int, hij) - call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij) - if (hij == 0.d0) cycle + call htilde_mu_mat_opt_bi_ortho_no_3e_both(det,gen,N_int, hij,hji) + if (hij == 0.d0.or.hji == 0.d0) cycle else ! hij = (mo_two_e_integral_complex(p1, p2, puti, putj) - mo_two_e_integral_complex(p2, p1, puti, putj)) ! hij = (mo_bi_ortho_tc_two_e(p1, p2, puti, putj) - mo_bi_ortho_tc_two_e(p2, p1, puti, putj)) hij = (mo_bi_ortho_tc_two_e(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e(puti, putj, p2, p1)) - if (hij == 0.d0) cycle - hij = (hij) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int) + hji = (mo_bi_ortho_tc_two_e_transp(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e_transp(puti, putj, p2, p1)) + if (hij == 0.d0.or.hji == 0.d0) cycle + phase = get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int) + hij = (hij) * phase + hji = (hji) * phase end if !DIR$ LOOP COUNT AVG(4) do k=1,N_states mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij - enddo - end do - - !!!!!!!!!! - do putj=puti+1, mo_num - if(bannedOrb(putj, sp)) cycle - if(banned(puti, putj, bant)) cycle ! rentable? - if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then - call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) - call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji) - if (hji == 0.d0) cycle - else -! hji = (mo_bi_ortho_tc_two_e( p1, p2, puti, putj) - mo_bi_ortho_tc_two_e( p2, p1, puti, putj)) - hji = (mo_bi_ortho_tc_two_e_transp(puti, putj, p1, p2 ) - mo_bi_ortho_tc_two_e_transp( puti, putj, p2, p1)) - if (hji == 0.d0) cycle - hji = (hji) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int) - end if - !DIR$ LOOP COUNT AVG(4) - do k=1,N_states mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji enddo end do + end do end if diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f index 3c6cbf60..84a1ce24 100644 --- a/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f +++ b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f @@ -335,8 +335,8 @@ subroutine get_d1_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, ! gen is a selector; mask is ionized generator; det is alpha ! hij is contribution to ! call i_h_j_complex(gen, det, N_int, hij) - call htilde_mu_mat_opt_bi_ortho_no_3e(det, gen, N_int, hij) - call htilde_mu_mat_opt_bi_ortho_no_3e(gen, det, N_int, hji) + call htilde_mu_mat_opt_bi_ortho_no_3e_both(det, gen, N_int, hij,hji) +! call htilde_mu_mat_opt_bi_ortho_no_3e(gen, det, N_int, hji) !DIR$ LOOP COUNT AVG(4) do k=1,N_states ! take conjugate to get contribution to instead of diff --git a/plugins/local/slater_tc/slater_tc_opt.irp.f b/plugins/local/slater_tc/slater_tc_opt.irp.f index 9ed2b389..5651a299 100644 --- a/plugins/local/slater_tc/slater_tc_opt.irp.f +++ b/plugins/local/slater_tc/slater_tc_opt.irp.f @@ -181,7 +181,7 @@ end ! --- -subroutine htilde_mu_mat_opt_bi_ortho_no_3e_both(key_j, key_i, Nint, htot) +subroutine htilde_mu_mat_opt_bi_ortho_no_3e_both(key_j, key_i, Nint, hji,hij) BEGIN_DOC ! @@ -199,24 +199,27 @@ subroutine htilde_mu_mat_opt_bi_ortho_no_3e_both(key_j, key_i, Nint, htot) implicit none integer, intent(in) :: Nint integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: htot + double precision, intent(out) :: hji,hij integer :: degree - htot = 0.d0 + hji = 0.d0 + hij = 0.d0 call get_excitation_degree(key_i, key_j, degree, Nint) if(degree.gt.2) return if(degree == 0) then - call diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_i,htot) + call diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_i,hji) + hij = hji else if (degree == 1) then - call single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint,key_j, key_i , htot) + call single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint,key_j, key_i , hji,hij) else if(degree == 2) then - call double_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, htot) + call double_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hji,hij) endif if(degree==0) then - htot += nuclear_repulsion + hji += nuclear_repulsion + hij += nuclear_repulsion endif end diff --git a/plugins/local/slater_tc/slater_tc_opt_single.irp.f b/plugins/local/slater_tc/slater_tc_opt_single.irp.f index 3f4e17e2..47bcbe34 100644 --- a/plugins/local/slater_tc/slater_tc_opt_single.irp.f +++ b/plugins/local/slater_tc/slater_tc_opt_single.irp.f @@ -652,7 +652,7 @@ subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hj hmono = 0.d0 htwoe = 0.d0 hji = 0.d0 - hji = 0.d0 + hij = 0.d0 call get_excitation_degree(key_i, key_j, degree, Nint) if(degree.ne.1)then return @@ -661,7 +661,7 @@ subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hj call get_single_excitation(key_i, key_j, exc, phase, Nint) call decode_exc(exc,1,h1,p1,h2,p2,s1,s2) - call get_single_excitation_from_fock_tc_no_3e_both(Nint, key_i, key_j, h1, p1, s1, phase, hmono, htwoe, hji,hij) + call get_single_excitation_from_fock_tc_no_3e_both(Nint, key_i, key_j, h1, p1, s1, phase, hji,hij) end