LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2025-01-08 20:33:26 +01:00
Code Issues Releases Wiki Activity

Minor modiffs

Browse Source
This commit is contained in:
Manu 2015-07-15 14:01:06 +02:00
parent cc89da9db3
commit 69250d7a2e
4 changed files with 126 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
scripts/generate_h_apply.py
View File

@ -28,6 +28,7 @@ filterhole
filterparticle
do_double_excitations
check_double_excitation
filter_vvvv_excitation
""".split()
class H_apply(object):
@ -50,7 +51,7 @@ class H_apply(object):
!$OMP accu,i_a,hole_tmp,particle_tmp,occ_particle_tmp, &
!$OMP occ_hole_tmp,key_idx,i_b,j_b,key,N_elec_in_key_part_1,&
!$OMP N_elec_in_key_hole_1,N_elec_in_key_part_2, &
!$OMP N_elec_in_key_hole_2,ia_ja_pairs) &
!$OMP N_elec_in_key_hole_2,ia_ja_pairs,key_union_hole_part) &
!$OMP SHARED(key_in,N_int,elec_num_tab,mo_tot_num, &
!$OMP hole_1, particl_1, hole_2, particl_2, &
!$OMP elec_alpha_num,i_generator) FIRSTPRIVATE(iproc)"""
@ -125,6 +126,21 @@ class H_apply(object):
self["check_double_excitation"] = """
check_double_excitation = .False.
"""
def filter_vvvv_excitation(self):
self["filter_vvvv_excitation"] = """
key_union_hole_part = 0_bit_kind
call set_bite_to_integer(i_a,key_union_hole_part,N_int)
call set_bite_to_integer(j_a,key_union_hole_part,N_int)
call set_bite_to_integer(i_b,key_union_hole_part,N_int)
call set_bite_to_integer(j_b,key_union_hole_part,N_int)
do jtest_vvvv = 1, N_int
if(iand(key_union_hole_part(jtest_vvvv),virt_bitmask(jtest_vvvv,1).ne.key_union_hole_part(jtest_vvvv)))then
b_cycle = .False.
endif
enddo
if(b_cycle) cycle
"""
def set_filter_holes(self):
self["filterhole"] = """
if(iand(ibset(0_bit_kind,j),hole(k,other_spin)).eq.0_bit_kind )cycle

14
src/Determinants/H_apply.template.f
View File

@ -18,6 +18,7 @@ subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_gene
integer(bit_kind), allocatable :: hole_save(:,:)
integer(bit_kind), allocatable :: key(:,:),hole(:,:), particle(:,:)
integer(bit_kind), allocatable :: hole_tmp(:,:), particle_tmp(:,:)
integer(bit_kind), allocatable :: key_union_hole_part(:)
integer :: ii,i,jj,j,k,ispin,l
integer, allocatable :: occ_particle(:,:), occ_hole(:,:)
integer, allocatable :: occ_particle_tmp(:,:), occ_hole_tmp(:,:)
@ -31,6 +32,7 @@ subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_gene
integer, allocatable :: ib_jb_pairs(:,:)
double precision :: diag_H_mat_elem
integer :: iproc
integer :: jtest_vvvv
integer(omp_lock_kind), save :: lck, ifirst=0
if (ifirst == 0) then
!$ call omp_init_lock(lck)
@ -38,6 +40,7 @@ subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_gene
endif
logical :: check_double_excitation
logical :: b_cycle
check_double_excitation = .True.
iproc = iproc_in
@ -50,7 +53,7 @@ subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_gene
key(N_int,2),hole(N_int,2), particle(N_int,2), hole_tmp(N_int,2),&
particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), &
occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),&
occ_hole_tmp(N_int*bit_kind_size,2))
occ_hole_tmp(N_int*bit_kind_size,2),key_union_hole_part(N_int))
$init_thread
@ -151,6 +154,7 @@ subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_gene
ASSERT (j_b > 0)
ASSERT (j_b <= mo_tot_num)
if (array_pairs(i_b,j_b)) then
$filter_vvvv_excitation
i+= 1
ib_jb_pairs(1,i) = i_b
ib_jb_pairs(2,i) = j_b
@ -200,6 +204,7 @@ subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_gene
ASSERT (j_b <= mo_tot_num)
if (j_b <= j_a) cycle
if (array_pairs(i_b,j_b)) then
$filter_vvvv_excitation
i+= 1
ib_jb_pairs(1,i) = i_b
ib_jb_pairs(2,i) = j_b
@ -245,7 +250,7 @@ subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_gene
key,hole, particle, hole_tmp,&
particle_tmp, occ_particle, &
occ_hole, occ_particle_tmp,&
occ_hole_tmp,array_pairs)
occ_hole_tmp,array_pairs,key_union_hole_part)
$omp_end_parallel
$finalization
end
@ -278,6 +283,7 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in $pa
integer :: N_elec_in_key_hole_1(2),N_elec_in_key_part_1(2)
integer :: N_elec_in_key_hole_2(2),N_elec_in_key_part_2(2)
logical :: is_a_two_holes_two_particles
integer(bit_kind), allocatable :: key_union_hole_part(:)
integer, allocatable :: ia_ja_pairs(:,:,:)
logical, allocatable :: array_pairs(:,:)
@ -305,7 +311,7 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in $pa
key(N_int,2),hole(N_int,2), particle(N_int,2), hole_tmp(N_int,2),&
particle_tmp(N_int,2), occ_particle(N_int*bit_kind_size,2), &
occ_hole(N_int*bit_kind_size,2), occ_particle_tmp(N_int*bit_kind_size,2),&
occ_hole_tmp(N_int*bit_kind_size,2))
occ_hole_tmp(N_int*bit_kind_size,2),key_union_hole_part(N_int))
$init_thread
!!!! First couple hole particle
do j = 1, N_int
@ -376,7 +382,7 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in $pa
key,hole, particle, hole_tmp,&
particle_tmp, occ_particle, &
occ_hole, occ_particle_tmp,&
occ_hole_tmp)
occ_hole_tmp,key_union_hole_part)
$omp_end_parallel
$finalization

11
src/Determinants/create_excitations.irp.f
View File

@ -34,3 +34,14 @@ subroutine do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok)
i_ok = -1
endif
end
subroutine set_bite_to_integer(i_physical,key,Nint)
use bitmasks
implicit none
integer, intent(in) :: i_physical,Nint
integer(bit_kind), intent(inout) :: key(Nint)
integer :: k,j,i
k = ishft(i_physical-1,-bit_kind_shift)+1
j = i_physical-ishft(k-1,bit_kind_shift)-1
key(k) = ibset(key(k),j)
end

88
src/Determinants/determinants.irp.f
View File

@ -731,3 +731,91 @@ end
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
PROVIDE progress_bar
call start_progress(7,'Saving wfunction',0.d0)
progress_bar(1) = 1
progress_value = dble(progress_bar(1))
call ezfio_set_determinants_N_int(N_int)
progress_bar(1) = 2
progress_value = dble(progress_bar(1))
call ezfio_set_determinants_bit_kind(bit_kind)
progress_bar(1) = 3
progress_value = dble(progress_bar(1))
call ezfio_set_determinants_N_det(ndetsave)
progress_bar(1) = 4
progress_value = dble(progress_bar(1))
call ezfio_set_determinants_n_states(nstates)
progress_bar(1) = 5
progress_value = dble(progress_bar(1))
call ezfio_set_determinants_mo_label(mo_label)
progress_bar(1) = 6
progress_value = dble(progress_bar(1))
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