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

Merge branch 'dev-stable' into dev-stable-tc-scf

Browse Source
This commit is contained in:
eginer 2023-04-10 16:13:04 +02:00
commit f4bcf66b9b
1 changed files with 72 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
src/determinants/h_apply.irp.f
View File

@ -69,9 +69,15 @@ subroutine resize_H_apply_buffer(new_size,iproc)
END_DOC
PROVIDE H_apply_buffer_allocated
ASSERT (new_size > 0)
ASSERT (iproc >= 0)
ASSERT (iproc < nproc)
if (N_det < 0) call abort() !irp_here//': N_det < 0')
if (N_int <= 0) call abort() !irp_here//': N_int <= 0')
if (new_size <= 0) call abort() !irp_here//': new_size <= 0')
if (iproc < 0) call abort() !irp_here//': iproc < 0')
if (iproc >= nproc) call abort() !irp_here//': iproc >= nproc')
allocate ( buffer_det(N_int,2,new_size), &
buffer_coef(new_size,N_states), &
@ -126,8 +132,10 @@ subroutine copy_H_apply_buffer_to_wf
ASSERT (N_int > 0)
ASSERT (N_det > 0)
ASSERT (N_det >= 0)
N_det_old = N_det
if (N_det > 0) then
allocate ( buffer_det(N_int,2,N_det), buffer_coef(N_det,N_states) )
! Backup determinants
@ -151,6 +159,7 @@ subroutine copy_H_apply_buffer_to_wf
enddo
ASSERT ( j == N_det_old )
enddo
endif
! Update N_det
N_det = N_det_old
@ -164,6 +173,7 @@ subroutine copy_H_apply_buffer_to_wf
TOUCH psi_det_size
endif
if (N_det_old > 0) then
! Restore backup in resized array
do i=1,N_det_old
psi_det(:,:,i) = buffer_det(:,:,i)
@ -175,6 +185,7 @@ subroutine copy_H_apply_buffer_to_wf
psi_coef(i,k) = buffer_coef(i,k)
enddo
enddo
endif
! Copy new buffers
@ -339,3 +350,33 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc)
call omp_unset_lock(H_apply_buffer_lock(1,iproc))
end
subroutine replace_wf(N_det_new, LDA, psi_coef_new, psi_det_new)
use omp_lib
implicit none
BEGIN_DOC
! Replaces the wave function.
! After calling this subroutine, N_det, psi_det and psi_coef need to be touched
END_DOC
integer, intent(in) :: N_det_new, LDA
double precision, intent(in) :: psi_coef_new(LDA,N_states)
integer(bit_kind), intent(in) :: psi_det_new(N_int,2,N_det_new)
integer :: i,j
PROVIDE H_apply_buffer_allocated
if (N_det_new <= 0) call abort() !irp_here//': N_det_new <= 0')
if (N_int <= 0) call abort() !irp_here//': N_int <= 0')
if (LDA < N_det_new) call abort() !irp_here//': LDA < N_det_new')
do j=0,nproc-1
H_apply_buffer(j)%N_det = 0
enddo
N_det = 0
SOFT_TOUCH N_det
call fill_H_apply_buffer_no_selection(N_det_new,psi_det_new,N_int,0)
call copy_h_apply_buffer_to_wf
psi_coef(1:N_det_new,1:N_states) = psi_coef_new(1:N_det_new,1:N_states)
end