LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-12-23 04:43:50 +01:00
Code Issues Releases Wiki Activity

Accelerated get_excitation_degree_vector

Browse Source
This commit is contained in:
Anthony Scemama 2015-07-29 15:35:01 +02:00
parent c042e5af0c
commit 7ef8ee171d
2 changed files with 118 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
plugins/MRCC_Utils_new/mrcc_amplitudes.irp.f
View File

@ -48,13 +48,16 @@ subroutine get_excitation_operators_for_one_ref(det_ref,i_state,ndetnonref,N_con
N_connect_ref = 0 N_connect_ref = 0
do i = 1, ndetnonref do i = 1, ndetnonref
call i_H_j_phase_out(det_ref,psi_non_ref(1,1,i),N_int,hij,phase,exc,degree) call i_H_j_phase_out(det_ref,psi_non_ref(1,1,i),N_int,hij,phase,exc,degree)
! if(dabs(hij).le.mo_integrals_threshold)cycle if (dabs(hij) <= mo_integrals_threshold) then
cycle
endif
N_connect_ref +=1 N_connect_ref +=1
index_connected(N_connect_ref) = i index_connected(N_connect_ref) = i
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
amplitudes_phase_less(N_connect_ref) = hij * lambda_mrcc(i_state,i) !*phase amplitudes_phase_less(N_connect_ref) = hij * lambda_mrcc(i_state,i) !*phase
if (degree==2) then if (degree==2) then
excitation_operators(1,N_connect_ref) = h1 excitation_operators(1,N_connect_ref) = h1
excitation_operators(2,N_connect_ref) = p1 excitation_operators(2,N_connect_ref) = p1
excitation_operators(3,N_connect_ref) = h2 excitation_operators(3,N_connect_ref) = h2
@ -63,10 +66,12 @@ subroutine get_excitation_operators_for_one_ref(det_ref,i_state,ndetnonref,N_con
excitation_operators(5,N_connect_ref) = 2 excitation_operators(5,N_connect_ref) = 2
elseif(s1==s2.and.s1==2)then ! double beta elseif(s1==s2.and.s1==2)then ! double beta
excitation_operators(5,N_connect_ref) = -2 excitation_operators(5,N_connect_ref) = -2
else else ! double alpha/beta
excitation_operators(5,N_connect_ref)= 0 ! double alpha/beta excitation_operators(5,N_connect_ref) = 0
endif endif
else if(degree==1) then else if(degree==1) then
if(s1==1)then ! mono alpha if(s1==1)then ! mono alpha
excitation_operators(5,N_connect_ref) = 1 excitation_operators(5,N_connect_ref) = 1
excitation_operators(1,N_connect_ref) = h1 excitation_operators(1,N_connect_ref) = h1
@ -76,8 +81,11 @@ subroutine get_excitation_operators_for_one_ref(det_ref,i_state,ndetnonref,N_con
excitation_operators(3,N_connect_ref) = h1 excitation_operators(3,N_connect_ref) = h1
excitation_operators(4,N_connect_ref) = p1 excitation_operators(4,N_connect_ref) = p1
endif endif
else else
N_connect_ref-=1 N_connect_ref-=1
endif endif
enddo enddo

34
src/Determinants/slater_rules.irp.f
View File

@ -960,7 +960,7 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx)
integer, intent(out) :: degree(sze) integer, intent(out) :: degree(sze)
integer, intent(out) :: idx(0:sze) integer, intent(out) :: idx(0:sze)
integer :: i,l integer :: i,l,d
ASSERT (Nint > 0) ASSERT (Nint > 0)
ASSERT (sze > 0) ASSERT (sze > 0)
@ -970,9 +970,12 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx)
!DIR$ LOOP COUNT (1000) !DIR$ LOOP COUNT (1000)
do i=1,sze do i=1,sze
degree(l) = ishft(popcnt(xor( key1(1,1,i), key2(1,1))) + & d = ishft(popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2))),-1) popcnt(xor( key1(1,2,i), key2(1,2))),-1)
if (degree(l) < 3) then if (d > 2) then
cycle
else
degree(l) = d
idx(l) = i idx(l) = i
l = l+1 l = l+1
endif endif
@ -982,11 +985,14 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx)
!DIR$ LOOP COUNT (1000) !DIR$ LOOP COUNT (1000)
do i=1,sze do i=1,sze
degree(l) = ishft(popcnt(xor( key1(1,1,i), key2(1,1))) + & d = ishft(popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2))) + & popcnt(xor( key1(1,2,i), key2(1,2))) + &
popcnt(xor( key1(2,1,i), key2(2,1))) + & popcnt(xor( key1(2,1,i), key2(2,1))) + &
popcnt(xor( key1(2,2,i), key2(2,2))),-1) popcnt(xor( key1(2,2,i), key2(2,2))),-1)
if (degree(l) < 3) then if (d > 2) then
cycle
else
degree(l) = d
idx(l) = i idx(l) = i
l = l+1 l = l+1
endif endif
@ -996,13 +1002,16 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx)
!DIR$ LOOP COUNT (1000) !DIR$ LOOP COUNT (1000)
do i=1,sze do i=1,sze
degree(l) = ishft( popcnt(xor( key1(1,1,i), key2(1,1))) + & d = ishft( popcnt(xor( key1(1,1,i), key2(1,1))) + &
popcnt(xor( key1(1,2,i), key2(1,2))) + & popcnt(xor( key1(1,2,i), key2(1,2))) + &
popcnt(xor( key1(2,1,i), key2(2,1))) + & popcnt(xor( key1(2,1,i), key2(2,1))) + &
popcnt(xor( key1(2,2,i), key2(2,2))) + & popcnt(xor( key1(2,2,i), key2(2,2))) + &
popcnt(xor( key1(3,1,i), key2(3,1))) + & popcnt(xor( key1(3,1,i), key2(3,1))) + &
popcnt(xor( key1(3,2,i), key2(3,2))),-1) popcnt(xor( key1(3,2,i), key2(3,2))),-1)
if (degree(l) < 3) then if (d > 2) then
cycle
else
degree(l) = d
idx(l) = i idx(l) = i
l = l+1 l = l+1
endif endif
@ -1012,14 +1021,17 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx)
!DIR$ LOOP COUNT (1000) !DIR$ LOOP COUNT (1000)
do i=1,sze do i=1,sze
degree(l) = 0 d = 0
!DEC$ LOOP COUNT MIN(4) !DEC$ LOOP COUNT MIN(4)
do l=1,Nint do l=1,Nint
degree(l) = degree(l)+ popcnt(xor( key1(l,1,i), key2(l,1))) +& d = d + popcnt(xor( key1(l,1,i), key2(l,1))) +&
popcnt(xor( key1(l,2,i), key2(l,2))) popcnt(xor( key1(l,2,i), key2(l,2)))
enddo enddo
degree(l) = ishft(degree(l),-1) d = ishft(d,-1)
if (degree(l) < 3) then if (d > 2) then
cycle
else
degree(l) = d
idx(l) = i idx(l) = i
l = l+1 l = l+1
endif endif