mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-06-01 10:15:18 +02:00
handling degerated vectors correctly for bi-orthogonality
This commit is contained in:
AbdAmmar
parent
368450f72b
commit
e3beae681b
|
|
@ -275,10 +275,11 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
|
||||||
double precision :: thr, thr_cut, thr_diag, thr_norm
|
double precision :: thr, thr_cut, thr_diag, thr_norm
|
||||||
double precision :: accu_d, accu_nd
|
double precision :: accu_d, accu_nd
|
||||||
|
|
||||||
integer, allocatable :: list_good(:), iorder(:)
|
integer, allocatable :: list_good(:), iorder(:), deg_num(:)
|
||||||
double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:)
|
double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:)
|
||||||
double precision, allocatable :: S(:,:)
|
double precision, allocatable :: S(:,:)
|
||||||
double precision, allocatable :: phi_1_tilde(:),phi_2_tilde(:),chi_1_tilde(:),chi_2_tilde(:)
|
double precision, allocatable :: phi_1_tilde(:),phi_2_tilde(:),chi_1_tilde(:),chi_2_tilde(:)
|
||||||
|
|
||||||
allocate(phi_1_tilde(n),phi_2_tilde(n),chi_1_tilde(n),chi_2_tilde(n))
|
allocate(phi_1_tilde(n),phi_2_tilde(n),chi_1_tilde(n),chi_2_tilde(n))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -496,18 +497,10 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
! call impose_orthog_degen_eigvec(n, eigval, reigvec)
|
allocate(deg_num(n))
|
||||||
! call impose_orthog_degen_eigvec(n, eigval, leigvec)
|
call reorder_degen_eigvec(n, deg_num, eigval, leigvec, reigvec)
|
||||||
|
call impose_biorthog_degen_eigvec(n, deg_num, eigval, leigvec, reigvec)
|
||||||
call reorder_degen_eigvec(n, eigval, leigvec, reigvec)
|
deallocate(deg_num)
|
||||||
call impose_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 check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .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
|
||||||
|
|
@ -515,12 +508,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
|
||||||
endif
|
endif
|
||||||
call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .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, thr_d, thr_nd, leigvec, reigvec)
|
!call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.)
|
||||||
!call impose_biorthog_lu(n, n_real_eigv, thr_d, thr_nd, leigvec, reigvec)
|
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.)
|
|
||||||
|
|
||||||
deallocate(S)
|
deallocate(S)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1865,7 +1865,7 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_
|
||||||
, Vl, size(Vl, 1), Vr, size(Vr, 1) &
|
, Vl, size(Vl, 1), Vr, size(Vr, 1) &
|
||||||
, 0.d0, S, size(S, 1) )
|
, 0.d0, S, size(S, 1) )
|
||||||
|
|
||||||
! print ca juste s'il y a besoin
|
! print S s'il y a besoin
|
||||||
!print *, ' overlap matrix:'
|
!print *, ' overlap matrix:'
|
||||||
!do i = 1, m
|
!do i = 1, m
|
||||||
! write(*,'(1000(F16.10,X))') S(i,:)
|
! write(*,'(1000(F16.10,X))') S(i,:)
|
||||||
|
|
@ -1877,11 +1877,13 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_
|
||||||
do j = 1, m
|
do j = 1, m
|
||||||
if(i==j) then
|
if(i==j) then
|
||||||
accu_d = accu_d + dabs(S(i,i))
|
accu_d = accu_d + dabs(S(i,i))
|
||||||
|
!print*, i, S(i,i)
|
||||||
else
|
else
|
||||||
accu_nd = accu_nd + S(j,i) * S(j,i)
|
accu_nd = accu_nd + S(j,i) * S(j,i)
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
!accu_nd = dsqrt(accu_nd) / dble(m*m)
|
||||||
accu_nd = dsqrt(accu_nd) / dble(m)
|
accu_nd = dsqrt(accu_nd) / dble(m)
|
||||||
|
|
||||||
if((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d) then
|
if((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d) then
|
||||||
|
|
@ -1951,24 +1953,21 @@ end subroutine check_orthog
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
subroutine reorder_degen_eigvec(n, e0, L0, R0)
|
subroutine reorder_degen_eigvec(n, deg_num, e0, L0, R0)
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
integer, intent(in) :: n
|
integer, intent(in) :: n
|
||||||
double precision, intent(in) :: e0(n)
|
double precision, intent(inout) :: e0(n), L0(n,n), R0(n,n)
|
||||||
double precision, intent(inout) :: L0(n,n), R0(n,n)
|
integer, intent(out) :: deg_num(n)
|
||||||
|
|
||||||
logical :: complex_root
|
logical :: complex_root
|
||||||
integer :: i, j, k, m, ii
|
integer :: i, j, k, m, ii, j_tmp
|
||||||
double precision :: ei, ej, de, de_thr
|
double precision :: ei, ej, de, de_thr
|
||||||
double precision :: accu_d, accu_nd
|
double precision :: accu_d, accu_nd
|
||||||
integer, allocatable :: deg_num(:)
|
double precision :: e0_tmp, L0_tmp(n), R0_tmp(n)
|
||||||
double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:)
|
double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:)
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
allocate( deg_num(n) )
|
|
||||||
do i = 1, n
|
do i = 1, n
|
||||||
deg_num(i) = 1
|
deg_num(i) = 1
|
||||||
enddo
|
enddo
|
||||||
|
|
@ -1979,24 +1978,41 @@ subroutine reorder_degen_eigvec(n, e0, L0, R0)
|
||||||
ei = e0(i)
|
ei = e0(i)
|
||||||
|
|
||||||
! already considered in degen vectors
|
! already considered in degen vectors
|
||||||
if(deg_num(i).eq.0) cycle
|
if(deg_num(i) .eq. 0) cycle
|
||||||
|
|
||||||
|
ii = 0
|
||||||
do j = i+1, n
|
do j = i+1, n
|
||||||
ej = e0(j)
|
ej = e0(j)
|
||||||
de = dabs(ei - ej)
|
de = dabs(ei - ej)
|
||||||
|
|
||||||
if(de .lt. de_thr) then
|
if(de .lt. de_thr) then
|
||||||
deg_num(i) = deg_num(i) + 1
|
ii = ii + 1
|
||||||
deg_num(j) = 0
|
|
||||||
endif
|
j_tmp = i + ii
|
||||||
|
|
||||||
|
deg_num(j_tmp) = 0
|
||||||
|
|
||||||
|
e0_tmp = e0(j_tmp)
|
||||||
|
e0(j_tmp) = e0(j)
|
||||||
|
e0(j) = e0_tmp
|
||||||
|
|
||||||
|
L0_tmp(1:n) = L0(1:n,j_tmp)
|
||||||
|
L0(1:n,j_tmp) = L0(1:n,j)
|
||||||
|
L0(1:n,j) = L0_tmp(1:n)
|
||||||
|
|
||||||
|
R0_tmp(1:n) = R0(1:n,j_tmp)
|
||||||
|
R0(1:n,j_tmp) = R0(1:n,j)
|
||||||
|
R0(1:n,j) = R0_tmp(1:n)
|
||||||
|
endif
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
deg_num(i) = ii + 1
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
ii = 0
|
ii = 0
|
||||||
do i = 1, n
|
do i = 1, n
|
||||||
if(deg_num(i) .gt. 1) then
|
if(deg_num(i) .gt. 1) then
|
||||||
print *, ' degen on', i, deg_num(i), e0(i)
|
!print *, ' degen on', i, deg_num(i), e0(i)
|
||||||
ii = ii + 1
|
ii = ii + 1
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
|
|
@ -2011,55 +2027,55 @@ subroutine reorder_degen_eigvec(n, e0, L0, R0)
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
do i = 1, n
|
! do i = 1, n
|
||||||
m = deg_num(i)
|
! m = deg_num(i)
|
||||||
|
!
|
||||||
if(m .gt. 1) then
|
! if(m .gt. 1) then
|
||||||
|
!
|
||||||
allocate(L(n,m))
|
! allocate(L(n,m))
|
||||||
allocate(R(n,m),S(m,m))
|
! allocate(R(n,m),S(m,m))
|
||||||
|
!
|
||||||
do j = 1, m
|
! do j = 1, m
|
||||||
L(1:n,j) = L0(1:n,i+j-1)
|
! L(1:n,j) = L0(1:n,i+j-1)
|
||||||
R(1:n,j) = R0(1:n,i+j-1)
|
! R(1:n,j) = R0(1:n,i+j-1)
|
||||||
enddo
|
! enddo
|
||||||
|
!
|
||||||
call dgemm( 'T', 'N', m, m, n, 1.d0 &
|
! !call dgemm( 'T', 'N', m, m, n, 1.d0 &
|
||||||
, L, size(L, 1), R, size(R, 1) &
|
! ! , L, size(L, 1), R, size(R, 1) &
|
||||||
, 0.d0, S, size(S, 1) )
|
! ! , 0.d0, S, size(S, 1) )
|
||||||
|
! !print*, 'Overlap matrix '
|
||||||
print*, 'Overlap matrix '
|
! !accu_nd = 0.d0
|
||||||
accu_nd = 0.d0
|
! !do j = 1, m
|
||||||
do j = 1, m
|
! ! write(*,'(100(F16.10,X))') S(1:m,j)
|
||||||
write(*,'(100(F16.10,X))') S(1:m,j)
|
! ! do k = 1, m
|
||||||
do k = 1, m
|
! ! if(j==k) cycle
|
||||||
if(j==k) cycle
|
! ! accu_nd += dabs(S(j,k))
|
||||||
accu_nd += dabs(S(j,k))
|
! ! enddo
|
||||||
enddo
|
! !enddo
|
||||||
enddo
|
! !print*,'accu_nd = ',accu_nd
|
||||||
print*,'accu_nd = ',accu_nd
|
!! if(accu_nd .gt.1.d-10) then
|
||||||
! if(accu_nd .gt.1.d-10) then
|
!! stop
|
||||||
! stop
|
!! endif
|
||||||
! endif
|
!
|
||||||
do j = 1, m
|
! do j = 1, m
|
||||||
L0(1:n,i+j-1) = L(1:n,j)
|
! L0(1:n,i+j-1) = L(1:n,j)
|
||||||
R0(1:n,i+j-1) = R(1:n,j)
|
! R0(1:n,i+j-1) = R(1:n,j)
|
||||||
enddo
|
! enddo
|
||||||
|
!
|
||||||
deallocate(L, R, S)
|
! deallocate(L, R, S)
|
||||||
|
!
|
||||||
endif
|
! endif
|
||||||
enddo
|
! enddo
|
||||||
|
!
|
||||||
end subroutine reorder_degen_eigvec
|
end subroutine reorder_degen_eigvec
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
|
subroutine impose_biorthog_degen_eigvec(n, deg_num, e0, L0, R0)
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
integer, intent(in) :: n
|
integer, intent(in) :: n, deg_num(n)
|
||||||
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)
|
||||||
|
|
||||||
|
|
@ -2067,41 +2083,13 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
|
||||||
integer :: i, j, k, m
|
integer :: i, j, k, m
|
||||||
double precision :: ei, ej, de, de_thr
|
double precision :: ei, ej, de, de_thr
|
||||||
double precision :: accu_d, accu_nd
|
double precision :: accu_d, accu_nd
|
||||||
integer, allocatable :: deg_num(:)
|
|
||||||
double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:)
|
double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:)
|
||||||
|
|
||||||
! ---
|
!do i = 1, n
|
||||||
|
! if(deg_num(i) .gt. 1) then
|
||||||
allocate( deg_num(n) )
|
! print *, ' degen on', i, deg_num(i), e0(i)
|
||||||
do i = 1, n
|
! endif
|
||||||
deg_num(i) = 1
|
!enddo
|
||||||
enddo
|
|
||||||
|
|
||||||
de_thr = thr_degen_tc
|
|
||||||
|
|
||||||
do i = 1, n-1
|
|
||||||
ei = e0(i)
|
|
||||||
|
|
||||||
! already considered in degen vectors
|
|
||||||
if(deg_num(i).eq.0) cycle
|
|
||||||
|
|
||||||
do j = i+1, n
|
|
||||||
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
|
|
||||||
|
|
||||||
do i = 1, n
|
|
||||||
if(deg_num(i) .gt. 1) then
|
|
||||||
print *, ' degen on', i, deg_num(i), e0(i)
|
|
||||||
endif
|
|
||||||
enddo
|
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
|
|
@ -2110,8 +2098,7 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
|
||||||
|
|
||||||
if(m .gt. 1) then
|
if(m .gt. 1) then
|
||||||
|
|
||||||
allocate(L(n,m))
|
allocate(L(n,m), R(n,m), S(m,m))
|
||||||
allocate(R(n,m))
|
|
||||||
|
|
||||||
do j = 1, m
|
do j = 1, m
|
||||||
L(1:n,j) = L0(1:n,i+j-1)
|
L(1:n,j) = L0(1:n,i+j-1)
|
||||||
|
|
@ -2120,8 +2107,51 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
call impose_orthog_svd(n, m, R)
|
!print*, 'Overlap matrix before'
|
||||||
L(:,:) = R(:,:)
|
call dgemm( 'T', 'N', m, m, n, 1.d0 &
|
||||||
|
, L, size(L, 1), R, size(R, 1) &
|
||||||
|
, 0.d0, S, size(S, 1) )
|
||||||
|
|
||||||
|
accu_nd = 0.d0
|
||||||
|
do j = 1, m
|
||||||
|
!write(*,'(100(F16.10,X))') S(1:m,j)
|
||||||
|
do k = 1, m
|
||||||
|
if(j==k) cycle
|
||||||
|
accu_nd += dabs(S(j,k))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
if(accu_nd .lt. 1d-12) then
|
||||||
|
deallocate(S, L, R)
|
||||||
|
cycle
|
||||||
|
endif
|
||||||
|
|
||||||
|
!print*, ' accu_nd before = ', accu_nd
|
||||||
|
|
||||||
|
call impose_biorthog_svd(n, m, L, R)
|
||||||
|
|
||||||
|
!print*, 'Overlap matrix after'
|
||||||
|
call dgemm( 'T', 'N', m, m, n, 1.d0 &
|
||||||
|
, L, size(L, 1), R, size(R, 1) &
|
||||||
|
, 0.d0, S, size(S, 1) )
|
||||||
|
accu_nd = 0.d0
|
||||||
|
do j = 1, m
|
||||||
|
!write(*,'(100(F16.10,X))') S(1:m,j)
|
||||||
|
do k = 1, m
|
||||||
|
if(j==k) cycle
|
||||||
|
accu_nd += dabs(S(j,k))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!print*,' accu_nd after = ', accu_nd
|
||||||
|
if(accu_nd .gt. 1d-12) then
|
||||||
|
print*, ' your strategy for degenerates orbitals failed !'
|
||||||
|
print*, m, 'deg on', i
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
|
||||||
|
deallocate(S)
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
!call impose_orthog_svd(n, m, L)
|
!call impose_orthog_svd(n, m, L)
|
||||||
!call impose_orthog_GramSchmidt(n, m, L)
|
!call impose_orthog_GramSchmidt(n, m, L)
|
||||||
|
|
@ -2142,7 +2172,6 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
|
||||||
!call bi_ortho_s_inv_half(m, L, R, S_inv_half)
|
!call bi_ortho_s_inv_half(m, L, R, S_inv_half)
|
||||||
!deallocate(S, S_inv_half)
|
!deallocate(S, S_inv_half)
|
||||||
|
|
||||||
!call impose_biorthog_svd(n, m, L, R)
|
|
||||||
!call impose_biorthog_inverse(n, m, L, R)
|
!call impose_biorthog_inverse(n, m, L, R)
|
||||||
|
|
||||||
!call impose_biorthog_qr(n, m, thr_d, thr_nd, L, R)
|
!call impose_biorthog_qr(n, m, thr_d, thr_nd, L, R)
|
||||||
|
|
@ -2158,7 +2187,6 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
|
||||||
|
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
! call impose_biorthog_inverse(n, n, L0, R0)
|
|
||||||
|
|
||||||
end subroutine impose_biorthog_degen_eigvec
|
end subroutine impose_biorthog_degen_eigvec
|
||||||
|
|
||||||
|
|
@ -2526,18 +2554,16 @@ subroutine impose_biorthog_svd(n, m, L, R)
|
||||||
double precision, allocatable :: S(:,:), tmp(:,:)
|
double precision, allocatable :: S(:,:), tmp(:,:)
|
||||||
double precision, allocatable :: U(:,:), V(:,:), Vt(:,:), D(:)
|
double precision, allocatable :: U(:,:), V(:,:), Vt(:,:), D(:)
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
allocate(S(m,m))
|
allocate(S(m,m))
|
||||||
|
|
||||||
call dgemm( 'T', 'N', m, m, n, 1.d0 &
|
call dgemm( 'T', 'N', m, m, n, 1.d0 &
|
||||||
, L, size(L, 1), R, size(R, 1) &
|
, L, size(L, 1), R, size(R, 1) &
|
||||||
, 0.d0, S, size(S, 1) )
|
, 0.d0, S, size(S, 1) )
|
||||||
|
|
||||||
print *, ' 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
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
|
|
@ -2574,52 +2600,33 @@ subroutine impose_biorthog_svd(n, m, L, R)
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
||||||
allocate(tmp(n,m))
|
! R <-- R x V x D^{-0.5}
|
||||||
|
! L <-- L x U x D^{-0.5}
|
||||||
|
|
||||||
! tmp <-- R x V
|
|
||||||
call dgemm( 'N', 'N', n, m, m, 1.d0 &
|
|
||||||
, R, size(R, 1), V, size(V, 1) &
|
|
||||||
, 0.d0, tmp, size(tmp, 1) )
|
|
||||||
deallocate(V)
|
|
||||||
! R <-- tmp x sigma^-0.5
|
|
||||||
do j = 1, m
|
|
||||||
do i = 1, n
|
|
||||||
R(i,j) = tmp(i,j) * D(j)
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
|
|
||||||
! tmp <-- L x U
|
|
||||||
call dgemm( 'N', 'N', n, m, m, 1.d0 &
|
|
||||||
, L, size(L, 1), U, size(U, 1) &
|
|
||||||
, 0.d0, tmp, size(tmp, 1) )
|
|
||||||
deallocate(U)
|
|
||||||
! L <-- tmp x sigma^-0.5
|
|
||||||
do j = 1, m
|
|
||||||
do i = 1, n
|
|
||||||
L(i,j) = tmp(i,j) * D(j)
|
|
||||||
enddo
|
|
||||||
enddo
|
|
||||||
|
|
||||||
deallocate(D, tmp)
|
|
||||||
|
|
||||||
! ---
|
|
||||||
|
|
||||||
allocate(S(m,m))
|
|
||||||
call dgemm( 'T', 'N', m, m, n, 1.d0 &
|
|
||||||
, L, size(L, 1), R, size(R, 1) &
|
|
||||||
, 0.d0, S, size(S, 1) )
|
|
||||||
|
|
||||||
print *, ' overlap aft SVD: '
|
|
||||||
do i = 1, m
|
do i = 1, m
|
||||||
write(*, '(1000(F16.10,X))') S(i,:)
|
do j = 1, m
|
||||||
|
V(j,i) = V(j,i) * D(i)
|
||||||
|
U(j,i) = U(j,i) * D(i)
|
||||||
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
deallocate(S)
|
allocate(tmp(n,m))
|
||||||
|
tmp(:,:) = R(:,:)
|
||||||
|
call dgemm( 'N', 'N', n, m, m, 1.d0 &
|
||||||
|
, tmp, size(tmp, 1), V, size(V, 1) &
|
||||||
|
, 0.d0, R, size(R, 1))
|
||||||
|
|
||||||
! ---
|
tmp(:,:) = L(:,:)
|
||||||
|
call dgemm( 'N', 'N', n, m, m, 1.d0 &
|
||||||
|
, tmp, size(tmp, 1), U, size(U, 1) &
|
||||||
|
, 0.d0, L, size(L, 1))
|
||||||
|
|
||||||
|
deallocate(tmp, U, V, D)
|
||||||
|
|
||||||
end subroutine impose_biorthog_svd
|
end subroutine impose_biorthog_svd
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
subroutine impose_biorthog_inverse(n, m, L, R)
|
subroutine impose_biorthog_inverse(n, m, L, R)
|
||||||
|
|
||||||
implicit none
|
implicit none
|
||||||
|
|
@ -2661,7 +2668,7 @@ subroutine impose_biorthog_inverse(n, m, L, R)
|
||||||
deallocate(S,Lt)
|
deallocate(S,Lt)
|
||||||
|
|
||||||
|
|
||||||
end subroutine impose_biorthog_svd
|
end subroutine impose_biorthog_inverse
|
||||||
|
|
||||||
|
|
||||||
! ---
|
! ---
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user