LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-22 03:23:29 +01:00
Code Releases Activity

Nice zeros in multi-state CI coefs

Browse Source
This commit is contained in:
Anthony Scemama 2020-11-11 11:56:31 +01:00
parent 6b2020d40d
commit 95be88c7e7
1 changed files with 25 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
src/davidson/diagonalization_hs2_dressed.irp.f
View File

@ -320,11 +320,16 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
do k=N_st+1,N_st_diag do k=N_st+1,N_st_diag
u_in(k,k) = 10.d0 u_in(k,k) = 10.d0
do i=1,sze do i=1,sze
call random_number(r1) ! This Preserves symmetry when zero coefs are in the guess
call random_number(r2) if (dabs(u_in(i,k-N_st)) < 1.d-5) then
r1 = dsqrt(-2.d0*dlog(r1)) u_in(i,k) =0.d0
r2 = dtwo_pi*r2 else
u_in(i,k) = r1*dcos(r2) call random_number(r1)
call random_number(r2)
r1 = dsqrt(-2.d0*dlog(r1))
r2 = dtwo_pi*r2
u_in(i,k) = r1*dcos(r2)
endif
enddo enddo
enddo enddo
do k=1,N_st_diag do k=1,N_st_diag
@ -655,11 +660,13 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
call dgemm('N','N', sze, N_st_diag, shift2, 1.d0, & call dgemm('N','N', sze, N_st_diag, shift2, 1.d0, &
U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1))
do k=1,N_st_diag do k=1,N_st_diag
do i=1,sze do i=1,sze
U(i,k) = u_in(i,k) U(i,k) = u_in(i,k)
enddo enddo
enddo enddo
if (disk_based) then if (disk_based) then
call ortho_qr_unblocked(U,size(U,1),sze,N_st_diag) call ortho_qr_unblocked(U,size(U,1),sze,N_st_diag)
call ortho_qr_unblocked(U,size(U,1),sze,N_st_diag) call ortho_qr_unblocked(U,size(U,1),sze,N_st_diag)
@ -667,11 +674,15 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
call ortho_qr(U,size(U,1),sze,N_st_diag) call ortho_qr(U,size(U,1),sze,N_st_diag)
call ortho_qr(U,size(U,1),sze,N_st_diag) call ortho_qr(U,size(U,1),sze,N_st_diag)
endif endif
! Adjust the phase
do j=1,N_st_diag do j=1,N_st_diag
! Find first non-zero
k=1 k=1
do while ((k<sze).and.(U(k,j) == 0.d0)) do while ((k<sze).and.(U(k,j) == 0.d0))
k = k+1 k = k+1
enddo enddo
! Check sign
if (U(k,j) * u_in(k,j) < 0.d0) then if (U(k,j) * u_in(k,j) < 0.d0) then
do i=1,sze do i=1,sze
W(i,j) = -W(i,j) W(i,j) = -W(i,j)
@ -679,6 +690,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
enddo enddo
endif endif
enddo enddo
do j=1,N_st_diag do j=1,N_st_diag
do i=1,sze do i=1,sze
S_d(i,j) = dble(S(i,j)) S_d(i,j) = dble(S(i,j))
@ -687,6 +699,14 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
enddo enddo
call nullify_small_elements(sze,N_st_diag,U,size(U,1),threshold_davidson_pt2)
do k=1,N_st_diag
do i=1,sze
u_in(i,k) = U(i,k)
enddo
enddo
do k=1,N_st_diag do k=1,N_st_diag
energies(k) = lambda(k) energies(k) = lambda(k)
s2_out(k) = s2(k) s2_out(k) = s2(k)