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

merged version: ok

Browse Source
This commit is contained in:
AbdAmmar 2022-10-31 19:14:27 +01:00
parent 0bea180fc6
commit 8bed36e93e
11 changed files with 1442 additions and 562 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
src/bi_ortho_mos/overlap.irp.f
View File

@ -76,14 +76,16 @@ END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, overlap_mo_r, (mo_num, mo_num)] BEGIN_PROVIDER [ double precision, overlap_mo_r, (mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, overlap_mo_l, (mo_num, mo_num)] &BEGIN_PROVIDER [ double precision, overlap_mo_l, (mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
! overlap_mo_r_mo(j,i) = <MO_i|MO_R_j> ! overlap_mo_r_mo(j,i) = <MO_i|MO_R_j>
END_DOC END_DOC
implicit none
integer :: i, j, p, q integer :: i, j, p, q
overlap_mo_r = 0.d0 overlap_mo_r = 0.d0
overlap_mo_l = 0.d0 overlap_mo_l = 0.d0
do i = 1, mo_num do i = 1, mo_num
@ -96,15 +98,21 @@ END_PROVIDER
enddo enddo
enddo enddo
enddo enddo
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, overlap_mo_r_mo, (mo_num, mo_num)] BEGIN_PROVIDER [ double precision, overlap_mo_r_mo, (mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, overlap_mo_l_mo, (mo_num, mo_num)] &BEGIN_PROVIDER [ double precision, overlap_mo_l_mo, (mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
! overlap_mo_r_mo(j,i) = <MO_j|MO_R_i> ! overlap_mo_r_mo(j,i) = <MO_j|MO_R_i>
END_DOC END_DOC
implicit none
integer :: i, j, p, q integer :: i, j, p, q
overlap_mo_r_mo = 0.d0 overlap_mo_r_mo = 0.d0
overlap_mo_l_mo = 0.d0 overlap_mo_l_mo = 0.d0
do i = 1, mo_num do i = 1, mo_num
@ -117,16 +125,23 @@ END_PROVIDER
enddo enddo
enddo enddo
enddo enddo
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, angle_left_right, (mo_num)] BEGIN_PROVIDER [ double precision, angle_left_right, (mo_num)]
&BEGIN_PROVIDER [ double precision, max_angle_left_right] &BEGIN_PROVIDER [ double precision, max_angle_left_right]
implicit none
BEGIN_DOC BEGIN_DOC
! angle_left_right(i) = angle between the left-eigenvector chi_i and the right-eigenvector phi_i ! angle_left_right(i) = angle between the left-eigenvector chi_i and the right-eigenvector phi_i
END_DOC END_DOC
implicit none
integer :: i, j integer :: i, j
double precision :: left, right, arg double precision :: left, right, arg
double precision :: angle(mo_num)
do i = 1, mo_num do i = 1, mo_num
left = overlap_mo_l(i,i) left = overlap_mo_l(i,i)
right = overlap_mo_r(i,i) right = overlap_mo_r(i,i)
@ -134,9 +149,12 @@ END_PROVIDER
arg = max(arg, -1.d0) arg = max(arg, -1.d0)
angle_left_right(i) = dacos(arg) * 180.d0/dacos(-1.d0) angle_left_right(i) = dacos(arg) * 180.d0/dacos(-1.d0)
enddo enddo
double precision :: angle(mo_num)
angle(1:mo_num) = dabs(angle_left_right(1:mo_num)) angle(1:mo_num) = dabs(angle_left_right(1:mo_num))
max_angle_left_right = maxval(angle) max_angle_left_right = maxval(angle)
END_PROVIDER END_PROVIDER
! ---

3
src/cipsi/selection.irp.f
View File

@ -732,7 +732,10 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
if (delta_E < 0.d0) then if (delta_E < 0.d0) then
tmp = -tmp tmp = -tmp
endif endif
!e_pert(istate) = alpha_h_psi * alpha_h_psi / (E0(istate) - Hii)
e_pert(istate) = 0.5d0 * (tmp - delta_E) e_pert(istate) = 0.5d0 * (tmp - delta_E)
if (dabs(alpha_h_psi) > 1.d-4) then if (dabs(alpha_h_psi) > 1.d-4) then
coef(istate) = e_pert(istate) / alpha_h_psi coef(istate) = e_pert(istate) / alpha_h_psi
else else

25
src/non_hermit_dav/biorthog.irp.f
View File

@ -252,7 +252,7 @@ end subroutine non_hrmt_real_diag_new
! --- ! ---
subroutine non_hrmt_bieig(n, A, leigvec, reigvec, n_real_eigv, eigval) subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, eigval)
BEGIN_DOC BEGIN_DOC
! !
@ -266,13 +266,14 @@ subroutine non_hrmt_bieig(n, A, leigvec, reigvec, n_real_eigv, eigval)
implicit none implicit none
integer, intent(in) :: n integer, intent(in) :: n
double precision, intent(in) :: A(n,n) double precision, intent(in) :: A(n,n)
double precision, intent(in) :: thr_d, thr_nd
integer, intent(out) :: n_real_eigv integer, intent(out) :: n_real_eigv
double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n) double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
integer :: i, j integer :: i, j
integer :: n_good integer :: n_good
double precision :: thr, thr_cut, thr_diag, thr_norm double precision :: thr, thr_cut, thr_diag, thr_norm
double precision :: accu_d, accu_nd, thr_d, thr_nd double precision :: accu_d, accu_nd
integer, allocatable :: list_good(:), iorder(:) integer, allocatable :: list_good(:), iorder(:)
double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:) double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:)
@ -393,22 +394,22 @@ subroutine non_hrmt_bieig(n, A, leigvec, reigvec, n_real_eigv, eigval)
! ------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------
! check bi-orthogonality ! check bi-orthogonality
thr_d = 1d-10 ! -7 thr_diag = 10.d0
thr_nd = 1d-10 ! -7 thr_norm = 1d+10
allocate( S(n_real_eigv,n_real_eigv) ) allocate( S(n_real_eigv,n_real_eigv) )
call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, .false.) call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .false.)
if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv)) .lt. thr_d) ) then if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv))/dble(n_real_eigv) .lt. thr_d) ) then
print *, ' lapack vectors are normalized and bi-orthogonalized' print *, ' lapack vectors are normalized and bi-orthogonalized'
deallocate(S) deallocate(S)
return return
elseif( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv)) .gt. thr_d) ) then elseif( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv))/dble(n_real_eigv) .gt. thr_d) ) then
print *, ' lapack vectors are not normalized but bi-orthogonalized' print *, ' lapack vectors are not normalized but bi-orthogonalized'
call check_biorthog_binormalize(n, n_real_eigv, leigvec, reigvec, .true.) call check_biorthog_binormalize(n, n_real_eigv, leigvec, reigvec, thr_d, thr_nd, .true.)
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.) call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.)
@ -427,17 +428,17 @@ subroutine non_hrmt_bieig(n, A, leigvec, reigvec, n_real_eigv, eigval)
call impose_biorthog_degen_eigvec(n, eigval, leigvec, reigvec) call impose_biorthog_degen_eigvec(n, eigval, leigvec, reigvec)
!call impose_orthog_biorthog_degen_eigvec(n, eigval, leigvec, reigvec) !call impose_orthog_biorthog_degen_eigvec(n, thr_d, thr_nd, eigval, leigvec, reigvec)
!call impose_unique_biorthog_degen_eigvec(n, eigval, mo_coef, ao_overlap, leigvec, reigvec) !call impose_unique_biorthog_degen_eigvec(n, eigval, mo_coef, ao_overlap, leigvec, reigvec)
! --- ! ---
call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, .false.) call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .false.)
if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv)) .gt. thr_d) ) then if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv)) .gt. thr_d) ) then
call check_biorthog_binormalize(n, n_real_eigv, leigvec, reigvec, .true.) call check_biorthog_binormalize(n, n_real_eigv, leigvec, reigvec, thr_d, thr_nd, .true.)
endif endif
call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, .true.) call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .true.)
!call impose_biorthog_qr(n, n_real_eigv, leigvec, reigvec) !call impose_biorthog_qr(n, n_real_eigv, leigvec, reigvec)
!call impose_biorthog_lu(n, n_real_eigv, leigvec, reigvec) !call impose_biorthog_lu(n, n_real_eigv, leigvec, reigvec)

359
src/non_hermit_dav/lapack_diag_non_hermit.irp.f
View File

@ -573,21 +573,22 @@ end subroutine non_hrmt_general_real_diag
! --- ! ---
subroutine impose_biorthog_qr(m, n, Vl, Vr) subroutine impose_biorthog_qr(m, n, thr_d, thr_nd, Vl, Vr)
implicit none implicit none
integer, intent(in) :: m, n integer, intent(in) :: m, n
double precision, intent(in) :: thr_d, thr_nd
double precision, intent(inout) :: Vl(m,n), Vr(m,n) double precision, intent(inout) :: Vl(m,n), Vr(m,n)
integer :: i, j integer :: i, j
integer :: LWORK, INFO integer :: LWORK, INFO
double precision :: accu_nd, accu_d, thr_nd, thr_d double precision :: accu_nd, accu_d
double precision, allocatable :: TAU(:), WORK(:) double precision, allocatable :: TAU(:), WORK(:)
double precision, allocatable :: S(:,:), R(:,:), tmp(:,:) double precision, allocatable :: S(:,:), R(:,:), tmp(:,:)
! --- ! ---
call check_biorthog_binormalize(m, n, Vl, Vr, .false.) call check_biorthog_binormalize(m, n, Vl, Vr, thr_d, thr_nd, .false.)
! --- ! ---
@ -609,9 +610,7 @@ subroutine impose_biorthog_qr(m, n, Vl, Vr)
enddo enddo
accu_nd = dsqrt(accu_nd) accu_nd = dsqrt(accu_nd)
thr_d = 1d-10 if((accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n))/dble(n) .lt. thr_d)) then
thr_nd = 1d-08
if((accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n)) .lt. thr_d)) then
print *, ' bi-orthogonal vectors without QR !' print *, ' bi-orthogonal vectors without QR !'
deallocate(S) deallocate(S)
return return
@ -1011,7 +1010,7 @@ subroutine check_degen(n, m, eigval, leigvec, reigvec)
double precision :: ei, ej, de, de_thr, accu_nd double precision :: ei, ej, de, de_thr, accu_nd
double precision, allocatable :: S(:,:) double precision, allocatable :: S(:,:)
de_thr = 1d-7 de_thr = 1d-6
do i = 1, m-1 do i = 1, m-1
ei = eigval(i) ei = eigval(i)
@ -1082,7 +1081,7 @@ subroutine impose_weighted_orthog_svd(n, m, W, C)
double precision, allocatable :: S(:,:), tmp(:,:) double precision, allocatable :: S(:,:), tmp(:,:)
double precision, allocatable :: U(:,:), Vt(:,:), D(:) double precision, allocatable :: U(:,:), Vt(:,:), D(:)
print *, ' apply SVD to orthogonalize vectors' print *, ' apply SVD to orthogonalize & normalize weighted vectors'
! --- ! ---
@ -1097,7 +1096,7 @@ subroutine impose_weighted_orthog_svd(n, m, W, C)
, 0.d0, S, size(S, 1) ) , 0.d0, S, size(S, 1) )
deallocate(tmp) deallocate(tmp)
print *, ' eigenvec overlap bef SVD: ' print *, ' overlap bef SVD: '
do i = 1, m do i = 1, m
write(*, '(1000(F16.10,X))') S(i,:) write(*, '(1000(F16.10,X))') S(i,:)
enddo enddo
@ -1160,7 +1159,7 @@ subroutine impose_weighted_orthog_svd(n, m, W, C)
, 0.d0, S, size(S, 1) ) , 0.d0, S, size(S, 1) )
deallocate(tmp) deallocate(tmp)
print *, ' eigenvec overlap aft SVD: ' print *, ' overlap aft SVD: '
do i = 1, m do i = 1, m
write(*, '(1000(F16.10,X))') S(i,:) write(*, '(1000(F16.10,X))') S(i,:)
enddo enddo
@ -1185,7 +1184,7 @@ subroutine impose_orthog_svd(n, m, C)
double precision, allocatable :: S(:,:), tmp(:,:) double precision, allocatable :: S(:,:), tmp(:,:)
double precision, allocatable :: U(:,:), Vt(:,:), D(:) double precision, allocatable :: U(:,:), Vt(:,:), D(:)
print *, ' apply SVD to orthogonalize vectors' print *, ' apply SVD to orthogonalize & normalize vectors'
! --- ! ---
@ -1379,7 +1378,7 @@ subroutine impose_orthog_GramSchmidt(n, m, C)
double precision, allocatable :: S(:,:) double precision, allocatable :: S(:,:)
print *, '' print *, ''
print *, ' apply Gram-Schmidt to orthogonalize vectors' print *, ' apply Gram-Schmidt to orthogonalize & normalize vectors'
print *, '' print *, ''
! --- ! ---
@ -1663,22 +1662,19 @@ end subroutine get_halfinv_svd
! --- ! ---
subroutine check_biorthog_binormalize(n, m, Vl, Vr, stop_ifnot) subroutine check_biorthog_binormalize(n, m, Vl, Vr, thr_d, thr_nd, stop_ifnot)
implicit none implicit none
integer, intent(in) :: n, m integer, intent(in) :: n, m
logical, intent(in) :: stop_ifnot logical, intent(in) :: stop_ifnot
double precision, intent(in) :: thr_d, thr_nd
double precision, intent(inout) :: Vl(n,m), Vr(n,m) double precision, intent(inout) :: Vl(n,m), Vr(n,m)
integer :: i, j integer :: i, j
double precision :: thr_d, thr_nd
double precision :: accu_d, accu_nd, s_tmp double precision :: accu_d, accu_nd, s_tmp
double precision, allocatable :: S(:,:) double precision, allocatable :: S(:,:)
thr_d = 1d-6
thr_nd = 1d-7
print *, ' check bi-orthonormality' print *, ' check bi-orthonormality'
! --- ! ---
@ -1713,7 +1709,7 @@ subroutine check_biorthog_binormalize(n, m, Vl, Vr, stop_ifnot)
endif endif
enddo enddo
enddo enddo
accu_nd = dsqrt(accu_nd) accu_nd = dsqrt(accu_nd) / dble(m)
print*, ' diag acc: ', accu_d print*, ' diag acc: ', accu_d
print*, ' nondiag acc: ', accu_nd print*, ' nondiag acc: ', accu_nd
@ -1755,7 +1751,7 @@ subroutine check_biorthog_binormalize(n, m, Vl, Vr, stop_ifnot)
endif endif
enddo enddo
enddo enddo
accu_nd = dsqrt(accu_nd) accu_nd = dsqrt(accu_nd) / dble(m)
print *, ' diag acc: ', accu_d print *, ' diag acc: ', accu_d
print *, ' nondiag acc: ', accu_nd print *, ' nondiag acc: ', accu_nd
@ -1774,22 +1770,19 @@ end subroutine check_biorthog_binormalize
! --- ! ---
subroutine check_weighted_biorthog(n, m, W, Vl, Vr, accu_d, accu_nd, S, stop_ifnot) subroutine check_weighted_biorthog(n, m, W, Vl, Vr, thr_d, thr_nd, accu_d, accu_nd, S, stop_ifnot)
implicit none implicit none
integer, intent(in) :: n, m integer, intent(in) :: n, m
double precision, intent(in) :: Vl(n,m), Vr(n,m), W(n,n) double precision, intent(in) :: Vl(n,m), Vr(n,m), W(n,n)
double precision, intent(in) :: thr_d, thr_nd
logical, intent(in) :: stop_ifnot logical, intent(in) :: stop_ifnot
double precision, intent(out) :: accu_d, accu_nd, S(m,m) double precision, intent(out) :: accu_d, accu_nd, S(m,m)
integer :: i, j integer :: i, j
double precision :: thr_d, thr_nd
double precision, allocatable :: SS(:,:), tmp(:,:) double precision, allocatable :: SS(:,:), tmp(:,:)
thr_d = 1d-6
thr_nd = 1d-08
print *, ' check weighted bi-orthogonality' print *, ' check weighted bi-orthogonality'
! --- ! ---
@ -1841,22 +1834,19 @@ end subroutine check_weighted_biorthog
! --- ! ---
subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, stop_ifnot) subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ifnot)
implicit none implicit none
integer, intent(in) :: n, m integer, intent(in) :: n, m
double precision, intent(in) :: Vl(n,m), Vr(n,m) double precision, intent(in) :: Vl(n,m), Vr(n,m)
logical, intent(in) :: stop_ifnot logical, intent(in) :: stop_ifnot
double precision, intent(in) :: thr_d, thr_nd
double precision, intent(out) :: accu_d, accu_nd, S(m,m) double precision, intent(out) :: accu_d, accu_nd, S(m,m)
integer :: i, j integer :: i, j
double precision :: thr_d, thr_nd
double precision, allocatable :: SS(:,:) double precision, allocatable :: SS(:,:)
thr_d = 1d-6
thr_nd = 1d-08
print *, ' check bi-orthogonality' print *, ' check bi-orthogonality'
! --- ! ---
@ -1880,7 +1870,7 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, stop_ifnot)
endif endif
enddo enddo
enddo enddo
accu_nd = dsqrt(accu_nd) accu_nd = dsqrt(accu_nd) / dble(m)
print *, ' accu_nd = ', accu_nd print *, ' accu_nd = ', accu_nd
print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m) print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m)
@ -2029,7 +2019,7 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
call impose_biorthog_svd(n, m, L, R) call impose_biorthog_svd(n, m, L, R)
!call impose_biorthog_qr(n, m, L, R) !call impose_biorthog_qr(n, m, thr_d, thr_nd, L, R)
! --- ! ---
@ -2047,11 +2037,12 @@ end subroutine impose_biorthog_degen_eigvec
! --- ! ---
subroutine impose_orthog_biorthog_degen_eigvec(n, e0, L0, R0) subroutine impose_orthog_biorthog_degen_eigvec(n, thr_d, thr_nd, e0, L0, R0)
implicit none implicit none
integer, intent(in) :: n integer, intent(in) :: n
double precision, intent(in) :: thr_d, thr_nd
double precision, intent(in) :: e0(n) double precision, intent(in) :: e0(n)
double precision, intent(inout) :: L0(n,n), R0(n,n) double precision, intent(inout) :: L0(n,n), R0(n,n)
@ -2116,12 +2107,12 @@ subroutine impose_orthog_biorthog_degen_eigvec(n, e0, L0, R0)
! --- ! ---
call impose_biorthog_qr(n, m, L, R) call impose_biorthog_qr(n, m, thr_d, thr_nd, L, R)
allocate(S(m,m)) allocate(S(m,m))
call check_biorthog(n, m, L, R, accu_d, accu_nd, S, .true.) call check_biorthog(n, m, L, R, accu_d, accu_nd, S, thr_d, thr_nd, .true.)
!call check_biorthog(n, m, L, L, accu_d, accu_nd, S, .true.) !call check_biorthog(n, m, L, L, accu_d, accu_nd, S, thr_d, thr_nd, .true.)
!call check_biorthog(n, m, R, R, accu_d, accu_nd, S, .false.) !call check_biorthog(n, m, R, R, accu_d, accu_nd, S, thr_d, thr_nd, .false.)
deallocate(S) deallocate(S)
! --- ! ---
@ -2140,11 +2131,12 @@ end subroutine impose_orthog_biorthog_degen_eigvec
! --- ! ---
subroutine impose_unique_biorthog_degen_eigvec(n, e0, C0, W0, L0, R0) subroutine impose_unique_biorthog_degen_eigvec(n, thr_d, thr_nd, e0, C0, W0, L0, R0)
implicit none implicit none
integer, intent(in) :: n integer, intent(in) :: n
double precision, intent(in) :: thr_d, thr_nd
double precision, intent(in) :: e0(n), W0(n,n), C0(n,n) double precision, intent(in) :: e0(n), W0(n,n), C0(n,n)
double precision, intent(inout) :: L0(n,n), R0(n,n) double precision, intent(inout) :: L0(n,n), R0(n,n)
@ -2255,7 +2247,7 @@ subroutine impose_unique_biorthog_degen_eigvec(n, e0, C0, W0, L0, R0)
call get_inv_half_nonsymmat_diago(S, m, S_inv_half, complex_root) call get_inv_half_nonsymmat_diago(S, m, S_inv_half, complex_root)
if(complex_root)then if(complex_root)then
call impose_biorthog_svd(n, m, L, R) call impose_biorthog_svd(n, m, L, R)
!call impose_biorthog_qr(n, m, L, R) !call impose_biorthog_qr(n, m, thr_d, thr_nd, L, R)
else else
call bi_ortho_s_inv_half(m, L, R, S_inv_half) call bi_ortho_s_inv_half(m, L, R, S_inv_half)
endif endif
@ -2502,8 +2494,288 @@ end subroutine impose_biorthog_svd
! --- ! ---
subroutine impose_weighted_biorthog_qr(m, n, thr_d, thr_nd, Vl, W, Vr)
subroutine impose_biorthog_svd_overlap(n, m, overlap, L, R) implicit none
integer, intent(in) :: m, n
double precision, intent(in) :: thr_d, thr_nd
double precision, intent(inout) :: Vl(m,n), W(m,m), Vr(m,n)
integer :: i, j
integer :: LWORK, INFO
double precision :: accu_nd, accu_d
double precision, allocatable :: TAU(:), WORK(:)
double precision, allocatable :: S(:,:), R(:,:), tmp(:,:), Stmp(:,:)
call check_weighted_biorthog_binormalize(m, n, Vl, W, Vr, thr_d, thr_nd, .false.)
! ---
allocate(Stmp(n,m), S(n,n))
call dgemm( 'T', 'N', n, m, m, 1.d0 &
, Vl, size(Vl, 1), W, size(W, 1) &
, 0.d0, Stmp, size(Stmp, 1) )
call dgemm( 'N', 'N', n, n, m, 1.d0 &
, Stmp, size(Stmp, 1), Vr, size(Vr, 1) &
, 0.d0, S, size(S, 1) )
deallocate(Stmp)
accu_nd = 0.d0
accu_d = 0.d0
do i = 1, n
do j = 1, n
if(i==j) then
accu_d += S(j,i)
else
accu_nd = accu_nd + S(j,i) * S(j,i)
endif
enddo
enddo
accu_nd = dsqrt(accu_nd)
if((accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n))/dble(n) .lt. thr_d)) then
print *, ' bi-orthogonal vectors without QR !'
deallocate(S)
return
endif
! -------------------------------------------------------------------------------------
! QR factorization of S: S = Q x R
print *, ' apply QR decomposition ...'
allocate( TAU(n), WORK(1) )
LWORK = -1
call dgeqrf(n, n, S, n, TAU, WORK, LWORK, INFO)
if(INFO .ne. 0) then
print*,'dgeqrf failed !!', INFO
stop
endif
LWORK = max(n, int(WORK(1)))
deallocate(WORK)
allocate( WORK(LWORK) )
call dgeqrf(n, n, S, n, TAU, WORK, LWORK, INFO)
if(INFO .ne. 0) then
print*,'dgeqrf failed !!', INFO
stop
endif
! save the upper triangular R
allocate( R(n,n) )
R(:,:) = S(:,:)
! get Q
LWORK = -1
call dorgqr(n, n, n, S, n, TAU, WORK, LWORK, INFO)
if(INFO .ne. 0) then
print*,'dorgqr failed !!', INFO
stop
endif
LWORK = max(n, int(WORK(1)))
deallocate(WORK)
allocate( WORK(LWORK) )
call dorgqr(n, n, n, S, n, TAU, WORK, LWORK, INFO)
if(INFO .ne. 0) then
print*,'dorgqr failed !!', INFO
stop
endif
deallocate( WORK, TAU )
!
! -------------------------------------------------------------------------------------
! ---
! -------------------------------------------------------------------------------------
! get bi-orhtog left & right vectors:
! Vr' = Vr x inv(R)
! Vl' = inv(Q) x Vl = Q.T x Vl
! Q.T x Vl, where Q = S
allocate( tmp(n,m) )
call dgemm( 'T', 'T', n, m, n, 1.d0 &
, S, size(S, 1), Vl, size(Vl, 1) &
, 0.d0, tmp, size(tmp, 1) )
do i = 1, n
do j = 1, m
Vl(j,i) = tmp(i,j)
enddo
enddo
deallocate(tmp)
! ---
! inv(R)
!print *, ' inversing upper triangular matrix ...'
call dtrtri("U", "N", n, R, n, INFO)
if(INFO .ne. 0) then
print*,'dtrtri failed !!', INFO
stop
endif
!print *, ' inversing upper triangular matrix OK'
do i = 1, n-1
do j = i+1, n
R(j,i) = 0.d0
enddo
enddo
!print *, ' inv(R):'
!do i = 1, n
! write(*, '(1000(F16.10,X))') R(i,:)
!enddo
! Vr x inv(R)
allocate( tmp(m,n) )
call dgemm( 'N', 'N', m, n, n, 1.d0 &
, Vr, size(Vr, 1), R, size(R, 1) &
, 0.d0, tmp, size(tmp, 1) )
deallocate( R )
do i = 1, n
do j = 1, m
Vr(j,i) = tmp(j,i)
enddo
enddo
deallocate(tmp)
call check_weighted_biorthog_binormalize(m, n, Vl, W, Vr, thr_d, thr_nd, .false.)
return
end subroutine impose_weighted_biorthog_qr
! ---
subroutine check_weighted_biorthog_binormalize(n, m, Vl, W, Vr, thr_d, thr_nd, stop_ifnot)
implicit none
integer, intent(in) :: n, m
logical, intent(in) :: stop_ifnot
double precision, intent(in) :: thr_d, thr_nd
double precision, intent(inout) :: Vl(n,m), W(n,n), Vr(n,m)
integer :: i, j
double precision :: accu_d, accu_nd, s_tmp
double precision, allocatable :: S(:,:), Stmp(:,:)
print *, ' check weighted bi-orthonormality'
! ---
allocate(Stmp(m,n), S(m,m))
call dgemm( 'T', 'N', m, n, n, 1.d0 &
, Vl, size(Vl, 1), W, size(W, 1) &
, 0.d0, Stmp, size(Stmp, 1) )
call dgemm( 'N', 'N', m, m, n, 1.d0 &
, Stmp, size(Stmp, 1), Vr, size(Vr, 1) &
, 0.d0, S, size(S, 1) )
deallocate(Stmp)
!print *, ' overlap matrix before:'
!do i = 1, m
! write(*,'(1000(F16.10,X))') S(i,:)
!enddo
! S(i,i) = -1
do i = 1, m
if( (S(i,i) + 1.d0) .lt. thr_d ) then
do j = 1, n
Vl(j,i) = -1.d0 * Vl(j,i)
enddo
S(i,i) = 1.d0
endif
enddo
accu_d = 0.d0
accu_nd = 0.d0
do i = 1, m
do j = 1, m
if(i==j) then
accu_d = accu_d + S(i,i)
else
accu_nd = accu_nd + S(j,i) * S(j,i)
endif
enddo
enddo
accu_nd = dsqrt(accu_nd) / dble(m)
print*, ' diag acc: ', accu_d
print*, ' nondiag acc: ', accu_nd
! ---
if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(m))/dble(m) .gt. thr_d) ) then
do i = 1, m
print *, i, S(i,i)
if(dabs(S(i,i) - 1.d0) .gt. thr_d) then
s_tmp = 1.d0 / dsqrt(S(i,i))
do j = 1, n
Vl(j,i) = Vl(j,i) * s_tmp
Vr(j,i) = Vr(j,i) * s_tmp
enddo
endif
enddo
endif
! ---
allocate(Stmp(m,n))
call dgemm( 'T', 'N', m, n, n, 1.d0 &
, Vl, size(Vl, 1), W, size(W, 1) &
, 0.d0, Stmp, size(Stmp, 1) )
call dgemm( 'N', 'N', m, m, n, 1.d0 &
, Stmp, size(Stmp, 1), Vr, size(Vr, 1) &
, 0.d0, S, size(S, 1) )
deallocate(Stmp)
!print *, ' overlap matrix after:'
!do i = 1, m
! write(*,'(1000(F16.10,X))') S(i,:)
!enddo
accu_d = 0.d0
accu_nd = 0.d0
do i = 1, m
do j = 1, m
if(i==j) then
accu_d = accu_d + S(i,i)
else
accu_nd = accu_nd + S(j,i) * S(j,i)
endif
enddo
enddo
accu_nd = dsqrt(accu_nd) / dble(m)
print *, ' diag acc: ', accu_d
print *, ' nondiag acc: ', accu_nd
deallocate(S)
! ---
if( stop_ifnot .and. ((accu_nd .gt. thr_nd) .or. (dabs(accu_d-dble(m))/dble(m) .gt. thr_d)) ) then
print *, accu_nd, thr_nd
print *, dabs(accu_d-dble(m))/dble(m), thr_d
print *, ' weighted biorthog_binormalize failed !'
stop
endif
end subroutine check_weighted_biorthog_binormalize
! ---
subroutine impose_weighted_biorthog_svd(n, m, overlap, L, R)
implicit none implicit none
@ -2527,6 +2799,7 @@ subroutine impose_biorthog_svd_overlap(n, m, overlap, L, R)
call dgemm( 'T', 'N', m, m, n, 1.d0 & call dgemm( 'T', 'N', m, m, n, 1.d0 &
, L, size(L, 1), Stmp, size(Stmp, 1) & , L, size(L, 1), Stmp, size(Stmp, 1) &
, 0.d0, S, size(S, 1) ) , 0.d0, S, size(S, 1) )
deallocate(Stmp)
print *, ' overlap bef SVD: ' print *, ' overlap bef SVD: '
do i = 1, m do i = 1, m
@ -2598,10 +2871,7 @@ subroutine impose_biorthog_svd_overlap(n, m, overlap, L, R)
! --- ! ---
allocate(S(m,m)) allocate(S(m,m),Stmp(n,m))
! call dgemm( 'T', 'N', m, m, n, 1.d0 &
! , L, size(L, 1), R, size(R, 1) &
! , 0.d0, S, size(S, 1) )
! S = C.T x overlap x C ! S = C.T x overlap x C
call dgemm( 'N', 'N', n, m, n, 1.d0 & call dgemm( 'N', 'N', n, m, n, 1.d0 &
, overlap, size(overlap, 1), R, size(R, 1) & , overlap, size(overlap, 1), R, size(R, 1) &
@ -2609,6 +2879,7 @@ subroutine impose_biorthog_svd_overlap(n, m, overlap, L, R)
call dgemm( 'T', 'N', m, m, n, 1.d0 & call dgemm( 'T', 'N', m, m, n, 1.d0 &
, L, size(L, 1), Stmp, size(Stmp, 1) & , L, size(L, 1), Stmp, size(Stmp, 1) &
, 0.d0, S, size(S, 1) ) , 0.d0, S, size(S, 1) )
deallocate(Stmp)
print *, ' overlap aft SVD with overlap: ' print *, ' overlap aft SVD with overlap: '
do i = 1, m do i = 1, m
@ -2618,7 +2889,7 @@ subroutine impose_biorthog_svd_overlap(n, m, overlap, L, R)
! --- ! ---
end subroutine impose_biorthog_svd end subroutine impose_weighted_biorthog_svd
! --- ! ---

47
src/tc_bi_ortho/tc_natorb.irp.f
View File

@ -1,37 +1,50 @@
! ---
BEGIN_PROVIDER [ double precision, natorb_tc_reigvec_mo, (mo_num, mo_num)] BEGIN_PROVIDER [ double precision, natorb_tc_reigvec_mo, (mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, natorb_tc_leigvec_mo, (mo_num, mo_num)] &BEGIN_PROVIDER [ double precision, natorb_tc_leigvec_mo, (mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, natorb_tc_eigval, (mo_num)] &BEGIN_PROVIDER [ double precision, natorb_tc_eigval, (mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
!
! natorb_tc_reigvec_mo : RIGHT eigenvectors of the ground state transition matrix (equivalent of natural orbitals) ! natorb_tc_reigvec_mo : RIGHT eigenvectors of the ground state transition matrix (equivalent of natural orbitals)
! natorb_tc_leigvec_mo : LEFT eigenvectors of the ground state transition matrix (equivalent of natural orbitals) ! natorb_tc_leigvec_mo : LEFT eigenvectors of the ground state transition matrix (equivalent of natural orbitals)
! natorb_tc_eigval : eigenvalues of the ground state transition matrix (equivalent of the occupation numbers). WARNINING :: can be negative !! ! natorb_tc_eigval : eigenvalues of the ground state transition matrix (equivalent of the occupation numbers). WARNINING :: can be negative !!
!
END_DOC END_DOC
double precision, allocatable :: dm_tmp(:,:),fock_diag(:)
double precision :: thr_deg implicit none
integer :: i, j, k, n_real integer :: i, j, k, n_real
double precision :: thr_d, thr_nd, thr_deg, accu
double precision :: accu_d, accu_nd
double precision, allocatable :: dm_tmp(:,:), fock_diag(:)
allocate(dm_tmp(mo_num,mo_num), fock_diag(mo_num)) allocate(dm_tmp(mo_num,mo_num), fock_diag(mo_num))
dm_tmp(:,:) = -tc_transition_matrix(:,:,1,1) dm_tmp(:,:) = -tc_transition_matrix(:,:,1,1)
print *, ' dm_tmp' print *, ' dm_tmp'
do i = 1, mo_num do i = 1, mo_num
fock_diag(i) = fock_matrix_tc_mo_tot(i,i) fock_diag(i) = fock_matrix_tc_mo_tot(i,i)
write(*, '(100(F16.10,X))') -dm_tmp(:,i) write(*, '(100(F16.10,X))') -dm_tmp(:,i)
enddo enddo
thr_d = 1.d-6
thr_nd = 1.d-6
thr_deg = 1.d-3 thr_deg = 1.d-3
call diag_mat_per_fock_degen(fock_diag,dm_tmp,mo_num,thr_deg,& call diag_mat_per_fock_degen( fock_diag, dm_tmp, mo_num, thr_d, thr_nd, thr_deg &
natorb_tc_leigvec_mo,natorb_tc_reigvec_mo,& , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo, natorb_tc_eigval)
natorb_tc_eigval)
! call non_hrmt_bieig( mo_num, dm_tmp& ! call non_hrmt_bieig( mo_num, dm_tmp&
! , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo& ! , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo&
! , n_real, natorb_tc_eigval ) ! , n_real, natorb_tc_eigval )
double precision :: accu
accu = 0.d0 accu = 0.d0
do i = 1, n_real do i = 1, n_real
print*,'natorb_tc_eigval(i) = ',-natorb_tc_eigval(i) print*,'natorb_tc_eigval(i) = ',-natorb_tc_eigval(i)
accu += -natorb_tc_eigval(i) accu += -natorb_tc_eigval(i)
enddo enddo
print *, ' accu = ', accu print *, ' accu = ', accu
dm_tmp = 0.d0 dm_tmp = 0.d0
do i = 1, n_real do i = 1, n_real
accu = 0.d0 accu = 0.d0
@ -47,7 +60,7 @@
enddo enddo
enddo enddo
enddo enddo
double precision :: accu_d, accu_nd
accu_d = 0.d0 accu_d = 0.d0
accu_nd = 0.d0 accu_nd = 0.d0
do i = 1, mo_num do i = 1, mo_num
@ -61,19 +74,27 @@
print *, ' Trace of the overlap between TC natural orbitals ', accu_d print *, ' Trace of the overlap between TC natural orbitals ', accu_d
print *, ' L1 norm of extra diagonal elements of overlap matrix ', accu_nd print *, ' L1 norm of extra diagonal elements of overlap matrix ', accu_nd
deallocate(dm_tmp, fock_diag)
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, fock_diag_sorted_r_natorb, (mo_num, mo_num)] BEGIN_PROVIDER [ double precision, fock_diag_sorted_r_natorb, (mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, fock_diag_sorted_l_natorb, (mo_num, mo_num)] &BEGIN_PROVIDER [ double precision, fock_diag_sorted_l_natorb, (mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, fock_diag_sorted_v_natorb, (mo_num)] &BEGIN_PROVIDER [ double precision, fock_diag_sorted_v_natorb, (mo_num)]
implicit none implicit none
integer :: i,j,k integer :: i,j,k
integer, allocatable :: iorder(:)
double precision, allocatable :: fock_diag(:)
print *, ' Diagonal elements of the Fock matrix before ' print *, ' Diagonal elements of the Fock matrix before '
do i = 1, mo_num do i = 1, mo_num
write(*,*) i, Fock_matrix_tc_mo_tot(i,i) write(*,*) i, Fock_matrix_tc_mo_tot(i,i)
enddo enddo
double precision, allocatable :: fock_diag(:)
allocate(fock_diag(mo_num)) allocate(fock_diag(mo_num))
fock_diag = 0.d0 fock_diag = 0.d0
do i = 1, mo_num do i = 1, mo_num
@ -84,16 +105,19 @@
enddo enddo
enddo enddo
enddo enddo
integer, allocatable :: iorder(:)
allocate(iorder(mo_num)) allocate(iorder(mo_num))
do i = 1, mo_num do i = 1, mo_num
iorder(i) = i iorder(i) = i
enddo enddo
call dsort(fock_diag, iorder, mo_num) call dsort(fock_diag, iorder, mo_num)
print *, ' Diagonal elements of the Fock matrix after ' print *, ' Diagonal elements of the Fock matrix after '
do i = 1, mo_num do i = 1, mo_num
write(*,*) i, fock_diag(i) write(*,*) i, fock_diag(i)
enddo enddo
deallocate(fock_diag)
do i = 1, mo_num do i = 1, mo_num
fock_diag_sorted_v_natorb(i) = natorb_tc_eigval(iorder(i)) fock_diag_sorted_v_natorb(i) = natorb_tc_eigval(iorder(i))
do j = 1, mo_num do j = 1, mo_num
@ -101,10 +125,11 @@
fock_diag_sorted_l_natorb(j,i) = natorb_tc_leigvec_mo(j,iorder(i)) fock_diag_sorted_l_natorb(j,i) = natorb_tc_leigvec_mo(j,iorder(i))
enddo enddo
enddo enddo
deallocate(iorder)
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, natorb_tc_reigvec_ao, (ao_num, mo_num)] BEGIN_PROVIDER [ double precision, natorb_tc_reigvec_ao, (ao_num, mo_num)]
&BEGIN_PROVIDER [ double precision, natorb_tc_leigvec_ao, (ao_num, mo_num)] &BEGIN_PROVIDER [ double precision, natorb_tc_leigvec_ao, (ao_num, mo_num)]

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

@ -11,18 +11,22 @@
integer :: n_real_tc integer :: n_real_tc
integer :: i, k, l integer :: i, k, l
double precision :: accu_d, accu_nd, accu_tmp double precision :: accu_d, accu_nd, accu_tmp
double precision :: thr_d, thr_nd
double precision :: norm double precision :: norm
double precision, allocatable :: eigval_right_tmp(:) double precision, allocatable :: eigval_right_tmp(:)
thr_d = 1d-6
thr_nd = 1d-6
allocate( eigval_right_tmp(mo_num) ) allocate( eigval_right_tmp(mo_num) )
PROVIDE Fock_matrix_tc_mo_tot PROVIDE Fock_matrix_tc_mo_tot
call non_hrmt_bieig( mo_num, Fock_matrix_tc_mo_tot & call non_hrmt_bieig( mo_num, Fock_matrix_tc_mo_tot, thr_d, thr_nd &
, 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 !if(max_ov_tc_scf)then
! call non_hrmt_fock_mat( mo_num, Fock_matrix_tc_mo_tot & ! call non_hrmt_fock_mat( mo_num, Fock_matrix_tc_mo_tot, thr_d, thr_nd &
! , 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 )
!else !else
@ -59,7 +63,7 @@
else else
accu_tmp = overlap_fock_tc_eigvec_mo(k,i) accu_tmp = overlap_fock_tc_eigvec_mo(k,i)
accu_nd += accu_tmp * accu_tmp accu_nd += accu_tmp * accu_tmp
if(dabs(overlap_fock_tc_eigvec_mo(k,i)).gt.1.d-10)then if(dabs(overlap_fock_tc_eigvec_mo(k,i)) .gt. thr_nd)then
print *, 'k,i', k, i, overlap_fock_tc_eigvec_mo(k,i) print *, 'k,i', k, i, overlap_fock_tc_eigvec_mo(k,i)
endif endif
endif endif
@ -67,9 +71,9 @@
enddo enddo
accu_nd = dsqrt(accu_nd)/accu_d accu_nd = dsqrt(accu_nd)/accu_d
if( accu_nd .gt. 1d-8 ) then if(accu_nd .gt. thr_nd) then
print *, ' bi-orthog failed' print *, ' bi-orthog failed'
print*,'accu_nd MO = ', accu_nd print*,'accu_nd MO = ', accu_nd, thr_nd
print*,'overlap_fock_tc_eigvec_mo = ' print*,'overlap_fock_tc_eigvec_mo = '
do i = 1, mo_num do i = 1, mo_num
write(*,'(100(F16.10,X))') overlap_fock_tc_eigvec_mo(i,:) write(*,'(100(F16.10,X))') overlap_fock_tc_eigvec_mo(i,:)
@ -77,13 +81,13 @@
stop stop
endif endif
if( dabs(accu_d - dble(mo_num)) .gt. 1e-7 ) then if( dabs(accu_d - dble(mo_num))/dble(mo_num) .gt. thr_d ) then
print *, 'mo_num = ', mo_num print *, 'mo_num = ', mo_num
print *, 'accu_d MO = ', accu_d print *, 'accu_d MO = ', accu_d, thr_d
print *, 'normalizing vectors ...' print *, 'normalizing vectors ...'
do i = 1, mo_num do i = 1, mo_num
norm = dsqrt(dabs(overlap_fock_tc_eigvec_mo(i,i))) norm = dsqrt(dabs(overlap_fock_tc_eigvec_mo(i,i)))
if( norm.gt.1e-7 ) then if(norm .gt. thr_d) then
do k = 1, mo_num do k = 1, mo_num
fock_tc_reigvec_mo(k,i) *= 1.d0/norm fock_tc_reigvec_mo(k,i) *= 1.d0/norm
fock_tc_leigvec_mo(k,i) *= 1.d0/norm fock_tc_leigvec_mo(k,i) *= 1.d0/norm

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

@ -116,17 +116,23 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ]
endif endif
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_tot, (mo_num, mo_num)] BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_tot, (mo_num, mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
! Total alpha+beta TC Fock matrix : h_c + Two-e^TC terms on the MO basis ! Total alpha+beta TC Fock matrix : h_c + Two-e^TC terms on the MO basis
END_DOC END_DOC
implicit none
Fock_matrix_tc_mo_tot = 0.5d0 * (Fock_matrix_tc_mo_alpha + Fock_matrix_tc_mo_beta) Fock_matrix_tc_mo_tot = 0.5d0 * (Fock_matrix_tc_mo_alpha + Fock_matrix_tc_mo_beta)
if(three_body_h_tc) then if(three_body_h_tc) then
Fock_matrix_tc_mo_tot += fock_3_mat Fock_matrix_tc_mo_tot += fock_3_mat
endif endif
!call restore_symmetry(mo_num, mo_num, Fock_matrix_tc_mo_tot, mo_num, 1.d-10) !call restore_symmetry(mo_num, mo_num, Fock_matrix_tc_mo_tot, mo_num, 1.d-10)
END_PROVIDER END_PROVIDER
! --- ! ---

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

@ -73,7 +73,7 @@ subroutine maximize_overlap()
! --- ! ---
call rotate_degen_eigvec(n, m, e, C, W, L, R) call rotate_degen_eigvec_to_maximize_overlap(n, m, e, C, W, L, R)
! --- ! ---
@ -115,7 +115,7 @@ end subroutine maximize_overlap
! --- ! ---
subroutine rotate_degen_eigvec(n, m, e0, C0, W0, L0, R0) subroutine rotate_degen_eigvec_to_maximize_overlap(n, m, e0, C0, W0, L0, R0)
implicit none implicit none
@ -124,7 +124,7 @@ subroutine rotate_degen_eigvec(n, m, e0, C0, W0, L0, R0)
double precision, intent(inout) :: L0(n,m), R0(n,m) double precision, intent(inout) :: L0(n,m), R0(n,m)
integer :: i, j, k, kk, mm, id1 integer :: i, j, k, kk, mm, id1, tot_deg
double precision :: ei, ej, de, de_thr double precision :: ei, ej, de, de_thr
integer, allocatable :: deg_num(:) integer, allocatable :: deg_num(:)
double precision, allocatable :: L(:,:), R(:,:), C(:,:), Lnew(:,:), Rnew(:,:), tmp(:,:) double precision, allocatable :: L(:,:), R(:,:), C(:,:), Lnew(:,:), Rnew(:,:), tmp(:,:)
@ -162,12 +162,19 @@ subroutine rotate_degen_eigvec(n, m, e0, C0, W0, L0, R0)
enddo enddo
enddo enddo
tot_deg = 0
do i = 1, m do i = 1, m
if(deg_num(i).gt.1) then if(deg_num(i).gt.1) then
print *, ' degen on', i, deg_num(i) print *, ' degen on', i, deg_num(i)
tot_deg = tot_deg + 1
endif endif
enddo enddo
if(tot_deg .eq. 0) then
print *, ' no degen'
return
endif
! --- ! ---
do i = 1, m do i = 1, m
@ -243,6 +250,122 @@ subroutine rotate_degen_eigvec(n, m, e0, C0, W0, L0, R0)
deallocate(S, Snew, T) deallocate(S, Snew, T)
end subroutine rotate_degen_eigvec end subroutine rotate_degen_eigvec_to_maximize_overlap
! ---
subroutine fix_right_to_one()
implicit none
integer :: i, j, m, n, mm, tot_deg
double precision :: accu_d, accu_nd
double precision :: de_thr, ei, ej, de
double precision :: thr_d, thr_nd
integer, allocatable :: deg_num(:)
double precision, allocatable :: R0(:,:), L0(:,:), W(:,:), e0(:)
double precision, allocatable :: R(:,:), L(:,:), S(:,:), Stmp(:,:), tmp(:,:)
thr_d = 1d-7
thr_nd = 1d-7
n = ao_num
m = mo_num
allocate(L0(n,m), R0(n,m), W(n,n), e0(m))
L0 = mo_l_coef
R0 = mo_r_coef
W = ao_overlap
print*, ' fock matrix diag elements'
do i = 1, m
e0(i) = Fock_matrix_tc_mo_tot(i,i)
print*, e0(i)
enddo
! ---
allocate( deg_num(m) )
do i = 1, m
deg_num(i) = 1
enddo
de_thr = 1d-6
do i = 1, m-1
ei = e0(i)
! already considered in degen vectors
if(deg_num(i).eq.0) cycle
do j = i+1, m
ej = e0(j)
de = dabs(ei - ej)
if(de .lt. de_thr) then
deg_num(i) = deg_num(i) + 1
deg_num(j) = 0
endif
enddo
enddo
deallocate(e0)
tot_deg = 0
do i = 1, m
if(deg_num(i).gt.1) then
print *, ' degen on', i, deg_num(i)
tot_deg = tot_deg + 1
endif
enddo
if(tot_deg .eq. 0) then
print *, ' no degen'
return
endif
! ---
do i = 1, m
mm = deg_num(i)
if(mm .gt. 1) then
allocate(L(n,mm), R(n,mm))
do j = 1, mm
L(1:n,j) = L0(1:n,i+j-1)
R(1:n,j) = R0(1:n,i+j-1)
enddo
! ---
call impose_weighted_orthog_svd(n, mm, W, R)
call impose_weighted_biorthog_qr(n, mm, thr_d, thr_nd, R, W, L)
! ---
do j = 1, mm
L0(1:n,i+j-1) = L(1:n,j)
R0(1:n,i+j-1) = R(1:n,j)
enddo
deallocate(L, R)
endif
enddo
call check_weighted_biorthog_binormalize(n, m, L0, W, R0, thr_d, thr_nd, .true.)
deallocate(W, deg_num)
mo_l_coef = L0
mo_r_coef = R0
deallocate(L0, R0)
call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
print *, ' orbitals are rotated '
return
end subroutine fix_right_to_one
! --- ! ---

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

@ -1,13 +1,20 @@
subroutine minimize_tc_orb_angles
! ---
subroutine minimize_tc_orb_angles()
implicit none implicit none
double precision :: thr_deg
logical :: good_angles logical :: good_angles
integer :: i integer :: i
double precision :: thr_deg
good_angles = .False. good_angles = .False.
thr_deg = thr_degen_tc thr_deg = thr_degen_tc
call print_energy_and_mos
i = 1 call print_energy_and_mos()
print *, ' Minimizing the angles between the TC orbitals' print *, ' Minimizing the angles between the TC orbitals'
i = 1
do while (.not. good_angles) do while (.not. good_angles)
print *, ' iteration = ', i print *, ' iteration = ', i
call routine_save_rotated_mos(thr_deg, good_angles) call routine_save_rotated_mos(thr_deg, good_angles)
@ -17,31 +24,49 @@ subroutine minimize_tc_orb_angles
print *, ' minimize_tc_orb_angles does not seem to converge ..' print *, ' minimize_tc_orb_angles does not seem to converge ..'
print *, ' Something is weird in the tc orbitals ...' print *, ' Something is weird in the tc orbitals ...'
print *, ' STOPPING' print *, ' STOPPING'
stop
endif endif
enddo enddo
print *, ' Converged ANGLES MINIMIZATION !!' print *, ' Converged ANGLES MINIMIZATION !!'
call print_angles_tc
call print_energy_and_mos call print_angles_tc()
call print_energy_and_mos()
end end
! ---
subroutine routine_save_rotated_mos(thr_deg, good_angles) subroutine routine_save_rotated_mos(thr_deg, good_angles)
implicit none implicit none
double precision, intent(in) :: thr_deg double precision, intent(in) :: thr_deg
logical, intent(out) :: good_angles logical, intent(out) :: good_angles
good_angles = .False.
integer :: i, j, k, n_degen_list, m, n, n_degen, ilast, ifirst integer :: i, j, k, n_degen_list, m, n, n_degen, ilast, ifirst
double precision :: max_angle, norm
integer, allocatable :: list_degen(:,:)
double precision, allocatable :: new_angles(:)
double precision, allocatable :: mo_r_coef_good(:,:), mo_l_coef_good(:,:) double precision, allocatable :: mo_r_coef_good(:,:), mo_l_coef_good(:,:)
allocate(mo_l_coef_good(ao_num, mo_num), mo_r_coef_good(ao_num,mo_num))
double precision, allocatable :: mo_r_coef_new(:,:) double precision, allocatable :: mo_r_coef_new(:,:)
double precision :: norm double precision, allocatable :: fock_diag(:),s_mat(:,:)
double precision, allocatable :: stmp(:,:), T(:,:), Snew(:,:), smat2(:,:)
double precision, allocatable :: mo_l_coef_tmp(:,:), mo_r_coef_tmp(:,:), mo_l_coef_new(:,:)
good_angles = .False.
allocate(mo_l_coef_good(ao_num, mo_num), mo_r_coef_good(ao_num,mo_num))
print *, ' ***************************************' print *, ' ***************************************'
print *, ' ***************************************' print *, ' ***************************************'
print *, ' THRESHOLD FOR DEGENERACIES ::: ', thr_deg print *, ' THRESHOLD FOR DEGENERACIES ::: ', thr_deg
print *, ' ***************************************' print *, ' ***************************************'
print *, ' ***************************************' print *, ' ***************************************'
print *, ' Starting with the following TC energy gradient :', grad_non_hermit print *, ' Starting with the following TC energy gradient :', grad_non_hermit
mo_r_coef_good = mo_r_coef mo_r_coef_good = mo_r_coef
mo_l_coef_good = mo_l_coef mo_l_coef_good = mo_l_coef
allocate(mo_r_coef_new(ao_num, mo_num)) allocate(mo_r_coef_new(ao_num, mo_num))
mo_r_coef_new = mo_r_coef mo_r_coef_new = mo_r_coef
do i = 1, mo_num do i = 1, mo_num
@ -50,12 +75,12 @@ subroutine routine_save_rotated_mos(thr_deg,good_angles)
mo_r_coef_new(j,i) *= norm mo_r_coef_new(j,i) *= norm
enddo enddo
enddo enddo
double precision, allocatable :: fock_diag(:),s_mat(:,:)
integer, allocatable :: list_degen(:,:)
allocate(list_degen(mo_num,0:mo_num), s_mat(mo_num,mo_num), fock_diag(mo_num)) allocate(list_degen(mo_num,0:mo_num), s_mat(mo_num,mo_num), fock_diag(mo_num))
do i = 1, mo_num do i = 1, mo_num
fock_diag(i) = Fock_matrix_tc_mo_tot(i,i) fock_diag(i) = Fock_matrix_tc_mo_tot(i,i)
enddo enddo
! compute the overlap between the left and rescaled right ! compute the overlap between the left and rescaled right
call build_s_matrix(ao_num, mo_num, mo_r_coef_new, mo_r_coef_new, ao_overlap, s_mat) call build_s_matrix(ao_num, mo_num, mo_r_coef_new, mo_r_coef_new, ao_overlap, s_mat)
! call give_degen(fock_diag,mo_num,thr_deg,list_degen,n_degen_list) ! call give_degen(fock_diag,mo_num,thr_deg,list_degen,n_degen_list)
@ -69,12 +94,13 @@ subroutine routine_save_rotated_mos(thr_deg,good_angles)
! ifirst = list_degen(1,i) ! ifirst = list_degen(1,i)
! ilast = list_degen(2,i) ! ilast = list_degen(2,i)
! n_degen = ilast - ifirst +1 ! n_degen = ilast - ifirst +1
n_degen = list_degen(i,0) n_degen = list_degen(i,0)
double precision, allocatable :: stmp(:,:),T(:,:),Snew(:,:),smat2(:,:)
double precision, allocatable :: mo_l_coef_tmp(:,:),mo_r_coef_tmp(:,:),mo_l_coef_new(:,:)
allocate(stmp(n_degen,n_degen), smat2(n_degen,n_degen)) allocate(stmp(n_degen,n_degen), smat2(n_degen,n_degen))
allocate(mo_r_coef_tmp(ao_num,n_degen), mo_l_coef_tmp(ao_num,n_degen), mo_l_coef_new(ao_num,n_degen)) allocate(mo_r_coef_tmp(ao_num,n_degen), mo_l_coef_tmp(ao_num,n_degen), mo_l_coef_new(ao_num,n_degen))
allocate(T(n_degen,n_degen), Snew(n_degen,n_degen)) allocate(T(n_degen,n_degen), Snew(n_degen,n_degen))
do j = 1, n_degen do j = 1, n_degen
mo_r_coef_tmp(1:ao_num,j) = mo_r_coef_new(1:ao_num,list_degen(i,j)) mo_r_coef_tmp(1:ao_num,j) = mo_r_coef_new(1:ao_num,list_degen(i,j))
mo_l_coef_tmp(1:ao_num,j) = mo_l_coef(1:ao_num,list_degen(i,j)) mo_l_coef_tmp(1:ao_num,j) = mo_l_coef(1:ao_num,list_degen(i,j))
@ -88,12 +114,14 @@ subroutine routine_save_rotated_mos(thr_deg,good_angles)
print *, ' Orthogonalization of LEFT functions' print *, ' Orthogonalization of LEFT functions'
print *, ' ------------------------------------' print *, ' ------------------------------------'
call orthog_functions(ao_num, n_degen, mo_l_coef_tmp, ao_overlap) call orthog_functions(ao_num, n_degen, mo_l_coef_tmp, ao_overlap)
print *, ' Overlap lef-right ' print *, ' Overlap lef-right '
call build_s_matrix(ao_num, n_degen, mo_r_coef_tmp, mo_l_coef_tmp, ao_overlap, stmp) call build_s_matrix(ao_num, n_degen, mo_r_coef_tmp, mo_l_coef_tmp, ao_overlap, stmp)
do j = 1, n_degen do j = 1, n_degen
write(*,'(100(F8.4,X))') stmp(:,j) write(*,'(100(F8.4,X))') stmp(:,j)
enddo enddo
call build_s_matrix(ao_num, n_degen, mo_l_coef_tmp, mo_l_coef_tmp, ao_overlap, stmp) call build_s_matrix(ao_num, n_degen, mo_l_coef_tmp, mo_l_coef_tmp, ao_overlap, stmp)
!print*,'LEFT/LEFT OVERLAP ' !print*,'LEFT/LEFT OVERLAP '
!do j = 1, n_degen !do j = 1, n_degen
! write(*,'(100(F16.10,X))')stmp(:,j) ! write(*,'(100(F16.10,X))')stmp(:,j)
@ -103,6 +131,7 @@ subroutine routine_save_rotated_mos(thr_deg,good_angles)
!do j = 1, n_degen !do j = 1, n_degen
! write(*,'(100(F16.10,X))')stmp(:,j) ! write(*,'(100(F16.10,X))')stmp(:,j)
!enddo !enddo
if(maxovl_tc) then if(maxovl_tc) then
T = 0.d0 T = 0.d0
Snew = 0.d0 Snew = 0.d0
@ -122,70 +151,77 @@ subroutine routine_save_rotated_mos(thr_deg,good_angles)
else else
mo_l_coef_new = mo_l_coef_tmp mo_l_coef_new = mo_l_coef_tmp
endif endif
call impose_biorthog_svd_overlap(ao_num, n_degen, ao_overlap, mo_l_coef_new, mo_r_coef_tmp)
call build_s_matrix(ao_num,n_degen,mo_l_coef_new,mo_r_coef_tmp,ao_overlap,stmp) call impose_weighted_biorthog_svd(ao_num, n_degen, ao_overlap, mo_l_coef_new, mo_r_coef_tmp)
!call build_s_matrix(ao_num, n_degen, mo_l_coef_new, mo_r_coef_tmp, ao_overlap, stmp)
!print*,'LAST OVERLAP ' !print*,'LAST OVERLAP '
!do j = 1, n_degen !do j = 1, n_degen
! write(*,'(100(F16.10,X))')stmp(:,j) ! write(*,'(100(F16.10,X))')stmp(:,j)
!enddo !enddo
call build_s_matrix(ao_num,n_degen,mo_l_coef_new,mo_l_coef_new,ao_overlap,stmp) !call build_s_matrix(ao_num, n_degen, mo_l_coef_new, mo_l_coef_new, ao_overlap, stmp)
!print*,'LEFT OVERLAP ' !print*,'LEFT OVERLAP '
!do j = 1, n_degen !do j = 1, n_degen
! write(*,'(100(F16.10,X))')stmp(:,j) ! write(*,'(100(F16.10,X))')stmp(:,j)
!enddo !enddo
call build_s_matrix(ao_num,n_degen,mo_r_coef_tmp,mo_r_coef_tmp,ao_overlap,stmp) !call build_s_matrix(ao_num, n_degen, mo_r_coef_tmp, mo_r_coef_tmp, ao_overlap, stmp)
!print*,'RIGHT OVERLAP ' !print*,'RIGHT OVERLAP '
!do j = 1, n_degen !do j = 1, n_degen
! write(*,'(100(F16.10,X))')stmp(:,j) ! write(*,'(100(F16.10,X))')stmp(:,j)
!enddo !enddo
do j = 1, n_degen do j = 1, n_degen
! mo_l_coef_good(1:ao_num,j+ifirst-1) = mo_l_coef_new(1:ao_num,j) !!! mo_l_coef_good(1:ao_num,j+ifirst-1) = mo_l_coef_new(1:ao_num,j)
! mo_r_coef_good(1:ao_num,j+ifirst-1) = mo_r_coef_tmp(1:ao_num,j) !!! mo_r_coef_good(1:ao_num,j+ifirst-1) = mo_r_coef_tmp(1:ao_num,j)
mo_l_coef_good(1:ao_num,list_degen(i,j)) = mo_l_coef_new(1:ao_num,j) mo_l_coef_good(1:ao_num,list_degen(i,j)) = mo_l_coef_new(1:ao_num,j)
mo_r_coef_good(1:ao_num,list_degen(i,j)) = mo_r_coef_tmp(1:ao_num,j) mo_r_coef_good(1:ao_num,list_degen(i,j)) = mo_r_coef_tmp(1:ao_num,j)
enddo enddo
deallocate(stmp, smat2) deallocate(stmp, smat2)
deallocate(mo_r_coef_tmp, mo_l_coef_tmp, mo_l_coef_new) deallocate(mo_r_coef_tmp, mo_l_coef_tmp, mo_l_coef_new)
deallocate(T, Snew) deallocate(T, Snew)
enddo enddo
allocate(stmp(mo_num, mo_num)) !allocate(stmp(mo_num, mo_num))
call build_s_matrix(ao_num,mo_num,mo_l_coef_good,mo_r_coef_good,ao_overlap,stmp) !call build_s_matrix(ao_num, mo_num, mo_l_coef_good, mo_r_coef_good, ao_overlap, stmp)
!print*,'LEFT/RIGHT OVERLAP ' !print*,'LEFT/RIGHT OVERLAP '
!do j = 1, mo_num !do j = 1, mo_num
! write(*,'(100(F16.10,X))')stmp(:,j) ! write(*,'(100(F16.10,X))')stmp(:,j)
!enddo !enddo
call build_s_matrix(ao_num,mo_num,mo_l_coef_good,mo_l_coef_good,ao_overlap,stmp) !call build_s_matrix(ao_num, mo_num, mo_l_coef_good, mo_l_coef_good, ao_overlap, stmp)
!print*,'LEFT/LEFT OVERLAP ' !print*,'LEFT/LEFT OVERLAP '
!do j = 1, mo_num !do j = 1, mo_num
! write(*,'(100(F16.10,X))')stmp(:,j) ! write(*,'(100(F16.10,X))')stmp(:,j)
!enddo !enddo
call build_s_matrix(ao_num,mo_num,mo_r_coef_good,mo_r_coef_good,ao_overlap,stmp) !call build_s_matrix(ao_num, mo_num, mo_r_coef_good, mo_r_coef_good, ao_overlap, stmp)
!print*,'RIGHT/RIGHT OVERLAP ' !print*,'RIGHT/RIGHT OVERLAP '
!do j = 1, mo_num !do j = 1, mo_num
! write(*,'(100(F16.10,X))')stmp(:,j) ! write(*,'(100(F16.10,X))')stmp(:,j)
!enddo !enddo
mo_r_coef = mo_r_coef_good mo_r_coef = mo_r_coef_good
mo_l_coef = mo_l_coef_good mo_l_coef = mo_l_coef_good
call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef) call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef) call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
TOUCH mo_l_coef mo_r_coef TOUCH mo_l_coef mo_r_coef
double precision, allocatable :: new_angles(:)
allocate(new_angles(mo_num)) allocate(new_angles(mo_num))
new_angles(1:mo_num) = dabs(angle_left_right(1:mo_num)) new_angles(1:mo_num) = dabs(angle_left_right(1:mo_num))
double precision :: max_angle
max_angle = maxval(new_angles) max_angle = maxval(new_angles)
good_angles = max_angle.lt.45.d0 good_angles = max_angle.lt.45.d0
print *, ' max_angle = ', max_angle print *, ' max_angle = ', max_angle
end end
! ---
subroutine build_s_matrix(m, n, C1, C2, overlap, smat) subroutine build_s_matrix(m, n, C1, C2, overlap, smat)
implicit none implicit none
integer, intent(in) :: m, n integer, intent(in) :: m, n
double precision, intent(in) :: C1(m,n), C2(m,n), overlap(m,m) double precision, intent(in) :: C1(m,n), C2(m,n), overlap(m,m)
double precision, intent(out) :: smat(n,n) double precision, intent(out) :: smat(n,n)
integer :: i, j, k, l integer :: i, j, k, l
smat = 0.D0 smat = 0.D0
do i = 1, n do i = 1, n
do j = 1, n do j = 1, n
@ -196,8 +232,11 @@ subroutine build_s_matrix(m,n,C1,C2,overlap,smat)
enddo enddo
enddo enddo
enddo enddo
end end
! ---
subroutine orthog_functions(m,n,coef,overlap) subroutine orthog_functions(m,n,coef,overlap)
implicit none implicit none
integer, intent(in) :: m,n integer, intent(in) :: m,n
@ -217,16 +256,24 @@ subroutine orthog_functions(m,n,coef,overlap)
coef(1,:m) *= 1.d0/dsqrt(stmp(j,j)) coef(1,:m) *= 1.d0/dsqrt(stmp(j,j))
enddo enddo
call build_s_matrix(m,n,coef,coef,overlap,stmp) call build_s_matrix(m,n,coef,coef,overlap,stmp)
!print*,'overlap after' !print*,'overlap after'
!do j = 1, n !do j = 1, n
! write(*,'(100(F16.10,X))')stmp(:,j) ! write(*,'(100(F16.10,X))')stmp(:,j)
!enddo !enddo
deallocate(stmp)
end end
subroutine print_angles_tc ! ---
subroutine print_angles_tc()
implicit none implicit none
integer :: i, j integer :: i, j
double precision :: left, right double precision :: left, right
print *, ' product of norms, angle between vectors' print *, ' product of norms, angle between vectors'
do i = 1, mo_num do i = 1, mo_num
left = overlap_mo_l(i,i) left = overlap_mo_l(i,i)
@ -234,15 +281,21 @@ subroutine print_angles_tc
! print*,Fock_matrix_tc_mo_tot(i,i),left*right,angle_left_right(i) ! print*,Fock_matrix_tc_mo_tot(i,i),left*right,angle_left_right(i)
print *, left*right, angle_left_right(i) print *, left*right, angle_left_right(i)
enddo enddo
end end
subroutine print_energy_and_mos ! ---
subroutine print_energy_and_mos()
implicit none implicit none
integer :: i integer :: i
print *, ' ' print *, ' '
print *, ' TC energy = ', TC_HF_energy print *, ' TC energy = ', TC_HF_energy
print *, ' TC SCF energy gradient = ', grad_non_hermit print *, ' TC SCF energy gradient = ', grad_non_hermit
print *, ' Max angle Left/right = ', max_angle_left_right print *, ' Max angle Left/right = ', max_angle_left_right
if(max_angle_left_right .lt. 45.d0) then if(max_angle_left_right .lt. 45.d0) then
print *, ' Maximum angle BELOW 45 degrees, everthing is OK !' print *, ' Maximum angle BELOW 45 degrees, everthing is OK !'
else if(max_angle_left_right .gt. 45.d0 .and. max_angle_left_right .lt. 75.d0) then else if(max_angle_left_right .gt. 45.d0 .and. max_angle_left_right .lt. 75.d0) then
@ -250,12 +303,16 @@ subroutine print_energy_and_mos
else if(max_angle_left_right .gt. 75.d0) then else if(max_angle_left_right .gt. 75.d0) then
print *, ' Maximum angle between ABOVE 75 degrees, YOU WILL CERTAINLY FIND TROUBLES IN TC-CI calculations ...' print *, ' Maximum angle between ABOVE 75 degrees, YOU WILL CERTAINLY FIND TROUBLES IN TC-CI calculations ...'
endif endif
print *, ' Diag Fock elem, product of left/right norm, angle left/right ' print *, ' Diag Fock elem, product of left/right norm, angle left/right '
do i = 1, mo_num do i = 1, mo_num
write(*, '(I3,X,100(F16.10,X))') i, Fock_matrix_tc_mo_tot(i,i), overlap_mo_l(i,i)*overlap_mo_r(i,i), angle_left_right(i) write(*, '(I3,X,100(F16.10,X))') i, Fock_matrix_tc_mo_tot(i,i), overlap_mo_l(i,i)*overlap_mo_r(i,i), angle_left_right(i)
enddo enddo
end end
! ---
subroutine sort_by_tc_fock subroutine sort_by_tc_fock
implicit none implicit none
integer, allocatable :: iorder(:) integer, allocatable :: iorder(:)
@ -276,3 +333,4 @@ subroutine sort_by_tc_fock
touch mo_l_coef mo_r_coef touch mo_l_coef mo_r_coef
end end

330
src/tools/print_he_energy.irp.f Normal file
View File

@ -0,0 +1,330 @@
! ---
program print_he_energy
implicit none
!call print_energy1()
call print_energy2()
end
! ---
subroutine print_energy1()
implicit none
integer :: i, j, k, l
double precision :: e, n, e_tmp, n_tmp
double precision, external :: ao_two_e_integral
e = 0.d0
n = 0.d0
! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
! < phi_1 phi_1 | h1 | phi_1 phi_1 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
e_tmp += mo_coef(i,1) * ao_one_e_integrals(i,j) * mo_coef(j,1)
n_tmp += mo_coef(i,1) * ao_overlap(i,j) * mo_coef(j,1)
enddo
enddo
e += e_tmp * n_tmp
! ---
! < phi_1 phi_1 | h2 | phi_1 phi_1 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
n_tmp += mo_coef(i,1) * ao_overlap(i,j) * mo_coef(j,1)
e_tmp += mo_coef(i,1) * ao_one_e_integrals(i,j) * mo_coef(j,1)
enddo
enddo
e += e_tmp * n_tmp
! ---
! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
! ---
do i = 1, ao_num
do j = 1, ao_num
do k = 1, ao_num
do l = 1, ao_num
! ( phi_1 phi_1 | phi_1 phi_1 )
e += mo_coef(i,1) * mo_coef(j,1) * ao_two_e_integral(i,j,k,l) * mo_coef(k,1) * mo_coef(l,1)
enddo
enddo
enddo
enddo
! ---
! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
! ---
! < phi_1 phi_1 | phi_1 phi_1 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
e_tmp += mo_coef(i,1) * ao_overlap(i,j) * mo_coef(j,1)
n_tmp += mo_coef(i,1) * ao_overlap(i,j) * mo_coef(j,1)
enddo
enddo
n += e_tmp * n_tmp
! ---
! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
e = e / n
print *, ' energy = ', e
end subroutine print_energy1
! ---
subroutine print_energy2()
implicit none
integer :: i, j, k, l
double precision :: e, n, e_tmp, n_tmp
double precision, external :: ao_two_e_integral
e = 0.d0
n = 0.d0
! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
! < phi_1 phi_2 | h1 | phi_1 phi_2 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
e_tmp += mo_coef(i,1) * ao_one_e_integrals(i,j) * mo_coef(j,1)
n_tmp += mo_coef(i,2) * ao_overlap(i,j) * mo_coef(j,2)
enddo
enddo
e += e_tmp * n_tmp
! ---
! < phi_1 phi_2 | h1 | phi_2 phi_1 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
e_tmp += mo_coef(i,1) * ao_one_e_integrals(i,j) * mo_coef(j,2)
n_tmp += mo_coef(i,2) * ao_overlap(i,j) * mo_coef(j,1)
enddo
enddo
e -= e_tmp * n_tmp
! ---
! < phi_2 phi_1 | h1 | phi_1 phi_2 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
e_tmp += mo_coef(i,2) * ao_one_e_integrals(i,j) * mo_coef(j,1)
n_tmp += mo_coef(i,1) * ao_overlap(i,j) * mo_coef(j,2)
enddo
enddo
e -= e_tmp * n_tmp
! ---
! < phi_2 phi_1 | h1 | phi_2 phi_1 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
e_tmp += mo_coef(i,2) * ao_one_e_integrals(i,j) * mo_coef(j,2)
n_tmp += mo_coef(i,1) * ao_overlap(i,j) * mo_coef(j,1)
enddo
enddo
e += e_tmp * n_tmp
! ---
! < phi_1 phi_2 | h2 | phi_1 phi_2 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
n_tmp += mo_coef(i,1) * ao_overlap(i,j) * mo_coef(j,1)
e_tmp += mo_coef(i,2) * ao_one_e_integrals(i,j) * mo_coef(j,2)
enddo
enddo
e += e_tmp * n_tmp
! ---
! < phi_1 phi_2 | h2 | phi_2 phi_1 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
n_tmp += mo_coef(i,1) * ao_overlap(i,j) * mo_coef(j,2)
e_tmp += mo_coef(i,2) * ao_one_e_integrals(i,j) * mo_coef(j,1)
enddo
enddo
e -= e_tmp * n_tmp
! ---
! < phi_2 phi_1 | h2 | phi_1 phi_2 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
n_tmp += mo_coef(i,2) * ao_overlap(i,j) * mo_coef(j,1)
e_tmp += mo_coef(i,1) * ao_one_e_integrals(i,j) * mo_coef(j,2)
enddo
enddo
e -= e_tmp * n_tmp
! ---
! < phi_2 phi_1 | h2 | phi_2 phi_1 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
n_tmp += mo_coef(i,2) * ao_overlap(i,j) * mo_coef(j,2)
e_tmp += mo_coef(i,1) * ao_one_e_integrals(i,j) * mo_coef(j,1)
enddo
enddo
e += e_tmp * n_tmp
! ---
! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
! ---
do i = 1, ao_num
do j = 1, ao_num
do k = 1, ao_num
do l = 1, ao_num
! ( phi_1 phi_1 | phi_2 phi_2 )
e += mo_coef(i,1) * mo_coef(j,1) * ao_two_e_integral(i,j,k,l) * mo_coef(k,2) * mo_coef(l,2)
! ( phi_1 phi_2 | phi_2 phi_1 )
e -= mo_coef(i,1) * mo_coef(j,2) * ao_two_e_integral(i,j,k,l) * mo_coef(k,2) * mo_coef(l,1)
! ( phi_2 phi_1 | phi_1 phi_2 )
e -= mo_coef(i,2) * mo_coef(j,1) * ao_two_e_integral(i,j,k,l) * mo_coef(k,1) * mo_coef(l,2)
! ( phi_2 phi_2 | phi_1 phi_1 )
e += mo_coef(i,2) * mo_coef(j,2) * ao_two_e_integral(i,j,k,l) * mo_coef(k,1) * mo_coef(l,1)
enddo
enddo
enddo
enddo
! ---
! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
! ---
! < phi_1 phi_2 | phi_1 phi_2 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
e_tmp += mo_coef(i,1) * ao_overlap(i,j) * mo_coef(j,1)
n_tmp += mo_coef(i,2) * ao_overlap(i,j) * mo_coef(j,2)
enddo
enddo
n += e_tmp * n_tmp
! ---
! < phi_1 phi_2 | phi_2 phi_1 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
e_tmp += mo_coef(i,1) * ao_overlap(i,j) * mo_coef(j,2)
n_tmp += mo_coef(i,2) * ao_overlap(i,j) * mo_coef(j,1)
enddo
enddo
n -= e_tmp * n_tmp
! ---
! < phi_2 phi_1 | phi_1 phi_2 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
e_tmp += mo_coef(i,2) * ao_overlap(i,j) * mo_coef(j,1)
n_tmp += mo_coef(i,1) * ao_overlap(i,j) * mo_coef(j,2)
enddo
enddo
n -= e_tmp * n_tmp
! ---
! < phi_2 phi_1 | phi_2 phi_1 >
e_tmp = 0.d0
n_tmp = 0.d0
do i = 1, ao_num
do j = 1, ao_num
e_tmp += mo_coef(i,2) * ao_overlap(i,j) * mo_coef(j,2)
n_tmp += mo_coef(i,1) * ao_overlap(i,j) * mo_coef(j,1)
enddo
enddo
n += e_tmp * n_tmp
! ---
! --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
e = e / n
print *, ' energy = ', e
end subroutine print_energy2
! ---

75
src/utils/block_diag_degen.irp.f
View File

@ -1,10 +1,9 @@
subroutine diag_mat_per_fock_degen(fock_diag,mat_ref,n,thr_deg,leigvec,reigvec,eigval) subroutine diag_mat_per_fock_degen(fock_diag, mat_ref, n, thr_d, thr_nd, thr_deg, leigvec, reigvec, eigval)
implicit none
integer, intent(in) :: n
double precision, intent(in) :: fock_diag(n),mat_ref(n,n),thr_deg
double precision, intent(out):: leigvec(n,n),reigvec(n,n),eigval(n)
BEGIN_DOC BEGIN_DOC
!
! subroutine that diagonalizes a matrix mat_ref BY BLOCK ! subroutine that diagonalizes a matrix mat_ref BY BLOCK
! !
! the blocks are defined by the elements having the SAME DEGENERACIES in the entries "fock_diag" ! the blocks are defined by the elements having the SAME DEGENERACIES in the entries "fock_diag"
@ -16,12 +15,21 @@ subroutine diag_mat_per_fock_degen(fock_diag,mat_ref,n,thr_deg,leigvec,reigvec,e
! : all elements having degeneracy 3 in fock_diag (i.e. two elements are equal) will be treated together ! : all elements having degeneracy 3 in fock_diag (i.e. two elements are equal) will be treated together
! !
! etc... the advantage is to guarentee no spurious mixing because of numerical problems. ! etc... the advantage is to guarentee no spurious mixing because of numerical problems.
!
END_DOC END_DOC
double precision, allocatable :: leigvec_unsrtd(:,:),reigvec_unsrtd(:,:),eigval_unsrtd(:)
integer, allocatable :: list_degen(:,:),list_same_degen(:) implicit none
integer, allocatable :: iorder(:),list_degen_sorted(:) integer, intent(in) :: n
double precision, intent(in) :: fock_diag(n), mat_ref(n,n), thr_d, thr_nd, thr_deg
double precision, intent(out) :: leigvec(n,n), reigvec(n,n), eigval(n)
integer :: n_degen_list, n_degen,size_mat, i, j, k, icount, m, index_degen integer :: n_degen_list, n_degen,size_mat, i, j, k, icount, m, index_degen
integer :: ii, jj, i_good, j_good, n_real integer :: ii, jj, i_good, j_good, n_real
integer :: icount_eigval
logical, allocatable :: is_ok(:)
integer, allocatable :: list_degen(:,:), list_same_degen(:)
integer, allocatable :: iorder(:), list_degen_sorted(:)
double precision, allocatable :: leigvec_unsrtd(:,:), reigvec_unsrtd(:,:), eigval_unsrtd(:)
double precision, allocatable :: mat_tmp(:,:), eigval_tmp(:), leigvec_tmp(:,:), reigvec_tmp(:,:) double precision, allocatable :: mat_tmp(:,:), eigval_tmp(:), leigvec_tmp(:,:), reigvec_tmp(:,:)
allocate(leigvec_unsrtd(n,n), reigvec_unsrtd(n,n), eigval_unsrtd(n)) allocate(leigvec_unsrtd(n,n), reigvec_unsrtd(n,n), eigval_unsrtd(n))
@ -29,38 +37,44 @@ subroutine diag_mat_per_fock_degen(fock_diag,mat_ref,n,thr_deg,leigvec,reigvec,e
reigvec_unsrtd = 0.d0 reigvec_unsrtd = 0.d0
eigval_unsrtd = 0.d0 eigval_unsrtd = 0.d0
allocate(list_degen(n,0:n))
! obtain degeneracies ! obtain degeneracies
allocate(list_degen(n,0:n))
call give_degen_full_list(fock_diag, n, thr_deg, list_degen, n_degen_list) call give_degen_full_list(fock_diag, n, thr_deg, list_degen, n_degen_list)
allocate(iorder(n_degen_list), list_degen_sorted(n_degen_list)) allocate(iorder(n_degen_list), list_degen_sorted(n_degen_list))
do i = 1, n_degen_list do i = 1, n_degen_list
n_degen = list_degen(i,0) n_degen = list_degen(i,0)
list_degen_sorted(i) = n_degen list_degen_sorted(i) = n_degen
iorder(i) = i iorder(i) = i
enddo enddo
! sort by number of degeneracies ! sort by number of degeneracies
call isort(list_degen_sorted, iorder, n_degen_list) call isort(list_degen_sorted, iorder, n_degen_list)
integer :: icount_eigval
logical, allocatable :: is_ok(:)
allocate(is_ok(n_degen_list)) allocate(is_ok(n_degen_list))
is_ok = .True. is_ok = .True.
icount_eigval = 0 icount_eigval = 0
! loop over degeneracies ! loop over degeneracies
do i = 1, n_degen_list do i = 1, n_degen_list
if(.not.is_ok(i)) cycle if(.not.is_ok(i)) cycle
is_ok(i) = .False. is_ok(i) = .False.
n_degen = list_degen_sorted(i) n_degen = list_degen_sorted(i)
print *, ' diagonalizing for n_degen = ', n_degen print *, ' diagonalizing for n_degen = ', n_degen
k = 1 k = 1
! group all the entries having the same degeneracies ! group all the entries having the same degeneracies
! do while (list_degen_sorted(i+k)==n_degen) !! do while (list_degen_sorted(i+k)==n_degen)
do m = i+1, n_degen_list do m = i+1, n_degen_list
if(list_degen_sorted(m)==n_degen) then if(list_degen_sorted(m)==n_degen) then
is_ok(i+k) = .False. is_ok(i+k) = .False.
k += 1 k += 1
endif endif
enddo enddo
print *, ' number of identical degeneracies = ', k print *, ' number of identical degeneracies = ', k
size_mat = k*n_degen size_mat = k*n_degen
print *, ' size_mat = ', size_mat print *, ' size_mat = ', size_mat
@ -75,10 +89,12 @@ subroutine diag_mat_per_fock_degen(fock_diag,mat_ref,n,thr_deg,leigvec,reigvec,e
list_same_degen(icount) = list_degen(index_degen,m) list_same_degen(icount) = list_degen(index_degen,m)
enddo enddo
enddo enddo
print *, ' list of elements ' print *, ' list of elements '
do icount = 1, size_mat do icount = 1, size_mat
print *, icount, list_same_degen(icount) print *, icount, list_same_degen(icount)
enddo enddo
! you copy subset of matrix elements having all the same degeneracy in mat_tmp ! you copy subset of matrix elements having all the same degeneracy in mat_tmp
do ii = 1, size_mat do ii = 1, size_mat
i_good = list_same_degen(ii) i_good = list_same_degen(ii)
@ -87,9 +103,11 @@ subroutine diag_mat_per_fock_degen(fock_diag,mat_ref,n,thr_deg,leigvec,reigvec,e
mat_tmp(jj,ii) = mat_ref(j_good,i_good) mat_tmp(jj,ii) = mat_ref(j_good,i_good)
enddo enddo
enddo enddo
call non_hrmt_bieig( size_mat, mat_tmp&
call non_hrmt_bieig( size_mat, mat_tmp, thr_d, thr_nd &
, leigvec_tmp, reigvec_tmp & , leigvec_tmp, reigvec_tmp &
, n_real, eigval_tmp ) , n_real, eigval_tmp )
do ii = 1, size_mat do ii = 1, size_mat
icount_eigval += 1 icount_eigval += 1
eigval_unsrtd(icount_eigval) = eigval_tmp(ii) ! copy eigenvalues eigval_unsrtd(icount_eigval) = eigval_tmp(ii) ! copy eigenvalues
@ -99,9 +117,11 @@ subroutine diag_mat_per_fock_degen(fock_diag,mat_ref,n,thr_deg,leigvec,reigvec,e
reigvec_unsrtd(j_good,icount_eigval) = reigvec_tmp(jj,ii) reigvec_unsrtd(j_good,icount_eigval) = reigvec_tmp(jj,ii)
enddo enddo
enddo enddo
deallocate(mat_tmp, list_same_degen) deallocate(mat_tmp, list_same_degen)
deallocate(eigval_tmp, leigvec_tmp, reigvec_tmp) deallocate(eigval_tmp, leigvec_tmp, reigvec_tmp)
enddo enddo
if(icount_eigval .ne. n) then if(icount_eigval .ne. n) then
print *, ' pb !! (icount_eigval.ne.n)' print *, ' pb !! (icount_eigval.ne.n)'
print *, ' icount_eigval,n', icount_eigval, n print *, ' icount_eigval,n', icount_eigval, n
@ -114,6 +134,7 @@ subroutine diag_mat_per_fock_degen(fock_diag,mat_ref,n,thr_deg,leigvec,reigvec,e
iorder(i) = i iorder(i) = i
enddo enddo
call dsort(eigval_unsrtd, iorder, n) call dsort(eigval_unsrtd, iorder, n)
do i = 1, n do i = 1, n
print*,'sorted eigenvalues ' print*,'sorted eigenvalues '
i_good = iorder(i) i_good = iorder(i)
@ -124,10 +145,18 @@ subroutine diag_mat_per_fock_degen(fock_diag,mat_ref,n,thr_deg,leigvec,reigvec,e
reigvec(j,i) = reigvec_unsrtd(j,i_good) reigvec(j,i) = reigvec_unsrtd(j,i_good)
enddo enddo
enddo enddo
deallocate(leigvec_unsrtd, reigvec_unsrtd, eigval_unsrtd)
deallocate(list_degen)
deallocate(iorder, list_degen_sorted)
deallocate(is_ok)
end end
! ---
subroutine give_degen_full_list(A,n,thr,list_degen,n_degen_list) subroutine give_degen_full_list(A,n,thr,list_degen,n_degen_list)
implicit none
BEGIN_DOC BEGIN_DOC
! you enter with an array A(n) and spits out all the elements degenerated up to thr ! you enter with an array A(n) and spits out all the elements degenerated up to thr
! !
@ -141,13 +170,18 @@ subroutine give_degen_full_list(A,n,thr,list_degen,n_degen_list)
! !
! if list_degen(i,0) == 1 it means that there is no degeneracy for that element ! if list_degen(i,0) == 1 it means that there is no degeneracy for that element
END_DOC END_DOC
implicit none
double precision, intent(in) :: A(n) double precision, intent(in) :: A(n)
double precision, intent(in) :: thr double precision, intent(in) :: thr
integer, intent(in) :: n integer, intent(in) :: n
integer, intent(out) :: list_degen(n,0:n), n_degen_list integer, intent(out) :: list_degen(n,0:n), n_degen_list
logical, allocatable :: is_ok(:)
allocate(is_ok(n))
integer :: i, j, icount, icheck integer :: i, j, icount, icheck
logical, allocatable :: is_ok(:)
allocate(is_ok(n))
n_degen_list = 0 n_degen_list = 0
is_ok = .True. is_ok = .True.
do i = 1, n do i = 1, n
@ -163,15 +197,22 @@ subroutine give_degen_full_list(A,n,thr,list_degen,n_degen_list)
list_degen(n_degen_list,icount) = j list_degen(n_degen_list,icount) = j
endif endif
enddo enddo
list_degen(n_degen_list,0) = icount list_degen(n_degen_list,0) = icount
enddo enddo
icheck = 0 icheck = 0
do i = 1, n_degen_list do i = 1, n_degen_list
icheck += list_degen(i,0) icheck += list_degen(i,0)
enddo enddo
if(icheck.ne.n)then if(icheck.ne.n)then
print *, ' pb ! :: icheck.ne.n' print *, ' pb ! :: icheck.ne.n'
print *, icheck, n print *, icheck, n
stop stop
endif endif
end end
! ---