mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-06-19 03:37:08 +02:00
213 lines
6.0 KiB
Fortran
213 lines
6.0 KiB
Fortran
|
|
! ---
|
|
|
|
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
|
|
integer :: i, j
|
|
double precision :: t0, t1
|
|
double precision, allocatable :: tmp(:,:)
|
|
double precision, allocatable :: F(:,:)
|
|
|
|
!print *, ' Providing FQS_SQF_ao ...'
|
|
!call wall_time(t0)
|
|
|
|
allocate(F(ao_num,ao_num))
|
|
if(var_tc) then
|
|
|
|
do i = 1, ao_num
|
|
do j = 1, ao_num
|
|
F(j,i) = Fock_matrix_vartc_ao_tot(j,i)
|
|
enddo
|
|
enddo
|
|
|
|
else
|
|
|
|
PROVIDE Fock_matrix_tc_ao_tot
|
|
do i = 1, ao_num
|
|
do j = 1, ao_num
|
|
F(j,i) = Fock_matrix_tc_ao_tot(j,i)
|
|
enddo
|
|
enddo
|
|
|
|
endif
|
|
|
|
allocate(tmp(ao_num,ao_num))
|
|
|
|
! F x Q
|
|
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
|
, F, size(F, 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), F, size(F, 1) &
|
|
, 1.d0, FQS_SQF_ao, size(FQS_SQF_ao, 1) )
|
|
|
|
deallocate(tmp)
|
|
deallocate(F)
|
|
|
|
!call wall_time(t1)
|
|
!print *, ' Wall time for FQS_SQF_ao =', t1-t0
|
|
|
|
END_PROVIDER
|
|
|
|
! ---
|
|
|
|
BEGIN_PROVIDER [double precision, FQS_SQF_mo, (mo_num, mo_num)]
|
|
|
|
implicit none
|
|
double precision :: t0, t1
|
|
|
|
!print*, ' Providing FQS_SQF_mo ...'
|
|
!call wall_time(t0)
|
|
|
|
PROVIDE mo_r_coef mo_l_coef
|
|
PROVIDE FQS_SQF_ao
|
|
|
|
call ao_to_mo_bi_ortho( FQS_SQF_ao, size(FQS_SQF_ao, 1) &
|
|
, FQS_SQF_mo, size(FQS_SQF_mo, 1) )
|
|
|
|
!call wall_time(t1)
|
|
!print*, ' Wall time for FQS_SQF_mo =', t1-t0
|
|
|
|
END_PROVIDER
|
|
|
|
! ---
|
|
|
|
! BEGIN_PROVIDER [ double precision, eigenval_Fock_tc_ao, (ao_num) ]
|
|
!&BEGIN_PROVIDER [ double precision, eigenvec_Fock_tc_ao, (ao_num,ao_num) ]
|
|
!
|
|
! BEGIN_DOC
|
|
! !
|
|
! ! Eigenvalues and eigenvectors of the Fock matrix over the ao basis
|
|
! !
|
|
! ! F' = X.T x F x X where X = ao_overlap^(-1/2)
|
|
! !
|
|
! ! F' x Cr' = Cr' x E ==> F Cr = Cr x E with Cr = X x Cr'
|
|
! ! F'.T x Cl' = Cl' x E ==> F.T Cl = Cl x E with Cl = X x Cl'
|
|
! !
|
|
! END_DOC
|
|
!
|
|
! implicit none
|
|
! double precision, allocatable :: tmp1(:,:), tmp2(:,:)
|
|
!
|
|
! ! ---
|
|
! ! Fock matrix in orthogonal basis: F' = X.T x F x X
|
|
!
|
|
! allocate(tmp1(ao_num,ao_num))
|
|
! call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
|
! , Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1), S_half_inv, size(S_half_inv, 1) &
|
|
! , 0.d0, tmp1, size(tmp1, 1) )
|
|
!
|
|
! allocate(tmp2(ao_num,ao_num))
|
|
! call dgemm( 'T', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
|
! , S_half_inv, size(S_half_inv, 1), tmp1, size(tmp1, 1) &
|
|
! , 0.d0, tmp2, size(tmp2, 1) )
|
|
!
|
|
! ! ---
|
|
!
|
|
! ! Diagonalize F' to obtain eigenvectors in orthogonal basis C' and eigenvalues
|
|
! ! TODO
|
|
!
|
|
! ! Back-transform eigenvectors: C =X.C'
|
|
!
|
|
!END_PROVIDER
|
|
|
|
! ---
|
|
|
|
~
|