LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-21 19:13:29 +01:00
Code Releases Activity

cleaning in tc_scf

Browse Source
This commit is contained in:
eginer 2023-02-07 16:45:10 +01:00
parent d6ed501c91
commit cc16cea1b0
17 changed files with 487 additions and 1720 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
src/tc_scf/diago_bi_ort_tcfock.irp.f
View File

@ -38,33 +38,9 @@
, fock_tc_leigvec_mo, fock_tc_reigvec_mo & , fock_tc_leigvec_mo, fock_tc_reigvec_mo &
, n_real_tc, eigval_right_tmp ) , n_real_tc, eigval_right_tmp )
!if(max_ov_tc_scf)then
! call non_hrmt_fock_mat( mo_num, F_tmp, thresh_biorthog_diag, thresh_biorthog_nondiag &
! , fock_tc_leigvec_mo, fock_tc_reigvec_mo &
! , n_real_tc, eigval_right_tmp )
!else
! call non_hrmt_diag_split_degen_bi_orthog( mo_num, F_tmp &
! , fock_tc_leigvec_mo, fock_tc_reigvec_mo &
! , n_real_tc, eigval_right_tmp )
!endif
deallocate(F_tmp) deallocate(F_tmp)
! if(n_real_tc .ne. mo_num)then
! print*,'n_real_tc ne mo_num ! ',n_real_tc
! stop
! endif
eigval_fock_tc_mo = eigval_right_tmp eigval_fock_tc_mo = eigval_right_tmp
! print*,'Eigenvalues of Fock_matrix_tc_mo_tot'
! do i = 1, elec_alpha_num
! print*, i, eigval_fock_tc_mo(i)
! enddo
! do i = elec_alpha_num+1, mo_num
! print*, i, eigval_fock_tc_mo(i) - level_shift_tcscf
! enddo
! deallocate( eigval_right_tmp )
! L.T x R ! L.T x R
call dgemm( "T", "N", mo_num, mo_num, mo_num, 1.d0 & call dgemm( "T", "N", mo_num, mo_num, mo_num, 1.d0 &

10
src/tc_scf/fock_3e_bi_ortho_uhf.irp.f
View File

@ -49,6 +49,11 @@ END_PROVIDER
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)] BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (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 implicit none
integer :: a, b, i, j, o 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 :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
@ -145,6 +150,11 @@ END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)] BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (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 implicit none
integer :: a, b, i, j, o integer :: a, b, i, j, o

0
src/tc_scf/fock_for_right.irp.f → src/tc_scf/fock_hermit.irp.f
View File

51
src/tc_scf/fock_tc.irp.f
View File

@ -6,10 +6,11 @@
BEGIN_DOC BEGIN_DOC
! !
! two_e_tc_non_hermit_integral_seq_alpha(k,i) = <k| F^tc_alpha |i> ! two_e_tc_non_hermit_integral_seq_alpha(k,i) = <k| F^tc_alpha |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 is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions
! !
! works in SEQUENTIAL
END_DOC END_DOC
implicit none implicit none
@ -17,8 +18,6 @@
double precision :: density, density_a, density_b double precision :: density, density_a, density_b
double precision :: t0, t1 double precision :: t0, t1
!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_alpha = 0.d0
two_e_tc_non_hermit_integral_seq_beta = 0.d0 two_e_tc_non_hermit_integral_seq_beta = 0.d0
@ -32,24 +31,6 @@
density_b = TCSCF_density_matrix_ao_beta (l,j) density_b = TCSCF_density_matrix_ao_beta (l,j)
density = density_a + density_b 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_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_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_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_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i)
! rho(l,j) * < k l| T | i j> ! 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) 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> ! rho(l,j) * < k l| T | i j>
@ -64,8 +45,6 @@
enddo enddo
enddo enddo
!call wall_time(t1)
!print*, ' wall time for two_e_tc_non_hermit_integral_seq after = ', t1 - t0
END_PROVIDER END_PROVIDER
@ -76,9 +55,9 @@ END_PROVIDER
BEGIN_DOC BEGIN_DOC
! !
! two_e_tc_non_hermit_integral_alpha(k,i) = <k| F^tc_alpha |i> ! two_e_tc_non_hermit_integral_alpha(k,i) = <k| F^tc_alpha |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 is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions
! !
END_DOC END_DOC
@ -88,8 +67,6 @@ END_PROVIDER
double precision :: t0, t1 double precision :: t0, t1
double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) double precision, allocatable :: tmp_a(:,:), tmp_b(:,:)
!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_alpha = 0.d0
two_e_tc_non_hermit_integral_beta = 0.d0 two_e_tc_non_hermit_integral_beta = 0.d0
@ -135,8 +112,6 @@ END_PROVIDER
deallocate(tmp_a, tmp_b) deallocate(tmp_a, tmp_b)
!$OMP END PARALLEL !$OMP END PARALLEL
!call wall_time(t1)
!print*, ' wall time for two_e_tc_non_hermit_integral after = ', t1 - t0
END_PROVIDER END_PROVIDER
@ -181,14 +156,6 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ]
if(bi_ortho) then if(bi_ortho) then
!allocate(tmp(ao_num,ao_num))
!tmp = Fock_matrix_tc_ao_alpha
!if(three_body_h_tc) then
! tmp += fock_3e_uhf_ao_a
!endif
!call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1))
!deallocate(tmp)
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_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) ) , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
if(three_body_h_tc) then if(three_body_h_tc) then
@ -217,14 +184,6 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ]
if(bi_ortho) then if(bi_ortho) then
!allocate(tmp(ao_num,ao_num))
!tmp = Fock_matrix_tc_ao_beta
!if(three_body_h_tc) then
! tmp += fock_3e_uhf_ao_b
!endif
!call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1))
!deallocate(tmp)
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_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) ) , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
if(three_body_h_tc) then if(three_body_h_tc) then

2
src/tc_scf/fock_tc_mo_tot.irp.f
View File

@ -3,7 +3,7 @@
&BEGIN_PROVIDER [ double precision, Fock_matrix_tc_diag_mo_tot, (mo_num)] &BEGIN_PROVIDER [ double precision, Fock_matrix_tc_diag_mo_tot, (mo_num)]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Fock matrix on the MO basis. ! TC-Fock matrix on the MO basis. WARNING !!! NON HERMITIAN !!!
! For open shells, the ROHF Fock Matrix is :: ! For open shells, the ROHF Fock Matrix is ::
! !
! | F-K | F + K/2 | F | ! | F-K | F + K/2 | F |

422
src/tc_scf/fock_three_bi_ortho.irp.f
View File

@ -1,178 +1,296 @@
BEGIN_PROVIDER [ double precision, fock_a_abb_3e_bi_orth_old, (mo_num, mo_num)]
implicit none ! ---
BEGIN_DOC
! fock_a_abb_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for alpha electrons from alpha,beta,beta contribution BEGIN_PROVIDER [double precision, fock_a_tot_3e_bi_orth, (mo_num, mo_num)]
END_DOC
fock_a_abb_3e_bi_orth_old = 0.d0 BEGIN_DOC
integer :: i,a,j,k ! Alpha part of the Fock matrix from three-electron terms
double precision :: direct_int, exch_23_int !
do i = 1, mo_num ! WARNING :: non hermitian if bi-ortho MOS used
do a = 1, mo_num END_DOC
implicit none
do j = 1, elec_beta_num integer :: i, a
do k = j+1, elec_beta_num
! see contrib_3e_soo PROVIDE mo_l_coef mo_r_coef
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23 fock_a_tot_3e_bi_orth = 0.d0
fock_a_abb_3e_bi_orth_old(a,i) += direct_int - exch_23_int
do i = 1, mo_num
do a = 1, mo_num
fock_a_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth (a,i)
fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp1_bi_ortho(a,i)
fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp2_bi_ortho(a,i)
enddo enddo
enddo
enddo enddo
enddo
fock_a_abb_3e_bi_orth_old = - fock_a_abb_3e_bi_orth_old
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, fock_a_aba_3e_bi_orth_old, (mo_num, mo_num)] ! ---
implicit none
BEGIN_DOC BEGIN_PROVIDER [double precision, fock_b_tot_3e_bi_orth, (mo_num, mo_num)]
! fock_a_aba_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for alpha electrons from alpha,alpha,beta contribution
END_DOC BEGIN_DOC
fock_a_aba_3e_bi_orth_old = 0.d0 ! Beta part of the Fock matrix from three-electron terms
integer :: i,a,j,k !
double precision :: direct_int, exch_13_int ! WARNING :: non hermitian if bi-ortho MOS used
do i = 1, mo_num END_DOC
do a = 1, mo_num implicit none
integer :: i, a
do j = 1, elec_alpha_num ! a
do k = 1, elec_beta_num ! b PROVIDE mo_l_coef mo_r_coef
! a b a a b a
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )! < a k j | i k j > fock_b_tot_3e_bi_orth = 0.d0
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13
fock_a_aba_3e_bi_orth_old(a,i) += direct_int - exch_13_int do i = 1, mo_num
do a = 1, mo_num
fock_b_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth (a,i)
fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp2_bi_ortho(a,i)
fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp1_bi_ortho(a,i)
enddo enddo
enddo
enddo enddo
enddo
fock_a_aba_3e_bi_orth_old = - fock_a_aba_3e_bi_orth_old
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, fock_a_aaa_3e_bi_orth_old, (mo_num, mo_num)] ! ---
implicit none
BEGIN_DOC BEGIN_PROVIDER [double precision, fock_cs_3e_bi_orth, (mo_num, mo_num)]
! fock_a_aaa_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for alpha electrons from alpha,alpha,alpha contribution
END_DOC implicit none
fock_a_aaa_3e_bi_orth_old = 0.d0 integer :: i, a, j, k
integer :: i,a,j,k double precision :: contrib_sss, contrib_sos, contrib_soo, contrib
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
do i = 1, mo_num double precision :: new
do a = 1, mo_num
PROVIDE mo_l_coef mo_r_coef
do j = 1, elec_alpha_num
do k = j+1, elec_alpha_num fock_cs_3e_bi_orth = 0.d0
! positive terms :: cycle contrib
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j > do i = 1, mo_num
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k > do a = 1, mo_num
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
fock_a_aaa_3e_bi_orth_old(a,i) += direct_int + c_3_int + c_minus_3_int do j = 1, elec_beta_num
! negative terms :: exchange contrib do k = 1, elec_beta_num
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23 !!call contrib_3e_sss(a,i,j,k,contrib_sss)
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12 !!call contrib_3e_soo(a,i,j,k,contrib_soo)
fock_a_aaa_3e_bi_orth_old(a,i) += - exch_13_int - exch_23_int - exch_12_int !!call contrib_3e_sos(a,i,j,k,contrib_sos)
!!contrib = 0.5d0 * (contrib_sss + contrib_soo) + contrib_sos
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
! negative terms :: exchange contrib
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
new = 2.d0 * direct_int + 0.5d0 * (c_3_int + c_minus_3_int - exch_12_int) -1.5d0 * exch_13_int - exch_23_int
fock_cs_3e_bi_orth(a,i) += new
enddo
enddo
enddo enddo
enddo
enddo enddo
enddo
fock_a_aaa_3e_bi_orth_old = - fock_a_aaa_3e_bi_orth_old fock_cs_3e_bi_orth = - fock_cs_3e_bi_orth
END_PROVIDER
BEGIN_PROVIDER [double precision, fock_a_tot_3e_bi_orth_old, (mo_num, mo_num)]
implicit none
BEGIN_DOC
! fock_a_tot_3e_bi_orth_old = bi-ortho 3-e Fock matrix for alpha electrons from all possible spin contributions
END_DOC
fock_a_tot_3e_bi_orth_old = fock_a_abb_3e_bi_orth_old + fock_a_aba_3e_bi_orth_old + fock_a_aaa_3e_bi_orth_old
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, fock_b_baa_3e_bi_orth_old, (mo_num, mo_num)] ! ---
implicit none
BEGIN_DOC BEGIN_PROVIDER [double precision, fock_a_tmp1_bi_ortho, (mo_num, mo_num)]
! fock_b_baa_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for beta electrons from beta,alpha,alpha contribution
END_DOC implicit none
fock_b_baa_3e_bi_orth_old = 0.d0 integer :: i, a, j, k
integer :: i,a,j,k double precision :: contrib_sss, contrib_sos, contrib_soo, contrib
double precision :: direct_int, exch_23_int double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
do i = 1, mo_num double precision :: new
do a = 1, mo_num
PROVIDE mo_l_coef mo_r_coef
do j = 1, elec_alpha_num
do k = j+1, elec_alpha_num fock_a_tmp1_bi_ortho = 0.d0
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23 do i = 1, mo_num
fock_b_baa_3e_bi_orth_old(a,i) += direct_int - exch_23_int do a = 1, mo_num
do j = elec_beta_num + 1, elec_alpha_num
do k = 1, elec_beta_num
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
fock_a_tmp1_bi_ortho(a,i) += 1.5d0 * (direct_int - exch_13_int) + 0.5d0 * (c_3_int + c_minus_3_int - exch_23_int - exch_12_int)
enddo
enddo
enddo enddo
enddo
enddo enddo
enddo
fock_b_baa_3e_bi_orth_old = - fock_b_baa_3e_bi_orth_old fock_a_tmp1_bi_ortho = - fock_a_tmp1_bi_ortho
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, fock_b_bab_3e_bi_orth_old, (mo_num, mo_num)] ! ---
implicit none
BEGIN_DOC BEGIN_PROVIDER [double precision, fock_a_tmp2_bi_ortho, (mo_num, mo_num)]
! fock_b_bab_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for beta electrons from beta,alpha,beta contribution
END_DOC implicit none
fock_b_bab_3e_bi_orth_old = 0.d0 integer :: i, a, j, k
integer :: i,a,j,k double precision :: contrib_sss
double precision :: direct_int, exch_13_int
do i = 1, mo_num PROVIDE mo_l_coef mo_r_coef
do a = 1, mo_num
fock_a_tmp2_bi_ortho = 0.d0
do j = 1, elec_beta_num
do k = 1, elec_alpha_num do i = 1, mo_num
! b a b b a b do a = 1, mo_num
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j > do j = 1, elec_alpha_num
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13 do k = elec_beta_num+1, elec_alpha_num
fock_b_bab_3e_bi_orth_old(a,i) += direct_int - exch_13_int call contrib_3e_sss(a, i, j, k, contrib_sss)
fock_a_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_sss
enddo
enddo
enddo enddo
enddo
enddo enddo
enddo
fock_b_bab_3e_bi_orth_old = - fock_b_bab_3e_bi_orth_old
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, fock_b_bbb_3e_bi_orth_old, (mo_num, mo_num)] ! ---
implicit none
BEGIN_DOC BEGIN_PROVIDER [double precision, fock_b_tmp1_bi_ortho, (mo_num, mo_num)]
! fock_b_bbb_3e_bi_orth_old(a,i) = bi-ortho 3-e Fock matrix for alpha electrons from alpha,alpha,alpha contribution
END_DOC implicit none
fock_b_bbb_3e_bi_orth_old = 0.d0 integer :: i, a, j, k
integer :: i,a,j,k double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int double precision :: new
do i = 1, mo_num
do a = 1, mo_num PROVIDE mo_l_coef mo_r_coef
do j = 1, elec_beta_num fock_b_tmp1_bi_ortho = 0.d0
do k = j+1, elec_beta_num
! positive terms :: cycle contrib do i = 1, mo_num
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j > do a = 1, mo_num
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k > do j = 1, elec_beta_num
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i > do k = elec_beta_num+1, elec_alpha_num
fock_b_bbb_3e_bi_orth_old(a,i) += direct_int + c_3_int + c_minus_3_int call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
! negative terms :: exchange contrib call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13 call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12 fock_b_tmp1_bi_ortho(a,i) += 1.5d0 * direct_int - 0.5d0 * exch_23_int - exch_13_int
fock_b_bbb_3e_bi_orth_old(a,i) += - exch_13_int - exch_23_int - exch_12_int enddo
enddo
enddo enddo
enddo
enddo enddo
enddo
fock_b_bbb_3e_bi_orth_old = - fock_b_bbb_3e_bi_orth_old
END_PROVIDER
BEGIN_PROVIDER [ double precision, fock_b_tot_3e_bi_orth_old, (mo_num, mo_num)] fock_b_tmp1_bi_ortho = - fock_b_tmp1_bi_ortho
implicit none
BEGIN_DOC
! fock_b_tot_3e_bi_orth_old = bi-ortho 3-e Fock matrix for alpha electrons from all possible spin contributions
END_DOC
fock_b_tot_3e_bi_orth_old = fock_b_bbb_3e_bi_orth_old + fock_b_bab_3e_bi_orth_old + fock_b_baa_3e_bi_orth_old
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_b_tmp2_bi_ortho, (mo_num, mo_num)]
implicit none
integer :: i, a, j, k
double precision :: contrib_soo
PROVIDE mo_l_coef mo_r_coef
fock_b_tmp2_bi_ortho = 0.d0
do i = 1, mo_num
do a = 1, mo_num
do j = elec_beta_num + 1, elec_alpha_num
do k = 1, elec_alpha_num
call contrib_3e_soo(a, i, j, k, contrib_soo)
fock_b_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_soo
enddo
enddo
enddo
enddo
END_PROVIDER
! ---
subroutine contrib_3e_sss(a, i, j, k, integral)
BEGIN_DOC
! returns the pure same spin contribution to F(a,i) from two orbitals j,k
END_DOC
implicit none
integer, intent(in) :: a, 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
PROVIDE mo_l_coef mo_r_coef
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a 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(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
integral += - exch_13_int - exch_23_int - exch_12_int
integral = -integral
end
! ---
subroutine contrib_3e_soo(a,i,j,k,integral)
BEGIN_DOC
! returns the same spin / opposite spin / opposite spin contribution to F(a,i) from two orbitals j,k
END_DOC
implicit none
integer, intent(in) :: a, i, j, k
double precision, intent(out) :: integral
double precision :: direct_int, exch_23_int
PROVIDE mo_l_coef mo_r_coef
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23
integral = direct_int - exch_23_int
integral = -integral
end
! ---
subroutine contrib_3e_sos(a, i, j, k, integral)
BEGIN_DOC
! returns the same spin / opposite spin / same spin contribution to F(a,i) from two orbitals j,k
END_DOC
PROVIDE mo_l_coef mo_r_coef
implicit none
integer, intent(in) :: a, i, j, k
double precision, intent(out) :: integral
double precision :: direct_int, exch_13_int
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13
integral = direct_int - exch_13_int
integral = -integral
end
! ---

286
src/tc_scf/fock_three_bi_ortho_new_new.irp.f
View File

@ -1,286 +0,0 @@
! ---
BEGIN_PROVIDER [double precision, fock_a_tot_3e_bi_orth, (mo_num, mo_num)]
implicit none
integer :: i, a
PROVIDE mo_l_coef mo_r_coef
fock_a_tot_3e_bi_orth = 0.d0
do i = 1, mo_num
do a = 1, mo_num
fock_a_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth (a,i)
fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp1_bi_ortho(a,i)
fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp2_bi_ortho(a,i)
enddo
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_b_tot_3e_bi_orth, (mo_num, mo_num)]
implicit none
integer :: i, a
PROVIDE mo_l_coef mo_r_coef
fock_b_tot_3e_bi_orth = 0.d0
do i = 1, mo_num
do a = 1, mo_num
fock_b_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth (a,i)
fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp2_bi_ortho(a,i)
fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp1_bi_ortho(a,i)
enddo
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_cs_3e_bi_orth, (mo_num, mo_num)]
implicit none
integer :: i, a, j, k
double precision :: contrib_sss, contrib_sos, contrib_soo, contrib
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
double precision :: new
PROVIDE mo_l_coef mo_r_coef
fock_cs_3e_bi_orth = 0.d0
do i = 1, mo_num
do a = 1, mo_num
do j = 1, elec_beta_num
do k = 1, elec_beta_num
!!call contrib_3e_sss(a,i,j,k,contrib_sss)
!!call contrib_3e_soo(a,i,j,k,contrib_soo)
!!call contrib_3e_sos(a,i,j,k,contrib_sos)
!!contrib = 0.5d0 * (contrib_sss + contrib_soo) + contrib_sos
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
! negative terms :: exchange contrib
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
new = 2.d0 * direct_int + 0.5d0 * (c_3_int + c_minus_3_int - exch_12_int) -1.5d0 * exch_13_int - exch_23_int
fock_cs_3e_bi_orth(a,i) += new
enddo
enddo
enddo
enddo
fock_cs_3e_bi_orth = - fock_cs_3e_bi_orth
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_a_tmp1_bi_ortho, (mo_num, mo_num)]
implicit none
integer :: i, a, j, k
double precision :: contrib_sss, contrib_sos, contrib_soo, contrib
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
double precision :: new
PROVIDE mo_l_coef mo_r_coef
fock_a_tmp1_bi_ortho = 0.d0
do i = 1, mo_num
do a = 1, mo_num
do j = elec_beta_num + 1, elec_alpha_num
do k = 1, elec_beta_num
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
fock_a_tmp1_bi_ortho(a,i) += 1.5d0 * (direct_int - exch_13_int) + 0.5d0 * (c_3_int + c_minus_3_int - exch_23_int - exch_12_int)
enddo
enddo
enddo
enddo
fock_a_tmp1_bi_ortho = - fock_a_tmp1_bi_ortho
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_a_tmp2_bi_ortho, (mo_num, mo_num)]
implicit none
integer :: i, a, j, k
double precision :: contrib_sss
PROVIDE mo_l_coef mo_r_coef
fock_a_tmp2_bi_ortho = 0.d0
do i = 1, mo_num
do a = 1, mo_num
do j = 1, elec_alpha_num
do k = elec_beta_num+1, elec_alpha_num
call contrib_3e_sss(a, i, j, k, contrib_sss)
fock_a_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_sss
enddo
enddo
enddo
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_b_tmp1_bi_ortho, (mo_num, mo_num)]
implicit none
integer :: i, a, j, k
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int
double precision :: new
PROVIDE mo_l_coef mo_r_coef
fock_b_tmp1_bi_ortho = 0.d0
do i = 1, mo_num
do a = 1, mo_num
do j = 1, elec_beta_num
do k = elec_beta_num+1, elec_alpha_num
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
fock_b_tmp1_bi_ortho(a,i) += 1.5d0 * direct_int - 0.5d0 * exch_23_int - exch_13_int
enddo
enddo
enddo
enddo
fock_b_tmp1_bi_ortho = - fock_b_tmp1_bi_ortho
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_b_tmp2_bi_ortho, (mo_num, mo_num)]
implicit none
integer :: i, a, j, k
double precision :: contrib_soo
PROVIDE mo_l_coef mo_r_coef
fock_b_tmp2_bi_ortho = 0.d0
do i = 1, mo_num
do a = 1, mo_num
do j = elec_beta_num + 1, elec_alpha_num
do k = 1, elec_alpha_num
call contrib_3e_soo(a, i, j, k, contrib_soo)
fock_b_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_soo
enddo
enddo
enddo
enddo
END_PROVIDER
! ---
subroutine contrib_3e_sss(a, i, j, k, integral)
BEGIN_DOC
! returns the pure same spin contribution to F(a,i) from two orbitals j,k
END_DOC
implicit none
integer, intent(in) :: a, 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
PROVIDE mo_l_coef mo_r_coef
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a 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(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
integral += - exch_13_int - exch_23_int - exch_12_int
integral = -integral
end
! ---
subroutine contrib_3e_soo(a,i,j,k,integral)
BEGIN_DOC
! returns the same spin / opposite spin / opposite spin contribution to F(a,i) from two orbitals j,k
END_DOC
implicit none
integer, intent(in) :: a, i, j, k
double precision, intent(out) :: integral
double precision :: direct_int, exch_23_int
PROVIDE mo_l_coef mo_r_coef
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23
integral = direct_int - exch_23_int
integral = -integral
end
! ---
subroutine contrib_3e_sos(a, i, j, k, integral)
BEGIN_DOC
! returns the same spin / opposite spin / same spin contribution to F(a,i) from two orbitals j,k
END_DOC
PROVIDE mo_l_coef mo_r_coef
implicit none
integer, intent(in) :: a, i, j, k
double precision, intent(out) :: integral
double precision :: direct_int, exch_13_int
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )! < a k j | i k j >
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13
integral = direct_int - exch_13_int
integral = -integral
end
! ---

141
src/tc_scf/fock_three.irp.f → src/tc_scf/fock_three_hermit.irp.f
View File

@ -227,3 +227,144 @@ BEGIN_PROVIDER [ double precision, fock_3_mat_b_op_sh, (mo_num, mo_num)]
enddo enddo
END_PROVIDER 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

140
src/tc_scf/fock_three_utils.irp.f
View File

@ -1,140 +0,0 @@
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

5
src/tc_scf/minimize_tc_angles.irp.f
View File

@ -1,10 +1,11 @@
program print_angles program print_angles
implicit none implicit none
BEGIN_DOC
! program that minimizes the angle between left- and right-orbitals when degeneracies are found in the TC-Fock matrix
END_DOC
my_grid_becke = .True. my_grid_becke = .True.
my_n_pt_r_grid = 30 my_n_pt_r_grid = 30
my_n_pt_a_grid = 50 my_n_pt_a_grid = 50
! my_n_pt_r_grid = 10 ! small grid for quick debug
! my_n_pt_a_grid = 14 ! small grid for quick debug
touch my_n_pt_r_grid my_n_pt_a_grid touch my_n_pt_r_grid my_n_pt_a_grid
! call sort_by_tc_fock ! call sort_by_tc_fock
call minimize_tc_orb_angles call minimize_tc_orb_angles

9
src/tc_scf/print_angle_tc_orb.irp.f
View File

@ -1,9 +0,0 @@
program print_angles
implicit none
my_grid_becke = .True.
! my_n_pt_r_grid = 30
! my_n_pt_a_grid = 50
my_n_pt_r_grid = 10 ! small grid for quick debug
my_n_pt_a_grid = 14 ! small grid for quick debug
call print_angles_tc
end

2
src/tc_scf/rotate_tcscf_orbitals.irp.f
View File

@ -4,7 +4,7 @@
program rotate_tcscf_orbitals program rotate_tcscf_orbitals
BEGIN_DOC BEGIN_DOC
! TODO : Put the documentation of the program here ! TODO : Rotate the bi-orthonormal orbitals in order to minimize left-right angles when degenerate
END_DOC END_DOC
implicit none implicit none

47
src/tc_scf/routines_rotates.irp.f
View File

@ -1,7 +1,54 @@
! ---
subroutine LTxSxR(n, m, L, S, R, C)
implicit none
integer, intent(in) :: n, m
double precision, intent(in) :: L(n,m), S(n,n), R(n,m)
double precision, intent(out) :: C(m,m)
integer :: i, j
double precision :: accu_d, accu_nd
double precision, allocatable :: tmp(:,:)
! L.T x S x R
allocate(tmp(m,n))
call dgemm( 'T', 'N', m, n, n, 1.d0 &
, L, size(L, 1), S, size(S, 1) &
, 0.d0, tmp, size(tmp, 1) )
call dgemm( 'N', 'N', m, m, n, 1.d0 &
, tmp, size(tmp, 1), R, size(R, 1) &
, 0.d0, C, size(C, 1) )
deallocate(tmp)
accu_d = 0.d0
accu_nd = 0.d0
do i = 1, m
do j = 1, m
if(j.eq.i) then
accu_d += dabs(C(j,i))
else
accu_nd += C(j,i) * C(j,i)
endif
enddo
enddo
accu_nd = dsqrt(accu_nd)
print*, ' accu_d = ', accu_d
print*, ' accu_nd = ', accu_nd
end subroutine LTxR
! ---
! --- ! ---
subroutine minimize_tc_orb_angles() subroutine minimize_tc_orb_angles()
BEGIN_DOC
! routine that minimizes the angle between left- and right-orbitals when degeneracies are found
END_DOC
implicit none implicit none
logical :: good_angles logical :: good_angles

9
src/tc_scf/tc_scf_dm.irp.f
View File

@ -2,6 +2,9 @@
BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num) ] BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num) ]
BEGIN_DOC
! TC-SCF transition density matrix on the AO basis for BETA electrons
END_DOC
implicit none implicit none
if(bi_ortho) then if(bi_ortho) then
@ -16,6 +19,9 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num) ] BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num) ]
BEGIN_DOC
! TC-SCF transition density matrix on the AO basis for ALPHA electrons
END_DOC
implicit none implicit none
if(bi_ortho) then if(bi_ortho) then
@ -31,6 +37,9 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_tot, (ao_num, ao_num) ] BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_tot, (ao_num, ao_num) ]
implicit none implicit none
BEGIN_DOC
! TC-SCF transition density matrix on the AO basis for ALPHA+BETA electrons
END_DOC
TCSCF_density_matrix_ao_tot = TCSCF_density_matrix_ao_beta + TCSCF_density_matrix_ao_alpha TCSCF_density_matrix_ao_tot = TCSCF_density_matrix_ao_beta + TCSCF_density_matrix_ao_alpha
END_PROVIDER END_PROVIDER

43
src/tc_scf/tc_scf_utils.irp.f
View File

@ -1,43 +0,0 @@
! ---
subroutine LTxSxR(n, m, L, S, R, C)
implicit none
integer, intent(in) :: n, m
double precision, intent(in) :: L(n,m), S(n,n), R(n,m)
double precision, intent(out) :: C(m,m)
integer :: i, j
double precision :: accu_d, accu_nd
double precision, allocatable :: tmp(:,:)
! L.T x S x R
allocate(tmp(m,n))
call dgemm( 'T', 'N', m, n, n, 1.d0 &
, L, size(L, 1), S, size(S, 1) &
, 0.d0, tmp, size(tmp, 1) )
call dgemm( 'N', 'N', m, m, n, 1.d0 &
, tmp, size(tmp, 1), R, size(R, 1) &
, 0.d0, C, size(C, 1) )
deallocate(tmp)
accu_d = 0.d0
accu_nd = 0.d0
do i = 1, m
do j = 1, m
if(j.eq.i) then
accu_d += dabs(C(j,i))
else
accu_nd += C(j,i) * C(j,i)
endif
enddo
enddo
accu_nd = dsqrt(accu_nd)
print*, ' accu_d = ', accu_d
print*, ' accu_nd = ', accu_nd
end subroutine LTxR
! ---

13
src/tc_scf/test_Ne.sh
View File

@ -1,13 +0,0 @@
QP_ROOT=/home/eginer/new_qp2/qp2
source ${QP_ROOT}/quantum_package.rc
echo Ne > Ne.xyz
echo $QP_ROOT
qp create_ezfio -b cc-pcvdz Ne.xyz -o Ne_tc_scf
qp run scf
qp set tc_keywords bi_ortho True
qp set ao_two_e_erf_ints mu_erf 0.87
qp set tc_keywords j1b_pen [1.5]
qp set tc_keywords j1b_type 3
qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
grep "TC energy =" Ne.ezfio.tc_scf.out | tail -1
eref=-128.552134

1003
src/tc_scf/test_int.irp.f
View File

File diff suppressed because it is too large Load Diff