mirror of
https://gitlab.com/scemama/qp_plugins_scemama.git
synced 2025-01-03 01:55:52 +01:00
saved 3 fichiers
This commit is contained in:
Abdallah Ammar
parent
e3bc5b8c40
commit
b012a115c7
451
devel/svdwf/Evar_TruncSVD.irp.f
Normal file
451
devel/svdwf/Evar_TruncSVD.irp.f
Normal file
@ -0,0 +1,451 @@
|
|||||||
|
program Evar_TruncSVD
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! study energy variation with truncated SVD
|
||||||
|
END_DOC
|
||||||
|
read_wf = .True.
|
||||||
|
TOUCH read_wf
|
||||||
|
! !!!
|
||||||
|
call run()
|
||||||
|
! !!!
|
||||||
|
end
|
||||||
|
! !!!
|
||||||
|
subroutine run
|
||||||
|
! !!!
|
||||||
|
implicit none
|
||||||
|
include 'constants.include.F'
|
||||||
|
! !!!
|
||||||
|
integer :: m, n, i_state
|
||||||
|
double precision :: error_thr, error_RRRSVD, norm_psi, norm_SVD, err_verif, err_tmp
|
||||||
|
integer :: i, j, k, l, It, PowerIt
|
||||||
|
integer :: It_max, PowerIt_max, nb_oversamp
|
||||||
|
integer :: r_init, delta_r, low_rank
|
||||||
|
double precision, allocatable :: B_old(:,:), Q_old(:,:)
|
||||||
|
double precision, allocatable :: UB(:,:), D(:), Vt(:,:), U(:,:)
|
||||||
|
double precision, allocatable :: P(:,:), r1(:,:)
|
||||||
|
double precision, allocatable :: Q_new(:,:), Q_tmp(:,:), Q_mult(:,:)
|
||||||
|
double precision, allocatable :: B_new(:,:), B_tmp(:,:)
|
||||||
|
double precision, allocatable :: URSVD(:,:), DRSVD(:), VtRSVD(:,:)
|
||||||
|
double precision, allocatable :: Uverif(:,:), Dverif(:), Vtverif(:,:), Averif(:,:)
|
||||||
|
double precision, allocatable :: Uezfio(:,:,:), Dezfio(:,:), Vezfio(:,:,:)
|
||||||
|
double precision :: tmp
|
||||||
|
! !!!
|
||||||
|
i_state = 1
|
||||||
|
m = n_det_alpha_unique
|
||||||
|
n = n_det_beta_unique
|
||||||
|
! !!!
|
||||||
|
!open(111, file = 'data_to_python.txt', action = 'WRITE' )
|
||||||
|
! do k = 1, N_det
|
||||||
|
! write(111, '(I8, 5X, I8, 5X, E15.7)' ) psi_bilinear_matrix_rows(k), psi_bilinear_matrix_columns(k), psi_bilinear_matrix_values(k,i_state)
|
||||||
|
! end do
|
||||||
|
!close(111)
|
||||||
|
! !!!
|
||||||
|
! !!!
|
||||||
|
print *, 'matrix:', m,'x',n
|
||||||
|
print *, 'N det:', N_det
|
||||||
|
! !!!
|
||||||
|
r_init = 78 !!!42
|
||||||
|
delta_r = 1
|
||||||
|
! !!!
|
||||||
|
PowerIt_max = 10
|
||||||
|
nb_oversamp = 10
|
||||||
|
! !!!
|
||||||
|
It_max = 10
|
||||||
|
error_thr = 1.d-3 !not stable if less thant 0.001
|
||||||
|
! !!!
|
||||||
|
! !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! !
|
||||||
|
! !!! ~ Rank Revealing Randomized SVD ~ !!! !
|
||||||
|
! !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! !
|
||||||
|
! !!!
|
||||||
|
norm_psi = 0.d0
|
||||||
|
do k = 1, N_det
|
||||||
|
norm_psi = norm_psi + psi_bilinear_matrix_values(k,i_state) * psi_bilinear_matrix_values(k,i_state)
|
||||||
|
enddo
|
||||||
|
! !!!
|
||||||
|
! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !
|
||||||
|
! !!! build initial QB decomposition !!! !
|
||||||
|
! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !
|
||||||
|
! !!!
|
||||||
|
allocate( Q_old(m, r_init) )
|
||||||
|
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,k,l,r1)
|
||||||
|
allocate( r1(N_det,2) )
|
||||||
|
!$OMP DO
|
||||||
|
do l = 1, r_init
|
||||||
|
Q_old(:,l) = 0.d0
|
||||||
|
call random_number(r1)
|
||||||
|
r1(:,1) = dsqrt(-2.d0*dlog(r1(:,1)))
|
||||||
|
r1(:,1) = r1(:,1) * dcos(dtwo_pi*r1(:,2))
|
||||||
|
do k = 1, N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
Q_old(i,l) = Q_old(i,l) + psi_bilinear_matrix_values(k,i_state) * r1(k,1)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
deallocate(r1)
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
! !!!
|
||||||
|
! power scheme
|
||||||
|
! !!!
|
||||||
|
allocate( P(n, r_init) )
|
||||||
|
do PowerIt = 1, PowerIt_max
|
||||||
|
! !!!
|
||||||
|
call my_ortho_qr(Q_old, size(Q_old,1), m, r_init)
|
||||||
|
! !!!
|
||||||
|
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l)
|
||||||
|
!$OMP DO
|
||||||
|
do l = 1, r_init
|
||||||
|
P(:,l) = 0.d0
|
||||||
|
do k = 1, N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
j = psi_bilinear_matrix_columns(k)
|
||||||
|
P(j,l) = P(j,l) + psi_bilinear_matrix_values(k,i_state) * Q_old(i,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
! !!!
|
||||||
|
call my_ortho_qr(P, size(P,1), n, r_init)
|
||||||
|
! !!!
|
||||||
|
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l)
|
||||||
|
!$OMP DO
|
||||||
|
do l = 1, r_init
|
||||||
|
Q_old(:,l) = 0.d0
|
||||||
|
do k = 1 , N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
j = psi_bilinear_matrix_columns(k)
|
||||||
|
Q_old(i,l) = Q_old(i,l) + psi_bilinear_matrix_values(k,i_state) * P(j,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
! !!!
|
||||||
|
enddo
|
||||||
|
deallocate( P )
|
||||||
|
! !!!
|
||||||
|
call my_ortho_qr(Q_old, size(Q_old,1), m, r_init)
|
||||||
|
! !!!
|
||||||
|
allocate( B_old(r_init,n) )
|
||||||
|
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l)
|
||||||
|
!$OMP DO
|
||||||
|
do l = 1, r_init
|
||||||
|
B_old(l,:) = 0.d0
|
||||||
|
do k = 1, N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
j = psi_bilinear_matrix_columns(k)
|
||||||
|
B_old(l,j) = B_old(l,j) + Q_old(i,l) * psi_bilinear_matrix_values(k,i_state)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
norm_SVD = 0.d0
|
||||||
|
do j = 1, n
|
||||||
|
do l = 1, r_init
|
||||||
|
norm_SVD = norm_SVD + B_old(l,j) * B_old(l,j)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
error_RRRSVD = dabs( norm_psi - norm_SVD ) / norm_psi
|
||||||
|
It = 1
|
||||||
|
low_rank = r_init
|
||||||
|
print *, It, low_rank, error_RRRSVD
|
||||||
|
! !!!
|
||||||
|
! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !
|
||||||
|
! !!! incrementally build up QB decomposition !!! !
|
||||||
|
! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !
|
||||||
|
! !!!
|
||||||
|
do while( ( error_RRRSVD.gt.error_thr ).and.( It.lt.It_max ).and.( low_rank.lt.(min(m,n)-delta_r) ) )
|
||||||
|
! !!!
|
||||||
|
allocate( Q_new(m,delta_r) )
|
||||||
|
allocate( r1(N_det, 2) )
|
||||||
|
do l = 1, delta_r
|
||||||
|
Q_new(:,l) = 0.d0
|
||||||
|
call random_number(r1)
|
||||||
|
r1(:,1) = dsqrt(-2.d0*dlog(r1(:,1)))
|
||||||
|
r1(:,1) = r1(:,1) * dcos(dtwo_pi*r1(:,2))
|
||||||
|
do k = 1, N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
Q_new(i,l) = Q_new(i,l) + psi_bilinear_matrix_values(k,i_state) * r1(k,1)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
deallocate(r1)
|
||||||
|
! !!!
|
||||||
|
! orthogonalization with Q_old: Q_new = Q_new - Q_old @ Q_old.T @ Q_new
|
||||||
|
! !!!
|
||||||
|
!allocate( Q_mult(m,m) )
|
||||||
|
!call dgemm( 'N', 'T', m, m, low_rank, +1.d0, Q_old, size(Q_old,1), Q_old, size(Q_old,1), 0.d0, Q_mult, size(Q_mult,1) )
|
||||||
|
!!do i = 1, m
|
||||||
|
!! do j = 1, m
|
||||||
|
!! Q_mult(j,i) = 0.d0
|
||||||
|
!! do l = 1, low_rank
|
||||||
|
!! Q_mult(j,i) = Q_mult(j,i) + Q_old(i,l) * Q_old(j,l)
|
||||||
|
!! enddo
|
||||||
|
!! enddo
|
||||||
|
!!enddo
|
||||||
|
!!call dgemm( 'N', 'N', m, delta_r, m, -1.d0, Q_mult, size(Q_mult,1), Q_new, size(Q_new,1), 1.d0, Q_new, size(Q_new,1) )
|
||||||
|
!do l = 1, delta_r
|
||||||
|
! do i = 1, m
|
||||||
|
! tmp = 0.d0
|
||||||
|
! do j = 1, m
|
||||||
|
! tmp = tmp + Q_mult(i,j) * Q_new(j,l)
|
||||||
|
! enddo
|
||||||
|
! Q_new(i,l) = Q_new(i,l) - tmp
|
||||||
|
! enddo
|
||||||
|
!enddo
|
||||||
|
!deallocate( Q_mult )
|
||||||
|
! !!!
|
||||||
|
! power scheme
|
||||||
|
! !!!
|
||||||
|
allocate( P(n, delta_r) )
|
||||||
|
do PowerIt = 1, PowerIt_max
|
||||||
|
! !!!
|
||||||
|
call my_ortho_qr(Q_new, size(Q_new,1), m, delta_r)
|
||||||
|
! !!!
|
||||||
|
do l = 1, delta_r
|
||||||
|
P(:,l) = 0.d0
|
||||||
|
do k = 1, N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
j = psi_bilinear_matrix_columns(k)
|
||||||
|
P(j,l) = P(j,l) + psi_bilinear_matrix_values(k,i_state) * Q_new(i,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
! !!!
|
||||||
|
call my_ortho_qr(P, size(P,1), n, delta_r)
|
||||||
|
! !!!
|
||||||
|
do l = 1, delta_r
|
||||||
|
Q_new(:,l) = 0.d0
|
||||||
|
do k = 1, N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
j = psi_bilinear_matrix_columns(k)
|
||||||
|
Q_new(i,l) = Q_new(i,l) + psi_bilinear_matrix_values(k,i_state) * P(j,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
! !!!
|
||||||
|
enddo
|
||||||
|
deallocate( P )
|
||||||
|
! !!!
|
||||||
|
! orthogonalization with Q_old: Q_new = Q_new - Q_old @ Q_old.T @ Q_new
|
||||||
|
! !!!
|
||||||
|
allocate( Q_mult(m,m) )
|
||||||
|
call dgemm( 'N', 'T', m, m, low_rank, +1.d0, Q_old, size(Q_old,1), Q_old, size(Q_old,1), 0.d0, Q_mult, size(Q_mult,1) )
|
||||||
|
!do i = 1, m
|
||||||
|
! do j = 1, m
|
||||||
|
! Q_mult(j,i) = 0.d0
|
||||||
|
! do l = 1, low_rank
|
||||||
|
! Q_mult(j,i) = Q_mult(j,i) + Q_old(i,l) * Q_old(j,l)
|
||||||
|
! enddo
|
||||||
|
! enddo
|
||||||
|
!enddo
|
||||||
|
!call dgemm( 'N', 'N', m, delta_r, m, -1.d0, Q_mult, size(Q_mult,1), Q_new, size(Q_new,1), 1.d0, Q_new, size(Q_new,1) )
|
||||||
|
do l = 1, delta_r
|
||||||
|
do i = 1, m
|
||||||
|
tmp = 0.d0
|
||||||
|
do j = 1, m
|
||||||
|
tmp = tmp + Q_mult(i,j) * Q_new(j,l)
|
||||||
|
enddo
|
||||||
|
Q_new(i,l) = Q_new(i,l) - tmp
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
deallocate( Q_mult )
|
||||||
|
! !!!
|
||||||
|
call my_ortho_qr(Q_new, size(Q_new,1), m, delta_r)
|
||||||
|
! !!!
|
||||||
|
allocate( B_new(delta_r,n) )
|
||||||
|
do l = 1 , delta_r
|
||||||
|
B_new(l,:) = 0.d0
|
||||||
|
do k = 1 , N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
j = psi_bilinear_matrix_columns(k)
|
||||||
|
B_new(l,j) = B_new(l,j) + Q_new(i,l) * psi_bilinear_matrix_values(k,i_state)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
! !!!
|
||||||
|
do j = 1, n
|
||||||
|
do l = 1, delta_r
|
||||||
|
norm_SVD = norm_SVD + B_new(l,j) * B_new(l,j)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
! !!!
|
||||||
|
error_RRRSVD = dabs( norm_psi - norm_SVD ) / norm_psi
|
||||||
|
It = It + 1
|
||||||
|
low_rank = low_rank + delta_r
|
||||||
|
! !!!
|
||||||
|
! build up approximate basis:
|
||||||
|
! Q_old = np.append(Q_new, Q_old, axis=1)
|
||||||
|
! B = np.append(B_new, B, axis=0)
|
||||||
|
! !!!
|
||||||
|
allocate( Q_tmp(m,low_rank) , B_tmp(low_rank,n) )
|
||||||
|
! !!!
|
||||||
|
!do l = 1, delta_r
|
||||||
|
! do i = 1, m
|
||||||
|
! Q_tmp(i,l) = Q_new(i,l)
|
||||||
|
! enddo
|
||||||
|
!enddo
|
||||||
|
!do l = 1 , low_rank-delta_r
|
||||||
|
! do i = 1, m
|
||||||
|
! Q_tmp(i,l+delta_r) = Q_old(i,l)
|
||||||
|
! enddo
|
||||||
|
!enddo
|
||||||
|
!do i = 1, n
|
||||||
|
! do l = 1 , delta_r
|
||||||
|
! B_tmp(l,i) = B_new(l,i)
|
||||||
|
! enddo
|
||||||
|
!enddo
|
||||||
|
!do i = 1, n
|
||||||
|
! do l = 1 , low_rank-delta_r
|
||||||
|
! B_tmp(l+delta_r,i) = B_old(l,i)
|
||||||
|
! enddo
|
||||||
|
!enddo
|
||||||
|
! !!!
|
||||||
|
do i = 1, m
|
||||||
|
do l = 1, low_rank-delta_r
|
||||||
|
Q_tmp(i,l) = Q_old(i,l)
|
||||||
|
enddo
|
||||||
|
do l = 1, delta_r
|
||||||
|
Q_tmp(i,l+low_rank-delta_r) = Q_new(i,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
do i = 1, n
|
||||||
|
do l = 1 , low_rank-delta_r
|
||||||
|
B_tmp(l,i) = B_old(l,i)
|
||||||
|
enddo
|
||||||
|
do l = 1 , delta_r
|
||||||
|
B_tmp(l+low_rank-delta_r,i) = B_new(l,i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
! !!!
|
||||||
|
deallocate( Q_old, B_old, Q_new, B_new )
|
||||||
|
allocate( Q_old(m,low_rank) , B_old(low_rank,n) )
|
||||||
|
! !!!
|
||||||
|
do l = 1, low_rank
|
||||||
|
do i = 1, m
|
||||||
|
Q_old(i,l) = Q_tmp(i,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
do l = 1, n
|
||||||
|
do i = 1, low_rank
|
||||||
|
B_old(i,l) = B_tmp(i,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
deallocate( Q_tmp , B_tmp )
|
||||||
|
! !!!
|
||||||
|
print *, It, low_rank, error_RRRSVD
|
||||||
|
! !!!
|
||||||
|
enddo
|
||||||
|
! !!!
|
||||||
|
! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !
|
||||||
|
! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !
|
||||||
|
! !!!
|
||||||
|
allocate( UB(low_rank,low_rank), D(low_rank), Vt(low_rank,n) )
|
||||||
|
call svd_s(B_old, size(B_old,1), UB, size(UB,1), D, Vt, size(Vt,1), low_rank, n)
|
||||||
|
deallocate(B_old)
|
||||||
|
print*, 'ok 1'
|
||||||
|
! !!!
|
||||||
|
allocate( U(m,low_rank) )
|
||||||
|
call dgemm('N', 'N', m, low_rank, low_rank, 1.d0, Q_old, size(Q_old,1), UB, size(UB,1), 0.d0, U, size(U,1))
|
||||||
|
deallocate( Q_old,UB )
|
||||||
|
print*, 'ok 2'
|
||||||
|
! !!!
|
||||||
|
! !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! !
|
||||||
|
! !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! !
|
||||||
|
! !!!
|
||||||
|
allocate( URSVD(m,low_rank), DRSVD(low_rank), VtRSVD(low_rank,n) )
|
||||||
|
call RSVD( i_state, low_rank, PowerIt_max, nb_oversamp, URSVD, DRSVD, VtRSVD )
|
||||||
|
print*, 'ok 3'
|
||||||
|
! !!!
|
||||||
|
! !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! !
|
||||||
|
! !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! !
|
||||||
|
! !!!
|
||||||
|
allocate( Averif(m,n), Uverif(m,n), Dverif(n), Vtverif(n,n) )
|
||||||
|
do i = 1, n
|
||||||
|
Averif(:,i) = 1d-16
|
||||||
|
enddo
|
||||||
|
do k = 1, N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
j = psi_bilinear_matrix_columns(k)
|
||||||
|
Averif(i,j) = psi_bilinear_matrix_values(k,i_state)
|
||||||
|
enddo
|
||||||
|
call svd_s( Averif, size(Averif,1), Uverif, size(Uverif,1), Dverif, Vtverif, size(Vtverif,1), m, n)
|
||||||
|
print*, 'ok 4'
|
||||||
|
! !!!
|
||||||
|
err_verif = 0.d0
|
||||||
|
do j = 1, n
|
||||||
|
do i = 1, m
|
||||||
|
err_tmp = 0.d0
|
||||||
|
do l = 1, low_rank
|
||||||
|
err_tmp = err_tmp + Dverif(l) * Uverif(i,l) * Vtverif(l,j)
|
||||||
|
enddo
|
||||||
|
err_verif = err_verif + ( Averif(i,j) - err_tmp )**2.d0
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*, 'err verif (%) = ', 100.d0 * dsqrt(err_verif/norm_psi)
|
||||||
|
! !!!
|
||||||
|
! !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! !
|
||||||
|
! !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! ~ !!! !
|
||||||
|
! !!!
|
||||||
|
open(111, file = 'singular_values.txt', action = 'WRITE' )
|
||||||
|
do i = 1, low_rank
|
||||||
|
write(111, '(I8, 5X, E15.7, 2(5X, E15.7, E15.7) )' ) i, Dverif(i), D(i), 100.d0*dabs(D(i)-Dverif(i))/Dverif(i), DRSVD(i), 100.d0*dabs(DRSVD(i)-Dverif(i))/Dverif(i)
|
||||||
|
end do
|
||||||
|
close(111)
|
||||||
|
! !!!
|
||||||
|
!deallocate( Averif, Uverif, Dverif, Vtverif )
|
||||||
|
! !!!
|
||||||
|
low_rank = 12
|
||||||
|
! !!!
|
||||||
|
err_verif = 0.d0
|
||||||
|
do j = 1, n
|
||||||
|
do i = 1, m
|
||||||
|
err_tmp = 0.d0
|
||||||
|
do l = 1, low_rank
|
||||||
|
err_tmp = err_tmp + Dverif(l) * Uverif(i,l) * Vtverif(l,j)
|
||||||
|
enddo
|
||||||
|
err_verif = err_verif + ( Averif(i,j) - err_tmp )**2.d0
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*, 'err verif (%) = ', 100.d0 * dsqrt(err_verif/norm_psi)
|
||||||
|
! !!!
|
||||||
|
print*, 'low_rank =', low_rank
|
||||||
|
allocate(Uezfio(m,low_rank,1), Dezfio(low_rank,1), Vezfio(n,low_rank,1))
|
||||||
|
do l = 1, low_rank
|
||||||
|
Dezfio(l,1) = Dverif(l)
|
||||||
|
do j = 1, m
|
||||||
|
Uezfio(j,l,1) = Uverif(j,l)
|
||||||
|
enddo
|
||||||
|
do j = 1, n
|
||||||
|
Vezfio(j,l,1) = Vtverif(l,j)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
deallocate( U, D, Vt )
|
||||||
|
! !!!
|
||||||
|
call ezfio_set_spindeterminants_n_det(N_det)
|
||||||
|
call ezfio_set_spindeterminants_n_states(N_states)
|
||||||
|
call ezfio_set_spindeterminants_n_det_alpha(n_det_alpha_unique)
|
||||||
|
call ezfio_set_spindeterminants_n_det_beta(n_det_beta_unique)
|
||||||
|
call ezfio_set_spindeterminants_psi_coef_matrix_rows(psi_bilinear_matrix_rows)
|
||||||
|
call ezfio_set_spindeterminants_psi_coef_matrix_columns(psi_bilinear_matrix_columns)
|
||||||
|
call ezfio_set_spindeterminants_psi_coef_matrix_values(psi_bilinear_matrix_values)
|
||||||
|
! !!!
|
||||||
|
call ezfio_set_spindeterminants_n_svd_coefs(low_rank)
|
||||||
|
call ezfio_set_spindeterminants_psi_svd_alpha(Uezfio)
|
||||||
|
call ezfio_set_spindeterminants_psi_svd_beta(Vezfio )
|
||||||
|
call ezfio_set_spindeterminants_psi_svd_coefs(Dezfio)
|
||||||
|
deallocate(Uezfio, Dezfio, Vezfio)
|
||||||
|
! !!!
|
||||||
|
!print*, PSI_energy(1) + nuclear_repulsion
|
||||||
|
!psi_bilinear_matrix(:,:,:) = 0.d0
|
||||||
|
!do low_rank = n, n
|
||||||
|
! call generate_all_alpha_beta_det_products
|
||||||
|
! do i = 1, N_det_beta_unique
|
||||||
|
! do j = 1, N_det_alpha_unique
|
||||||
|
! psi_bilinear_matrix(j,i,1) = 0.d0
|
||||||
|
! do l = 1, r
|
||||||
|
! psi_bilinear_matrix(j,i,1) = psi_bilinear_matrix(j,i,1) + D(l) * U(j,l) * V(i,l)
|
||||||
|
! enddo
|
||||||
|
! enddo
|
||||||
|
! enddo
|
||||||
|
! TOUCH psi_bilinear_matrix
|
||||||
|
! call update_wf_of_psi_bilinear_matrix(.False.)
|
||||||
|
! print*, low_rank, PSI_energy(1) + nuclear_repulsion !CI_energy(1)
|
||||||
|
!enddo
|
||||||
|
!deallocate(U,D,V)
|
||||||
|
! !!!
|
||||||
|
end
|
||||||
114
devel/svdwf/RSVD.irp.f
Normal file
114
devel/svdwf/RSVD.irp.f
Normal file
@ -0,0 +1,114 @@
|
|||||||
|
! !!!
|
||||||
|
subroutine RSVD( i_state, low_rank, PowerIt_max, nb_oversamp, URSVD, DRSVD, VtRSVD )
|
||||||
|
! !!!
|
||||||
|
BEGIN_DOC
|
||||||
|
! standard RSVD for a prefixed rank
|
||||||
|
END_DOC
|
||||||
|
! !!!
|
||||||
|
implicit none
|
||||||
|
include 'constants.include.F'
|
||||||
|
! !!!
|
||||||
|
integer, intent(in) :: i_state, low_rank, PowerIt_max, nb_oversamp
|
||||||
|
double precision, intent(out) :: URSVD(n_det_alpha_unique,low_rank), DRSVD(low_rank), VtRSVD(low_rank,n_det_beta_unique)
|
||||||
|
! !!!
|
||||||
|
integer :: i, j, k, l, PowerIt, m, n
|
||||||
|
double precision, allocatable :: r1(:,:), Q(:,:), P(:,:), B(:,:)
|
||||||
|
double precision, allocatable :: UB(:,:), D(:), Vt(:,:), U(:,:)
|
||||||
|
! !!!
|
||||||
|
m = n_det_alpha_unique
|
||||||
|
n = n_det_beta_unique
|
||||||
|
! !!!
|
||||||
|
! !!! !!! !!! !!! !!! !!! !!! !!! !!! !!! !
|
||||||
|
! !!!
|
||||||
|
allocate( Q(m, low_rank+nb_oversamp) )
|
||||||
|
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,k,l,r1)
|
||||||
|
allocate( r1(N_det,2) )
|
||||||
|
!$OMP DO
|
||||||
|
do l = 1, low_rank+nb_oversamp
|
||||||
|
Q(:,l) = 0.d0
|
||||||
|
call random_number(r1)
|
||||||
|
r1(:,1) = dsqrt(-2.d0*dlog(r1(:,1)))
|
||||||
|
r1(:,1) = r1(:,1) * dcos(dtwo_pi*r1(:,2))
|
||||||
|
do k = 1, N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
Q(i,l) = Q(i,l) + psi_bilinear_matrix_values(k,i_state) * r1(k,1)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
deallocate(r1)
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
! !!!
|
||||||
|
call ortho_qr(Q, size(Q,1), m, low_rank+nb_oversamp)
|
||||||
|
! !!!
|
||||||
|
! power scheme
|
||||||
|
! !!!
|
||||||
|
allocate( P(n, low_rank+nb_oversamp) )
|
||||||
|
do PowerIt = 1, PowerIt_max
|
||||||
|
! !!!
|
||||||
|
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l)
|
||||||
|
!$OMP DO
|
||||||
|
do l = 1, low_rank+nb_oversamp
|
||||||
|
P(:,l) = 0.d0
|
||||||
|
do k = 1, N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
j = psi_bilinear_matrix_columns(k)
|
||||||
|
P(j,l) = P(j,l) + psi_bilinear_matrix_values(k,i_state) * Q(i,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
! !!!
|
||||||
|
call ortho_qr(P, size(P,1), n, low_rank+nb_oversamp)
|
||||||
|
! !!!
|
||||||
|
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l)
|
||||||
|
!$OMP DO
|
||||||
|
do l = 1, low_rank+nb_oversamp
|
||||||
|
Q(:,l) = 0.d0
|
||||||
|
do k = 1 , N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
j = psi_bilinear_matrix_columns(k)
|
||||||
|
Q(i,l) = Q(i,l) + psi_bilinear_matrix_values(k,i_state) * P(j,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
! !!!
|
||||||
|
call ortho_qr(Q, size(Q,1), m, low_rank+nb_oversamp)
|
||||||
|
! !!!
|
||||||
|
enddo
|
||||||
|
deallocate(P)
|
||||||
|
! !!!
|
||||||
|
allocate( B(low_rank+nb_oversamp,n) )
|
||||||
|
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l)
|
||||||
|
!$OMP DO
|
||||||
|
do l = 1, low_rank+nb_oversamp
|
||||||
|
B(l,:) = 0.d0
|
||||||
|
do k = 1, N_det
|
||||||
|
i = psi_bilinear_matrix_rows(k)
|
||||||
|
j = psi_bilinear_matrix_columns(k)
|
||||||
|
B(l,j) = B(l,j) + psi_bilinear_matrix_values(k,i_state) * Q(i,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
! !!!
|
||||||
|
allocate( UB(low_rank+nb_oversamp,low_rank+nb_oversamp), D(low_rank+nb_oversamp), Vt(low_rank+nb_oversamp,n) )
|
||||||
|
call svd_s( B, size(B,1), UB, size(UB,1), D, Vt, size(Vt,1), low_rank+nb_oversamp, n)
|
||||||
|
deallocate(B)
|
||||||
|
allocate( U(m,low_rank+nb_oversamp) )
|
||||||
|
call dgemm('N', 'N', m, low_rank+nb_oversamp, low_rank+nb_oversamp, 1.d0, Q, size(Q,1), UB, size(UB,1), 0.d0, U, size(U,1))
|
||||||
|
deallocate( Q,UB )
|
||||||
|
! !!!
|
||||||
|
do l = 1, low_rank
|
||||||
|
DRSVD(l) = D(l)
|
||||||
|
do i = 1, m
|
||||||
|
URSVD(i,l) = U(i,l)
|
||||||
|
enddo
|
||||||
|
do i = 1, n
|
||||||
|
VtRSVD(l,i) = Vt(l,i)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
! !!!
|
||||||
|
return
|
||||||
|
! !!!
|
||||||
|
end
|
||||||
127
devel/svdwf/linear_algebra.irp.f
Normal file
127
devel/svdwf/linear_algebra.irp.f
Normal file
@ -0,0 +1,127 @@
|
|||||||
|
subroutine svd_s(A, LDA, U, LDU, D, Vt, LDVt, m, n)
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! !!!
|
||||||
|
! DGESVD computes the singular value decomposition (SVD) of a real
|
||||||
|
! M-by-N matrix A, optionally computing the left and/or right singular
|
||||||
|
! vectors. The SVD is written:
|
||||||
|
! A = U * SIGMA * transpose(V)
|
||||||
|
! where SIGMA is an M-by-N matrix which is zero except for its
|
||||||
|
! min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
|
||||||
|
! V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
|
||||||
|
! are the singular values of A; they are real and non-negative, and
|
||||||
|
! are returned in descending order. The first min(m,n) columns of
|
||||||
|
! U and V are the left and right singular vectors of A.
|
||||||
|
!
|
||||||
|
! Note that the routine returns V**T, not V.
|
||||||
|
! !!!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
integer, intent(in) :: LDA, LDU, LDVt, m, n
|
||||||
|
double precision, intent(in) :: A(LDA,n)
|
||||||
|
double precision, intent(out) :: U(LDU,min(m,n)), Vt(LDVt,n), D(min(m,n))
|
||||||
|
double precision,allocatable :: work(:), A_tmp(:,:)
|
||||||
|
integer :: info, lwork, i, j, k
|
||||||
|
|
||||||
|
|
||||||
|
allocate (A_tmp(LDA,n))
|
||||||
|
do k=1,n
|
||||||
|
do i=1,m
|
||||||
|
A_tmp(i,k) = A(i,k) + 1d-16
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Find optimal size for temp arrays
|
||||||
|
allocate(work(1))
|
||||||
|
lwork = -1
|
||||||
|
call dgesvd('A', 'S', m, n, A_tmp, LDA, &
|
||||||
|
D, U, LDU, Vt, LDVt, work, lwork, info)
|
||||||
|
! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648
|
||||||
|
lwork = max(int(work(1)), 5*MIN(M,N))
|
||||||
|
deallocate(work)
|
||||||
|
|
||||||
|
allocate(work(lwork))
|
||||||
|
call dgesvd('A','S', m, n, A_tmp, LDA, &
|
||||||
|
D, U, LDU, Vt, LDVt, work, lwork, info)
|
||||||
|
deallocate(A_tmp,work)
|
||||||
|
|
||||||
|
if (info /= 0) then
|
||||||
|
print *, info, ': SVD in svds failed'
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
|
||||||
|
do j=1,min(m,n)
|
||||||
|
do i=1,m
|
||||||
|
if (dabs(U(i,j)) < 1.d-14) U(i,j) = 0.d0
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
do j = 1, n
|
||||||
|
do i = 1, LDVt
|
||||||
|
if (dabs(Vt(i,j)) < 1.d-14) Vt(i,j) = 0.d0
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine my_ortho_qr(A,LDA,m,n)
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Orthogonalization using Q.R factorization
|
||||||
|
!
|
||||||
|
! A : matrix to orthogonalize
|
||||||
|
!
|
||||||
|
! LDA : leftmost dimension of A
|
||||||
|
!
|
||||||
|
! m : Number of rows of A
|
||||||
|
!
|
||||||
|
! n : Number of columns of A
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: m, n, LDA
|
||||||
|
double precision, intent(inout) :: A(LDA,n)
|
||||||
|
integer :: LWORK, INFO, nTAU, ii, jj
|
||||||
|
double precision, allocatable :: TAU(:), WORK(:)
|
||||||
|
double precision :: Adorgqr(LDA,n)
|
||||||
|
|
||||||
|
allocate (TAU(min(m,n)), WORK(1))
|
||||||
|
|
||||||
|
LWORK=-1
|
||||||
|
call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO )
|
||||||
|
! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648
|
||||||
|
LWORK=max(n,int(WORK(1)))
|
||||||
|
|
||||||
|
deallocate(WORK)
|
||||||
|
allocate(WORK(LWORK))
|
||||||
|
call dgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO )
|
||||||
|
if(INFO.ne.0 ) then
|
||||||
|
print*, 'problem in DGEQRF'
|
||||||
|
endif
|
||||||
|
|
||||||
|
nTAU = size(TAU)
|
||||||
|
do jj = 1, n
|
||||||
|
do ii = 1, LDA
|
||||||
|
Adorgqr(ii,jj) = A(ii,jj)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
LWORK=-1
|
||||||
|
call dorgqr(m, n, nTAU, Adorgqr, LDA, TAU, WORK, LWORK, INFO)
|
||||||
|
! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648
|
||||||
|
LWORK=max(n,int(WORK(1)))
|
||||||
|
|
||||||
|
deallocate(WORK)
|
||||||
|
allocate(WORK(LWORK))
|
||||||
|
call dorgqr(m, n, nTAU, A, LDA, TAU, WORK, LWORK, INFO)
|
||||||
|
if(INFO.ne.0 ) then
|
||||||
|
print*, 'problem in DORGQR'
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
deallocate(WORK,TAU)
|
||||||
|
end
|
||||||
Loading…
Reference in New Issue
Block a user