PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2025-05-06 23:25:01 +02:00
Code Releases Activity

Remove orthoqr csf.

Browse Source
This commit is contained in:
v1j4y 2022-11-23 12:10:22 +01:00
parent f2f9b9ffd0
commit 57bb5ed4dd
2 changed files with 146 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
src/csf/cfgCI_utils.c
View File

@ -253,25 +253,25 @@ void generateAllBFs(int64_t Isomo, int64_t MS, Tree *bftree, int *NBF, int *NSOM
buildTreeDriver(bftree, *NSOMO, MS, NBF); buildTreeDriver(bftree, *NSOMO, MS, NBF);
} }
void ortho_qr_csf(double *overlapMatrix, int lda, double *orthoMatrix, int rows, int cols); //void ortho_qr_csf(double *overlapMatrix, int lda, double *orthoMatrix, int rows, int cols);
void gramSchmidt_qp(double *overlapMatrix, int rows, int cols, double *orthoMatrix){ //void gramSchmidt_qp(double *overlapMatrix, int rows, int cols, double *orthoMatrix){
int i,j; // int i,j;
//for(j=0;j<cols;++j){ // //for(j=0;j<cols;++j){
// for(i=0;i<rows;++i){ // // for(i=0;i<rows;++i){
// printf(" %3.2f ",overlapMatrix[j*rows + i]); // // printf(" %3.2f ",overlapMatrix[j*rows + i]);
// } // // }
// printf("\n"); // // printf("\n");
//} // //}
// Call the function ortho_qr from qp // // Call the function ortho_qr from qp
ortho_qr_csf(overlapMatrix, rows, orthoMatrix, rows, cols); // ortho_qr_csf(overlapMatrix, rows, orthoMatrix, rows, cols);
//for(j=0;j<cols;++j){ // //for(j=0;j<cols;++j){
// for(i=0;i<rows;++i){ // // for(i=0;i<rows;++i){
// printf(" %3.2f ",orthoMatrix[j*rows + i]); // // printf(" %3.2f ",orthoMatrix[j*rows + i]);
// } // // }
// printf("\n"); // // printf("\n");
//} // //}
} //}
void gramSchmidt(double *overlapMatrix, int rows, int cols, double *orthoMatrix){ void gramSchmidt(double *overlapMatrix, int rows, int cols, double *orthoMatrix){

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

@ -458,37 +458,37 @@ subroutine ortho_canonical_complex(overlap,LDA,N,C,LDC,m,cutoff)
end end
subroutine ortho_qr_complex(A,LDA,m,n) !!subroutine ortho_qr_complex(A,LDA,m,n)
implicit none !! implicit none
BEGIN_DOC !! BEGIN_DOC
! Orthogonalization using Q.R factorization !! ! Orthogonalization using Q.R factorization
! !! !
! A : matrix to orthogonalize !! ! A : matrix to orthogonalize
! !! !
! LDA : leftmost dimension of A !! ! LDA : leftmost dimension of A
! !! !
! n : Number of rows of A !! ! n : Number of rows of A
! !! !
! m : Number of columns of A !! ! m : Number of columns of A
! !! !
END_DOC !! END_DOC
integer, intent(in) :: m,n, LDA !! integer, intent(in) :: m,n, LDA
complex*16, intent(inout) :: A(LDA,n) !! complex*16, intent(inout) :: A(LDA,n)
!!
integer :: lwork, info !! integer :: lwork, info
integer, allocatable :: jpvt(:) !! integer, allocatable :: jpvt(:)
complex*16, allocatable :: tau(:), work(:) !! complex*16, allocatable :: tau(:), work(:)
!!
allocate (jpvt(n), tau(n), work(1)) !! allocate (jpvt(n), tau(n), work(1))
LWORK=-1 !! LWORK=-1
call zgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) !! call zgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO )
LWORK=2*int(WORK(1)) !! LWORK=2*int(WORK(1))
deallocate(WORK) !! deallocate(WORK)
allocate(WORK(LWORK)) !! allocate(WORK(LWORK))
call zgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO ) !! call zgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO )
call zungqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO) !! call zungqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO)
deallocate(WORK,jpvt,tau) !! deallocate(WORK,jpvt,tau)
end !!end
subroutine ortho_qr_unblocked_complex(A,LDA,m,n) subroutine ortho_qr_unblocked_complex(A,LDA,m,n)
implicit none implicit none
@ -1132,103 +1132,103 @@ subroutine ortho_svd(A,LDA,m,n)
deallocate(U,D, Vt) deallocate(U,D, Vt)
end end
!!
subroutine ortho_qr_withB(A,LDA,B,m,n) !!subroutine ortho_qr_withB(A,LDA,B,m,n)
implicit none !! implicit none
BEGIN_DOC !! BEGIN_DOC
! Orthogonalization using Q.R factorization !! ! Orthogonalization using Q.R factorization
! !! !
! A : Overlap Matrix !! ! A : Overlap Matrix
! !! !
! LDA : leftmost dimension of A !! ! LDA : leftmost dimension of A
! !! !
! m : Number of rows of A !! ! m : Number of rows of A
! !! !
! n : Number of columns of A !! ! n : Number of columns of A
! !! !
! B : Output orthogonal basis !! ! B : Output orthogonal basis
! !! !
END_DOC !! END_DOC
integer, intent(in) :: m,n, LDA !! integer, intent(in) :: m,n, LDA
double precision, intent(inout) :: A(LDA,n) !! double precision, intent(inout) :: A(LDA,n)
double precision, intent(inout) :: B(LDA,n) !! double precision, intent(inout) :: B(LDA,n)
!!
integer :: LWORK, INFO !! integer :: LWORK, INFO
integer, allocatable :: jpvt(:) !! integer, allocatable :: jpvt(:)
double precision, allocatable :: TAU(:), WORK(:) !! double precision, allocatable :: TAU(:), WORK(:)
double precision, allocatable :: C(:,:) !! double precision, allocatable :: C(:,:)
double precision :: norm !! double precision :: norm
integer :: i,j !! integer :: i,j
!!
allocate (TAU(min(m,n)), WORK(1)) !! allocate (TAU(min(m,n)), WORK(1))
allocate (jpvt(n)) !! allocate (jpvt(n))
!print *," In function ortho" !! !print *," In function ortho"
B = A !! B = A
!!
jpvt(1:n)=1 !! jpvt(1:n)=1
!!
LWORK=-1 !! LWORK=-1
call dgeqp3( m, n, A, LDA, jpvt, TAU, WORK, LWORK, INFO ) !! call dgeqp3( m, n, A, LDA, jpvt, TAU, WORK, LWORK, INFO )
!!
! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 !! ! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648
LWORK=max(n,int(WORK(1))) !! LWORK=max(n,int(WORK(1)))
!!
deallocate(WORK) !! deallocate(WORK)
allocate(WORK(LWORK)) !! allocate(WORK(LWORK))
call dgeqp3(m, n, A, LDA, jpvt, TAU, WORK, LWORK, INFO ) !! call dgeqp3(m, n, A, LDA, jpvt, TAU, WORK, LWORK, INFO )
print *,A !! print *,A
print *,jpvt !! print *,jpvt
deallocate(WORK,TAU) !! deallocate(WORK,TAU)
!stop !! !stop
!!
!LWORK=-1 !! !LWORK=-1
!call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) !! !call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO )
!! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 !! !! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648
!LWORK=max(n,int(WORK(1))) !! !LWORK=max(n,int(WORK(1)))
!!
!deallocate(WORK) !! !deallocate(WORK)
!allocate(WORK(LWORK)) !! !allocate(WORK(LWORK))
!call dgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO ) !! !call dgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO )
!!
!LWORK=-1 !! !LWORK=-1
!call dorgqr(m, n, n, A, LDA, TAU, WORK, LWORK, INFO) !! !call dorgqr(m, n, n, A, LDA, TAU, WORK, LWORK, INFO)
!! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 !! !! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648
!LWORK=max(n,int(WORK(1))) !! !LWORK=max(n,int(WORK(1)))
!!
!deallocate(WORK) !! !deallocate(WORK)
!allocate(WORK(LWORK)) !! !allocate(WORK(LWORK))
!call dorgqr(m, n, n, A, LDA, TAU, WORK, LWORK, INFO) !! !call dorgqr(m, n, n, A, LDA, TAU, WORK, LWORK, INFO)
! !! !
!allocate(C(LDA,n)) !! !allocate(C(LDA,n))
!call dgemm('N','N',m,n,n,1.0d0,B,LDA,A,LDA,0.0d0,C,LDA) !! !call dgemm('N','N',m,n,n,1.0d0,B,LDA,A,LDA,0.0d0,C,LDA)
!norm = 0.0d0 !! !norm = 0.0d0
!B = 0.0d0 !! !B = 0.0d0
!!print *,C !! !!print *,C
!do i=1,m !! !do i=1,m
! norm = 0.0d0 !! ! norm = 0.0d0
! do j=1,n !! ! do j=1,n
! norm = norm + C(j,i)*C(j,i) !! ! norm = norm + C(j,i)*C(j,i)
! end do !! ! end do
! norm = 1.0d0/dsqrt(norm) !! ! norm = 1.0d0/dsqrt(norm)
! do j=1,n !! ! do j=1,n
! B(j,i) = C(j,i) !! ! B(j,i) = C(j,i)
! end do !! ! end do
!end do !! !end do
!print *,B !! !print *,B
!!
!!
!deallocate(WORK,TAU) !! !deallocate(WORK,TAU)
end !!end
!!
subroutine ortho_qr_csf(A, LDA, B, m, n) bind(C, name="ortho_qr_csf") !!subroutine ortho_qr_csf(A, LDA, B, m, n) bind(C, name="ortho_qr_csf")
use iso_c_binding !! use iso_c_binding
integer(c_int32_t), value :: LDA !! integer(c_int32_t), value :: LDA
integer(c_int32_t), value :: m !! integer(c_int32_t), value :: m
integer(c_int32_t), value :: n !! integer(c_int32_t), value :: n
integer(c_int16_t) :: A(LDA,n) !! integer(c_int16_t) :: A(LDA,n)
integer(c_int16_t) :: B(LDA,n) !! integer(c_int16_t) :: B(LDA,n)
call ortho_qr_withB(A,LDA,B,m,n) !! call ortho_qr_withB(A,LDA,B,m,n)
end subroutine ortho_qr_csf !!end subroutine ortho_qr_csf
subroutine ortho_qr(A,LDA,m,n) subroutine ortho_qr(A,LDA,m,n)
implicit none implicit none