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

tc_scf compiles and gives good energy for Ne. Added a test in test_Ne.sh
Some checks failed
continuous-integration/drone/push Build is failing
Details

Browse Source
This commit is contained in:
eginer 2023-02-06 19:26:58 +01:00
parent ca4cdf56d5
commit a4bb488d64
33 changed files with 6498 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/tc_scf/EZFIO.cfg Normal file
View File

@ -0,0 +1,4 @@
[bitc_energy]
type: Threshold
doc: Energy bi-tc HF
interface: ezfio

6
src/tc_scf/NEED Normal file
View File

@ -0,0 +1,6 @@
hartree_fock
bi_ortho_mos
three_body_ints
bi_ort_ints
tc_keywords
non_hermit_dav

74
src/tc_scf/combine_lr_tcscf.irp.f Normal file
View File

@ -0,0 +1,74 @@
! ---
program combine_lr_tcscf
BEGIN_DOC
! TODO : Put the documentation of the program here
END_DOC
implicit none
my_grid_becke = .True.
my_n_pt_r_grid = 30
my_n_pt_a_grid = 50
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
! ---

229
src/tc_scf/diago_bi_ort_tcfock.irp.f Normal file
View File

@ -0,0 +1,229 @@
! ---
BEGIN_PROVIDER [ double precision, fock_tc_reigvec_mo, (mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, fock_tc_leigvec_mo, (mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, eigval_fock_tc_mo, (mo_num)]
&BEGIN_PROVIDER [ double precision, overlap_fock_tc_eigvec_mo, (mo_num, mo_num)]
BEGIN_DOC
! EIGENVECTORS OF FOCK MATRIX ON THE MO BASIS and their OVERLAP
END_DOC
implicit none
integer :: n_real_tc
integer :: i, j, k, l
double precision :: accu_d, accu_nd, accu_tmp
double precision :: norm
double precision, allocatable :: eigval_right_tmp(:)
double precision, allocatable :: F_tmp(:,:)
allocate( eigval_right_tmp(mo_num), F_tmp(mo_num,mo_num) )
PROVIDE Fock_matrix_tc_mo_tot
do i = 1, mo_num
do j = 1, mo_num
F_tmp(j,i) = Fock_matrix_tc_mo_tot(j,i)
enddo
enddo
! insert level shift here
do i = elec_beta_num+1, elec_alpha_num
F_tmp(i,i) += 0.5d0 * level_shift_tcscf
enddo
do i = elec_alpha_num+1, mo_num
F_tmp(i,i) += level_shift_tcscf
enddo
call non_hrmt_bieig( mo_num, F_tmp, thresh_biorthog_diag, thresh_biorthog_nondiag &
, fock_tc_leigvec_mo, fock_tc_reigvec_mo &
, 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)
! 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
! 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
call dgemm( "T", "N", mo_num, mo_num, mo_num, 1.d0 &
, fock_tc_leigvec_mo, size(fock_tc_leigvec_mo, 1) &
, fock_tc_reigvec_mo, size(fock_tc_reigvec_mo, 1) &
, 0.d0, overlap_fock_tc_eigvec_mo, size(overlap_fock_tc_eigvec_mo, 1) )
! ---
accu_d = 0.d0
accu_nd = 0.d0
do i = 1, mo_num
do k = 1, mo_num
if(i==k) then
accu_tmp = overlap_fock_tc_eigvec_mo(k,i)
accu_d += dabs(accu_tmp )
else
accu_tmp = overlap_fock_tc_eigvec_mo(k,i)
accu_nd += accu_tmp * accu_tmp
if(dabs(overlap_fock_tc_eigvec_mo(k,i)) .gt. thresh_biorthog_nondiag)then
print *, 'k,i', k, i, overlap_fock_tc_eigvec_mo(k,i)
endif
endif
enddo
enddo
accu_nd = dsqrt(accu_nd) / accu_d
if(accu_nd .gt. thresh_biorthog_nondiag) then
print *, ' bi-orthog failed'
print *, ' accu_nd MO = ', accu_nd, thresh_biorthog_nondiag
print *, ' overlap_fock_tc_eigvec_mo = '
do i = 1, mo_num
write(*,'(100(F16.10,X))') overlap_fock_tc_eigvec_mo(i,:)
enddo
stop
endif
! ---
if(dabs(accu_d - dble(mo_num))/dble(mo_num) .gt. thresh_biorthog_diag) then
print *, ' mo_num = ', mo_num
print *, ' accu_d MO = ', accu_d, thresh_biorthog_diag
print *, ' normalizing vectors ...'
do i = 1, mo_num
norm = dsqrt(dabs(overlap_fock_tc_eigvec_mo(i,i)))
if(norm .gt. thresh_biorthog_diag) then
do k = 1, mo_num
fock_tc_reigvec_mo(k,i) *= 1.d0/norm
fock_tc_leigvec_mo(k,i) *= 1.d0/norm
enddo
endif
enddo
call dgemm( "T", "N", mo_num, mo_num, mo_num, 1.d0 &
, fock_tc_leigvec_mo, size(fock_tc_leigvec_mo, 1) &
, fock_tc_reigvec_mo, size(fock_tc_reigvec_mo, 1) &
, 0.d0, overlap_fock_tc_eigvec_mo, size(overlap_fock_tc_eigvec_mo, 1) )
accu_d = 0.d0
accu_nd = 0.d0
do i = 1, mo_num
do k = 1, mo_num
if(i==k) then
accu_tmp = overlap_fock_tc_eigvec_mo(k,i)
accu_d += dabs(accu_tmp)
else
accu_tmp = overlap_fock_tc_eigvec_mo(k,i)
accu_nd += accu_tmp * accu_tmp
if(dabs(overlap_fock_tc_eigvec_mo(k,i)) .gt. thresh_biorthog_nondiag)then
print *, 'k,i', k, i, overlap_fock_tc_eigvec_mo(k,i)
endif
endif
enddo
enddo
accu_nd = dsqrt(accu_nd) / accu_d
if(accu_nd .gt. thresh_biorthog_diag) then
print *, ' bi-orthog failed'
print *, ' accu_nd MO = ', accu_nd, thresh_biorthog_nondiag
print *, ' overlap_fock_tc_eigvec_mo = '
do i = 1, mo_num
write(*,'(100(F16.10,X))') overlap_fock_tc_eigvec_mo(i,:)
enddo
stop
endif
endif
! ---
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, fock_tc_reigvec_ao, (ao_num, mo_num)]
&BEGIN_PROVIDER [ double precision, fock_tc_leigvec_ao, (ao_num, mo_num)]
&BEGIN_PROVIDER [ double precision, overlap_fock_tc_eigvec_ao, (mo_num, mo_num) ]
BEGIN_DOC
! EIGENVECTORS OF FOCK MATRIX ON THE AO BASIS and their OVERLAP
!
! THE OVERLAP SHOULD BE THE SAME AS overlap_fock_tc_eigvec_mo
END_DOC
implicit none
integer :: i, j, k, q, p
double precision :: accu, accu_d
double precision, allocatable :: tmp(:,:)
PROVIDE mo_l_coef mo_r_coef
! ! MO_R x R
call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
, mo_r_coef, size(mo_r_coef, 1) &
, fock_tc_reigvec_mo, size(fock_tc_reigvec_mo, 1) &
, 0.d0, fock_tc_reigvec_ao, size(fock_tc_reigvec_ao, 1) )
! MO_L x L
call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
, mo_l_coef, size(mo_l_coef, 1) &
, fock_tc_leigvec_mo, size(fock_tc_leigvec_mo, 1) &
, 0.d0, fock_tc_leigvec_ao, size(fock_tc_leigvec_ao, 1) )
allocate( tmp(mo_num,ao_num) )
! tmp <-- L.T x S_ao
call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
, fock_tc_leigvec_ao, size(fock_tc_leigvec_ao, 1), ao_overlap, size(ao_overlap, 1) &
, 0.d0, tmp, size(tmp, 1) )
! S <-- tmp x R
call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
, tmp, size(tmp, 1), fock_tc_reigvec_ao, size(fock_tc_reigvec_ao, 1) &
, 0.d0, overlap_fock_tc_eigvec_ao, size(overlap_fock_tc_eigvec_ao, 1) )
deallocate( tmp )
! ---
double precision :: norm
do i = 1, mo_num
norm = 1.d0/dsqrt(dabs(overlap_fock_tc_eigvec_ao(i,i)))
do j = 1, mo_num
fock_tc_reigvec_ao(j,i) *= norm
fock_tc_leigvec_ao(j,i) *= norm
enddo
enddo
allocate( tmp(mo_num,ao_num) )
! tmp <-- L.T x S_ao
call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
, fock_tc_leigvec_ao, size(fock_tc_leigvec_ao, 1), ao_overlap, size(ao_overlap, 1) &
, 0.d0, tmp, size(tmp, 1) )
! S <-- tmp x R
call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
, tmp, size(tmp, 1), fock_tc_reigvec_ao, size(fock_tc_reigvec_ao, 1) &
, 0.d0, overlap_fock_tc_eigvec_ao, size(overlap_fock_tc_eigvec_ao, 1) )
deallocate( tmp )
END_PROVIDER

186
src/tc_scf/diis_tcscf.irp.f Normal file
View File

@ -0,0 +1,186 @@
! ---
BEGIN_PROVIDER [ double precision, threshold_DIIS_nonzero_TCSCF ]
implicit none
if(threshold_DIIS_TCSCF == 0.d0) then
threshold_DIIS_nonzero_TCSCF = dsqrt(thresh_tcscf)
else
threshold_DIIS_nonzero_TCSCF = threshold_DIIS_TCSCF
endif
ASSERT(threshold_DIIS_nonzero_TCSCF >= 0.d0)
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, Q_alpha, (ao_num, ao_num) ]
BEGIN_DOC
!
! Q_alpha = mo_r_coef x eta_occ_alpha x mo_l_coef.T
!
! [Q_alpha]_ij = \sum_{k=1}^{elec_alpha_num} [mo_r_coef]_ik [mo_l_coef]_jk
!
END_DOC
implicit none
Q_alpha = 0.d0
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
, 0.d0, Q_alpha, size(Q_alpha, 1) )
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, Q_beta, (ao_num, ao_num) ]
BEGIN_DOC
!
! Q_beta = mo_r_coef x eta_occ_beta x mo_l_coef.T
!
! [Q_beta]_ij = \sum_{k=1}^{elec_beta_num} [mo_r_coef]_ik [mo_l_coef]_jk
!
END_DOC
implicit none
Q_beta = 0.d0
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
, 0.d0, Q_beta, size(Q_beta, 1) )
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, Q_matrix, (ao_num, ao_num) ]
BEGIN_DOC
!
! Q_matrix = 2 mo_r_coef x eta_occ x mo_l_coef.T
!
! with:
! | 1 if i = j = 1, ..., nb of occ orbitals
! [eta_occ]_ij = |
! | 0 otherwise
!
! the diis error is defines as:
! e = F_ao x Q x ao_overlap - ao_overlap x Q x F_ao
! with:
! mo_l_coef.T x ao_overlap x mo_r_coef = I
! F_mo = mo_l_coef.T x F_ao x mo_r_coef
! F_ao = (ao_overlap x mo_r_coef) x F_mo x (ao_overlap x mo_l_coef).T
!
! ==> e = 2 ao_overlap x mo_r_coef x [ F_mo x eta_occ - eta_occ x F_mo ] x (ao_overlap x mo_l_coef).T
!
! at convergence:
! F_mo x eta_occ - eta_occ x F_mo = 0
! ==> [F_mo]_ij ([eta_occ]_ii - [eta_occ]_jj) = 0
! ==> [F_mo]_ia = [F_mo]_ai = 0 where: i = occ and a = vir
! ==> Brillouin conditions
!
END_DOC
implicit none
if(elec_alpha_num == elec_beta_num) then
Q_matrix = Q_alpha + Q_alpha
else
Q_matrix = Q_alpha + Q_beta
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
implicit none
double precision, allocatable :: tmp(:,:)
allocate(tmp(ao_num,ao_num))
! F x Q
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
, Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1), Q_matrix, size(Q_matrix, 1) &
, 0.d0, tmp, size(tmp, 1) )
! F x Q x S
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
, tmp, size(tmp, 1), ao_overlap, size(ao_overlap, 1) &
, 0.d0, FQS_SQF_ao, size(FQS_SQF_ao, 1) )
! S x Q
tmp = 0.d0
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
, ao_overlap, size(ao_overlap, 1), Q_matrix, size(Q_matrix, 1) &
, 0.d0, tmp, size(tmp, 1) )
! F x Q x S - S x Q x F
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, -1.d0 &
, tmp, size(tmp, 1), Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1) &
, 1.d0, FQS_SQF_ao, size(FQS_SQF_ao, 1) )
deallocate(tmp)
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, FQS_SQF_mo, (mo_num, mo_num)]
implicit none
call ao_to_mo_bi_ortho( FQS_SQF_ao, size(FQS_SQF_ao, 1) &
, FQS_SQF_mo, size(FQS_SQF_mo, 1) )
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
! ---
~

405
src/tc_scf/fock_3e_bi_ortho_uhf.irp.f Normal file
View File

@ -0,0 +1,405 @@
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (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
PROVIDE mo_l_coef mo_r_coef
!print *, ' PROVIDING fock_3e_uhf_mo_cs ...'
call wall_time(ti)
fock_3e_uhf_mo_cs = 0.d0
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)
fock_3e_uhf_mo_cs(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
call wall_time(tf)
!print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
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
PROVIDE mo_l_coef mo_r_coef
!print *, ' PROVIDING fock_3e_uhf_mo_a ...'
call wall_time(ti)
o = elec_beta_num + 1
fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs
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)
fock_3e_uhf_mo_a(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)
fock_3e_uhf_mo_a(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)
fock_3e_uhf_mo_a(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
call wall_time(tf)
!print *, ' total Wall time for fock_3e_uhf_mo_a =', tf - ti
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
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
PROVIDE mo_l_coef mo_r_coef
!print *, ' PROVIDING fock_3e_uhf_mo_b ...'
call wall_time(ti)
o = elec_beta_num + 1
fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs
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)
fock_3e_uhf_mo_b(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)
fock_3e_uhf_mo_b(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)
fock_3e_uhf_mo_b(b,a) -= 0.5d0 * ( I_bij_aij &
- I_bij_aji )
enddo
enddo
! ---
enddo
enddo
call wall_time(tf)
!print *, ' total Wall time for fock_3e_uhf_mo_b =', 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
! ---

107
src/tc_scf/fock_for_right.irp.f Normal file
View File

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

307
src/tc_scf/fock_tc.irp.f Normal file
View File

@ -0,0 +1,307 @@
! ---
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_DOC
!
! two_e_tc_non_hermit_integral_seq_alpha(k,i) = <k| F^tc_alpha |i>
!
! where F^tc is the two-body part of the TC Fock matrix and k,i are AO basis functions
!
END_DOC
implicit none
integer :: i, j, k, l
double precision :: density, density_a, density_b
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_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_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>
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) = <k| F^tc_alpha |i>
!
! where F^tc is the two-body part of the TC Fock matrix and k,i are AO basis functions
!
END_DOC
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(:,:)
!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
!$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)
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_tc_non_hermit_integral_alpha(j,i) += tmp_a(j,i)
two_e_tc_non_hermit_integral_beta (j,i) += tmp_b(j,i)
enddo
enddo
!$OMP END CRITICAL
deallocate(tmp_a, tmp_b)
!$OMP END PARALLEL
!call wall_time(t1)
!print*, ' wall time for two_e_tc_non_hermit_integral after = ', t1 - t0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_alpha, (ao_num, ao_num)]
BEGIN_DOC
! Total alpha TC Fock matrix : h_c + Two-e^TC terms on the AO basis
END_DOC
implicit none
Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_alpha
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_beta, (ao_num, ao_num)]
BEGIN_DOC
! Total beta TC Fock matrix : h_c + Two-e^TC terms on the AO basis
END_DOC
implicit none
Fock_matrix_tc_ao_beta = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_beta
END_PROVIDER
! ---
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
END_DOC
implicit none
double precision, allocatable :: tmp(:,:)
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) &
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
if(three_body_h_tc) then
!Fock_matrix_tc_mo_alpha += fock_a_tot_3e_bi_orth
Fock_matrix_tc_mo_alpha += fock_3e_uhf_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) )
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ]
BEGIN_DOC
! Total beta TC Fock matrix : h_c + Two-e^TC terms on the MO basis
END_DOC
implicit none
double precision, allocatable :: tmp(:,:)
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) &
, Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
if(three_body_h_tc) then
!Fock_matrix_tc_mo_beta += fock_b_tot_3e_bi_orth
Fock_matrix_tc_mo_beta += fock_3e_uhf_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) )
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, grad_non_hermit_left]
&BEGIN_PROVIDER [ double precision, grad_non_hermit_right]
&BEGIN_PROVIDER [ double precision, grad_non_hermit]
implicit none
integer :: i, k
grad_non_hermit_left = 0.d0
grad_non_hermit_right = 0.d0
do i = 1, elec_beta_num ! doc --> SOMO
do k = elec_beta_num+1, elec_alpha_num
grad_non_hermit_left = max(grad_non_hermit_left , dabs(Fock_matrix_tc_mo_tot(k,i)))
grad_non_hermit_right = max(grad_non_hermit_right, dabs(Fock_matrix_tc_mo_tot(i,k)))
!grad_non_hermit_left += dabs(Fock_matrix_tc_mo_tot(k,i))
!grad_non_hermit_right += dabs(Fock_matrix_tc_mo_tot(i,k))
!grad_non_hermit_left += Fock_matrix_tc_mo_tot(k,i) * Fock_matrix_tc_mo_tot(k,i)
!grad_non_hermit_right += Fock_matrix_tc_mo_tot(i,k) * Fock_matrix_tc_mo_tot(i,k)
enddo
enddo
do i = 1, elec_beta_num ! doc --> virt
do k = elec_alpha_num+1, mo_num
grad_non_hermit_left = max(grad_non_hermit_left , dabs(Fock_matrix_tc_mo_tot(k,i)))
grad_non_hermit_right = max(grad_non_hermit_right, dabs(Fock_matrix_tc_mo_tot(i,k)))
!grad_non_hermit_left += dabs(Fock_matrix_tc_mo_tot(k,i))
!grad_non_hermit_right += dabs(Fock_matrix_tc_mo_tot(i,k))
grad_non_hermit_left += Fock_matrix_tc_mo_tot(k,i) * Fock_matrix_tc_mo_tot(k,i)
grad_non_hermit_right += Fock_matrix_tc_mo_tot(i,k) * Fock_matrix_tc_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_non_hermit_left = max(grad_non_hermit_left , dabs(Fock_matrix_tc_mo_tot(k,i)))
grad_non_hermit_right = max(grad_non_hermit_right, dabs(Fock_matrix_tc_mo_tot(i,k)))
!grad_non_hermit_left += dabs(Fock_matrix_tc_mo_tot(k,i))
!grad_non_hermit_right += dabs(Fock_matrix_tc_mo_tot(i,k))
grad_non_hermit_left += Fock_matrix_tc_mo_tot(k,i) * Fock_matrix_tc_mo_tot(k,i)
grad_non_hermit_right += Fock_matrix_tc_mo_tot(i,k) * Fock_matrix_tc_mo_tot(i,k)
enddo
enddo
!grad_non_hermit = dsqrt(grad_non_hermit_left) + dsqrt(grad_non_hermit_right)
grad_non_hermit = grad_non_hermit_left + grad_non_hermit_right
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_tot, (ao_num, ao_num) ]
implicit none
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) )
END_PROVIDER
! ---

144
src/tc_scf/fock_tc_mo_tot.irp.f Normal file
View File

@ -0,0 +1,144 @@
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)]
implicit none
BEGIN_DOC
! Fock matrix on the MO