mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-12-25 13:03:28 +01:00
Guarded trailz with IRP_IF
This commit is contained in:
parent
46d9f3c847
commit
e2565bab76
@ -97,7 +97,11 @@ subroutine configuration_to_dets(o,d,sze,n_alpha,Nint)
|
|||||||
do while(v /= 0_bit_kind)
|
do while(v /= 0_bit_kind)
|
||||||
n = n+1
|
n = n+1
|
||||||
iint(n) = i
|
iint(n) = i
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
ipos(n) = popcnt(ieor(v,v-1))-1
|
||||||
|
IRP_ELSE
|
||||||
ipos(n) = trailz(v)
|
ipos(n) = trailz(v)
|
||||||
|
IRP_ENDIF
|
||||||
v = iand(v,v-1)
|
v = iand(v,v-1)
|
||||||
enddo
|
enddo
|
||||||
n_alpha_in_single = n_alpha_in_single - popcnt( o(i,2) )
|
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
|
v_prev = v
|
||||||
t = ior(v,v-1)
|
t = ior(v,v-1)
|
||||||
tt = t+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) )
|
v = ior(tt, shiftr( and(not(t),tt) - 1, trailz(v)+1) )
|
||||||
|
IRP_ENDIF
|
||||||
|
|
||||||
! Find what has changed between v_prev and v
|
! Find what has changed between v_prev and v
|
||||||
diff = ieor(v,v_prev)
|
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
|
! Swap bits only where they have changed from v_prev to v
|
||||||
do while (diff /= 0_bit_kind)
|
do while (diff /= 0_bit_kind)
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
k = popcnt(ieor(diff,diff-1))
|
||||||
|
IRP_ELSE
|
||||||
k = trailz(diff)+1
|
k = trailz(diff)+1
|
||||||
|
IRP_ENDIF
|
||||||
if (btest(v,k-1)) then
|
if (btest(v,k-1)) then
|
||||||
d(iint(k),1,i) = ibset( d(iint(k),1,i), ipos(k) )
|
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) )
|
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
|
v_prev = v
|
||||||
t = ior(v,v-1)
|
t = ior(v,v-1)
|
||||||
tt = t+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) )
|
v = ior(tt, shiftr( and(not(t),tt) - 1, trailz(v)+1) )
|
||||||
|
IRP_ENDIF
|
||||||
|
|
||||||
! Find what has changed between v_prev and v
|
! Find what has changed between v_prev and v
|
||||||
diff = ieor(v,v_prev)
|
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
|
! Swap bits only where they have changed from v_prev to v
|
||||||
do while (diff /= 0_bit_kind)
|
do while (diff /= 0_bit_kind)
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
k = popcnt(ieor(diff,diff-1))
|
||||||
|
IRP_ELSE
|
||||||
k = trailz(diff)+1
|
k = trailz(diff)+1
|
||||||
|
IRP_ENDIF
|
||||||
if (btest(v,k-1)) then
|
if (btest(v,k-1)) then
|
||||||
d(iint(k),1,i) = ibset( d(iint(k),1,i), ipos(k) )
|
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) )
|
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)
|
do while(v /= 0_bit_kind)
|
||||||
n = n+1
|
n = n+1
|
||||||
iint(n) = i
|
iint(n) = i
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
ipos(n) = popcnt(ieor(v,v-1))-1
|
||||||
|
IRP_ELSE
|
||||||
ipos(n) = trailz(v)
|
ipos(n) = trailz(v)
|
||||||
|
IRP_ENDIF
|
||||||
v = iand(v,v-1)
|
v = iand(v,v-1)
|
||||||
enddo
|
enddo
|
||||||
n_alpha_in_single = n_alpha_in_single - popcnt( o(i,2) )
|
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
|
v_prev = v
|
||||||
t = ior(v,v-1)
|
t = ior(v,v-1)
|
||||||
tt = t+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) )
|
v = ior(tt, shiftr( and(not(t),tt) - 1, trailz(v)+1) )
|
||||||
|
IRP_ENDIF
|
||||||
|
|
||||||
! Find what has changed between v_prev and v
|
! Find what has changed between v_prev and v
|
||||||
diff = ieor(v,v_prev)
|
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
|
! Swap bits only where they have changed from v_prev to v
|
||||||
do while (diff /= 0_bit_kind)
|
do while (diff /= 0_bit_kind)
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
k = popcnt(ieor(diff,diff-1))
|
||||||
|
IRP_ELSE
|
||||||
k = trailz(diff)+1
|
k = trailz(diff)+1
|
||||||
|
IRP_ENDIF
|
||||||
if (btest(v,k-1)) then
|
if (btest(v,k-1)) then
|
||||||
d(iint(k),1,i) = ibset( d(iint(k),1,i), ipos(k) )
|
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) )
|
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
|
v_prev = v
|
||||||
t = ior(v,v-1)
|
t = ior(v,v-1)
|
||||||
tt = t+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) )
|
v = ior(tt, shiftr( and(not(t),tt) - 1, trailz(v)+1) )
|
||||||
|
IRP_ENDIF
|
||||||
|
|
||||||
! Find what has changed between v_prev and v
|
! Find what has changed between v_prev and v
|
||||||
diff = ieor(v,v_prev)
|
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
|
! Swap bits only where they have changed from v_prev to v
|
||||||
do while (diff /= 0_bit_kind)
|
do while (diff /= 0_bit_kind)
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
k = popcnt(ieor(diff,diff-1))
|
||||||
|
IRP_ELSE
|
||||||
k = trailz(diff)+1
|
k = trailz(diff)+1
|
||||||
|
IRP_ENDIF
|
||||||
if (btest(v,k-1)) then
|
if (btest(v,k-1)) then
|
||||||
d(iint(k),1,i) = ibset( d(iint(k),1,i), ipos(k) )
|
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) )
|
d(iint(k),2,i) = ibclr( d(iint(k),2,i), ipos(k) )
|
||||||
|
@ -98,7 +98,11 @@ subroutine get_phase_qp_to_cfg(Ialpha, Ibeta, phaseout)
|
|||||||
|
|
||||||
do while(detb(k) /= 0_bit_kind)
|
do while(detb(k) /= 0_bit_kind)
|
||||||
! Find the lowest beta electron and clear it
|
! 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))
|
ipos = trailz(detb(k))
|
||||||
|
IRP_ENDIF
|
||||||
detb(k) = ibclr(detb(k),ipos)
|
detb(k) = ibclr(detb(k),ipos)
|
||||||
|
|
||||||
! Create a mask will all MOs higher than the beta electron
|
! Create a mask will all MOs higher than the beta electron
|
||||||
|
@ -206,7 +206,11 @@ subroutine get_double_excitation(det1,det2,exc,phase,Nint)
|
|||||||
particle = iand(tmp, det2(l,ispin))
|
particle = iand(tmp, det2(l,ispin))
|
||||||
hole = iand(tmp, det1(l,ispin))
|
hole = iand(tmp, det1(l,ispin))
|
||||||
do while (particle /= 0_bit_kind)
|
do while (particle /= 0_bit_kind)
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
tz = popcnt(ieor(particle,particle-1))-1
|
||||||
|
IRP_ELSE
|
||||||
tz = trailz(particle)
|
tz = trailz(particle)
|
||||||
|
IRP_ENDIF
|
||||||
idx_particle = idx_particle + 1
|
idx_particle = idx_particle + 1
|
||||||
exc(0,2,ispin) = exc(0,2,ispin) + 1
|
exc(0,2,ispin) = exc(0,2,ispin) + 1
|
||||||
exc(idx_particle,2,ispin) = tz+ishift
|
exc(idx_particle,2,ispin) = tz+ishift
|
||||||
@ -216,7 +220,11 @@ subroutine get_double_excitation(det1,det2,exc,phase,Nint)
|
|||||||
exit
|
exit
|
||||||
endif
|
endif
|
||||||
do while (hole /= 0_bit_kind)
|
do while (hole /= 0_bit_kind)
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
tz = popcnt(ieor(hole,hole-1))-1
|
||||||
|
IRP_ELSE
|
||||||
tz = trailz(hole)
|
tz = trailz(hole)
|
||||||
|
IRP_ENDIF
|
||||||
idx_hole = idx_hole + 1
|
idx_hole = idx_hole + 1
|
||||||
exc(0,1,ispin) = exc(0,1,ispin) + 1
|
exc(0,1,ispin) = exc(0,1,ispin) + 1
|
||||||
exc(idx_hole,1,ispin) = tz+ishift
|
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))
|
particle = iand(tmp, det2(l,ispin))
|
||||||
hole = iand(tmp, det1(l,ispin))
|
hole = iand(tmp, det1(l,ispin))
|
||||||
if (particle /= 0_bit_kind) then
|
if (particle /= 0_bit_kind) then
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
tz = popcnt(ieor(particle,particle-1))-1
|
||||||
|
IRP_ELSE
|
||||||
tz = trailz(particle)
|
tz = trailz(particle)
|
||||||
|
IRP_ENDIF
|
||||||
exc(0,2,ispin) = 1
|
exc(0,2,ispin) = 1
|
||||||
exc(1,2,ispin) = tz+ishift
|
exc(1,2,ispin) = tz+ishift
|
||||||
endif
|
endif
|
||||||
if (hole /= 0_bit_kind) then
|
if (hole /= 0_bit_kind) then
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
tz = popcnt(ieor(hole,hole-1))-1
|
||||||
|
IRP_ELSE
|
||||||
tz = trailz(hole)
|
tz = trailz(hole)
|
||||||
|
IRP_ENDIF
|
||||||
exc(0,1,ispin) = 1
|
exc(0,1,ispin) = 1
|
||||||
exc(1,1,ispin) = tz+ishift
|
exc(1,1,ispin) = tz+ishift
|
||||||
endif
|
endif
|
||||||
@ -445,14 +461,22 @@ subroutine bitstring_to_list_ab( string, list, n_elements, Nint)
|
|||||||
do i=1,Nint
|
do i=1,Nint
|
||||||
l = string(i,1)
|
l = string(i,1)
|
||||||
do while (l /= 0_bit_kind)
|
do while (l /= 0_bit_kind)
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
j = popcnt(ieor(l,l-1))-1
|
||||||
|
IRP_ELSE
|
||||||
j = trailz(l)
|
j = trailz(l)
|
||||||
|
IRP_ENDIF
|
||||||
n_elements(1) = n_elements(1)+1
|
n_elements(1) = n_elements(1)+1
|
||||||
l = ibclr(l,j)
|
l = ibclr(l,j)
|
||||||
list(n_elements(1),1) = ishift+j
|
list(n_elements(1),1) = ishift+j
|
||||||
enddo
|
enddo
|
||||||
l = string(i,2)
|
l = string(i,2)
|
||||||
do while (l /= 0_bit_kind)
|
do while (l /= 0_bit_kind)
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
j = popcnt(ieor(l,l-1))-1
|
||||||
|
IRP_ELSE
|
||||||
j = trailz(l)
|
j = trailz(l)
|
||||||
|
IRP_ENDIF
|
||||||
n_elements(2) = n_elements(2)+1
|
n_elements(2) = n_elements(2)+1
|
||||||
l = ibclr(l,j)
|
l = ibclr(l,j)
|
||||||
list(n_elements(2),2) = ishift+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))
|
particle = iand(tmp, det2(l))
|
||||||
hole = iand(tmp, det1(l))
|
hole = iand(tmp, det1(l))
|
||||||
do while (particle /= 0_bit_kind)
|
do while (particle /= 0_bit_kind)
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
tz = popcnt(ieor(particle,particle-1))-1
|
||||||
|
IRP_ELSE
|
||||||
tz = trailz(particle)
|
tz = trailz(particle)
|
||||||
|
IRP_ENDIF
|
||||||
idx_particle = idx_particle + 1
|
idx_particle = idx_particle + 1
|
||||||
exc(0,2) = exc(0,2) + 1
|
exc(0,2) = exc(0,2) + 1
|
||||||
exc(idx_particle,2) = tz+ishift
|
exc(idx_particle,2) = tz+ishift
|
||||||
@ -2016,7 +2044,11 @@ subroutine get_double_excitation_spin(det1,det2,exc,phase,Nint)
|
|||||||
exit
|
exit
|
||||||
endif
|
endif
|
||||||
do while (hole /= 0_bit_kind)
|
do while (hole /= 0_bit_kind)
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
tz = popcnt(ieor(hole,hole-1))-1
|
||||||
|
IRP_ELSE
|
||||||
tz = trailz(hole)
|
tz = trailz(hole)
|
||||||
|
IRP_ENDIF
|
||||||
idx_hole = idx_hole + 1
|
idx_hole = idx_hole + 1
|
||||||
exc(0,1) = exc(0,1) + 1
|
exc(0,1) = exc(0,1) + 1
|
||||||
exc(idx_hole,1) = tz+ishift
|
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))
|
particle = iand(tmp, det2(l))
|
||||||
hole = iand(tmp, det1(l))
|
hole = iand(tmp, det1(l))
|
||||||
if (particle /= 0_bit_kind) then
|
if (particle /= 0_bit_kind) then
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
tz = popcnt(ieor(particle,particle-1))-1
|
||||||
|
IRP_ELSE
|
||||||
tz = trailz(particle)
|
tz = trailz(particle)
|
||||||
|
IRP_ENDIF
|
||||||
exc(0,2) = 1
|
exc(0,2) = 1
|
||||||
exc(1,2) = tz+ishift
|
exc(1,2) = tz+ishift
|
||||||
endif
|
endif
|
||||||
if (hole /= 0_bit_kind) then
|
if (hole /= 0_bit_kind) then
|
||||||
|
IRP_IF WITHOUT_TRAILZ
|
||||||
|
tz = popcnt(ieor(hole,hole-1))-1
|
||||||
|
IRP_ELSE
|
||||||
tz = trailz(hole)
|
tz = trailz(hole)
|
||||||
|
IRP_ENDIF
|
||||||
exc(0,1) = 1
|
exc(0,1) = 1
|
||||||
exc(1,1) = tz+ishift
|
exc(1,1) = tz+ishift
|
||||||
endif
|
endif
|
||||||
|
Loading…
Reference in New Issue
Block a user