mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-06-19 03:37:08 +02:00
97 lines
2.1 KiB
Fortran
97 lines
2.1 KiB
Fortran
|
|
! ---
|
|
|
|
BEGIN_PROVIDER [ double precision, fock_vartc_eigvec_mo, (mo_num, mo_num)]
|
|
|
|
implicit none
|
|
|
|
integer :: i, j
|
|
integer :: liwork, lwork, n, info
|
|
integer, allocatable :: iwork(:)
|
|
double precision, allocatable :: work(:), F(:,:), F_save(:,:)
|
|
double precision, allocatable :: diag(:)
|
|
|
|
PROVIDE mo_r_coef
|
|
PROVIDE Fock_matrix_vartc_mo_tot
|
|
|
|
allocate( F(mo_num,mo_num), F_save(mo_num,mo_num) )
|
|
allocate (diag(mo_num) )
|
|
|
|
do j = 1, mo_num
|
|
do i = 1, mo_num
|
|
F(i,j) = Fock_matrix_vartc_mo_tot(i,j)
|
|
enddo
|
|
enddo
|
|
|
|
! Insert level shift here
|
|
do i = elec_beta_num+1, elec_alpha_num
|
|
F(i,i) += 0.5d0 * level_shift_tcscf
|
|
enddo
|
|
do i = elec_alpha_num+1, mo_num
|
|
F(i,i) += level_shift_tcscf
|
|
enddo
|
|
|
|
n = mo_num
|
|
lwork = 1+6*n + 2*n*n
|
|
liwork = 3 + 5*n
|
|
|
|
allocate(work(lwork))
|
|
allocate(iwork(liwork) )
|
|
|
|
lwork = -1
|
|
liwork = -1
|
|
|
|
F_save = F
|
|
call dsyevd('V', 'U', mo_num, F, size(F, 1), diag, work, lwork, iwork, liwork, info)
|
|
|
|
if (info /= 0) then
|
|
print *, irp_here//' DSYEVD failed : ', info
|
|
stop 1
|
|
endif
|
|
lwork = int(work(1))
|
|
liwork = iwork(1)
|
|
deallocate(iwork)
|
|
deallocate(work)
|
|
|
|
allocate(work(lwork))
|
|
allocate(iwork(liwork) )
|
|
call dsyevd('V', 'U', mo_num, F, size(F, 1), diag, work, lwork, iwork, liwork, info)
|
|
deallocate(iwork)
|
|
|
|
if (info /= 0) then
|
|
F = F_save
|
|
call dsyev('V', 'L', mo_num, F, size(F, 1), diag, work, lwork, info)
|
|
|
|
if (info /= 0) then
|
|
print *, irp_here//' DSYEV failed : ', info
|
|
stop 1
|
|
endif
|
|
endif
|
|
|
|
do i = 1, mo_num
|
|
do j = 1, mo_num
|
|
fock_vartc_eigvec_mo(j,i) = F(j,i)
|
|
enddo
|
|
enddo
|
|
|
|
deallocate(work, F, F_save, diag)
|
|
|
|
END_PROVIDER
|
|
|
|
! ---
|
|
|
|
BEGIN_PROVIDER [ double precision, fock_vartc_eigvec_ao, (ao_num, mo_num)]
|
|
|
|
implicit none
|
|
|
|
PROVIDE mo_r_coef
|
|
|
|
call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
|
|
, mo_r_coef, size(mo_r_coef, 1), fock_vartc_eigvec_mo, size(fock_vartc_eigvec_mo, 1) &
|
|
, 0.d0, fock_vartc_eigvec_ao, size(fock_vartc_eigvec_ao, 1))
|
|
|
|
END_PROVIDER
|
|
|
|
! ---
|
|
|