PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-07-22 18:57:36 +02:00
Code Releases Activity

OPENMP & DGEMM in pseudo_inv

Browse Source
This commit is contained in:
AbdAmmar 2024-01-25 22:13:13 +01:00
parent 3cab869c2d
commit 8018440410
1 changed files with 39 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
src/utils/linear_algebra.irp.f
View File

@ -1321,19 +1321,22 @@ subroutine get_inverse(A,LDA,m,C,LDC)
deallocate(ipiv,work) deallocate(ipiv,work)
end end
subroutine get_pseudo_inverse(A,LDA,m,n,C,LDC,cutoff) subroutine get_pseudo_inverse(A, LDA, m, n, C, LDC, cutoff)
implicit none
BEGIN_DOC BEGIN_DOC
! Find C = A^-1 ! Find C = A^-1
END_DOC END_DOC
integer, intent(in) :: m,n, LDA, LDC
double precision, intent(in) :: A(LDA,n)
double precision, intent(in) :: cutoff
double precision, intent(out) :: C(LDC,m)
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A_tmp(:,:) implicit none
integer :: info, lwork integer, intent(in) :: m, n, LDA, LDC
integer :: i,j,k double precision, intent(in) :: A(LDA,n)
double precision, intent(in) :: cutoff
double precision, intent(out) :: C(LDC,m)
integer :: info, lwork
integer :: i, j, k, n_svd
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A_tmp(:,:)
allocate (D(n),U(m,n),Vt(n,n),work(1),A_tmp(m,n)) allocate (D(n),U(m,n),Vt(n,n),work(1),A_tmp(m,n))
do j=1,n do j=1,n
do i=1,m do i=1,m
@ -1355,22 +1358,40 @@ subroutine get_pseudo_inverse(A,LDA,m,n,C,LDC,cutoff)
stop 1 stop 1
endif endif
do i=1,n n_svd = 0
if (D(i)/D(1) > cutoff) then do i = 1, n
D(i) = 1.d0/D(i) if(D(i)/D(1) > cutoff) then
D(i) = 1.d0 / D(i)
n_svd = n_svd + 1
else else
D(i) = 0.d0 D(i) = 0.d0
endif endif
enddo enddo
print*, ' n_svd = ', n_svd
C = 0.d0 !$OMP PARALLEL &
do i=1,m !$OMP DEFAULT (NONE) &
do j=1,n !$OMP PRIVATE (i, j) &
do k=1,n !$OMP SHARED (n, n_svd, D, Vt)
C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j) !$OMP DO
enddo do j = 1, n
do i = 1, n_svd
Vt(i,j) = D(i) * Vt(i,j)
enddo enddo
enddo enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm("N", "N", m, n, n_svd, 1.d0, U, m, Vt, n, 0.d0, C, LDC)
!C = 0.d0
!do i=1,m
! do j=1,n
! do k=1,n
! C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j)
! enddo
! enddo
!enddo
deallocate(U,D,Vt,work,A_tmp) deallocate(U,D,Vt,work,A_tmp)