10
0
mirror of https://github.com/LCPQ/quantum_package synced 2024-12-23 04:43:50 +01:00

Indentation

This commit is contained in:
Anthony Scemama 2017-11-29 13:56:48 +01:00
parent 4a7a80679b
commit 2dea5ea1af
3 changed files with 512 additions and 511 deletions

View File

@ -18,80 +18,80 @@ END_PROVIDER
BEGIN_PROVIDER [ integer, N_det ] BEGIN_PROVIDER [ integer, N_det ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Number of determinants in the wave function ! Number of determinants in the wave function
END_DOC END_DOC
logical :: exists logical :: exists
character*(64) :: label character*(64) :: label
PROVIDE read_wf mo_label ezfio_filename nproc PROVIDE read_wf mo_label ezfio_filename nproc
if (mpi_master) then if (mpi_master) then
if (read_wf) then if (read_wf) then
call ezfio_has_determinants_n_det(exists) call ezfio_has_determinants_n_det(exists)
if (exists) then if (exists) then
call ezfio_has_determinants_mo_label(exists) call ezfio_has_determinants_mo_label(exists)
if (exists) then if (exists) then
call ezfio_get_determinants_mo_label(label) call ezfio_get_determinants_mo_label(label)
exists = (label == mo_label) exists = (label == mo_label)
endif endif
endif endif
if (exists) then if (exists) then
call ezfio_get_determinants_n_det(N_det) call ezfio_get_determinants_n_det(N_det)
else else
N_det = 1 N_det = 1
endif endif
else else
N_det = 1 N_det = 1
endif endif
call write_int(output_determinants,N_det,'Number of determinants') call write_int(output_determinants,N_det,'Number of determinants')
endif endif
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST( N_det, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST( N_det, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
stop 'Unable to read N_det with MPI' stop 'Unable to read N_det with MPI'
endif endif
IRP_ENDIF IRP_ENDIF
ASSERT (N_det > 0) ASSERT (N_det > 0)
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [integer, max_degree_exc] BEGIN_PROVIDER [integer, max_degree_exc]
implicit none implicit none
integer :: i,degree integer :: i,degree
max_degree_exc = 0 max_degree_exc = 0
BEGIN_DOC BEGIN_DOC
! Maximum degree of excitation in the wf ! Maximum degree of excitation in the wf
END_DOC END_DOC
do i = 1, N_det do i = 1, N_det
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int) call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
if(degree.gt.max_degree_exc)then if(degree.gt.max_degree_exc)then
max_degree_exc= degree max_degree_exc= degree
endif endif
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer, psi_det_size ] BEGIN_PROVIDER [ integer, psi_det_size ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Size of the psi_det/psi_coef arrays ! Size of the psi_det/psi_coef arrays
END_DOC END_DOC
PROVIDE ezfio_filename output_determinants PROVIDE ezfio_filename output_determinants
logical :: exists logical :: exists
if (mpi_master) then if (mpi_master) then
call ezfio_has_determinants_n_det(exists) call ezfio_has_determinants_n_det(exists)
if (exists) then if (exists) then
call ezfio_get_determinants_n_det(psi_det_size) call ezfio_get_determinants_n_det(psi_det_size)
else else
psi_det_size = 1 psi_det_size = 1
endif
psi_det_size = max(psi_det_size,100000)
call write_int(output_determinants,psi_det_size,'Dimension of the psi arrays')
endif endif
psi_det_size = max(psi_det_size,100000)
call write_int(output_determinants,psi_det_size,'Dimension of the psi arrays')
endif
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
stop 'Unable to read psi_det_size with MPI' stop 'Unable to read psi_det_size with MPI'
@ -102,61 +102,61 @@ BEGIN_PROVIDER [ integer, psi_det_size ]
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ] BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! The wave function determinants. Initialized with Hartree-Fock if the EZFIO file ! The wave function determinants. Initialized with Hartree-Fock if the EZFIO file
! is empty ! is empty
END_DOC END_DOC
integer :: i integer :: i
logical :: exists logical :: exists
character*(64) :: label character*(64) :: label
PROVIDE read_wf N_det mo_label ezfio_filename HF_bitmask mo_coef PROVIDE read_wf N_det mo_label ezfio_filename HF_bitmask mo_coef
psi_det = 0_bit_kind psi_det = 0_bit_kind
if (mpi_master) then if (mpi_master) then
if (read_wf) then if (read_wf) then
call ezfio_has_determinants_N_int(exists) call ezfio_has_determinants_N_int(exists)
if (exists) then
call ezfio_has_determinants_bit_kind(exists)
if (exists) then
call ezfio_has_determinants_N_det(exists)
if (exists) then if (exists) then
call ezfio_has_determinants_N_states(exists) call ezfio_has_determinants_bit_kind(exists)
if (exists) then
call ezfio_has_determinants_psi_det(exists)
if (exists) then if (exists) then
call ezfio_has_determinants_mo_label(exists) call ezfio_has_determinants_N_det(exists)
if (exists) then if (exists) then
call ezfio_get_determinants_mo_label(label) call ezfio_has_determinants_N_states(exists)
exists = (label == mo_label) if (exists) then
call ezfio_has_determinants_psi_det(exists)
if (exists) then
call ezfio_has_determinants_mo_label(exists)
if (exists) then
call ezfio_get_determinants_mo_label(label)
exists = (label == mo_label)
endif
endif
endif
endif endif
endif endif
endif
endif endif
endif
endif
if (exists) then if (exists) then
call read_dets(psi_det,N_int,N_det) call read_dets(psi_det,N_int,N_det)
print *, 'Read psi_det' print *, 'Read psi_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
else else
psi_det = 0_bit_kind psi_det = 0_bit_kind
do i=1,N_int do i=1,N_int
psi_det(i,1,1) = HF_bitmask(i,1) psi_det(i,1,1) = HF_bitmask(i,1)
psi_det(i,2,1) = HF_bitmask(i,2) psi_det(i,2,1) = HF_bitmask(i,2)
enddo enddo
endif endif
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
endif endif
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST( psi_det, N_int*2*N_det, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST( psi_det, N_int*2*N_det, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
stop 'Unable to read psi_det with MPI' stop 'Unable to read psi_det with MPI'
@ -186,25 +186,25 @@ BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ]
enddo enddo
if (mpi_master) then if (mpi_master) then
if (read_wf) then if (read_wf) then
call ezfio_has_determinants_psi_coef(exists) call ezfio_has_determinants_psi_coef(exists)
if (exists) then
call ezfio_has_determinants_mo_label(exists)
if (exists) then if (exists) then
call ezfio_get_determinants_mo_label(label) call ezfio_has_determinants_mo_label(exists)
exists = (label == mo_label) if (exists) then
call ezfio_get_determinants_mo_label(label)
exists = (label == mo_label)
endif
endif
if (exists) then
call ezfio_get_determinants_psi_coef(psi_coef)
endif endif
endif
if (exists) then
call ezfio_get_determinants_psi_coef(psi_coef)
endif
endif endif
print *, 'Read psi_coef' print *, 'Read psi_coef'
endif endif
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST( psi_coef, N_states*psi_det_size, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST( psi_coef, N_states*psi_det_size, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
stop 'Unable to read psi_coef with MPI' stop 'Unable to read psi_coef with MPI'
@ -218,20 +218,20 @@ END_PROVIDER
subroutine update_psi_average_norm_contrib(w) subroutine update_psi_average_norm_contrib(w)
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Compute psi_average_norm_contrib for different state average weights w(:) ! Compute psi_average_norm_contrib for different state average weights w(:)
END_DOC END_DOC
double precision, intent(in) :: w(N_states) double precision, intent(in) :: w(N_states)
double precision :: w0(N_states), f double precision :: w0(N_states), f
w0(:) = w(:)/sum(w(:)) w0(:) = w(:)/sum(w(:))
integer :: i,j,k integer :: i,j,k
do i=1,N_det do i=1,N_det
psi_average_norm_contrib(i) = psi_coef(i,1)*psi_coef(i,1)*w(1) psi_average_norm_contrib(i) = psi_coef(i,1)*psi_coef(i,1)*w(1)
enddo enddo
do k=2,N_states do k=2,N_states
do i=1,N_det do i=1,N_det
psi_average_norm_contrib(i) = psi_average_norm_contrib(i) + & psi_average_norm_contrib(i) = psi_average_norm_contrib(i) + &
psi_coef(i,k)*psi_coef(i,k)*w(k) psi_coef(i,k)*psi_coef(i,k)*w(k)
enddo enddo
enddo enddo
f = 1.d0/sum(psi_average_norm_contrib(1:N_det)) f = 1.d0/sum(psi_average_norm_contrib(1:N_det))
@ -244,26 +244,26 @@ end subroutine
BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (psi_det_size) ] BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (psi_det_size) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Contribution of determinants to the state-averaged density ! Contribution of determinants to the state-averaged density
END_DOC END_DOC
integer :: i,j,k integer :: i,j,k
double precision :: f double precision :: f
f = 1.d0/dble(N_states) f = 1.d0/dble(N_states)
do i=1,N_det do i=1,N_det
psi_average_norm_contrib(i) = psi_coef(i,1)*psi_coef(i,1)*f psi_average_norm_contrib(i) = psi_coef(i,1)*psi_coef(i,1)*f
enddo enddo
do k=2,N_states do k=2,N_states
do i=1,N_det do i=1,N_det
psi_average_norm_contrib(i) = psi_average_norm_contrib(i) + & psi_average_norm_contrib(i) = psi_average_norm_contrib(i) + &
psi_coef(i,k)*psi_coef(i,k)*f psi_coef(i,k)*psi_coef(i,k)*f
enddo enddo
enddo enddo
f = 1.d0/sum(psi_average_norm_contrib(1:N_det)) f = 1.d0/sum(psi_average_norm_contrib(1:N_det))
do i=1,N_det do i=1,N_det
psi_average_norm_contrib(i) = psi_average_norm_contrib(i)*f psi_average_norm_contrib(i) = psi_average_norm_contrib(i)*f
enddo enddo
END_PROVIDER END_PROVIDER
@ -279,109 +279,109 @@ END_PROVIDER
&BEGIN_PROVIDER [ double precision, psi_coef_sorted, (psi_det_size,N_states) ] &BEGIN_PROVIDER [ double precision, psi_coef_sorted, (psi_det_size,N_states) ]
&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted, (psi_det_size) ] &BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted, (psi_det_size) ]
&BEGIN_PROVIDER [ integer, psi_det_sorted_order, (psi_det_size) ] &BEGIN_PROVIDER [ integer, psi_det_sorted_order, (psi_det_size) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Wave function sorted by determinants contribution to the norm (state-averaged) ! Wave function sorted by determinants contribution to the norm (state-averaged)
! !
! psi_det_sorted_order(i) -> k : index in psi_det ! psi_det_sorted_order(i) -> k : index in psi_det
END_DOC END_DOC
integer :: i,j,k integer :: i,j,k
integer, allocatable :: iorder(:) integer, allocatable :: iorder(:)
allocate ( iorder(N_det) ) allocate ( iorder(N_det) )
do i=1,N_det do i=1,N_det
psi_average_norm_contrib_sorted(i) = -psi_average_norm_contrib(i) psi_average_norm_contrib_sorted(i) = -psi_average_norm_contrib(i)
iorder(i) = i iorder(i) = i
enddo enddo
call dsort(psi_average_norm_contrib_sorted,iorder,N_det) call dsort(psi_average_norm_contrib_sorted,iorder,N_det)
do i=1,N_det do i=1,N_det
do j=1,N_int do j=1,N_int
psi_det_sorted(j,1,i) = psi_det(j,1,iorder(i)) psi_det_sorted(j,1,i) = psi_det(j,1,iorder(i))
psi_det_sorted(j,2,i) = psi_det(j,2,iorder(i)) psi_det_sorted(j,2,i) = psi_det(j,2,iorder(i))
enddo enddo
do k=1,N_states do k=1,N_states
psi_coef_sorted(i,k) = psi_coef(iorder(i),k) psi_coef_sorted(i,k) = psi_coef(iorder(i),k)
enddo enddo
psi_average_norm_contrib_sorted(i) = -psi_average_norm_contrib_sorted(i) psi_average_norm_contrib_sorted(i) = -psi_average_norm_contrib_sorted(i)
enddo enddo
do i=1,N_det do i=1,N_det
psi_det_sorted_order(iorder(i)) = i psi_det_sorted_order(iorder(i)) = i
enddo enddo
deallocate(iorder) deallocate(iorder)
END_PROVIDER END_PROVIDER
subroutine flip_generators() subroutine flip_generators()
integer :: i,j,k integer :: i,j,k
integer(bit_kind) :: detmp(N_int,2) integer(bit_kind) :: detmp(N_int,2)
double precision :: tmp(N_states) double precision :: tmp(N_states)
do i=1,N_det_generators/2 do i=1,N_det_generators/2
detmp(:,:) = psi_det_sorted(:,:,i) detmp(:,:) = psi_det_sorted(:,:,i)
tmp = psi_coef_sorted(i, :) tmp = psi_coef_sorted(i, :)
psi_det_sorted(:,:,i) = psi_det_sorted(:,:,N_det_generators+1-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_coef_sorted(i, :) = psi_coef_sorted(N_det_generators+1-i, :)
psi_det_sorted(:,:,N_det_generators+1-i) = detmp(:,:) psi_det_sorted(:,:,N_det_generators+1-i) = detmp(:,:)
psi_coef_sorted(N_det_generators+1-i, :) = tmp psi_coef_sorted(N_det_generators+1-i, :) = tmp
end do end do
TOUCH psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted TOUCH psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted
end subroutine end subroutine
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit, (N_int,2,psi_det_size) ] 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) ] &BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (psi_det_size,N_states) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Determinants on which we apply <i|H|psi> for perturbation. ! Determinants on which we apply <i|H|psi> for perturbation.
! They are sorted by determinants interpreted as integers. Useful ! They are sorted by determinants interpreted as integers. Useful
! to accelerate the search of a random determinant in the wave ! to accelerate the search of a random determinant in the wave
! function. ! function.
END_DOC END_DOC
call sort_dets_by_det_search_key(N_det, psi_det, psi_coef, & call sort_dets_by_det_search_key(N_det, psi_det, psi_coef, &
psi_det_sorted_bit, psi_coef_sorted_bit) psi_det_sorted_bit, psi_coef_sorted_bit)
END_PROVIDER END_PROVIDER
subroutine sort_dets_by_det_search_key(Ndet, det_in, coef_in, det_out, coef_out) subroutine sort_dets_by_det_search_key(Ndet, det_in, coef_in, det_out, coef_out)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: Ndet integer, intent(in) :: Ndet
integer(bit_kind), intent(in) :: det_in (N_int,2,psi_det_size) integer(bit_kind), intent(in) :: det_in (N_int,2,psi_det_size)
double precision , intent(in) :: coef_in(psi_det_size,N_states) double precision , intent(in) :: coef_in(psi_det_size,N_states)
integer(bit_kind), intent(out) :: det_out (N_int,2,psi_det_size) integer(bit_kind), intent(out) :: det_out (N_int,2,psi_det_size)
double precision , intent(out) :: coef_out(psi_det_size,N_states) double precision , intent(out) :: coef_out(psi_det_size,N_states)
BEGIN_DOC BEGIN_DOC
! Determinants are sorted are sorted according to their det_search_key. ! Determinants are sorted are sorted according to their det_search_key.
! Useful to accelerate the search of a random determinant in the wave ! Useful to accelerate the search of a random determinant in the wave
! function. ! function.
END_DOC END_DOC
integer :: i,j,k integer :: i,j,k
integer, allocatable :: iorder(:) integer, allocatable :: iorder(:)
integer*8, allocatable :: bit_tmp(:) integer*8, allocatable :: bit_tmp(:)
integer*8, external :: det_search_key integer*8, external :: det_search_key
allocate ( iorder(Ndet), bit_tmp(Ndet) ) allocate ( iorder(Ndet), bit_tmp(Ndet) )
do i=1,Ndet do i=1,Ndet
iorder(i) = i iorder(i) = i
!$DIR FORCEINLINE !$DIR FORCEINLINE
bit_tmp(i) = det_search_key(det_in(1,1,i),N_int) bit_tmp(i) = det_search_key(det_in(1,1,i),N_int)
enddo enddo
call i8sort(bit_tmp,iorder,Ndet) call i8sort(bit_tmp,iorder,Ndet)
!DIR$ IVDEP !DIR$ IVDEP
do i=1,Ndet do i=1,Ndet
do j=1,N_int do j=1,N_int
det_out(j,1,i) = det_in(j,1,iorder(i)) det_out(j,1,i) = det_in(j,1,iorder(i))
det_out(j,2,i) = det_in(j,2,iorder(i)) det_out(j,2,i) = det_in(j,2,iorder(i))
enddo enddo
do k=1,N_states do k=1,N_states
coef_out(i,k) = coef_in(iorder(i),k) coef_out(i,k) = coef_in(iorder(i),k)
enddo enddo
enddo enddo
deallocate(iorder, bit_tmp) deallocate(iorder, bit_tmp)
end end
@ -391,21 +391,21 @@ end
&BEGIN_PROVIDER [ double precision, psi_coef_min, (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_max, (N_states) ]
&BEGIN_PROVIDER [ double precision, abs_psi_coef_min, (N_states) ] &BEGIN_PROVIDER [ double precision, abs_psi_coef_min, (N_states) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Max and min values of the coefficients ! Max and min values of the coefficients
END_DOC END_DOC
integer:: i integer :: i
do i=1,N_states do i=1,N_states
psi_coef_min(i) = minval(psi_coef(:,i)) psi_coef_min(i) = minval(psi_coef(:,i))
psi_coef_max(i) = maxval(psi_coef(:,i)) psi_coef_max(i) = maxval(psi_coef(:,i))
abs_psi_coef_min(i) = minval( dabs(psi_coef(:,i)) ) abs_psi_coef_min(i) = minval( dabs(psi_coef(:,i)) )
abs_psi_coef_max(i) = maxval( 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_max(i), 'Max coef')
call write_double(6,psi_coef_min(i), 'Min 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_max(i), 'Max abs coef')
call write_double(6,abs_psi_coef_min(i), 'Min abs coef') call write_double(6,abs_psi_coef_min(i), 'Min abs coef')
enddo enddo
END_PROVIDER END_PROVIDER
@ -460,9 +460,9 @@ subroutine read_dets(det,Nint,Ndet)
end end
subroutine save_ref_determinant subroutine save_ref_determinant
implicit none implicit none
use bitmasks use bitmasks
double precision :: buffer(1,N_states) double precision :: buffer(1,N_states)
buffer = 0.d0 buffer = 0.d0
buffer(1,1) = 1.d0 buffer(1,1) = 1.d0
call save_wavefunction_general(1,N_states,ref_bitmask,1,buffer) call save_wavefunction_general(1,N_states,ref_bitmask,1,buffer)
@ -475,7 +475,7 @@ subroutine save_wavefunction
implicit none implicit none
use bitmasks use bitmasks
BEGIN_DOC BEGIN_DOC
! Save the wave function into the EZFIO file ! Save the wave function into the EZFIO file
END_DOC END_DOC
if (mpi_master) then if (mpi_master) then
call save_wavefunction_general(N_det,min(N_states,N_det),psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) call save_wavefunction_general(N_det,min(N_states,N_det),psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted)
@ -487,7 +487,7 @@ subroutine save_wavefunction_unsorted
implicit none implicit none
use bitmasks use bitmasks
BEGIN_DOC BEGIN_DOC
! Save the wave function into the EZFIO file ! Save the wave function into the EZFIO file
END_DOC END_DOC
if (mpi_master) then if (mpi_master) then
call save_wavefunction_general(N_det,min(N_states,N_det),psi_det,size(psi_coef,1),psi_coef) call save_wavefunction_general(N_det,min(N_states,N_det),psi_det,size(psi_coef,1),psi_coef)
@ -497,60 +497,60 @@ end
subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef)
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Save the wave function into the EZFIO file ! Save the wave function into the EZFIO file
END_DOC END_DOC
use bitmasks use bitmasks
include 'constants.include.F' include 'constants.include.F'
integer, intent(in) :: ndet,nstates,dim_psicoef integer, intent(in) :: ndet,nstates,dim_psicoef
integer(bit_kind), intent(in) :: psidet(N_int,2,ndet) integer(bit_kind), intent(in) :: psidet(N_int,2,ndet)
double precision, intent(in) :: psicoef(dim_psicoef,nstates) double precision, intent(in) :: psicoef(dim_psicoef,nstates)
integer*8, allocatable :: psi_det_save(:,:,:) integer*8, allocatable :: psi_det_save(:,:,:)
double precision, allocatable :: psi_coef_save(:,:) double precision, allocatable :: psi_coef_save(:,:)
integer :: i,j,k integer :: i,j,k
if (mpi_master) then if (mpi_master) then
call ezfio_set_determinants_N_int(N_int) call ezfio_set_determinants_N_int(N_int)
call ezfio_set_determinants_bit_kind(bit_kind) call ezfio_set_determinants_bit_kind(bit_kind)
call ezfio_set_determinants_N_det(ndet) call ezfio_set_determinants_N_det(ndet)
call ezfio_set_determinants_n_states(nstates) call ezfio_set_determinants_n_states(nstates)
call ezfio_set_determinants_mo_label(mo_label) call ezfio_set_determinants_mo_label(mo_label)
allocate (psi_det_save(N_int,2,ndet)) allocate (psi_det_save(N_int,2,ndet))
do i=1,ndet
do j=1,2
do k=1,N_int
psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8)
enddo
enddo
enddo
call ezfio_set_determinants_psi_det(psi_det_save)
deallocate (psi_det_save)
allocate (psi_coef_save(ndet,nstates))
double precision :: accu_norm(nstates)
accu_norm = 0.d0
do k=1,nstates
do i=1,ndet do i=1,ndet
accu_norm(k) = accu_norm(k) + psicoef(i,k) * psicoef(i,k) do j=1,2
psi_coef_save(i,k) = psicoef(i,k) do k=1,N_int
psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8)
enddo
enddo
enddo enddo
if (accu_norm(k) == 0.d0) then call ezfio_set_determinants_psi_det(psi_det_save)
accu_norm(k) = 1.e-12 deallocate (psi_det_save)
endif
enddo
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
call ezfio_set_determinants_psi_coef(psi_coef_save) allocate (psi_coef_save(ndet,nstates))
deallocate (psi_coef_save) double precision :: accu_norm(nstates)
call write_int(output_determinants,ndet,'Saved determinants') accu_norm = 0.d0
do k=1,nstates
do i=1,ndet
accu_norm(k) = accu_norm(k) + psicoef(i,k) * psicoef(i,k)
psi_coef_save(i,k) = psicoef(i,k)
enddo
if (accu_norm(k) == 0.d0) then
accu_norm(k) = 1.e-12
endif
enddo
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
call ezfio_set_determinants_psi_coef(psi_coef_save)
deallocate (psi_coef_save)
call write_int(output_determinants,ndet,'Saved determinants')
endif endif
end end
@ -559,14 +559,14 @@ end
subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,index_det_save) subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,index_det_save)
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Save the wave function into the EZFIO file ! Save the wave function into the EZFIO file
END_DOC END_DOC
use bitmasks use bitmasks
integer, intent(in) :: ndet,nstates integer, intent(in) :: ndet,nstates
integer(bit_kind), intent(in) :: psidet(N_int,2,ndet) integer(bit_kind), intent(in) :: psidet(N_int,2,ndet)
double precision, intent(in) :: psicoef(ndet,nstates) double precision, intent(in) :: psicoef(ndet,nstates)
integer, intent(in) :: index_det_save(ndet) integer, intent(in) :: index_det_save(ndet)
integer, intent(in) :: ndetsave integer, intent(in) :: ndetsave
integer*8, allocatable :: psi_det_save(:,:,:) integer*8, allocatable :: psi_det_save(:,:,:)
double precision, allocatable :: psi_coef_save(:,:) double precision, allocatable :: psi_coef_save(:,:)
integer*8 :: det_8(100) integer*8 :: det_8(100)
@ -574,7 +574,7 @@ subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,inde
integer :: N_int2 integer :: N_int2
equivalence (det_8, det_bk) equivalence (det_8, det_bk)
integer :: i,k integer :: i,k
call ezfio_set_determinants_N_int(N_int) call ezfio_set_determinants_N_int(N_int)
call ezfio_set_determinants_bit_kind(bit_kind) call ezfio_set_determinants_bit_kind(bit_kind)
@ -604,7 +604,7 @@ subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,inde
progress_bar(1) = 7 progress_bar(1) = 7
progress_value = dble(progress_bar(1)) progress_value = dble(progress_bar(1))
allocate (psi_coef_save(ndetsave,nstates)) allocate (psi_coef_save(ndetsave,nstates))
double precision :: accu_norm(nstates) double precision :: accu_norm(nstates)
accu_norm = 0.d0 accu_norm = 0.d0
do k=1,nstates do k=1,nstates
do i=1,ndetsave do i=1,ndetsave
@ -613,7 +613,7 @@ subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,inde
enddo enddo
enddo enddo
do k = 1, nstates do k = 1, nstates
accu_norm(k) = 1.d0/dsqrt(accu_norm(k)) accu_norm(k) = 1.d0/dsqrt(accu_norm(k))
enddo enddo
do k=1,nstates do k=1,nstates
do i=1,ndetsave do i=1,ndetsave
@ -628,43 +628,43 @@ end
logical function detEq(a,b,Nint) logical function detEq(a,b,Nint)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: Nint integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: a(Nint,2), b(Nint,2) integer(bit_kind), intent(in) :: a(Nint,2), b(Nint,2)
integer :: ni, i integer :: ni, i
detEq = .false. detEq = .false.
do i=1,2 do i=1,2
do ni=1,Nint do ni=1,Nint
if(a(ni,i) /= b(ni,i)) return if(a(ni,i) /= b(ni,i)) return
end do end do
end do end do
detEq = .true. detEq = .true.
end function end function
integer function detCmp(a,b,Nint) integer function detCmp(a,b,Nint)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: Nint integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: a(Nint,2), b(Nint,2) integer(bit_kind), intent(in) :: a(Nint,2), b(Nint,2)
integer :: ni, i integer :: ni, i
detCmp = 0 detCmp = 0
do i=1,2 do i=1,2
do ni=Nint,1,-1 do ni=Nint,1,-1
if(a(ni,i) < b(ni,i)) then if(a(ni,i) < b(ni,i)) then
detCmp = -1 detCmp = -1
return return
else if(a(ni,i) > b(ni,i)) then else if(a(ni,i) > b(ni,i)) then
detCmp = 1 detCmp = 1
return return
end if end if
end do end do
end do end do
end function end function
@ -672,20 +672,20 @@ subroutine apply_excitation(det, exc, res, ok, Nint)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: Nint integer, intent(in) :: Nint
integer, intent(in) :: exc(0:2,2,2) integer, intent(in) :: exc(0:2,2,2)
integer(bit_kind),intent(in) :: det(Nint, 2) integer(bit_kind),intent(in) :: det(Nint, 2)
integer(bit_kind),intent(out) :: res(Nint, 2) integer(bit_kind),intent(out) :: res(Nint, 2)
logical, intent(out) :: ok logical, intent(out) :: ok
integer :: h1,p1,h2,p2,s1,s2,degree integer :: h1,p1,h2,p2,s1,s2,degree
integer :: ii, pos integer :: ii, pos
ok = .false. ok = .false.
degree = exc(0,1,1) + exc(0,1,2) degree = exc(0,1,1) + exc(0,1,2)
! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) ! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
! INLINE ! INLINE
select case(degree) select case(degree)
case(2) case(2)
if (exc(0,1,1) == 2) then if (exc(0,1,1) == 2) then
@ -733,12 +733,12 @@ subroutine apply_excitation(det, exc, res, ok, Nint)
p2 = 0 p2 = 0
s1 = 0 s1 = 0
s2 = 0 s2 = 0
case default case default
print *, degree print *, degree
print *, "apply ex" print *, "apply ex"
STOP STOP
end select end select
! END INLINE ! END INLINE
res = det res = det
@ -770,21 +770,21 @@ end subroutine
subroutine apply_particles(det, s1, p1, s2, p2, res, ok, Nint) subroutine apply_particles(det, s1, p1, s2, p2, res, ok, Nint)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: Nint integer, intent(in) :: Nint
integer, intent(in) :: s1, p1, s2, p2 integer, intent(in) :: s1, p1, s2, p2
integer(bit_kind),intent(in) :: det(Nint, 2) integer(bit_kind),intent(in) :: det(Nint, 2)
integer(bit_kind),intent(out) :: res(Nint, 2) integer(bit_kind),intent(out) :: res(Nint, 2)
logical, intent(out) :: ok logical, intent(out) :: ok
integer :: ii, pos integer :: ii, pos
ok = .false. ok = .false.
res = det res = det
if(p1 /= 0) then if(p1 /= 0) then
ii = ishft(p1-1,-bit_kind_shift) + 1 ii = ishft(p1-1,-bit_kind_shift) + 1
pos = p1-1-ishft(ii-1,bit_kind_shift) pos = p1-1-ishft(ii-1,bit_kind_shift)
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return
res(ii, s1) = ibset(res(ii, s1), pos) res(ii, s1) = ibset(res(ii, s1), pos)
end if end if
ii = ishft(p2-1,-bit_kind_shift) + 1 ii = ishft(p2-1,-bit_kind_shift) + 1
@ -799,21 +799,21 @@ end subroutine
subroutine apply_holes(det, s1, h1, s2, h2, res, ok, Nint) subroutine apply_holes(det, s1, h1, s2, h2, res, ok, Nint)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: Nint integer, intent(in) :: Nint
integer, intent(in) :: s1, h1, s2, h2 integer, intent(in) :: s1, h1, s2, h2
integer(bit_kind),intent(in) :: det(Nint, 2) integer(bit_kind),intent(in) :: det(Nint, 2)
integer(bit_kind),intent(out) :: res(Nint, 2) integer(bit_kind),intent(out) :: res(Nint, 2)
logical, intent(out) :: ok logical, intent(out) :: ok
integer :: ii, pos integer :: ii, pos
ok = .false. ok = .false.
res = det res = det
if(h1 /= 0) then if(h1 /= 0) then
ii = ishft(h1-1,-bit_kind_shift) + 1 ii = ishft(h1-1,-bit_kind_shift) + 1
pos = h1-1-ishft(ii-1,bit_kind_shift) pos = h1-1-ishft(ii-1,bit_kind_shift)
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return
res(ii, s1) = ibclr(res(ii, s1), pos) res(ii, s1) = ibclr(res(ii, s1), pos)
end if end if
ii = ishft(h2-1,-bit_kind_shift) + 1 ii = ishft(h2-1,-bit_kind_shift) + 1
@ -827,12 +827,12 @@ end subroutine
subroutine apply_particle(det, s1, p1, res, ok, Nint) subroutine apply_particle(det, s1, p1, res, ok, Nint)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: Nint integer, intent(in) :: Nint
integer, intent(in) :: s1, p1 integer, intent(in) :: s1, p1
integer(bit_kind),intent(in) :: det(Nint, 2) integer(bit_kind),intent(in) :: det(Nint, 2)
integer(bit_kind),intent(out) :: res(Nint, 2) integer(bit_kind),intent(out) :: res(Nint, 2)
logical, intent(out) :: ok logical, intent(out) :: ok
integer :: ii, pos integer :: ii, pos
ok = .false. ok = .false.
res = det res = det
@ -849,12 +849,12 @@ end subroutine
subroutine apply_hole(det, s1, h1, res, ok, Nint) subroutine apply_hole(det, s1, h1, res, ok, Nint)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: Nint integer, intent(in) :: Nint
integer, intent(in) :: s1, h1 integer, intent(in) :: s1, h1
integer(bit_kind),intent(in) :: det(Nint, 2) integer(bit_kind),intent(in) :: det(Nint, 2)
integer(bit_kind),intent(out) :: res(Nint, 2) integer(bit_kind),intent(out) :: res(Nint, 2)
logical, intent(out) :: ok logical, intent(out) :: ok
integer :: ii, pos integer :: ii, pos
ok = .false. ok = .false.
res = det res = det

View File

@ -1,7 +1,7 @@
BEGIN_PROVIDER [ integer, mo_tot_num ] BEGIN_PROVIDER [ integer, mo_tot_num ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Number of MOs ! Number of MOs
END_DOC END_DOC
logical :: has logical :: has
@ -11,14 +11,14 @@ BEGIN_PROVIDER [ integer, mo_tot_num ]
endif endif
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST( has, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST( has, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
stop 'Unable to read mo_tot_num with MPI' stop 'Unable to read mo_tot_num with MPI'
endif endif
IRP_ENDIF IRP_ENDIF
if (.not.has) then if (.not.has) then
mo_tot_num = ao_ortho_canonical_num mo_tot_num = ao_ortho_canonical_num
else else
if (mpi_master) then if (mpi_master) then
call ezfio_get_mo_basis_mo_tot_num(mo_tot_num) call ezfio_get_mo_basis_mo_tot_num(mo_tot_num)

View File

@ -7,61 +7,61 @@ BEGIN_PROVIDER [ double precision, nucl_coord, (nucl_num,3) ]
PROVIDE ezfio_filename nucl_label nucl_charge PROVIDE ezfio_filename nucl_label nucl_charge
if (mpi_master) then if (mpi_master) then
double precision, allocatable :: buffer(:,:) double precision, allocatable :: buffer(:,:)
nucl_coord = 0.d0 nucl_coord = 0.d0
allocate (buffer(nucl_num,3)) allocate (buffer(nucl_num,3))
buffer = 0.d0 buffer = 0.d0
logical :: has logical :: has
call ezfio_has_nuclei_nucl_coord(has) call ezfio_has_nuclei_nucl_coord(has)
if (.not.has) then if (.not.has) then
print *, irp_here print *, irp_here
stop 1 stop 1
endif endif
call ezfio_get_nuclei_nucl_coord(buffer) call ezfio_get_nuclei_nucl_coord(buffer)
integer :: i,j integer :: i,j
do i=1,3 do i=1,3
do j=1,nucl_num do j=1,nucl_num
nucl_coord(j,i) = buffer(j,i) nucl_coord(j,i) = buffer(j,i)
enddo enddo
enddo enddo
deallocate(buffer) deallocate(buffer)
character*(64), parameter :: f = '(A16, 4(1X,F12.6))' character*(64), parameter :: f = '(A16, 4(1X,F12.6))'
character*(64), parameter :: ft= '(A16, 4(1X,A12 ))' character*(64), parameter :: ft= '(A16, 4(1X,A12 ))'
double precision, parameter :: a0= 0.529177249d0 double precision, parameter :: a0= 0.529177249d0
call write_time(output_Nuclei) call write_time(output_Nuclei)
write(output_Nuclei,'(A)') '' write(output_Nuclei,'(A)') ''
write(output_Nuclei,'(A)') 'Nuclear Coordinates (Angstroms)' write(output_Nuclei,'(A)') 'Nuclear Coordinates (Angstroms)'
write(output_Nuclei,'(A)') '===============================' write(output_Nuclei,'(A)') '==============================='
write(output_Nuclei,'(A)') '' write(output_Nuclei,'(A)') ''
write(output_Nuclei,ft) & write(output_Nuclei,ft) &
'================','============','============','============','============' '================','============','============','============','============'
write(output_Nuclei,*) & write(output_Nuclei,*) &
' Atom Charge X Y Z ' ' Atom Charge X Y Z '
write(output_Nuclei,ft) & write(output_Nuclei,ft) &
'================','============','============','============','============' '================','============','============','============','============'
do i=1,nucl_num do i=1,nucl_num
write(output_Nuclei,f) nucl_label(i), nucl_charge(i), & write(output_Nuclei,f) nucl_label(i), nucl_charge(i), &
nucl_coord(i,1)*a0, & nucl_coord(i,1)*a0, &
nucl_coord(i,2)*a0, & nucl_coord(i,2)*a0, &
nucl_coord(i,3)*a0 nucl_coord(i,3)*a0
enddo enddo
write(output_Nuclei,ft) & write(output_Nuclei,ft) &
'================','============','============','============','============' '================','============','============','============','============'
write(output_Nuclei,'(A)') '' write(output_Nuclei,'(A)') ''
endif endif
IRP_IF MPI IRP_IF MPI
include 'mpif.h' include 'mpif.h'
integer :: ierr integer :: ierr
call MPI_BCAST( nucl_coord, 3*nucl_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) call MPI_BCAST( nucl_coord, 3*nucl_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then if (ierr /= MPI_SUCCESS) then
stop 'Unable to read nucl_coord with MPI' stop 'Unable to read nucl_coord with MPI'
endif endif
IRP_ENDIF IRP_ENDIF
END_PROVIDER END_PROVIDER
@ -146,29 +146,30 @@ BEGIN_PROVIDER [ double precision, nuclear_repulsion ]
END_DOC END_DOC
PROVIDE mpi_master nucl_coord nucl_charge nucl_num PROVIDE mpi_master nucl_coord nucl_charge nucl_num
IF (disk_access_nuclear_repulsion.EQ.'Read') THEN if (disk_access_nuclear_repulsion.EQ.'Read') then
LOGICAL :: has logical :: has
if (mpi_master) then
call ezfio_has_nuclei_nuclear_repulsion(has) if (mpi_master) then
if (has) then call ezfio_has_nuclei_nuclear_repulsion(has)
call ezfio_get_nuclei_nuclear_repulsion(nuclear_repulsion) if (has) then
else call ezfio_get_nuclei_nuclear_repulsion(nuclear_repulsion)
print *, 'nuclei/nuclear_repulsion not found in EZFIO file' else
stop 1 print *, 'nuclei/nuclear_repulsion not found in EZFIO file'
endif stop 1
print*, 'Read nuclear_repulsion' endif
endif print*, 'Read nuclear_repulsion'
IRP_IF MPI endif
include 'mpif.h' IRP_IF MPI
integer :: ierr include 'mpif.h'
call MPI_BCAST( nuclear_repulsion, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) integer :: ierr
if (ierr /= MPI_SUCCESS) then call MPI_BCAST( nuclear_repulsion, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
stop 'Unable to read nuclear_repulsion with MPI' if (ierr /= MPI_SUCCESS) then
endif stop 'Unable to read nuclear_repulsion with MPI'
IRP_ENDIF endif
IRP_ENDIF
ELSE else
integer :: k,l integer :: k,l
double precision :: Z12, r2, x(3) double precision :: Z12, r2, x(3)
@ -187,17 +188,17 @@ BEGIN_PROVIDER [ double precision, nuclear_repulsion ]
enddo enddo
enddo enddo
nuclear_repulsion *= 0.5d0 nuclear_repulsion *= 0.5d0
END IF end if
call write_time(output_Nuclei) call write_time(output_Nuclei)
call write_double(output_Nuclei,nuclear_repulsion, & call write_double(output_Nuclei,nuclear_repulsion, &
'Nuclear repulsion energy') 'Nuclear repulsion energy')
IF (disk_access_nuclear_repulsion.EQ.'Write') THEN if (disk_access_nuclear_repulsion.EQ.'Write') then
if (mpi_master) then if (mpi_master) then
call ezfio_set_nuclei_nuclear_repulsion(nuclear_repulsion) call ezfio_set_nuclei_nuclear_repulsion(nuclear_repulsion)
endif endif
END IF endif
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ character*(128), element_name, (78)] BEGIN_PROVIDER [ character*(128), element_name, (78)]