9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-07-27 21:07:23 +02:00

Working on obtain I for alpha.

This commit is contained in:
v1j4y 2022-12-10 11:36:12 +01:00
parent 0234e46e1b
commit 4b3b6300ef

View File

@ -315,86 +315,35 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI
!print *,"obt SOMO -> VMO" !print *,"obt SOMO -> VMO"
extyp = 3 extyp = 3
if(N_int .eq. 1) then if(N_int .eq. 1) then
IJsomo = IEOR(Isomo, Jsomo) IJsomo = IEOR(Isomo, Jsomo)
!IRP_IF WITHOUT_TRAILZ p = TRAILZ(IAND(Isomo,IJsomo)) + 1
! p = (popcnt(ieor( IAND(Isomo,IJsomo) , IAND(Isomo,IJsomo) -1))-1) + 1 IJsomo = IBCLR(IJsomo,p-1)
!IRP_ELSE q = TRAILZ(IJsomo) + 1
p = TRAILZ(IAND(Isomo,IJsomo)) + 1 !print *," p=",p," q=",q
!IRP_ENDIF !call get_single_excitation_cfg(Jcfg, Icfg, p, q, N_int)
IJsomo = IBCLR(IJsomo,p-1) else
!IRP_IF WITHOUT_TRAILZ ! Find p
! q = (popcnt(ieor(IJsomo,IJsomo-1))-1) + 1 do ii=1,N_int
!IRP_ELSE Isomo = Ialpha(ii,1)
q = TRAILZ(IJsomo) + 1 Jsomo = psi_configuration(ii,1,i)
!IRP_ENDIF IJsomo = IEOR(Isomo, Jsomo)
!print *," p=",p," q=",q if(popcnt(IAND(Isomo,IJsomo)) > 0)then
!call get_single_excitation_cfg(Jcfg, Icfg, p, q, N_int) p = TRAILZ(IAND(Isomo,IJsomo)) + 1 + ii * bit_kind_size
else EXIT
exc = 0 endif
do ii = 1,2 end do
ishift = 1-bit_kind_size ! Find q
do l=1,N_int do ii=1,N_int
ishift = ishift + bit_kind_size Isomo = Ialpha(ii,1)
if (Jcfg(l,ii) == Icfg(l,ii)) then Jsomo = psi_configuration(ii,1,i)
cycle IJsomo = IEOR(Isomo, Jsomo)
endif IJsomo = IBCLR(IJsomo,p-1)
tmp = xor( Jcfg(l,ii), Icfg(l,ii) ) if(popcnt(IJsomo) > 0)then
particle = iand(tmp, Icfg(l,ii)) q = TRAILZ(IJsomo) + 1 + ii * bit_kind_size
hole = iand(tmp, Jcfg(l,ii)) EXIT
if (particle /= 0_bit_kind) then endif
tz = trailz(particle) enddo
exc(0,2,ii) = 1 endif
exc(1,2,ii) = tz+ishift
!print *,"part ",tz+ishift, " ii=",ii, exc(1,2,2)
endif
if (hole /= 0_bit_kind) then
tz = trailz(hole)
exc(0,1,ii) = 1
exc(1,1,ii) = tz+ishift
!print *,"hole ",tz+ishift, " ii=",ii, exc(1,1,2)
endif
if ( iand(exc(0,1,ii),exc(0,2,ii)) /= 1) then ! exc(0,1,ii)/=1 and exc(0,2,ii) /= 1
cycle
endif
high = max(exc(1,1,ii), exc(1,2,ii))-1
low = min(exc(1,1,ii), exc(1,2,ii))
ASSERT (low >= 0)
ASSERT (high > 0)
k = shiftr(high,bit_kind_shift)+1
j = shiftr(low,bit_kind_shift)+1
m = iand(high,bit_kind_size-1)
n = iand(low,bit_kind_size-1)
if (j==k) then
nperm = nperm + popcnt(iand(Jcfg(j,ii), &
iand( shiftl(1_bit_kind,m)-1_bit_kind, &
not(shiftl(1_bit_kind,n))+1_bit_kind)) )
else
nperm = nperm + popcnt( &
iand(Jcfg(j,ii), &
iand(not(0_bit_kind), &
(not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) &
+ popcnt(iand(Jcfg(k,ii), &
(shiftl(1_bit_kind,m) - 1_bit_kind ) ))
do iii=j+1,k-1
nperm = nperm + popcnt(Jcfg(iii,ii))
end do
endif
! Set p and q
q = max(exc(1,1,1),exc(1,1,2))
p = max(exc(1,2,1),exc(1,2,2))
exit
enddo
enddo
endif
!assert ( p == pp) !assert ( p == pp)
!assert ( q == qq) !assert ( q == qq)
!print *," --- p=",p," q=",q !print *," --- p=",p," q=",q
@ -409,88 +358,35 @@ endif
!print *,"obt DOMO -> VMO" !print *,"obt DOMO -> VMO"
extyp = 2 extyp = 2
if(N_int.eq.1)then if(N_int.eq.1)then
!IRP_IF WITHOUT_TRAILZ p = TRAILZ(IEOR(Idomo,Jdomo)) + 1
! p = (popcnt(ieor( IEOR(Idomo,Jdomo),IEOR(Idomo,Jdomo) -1))-1) + 1 Isomo = IEOR(Isomo, Jsomo)
!IRP_ELSE Isomo = IBCLR(Isomo,p-1)
p = TRAILZ(IEOR(Idomo,Jdomo)) + 1 q = TRAILZ(Isomo) + 1
!IRP_ENDIF else
Isomo = IEOR(Isomo, Jsomo)
Isomo = IBCLR(Isomo,p-1)
!IRP_IF WITHOUT_TRAILZ
! q = (popcnt(ieor(Isomo,Isomo-1))-1) + 1
!IRP_ELSE
q = TRAILZ(Isomo) + 1
!IRP_ENDIF
else
exc=0
exc(0,1,1) = 0
exc(0,2,1) = 0
exc(0,1,2) = 0
exc(0,2,2) = 0
do ii = 1,2
ishift = 1-bit_kind_size
do l=1,N_int
ishift = ishift + bit_kind_size
if (Jcfg(l,ii) == Icfg(l,ii)) then
cycle
endif
tmp = xor( Jcfg(l,ii), Icfg(l,ii) )
particle = iand(tmp, Icfg(l,ii))
hole = iand(tmp, Jcfg(l,ii))
if (particle /= 0_bit_kind) then
tz = trailz(particle)
exc(0,2,ii) = 1
exc(1,2,ii) = tz+ishift
!print *,"part ",tz+ishift, " ii=",ii
endif
if (hole /= 0_bit_kind) then
tz = trailz(hole)
exc(0,1,ii) = 1
exc(1,1,ii) = tz+ishift
!print *,"hole ",tz+ishift, " ii=",ii
endif
if ( iand(exc(0,1,ii),exc(0,2,ii)) /= 1) then ! exc(0,1,ii)/=1 and exc(0,2,ii) /= 1 ! Find p
cycle do ii=1,N_int
endif Isomo = Ialpha(ii,1)
Jsomo = psi_configuration(ii,1,i)
high = max(exc(1,1,ii), exc(1,2,ii))-1 Idomo = Ialpha(ii,2)
low = min(exc(1,1,ii), exc(1,2,ii)) Jdomo = psi_configuration(ii,2,i)
if(popcnt(IEOR(Idomo,Jdomo)) > 0)then
ASSERT (low >= 0) p = TRAILZ(IEOR(Idomo,Jdomo)) + 1 + ii * bit_kind_size
ASSERT (high > 0) EXIT
endif
k = shiftr(high,bit_kind_shift)+1 end do
j = shiftr(low,bit_kind_shift)+1 ! Find q
m = iand(high,bit_kind_size-1) do ii=1,N_int
n = iand(low,bit_kind_size-1) Isomo = Ialpha(ii,1)
Jsomo = psi_configuration(ii,1,i)
if (j==k) then Isomo = IEOR(Isomo, Jsomo)
nperm = nperm + popcnt(iand(Jcfg(j,ii), & Isomo = IBCLR(Isomo,p-1)
iand( shiftl(1_bit_kind,m)-1_bit_kind, & if(popcnt(Isomo) > 0)then
not(shiftl(1_bit_kind,n))+1_bit_kind)) ) q = TRAILZ(Isomo) + 1 + ii * bit_kind_size
else EXIT
nperm = nperm + popcnt( & endif
iand(Jcfg(j,ii), & end do
iand(not(0_bit_kind), & endif
(not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) &
+ popcnt(iand(Jcfg(k,ii), &
(shiftl(1_bit_kind,m) - 1_bit_kind ) ))
do iii=j+1,k-1
nperm = nperm + popcnt(Jcfg(iii,ii))
end do
endif
! Set p and q
q = max(exc(1,1,1),exc(1,1,2))
p = max(exc(1,2,1),exc(1,2,2))
exit
enddo
enddo
endif
!assert ( p == pp) !assert ( p == pp)
!assert ( q == qq) !assert ( q == qq)
else else
@ -498,183 +394,75 @@ endif
!print *,"obt SOMO -> SOMO" !print *,"obt SOMO -> SOMO"
extyp = 1 extyp = 1
if(N_int.eq.1)then if(N_int.eq.1)then
!IRP_IF WITHOUT_TRAILZ q = TRAILZ(IEOR(Idomo,Jdomo)) + 1
! q = (popcnt(ieor( IEOR(Idomo,Jdomo), IEOR(Idomo,Jdomo)-1))-1) + 1 Isomo = IEOR(Isomo, Jsomo)
!IRP_ELSE Isomo = IBCLR(Isomo,q-1)
q = TRAILZ(IEOR(Idomo,Jdomo)) + 1 p = TRAILZ(Isomo) + 1
!IRP_ENDIF ! Check for Minimal alpha electrons (MS)
Isomo = IEOR(Isomo, Jsomo) !if(POPCNT(Isomo).lt.MS)then
Isomo = IBCLR(Isomo,q-1) ! cycle
!IRP_IF WITHOUT_TRAILZ !endif
! p = (popcnt(ieor(Isomo,Isomo-1))-1) + 1 else
!IRP_ELSE ! Find p
p = TRAILZ(Isomo) + 1 do ii=1,N_int
!IRP_ENDIF Isomo = Ialpha(ii,1)
! Check for Minimal alpha electrons (MS) Jsomo = psi_configuration(ii,1,i)
!if(POPCNT(Isomo).lt.MS)then Idomo = Ialpha(ii,2)
! cycle Jdomo = psi_configuration(ii,2,i)
!endif if(popcnt(IEOR(Idomo,Jdomo)) > 0)then
else q = TRAILZ(IEOR(Idomo,Jdomo)) + 1 + ii * bit_kind_size
exc=0 EXIT
exc(0,1,1) = 0 endif
exc(0,2,1) = 0 enddo
exc(0,1,2) = 0 ! Find q
exc(0,2,2) = 0 do ii=1,N_int
do ii = 1,2 Isomo = Ialpha(ii,1)
ishift = 1-bit_kind_size Jsomo = psi_configuration(ii,1,i)
do l=1,N_int Isomo = IEOR(Isomo, Jsomo)
ishift = ishift + bit_kind_size Isomo = IBCLR(Isomo,q-1)
if (Jcfg(l,ii) == Icfg(l,ii)) then if(popcnt(Isomo) > 0)then
cycle p = TRAILZ(Isomo) + 1 + ii * bit_kind_size
endif EXIT
tmp = xor( Jcfg(l,ii), Icfg(l,ii) ) endif
particle = iand(tmp, Icfg(l,ii)) enddo
hole = iand(tmp, Jcfg(l,ii)) endif
if (particle /= 0_bit_kind) then
tz = trailz(particle)
exc(0,2,ii) = 1
exc(1,2,ii) = tz+ishift
!print *,"part ",tz+ishift, " ii=",ii
endif
if (hole /= 0_bit_kind) then
tz = trailz(hole)
exc(0,1,ii) = 1
exc(1,1,ii) = tz+ishift
!print *,"hole ",tz+ishift, " ii=",ii
endif
if ( iand(exc(0,1,ii),exc(0,2,ii)) /= 1) then ! exc(0,1,ii)/=1 and exc(0,2,ii) /= 1
cycle
endif
high = max(exc(1,1,ii), exc(1,2,ii))-1
low = min(exc(1,1,ii), exc(1,2,ii))
ASSERT (low >= 0)
ASSERT (high > 0)
k = shiftr(high,bit_kind_shift)+1
j = shiftr(low,bit_kind_shift)+1
m = iand(high,bit_kind_size-1)
n = iand(low,bit_kind_size-1)
if (j==k) then
nperm = nperm + popcnt(iand(Jcfg(j,ii), &
iand( shiftl(1_bit_kind,m)-1_bit_kind, &
not(shiftl(1_bit_kind,n))+1_bit_kind)) )
else
nperm = nperm + popcnt( &
iand(Jcfg(j,ii), &
iand(not(0_bit_kind), &
(not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) &
+ popcnt(iand(Jcfg(k,ii), &
(shiftl(1_bit_kind,m) - 1_bit_kind ) ))
do iii=j+1,k-1
nperm = nperm + popcnt(Jcfg(iii,ii))
end do
endif
! Set p and q
q = max(exc(1,1,1),exc(1,1,2))
p = max(exc(1,2,1),exc(1,2,2))
exit
enddo
enddo
endif
!assert ( p == pp) !assert ( p == pp)
!assert ( q == qq) !assert ( q == qq)
end if endif
case (2) case (2)
! DOMO -> SOMO ! DOMO -> SOMO
!print *,"obt DOMO -> SOMO" !print *,"obt DOMO -> SOMO"
extyp = 4 extyp = 4
if(N_int.eq.1)then if(N_int.eq.1)then
IJsomo = IEOR(Isomo, Jsomo) IJsomo = IEOR(Isomo, Jsomo)
!IRP_IF WITHOUT_TRAILZ p = TRAILZ(IAND(Jsomo,IJsomo)) + 1
! p = (popcnt(ieor( IAND(Jsomo,IJsomo), IAND(Jsomo,IJsomo)-1))-1) + 1 IJsomo = IBCLR(IJsomo,p-1)
!IRP_ELSE q = TRAILZ(IJsomo) + 1
p = TRAILZ(IAND(Jsomo,IJsomo)) + 1 else
!IRP_ENDIF ! Find p
IJsomo = IBCLR(IJsomo,p-1) do ii=1,N_int
!IRP_IF WITHOUT_TRAILZ Isomo = Ialpha(ii,1)
! q = (popcnt(ieor( IJsomo , IJsomo -1))-1) + 1 Jsomo = psi_configuration(ii,1,i)
!IRP_ELSE Idomo = Ialpha(ii,2)
q = TRAILZ(IJsomo) + 1 Jdomo = psi_configuration(ii,2,i)
!IRP_ENDIF IJsomo = IEOR(Isomo, Jsomo)
if(popcnt(IAND(Jsomo,IJsomo)) > 0)then
else p = TRAILZ(IAND(Jsomo,IJsomo)) + 1 + ii * bit_kind_size
exc=0 EXIT
exc(0,1,1) = 0 endif
exc(0,2,1) = 0 enddo
exc(0,1,2) = 0 ! Find q
exc(0,2,2) = 0 do ii=1,N_int
do ii = 1,2 Isomo = Ialpha(ii,1)
ishift = 1-bit_kind_size Jsomo = psi_configuration(ii,1,i)
do l=1,N_int IJsomo = IEOR(Isomo, Jsomo)
ishift = ishift + bit_kind_size IJsomo = IBCLR(IJsomo,p-1)
if (Jcfg(l,ii) == Icfg(l,ii)) then if(popcnt(IJsomo) > 0)then
cycle q = TRAILZ(IJsomo) + 1 + ii * bit_kind_size
endif EXIT
tmp = xor( Jcfg(l,ii), Icfg(l,ii) ) endif
particle = iand(tmp, Icfg(l,ii)) enddo
hole = iand(tmp, Jcfg(l,ii)) endif
if (particle /= 0_bit_kind) then
tz = trailz(particle)
exc(0,2,ii) = 1
exc(1,2,ii) = tz+ishift
!print *,"part ",tz+ishift, " ii=",ii
endif
if (hole /= 0_bit_kind) then
tz = trailz(hole)
exc(0,1,ii) = 1
exc(1,1,ii) = tz+ishift
!print *,"hole ",tz+ishift, " ii=",ii
endif
if ( iand(exc(0,1,ii),exc(0,2,ii)) /= 1) then ! exc(0,1,ii)/=1 and exc(0,2,ii) /= 1
cycle
endif
high = max(exc(1,1,ii), exc(1,2,ii))-1
low = min(exc(1,1,ii), exc(1,2,ii))
ASSERT (low >= 0)
ASSERT (high > 0)
k = shiftr(high,bit_kind_shift)+1
j = shiftr(low,bit_kind_shift)+1
m = iand(high,bit_kind_size-1)
n = iand(low,bit_kind_size-1)
if (j==k) then
nperm = nperm + popcnt(iand(Jcfg(j,ii), &
iand( shiftl(1_bit_kind,m)-1_bit_kind, &
not(shiftl(1_bit_kind,n))+1_bit_kind)) )
else
nperm = nperm + popcnt( &
iand(Jcfg(j,ii), &
iand(not(0_bit_kind), &
(not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) &
+ popcnt(iand(Jcfg(k,ii), &
(shiftl(1_bit_kind,m) - 1_bit_kind ) ))
do iii=j+1,k-1
nperm = nperm + popcnt(Jcfg(iii,ii))
end do
endif
! Set p and q
q = max(exc(1,1,1),exc(1,1,2))
p = max(exc(1,2,1),exc(1,2,2))
exit
enddo
enddo
endif
!assert ( p == pp) !assert ( p == pp)
!assert ( q == qq) !assert ( q == qq)
case default case default