LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-11-07 14:03:37 +01:00
Code Releases Activity

Guarded trailz with IRP_IF

Browse Source
This commit is contained in:
Anthony Scemama 2021-03-20 17:43:32 +01:00
parent 46d9f3c847
commit e2565bab76
3 changed files with 84 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -97,7 +97,11 @@ subroutine configuration_to_dets(o,d,sze,n_alpha,Nint)
do while(v /= 0_bit_kind)
n = n+1
iint(n) = i
IRP_IF WITHOUT_TRAILZ
ipos(n) = popcnt(ieor(v,v-1))-1
IRP_ELSE
ipos(n) = trailz(v)
IRP_ENDIF
v = iand(v,v-1)
enddo
n_alpha_in_single = n_alpha_in_single - popcnt( o(i,2) )
@ -130,7 +134,11 @@ subroutine configuration_to_dets(o,d,sze,n_alpha,Nint)
v_prev = v
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))) )
IRP_ELSE
v = ior(tt, shiftr( and(not(t),tt) - 1, trailz(v)+1) )
IRP_ENDIF
! Find what has changed between v_prev and v
diff = ieor(v,v_prev)
@ -141,7 +149,11 @@ subroutine configuration_to_dets(o,d,sze,n_alpha,Nint)
! Swap bits only where they have changed from v_prev to v
do while (diff /= 0_bit_kind)
IRP_IF WITHOUT_TRAILZ
k = popcnt(ieor(diff,diff-1))
IRP_ELSE
k = trailz(diff)+1
IRP_ENDIF
if (btest(v,k-1)) then
d(iint(k),1,i) = ibset( d(iint(k),1,i), ipos(k) )
d(iint(k),2,i) = ibclr( d(iint(k),2,i), ipos(k) )
@ -165,7 +177,11 @@ subroutine configuration_to_dets(o,d,sze,n_alpha,Nint)
v_prev = v
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))) )
IRP_ELSE
v = ior(tt, shiftr( and(not(t),tt) - 1, trailz(v)+1) )
IRP_ENDIF
! Find what has changed between v_prev and v
diff = ieor(v,v_prev)
@ -176,7 +192,11 @@ subroutine configuration_to_dets(o,d,sze,n_alpha,Nint)
! Swap bits only where they have changed from v_prev to v
do while (diff /= 0_bit_kind)
IRP_IF WITHOUT_TRAILZ
k = popcnt(ieor(diff,diff-1))
IRP_ELSE
k = trailz(diff)+1
IRP_ENDIF
if (btest(v,k-1)) then
d(iint(k),1,i) = ibset( d(iint(k),1,i), ipos(k) )
d(iint(k),2,i) = ibclr( d(iint(k),2,i), ipos(k) )
@ -235,7 +255,11 @@ subroutine configuration_to_dets_tree_addressing(o,d,sze,n_alpha,Nint)
do while(v /= 0_bit_kind)
n = n+1
iint(n) = i
IRP_IF WITHOUT_TRAILZ
ipos(n) = popcnt(ieor(v,v-1))-1
IRP_ELSE
ipos(n) = trailz(v)
IRP_ENDIF
v = iand(v,v-1)
enddo
n_alpha_in_single = n_alpha_in_single - popcnt( o(i,2) )
@ -268,7 +292,11 @@ subroutine configuration_to_dets_tree_addressing(o,d,sze,n_alpha,Nint)
v_prev = v
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))) )
IRP_ELSE
v = ior(tt, shiftr( and(not(t),tt) - 1, trailz(v)+1) )
IRP_ENDIF
! Find what has changed between v_prev and v
diff = ieor(v,v_prev)
@ -279,7 +307,11 @@ subroutine configuration_to_dets_tree_addressing(o,d,sze,n_alpha,Nint)
! Swap bits only where they have changed from v_prev to v
do while (diff /= 0_bit_kind)
IRP_IF WITHOUT_TRAILZ
k = popcnt(ieor(diff,diff-1))
IRP_ELSE
k = trailz(diff)+1
IRP_ENDIF
if (btest(v,k-1)) then
d(iint(k),1,i) = ibset( d(iint(k),1,i), ipos(k) )
d(iint(k),2,i) = ibclr( d(iint(k),2,i), ipos(k) )
@ -303,7 +335,11 @@ subroutine configuration_to_dets_tree_addressing(o,d,sze,n_alpha,Nint)
v_prev = v
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))) )
IRP_ELSE
v = ior(tt, shiftr( and(not(t),tt) - 1, trailz(v)+1) )
IRP_ENDIF
! Find what has changed between v_prev and v
diff = ieor(v,v_prev)
@ -314,7 +350,11 @@ subroutine configuration_to_dets_tree_addressing(o,d,sze,n_alpha,Nint)
! Swap bits only where they have changed from v_prev to v
do while (diff /= 0_bit_kind)
IRP_IF WITHOUT_TRAILZ
k = popcnt(ieor(diff,diff-1))
IRP_ELSE
k = trailz(diff)+1
IRP_ENDIF
if (btest(v,k-1)) then
d(iint(k),1,i) = ibset( d(iint(k),1,i), ipos(k) )
d(iint(k),2,i) = ibclr( d(iint(k),2,i), ipos(k) )

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

@ -98,7 +98,11 @@ subroutine get_phase_qp_to_cfg(Ialpha, Ibeta, phaseout)
do while(detb(k) /= 0_bit_kind)
! Find the lowest beta electron and clear it
IRP_IF WITHOUT_TRAILZ
ipos = popcnt(ieor(detb(k),detb(k)-1))-1
IRP_ELSE
ipos = trailz(detb(k))
IRP_ENDIF
detb(k) = ibclr(detb(k),ipos)
! Create a mask will all MOs higher than the beta electron

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

@ -206,7 +206,11 @@ subroutine get_double_excitation(det1,det2,exc,phase,Nint)
particle = iand(tmp, det2(l,ispin))
hole = iand(tmp, det1(l,ispin))
do while (particle /= 0_bit_kind)
IRP_IF WITHOUT_TRAILZ
tz = popcnt(ieor(particle,particle-1))-1
IRP_ELSE
tz = trailz(particle)
IRP_ENDIF
idx_particle = idx_particle + 1
exc(0,2,ispin) = exc(0,2,ispin) + 1
exc(idx_particle,2,ispin) = tz+ishift
@ -216,7 +220,11 @@ subroutine get_double_excitation(det1,det2,exc,phase,Nint)
exit
endif
do while (hole /= 0_bit_kind)
IRP_IF WITHOUT_TRAILZ
tz = popcnt(ieor(hole,hole-1))-1
IRP_ELSE
tz = trailz(hole)
IRP_ENDIF
idx_hole = idx_hole + 1
exc(0,1,ispin) = exc(0,1,ispin) + 1
exc(idx_hole,1,ispin) = tz+ishift
@ -373,12 +381,20 @@ subroutine get_single_excitation(det1,det2,exc,phase,Nint)
particle = iand(tmp, det2(l,ispin))
hole = iand(tmp, det1(l,ispin))
if (particle /= 0_bit_kind) then
IRP_IF WITHOUT_TRAILZ
tz = popcnt(ieor(particle,particle-1))-1
IRP_ELSE
tz = trailz(particle)
IRP_ENDIF
exc(0,2,ispin) = 1
exc(1,2,ispin) = tz+ishift
endif
if (hole /= 0_bit_kind) then
IRP_IF WITHOUT_TRAILZ
tz = popcnt(ieor(hole,hole-1))-1
IRP_ELSE
tz = trailz(hole)
IRP_ENDIF
exc(0,1,ispin) = 1
exc(1,1,ispin) = tz+ishift
endif
@ -445,14 +461,22 @@ subroutine bitstring_to_list_ab( string, list, n_elements, Nint)
do i=1,Nint
l = string(i,1)
do while (l /= 0_bit_kind)
IRP_IF WITHOUT_TRAILZ
j = popcnt(ieor(l,l-1))-1
IRP_ELSE
j = trailz(l)
IRP_ENDIF
n_elements(1) = n_elements(1)+1
l = ibclr(l,j)
list(n_elements(1),1) = ishift+j
enddo
l = string(i,2)
do while (l /= 0_bit_kind)
IRP_IF WITHOUT_TRAILZ
j = popcnt(ieor(l,l-1))-1
IRP_ELSE
j = trailz(l)
IRP_ENDIF
n_elements(2) = n_elements(2)+1
l = ibclr(l,j)
list(n_elements(2),2) = ishift+j
@ -2006,7 +2030,11 @@ subroutine get_double_excitation_spin(det1,det2,exc,phase,Nint)
particle = iand(tmp, det2(l))
hole = iand(tmp, det1(l))
do while (particle /= 0_bit_kind)
IRP_IF WITHOUT_TRAILZ
tz = popcnt(ieor(particle,particle-1))-1
IRP_ELSE
tz = trailz(particle)
IRP_ENDIF
idx_particle = idx_particle + 1
exc(0,2) = exc(0,2) + 1
exc(idx_particle,2) = tz+ishift
@ -2016,7 +2044,11 @@ subroutine get_double_excitation_spin(det1,det2,exc,phase,Nint)
exit
endif
do while (hole /= 0_bit_kind)
IRP_IF WITHOUT_TRAILZ
tz = popcnt(ieor(hole,hole-1))-1
IRP_ELSE
tz = trailz(hole)
IRP_ENDIF
idx_hole = idx_hole + 1
exc(0,1) = exc(0,1) + 1
exc(idx_hole,1) = tz+ishift
@ -2133,12 +2165,20 @@ subroutine get_single_excitation_spin(det1,det2,exc,phase,Nint)
particle = iand(tmp, det2(l))
hole = iand(tmp, det1(l))
if (particle /= 0_bit_kind) then
IRP_IF WITHOUT_TRAILZ
tz = popcnt(ieor(particle,particle-1))-1
IRP_ELSE
tz = trailz(particle)
IRP_ENDIF
exc(0,2) = 1
exc(1,2) = tz+ishift
endif
if (hole /= 0_bit_kind) then
IRP_IF WITHOUT_TRAILZ
tz = popcnt(ieor(hole,hole-1))-1
IRP_ELSE
tz = trailz(hole)
IRP_ENDIF
exc(0,1) = 1
exc(1,1) = tz+ishift
endif