LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-11-03 20:54:00 +01:00
Code Issues Releases Wiki Activity

Fixed linear-dep threshold

Browse Source
This commit is contained in:
Anthony Scemama 2018-01-08 18:26:51 +01:00
parent a68f3bb909
commit 9d1ab2848d
2 changed files with 7 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
src/Utils/LinearAlgebra.irp.f
View File

@ -81,10 +81,11 @@ subroutine ortho_canonical(overlap,LDA,N,C,LDC,m)
call svd(overlap,lda,U,ldc,D,Vt,lda,n,n) call svd(overlap,lda,U,ldc,D,Vt,lda,n,n)
D(:) = dsqrt(D(:))
m=n m=n
do i=1,n do i=1,n
if ( D(i) >= 1.d-6 ) then if ( D(i) >= 1.d-6 ) then
D(i) = 1.d0/dsqrt(D(i)) D(i) = 1.d0/D(i)
else else
m = i-1 m = i-1
print *, 'Removed Linear dependencies below:', 1.d0/D(m) print *, 'Removed Linear dependencies below:', 1.d0/D(m)
@ -101,25 +102,19 @@ subroutine ortho_canonical(overlap,LDA,N,C,LDC,m)
endif endif
enddo enddo
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(S,U,D,Vt,n,C,m) &
!$OMP PRIVATE(i,j)
!$OMP DO
do j=1,n do j=1,n
do i=1,n do i=1,n
S(i,j) = U(i,j)*D(j) S(i,j) = U(i,j)*D(j)
enddo enddo
enddo
do j=1,n
do i=1,n do i=1,n
U(i,j) = C(i,j) U(i,j) = C(i,j)
enddo enddo
enddo enddo
!$OMP END DO
!$OMP END PARALLEL call dgemm('N','N',n,n,n,1.d0,U,size(U,1),S,size(S,1),0.d0,C,size(C,1))
call dgemm('N','N',n,m,n,1.d0,U,size(U,1),S,size(S,1),0.d0,C,size(C,1))
deallocate (U, Vt, D, S) deallocate (U, Vt, D, S)
end end