mirror of
https://github.com/LCPQ/quantum_package
synced 2024-06-24 06:02:17 +02:00
357 lines
12 KiB
Fortran
357 lines
12 KiB
Fortran
subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2 $parameters )
|
|
use omp_lib
|
|
use bitmasks
|
|
implicit none
|
|
$declarations
|
|
integer(omp_lock_kind) :: lck
|
|
integer(bit_kind),intent(in) :: key_in(N_int,2)
|
|
integer(bit_kind),allocatable :: keys_out(:,:,:)
|
|
double precision, allocatable :: hij_tab(:)
|
|
integer(bit_kind), intent(in) :: hole_1(N_int,2), particl_1(N_int,2)
|
|
integer(bit_kind), intent(in) :: hole_2(N_int,2), particl_2(N_int,2)
|
|
integer(bit_kind) :: hole_save(N_int,2)
|
|
integer(bit_kind) :: key(N_int,2),hole(N_int,2), particle(N_int,2)
|
|
integer(bit_kind) :: hole_tmp(N_int,2), particle_tmp(N_int,2)
|
|
integer :: ii,i,jj,j,k,ispin,l
|
|
integer :: occ_particle(N_int*bit_kind_size,2)
|
|
integer :: occ_hole(N_int*bit_kind_size,2)
|
|
integer :: occ_particle_tmp(N_int*bit_kind_size,2)
|
|
integer :: occ_hole_tmp(N_int*bit_kind_size,2)
|
|
integer :: kk,pp,other_spin,key_idx
|
|
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)
|
|
|
|
integer,parameter :: size_max = $size_max
|
|
double precision :: hij_elec, mo_bielec_integral, thresh
|
|
integer, allocatable :: ia_ja_pairs(:,:,:)
|
|
double precision :: diag_H_mat_elem, E_ref
|
|
|
|
PROVIDE mo_integrals_map
|
|
PROVIDE mo_bielec_integrals_in_map
|
|
|
|
$set_i_H_j_threshold
|
|
|
|
$omp_init_lock
|
|
|
|
|
|
E_ref = diag_H_mat_elem(key_in,N_int)
|
|
|
|
$initialization
|
|
|
|
$omp_parallel
|
|
allocate (keys_out(N_int,2,size_max),hij_tab(size_max))
|
|
|
|
!print*,'key_in !!'
|
|
!call print_key(key_in)
|
|
!print*,'hole_1, particl_1'
|
|
!call print_key(hole_1)
|
|
!call print_key(particl_1)
|
|
!print*,'hole_2, particl_2'
|
|
!call print_key(hole_2)
|
|
!call print_key(particl_2)
|
|
|
|
|
|
!!!! First couple hole particle
|
|
do j = 1, N_int
|
|
hole(j,1) = iand(hole_1(j,1),key_in(j,1))
|
|
hole(j,2) = iand(hole_1(j,2),key_in(j,2))
|
|
particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1))
|
|
particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2))
|
|
enddo
|
|
call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int)
|
|
call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int)
|
|
call bitstring_to_list(hole(1,1),occ_hole(1,1),N_elec_in_key_hole_1(1),N_int)
|
|
call bitstring_to_list(hole(1,2),occ_hole(1,2),N_elec_in_key_hole_1(2),N_int)
|
|
allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2))
|
|
|
|
do ispin=1,2
|
|
i=0
|
|
do ii=N_elec_in_key_hole_1(ispin),1,-1 ! hole
|
|
i_a = occ_hole(ii,ispin)
|
|
ASSERT (i_a > 0)
|
|
ASSERT (i_a <= mo_tot_num)
|
|
|
|
do jj=1,N_elec_in_key_part_1(ispin) !particle
|
|
j_a = occ_particle(jj,ispin)
|
|
ASSERT (j_a > 0)
|
|
ASSERT (j_a <= mo_tot_num)
|
|
i += 1
|
|
ia_ja_pairs(1,i,ispin) = i_a
|
|
ia_ja_pairs(2,i,ispin) = j_a
|
|
enddo
|
|
enddo
|
|
ia_ja_pairs(1,0,ispin) = i
|
|
enddo
|
|
|
|
key_idx = 0
|
|
|
|
integer :: i_a,j_a,i_b,j_b,k_a,l_a,k_b,l_b
|
|
integer(bit_kind) :: test(N_int,2)
|
|
double precision :: accu
|
|
accu = 0.d0
|
|
hij_elec = 0.d0
|
|
do ispin=1,2
|
|
other_spin = iand(ispin,1)+1
|
|
$omp_do
|
|
do ii=1,ia_ja_pairs(1,0,ispin)
|
|
i_a = ia_ja_pairs(1,ii,ispin)
|
|
ASSERT (i_a > 0)
|
|
ASSERT (i_a <= mo_tot_num)
|
|
j_a = ia_ja_pairs(2,ii,ispin)
|
|
ASSERT (j_a > 0)
|
|
ASSERT (j_a <= mo_tot_num)
|
|
hole = key_in
|
|
k = ishft(i_a-1,-bit_kind_shift)+1
|
|
j = i_a-ishft(k-1,bit_kind_shift)-1
|
|
hole(k,ispin) = ibclr(hole(k,ispin),j)
|
|
k_a = ishft(j_a-1,-bit_kind_shift)+1
|
|
l_a = j_a-ishft(k_a-1,bit_kind_shift)-1
|
|
hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a)
|
|
|
|
!!!! Second couple hole particle
|
|
do j = 1, N_int
|
|
hole_tmp(j,1) = iand(hole_2(j,1),hole(j,1))
|
|
hole_tmp(j,2) = iand(hole_2(j,2),hole(j,2))
|
|
particle_tmp(j,1) = iand(xor(particl_2(j,1),hole(j,1)),particl_2(j,1))
|
|
particle_tmp(j,2) = iand(xor(particl_2(j,2),hole(j,2)),particl_2(j,2))
|
|
enddo
|
|
|
|
call bitstring_to_list(particle_tmp(1,1),occ_particle_tmp(1,1),N_elec_in_key_part_2(1),N_int)
|
|
call bitstring_to_list(particle_tmp(1,2),occ_particle_tmp(1,2),N_elec_in_key_part_2(2),N_int)
|
|
call bitstring_to_list(hole_tmp (1,1),occ_hole_tmp (1,1),N_elec_in_key_hole_2(1),N_int)
|
|
call bitstring_to_list(hole_tmp (1,2),occ_hole_tmp (1,2),N_elec_in_key_hole_2(2),N_int)
|
|
|
|
! hole = a^(+)_j_a(ispin) a_i_a(ispin)|key_in> : mono exc :: orb(i_a,ispin) --> orb(j_a,ispin)
|
|
hole_save = hole
|
|
if (ispin == 1) then
|
|
integer :: jjj
|
|
|
|
do kk = 1,N_elec_in_key_hole_2(other_spin)
|
|
hole = hole_save
|
|
i_b = occ_hole_tmp(kk,other_spin)
|
|
ASSERT (i_b > 0)
|
|
ASSERT (i_b <= mo_tot_num)
|
|
k = ishft(i_b-1,-bit_kind_shift)+1
|
|
j = i_b-ishft(k-1,bit_kind_shift)-1
|
|
hole(k,other_spin) = ibclr(hole(k,other_spin),j)
|
|
do jjj=1,N_elec_in_key_part_2(other_spin) ! particule
|
|
j_b = occ_particle_tmp(jjj,other_spin)
|
|
ASSERT (j_b > 0)
|
|
ASSERT (j_b <= mo_tot_num)
|
|
if(dabs( mo_bielec_integral(j_a,j_b,i_a,i_b))<thresh)cycle
|
|
key = hole
|
|
k = ishft(j_b-1,-bit_kind_shift)+1
|
|
l = j_b-ishft(k-1,bit_kind_shift)-1
|
|
key(k,other_spin) = ibset(key(k,other_spin),l)
|
|
call i_H_j(key,key_in,N_int,hij_elec)
|
|
if(dabs(hij_elec)>=thresh) then
|
|
key_idx += 1
|
|
do k=1,N_int
|
|
keys_out(k,1,key_idx) = key(k,1)
|
|
keys_out(k,2,key_idx) = key(k,2)
|
|
enddo
|
|
hij_tab(key_idx) = hij_elec
|
|
ASSERT (key_idx <= size_max)
|
|
if (key_idx == size_max) then
|
|
$omp_set_lock
|
|
$keys_work
|
|
$omp_unset_lock
|
|
key_idx = 0
|
|
endif
|
|
endif
|
|
enddo
|
|
if (key_idx > ishft(size_max,-5)) then
|
|
if ($omp_test_lock) then
|
|
$keys_work
|
|
$omp_unset_lock
|
|
key_idx = 0
|
|
endif
|
|
endif
|
|
enddo
|
|
endif
|
|
! does all the mono excitations of the same spin
|
|
do kk = 1,N_elec_in_key_hole_2(ispin)
|
|
i_b = occ_hole_tmp(kk,ispin)
|
|
ASSERT (i_b > 0)
|
|
ASSERT (i_b <= mo_tot_num)
|
|
if (i_b <= i_a.or.i_b == j_a) cycle
|
|
hole = hole_save
|
|
k = ishft(i_b-1,-bit_kind_shift)+1
|
|
j = i_b-ishft(k-1,bit_kind_shift)-1
|
|
hole(k,ispin) = ibclr(hole(k,ispin),j)
|
|
do jjj=1,N_elec_in_key_part_2(ispin)
|
|
j_b = occ_particle_tmp(jjj,ispin)
|
|
ASSERT (j_b > 0)
|
|
ASSERT (j_b <= mo_tot_num)
|
|
if (j_b <= j_a) cycle
|
|
if(dabs( mo_bielec_integral(j_a,j_b,i_b,i_a))<thresh)cycle
|
|
key = hole
|
|
k = ishft(j_b-1,-bit_kind_shift)+1
|
|
l = j_b-ishft(k-1,bit_kind_shift)-1
|
|
key(k,ispin) = ibset(key(k,ispin),l)
|
|
!! a^((+)_j_b(ispin) a_i_b(ispin) : mono exc :: orb(i_b,ispin) --> orb(j_b,ispin)
|
|
|
|
call i_H_j(key,key_in,N_int,hij_elec)
|
|
if(dabs(hij_elec)>=thresh) then
|
|
key_idx += 1
|
|
do k=1,N_int
|
|
keys_out(k,1,key_idx) = key(k,1)
|
|
keys_out(k,2,key_idx) = key(k,2)
|
|
enddo
|
|
hij_tab(key_idx) = hij_elec
|
|
ASSERT (key_idx <= size_max)
|
|
if (key_idx == size_max) then
|
|
$omp_set_lock
|
|
$keys_work
|
|
$omp_unset_lock
|
|
key_idx = 0
|
|
endif
|
|
endif
|
|
enddo
|
|
if (key_idx > ishft(size_max,-5)) then
|
|
if ($omp_test_lock) then
|
|
$keys_work
|
|
$omp_unset_lock
|
|
key_idx = 0
|
|
endif
|
|
endif
|
|
enddo! kk
|
|
enddo ! ii
|
|
$omp_enddo
|
|
enddo ! ispin
|
|
$omp_set_lock
|
|
$keys_work
|
|
$omp_unset_lock
|
|
deallocate (keys_out,hij_tab,ia_ja_pairs)
|
|
$omp_end_parallel
|
|
$omp_destroy_lock
|
|
$finalization
|
|
|
|
end
|
|
|
|
subroutine $subroutine_monoexc(key_in, hole_1,particl_1 $parameters )
|
|
use omp_lib
|
|
use bitmasks
|
|
implicit none
|
|
$declarations
|
|
integer(omp_lock_kind) :: lck
|
|
integer(bit_kind),intent(in) :: key_in(N_int,2)
|
|
integer(bit_kind),allocatable :: keys_out(:,:,:)
|
|
double precision, allocatable :: hij_tab(:)
|
|
integer(bit_kind), intent(in) :: hole_1(N_int,2), particl_1(N_int,2)
|
|
integer(bit_kind) :: hole_2(N_int,2), particl_2(N_int,2)
|
|
integer(bit_kind) :: hole_save(N_int,2)
|
|
integer(bit_kind) :: key(N_int,2),hole(N_int,2), particle(N_int,2)
|
|
integer(bit_kind) :: hole_tmp(N_int,2), particle_tmp(N_int,2)
|
|
integer :: ii,i,jj,j,k,ispin,l
|
|
integer :: occ_particle(N_int*bit_kind_size,2)
|
|
integer :: occ_hole(N_int*bit_kind_size,2)
|
|
integer :: occ_particle_tmp(N_int*bit_kind_size,2)
|
|
integer :: occ_hole_tmp(N_int*bit_kind_size,2)
|
|
integer :: kk,pp,other_spin,key_idx
|
|
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)
|
|
|
|
integer,parameter :: size_max = $size_max
|
|
double precision :: hij_elec, thresh
|
|
integer, allocatable :: ia_ja_pairs(:,:,:)
|
|
double precision :: diag_H_mat_elem, E_ref
|
|
|
|
PROVIDE mo_integrals_map
|
|
PROVIDE mo_bielec_integrals_in_map
|
|
|
|
$set_i_H_j_threshold
|
|
|
|
$omp_init_lock
|
|
|
|
|
|
E_ref = diag_H_mat_elem(key_in,N_int)
|
|
|
|
$initialization
|
|
|
|
$omp_parallel
|
|
allocate (keys_out(N_int,2,size_max),hij_tab(size_max))
|
|
!!!! First couple hole particle
|
|
do j = 1, N_int
|
|
hole(j,1) = iand(hole_1(j,1),key_in(j,1))
|
|
hole(j,2) = iand(hole_1(j,2),key_in(j,2))
|
|
particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1))
|
|
particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2))
|
|
enddo
|
|
|
|
call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int)
|
|
call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int)
|
|
call bitstring_to_list(hole (1,1),occ_hole (1,1),N_elec_in_key_hole_1(1),N_int)
|
|
call bitstring_to_list(hole (1,2),occ_hole (1,2),N_elec_in_key_hole_1(2),N_int)
|
|
allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2))
|
|
|
|
do ispin=1,2
|
|
i=0
|
|
do ii=N_elec_in_key_hole_1(ispin),1,-1 ! hole
|
|
i_a = occ_hole(ii,ispin)
|
|
do jj=1,N_elec_in_key_part_1(ispin) !particule
|
|
j_a = occ_particle(jj,ispin)
|
|
i += 1
|
|
ia_ja_pairs(1,i,ispin) = i_a
|
|
ia_ja_pairs(2,i,ispin) = j_a
|
|
enddo
|
|
enddo
|
|
ia_ja_pairs(1,0,ispin) = i
|
|
enddo
|
|
|
|
key_idx = 0
|
|
|
|
integer :: i_a,j_a,i_b,j_b,k_a,l_a,k_b,l_b
|
|
integer(bit_kind) :: test(N_int,2)
|
|
double precision :: accu
|
|
accu = 0.d0
|
|
hij_elec = 0.d0
|
|
do ispin=1,2
|
|
other_spin = iand(ispin,1)+1
|
|
$omp_do
|
|
do ii=1,ia_ja_pairs(1,0,ispin)
|
|
i_a = ia_ja_pairs(1,ii,ispin)
|
|
j_a = ia_ja_pairs(2,ii,ispin)
|
|
hole = key_in
|
|
k = ishft(i_a-1,-bit_kind_shift)+1
|
|
j = i_a-ishft(k-1,bit_kind_shift)-1
|
|
hole(k,ispin) = ibclr(hole(k,ispin),j)
|
|
k_a = ishft(j_a-1,-bit_kind_shift)+1
|
|
l_a = j_a-ishft(k_a-1,bit_kind_shift)-1
|
|
hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a)
|
|
call i_H_j(hole,key_in,N_int,hij_elec)
|
|
if(dabs(hij_elec) .ge. thresh)then
|
|
key_idx += 1
|
|
do k=1,N_int
|
|
keys_out(k,1,key_idx) = hole(k,1)
|
|
keys_out(k,2,key_idx) = hole(k,2)
|
|
enddo
|
|
hij_tab(key_idx) = hij_elec
|
|
if (key_idx > ishft(size_max,-5)) then
|
|
if ($omp_test_lock) then
|
|
$keys_work
|
|
$omp_unset_lock
|
|
key_idx = 0
|
|
endif
|
|
endif
|
|
if (key_idx == size_max) then
|
|
$omp_set_lock
|
|
$keys_work
|
|
$omp_unset_lock
|
|
key_idx = 0
|
|
endif
|
|
endif
|
|
enddo ! ii
|
|
$omp_enddo
|
|
enddo ! ispin
|
|
$omp_set_lock
|
|
$keys_work
|
|
$omp_unset_lock
|
|
deallocate (keys_out,hij_tab,ia_ja_pairs)
|
|
$omp_end_parallel
|
|
$omp_destroy_lock
|
|
$finalization
|
|
|
|
end
|
|
|