PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-22 20:34:58 +01:00
Code Releases Activity

Guarded shiftl with IRP_IF

Browse Source
This commit is contained in:
Anthony Scemama 2021-03-21 09:05:31 +01:00
parent 32c2d2c80e
commit 50c73e2de4
18 changed files with 302 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -69,22 +69,19 @@ subroutine two_e_integrals_index_reverse(i,j,k,l,i1)
integer(key_kind), intent(in) :: i1
integer(key_kind) :: i2,i3
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
i2 = ceiling(0.5d0*(dsqrt(dble(ishft(i1,3)+1))-1.d0))
l(1) = ceiling(0.5d0*(dsqrt(dble(ishft(i2,3)+1))-1.d0))
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
k(1) = ceiling(0.5d0*(dsqrt(dble(ishft(i3,3)+1))-1.d0))
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
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))
i3 = i1 - shiftr(i2*i2-i2,1)
k(1) = ceiling(0.5d0*(dsqrt(dble(shiftl(i3,3)+1))-1.d0))
j(1) = int(i2 - shiftr(l(1)*l(1)-l(1),1),4)
i(1) = int(i3 - shiftr(k(1)*k(1)-k(1),1),4)
IRP_ENDIF
@ -334,9 +331,15 @@ BEGIN_PROVIDER [ double precision, ao_integrals_cache, (0:64*64*64*64) ]
!DIR$ FORCEINLINE
call map_get(ao_integrals_map,idx,integral)
ii = l-ao_integrals_cache_min
IRP_IF WITHOUT_SHIFTRL
ii = ior( ishft(ii,6), k-ao_integrals_cache_min)
ii = ior( ishft(ii,6), j-ao_integrals_cache_min)
ii = ior( ishft(ii,6), i-ao_integrals_cache_min)
IRP_ELSE
ii = ior( shiftl(ii,6), k-ao_integrals_cache_min)
ii = ior( shiftl(ii,6), j-ao_integrals_cache_min)
ii = ior( shiftl(ii,6), i-ao_integrals_cache_min)
IRP_ENDIF
ao_integrals_cache(ii) = integral
enddo
enddo
@ -374,9 +377,15 @@ double precision function get_ao_two_e_integral(i,j,k,l,map) result(result)
call map_get(map,idx,tmp)
else
ii = l-ao_integrals_cache_min
IRP_IF WITHOUT_SHIFTRL
ii = ior( ishft(ii,6), k-ao_integrals_cache_min)
ii = ior( ishft(ii,6), j-ao_integrals_cache_min)
ii = ior( ishft(ii,6), i-ao_integrals_cache_min)
IRP_ELSE
ii = ior( shiftl(ii,6), k-ao_integrals_cache_min)
ii = ior( shiftl(ii,6), j-ao_integrals_cache_min)
ii = ior( shiftl(ii,6), i-ao_integrals_cache_min)
IRP_ENDIF
tmp = ao_integrals_cache(ii)
endif
endif
@ -422,9 +431,15 @@ BEGIN_PROVIDER [ complex*16, ao_integrals_cache_periodic, (0:64*64*64*64) ]
endif
ii = l-ao_integrals_cache_min
IRP_IF WITHOUT_SHIFTRL
ii = ior( ishft(ii,6), k-ao_integrals_cache_min)
ii = ior( ishft(ii,6), j-ao_integrals_cache_min)
ii = ior( ishft(ii,6), i-ao_integrals_cache_min)
IRP_ELSE
ii = ior( shiftl(ii,6), k-ao_integrals_cache_min)
ii = ior( shiftl(ii,6), j-ao_integrals_cache_min)
ii = ior( shiftl(ii,6), i-ao_integrals_cache_min)
IRP_ENDIF
ao_integrals_cache_periodic(ii) = integral
enddo
enddo
@ -480,9 +495,15 @@ complex*16 function get_ao_two_e_integral_periodic(i,j,k,l,map) result(result)
endif
else
ii = l-ao_integrals_cache_min
IRP_IF WITHOUT_SHIFTRL
ii = ior( ishft(ii,6), k-ao_integrals_cache_min)
ii = ior( ishft(ii,6), j-ao_integrals_cache_min)
ii = ior( ishft(ii,6), i-ao_integrals_cache_min)
IRP_ELSE
ii = ior( shiftl(ii,6), k-ao_integrals_cache_min)
ii = ior( shiftl(ii,6), j-ao_integrals_cache_min)
ii = ior( shiftl(ii,6), i-ao_integrals_cache_min)
IRP_ENDIF
tmp = ao_integrals_cache_periodic(ii)
endif
result = tmp

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

@ -624,7 +624,11 @@ double precision function ERI(alpha,beta,delta,gama,a_x,b_x,c_x,d_x,a_y,b_y,c_y,
p = alpha + beta
q = delta + gama
ASSERT (p+q >= 0.d0)
IRP_IF WITHOUT_SHIFTRL
n_pt = ishft( nx+ny+nz,1 )
IRP_ELSE
n_pt = shiftl( nx+ny+nz,1 )
IRP_ENDIF
coeff = pi_5_2 / (p * q * dsqrt(p+q))
if (n_pt == 0) then
@ -784,7 +788,11 @@ integer function n_pt_sup(a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z)
! $I_x(a_x,b_x,c_x,d_x) \, I_y(a_y,b_y,c_y,d_y) \, I_z(a_z,b_z,c_z,d_z)$
END_DOC
integer :: a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z
IRP_IF WITHOUT_SHIFTRL
n_pt_sup = ishft( a_x+b_x+c_x+d_x + a_y+b_y+c_y+d_y + a_z+b_z+c_z+d_z,1 )
IRP_ELSE
n_pt_sup = shiftl( a_x+b_x+c_x+d_x + a_y+b_y+c_y+d_y + a_z+b_z+c_z+d_z,1 )
IRP_ENDIF
end

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

@ -339,10 +339,11 @@ logical function is_i_in_virtual(i)
key= 0_bit_kind
IRP_IF WITHOUT_SHIFTRL
k = ishft(i-1,-bit_kind_shift)+1
j = i-ishft(k-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
IRP_ENDIF
key(k) = ibset(key(k),j)
accu = 0
do k = 1, N_int

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

@ -87,10 +87,11 @@ subroutine list_to_bitstring( string, list, n_elements, Nint)
do i=1,n_elements
IRP_IF WITHOUT_SHIFTRL
iint = ishft(list(i)-1,-bit_kind_shift) + 1
ipos = list(i)-ishft((iint-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
IRP_ENDIF
string(iint) = ibset( string(iint), ipos )
enddo
@ -123,7 +124,11 @@ subroutine bitstring_to_str( output, string, Nint )
output(ibuf:ibuf) = '-'
endif
ibuf = ibuf+1
IRP_IF WITHOUT_SHIFTRL
itemp = ishft(itemp,1)
IRP_ELSE
itemp = shiftl(itemp,1)
IRP_ENDIF
enddo
enddo
output(ibuf:ibuf) = '|'
@ -157,7 +162,11 @@ subroutine configuration_to_str( output, string, Nint )
output(ibuf:ibuf) = '0'
endif
ibuf = ibuf+1
IRP_IF WITHOUT_SHIFTRL
itemp = ishft(itemp,1)
IRP_ELSE
itemp = shiftl(itemp,1)
IRP_ENDIF
enddo
enddo
output(ibuf:ibuf) = '|'

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

@ -12,10 +12,11 @@ logical function is_the_hole_in_det(key_in,ispin,i_hole)
enddo
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_hole-1,-bit_kind_shift)+1
j = i_hole-ishft(k-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
IRP_ENDIF
itest(k) = ibset(itest(k),j)
j = 0
do i = 1, N_int
@ -44,10 +45,11 @@ logical function is_the_particl_in_det(key_in,ispin,i_particl)
enddo
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_particl-1,-bit_kind_shift)+1
j = i_particl-ishft(k-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
IRP_ENDIF
itest(k) = ibset(itest(k),j)
j = 0
do i = 1, N_int

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

@ -23,10 +23,11 @@ subroutine modify_bitmasks_for_hole(i_hole)
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_hole-1,-bit_kind_shift)+1
j = i_hole-ishft(k-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
IRP_ENDIF
do l = 1, 3
i = index_holes_bitmask(l)
do ispin=1,2
@ -48,10 +49,11 @@ subroutine modify_bitmasks_for_hole_in_out(i_hole)
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_hole-1,-bit_kind_shift)+1
j = i_hole-ishft(k-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
IRP_ENDIF
do l = 1, 3
i = index_holes_bitmask(l)
do ispin=1,2
@ -83,10 +85,11 @@ subroutine modify_bitmasks_for_particl(i_part)
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_part-1,-bit_kind_shift)+1
j = i_part-ishft(k-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
IRP_ENDIF
do l = 1, 3
i = index_particl_bitmask(l)
do ispin=1,2

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

@ -12,6 +12,20 @@ subroutine get_mask_phase(det1, pm, Nint)
tmp1 = 0_8
tmp2 = 0_8
do i=1,Nint
IRP_IF WITHOUT_SHIFTRL
pm(i,1) = ieor(pm(i,1), ishft(pm(i,1), 1))
pm(i,2) = ieor(pm(i,2), ishft(pm(i,2), 1))
pm(i,1) = ieor(pm(i,1), ishft(pm(i,1), 2))
pm(i,2) = ieor(pm(i,2), ishft(pm(i,2), 2))
pm(i,1) = ieor(pm(i,1), ishft(pm(i,1), 4))
pm(i,2) = ieor(pm(i,2), ishft(pm(i,2), 4))
pm(i,1) = ieor(pm(i,1), ishft(pm(i,1), 8))
pm(i,2) = ieor(pm(i,2), ishft(pm(i,2), 8))
pm(i,1) = ieor(pm(i,1), ishft(pm(i,1), 16))
pm(i,2) = ieor(pm(i,2), ishft(pm(i,2), 16))
pm(i,1) = ieor(pm(i,1), ishft(pm(i,1), 32))
pm(i,2) = ieor(pm(i,2), ishft(pm(i,2), 32))
IRP_ELSE
pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 1))
pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 1))
pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 2))
@ -24,6 +38,7 @@ subroutine get_mask_phase(det1, pm, Nint)
pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 16))
pm(i,1) = ieor(pm(i,1), shiftl(pm(i,1), 32))
pm(i,2) = ieor(pm(i,2), shiftl(pm(i,2), 32))
IRP_ENDIF
pm(i,1) = ieor(pm(i,1), tmp1)
pm(i,2) = ieor(pm(i,2), tmp2)
if(iand(popcnt(det1(i,1)), 1) == 1) tmp1 = not(tmp1)

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

@ -107,7 +107,11 @@ IRP_ENDIF
n_alpha_in_single = n_alpha_in_single - popcnt( o(i,2) )
enddo
IRP_IF WITHOUT_SHIFTRL
v = ishft(1,n_alpha_in_single) - 1
IRP_ELSE
v = shiftl(1,n_alpha_in_single) - 1
IRP_ENDIF
! Initialize first determinant
d(:,1,1) = o(:,2)
@ -123,7 +127,11 @@ IRP_ENDIF
sze = int(binom_int(n,n_alpha_in_single),4)
IRP_IF WITHOUT_SHIFTRL
if ( (ishft(n_alpha_in_single,1) == n).and.n>0 ) then
IRP_ELSE
if ( (shiftl(n_alpha_in_single,1) == n).and.n>0 ) then
IRP_ENDIF
! Time reversal symmetry
d(:,1,2) = d(:,2,1)
@ -265,7 +273,11 @@ IRP_ENDIF
n_alpha_in_single = n_alpha_in_single - popcnt( o(i,2) )
enddo
IRP_IF WITHOUT_SHIFTRL
v = ishft(1,n_alpha_in_single) - 1
IRP_ELSE
v = shiftl(1,n_alpha_in_single) - 1
IRP_ENDIF
! Initialize first determinant
d(:,1,1) = o(:,2)
@ -281,7 +293,11 @@ IRP_ENDIF
sze = int(binom_int(n,n_alpha_in_single),4)
IRP_IF WITHOUT_SHIFTRL
if ( (ishft(n_alpha_in_single,1) == n).and.n>0 ) then
IRP_ELSE
if ( (shiftl(n_alpha_in_single,1) == n).and.n>0 ) then
IRP_ENDIF
! Time reversal symmetry
d(:,1,sze) = d(:,2,1)

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

@ -28,7 +28,11 @@ IRP_ENDIF
n_open_shells = n_open_shells + popcnt(cfg(i,1))
enddo
mask = n_open_shells
IRP_IF WITHOUT_SHIFTRL
mask = ishft(mask,56)
IRP_ELSE
mask = shiftl(mask,56)
IRP_ENDIF
configuration_search_key = ior (mask,configuration_search_key)
end

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

@ -21,10 +21,11 @@ subroutine do_single_excitation_cfg(key_in,key_out,i_hole,i_particle,ok)
! hole
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_hole-1,-bit_kind_shift)+1
j = i_hole-ishft(k-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
IRP_ENDIF
mask = ibset(0_bit_kind,j)
! Check if the position j is singly occupied
@ -52,10 +53,11 @@ IRP_ENDIF
! particle
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_particle-1,-bit_kind_shift)+1
j = i_particle-ishft(k-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
IRP_ENDIF
mask = ibset(0_bit_kind,j)
! Check if the position j is singly occupied
@ -119,10 +121,11 @@ subroutine do_single_excitation_cfg_with_type(key_in,key_out,i_hole,i_particle,e
! hole
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_hole-1,-bit_kind_shift)+1
j = i_hole-ishft(k-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
IRP_ENDIF
mask = ibset(0_bit_kind,j)
! Check if the position j is singly occupied
@ -152,10 +155,11 @@ IRP_ENDIF
! particle
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_particle-1,-bit_kind_shift)+1
j = i_particle-ishft(k-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
IRP_ENDIF
mask = ibset(0_bit_kind,j)
! Check if the position j is singly occupied

4
src/csf/sigma_vector.irp.f
View File

@ -106,7 +106,11 @@ IRP_ENDIF
detb(k) = ibclr(detb(k),ipos)
! Create a mask will all MOs higher than the beta electron
IRP_IF WITHOUT_SHIFTRL
mask = not(ishft(1_bit_kind,ipos + 1) - 1_bit_kind)
IRP_ELSE
mask = not(shiftl(1_bit_kind,ipos + 1) - 1_bit_kind)
IRP_ENDIF
! Apply the mask to the alpha string to count how many electrons to cross
nperm = popcnt( iand(mask, deta(k)) )

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

@ -20,10 +20,11 @@ subroutine do_single_excitation(key_in,i_hole,i_particle,ispin,i_ok)
! hole
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_hole-1,-bit_kind_shift)+1
j = i_hole-ishft(k-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
IRP_ENDIF
mask = ibset(0_bit_kind,j)
! check whether position j is occupied
if (iand(key_in(k,ispin),mask) /= 0_bit_kind) then
@ -36,10 +37,11 @@ IRP_ENDIF
! particle
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_particle-1,-bit_kind_shift)+1
j = i_particle-ishft(k-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
IRP_ENDIF
mask = ibset(0_bit_kind,j)
if (iand(key_in(k,ispin),mask) == 0_bit_kind) then
key_in(k,ispin) = ibset(key_in(k,ispin),j)
@ -102,10 +104,11 @@ logical function is_spin_flip_possible(key_in,i_flip,ispin)
key_tmp = 0_bit_kind
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_flip-1,-bit_kind_shift)+1
j = i_flip-ishft(k-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
IRP_ENDIF
key_tmp(k,1) = ibset(key_tmp(k,1),j)
integer :: other_spin(2)
other_spin(1) = 2

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

@ -802,39 +802,46 @@ subroutine apply_excitation(det, exc, res, ok, Nint)
IRP_IF WITHOUT_SHIFTRL
ii = ishft(h1-1,-bit_kind_shift) + 1
pos = h1-1-ishft(ii-1,bit_kind_shift)
IRP_ELSE
ii = shiftr(h1-1,bit_kind_shift) + 1
IRP_ENDIF
pos = h1-1-shiftl(ii-1,bit_kind_shift)
IRP_ENDIF
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
pos = p1-1-ishft(ii-1,bit_kind_shift)
if(iand(det(ii, s1),ishft(1_bit_kind, pos)) /= 0_8) return
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
IRP_ENDIF
res(ii, s1) = ibset(res(ii, s1), pos)
if(degree == 2) then
IRP_IF WITHOUT_SHIFTRL
ii = ishft(h2-1,-bit_kind_shift) + 1
pos = h2-1-ishft(ii-1,bit_kind_shift)
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return
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
IRP_ENDIF
res(ii, s2) = ibclr(res(ii, s2), pos)
IRP_IF WITHOUT_SHIFTRL
ii = ishft(p2-1,-bit_kind_shift) + 1
pos = p2-1-ishft(ii-1,bit_kind_shift)
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return
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
IRP_ENDIF
res(ii, s2) = ibset(res(ii, s2), pos)
endif
ok = .true.
@ -857,21 +864,25 @@ subroutine apply_particles(det, s1, p1, s2, p2, res, ok, Nint)
if(p1 /= 0) then
IRP_IF WITHOUT_SHIFTRL
ii =ishft(p1-1,-bit_kind_shift) + 1
pos = p1-1-ishft(ii-1,bit_kind_shift)
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return
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
IRP_ENDIF
res(ii, s1) = ibset(res(ii, s1), pos)
end if
IRP_IF WITHOUT_SHIFTRL
ii = ishft(p2-1,-bit_kind_shift) + 1
pos = p2-1-ishft(ii-1,bit_kind_shift)
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return
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
IRP_ENDIF
res(ii, s2) = ibset(res(ii, s2), pos)
ok = .true.
@ -894,21 +905,25 @@ subroutine apply_holes(det, s1, h1, s2, h2, res, ok, Nint)
if(h1 /= 0) then
IRP_IF WITHOUT_SHIFTRL
ii = ishft(h1-1,-bit_kind_shift) + 1
pos = h1-1-ishft(ii-1,bit_kind_shift)
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return
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
IRP_ENDIF
res(ii, s1) = ibclr(res(ii, s1), pos)
end if
IRP_IF WITHOUT_SHIFTRL
ii = ishft(h2-1,-bit_kind_shift) + 1
pos = h2-1-ishft(ii-1,bit_kind_shift)
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return
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
IRP_ENDIF
res(ii, s2) = ibclr(res(ii, s2), pos)
ok = .true.
@ -929,11 +944,13 @@ subroutine apply_particle(det, s1, p1, res, ok, Nint)
IRP_IF WITHOUT_SHIFTRL
ii = ishft(p1-1,-bit_kind_shift) + 1
pos = p1-1-ishft(ii-1,bit_kind_shift)
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return
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
IRP_ENDIF
res(ii, s1) = ibset(res(ii, s1), pos)
ok = .true.
@ -955,11 +972,13 @@ subroutine apply_hole(det, s1, h1, res, ok, Nint)
IRP_IF WITHOUT_SHIFTRL
ii = ishft(h1-1,-bit_kind_shift) + 1
pos = h1-1-ishft(ii-1,bit_kind_shift)
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return
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
IRP_ENDIF
res(ii, s1) = ibclr(res(ii, s1), pos)
ok = .true.

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

@ -100,8 +100,8 @@ subroutine $subroutine_diexcP(key_in, fs1, fh1, particl_1, fs2, fh2, particl_2,
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))
p1_mask(ishft(fh1-1,-bit_kind_shift) + 1, fs1) = ishft(one,iand(fh1-1,bit_kind_size-1))
p2_mask(ishft(fh2-1,-bit_kind_shift) + 1, fs2) = ishft(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))
@ -113,8 +113,8 @@ IRP_ENDIF
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))
key_mask(ishft(fh1-1,-bit_kind_shift) + 1, fs1) -= ishft(one,iand(fh1-1,bit_kind_size-1))
key_mask(ishft(fh2-1,-bit_kind_shift) + 1, fs2) -= ishft(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))
@ -240,20 +240,22 @@ 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
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)
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)
IRP_ENDIF
!!!! Second couple hole particle
do j = 1, N_int
@ -298,21 +300,25 @@ IRP_ENDIF
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
j = i_b-ishft(k-1,bit_kind_shift)-1
hole(k,other_spin) = ibclr(hole(k,other_spin),j)
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)
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)
IRP_ENDIF
$filter2h2p_double
$filter_only_1h1p_double
$filter_only_1h2p_double
@ -362,21 +368,25 @@ IRP_ENDIF
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
j = i_b-ishft(k-1,bit_kind_shift)-1
hole(k,ispin) = ibclr(hole(k,ispin),j)
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)
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)
IRP_ENDIF
$filter2h2p_double
$filter_only_1h1p_double
$filter_only_1h2p_double
@ -524,18 +534,20 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato
hole = key_in
IRP_IF WITHOUT_SHIFTRL
k = ishft(i_a-1,-bit_kind_shift)+1
j = i_a-ishft(k-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
IRP_ENDIF
$filterhole
hole(k,ispin) = ibclr(hole(k,ispin),j)
IRP_IF WITHOUT_SHIFTRL
k_a = ishft(j_a-1,-bit_kind_shift)+1
l_a = j_a-ishft(k_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
IRP_ENDIF
$filterparticle
hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a)
$only_2p_single

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

@ -43,7 +43,11 @@ subroutine get_excitation_degree(key1,key2,degree,Nint)
case default
integer :: lmax
IRP_IF WITHOUT_SHIFTRL
lmax = ishft(Nint,1)
IRP_ELSE
lmax = shiftl(Nint,1)
IRP_ENDIF
do l=1,lmax
xorvec(l) = xor( key1(l), key2(l))
enddo
@ -262,16 +266,31 @@ IRP_ENDIF
n = iand(low,bit_kind_size-1)
if (j==k) then
IRP_IF WITHOUT_SHIFTRL
nperm = nperm + popcnt(iand(det1(j,ispin), &
iand( ishft(1_bit_kind,m)-1_bit_kind, &
not(ishft(1_bit_kind,n))+1_bit_kind)) )
IRP_ELSE
nperm = nperm + popcnt(iand(det1(j,ispin), &
iand( shiftl(1_bit_kind,m)-1_bit_kind, &
not(shiftl(1_bit_kind,n))+1_bit_kind)) )
IRP_ENDIF
else
IRP_IF WITHOUT_SHIFTRL
nperm = nperm + popcnt( &
iand(det1(j,ispin), &
iand(not(0_bit_kind), &
(not(ishft(1_bit_kind,n)) + 1_bit_kind) ))) &
+ popcnt(iand(det1(k,ispin), &
(ishft(1_bit_kind,m) - 1_bit_kind ) ))
IRP_ELSE
nperm = nperm + popcnt( &
iand(det1(j,ispin), &
iand(not(0_bit_kind), &
(not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) &
+ popcnt(iand(det1(k,ispin), &
(shiftl(1_bit_kind,m) - 1_bit_kind ) ))
IRP_ENDIF
do i=j+1,k-1
nperm = nperm + popcnt(det1(i,ispin))
@ -299,16 +318,31 @@ IRP_ENDIF
n = iand(low,bit_kind_size-1)
if (j==k) then
IRP_IF WITHOUT_SHIFTRL
nperm = nperm + popcnt(iand(det1(j,ispin), &
iand( shiftl(1_bit_kind,m)-1_bit_kind, &
not(shiftl(1_bit_kind,n))+1_bit_kind)) )
iand( ishft(1_bit_kind,m)-1_bit_kind, &
not(ishft(1_bit_kind,n))+1_bit_kind)) )
IRP_ELSE
nperm = nperm + popcnt(iand(det1(j,ispin), &
iand( shiftl(1_bit_kind,m)-1_bit_kind, &
not(shiftl(1_bit_kind,n))+1_bit_kind)) )
IRP_ENDIF
else
IRP_IF WITHOUT_SHIFTRL
nperm = nperm + popcnt( &
iand(det1(j,ispin), &
iand(not(0_bit_kind), &
(not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) &
(not(ishft(1_bit_kind,n)) + 1_bit_kind) ))) &
+ popcnt(iand(det1(k,ispin), &
(shiftl(1_bit_kind,m) - 1_bit_kind ) ))
(ishft(1_bit_kind,m) - 1_bit_kind ) ))
IRP_ELSE
nperm = nperm + popcnt( &
iand(det1(j,ispin), &
iand(not(0_bit_kind), &
(not(shiftl(1_bit_kind,n)) + 1_bit_kind) )))&
+ popcnt(iand(det1(k,ispin), &
(shiftl(1_bit_kind,m) - 1_bit_kind ) ))
IRP_ENDIF
do i=j+1,k-1
nperm = nperm + popcnt(det1(i,ispin))
@ -344,12 +378,21 @@ subroutine get_phasemask_bit(det1, pm, Nint)
do ispin=1,2
tmp = 0_8
do i=1,Nint
IRP_IF WITHOUT_SHIFTRL
pm(i,ispin) = xor(det1(i,ispin), ishft(det1(i,ispin), 1))
pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 2))
pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 4))
pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 8))
pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 16))
pm(i,ispin) = xor(pm(i,ispin), ishft(pm(i,ispin), 32))
IRP_ELSE
pm(i,ispin) = xor(det1(i,ispin), shiftl(det1(i,ispin), 1))
pm(i,ispin) = xor(pm(i,ispin), shiftl(pm(i,ispin), 2))
pm(i,ispin) = xor(pm(i,ispin), shiftl(pm(i,ispin), 4))
pm(i,ispin) = xor(pm(i,ispin), shiftl(pm(i,ispin), 8))
pm(i,ispin) = xor(pm(i,ispin), shiftl(pm(i,ispin), 16))
pm(i,ispin) = xor(pm(i,ispin), shiftl(pm(i,ispin), 32))
IRP_ENDIF
pm(i,ispin) = xor(pm(i,ispin), tmp)
if(iand(popcnt(det1(i,ispin)), 1) == 1) tmp = not(tmp)
end do
@ -434,16 +477,31 @@ IRP_ENDIF
n = iand(low,bit_kind_size-1)
if (j==k) then
IRP_IF WITHOUT_SHIFTRL
nperm = nperm + popcnt(iand(det1(j,ispin), &
iand( shiftl(1_bit_kind,m)-1_bit_kind, &
iand( ishft(1_bit_kind,m)-1_bit_kind, &
not(ishft(1_bit_kind,n))+1_bit_kind)) )
IRP_ELSE
nperm = nperm + popcnt(iand(det1(j,ispin), &
iand( shiftl(1_bit_kind,m)-1_bit_kind, &
not(shiftl(1_bit_kind,n))+1_bit_kind)) )
IRP_ENDIF
else
IRP_IF WITHOUT_SHIFTRL
nperm = nperm + popcnt( &
iand(det1(j,ispin), &
iand(not(0_bit_kind), &
(not(ishft(1_bit_kind,n)) + 1_bit_kind) ))) &
+ popcnt(iand(det1(k,ispin), &
(ishft(1_bit_kind,m) - 1_bit_kind ) ))
IRP_ELSE
nperm = nperm + popcnt( &
iand(det1(j,ispin), &
iand(not(0_bit_kind), &
(not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) &
+ popcnt(iand(det1(k,ispin), &
(shiftl(1_bit_kind,m) - 1_bit_kind ) ))
IRP_ENDIF
do i=j+1,k-1
nperm = nperm + popcnt(det1(i,ispin))
@ -1887,7 +1945,11 @@ IRP_ELSE
k = shiftr(iorb-1,bit_kind_shift)+1
IRP_ENDIF
ASSERT (k>0)
IRP_IF WITHOUT_SHIFTRL
l = iorb - ishft(k-1,bit_kind_shift)-1
IRP_ELSE
l = iorb - shiftl(k-1,bit_kind_shift)-1
IRP_ENDIF
key(k,ispin) = ibclr(key(k,ispin),l)
other_spin = iand(ispin,1)+1
@ -1952,7 +2014,11 @@ IRP_ELSE
k = shiftr(iorb-1,bit_kind_shift)+1
IRP_ENDIF
ASSERT (k >0)
IRP_IF WITHOUT_SHIFTRL
l = iorb - ishft(k-1,bit_kind_shift)-1
IRP_ELSE
l = iorb - shiftl(k-1,bit_kind_shift)-1
IRP_ENDIF
ASSERT (l >= 0)
key(k,ispin) = ibset(key(k,ispin),l)
other_spin = iand(ispin,1)+1

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

@ -73,9 +73,15 @@ BEGIN_PROVIDER [ double precision, mo_integrals_cache, (0_8:128_8*128_8*128_8*12
!DIR$ FORCEINLINE
call map_get(mo_integrals_map,idx,integral)
ii = l-mo_integrals_cache_min_8
IRP_IF WITHOUT_SHIFTRL
ii = ior( ishft(ii,7), k-mo_integrals_cache_min_8)
ii = ior( ishft(ii,7), j-mo_integrals_cache_min_8)
ii = ior( ishft(ii,7), i-mo_integrals_cache_min_8)
IRP_ELSE
ii = ior( shiftl(ii,7), k-mo_integrals_cache_min_8)
ii = ior( shiftl(ii,7), j-mo_integrals_cache_min_8)
ii = ior( shiftl(ii,7), i-mo_integrals_cache_min_8)
IRP_ENDIF
mo_integrals_cache(ii) = integral
enddo
enddo
@ -121,9 +127,15 @@ double precision function get_two_e_integral(i,j,k,l,map)
get_two_e_integral = dble(tmp)
else
ii_8 = int(l,8)-mo_integrals_cache_min_8
IRP_IF WITHOUT_SHIFTRL
ii_8 = ior( ishft(ii_8,7), int(k,8)-mo_integrals_cache_min_8)
ii_8 = ior( ishft(ii_8,7), int(j,8)-mo_integrals_cache_min_8)
ii_8 = ior( ishft(ii_8,7), int(i,8)-mo_integrals_cache_min_8)
IRP_ELSE
ii_8 = ior( shiftl(ii_8,7), int(k,8)-mo_integrals_cache_min_8)
ii_8 = ior( shiftl(ii_8,7), int(j,8)-mo_integrals_cache_min_8)
ii_8 = ior( shiftl(ii_8,7), int(i,8)-mo_integrals_cache_min_8)
IRP_ENDIF
get_two_e_integral = mo_integrals_cache(ii_8)
endif
end
@ -179,8 +191,13 @@ subroutine get_mo_two_e_integrals(j,k,l,sze,out_val,map)
ii0 = ior(ii0, j-mo_integrals_cache_min)
ii0_8 = int(l,8)-mo_integrals_cache_min_8
IRP_IF WITHOUT_SHIFTRL
ii0_8 = ior( ishft(ii0_8,7), int(k,8)-mo_integrals_cache_min_8)
ii0_8 = ior( ishft(ii0_8,7), int(j,8)-mo_integrals_cache_min_8)
IRP_ELSE
ii0_8 = ior( shiftl(ii0_8,7), int(k,8)-mo_integrals_cache_min_8)
ii0_8 = ior( shiftl(ii0_8,7), int(j,8)-mo_integrals_cache_min_8)
IRP_ENDIF
q = min(j,l)
s = max(j,l)
@ -194,7 +211,11 @@ IRP_ENDIF
if (banned_excitation(i,k)) cycle
ii = ior(ii0, i-mo_integrals_cache_min)
if (iand(ii, -128) == 0) then
IRP_IF WITHOUT_SHIFTRL
ii_8 = ior( ishft(ii0_8,7), int(i,8)-mo_integrals_cache_min_8)
IRP_ELSE
ii_8 = ior( shiftl(ii0_8,7), int(i,8)-mo_integrals_cache_min_8)
IRP_ENDIF
out_val(i) = mo_integrals_cache(ii_8)
else
p = min(i,k)

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

@ -614,7 +614,7 @@ double precision function rint1(n,rho)
rho_tmp = 1.d0
do k=1,20
rho_tmp = -rho_tmp*rho
diff=rho_tmp*fact_inv(k)*inv_int(shiftl(k+n,1)+1)
diff=rho_tmp*fact_inv(k)*inv_int(ishft(k+n,1)+1)
rint1=rint1+diff
if (dabs(diff) > eps) then
cycle

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

@ -140,7 +140,11 @@ IRP_ENDIF
endif
endif
i=l
IRP_IF WITHOUT_SHIFTRL
j = ishft(l,1)
IRP_ELSE
j = shiftl(l,1)
IRP_ENDIF
do while (j<k)
if ( x(j) < x(j+1) ) then
j=j+1
@ -149,7 +153,11 @@ IRP_ENDIF
x(i) = x(j)
iorder(i) = iorder(j)
i = j
IRP_IF WITHOUT_SHIFTRL
j = ishft(j,1)
IRP_ELSE
j = shiftl(j,1)
IRP_ENDIF
else
j = k+1
endif
@ -159,7 +167,11 @@ IRP_ENDIF
x(i) = x(j)
iorder(i) = iorder(j)
i = j
IRP_IF WITHOUT_SHIFTRL
j = ishft(j,1)
IRP_ELSE
j = shiftl(j,1)
IRP_ENDIF
else
j = k+1
endif
@ -205,7 +217,11 @@ IRP_ENDIF
endif
endif
i=l
IRP_IF WITHOUT_SHIFTRL
j = ishft(l,1)
IRP_ELSE
j = shiftl(l,1)
IRP_ENDIF
do while (j<k)
if ( x(j) < x(j+1) ) then
j=j+1
@ -214,7 +230,11 @@ IRP_ENDIF
x(i) = x(j)
iorder(i) = iorder(j)
i = j
IRP_IF WITHOUT_SHIFTRL
j = ishft(j,1)
IRP_ELSE
j = shiftl(j,1)
IRP_ENDIF
else
j = k+1
endif
@ -224,7 +244,11 @@ IRP_ENDIF
x(i) = x(j)
iorder(i) = iorder(j)
i = j
IRP_IF WITHOUT_SHIFTRL
j = ishft(j,1)
IRP_ELSE
j = shiftl(j,1)
IRP_ENDIF
else
j = k+1
endif