mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-12-12 22:53:29 +01:00
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
Some checks failed
continuous-integration/drone/push Build is failing
This commit is contained in:
parent
ca4cdf56d5
commit
a4bb488d64
4
src/tc_scf/EZFIO.cfg
Normal file
4
src/tc_scf/EZFIO.cfg
Normal file
@ -0,0 +1,4 @@
|
||||
[bitc_energy]
|
||||
type: Threshold
|
||||
doc: Energy bi-tc HF
|
||||
interface: ezfio
|
6
src/tc_scf/NEED
Normal file
6
src/tc_scf/NEED
Normal 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
74
src/tc_scf/combine_lr_tcscf.irp.f
Normal 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
229
src/tc_scf/diago_bi_ort_tcfock.irp.f
Normal 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
186
src/tc_scf/diis_tcscf.irp.f
Normal 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
405
src/tc_scf/fock_3e_bi_ortho_uhf.irp.f
Normal 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
107
src/tc_scf/fock_for_right.irp.f
Normal 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
307
src/tc_scf/fock_tc.irp.f
Normal 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
144
src/tc_scf/fock_tc_mo_tot.irp.f
Normal 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 |