mirror of
https://github.com/LCPQ/quantum_package
synced 2024-08-29 23:53:42 +02:00
176 lines
4.5 KiB
Fortran
176 lines
4.5 KiB
Fortran
|
|
subroutine filter_connected(key1,key2,Nint,sze,idx)
|
|
use bitmasks
|
|
implicit none
|
|
BEGIN_DOC
|
|
! Filters out the determinants that are not connected by H
|
|
END_DOC
|
|
integer, intent(in) :: Nint, sze
|
|
integer(bit_kind), intent(in) :: key1(Nint,2,sze)
|
|
integer(bit_kind), intent(in) :: key2(Nint,2)
|
|
integer, intent(out) :: idx(0:sze)
|
|
|
|
integer :: i,j,l
|
|
integer :: degree_x2
|
|
|
|
ASSERT (Nint > 0)
|
|
ASSERT (sze >= 0)
|
|
|
|
l=1
|
|
|
|
if (Nint==1) then
|
|
|
|
!DIR$ LOOP COUNT (1000)
|
|
do i=1,sze
|
|
degree_x2 = popcnt( xor( key1(1,1,i), key2(1,1))) &
|
|
+ popcnt( xor( key1(1,2,i), key2(1,2)))
|
|
if (degree_x2 < 5) then
|
|
idx(l) = i
|
|
l = l+1
|
|
endif
|
|
enddo
|
|
|
|
else if (Nint==2) then
|
|
|
|
!DIR$ LOOP COUNT (1000)
|
|
do i=1,sze
|
|
degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + &
|
|
popcnt(xor( key1(2,1,i), key2(2,1))) + &
|
|
popcnt(xor( key1(1,2,i), key2(1,2))) + &
|
|
popcnt(xor( key1(2,2,i), key2(2,2)))
|
|
if (degree_x2 < 5) then
|
|
idx(l) = i
|
|
l = l+1
|
|
endif
|
|
enddo
|
|
|
|
else if (Nint==3) then
|
|
|
|
!DIR$ LOOP COUNT (1000)
|
|
do i=1,sze
|
|
degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + &
|
|
popcnt(xor( key1(1,2,i), key2(1,2))) + &
|
|
popcnt(xor( key1(2,1,i), key2(2,1))) + &
|
|
popcnt(xor( key1(2,2,i), key2(2,2))) + &
|
|
popcnt(xor( key1(3,1,i), key2(3,1))) + &
|
|
popcnt(xor( key1(3,2,i), key2(3,2)))
|
|
if (degree_x2 < 5) then
|
|
idx(l) = i
|
|
l = l+1
|
|
endif
|
|
enddo
|
|
|
|
else
|
|
|
|
!DIR$ LOOP COUNT (1000)
|
|
do i=1,sze
|
|
degree_x2 = 0
|
|
!DEC$ LOOP COUNT MIN(4)
|
|
do j=1,Nint
|
|
degree_x2 = degree_x2+ popcnt(xor( key1(j,1,i), key2(j,1))) +&
|
|
popcnt(xor( key1(j,2,i), key2(j,2)))
|
|
if (degree_x2 > 4) then
|
|
exit
|
|
endif
|
|
enddo
|
|
if (degree_x2 <= 5) then
|
|
idx(l) = i
|
|
l = l+1
|
|
endif
|
|
enddo
|
|
|
|
endif
|
|
idx(0) = l-1
|
|
end
|
|
|
|
subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx)
|
|
use bitmasks
|
|
implicit none
|
|
integer, intent(in) :: Nint, sze
|
|
integer(bit_kind), intent(in) :: key1(Nint,2,sze)
|
|
integer(bit_kind), intent(in) :: key2(Nint,2)
|
|
integer, intent(out) :: idx(0:sze)
|
|
|
|
integer :: i,l
|
|
integer :: degree_x2
|
|
|
|
ASSERT (Nint > 0)
|
|
ASSERT (Nint == N_int)
|
|
ASSERT (sze > 0)
|
|
|
|
l=1
|
|
|
|
if (Nint==1) then
|
|
|
|
!DIR$ LOOP COUNT (1000)
|
|
do i=1,sze
|
|
degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + &
|
|
popcnt(xor( key1(1,2,i), key2(1,2)))
|
|
if (degree_x2 < 5) then
|
|
if(degree_x2 .ne. 0)then
|
|
idx(l) = i
|
|
l = l+1
|
|
endif
|
|
endif
|
|
enddo
|
|
|
|
else if (Nint==2) then
|
|
|
|
!DIR$ LOOP COUNT (1000)
|
|
do i=1,sze
|
|
degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + &
|
|
popcnt(xor( key1(2,1,i), key2(2,1))) + &
|
|
popcnt(xor( key1(1,2,i), key2(1,2))) + &
|
|
popcnt(xor( key1(2,2,i), key2(2,2)))
|
|
if (degree_x2 < 5) then
|
|
if(degree_x2 .ne. 0)then
|
|
idx(l) = i
|
|
l = l+1
|
|
endif
|
|
endif
|
|
enddo
|
|
|
|
else if (Nint==3) then
|
|
|
|
!DIR$ LOOP COUNT (1000)
|
|
do i=1,sze
|
|
degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + &
|
|
popcnt(xor( key1(1,2,i), key2(1,2))) + &
|
|
popcnt(xor( key1(2,1,i), key2(2,1))) + &
|
|
popcnt(xor( key1(2,2,i), key2(2,2))) + &
|
|
popcnt(xor( key1(3,1,i), key2(3,1))) + &
|
|
popcnt(xor( key1(3,2,i), key2(3,2)))
|
|
if (degree_x2 < 5) then
|
|
if(degree_x2 .ne. 0)then
|
|
idx(l) = i
|
|
l = l+1
|
|
endif
|
|
endif
|
|
enddo
|
|
|
|
else
|
|
|
|
!DIR$ LOOP COUNT (1000)
|
|
do i=1,sze
|
|
degree_x2 = 0
|
|
!DEC$ LOOP COUNT MIN(4)
|
|
do l=1,Nint
|
|
degree_x2 = degree_x2+ popcnt(xor( key1(l,1,i), key2(l,1))) +&
|
|
popcnt(xor( key1(l,2,i), key2(l,2)))
|
|
if (degree_x2 > 4) then
|
|
exit
|
|
endif
|
|
enddo
|
|
if (degree_x2 <= 5) then
|
|
if(degree_x2 .ne. 0)then
|
|
idx(l) = i
|
|
l = l+1
|
|
endif
|
|
endif
|
|
enddo
|
|
|
|
endif
|
|
idx(0) = l-1
|
|
end
|
|
|