From ad6419f3af1d1106a329cdf757ff949b8eb15f0c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sat, 20 Mar 2021 18:20:58 +0100 Subject: [PATCH] Guarded shiftr with IRP_IF --- src/ao_one_e_ints/pot_ao_ints.irp.f | 24 ++++ src/ao_two_e_ints/map_integrals.irp.f | 24 ++++ src/ao_two_e_ints/two_e_integrals.irp.f | 12 ++ src/bitmask/bitmask_cas_routines.irp.f | 4 + src/bitmask/bitmasks_routines.irp.f | 4 + src/bitmask/find_hole.irp.f | 8 ++ src/bitmask/modify_bitmasks.irp.f | 12 ++ src/cipsi/pt2_stoch_routines.irp.f | 4 + src/cipsi/selection.irp.f | 20 +++ src/csf/configurations.irp.f | 24 +++- src/csf/connected_to_ref.irp.f | 5 + src/csf/create_excitations.irp.f | 16 +++ src/davidson/u0_h_u0.irp.f | 8 ++ src/davidson/u0_hs2_u0.irp.f | 8 ++ src/determinants/connected_to_ref.irp.f | 13 ++ src/determinants/create_excitations.irp.f | 12 ++ src/determinants/determinants.irp.f | 40 ++++++ src/determinants/h_apply.template.f | 53 +++++++ src/determinants/slater_rules.irp.f | 160 +++++++++++++++++++++- src/determinants/spindeterminants.irp.f | 16 +++ src/mo_two_e_ints/map_integrals.irp.f | 12 ++ src/mo_two_e_ints/mo_bi_integrals.irp.f | 36 +++++ src/utils/integration.irp.f | 12 ++ src/utils/sort.irp.f | 6 +- 24 files changed, 527 insertions(+), 6 deletions(-) diff --git a/src/ao_one_e_ints/pot_ao_ints.irp.f b/src/ao_one_e_ints/pot_ao_ints.irp.f index 4108ce71..89d5ab6c 100644 --- a/src/ao_one_e_ints/pot_ao_ints.irp.f +++ b/src/ao_one_e_ints/pot_ao_ints.irp.f @@ -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 diff --git a/src/ao_two_e_ints/map_integrals.irp.f b/src/ao_two_e_ints/map_integrals.irp.f index 55b2d5e2..4f171596 100644 --- a/src/ao_two_e_ints/map_integrals.irp.f +++ b/src/ao_two_e_ints/map_integrals.irp.f @@ -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 diff --git a/src/ao_two_e_ints/two_e_integrals.irp.f b/src/ao_two_e_ints/two_e_integrals.irp.f index 8032bd92..602f81f5 100644 --- a/src/ao_two_e_ints/two_e_integrals.irp.f +++ b/src/ao_two_e_ints/two_e_integrals.irp.f @@ -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 diff --git a/src/bitmask/bitmask_cas_routines.irp.f b/src/bitmask/bitmask_cas_routines.irp.f index 4c3faebe..b1ba0233 100644 --- a/src/bitmask/bitmask_cas_routines.irp.f +++ b/src/bitmask/bitmask_cas_routines.irp.f @@ -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 diff --git a/src/bitmask/bitmasks_routines.irp.f b/src/bitmask/bitmasks_routines.irp.f index c34d54dc..8ac82b38 100644 --- a/src/bitmask/bitmasks_routines.irp.f +++ b/src/bitmask/bitmasks_routines.irp.f @@ -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 diff --git a/src/bitmask/find_hole.irp.f b/src/bitmask/find_hole.irp.f index 4ef1ab4f..5b0f8112 100644 --- a/src/bitmask/find_hole.irp.f +++ b/src/bitmask/find_hole.irp.f @@ -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 diff --git a/src/bitmask/modify_bitmasks.irp.f b/src/bitmask/modify_bitmasks.irp.f index 834be6c8..7d685a99 100644 --- a/src/bitmask/modify_bitmasks.irp.f +++ b/src/bitmask/modify_bitmasks.irp.f @@ -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) diff --git a/src/cipsi/pt2_stoch_routines.irp.f b/src/cipsi/pt2_stoch_routines.irp.f index d0d7e511..d7fb946f 100644 --- a/src/cipsi/pt2_stoch_routines.irp.f +++ b/src/cipsi/pt2_stoch_routines.irp.f @@ -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 diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index 215f182a..62df93ee 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -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 diff --git a/src/csf/configurations.irp.f b/src/csf/configurations.irp.f index 2c0e586f..b63084a1 100644 --- a/src/csf/configurations.irp.f +++ b/src/csf/configurations.irp.f @@ -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 diff --git a/src/csf/connected_to_ref.irp.f b/src/csf/connected_to_ref.irp.f index c6488976..cdc4c1d9 100644 --- a/src/csf/connected_to_ref.irp.f +++ b/src/csf/connected_to_ref.irp.f @@ -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) diff --git a/src/csf/create_excitations.irp.f b/src/csf/create_excitations.irp.f index 651c4810..79b13bdf 100644 --- a/src/csf/create_excitations.irp.f +++ b/src/csf/create_excitations.irp.f @@ -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) diff --git a/src/davidson/u0_h_u0.irp.f b/src/davidson/u0_h_u0.irp.f index 3f5113db..136b11f8 100644 --- a/src/davidson/u0_h_u0.irp.f +++ b/src/davidson/u0_h_u0.irp.f @@ -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 diff --git a/src/davidson/u0_hs2_u0.irp.f b/src/davidson/u0_hs2_u0.irp.f index 96c266c2..d238a716 100644 --- a/src/davidson/u0_hs2_u0.irp.f +++ b/src/davidson/u0_hs2_u0.irp.f @@ -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 diff --git a/src/determinants/connected_to_ref.irp.f b/src/determinants/connected_to_ref.irp.f index 5c0cdd2a..0a5a3293 100644 --- a/src/determinants/connected_to_ref.irp.f +++ b/src/determinants/connected_to_ref.irp.f @@ -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 diff --git a/src/determinants/create_excitations.irp.f b/src/determinants/create_excitations.irp.f index a597116b..e62d80c2 100644 --- a/src/determinants/create_excitations.irp.f +++ b/src/determinants/create_excitations.irp.f @@ -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) diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index 2a6057de..1b7af56c 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -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) diff --git a/src/determinants/h_apply.template.f b/src/determinants/h_apply.template.f index a6f9dadd..bfe89cbd 100644 --- a/src/determinants/h_apply.template.f +++ b/src/determinants/h_apply.template.f @@ -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) diff --git a/src/determinants/slater_rules.irp.f b/src/determinants/slater_rules.irp.f index bb60f386..46a7efa6 100644 --- a/src/determinants/slater_rules.irp.f +++ b/src/determinants/slater_rules.irp.f @@ -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), & diff --git a/src/determinants/spindeterminants.irp.f b/src/determinants/spindeterminants.irp.f index 8ba405e0..7f7291ba 100644 --- a/src/determinants/spindeterminants.irp.f +++ b/src/determinants/spindeterminants.irp.f @@ -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 diff --git a/src/mo_two_e_ints/map_integrals.irp.f b/src/mo_two_e_ints/map_integrals.irp.f index 8756ee47..73dd417f 100644 --- a/src/mo_two_e_ints/map_integrals.irp.f +++ b/src/mo_two_e_ints/map_integrals.irp.f @@ -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) diff --git a/src/mo_two_e_ints/mo_bi_integrals.irp.f b/src/mo_two_e_ints/mo_bi_integrals.irp.f index b926d688..44463ff0 100644 --- a/src/mo_two_e_ints/mo_bi_integrals.irp.f +++ b/src/mo_two_e_ints/mo_bi_integrals.irp.f @@ -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) diff --git a/src/utils/integration.irp.f b/src/utils/integration.irp.f index c907e425..a16c4e88 100644 --- a/src/utils/integration.irp.f +++ b/src/utils/integration.irp.f @@ -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 diff --git a/src/utils/sort.irp.f b/src/utils/sort.irp.f index 2a655eed..1ac96cae 100644 --- a/src/utils/sort.irp.f +++ b/src/utils/sort.irp.f @@ -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