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

Rewrite get_phase_qp_to_cfg

Browse Source
This commit is contained in:
Anthony Scemama 2021-02-26 17:28:03 +01:00
parent 1691c74539
commit 52701979ce
1 changed files with 55 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,9 +1,9 @@
BEGIN_PROVIDER [ integer, NSOMOMax] BEGIN_PROVIDER [ integer, NSOMOMax]
&BEGIN_PROVIDER [ integer, NCSFMax] &BEGIN_PROVIDER [ integer, NCSFMax]
&BEGIN_PROVIDER [ integer*8, NMO] &BEGIN_PROVIDER [ integer*8, NMO]
&BEGIN_PROVIDER [ integer, NBFMax] &BEGIN_PROVIDER [ integer, NBFMax]
&BEGIN_PROVIDER [ integer, n_CSF] &BEGIN_PROVIDER [ integer, n_CSF]
&BEGIN_PROVIDER [ integer, maxDetDimPerBF] &BEGIN_PROVIDER [ integer, maxDetDimPerBF]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Documentation for NSOMOMax ! Documentation for NSOMOMax
@ -22,7 +22,7 @@
integer NSOMO integer NSOMO
integer dimcsfpercfg integer dimcsfpercfg
integer detDimperBF integer detDimperBF
real*8 :: coeff real*8 :: coeff
integer MS integer MS
integer ncfgpersomo integer ncfgpersomo
detDimperBF = 0 detDimperBF = 0
@ -31,21 +31,20 @@
n_CSF = cfg_seniority_index(0)-1 n_CSF = cfg_seniority_index(0)-1
ncfgprev = cfg_seniority_index(0) ncfgprev = cfg_seniority_index(0)
do i = 0-iand(MS,1)+2, NSOMOMax,2 do i = 0-iand(MS,1)+2, NSOMOMax,2
if(cfg_seniority_index(i) .EQ. -1)then if(cfg_seniority_index(i) .EQ. -1)then
ncfgpersomo = N_configuration + 1 ncfgpersomo = N_configuration + 1
else else
ncfgpersomo = cfg_seniority_index(i) ncfgpersomo = cfg_seniority_index(i)
endif endif
ncfg = ncfgpersomo - ncfgprev ncfg = ncfgpersomo - ncfgprev
!detDimperBF = max(1,nint((binom(i,(i+1)/2)))) !detDimperBF = max(1,nint((binom(i,(i+1)/2))))
dimcsfpercfg = max(1,nint((binom(i-2,(i-2+1)/2)-binom(i-2,((i-2+1)/2)+1)))) dimcsfpercfg = max(1,nint((binom(i-2,(i-2+1)/2)-binom(i-2,((i-2+1)/2)+1))))
n_CSF += ncfg * dimcsfpercfg n_CSF += ncfg * dimcsfpercfg
!if(cfg_seniority_index(i+2) == -1) EXIT !if(cfg_seniority_index(i+2) == -1) EXIT
!if(detDimperBF > maxDetDimPerBF) maxDetDimPerBF = detDimperBF !if(detDimperBF > maxDetDimPerBF) maxDetDimPerBF = detDimperBF
ncfgprev = cfg_seniority_index(i) ncfgprev = cfg_seniority_index(i)
enddo enddo
END_PROVIDER END_PROVIDER
subroutine get_phase_qp_to_cfg(Ialpha, Ibeta, phaseout) subroutine get_phase_qp_to_cfg(Ialpha, Ibeta, phaseout)
use bitmasks use bitmasks
@ -62,41 +61,44 @@ subroutine get_phase_qp_to_cfg(Ialpha, Ibeta, phaseout)
integer(bit_kind),intent(in) :: Ialpha(N_int) integer(bit_kind),intent(in) :: Ialpha(N_int)
integer(bit_kind),intent(in) :: Ibeta(N_int) integer(bit_kind),intent(in) :: Ibeta(N_int)
real*8,intent(out) :: phaseout real*8,intent(out) :: phaseout
integer(bit_kind) :: mask(N_int), deta(N_int), detb(N_int) integer(bit_kind) :: mask, mask2(N_int), deta(N_int), detb(N_int)
integer :: nbetas integer :: nbetas
integer :: count, k integer :: count, k
if (N_int >1 ) then
stop 'TODO: get_phase_qp_to_cfg '
endif
nbetas = 0 ! Remove the DOMOs
mask = 0_bit_kind mask2 = IAND(Ialpha,Ibeta)
count = 0 deta = IEOR(Ialpha,mask2)
deta = Ialpha detb = IEOR(Ibeta ,mask2)
detb = Ibeta
! remove the domos ! Find how many alpha electrons there are in all the N_ints
mask = IAND(deta,detb) integer :: Na(N_int)
deta = IEOR(deta,mask) do k=1,N_int
detb = IEOR(detb,mask) Na(k) = popcnt(deta(k))
mask = 0 enddo
phaseout = 1.0
k = 1 integer :: shift, ipos, nperm
do while((deta(k)).GT.0_8) phaseout = 1.d0
mask(k) = ISHFT(1_8,count) do k=1,N_int
if(POPCNT(IAND(deta(k),mask(k))).EQ.1)then
if(IAND(nbetas,1).EQ.0) then do while(detb(k) /= 0_bit_kind)
phaseout *= 1.0d0 ! Find the lowest beta electron and clear it
else ipos = trailz(detb(k))
phaseout *= -1.0d0 detb(k) = ibclr(detb(k),ipos)
endif
deta(k) = IEOR(deta(k),mask(k)) ! Create a mask will all MOs higher than the beta electron
else mask = not(shiftl(1_bit_kind,ipos+1) - 1_bit_kind)
if(POPCNT(IAND(detb(k),mask(k))).EQ.1) then
nbetas += 1 ! Apply the mask to the alpha string to count how many electrons to cross
detb(k) = IEOR(detb(k),mask(k)) nperm = popcnt( iand(mask, deta(k)) )
endif
endif ! Count how many alpha electrons are above the beta electron in the other integers
count += 1 nperm = nperm + sum(Na(k+1:N_int))
if (iand(nperm,1) == 1) then
phaseout = -phaseout
endif
enddo
enddo enddo
end subroutine get_phase_qp_to_cfg end subroutine get_phase_qp_to_cfg