2014-05-13 13:57:58 +02:00
|
|
|
use bitmasks
|
|
|
|
|
2016-09-20 17:29:02 +02:00
|
|
|
BEGIN_PROVIDER [ character*(64), diag_algorithm ]
|
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Diagonalization algorithm (Davidson or Lapack)
|
|
|
|
END_DOC
|
|
|
|
if (N_det > N_det_max_jacobi) then
|
|
|
|
diag_algorithm = "Davidson"
|
|
|
|
else
|
|
|
|
diag_algorithm = "Lapack"
|
|
|
|
endif
|
|
|
|
|
2016-09-25 23:28:25 +02:00
|
|
|
if (N_det < N_states) then
|
2016-09-20 17:29:02 +02:00
|
|
|
diag_algorithm = "Lapack"
|
|
|
|
endif
|
|
|
|
END_PROVIDER
|
|
|
|
|
|
|
|
|
2014-05-13 13:57:58 +02:00
|
|
|
BEGIN_PROVIDER [ integer, N_det ]
|
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Number of determinants in the wave function
|
|
|
|
END_DOC
|
2014-05-25 01:18:41 +02:00
|
|
|
logical :: exists
|
2017-04-12 19:29:21 +02:00
|
|
|
character*(64) :: label
|
2014-05-25 01:18:41 +02:00
|
|
|
PROVIDE ezfio_filename
|
2015-11-12 01:08:04 +01:00
|
|
|
PROVIDE nproc
|
2014-06-27 10:16:40 +02:00
|
|
|
if (read_wf) then
|
|
|
|
call ezfio_has_determinants_n_det(exists)
|
2014-06-09 00:15:48 +02:00
|
|
|
if (exists) then
|
2015-02-12 16:36:41 +01:00
|
|
|
call ezfio_has_determinants_mo_label(exists)
|
|
|
|
if (exists) then
|
|
|
|
call ezfio_get_determinants_mo_label(label)
|
|
|
|
exists = (label == mo_label)
|
|
|
|
endif
|
2014-06-09 00:15:48 +02:00
|
|
|
endif
|
2014-06-27 10:16:40 +02:00
|
|
|
if (exists) then
|
|
|
|
call ezfio_get_determinants_n_det(N_det)
|
|
|
|
else
|
|
|
|
N_det = 1
|
|
|
|
endif
|
2014-05-25 01:18:41 +02:00
|
|
|
else
|
|
|
|
N_det = 1
|
|
|
|
endif
|
2015-04-20 10:12:08 +02:00
|
|
|
call write_int(output_determinants,N_det,'Number of determinants')
|
2014-05-25 01:18:41 +02:00
|
|
|
ASSERT (N_det > 0)
|
2014-05-13 13:57:58 +02:00
|
|
|
END_PROVIDER
|
|
|
|
|
2015-03-19 21:14:52 +01:00
|
|
|
BEGIN_PROVIDER [integer, max_degree_exc]
|
|
|
|
implicit none
|
|
|
|
integer :: i,degree
|
|
|
|
max_degree_exc = 0
|
|
|
|
BEGIN_DOC
|
|
|
|
! Maximum degree of excitation in the wf
|
|
|
|
END_DOC
|
|
|
|
do i = 1, N_det
|
|
|
|
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
|
|
|
if(degree.gt.max_degree_exc)then
|
|
|
|
max_degree_exc= degree
|
|
|
|
endif
|
|
|
|
enddo
|
|
|
|
END_PROVIDER
|
2014-05-25 01:18:41 +02:00
|
|
|
|
2014-05-14 15:40:40 +02:00
|
|
|
BEGIN_PROVIDER [ integer, psi_det_size ]
|
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Size of the psi_det/psi_coef arrays
|
|
|
|
END_DOC
|
2014-06-08 00:22:33 +02:00
|
|
|
PROVIDE ezfio_filename
|
|
|
|
logical :: exists
|
|
|
|
call ezfio_has_determinants_n_det(exists)
|
|
|
|
if (exists) then
|
|
|
|
call ezfio_get_determinants_n_det(psi_det_size)
|
|
|
|
else
|
|
|
|
psi_det_size = 1
|
|
|
|
endif
|
2016-07-06 16:15:47 +02:00
|
|
|
psi_det_size = max(psi_det_size,100000)
|
2015-04-20 10:12:08 +02:00
|
|
|
call write_int(output_determinants,psi_det_size,'Dimension of the psi arrays')
|
2014-06-08 00:22:33 +02:00
|
|
|
|
2014-05-14 15:40:40 +02:00
|
|
|
END_PROVIDER
|
|
|
|
|
2014-06-07 22:07:50 +02:00
|
|
|
BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ]
|
2014-05-13 13:57:58 +02:00
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
2014-06-04 21:28:43 +02:00
|
|
|
! The wave function determinants. Initialized with Hartree-Fock if the EZFIO file
|
2014-05-25 01:18:41 +02:00
|
|
|
! is empty
|
2014-05-13 13:57:58 +02:00
|
|
|
END_DOC
|
2014-06-08 00:22:33 +02:00
|
|
|
integer :: i
|
2014-06-07 22:07:50 +02:00
|
|
|
logical :: exists
|
2017-04-12 19:29:21 +02:00
|
|
|
character*(64) :: label
|
2014-06-09 00:15:48 +02:00
|
|
|
|
2016-09-26 20:34:16 +02:00
|
|
|
psi_det = 0_bit_kind
|
2014-06-27 10:16:40 +02:00
|
|
|
if (read_wf) then
|
|
|
|
call ezfio_has_determinants_N_int(exists)
|
2014-06-07 22:07:50 +02:00
|
|
|
if (exists) then
|
2014-06-27 10:16:40 +02:00
|
|
|
call ezfio_has_determinants_bit_kind(exists)
|
2014-06-07 22:07:50 +02:00
|
|
|
if (exists) then
|
2014-06-27 10:16:40 +02:00
|
|
|
call ezfio_has_determinants_N_det(exists)
|
2014-06-09 00:15:48 +02:00
|
|
|
if (exists) then
|
2014-06-27 10:16:40 +02:00
|
|
|
call ezfio_has_determinants_N_states(exists)
|
|
|
|
if (exists) then
|
|
|
|
call ezfio_has_determinants_psi_det(exists)
|
2014-06-09 00:15:48 +02:00
|
|
|
if (exists) then
|
2014-06-27 10:16:40 +02:00
|
|
|
call ezfio_has_determinants_mo_label(exists)
|
|
|
|
if (exists) then
|
|
|
|
call ezfio_get_determinants_mo_label(label)
|
|
|
|
exists = (label == mo_label)
|
|
|
|
endif
|
2014-06-09 00:15:48 +02:00
|
|
|
endif
|
2014-06-27 10:16:40 +02:00
|
|
|
endif
|
2014-06-09 00:15:48 +02:00
|
|
|
endif
|
2014-06-07 22:07:50 +02:00
|
|
|
endif
|
|
|
|
endif
|
2014-06-27 10:16:40 +02:00
|
|
|
|
|
|
|
if (exists) then
|
|
|
|
call read_dets(psi_det,N_int,N_det)
|
|
|
|
else
|
|
|
|
psi_det = 0_bit_kind
|
|
|
|
do i=1,N_int
|
|
|
|
psi_det(i,1,1) = HF_bitmask(i,1)
|
|
|
|
psi_det(i,2,1) = HF_bitmask(i,2)
|
|
|
|
enddo
|
|
|
|
endif
|
2014-06-07 22:07:50 +02:00
|
|
|
else
|
|
|
|
psi_det = 0_bit_kind
|
|
|
|
do i=1,N_int
|
|
|
|
psi_det(i,1,1) = HF_bitmask(i,1)
|
|
|
|
psi_det(i,2,1) = HF_bitmask(i,2)
|
|
|
|
enddo
|
|
|
|
endif
|
2014-05-13 13:57:58 +02:00
|
|
|
|
2014-06-04 21:28:43 +02:00
|
|
|
END_PROVIDER
|
|
|
|
|
2014-10-15 10:08:00 +02:00
|
|
|
|
|
|
|
|
2016-09-24 02:03:22 +02:00
|
|
|
BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ]
|
2014-06-07 22:07:50 +02:00
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file
|
|
|
|
! is empty
|
|
|
|
END_DOC
|
|
|
|
|
|
|
|
integer :: i,k, N_int2
|
|
|
|
logical :: exists
|
|
|
|
double precision, allocatable :: psi_coef_read(:,:)
|
2014-06-09 00:15:48 +02:00
|
|
|
character*(64) :: label
|
2014-10-07 16:23:19 +02:00
|
|
|
|
|
|
|
psi_coef = 0.d0
|
2016-09-26 20:34:16 +02:00
|
|
|
do i=1,min(N_states,psi_det_size)
|
2014-10-07 16:23:19 +02:00
|
|
|
psi_coef(i,i) = 1.d0
|
|
|
|
enddo
|
2015-03-19 21:14:52 +01:00
|
|
|
|
2014-06-27 10:16:40 +02:00
|
|
|
if (read_wf) then
|
|
|
|
call ezfio_has_determinants_psi_coef(exists)
|
2014-06-09 00:15:48 +02:00
|
|
|
if (exists) then
|
2014-06-27 10:16:40 +02:00
|
|
|
call ezfio_has_determinants_mo_label(exists)
|
|
|
|
if (exists) then
|
|
|
|
call ezfio_get_determinants_mo_label(label)
|
|
|
|
exists = (label == mo_label)
|
|
|
|
endif
|
2014-06-09 00:15:48 +02:00
|
|
|
endif
|
2014-06-07 22:07:50 +02:00
|
|
|
|
2014-06-27 10:16:40 +02:00
|
|
|
if (exists) then
|
|
|
|
|
|
|
|
allocate (psi_coef_read(N_det,N_states))
|
|
|
|
call ezfio_get_determinants_psi_coef(psi_coef_read)
|
|
|
|
do k=1,N_states
|
|
|
|
do i=1,N_det
|
|
|
|
psi_coef(i,k) = psi_coef_read(i,k)
|
|
|
|
enddo
|
2014-06-07 22:07:50 +02:00
|
|
|
enddo
|
2014-06-27 10:16:40 +02:00
|
|
|
deallocate(psi_coef_read)
|
|
|
|
|
|
|
|
endif
|
2014-06-07 22:07:50 +02:00
|
|
|
|
|
|
|
endif
|
2014-06-08 00:22:33 +02:00
|
|
|
|
2014-06-07 22:07:50 +02:00
|
|
|
|
2014-05-13 13:57:58 +02:00
|
|
|
END_PROVIDER
|
|
|
|
|
|
|
|
|
2014-11-28 22:32:21 +01:00
|
|
|
BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (psi_det_size) ]
|
2014-05-29 01:38:46 +02:00
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Contribution of determinants to the state-averaged density
|
|
|
|
END_DOC
|
|
|
|
integer :: i,j,k
|
|
|
|
double precision :: f
|
|
|
|
f = 1.d0/dble(N_states)
|
|
|
|
do i=1,N_det
|
|
|
|
psi_average_norm_contrib(i) = psi_coef(i,1)*psi_coef(i,1)*f
|
|
|
|
enddo
|
|
|
|
do k=2,N_states
|
|
|
|
do i=1,N_det
|
|
|
|
psi_average_norm_contrib(i) = psi_average_norm_contrib(i) + &
|
|
|
|
psi_coef(i,k)*psi_coef(i,k)*f
|
|
|
|
enddo
|
|
|
|
enddo
|
2016-09-27 09:28:34 +02:00
|
|
|
f = 1.d0/sum(psi_average_norm_contrib(1:N_det))
|
|
|
|
do i=1,N_det
|
|
|
|
psi_average_norm_contrib(i) = psi_average_norm_contrib(i)*f
|
|
|
|
enddo
|
2014-05-29 01:38:46 +02:00
|
|
|
END_PROVIDER
|
|
|
|
|
2014-11-28 09:46:34 +01:00
|
|
|
|
|
|
|
|
|
|
|
!==============================================================================!
|
|
|
|
! !
|
|
|
|
! Sorting providers !
|
|
|
|
! !
|
|
|
|
!==============================================================================!
|
|
|
|
|
|
|
|
|
2014-11-28 22:32:21 +01:00
|
|
|
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted, (N_int,2,psi_det_size) ]
|
|
|
|
&BEGIN_PROVIDER [ double precision, psi_coef_sorted, (psi_det_size,N_states) ]
|
|
|
|
&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted, (psi_det_size) ]
|
2017-05-10 15:06:03 +02:00
|
|
|
&BEGIN_PROVIDER [ integer, psi_det_sorted_order, (psi_det_size) ]
|
2014-05-29 01:38:46 +02:00
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
2014-06-02 15:18:45 +02:00
|
|
|
! Wave function sorted by determinants contribution to the norm (state-averaged)
|
2017-05-10 15:06:03 +02:00
|
|
|
!
|
|
|
|
! psi_det_sorted_order(i) -> k : index in psi_det
|
2014-05-29 01:38:46 +02:00
|
|
|
END_DOC
|
|
|
|
integer :: i,j,k
|
|
|
|
integer, allocatable :: iorder(:)
|
|
|
|
allocate ( iorder(N_det) )
|
|
|
|
do i=1,N_det
|
|
|
|
psi_average_norm_contrib_sorted(i) = -psi_average_norm_contrib(i)
|
|
|
|
iorder(i) = i
|
|
|
|
enddo
|
|
|
|
call dsort(psi_average_norm_contrib_sorted,iorder,N_det)
|
|
|
|
do i=1,N_det
|
|
|
|
do j=1,N_int
|
|
|
|
psi_det_sorted(j,1,i) = psi_det(j,1,iorder(i))
|
|
|
|
psi_det_sorted(j,2,i) = psi_det(j,2,iorder(i))
|
|
|
|
enddo
|
|
|
|
do k=1,N_states
|
|
|
|
psi_coef_sorted(i,k) = psi_coef(iorder(i),k)
|
|
|
|
enddo
|
|
|
|
psi_average_norm_contrib_sorted(i) = -psi_average_norm_contrib_sorted(i)
|
|
|
|
enddo
|
2017-05-10 20:42:14 +02:00
|
|
|
do i=1,N_det
|
|
|
|
psi_det_sorted_order(iorder(i)) = i
|
|
|
|
enddo
|
|
|
|
|
2014-05-29 01:38:46 +02:00
|
|
|
|
|
|
|
deallocate(iorder)
|
|
|
|
|
|
|
|
END_PROVIDER
|
|
|
|
|
2016-07-21 15:28:22 +02:00
|
|
|
subroutine flip_generators()
|
|
|
|
integer :: i,j,k
|
|
|
|
integer(bit_kind) :: detmp(N_int,2)
|
|
|
|
double precision :: tmp(N_states)
|
|
|
|
|
|
|
|
do i=1,N_det_generators/2
|
|
|
|
detmp(:,:) = psi_det_sorted(:,:,i)
|
|
|
|
tmp = psi_coef_sorted(i, :)
|
|
|
|
psi_det_sorted(:,:,i) = psi_det_sorted(:,:,N_det_generators+1-i)
|
|
|
|
psi_coef_sorted(i, :) = psi_coef_sorted(N_det_generators+1-i, :)
|
|
|
|
|
|
|
|
psi_det_sorted(:,:,N_det_generators+1-i) = detmp(:,:)
|
|
|
|
psi_coef_sorted(N_det_generators+1-i, :) = tmp
|
|
|
|
end do
|
|
|
|
|
|
|
|
TOUCH psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted
|
|
|
|
end subroutine
|
|
|
|
|
2014-11-28 22:32:21 +01:00
|
|
|
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit, (N_int,2,psi_det_size) ]
|
|
|
|
&BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (psi_det_size,N_states) ]
|
2014-06-02 15:18:45 +02:00
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Determinants on which we apply <i|H|psi> for perturbation.
|
2014-11-28 09:46:34 +01:00
|
|
|
! They are sorted by determinants interpreted as integers. Useful
|
|
|
|
! to accelerate the search of a random determinant in the wave
|
|
|
|
! function.
|
2014-06-02 15:18:45 +02:00
|
|
|
END_DOC
|
2015-04-09 23:59:06 +02:00
|
|
|
|
|
|
|
call sort_dets_by_det_search_key(N_det, psi_det, psi_coef, &
|
|
|
|
psi_det_sorted_bit, psi_coef_sorted_bit)
|
|
|
|
END_PROVIDER
|
|
|
|
|
|
|
|
subroutine sort_dets_by_det_search_key(Ndet, det_in, coef_in, det_out, coef_out)
|
|
|
|
use bitmasks
|
|
|
|
implicit none
|
|
|
|
integer, intent(in) :: Ndet
|
|
|
|
integer(bit_kind), intent(in) :: det_in (N_int,2,psi_det_size)
|
|
|
|
double precision , intent(in) :: coef_in(psi_det_size,N_states)
|
|
|
|
integer(bit_kind), intent(out) :: det_out (N_int,2,psi_det_size)
|
|
|
|
double precision , intent(out) :: coef_out(psi_det_size,N_states)
|
|
|
|
BEGIN_DOC
|
|
|
|
! Determinants are sorted are sorted according to their det_search_key.
|
|
|
|
! Useful to accelerate the search of a random determinant in the wave
|
|
|
|
! function.
|
|
|
|
END_DOC
|
2014-06-02 15:18:45 +02:00
|
|
|
integer :: i,j,k
|
|
|
|
integer, allocatable :: iorder(:)
|
|
|
|
integer*8, allocatable :: bit_tmp(:)
|
|
|
|
integer*8, external :: det_search_key
|
|
|
|
|
2015-04-09 23:59:06 +02:00
|
|
|
allocate ( iorder(Ndet), bit_tmp(Ndet) )
|
2014-06-02 15:18:45 +02:00
|
|
|
|
2015-04-09 23:59:06 +02:00
|
|
|
do i=1,Ndet
|
2014-06-02 15:18:45 +02:00
|
|
|
iorder(i) = i
|
|
|
|
!$DIR FORCEINLINE
|
2015-04-09 23:59:06 +02:00
|
|
|
bit_tmp(i) = det_search_key(det_in(1,1,i),N_int)
|
2014-06-02 15:18:45 +02:00
|
|
|
enddo
|
2015-04-09 23:59:06 +02:00
|
|
|
call i8sort(bit_tmp,iorder,Ndet)
|
2014-06-02 15:18:45 +02:00
|
|
|
!DIR$ IVDEP
|
2015-04-09 23:59:06 +02:00
|
|
|
do i=1,Ndet
|
2014-06-02 15:18:45 +02:00
|
|
|
do j=1,N_int
|
2015-04-09 23:59:06 +02:00
|
|
|
det_out(j,1,i) = det_in(j,1,iorder(i))
|
|
|
|
det_out(j,2,i) = det_in(j,2,iorder(i))
|
2014-06-02 15:18:45 +02:00
|
|
|
enddo
|
|
|
|
do k=1,N_states
|
2015-04-09 23:59:06 +02:00
|
|
|
coef_out(i,k) = coef_in(iorder(i),k)
|
2014-06-02 15:18:45 +02:00
|
|
|
enddo
|
|
|
|
enddo
|
|
|
|
|
2014-10-15 10:08:00 +02:00
|
|
|
deallocate(iorder, bit_tmp)
|
2014-06-02 15:18:45 +02:00
|
|
|
|
2015-04-09 23:59:06 +02:00
|
|
|
end
|
|
|
|
|
2014-06-02 15:18:45 +02:00
|
|
|
|
2014-11-28 22:32:21 +01:00
|
|
|
|
2015-07-13 18:00:38 +02:00
|
|
|
BEGIN_PROVIDER [ double precision, psi_coef_max, (N_states) ]
|
|
|
|
&BEGIN_PROVIDER [ double precision, psi_coef_min, (N_states) ]
|
|
|
|
&BEGIN_PROVIDER [ double precision, abs_psi_coef_max, (N_states) ]
|
|
|
|
&BEGIN_PROVIDER [ double precision, abs_psi_coef_min, (N_states) ]
|
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Max and min values of the coefficients
|
|
|
|
END_DOC
|
|
|
|
integer:: i
|
|
|
|
do i=1,N_states
|
|
|
|
psi_coef_min(i) = minval(psi_coef(:,i))
|
|
|
|
psi_coef_max(i) = maxval(psi_coef(:,i))
|
2016-11-29 17:54:10 +01:00
|
|
|
abs_psi_coef_min(i) = minval( dabs(psi_coef(:,i)) )
|
|
|
|
abs_psi_coef_max(i) = maxval( dabs(psi_coef(:,i)) )
|
|
|
|
call write_double(6,psi_coef_max(i), 'Max coef')
|
|
|
|
call write_double(6,psi_coef_min(i), 'Min coef')
|
|
|
|
call write_double(6,abs_psi_coef_max(i), 'Max abs coef')
|
|
|
|
call write_double(6,abs_psi_coef_min(i), 'Min abs coef')
|
2015-07-13 18:00:38 +02:00
|
|
|
enddo
|
|
|
|
|
|
|
|
END_PROVIDER
|
|
|
|
|
2014-11-28 19:50:48 +01:00
|
|
|
|
2014-11-28 09:46:34 +01:00
|
|
|
!==============================================================================!
|
|
|
|
! !
|
|
|
|
! Read/write routines !
|
|
|
|
! !
|
|
|
|
!==============================================================================!
|
|
|
|
|
|
|
|
subroutine read_dets(det,Nint,Ndet)
|
|
|
|
use bitmasks
|
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Reads the determinants from the EZFIO file
|
|
|
|
END_DOC
|
|
|
|
|
|
|
|
integer, intent(in) :: Nint,Ndet
|
|
|
|
integer(bit_kind), intent(out) :: det(Nint,2,Ndet)
|
|
|
|
integer*8, allocatable :: psi_det_read(:,:,:)
|
|
|
|
double precision, allocatable :: psi_coef_read(:,:)
|
|
|
|
integer*8 :: det_8(100)
|
|
|
|
integer(bit_kind) :: det_bk((100*8)/bit_kind)
|
|
|
|
integer :: N_int2
|
|
|
|
integer :: i,k
|
|
|
|
equivalence (det_8, det_bk)
|
|
|
|
|
|
|
|
call ezfio_get_determinants_N_int(N_int2)
|
|
|
|
ASSERT (N_int2 == Nint)
|
|
|
|
call ezfio_get_determinants_bit_kind(k)
|
|
|
|
ASSERT (k == bit_kind)
|
|
|
|
|
|
|
|
N_int2 = (Nint*bit_kind)/8
|
|
|
|
allocate (psi_det_read(N_int2,2,Ndet))
|
|
|
|
call ezfio_get_determinants_psi_det (psi_det_read)
|
|
|
|
! print*,'N_int2 = ',N_int2,N_int
|
|
|
|
! print*,'k',k,bit_kind
|
|
|
|
! print*,'psi_det_read = ',Ndet
|
|
|
|
do i=1,Ndet
|
|
|
|
do k=1,N_int2
|
|
|
|
det_8(k) = psi_det_read(k,1,i)
|
|
|
|
enddo
|
|
|
|
do k=1,Nint
|
|
|
|
det(k,1,i) = det_bk(k)
|
|
|
|
enddo
|
|
|
|
do k=1,N_int2
|
|
|
|
det_8(k) = psi_det_read(k,2,i)
|
|
|
|
enddo
|
|
|
|
do k=1,Nint
|
|
|
|
det(k,2,i) = det_bk(k)
|
|
|
|
enddo
|
|
|
|
enddo
|
|
|
|
deallocate(psi_det_read)
|
|
|
|
|
|
|
|
end
|
|
|
|
|
2016-02-17 17:15:54 +01:00
|
|
|
subroutine save_ref_determinant
|
|
|
|
implicit none
|
|
|
|
use bitmasks
|
2016-02-19 00:20:28 +01:00
|
|
|
double precision :: buffer(1,1)
|
|
|
|
buffer(1,1) = 1.d0
|
|
|
|
call save_wavefunction_general(1,1,ref_bitmask,1,buffer)
|
2016-02-17 17:15:54 +01:00
|
|
|
end
|
|
|
|
|
|
|
|
|
|
|
|
|
2014-06-02 15:18:45 +02:00
|
|
|
|
2014-06-07 22:07:50 +02:00
|
|
|
subroutine save_wavefunction
|
|
|
|
implicit none
|
2014-07-09 00:41:08 +02:00
|
|
|
use bitmasks
|
2014-06-07 22:07:50 +02:00
|
|
|
BEGIN_DOC
|
|
|
|
! Save the wave function into the EZFIO file
|
|
|
|
END_DOC
|
2015-02-12 16:36:41 +01:00
|
|
|
call save_wavefunction_general(N_det,N_states,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted)
|
2014-06-07 22:07:50 +02:00
|
|
|
end
|
|
|
|
|
2015-03-19 21:14:52 +01:00
|
|
|
|
|
|
|
subroutine save_wavefunction_unsorted
|
|
|
|
implicit none
|
|
|
|
use bitmasks
|
|
|
|
BEGIN_DOC
|
|
|
|
! Save the wave function into the EZFIO file
|
|
|
|
END_DOC
|
|
|
|
call save_wavefunction_general(N_det,N_states,psi_det,size(psi_coef,1),psi_coef)
|
|
|
|
end
|
|
|
|
|
2015-02-12 16:36:41 +01:00
|
|
|
subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef)
|
2014-07-09 00:41:08 +02:00
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Save the wave function into the EZFIO file
|
|
|
|
END_DOC
|
|
|
|
use bitmasks
|
2015-02-12 16:36:41 +01:00
|
|
|
integer, intent(in) :: ndet,nstates,dim_psicoef
|
2014-07-09 00:41:08 +02:00
|
|
|
integer(bit_kind), intent(in) :: psidet(N_int,2,ndet)
|
2015-02-12 16:36:41 +01:00
|
|
|
double precision, intent(in) :: psicoef(dim_psicoef,nstates)
|
2014-07-09 00:41:08 +02:00
|
|
|
integer*8, allocatable :: psi_det_save(:,:,:)
|
|
|
|
double precision, allocatable :: psi_coef_save(:,:)
|
|
|
|
integer*8 :: det_8(100)
|
|
|
|
integer(bit_kind) :: det_bk((100*8)/bit_kind)
|
|
|
|
integer :: N_int2
|
|
|
|
equivalence (det_8, det_bk)
|
|
|
|
|
|
|
|
integer :: i,k
|
|
|
|
|
|
|
|
call ezfio_set_determinants_N_int(N_int)
|
|
|
|
call ezfio_set_determinants_bit_kind(bit_kind)
|
|
|
|
call ezfio_set_determinants_N_det(ndet)
|
|
|
|
call ezfio_set_determinants_n_states(nstates)
|
|
|
|
call ezfio_set_determinants_mo_label(mo_label)
|
|
|
|
|
|
|
|
N_int2 = (N_int*bit_kind)/8
|
|
|
|
allocate (psi_det_save(N_int2,2,ndet))
|
|
|
|
do i=1,ndet
|
|
|
|
do k=1,N_int
|
|
|
|
det_bk(k) = psidet(k,1,i)
|
|
|
|
enddo
|
|
|
|
do k=1,N_int2
|
|
|
|
psi_det_save(k,1,i) = det_8(k)
|
|
|
|
enddo
|
|
|
|
do k=1,N_int
|
|
|
|
det_bk(k) = psidet(k,2,i)
|
|
|
|
enddo
|
|
|
|
do k=1,N_int2
|
|
|
|
psi_det_save(k,2,i) = det_8(k)
|
|
|
|
enddo
|
|
|
|
enddo
|
|
|
|
call ezfio_set_determinants_psi_det(psi_det_save)
|
|
|
|
deallocate (psi_det_save)
|
|
|
|
|
|
|
|
allocate (psi_coef_save(ndet,nstates))
|
2015-03-19 21:14:52 +01:00
|
|
|
double precision :: accu_norm(nstates)
|
|
|
|
accu_norm = 0.d0
|
2014-07-09 00:41:08 +02:00
|
|
|
do k=1,nstates
|
|
|
|
do i=1,ndet
|
2015-03-19 21:14:52 +01:00
|
|
|
accu_norm(k) = accu_norm(k) + psicoef(i,k) * psicoef(i,k)
|
2014-07-09 00:41:08 +02:00
|
|
|
psi_coef_save(i,k) = psicoef(i,k)
|
|
|
|
enddo
|
|
|
|
enddo
|
2015-03-19 21:14:52 +01:00
|
|
|
do k = 1, nstates
|
|
|
|
accu_norm(k) = 1.d0/dsqrt(accu_norm(k))
|
|
|
|
enddo
|
|
|
|
do k=1,nstates
|
|
|
|
do i=1,ndet
|
|
|
|
psi_coef_save(i,k) = psi_coef_save(i,k) * accu_norm(k)
|
|
|
|
enddo
|
|
|
|
enddo
|
|
|
|
|
2014-07-09 00:41:08 +02:00
|
|
|
call ezfio_set_determinants_psi_coef(psi_coef_save)
|
2015-04-20 10:12:08 +02:00
|
|
|
call write_int(output_determinants,ndet,'Saved determinants')
|
2014-10-09 12:26:17 +02:00
|
|
|
call stop_progress
|
2014-07-09 00:41:08 +02:00
|
|
|
deallocate (psi_coef_save)
|
|
|
|
end
|
2014-11-28 09:46:34 +01:00
|
|
|
|
|
|
|
|
|
|
|
|
2015-07-15 14:01:06 +02:00
|
|
|
subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,index_det_save)
|
|
|
|
implicit none
|
|
|
|
BEGIN_DOC
|
|
|
|
! Save the wave function into the EZFIO file
|
|
|
|
END_DOC
|
|
|
|
use bitmasks
|
|
|
|
integer, intent(in) :: ndet,nstates
|
|
|
|
integer(bit_kind), intent(in) :: psidet(N_int,2,ndet)
|
|
|
|
double precision, intent(in) :: psicoef(ndet,nstates)
|
|
|
|
integer, intent(in) :: index_det_save(ndet)
|
|
|
|
integer, intent(in) :: ndetsave
|
|
|
|
integer*8, allocatable :: psi_det_save(:,:,:)
|
|
|
|
double precision, allocatable :: psi_coef_save(:,:)
|
|
|
|
integer*8 :: det_8(100)
|
|
|
|
integer(bit_kind) :: det_bk((100*8)/bit_kind)
|
|
|
|
integer :: N_int2
|
|
|
|
equivalence (det_8, det_bk)
|
|
|
|
|
|
|
|
integer :: i,k
|
|
|
|
|
|
|
|
call ezfio_set_determinants_N_int(N_int)
|
|
|
|
call ezfio_set_determinants_bit_kind(bit_kind)
|
|
|
|
call ezfio_set_determinants_N_det(ndetsave)
|
|
|
|
call ezfio_set_determinants_n_states(nstates)
|
|
|
|
call ezfio_set_determinants_mo_label(mo_label)
|
|
|
|
|
|
|
|
N_int2 = (N_int*bit_kind)/8
|
|
|
|
allocate (psi_det_save(N_int2,2,ndetsave))
|
|
|
|
do i=1,ndetsave
|
|
|
|
do k=1,N_int
|
|
|
|
det_bk(k) = psidet(k,1,index_det_save(i))
|
|
|
|
enddo
|
|
|
|
do k=1,N_int2
|
|
|
|
psi_det_save(k,1,i) = det_8(k)
|
|
|
|
enddo
|
|
|
|
do k=1,N_int
|
|
|
|
det_bk(k) = psidet(k,2,index_det_save(i))
|
|
|
|
enddo
|
|
|
|
do k=1,N_int2
|
|
|
|
psi_det_save(k,2,i) = det_8(k)
|
|
|
|
enddo
|
|
|
|
enddo
|
|
|
|
call ezfio_set_determinants_psi_det(psi_det_save)
|
|
|
|
deallocate (psi_det_save)
|
|
|
|
|
|
|
|
progress_bar(1) = 7
|
|
|
|
progress_value = dble(progress_bar(1))
|
|
|
|
allocate (psi_coef_save(ndetsave,nstates))
|
|
|
|
double precision :: accu_norm(nstates)
|
|
|
|
accu_norm = 0.d0
|
|
|
|
do k=1,nstates
|
|
|
|
do i=1,ndetsave
|
|
|
|
accu_norm(k) = accu_norm(k) + psicoef(index_det_save(i),k) * psicoef(index_det_save(i),k)
|
|
|
|
psi_coef_save(i,k) = psicoef(index_det_save(i),k)
|
|
|
|
enddo
|
|
|
|
enddo
|
|
|
|
do k = 1, nstates
|
|
|
|
accu_norm(k) = 1.d0/dsqrt(accu_norm(k))
|
|
|
|
enddo
|
|
|
|
do k=1,nstates
|
|
|
|
do i=1,ndetsave
|
|
|
|
psi_coef_save(i,k) = psi_coef_save(i,k) * accu_norm(k)
|
|
|
|
enddo
|
|
|
|
enddo
|
|
|
|
|
|
|
|
call ezfio_set_determinants_psi_coef(psi_coef_save)
|
|
|
|
call write_int(output_determinants,ndet,'Saved determinants')
|
|
|
|
call stop_progress
|
|
|
|
deallocate (psi_coef_save)
|
|
|
|
end
|
|
|
|
|
|
|
|
|
2016-05-20 09:44:22 +02:00
|
|
|
logical function detEq(a,b,Nint)
|
|
|
|
use bitmasks
|
|
|
|
implicit none
|
|
|
|
integer, intent(in) :: Nint
|
|
|
|
integer(bit_kind), intent(in) :: a(Nint,2), b(Nint,2)
|
|
|
|
integer :: ni, i
|
|
|
|
|
|
|
|
detEq = .false.
|
|
|
|
do i=1,2
|
|
|
|
do ni=1,Nint
|
|
|
|
if(a(ni,i) /= b(ni,i)) return
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
detEq = .true.
|
|
|
|
end function
|
|
|
|
|
|
|
|
|
|
|
|
integer function detCmp(a,b,Nint)
|
|
|
|
use bitmasks
|
|
|
|
implicit none
|
|
|
|
integer, intent(in) :: Nint
|
|
|
|
integer(bit_kind), intent(in) :: a(Nint,2), b(Nint,2)
|
|
|
|
integer :: ni, i
|
|
|
|
|
|
|
|
detCmp = 0
|
|
|
|
do i=1,2
|
|
|
|
do ni=Nint,1,-1
|
|
|
|
|
|
|
|
if(a(ni,i) < b(ni,i)) then
|
|
|
|
detCmp = -1
|
|
|
|
return
|
|
|
|
else if(a(ni,i) > b(ni,i)) then
|
|
|
|
detCmp = 1
|
|
|
|
return
|
|
|
|
end if
|
|
|
|
|
|
|
|
end do
|
|
|
|
end do
|
|
|
|
end function
|
|
|
|
|
|
|
|
|
2016-09-01 14:43:13 +02:00
|
|
|
subroutine apply_excitation(det, exc, res, ok, Nint)
|
|
|
|
use bitmasks
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
integer, intent(in) :: Nint
|
|
|
|
integer, intent(in) :: exc(0:2,2,2)
|
|
|
|
integer(bit_kind),intent(in) :: det(Nint, 2)
|
|
|
|
integer(bit_kind),intent(out) :: res(Nint, 2)
|
|
|
|
logical, intent(out) :: ok
|
|
|
|
integer :: h1,p1,h2,p2,s1,s2,degree
|
|
|
|
integer :: ii, pos
|
|
|
|
|
|
|
|
|
|
|
|
ok = .false.
|
|
|
|
degree = exc(0,1,1) + exc(0,1,2)
|
|
|
|
|
2016-11-30 20:57:24 +01:00
|
|
|
! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
|
|
|
! INLINE
|
|
|
|
select case(degree)
|
|
|
|
case(2)
|
|
|
|
if (exc(0,1,1) == 2) then
|
|
|
|
h1 = exc(1,1,1)
|
|
|
|
h2 = exc(2,1,1)
|
|
|
|
p1 = exc(1,2,1)
|
|
|
|
p2 = exc(2,2,1)
|
|
|
|
s1 = 1
|
|
|
|
s2 = 1
|
|
|
|
else if (exc(0,1,2) == 2) then
|
|
|
|
h1 = exc(1,1,2)
|
|
|
|
h2 = exc(2,1,2)
|
|
|
|
p1 = exc(1,2,2)
|
|
|
|
p2 = exc(2,2,2)
|
|
|
|
s1 = 2
|
|
|
|
s2 = 2
|
|
|
|
else
|
|
|
|
h1 = exc(1,1,1)
|
|
|
|
h2 = exc(1,1,2)
|
|
|
|
p1 = exc(1,2,1)
|
|
|
|
p2 = exc(1,2,2)
|
|
|
|
s1 = 1
|
|
|
|
s2 = 2
|
|
|
|
endif
|
|
|
|
case(1)
|
|
|
|
if (exc(0,1,1) == 1) then
|
|
|
|
h1 = exc(1,1,1)
|
|
|
|
h2 = 0
|
|
|
|
p1 = exc(1,2,1)
|
|
|
|
p2 = 0
|
|
|
|
s1 = 1
|
|
|
|
s2 = 0
|
|
|
|
else
|
|
|
|
h1 = exc(1,1,2)
|
|
|
|
h2 = 0
|
|
|
|
p1 = exc(1,2,2)
|
|
|
|
p2 = 0
|
|
|
|
s1 = 2
|
|
|
|
s2 = 0
|
|
|
|
endif
|
|
|
|
case(0)
|
|
|
|
h1 = 0
|
|
|
|
p1 = 0
|
|
|
|
h2 = 0
|
|
|
|
p2 = 0
|
|
|
|
s1 = 0
|
|
|
|
s2 = 0
|
|
|
|
case default
|
|
|
|
print *, degree
|
|
|
|
print *, "apply ex"
|
|
|
|
STOP
|
|
|
|
end select
|
|
|
|
! END INLINE
|
|
|
|
|
2016-09-01 14:43:13 +02:00
|
|
|
res = det
|
|
|
|
|
2016-11-30 20:57:24 +01:00
|
|
|
ii = ishft(h1-1,-bit_kind_shift) + 1
|
|
|
|
pos = h1-1-ishft(ii-1,bit_kind_shift)
|
|
|
|
if(iand(det(ii, s1), ibset(0_bit_kind, pos)) == 0_8) return
|
2016-09-01 14:43:13 +02:00
|
|
|
res(ii, s1) = ibclr(res(ii, s1), pos)
|
|
|
|
|
2016-11-30 20:57:24 +01:00
|
|
|
ii = ishft(p1-1,-bit_kind_shift) + 1
|
|
|
|
pos = p1-1-ishft(ii-1,bit_kind_shift)
|
2016-09-01 14:43:13 +02:00
|
|
|
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return
|
|
|
|
res(ii, s1) = ibset(res(ii, s1), pos)
|
|
|
|
|
|
|
|
if(degree == 2) then
|
2016-11-30 20:57:24 +01:00
|
|
|
ii = ishft(h2-1,-bit_kind_shift) + 1
|
|
|
|
pos = h2-1-ishft(ii-1,bit_kind_shift)
|
2016-09-01 14:43:13 +02:00
|
|
|
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return
|
|
|
|
res(ii, s2) = ibclr(res(ii, s2), pos)
|
|
|
|
|
2016-11-30 20:57:24 +01:00
|
|
|
ii = ishft(p2-1,-bit_kind_shift) + 1
|
|
|
|
pos = p2-1-ishft(ii-1,bit_kind_shift)
|
2016-09-01 14:43:13 +02:00
|
|
|
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return
|
|
|
|
res(ii, s2) = ibset(res(ii, s2), pos)
|
|
|
|
endif
|
|
|
|
ok = .true.
|
|
|
|
end subroutine
|
|
|
|
|
|
|
|
|
2016-09-05 17:16:09 +02:00
|
|
|
subroutine apply_particles(det, s1, p1, s2, p2, res, ok, Nint)
|
2016-09-01 14:43:13 +02:00
|
|
|
use bitmasks
|
|
|
|
implicit none
|
|
|
|
integer, intent(in) :: Nint
|
|
|
|
integer, intent(in) :: s1, p1, s2, p2
|
|
|
|
integer(bit_kind),intent(in) :: det(Nint, 2)
|
|
|
|
integer(bit_kind),intent(out) :: res(Nint, 2)
|
|
|
|
logical, intent(out) :: ok
|
|
|
|
integer :: ii, pos
|
|
|
|
|
|
|
|
ok = .false.
|
|
|
|
res = det
|
|
|
|
|
|
|
|
if(p1 /= 0) then
|
2016-11-30 21:12:21 +01:00
|
|
|
ii = ishft(p1-1,-bit_kind_shift) + 1
|
|
|
|
pos = p1-1-ishft(ii-1,bit_kind_shift)
|
2016-09-01 14:43:13 +02:00
|
|
|
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return
|
|
|
|
res(ii, s1) = ibset(res(ii, s1), pos)
|
|
|
|
end if
|
|
|
|
|
2016-11-30 21:12:21 +01:00
|
|
|
ii = ishft(p2-1,-bit_kind_shift) + 1
|
|
|
|
pos = p2-1-ishft(ii-1,bit_kind_shift)
|
2016-09-01 14:43:13 +02:00
|
|
|
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return
|
|
|
|
res(ii, s2) = ibset(res(ii, s2), pos)
|
|
|
|
|
|
|
|
ok = .true.
|
|
|
|
end subroutine
|
|
|
|
|
|
|
|
|
2016-09-05 17:16:09 +02:00
|
|
|
subroutine apply_holes(det, s1, h1, s2, h2, res, ok, Nint)
|
2016-09-01 14:43:13 +02:00
|
|
|
use bitmasks
|
|
|
|
implicit none
|
|
|
|
integer, intent(in) :: Nint
|
|
|
|
integer, intent(in) :: s1, h1, s2, h2
|
|
|
|
integer(bit_kind),intent(in) :: det(Nint, 2)
|
|
|
|
integer(bit_kind),intent(out) :: res(Nint, 2)
|
|
|
|
logical, intent(out) :: ok
|
|
|
|
integer :: ii, pos
|
|
|
|
|
|
|
|
ok = .false.
|
|
|
|
res = det
|
|
|
|
|
|
|
|
if(h1 /= 0) then
|
2016-11-30 21:12:21 +01:00
|
|
|
ii = ishft(h1-1,-bit_kind_shift) + 1
|
|
|
|
pos = h1-1-ishft(ii-1,bit_kind_shift)
|
2016-09-01 14:43:13 +02:00
|
|
|
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return
|
|
|
|
res(ii, s1) = ibclr(res(ii, s1), pos)
|
|
|
|
end if
|
|
|
|
|
2016-11-30 21:12:21 +01:00
|
|
|
ii = ishft(h2-1,-bit_kind_shift) + 1
|
|
|
|
pos = h2-1-ishft(ii-1,bit_kind_shift)
|
2016-09-01 14:43:13 +02:00
|
|
|
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return
|
|
|
|
res(ii, s2) = ibclr(res(ii, s2), pos)
|
|
|
|
|
|
|
|
ok = .true.
|
|
|
|
end subroutine
|
|
|
|
|
2016-09-05 17:16:09 +02:00
|
|
|
subroutine apply_particle(det, s1, p1, res, ok, Nint)
|
|
|
|
use bitmasks
|
|
|
|
implicit none
|
|
|
|
integer, intent(in) :: Nint
|
|
|
|
integer, intent(in) :: s1, p1
|
|
|
|
integer(bit_kind),intent(in) :: det(Nint, 2)
|
|
|
|
integer(bit_kind),intent(out) :: res(Nint, 2)
|
|
|
|
logical, intent(out) :: ok
|
|
|
|
integer :: ii, pos
|
|
|
|
|
|
|
|
ok = .false.
|
|
|
|
res = det
|
|
|
|
|
2016-11-30 21:12:21 +01:00
|
|
|
ii = ishft(p1-1,-bit_kind_shift) + 1
|
|
|
|
pos = p1-1-ishft(ii-1,bit_kind_shift)
|
2016-09-05 17:16:09 +02:00
|
|
|
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return
|
|
|
|
res(ii, s1) = ibset(res(ii, s1), pos)
|
|
|
|
|
|
|
|
ok = .true.
|
|
|
|
end subroutine
|
|
|
|
|
|
|
|
|
|
|
|
subroutine apply_hole(det, s1, h1, res, ok, Nint)
|
|
|
|
use bitmasks
|
|
|
|
implicit none
|
|
|
|
integer, intent(in) :: Nint
|
|
|
|
integer, intent(in) :: s1, h1
|
|
|
|
integer(bit_kind),intent(in) :: det(Nint, 2)
|
|
|
|
integer(bit_kind),intent(out) :: res(Nint, 2)
|
|
|
|
logical, intent(out) :: ok
|
|
|
|
integer :: ii, pos
|
|
|
|
|
|
|
|
ok = .false.
|
|
|
|
res = det
|
|
|
|
|
2016-11-30 21:12:21 +01:00
|
|
|
ii = ishft(h1-1,-bit_kind_shift) + 1
|
|
|
|
pos = h1-1-ishft(ii-1,bit_kind_shift)
|
2016-09-05 17:16:09 +02:00
|
|
|
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return
|
|
|
|
res(ii, s1) = ibclr(res(ii, s1), pos)
|
|
|
|
|
|
|
|
ok = .true.
|
2016-09-20 17:29:02 +02:00
|
|
|
end subroutine
|