1
0
mirror of https://gitlab.com/scemama/qp_plugins_scemama.git synced 2024-12-22 12:23:37 +01:00

Added svdwf module

This commit is contained in:
Anthony Scemama 2020-09-30 20:44:53 +02:00
parent 04c75ab70c
commit 16d5b14f36
6 changed files with 214 additions and 2 deletions

View File

@ -96,7 +96,7 @@ subroutine get_fock_matrix_alpha(det,F)
integer :: i,j,k
F(:,:) = fock_op_cshell_ref_bitmask(:,:)
F(:,:) = fock_operator_closed_shell_ref_bitmask(:,:)
end
@ -112,7 +112,7 @@ subroutine get_fock_matrix_beta(det,F)
integer :: i,j,k
F(:,:) = fock_op_cshell_ref_bitmask(:,:)
F(:,:) = fock_operator_closed_shell_ref_bitmask(:,:)
end

59
devel/svdwf/.gitignore vendored Normal file
View File

@ -0,0 +1,59 @@
IRPF90_temp/
IRPF90_man/
build.ninja
irpf90.make
ezfio_interface.irp.f
irpf90_entities
tags
Makefile
ao_basis
ao_one_e_ints
ao_two_e_erf_ints
ao_two_e_ints
aux_quantities
becke_numerical_grid
bitmask
cis
cisd
cipsi
davidson
davidson_dressed
davidson_undressed
density_for_dft
determinants
dft_keywords
dft_utils_in_r
dft_utils_one_e
dft_utils_two_body
dressing
dummy
electrons
ezfio_files
fci
generators_cas
generators_full
hartree_fock
iterations
kohn_sham
kohn_sham_rs
mo_basis
mo_guess
mo_one_e_ints
mo_two_e_erf_ints
mo_two_e_ints
mpi
mrpt_utils
nuclei
perturbation
pseudo
psiref_cas
psiref_utils
scf_utils
selectors_cassd
selectors_full
selectors_utils
single_ref_method
slave
tools
utils
zmq

1
devel/svdwf/NEED Normal file
View File

@ -0,0 +1 @@
determinants

4
devel/svdwf/README.rst Normal file
View File

@ -0,0 +1,4 @@
=====
svdwf
=====

View File

@ -0,0 +1,101 @@
program svdwf
implicit none
BEGIN_DOC
! Make the SVD of the alpha-beta wave function and print singular values.
END_DOC
read_wf = .True.
TOUCH read_wf
call run()
end
subroutine run
implicit none
include 'constants.include.F'
double precision, allocatable :: U(:,:), V(:,:), D(:), A(:,:)
integer :: i, j, k, l, q, r, m, n, iter
double precision,allocatable :: Z(:,:), P(:,:), Yt(:,:), UYt(:,:)
double precision :: r1,r2
m = n_det_alpha_unique
n = n_det_beta_unique
r = min(1000,n)
allocate(Z(m,r))
! Z(m,r) = A(m,n).P(n,r)
Z(:,:) = 0.d0
do l=1,r
do k=1,N_det
i = psi_bilinear_matrix_rows(k)
j = psi_bilinear_matrix_columns(k)
call random_number(r1)
call random_number(r2)
r1 = dsqrt(-2.d0*dlog(r1))
r2 = dtwo_pi*r2
Z(i,l) = Z(i,l) + psi_bilinear_matrix_values(k,1) * r1*dcos(r2)
enddo
enddo
! Power iterations
allocate(P(n,r))
do iter=1,20
! P(n,r) = At(n,m).Z(m,r)
P(:,:) = 0.d0
do l=1,r
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,1) * Z(i,l)
enddo
enddo
Z(:,:) = 0.d0
do l=1,r
do k=1,N_det
i = psi_bilinear_matrix_rows(k)
j = psi_bilinear_matrix_columns(k)
Z(i,l) = Z(i,l) + psi_bilinear_matrix_values(k,1) * P(j,l)
enddo
enddo
! Compute QR
call ortho_qr(Z,size(Z,1),m,r)
enddo
! Y(r,n) = Zt(r,m).A(m,n)
allocate(Yt(n,r))
Yt(:,:) = 0.d0
do l=1,r
do k=1,N_det
i = psi_bilinear_matrix_rows(k)
j = psi_bilinear_matrix_columns(k)
Yt(j,l) = Yt(j,l) + Z(i,l) * psi_bilinear_matrix_values(k,1)
enddo
enddo
allocate(D(r),V(n,r), UYt(r,r))
call svd(Yt,size(Yt,1),V,size(V,1),D,UYt,size(UYt,1),n,r)
deallocate(Yt)
! U(m,r) = Z(m,r).UY(r,r)
allocate(U(m,r))
call dgemm('N','T',m,r,r,1.d0,Z,size(Z,1),UYt,size(UYt,1),0.d0,U,size(U,1))
deallocate(UYt,Z)
do i=1,r
print *, i, real(D(i)), real(D(i)**2), real(sum(D(1:i)**2))
if (D(i) < 1.d-15) then
k = i
exit
endif
enddo
print *, 'threshold: ', 2.858 * D(k/2)
do i=1,m
print '(I6,4(X,F12.8))', i, U(i,1:4)
enddo
print *, ''
do i=1,n
print '(I6,4(X,F12.8))', i, V(i,1:4)
enddo
deallocate(U,D,V)
end

47
devel/svdwf/svdwf.irp.f Normal file
View File

@ -0,0 +1,47 @@
program svdwf
implicit none
BEGIN_DOC
! TODO : Make the SVD of the alpha-beta wave function and print singular values.
END_DOC
read_wf = .True.
TOUCH read_wf
call run()
end
subroutine run
implicit none
double precision, allocatable :: U(:,:), Vt(:,:), D(:), A(:,:)
integer :: i, j, k, p, q
allocate( A (n_det_alpha_unique, n_det_beta_unique), &
U (n_det_alpha_unique, n_det_alpha_unique), &
Vt(n_det_beta_unique, n_det_beta_unique), &
D(max(n_det_beta_unique,n_det_alpha_unique)) )
A = 0.D0
do k=1,N_det
i = psi_bilinear_matrix_rows(k)
j = psi_bilinear_matrix_columns(k)
A(i,j) = psi_bilinear_matrix_values(k,1)
enddo
call randomized_svd(A, size(A,1), &
U, size(U,1), D, Vt, size(Vt,1), n_det_alpha_unique, n_det_beta_unique, &
6,1000)
do i=1,n_det_beta_unique
print *, i, real(D(i)), real(D(i)**2), real(sum(D(1:i)**2))
if (D(i) < 1.d-15) then
k = i
exit
endif
enddo
print *, 'threshold: ', 2.858 * D(k/2)
do i=1,n_det_alpha_unique
print '(I6,4(X,F12.8))', i, U(i,1:4)
enddo
print *, ''
do i=1,n_det_beta_unique
print '(I6,4(X,F12.8))', i, Vt(1:4,i)
enddo
end