284 lines
8.1 KiB
Fortran
284 lines
8.1 KiB
Fortran
|
|
integer function n_open_shell(det_in,nint)
|
|
implicit none
|
|
use bitmasks
|
|
integer(bit_kind), intent(in) :: det_in(nint,2),nint
|
|
integer :: i
|
|
n_open_shell = 0
|
|
do i=1,Nint
|
|
n_open_shell += popcnt(iand(xor(det_in(i,1),det_in(i,2)),det_in(i,1)))
|
|
enddo
|
|
end
|
|
|
|
integer function n_closed_shell(det_in,nint)
|
|
implicit none
|
|
use bitmasks
|
|
integer(bit_kind), intent(in) :: det_in(nint,2),nint
|
|
integer :: i
|
|
n_closed_shell = 0
|
|
do i=1,Nint
|
|
n_closed_shell += popcnt(iand(det_in(i,1),det_in(i,2)))
|
|
enddo
|
|
end
|
|
|
|
integer function n_closed_shell_cas(det_in,nint)
|
|
implicit none
|
|
use bitmasks
|
|
integer(bit_kind), intent(in) :: det_in(nint,2),nint
|
|
integer(bit_kind) :: det_tmp(nint,2)
|
|
integer :: i
|
|
n_closed_shell_cas = 0
|
|
do i=1,Nint
|
|
det_tmp(i,1) = xor(det_in(i,1),reunion_of_core_inact_bitmask(i,1))
|
|
det_tmp(i,2) = xor(det_in(i,2),reunion_of_core_inact_bitmask(i,2))
|
|
enddo
|
|
!call debug_det(det_tmp,nint)
|
|
do i=1,Nint
|
|
n_closed_shell_cas += popcnt(iand(det_tmp(i,1),det_tmp(i,2)))
|
|
enddo
|
|
end
|
|
|
|
subroutine doubly_occ_empty_in_couple(det_in,n_couples,couples,couples_out)
|
|
implicit none
|
|
use bitmasks
|
|
integer, intent(in) :: n_couples,couples(n_couples,2)
|
|
integer(bit_kind),intent(in) :: det_in(N_int,2)
|
|
logical, intent(out) :: couples_out(0:n_couples)
|
|
integer(bit_kind) :: det_tmp(N_int)
|
|
integer(bit_kind) :: det_tmp_bis(N_int)
|
|
BEGIN_DOC
|
|
! n_couples is the number of couples of orbitals to be checked
|
|
! couples(i,1) = first orbital of the ith couple
|
|
! couples(i,2) = second orbital of the ith couple
|
|
! returns the array couples_out
|
|
! couples_out(i) = .True. if det_in contains
|
|
! an orbital empty in the ith couple AND
|
|
! an orbital doubly occupied in the ith couple
|
|
END_DOC
|
|
integer :: i,j,k,l
|
|
|
|
! det_tmp tells you if the orbitals are occupied or not
|
|
do j = 1, N_int
|
|
det_tmp(j) = ior(det_in(j,1),det_in(j,2))
|
|
enddo
|
|
|
|
couples_out(0) = .False.
|
|
do i = 1, n_couples
|
|
do j = 1, N_int
|
|
det_tmp_bis(j) = 0_bit_kind
|
|
enddo
|
|
call set_bit_to_integer(couples(i,1),det_tmp_bis,N_int) ! first orb
|
|
call set_bit_to_integer(couples(i,2),det_tmp_bis,N_int) ! second orb
|
|
! det_tmp is zero except for the two orbitals of the couple
|
|
integer :: i_count
|
|
i_count = 0
|
|
do j = 1, N_int
|
|
i_count += popcnt(iand(det_tmp(j),det_tmp_bis(j))) ! check if the two orbitals are both occupied
|
|
enddo
|
|
if(i_count .ne. 1)then
|
|
couples_out(i) = .False.
|
|
cycle
|
|
endif
|
|
|
|
! test if orbital there are two electrons or not
|
|
i_count = 0
|
|
do j = 1, N_int
|
|
i_count += popcnt(iand(iand(det_in(j,1),det_in(j,2)),det_tmp_bis(j)))
|
|
enddo
|
|
if(i_count.ne.1)then
|
|
couples_out(i) = .False.
|
|
else
|
|
couples_out(i) = .True.
|
|
couples_out(0) = .True.
|
|
endif
|
|
enddo
|
|
end
|
|
|
|
subroutine give_index_of_doubly_occ_in_active_space(det_in,doubly_occupied_array)
|
|
implicit none
|
|
use bitmasks
|
|
integer(bit_kind), intent(in) :: det_in(N_int,2)
|
|
logical, intent(out) :: doubly_occupied_array(n_act_orb)
|
|
integer(bit_kind) :: det_tmp(N_int)
|
|
integer(bit_kind) :: det_tmp_bis(N_int)
|
|
BEGIN_DOC
|
|
END_DOC
|
|
integer :: i,j,k,l
|
|
|
|
! det_tmp tells you if the orbitals are occupied or not
|
|
do j = 1, N_int
|
|
det_tmp(j) = ior(det_in(j,1),det_in(j,2))
|
|
enddo
|
|
|
|
do i = 1, n_act_orb
|
|
do j = 1, N_int
|
|
det_tmp_bis(j) = 0_bit_kind
|
|
enddo
|
|
i_bite = list_act(i)
|
|
call set_bit_to_integer(i_bite,det_tmp_bis,N_int) ! act orb
|
|
! det_tmp is zero except for the orbital "ith" active orbital
|
|
integer :: i_count,i_bite
|
|
|
|
! test if orbital there are two electrons or not
|
|
i_count = 0
|
|
do j = 1, N_int
|
|
i_count += popcnt(iand(iand(det_in(j,1),det_in(j,2)),det_tmp_bis(j)))
|
|
enddo
|
|
if(i_count.ne.1)then
|
|
doubly_occupied_array(i) = .False.
|
|
else
|
|
doubly_occupied_array(i) = .True.
|
|
endif
|
|
enddo
|
|
end
|
|
|
|
subroutine doubly_occ_empty_in_couple_and_no_hund_elsewhere(det_in,n_couple_no_hund,couple_ion,couple_no_hund,is_ok)
|
|
implicit none
|
|
use bitmasks
|
|
integer, intent(in) :: n_couple_no_hund,couple_ion(2),couple_no_hund(n_couple_no_hund,2)
|
|
integer(bit_kind),intent(in) :: det_in(N_int,2)
|
|
logical, intent(out) :: is_ok
|
|
integer(bit_kind) :: det_tmp(N_int)
|
|
integer(bit_kind) :: det_tmp_bis(N_int)
|
|
BEGIN_DOC
|
|
! n_couples is the number of couples of orbitals to be checked
|
|
! couples(i,1) = first orbital of the ith couple
|
|
! couples(i,2) = second orbital of the ith couple
|
|
! returns the array couples_out
|
|
! couples_out(i) = .True. if det_in contains
|
|
! an orbital empty in the ith couple AND
|
|
! an orbital doubly occupied in the ith couple
|
|
END_DOC
|
|
integer :: i,j,k,l
|
|
|
|
! det_tmp tells you if the orbitals are occupied or not
|
|
do j = 1, N_int
|
|
det_tmp(j) = ior(det_in(j,1),det_in(j,2))
|
|
enddo
|
|
|
|
is_ok = .False.
|
|
do j = 1, N_int
|
|
det_tmp_bis(j) = 0_bit_kind
|
|
enddo
|
|
call set_bit_to_integer(couple_ion(1),det_tmp_bis,N_int) ! first orb
|
|
call set_bit_to_integer(couple_ion(2),det_tmp_bis,N_int) ! second orb
|
|
! det_tmp is zero except for the two orbitals of the couple
|
|
integer :: i_count
|
|
i_count = 0
|
|
do j = 1, N_int
|
|
i_count += popcnt(iand(det_tmp(j),det_tmp_bis(j))) ! check if the two orbitals are both occupied
|
|
enddo
|
|
if(i_count .ne. 1)then
|
|
is_ok = .False.
|
|
return
|
|
endif
|
|
|
|
! test if orbital there are two electrons or not
|
|
i_count = 0
|
|
do j = 1, N_int
|
|
i_count += popcnt(iand(iand(det_in(j,1),det_in(j,2)),det_tmp_bis(j)))
|
|
enddo
|
|
if(i_count.ne.1)then
|
|
is_ok = .False.
|
|
return
|
|
else
|
|
do i = 1, n_couple_no_hund
|
|
do j = 1, N_int
|
|
det_tmp_bis(j) = 0_bit_kind
|
|
enddo
|
|
call set_bit_to_integer(couple_no_hund (i,1),det_tmp_bis,N_int) ! first orb
|
|
call set_bit_to_integer(couple_no_hund (i,2),det_tmp_bis,N_int) ! second orb
|
|
! det_tmp_bis is zero except for the two orbitals of the couple
|
|
i_count = 0
|
|
do j = 1, N_int
|
|
i_count += popcnt(iand(det_tmp(j),det_tmp_bis(j))) ! check if the two orbitals are both occupied
|
|
enddo
|
|
if(i_count .ne. 2)then
|
|
is_ok = .False.
|
|
return
|
|
endif
|
|
! test if orbital there are one alpha and one beta
|
|
integer :: i_count_alpha,i_count_beta
|
|
i_count_alpha = 0
|
|
i_count_beta = 0
|
|
do j = 1, N_int
|
|
i_count_alpha += popcnt(iand(det_in(j,1),det_tmp_bis(j)))
|
|
i_count_beta += popcnt(iand(det_in(j,2),det_tmp_bis(j)))
|
|
enddo
|
|
if(i_count_alpha==1.and.i_count_beta==1)then
|
|
is_ok = .True.
|
|
else
|
|
is_ok = .False.
|
|
return
|
|
endif
|
|
enddo
|
|
is_ok = .True.
|
|
endif
|
|
end
|
|
|
|
|
|
subroutine neutral_no_hund_in_couple(det_in,n_couples,couples,couples_out)
|
|
implicit none
|
|
use bitmasks
|
|
integer, intent(in) :: n_couples,couples(n_couples,2)
|
|
integer(bit_kind),intent(in) :: det_in(N_int,2)
|
|
logical, intent(out) :: couples_out(0:n_couples)
|
|
integer(bit_kind) :: det_tmp(N_int)
|
|
integer(bit_kind) :: det_tmp_bis(N_int)
|
|
BEGIN_DOC
|
|
! n_couples is the number of couples of orbitals to be checked
|
|
! couples(i,1) = first orbital of the ith couple
|
|
! couples(i,2) = second orbital of the ith couple
|
|
! returns the array couples_out
|
|
! couples_out(i) = .True. if det_in contains
|
|
! an orbital empty in the ith couple AND
|
|
! an orbital doubly occupied in the ith couple
|
|
END_DOC
|
|
integer :: i,j,k,l
|
|
|
|
! det_tmp tells you if the orbitals are occupied or not
|
|
do j = 1, N_int
|
|
det_tmp(j) = ior(det_in(j,1),det_in(j,2))
|
|
enddo
|
|
|
|
couples_out(0) = .True.
|
|
do i = 1, n_couples
|
|
do j = 1, N_int
|
|
det_tmp_bis(j) = 0_bit_kind
|
|
enddo
|
|
call set_bit_to_integer(couples(i,1),det_tmp_bis,N_int) ! first orb
|
|
call set_bit_to_integer(couples(i,2),det_tmp_bis,N_int) ! second orb
|
|
! det_tmp_bis is zero except for the two orbitals of the couple
|
|
integer :: i_count
|
|
i_count = 0
|
|
do j = 1, N_int
|
|
i_count += popcnt(iand(det_tmp(j),det_tmp_bis(j))) ! check if the two orbitals are both occupied
|
|
enddo
|
|
if(i_count .ne. 2)then
|
|
couples_out(i) = .False.
|
|
cycle
|
|
endif
|
|
|
|
! test if orbital there are one alpha and one beta
|
|
integer :: i_count_alpha,i_count_beta
|
|
i_count_alpha = 0
|
|
i_count_beta = 0
|
|
do j = 1, N_int
|
|
i_count_alpha += popcnt(iand(det_in(j,1),det_tmp_bis(j)))
|
|
i_count_beta += popcnt(iand(det_in(j,2),det_tmp_bis(j)))
|
|
enddo
|
|
if(i_count_alpha==1.and.i_count_beta==1)then
|
|
couples_out(i) = .True.
|
|
else
|
|
couples_out(i) = .False.
|
|
endif
|
|
enddo
|
|
do i = 1, n_couples
|
|
if(.not.couples_out(i))then
|
|
couples_out(0) = .False.
|
|
endif
|
|
enddo
|
|
end
|
|
|
|
|