PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-06-26 15:12:19 +02:00
Code Releases Activity

Guarded shiftr with IRP_IF

Browse Source
This commit is contained in:
Anthony Scemama 2021-03-20 18:20:58 +01:00
parent e2565bab76
commit ad6419f3af
24 changed files with 527 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
src/ao_one_e_ints/pot_ao_ints.irp.f
View File

@ -568,9 +568,17 @@ double precision function V_r(n,alpha)
integer :: n
include 'utils/constants.include.F'
if(iand(n,1).eq.1)then
IRP_IF WITHOUT_SHIFTRL
V_r = 0.5d0 * fact(ishft(n,-1)) / (alpha ** (ishft(n,-1) + 1))
IRP_ELSE
V_r = 0.5d0 * fact(shiftr(n,1)) / (alpha ** (shiftr(n,1) + 1))
IRP_ENDIF
else
IRP_IF WITHOUT_SHIFTRL
V_r = sqpi * fact(n) / fact(ishft(n,-1)) * (0.5d0/sqrt(alpha)) ** (n+1)
IRP_ELSE
V_r = sqpi * fact(n) / fact(shiftr(n,1)) * (0.5d0/sqrt(alpha)) ** (n+1)
IRP_ENDIF
endif
end
@ -585,7 +593,11 @@ double precision function V_phi(n,m)
integer :: n,m, i
double precision :: prod, Wallis
prod = 1.d0
IRP_IF WITHOUT_SHIFTRL
do i = 0,ishft(n,-1)-1
IRP_ELSE
do i = 0,shiftr(n,1)-1
IRP_ENDIF
prod = prod/ (1.d0 + dfloat(m+1)/dfloat(n-i-i-1))
enddo
V_phi = 4.d0 * prod * Wallis(m)
@ -604,7 +616,11 @@ double precision function V_theta(n,m)
include 'utils/constants.include.F'
V_theta = 0.d0
prod = 1.d0
IRP_IF WITHOUT_SHIFTRL
do i = 0,ishft(n,-1)-1
IRP_ELSE
do i = 0,shiftr(n,1)-1
IRP_ENDIF
prod = prod / (1.d0 + dfloat(m+1)/dfloat(n-i-i-1))
enddo
V_theta = (prod+prod) * Wallis(m)
@ -622,10 +638,18 @@ double precision function Wallis(n)
integer :: n,p
include 'utils/constants.include.F'
if(iand(n,1).eq.0)then
IRP_IF WITHOUT_SHIFTRL
Wallis = fact(ishft(n,-1))
IRP_ELSE
Wallis = fact(shiftr(n,1))
IRP_ENDIF
Wallis = pi * fact(n) / (dble(ibset(0_8,n)) * (Wallis+Wallis)*Wallis)
else
IRP_IF WITHOUT_SHIFTRL
p = ishft(n,-1)
IRP_ELSE
p = shiftr(n,1)
IRP_ENDIF
Wallis = fact(p)
Wallis = dble(ibset(0_8,p+p)) * Wallis*Wallis / fact(p+p+1)
endif

24
src/ao_two_e_ints/map_integrals.irp.f
View File

@ -28,13 +28,25 @@ subroutine two_e_integrals_index(i,j,k,l,i1)
integer(key_kind) :: p,q,r,s,i2
p = min(i,k)
r = max(i,k)
IRP_IF WITHOUT_SHIFTRL
p = p+ishft(r*r-r,-1)
IRP_ELSE
p = p+shiftr(r*r-r,1)
IRP_ENDIF
q = min(j,l)
s = max(j,l)
IRP_IF WITHOUT_SHIFTRL
q = q+ishft(s*s-s,-1)
IRP_ELSE
q = q+shiftr(s*s-s,1)
IRP_ENDIF
i1 = min(p,q)
i2 = max(p,q)
IRP_IF WITHOUT_SHIFTRL
i1 = i1+ishft(i2*i2-i2,-1)
IRP_ELSE
i1 = i1+shiftr(i2*i2-i2,1)
IRP_ENDIF
end
@ -59,10 +71,22 @@ subroutine two_e_integrals_index_reverse(i,j,k,l,i1)
i = 0
i2 = ceiling(0.5d0*(dsqrt(dble(shiftl(i1,3)+1))-1.d0))
l(1) = ceiling(0.5d0*(dsqrt(dble(shiftl(i2,3)+1))-1.d0))
IRP_IF WITHOUT_SHIFTRL
i3 = i1 - ishft(i2*i2-i2,-1)
IRP_ELSE
i3 = i1 - shiftr(i2*i2-i2,1)
IRP_ENDIF
k(1) = ceiling(0.5d0*(dsqrt(dble(shiftl(i3,3)+1))-1.d0))
IRP_IF WITHOUT_SHIFTRL
j(1) = int(i2 - ishft(l(1)*l(1)-l(1),-1),4)
IRP_ELSE
j(1) = int(i2 - shiftr(l(1)*l(1)-l(1),1),4)
IRP_ENDIF
IRP_IF WITHOUT_SHIFTRL
i(1) = int(i3 - ishft(k(1)*k(1)-k(1),-1),4)
IRP_ELSE
i(1) = int(i3 - shiftr(k(1)*k(1)-k(1),1),4)
IRP_ENDIF
!ijkl
i(2) = i(1) !ilkj

12
src/ao_two_e_ints/two_e_integrals.irp.f
View File

@ -655,7 +655,11 @@ subroutine integrale_new(I_f,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z,p,q
double precision :: I_f, pq_inv, p10_1, p10_2, p01_1, p01_2,rho,pq_inv_2
integer :: ix,iy,iz, jx,jy,jz, sx,sy,sz
IRP_IF WITHOUT_SHIFTRL
j = ishft(n_pt,-1)
IRP_ELSE
j = shiftr(n_pt,1)
IRP_ENDIF
ASSERT (n_pt > 1)
pq_inv = 0.5d0/(p+q)
pq_inv_2 = pq_inv + pq_inv
@ -1178,9 +1182,17 @@ subroutine compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value)
n_integrals = 0
IRP_IF WITHOUT_SHIFTRL
j1 = j+ishft(l*l-l,-1)
IRP_ELSE
j1 = j+shiftr(l*l-l,1)
IRP_ENDIF
do k = 1, ao_num ! r1
IRP_IF WITHOUT_SHIFTRL
i1 = ishft(k*k-k,-1)
IRP_ELSE
i1 = shiftr(k*k-k,1)
IRP_ENDIF
if (i1 > j1) then
exit
endif

4
src/bitmask/bitmask_cas_routines.irp.f
View File

@ -337,7 +337,11 @@ logical function is_i_in_virtual(i)
integer :: accu
is_i_in_virtual = .False.
key= 0_bit_kind
IRP_IF WITHOUT_SHIFTRL
k = ishft(i-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i-1,bit_kind_shift)+1
IRP_ENDIF
j = i-shiftl(k-1,bit_kind_shift)-1
key(k) = ibset(key(k),j)
accu = 0

4
src/bitmask/bitmasks_routines.irp.f
View File

@ -85,7 +85,11 @@ subroutine list_to_bitstring( string, list, n_elements, Nint)
string = 0_bit_kind
do i=1,n_elements
IRP_IF WITHOUT_SHIFTRL
iint = ishft(list(i)-1,-bit_kind_shift) + 1
IRP_ELSE
iint = shiftr(list(i)-1,bit_kind_shift) + 1
IRP_ENDIF
ipos = list(i)-shiftl((iint-1),bit_kind_shift)-1
string(iint) = ibset( string(iint), ipos )
enddo

8
src/bitmask/find_hole.irp.f
View File

@ -10,7 +10,11 @@ logical function is_the_hole_in_det(key_in,ispin,i_hole)
do i = 1, N_int
itest(i) = 0_bit_kind
enddo
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_hole-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_hole-1,bit_kind_shift)+1
IRP_ENDIF
j = i_hole-shiftl(k-1,bit_kind_shift)-1
itest(k) = ibset(itest(k),j)
j = 0
@ -38,7 +42,11 @@ logical function is_the_particl_in_det(key_in,ispin,i_particl)
do i = 1, N_int
itest(i) = 0_bit_kind
enddo
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_particl-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_particl-1,bit_kind_shift)+1
IRP_ENDIF
j = i_particl-shiftl(k-1,bit_kind_shift)-1
itest(k) = ibset(itest(k),j)
j = 0

12
src/bitmask/modify_bitmasks.irp.f
View File

@ -21,7 +21,11 @@ subroutine modify_bitmasks_for_hole(i_hole)
enddo
enddo
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_hole-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_hole-1,bit_kind_shift)+1
IRP_ENDIF
j = i_hole-shiftl(k-1,bit_kind_shift)-1
do l = 1, 3
i = index_holes_bitmask(l)
@ -42,7 +46,11 @@ subroutine modify_bitmasks_for_hole_in_out(i_hole)
! the electrons occupying i_hole
END_DOC
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_hole-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_hole-1,bit_kind_shift)+1
IRP_ENDIF
j = i_hole-shiftl(k-1,bit_kind_shift)-1
do l = 1, 3
i = index_holes_bitmask(l)
@ -73,7 +81,11 @@ subroutine modify_bitmasks_for_particl(i_part)
enddo
enddo
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_part-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_part-1,bit_kind_shift)+1
IRP_ENDIF
j = i_part-shiftl(k-1,bit_kind_shift)-1
do l = 1, 3
i = index_particl_bitmask(l)

4
src/cipsi/pt2_stoch_routines.irp.f
View File

@ -633,7 +633,11 @@ integer function pt2_find_sample_lr(v, w, l_in, r_in)
r=r_in
do while(r-l > 1)
IRP_IF WITHOUT_SHIFTRL
i = ishft(r+l,-1)
IRP_ELSE
i = shiftr(r+l,1)
IRP_ENDIF
if(w(i) < v) then
l = i
else

20
src/cipsi/selection.irp.f
View File

@ -77,6 +77,25 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2, Nint)
integer :: p1_int, p2_int
integer :: h1_bit, h2_bit
integer :: p1_bit, p2_bit
IRP_IF WITHOUT_SHIFTRL
h1_int = ishft(h1-1,-bit_kind_shift)+1
h1_bit = h1 - ishft (h1_int-1,bit_kind_shift)-1
h2_int = ishft(h2-1,-bit_kind_shift)+1
h2_bit = h2 - ishft(h2_int-1,bit_kind_shift)-1
p1_int = ishft(p1-1,-bit_kind_shift)+1
p1_bit = p1 - ishft(p1_int-1,bit_kind_shift)-1
p2_int = ishft(p2-1,-bit_kind_shift)+1
p2_bit = p2 - ishft(p2_int-1,bit_kind_shift)-1
! Put the phasemask bits at position 0, and add them all
h1_bit = int(ishft(phasemask(h1_int,s1),-h1_bit))
p1_bit = int(ishft(phasemask(p1_int,s1),-p1_bit))
h2_bit = int(ishft(phasemask(h2_int,s2),-h2_bit))
p2_bit = int(ishft(phasemask(p2_int,s2),-p2_bit))
IRP_ELSE
h1_int = shiftr(h1-1,bit_kind_shift)+1
h1_bit = h1 - shiftl(h1_int-1,bit_kind_shift)-1
@ -95,6 +114,7 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2, Nint)
p1_bit = int(shiftr(phasemask(p1_int,s1),p1_bit))
h2_bit = int(shiftr(phasemask(h2_int,s2),h2_bit))
p2_bit = int(shiftr(phasemask(p2_int,s2),p2_bit))
IRP_ENDIF
np = h1_bit + p1_bit + h2_bit + p2_bit

24
src/csf/configurations.irp.f
View File

@ -135,7 +135,7 @@ IRP_ENDIF
t = ior(v,v-1)
tt = t+1
IRP_IF WITHOUT_TRAILZ
v = ior(tt, shiftr( and(not(t),tt) - 1, popcnt(ieor(v,v-1))) )
v = ior(tt, ishft( and(not(t),tt) - 1, -popcnt(ieor(v,v-1))) )
IRP_ELSE
v = ior(tt, shiftr( and(not(t),tt) - 1, trailz(v)+1) )
IRP_ENDIF
@ -178,7 +178,7 @@ IRP_ENDIF
t = ior(v,v-1)
tt = t+1
IRP_IF WITHOUT_TRAILZ
v = ior(tt, shiftr( and(not(t),tt) - 1, popcnt(ieor(v,v-1))) )
v = ior(tt, ishft( and(not(t),tt) - 1, -popcnt(ieor(v,v-1))) )
IRP_ELSE
v = ior(tt, shiftr( and(not(t),tt) - 1, trailz(v)+1) )
IRP_ENDIF
@ -293,7 +293,7 @@ IRP_ENDIF
t = ior(v,v-1)
tt = t+1
IRP_IF WITHOUT_TRAILZ
v = ior(tt, shiftr( and(not(t),tt) - 1, popcnt(ieor(v,v-1))) )
v = ior(tt, ishft( and(not(t),tt) - 1, -popcnt(ieor(v,v-1))) )
IRP_ELSE
v = ior(tt, shiftr( and(not(t),tt) - 1, trailz(v)+1) )
IRP_ENDIF
@ -336,7 +336,7 @@ IRP_ENDIF
t = ior(v,v-1)
tt = t+1
IRP_IF WITHOUT_TRAILZ
v = ior(tt, shiftr( and(not(t),tt) - 1, popcnt(ieor(v,v-1))) )
v = ior(tt, ishft( and(not(t),tt) - 1, -popcnt(ieor(v,v-1))) )
IRP_ELSE
v = ior(tt, shiftr( and(not(t),tt) - 1, trailz(v)+1) )
IRP_ENDIF
@ -563,7 +563,11 @@ BEGIN_PROVIDER [ integer, det_to_configuration, (N_det) ]
! Binary search
l = 0
r = N_configuration+1
IRP_IF WITHOUT_SHIFTRL
j = ishft(r-l,-1)
IRP_ELSE
j = shiftr(r-l,1)
IRP_ENDIF
do while (j>=1)
j = j+l
if (bit_tmp(j) == key) then
@ -588,7 +592,11 @@ BEGIN_PROVIDER [ integer, det_to_configuration, (N_det) ]
else
l = j
endif
IRP_IF WITHOUT_SHIFTRL
j = ishft(r-l,-1)
IRP_ELSE
j = shiftr(r-l,1)
IRP_ENDIF
enddo
enddo
@ -815,7 +823,11 @@ subroutine binary_search_cfg(cfgInp,addcfg,bit_tmp)
! Binary search
l = 0
r = N_configuration+1
IRP_IF WITHOUT_SHIFTRL
j = ishft(r-l,-1)
IRP_ELSE
j = shiftr(r-l,1)
IRP_ENDIF
do while (j>=1)
j = j+l
if (bit_tmp(j) == key) then
@ -845,7 +857,11 @@ subroutine binary_search_cfg(cfgInp,addcfg,bit_tmp)
else
l = j
endif
IRP_IF WITHOUT_SHIFTRL
j = ishft(r-l,-1)
IRP_ELSE
j = shiftr(r-l,1)
IRP_ENDIF
enddo
addcfg = -1

5
src/csf/connected_to_ref.irp.f
View File

@ -11,8 +11,13 @@ integer*8 function configuration_search_key(cfg,Nint)
integer :: i, n_open_shells
integer*8 :: mask
IRP_IF WITHOUT_SHIFTRL
i = ishft(elec_alpha_num, -bit_kind_shift)+1
configuration_search_key = int(ishft(ior(cfg(i,1),cfg(i,2)),-1)+sum(cfg),8)
IRP_ELSE
i = shiftr(elec_alpha_num, bit_kind_shift)+1
configuration_search_key = int(shiftr(ior(cfg(i,1),cfg(i,2)),1)+sum(cfg),8)
IRP_ENDIF
mask = X'00FFFFFFFFFFFFFF'
configuration_search_key = iand(mask,configuration_search_key)

16
src/csf/create_excitations.irp.f
View File

@ -19,7 +19,11 @@ subroutine do_single_excitation_cfg(key_in,key_out,i_hole,i_particle,ok)
key_out(:,:) = key_in(:,:)
! hole
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_hole-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_hole-1,bit_kind_shift)+1
IRP_ENDIF
j = i_hole-shiftl(k-1,bit_kind_shift)-1
mask = ibset(0_bit_kind,j)
@ -46,7 +50,11 @@ subroutine do_single_excitation_cfg(key_in,key_out,i_hole,i_particle,ok)
! particle
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_particle-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_particle-1,bit_kind_shift)+1
IRP_ENDIF
j = i_particle-shiftl(k-1,bit_kind_shift)-1
mask = ibset(0_bit_kind,j)
@ -109,7 +117,11 @@ subroutine do_single_excitation_cfg_with_type(key_in,key_out,i_hole,i_particle,e
key_out(:,:) = key_in(:,:)
! hole
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_hole-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_hole-1,bit_kind_shift)+1
IRP_ENDIF
j = i_hole-shiftl(k-1,bit_kind_shift)-1
mask = ibset(0_bit_kind,j)
@ -138,7 +150,11 @@ subroutine do_single_excitation_cfg_with_type(key_in,key_out,i_hole,i_particle,e
! particle
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_particle-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_particle-1,bit_kind_shift)+1
IRP_ENDIF
j = i_particle-shiftl(k-1,bit_kind_shift)-1
mask = ibset(0_bit_kind,j)

8
src/davidson/u0_h_u0.irp.f
View File

@ -328,7 +328,11 @@ compute_singles=.True.
! right_max = -1_8
! right = singles_alpha_csc_idx(krow+1)
! do while (right-left>0_8)
!IRP_IF WITHOUT_SHIFTRL
! k8 = ishft(right+left,-1)
!IRP_ELSE
! k8 = shiftr(right+left,1)
! if (singles_alpha_csc(k8) > lrow) then
! right = k8
! else if (singles_alpha_csc(k8) < lrow) then
@ -356,7 +360,11 @@ compute_singles=.True.
! left = last_found
! right = right_max
! do while (right-left>0_8)
!IRP_IF WITHOUT_SHIFTRL
! k8 = ishft(right+left,-1)
!IRP_ELSE
! k8 = shiftr(right+left,1)
! if (singles_alpha_csc(k8) > lrow) then
! right = k8
! else if (singles_alpha_csc(k8) < lrow) then

8
src/davidson/u0_hs2_u0.irp.f
View File

@ -367,7 +367,11 @@ compute_singles=.True.
! right_max = -1_8
! right = singles_alpha_csc_idx(krow+1)
! do while (right-left>0_8)
!IRP_IF WITHOUT_SHIFTRL
! k8 = ishft(right+left,-1)
!IRP_ELSE
! k8 = shiftr(right+left,1)
!IRP_ENDIF
! if (singles_alpha_csc(k8) > lrow) then
! right = k8
! else if (singles_alpha_csc(k8) < lrow) then
@ -395,7 +399,11 @@ compute_singles=.True.
! left = last_found
! right = right_max
! do while (right-left>0_8)
!IRP_IF WITHOUT_SHIFTRL
! k8 = ishft(right+left,-1)
!IRP_ELSE
! k8 = shiftr(right+left,1)
!IRP_ENDIF
! if (singles_alpha_csc(k8) > lrow) then
! right = k8
! else if (singles_alpha_csc(k8) < lrow) then

13
src/determinants/connected_to_ref.irp.f
View File

@ -7,8 +7,13 @@ integer*8 function det_search_key(det,Nint)
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: det(Nint,2)
integer :: i
IRP_IF WITHOUT_SHIFTRL
i = ishft(elec_alpha_num,- bit_kind_shift)+1
det_search_key = int(ishft(ior(det(i,1),det(i,2)),-1)+sum(det),8)
IRP_ELSE
i = shiftr(elec_alpha_num, bit_kind_shift)+1
det_search_key = int(shiftr(ior(det(i,1),det(i,2)),1)+sum(det),8)
IRP_ENDIF
end
@ -53,7 +58,11 @@ integer function get_index_in_psi_det_sorted_bit(key,Nint)
!DIR$ FORCEINLINE
det_search = det_search_key(psi_det_sorted_bit(1,1,1),Nint)
IRP_IF WITHOUT_SHIFTRL
istep = ishft(iend-ibegin,-1)
IRP_ELSE
istep = shiftr(iend-ibegin,1)
IRP_ENDIF
i=ibegin+istep
do while (istep > 0)
!DIR$ FORCEINLINE
@ -65,7 +74,11 @@ integer function get_index_in_psi_det_sorted_bit(key,Nint)
else
ibegin = i
endif
IRP_IF WITHOUT_SHIFTRL
istep = ishft(iend-ibegin,-1)
IRP_ELSE
istep = shiftr(iend-ibegin,1)
IRP_ENDIF
i = ibegin + istep
end do

12
src/determinants/create_excitations.irp.f
View File

@ -18,7 +18,11 @@ subroutine do_single_excitation(key_in,i_hole,i_particle,ispin,i_ok)
ASSERT (i_particle <= mo_num)
i_ok = 1
! hole
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_hole-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_hole-1,bit_kind_shift)+1
IRP_ENDIF
j = i_hole-shiftl(k-1,bit_kind_shift)-1
mask = ibset(0_bit_kind,j)
! check whether position j is occupied
@ -30,7 +34,11 @@ subroutine do_single_excitation(key_in,i_hole,i_particle,ispin,i_ok)
end if
! particle
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_particle-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_particle-1,bit_kind_shift)+1
IRP_ENDIF
j = i_particle-shiftl(k-1,bit_kind_shift)-1
mask = ibset(0_bit_kind,j)
if (iand(key_in(k,ispin),mask) == 0_bit_kind) then
@ -92,7 +100,11 @@ logical function is_spin_flip_possible(key_in,i_flip,ispin)
integer(bit_kind) :: key_tmp(N_int,2)
is_spin_flip_possible = .False.
key_tmp = 0_bit_kind
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_flip-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_flip-1,bit_kind_shift)+1
IRP_ENDIF
j = i_flip-shiftl(k-1,bit_kind_shift)-1
key_tmp(k,1) = ibset(key_tmp(k,1),j)
integer :: other_spin(2)

40
src/determinants/determinants.irp.f
View File

@ -800,23 +800,39 @@ subroutine apply_excitation(det, exc, res, ok, Nint)
res = det
IRP_IF WITHOUT_SHIFTRL
ii = ishft(h1-1,-bit_kind_shift) + 1
IRP_ELSE
ii = shiftr(h1-1,bit_kind_shift) + 1
IRP_ENDIF
pos = h1-1-shiftl(ii-1,bit_kind_shift)
if(iand(det(ii, s1), ibset(0_bit_kind, pos)) == 0_8) return
res(ii, s1) = ibclr(res(ii, s1), pos)
IRP_IF WITHOUT_SHIFTRL
ii = ishft(p1-1,-bit_kind_shift) + 1
IRP_ELSE
ii = shiftr(p1-1,bit_kind_shift) + 1
IRP_ENDIF
pos = p1-1-shiftl(ii-1,bit_kind_shift)
if(iand(det(ii, s1),shiftl(1_bit_kind, pos)) /= 0_8) return
res(ii, s1) = ibset(res(ii, s1), pos)
if(degree == 2) then
IRP_IF WITHOUT_SHIFTRL
ii = ishft(h2-1,-bit_kind_shift) + 1
IRP_ELSE
ii = shiftr(h2-1,bit_kind_shift) + 1
IRP_ENDIF
pos = h2-1-shiftl(ii-1,bit_kind_shift)
if(iand(det(ii, s2), shiftl(1_bit_kind, pos)) == 0_8) return
res(ii, s2) = ibclr(res(ii, s2), pos)
IRP_IF WITHOUT_SHIFTRL
ii = ishft(p2-1,-bit_kind_shift) + 1
IRP_ELSE
ii = shiftr(p2-1,bit_kind_shift) + 1
IRP_ENDIF
pos = p2-1-shiftl(ii-1,bit_kind_shift)
if(iand(det(ii, s2), shiftl(1_bit_kind, pos)) /= 0_8) return
res(ii, s2) = ibset(res(ii, s2), pos)
@ -839,13 +855,21 @@ subroutine apply_particles(det, s1, p1, s2, p2, res, ok, Nint)
res = det
if(p1 /= 0) then
IRP_IF WITHOUT_SHIFTRL
ii =ishft(p1-1,-bit_kind_shift) + 1
IRP_ELSE
ii =shiftr(p1-1,bit_kind_shift) + 1
IRP_ENDIF
pos = p1-1-shiftl(ii-1,bit_kind_shift)
if(iand(det(ii, s1), shiftl(1_bit_kind, pos)) /= 0_8) return
res(ii, s1) = ibset(res(ii, s1), pos)
end if
IRP_IF WITHOUT_SHIFTRL
ii = ishft(p2-1,-bit_kind_shift) + 1
IRP_ELSE
ii = shiftr(p2-1,bit_kind_shift) + 1
IRP_ENDIF
pos = p2-1-shiftl(ii-1,bit_kind_shift)
if(iand(det(ii, s2), shiftl(1_bit_kind, pos)) /= 0_8) return
res(ii, s2) = ibset(res(ii, s2), pos)
@ -868,13 +892,21 @@ subroutine apply_holes(det, s1, h1, s2, h2, res, ok, Nint)
res = det
if(h1 /= 0) then
IRP_IF WITHOUT_SHIFTRL
ii = ishft(h1-1,-bit_kind_shift) + 1
IRP_ELSE
ii = shiftr(h1-1,bit_kind_shift) + 1
IRP_ENDIF
pos = h1-1-shiftl(ii-1,bit_kind_shift)
if(iand(det(ii, s1), shiftl(1_bit_kind, pos)) == 0_8) return
res(ii, s1) = ibclr(res(ii, s1), pos)
end if
IRP_IF WITHOUT_SHIFTRL
ii = ishft(h2-1,-bit_kind_shift) + 1
IRP_ELSE
ii = shiftr(h2-1,bit_kind_shift) + 1
IRP_ENDIF
pos = h2-1-shiftl(ii-1,bit_kind_shift)
if(iand(det(ii, s2), shiftl(1_bit_kind, pos)) == 0_8) return
res(ii, s2) = ibclr(res(ii, s2), pos)
@ -895,7 +927,11 @@ subroutine apply_particle(det, s1, p1, res, ok, Nint)
ok = .false.
res = det
IRP_IF WITHOUT_SHIFTRL
ii = ishft(p1-1,-bit_kind_shift) + 1
IRP_ELSE
ii = shiftr(p1-1,bit_kind_shift) + 1
IRP_ENDIF
pos = p1-1-shiftl(ii-1,bit_kind_shift)
if(iand(det(ii, s1), shiftl(1_bit_kind, pos)) /= 0_8) return
res(ii, s1) = ibset(res(ii, s1), pos)
@ -917,7 +953,11 @@ subroutine apply_hole(det, s1, h1, res, ok, Nint)
ok = .false.
res = det
IRP_IF WITHOUT_SHIFTRL
ii = ishft(h1-1,-bit_kind_shift) + 1
IRP_ELSE
ii = shiftr(h1-1,bit_kind_shift) + 1
IRP_ENDIF
pos = h1-1-shiftl(ii-1,bit_kind_shift)
if(iand(det(ii, s1), shiftl(1_bit_kind, pos)) == 0_8) return
res(ii, s1) = ibclr(res(ii, s1), pos)

53
src/determinants/h_apply.template.f
View File

@ -22,12 +22,23 @@ subroutine $subroutine_diexc(key_in, key_prev, hole_1,particl_1, hole_2, particl
do sp=1,2
do ni=1,N_int
do i=1,bit_kind_size
IRP_IF WITHOUT_SHIFTRL
if(iand(1_bit_kind,ishft(key_in(ni, sp), (1-i))) == 0) then
cycle
end if
IRP_ELSE
if(iand(1_bit_kind,shiftr(key_in(ni, sp), (i-1))) == 0) then
cycle
end if
IRP_ENDIF
mi = (ni-1)*bit_kind_size+i
IRP_IF WITHOUT_SHIFTRL
status(mi, sp) = int(iand(1_bit_kind,ishft(hole_1(ni,sp),(1-i))),4)
status(mi, sp) = status(mi, sp) + 2*int(iand(1_bit_kind,ishft(hole_2(ni,sp),(1-i))),4)
IRP_ELSE
status(mi, sp) = int(iand(1_bit_kind,shiftr(hole_1(ni,sp),(i-1))),4)
status(mi, sp) = status(mi, sp) + 2*int(iand(1_bit_kind,shiftr(hole_2(ni,sp),(i-1))),4)
IRP_ENDIF
if(status(mi, sp) /= 0 .and. mi > highest) then
highest = mi
end if
@ -88,16 +99,26 @@ subroutine $subroutine_diexcP(key_in, fs1, fh1, particl_1, fs2, fh2, particl_2,
p2_mask(k,1) = 0_bit_kind
p2_mask(k,2) = 0_bit_kind
enddo
IRP_IF WITHOUT_SHIFTRL
p1_mask(ishft(fh1-1,-bit_kind_shift) + 1, fs1) = shiftl(one,iand(fh1-1,bit_kind_size-1))
p2_mask(ishft(fh2-1,-bit_kind_shift) + 1, fs2) = shiftl(one,iand(fh2-1,bit_kind_size-1))
IRP_ELSE
p1_mask(shiftr(fh1-1,bit_kind_shift) + 1, fs1) = shiftl(one,iand(fh1-1,bit_kind_size-1))
p2_mask(shiftr(fh2-1,bit_kind_shift) + 1, fs2) = shiftl(one,iand(fh2-1,bit_kind_size-1))
IRP_ENDIF
do k=1,N_int
key_mask(k,1) = key_in(k,1)
key_mask(k,2) = key_in(k,2)
enddo
IRP_IF WITHOUT_SHIFTRL
key_mask(ishft(fh1-1,-bit_kind_shift) + 1, fs1) -= shiftl(one,iand(fh1-1,bit_kind_size-1))
key_mask(ishft(fh2-1,-bit_kind_shift) + 1, fs2) -= shiftl(one,iand(fh2-1,bit_kind_size-1))
IRP_ELSE
key_mask(shiftr(fh1-1,bit_kind_shift) + 1, fs1) -= shiftl(one,iand(fh1-1,bit_kind_size-1))
key_mask(shiftr(fh2-1,bit_kind_shift) + 1, fs2) -= shiftl(one,iand(fh2-1,bit_kind_size-1))
IRP_ENDIF
call $subroutine_diexcOrg(key_in, key_mask, p1_mask, particl_1, p2_mask, particl_2, fock_diag_tmp, i_generator, iproc_in $parameters )
@ -219,10 +240,18 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
ASSERT (j_a > 0)
ASSERT (j_a <= mo_num)
hole = key_in
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_a-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_a-1,bit_kind_shift)+1
IRP_ENDIF
j = i_a-shiftl(k-1,bit_kind_shift)-1
hole(k,ispin) = ibclr(hole(k,ispin),j)
IRP_IF WITHOUT_SHIFTRL
k_a = ishft(j_a-1,-bit_kind_shift)+1
IRP_ELSE
k_a = shiftr(j_a-1,bit_kind_shift)+1
IRP_ENDIF
l_a = j_a-shiftl(k_a-1,bit_kind_shift)-1
hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a)
@ -269,11 +298,19 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
hole = hole_save
i_b = ib_jb_pairs(1,kk)
j_b = ib_jb_pairs(2,kk)
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_b-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_b-1,bit_kind_shift)+1
IRP_ENDIF
j = i_b-shiftl(k-1,bit_kind_shift)-1
hole(k,other_spin) = ibclr(hole(k,other_spin),j)
key = hole
IRP_IF WITHOUT_SHIFTRL
k = ishft(j_b-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(j_b-1,bit_kind_shift)+1
IRP_ENDIF
l = j_b-shiftl(k-1,bit_kind_shift)-1
key(k,other_spin) = ibset(key(k,other_spin),l)
$filter2h2p_double
@ -325,11 +362,19 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
hole = hole_save
i_b = ib_jb_pairs(1,kk)
j_b = ib_jb_pairs(2,kk)
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_b-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_b-1,bit_kind_shift)+1
IRP_ENDIF
j = i_b-shiftl(k-1,bit_kind_shift)-1
hole(k,ispin) = ibclr(hole(k,ispin),j)
key = hole
IRP_IF WITHOUT_SHIFTRL
k = ishft(j_b-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(j_b-1,bit_kind_shift)+1
IRP_ENDIF
l = j_b-shiftl(k-1,bit_kind_shift)-1
key(k,ispin) = ibset(key(k,ispin),l)
$filter2h2p_double
@ -477,11 +522,19 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato
i_a = ia_ja_pairs(1,ii,ispin)
j_a = ia_ja_pairs(2,ii,ispin)
hole = key_in
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_a-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(i_a-1,bit_kind_shift)+1
IRP_ENDIF
j = i_a-shiftl(k-1,bit_kind_shift)-1
$filterhole
hole(k,ispin) = ibclr(hole(k,ispin),j)
IRP_IF WITHOUT_SHIFTRL
k_a = ishft(j_a-1,-bit_kind_shift)+1
IRP_ELSE
k_a = shiftr(j_a-1,bit_kind_shift)+1
IRP_ENDIF
l_a = j_a-shiftl(k_a-1,bit_kind_shift)-1
$filterparticle
hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a)

160
src/determinants/slater_rules.irp.f
View File

@ -51,7 +51,11 @@ subroutine get_excitation_degree(key1,key2,degree,Nint)
end select
IRP_IF WITHOUT_SHIFTRL
degree = ishft(degree,-1)
IRP_ELSE
degree = shiftr(degree,1)
IRP_ENDIF
end
@ -247,8 +251,13 @@ IRP_ENDIF
ASSERT (low >= 0)
ASSERT (high > 0)
IRP_IF WITHOUT_SHIFTRL
k = ishft(high,-bit_kind_shift)+1
j = ishft(low,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(high,bit_kind_shift)+1
j = shiftr(low,bit_kind_shift)+1
IRP_ENDIF
m = iand(high,bit_kind_size-1)
n = iand(low,bit_kind_size-1)
@ -279,8 +288,13 @@ IRP_ENDIF
ASSERT (low > 0)
ASSERT (high > 0)
IRP_IF WITHOUT_SHIFTRL
k = ishft(high,-bit_kind_shift)+1
j = ishft(low,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(high,bit_kind_shift)+1
j = shiftr(low,bit_kind_shift)+1
IRP_ENDIF
m = iand(high,bit_kind_size-1)
n = iand(low,bit_kind_size-1)
@ -409,8 +423,13 @@ IRP_ENDIF
ASSERT (low >= 0)
ASSERT (high > 0)
IRP_IF WITHOUT_SHIFTRL
k = ishft(high,-bit_kind_shift)+1
j = ishft(low,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(high,bit_kind_shift)+1
j = shiftr(low,bit_kind_shift)+1
IRP_ENDIF
m = iand(high,bit_kind_size-1)
n = iand(low,bit_kind_size-1)
@ -1112,7 +1131,11 @@ subroutine get_excitation_degree_vector_single(key1,key2,degree,Nint,sze,idx)
if (d > 2) then
cycle
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1129,7 +1152,11 @@ subroutine get_excitation_degree_vector_single(key1,key2,degree,Nint,sze,idx)
if (d > 2) then
cycle
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1148,7 +1175,11 @@ subroutine get_excitation_degree_vector_single(key1,key2,degree,Nint,sze,idx)
if (d > 2) then
cycle
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1167,7 +1198,11 @@ subroutine get_excitation_degree_vector_single(key1,key2,degree,Nint,sze,idx)
if (d > 2) then
cycle
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1211,7 +1246,11 @@ subroutine get_excitation_degree_vector_single_or_exchange(key1,key2,degree,Nint
if (d > 4)cycle
if (d ==4)then
if(popcnt(xor(key_tmp(1,1),key_tmp(1,2))) == 0)then
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
else
@ -1219,7 +1258,11 @@ subroutine get_excitation_degree_vector_single_or_exchange(key1,key2,degree,Nint
endif
! pause
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1269,7 +1312,11 @@ subroutine get_excitation_degree_vector_double_alpha_beta(key1,key2,degree,Nint,
degree_alpha = popcnt(key_tmp(1,1))
degree_beta = popcnt(key_tmp(1,2))
if(degree_alpha .ge.3 .or. degree_beta .ge.3 )cycle !! no double excitations of same spin
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
enddo
@ -1289,7 +1336,11 @@ subroutine get_excitation_degree_vector_double_alpha_beta(key1,key2,degree,Nint,
degree_alpha = popcnt(key_tmp(1,1)) + popcnt(key_tmp(2,1))
degree_beta = popcnt(key_tmp(1,2)) + popcnt(key_tmp(2,2))
if(degree_alpha .ge.3 .or. degree_beta .ge.3 )cycle !! no double excitations of same spin
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
enddo
@ -1314,7 +1365,11 @@ subroutine get_excitation_degree_vector_double_alpha_beta(key1,key2,degree,Nint,
degree_alpha = popcnt(key_tmp(1,1)) + popcnt(key_tmp(2,1)) + popcnt(key_tmp(3,1))
degree_beta = popcnt(key_tmp(1,2)) + popcnt(key_tmp(2,2)) + popcnt(key_tmp(3,2))
if(degree_alpha .ge.3 .or. degree_beta .ge.3 )cycle !! no double excitations of same spin
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
enddo
@ -1336,7 +1391,11 @@ subroutine get_excitation_degree_vector_double_alpha_beta(key1,key2,degree,Nint,
degree_beta += popcnt(key_tmp(m,2))
enddo
if(degree_alpha .ge.3 .or. degree_beta .ge.3 )cycle !! no double excitations of same spin
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
enddo
@ -1391,19 +1450,30 @@ subroutine get_excitation_degree_vector_single_or_exchange_verbose(key1,key2,deg
if (d > 4)cycle
if (d ==4)then
if(exchange_1 .eq. 0 ) then
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
else
cycle
endif
! pause
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1423,11 +1493,19 @@ subroutine get_excitation_degree_vector_single_or_exchange_verbose(key1,key2,deg
if (d > 4)cycle
if (d ==4)then
if(exchange_1 .eq. 0 ) then
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
else
@ -1435,7 +1513,11 @@ subroutine get_excitation_degree_vector_single_or_exchange_verbose(key1,key2,deg
endif
! pause
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1460,11 +1542,19 @@ subroutine get_excitation_degree_vector_single_or_exchange_verbose(key1,key2,deg
if (d > 4)cycle
if (d ==4)then
if(exchange_1 .eq. 0 ) then
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
else
@ -1472,7 +1562,11 @@ subroutine get_excitation_degree_vector_single_or_exchange_verbose(key1,key2,deg
endif
! pause
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1495,18 +1589,30 @@ subroutine get_excitation_degree_vector_single_or_exchange_verbose(key1,key2,deg
if (d > 4)cycle
if (d ==4)then
if(exchange_1 .eq. 0 ) then
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
else
cycle
endif
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1543,7 +1649,11 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx)
if (d > 4) then
cycle
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1559,7 +1669,11 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx)
if (d > 4) then
cycle
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1577,7 +1691,11 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx)
if (d > 4) then
cycle
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1594,7 +1712,11 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx)
if (d > 4) then
cycle
else
IRP_IF WITHOUT_SHIFTRL
degree(l) = ishft(d,-1)
IRP_ELSE
degree(l) = shiftr(d,1)
IRP_ENDIF
idx(l) = i
l = l+1
endif
@ -1759,7 +1881,11 @@ subroutine a_operator(iorb,ispin,key,hjj,Nint,na,nb)
ASSERT (ispin < 3)
ASSERT (Nint > 0)
IRP_IF WITHOUT_SHIFTRL
k = ishft(iorb-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(iorb-1,bit_kind_shift)+1
IRP_ENDIF
ASSERT (k>0)
l = iorb - shiftl(k-1,bit_kind_shift)-1
key(k,ispin) = ibclr(key(k,ispin),l)
@ -1820,7 +1946,11 @@ subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb)
ASSERT (tmp(1) == elec_alpha_num)
ASSERT (tmp(2) == elec_beta_num)
IRP_IF WITHOUT_SHIFTRL
k = ishft(iorb-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(iorb-1,bit_kind_shift)+1
IRP_ENDIF
ASSERT (k >0)
l = iorb - shiftl(k-1,bit_kind_shift)-1
ASSERT (l >= 0)
@ -1911,7 +2041,11 @@ subroutine get_excitation_degree_spin(key1,key2,degree,Nint)
end select
IRP_IF WITHOUT_SHIFTRL
degree = ishft(degree,-1)
IRP_ELSE
degree = shiftr(degree,1)
IRP_ENDIF
end
@ -2066,10 +2200,18 @@ IRP_ENDIF
high = max(exc(1,1), exc(1,2))
ASSERT (low > 0)
IRP_IF WITHOUT_SHIFTRL
j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint)
IRP_ELSE
j = shiftr(low-1,bit_kind_shift)+1 ! Find integer in array(Nint)
IRP_ENDIF
n = iand(low-1,bit_kind_size-1)+1 ! mod(low,bit_kind_size)
ASSERT (high > 0)
IRP_IF WITHOUT_SHIFTRL
k = ishft(high-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(high-1,bit_kind_shift)+1
IRP_ENDIF
m = iand(high-1,bit_kind_size-1)+1
if (j==k) then
@ -2094,10 +2236,18 @@ IRP_ENDIF
high = max(exc(i,1), exc(i,2))
ASSERT (low > 0)
IRP_IF WITHOUT_SHIFTRL
j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint)
IRP_ELSE
j = shiftr(low-1,bit_kind_shift)+1 ! Find integer in array(Nint)
IRP_ENDIF
n = iand(low-1,bit_kind_size-1)+1 ! mod(low,bit_kind_size)
ASSERT (high > 0)
IRP_IF WITHOUT_SHIFTRL
k = ishft(high-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(high-1,bit_kind_shift)+1
IRP_ENDIF
m = iand(high-1,bit_kind_size-1)+1
if (j==k) then
@ -2191,10 +2341,18 @@ IRP_ENDIF
high = max(exc(1,1),exc(1,2))
ASSERT (low > 0)
IRP_IF WITHOUT_SHIFTRL
j = ishft(low-1,-bit_kind_shift)+1 ! Find integer in array(Nint)
IRP_ELSE
j = shiftr(low-1,bit_kind_shift)+1 ! Find integer in array(Nint)
IRP_ENDIF
n = iand(low-1,bit_kind_size-1)+1 ! mod(low,bit_kind_size)
ASSERT (high > 0)
IRP_IF WITHOUT_SHIFTRL
k = ishft(high-1,-bit_kind_shift)+1
IRP_ELSE
k = shiftr(high-1,bit_kind_shift)+1
IRP_ENDIF
m = iand(high-1,bit_kind_size-1)+1
if (j==k) then
nperm = popcnt(iand(det1(j), &

16
src/determinants/spindeterminants.irp.f
View File

@ -172,7 +172,11 @@ integer function get_index_in_psi_det_alpha_unique(key,Nint)
!DIR$ FORCEINLINE
det_search = spin_det_search_key(psi_det_alpha_unique(1,1),Nint)
IRP_IF WITHOUT_SHIFTRL
istep = ishft(iend-ibegin,-1)
IRP_ELSE
istep = shiftr(iend-ibegin,1)
IRP_ENDIF
i=ibegin+istep
do while (istep > 0)
!DIR$ FORCEINLINE
@ -184,7 +188,11 @@ integer function get_index_in_psi_det_alpha_unique(key,Nint)
else
ibegin = i
endif
IRP_IF WITHOUT_SHIFTRL
istep = ishft(iend-ibegin,-1)
IRP_ELSE
istep = shiftr(iend-ibegin,1)
IRP_ENDIF
i = ibegin + istep
end do
@ -252,7 +260,11 @@ integer function get_index_in_psi_det_beta_unique(key,Nint)
!DIR$ FORCEINLINE
det_search = spin_det_search_key(psi_det_beta_unique(1,1),Nint)
IRP_IF WITHOUT_SHIFTRL
istep = ishft(iend-ibegin,-1)
IRP_ELSE
istep = shiftr(iend-ibegin,1)
IRP_ENDIF
i=ibegin+istep
do while (istep > 0)
!DIR$ FORCEINLINE
@ -264,7 +276,11 @@ integer function get_index_in_psi_det_beta_unique(key,Nint)
else
ibegin = i
endif
IRP_IF WITHOUT_SHIFTRL
istep = ishft(iend-ibegin,-1)
IRP_ELSE
istep = shiftr(iend-ibegin,1)
IRP_ENDIF
i = ibegin + istep
end do

12
src/mo_two_e_ints/map_integrals.irp.f
View File

@ -184,7 +184,11 @@ subroutine get_mo_two_e_integrals(j,k,l,sze,out_val,map)
q = min(j,l)
s = max(j,l)
IRP_IF WITHOUT_SHIFTRL
q = q+ishft(s*s-s,-1)
IRP_ELSE
q = q+shiftr(s*s-s,1)
IRP_ENDIF
do i=1,sze
if (banned_excitation(i,k)) cycle
@ -195,10 +199,18 @@ subroutine get_mo_two_e_integrals(j,k,l,sze,out_val,map)
else
p = min(i,k)
r = max(i,k)
IRP_IF WITHOUT_SHIFTRL
p = p+ishft(r*r-r,-1)
IRP_ELSE
p = p+shiftr(r*r-r,1)
IRP_ENDIF
i1 = min(p,q)
i2 = max(p,q)
IRP_IF WITHOUT_SHIFTRL
idx = i1+ishft(i2*i2-i2,-1)
IRP_ELSE
idx = i1+shiftr(i2*i2-i2,1)
IRP_ENDIF
!DIR$ FORCEINLINE
call map_get(map,idx,tmp)
out_val(i) = dble(tmp)

36
src/mo_two_e_ints/mo_bi_integrals.irp.f
View File

@ -9,13 +9,25 @@ subroutine mo_two_e_integrals_index(i,j,k,l,i1)
integer(key_kind) :: p,q,r,s,i2
p = min(i,k)
r = max(i,k)
IRP_IF WITHOUT_SHIFTRL
p = p+ishft(r*r-r,-1)
IRP_ELSE
p = p+shiftr(r*r-r,1)
IRP_ENDIF
q = min(j,l)
s = max(j,l)
IRP_IF WITHOUT_SHIFTRL
q = q+ishft(s*s-s,-1)
IRP_ELSE
q = q+shiftr(s*s-s,1)
IRP_ENDIF
i1 = min(p,q)
i2 = max(p,q)
IRP_IF WITHOUT_SHIFTRL
i1 = i1+ishft(i2*i2-i2,-1)
IRP_ELSE
i1 = i1+shiftr(i2*i2-i2,1)
IRP_ENDIF
end
@ -280,7 +292,11 @@ subroutine add_integrals_to_map(mask_ijkl)
if (abs(c) < thr_coef) then
cycle
endif
IRP_IF WITHOUT_SHIFTRL
j1 = ishft((l*l-l),-1)
IRP_ELSE
j1 = shiftr((l*l-l),1)
IRP_ENDIF
do j0 = 1, n_j
j = list_ijkl(j0,2)
if (j > l) then
@ -289,7 +305,11 @@ subroutine add_integrals_to_map(mask_ijkl)
j1 += 1
do k0 = 1, n_k
k = list_ijkl(k0,3)
IRP_IF WITHOUT_SHIFTRL
i1 = ishft((k*k-k),-1)
IRP_ELSE
i1 = shiftr((k*k-k),1)
IRP_ENDIF
if (i1<=j1) then
continue
else
@ -556,7 +576,11 @@ subroutine add_integrals_to_map_three_indices(mask_ijk)
endif
do k0 = 1, n_k
k = list_ijkl(k0,3)
IRP_IF WITHOUT_SHIFTRL
i1 = ishft((k*k-k),-1)
IRP_ELSE
i1 = shiftr((k*k-k),1)
IRP_ENDIF
two_e_tmp_1 = 0.d0
j0 = l0
j = list_ijkl(j0,2)
@ -600,7 +624,11 @@ subroutine add_integrals_to_map_three_indices(mask_ijk)
endif
do k0 = 1, n_k
k = list_ijkl(k0,3)
IRP_IF WITHOUT_SHIFTRL
i1 = ishft((k*k-k),-1)
IRP_ELSE
i1 = shiftr((k*k-k),1)
IRP_ENDIF
two_e_tmp_1 = 0.d0
j0 = k0
j = list_ijkl(k0,2)
@ -837,7 +865,11 @@ subroutine add_integrals_to_map_no_exit_34(mask_ijkl)
if (abs(c) < thr_coef) then
cycle
endif
IRP_IF WITHOUT_SHIFTRL
j1 = ishft((l*l-l),-1)
IRP_ELSE
j1 = shiftr((l*l-l),1)
IRP_ENDIF
do j0 = 1, n_j
j = list_ijkl(j0,2)
if (j > l) then
@ -846,7 +878,11 @@ subroutine add_integrals_to_map_no_exit_34(mask_ijkl)
j1 += 1
do k0 = 1, n_k
k = list_ijkl(k0,3)
IRP_IF WITHOUT_SHIFTRL
i1 = ishft((k*k-k),-1)
IRP_ELSE
i1 = shiftr((k*k-k),1)
IRP_ENDIF
two_e_tmp_1 = 0.d0
do i0 = 1, n_i
i = list_ijkl(i0,1)

12
src/utils/integration.irp.f
View File

@ -423,7 +423,11 @@ double precision function F_integral(n,p)
F_integral = sqpi * sqrt_p
return
endif
IRP_IF WITHOUT_SHIFTRL
F_integral = sqpi * 0.5d0**n * sqrt_p**(n+1) * fact(n)/fact(ishft(n,-1))
IRP_ELSE
F_integral = sqpi * 0.5d0**n * sqrt_p**(n+1) * fact(n)/fact(shiftr(n,1))
IRP_ENDIF
end
@ -500,7 +504,11 @@ double precision function rint_sum(n_pt_out,rho,d1)
endif
do i=2,n_pt_out,2
IRP_IF WITHOUT_SHIFTRL
n = ishft(i,-1)
IRP_ELSE
n = shiftr(i,1)
IRP_ENDIF
rint_sum = rint_sum + d1(i)*rint1(n,rho)
enddo
@ -525,7 +533,11 @@ double precision function rint_sum(n_pt_out,rho,d1)
di = di+2.d0
enddo
do i=42,n_pt_out,2
IRP_IF WITHOUT_SHIFTRL
n = ishft(i,-1)
IRP_ELSE
n = shiftr(i,1)
IRP_ENDIF
rint_sum = rint_sum + d1(i)*rint_large_n(n,rho)
enddo

6
src/utils/sort.irp.f
View File

@ -57,10 +57,14 @@ BEGIN_TEMPLATE
$type :: c, tmp
integer :: itmp
integer :: i, j
if(isize<2)return
IRP_IF WITHOUT_SHIFTRL
c = x( ishft(first+last,-1) )
IRP_ELSE
c = x( shiftr(first+last,1) )
IRP_ENDIF
i = first
j = last
do