mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-08-30 15:53:42 +02:00
Merge branch 'dev-lct' into master
This commit is contained in:
commit
af01bbe2d5
@ -10,7 +10,6 @@ let localport = 42379
|
|||||||
let in_time_sum = ref 1.e-9
|
let in_time_sum = ref 1.e-9
|
||||||
and in_size_sum = ref 0.
|
and in_size_sum = ref 0.
|
||||||
|
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
let open Command_line in
|
let open Command_line in
|
||||||
begin
|
begin
|
||||||
|
@ -64,7 +64,7 @@
|
|||||||
enddo
|
enddo
|
||||||
|
|
||||||
! Ga-Kr
|
! Ga-Kr
|
||||||
do i = 31, 36
|
do i = 31, 100
|
||||||
alpha_knowles(i) = 7.d0
|
alpha_knowles(i) = 7.d0
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
@ -92,7 +92,7 @@ END_PROVIDER
|
|||||||
BEGIN_PROVIDER [ integer(bit_kind), ref_bitmask, (N_int,2)]
|
BEGIN_PROVIDER [ integer(bit_kind), ref_bitmask, (N_int,2)]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Reference bit mask, used in Slater rules, chosen as Hartree-Fock bitmask
|
! Reference bit mask, used in Slater rules, chosen as Hartree-Fock bitmask
|
||||||
END_DOC
|
END_DOC
|
||||||
ref_bitmask = HF_bitmask
|
ref_bitmask = HF_bitmask
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
@ -292,7 +292,7 @@ BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask, (N_int,2,6,N_generators_
|
|||||||
logical :: exists
|
logical :: exists
|
||||||
PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask
|
PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask
|
||||||
|
|
||||||
if (mpi_master) then
|
if (mpi_master) then
|
||||||
call ezfio_has_bitmasks_generators(exists)
|
call ezfio_has_bitmasks_generators(exists)
|
||||||
if (exists) then
|
if (exists) then
|
||||||
call ezfio_get_bitmasks_generators(generators_bitmask)
|
call ezfio_get_bitmasks_generators(generators_bitmask)
|
||||||
@ -443,16 +443,7 @@ BEGIN_PROVIDER [ integer(bit_kind), cas_bitmask, (N_int,2,N_cas_bitmask) ]
|
|||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer, n_core_inact_orb ]
|
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)]
|
||||||
implicit none
|
|
||||||
integer :: i
|
|
||||||
n_core_inact_orb = 0
|
|
||||||
do i = 1, N_int
|
|
||||||
n_core_inact_orb += popcnt(reunion_of_core_inact_bitmask(i,1))
|
|
||||||
enddo
|
|
||||||
ENd_PROVIDER
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)]
|
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Reunion of the core and inactive and virtual bitmasks
|
! Reunion of the core and inactive and virtual bitmasks
|
||||||
@ -462,10 +453,24 @@ END_PROVIDER
|
|||||||
reunion_of_core_inact_bitmask(i,1) = ior(core_bitmask(i,1),inact_bitmask(i,1))
|
reunion_of_core_inact_bitmask(i,1) = ior(core_bitmask(i,1),inact_bitmask(i,1))
|
||||||
reunion_of_core_inact_bitmask(i,2) = ior(core_bitmask(i,2),inact_bitmask(i,2))
|
reunion_of_core_inact_bitmask(i,2) = ior(core_bitmask(i,2),inact_bitmask(i,2))
|
||||||
enddo
|
enddo
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask, (N_int,2)]
|
BEGIN_PROVIDER [integer(bit_kind), reunion_of_inact_act_bitmask, (N_int,2)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Reunion of the inactive and active bitmasks
|
||||||
|
END_DOC
|
||||||
|
integer :: i,j
|
||||||
|
|
||||||
|
do i = 1, N_int
|
||||||
|
reunion_of_inact_act_bitmask(i,1) = ior(inact_bitmask(i,1),act_bitmask(i,1))
|
||||||
|
reunion_of_inact_act_bitmask(i,2) = ior(inact_bitmask(i,2),act_bitmask(i,2))
|
||||||
|
enddo
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask, (N_int,2)]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Reunion of the core, inactive and active bitmasks
|
! Reunion of the core, inactive and active bitmasks
|
||||||
@ -476,10 +481,10 @@ END_PROVIDER
|
|||||||
reunion_of_core_inact_act_bitmask(i,1) = ior(reunion_of_core_inact_bitmask(i,1),act_bitmask(i,1))
|
reunion_of_core_inact_act_bitmask(i,1) = ior(reunion_of_core_inact_bitmask(i,1),act_bitmask(i,1))
|
||||||
reunion_of_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),act_bitmask(i,2))
|
reunion_of_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),act_bitmask(i,2))
|
||||||
enddo
|
enddo
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask, (N_int,2)]
|
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask, (N_int,2)]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Reunion of the inactive, active and virtual bitmasks
|
! Reunion of the inactive, active and virtual bitmasks
|
||||||
@ -489,7 +494,7 @@ END_PROVIDER
|
|||||||
reunion_of_bitmask(i,1) = ior(ior(cas_bitmask(i,1,1),inact_bitmask(i,1)),virt_bitmask(i,1))
|
reunion_of_bitmask(i,1) = ior(ior(cas_bitmask(i,1,1),inact_bitmask(i,1)),virt_bitmask(i,1))
|
||||||
reunion_of_bitmask(i,2) = ior(ior(cas_bitmask(i,2,1),inact_bitmask(i,2)),virt_bitmask(i,2))
|
reunion_of_bitmask(i,2) = ior(ior(cas_bitmask(i,2,1),inact_bitmask(i,2)),virt_bitmask(i,2))
|
||||||
enddo
|
enddo
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer(bit_kind), inact_virt_bitmask, (N_int,2)]
|
BEGIN_PROVIDER [ integer(bit_kind), inact_virt_bitmask, (N_int,2)]
|
||||||
@ -505,7 +510,7 @@ END_PROVIDER
|
|||||||
core_inact_virt_bitmask(i,1) = ior(core_bitmask(i,1),inact_virt_bitmask(i,1))
|
core_inact_virt_bitmask(i,1) = ior(core_bitmask(i,1),inact_virt_bitmask(i,1))
|
||||||
core_inact_virt_bitmask(i,2) = ior(core_bitmask(i,2),inact_virt_bitmask(i,2))
|
core_inact_virt_bitmask(i,2) = ior(core_bitmask(i,2),inact_virt_bitmask(i,2))
|
||||||
enddo
|
enddo
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer, i_bitmask_gen ]
|
BEGIN_PROVIDER [ integer, i_bitmask_gen ]
|
||||||
implicit none
|
implicit none
|
||||||
@ -516,7 +521,7 @@ BEGIN_PROVIDER [ integer, i_bitmask_gen ]
|
|||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer(bit_kind), unpaired_alpha_electrons, (N_int)]
|
BEGIN_PROVIDER [ integer(bit_kind), unpaired_alpha_electrons, (N_int)]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Bitmask reprenting the unpaired alpha electrons in the HF_bitmask
|
! Bitmask reprenting the unpaired alpha electrons in the HF_bitmask
|
||||||
@ -526,19 +531,19 @@ END_PROVIDER
|
|||||||
do i = 1, N_int
|
do i = 1, N_int
|
||||||
unpaired_alpha_electrons(i) = xor(HF_bitmask(i,1),HF_bitmask(i,2))
|
unpaired_alpha_electrons(i) = xor(HF_bitmask(i,1),HF_bitmask(i,2))
|
||||||
enddo
|
enddo
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)]
|
BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)]
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i,j
|
integer :: i,j
|
||||||
do i = 1, N_int
|
do i = 1, N_int
|
||||||
closed_shell_ref_bitmask(i,1) = ior(ref_bitmask(i,1),cas_bitmask(i,1,1))
|
closed_shell_ref_bitmask(i,1) = ior(ref_bitmask(i,1),cas_bitmask(i,1,1))
|
||||||
closed_shell_ref_bitmask(i,2) = ior(ref_bitmask(i,2),cas_bitmask(i,2,1))
|
closed_shell_ref_bitmask(i,2) = ior(ref_bitmask(i,2),cas_bitmask(i,2,1))
|
||||||
enddo
|
enddo
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_cas_inact_bitmask, (N_int,2)]
|
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_cas_inact_bitmask, (N_int,2)]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Reunion of the inactive, active and virtual bitmasks
|
! Reunion of the inactive, active and virtual bitmasks
|
||||||
@ -548,21 +553,5 @@ END_PROVIDER
|
|||||||
reunion_of_cas_inact_bitmask(i,1) = ior(act_bitmask(i,1),inact_bitmask(i,1))
|
reunion_of_cas_inact_bitmask(i,1) = ior(act_bitmask(i,1),inact_bitmask(i,1))
|
||||||
reunion_of_cas_inact_bitmask(i,2) = ior(act_bitmask(i,2),inact_bitmask(i,2))
|
reunion_of_cas_inact_bitmask(i,2) = ior(act_bitmask(i,2),inact_bitmask(i,2))
|
||||||
enddo
|
enddo
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, n_core_orb_allocate]
|
|
||||||
implicit none
|
|
||||||
n_core_orb_allocate = max(n_core_orb,1)
|
|
||||||
END_PROVIDER
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, n_inact_orb_allocate]
|
|
||||||
implicit none
|
|
||||||
n_inact_orb_allocate = max(n_inact_orb,1)
|
|
||||||
END_PROVIDER
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, n_virt_orb_allocate]
|
|
||||||
implicit none
|
|
||||||
n_virt_orb_allocate = max(n_virt_orb,1)
|
|
||||||
END_PROVIDER
|
|
||||||
|
|
||||||
|
@ -33,7 +33,7 @@ subroutine bitstring_to_list( string, list, n_elements, Nint)
|
|||||||
use bitmasks
|
use bitmasks
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Gives the inidices(+1) of the bits set to 1 in the bit string
|
! Gives the indices(+1) of the bits set to 1 in the bit string
|
||||||
END_DOC
|
END_DOC
|
||||||
integer, intent(in) :: Nint
|
integer, intent(in) :: Nint
|
||||||
integer(bit_kind), intent(in) :: string(Nint)
|
integer(bit_kind), intent(in) :: string(Nint)
|
||||||
@ -213,3 +213,34 @@ subroutine print_spindet(string,Nint)
|
|||||||
print *, trim(output(1))
|
print *, trim(output(1))
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
logical function is_integer_in_string(bite,string,Nint)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: bite,Nint
|
||||||
|
integer(bit_kind), intent(in) :: string(Nint)
|
||||||
|
integer(bit_kind) :: string_bite(Nint)
|
||||||
|
integer :: i,itot,itot_and
|
||||||
|
character*(2048) :: output(1)
|
||||||
|
string_bite = 0_bit_kind
|
||||||
|
call set_bit_to_integer(bite,string_bite,Nint)
|
||||||
|
itot = 0
|
||||||
|
itot_and = 0
|
||||||
|
is_integer_in_string = .False.
|
||||||
|
!print*,''
|
||||||
|
!print*,''
|
||||||
|
!print*,'bite = ',bite
|
||||||
|
!call bitstring_to_str( output(1), string_bite, Nint )
|
||||||
|
! print *, trim(output(1))
|
||||||
|
!call bitstring_to_str( output(1), string, Nint )
|
||||||
|
! print *, trim(output(1))
|
||||||
|
do i = 1, Nint
|
||||||
|
itot += popcnt(string(i))
|
||||||
|
itot_and += popcnt(ior(string(i),string_bite(i)))
|
||||||
|
enddo
|
||||||
|
!print*,'itot,itot_and',itot,itot_and
|
||||||
|
if(itot == itot_and)then
|
||||||
|
is_integer_in_string = .True.
|
||||||
|
endif
|
||||||
|
!pause
|
||||||
|
end
|
||||||
|
@ -1,246 +1,383 @@
|
|||||||
use bitmasks
|
use bitmasks
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, n_core_orb]
|
||||||
BEGIN_PROVIDER [ integer, n_core_orb]
|
|
||||||
&BEGIN_PROVIDER [ integer, n_inact_orb ]
|
|
||||||
&BEGIN_PROVIDER [ integer, n_act_orb]
|
|
||||||
&BEGIN_PROVIDER [ integer, n_virt_orb ]
|
|
||||||
&BEGIN_PROVIDER [ integer, n_del_orb ]
|
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! inact_bitmask : Bitmask of the inactive orbitals which are supposed to be doubly excited
|
! Number of core MOs
|
||||||
! in post CAS methods
|
|
||||||
! n_inact_orb : Number of inactive orbitals
|
|
||||||
! virt_bitmask : Bitmaks of vritual orbitals which are supposed to be recieve electrons
|
|
||||||
! in post CAS methods
|
|
||||||
! n_virt_orb : Number of virtual orbitals
|
|
||||||
! list_inact : List of the inactive orbitals which are supposed to be doubly excited
|
|
||||||
! in post CAS methods
|
|
||||||
! list_virt : List of vritual orbitals which are supposed to be recieve electrons
|
|
||||||
! in post CAS methods
|
|
||||||
! list_inact_reverse : reverse list of inactive orbitals
|
|
||||||
! list_inact_reverse(i) = 0 ::> not an inactive
|
|
||||||
! list_inact_reverse(i) = k ::> IS the kth inactive
|
|
||||||
! list_virt_reverse : reverse list of virtual orbitals
|
|
||||||
! list_virt_reverse(i) = 0 ::> not an virtual
|
|
||||||
! list_virt_reverse(i) = k ::> IS the kth virtual
|
|
||||||
! list_act(i) = index of the ith active orbital
|
|
||||||
!
|
|
||||||
! list_act_reverse : reverse list of active orbitals
|
|
||||||
! list_act_reverse(i) = 0 ::> not an active
|
|
||||||
! list_act_reverse(i) = k ::> IS the kth active orbital
|
|
||||||
END_DOC
|
END_DOC
|
||||||
logical :: exists
|
integer :: i
|
||||||
integer :: j,i
|
|
||||||
|
|
||||||
n_core_orb = 0
|
n_core_orb = 0
|
||||||
n_inact_orb = 0
|
|
||||||
n_act_orb = 0
|
|
||||||
n_virt_orb = 0
|
|
||||||
n_del_orb = 0
|
|
||||||
do i = 1, mo_num
|
do i = 1, mo_num
|
||||||
if(mo_class(i) == 'Core')then
|
if(mo_class(i) == 'Core')then
|
||||||
n_core_orb += 1
|
n_core_orb += 1
|
||||||
else if (mo_class(i) == 'Inactive')then
|
endif
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call write_int(6,n_core_orb, 'Number of core MOs')
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, n_inact_orb ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Number of inactive MOs
|
||||||
|
END_DOC
|
||||||
|
integer :: i
|
||||||
|
|
||||||
|
n_inact_orb = 0
|
||||||
|
do i = 1, mo_num
|
||||||
|
if (mo_class(i) == 'Inactive')then
|
||||||
n_inact_orb += 1
|
n_inact_orb += 1
|
||||||
else if (mo_class(i) == 'Active')then
|
endif
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call write_int(6,n_inact_orb,'Number of inactive MOs')
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, n_act_orb]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Number of active MOs
|
||||||
|
END_DOC
|
||||||
|
integer :: i
|
||||||
|
|
||||||
|
n_act_orb = 0
|
||||||
|
do i = 1, mo_num
|
||||||
|
if (mo_class(i) == 'Active')then
|
||||||
n_act_orb += 1
|
n_act_orb += 1
|
||||||
else if (mo_class(i) == 'Virtual')then
|
endif
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call write_int(6,n_act_orb, 'Number of active MOs')
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, n_virt_orb ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Number of virtual MOs
|
||||||
|
END_DOC
|
||||||
|
integer :: i
|
||||||
|
|
||||||
|
n_virt_orb = 0
|
||||||
|
do i = 1, mo_num
|
||||||
|
if (mo_class(i) == 'Virtual')then
|
||||||
n_virt_orb += 1
|
n_virt_orb += 1
|
||||||
else if (mo_class(i) == 'Deleted')then
|
endif
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call write_int(6,n_virt_orb, 'Number of virtual MOs')
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, n_del_orb ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Number of deleted MOs
|
||||||
|
END_DOC
|
||||||
|
integer :: i
|
||||||
|
|
||||||
|
n_del_orb = 0
|
||||||
|
do i = 1, mo_num
|
||||||
|
if (mo_class(i) == 'Deleted')then
|
||||||
n_del_orb += 1
|
n_del_orb += 1
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
|
|
||||||
call write_int(6,n_core_orb, 'Number of core MOs')
|
|
||||||
call write_int(6,n_inact_orb,'Number of inactive MOs')
|
|
||||||
call write_int(6,n_act_orb, 'Number of active MOs')
|
|
||||||
call write_int(6,n_virt_orb, 'Number of virtual MOs')
|
|
||||||
call write_int(6,n_del_orb, 'Number of deleted MOs')
|
call write_int(6,n_del_orb, 'Number of deleted MOs')
|
||||||
|
|
||||||
END_PROVIDER
|
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, dim_list_core_orb]
|
|
||||||
&BEGIN_PROVIDER [integer, dim_list_inact_orb]
|
|
||||||
&BEGIN_PROVIDER [integer, dim_list_virt_orb]
|
|
||||||
&BEGIN_PROVIDER [integer, dim_list_act_orb]
|
|
||||||
&BEGIN_PROVIDER [integer, dim_list_del_orb]
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! dimensions for the allocation of list_inact, list_virt, list_core and list_act
|
|
||||||
! it is at least 1
|
|
||||||
END_DOC
|
|
||||||
dim_list_core_orb = max(n_core_orb,1)
|
|
||||||
dim_list_inact_orb = max(n_inact_orb,1)
|
|
||||||
dim_list_virt_orb = max(n_virt_orb,1)
|
|
||||||
dim_list_act_orb = max(n_act_orb,1)
|
|
||||||
dim_list_del_orb = max(n_del_orb,1)
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer, list_inact, (dim_list_inact_orb)]
|
|
||||||
&BEGIN_PROVIDER [ integer, list_virt, (dim_list_virt_orb)]
|
BEGIN_PROVIDER [ integer, n_core_inact_orb ]
|
||||||
&BEGIN_PROVIDER [ integer, list_inact_reverse, (mo_num)]
|
|
||||||
&BEGIN_PROVIDER [ integer, list_virt_reverse, (mo_num)]
|
|
||||||
&BEGIN_PROVIDER [ integer, list_del_reverse, (mo_num)]
|
|
||||||
&BEGIN_PROVIDER [ integer, list_del, (mo_num)]
|
|
||||||
&BEGIN_PROVIDER [integer, list_core, (dim_list_core_orb)]
|
|
||||||
&BEGIN_PROVIDER [integer, list_core_reverse, (mo_num)]
|
|
||||||
&BEGIN_PROVIDER [integer, list_act, (dim_list_act_orb)]
|
|
||||||
&BEGIN_PROVIDER [integer, list_act_reverse, (mo_num)]
|
|
||||||
&BEGIN_PROVIDER [ integer(bit_kind), core_bitmask, (N_int,2)]
|
|
||||||
&BEGIN_PROVIDER [ integer(bit_kind), inact_bitmask, (N_int,2) ]
|
|
||||||
&BEGIN_PROVIDER [ integer(bit_kind), act_bitmask, (N_int,2) ]
|
|
||||||
&BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask, (N_int,2) ]
|
|
||||||
&BEGIN_PROVIDER [ integer(bit_kind), del_bitmask, (N_int,2) ]
|
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! inact_bitmask : Bitmask of the inactive orbitals which are supposed to be doubly excited
|
! n_core + n_inact
|
||||||
! in post CAS methods
|
|
||||||
! n_inact_orb : Number of inactive orbitals
|
|
||||||
! virt_bitmask : Bitmaks of vritual orbitals which are supposed to be recieve electrons
|
|
||||||
! in post CAS methods
|
|
||||||
! n_virt_orb : Number of virtual orbitals
|
|
||||||
! list_inact : List of the inactive orbitals which are supposed to be doubly excited
|
|
||||||
! in post CAS methods
|
|
||||||
! list_virt : List of vritual orbitals which are supposed to be recieve electrons
|
|
||||||
! in post CAS methods
|
|
||||||
! list_inact_reverse : reverse list of inactive orbitals
|
|
||||||
! list_inact_reverse(i) = 0 ::> not an inactive
|
|
||||||
! list_inact_reverse(i) = k ::> IS the kth inactive
|
|
||||||
! list_virt_reverse : reverse list of virtual orbitals
|
|
||||||
! list_virt_reverse(i) = 0 ::> not an virtual
|
|
||||||
! list_virt_reverse(i) = k ::> IS the kth virtual
|
|
||||||
! list_act(i) = index of the ith active orbital
|
|
||||||
!
|
|
||||||
! list_act_reverse : reverse list of active orbitals
|
|
||||||
! list_act_reverse(i) = 0 ::> not an active
|
|
||||||
! list_act_reverse(i) = k ::> IS the kth active orbital
|
|
||||||
END_DOC
|
END_DOC
|
||||||
logical :: exists
|
integer :: i
|
||||||
integer :: j,i
|
n_core_inact_orb = 0
|
||||||
integer :: n_core_orb_tmp, n_inact_orb_tmp, n_act_orb_tmp, n_virt_orb_tmp,n_del_orb_tmp
|
do i = 1, N_int
|
||||||
integer :: list_core_tmp(N_int*bit_kind_size)
|
n_core_inact_orb += popcnt(reunion_of_core_inact_bitmask(i,1))
|
||||||
integer :: list_inact_tmp(N_int*bit_kind_size)
|
|
||||||
integer :: list_act_tmp(N_int*bit_kind_size)
|
|
||||||
integer :: list_virt_tmp(N_int*bit_kind_size)
|
|
||||||
integer :: list_del_tmp(N_int*bit_kind_size)
|
|
||||||
list_core = 0
|
|
||||||
list_inact = 0
|
|
||||||
list_act = 0
|
|
||||||
list_virt = 0
|
|
||||||
list_del = 0
|
|
||||||
list_core_reverse = 0
|
|
||||||
list_inact_reverse = 0
|
|
||||||
list_act_reverse = 0
|
|
||||||
list_virt_reverse = 0
|
|
||||||
list_del_reverse = 0
|
|
||||||
n_core_orb_tmp = 0
|
|
||||||
n_inact_orb_tmp = 0
|
|
||||||
n_act_orb_tmp = 0
|
|
||||||
n_virt_orb_tmp = 0
|
|
||||||
n_del_orb_tmp = 0
|
|
||||||
do i = 1, mo_num
|
|
||||||
if(mo_class(i) == 'Core')then
|
|
||||||
n_core_orb_tmp += 1
|
|
||||||
list_core(n_core_orb_tmp) = i
|
|
||||||
list_core_tmp(n_core_orb_tmp) = i
|
|
||||||
list_core_reverse(i) = n_core_orb_tmp
|
|
||||||
else if (mo_class(i) == 'Inactive')then
|
|
||||||
n_inact_orb_tmp += 1
|
|
||||||
list_inact(n_inact_orb_tmp) = i
|
|
||||||
list_inact_tmp(n_inact_orb_tmp) = i
|
|
||||||
list_inact_reverse(i) = n_inact_orb_tmp
|
|
||||||
else if (mo_class(i) == 'Active')then
|
|
||||||
n_act_orb_tmp += 1
|
|
||||||
list_act(n_act_orb_tmp) = i
|
|
||||||
list_act_tmp(n_act_orb_tmp) = i
|
|
||||||
list_act_reverse(i) = n_act_orb_tmp
|
|
||||||
else if (mo_class(i) == 'Virtual')then
|
|
||||||
n_virt_orb_tmp += 1
|
|
||||||
list_virt(n_virt_orb_tmp) = i
|
|
||||||
list_virt_tmp(n_virt_orb_tmp) = i
|
|
||||||
list_virt_reverse(i) = n_virt_orb_tmp
|
|
||||||
else if (mo_class(i) == 'Deleted')then
|
|
||||||
n_del_orb_tmp += 1
|
|
||||||
list_del(n_del_orb_tmp) = i
|
|
||||||
list_del_tmp(n_del_orb_tmp) = i
|
|
||||||
list_del_reverse(i) = n_del_orb_tmp
|
|
||||||
endif
|
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
if(n_core_orb.ne.0)then
|
|
||||||
call list_to_bitstring( core_bitmask(1,1), list_core, n_core_orb, N_int)
|
|
||||||
call list_to_bitstring( core_bitmask(1,2), list_core, n_core_orb, N_int)
|
|
||||||
endif
|
|
||||||
if(n_inact_orb.ne.0)then
|
|
||||||
call list_to_bitstring( inact_bitmask(1,1), list_inact, n_inact_orb, N_int)
|
|
||||||
call list_to_bitstring( inact_bitmask(1,2), list_inact, n_inact_orb, N_int)
|
|
||||||
endif
|
|
||||||
if(n_act_orb.ne.0)then
|
|
||||||
call list_to_bitstring( act_bitmask(1,1), list_act, n_act_orb, N_int)
|
|
||||||
call list_to_bitstring( act_bitmask(1,2), list_act, n_act_orb, N_int)
|
|
||||||
endif
|
|
||||||
if(n_virt_orb.ne.0)then
|
|
||||||
call list_to_bitstring( virt_bitmask(1,1), list_virt, n_virt_orb, N_int)
|
|
||||||
call list_to_bitstring( virt_bitmask(1,2), list_virt, n_virt_orb, N_int)
|
|
||||||
endif
|
|
||||||
if(n_del_orb.ne.0)then
|
|
||||||
call list_to_bitstring( del_bitmask(1,1), list_del, n_del_orb, N_int)
|
|
||||||
call list_to_bitstring( del_bitmask(1,2), list_del, n_del_orb, N_int)
|
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, n_inact_act_orb ]
|
BEGIN_PROVIDER [integer, n_inact_act_orb ]
|
||||||
implicit none
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! n_inact + n_act
|
||||||
|
END_DOC
|
||||||
n_inact_act_orb = (n_inact_orb+n_act_orb)
|
n_inact_act_orb = (n_inact_orb+n_act_orb)
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, list_inact_act, (n_inact_act_orb)]
|
BEGIN_PROVIDER [integer, dim_list_core_orb]
|
||||||
integer :: i,itmp
|
implicit none
|
||||||
itmp = 0
|
BEGIN_DOC
|
||||||
do i = 1, n_inact_orb
|
! dimensions for the allocation of list_core.
|
||||||
itmp += 1
|
! it is at least 1
|
||||||
list_inact_act(itmp) = list_inact(i)
|
END_DOC
|
||||||
enddo
|
dim_list_core_orb = max(n_core_orb,1)
|
||||||
do i = 1, n_act_orb
|
END_PROVIDER
|
||||||
itmp += 1
|
|
||||||
list_inact_act(itmp) = list_act(i)
|
BEGIN_PROVIDER [integer, dim_list_inact_orb]
|
||||||
enddo
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! dimensions for the allocation of list_inact.
|
||||||
|
! it is at least 1
|
||||||
|
END_DOC
|
||||||
|
dim_list_inact_orb = max(n_inact_orb,1)
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [integer, dim_list_act_orb]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! dimensions for the allocation of list_act.
|
||||||
|
! it is at least 1
|
||||||
|
END_DOC
|
||||||
|
dim_list_act_orb = max(n_act_orb,1)
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [integer, dim_list_virt_orb]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! dimensions for the allocation of list_virt.
|
||||||
|
! it is at least 1
|
||||||
|
END_DOC
|
||||||
|
dim_list_virt_orb = max(n_virt_orb,1)
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [integer, dim_list_del_orb]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! dimensions for the allocation of list_del.
|
||||||
|
! it is at least 1
|
||||||
|
END_DOC
|
||||||
|
dim_list_del_orb = max(n_del_orb,1)
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, n_core_inact_act_orb ]
|
BEGIN_PROVIDER [integer, n_core_inact_act_orb ]
|
||||||
implicit none
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Number of core inactive and active MOs
|
||||||
|
END_DOC
|
||||||
n_core_inact_act_orb = (n_core_orb + n_inact_orb + n_act_orb)
|
n_core_inact_act_orb = (n_core_orb + n_inact_orb + n_act_orb)
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer(bit_kind), core_bitmask , (N_int,2) ]
|
||||||
|
&BEGIN_PROVIDER [ integer(bit_kind), inact_bitmask, (N_int,2) ]
|
||||||
|
&BEGIN_PROVIDER [ integer(bit_kind), act_bitmask , (N_int,2) ]
|
||||||
|
&BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask , (N_int,2) ]
|
||||||
|
&BEGIN_PROVIDER [ integer(bit_kind), del_bitmask , (N_int,2) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Bitmask identifying the core/inactive/active/virtual/deleted MOs
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
core_bitmask = 0_bit_kind
|
||||||
|
inact_bitmask = 0_bit_kind
|
||||||
|
act_bitmask = 0_bit_kind
|
||||||
|
virt_bitmask = 0_bit_kind
|
||||||
|
del_bitmask = 0_bit_kind
|
||||||
|
|
||||||
|
if(n_core_orb > 0)then
|
||||||
|
call list_to_bitstring( core_bitmask(1,1), list_core, n_core_orb, N_int)
|
||||||
|
call list_to_bitstring( core_bitmask(1,2), list_core, n_core_orb, N_int)
|
||||||
|
endif
|
||||||
|
if(n_inact_orb > 0)then
|
||||||
|
call list_to_bitstring( inact_bitmask(1,1), list_inact, n_inact_orb, N_int)
|
||||||
|
call list_to_bitstring( inact_bitmask(1,2), list_inact, n_inact_orb, N_int)
|
||||||
|
endif
|
||||||
|
if(n_act_orb > 0)then
|
||||||
|
call list_to_bitstring( act_bitmask(1,1), list_act, n_act_orb, N_int)
|
||||||
|
call list_to_bitstring( act_bitmask(1,2), list_act, n_act_orb, N_int)
|
||||||
|
endif
|
||||||
|
if(n_virt_orb > 0)then
|
||||||
|
call list_to_bitstring( virt_bitmask(1,1), list_virt, n_virt_orb, N_int)
|
||||||
|
call list_to_bitstring( virt_bitmask(1,2), list_virt, n_virt_orb, N_int)
|
||||||
|
endif
|
||||||
|
if(n_del_orb > 0)then
|
||||||
|
call list_to_bitstring( del_bitmask(1,1), list_del, n_del_orb, N_int)
|
||||||
|
call list_to_bitstring( del_bitmask(1,2), list_del, n_del_orb, N_int)
|
||||||
|
endif
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [integer, list_core_inact_act, (n_core_inact_act_orb)]
|
|
||||||
&BEGIN_PROVIDER [ integer, list_core_inact_act_reverse, (n_core_inact_act_orb)]
|
|
||||||
integer :: i,itmp
|
|
||||||
itmp = 0
|
|
||||||
do i = 1, n_core_orb
|
|
||||||
itmp += 1
|
|
||||||
list_core_inact_act(itmp) = list_core(i)
|
|
||||||
enddo
|
|
||||||
do i = 1, n_inact_orb
|
|
||||||
itmp += 1
|
|
||||||
list_core_inact_act(itmp) = list_inact(i)
|
|
||||||
enddo
|
|
||||||
do i = 1, n_act_orb
|
|
||||||
itmp += 1
|
|
||||||
list_core_inact_act(itmp) = list_act(i)
|
|
||||||
enddo
|
|
||||||
|
|
||||||
integer :: occ_inact(N_int*bit_kind_size)
|
|
||||||
occ_inact = 0
|
|
||||||
call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), occ_inact(1), itest, N_int)
|
|
||||||
|
BEGIN_PROVIDER [ integer, list_core , (dim_list_core_orb) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, list_core_reverse, (mo_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! List of MO indices which are in the core.
|
||||||
|
END_DOC
|
||||||
|
integer :: i, n
|
||||||
|
list_core = 0
|
||||||
|
list_core_reverse = 0
|
||||||
|
|
||||||
|
n=0
|
||||||
|
do i = 1, mo_num
|
||||||
|
if(mo_class(i) == 'Core')then
|
||||||
|
n += 1
|
||||||
|
list_core(n) = i
|
||||||
|
list_core_reverse(i) = n
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
print *, 'Core MOs:'
|
||||||
|
print *, list_core(1:n_core_orb)
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, list_inact , (dim_list_inact_orb) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, list_inact_reverse, (mo_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! List of MO indices which are inactive.
|
||||||
|
END_DOC
|
||||||
|
integer :: i, n
|
||||||
|
list_inact = 0
|
||||||
list_inact_reverse = 0
|
list_inact_reverse = 0
|
||||||
do i = 1, n_core_inact_act_orb
|
|
||||||
list_core_inact_act_reverse(occ_inact(i)) = i
|
n=0
|
||||||
|
do i = 1, mo_num
|
||||||
|
if (mo_class(i) == 'Inactive')then
|
||||||
|
n += 1
|
||||||
|
list_inact(n) = i
|
||||||
|
list_inact_reverse(i) = n
|
||||||
|
endif
|
||||||
enddo
|
enddo
|
||||||
|
print *, 'Inactive MOs:'
|
||||||
|
print *, list_inact(1:n_inact_orb)
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, list_virt , (dim_list_virt_orb) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, list_virt_reverse, (mo_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! List of MO indices which are virtual
|
||||||
|
END_DOC
|
||||||
|
integer :: i, n
|
||||||
|
list_virt = 0
|
||||||
|
list_virt_reverse = 0
|
||||||
|
|
||||||
|
n=0
|
||||||
|
do i = 1, mo_num
|
||||||
|
if (mo_class(i) == 'Virtual')then
|
||||||
|
n += 1
|
||||||
|
list_virt(n) = i
|
||||||
|
list_virt_reverse(i) = n
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
print *, 'Virtual MOs:'
|
||||||
|
print *, list_virt(1:n_virt_orb)
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, list_del , (dim_list_del_orb) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, list_del_reverse, (mo_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! List of MO indices which are deleted.
|
||||||
|
END_DOC
|
||||||
|
integer :: i, n
|
||||||
|
list_del = 0
|
||||||
|
list_del_reverse = 0
|
||||||
|
|
||||||
|
n=0
|
||||||
|
do i = 1, mo_num
|
||||||
|
if (mo_class(i) == 'Deleted')then
|
||||||
|
n += 1
|
||||||
|
list_del(n) = i
|
||||||
|
list_del_reverse(i) = n
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
print *, 'Deleted MOs:'
|
||||||
|
print *, list_del(1:n_del_orb)
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, list_act , (dim_list_act_orb) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, list_act_reverse, (mo_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! List of MO indices which are in the active.
|
||||||
|
END_DOC
|
||||||
|
integer :: i, n
|
||||||
|
list_act = 0
|
||||||
|
list_act_reverse = 0
|
||||||
|
|
||||||
|
n=0
|
||||||
|
do i = 1, mo_num
|
||||||
|
if (mo_class(i) == 'Active')then
|
||||||
|
n += 1
|
||||||
|
list_act(n) = i
|
||||||
|
list_act_reverse(i) = n
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
print *, 'Active MOs:'
|
||||||
|
print *, list_act(1:n_act_orb)
|
||||||
|
print*, list_act_reverse(1:n_act_orb)
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, list_core_inact , (n_core_inact_orb) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, list_core_inact_reverse, (mo_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! List of indices of the core and inactive MOs
|
||||||
|
END_DOC
|
||||||
|
integer :: i,itmp
|
||||||
|
call bitstring_to_list(reunion_of_core_inact_bitmask(1,1), list_core_inact, itmp, N_int)
|
||||||
|
list_core_inact_reverse = 0
|
||||||
|
ASSERT (itmp == n_core_inact_orb)
|
||||||
|
do i = 1, n_core_inact_orb
|
||||||
|
list_core_inact_reverse(list_core_inact(i)) = i
|
||||||
|
enddo
|
||||||
|
print *, 'Core and Inactive MOs:'
|
||||||
|
print *, list_core_inact(1:n_core_inact_orb)
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, list_core_inact_act , (n_core_inact_act_orb) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, list_core_inact_act_reverse, (mo_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! List of indices of the core inactive and active MOs
|
||||||
|
END_DOC
|
||||||
|
integer :: i,itmp
|
||||||
|
call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), list_core_inact_act, itmp, N_int)
|
||||||
|
list_core_inact_act_reverse = 0
|
||||||
|
ASSERT (itmp == n_core_inact_act_orb)
|
||||||
|
do i = 1, n_core_inact_act_orb
|
||||||
|
list_core_inact_act_reverse(list_core_inact_act(i)) = i
|
||||||
|
enddo
|
||||||
|
print *, 'Core, Inactive and Active MOs:'
|
||||||
|
print *, list_core_inact_act(1:n_core_inact_act_orb)
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, list_inact_act , (n_inact_act_orb) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, list_inact_act_reverse, (mo_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! List of indices of the inactive and active MOs
|
||||||
|
END_DOC
|
||||||
|
integer :: i,itmp
|
||||||
|
call bitstring_to_list(reunion_of_inact_act_bitmask(1,1), list_inact_act, itmp, N_int)
|
||||||
|
list_inact_act_reverse = 0
|
||||||
|
ASSERT (itmp == n_inact_act_orb)
|
||||||
|
do i = 1, n_inact_act_orb
|
||||||
|
list_inact_act_reverse(list_inact_act(i)) = i
|
||||||
|
enddo
|
||||||
|
print *, 'Inactive and Active MOs:'
|
||||||
|
print *, list_inact_act(1:n_inact_act_orb)
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
19
src/casscf/EZFIO.cfg
Normal file
19
src/casscf/EZFIO.cfg
Normal file
@ -0,0 +1,19 @@
|
|||||||
|
[energy]
|
||||||
|
type: double precision
|
||||||
|
doc: Calculated Selected |FCI| energy
|
||||||
|
interface: ezfio
|
||||||
|
size: (determinants.n_states)
|
||||||
|
|
||||||
|
[energy_pt2]
|
||||||
|
type: double precision
|
||||||
|
doc: Calculated |FCI| energy + |PT2|
|
||||||
|
interface: ezfio
|
||||||
|
size: (determinants.n_states)
|
||||||
|
|
||||||
|
[cisd_guess]
|
||||||
|
type: logical
|
||||||
|
doc: If true, the CASSCF starts with a CISD wave function
|
||||||
|
interface: ezfio,provider,ocaml
|
||||||
|
default: True
|
||||||
|
|
||||||
|
|
4
src/casscf/NEED
Normal file
4
src/casscf/NEED
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
cipsi
|
||||||
|
selectors_full
|
||||||
|
generators_fluid
|
||||||
|
two_body_rdm
|
5
src/casscf/README.rst
Normal file
5
src/casscf/README.rst
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
======
|
||||||
|
casscf
|
||||||
|
======
|
||||||
|
|
||||||
|
|CASSCF| program with the CIPSI algorithm.
|
6
src/casscf/bavard.irp.f
Normal file
6
src/casscf/bavard.irp.f
Normal file
@ -0,0 +1,6 @@
|
|||||||
|
! -*- F90 -*-
|
||||||
|
BEGIN_PROVIDER [logical, bavard]
|
||||||
|
! bavard=.true.
|
||||||
|
bavard=.false.
|
||||||
|
END_PROVIDER
|
||||||
|
|
155
src/casscf/bielec.irp.f
Normal file
155
src/casscf/bielec.irp.f
Normal file
@ -0,0 +1,155 @@
|
|||||||
|
BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_inact_act_orb,n_core_inact_act_orb)]
|
||||||
|
BEGIN_DOC
|
||||||
|
! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active
|
||||||
|
! indices are unshifted orbital numbers
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,j,ii,jj,p,q,i3,j3,t3,v3
|
||||||
|
real*8 :: mo_two_e_integral
|
||||||
|
|
||||||
|
bielec_PQxx(:,:,:,:) = 0.d0
|
||||||
|
PROVIDE mo_two_e_integrals_in_map
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT(NONE) &
|
||||||
|
!$OMP PRIVATE(i,ii,j,jj,i3,j3) &
|
||||||
|
!$OMP SHARED(n_core_inact_orb,list_core_inact,mo_num,bielec_PQxx, &
|
||||||
|
!$OMP n_act_orb,mo_integrals_map,list_act)
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
do j=i,n_core_inact_orb
|
||||||
|
jj=list_core_inact(j)
|
||||||
|
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j),mo_integrals_map)
|
||||||
|
bielec_PQxx(:,:,j,i)=bielec_PQxx(:,:,i,j)
|
||||||
|
end do
|
||||||
|
do j=1,n_act_orb
|
||||||
|
jj=list_act(j)
|
||||||
|
j3=j+n_core_inact_orb
|
||||||
|
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j3),mo_integrals_map)
|
||||||
|
bielec_PQxx(:,:,j3,i)=bielec_PQxx(:,:,i,j3)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO
|
||||||
|
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do i=1,n_act_orb
|
||||||
|
ii=list_act(i)
|
||||||
|
i3=i+n_core_inact_orb
|
||||||
|
do j=i,n_act_orb
|
||||||
|
jj=list_act(j)
|
||||||
|
j3=j+n_core_inact_orb
|
||||||
|
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i3,j3),mo_integrals_map)
|
||||||
|
bielec_PQxx(:,:,j3,i3)=bielec_PQxx(:,:,i3,j3)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO
|
||||||
|
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_act_orb,n_core_inact_act_orb, mo_num)]
|
||||||
|
BEGIN_DOC
|
||||||
|
! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active
|
||||||
|
! indices are unshifted orbital numbers
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,j,ii,jj,p,q,i3,j3,t3,v3
|
||||||
|
double precision, allocatable :: integrals_array(:,:)
|
||||||
|
real*8 :: mo_two_e_integral
|
||||||
|
|
||||||
|
PROVIDE mo_two_e_integrals_in_map
|
||||||
|
bielec_PxxQ = 0.d0
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT(NONE) &
|
||||||
|
!$OMP PRIVATE(i,ii,j,jj,i3,j3,integrals_array) &
|
||||||
|
!$OMP SHARED(n_core_inact_orb,list_core_inact,mo_num,bielec_PxxQ, &
|
||||||
|
!$OMP n_act_orb,mo_integrals_map,list_act)
|
||||||
|
|
||||||
|
allocate(integrals_array(mo_num,mo_num))
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
do j=i,n_core_inact_orb
|
||||||
|
jj=list_core_inact(j)
|
||||||
|
call get_mo_two_e_integrals_ij(ii,jj,mo_num,integrals_array,mo_integrals_map)
|
||||||
|
do q=1,mo_num
|
||||||
|
do p=1,mo_num
|
||||||
|
bielec_PxxQ(p,i,j,q)=integrals_array(p,q)
|
||||||
|
bielec_PxxQ(p,j,i,q)=integrals_array(q,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do j=1,n_act_orb
|
||||||
|
jj=list_act(j)
|
||||||
|
j3=j+n_core_inact_orb
|
||||||
|
call get_mo_two_e_integrals_ij(ii,jj,mo_num,integrals_array,mo_integrals_map)
|
||||||
|
do q=1,mo_num
|
||||||
|
do p=1,mo_num
|
||||||
|
bielec_PxxQ(p,i,j3,q)=integrals_array(p,q)
|
||||||
|
bielec_PxxQ(p,j3,i,q)=integrals_array(q,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO
|
||||||
|
|
||||||
|
|
||||||
|
! (ip|qj)
|
||||||
|
!$OMP DO
|
||||||
|
do i=1,n_act_orb
|
||||||
|
ii=list_act(i)
|
||||||
|
i3=i+n_core_inact_orb
|
||||||
|
do j=i,n_act_orb
|
||||||
|
jj=list_act(j)
|
||||||
|
j3=j+n_core_inact_orb
|
||||||
|
call get_mo_two_e_integrals_ij(ii,jj,mo_num,integrals_array,mo_integrals_map)
|
||||||
|
do q=1,mo_num
|
||||||
|
do p=1,mo_num
|
||||||
|
bielec_PxxQ(p,i3,j3,q)=integrals_array(p,q)
|
||||||
|
bielec_PxxQ(p,j3,i3,q)=integrals_array(q,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO
|
||||||
|
|
||||||
|
deallocate(integrals_array)
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)]
|
||||||
|
BEGIN_DOC
|
||||||
|
! bielecCI : integrals (tu|vp) with p arbitrary, tuv active
|
||||||
|
! index p runs over the whole basis, t,u,v only over the active orbitals
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,j,k,p,t,u,v
|
||||||
|
double precision, external :: mo_two_e_integral
|
||||||
|
PROVIDE mo_two_e_integrals_in_map
|
||||||
|
|
||||||
|
!$OMP PARALLEL DO DEFAULT(NONE) &
|
||||||
|
!$OMP PRIVATE(i,j,k,p,t,u,v) &
|
||||||
|
!$OMP SHARED(mo_num,n_act_orb,list_act,bielecCI)
|
||||||
|
do p=1,mo_num
|
||||||
|
do j=1,n_act_orb
|
||||||
|
u=list_act(j)
|
||||||
|
do k=1,n_act_orb
|
||||||
|
v=list_act(k)
|
||||||
|
do i=1,n_act_orb
|
||||||
|
t=list_act(i)
|
||||||
|
bielecCI(i,k,j,p) = mo_two_e_integral(t,u,v,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END PARALLEL DO
|
||||||
|
|
||||||
|
END_PROVIDER
|
369
src/casscf/bielec_natorb.irp.f
Normal file
369
src/casscf/bielec_natorb.irp.f
Normal file
@ -0,0 +1,369 @@
|
|||||||
|
BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_inact_act_orb,n_core_inact_act_orb)]
|
||||||
|
BEGIN_DOC
|
||||||
|
! integral (pq|xx) in the basis of natural MOs
|
||||||
|
! indices are unshifted orbital numbers
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,j,k,l,t,u,p,q
|
||||||
|
double precision, allocatable :: f(:,:,:), d(:,:,:)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT(NONE) &
|
||||||
|
!$OMP PRIVATE(j,k,l,p,d,f) &
|
||||||
|
!$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, &
|
||||||
|
!$OMP bielec_PQxx_no,bielec_PQxx,list_act,natorbsCI)
|
||||||
|
|
||||||
|
allocate (f(n_act_orb,mo_num,n_core_inact_act_orb), &
|
||||||
|
d(n_act_orb,mo_num,n_core_inact_act_orb))
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do l=1,n_core_inact_act_orb
|
||||||
|
bielec_PQxx_no(:,:,:,l) = bielec_PQxx(:,:,:,l)
|
||||||
|
|
||||||
|
do k=1,n_core_inact_act_orb
|
||||||
|
do j=1,mo_num
|
||||||
|
do p=1,n_act_orb
|
||||||
|
f(p,j,k)=bielec_PQxx_no(list_act(p),j,k,l)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call dgemm('T','N',n_act_orb,mo_num*n_core_inact_act_orb,n_act_orb,1.d0, &
|
||||||
|
natorbsCI, size(natorbsCI,1), &
|
||||||
|
f, n_act_orb, &
|
||||||
|
0.d0, &
|
||||||
|
d, n_act_orb)
|
||||||
|
do k=1,n_core_inact_act_orb
|
||||||
|
do j=1,mo_num
|
||||||
|
do p=1,n_act_orb
|
||||||
|
bielec_PQxx_no(list_act(p),j,k,l)=d(p,j,k)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
do j=1,mo_num
|
||||||
|
do p=1,n_act_orb
|
||||||
|
f(p,j,k)=bielec_PQxx_no(j,list_act(p),k,l)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call dgemm('T','N',n_act_orb,mo_num*n_core_inact_act_orb,n_act_orb,1.d0, &
|
||||||
|
natorbsCI, n_act_orb, &
|
||||||
|
f, n_act_orb, &
|
||||||
|
0.d0, &
|
||||||
|
d, n_act_orb)
|
||||||
|
do k=1,n_core_inact_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do j=1,mo_num
|
||||||
|
bielec_PQxx_no(j,list_act(p),k,l)=d(p,j,k)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
|
deallocate (f,d)
|
||||||
|
|
||||||
|
allocate (f(mo_num,mo_num,n_act_orb),d(mo_num,mo_num,n_act_orb))
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do l=1,n_core_inact_act_orb
|
||||||
|
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do k=1,mo_num
|
||||||
|
do j=1,mo_num
|
||||||
|
f(j,k,p) = bielec_PQxx_no(j,k,n_core_inact_orb+p,l)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call dgemm('N','N',mo_num*mo_num,n_act_orb,n_act_orb,1.d0, &
|
||||||
|
f, mo_num*mo_num, &
|
||||||
|
natorbsCI, n_act_orb, &
|
||||||
|
0.d0, &
|
||||||
|
d, mo_num*mo_num)
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do k=1,mo_num
|
||||||
|
do j=1,mo_num
|
||||||
|
bielec_PQxx_no(j,k,n_core_inact_orb+p,l)=d(j,k,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
|
!$OMP BARRIER
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do l=1,n_core_inact_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do k=1,mo_num
|
||||||
|
do j=1,mo_num
|
||||||
|
f(j,k,p) = bielec_PQxx_no(j,k,l,n_core_inact_orb+p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call dgemm('N','N',mo_num*mo_num,n_act_orb,n_act_orb,1.d0, &
|
||||||
|
f, mo_num*mo_num, &
|
||||||
|
natorbsCI, n_act_orb, &
|
||||||
|
0.d0, &
|
||||||
|
d, mo_num*mo_num)
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do k=1,mo_num
|
||||||
|
do j=1,mo_num
|
||||||
|
bielec_PQxx_no(j,k,l,n_core_inact_orb+p)=d(j,k,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO
|
||||||
|
|
||||||
|
deallocate (f,d)
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inact_act_orb, mo_num)]
|
||||||
|
BEGIN_DOC
|
||||||
|
! integral (px|xq) in the basis of natural MOs
|
||||||
|
! indices are unshifted orbital numbers
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,j,k,l,t,u,p,q
|
||||||
|
double precision, allocatable :: f(:,:,:), d(:,:,:)
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT(NONE) &
|
||||||
|
!$OMP PRIVATE(j,k,l,p,d,f) &
|
||||||
|
!$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, &
|
||||||
|
!$OMP bielec_PxxQ_no,bielec_PxxQ,list_act,natorbsCI)
|
||||||
|
|
||||||
|
|
||||||
|
allocate (f(n_act_orb,n_core_inact_act_orb,n_core_inact_act_orb), &
|
||||||
|
d(n_act_orb,n_core_inact_act_orb,n_core_inact_act_orb))
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do j=1,mo_num
|
||||||
|
bielec_PxxQ_no(:,:,:,j) = bielec_PxxQ(:,:,:,j)
|
||||||
|
do l=1,n_core_inact_act_orb
|
||||||
|
do k=1,n_core_inact_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
f(p,k,l) = bielec_PxxQ_no(list_act(p),k,l,j)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call dgemm('T','N',n_act_orb,n_core_inact_act_orb**2,n_act_orb,1.d0, &
|
||||||
|
natorbsCI, size(natorbsCI,1), &
|
||||||
|
f, n_act_orb, &
|
||||||
|
0.d0, &
|
||||||
|
d, n_act_orb)
|
||||||
|
do l=1,n_core_inact_act_orb
|
||||||
|
do k=1,n_core_inact_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
bielec_PxxQ_no(list_act(p),k,l,j)=d(p,k,l)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
|
deallocate (f,d)
|
||||||
|
|
||||||
|
allocate (f(n_act_orb,mo_num,n_core_inact_act_orb), &
|
||||||
|
d(n_act_orb,mo_num,n_core_inact_act_orb))
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do k=1,mo_num
|
||||||
|
do l=1,n_core_inact_act_orb
|
||||||
|
do j=1,mo_num
|
||||||
|
do p=1,n_act_orb
|
||||||
|
f(p,j,l) = bielec_PxxQ_no(j,n_core_inact_orb+p,l,k)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call dgemm('T','N',n_act_orb,mo_num*n_core_inact_act_orb,n_act_orb,1.d0, &
|
||||||
|
natorbsCI, size(natorbsCI,1), &
|
||||||
|
f, n_act_orb, &
|
||||||
|
0.d0, &
|
||||||
|
d, n_act_orb)
|
||||||
|
do l=1,n_core_inact_act_orb
|
||||||
|
do j=1,mo_num
|
||||||
|
do p=1,n_act_orb
|
||||||
|
bielec_PxxQ_no(j,n_core_inact_orb+p,l,k)=d(p,j,l)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
|
deallocate(f,d)
|
||||||
|
|
||||||
|
allocate(f(mo_num,n_core_inact_act_orb,n_act_orb), &
|
||||||
|
d(mo_num,n_core_inact_act_orb,n_act_orb) )
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do k=1,mo_num
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do l=1,n_core_inact_act_orb
|
||||||
|
do j=1,mo_num
|
||||||
|
f(j,l,p) = bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call dgemm('N','N',mo_num*n_core_inact_act_orb,n_act_orb,n_act_orb,1.d0, &
|
||||||
|
f, mo_num*n_core_inact_act_orb, &
|
||||||
|
natorbsCI, size(natorbsCI,1), &
|
||||||
|
0.d0, &
|
||||||
|
d, mo_num*n_core_inact_act_orb)
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do l=1,n_core_inact_act_orb
|
||||||
|
do j=1,mo_num
|
||||||
|
bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)=d(j,l,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
|
!$OMP BARRIER
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do l=1,n_core_inact_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do k=1,n_core_inact_act_orb
|
||||||
|
do j=1,mo_num
|
||||||
|
f(j,k,p) = bielec_PxxQ_no(j,k,l,n_core_inact_orb+p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call dgemm('N','N',mo_num*n_core_inact_act_orb,n_act_orb,n_act_orb,1.d0, &
|
||||||
|
f, mo_num*n_core_inact_act_orb, &
|
||||||
|
natorbsCI, size(natorbsCI,1), &
|
||||||
|
0.d0, &
|
||||||
|
d, mo_num*n_core_inact_act_orb)
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do k=1,n_core_inact_act_orb
|
||||||
|
do j=1,mo_num
|
||||||
|
bielec_PxxQ_no(j,k,l,n_core_inact_orb+p)=d(j,k,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
deallocate(f,d)
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)]
|
||||||
|
BEGIN_DOC
|
||||||
|
! integrals (tu|vp) in the basis of natural MOs
|
||||||
|
! index p runs over the whole basis, t,u,v only over the active orbitals
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,j,k,l,t,u,p,q
|
||||||
|
double precision, allocatable :: f(:,:,:), d(:,:,:)
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT(NONE) &
|
||||||
|
!$OMP PRIVATE(j,k,l,p,d,f) &
|
||||||
|
!$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, &
|
||||||
|
!$OMP bielecCI_no,bielecCI,list_act,natorbsCI)
|
||||||
|
|
||||||
|
allocate (f(n_act_orb,n_act_orb,mo_num), &
|
||||||
|
d(n_act_orb,n_act_orb,mo_num))
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do l=1,mo_num
|
||||||
|
bielecCI_no(:,:,:,l) = bielecCI(:,:,:,l)
|
||||||
|
do k=1,n_act_orb
|
||||||
|
do j=1,n_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
f(p,j,k)=bielecCI_no(p,j,k,l)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call dgemm('T','N',n_act_orb,n_act_orb*n_act_orb,n_act_orb,1.d0, &
|
||||||
|
natorbsCI, size(natorbsCI,1), &
|
||||||
|
f, n_act_orb, &
|
||||||
|
0.d0, &
|
||||||
|
d, n_act_orb)
|
||||||
|
do k=1,n_act_orb
|
||||||
|
do j=1,n_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
bielecCI_no(p,j,k,l)=d(p,j,k)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
do j=1,n_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
f(p,j,k)=bielecCI_no(j,p,k,l)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call dgemm('T','N',n_act_orb,n_act_orb*n_act_orb,n_act_orb,1.d0, &
|
||||||
|
natorbsCI, n_act_orb, &
|
||||||
|
f, n_act_orb, &
|
||||||
|
0.d0, &
|
||||||
|
d, n_act_orb)
|
||||||
|
do k=1,n_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do j=1,n_act_orb
|
||||||
|
bielecCI_no(j,p,k,l)=d(p,j,k)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do k=1,n_act_orb
|
||||||
|
do j=1,n_act_orb
|
||||||
|
f(j,k,p)=bielecCI_no(j,k,p,l)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call dgemm('N','N',n_act_orb*n_act_orb,n_act_orb,n_act_orb,1.d0, &
|
||||||
|
f, n_act_orb*n_act_orb, &
|
||||||
|
natorbsCI, n_act_orb, &
|
||||||
|
0.d0, &
|
||||||
|
d, n_act_orb*n_act_orb)
|
||||||
|
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do k=1,n_act_orb
|
||||||
|
do j=1,n_act_orb
|
||||||
|
bielecCI_no(j,k,p,l)=d(j,k,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do l=1,n_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do k=1,n_act_orb
|
||||||
|
do j=1,n_act_orb
|
||||||
|
f(j,k,p)=bielecCI_no(j,k,l,list_act(p))
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call dgemm('N','N',n_act_orb*n_act_orb,n_act_orb,n_act_orb,1.d0, &
|
||||||
|
f, n_act_orb*n_act_orb, &
|
||||||
|
natorbsCI, n_act_orb, &
|
||||||
|
0.d0, &
|
||||||
|
d, n_act_orb*n_act_orb)
|
||||||
|
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do k=1,n_act_orb
|
||||||
|
do j=1,n_act_orb
|
||||||
|
bielecCI_no(j,k,l,list_act(p))=d(j,k,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO
|
||||||
|
|
||||||
|
deallocate(d,f)
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
124
src/casscf/casscf.irp.f
Normal file
124
src/casscf/casscf.irp.f
Normal file
@ -0,0 +1,124 @@
|
|||||||
|
program casscf
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! TODO : Put the documentation of the program here
|
||||||
|
END_DOC
|
||||||
|
no_vvvv_integrals = .True.
|
||||||
|
SOFT_TOUCH no_vvvv_integrals
|
||||||
|
threshold_davidson = 1.d-7
|
||||||
|
touch threshold_davidson
|
||||||
|
if(cisd_guess)then
|
||||||
|
logical :: converged
|
||||||
|
integer :: iteration
|
||||||
|
double precision :: energy
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'USING A CISD WAVE FUNCTION AS GUESS FOR THE MCSCF WF'
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'*******************************'
|
||||||
|
converged = .False.
|
||||||
|
iteration = 0
|
||||||
|
generators_type = "HF"
|
||||||
|
touch generators_type
|
||||||
|
read_wf = .False.
|
||||||
|
touch read_wf
|
||||||
|
logical :: do_cisdtq
|
||||||
|
do_cisdtq = .True.
|
||||||
|
double precision :: thr
|
||||||
|
thr = 5.d-3
|
||||||
|
do while (.not.converged)
|
||||||
|
call cisd_scf_iteration(converged,iteration,energy,thr)
|
||||||
|
if(HF_index.ne.1.and.iteration.gt.0)then
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'The HF determinant is not the dominant determinant in the CISD WF ...'
|
||||||
|
print*,'Therefore we skip the CISD WF ..'
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'*******************************'
|
||||||
|
do_cisdtq = .False.
|
||||||
|
exit
|
||||||
|
endif
|
||||||
|
if(iteration.gt.15.and..not.converged)then
|
||||||
|
print*,'It seems that the orbital optimization for the CISD WAVE FUNCTION CANNOT CONVERGE ...'
|
||||||
|
print*,'Passing to CISDTQ WAVE FUNCTION'
|
||||||
|
exit
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
if(do_cisdtq)then
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'SWITCHING WITH A CISDTQ WAVE FUNCTION AS GUESS FOR THE MCSCF WF'
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'*******************************'
|
||||||
|
converged = .False.
|
||||||
|
iteration = 0
|
||||||
|
read_wf = .False.
|
||||||
|
touch read_wf
|
||||||
|
pt2_max = 0.01d0
|
||||||
|
touch pt2_max
|
||||||
|
energy = 0.d0
|
||||||
|
do while (.not.converged)
|
||||||
|
call cisdtq_scf_iteration(converged,iteration,energy,thr)
|
||||||
|
if(HF_index.ne.1.and.iteration.gt.0)then
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'The HF determinant is not the dominant determinant in the CISDTQ WF ...'
|
||||||
|
print*,'Therefore we skip the CISDTQ WF ..'
|
||||||
|
print*,'*******************************'
|
||||||
|
print*,'*******************************'
|
||||||
|
exit
|
||||||
|
endif
|
||||||
|
if(iteration.gt.15.and..not.converged)then
|
||||||
|
print*,'It seems that the orbital optimization for the CISDTQ WAVE FUNCTION CANNOT CONVERGE ...'
|
||||||
|
print*,'Passing to CISDTQ WAVE FUNCTION'
|
||||||
|
exit
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
read_wf = .False.
|
||||||
|
touch read_wf
|
||||||
|
pt2_max = 0.0d0
|
||||||
|
touch pt2_max
|
||||||
|
! call run_cipsi_scf
|
||||||
|
call run
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine run
|
||||||
|
implicit none
|
||||||
|
double precision :: energy_old, energy
|
||||||
|
logical :: converged
|
||||||
|
integer :: iteration
|
||||||
|
converged = .False.
|
||||||
|
|
||||||
|
energy = 0.d0
|
||||||
|
mo_label = "MCSCF"
|
||||||
|
iteration = 1
|
||||||
|
do while (.not.converged)
|
||||||
|
call run_stochastic_cipsi
|
||||||
|
energy_old = energy
|
||||||
|
energy = eone+etwo+ecore
|
||||||
|
|
||||||
|
call write_time(6)
|
||||||
|
call write_int(6,iteration,'CAS-SCF iteration')
|
||||||
|
call write_double(6,energy,'CAS-SCF energy')
|
||||||
|
call write_double(6,energy_improvement, 'Predicted energy improvement')
|
||||||
|
|
||||||
|
converged = dabs(energy_improvement) < thresh_scf
|
||||||
|
! pt2_max = dabs(energy_improvement / pt2_relative_error)
|
||||||
|
|
||||||
|
mo_coef = NewOrbs
|
||||||
|
call save_mos
|
||||||
|
iteration += 1
|
||||||
|
N_det = N_det/2
|
||||||
|
psi_det = psi_det_sorted
|
||||||
|
psi_coef = psi_coef_sorted
|
||||||
|
read_wf = .True.
|
||||||
|
call clear_mo_map
|
||||||
|
SOFT_TOUCH mo_coef N_det pt2_max psi_det psi_coef
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
14
src/casscf/change_bitmasks.irp.f
Normal file
14
src/casscf/change_bitmasks.irp.f
Normal file
@ -0,0 +1,14 @@
|
|||||||
|
subroutine only_act_bitmask
|
||||||
|
implicit none
|
||||||
|
integer :: i,j,k
|
||||||
|
do k = 1, N_generators_bitmask
|
||||||
|
do j = 1, 6
|
||||||
|
do i = 1, N_int
|
||||||
|
generators_bitmask(i,1,j,k) = act_bitmask(i,1)
|
||||||
|
generators_bitmask(i,2,j,k) = act_bitmask(i,2)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
touch generators_bitmask
|
||||||
|
end
|
||||||
|
|
75
src/casscf/cipsi_routines.irp.f
Normal file
75
src/casscf/cipsi_routines.irp.f
Normal file
@ -0,0 +1,75 @@
|
|||||||
|
subroutine run_cipsi_scf
|
||||||
|
implicit none
|
||||||
|
double precision :: energy_old, energy, extrap,extrap_old,pt2_max_begin
|
||||||
|
logical :: converged
|
||||||
|
integer :: iteration
|
||||||
|
print*,'*********************************'
|
||||||
|
print*,'*********************************'
|
||||||
|
print*,' DOING THE CIPSI-SCF '
|
||||||
|
print*,'*********************************'
|
||||||
|
converged = .False.
|
||||||
|
pt2_max_begin = pt2_max
|
||||||
|
energy = 0.d0
|
||||||
|
extrap = 0.d0
|
||||||
|
mo_label = "MCSCF"
|
||||||
|
iteration = 1
|
||||||
|
threshold_davidson = 1.d-09
|
||||||
|
touch threshold_davidson
|
||||||
|
do while (.not.converged)
|
||||||
|
print*,''
|
||||||
|
call write_int(6,iteration,'CI STEP OF THE ITERATION = ')
|
||||||
|
call write_double(6,pt2_max,'PT2 MAX = ')
|
||||||
|
!call cisd_guess_wf
|
||||||
|
generators_type = "CAS"
|
||||||
|
touch generators_type
|
||||||
|
call run_stochastic_cipsi
|
||||||
|
call change_orb_cipsi(converged,iteration,energy)
|
||||||
|
if(iteration.gt.n_it_scf_max.and..not.converged)then
|
||||||
|
print*,'It seems that the orbital optimization for the CISDTQ WAVE FUNCTION CANNOT CONVERGE ...'
|
||||||
|
print*,'The required delta E was :',thresh_scf
|
||||||
|
print*,'The obtained delta E was :',extrap - extrap_old
|
||||||
|
print*,'After ',iteration,'iterations ...'
|
||||||
|
print*,'Getting out of the SCF loop ...'
|
||||||
|
exit
|
||||||
|
endif
|
||||||
|
iteration += 1
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine change_orb_cipsi(converged,iteration,energy)
|
||||||
|
implicit none
|
||||||
|
double precision :: energy_old, extrap,extrap_old,pt2_max_begin
|
||||||
|
double precision, intent(inout):: energy
|
||||||
|
logical, intent(out) :: converged
|
||||||
|
integer, intent(in) :: iteration
|
||||||
|
extrap_old = energy
|
||||||
|
energy = eone+etwo+ecore
|
||||||
|
extrap = extrapolated_energy(2,1)
|
||||||
|
|
||||||
|
call write_time(6)
|
||||||
|
call write_int(6,iteration,'CAS-SCF iteration')
|
||||||
|
call write_double(6,energy,'CAS-SCF variational energy')
|
||||||
|
call write_double(6,extrap,'CAS-SCF extrapolated energy')
|
||||||
|
call write_double(6,extrap - extrap_old,'Change in extrapolated energy')
|
||||||
|
energy = extrap
|
||||||
|
call write_double(6,energy_improvement, 'Predicted energy improvement')
|
||||||
|
|
||||||
|
converged = dabs(extrap - extrap_old) < thresh_scf
|
||||||
|
pt2_max = dabs(extrap - extrap_old) * 10.d0
|
||||||
|
pt2_max = min(pt2_max,1.d-2)
|
||||||
|
pt2_max = max(pt2_max,1.d-10)
|
||||||
|
if(N_det.gt.10**6)then
|
||||||
|
pt2_max = max(pt2_max,1.d-2)
|
||||||
|
endif
|
||||||
|
|
||||||
|
mo_coef = NewOrbs
|
||||||
|
call save_mos
|
||||||
|
call map_deinit(mo_integrals_map)
|
||||||
|
N_det = N_det/2
|
||||||
|
psi_det = psi_det_sorted
|
||||||
|
psi_coef = psi_coef_sorted
|
||||||
|
read_wf = .True.
|
||||||
|
FREE mo_integrals_map mo_two_e_integrals_in_map
|
||||||
|
SOFT_TOUCH mo_coef N_det pt2_max psi_det psi_coef
|
||||||
|
end
|
85
src/casscf/cisd_routine.irp.f
Normal file
85
src/casscf/cisd_routine.irp.f
Normal file
@ -0,0 +1,85 @@
|
|||||||
|
subroutine cisd_scf_iteration(converged,iteration,energy,thr)
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: thr
|
||||||
|
logical, intent(out) :: converged
|
||||||
|
integer, intent(inout) :: iteration
|
||||||
|
double precision, intent(out) :: energy
|
||||||
|
converged = .False.
|
||||||
|
call only_act_bitmask
|
||||||
|
N_det = N_det_generators
|
||||||
|
psi_coef = psi_coef_generators
|
||||||
|
psi_det = psi_det_generators
|
||||||
|
touch N_det psi_coef psi_det
|
||||||
|
call run_cisd
|
||||||
|
call change_orb_cisd(converged,iteration,energy,thr)
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine cisd_guess_wf
|
||||||
|
implicit none
|
||||||
|
call only_act_bitmask
|
||||||
|
N_det = N_det_generators
|
||||||
|
psi_coef = psi_coef_generators
|
||||||
|
psi_det = psi_det_generators
|
||||||
|
touch N_det psi_coef psi_det
|
||||||
|
generators_type = "HF"
|
||||||
|
touch generators_type
|
||||||
|
call run_cisd
|
||||||
|
touch N_det psi_coef psi_det psi_coef_sorted psi_det_sorted psi_det_sorted_order psi_average_norm_contrib_sorted
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine change_orb_cisd(converged,iteration,energy,thr)
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: thr
|
||||||
|
logical, intent(inout) :: converged
|
||||||
|
integer, intent(inout) :: iteration
|
||||||
|
double precision, intent(inout) :: energy
|
||||||
|
double precision :: energy_old
|
||||||
|
energy_old = energy
|
||||||
|
|
||||||
|
energy = eone+etwo+ecore
|
||||||
|
|
||||||
|
call write_time(6)
|
||||||
|
call write_int(6,iteration,'CISD-SCF iteration')
|
||||||
|
call write_double(6,energy,'CISD-SCF energy')
|
||||||
|
call write_double(6,energy_improvement, 'Predicted energy improvement')
|
||||||
|
converged = dabs(energy_improvement) < thr
|
||||||
|
|
||||||
|
mo_coef = NewOrbs
|
||||||
|
call save_mos
|
||||||
|
call map_deinit(mo_integrals_map)
|
||||||
|
FREE mo_integrals_map mo_two_e_integrals_in_map
|
||||||
|
iteration += 1
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine run_cisd
|
||||||
|
implicit none
|
||||||
|
integer :: i
|
||||||
|
|
||||||
|
if(pseudo_sym)then
|
||||||
|
call H_apply_cisd_sym
|
||||||
|
else
|
||||||
|
call H_apply_cisd
|
||||||
|
endif
|
||||||
|
print *, 'N_det = ', N_det
|
||||||
|
print*,'******************************'
|
||||||
|
print *, 'Energies of the states:'
|
||||||
|
do i = 1,N_states
|
||||||
|
print *, i, CI_energy(i)
|
||||||
|
enddo
|
||||||
|
if (N_states > 1) then
|
||||||
|
print*,'******************************'
|
||||||
|
print*,'Excitation energies '
|
||||||
|
do i = 2, N_states
|
||||||
|
print*, i ,CI_energy(i) - CI_energy(1)
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
psi_coef = ci_eigenvectors
|
||||||
|
SOFT_TOUCH psi_coef
|
||||||
|
call save_wavefunction
|
||||||
|
|
||||||
|
end
|
47
src/casscf/cisdtq_routine.irp.f
Normal file
47
src/casscf/cisdtq_routine.irp.f
Normal file
@ -0,0 +1,47 @@
|
|||||||
|
subroutine cisdtq_scf_iteration(converged,iteration,energy,thr)
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: thr
|
||||||
|
logical, intent(out) :: converged
|
||||||
|
integer, intent(inout) :: iteration
|
||||||
|
double precision, intent(inout) :: energy
|
||||||
|
converged = .False.
|
||||||
|
call only_act_bitmask
|
||||||
|
generators_type = "HF_SD"
|
||||||
|
threshold_generators = 0.99d0
|
||||||
|
touch threshold_generators
|
||||||
|
touch generators_type
|
||||||
|
selection_factor = 5
|
||||||
|
touch selection_factor
|
||||||
|
call run_stochastic_cipsi
|
||||||
|
call change_orb_cisdtq(converged,iteration,energy,thr)
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine change_orb_cisdtq(converged,iteration,energy,thr)
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: thr
|
||||||
|
logical, intent(inout) :: converged
|
||||||
|
integer, intent(inout) :: iteration
|
||||||
|
double precision, intent(inout) :: energy
|
||||||
|
double precision :: extrap,extrap_old,pt2_max_begin
|
||||||
|
extrap_old = energy
|
||||||
|
extrap = extrapolated_energy(2,1)
|
||||||
|
energy = extrap
|
||||||
|
|
||||||
|
call write_time(6)
|
||||||
|
call write_int(6,iteration,'CISDTQ-SCF iteration')
|
||||||
|
call write_double(6,energy,'CISDTQ-SCF variational energy')
|
||||||
|
call write_double(6,extrap,'CISDTQ-SCF extrapolated energy')
|
||||||
|
call write_double(6,extrap - extrap_old,'Change in extrapolated energy')
|
||||||
|
|
||||||
|
converged = dabs(extrap - extrap_old) < thr
|
||||||
|
pt2_max = dabs(extrap - extrap_old) * 10.d0
|
||||||
|
pt2_max = max(pt2_max,1.d-10)
|
||||||
|
|
||||||
|
mo_coef = NewOrbs
|
||||||
|
call save_mos
|
||||||
|
call map_deinit(mo_integrals_map)
|
||||||
|
FREE mo_integrals_map mo_two_e_integrals_in_map
|
||||||
|
iteration += 1
|
||||||
|
|
||||||
|
end
|
||||||
|
|
12
src/casscf/class.irp.f
Normal file
12
src/casscf/class.irp.f
Normal file
@ -0,0 +1,12 @@
|
|||||||
|
BEGIN_PROVIDER [ logical, do_only_1h1p ]
|
||||||
|
&BEGIN_PROVIDER [ logical, do_only_cas ]
|
||||||
|
&BEGIN_PROVIDER [ logical, do_ddci ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! In the CAS case, all those are always false except do_only_cas
|
||||||
|
END_DOC
|
||||||
|
do_only_cas = .True.
|
||||||
|
do_only_1h1p = .False.
|
||||||
|
do_ddci = .False.
|
||||||
|
END_PROVIDER
|
||||||
|
|
67
src/casscf/densities.irp.f
Normal file
67
src/casscf/densities.irp.f
Normal file
@ -0,0 +1,67 @@
|
|||||||
|
use bitmasks
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! the first-order density matrix in the basis of the starting MOs.
|
||||||
|
! matrix is state averaged.
|
||||||
|
END_DOC
|
||||||
|
integer :: t,u
|
||||||
|
|
||||||
|
do u=1,n_act_orb
|
||||||
|
do t=1,n_act_orb
|
||||||
|
D0tu(t,u) = one_e_dm_mo_alpha_average( list_act(t), list_act(u) ) + &
|
||||||
|
one_e_dm_mo_beta_average ( list_act(t), list_act(u) )
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ]
|
||||||
|
BEGIN_DOC
|
||||||
|
! The second-order density matrix in the basis of the starting MOs ONLY IN THE RANGE OF ACTIVE MOS
|
||||||
|
! The values are state averaged
|
||||||
|
!
|
||||||
|
! We use the spin-free generators of mono-excitations
|
||||||
|
! E_pq destroys q and creates p
|
||||||
|
! D_pq = <0|E_pq|0> = D_qp
|
||||||
|
! P_pqrs = 1/2 <0|E_pq E_rs - delta_qr E_ps|0>
|
||||||
|
!
|
||||||
|
! P0tuvx(p,q,r,s) = chemist notation : 1/2 <0|E_pq E_rs - delta_qr E_ps|0>
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: t,u,v,x
|
||||||
|
integer :: tt,uu,vv,xx
|
||||||
|
integer :: mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart
|
||||||
|
integer :: ierr
|
||||||
|
real*8 :: phase1,phase11,phase12,phase2,phase21,phase22
|
||||||
|
integer :: nu1,nu2,nu11,nu12,nu21,nu22
|
||||||
|
integer :: ierr1,ierr2,ierr11,ierr12,ierr21,ierr22
|
||||||
|
real*8 :: cI_mu(N_states),term
|
||||||
|
integer(bit_kind), dimension(N_int,2) :: det_mu, det_mu_ex
|
||||||
|
integer(bit_kind), dimension(N_int,2) :: det_mu_ex1, det_mu_ex11, det_mu_ex12
|
||||||
|
integer(bit_kind), dimension(N_int,2) :: det_mu_ex2, det_mu_ex21, det_mu_ex22
|
||||||
|
|
||||||
|
if (bavard) then
|
||||||
|
write(6,*) ' providing the 2 body RDM on the active part'
|
||||||
|
endif
|
||||||
|
|
||||||
|
P0tuvx= 0.d0
|
||||||
|
do istate=1,N_states
|
||||||
|
do x = 1, n_act_orb
|
||||||
|
xx = list_act(x)
|
||||||
|
do v = 1, n_act_orb
|
||||||
|
vv = list_act(v)
|
||||||
|
do u = 1, n_act_orb
|
||||||
|
uu = list_act(u)
|
||||||
|
do t = 1, n_act_orb
|
||||||
|
tt = list_act(t)
|
||||||
|
! P0tuvx(t,u,v,x) = state_av_act_two_rdm_openmp_spin_trace_mo(t,v,u,x)
|
||||||
|
P0tuvx(t,u,v,x) = state_av_act_two_rdm_spin_trace_mo(t,v,u,x)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
125
src/casscf/det_manip.irp.f
Normal file
125
src/casscf/det_manip.irp.f
Normal file
@ -0,0 +1,125 @@
|
|||||||
|
use bitmasks
|
||||||
|
|
||||||
|
subroutine do_signed_mono_excitation(key1,key2,nu,ihole,ipart, &
|
||||||
|
ispin,phase,ierr)
|
||||||
|
BEGIN_DOC
|
||||||
|
! we create the mono-excitation, and determine, if possible,
|
||||||
|
! the phase and the number in the list of determinants
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer(bit_kind) :: key1(N_int,2),key2(N_int,2)
|
||||||
|
integer(bit_kind), allocatable :: keytmp(:,:)
|
||||||
|
integer :: exc(0:2,2,2),ihole,ipart,ierr,nu,ispin
|
||||||
|
real*8 :: phase
|
||||||
|
logical :: found
|
||||||
|
allocate(keytmp(N_int,2))
|
||||||
|
|
||||||
|
nu=-1
|
||||||
|
phase=1.D0
|
||||||
|
ierr=0
|
||||||
|
call det_copy(key1,key2,N_int)
|
||||||
|
! write(6,*) ' key2 before excitation ',ihole,' -> ',ipart,' spin = ',ispin
|
||||||
|
! call print_det(key2,N_int)
|
||||||
|
call do_single_excitation(key2,ihole,ipart,ispin,ierr)
|
||||||
|
! write(6,*) ' key2 after ',ihole,' -> ',ipart,' spin = ',ispin
|
||||||
|
! call print_det(key2,N_int)
|
||||||
|
! write(6,*) ' excitation ',ihole,' -> ',ipart,' gives ierr = ',ierr
|
||||||
|
if (ierr.eq.1) then
|
||||||
|
! excitation is possible
|
||||||
|
! get the phase
|
||||||
|
call get_single_excitation(key1,key2,exc,phase,N_int)
|
||||||
|
! get the number in the list
|
||||||
|
found=.false.
|
||||||
|
nu=0
|
||||||
|
|
||||||
|
!TODO BOTTLENECK
|
||||||
|
do while (.not.found)
|
||||||
|
nu+=1
|
||||||
|
if (nu.gt.N_det) then
|
||||||
|
! the determinant is possible, but not in the list
|
||||||
|
found=.true.
|
||||||
|
nu=-1
|
||||||
|
else
|
||||||
|
call det_extract(keytmp,nu,N_int)
|
||||||
|
integer :: i,ii
|
||||||
|
found=.true.
|
||||||
|
do ii=1,2
|
||||||
|
do i=1,N_int
|
||||||
|
if (keytmp(i,ii).ne.key2(i,ii)) then
|
||||||
|
found=.false.
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
!
|
||||||
|
! we found the new string, the phase, and possibly the number in the list
|
||||||
|
!
|
||||||
|
end subroutine do_signed_mono_excitation
|
||||||
|
|
||||||
|
subroutine det_extract(key,nu,Nint)
|
||||||
|
BEGIN_DOC
|
||||||
|
! extract a determinant from the list of determinants
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: ispin,i,nu,Nint
|
||||||
|
integer(bit_kind) :: key(Nint,2)
|
||||||
|
do ispin=1,2
|
||||||
|
do i=1,Nint
|
||||||
|
key(i,ispin)=psi_det(i,ispin,nu)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end subroutine det_extract
|
||||||
|
|
||||||
|
subroutine det_copy(key1,key2,Nint)
|
||||||
|
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||||
|
BEGIN_DOC
|
||||||
|
! copy a determinant from key1 to key2
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: ispin,i,Nint
|
||||||
|
integer(bit_kind) :: key1(Nint,2),key2(Nint,2)
|
||||||
|
do ispin=1,2
|
||||||
|
do i=1,Nint
|
||||||
|
key2(i,ispin)=key1(i,ispin)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end subroutine det_copy
|
||||||
|
|
||||||
|
subroutine do_spinfree_mono_excitation(key_in,key_out1,key_out2 &
|
||||||
|
,nu1,nu2,ihole,ipart,phase1,phase2,ierr,jerr)
|
||||||
|
BEGIN_DOC
|
||||||
|
! we create the spin-free mono-excitation E_pq=(a^+_p a_q + a^+_P a_Q)
|
||||||
|
! we may create two determinants as result
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer(bit_kind) :: key_in(N_int,2),key_out1(N_int,2)
|
||||||
|
integer(bit_kind) :: key_out2(N_int,2)
|
||||||
|
integer :: ihole,ipart,ierr,jerr,nu1,nu2
|
||||||
|
integer :: ispin
|
||||||
|
real*8 :: phase1,phase2
|
||||||
|
|
||||||
|
! write(6,*) ' applying E_',ipart,ihole,' on determinant '
|
||||||
|
! call print_det(key_in,N_int)
|
||||||
|
|
||||||
|
! spin alpha
|
||||||
|
ispin=1
|
||||||
|
call do_signed_mono_excitation(key_in,key_out1,nu1,ihole &
|
||||||
|
,ipart,ispin,phase1,ierr)
|
||||||
|
! if (ierr.eq.1) then
|
||||||
|
! write(6,*) ' 1 result is ',nu1,phase1
|
||||||
|
! call print_det(key_out1,N_int)
|
||||||
|
! end if
|
||||||
|
! spin beta
|
||||||
|
ispin=2
|
||||||
|
call do_signed_mono_excitation(key_in,key_out2,nu2,ihole &
|
||||||
|
,ipart,ispin,phase2,jerr)
|
||||||
|
! if (jerr.eq.1) then
|
||||||
|
! write(6,*) ' 2 result is ',nu2,phase2
|
||||||
|
! call print_det(key_out2,N_int)
|
||||||
|
! end if
|
||||||
|
|
||||||
|
end subroutine do_spinfree_mono_excitation
|
||||||
|
|
3
src/casscf/driver_optorb.irp.f
Normal file
3
src/casscf/driver_optorb.irp.f
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
subroutine driver_optorb
|
||||||
|
implicit none
|
||||||
|
end
|
57
src/casscf/get_energy.irp.f
Normal file
57
src/casscf/get_energy.irp.f
Normal file
@ -0,0 +1,57 @@
|
|||||||
|
program print_2rdm
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! get the active part of the bielectronic energy on a given wave function.
|
||||||
|
!
|
||||||
|
! useful to test the active part of the spin trace 2 rdms
|
||||||
|
END_DOC
|
||||||
|
no_vvvv_integrals = .True.
|
||||||
|
read_wf = .True.
|
||||||
|
touch read_wf no_vvvv_integrals
|
||||||
|
call routine
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine routine
|
||||||
|
integer :: i,j,k,l
|
||||||
|
integer :: ii,jj,kk,ll
|
||||||
|
double precision :: accu(4),twodm,thr,act_twodm2,integral,get_two_e_integral
|
||||||
|
thr = 1.d-10
|
||||||
|
|
||||||
|
|
||||||
|
accu = 0.d0
|
||||||
|
do ll = 1, n_act_orb
|
||||||
|
l = list_act(ll)
|
||||||
|
do kk = 1, n_act_orb
|
||||||
|
k = list_act(kk)
|
||||||
|
do jj = 1, n_act_orb
|
||||||
|
j = list_act(jj)
|
||||||
|
do ii = 1, n_act_orb
|
||||||
|
i = list_act(ii)
|
||||||
|
integral = get_two_e_integral(i,j,k,l,mo_integrals_map)
|
||||||
|
accu(1) += state_av_act_two_rdm_spin_trace_mo(ii,jj,kk,ll) * integral
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*,'accu = ',accu(1)
|
||||||
|
|
||||||
|
accu = 0.d0
|
||||||
|
do ll = 1, n_act_orb
|
||||||
|
l = list_act(ll)
|
||||||
|
do kk = 1, n_act_orb
|
||||||
|
k = list_act(kk)
|
||||||
|
do jj = 1, n_act_orb
|
||||||
|
j = list_act(jj)
|
||||||
|
do ii = 1, n_act_orb
|
||||||
|
i = list_act(ii)
|
||||||
|
integral = get_two_e_integral(i,j,k,l,mo_integrals_map)
|
||||||
|
accu(1) += state_av_act_two_rdm_openmp_spin_trace_mo(ii,jj,kk,ll) * integral
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*,'accu = ',accu(1)
|
||||||
|
print*,'psi_energy_two_e = ',psi_energy_two_e
|
||||||
|
|
||||||
|
print *, psi_energy_with_nucl_rep
|
||||||
|
end
|
246
src/casscf/gradient.irp.f
Normal file
246
src/casscf/gradient.irp.f
Normal file
@ -0,0 +1,246 @@
|
|||||||
|
use bitmasks
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, nMonoEx ]
|
||||||
|
BEGIN_DOC
|
||||||
|
! Number of single excitations
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
nMonoEx=n_core_inact_orb*n_act_orb+n_core_inact_orb*n_virt_orb+n_act_orb*n_virt_orb
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [integer, excit, (2,nMonoEx)]
|
||||||
|
&BEGIN_PROVIDER [character*3, excit_class, (nMonoEx)]
|
||||||
|
BEGIN_DOC
|
||||||
|
! a list of the orbitals involved in the excitation
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i,t,a,ii,tt,aa,indx
|
||||||
|
indx=0
|
||||||
|
do ii=1,n_core_inact_orb
|
||||||
|
i=list_core_inact(ii)
|
||||||
|
do tt=1,n_act_orb
|
||||||
|
t=list_act(tt)
|
||||||
|
indx+=1
|
||||||
|
excit(1,indx)=i
|
||||||
|
excit(2,indx)=t
|
||||||
|
excit_class(indx)='c-a'
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
do ii=1,n_core_inact_orb
|
||||||
|
i=list_core_inact(ii)
|
||||||
|
do aa=1,n_virt_orb
|
||||||
|
a=list_virt(aa)
|
||||||
|
indx+=1
|
||||||
|
excit(1,indx)=i
|
||||||
|
excit(2,indx)=a
|
||||||
|
excit_class(indx)='c-v'
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
do tt=1,n_act_orb
|
||||||
|
t=list_act(tt)
|
||||||
|
do aa=1,n_virt_orb
|
||||||
|
a=list_virt(aa)
|
||||||
|
indx+=1
|
||||||
|
excit(1,indx)=t
|
||||||
|
excit(2,indx)=a
|
||||||
|
excit_class(indx)='a-v'
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
if (bavard) then
|
||||||
|
write(6,*) ' Filled the table of the Monoexcitations '
|
||||||
|
do indx=1,nMonoEx
|
||||||
|
write(6,*) ' ex ',indx,' : ',excit(1,indx),' -> ' &
|
||||||
|
,excit(2,indx),' ',excit_class(indx)
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, gradvec, (nMonoEx)]
|
||||||
|
BEGIN_DOC
|
||||||
|
! calculate the orbital gradient <Psi| H E_pq |Psi> by hand, i.e. for
|
||||||
|
! each determinant I we determine the string E_pq |I> (alpha and beta
|
||||||
|
! separately) and generate <Psi|H E_pq |I>
|
||||||
|
! sum_I c_I <Psi|H E_pq |I> is then the pq component of the orbital
|
||||||
|
! gradient
|
||||||
|
! E_pq = a^+_pa_q + a^+_Pa_Q
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: ii,tt,aa,indx,ihole,ipart,istate
|
||||||
|
real*8 :: res
|
||||||
|
|
||||||
|
do indx=1,nMonoEx
|
||||||
|
ihole=excit(1,indx)
|
||||||
|
ipart=excit(2,indx)
|
||||||
|
call calc_grad_elem(ihole,ipart,res)
|
||||||
|
gradvec(indx)=res
|
||||||
|
end do
|
||||||
|
|
||||||
|
real*8 :: norm_grad
|
||||||
|
norm_grad=0.d0
|
||||||
|
do indx=1,nMonoEx
|
||||||
|
norm_grad+=gradvec(indx)*gradvec(indx)
|
||||||
|
end do
|
||||||
|
norm_grad=sqrt(norm_grad)
|
||||||
|
if (bavard) then
|
||||||
|
write(6,*)
|
||||||
|
write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad
|
||||||
|
write(6,*)
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
subroutine calc_grad_elem(ihole,ipart,res)
|
||||||
|
BEGIN_DOC
|
||||||
|
! eq 18 of Siegbahn et al, Physica Scripta 1980
|
||||||
|
! we calculate 2 <Psi| H E_pq | Psi>, q=hole, p=particle
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: ihole,ipart,mu,iii,ispin,ierr,nu,istate
|
||||||
|
real*8 :: res
|
||||||
|
integer(bit_kind), allocatable :: det_mu(:,:),det_mu_ex(:,:)
|
||||||
|
real*8 :: i_H_psi_array(N_states),phase
|
||||||
|
allocate(det_mu(N_int,2))
|
||||||
|
allocate(det_mu_ex(N_int,2))
|
||||||
|
|
||||||
|
res=0.D0
|
||||||
|
|
||||||
|
do mu=1,n_det
|
||||||
|
! get the string of the determinant
|
||||||
|
call det_extract(det_mu,mu,N_int)
|
||||||
|
do ispin=1,2
|
||||||
|
! do the monoexcitation on it
|
||||||
|
call det_copy(det_mu,det_mu_ex,N_int)
|
||||||
|
call do_signed_mono_excitation(det_mu,det_mu_ex,nu &
|
||||||
|
,ihole,ipart,ispin,phase,ierr)
|
||||||
|
if (ierr.eq.1) then
|
||||||
|
call i_H_psi(det_mu_ex,psi_det,psi_coef,N_int &
|
||||||
|
,N_det,N_det,N_states,i_H_psi_array)
|
||||||
|
do istate=1,N_states
|
||||||
|
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
! state-averaged gradient
|
||||||
|
res*=2.D0/dble(N_states)
|
||||||
|
|
||||||
|
end subroutine calc_grad_elem
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, gradvec2, (nMonoEx)]
|
||||||
|
BEGIN_DOC
|
||||||
|
! calculate the orbital gradient <Psi| H E_pq |Psi> from density
|
||||||
|
! matrices and integrals; Siegbahn et al, Phys Scr 1980
|
||||||
|
! eqs 14 a,b,c
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,t,a,indx
|
||||||
|
real*8 :: gradvec_it,gradvec_ia,gradvec_ta
|
||||||
|
real*8 :: norm_grad
|
||||||
|
|
||||||
|
indx=0
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
do t=1,n_act_orb
|
||||||
|
indx+=1
|
||||||
|
gradvec2(indx)=gradvec_it(i,t)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
do a=1,n_virt_orb
|
||||||
|
indx+=1
|
||||||
|
gradvec2(indx)=gradvec_ia(i,a)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
do t=1,n_act_orb
|
||||||
|
do a=1,n_virt_orb
|
||||||
|
indx+=1
|
||||||
|
gradvec2(indx)=gradvec_ta(t,a)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
norm_grad=0.d0
|
||||||
|
do indx=1,nMonoEx
|
||||||
|
norm_grad+=gradvec2(indx)*gradvec2(indx)
|
||||||
|
end do
|
||||||
|
norm_grad=sqrt(norm_grad)
|
||||||
|
! if (bavard) then
|
||||||
|
write(6,*)
|
||||||
|
write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad
|
||||||
|
write(6,*)
|
||||||
|
! endif
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
real*8 function gradvec_it(i,t)
|
||||||
|
BEGIN_DOC
|
||||||
|
! the orbital gradient core/inactive -> active
|
||||||
|
! we assume natural orbitals
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,t
|
||||||
|
|
||||||
|
integer :: ii,tt,v,vv,x,y
|
||||||
|
integer :: x3,y3
|
||||||
|
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
tt=list_act(t)
|
||||||
|
gradvec_it=2.D0*(Fipq(tt,ii)+Fapq(tt,ii))
|
||||||
|
gradvec_it-=occnum(tt)*Fipq(ii,tt)
|
||||||
|
do v=1,n_act_orb
|
||||||
|
vv=list_act(v)
|
||||||
|
do x=1,n_act_orb
|
||||||
|
x3=x+n_core_inact_orb
|
||||||
|
do y=1,n_act_orb
|
||||||
|
y3=y+n_core_inact_orb
|
||||||
|
gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx_no(ii,vv,x3,y3)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
gradvec_it*=2.D0
|
||||||
|
end function gradvec_it
|
||||||
|
|
||||||
|
real*8 function gradvec_ia(i,a)
|
||||||
|
BEGIN_DOC
|
||||||
|
! the orbital gradient core/inactive -> virtual
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,a,ii,aa
|
||||||
|
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
aa=list_virt(a)
|
||||||
|
gradvec_ia=2.D0*(Fipq(aa,ii)+Fapq(aa,ii))
|
||||||
|
gradvec_ia*=2.D0
|
||||||
|
|
||||||
|
end function gradvec_ia
|
||||||
|
|
||||||
|
real*8 function gradvec_ta(t,a)
|
||||||
|
BEGIN_DOC
|
||||||
|
! the orbital gradient active -> virtual
|
||||||
|
! we assume natural orbitals
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: t,a,tt,aa,v,vv,x,y
|
||||||
|
|
||||||
|
tt=list_act(t)
|
||||||
|
aa=list_virt(a)
|
||||||
|
gradvec_ta=0.D0
|
||||||
|
gradvec_ta+=occnum(tt)*Fipq(aa,tt)
|
||||||
|
do v=1,n_act_orb
|
||||||
|
do x=1,n_act_orb
|
||||||
|
do y=1,n_act_orb
|
||||||
|
gradvec_ta+=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,aa)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
gradvec_ta*=2.D0
|
||||||
|
|
||||||
|
end function gradvec_ta
|
||||||
|
|
18
src/casscf/h_apply.irp.f
Normal file
18
src/casscf/h_apply.irp.f
Normal file
@ -0,0 +1,18 @@
|
|||||||
|
! Generates subroutine H_apply_cisd
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
BEGIN_SHELL [ /usr/bin/env python2 ]
|
||||||
|
from generate_h_apply import H_apply
|
||||||
|
H = H_apply("cisd",do_double_exc=True)
|
||||||
|
print H
|
||||||
|
|
||||||
|
from generate_h_apply import H_apply
|
||||||
|
H = H_apply("cisdtq",do_double_exc=True)
|
||||||
|
H.set_selection_pt2("epstein_nesbet_2x2")
|
||||||
|
print H
|
||||||
|
|
||||||
|
H = H_apply("cisd_sym",do_double_exc=True)
|
||||||
|
H.filter_only_connected_to_hf()
|
||||||
|
print H
|
||||||
|
END_SHELL
|
||||||
|
|
687
src/casscf/hessian.irp.f
Normal file
687
src/casscf/hessian.irp.f
Normal file
@ -0,0 +1,687 @@
|
|||||||
|
use bitmasks
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, hessmat, (nMonoEx,nMonoEx)]
|
||||||
|
BEGIN_DOC
|
||||||
|
! calculate the orbital hessian 2 <Psi| E_pq H E_rs |Psi>
|
||||||
|
! + <Psi| E_pq E_rs H |Psi> + <Psi| E_rs E_pq H |Psi> by hand,
|
||||||
|
! determinant per determinant, as for the gradient
|
||||||
|
!
|
||||||
|
! we assume that we have natural active orbitals
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: indx,ihole,ipart
|
||||||
|
integer :: jndx,jhole,jpart
|
||||||
|
character*3 :: iexc,jexc
|
||||||
|
real*8 :: res
|
||||||
|
|
||||||
|
if (bavard) then
|
||||||
|
write(6,*) ' providing Hessian matrix hessmat '
|
||||||
|
write(6,*) ' nMonoEx = ',nMonoEx
|
||||||
|
endif
|
||||||
|
|
||||||
|
do indx=1,nMonoEx
|
||||||
|
do jndx=1,nMonoEx
|
||||||
|
hessmat(indx,jndx)=0.D0
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
do indx=1,nMonoEx
|
||||||
|
ihole=excit(1,indx)
|
||||||
|
ipart=excit(2,indx)
|
||||||
|
iexc=excit_class(indx)
|
||||||
|
do jndx=indx,nMonoEx
|
||||||
|
jhole=excit(1,jndx)
|
||||||
|
jpart=excit(2,jndx)
|
||||||
|
jexc=excit_class(jndx)
|
||||||
|
call calc_hess_elem(ihole,ipart,jhole,jpart,res)
|
||||||
|
hessmat(indx,jndx)=res
|
||||||
|
hessmat(jndx,indx)=res
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
subroutine calc_hess_elem(ihole,ipart,jhole,jpart,res)
|
||||||
|
BEGIN_DOC
|
||||||
|
! eq 19 of Siegbahn et al, Physica Scripta 1980
|
||||||
|
! we calculate 2 <Psi| E_pq H E_rs |Psi>
|
||||||
|
! + <Psi| E_pq E_rs H |Psi> + <Psi| E_rs E_pq H |Psi>
|
||||||
|
! average over all states is performed.
|
||||||
|
! no transition between states.
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: ihole,ipart,ispin,mu,istate
|
||||||
|
integer :: jhole,jpart,jspin
|
||||||
|
integer :: mu_pq, mu_pqrs, mu_rs, mu_rspq, nu_rs,nu
|
||||||
|
real*8 :: res
|
||||||
|
integer(bit_kind), allocatable :: det_mu(:,:)
|
||||||
|
integer(bit_kind), allocatable :: det_nu(:,:)
|
||||||
|
integer(bit_kind), allocatable :: det_mu_pq(:,:)
|
||||||
|
integer(bit_kind), allocatable :: det_mu_rs(:,:)
|
||||||
|
integer(bit_kind), allocatable :: det_nu_rs(:,:)
|
||||||
|
integer(bit_kind), allocatable :: det_mu_pqrs(:,:)
|
||||||
|
integer(bit_kind), allocatable :: det_mu_rspq(:,:)
|
||||||
|
real*8 :: i_H_psi_array(N_states),phase,phase2,phase3
|
||||||
|
real*8 :: i_H_j_element
|
||||||
|
allocate(det_mu(N_int,2))
|
||||||
|
allocate(det_nu(N_int,2))
|
||||||
|
allocate(det_mu_pq(N_int,2))
|
||||||
|
allocate(det_mu_rs(N_int,2))
|
||||||
|
allocate(det_nu_rs(N_int,2))
|
||||||
|
allocate(det_mu_pqrs(N_int,2))
|
||||||
|
allocate(det_mu_rspq(N_int,2))
|
||||||
|
integer :: mu_pq_possible
|
||||||
|
integer :: mu_rs_possible
|
||||||
|
integer :: nu_rs_possible
|
||||||
|
integer :: mu_pqrs_possible
|
||||||
|
integer :: mu_rspq_possible
|
||||||
|
|
||||||
|
res=0.D0
|
||||||
|
|
||||||
|
! the terms <0|E E H |0>
|
||||||
|
do mu=1,n_det
|
||||||
|
! get the string of the determinant
|
||||||
|
call det_extract(det_mu,mu,N_int)
|
||||||
|
do ispin=1,2
|
||||||
|
! do the monoexcitation pq on it
|
||||||
|
call det_copy(det_mu,det_mu_pq,N_int)
|
||||||
|
call do_signed_mono_excitation(det_mu,det_mu_pq,mu_pq &
|
||||||
|
,ihole,ipart,ispin,phase,mu_pq_possible)
|
||||||
|
if (mu_pq_possible.eq.1) then
|
||||||
|
! possible, but not necessarily in the list
|
||||||
|
! do the second excitation
|
||||||
|
do jspin=1,2
|
||||||
|
call det_copy(det_mu_pq,det_mu_pqrs,N_int)
|
||||||
|
call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs&
|
||||||
|
,jhole,jpart,jspin,phase2,mu_pqrs_possible)
|
||||||
|
! excitation possible
|
||||||
|
if (mu_pqrs_possible.eq.1) then
|
||||||
|
call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int &
|
||||||
|
,N_det,N_det,N_states,i_H_psi_array)
|
||||||
|
do istate=1,N_states
|
||||||
|
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
! try the de-excitation with opposite sign
|
||||||
|
call det_copy(det_mu_pq,det_mu_pqrs,N_int)
|
||||||
|
call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs&
|
||||||
|
,jpart,jhole,jspin,phase2,mu_pqrs_possible)
|
||||||
|
phase2=-phase2
|
||||||
|
! excitation possible
|
||||||
|
if (mu_pqrs_possible.eq.1) then
|
||||||
|
call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int &
|
||||||
|
,N_det,N_det,N_states,i_H_psi_array)
|
||||||
|
do istate=1,N_states
|
||||||
|
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
! exchange the notion of pq and rs
|
||||||
|
! do the monoexcitation rs on the initial determinant
|
||||||
|
call det_copy(det_mu,det_mu_rs,N_int)
|
||||||
|
call do_signed_mono_excitation(det_mu,det_mu_rs,mu_rs &
|
||||||
|
,jhole,jpart,ispin,phase2,mu_rs_possible)
|
||||||
|
if (mu_rs_possible.eq.1) then
|
||||||
|
! do the second excitation
|
||||||
|
do jspin=1,2
|
||||||
|
call det_copy(det_mu_rs,det_mu_rspq,N_int)
|
||||||
|
call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq&
|
||||||
|
,ihole,ipart,jspin,phase3,mu_rspq_possible)
|
||||||
|
! excitation possible (of course, the result is outside the CAS)
|
||||||
|
if (mu_rspq_possible.eq.1) then
|
||||||
|
call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int &
|
||||||
|
,N_det,N_det,N_states,i_H_psi_array)
|
||||||
|
do istate=1,N_states
|
||||||
|
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
! we may try the de-excitation, with opposite sign
|
||||||
|
call det_copy(det_mu_rs,det_mu_rspq,N_int)
|
||||||
|
call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq&
|
||||||
|
,ipart,ihole,jspin,phase3,mu_rspq_possible)
|
||||||
|
phase3=-phase3
|
||||||
|
! excitation possible (of course, the result is outside the CAS)
|
||||||
|
if (mu_rspq_possible.eq.1) then
|
||||||
|
call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int &
|
||||||
|
,N_det,N_det,N_states,i_H_psi_array)
|
||||||
|
do istate=1,N_states
|
||||||
|
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
!
|
||||||
|
! the operator E H E, we have to do a double loop over the determinants
|
||||||
|
! we still have the determinant mu_pq and the phase in memory
|
||||||
|
if (mu_pq_possible.eq.1) then
|
||||||
|
do nu=1,N_det
|
||||||
|
call det_extract(det_nu,nu,N_int)
|
||||||
|
do jspin=1,2
|
||||||
|
call det_copy(det_nu,det_nu_rs,N_int)
|
||||||
|
call do_signed_mono_excitation(det_nu,det_nu_rs,nu_rs &
|
||||||
|
,jhole,jpart,jspin,phase2,nu_rs_possible)
|
||||||
|
! excitation possible ?
|
||||||
|
if (nu_rs_possible.eq.1) then
|
||||||
|
call i_H_j(det_mu_pq,det_nu_rs,N_int,i_H_j_element)
|
||||||
|
do istate=1,N_states
|
||||||
|
res+=2.D0*i_H_j_element*psi_coef(mu,istate) &
|
||||||
|
*psi_coef(nu,istate)*phase*phase2
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
! state-averaged Hessian
|
||||||
|
res*=1.D0/dble(N_states)
|
||||||
|
|
||||||
|
end subroutine calc_hess_elem
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)]
|
||||||
|
BEGIN_DOC
|
||||||
|
! explicit hessian matrix from density matrices and integrals
|
||||||
|
! of course, this will be used for a direct Davidson procedure later
|
||||||
|
! we will not store the matrix in real life
|
||||||
|
! formulas are broken down as functions for the 6 classes of matrix elements
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,j,t,u,a,b,indx,jndx,bstart,ustart,indx_shift
|
||||||
|
|
||||||
|
real*8 :: hessmat_itju
|
||||||
|
real*8 :: hessmat_itja
|
||||||
|
real*8 :: hessmat_itua
|
||||||
|
real*8 :: hessmat_iajb
|
||||||
|
real*8 :: hessmat_iatb
|
||||||
|
real*8 :: hessmat_taub
|
||||||
|
|
||||||
|
if (bavard) then
|
||||||
|
write(6,*) ' providing Hessian matrix hessmat2 '
|
||||||
|
write(6,*) ' nMonoEx = ',nMonoEx
|
||||||
|
endif
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT(NONE) &
|
||||||
|
!$OMP SHARED(hessmat2,n_core_inact_orb,n_act_orb,n_virt_orb,nMonoEx) &
|
||||||
|
!$OMP PRIVATE(i,indx,jndx,j,ustart,t,u,a,bstart,indx_shift)
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
do t=1,n_act_orb
|
||||||
|
indx = t + (i-1)*n_act_orb
|
||||||
|
jndx=indx
|
||||||
|
do j=i,n_core_inact_orb
|
||||||
|
if (i.eq.j) then
|
||||||
|
ustart=t
|
||||||
|
else
|
||||||
|
ustart=1
|
||||||
|
end if
|
||||||
|
do u=ustart,n_act_orb
|
||||||
|
hessmat2(jndx,indx)=hessmat_itju(i,t,j,u)
|
||||||
|
jndx+=1
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do j=1,n_core_inact_orb
|
||||||
|
do a=1,n_virt_orb
|
||||||
|
hessmat2(jndx,indx)=hessmat_itja(i,t,j,a)
|
||||||
|
jndx+=1
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do u=1,n_act_orb
|
||||||
|
do a=1,n_virt_orb
|
||||||
|
hessmat2(jndx,indx)=hessmat_itua(i,t,u,a)
|
||||||
|
jndx+=1
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
|
indx_shift = n_core_inact_orb*n_act_orb
|
||||||
|
!$OMP DO
|
||||||
|
do a=1,n_virt_orb
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
indx = a + (i-1)*n_virt_orb + indx_shift
|
||||||
|
jndx=indx
|
||||||
|
do j=i,n_core_inact_orb
|
||||||
|
if (i.eq.j) then
|
||||||
|
bstart=a
|
||||||
|
else
|
||||||
|
bstart=1
|
||||||
|
end if
|
||||||
|
do b=bstart,n_virt_orb
|
||||||
|
hessmat2(jndx,indx)=hessmat_iajb(i,a,j,b)
|
||||||
|
jndx+=1
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do t=1,n_act_orb
|
||||||
|
do b=1,n_virt_orb
|
||||||
|
hessmat2(jndx,indx)=hessmat_iatb(i,a,t,b)
|
||||||
|
jndx+=1
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
|
indx_shift += n_core_inact_orb*n_virt_orb
|
||||||
|
!$OMP DO
|
||||||
|
do a=1,n_virt_orb
|
||||||
|
do t=1,n_act_orb
|
||||||
|
indx = a + (t-1)*n_virt_orb + indx_shift
|
||||||
|
jndx=indx
|
||||||
|
do u=t,n_act_orb
|
||||||
|
if (t.eq.u) then
|
||||||
|
bstart=a
|
||||||
|
else
|
||||||
|
bstart=1
|
||||||
|
end if
|
||||||
|
do b=bstart,n_virt_orb
|
||||||
|
hessmat2(jndx,indx)=hessmat_taub(t,a,u,b)
|
||||||
|
jndx+=1
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO
|
||||||
|
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
do jndx=1,nMonoEx
|
||||||
|
do indx=1,jndx-1
|
||||||
|
hessmat2(indx,jndx) = hessmat2(jndx,indx)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
real*8 function hessmat_itju(i,t,j,u)
|
||||||
|
BEGIN_DOC
|
||||||
|
! the orbital hessian for core/inactive -> active, core/inactive -> active
|
||||||
|
! i, t, j, u are list indices, the corresponding orbitals are ii,tt,jj,uu
|
||||||
|
!
|
||||||
|
! we assume natural orbitals
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj
|
||||||
|
real*8 :: term,t2
|
||||||
|
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
tt=list_act(t)
|
||||||
|
if (i.eq.j) then
|
||||||
|
if (t.eq.u) then
|
||||||
|
! diagonal element
|
||||||
|
term=occnum(tt)*Fipq(ii,ii)+2.D0*(Fipq(tt,tt)+Fapq(tt,tt)) &
|
||||||
|
-2.D0*(Fipq(ii,ii)+Fapq(ii,ii))
|
||||||
|
term+=2.D0*(3.D0*bielec_pxxq_no(tt,i,i,tt)-bielec_pqxx_no(tt,tt,i,i))
|
||||||
|
term-=2.D0*occnum(tt)*(3.D0*bielec_pxxq_no(tt,i,i,tt) &
|
||||||
|
-bielec_pqxx_no(tt,tt,i,i))
|
||||||
|
term-=occnum(tt)*Fipq(tt,tt)
|
||||||
|
do v=1,n_act_orb
|
||||||
|
vv=list_act(v)
|
||||||
|
do x=1,n_act_orb
|
||||||
|
xx=list_act(x)
|
||||||
|
term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(vv,xx,i,i) &
|
||||||
|
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* &
|
||||||
|
bielec_pxxq_no(vv,i,i,xx))
|
||||||
|
do y=1,n_act_orb
|
||||||
|
term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
else
|
||||||
|
! it/iu, t != u
|
||||||
|
uu=list_act(u)
|
||||||
|
term=2.D0*(Fipq(tt,uu)+Fapq(tt,uu))
|
||||||
|
term+=2.D0*(4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) &
|
||||||
|
-bielec_PQxx_no(tt,uu,i,j))
|
||||||
|
term-=occnum(tt)*Fipq(uu,tt)
|
||||||
|
term-=(occnum(tt)+occnum(uu)) &
|
||||||
|
*(3.D0*bielec_PxxQ_no(tt,i,i,uu)-bielec_PQxx_no(uu,tt,i,i))
|
||||||
|
do v=1,n_act_orb
|
||||||
|
vv=list_act(v)
|
||||||
|
! term-=D0tu(u,v)*Fipq(tt,vv) ! published, but inverting t and u seems more correct
|
||||||
|
do x=1,n_act_orb
|
||||||
|
xx=list_act(x)
|
||||||
|
term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx_no(vv,xx,i,i) &
|
||||||
|
+(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) &
|
||||||
|
*bielec_pxxq_no(vv,i,i,xx))
|
||||||
|
do y=1,n_act_orb
|
||||||
|
term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(u,v,y,xx)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
else
|
||||||
|
! it/ju
|
||||||
|
jj=list_core_inact(j)
|
||||||
|
uu=list_act(u)
|
||||||
|
if (t.eq.u) then
|
||||||
|
term=occnum(tt)*Fipq(ii,jj)
|
||||||
|
term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj))
|
||||||
|
else
|
||||||
|
term=0.D0
|
||||||
|
end if
|
||||||
|
term+=2.D0*(4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) &
|
||||||
|
-bielec_PQxx_no(tt,uu,i,j))
|
||||||
|
term-=(occnum(tt)+occnum(uu))* &
|
||||||
|
(4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) &
|
||||||
|
-bielec_PQxx_no(uu,tt,i,j))
|
||||||
|
do v=1,n_act_orb
|
||||||
|
vv=list_act(v)
|
||||||
|
do x=1,n_act_orb
|
||||||
|
xx=list_act(x)
|
||||||
|
term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx_no(vv,xx,i,j) &
|
||||||
|
+(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) &
|
||||||
|
*bielec_pxxq_no(vv,i,j,xx))
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
|
||||||
|
term*=2.D0
|
||||||
|
hessmat_itju=term
|
||||||
|
|
||||||
|
end function hessmat_itju
|
||||||
|
|
||||||
|
real*8 function hessmat_itja(i,t,j,a)
|
||||||
|
BEGIN_DOC
|
||||||
|
! the orbital hessian for core/inactive -> active, core/inactive -> virtual
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y
|
||||||
|
real*8 :: term
|
||||||
|
|
||||||
|
! it/ja
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
tt=list_act(t)
|
||||||
|
jj=list_core_inact(j)
|
||||||
|
aa=list_virt(a)
|
||||||
|
term=2.D0*(4.D0*bielec_pxxq_no(aa,j,i,tt) &
|
||||||
|
-bielec_pqxx_no(aa,tt,i,j) -bielec_pxxq_no(aa,i,j,tt))
|
||||||
|
term-=occnum(tt)*(4.D0*bielec_pxxq_no(aa,j,i,tt) &
|
||||||
|
-bielec_pqxx_no(aa,tt,i,j) -bielec_pxxq_no(aa,i,j,tt))
|
||||||
|
if (i.eq.j) then
|
||||||
|
term+=2.D0*(Fipq(aa,tt)+Fapq(aa,tt))
|
||||||
|
term-=0.5D0*occnum(tt)*Fipq(aa,tt)
|
||||||
|
do v=1,n_act_orb
|
||||||
|
do x=1,n_act_orb
|
||||||
|
do y=1,n_act_orb
|
||||||
|
term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,aa)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
term*=2.D0
|
||||||
|
hessmat_itja=term
|
||||||
|
|
||||||
|
end function hessmat_itja
|
||||||
|
|
||||||
|
real*8 function hessmat_itua(i,t,u,a)
|
||||||
|
BEGIN_DOC
|
||||||
|
! the orbital hessian for core/inactive -> active, active -> virtual
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3
|
||||||
|
real*8 :: term
|
||||||
|
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
tt=list_act(t)
|
||||||
|
t3=t+n_core_inact_orb
|
||||||
|
uu=list_act(u)
|
||||||
|
u3=u+n_core_inact_orb
|
||||||
|
aa=list_virt(a)
|
||||||
|
if (t.eq.u) then
|
||||||
|
term=-occnum(tt)*Fipq(aa,ii)
|
||||||
|
else
|
||||||
|
term=0.D0
|
||||||
|
end if
|
||||||
|
term-=occnum(uu)*(bielec_pqxx_no(aa,ii,t3,u3)-4.D0*bielec_pqxx_no(aa,uu,t3,i)&
|
||||||
|
+bielec_pxxq_no(aa,t3,u3,ii))
|
||||||
|
do v=1,n_act_orb
|
||||||
|
vv=list_act(v)
|
||||||
|
v3=v+n_core_inact_orb
|
||||||
|
do x=1,n_act_orb
|
||||||
|
integer :: x3
|
||||||
|
xx=list_act(x)
|
||||||
|
x3=x+n_core_inact_orb
|
||||||
|
term-=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,ii,v3,x3) &
|
||||||
|
+(P0tuvx_no(t,v,u,x)+P0tuvx_no(t,v,x,u)) &
|
||||||
|
*bielec_pqxx_no(aa,xx,v3,i))
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
if (t.eq.u) then
|
||||||
|
term+=Fipq(aa,ii)+Fapq(aa,ii)
|
||||||
|
end if
|
||||||
|
term*=2.D0
|
||||||
|
hessmat_itua=term
|
||||||
|
|
||||||
|
end function hessmat_itua
|
||||||
|
|
||||||
|
real*8 function hessmat_iajb(i,a,j,b)
|
||||||
|
BEGIN_DOC
|
||||||
|
! the orbital hessian for core/inactive -> virtual, core/inactive -> virtual
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,a,j,b,ii,aa,jj,bb
|
||||||
|
real*8 :: term
|
||||||
|
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
aa=list_virt(a)
|
||||||
|
if (i.eq.j) then
|
||||||
|
if (a.eq.b) then
|
||||||
|
! ia/ia
|
||||||
|
term=2.D0*(Fipq(aa,aa)+Fapq(aa,aa)-Fipq(ii,ii)-Fapq(ii,ii))
|
||||||
|
term+=2.D0*(3.D0*bielec_pxxq_no(aa,i,i,aa)-bielec_pqxx_no(aa,aa,i,i))
|
||||||
|
else
|
||||||
|
bb=list_virt(b)
|
||||||
|
! ia/ib
|
||||||
|
term=2.D0*(Fipq(aa,bb)+Fapq(aa,bb))
|
||||||
|
term+=2.D0*(3.D0*bielec_pxxq_no(aa,i,i,bb)-bielec_pqxx_no(aa,bb,i,i))
|
||||||
|
end if
|
||||||
|
else
|
||||||
|
! ia/jb
|
||||||
|
jj=list_core_inact(j)
|
||||||
|
bb=list_virt(b)
|
||||||
|
term=2.D0*(4.D0*bielec_pxxq_no(aa,i,j,bb)-bielec_pqxx_no(aa,bb,i,j) &
|
||||||
|
-bielec_pxxq_no(aa,j,i,bb))
|
||||||
|
if (a.eq.b) then
|
||||||
|
term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj))
|
||||||
|
end if
|
||||||
|
end if
|
||||||
|
term*=2.D0
|
||||||
|
hessmat_iajb=term
|
||||||
|
|
||||||
|
end function hessmat_iajb
|
||||||
|
|
||||||
|
real*8 function hessmat_iatb(i,a,t,b)
|
||||||
|
BEGIN_DOC
|
||||||
|
! the orbital hessian for core/inactive -> virtual, active -> virtual
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3
|
||||||
|
real*8 :: term
|
||||||
|
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
aa=list_virt(a)
|
||||||
|
tt=list_act(t)
|
||||||
|
bb=list_virt(b)
|
||||||
|
t3=t+n_core_inact_orb
|
||||||
|
term=occnum(tt)*(4.D0*bielec_pxxq_no(aa,i,t3,bb)-bielec_pxxq_no(aa,t3,i,bb)&
|
||||||
|
-bielec_pqxx_no(aa,bb,i,t3))
|
||||||
|
if (a.eq.b) then
|
||||||
|
term-=Fipq(tt,ii)+Fapq(tt,ii)
|
||||||
|
term-=0.5D0*occnum(tt)*Fipq(tt,ii)
|
||||||
|
do v=1,n_act_orb
|
||||||
|
do x=1,n_act_orb
|
||||||
|
do y=1,n_act_orb
|
||||||
|
term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,ii)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
term*=2.D0
|
||||||
|
hessmat_iatb=term
|
||||||
|
|
||||||
|
end function hessmat_iatb
|
||||||
|
|
||||||
|
real*8 function hessmat_taub(t,a,u,b)
|
||||||
|
BEGIN_DOC
|
||||||
|
! the orbital hessian for act->virt,act->virt
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: t,a,u,b,tt,aa,uu,bb,v,vv,x,xx,y
|
||||||
|
integer :: v3,x3
|
||||||
|
real*8 :: term,t1,t2,t3
|
||||||
|
|
||||||
|
double precision,allocatable :: P0tuvx_no_t(:,:,:)
|
||||||
|
double precision :: bielec_pqxx_no_2(n_act_orb,n_act_orb)
|
||||||
|
double precision :: bielec_pxxq_no_2(n_act_orb,n_act_orb)
|
||||||
|
tt=list_act(t)
|
||||||
|
aa=list_virt(a)
|
||||||
|
if (t == u) then
|
||||||
|
if (a == b) then
|
||||||
|
! ta/ta
|
||||||
|
t1=occnum(tt)*Fipq(aa,aa)
|
||||||
|
t2=0.D0
|
||||||
|
t3=0.D0
|
||||||
|
t1-=occnum(tt)*Fipq(tt,tt)
|
||||||
|
do x=1,n_act_orb
|
||||||
|
xx=list_act(x)
|
||||||
|
x3=x+n_core_inact_orb
|
||||||
|
do v=1,n_act_orb
|
||||||
|
vv=list_act(v)
|
||||||
|
v3=v+n_core_inact_orb
|
||||||
|
t2+=P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do v=1,n_act_orb
|
||||||
|
vv=list_act(v)
|
||||||
|
v3=v+n_core_inact_orb
|
||||||
|
do x=1,n_act_orb
|
||||||
|
xx=list_act(x)
|
||||||
|
x3=x+n_core_inact_orb
|
||||||
|
t2+=(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* &
|
||||||
|
bielec_pxxq_no(aa,x3,v3,aa)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do y=1,n_act_orb
|
||||||
|
do x=1,n_act_orb
|
||||||
|
xx=list_act(x)
|
||||||
|
do v=1,n_act_orb
|
||||||
|
t3-=P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
term=t1+2.d0*(t2+t3)
|
||||||
|
else
|
||||||
|
bb=list_virt(b)
|
||||||
|
! ta/tb b/=a
|
||||||
|
term=0.5d0*occnum(tt)*Fipq(aa,bb)
|
||||||
|
do x=1,n_act_orb
|
||||||
|
xx=list_act(x)
|
||||||
|
x3=x+n_core_inact_orb
|
||||||
|
do v=1,n_act_orb
|
||||||
|
vv=list_act(v)
|
||||||
|
v3=v+n_core_inact_orb
|
||||||
|
term = term + P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do v=1,n_act_orb
|
||||||
|
vv=list_act(v)
|
||||||
|
v3=v+n_core_inact_orb
|
||||||
|
do x=1,n_act_orb
|
||||||
|
xx=list_act(x)
|
||||||
|
x3=x+n_core_inact_orb
|
||||||
|
term= term + (P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) &
|
||||||
|
*bielec_pxxq_no(aa,x3,v3,bb)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
term += term
|
||||||
|
end if
|
||||||
|
else
|
||||||
|
! ta/ub t/=u
|
||||||
|
uu=list_act(u)
|
||||||
|
bb=list_virt(b)
|
||||||
|
allocate(P0tuvx_no_t(n_act_orb,n_act_orb,n_act_orb))
|
||||||
|
P0tuvx_no_t(:,:,:) = P0tuvx_no(t,:,:,:)
|
||||||
|
do x=1,n_act_orb
|
||||||
|
x3=x+n_core_inact_orb
|
||||||
|
do v=1,n_act_orb
|
||||||
|
v3=v+n_core_inact_orb
|
||||||
|
bielec_pqxx_no_2(v,x) = bielec_pqxx_no(aa,bb,v3,x3)
|
||||||
|
bielec_pxxq_no_2(v,x) = bielec_pxxq_no(aa,v3,x3,bb)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
term=0.D0
|
||||||
|
do x=1,n_act_orb
|
||||||
|
do v=1,n_act_orb
|
||||||
|
term += P0tuvx_no_t(u,v,x)*bielec_pqxx_no_2(v,x)
|
||||||
|
term += bielec_pxxq_no_2(x,v) * (P0tuvx_no_t(x,v,u)+P0tuvx_no_t(x,u,v))
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
term = 6.d0*term
|
||||||
|
if (a.eq.b) then
|
||||||
|
term-=0.5D0*(occnum(tt)*Fipq(uu,tt)+occnum(uu)*Fipq(tt,uu))
|
||||||
|
do v=1,n_act_orb
|
||||||
|
do y=1,n_act_orb
|
||||||
|
do x=1,n_act_orb
|
||||||
|
term-=P0tuvx_no_t(v,x,y)*bielecCI_no(x,y,v,uu)
|
||||||
|
term-=P0tuvx_no(u,v,x,y)*bielecCI_no(x,y,v,tt)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
|
||||||
|
end if
|
||||||
|
|
||||||
|
term*=2.D0
|
||||||
|
hessmat_taub=term
|
||||||
|
|
||||||
|
end function hessmat_taub
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, hessdiag, (nMonoEx)]
|
||||||
|
BEGIN_DOC
|
||||||
|
! the diagonal of the Hessian, needed for the Davidson procedure
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: i,t,a,indx,indx_shift
|
||||||
|
real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT(NONE) &
|
||||||
|
!$OMP SHARED(hessdiag,n_core_inact_orb,n_act_orb,n_virt_orb,nMonoEx) &
|
||||||
|
!$OMP PRIVATE(i,indx,t,a,indx_shift)
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
do t=1,n_act_orb
|
||||||
|
indx = t + (i-1)*n_act_orb
|
||||||
|
hessdiag(indx)=hessmat_itju(i,t,i,t)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
|
indx_shift = n_core_inact_orb*n_act_orb
|
||||||
|
!$OMP DO
|
||||||
|
do a=1,n_virt_orb
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
indx = a + (i-1)*n_virt_orb + indx_shift
|
||||||
|
hessdiag(indx)=hessmat_iajb(i,a,i,a)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO NOWAIT
|
||||||
|
|
||||||
|
indx_shift += n_core_inact_orb*n_virt_orb
|
||||||
|
!$OMP DO
|
||||||
|
do a=1,n_virt_orb
|
||||||
|
do t=1,n_act_orb
|
||||||
|
indx = a + (t-1)*n_virt_orb + indx_shift
|
||||||
|
hessdiag(indx)=hessmat_taub(t,a,t,a)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
!$OMP END DO
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
END_PROVIDER
|
80
src/casscf/mcscf_fock.irp.f
Normal file
80
src/casscf/mcscf_fock.irp.f
Normal file
@ -0,0 +1,80 @@
|
|||||||
|
BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ]
|
||||||
|
BEGIN_DOC
|
||||||
|
! the inactive Fock matrix, in molecular orbitals
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: p,q,k,kk,t,tt,u,uu
|
||||||
|
|
||||||
|
do q=1,mo_num
|
||||||
|
do p=1,mo_num
|
||||||
|
Fipq(p,q)=one_ints_no(p,q)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
! the inactive Fock matrix
|
||||||
|
do k=1,n_core_inact_orb
|
||||||
|
kk=list_core_inact(k)
|
||||||
|
do q=1,mo_num
|
||||||
|
do p=1,mo_num
|
||||||
|
Fipq(p,q)+=2.D0*bielec_pqxx_no(p,q,k,k) -bielec_pxxq_no(p,k,k,q)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
if (bavard) then
|
||||||
|
integer :: i
|
||||||
|
write(6,*)
|
||||||
|
write(6,*) ' the diagonal of the inactive effective Fock matrix '
|
||||||
|
write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num)
|
||||||
|
write(6,*)
|
||||||
|
end if
|
||||||
|
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ]
|
||||||
|
BEGIN_DOC
|
||||||
|
! the active active Fock matrix, in molecular orbitals
|
||||||
|
! we create them in MOs, quite expensive
|
||||||
|
!
|
||||||
|
! for an implementation in AOs we need first the natural orbitals
|
||||||
|
! for forming an active density matrix in AOs
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer :: p,q,k,kk,t,tt,u,uu
|
||||||
|
|
||||||
|
Fapq = 0.d0
|
||||||
|
|
||||||
|
! the active Fock matrix, D0tu is diagonal
|
||||||
|
do t=1,n_act_orb
|
||||||
|
tt=list_act(t)
|
||||||
|
do q=1,mo_num
|
||||||
|
do p=1,mo_num
|
||||||
|
Fapq(p,q)+=occnum(tt) &
|
||||||
|
*(bielec_pqxx_no(p,q,tt,tt)-0.5D0*bielec_pxxq_no(p,tt,tt,q))
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
if (bavard) then
|
||||||
|
integer :: i
|
||||||
|
write(6,*)
|
||||||
|
write(6,*) ' the effective Fock matrix over MOs'
|
||||||
|
write(6,*)
|
||||||
|
|
||||||
|
write(6,*)
|
||||||
|
write(6,*) ' the diagonal of the inactive effective Fock matrix '
|
||||||
|
write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num)
|
||||||
|
write(6,*)
|
||||||
|
write(6,*)
|
||||||
|
write(6,*) ' the diagonal of the active Fock matrix '
|
||||||
|
write(6,'(5(i3,F12.5))') (i,Fapq(i,i),i=1,mo_num)
|
||||||
|
write(6,*)
|
||||||
|
end if
|
||||||
|
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
231
src/casscf/natorb.irp.f
Normal file
231
src/casscf/natorb.irp.f
Normal file
@ -0,0 +1,231 @@
|
|||||||
|
BEGIN_PROVIDER [real*8, occnum, (mo_num)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! MO occupation numbers
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
integer :: i
|
||||||
|
occnum=0.D0
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
occnum(list_core_inact(i))=2.D0
|
||||||
|
end do
|
||||||
|
|
||||||
|
do i=1,n_act_orb
|
||||||
|
occnum(list_act(i))=occ_act(i)
|
||||||
|
end do
|
||||||
|
|
||||||
|
if (bavard) then
|
||||||
|
write(6,*) ' occupation numbers '
|
||||||
|
do i=1,mo_num
|
||||||
|
write(6,*) i,occnum(i)
|
||||||
|
end do
|
||||||
|
endif
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ real*8, natorbsCI, (n_act_orb,n_act_orb) ]
|
||||||
|
&BEGIN_PROVIDER [ real*8, occ_act, (n_act_orb) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Natural orbitals of CI
|
||||||
|
END_DOC
|
||||||
|
integer :: i, j
|
||||||
|
double precision :: Vt(n_act_orb,n_act_orb)
|
||||||
|
|
||||||
|
! call lapack_diag(occ_act,natorbsCI,D0tu,n_act_orb,n_act_orb)
|
||||||
|
call svd(D0tu, size(D0tu,1), natorbsCI,size(natorbsCI,1), occ_act, Vt, size(Vt,1),n_act_orb,n_act_orb)
|
||||||
|
|
||||||
|
if (bavard) then
|
||||||
|
write(6,*) ' found occupation numbers as '
|
||||||
|
do i=1,n_act_orb
|
||||||
|
write(6,*) i,occ_act(i)
|
||||||
|
end do
|
||||||
|
|
||||||
|
integer :: nmx
|
||||||
|
real*8 :: xmx
|
||||||
|
do i=1,n_act_orb
|
||||||
|
! largest element of the eigenvector should be positive
|
||||||
|
xmx=0.D0
|
||||||
|
nmx=0
|
||||||
|
do j=1,n_act_orb
|
||||||
|
if (abs(natOrbsCI(j,i)).gt.xmx) then
|
||||||
|
nmx=j
|
||||||
|
xmx=abs(natOrbsCI(j,i))
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
xmx=sign(1.D0,natOrbsCI(nmx,i))
|
||||||
|
do j=1,n_act_orb
|
||||||
|
natOrbsCI(j,i)*=xmx
|
||||||
|
end do
|
||||||
|
|
||||||
|
write(6,*) ' Eigenvector No ',i
|
||||||
|
write(6,'(5(I3,F12.5))') (j,natOrbsCI(j,i),j=1,n_act_orb)
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! 4-index transformation of 2part matrices
|
||||||
|
END_DOC
|
||||||
|
integer :: i,j,k,l,p,q
|
||||||
|
real*8 :: d(n_act_orb)
|
||||||
|
|
||||||
|
! index per index
|
||||||
|
! first quarter
|
||||||
|
P0tuvx_no(:,:,:,:) = P0tuvx(:,:,:,:)
|
||||||
|
|
||||||
|
do j=1,n_act_orb
|
||||||
|
do k=1,n_act_orb
|
||||||
|
do l=1,n_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
d(p)=0.D0
|
||||||
|
end do
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do q=1,n_act_orb
|
||||||
|
d(p)+=P0tuvx_no(q,j,k,l)*natorbsCI(q,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do p=1,n_act_orb
|
||||||
|
P0tuvx_no(p,j,k,l)=d(p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
! 2nd quarter
|
||||||
|
do j=1,n_act_orb
|
||||||
|
do k=1,n_act_orb
|
||||||
|
do l=1,n_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
d(p)=0.D0
|
||||||
|
end do
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do q=1,n_act_orb
|
||||||
|
d(p)+=P0tuvx_no(j,q,k,l)*natorbsCI(q,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do p=1,n_act_orb
|
||||||
|
P0tuvx_no(j,p,k,l)=d(p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
! 3rd quarter
|
||||||
|
do j=1,n_act_orb
|
||||||
|
do k=1,n_act_orb
|
||||||
|
do l=1,n_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
d(p)=0.D0
|
||||||
|
end do
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do q=1,n_act_orb
|
||||||
|
d(p)+=P0tuvx_no(j,k,q,l)*natorbsCI(q,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do p=1,n_act_orb
|
||||||
|
P0tuvx_no(j,k,p,l)=d(p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
! 4th quarter
|
||||||
|
do j=1,n_act_orb
|
||||||
|
do k=1,n_act_orb
|
||||||
|
do l=1,n_act_orb
|
||||||
|
do p=1,n_act_orb
|
||||||
|
d(p)=0.D0
|
||||||
|
end do
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do q=1,n_act_orb
|
||||||
|
d(p)+=P0tuvx_no(j,k,l,q)*natorbsCI(q,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do p=1,n_act_orb
|
||||||
|
P0tuvx_no(j,k,l,p)=d(p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Transformed one-e integrals
|
||||||
|
END_DOC
|
||||||
|
integer :: i,j, p, q
|
||||||
|
real*8 :: d(n_act_orb)
|
||||||
|
one_ints_no(:,:)=mo_one_e_integrals(:,:)
|
||||||
|
|
||||||
|
! 1st half-trf
|
||||||
|
do j=1,mo_num
|
||||||
|
do p=1,n_act_orb
|
||||||
|
d(p)=0.D0
|
||||||
|
end do
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do q=1,n_act_orb
|
||||||
|
d(p)+=one_ints_no(list_act(q),j)*natorbsCI(q,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do p=1,n_act_orb
|
||||||
|
one_ints_no(list_act(p),j)=d(p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
! 2nd half-trf
|
||||||
|
do j=1,mo_num
|
||||||
|
do p=1,n_act_orb
|
||||||
|
d(p)=0.D0
|
||||||
|
end do
|
||||||
|
do p=1,n_act_orb
|
||||||
|
do q=1,n_act_orb
|
||||||
|
d(p)+=one_ints_no(j,list_act(q))*natorbsCI(q,p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do p=1,n_act_orb
|
||||||
|
one_ints_no(j,list_act(p))=d(p)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, NatOrbsCI_mos, (mo_num, mo_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Rotation matrix from current MOs to the CI natural MOs
|
||||||
|
END_DOC
|
||||||
|
integer :: p,q
|
||||||
|
|
||||||
|
NatOrbsCI_mos(:,:) = 0.d0
|
||||||
|
|
||||||
|
do q = 1,mo_num
|
||||||
|
NatOrbsCI_mos(q,q) = 1.d0
|
||||||
|
enddo
|
||||||
|
|
||||||
|
do q = 1,n_act_orb
|
||||||
|
do p = 1,n_act_orb
|
||||||
|
NatOrbsCI_mos(list_act(p),list_act(q)) = natorbsCI(p,q)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! FCI natural orbitals
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
call dgemm('N','N', ao_num,mo_num,mo_num,1.d0, &
|
||||||
|
mo_coef, size(mo_coef,1), &
|
||||||
|
NatOrbsCI_mos, size(NatOrbsCI_mos,1), 0.d0, &
|
||||||
|
NatOrbsFCI, size(NatOrbsFCI,1))
|
||||||
|
END_PROVIDER
|
||||||
|
|
181
src/casscf/neworbs.irp.f
Normal file
181
src/casscf/neworbs.irp.f
Normal file
@ -0,0 +1,181 @@
|
|||||||
|
BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Single-excitation matrix
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
integer :: i,j
|
||||||
|
|
||||||
|
do i=1,nMonoEx+1
|
||||||
|
do j=1,nMonoEx+1
|
||||||
|
SXmatrix(i,j)=0.D0
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
do i=1,nMonoEx
|
||||||
|
SXmatrix(1,i+1)=gradvec2(i)
|
||||||
|
SXmatrix(1+i,1)=gradvec2(i)
|
||||||
|
end do
|
||||||
|
|
||||||
|
do i=1,nMonoEx
|
||||||
|
do j=1,nMonoEx
|
||||||
|
SXmatrix(i+1,j+1)=hessmat2(i,j)
|
||||||
|
SXmatrix(j+1,i+1)=hessmat2(i,j)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
if (bavard) then
|
||||||
|
do i=2,nMonoEx
|
||||||
|
write(6,*) ' diagonal of the Hessian : ',i,hessmat2(i,i)
|
||||||
|
end do
|
||||||
|
end if
|
||||||
|
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, SXeigenvec, (nMonoEx+1,nMonoEx+1)]
|
||||||
|
&BEGIN_PROVIDER [real*8, SXeigenval, (nMonoEx+1)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Eigenvectors/eigenvalues of the single-excitation matrix
|
||||||
|
END_DOC
|
||||||
|
call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1)
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, SXvector, (nMonoEx+1)]
|
||||||
|
&BEGIN_PROVIDER [real*8, energy_improvement]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Best eigenvector of the single-excitation matrix
|
||||||
|
END_DOC
|
||||||
|
integer :: ierr,matz,i
|
||||||
|
real*8 :: c0
|
||||||
|
|
||||||
|
if (bavard) then
|
||||||
|
write(6,*) ' SXdiag : lowest 5 eigenvalues '
|
||||||
|
write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1)
|
||||||
|
write(6,*) ' 2 - ',SXeigenval(2),SXeigenvec(1,2)
|
||||||
|
write(6,*) ' 3 - ',SXeigenval(3),SXeigenvec(1,3)
|
||||||
|
write(6,*) ' 4 - ',SXeigenval(4),SXeigenvec(1,4)
|
||||||
|
write(6,*) ' 5 - ',SXeigenval(5),SXeigenvec(1,5)
|
||||||
|
write(6,*)
|
||||||
|
write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1)
|
||||||
|
endif
|
||||||
|
energy_improvement = SXeigenval(1)
|
||||||
|
|
||||||
|
integer :: best_vector
|
||||||
|
real*8 :: best_overlap
|
||||||
|
best_overlap=0.D0
|
||||||
|
best_vector = -1000
|
||||||
|
do i=1,nMonoEx+1
|
||||||
|
if (SXeigenval(i).lt.0.D0) then
|
||||||
|
if (abs(SXeigenvec(1,i)).gt.best_overlap) then
|
||||||
|
best_overlap=abs(SXeigenvec(1,i))
|
||||||
|
best_vector=i
|
||||||
|
end if
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
if(best_vector.lt.0)then
|
||||||
|
best_vector = minloc(SXeigenval,nMonoEx+1)
|
||||||
|
endif
|
||||||
|
energy_improvement = SXeigenval(best_vector)
|
||||||
|
|
||||||
|
c0=SXeigenvec(1,best_vector)
|
||||||
|
|
||||||
|
if (bavard) then
|
||||||
|
write(6,*) ' SXdiag : eigenvalue for best overlap with '
|
||||||
|
write(6,*) ' previous orbitals = ',SXeigenval(best_vector)
|
||||||
|
write(6,*) ' weight of the 1st element ',c0
|
||||||
|
endif
|
||||||
|
|
||||||
|
do i=1,nMonoEx+1
|
||||||
|
SXvector(i)=SXeigenvec(i,best_vector)/c0
|
||||||
|
end do
|
||||||
|
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, NewOrbs, (ao_num,mo_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Updated orbitals
|
||||||
|
END_DOC
|
||||||
|
integer :: i,j,ialph
|
||||||
|
|
||||||
|
call dgemm('N','T', ao_num,mo_num,mo_num,1.d0, &
|
||||||
|
NatOrbsFCI, size(NatOrbsFCI,1), &
|
||||||
|
Umat, size(Umat,1), 0.d0, &
|
||||||
|
NewOrbs, size(NewOrbs,1))
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Orbital rotation matrix
|
||||||
|
END_DOC
|
||||||
|
integer :: i,j,indx,k,iter,t,a,ii,tt,aa
|
||||||
|
logical :: converged
|
||||||
|
|
||||||
|
real*8 :: Tpotmat (mo_num,mo_num), Tpotmat2 (mo_num,mo_num)
|
||||||
|
real*8 :: Tmat(mo_num,mo_num)
|
||||||
|
real*8 :: f
|
||||||
|
|
||||||
|
! the orbital rotation matrix T
|
||||||
|
Tmat(:,:)=0.D0
|
||||||
|
indx=1
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
do t=1,n_act_orb
|
||||||
|
tt=list_act(t)
|
||||||
|
indx+=1
|
||||||
|
Tmat(ii,tt)= SXvector(indx)
|
||||||
|
Tmat(tt,ii)=-SXvector(indx)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
do a=1,n_virt_orb
|
||||||
|
aa=list_virt(a)
|
||||||
|
indx+=1
|
||||||
|
Tmat(ii,aa)= SXvector(indx)
|
||||||
|
Tmat(aa,ii)=-SXvector(indx)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do t=1,n_act_orb
|
||||||
|
tt=list_act(t)
|
||||||
|
do a=1,n_virt_orb
|
||||||
|
aa=list_virt(a)
|
||||||
|
indx+=1
|
||||||
|
Tmat(tt,aa)= SXvector(indx)
|
||||||
|
Tmat(aa,tt)=-SXvector(indx)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
! Form the exponential
|
||||||
|
|
||||||
|
Tpotmat(:,:)=0.D0
|
||||||
|
Umat(:,:) =0.D0
|
||||||
|
do i=1,mo_num
|
||||||
|
Tpotmat(i,i)=1.D0
|
||||||
|
Umat(i,i) =1.d0
|
||||||
|
end do
|
||||||
|
iter=0
|
||||||
|
converged=.false.
|
||||||
|
do while (.not.converged)
|
||||||
|
iter+=1
|
||||||
|
f = 1.d0 / dble(iter)
|
||||||
|
Tpotmat2(:,:) = Tpotmat(:,:) * f
|
||||||
|
call dgemm('N','N', mo_num,mo_num,mo_num,1.d0, &
|
||||||
|
Tpotmat2, size(Tpotmat2,1), &
|
||||||
|
Tmat, size(Tmat,1), 0.d0, &
|
||||||
|
Tpotmat, size(Tpotmat,1))
|
||||||
|
Umat(:,:) = Umat(:,:) + Tpotmat(:,:)
|
||||||
|
|
||||||
|
converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30)
|
||||||
|
end do
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
|
9
src/casscf/save_energy.irp.f
Normal file
9
src/casscf/save_energy.irp.f
Normal file
@ -0,0 +1,9 @@
|
|||||||
|
subroutine save_energy(E,pt2)
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Saves the energy in |EZFIO|.
|
||||||
|
END_DOC
|
||||||
|
double precision, intent(in) :: E(N_states), pt2(N_states)
|
||||||
|
call ezfio_set_casscf_energy(E(1:N_states))
|
||||||
|
call ezfio_set_casscf_energy_pt2(E(1:N_states)+pt2(1:N_states))
|
||||||
|
end
|
29
src/casscf/test_pert_2rdm.irp.f
Normal file
29
src/casscf/test_pert_2rdm.irp.f
Normal file
@ -0,0 +1,29 @@
|
|||||||
|
program test_pert_2rdm
|
||||||
|
implicit none
|
||||||
|
read_wf = .True.
|
||||||
|
touch read_wf
|
||||||
|
!call get_pert_2rdm
|
||||||
|
integer :: i,j,k,l,ii,jj,kk,ll
|
||||||
|
double precision :: accu , get_two_e_integral, integral
|
||||||
|
accu = 0.d0
|
||||||
|
print*,'n_orb_pert_rdm = ',n_orb_pert_rdm
|
||||||
|
do ii = 1, n_orb_pert_rdm
|
||||||
|
i = list_orb_pert_rdm(ii)
|
||||||
|
do jj = 1, n_orb_pert_rdm
|
||||||
|
j = list_orb_pert_rdm(jj)
|
||||||
|
do kk = 1, n_orb_pert_rdm
|
||||||
|
k= list_orb_pert_rdm(kk)
|
||||||
|
do ll = 1, n_orb_pert_rdm
|
||||||
|
l = list_orb_pert_rdm(ll)
|
||||||
|
integral = get_two_e_integral(i,j,k,l,mo_integrals_map)
|
||||||
|
! if(dabs(pert_2rdm_provider(ii,jj,kk,ll) * integral).gt.1.d-12)then
|
||||||
|
! print*,i,j,k,l
|
||||||
|
! print*,pert_2rdm_provider(ii,jj,kk,ll) * integral,pert_2rdm_provider(ii,jj,kk,ll), pert_2rdm_provider(ii,jj,kk,ll), integral
|
||||||
|
! endif
|
||||||
|
accu += pert_2rdm_provider(ii,jj,kk,ll) * integral
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
print*,'accu = ',accu
|
||||||
|
end
|
101
src/casscf/tot_en.irp.f
Normal file
101
src/casscf/tot_en.irp.f
Normal file
@ -0,0 +1,101 @@
|
|||||||
|
BEGIN_PROVIDER [real*8, etwo]
|
||||||
|
&BEGIN_PROVIDER [real*8, eone]
|
||||||
|
&BEGIN_PROVIDER [real*8, eone_bis]
|
||||||
|
&BEGIN_PROVIDER [real*8, etwo_bis]
|
||||||
|
&BEGIN_PROVIDER [real*8, etwo_ter]
|
||||||
|
&BEGIN_PROVIDER [real*8, ecore]
|
||||||
|
&BEGIN_PROVIDER [real*8, ecore_bis]
|
||||||
|
implicit none
|
||||||
|
integer :: t,u,v,x,i,ii,tt,uu,vv,xx,j,jj,t3,u3,v3,x3
|
||||||
|
real*8 :: e_one_all,e_two_all
|
||||||
|
e_one_all=0.D0
|
||||||
|
e_two_all=0.D0
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
e_one_all+=2.D0*mo_one_e_integrals(ii,ii)
|
||||||
|
do j=1,n_core_inact_orb
|
||||||
|
jj=list_core_inact(j)
|
||||||
|
e_two_all+=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i)
|
||||||
|
end do
|
||||||
|
do t=1,n_act_orb
|
||||||
|
tt=list_act(t)
|
||||||
|
t3=t+n_core_inact_orb
|
||||||
|
do u=1,n_act_orb
|
||||||
|
uu=list_act(u)
|
||||||
|
u3=u+n_core_inact_orb
|
||||||
|
e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) &
|
||||||
|
-bielec_PQxx(tt,ii,i,u3))
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
do t=1,n_act_orb
|
||||||
|
tt=list_act(t)
|
||||||
|
do u=1,n_act_orb
|
||||||
|
uu=list_act(u)
|
||||||
|
e_one_all+=D0tu(t,u)*mo_one_e_integrals(tt,uu)
|
||||||
|
do v=1,n_act_orb
|
||||||
|
v3=v+n_core_inact_orb
|
||||||
|
do x=1,n_act_orb
|
||||||
|
x3=x+n_core_inact_orb
|
||||||
|
e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxx(tt,uu,v3,x3)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
ecore =nuclear_repulsion
|
||||||
|
ecore_bis=nuclear_repulsion
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
ecore +=2.D0*mo_one_e_integrals(ii,ii)
|
||||||
|
ecore_bis+=2.D0*mo_one_e_integrals(ii,ii)
|
||||||
|
do j=1,n_core_inact_orb
|
||||||
|
jj=list_core_inact(j)
|
||||||
|
ecore +=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i)
|
||||||
|
ecore_bis+=2.D0*bielec_PxxQ(ii,i,j,jj)-bielec_PxxQ(ii,j,j,ii)
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
eone =0.D0
|
||||||
|
eone_bis=0.D0
|
||||||
|
etwo =0.D0
|
||||||
|
etwo_bis=0.D0
|
||||||
|
etwo_ter=0.D0
|
||||||
|
do t=1,n_act_orb
|
||||||
|
tt=list_act(t)
|
||||||
|
t3=t+n_core_inact_orb
|
||||||
|
do u=1,n_act_orb
|
||||||
|
uu=list_act(u)
|
||||||
|
u3=u+n_core_inact_orb
|
||||||
|
eone +=D0tu(t,u)*mo_one_e_integrals(tt,uu)
|
||||||
|
eone_bis+=D0tu(t,u)*mo_one_e_integrals(tt,uu)
|
||||||
|
do i=1,n_core_inact_orb
|
||||||
|
ii=list_core_inact(i)
|
||||||
|
eone +=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) &
|
||||||
|
-bielec_PQxx(tt,ii,i,u3))
|
||||||
|
eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQ(tt,u3,i,ii) &
|
||||||
|
-bielec_PxxQ(tt,i,i,uu))
|
||||||
|
end do
|
||||||
|
do v=1,n_act_orb
|
||||||
|
vv=list_act(v)
|
||||||
|
v3=v+n_core_inact_orb
|
||||||
|
do x=1,n_act_orb
|
||||||
|
xx=list_act(x)
|
||||||
|
x3=x+n_core_inact_orb
|
||||||
|
real*8 :: h1,h2,h3
|
||||||
|
h1=bielec_PQxx(tt,uu,v3,x3)
|
||||||
|
h2=bielec_PxxQ(tt,u3,v3,xx)
|
||||||
|
h3=bielecCI(t,u,v,xx)
|
||||||
|
etwo +=P0tuvx(t,u,v,x)*h1
|
||||||
|
etwo_bis+=P0tuvx(t,u,v,x)*h2
|
||||||
|
etwo_ter+=P0tuvx(t,u,v,x)*h3
|
||||||
|
if ((h1.ne.h2).or.(h1.ne.h3)) then
|
||||||
|
write(6,9901) t,u,v,x,h1,h2,h3
|
||||||
|
9901 format('aie: ',4I4,3E20.12)
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
@ -3,3 +3,4 @@ zmq
|
|||||||
mpi
|
mpi
|
||||||
davidson_undressed
|
davidson_undressed
|
||||||
iterations
|
iterations
|
||||||
|
two_body_rdm
|
||||||
|
@ -13,6 +13,7 @@ subroutine run_cipsi
|
|||||||
rss = memory_of_double(N_states)*4.d0
|
rss = memory_of_double(N_states)*4.d0
|
||||||
call check_mem(rss,irp_here)
|
call check_mem(rss,irp_here)
|
||||||
|
|
||||||
|
N_iter = 1
|
||||||
allocate (pt2(N_states), zeros(N_states), rpt2(N_states), norm(N_states), variance(N_states))
|
allocate (pt2(N_states), zeros(N_states), rpt2(N_states), norm(N_states), variance(N_states))
|
||||||
|
|
||||||
double precision :: hf_energy_ref
|
double precision :: hf_energy_ref
|
||||||
|
0
src/cipsi/lock_2rdm.irp.f
Normal file
0
src/cipsi/lock_2rdm.irp.f
Normal file
183
src/cipsi/pert_rdm_providers.irp.f
Normal file
183
src/cipsi/pert_rdm_providers.irp.f
Normal file
@ -0,0 +1,183 @@
|
|||||||
|
|
||||||
|
use bitmasks
|
||||||
|
use omp_lib
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer(omp_lock_kind), pert_2rdm_lock]
|
||||||
|
use f77_zmq
|
||||||
|
implicit none
|
||||||
|
call omp_init_lock(pert_2rdm_lock)
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [logical , pert_2rdm ]
|
||||||
|
implicit none
|
||||||
|
pert_2rdm = .False.
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [integer, n_orb_pert_rdm]
|
||||||
|
implicit none
|
||||||
|
n_orb_pert_rdm = n_act_orb
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [integer, list_orb_reverse_pert_rdm, (mo_num)]
|
||||||
|
implicit none
|
||||||
|
list_orb_reverse_pert_rdm = list_act_reverse
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [integer, list_orb_pert_rdm, (n_orb_pert_rdm)]
|
||||||
|
implicit none
|
||||||
|
list_orb_pert_rdm = list_act
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, pert_2rdm_provider, (n_orb_pert_rdm,n_orb_pert_rdm,n_orb_pert_rdm,n_orb_pert_rdm)]
|
||||||
|
implicit none
|
||||||
|
pert_2rdm_provider = 0.d0
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf, psi_det_connection, psi_coef_connection_reverse, n_det_connection)
|
||||||
|
use bitmasks
|
||||||
|
use selection_types
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: n_det_connection
|
||||||
|
double precision, intent(in) :: psi_coef_connection_reverse(N_states,n_det_connection)
|
||||||
|
integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection)
|
||||||
|
integer, intent(in) :: i_generator, sp, h1, h2
|
||||||
|
double precision, intent(in) :: mat(N_states, mo_num, mo_num)
|
||||||
|
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num)
|
||||||
|
double precision, intent(in) :: fock_diag_tmp(mo_num)
|
||||||
|
double precision, intent(in) :: E0(N_states)
|
||||||
|
double precision, intent(inout) :: pt2(N_states)
|
||||||
|
double precision, intent(inout) :: variance(N_states)
|
||||||
|
double precision, intent(inout) :: norm(N_states)
|
||||||
|
type(selection_buffer), intent(inout) :: buf
|
||||||
|
logical :: ok
|
||||||
|
integer :: s1, s2, p1, p2, ib, j, istate
|
||||||
|
integer(bit_kind) :: mask(N_int, 2), det(N_int, 2)
|
||||||
|
double precision :: e_pert, delta_E, val, Hii, sum_e_pert, tmp, alpha_h_psi, coef(N_states)
|
||||||
|
double precision, external :: diag_H_mat_elem_fock
|
||||||
|
double precision :: E_shift
|
||||||
|
|
||||||
|
logical, external :: detEq
|
||||||
|
double precision, allocatable :: values(:)
|
||||||
|
integer, allocatable :: keys(:,:)
|
||||||
|
integer :: nkeys
|
||||||
|
integer :: sze_buff
|
||||||
|
sze_buff = 5 * mo_num ** 2
|
||||||
|
allocate(keys(4,sze_buff),values(sze_buff))
|
||||||
|
nkeys = 0
|
||||||
|
if(sp == 3) then
|
||||||
|
s1 = 1
|
||||||
|
s2 = 2
|
||||||
|
else
|
||||||
|
s1 = sp
|
||||||
|
s2 = sp
|
||||||
|
end if
|
||||||
|
call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int)
|
||||||
|
E_shift = 0.d0
|
||||||
|
|
||||||
|
if (h0_type == 'SOP') then
|
||||||
|
j = det_to_occ_pattern(i_generator)
|
||||||
|
E_shift = psi_det_Hii(i_generator) - psi_occ_pattern_Hii(j)
|
||||||
|
endif
|
||||||
|
|
||||||
|
do p1=1,mo_num
|
||||||
|
if(bannedOrb(p1, s1)) cycle
|
||||||
|
ib = 1
|
||||||
|
if(sp /= 3) ib = p1+1
|
||||||
|
|
||||||
|
do p2=ib,mo_num
|
||||||
|
|
||||||
|
! -----
|
||||||
|
! /!\ Generating only single excited determinants doesn't work because a
|
||||||
|
! determinant generated by a single excitation may be doubly excited wrt
|
||||||
|
! to a determinant of the future. In that case, the determinant will be
|
||||||
|
! detected as already generated when generating in the future with a
|
||||||
|
! double excitation.
|
||||||
|
!
|
||||||
|
! if (.not.do_singles) then
|
||||||
|
! if ((h1 == p1) .or. (h2 == p2)) then
|
||||||
|
! cycle
|
||||||
|
! endif
|
||||||
|
! endif
|
||||||
|
!
|
||||||
|
! if (.not.do_doubles) then
|
||||||
|
! if ((h1 /= p1).and.(h2 /= p2)) then
|
||||||
|
! cycle
|
||||||
|
! endif
|
||||||
|
! endif
|
||||||
|
! -----
|
||||||
|
|
||||||
|
if(bannedOrb(p2, s2)) cycle
|
||||||
|
if(banned(p1,p2)) cycle
|
||||||
|
|
||||||
|
|
||||||
|
if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle
|
||||||
|
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
|
||||||
|
|
||||||
|
if (do_only_cas) then
|
||||||
|
integer, external :: number_of_holes, number_of_particles
|
||||||
|
if (number_of_particles(det)>0) then
|
||||||
|
cycle
|
||||||
|
endif
|
||||||
|
if (number_of_holes(det)>0) then
|
||||||
|
cycle
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
|
||||||
|
if (do_ddci) then
|
||||||
|
logical, external :: is_a_two_holes_two_particles
|
||||||
|
if (is_a_two_holes_two_particles(det)) then
|
||||||
|
cycle
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
|
||||||
|
if (do_only_1h1p) then
|
||||||
|
logical, external :: is_a_1h1p
|
||||||
|
if (.not.is_a_1h1p(det)) cycle
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
|
||||||
|
|
||||||
|
sum_e_pert = 0d0
|
||||||
|
integer :: degree
|
||||||
|
call get_excitation_degree(det,HF_bitmask,degree,N_int)
|
||||||
|
if(degree == 2)cycle
|
||||||
|
do istate=1,N_states
|
||||||
|
delta_E = E0(istate) - Hii + E_shift
|
||||||
|
alpha_h_psi = mat(istate, p1, p2)
|
||||||
|
val = alpha_h_psi + alpha_h_psi
|
||||||
|
tmp = dsqrt(delta_E * delta_E + val * val)
|
||||||
|
if (delta_E < 0.d0) then
|
||||||
|
tmp = -tmp
|
||||||
|
endif
|
||||||
|
e_pert = 0.5d0 * (tmp - delta_E)
|
||||||
|
coef(istate) = e_pert / alpha_h_psi
|
||||||
|
print*,e_pert,coef,alpha_h_psi
|
||||||
|
pt2(istate) = pt2(istate) + e_pert
|
||||||
|
variance(istate) = variance(istate) + alpha_h_psi * alpha_h_psi
|
||||||
|
norm(istate) = norm(istate) + coef(istate) * coef(istate)
|
||||||
|
|
||||||
|
if (weight_selection /= 5) then
|
||||||
|
! Energy selection
|
||||||
|
sum_e_pert = sum_e_pert + e_pert * selection_weight(istate)
|
||||||
|
|
||||||
|
else
|
||||||
|
! Variance selection
|
||||||
|
sum_e_pert = sum_e_pert - alpha_h_psi * alpha_h_psi * selection_weight(istate)
|
||||||
|
endif
|
||||||
|
end do
|
||||||
|
call give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection_reverse,n_det_connection,nkeys,keys,values,sze_buff)
|
||||||
|
|
||||||
|
if(sum_e_pert <= buf%mini) then
|
||||||
|
call add_to_selection_buffer(buf, det, sum_e_pert)
|
||||||
|
end if
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock)
|
||||||
|
end
|
||||||
|
|
||||||
|
|
@ -135,7 +135,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
|
|||||||
PROVIDE psi_occ_pattern_hii det_to_occ_pattern
|
PROVIDE psi_occ_pattern_hii det_to_occ_pattern
|
||||||
endif
|
endif
|
||||||
|
|
||||||
if (N_det < max(4,N_states)) then
|
if (N_det <= max(4,N_states)) then
|
||||||
pt2=0.d0
|
pt2=0.d0
|
||||||
variance=0.d0
|
variance=0.d0
|
||||||
norm=0.d0
|
norm=0.d0
|
||||||
@ -719,6 +719,15 @@ END_PROVIDER
|
|||||||
|
|
||||||
double precision :: rss
|
double precision :: rss
|
||||||
double precision, external :: memory_of_double, memory_of_int
|
double precision, external :: memory_of_double, memory_of_int
|
||||||
|
if (N_det_generators == 1) then
|
||||||
|
pt2_w = 1.d0
|
||||||
|
pt2_cw = 1.d0
|
||||||
|
pt2_W_T = 1.d0
|
||||||
|
pt2_u_0 = 1.d0
|
||||||
|
pt2_n_0 = 1
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
|
||||||
rss = memory_of_double(2*N_det_generators+1)
|
rss = memory_of_double(2*N_det_generators+1)
|
||||||
call check_mem(rss,irp_here)
|
call check_mem(rss,irp_here)
|
||||||
|
|
||||||
@ -754,7 +763,7 @@ END_PROVIDER
|
|||||||
end if
|
end if
|
||||||
pt2_n_0(1) += 1
|
pt2_n_0(1) += 1
|
||||||
if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then
|
if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then
|
||||||
stop "teeth building failed"
|
print *, "teeth building failed"
|
||||||
end if
|
end if
|
||||||
end do
|
end do
|
||||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
@ -61,7 +61,6 @@ subroutine run_selection_slave(thread,iproc,energy)
|
|||||||
! Only first time
|
! Only first time
|
||||||
bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2)
|
bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2)
|
||||||
call create_selection_buffer(bsize, bsize*2, buf)
|
call create_selection_buffer(bsize, bsize*2, buf)
|
||||||
! call create_selection_buffer(N, N*2, buf2)
|
|
||||||
buffer_ready = .True.
|
buffer_ready = .True.
|
||||||
else
|
else
|
||||||
ASSERT (N == buf%N)
|
ASSERT (N == buf%N)
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
|
||||||
use bitmasks
|
use bitmasks
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, pt2_match_weight, (N_states) ]
|
BEGIN_PROVIDER [ double precision, pt2_match_weight, (N_states) ]
|
||||||
@ -248,6 +249,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
|
|||||||
integer,allocatable :: tmp_array(:)
|
integer,allocatable :: tmp_array(:)
|
||||||
integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :)
|
integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :)
|
||||||
logical, allocatable :: banned(:,:,:), bannedOrb(:,:)
|
logical, allocatable :: banned(:,:,:), bannedOrb(:,:)
|
||||||
|
double precision, allocatable :: coef_fullminilist_rev(:,:)
|
||||||
|
|
||||||
|
|
||||||
double precision, allocatable :: mat(:,:,:)
|
double precision, allocatable :: mat(:,:,:)
|
||||||
@ -546,6 +548,14 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
|
|||||||
|
|
||||||
allocate (fullminilist (N_int, 2, fullinteresting(0)), &
|
allocate (fullminilist (N_int, 2, fullinteresting(0)), &
|
||||||
minilist (N_int, 2, interesting(0)) )
|
minilist (N_int, 2, interesting(0)) )
|
||||||
|
if(pert_2rdm)then
|
||||||
|
allocate(coef_fullminilist_rev(N_states,fullinteresting(0)))
|
||||||
|
do i=1,fullinteresting(0)
|
||||||
|
do j = 1, N_states
|
||||||
|
coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
do i=1,fullinteresting(0)
|
do i=1,fullinteresting(0)
|
||||||
fullminilist(1:N_int,1:2,i) = psi_det_sorted(1:N_int,1:2,fullinteresting(i))
|
fullminilist(1:N_int,1:2,i) = psi_det_sorted(1:N_int,1:2,fullinteresting(i))
|
||||||
enddo
|
enddo
|
||||||
@ -597,12 +607,19 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
|
|||||||
|
|
||||||
call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting)
|
call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting)
|
||||||
|
|
||||||
|
if(.not.pert_2rdm)then
|
||||||
call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf)
|
call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf)
|
||||||
|
else
|
||||||
|
call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf,fullminilist, coef_fullminilist_rev, fullinteresting(0))
|
||||||
|
endif
|
||||||
end if
|
end if
|
||||||
enddo
|
enddo
|
||||||
if(s1 /= s2) monoBdo = .false.
|
if(s1 /= s2) monoBdo = .false.
|
||||||
enddo
|
enddo
|
||||||
deallocate(fullminilist,minilist)
|
deallocate(fullminilist,minilist)
|
||||||
|
if(pert_2rdm)then
|
||||||
|
deallocate(coef_fullminilist_rev)
|
||||||
|
endif
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
deallocate(preinteresting, prefullinteresting, interesting, fullinteresting)
|
deallocate(preinteresting, prefullinteresting, interesting, fullinteresting)
|
||||||
@ -633,6 +650,10 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
|||||||
double precision :: E_shift
|
double precision :: E_shift
|
||||||
|
|
||||||
logical, external :: detEq
|
logical, external :: detEq
|
||||||
|
double precision, allocatable :: values(:)
|
||||||
|
integer, allocatable :: keys(:,:)
|
||||||
|
integer :: nkeys
|
||||||
|
|
||||||
|
|
||||||
if(sp == 3) then
|
if(sp == 3) then
|
||||||
s1 = 1
|
s1 = 1
|
||||||
@ -683,6 +704,16 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
|||||||
if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle
|
if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle
|
||||||
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
|
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
|
||||||
|
|
||||||
|
if (do_only_cas) then
|
||||||
|
integer, external :: number_of_holes, number_of_particles
|
||||||
|
if (number_of_particles(det)>0) then
|
||||||
|
cycle
|
||||||
|
endif
|
||||||
|
if (number_of_holes(det)>0) then
|
||||||
|
cycle
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
|
||||||
if (do_ddci) then
|
if (do_ddci) then
|
||||||
logical, external :: is_a_two_holes_two_particles
|
logical, external :: is_a_two_holes_two_particles
|
||||||
if (is_a_two_holes_two_particles(det)) then
|
if (is_a_two_holes_two_particles(det)) then
|
||||||
@ -735,7 +766,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
|||||||
end do
|
end do
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting)
|
subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting)
|
||||||
use bitmasks
|
use bitmasks
|
||||||
implicit none
|
implicit none
|
||||||
|
@ -12,6 +12,7 @@ subroutine run_stochastic_cipsi
|
|||||||
double precision, external :: memory_of_double
|
double precision, external :: memory_of_double
|
||||||
PROVIDE H_apply_buffer_allocated N_generators_bitmask
|
PROVIDE H_apply_buffer_allocated N_generators_bitmask
|
||||||
|
|
||||||
|
N_iter = 1
|
||||||
threshold_generators = 1.d0
|
threshold_generators = 1.d0
|
||||||
SOFT_TOUCH threshold_generators
|
SOFT_TOUCH threshold_generators
|
||||||
|
|
||||||
|
223
src/cipsi/update_2rdm.irp.f
Normal file
223
src/cipsi/update_2rdm.irp.f
Normal file
@ -0,0 +1,223 @@
|
|||||||
|
use bitmasks
|
||||||
|
|
||||||
|
subroutine give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection_reverse,n_det_connection,nkeys,keys,values,sze_buff)
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: n_det_connection,sze_buff
|
||||||
|
double precision, intent(in) :: coef(N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection)
|
||||||
|
double precision, intent(in) :: psi_coef_connection_reverse(N_states,n_det_connection)
|
||||||
|
integer, intent(inout) :: keys(4,sze_buff),nkeys
|
||||||
|
double precision, intent(inout) :: values(sze_buff)
|
||||||
|
integer :: i,j
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
integer :: degree
|
||||||
|
double precision :: phase, contrib
|
||||||
|
do i = 1, n_det_connection
|
||||||
|
call get_excitation(det,psi_det_connection(1,1,i),exc,degree,phase,N_int)
|
||||||
|
if(degree.gt.2)cycle
|
||||||
|
contrib = 0.d0
|
||||||
|
do j = 1, N_states
|
||||||
|
contrib += state_average_weight(j) * psi_coef_connection_reverse(j,i) * phase * coef(j)
|
||||||
|
enddo
|
||||||
|
! case of single excitations
|
||||||
|
if(degree == 1)then
|
||||||
|
if (nkeys + 6 * elec_alpha_num .ge. sze_buff)then
|
||||||
|
call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock)
|
||||||
|
nkeys = 0
|
||||||
|
endif
|
||||||
|
call update_buffer_single_exc_rdm(det,psi_det_connection(1,1,i),exc,phase,contrib,nkeys,keys,values,sze_buff)
|
||||||
|
else
|
||||||
|
!! case of double excitations
|
||||||
|
! if (nkeys + 4 .ge. sze_buff)then
|
||||||
|
! call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock)
|
||||||
|
! nkeys = 0
|
||||||
|
! endif
|
||||||
|
! call update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff)
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
!call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock)
|
||||||
|
!nkeys = 0
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine update_buffer_single_exc_rdm(det1,det2,exc,phase,contrib,nkeys,keys,values,sze_buff)
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: sze_buff
|
||||||
|
integer(bit_kind), intent(in) :: det1(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: det2(N_int,2)
|
||||||
|
integer,intent(in) :: exc(0:2,2,2)
|
||||||
|
double precision,intent(in) :: phase, contrib
|
||||||
|
integer, intent(inout) :: nkeys, keys(4,sze_buff)
|
||||||
|
double precision, intent(inout):: values(sze_buff)
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2),ispin,other_spin
|
||||||
|
integer :: h1,h2,p1,p2,i
|
||||||
|
call bitstring_to_list_ab(det1, occ, n_occ_ab, N_int)
|
||||||
|
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
ispin = 1
|
||||||
|
other_spin = 2
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
ispin = 2
|
||||||
|
other_spin = 1
|
||||||
|
endif
|
||||||
|
if(list_orb_reverse_pert_rdm(h1).lt.0)return
|
||||||
|
h1 = list_orb_reverse_pert_rdm(h1)
|
||||||
|
if(list_orb_reverse_pert_rdm(p1).lt.0)return
|
||||||
|
p1 = list_orb_reverse_pert_rdm(p1)
|
||||||
|
!update the alpha/beta part
|
||||||
|
do i = 1, n_occ_ab(other_spin)
|
||||||
|
h2 = occ(i,other_spin)
|
||||||
|
if(list_orb_reverse_pert_rdm(h2).lt.0)return
|
||||||
|
h2 = list_orb_reverse_pert_rdm(h2)
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * contrib * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * contrib * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = h2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
enddo
|
||||||
|
!update the same spin part
|
||||||
|
!do i = 1, n_occ_ab(ispin)
|
||||||
|
! h2 = occ(i,ispin)
|
||||||
|
! if(list_orb_reverse_pert_rdm(h2).lt.0)return
|
||||||
|
! h2 = list_orb_reverse_pert_rdm(h2)
|
||||||
|
|
||||||
|
! nkeys += 1
|
||||||
|
! values(nkeys) = 0.5d0 * contrib * phase
|
||||||
|
! keys(1,nkeys) = h1
|
||||||
|
! keys(2,nkeys) = h2
|
||||||
|
! keys(3,nkeys) = p1
|
||||||
|
! keys(4,nkeys) = h2
|
||||||
|
|
||||||
|
! nkeys += 1
|
||||||
|
! values(nkeys) = - 0.5d0 * contrib * phase
|
||||||
|
! keys(1,nkeys) = h1
|
||||||
|
! keys(2,nkeys) = h2
|
||||||
|
! keys(3,nkeys) = h2
|
||||||
|
! keys(4,nkeys) = p1
|
||||||
|
!
|
||||||
|
! nkeys += 1
|
||||||
|
! values(nkeys) = 0.5d0 * contrib * phase
|
||||||
|
! keys(1,nkeys) = h2
|
||||||
|
! keys(2,nkeys) = h1
|
||||||
|
! keys(3,nkeys) = h2
|
||||||
|
! keys(4,nkeys) = p1
|
||||||
|
|
||||||
|
! nkeys += 1
|
||||||
|
! values(nkeys) = - 0.5d0 * contrib * phase
|
||||||
|
! keys(1,nkeys) = h2
|
||||||
|
! keys(2,nkeys) = h1
|
||||||
|
! keys(3,nkeys) = p1
|
||||||
|
! keys(4,nkeys) = h2
|
||||||
|
!enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff)
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: sze_buff
|
||||||
|
integer,intent(in) :: exc(0:2,2,2)
|
||||||
|
double precision,intent(in) :: phase, contrib
|
||||||
|
integer, intent(inout) :: nkeys, keys(4,sze_buff)
|
||||||
|
double precision, intent(inout):: values(sze_buff)
|
||||||
|
integer :: h1,h2,p1,p2
|
||||||
|
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Double alpha/beta
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
h2 = exc(1,1,2)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
p2 = exc(1,2,2)
|
||||||
|
! check if the orbitals involved are within the orbital range
|
||||||
|
if(list_orb_reverse_pert_rdm(h1).lt.0)return
|
||||||
|
h1 = list_orb_reverse_pert_rdm(h1)
|
||||||
|
if(list_orb_reverse_pert_rdm(h2).lt.0)return
|
||||||
|
h2 = list_orb_reverse_pert_rdm(h2)
|
||||||
|
if(list_orb_reverse_pert_rdm(p1).lt.0)return
|
||||||
|
p1 = list_orb_reverse_pert_rdm(p1)
|
||||||
|
if(list_orb_reverse_pert_rdm(p2).lt.0)return
|
||||||
|
p2 = list_orb_reverse_pert_rdm(p2)
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * contrib * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = p2
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * contrib * phase
|
||||||
|
keys(1,nkeys) = p1
|
||||||
|
keys(2,nkeys) = p2
|
||||||
|
keys(3,nkeys) = h1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
|
||||||
|
else
|
||||||
|
if (exc(0,1,1) == 2) then
|
||||||
|
! Double alpha/alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
h2 = exc(2,1,1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
p2 = exc(2,2,1)
|
||||||
|
else if (exc(0,1,2) == 2) then
|
||||||
|
! Double beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
h2 = exc(2,1,2)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
p2 = exc(2,2,2)
|
||||||
|
endif
|
||||||
|
! check if the orbitals involved are within the orbital range
|
||||||
|
if(list_orb_reverse_pert_rdm(h1).lt.0)return
|
||||||
|
h1 = list_orb_reverse_pert_rdm(h1)
|
||||||
|
if(list_orb_reverse_pert_rdm(h2).lt.0)return
|
||||||
|
h2 = list_orb_reverse_pert_rdm(h2)
|
||||||
|
if(list_orb_reverse_pert_rdm(p1).lt.0)return
|
||||||
|
p1 = list_orb_reverse_pert_rdm(p1)
|
||||||
|
if(list_orb_reverse_pert_rdm(p2).lt.0)return
|
||||||
|
p2 = list_orb_reverse_pert_rdm(p2)
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * contrib * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = p2
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = - 0.5d0 * contrib * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * contrib * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = p2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = - 0.5d0 * contrib * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = p2
|
||||||
|
endif
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
@ -46,34 +46,6 @@ program cisd
|
|||||||
END_DOC
|
END_DOC
|
||||||
read_wf = .False.
|
read_wf = .False.
|
||||||
SOFT_TOUCH read_wf
|
SOFT_TOUCH read_wf
|
||||||
call run
|
call only_act_bitmask
|
||||||
end
|
call run_cisd
|
||||||
|
|
||||||
subroutine run
|
|
||||||
implicit none
|
|
||||||
integer :: i
|
|
||||||
|
|
||||||
if(pseudo_sym)then
|
|
||||||
call H_apply_cisd_sym
|
|
||||||
else
|
|
||||||
call H_apply_cisd
|
|
||||||
endif
|
|
||||||
print *, 'N_det = ', N_det
|
|
||||||
print*,'******************************'
|
|
||||||
print *, 'Energies of the states:'
|
|
||||||
do i = 1,N_states
|
|
||||||
print *, i, CI_energy(i)
|
|
||||||
enddo
|
|
||||||
if (N_states > 1) then
|
|
||||||
print*,'******************************'
|
|
||||||
print*,'Excitation energies '
|
|
||||||
do i = 2, N_states
|
|
||||||
print*, i ,CI_energy(i) - CI_energy(1)
|
|
||||||
enddo
|
|
||||||
endif
|
|
||||||
psi_coef = ci_eigenvectors
|
|
||||||
SOFT_TOUCH psi_coef
|
|
||||||
call save_wavefunction
|
|
||||||
call ezfio_set_cisd_energy(CI_energy)
|
|
||||||
|
|
||||||
end
|
end
|
||||||
|
42
src/cisd/cisd_routine.irp.f
Normal file
42
src/cisd/cisd_routine.irp.f
Normal file
@ -0,0 +1,42 @@
|
|||||||
|
subroutine only_act_bitmask
|
||||||
|
implicit none
|
||||||
|
integer :: i,j,k
|
||||||
|
do k = 1, N_generators_bitmask
|
||||||
|
do j = 1, 6
|
||||||
|
do i = 1, N_int
|
||||||
|
generators_bitmask(i,1,j,k) = act_bitmask(i,1)
|
||||||
|
generators_bitmask(i,2,j,k) = act_bitmask(i,2)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
touch generators_bitmask
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine run_cisd
|
||||||
|
implicit none
|
||||||
|
integer :: i
|
||||||
|
|
||||||
|
if(pseudo_sym)then
|
||||||
|
call H_apply_cisd_sym
|
||||||
|
else
|
||||||
|
call H_apply_cisd
|
||||||
|
endif
|
||||||
|
print *, 'N_det = ', N_det
|
||||||
|
print*,'******************************'
|
||||||
|
print *, 'Energies of the states:'
|
||||||
|
do i = 1,N_states
|
||||||
|
print *, i, CI_energy(i)
|
||||||
|
enddo
|
||||||
|
if (N_states > 1) then
|
||||||
|
print*,'******************************'
|
||||||
|
print*,'Excitation energies '
|
||||||
|
do i = 2, N_states
|
||||||
|
print*, i ,CI_energy(i) - CI_energy(1)
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
psi_coef = ci_eigenvectors
|
||||||
|
SOFT_TOUCH psi_coef
|
||||||
|
call save_wavefunction
|
||||||
|
call ezfio_set_cisd_energy(CI_energy)
|
||||||
|
|
||||||
|
end
|
@ -6,7 +6,7 @@ BEGIN_PROVIDER [ double precision, psi_energy_two_e, (N_states) ]
|
|||||||
integer :: i,j
|
integer :: i,j
|
||||||
call u_0_H_u_0_two_e(psi_energy_two_e,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size)
|
call u_0_H_u_0_two_e(psi_energy_two_e,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size)
|
||||||
do i=N_det+1,N_states
|
do i=N_det+1,N_states
|
||||||
psi_energy(i) = 0.d0
|
psi_energy_two_e(i) = 0.d0
|
||||||
enddo
|
enddo
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
@ -106,12 +106,31 @@ END_PROVIDER
|
|||||||
BEGIN_PROVIDER [double precision, one_e_dm_average_mo_for_dft, (mo_num,mo_num)]
|
BEGIN_PROVIDER [double precision, one_e_dm_average_mo_for_dft, (mo_num,mo_num)]
|
||||||
implicit none
|
implicit none
|
||||||
integer :: i
|
integer :: i
|
||||||
one_e_dm_average_mo_for_dft = 0.d0
|
one_e_dm_average_mo_for_dft = one_e_dm_average_alpha_mo_for_dft + one_e_dm_average_beta_mo_for_dft
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, one_e_dm_average_alpha_mo_for_dft, (mo_num,mo_num)]
|
||||||
|
implicit none
|
||||||
|
integer :: i
|
||||||
|
one_e_dm_average_alpha_mo_for_dft = 0.d0
|
||||||
do i = 1, N_states
|
do i = 1, N_states
|
||||||
one_e_dm_average_mo_for_dft(:,:) += one_e_dm_mo_for_dft(:,:,i) * state_average_weight(i)
|
one_e_dm_average_alpha_mo_for_dft(:,:) += one_e_dm_mo_alpha_for_dft(:,:,i) * state_average_weight(i)
|
||||||
enddo
|
enddo
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, one_e_dm_average_beta_mo_for_dft, (mo_num,mo_num)]
|
||||||
|
implicit none
|
||||||
|
integer :: i
|
||||||
|
one_e_dm_average_beta_mo_for_dft = 0.d0
|
||||||
|
do i = 1, N_states
|
||||||
|
one_e_dm_average_beta_mo_for_dft(:,:) += one_e_dm_mo_beta_for_dft(:,:,i) * state_average_weight(i)
|
||||||
|
enddo
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, one_e_dm_alpha_ao_for_dft, (ao_num,ao_num,N_states) ]
|
BEGIN_PROVIDER [ double precision, one_e_dm_alpha_ao_for_dft, (ao_num,ao_num,N_states) ]
|
||||||
&BEGIN_PROVIDER [ double precision, one_e_dm_beta_ao_for_dft, (ao_num,ao_num,N_states) ]
|
&BEGIN_PROVIDER [ double precision, one_e_dm_beta_ao_for_dft, (ao_num,ao_num,N_states) ]
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
|
609
src/determinants/two_e_density_matrix.irp.pouet
Normal file
609
src/determinants/two_e_density_matrix.irp.pouet
Normal file
@ -0,0 +1,609 @@
|
|||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, two_bod_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! two_bod_alpha_beta(i,j,k,l) = <Psi| a^{dagger}_{j,alpha} a^{dagger}_{l,beta} a_{k,beta} a_{i,alpha} | Psi>
|
||||||
|
! 1 1 2 2 = chemist notations
|
||||||
|
! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
integer :: dim1,dim2,dim3,dim4
|
||||||
|
double precision :: cpu_0,cpu_1
|
||||||
|
dim1 = mo_num
|
||||||
|
dim2 = mo_num
|
||||||
|
dim3 = mo_num
|
||||||
|
dim4 = mo_num
|
||||||
|
two_bod_alpha_beta_mo = 0.d0
|
||||||
|
print*,'providing two_bod_alpha_beta ...'
|
||||||
|
call wall_time(cpu_0)
|
||||||
|
call two_body_dm_nstates_openmp(two_bod_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
call wall_time(cpu_1)
|
||||||
|
print*,'two_bod_alpha_beta provided in',dabs(cpu_1-cpu_0)
|
||||||
|
|
||||||
|
integer :: ii,jj,i,j,k,l
|
||||||
|
if(no_core_density .EQ. "no_core_dm")then
|
||||||
|
print*,'USING THE VALENCE ONLY TWO BODY DENSITY'
|
||||||
|
|
||||||
|
do ii = 1, n_core_orb ! 1
|
||||||
|
i = list_core(ii)
|
||||||
|
do j = 1, mo_num ! 2
|
||||||
|
do k = 1, mo_num ! 1
|
||||||
|
do l = 1, mo_num ! 2
|
||||||
|
! 2 2 1 1
|
||||||
|
two_bod_alpha_beta_mo(l,j,k,i,:) = 0.d0
|
||||||
|
two_bod_alpha_beta_mo(j,l,k,i,:) = 0.d0
|
||||||
|
two_bod_alpha_beta_mo(l,j,i,k,:) = 0.d0
|
||||||
|
two_bod_alpha_beta_mo(j,l,i,k,:) = 0.d0
|
||||||
|
|
||||||
|
two_bod_alpha_beta_mo(k,i,l,j,:) = 0.d0
|
||||||
|
two_bod_alpha_beta_mo(k,i,j,l,:) = 0.d0
|
||||||
|
two_bod_alpha_beta_mo(i,k,l,j,:) = 0.d0
|
||||||
|
two_bod_alpha_beta_mo(i,k,j,l,:) = 0.d0
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
endif
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, two_bod_alpha_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! two_bod_alpha_beta_mo_physicist,(i,j,k,l) = <Psi| a^{dagger}_{k,alpha} a^{dagger}_{l,beta} a_{j,beta} a_{i,alpha} | Psi>
|
||||||
|
! 1 2 1 2 = physicist notations
|
||||||
|
! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
integer :: i,j,k,l,istate
|
||||||
|
double precision :: cpu_0,cpu_1
|
||||||
|
two_bod_alpha_beta_mo_physicist = 0.d0
|
||||||
|
print*,'providing two_bod_alpha_beta_mo_physicist ...'
|
||||||
|
call wall_time(cpu_0)
|
||||||
|
do istate = 1, N_states
|
||||||
|
do i = 1, mo_num
|
||||||
|
do j = 1, mo_num
|
||||||
|
do k = 1, mo_num
|
||||||
|
do l = 1, mo_num
|
||||||
|
! 1 2 1 2 1 1 2 2
|
||||||
|
two_bod_alpha_beta_mo_physicist(l,k,i,j,istate) = two_bod_alpha_beta_mo(i,l,j,k,istate)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
call wall_time(cpu_1)
|
||||||
|
print*,'two_bod_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0)
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
subroutine two_body_dm_nstates_openmp(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes v_0 = H|u_0> and s_0 = S^2 |u_0>
|
||||||
|
!
|
||||||
|
! Assumes that the determinants are in psi_det
|
||||||
|
!
|
||||||
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: u_0(sze,N_st)
|
||||||
|
integer :: k
|
||||||
|
double precision, allocatable :: u_t(:,:)
|
||||||
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
|
||||||
|
allocate(u_t(N_st,N_det))
|
||||||
|
do k=1,N_st
|
||||||
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
||||||
|
enddo
|
||||||
|
call dtranspose( &
|
||||||
|
u_0, &
|
||||||
|
size(u_0, 1), &
|
||||||
|
u_t, &
|
||||||
|
size(u_t, 1), &
|
||||||
|
N_det, N_st)
|
||||||
|
|
||||||
|
call two_body_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1)
|
||||||
|
deallocate(u_t)
|
||||||
|
|
||||||
|
do k=1,N_st
|
||||||
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine two_body_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes v_0 = H|u_0> and s_0 = S^2 |u_0>
|
||||||
|
!
|
||||||
|
! Default should be 1,N_det,0,1
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(in) :: u_t(N_st,N_det)
|
||||||
|
|
||||||
|
|
||||||
|
PROVIDE N_int
|
||||||
|
|
||||||
|
select case (N_int)
|
||||||
|
case (1)
|
||||||
|
call two_body_dm_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (2)
|
||||||
|
call two_body_dm_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (3)
|
||||||
|
call two_body_dm_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (4)
|
||||||
|
call two_body_dm_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case default
|
||||||
|
call two_body_dm_nstates_openmp_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
end select
|
||||||
|
end
|
||||||
|
BEGIN_TEMPLATE
|
||||||
|
|
||||||
|
subroutine two_body_dm_nstates_openmp_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(in) :: u_t(N_st,N_det)
|
||||||
|
|
||||||
|
double precision :: hij, sij
|
||||||
|
integer :: i,j,k,l
|
||||||
|
integer :: k_a, k_b, l_a, l_b, m_a, m_b
|
||||||
|
integer :: istate
|
||||||
|
integer :: krow, kcol, krow_b, kcol_b
|
||||||
|
integer :: lrow, lcol
|
||||||
|
integer :: mrow, mcol
|
||||||
|
integer(bit_kind) :: spindet($N_int)
|
||||||
|
integer(bit_kind) :: tmp_det($N_int,2)
|
||||||
|
integer(bit_kind) :: tmp_det2($N_int,2)
|
||||||
|
integer(bit_kind) :: tmp_det3($N_int,2)
|
||||||
|
integer(bit_kind), allocatable :: buffer(:,:)
|
||||||
|
integer :: n_doubles
|
||||||
|
integer, allocatable :: doubles(:)
|
||||||
|
integer, allocatable :: singles_a(:)
|
||||||
|
integer, allocatable :: singles_b(:)
|
||||||
|
integer, allocatable :: idx(:), idx0(:)
|
||||||
|
integer :: maxab, n_singles_a, n_singles_b, kcol_prev, nmax
|
||||||
|
integer*8 :: k8
|
||||||
|
|
||||||
|
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
|
||||||
|
allocate(idx0(maxab))
|
||||||
|
|
||||||
|
do i=1,maxab
|
||||||
|
idx0(i) = i
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Prepare the array of all alpha single excitations
|
||||||
|
! -------------------------------------------------
|
||||||
|
|
||||||
|
PROVIDE N_int nthreads_davidson
|
||||||
|
|
||||||
|
! Alpha/Beta double excitations
|
||||||
|
! =============================
|
||||||
|
|
||||||
|
allocate( buffer($N_int,maxab), &
|
||||||
|
singles_a(maxab), &
|
||||||
|
singles_b(maxab), &
|
||||||
|
doubles(maxab), &
|
||||||
|
idx(maxab))
|
||||||
|
|
||||||
|
kcol_prev=-1
|
||||||
|
|
||||||
|
ASSERT (iend <= N_det)
|
||||||
|
ASSERT (istart > 0)
|
||||||
|
ASSERT (istep > 0)
|
||||||
|
|
||||||
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
if (kcol /= kcol_prev) then
|
||||||
|
call get_all_spin_singles_$N_int( &
|
||||||
|
psi_det_beta_unique, idx0, &
|
||||||
|
tmp_det(1,2), N_det_beta_unique, &
|
||||||
|
singles_b, n_singles_b)
|
||||||
|
endif
|
||||||
|
kcol_prev = kcol
|
||||||
|
|
||||||
|
! Loop over singly excited beta columns
|
||||||
|
! -------------------------------------
|
||||||
|
|
||||||
|
do i=1,n_singles_b
|
||||||
|
lcol = singles_b(i)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
|
||||||
|
|
||||||
|
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
idx(j) = l_a
|
||||||
|
l_a = l_a+1
|
||||||
|
enddo
|
||||||
|
j = j-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_$N_int( &
|
||||||
|
buffer, idx, tmp_det(1,1), j, &
|
||||||
|
singles_a, n_singles_a )
|
||||||
|
|
||||||
|
! Loop over alpha singles
|
||||||
|
! -----------------------
|
||||||
|
|
||||||
|
do k = 1,n_singles_a
|
||||||
|
l_a = singles_a(k)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
!!!!!!!!!!!!!!!!!! ALPHA BETA
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
call off_diagonal_double_to_two_body_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
|
|
||||||
|
! Single and double alpha excitations
|
||||||
|
! ===================================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
! Initial determinant is at k_b in beta-major representation
|
||||||
|
! ----------------------------------------------------------------------
|
||||||
|
|
||||||
|
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||||
|
|
||||||
|
spindet(1:$N_int) = tmp_det(1:$N_int,1)
|
||||||
|
|
||||||
|
! Loop inside the beta column to gather all the connected alphas
|
||||||
|
lcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||||
|
do i=1,N_det_alpha_unique
|
||||||
|
if (l_a > N_det) exit
|
||||||
|
lcol = psi_bilinear_matrix_columns(l_a)
|
||||||
|
if (lcol /= kcol) exit
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
idx(i) = l_a
|
||||||
|
l_a = l_a+1
|
||||||
|
enddo
|
||||||
|
i = i-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_and_doubles_$N_int( &
|
||||||
|
buffer, idx, spindet, i, &
|
||||||
|
singles_a, doubles, n_singles_a, n_doubles )
|
||||||
|
|
||||||
|
! Compute Hij for all alpha singles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
do i=1,n_singles_a
|
||||||
|
l_a = singles_a(i)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
!!!! MONO SPIN
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
call off_diagonal_single_to_two_body_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
!! Compute Hij for all alpha doubles
|
||||||
|
!! ----------------------------------
|
||||||
|
!
|
||||||
|
!do i=1,n_doubles
|
||||||
|
! l_a = doubles(i)
|
||||||
|
! ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
! lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
! ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
! call i_H_j_double_spin_erf( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij)
|
||||||
|
! do l=1,N_st
|
||||||
|
! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
|
||||||
|
! ! same spin => sij = 0
|
||||||
|
! enddo
|
||||||
|
!enddo
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
! Single and double beta excitations
|
||||||
|
! ==================================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
spindet(1:$N_int) = tmp_det(1:$N_int,2)
|
||||||
|
|
||||||
|
! Initial determinant is at k_b in beta-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||||
|
|
||||||
|
! Loop inside the alpha row to gather all the connected betas
|
||||||
|
lrow = psi_bilinear_matrix_transp_rows(k_b)
|
||||||
|
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
|
||||||
|
do i=1,N_det_beta_unique
|
||||||
|
if (l_b > N_det) exit
|
||||||
|
lrow = psi_bilinear_matrix_transp_rows(l_b)
|
||||||
|
if (lrow /= krow) exit
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
|
||||||
|
idx(i) = l_b
|
||||||
|
l_b = l_b+1
|
||||||
|
enddo
|
||||||
|
i = i-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_and_doubles_$N_int( &
|
||||||
|
buffer, idx, spindet, i, &
|
||||||
|
singles_b, doubles, n_singles_b, n_doubles )
|
||||||
|
|
||||||
|
! Compute Hij for all beta singles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
do i=1,n_singles_b
|
||||||
|
l_b = singles_b(i)
|
||||||
|
ASSERT (l_b <= N_det)
|
||||||
|
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
|
||||||
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
call off_diagonal_single_to_two_body_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
enddo
|
||||||
|
!
|
||||||
|
!! Compute Hij for all beta doubles
|
||||||
|
!! ----------------------------------
|
||||||
|
!
|
||||||
|
!do i=1,n_doubles
|
||||||
|
! l_b = doubles(i)
|
||||||
|
! ASSERT (l_b <= N_det)
|
||||||
|
|
||||||
|
! lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
! ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
! call i_H_j_double_spin_erf( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij)
|
||||||
|
! l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
|
! ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
! do l=1,N_st
|
||||||
|
! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
|
||||||
|
! ! same spin => sij = 0
|
||||||
|
! enddo
|
||||||
|
!enddo
|
||||||
|
|
||||||
|
|
||||||
|
! Diagonal contribution
|
||||||
|
! =====================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
double precision, external :: diag_H_mat_elem_erf, diag_S_mat_elem
|
||||||
|
double precision :: c_1(N_states),c_2(N_states)
|
||||||
|
do l = 1, N_states
|
||||||
|
c_1(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call diagonal_contrib_to_two_body_ab_dm(tmp_det,c_1,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
|
||||||
|
end do
|
||||||
|
deallocate(buffer, singles_a, singles_b, doubles, idx)
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
SUBST [ N_int ]
|
||||||
|
|
||||||
|
1;;
|
||||||
|
2;;
|
||||||
|
3;;
|
||||||
|
4;;
|
||||||
|
N_int;;
|
||||||
|
|
||||||
|
END_TEMPLATE
|
||||||
|
|
||||||
|
subroutine diagonal_contrib_to_two_body_ab_dm(det_1,c_1,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2)
|
||||||
|
double precision, intent(in) :: c_1(N_states)
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate
|
||||||
|
double precision :: c_1_bis
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
do istate = 1, N_states
|
||||||
|
c_1_bis = c_1(istate) * c_1(istate)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(j,2)
|
||||||
|
big_array(h1,h1,h2,h2,istate) += c_1_bis
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine diagonal_contrib_to_all_two_body_dm(det_1,c_1,big_array_ab,big_array_aa,big_array_bb,dim1,dim2,dim3,dim4)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2)
|
||||||
|
double precision, intent(in) :: c_1(N_states)
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate
|
||||||
|
double precision :: c_1_bis
|
||||||
|
BEGIN_DOC
|
||||||
|
! no factor 1/2 have to be taken into account as the permutations are already taken into account
|
||||||
|
END_DOC
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
do istate = 1, N_states
|
||||||
|
c_1_bis = c_1(istate) * c_1(istate)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(j,2)
|
||||||
|
big_array_ab(h1,h1,h2,h2,istate) += c_1_bis
|
||||||
|
enddo
|
||||||
|
do j = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(j,1)
|
||||||
|
big_array_aa(h1,h2,h1,h2,istate) -= c_1_bis
|
||||||
|
big_array_aa(h1,h1,h2,h2,istate) += c_1_bis
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h1 = occ(i,2)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(j,2)
|
||||||
|
big_array_bb(h1,h1,h2,h2,istate) += c_1_bis
|
||||||
|
big_array_bb(h1,h2,h1,h2,istate) -= c_1_bis
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine off_diagonal_double_to_two_body_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
double precision, intent(in) :: c_1(N_states),c_2(N_states)
|
||||||
|
integer :: i,j,h1,h2,p1,p2,istate
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
call get_double_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
h2 = exc(1,1,2)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
p2 = exc(1,2,2)
|
||||||
|
do istate = 1, N_states
|
||||||
|
big_array(h1,p1,h2,p2,istate) += c_1(istate) * phase * c_2(istate)
|
||||||
|
! big_array(p1,h1,p2,h2,istate) += c_1(istate) * phase * c_2(istate)
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine off_diagonal_single_to_two_body_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
double precision, intent(in) :: c_1(N_states),c_2(N_states)
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
do istate = 1, N_states
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(i,2)
|
||||||
|
big_array(h1,p1,h2,h2,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
do istate = 1, N_states
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(i,1)
|
||||||
|
big_array(h2,h2,h1,p1,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
end
|
@ -15,7 +15,7 @@ prefix = ""
|
|||||||
for f in functionals:
|
for f in functionals:
|
||||||
print """
|
print """
|
||||||
%sif (trim(exchange_functional) == '%s') then
|
%sif (trim(exchange_functional) == '%s') then
|
||||||
energy_x = energy_x_%s"""%(prefix, f, f)
|
energy_x = (1.d0 - HF_exchange ) * energy_x_%s"""%(prefix, f, f)
|
||||||
prefix = "else "
|
prefix = "else "
|
||||||
print """
|
print """
|
||||||
else
|
else
|
||||||
|
@ -17,8 +17,8 @@ prefix = ""
|
|||||||
for f in functionals:
|
for f in functionals:
|
||||||
print """
|
print """
|
||||||
%sif (trim(exchange_functional) == '%s') then
|
%sif (trim(exchange_functional) == '%s') then
|
||||||
potential_x_alpha_ao = potential_x_alpha_ao_%s
|
potential_x_alpha_ao = ( 1.d0 - HF_exchange ) * potential_x_alpha_ao_%s
|
||||||
potential_x_beta_ao = potential_x_beta_ao_%s"""%(prefix, f, f, f)
|
potential_x_beta_ao = ( 1.d0 - HF_exchange ) * potential_x_beta_ao_%s"""%(prefix, f, f, f)
|
||||||
prefix = "else "
|
prefix = "else "
|
||||||
print """
|
print """
|
||||||
else
|
else
|
||||||
|
@ -32,6 +32,7 @@
|
|||||||
! k = 1 : x, k= 2, y, k 3, z
|
! k = 1 : x, k= 2, y, k 3, z
|
||||||
END_DOC
|
END_DOC
|
||||||
integer :: m
|
integer :: m
|
||||||
|
print*,'mo_num,n_points_final_grid',mo_num,n_points_final_grid
|
||||||
mos_grad_in_r_array = 0.d0
|
mos_grad_in_r_array = 0.d0
|
||||||
do m=1,3
|
do m=1,3
|
||||||
call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_coef_transp,mo_num,aos_grad_in_r_array(1,1,m),ao_num,0.d0,mos_grad_in_r_array(1,1,m),mo_num)
|
call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_coef_transp,mo_num,aos_grad_in_r_array(1,1,m),ao_num,0.d0,mos_grad_in_r_array(1,1,m),mo_num)
|
||||||
|
28
src/dft_utils_one_e/ec_lyp_2.irp.f
Normal file
28
src/dft_utils_one_e/ec_lyp_2.irp.f
Normal file
@ -0,0 +1,28 @@
|
|||||||
|
double precision function ec_lyp2(RhoA,RhoB,GA,GB,GAB)
|
||||||
|
include 'constants.include.F'
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: RhoA,RhoB,GA,GB,GAB
|
||||||
|
double precision :: Tol,caa,cab,cac,cad,cae,RA,RB,comega,cdelta,cLaa,cLbb,cLab,E
|
||||||
|
ec_lyp2 = 0.d0
|
||||||
|
Tol=1D-14
|
||||||
|
E=2.718281828459045D0
|
||||||
|
caa=0.04918D0
|
||||||
|
cab=0.132D0
|
||||||
|
cac=0.2533D0
|
||||||
|
cad=0.349D0
|
||||||
|
cae=(2D0**(11D0/3D0))*((3D0/10D0)*((3D0*(Pi**2D0))**(2D0/3D0)))
|
||||||
|
|
||||||
|
|
||||||
|
RA = MAX(RhoA,0D0)
|
||||||
|
RB = MAX(RhoB,0D0)
|
||||||
|
IF ((RA.gt.Tol).OR.(RB.gt.Tol)) THEN
|
||||||
|
IF ((RA.gt.Tol).AND.(RB.gt.Tol)) THEN
|
||||||
|
comega = 1D0/(E**(cac/(RA+RB)**(1D0/3D0))*(RA+RB)**(10D0/3D0)*(cad+(RA+RB)**(1D0/3D0)))
|
||||||
|
cdelta = (cac+cad+(cac*cad)/(RA+RB)**(1D0/3D0))/(cad+(RA+RB)**(1D0/3D0))
|
||||||
|
cLaa = (cab*comega*RB*(RA-3D0*cdelta*RA-9D0*RB-((-11D0+cdelta)*RA**2D0)/(RA+RB)))/9D0
|
||||||
|
cLbb = (cab*comega*RA*(-9D0*RA+(RB*(RA-3D0*cdelta*RA-4D0*(-3D0+cdelta)*RB))/(RA+RB)))/9D0
|
||||||
|
cLab = cab*comega*(((47D0-7D0*cdelta)*RA*RB)/9D0-(4D0*(RA+RB)**2D0)/3D0)
|
||||||
|
ec_lyp2 = -(caa*(cLaa*GA+cLab*GAB+cLbb*GB+cab*cae*comega*RA*RB*(RA**(8D0/3D0)+RB**(8D0/3D0))+(4D0*RA*RB)/(RA+RB+cad*(RA+RB)**(2D0/3D0))))
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
end
|
@ -38,6 +38,8 @@ double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2)
|
|||||||
! correlation energy lsda1
|
! correlation energy lsda1
|
||||||
call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1)
|
call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1)
|
||||||
|
|
||||||
|
! correlation energy per particle
|
||||||
|
e_c_lsda1 = e_c_lsda1/rho
|
||||||
xi = spin_d/rho
|
xi = spin_d/rho
|
||||||
rs = (cst_43 * pi * rho)**(-cst_13)
|
rs = (cst_43 * pi * rho)**(-cst_13)
|
||||||
s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 )
|
s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 )
|
||||||
@ -61,7 +63,12 @@ double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2)
|
|||||||
g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0
|
g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0
|
||||||
h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2))
|
h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2))
|
||||||
! interpolation function
|
! interpolation function
|
||||||
fc_alpha = dexp(-c_1c * alpha * inv_1alph) * step_f(cst_1alph) - d_c * dexp(c_2c * inv_1alph) * step_f(-cst_1alph)
|
|
||||||
|
if(cst_1alph.gt.0.d0)then
|
||||||
|
fc_alpha = dexp(-c_1c * alpha * inv_1alph)
|
||||||
|
else
|
||||||
|
fc_alpha = - d_c * dexp(c_2c * inv_1alph)
|
||||||
|
endif
|
||||||
! first part of the correlation energy
|
! first part of the correlation energy
|
||||||
e_c_1 = e_c_lsda1 + h1
|
e_c_1 = e_c_lsda1 + h1
|
||||||
|
|
||||||
@ -82,15 +89,6 @@ double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2)
|
|||||||
ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1)
|
ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1)
|
||||||
end
|
end
|
||||||
|
|
||||||
double precision function step_f(x)
|
|
||||||
implicit none
|
|
||||||
double precision, intent(in) :: x
|
|
||||||
if(x.lt.0.d0)then
|
|
||||||
step_f = 0.d0
|
|
||||||
else
|
|
||||||
step_f = 1.d0
|
|
||||||
endif
|
|
||||||
end
|
|
||||||
|
|
||||||
double precision function beta_rs(rs)
|
double precision function beta_rs(rs)
|
||||||
implicit none
|
implicit none
|
||||||
@ -98,3 +96,4 @@ double precision function beta_rs(rs)
|
|||||||
beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs)
|
beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs)
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
100
src/dft_utils_one_e/ec_scan_2.irp.f
Normal file
100
src/dft_utils_one_e/ec_scan_2.irp.f
Normal file
@ -0,0 +1,100 @@
|
|||||||
|
double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2)
|
||||||
|
include 'constants.include.F'
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: rho_a,rho_b,tau,grad_rho_2
|
||||||
|
double precision :: cst_13,cst_23,cst_43,cst_53,rho_inv,cst_18,cst_3pi2
|
||||||
|
double precision :: thr,nup,ndo,xi,s,spin_d,drho,drho2,rho,inv_1alph,e_c_lsda1,h0
|
||||||
|
double precision :: rs,t_w,t_unif,ds_xi,alpha,fc_alpha,step_f,cst_1alph,beta_inf
|
||||||
|
double precision :: c_1c,c_2c,d_c,e_c_ldsa1,h1,phi,t,beta_rs,gama,a,w_1,g_at2,phi_3,e_c_1
|
||||||
|
double precision :: b_1c,b_2c,b_3c,dx_xi,gc_xi,e_c_lsda0,w_0,g_inf,cx_xi,x_inf,f0,e_c_0
|
||||||
|
thr = 1.d-12
|
||||||
|
nup = max(rho_a,thr)
|
||||||
|
ndo = max(rho_b,thr)
|
||||||
|
rho = nup + ndo
|
||||||
|
ec_scan = 0.d0
|
||||||
|
if((rho).lt.thr)return
|
||||||
|
! constants ...
|
||||||
|
rho_inv = 1.d0/rho
|
||||||
|
cst_13 = 1.d0/3.d0
|
||||||
|
cst_23 = 2.d0 * cst_13
|
||||||
|
cst_43 = 4.d0 * cst_13
|
||||||
|
cst_53 = 5.d0 * cst_13
|
||||||
|
cst_18 = 1.d0/8.d0
|
||||||
|
cst_3pi2 = 3.d0 * pi*pi
|
||||||
|
drho2 = max(grad_rho_2,thr)
|
||||||
|
drho = dsqrt(drho2)
|
||||||
|
if((nup-ndo).gt.0.d0)then
|
||||||
|
spin_d = max(nup-ndo,thr)
|
||||||
|
else
|
||||||
|
spin_d = min(nup-ndo,-thr)
|
||||||
|
endif
|
||||||
|
c_1c = 0.64d0
|
||||||
|
c_2c = 1.5d0
|
||||||
|
d_c = 0.7d0
|
||||||
|
b_1c = 0.0285764d0
|
||||||
|
b_2c = 0.0889d0
|
||||||
|
b_3c = 0.125541d0
|
||||||
|
gama = 0.031091d0
|
||||||
|
! correlation energy lsda1
|
||||||
|
call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1)
|
||||||
|
|
||||||
|
xi = spin_d/rho
|
||||||
|
rs = (cst_43 * pi * rho)**(-cst_13)
|
||||||
|
s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 )
|
||||||
|
t_w = drho2 * cst_18 * rho_inv
|
||||||
|
ds_xi = 0.5d0 * ( (1.d0+xi)**cst_53 + (1.d0 - xi)**cst_53)
|
||||||
|
t_unif = 0.3d0 * (cst_3pi2)**cst_23 * rho**cst_53*ds_xi
|
||||||
|
t_unif = max(t_unif,thr)
|
||||||
|
alpha = (tau - t_w)/t_unif
|
||||||
|
cst_1alph= 1.d0 - alpha
|
||||||
|
if(cst_1alph.gt.0.d0)then
|
||||||
|
cst_1alph= max(cst_1alph,thr)
|
||||||
|
else
|
||||||
|
cst_1alph= min(cst_1alph,-thr)
|
||||||
|
endif
|
||||||
|
inv_1alph= 1.d0/cst_1alph
|
||||||
|
phi = 0.5d0 * ( (1.d0+xi)**cst_23 + (1.d0 - xi)**cst_23)
|
||||||
|
phi_3 = phi*phi*phi
|
||||||
|
t = (cst_3pi2/16.d0)**cst_13 * s / (phi * rs**0.5d0)
|
||||||
|
w_1 = dexp(-e_c_lsda1/(gama * phi_3)) - 1.d0
|
||||||
|
a = beta_rs(rs) /(gama * w_1)
|
||||||
|
g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0
|
||||||
|
h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2))
|
||||||
|
! interpolation function
|
||||||
|
fc_alpha = dexp(-c_1c * alpha * inv_1alph) * step_f(cst_1alph) - d_c * dexp(c_2c * inv_1alph) * step_f(-cst_1alph)
|
||||||
|
! first part of the correlation energy
|
||||||
|
e_c_1 = e_c_lsda1 + h1
|
||||||
|
|
||||||
|
dx_xi = 0.5d0 * ( (1.d0+xi)**cst_43 + (1.d0 - xi)**cst_43)
|
||||||
|
gc_xi = (1.d0 - 2.3631d0 * (dx_xi - 1.d0) ) * (1.d0 - xi**12.d0)
|
||||||
|
e_c_lsda0= - b_1c / (1.d0 + b_2c * rs**0.5d0 + b_3c * rs)
|
||||||
|
w_0 = dexp(-e_c_lsda0/b_1c) - 1.d0
|
||||||
|
beta_inf = 0.066725d0 * 0.1d0 / 0.1778d0
|
||||||
|
cx_xi = -3.d0/(4.d0*pi) * (9.d0 * pi/4.d0)**cst_13 * dx_xi
|
||||||
|
|
||||||
|
x_inf = 0.128026d0
|
||||||
|
f0 = -0.9d0
|
||||||
|
g_inf = 1.d0/(1.d0 + 4.d0 * x_inf * s*s)**0.25d0
|
||||||
|
|
||||||
|
h0 = b_1c * dlog(1.d0 + w_0 * (1.d0 - g_inf))
|
||||||
|
e_c_0 = (e_c_lsda0 + h0) * gc_xi
|
||||||
|
|
||||||
|
ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1)
|
||||||
|
end
|
||||||
|
|
||||||
|
double precision function step_f(x)
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) :: x
|
||||||
|
if(x.lt.0.d0)then
|
||||||
|
step_f = 0.d0
|
||||||
|
else
|
||||||
|
step_f = 1.d0
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
double precision function beta_rs(rs)
|
||||||
|
implicit none
|
||||||
|
double precision, intent(in) ::rs
|
||||||
|
beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs)
|
||||||
|
|
||||||
|
end
|
@ -1,10 +1,12 @@
|
|||||||
BEGIN_PROVIDER [ logical, do_only_1h1p ]
|
BEGIN_PROVIDER [ logical, do_only_1h1p ]
|
||||||
|
&BEGIN_PROVIDER [ logical, do_only_cas ]
|
||||||
&BEGIN_PROVIDER [ logical, do_ddci ]
|
&BEGIN_PROVIDER [ logical, do_ddci ]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! In the FCI case, all those are always false
|
! In the FCI case, all those are always false
|
||||||
END_DOC
|
END_DOC
|
||||||
do_only_1h1p = .False.
|
do_only_1h1p = .False.
|
||||||
|
do_only_cas = .False.
|
||||||
do_ddci = .False.
|
do_ddci = .False.
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
@ -55,6 +55,7 @@ END_PROVIDER
|
|||||||
nongen(inongen) = i
|
nongen(inongen) = i
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
|
ASSERT (m == N_det_generators)
|
||||||
|
|
||||||
psi_det_sorted_gen(:,:,:N_det_generators) = psi_det_generators(:,:,:N_det_generators)
|
psi_det_sorted_gen(:,:,:N_det_generators) = psi_det_generators(:,:,:N_det_generators)
|
||||||
psi_coef_sorted_gen(:N_det_generators, :) = psi_coef_generators(:N_det_generators, :)
|
psi_coef_sorted_gen(:N_det_generators, :) = psi_coef_generators(:N_det_generators, :)
|
||||||
|
1
src/generators_fluid/NEED
Normal file
1
src/generators_fluid/NEED
Normal file
@ -0,0 +1 @@
|
|||||||
|
determinants
|
0
src/generators_fluid/README.rst
Normal file
0
src/generators_fluid/README.rst
Normal file
23
src/generators_fluid/extract_cas.irp.f
Normal file
23
src/generators_fluid/extract_cas.irp.f
Normal file
@ -0,0 +1,23 @@
|
|||||||
|
subroutine extract_cas
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Replaces the total wave function by the normalized projection on the CAS.
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
integer :: i,j,k
|
||||||
|
do k=1,N_states
|
||||||
|
do j=1,N_det_generators
|
||||||
|
psi_coef(j,k) = psi_coef_generators(j,k)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
|
||||||
|
do j=1,N_det_generators
|
||||||
|
do k=1,N_int
|
||||||
|
psi_det(k,1,j) = psi_det_generators(k,1,j)
|
||||||
|
psi_det(k,2,j) = psi_det_generators(k,2,j)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
N_det = N_det_generators
|
||||||
|
|
||||||
|
SOFT_TOUCH N_det psi_det psi_coef
|
||||||
|
end
|
101
src/generators_fluid/generators.irp.f
Normal file
101
src/generators_fluid/generators.irp.f
Normal file
@ -0,0 +1,101 @@
|
|||||||
|
use bitmasks
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ character*(32), generators_type]
|
||||||
|
implicit none
|
||||||
|
generators_type = trim("CAS")
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, N_det_generators ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Number of generator detetrminants
|
||||||
|
END_DOC
|
||||||
|
if(generators_type == "CAS")then
|
||||||
|
N_det_generators = N_det_generators_CAS
|
||||||
|
else if (generators_type == "HF")then
|
||||||
|
N_det_generators = N_det_generators_HF
|
||||||
|
else if (generators_type == "HF_SD")then
|
||||||
|
N_det_generators = N_det_generators_HF_SD
|
||||||
|
endif
|
||||||
|
N_det_generators = max(N_det_generators,1)
|
||||||
|
call write_int(6,N_det_generators,'Number of generators')
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! For Single reference wave functions, the generator is the
|
||||||
|
! Hartree-Fock determinant
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
if(generators_type == "CAS")then
|
||||||
|
psi_det_generators(1:N_int,1:2,1:N_det_generators_CAS) = psi_det_generators_CAS(1:N_int,1:2,1:N_det_generators_CAS)
|
||||||
|
psi_coef_generators(1:N_det_generators_CAS,1:N_states) = psi_coef_generators_CAS(1:N_det_generators_CAS,1:N_states)
|
||||||
|
else if (generators_type == "HF")then
|
||||||
|
psi_det_generators(1:N_int,1:2,1:N_det_generators_HF) = psi_det_generators_HF(1:N_int,1:2,1:N_det_generators_HF)
|
||||||
|
psi_coef_generators(1:N_det_generators_HF,1:N_states) = psi_coef_generators_HF(1:N_det_generators_HF,1:N_states)
|
||||||
|
else if (generators_type == "HF_SD")then
|
||||||
|
psi_det_generators(1:N_int,1:2,1:N_det_generators_HF_SD) = psi_det_generators_HF_SD(1:N_int,1:2,1:N_det_generators_HF_SD)
|
||||||
|
psi_coef_generators(1:N_det_generators_HF_SD,1:N_states) = psi_coef_generators_HF_SD(1:N_det_generators_HF_SD,1:N_states)
|
||||||
|
endif
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,psi_det_size) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (psi_det_size,N_states) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (psi_det_size) ]
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! For Single reference wave functions, the generator is the
|
||||||
|
! Hartree-Fock determinant
|
||||||
|
END_DOC
|
||||||
|
if(generators_type == "CAS")then
|
||||||
|
psi_det_sorted_gen = psi_det_sorted_gen_CAS
|
||||||
|
psi_coef_sorted_gen = psi_coef_sorted_gen_CAS
|
||||||
|
psi_det_sorted_gen_order = psi_det_sorted_gen_CAS_order
|
||||||
|
else if(generators_type == "HF")then
|
||||||
|
psi_det_sorted_gen = 0_bit_kind
|
||||||
|
psi_coef_sorted_gen = 0.d0
|
||||||
|
psi_det_sorted_gen_order = 0
|
||||||
|
else if(generators_type == "HF_SD")then
|
||||||
|
psi_det_sorted_gen = psi_det_sorted_gen_HF_SD
|
||||||
|
psi_coef_sorted_gen = psi_coef_sorted_gen_HF_SD
|
||||||
|
psi_det_sorted_gen_order = psi_det_sorted_gen_HF_SD_order
|
||||||
|
endif
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [integer, degree_max_generators]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Max degree of excitation (respect to HF) of the generators
|
||||||
|
END_DOC
|
||||||
|
integer :: i,degree
|
||||||
|
degree_max_generators = 0
|
||||||
|
do i = 1, N_det_generators
|
||||||
|
call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int)
|
||||||
|
if(degree .gt. degree_max_generators)then
|
||||||
|
degree_max_generators = degree
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, size_select_max]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Size of the select_max array
|
||||||
|
END_DOC
|
||||||
|
size_select_max = 10000
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Memo to skip useless selectors
|
||||||
|
END_DOC
|
||||||
|
select_max = huge(1.d0)
|
||||||
|
END_PROVIDER
|
||||||
|
|
69
src/generators_fluid/generators_cas.irp.f
Normal file
69
src/generators_fluid/generators_cas.irp.f
Normal file
@ -0,0 +1,69 @@
|
|||||||
|
use bitmasks
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, N_det_generators_CAS ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Number of generator detetrminants
|
||||||
|
END_DOC
|
||||||
|
integer :: i,k,l
|
||||||
|
logical :: good
|
||||||
|
integer, external :: number_of_holes,number_of_particles
|
||||||
|
call write_time(6)
|
||||||
|
N_det_generators_CAS = 0
|
||||||
|
do i=1,N_det
|
||||||
|
good = ( number_of_holes(psi_det_sorted(1,1,i)) ==0).and.(number_of_particles(psi_det_sorted(1,1,i))==0 )
|
||||||
|
if (good) then
|
||||||
|
N_det_generators_CAS += 1
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
N_det_generators_CAS = max(N_det_generators_CAS,1)
|
||||||
|
call write_int(6,N_det_generators_CAS,'Number of generators_CAS')
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_CAS, (N_int,2,psi_det_size) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, psi_coef_generators_CAS, (psi_det_size,N_states) ]
|
||||||
|
&BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen_CAS, (N_int,2,psi_det_size) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen_CAS, (psi_det_size,N_states) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_CAS_order, (psi_det_size) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! For Single reference wave functions, the gen_CASerator is the
|
||||||
|
! Hartree-Fock determinant
|
||||||
|
END_DOC
|
||||||
|
integer :: i, k, l, m
|
||||||
|
logical :: good
|
||||||
|
integer, external :: number_of_holes,number_of_particles
|
||||||
|
integer, allocatable :: nongen_CAS(:)
|
||||||
|
integer :: inongen_CAS
|
||||||
|
|
||||||
|
allocate(nongen_CAS(N_det))
|
||||||
|
|
||||||
|
inongen_CAS = 0
|
||||||
|
m=0
|
||||||
|
do i=1,N_det
|
||||||
|
good = ( number_of_holes(psi_det_sorted(1,1,i)) ==0).and.(number_of_particles(psi_det_sorted(1,1,i))==0 )
|
||||||
|
if (good) then
|
||||||
|
m = m+1
|
||||||
|
psi_det_sorted_gen_CAS_order(i) = m
|
||||||
|
do k=1,N_int
|
||||||
|
psi_det_generators_CAS(k,1,m) = psi_det_sorted(k,1,i)
|
||||||
|
psi_det_generators_CAS(k,2,m) = psi_det_sorted(k,2,i)
|
||||||
|
enddo
|
||||||
|
psi_coef_generators_CAS(m,:) = psi_coef_sorted(i,:)
|
||||||
|
else
|
||||||
|
inongen_CAS += 1
|
||||||
|
nongen_CAS(inongen_CAS) = i
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
ASSERT (m == N_det_generators_CAS)
|
||||||
|
|
||||||
|
psi_det_sorted_gen_CAS(:,:,:N_det_generators_CAS) = psi_det_generators_CAS(:,:,:N_det_generators_CAS)
|
||||||
|
psi_coef_sorted_gen_CAS(:N_det_generators_CAS, :) = psi_coef_generators_CAS(:N_det_generators_CAS, :)
|
||||||
|
do i=1,inongen_CAS
|
||||||
|
psi_det_sorted_gen_CAS_order(nongen_CAS(i)) = N_det_generators_CAS+i
|
||||||
|
psi_det_sorted_gen_CAS(:,:,N_det_generators_CAS+i) = psi_det_sorted(:,:,nongen_CAS(i))
|
||||||
|
psi_coef_sorted_gen_CAS(N_det_generators_CAS+i, :) = psi_coef_sorted(nongen_CAS(i),:)
|
||||||
|
end do
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
51
src/generators_fluid/generators_hf.irp.f
Normal file
51
src/generators_fluid/generators_hf.irp.f
Normal file
@ -0,0 +1,51 @@
|
|||||||
|
|
||||||
|
use bitmasks
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, N_det_generators_HF ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! For Single reference wave functions, the number of generators is 1 : the
|
||||||
|
! Hartree-Fock determinant
|
||||||
|
END_DOC
|
||||||
|
N_det_generators_HF = 1
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_HF, (N_int,2,psi_det_size) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, psi_coef_generators_HF, (psi_det_size,N_states) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! For Single reference wave functions, the generator is the
|
||||||
|
! Hartree-Fock determinant
|
||||||
|
END_DOC
|
||||||
|
psi_det_generators_HF = 0_bit_kind
|
||||||
|
integer :: i,j
|
||||||
|
integer :: degree
|
||||||
|
|
||||||
|
do i=1,N_int
|
||||||
|
psi_det_generators_HF(i,1,1) = HF_bitmask(i,1)
|
||||||
|
psi_det_generators_HF(i,2,1) = HF_bitmask(i,2)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
do j=1,N_det
|
||||||
|
call get_excitation_degree(HF_bitmask,psi_det(1,1,j),degree,N_int)
|
||||||
|
if (degree == 0) then
|
||||||
|
exit
|
||||||
|
endif
|
||||||
|
end do
|
||||||
|
|
||||||
|
psi_det_generators_HF(:,:,1) = psi_det(:,:,j)
|
||||||
|
psi_coef_generators_HF(1,:) = 1.d0
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer , HF_index ]
|
||||||
|
implicit none
|
||||||
|
integer :: j,degree
|
||||||
|
do j=1,N_det
|
||||||
|
call get_excitation_degree(HF_bitmask,psi_det_sorted(1,1,j),degree,N_int)
|
||||||
|
if (degree == 0) then
|
||||||
|
HF_index = j
|
||||||
|
exit
|
||||||
|
endif
|
||||||
|
end do
|
||||||
|
END_PROVIDER
|
80
src/generators_fluid/generators_hf_sd.irp.f
Normal file
80
src/generators_fluid/generators_hf_sd.irp.f
Normal file
@ -0,0 +1,80 @@
|
|||||||
|
|
||||||
|
use bitmasks
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer, N_det_generators_HF_SD ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! For Single reference wave functions, the number of generators is 1 : the
|
||||||
|
! Hartree-Fock determinant
|
||||||
|
END_DOC
|
||||||
|
N_det_generators_HF_SD = 0
|
||||||
|
integer :: i,degree
|
||||||
|
double precision :: thr
|
||||||
|
double precision :: accu
|
||||||
|
accu = 0.d0
|
||||||
|
thr = threshold_generators
|
||||||
|
do i = 1, N_det
|
||||||
|
call get_excitation_degree(HF_bitmask,psi_det_sorted(1,1,i),degree,N_int)
|
||||||
|
if(degree.le.2.and. accu .le. thr )then
|
||||||
|
accu += psi_coef_sorted(i,1)**2
|
||||||
|
N_det_generators_HF_SD += 1
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
!print*,''
|
||||||
|
!print*,'N_det_generators_HF_SD = ',N_det_generators_HF_SD
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_HF_SD, (N_int,2,psi_det_size) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, psi_coef_generators_HF_SD, (psi_det_size,N_states) ]
|
||||||
|
&BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen_HF_SD, (N_int,2,psi_det_size) ]
|
||||||
|
&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen_HF_SD, (psi_det_size,N_states) ]
|
||||||
|
&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_HF_SD_order, (psi_det_size) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! For Single reference wave functions, the generator is the
|
||||||
|
! Hartree-Fock determinant
|
||||||
|
END_DOC
|
||||||
|
psi_det_generators_HF_SD = 0_bit_kind
|
||||||
|
integer :: i,j,k
|
||||||
|
integer :: degree
|
||||||
|
double precision :: thr
|
||||||
|
double precision :: accu
|
||||||
|
integer, allocatable :: nongen(:)
|
||||||
|
integer :: inongen
|
||||||
|
|
||||||
|
allocate(nongen(N_det))
|
||||||
|
|
||||||
|
thr = threshold_generators
|
||||||
|
|
||||||
|
accu = 0.d0
|
||||||
|
k = 0
|
||||||
|
inongen = 0
|
||||||
|
do j=1,N_det
|
||||||
|
call get_excitation_degree(HF_bitmask,psi_det_sorted(1,1,j),degree,N_int)
|
||||||
|
if(degree.le.2.and. accu.le.thr )then
|
||||||
|
accu += psi_coef_sorted(j,1)**2
|
||||||
|
k += 1
|
||||||
|
psi_det_sorted_gen_HF_SD_order(j) = k
|
||||||
|
do i = 1, N_int
|
||||||
|
psi_det_generators_HF_SD(i,1,k) = psi_det_sorted(i,1,j)
|
||||||
|
psi_det_generators_HF_SD(i,2,k) = psi_det_sorted(i,2,j)
|
||||||
|
enddo
|
||||||
|
do i = 1, N_states
|
||||||
|
psi_coef_generators_HF_SD(k,i) = psi_coef_sorted(j,i)
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
inongen += 1
|
||||||
|
nongen(inongen) = j
|
||||||
|
endif
|
||||||
|
end do
|
||||||
|
|
||||||
|
psi_det_sorted_gen_HF_SD(:,:,:N_det_generators_HF_SD) = psi_det_generators_HF_SD(:,:,:N_det_generators_HF_SD)
|
||||||
|
psi_coef_sorted_gen_HF_SD(:N_det_generators_HF_SD, :) = psi_coef_generators_HF_SD(:N_det_generators_HF_SD, :)
|
||||||
|
do i=1,inongen
|
||||||
|
psi_det_sorted_gen_HF_SD_order(nongen(i)) = N_det_generators_HF_SD+i
|
||||||
|
psi_det_sorted_gen_HF_SD(:,:,N_det_generators_HF_SD+i) = psi_det_sorted(:,:,nongen(i))
|
||||||
|
psi_coef_sorted_gen_HF_SD(N_det_generators_HF_SD+i, :) = psi_coef_sorted(nongen(i),:)
|
||||||
|
end do
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
@ -11,24 +11,3 @@ interface: ezfio,provider,ocaml
|
|||||||
default: 1.e-15
|
default: 1.e-15
|
||||||
ezfio_name: threshold_mo
|
ezfio_name: threshold_mo
|
||||||
|
|
||||||
[no_vvvv_integrals]
|
|
||||||
type: logical
|
|
||||||
doc: If `True`, computes all integrals except for the integrals having 4 virtual indices
|
|
||||||
interface: ezfio,provider,ocaml
|
|
||||||
default: False
|
|
||||||
ezfio_name: no_vvvv_integrals
|
|
||||||
|
|
||||||
[no_ivvv_integrals]
|
|
||||||
type: logical
|
|
||||||
doc: Can be switched on only if `no_vvvv_integrals` is `True`, then does not compute the integrals with 3 virtual indices and 1 belonging to the core inactive active orbitals
|
|
||||||
interface: ezfio,provider,ocaml
|
|
||||||
default: False
|
|
||||||
ezfio_name: no_ivvv_integrals
|
|
||||||
|
|
||||||
[no_vvv_integrals]
|
|
||||||
type: logical
|
|
||||||
doc: Can be switched on only if `no_vvvv_integrals` is `True`, then does not compute the integrals with 3 virtual orbitals
|
|
||||||
interface: ezfio,provider,ocaml
|
|
||||||
default: False
|
|
||||||
ezfio_name: no_vvv_integrals
|
|
||||||
|
|
||||||
|
180
src/mo_two_e_ints/four_idx_novvvv.irp.f
Normal file
180
src/mo_two_e_ints/four_idx_novvvv.irp.f
Normal file
@ -0,0 +1,180 @@
|
|||||||
|
BEGIN_PROVIDER [ logical, no_vvvv_integrals ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! If `True`, computes all integrals except for the integrals having 3 or 4 virtual indices
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
no_vvvv_integrals = .False.
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, mo_coef_novirt, (ao_num,n_core_inact_act_orb) ]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! MO coefficients without virtual MOs
|
||||||
|
END_DOC
|
||||||
|
integer :: j,jj
|
||||||
|
|
||||||
|
do j=1,n_core_inact_act_orb
|
||||||
|
jj = list_core_inact_act(j)
|
||||||
|
mo_coef_novirt(:,j) = mo_coef(:,jj)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
subroutine ao_to_mo_novirt(A_ao,LDA_ao,A_mo,LDA_mo)
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Transform A from the |AO| basis to the |MO| basis excluding virtuals
|
||||||
|
!
|
||||||
|
! $C^\dagger.A_{ao}.C$
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: LDA_ao,LDA_mo
|
||||||
|
double precision, intent(in) :: A_ao(LDA_ao,ao_num)
|
||||||
|
double precision, intent(out) :: A_mo(LDA_mo,n_core_inact_act_orb)
|
||||||
|
double precision, allocatable :: T(:,:)
|
||||||
|
|
||||||
|
allocate ( T(ao_num,n_core_inact_act_orb) )
|
||||||
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
|
||||||
|
|
||||||
|
call dgemm('N','N', ao_num, n_core_inact_act_orb, ao_num, &
|
||||||
|
1.d0, A_ao,LDA_ao, &
|
||||||
|
mo_coef_novirt, size(mo_coef_novirt,1), &
|
||||||
|
0.d0, T, size(T,1))
|
||||||
|
|
||||||
|
call dgemm('T','N', n_core_inact_act_orb, n_core_inact_act_orb, ao_num,&
|
||||||
|
1.d0, mo_coef_novirt,size(mo_coef_novirt,1), &
|
||||||
|
T, ao_num, &
|
||||||
|
0.d0, A_mo, size(A_mo,1))
|
||||||
|
|
||||||
|
deallocate(T)
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine four_idx_novvvv
|
||||||
|
use map_module
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Retransform MO integrals for next CAS-SCF step
|
||||||
|
END_DOC
|
||||||
|
integer :: i,j,k,l,n_integrals
|
||||||
|
double precision, allocatable :: f(:,:,:), f2(:,:,:), d(:,:), T(:,:,:,:), T2(:,:,:,:)
|
||||||
|
double precision, external :: get_ao_two_e_integral
|
||||||
|
integer(key_kind), allocatable :: idx(:)
|
||||||
|
real(integral_kind), allocatable :: values(:)
|
||||||
|
|
||||||
|
integer :: p,q,r,s
|
||||||
|
double precision :: c
|
||||||
|
allocate( T(n_core_inact_act_orb,n_core_inact_act_orb,ao_num,ao_num) , &
|
||||||
|
T2(n_core_inact_act_orb,n_core_inact_act_orb,ao_num,ao_num) )
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT(NONE) &
|
||||||
|
!$OMP SHARED(mo_num,ao_num,T,n_core_inact_act_orb, mo_coef_transp, &
|
||||||
|
!$OMP mo_integrals_threshold,mo_coef,mo_integrals_map, &
|
||||||
|
!$OMP list_core_inact_act,T2,ao_integrals_map) &
|
||||||
|
!$OMP PRIVATE(i,j,k,l,p,q,r,s,idx,values,n_integrals, &
|
||||||
|
!$OMP f,f2,d,c)
|
||||||
|
allocate(f(ao_num,ao_num,ao_num), f2(ao_num,ao_num,ao_num), d(mo_num,mo_num), &
|
||||||
|
idx(mo_num*mo_num), values(mo_num*mo_num) )
|
||||||
|
|
||||||
|
! <aa|vv>
|
||||||
|
!$OMP DO
|
||||||
|
do s=1,ao_num
|
||||||
|
do r=1,ao_num
|
||||||
|
do q=1,ao_num
|
||||||
|
do p=1,r
|
||||||
|
f (p,q,r) = get_ao_two_e_integral(p,q,r,s,ao_integrals_map)
|
||||||
|
f (r,q,p) = f(p,q,r)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
do r=1,ao_num
|
||||||
|
do q=1,ao_num
|
||||||
|
do p=1,ao_num
|
||||||
|
f2(p,q,r) = f(p,r,q)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
! f (p,q,r) = <pq|rs>
|
||||||
|
! f2(p,q,r) = <pr|qs>
|
||||||
|
|
||||||
|
do r=1,ao_num
|
||||||
|
call ao_to_mo_novirt(f (1,1,r),size(f ,1),T (1,1,r,s),size(T,1))
|
||||||
|
call ao_to_mo_novirt(f2(1,1,r),size(f2,1),T2(1,1,r,s),size(T,1))
|
||||||
|
enddo
|
||||||
|
! T (i,j,p,q) = <ij|rs>
|
||||||
|
! T2(i,j,p,q) = <ir|js>
|
||||||
|
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
|
||||||
|
!$OMP DO
|
||||||
|
do j=1,n_core_inact_act_orb
|
||||||
|
do i=1,n_core_inact_act_orb
|
||||||
|
do s=1,ao_num
|
||||||
|
do r=1,ao_num
|
||||||
|
f (r,s,1) = T (i,j,r,s)
|
||||||
|
f2(r,s,1) = T2(i,j,r,s)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
call ao_to_mo(f ,size(f ,1),d,size(d,1))
|
||||||
|
n_integrals = 0
|
||||||
|
do l=1,mo_num
|
||||||
|
do k=1,mo_num
|
||||||
|
n_integrals+=1
|
||||||
|
call two_e_integrals_index(list_core_inact_act(i),list_core_inact_act(j),k,l,idx(n_integrals))
|
||||||
|
values(n_integrals) = d(k,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
call map_append(mo_integrals_map, idx, values, n_integrals)
|
||||||
|
|
||||||
|
call ao_to_mo(f2,size(f2,1),d,size(d,1))
|
||||||
|
n_integrals = 0
|
||||||
|
do l=1,mo_num
|
||||||
|
do k=1,mo_num
|
||||||
|
n_integrals+=1
|
||||||
|
call two_e_integrals_index(list_core_inact_act(i),k,list_core_inact_act(j),l,idx(n_integrals))
|
||||||
|
values(n_integrals) = d(k,l)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
call map_append(mo_integrals_map, idx, values, n_integrals)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
deallocate(f,f2,d,idx,values)
|
||||||
|
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
deallocate(T,T2)
|
||||||
|
|
||||||
|
|
||||||
|
call map_sort(mo_integrals_map)
|
||||||
|
call map_unique(mo_integrals_map)
|
||||||
|
call map_shrink(mo_integrals_map,real(mo_integrals_threshold,integral_kind))
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine four_idx_novvvv2
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
integer :: i
|
||||||
|
integer(bit_kind) :: mask_ijkl(N_int,4)
|
||||||
|
|
||||||
|
print*, '<ix|ix>'
|
||||||
|
do i = 1,N_int
|
||||||
|
mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
|
||||||
|
mask_ijkl(i,2) = full_ijkl_bitmask_4(i,1)
|
||||||
|
mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1)
|
||||||
|
mask_ijkl(i,4) = full_ijkl_bitmask_4(i,1)
|
||||||
|
enddo
|
||||||
|
call add_integrals_to_map(mask_ijkl)
|
||||||
|
|
||||||
|
print*, '<ii|vv>'
|
||||||
|
do i = 1,N_int
|
||||||
|
mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
|
||||||
|
mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1)
|
||||||
|
mask_ijkl(i,3) = virt_bitmask(i,1)
|
||||||
|
mask_ijkl(i,4) = virt_bitmask(i,1)
|
||||||
|
enddo
|
||||||
|
call add_integrals_to_map(mask_ijkl)
|
||||||
|
|
||||||
|
end
|
@ -22,16 +22,13 @@ end
|
|||||||
BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ]
|
BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ]
|
||||||
use map_module
|
use map_module
|
||||||
implicit none
|
implicit none
|
||||||
integer(bit_kind) :: mask_ijkl(N_int,4)
|
|
||||||
integer(bit_kind) :: mask_ijk(N_int,3)
|
|
||||||
|
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! If True, the map of MO two-electron integrals is provided
|
! If True, the map of MO two-electron integrals is provided
|
||||||
END_DOC
|
END_DOC
|
||||||
|
integer(bit_kind) :: mask_ijkl(N_int,4)
|
||||||
|
integer(bit_kind) :: mask_ijk(N_int,3)
|
||||||
|
double precision :: cpu_1, cpu_2, wall_1, wall_2
|
||||||
|
|
||||||
! The following line avoids a subsequent crash when the memory used is more
|
|
||||||
! than half of the virtual memory, due to a fork in zcat when reading arrays
|
|
||||||
! with EZFIO
|
|
||||||
PROVIDE mo_class
|
PROVIDE mo_class
|
||||||
|
|
||||||
mo_two_e_integrals_in_map = .True.
|
mo_two_e_integrals_in_map = .True.
|
||||||
@ -49,106 +46,28 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ]
|
|||||||
print *, '---------------------------------'
|
print *, '---------------------------------'
|
||||||
print *, ''
|
print *, ''
|
||||||
|
|
||||||
|
call wall_time(wall_1)
|
||||||
|
call cpu_time(cpu_1)
|
||||||
|
|
||||||
if(no_vvvv_integrals)then
|
if(no_vvvv_integrals)then
|
||||||
integer :: i,j,k,l
|
call four_idx_novvvv
|
||||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!!
|
|
||||||
! (core+inact+act) ^ 4
|
|
||||||
! <ii|ii>
|
|
||||||
print*, ''
|
|
||||||
print*, '<ii|ii>'
|
|
||||||
do i = 1,N_int
|
|
||||||
mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
|
|
||||||
mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1)
|
|
||||||
mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1)
|
|
||||||
mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1)
|
|
||||||
enddo
|
|
||||||
call add_integrals_to_map(mask_ijkl)
|
|
||||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!!
|
|
||||||
! (core+inact+act) ^ 2 (virt) ^2
|
|
||||||
! <iv|iv> = J_iv
|
|
||||||
print*, ''
|
|
||||||
print*, '<iv|iv>'
|
|
||||||
do i = 1,N_int
|
|
||||||
mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
|
|
||||||
mask_ijkl(i,2) = virt_bitmask(i,1)
|
|
||||||
mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1)
|
|
||||||
mask_ijkl(i,4) = virt_bitmask(i,1)
|
|
||||||
enddo
|
|
||||||
call add_integrals_to_map(mask_ijkl)
|
|
||||||
|
|
||||||
! (core+inact+act) ^ 2 (virt) ^2
|
|
||||||
! <ii|vv> = (iv|iv)
|
|
||||||
print*, ''
|
|
||||||
print*, '<ii|vv>'
|
|
||||||
do i = 1,N_int
|
|
||||||
mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
|
|
||||||
mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1)
|
|
||||||
mask_ijkl(i,3) = virt_bitmask(i,1)
|
|
||||||
mask_ijkl(i,4) = virt_bitmask(i,1)
|
|
||||||
enddo
|
|
||||||
call add_integrals_to_map(mask_ijkl)
|
|
||||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
if(.not.no_vvv_integrals)then
|
|
||||||
print*, ''
|
|
||||||
print*, '<rv|sv> and <rv|vs>'
|
|
||||||
do i = 1,N_int
|
|
||||||
mask_ijk(i,1) = virt_bitmask(i,1)
|
|
||||||
mask_ijk(i,2) = virt_bitmask(i,1)
|
|
||||||
mask_ijk(i,3) = virt_bitmask(i,1)
|
|
||||||
enddo
|
|
||||||
call add_integrals_to_map_three_indices(mask_ijk)
|
|
||||||
endif
|
|
||||||
|
|
||||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!!
|
|
||||||
! (core+inact+act) ^ 3 (virt) ^1
|
|
||||||
! <iv|ii>
|
|
||||||
print*, ''
|
|
||||||
print*, '<iv|ii>'
|
|
||||||
do i = 1,N_int
|
|
||||||
mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
|
|
||||||
mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1)
|
|
||||||
mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1)
|
|
||||||
mask_ijkl(i,4) = virt_bitmask(i,1)
|
|
||||||
enddo
|
|
||||||
call add_integrals_to_map(mask_ijkl)
|
|
||||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!!
|
|
||||||
! (core+inact+act) ^ 1 (virt) ^3
|
|
||||||
! <iv|vv>
|
|
||||||
if(.not.no_ivvv_integrals)then
|
|
||||||
print*, ''
|
|
||||||
print*, '<iv|vv>'
|
|
||||||
do i = 1,N_int
|
|
||||||
mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
|
|
||||||
mask_ijkl(i,2) = virt_bitmask(i,1)
|
|
||||||
mask_ijkl(i,3) = virt_bitmask(i,1)
|
|
||||||
mask_ijkl(i,4) = virt_bitmask(i,1)
|
|
||||||
enddo
|
|
||||||
call add_integrals_to_map_no_exit_34(mask_ijkl)
|
|
||||||
endif
|
|
||||||
|
|
||||||
else
|
else
|
||||||
call add_integrals_to_map(full_ijkl_bitmask_4)
|
call add_integrals_to_map(full_ijkl_bitmask_4)
|
||||||
|
endif
|
||||||
|
|
||||||
! call four_index_transform_zmq(ao_integrals_map,mo_integrals_map, &
|
call wall_time(wall_2)
|
||||||
! mo_coef, size(mo_coef,1), &
|
call cpu_time(cpu_2)
|
||||||
! 1, 1, 1, 1, ao_num, ao_num, ao_num, ao_num, &
|
|
||||||
! 1, 1, 1, 1, mo_num, mo_num, mo_num, mo_num)
|
|
||||||
!
|
|
||||||
! call four_index_transform_block(ao_integrals_map,mo_integrals_map, &
|
|
||||||
! mo_coef, size(mo_coef,1), &
|
|
||||||
! 1, 1, 1, 1, ao_num, ao_num, ao_num, ao_num, &
|
|
||||||
! 1, 1, 1, 1, mo_num, mo_num, mo_num, mo_num)
|
|
||||||
!
|
|
||||||
! call four_index_transform(ao_integrals_map,mo_integrals_map, &
|
|
||||||
! mo_coef, size(mo_coef,1), &
|
|
||||||
! 1, 1, 1, 1, ao_num, ao_num, ao_num, ao_num, &
|
|
||||||
! 1, 1, 1, 1, mo_num, mo_num, mo_num, mo_num)
|
|
||||||
|
|
||||||
integer*8 :: get_mo_map_size, mo_map_size
|
integer*8 :: get_mo_map_size, mo_map_size
|
||||||
mo_map_size = get_mo_map_size()
|
mo_map_size = get_mo_map_size()
|
||||||
|
|
||||||
print*,'Molecular integrals provided'
|
double precision, external :: map_mb
|
||||||
endif
|
print*,'Molecular integrals provided:'
|
||||||
|
print*,' Size of MO map ', map_mb(mo_integrals_map) ,'MB'
|
||||||
|
print*,' Number of MO integrals: ', mo_map_size
|
||||||
|
print*,' cpu time :',cpu_2 - cpu_1, 's'
|
||||||
|
print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')'
|
||||||
|
|
||||||
if (write_mo_two_e_integrals.and.mpi_master) then
|
if (write_mo_two_e_integrals.and.mpi_master) then
|
||||||
call ezfio_set_work_empty(.False.)
|
call ezfio_set_work_empty(.False.)
|
||||||
call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map)
|
call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map)
|
||||||
@ -185,7 +104,7 @@ subroutine add_integrals_to_map(mask_ijkl)
|
|||||||
integer :: size_buffer
|
integer :: size_buffer
|
||||||
integer(key_kind),allocatable :: buffer_i(:)
|
integer(key_kind),allocatable :: buffer_i(:)
|
||||||
real(integral_kind),allocatable :: buffer_value(:)
|
real(integral_kind),allocatable :: buffer_value(:)
|
||||||
double precision :: map_mb
|
double precision, external :: map_mb
|
||||||
|
|
||||||
integer :: i1,j1,k1,l1, ii1, kmax, thread_num
|
integer :: i1,j1,k1,l1, ii1, kmax, thread_num
|
||||||
integer :: i2,i3,i4
|
integer :: i2,i3,i4
|
||||||
@ -201,10 +120,6 @@ subroutine add_integrals_to_map(mask_ijkl)
|
|||||||
call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int )
|
call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int )
|
||||||
call bitstring_to_list( mask_ijkl(1,3), list_ijkl(1,3), n_k, N_int )
|
call bitstring_to_list( mask_ijkl(1,3), list_ijkl(1,3), n_k, N_int )
|
||||||
call bitstring_to_list( mask_ijkl(1,4), list_ijkl(1,4), n_l, N_int )
|
call bitstring_to_list( mask_ijkl(1,4), list_ijkl(1,4), n_l, N_int )
|
||||||
character*(2048) :: output(1)
|
|
||||||
print *, 'i'
|
|
||||||
call bitstring_to_str( output(1), mask_ijkl(1,1), N_int )
|
|
||||||
print *, trim(output(1))
|
|
||||||
j = 0
|
j = 0
|
||||||
do i = 1, N_int
|
do i = 1, N_int
|
||||||
j += popcnt(mask_ijkl(i,1))
|
j += popcnt(mask_ijkl(i,1))
|
||||||
@ -213,9 +128,6 @@ subroutine add_integrals_to_map(mask_ijkl)
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
print*, 'j'
|
|
||||||
call bitstring_to_str( output(1), mask_ijkl(1,2), N_int )
|
|
||||||
print *, trim(output(1))
|
|
||||||
j = 0
|
j = 0
|
||||||
do i = 1, N_int
|
do i = 1, N_int
|
||||||
j += popcnt(mask_ijkl(i,2))
|
j += popcnt(mask_ijkl(i,2))
|
||||||
@ -224,9 +136,6 @@ subroutine add_integrals_to_map(mask_ijkl)
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
print*, 'k'
|
|
||||||
call bitstring_to_str( output(1), mask_ijkl(1,3), N_int )
|
|
||||||
print *, trim(output(1))
|
|
||||||
j = 0
|
j = 0
|
||||||
do i = 1, N_int
|
do i = 1, N_int
|
||||||
j += popcnt(mask_ijkl(i,3))
|
j += popcnt(mask_ijkl(i,3))
|
||||||
@ -235,9 +144,6 @@ subroutine add_integrals_to_map(mask_ijkl)
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
print*, 'l'
|
|
||||||
call bitstring_to_str( output(1), mask_ijkl(1,4), N_int )
|
|
||||||
print *, trim(output(1))
|
|
||||||
j = 0
|
j = 0
|
||||||
do i = 1, N_int
|
do i = 1, N_int
|
||||||
j += popcnt(mask_ijkl(i,4))
|
j += popcnt(mask_ijkl(i,4))
|
||||||
@ -247,14 +153,12 @@ subroutine add_integrals_to_map(mask_ijkl)
|
|||||||
endif
|
endif
|
||||||
|
|
||||||
size_buffer = min(ao_num*ao_num*ao_num,16000000)
|
size_buffer = min(ao_num*ao_num*ao_num,16000000)
|
||||||
print*, 'Providing the molecular integrals '
|
|
||||||
print*, 'Buffers : ', 8.*(mo_num*(n_j)*(n_k+1) + mo_num+&
|
print*, 'Buffers : ', 8.*(mo_num*(n_j)*(n_k+1) + mo_num+&
|
||||||
ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core'
|
ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core'
|
||||||
|
|
||||||
call wall_time(wall_1)
|
|
||||||
call cpu_time(cpu_1)
|
|
||||||
double precision :: accu_bis
|
double precision :: accu_bis
|
||||||
accu_bis = 0.d0
|
accu_bis = 0.d0
|
||||||
|
call wall_time(wall_1)
|
||||||
|
|
||||||
!$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, &
|
!$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, &
|
||||||
!$OMP two_e_tmp_0_idx, two_e_tmp_0, two_e_tmp_1,two_e_tmp_2,two_e_tmp_3,&
|
!$OMP two_e_tmp_0_idx, two_e_tmp_0, two_e_tmp_1,two_e_tmp_2,two_e_tmp_3,&
|
||||||
@ -452,12 +356,6 @@ subroutine add_integrals_to_map(mask_ijkl)
|
|||||||
deallocate(list_ijkl)
|
deallocate(list_ijkl)
|
||||||
|
|
||||||
|
|
||||||
print*,'Molecular integrals provided:'
|
|
||||||
print*,' Size of MO map ', map_mb(mo_integrals_map) ,'MB'
|
|
||||||
print*,' Number of MO integrals: ', mo_map_size
|
|
||||||
print*,' cpu time :',cpu_2 - cpu_1, 's'
|
|
||||||
print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')'
|
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
@ -504,10 +402,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk)
|
|||||||
call bitstring_to_list( mask_ijk(1,1), list_ijkl(1,1), n_i, N_int )
|
call bitstring_to_list( mask_ijk(1,1), list_ijkl(1,1), n_i, N_int )
|
||||||
call bitstring_to_list( mask_ijk(1,2), list_ijkl(1,2), n_j, N_int )
|
call bitstring_to_list( mask_ijk(1,2), list_ijkl(1,2), n_j, N_int )
|
||||||
call bitstring_to_list( mask_ijk(1,3), list_ijkl(1,3), n_k, N_int )
|
call bitstring_to_list( mask_ijk(1,3), list_ijkl(1,3), n_k, N_int )
|
||||||
character*(2048) :: output(1)
|
|
||||||
print*, 'i'
|
|
||||||
call bitstring_to_str( output(1), mask_ijk(1,1), N_int )
|
|
||||||
print *, trim(output(1))
|
|
||||||
j = 0
|
j = 0
|
||||||
do i = 1, N_int
|
do i = 1, N_int
|
||||||
j += popcnt(mask_ijk(i,1))
|
j += popcnt(mask_ijk(i,1))
|
||||||
@ -516,9 +410,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk)
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
print*, 'j'
|
|
||||||
call bitstring_to_str( output(1), mask_ijk(1,2), N_int )
|
|
||||||
print *, trim(output(1))
|
|
||||||
j = 0
|
j = 0
|
||||||
do i = 1, N_int
|
do i = 1, N_int
|
||||||
j += popcnt(mask_ijk(i,2))
|
j += popcnt(mask_ijk(i,2))
|
||||||
@ -527,9 +418,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk)
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
print*, 'k'
|
|
||||||
call bitstring_to_str( output(1), mask_ijk(1,3), N_int )
|
|
||||||
print *, trim(output(1))
|
|
||||||
j = 0
|
j = 0
|
||||||
do i = 1, N_int
|
do i = 1, N_int
|
||||||
j += popcnt(mask_ijk(i,3))
|
j += popcnt(mask_ijk(i,3))
|
||||||
|
@ -50,7 +50,58 @@ BEGIN_PROVIDER [ double precision, slater_bragg_radii, (0:100)]
|
|||||||
slater_bragg_radii(33) = 1.15d0
|
slater_bragg_radii(33) = 1.15d0
|
||||||
slater_bragg_radii(34) = 1.15d0
|
slater_bragg_radii(34) = 1.15d0
|
||||||
slater_bragg_radii(35) = 1.15d0
|
slater_bragg_radii(35) = 1.15d0
|
||||||
slater_bragg_radii(36) = 1.15d0
|
slater_bragg_radii(36) = 1.10d0
|
||||||
|
|
||||||
|
slater_bragg_radii(37) = 2.35d0
|
||||||
|
slater_bragg_radii(38) = 2.00d0
|
||||||
|
slater_bragg_radii(39) = 1.80d0
|
||||||
|
slater_bragg_radii(40) = 1.55d0
|
||||||
|
slater_bragg_radii(41) = 1.45d0
|
||||||
|
slater_bragg_radii(42) = 1.45d0
|
||||||
|
slater_bragg_radii(43) = 1.35d0
|
||||||
|
slater_bragg_radii(44) = 1.30d0
|
||||||
|
slater_bragg_radii(45) = 1.35d0
|
||||||
|
slater_bragg_radii(46) = 1.40d0
|
||||||
|
slater_bragg_radii(47) = 1.60d0
|
||||||
|
slater_bragg_radii(48) = 1.55d0
|
||||||
|
slater_bragg_radii(49) = 1.55d0
|
||||||
|
slater_bragg_radii(50) = 1.45d0
|
||||||
|
slater_bragg_radii(51) = 1.45d0
|
||||||
|
slater_bragg_radii(52) = 1.40d0
|
||||||
|
slater_bragg_radii(53) = 1.40d0
|
||||||
|
slater_bragg_radii(54) = 1.40d0
|
||||||
|
slater_bragg_radii(55) = 2.60d0
|
||||||
|
slater_bragg_radii(56) = 2.15d0
|
||||||
|
slater_bragg_radii(57) = 1.95d0
|
||||||
|
slater_bragg_radii(58) = 1.85d0
|
||||||
|
slater_bragg_radii(59) = 1.85d0
|
||||||
|
slater_bragg_radii(60) = 1.85d0
|
||||||
|
slater_bragg_radii(61) = 1.85d0
|
||||||
|
slater_bragg_radii(62) = 1.85d0
|
||||||
|
slater_bragg_radii(63) = 1.85d0
|
||||||
|
slater_bragg_radii(64) = 1.80d0
|
||||||
|
slater_bragg_radii(65) = 1.75d0
|
||||||
|
slater_bragg_radii(66) = 1.75d0
|
||||||
|
slater_bragg_radii(67) = 1.75d0
|
||||||
|
slater_bragg_radii(68) = 1.75d0
|
||||||
|
slater_bragg_radii(69) = 1.75d0
|
||||||
|
slater_bragg_radii(70) = 1.75d0
|
||||||
|
slater_bragg_radii(71) = 1.75d0
|
||||||
|
slater_bragg_radii(72) = 1.55d0
|
||||||
|
slater_bragg_radii(73) = 1.45d0
|
||||||
|
slater_bragg_radii(74) = 1.35d0
|
||||||
|
slater_bragg_radii(75) = 1.30d0
|
||||||
|
slater_bragg_radii(76) = 1.30d0
|
||||||
|
slater_bragg_radii(77) = 1.35d0
|
||||||
|
slater_bragg_radii(78) = 1.35d0
|
||||||
|
slater_bragg_radii(79) = 1.35d0
|
||||||
|
slater_bragg_radii(80) = 1.50d0
|
||||||
|
slater_bragg_radii(81) = 1.90d0
|
||||||
|
slater_bragg_radii(82) = 1.75d0
|
||||||
|
slater_bragg_radii(83) = 1.60d0
|
||||||
|
slater_bragg_radii(84) = 1.90d0
|
||||||
|
slater_bragg_radii(85) = 1.50d0
|
||||||
|
slater_bragg_radii(86) = 1.50d0
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
@ -38,22 +38,6 @@ END_PROVIDER
|
|||||||
END_DOC
|
END_DOC
|
||||||
integer :: i,k
|
integer :: i,k
|
||||||
|
|
||||||
! if (threshold_selectors == 1.d0) then
|
|
||||||
!
|
|
||||||
! do i=1,N_det_selectors
|
|
||||||
! do k=1,N_int
|
|
||||||
! psi_selectors(k,1,i) = psi_det(k,1,i)
|
|
||||||
! psi_selectors(k,2,i) = psi_det(k,2,i)
|
|
||||||
! enddo
|
|
||||||
! enddo
|
|
||||||
! do k=1,N_states
|
|
||||||
! do i=1,N_det_selectors
|
|
||||||
! psi_selectors_coef(i,k) = psi_coef(i,k)
|
|
||||||
! enddo
|
|
||||||
! enddo
|
|
||||||
!
|
|
||||||
! else
|
|
||||||
|
|
||||||
do i=1,N_det_selectors
|
do i=1,N_det_selectors
|
||||||
do k=1,N_int
|
do k=1,N_int
|
||||||
psi_selectors(k,1,i) = psi_det_sorted(k,1,i)
|
psi_selectors(k,1,i) = psi_det_sorted(k,1,i)
|
||||||
@ -66,7 +50,6 @@ END_PROVIDER
|
|||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! endif
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
@ -51,7 +51,7 @@ subroutine routine
|
|||||||
if(degree == 0)then
|
if(degree == 0)then
|
||||||
print*,'Reference determinant '
|
print*,'Reference determinant '
|
||||||
call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,h00)
|
call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,h00)
|
||||||
else
|
else if(degree .le. 2)then
|
||||||
call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hii)
|
call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hii)
|
||||||
call i_H_j(psi_det(1,1,1),psi_det(1,1,i),N_int,hij)
|
call i_H_j(psi_det(1,1,1),psi_det(1,1,i),N_int,hij)
|
||||||
delta_e = hii - h00
|
delta_e = hii - h00
|
||||||
|
1
src/two_body_rdm/NEED
Normal file
1
src/two_body_rdm/NEED
Normal file
@ -0,0 +1 @@
|
|||||||
|
davidson_undressed
|
8
src/two_body_rdm/README.rst
Normal file
8
src/two_body_rdm/README.rst
Normal file
@ -0,0 +1,8 @@
|
|||||||
|
============
|
||||||
|
two_body_rdm
|
||||||
|
============
|
||||||
|
|
||||||
|
Contains the two rdms $\alpha\alpha$, $\beta\beta$ and $\alpha\beta$ stored as
|
||||||
|
arrays, with pysicists notation, consistent with the two-electron integrals in the
|
||||||
|
MO basis.
|
||||||
|
|
402
src/two_body_rdm/ab_only_routines.irp.f
Normal file
402
src/two_body_rdm/ab_only_routines.irp.f
Normal file
@ -0,0 +1,402 @@
|
|||||||
|
|
||||||
|
subroutine two_rdm_ab_nstates(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes the alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS
|
||||||
|
!
|
||||||
|
! Assumes that the determinants are in psi_det
|
||||||
|
!
|
||||||
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: u_0(sze,N_st)
|
||||||
|
integer :: k
|
||||||
|
double precision, allocatable :: u_t(:,:)
|
||||||
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
|
||||||
|
allocate(u_t(N_st,N_det))
|
||||||
|
do k=1,N_st
|
||||||
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
||||||
|
enddo
|
||||||
|
call dtranspose( &
|
||||||
|
u_0, &
|
||||||
|
size(u_0, 1), &
|
||||||
|
u_t, &
|
||||||
|
size(u_t, 1), &
|
||||||
|
N_det, N_st)
|
||||||
|
|
||||||
|
call two_rdm_ab_nstates_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1)
|
||||||
|
deallocate(u_t)
|
||||||
|
|
||||||
|
do k=1,N_st
|
||||||
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine two_rdm_ab_nstates_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes the alpha/beta part of the two-body density matrix
|
||||||
|
!
|
||||||
|
! Default should be 1,N_det,0,1
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(in) :: u_t(N_st,N_det)
|
||||||
|
|
||||||
|
|
||||||
|
PROVIDE N_int
|
||||||
|
|
||||||
|
select case (N_int)
|
||||||
|
case (1)
|
||||||
|
call two_rdm_ab_nstates_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (2)
|
||||||
|
call two_rdm_ab_nstates_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (3)
|
||||||
|
call two_rdm_ab_nstates_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (4)
|
||||||
|
call two_rdm_ab_nstates_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case default
|
||||||
|
call two_rdm_ab_nstates_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
end select
|
||||||
|
end
|
||||||
|
BEGIN_TEMPLATE
|
||||||
|
|
||||||
|
subroutine two_rdm_ab_nstates_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(in) :: u_t(N_st,N_det)
|
||||||
|
|
||||||
|
double precision :: hij, sij
|
||||||
|
integer :: i,j,k,l
|
||||||
|
integer :: k_a, k_b, l_a, l_b, m_a, m_b
|
||||||
|
integer :: istate
|
||||||
|
integer :: krow, kcol, krow_b, kcol_b
|
||||||
|
integer :: lrow, lcol
|
||||||
|
integer :: mrow, mcol
|
||||||
|
integer(bit_kind) :: spindet($N_int)
|
||||||
|
integer(bit_kind) :: tmp_det($N_int,2)
|
||||||
|
integer(bit_kind) :: tmp_det2($N_int,2)
|
||||||
|
integer(bit_kind) :: tmp_det3($N_int,2)
|
||||||
|
integer(bit_kind), allocatable :: buffer(:,:)
|
||||||
|
integer :: n_doubles
|
||||||
|
integer, allocatable :: doubles(:)
|
||||||
|
integer, allocatable :: singles_a(:)
|
||||||
|
integer, allocatable :: singles_b(:)
|
||||||
|
integer, allocatable :: idx(:), idx0(:)
|
||||||
|
integer :: maxab, n_singles_a, n_singles_b, kcol_prev, nmax
|
||||||
|
integer*8 :: k8
|
||||||
|
|
||||||
|
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
|
||||||
|
allocate(idx0(maxab))
|
||||||
|
|
||||||
|
do i=1,maxab
|
||||||
|
idx0(i) = i
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Prepare the array of all alpha single excitations
|
||||||
|
! -------------------------------------------------
|
||||||
|
|
||||||
|
PROVIDE N_int nthreads_davidson
|
||||||
|
|
||||||
|
! Alpha/Beta double excitations
|
||||||
|
! =============================
|
||||||
|
|
||||||
|
allocate( buffer($N_int,maxab), &
|
||||||
|
singles_a(maxab), &
|
||||||
|
singles_b(maxab), &
|
||||||
|
doubles(maxab), &
|
||||||
|
idx(maxab))
|
||||||
|
|
||||||
|
kcol_prev=-1
|
||||||
|
|
||||||
|
ASSERT (iend <= N_det)
|
||||||
|
ASSERT (istart > 0)
|
||||||
|
ASSERT (istep > 0)
|
||||||
|
|
||||||
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
if (kcol /= kcol_prev) then
|
||||||
|
call get_all_spin_singles_$N_int( &
|
||||||
|
psi_det_beta_unique, idx0, &
|
||||||
|
tmp_det(1,2), N_det_beta_unique, &
|
||||||
|
singles_b, n_singles_b)
|
||||||
|
endif
|
||||||
|
kcol_prev = kcol
|
||||||
|
|
||||||
|
! Loop over singly excited beta columns
|
||||||
|
! -------------------------------------
|
||||||
|
|
||||||
|
do i=1,n_singles_b
|
||||||
|
lcol = singles_b(i)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
|
||||||
|
|
||||||
|
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
idx(j) = l_a
|
||||||
|
l_a = l_a+1
|
||||||
|
enddo
|
||||||
|
j = j-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_$N_int( &
|
||||||
|
buffer, idx, tmp_det(1,1), j, &
|
||||||
|
singles_a, n_singles_a )
|
||||||
|
|
||||||
|
! Loop over alpha singles
|
||||||
|
! -----------------------
|
||||||
|
|
||||||
|
do k = 1,n_singles_a
|
||||||
|
l_a = singles_a(k)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
!!!!!!!!!!!!!!!!!! ALPHA BETA
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
|
|
||||||
|
! Single and double alpha excitations
|
||||||
|
! ===================================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
! Initial determinant is at k_b in beta-major representation
|
||||||
|
! ----------------------------------------------------------------------
|
||||||
|
|
||||||
|
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||||
|
|
||||||
|
spindet(1:$N_int) = tmp_det(1:$N_int,1)
|
||||||
|
|
||||||
|
! Loop inside the beta column to gather all the connected alphas
|
||||||
|
lcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||||
|
do i=1,N_det_alpha_unique
|
||||||
|
if (l_a > N_det) exit
|
||||||
|
lcol = psi_bilinear_matrix_columns(l_a)
|
||||||
|
if (lcol /= kcol) exit
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
idx(i) = l_a
|
||||||
|
l_a = l_a+1
|
||||||
|
enddo
|
||||||
|
i = i-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_and_doubles_$N_int( &
|
||||||
|
buffer, idx, spindet, i, &
|
||||||
|
singles_a, doubles, n_singles_a, n_doubles )
|
||||||
|
|
||||||
|
! Compute Hij for all alpha singles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
do i=1,n_singles_a
|
||||||
|
l_a = singles_a(i)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
!!!! MONO SPIN
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
!! Compute Hij for all alpha doubles
|
||||||
|
!! ----------------------------------
|
||||||
|
!
|
||||||
|
!do i=1,n_doubles
|
||||||
|
! l_a = doubles(i)
|
||||||
|
! ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
! lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
! ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
! call i_H_j_double_spin_erf( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij)
|
||||||
|
! do l=1,N_st
|
||||||
|
! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
|
||||||
|
! ! same spin => sij = 0
|
||||||
|
! enddo
|
||||||
|
!enddo
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
! Single and double beta excitations
|
||||||
|
! ==================================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
spindet(1:$N_int) = tmp_det(1:$N_int,2)
|
||||||
|
|
||||||
|
! Initial determinant is at k_b in beta-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||||
|
|
||||||
|
! Loop inside the alpha row to gather all the connected betas
|
||||||
|
lrow = psi_bilinear_matrix_transp_rows(k_b)
|
||||||
|
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
|
||||||
|
do i=1,N_det_beta_unique
|
||||||
|
if (l_b > N_det) exit
|
||||||
|
lrow = psi_bilinear_matrix_transp_rows(l_b)
|
||||||
|
if (lrow /= krow) exit
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
|
||||||
|
idx(i) = l_b
|
||||||
|
l_b = l_b+1
|
||||||
|
enddo
|
||||||
|
i = i-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_and_doubles_$N_int( &
|
||||||
|
buffer, idx, spindet, i, &
|
||||||
|
singles_b, doubles, n_singles_b, n_doubles )
|
||||||
|
|
||||||
|
! Compute Hij for all beta singles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
do i=1,n_singles_b
|
||||||
|
l_b = singles_b(i)
|
||||||
|
ASSERT (l_b <= N_det)
|
||||||
|
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
|
||||||
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
enddo
|
||||||
|
!
|
||||||
|
!! Compute Hij for all beta doubles
|
||||||
|
!! ----------------------------------
|
||||||
|
!
|
||||||
|
!do i=1,n_doubles
|
||||||
|
! l_b = doubles(i)
|
||||||
|
! ASSERT (l_b <= N_det)
|
||||||
|
|
||||||
|
! lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
! ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
! call i_H_j_double_spin_erf( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij)
|
||||||
|
! l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
|
! ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
! do l=1,N_st
|
||||||
|
! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a)
|
||||||
|
! ! same spin => sij = 0
|
||||||
|
! enddo
|
||||||
|
!enddo
|
||||||
|
|
||||||
|
|
||||||
|
! Diagonal contribution
|
||||||
|
! =====================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
double precision, external :: diag_H_mat_elem_erf, diag_S_mat_elem
|
||||||
|
double precision :: c_1(N_states),c_2(N_states)
|
||||||
|
do l = 1, N_states
|
||||||
|
c_1(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call diagonal_contrib_to_two_rdm_ab_dm(tmp_det,c_1,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
|
||||||
|
end do
|
||||||
|
deallocate(buffer, singles_a, singles_b, doubles, idx)
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
SUBST [ N_int ]
|
||||||
|
|
||||||
|
1;;
|
||||||
|
2;;
|
||||||
|
3;;
|
||||||
|
4;;
|
||||||
|
N_int;;
|
||||||
|
|
||||||
|
END_TEMPLATE
|
442
src/two_body_rdm/all_2rdm_routines.irp.f
Normal file
442
src/two_body_rdm/all_2rdm_routines.irp.f
Normal file
@ -0,0 +1,442 @@
|
|||||||
|
subroutine all_two_rdm_dm_nstates(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes the alpha/alpha, beta/beta and alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS
|
||||||
|
!
|
||||||
|
! Assumes that the determinants are in psi_det
|
||||||
|
!
|
||||||
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: u_0(sze,N_st)
|
||||||
|
integer :: k
|
||||||
|
double precision, allocatable :: u_t(:,:)
|
||||||
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
|
||||||
|
allocate(u_t(N_st,N_det))
|
||||||
|
do k=1,N_st
|
||||||
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
||||||
|
enddo
|
||||||
|
call dtranspose( &
|
||||||
|
u_0, &
|
||||||
|
size(u_0, 1), &
|
||||||
|
u_t, &
|
||||||
|
size(u_t, 1), &
|
||||||
|
N_det, N_st)
|
||||||
|
|
||||||
|
call all_two_rdm_dm_nstates_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1)
|
||||||
|
deallocate(u_t)
|
||||||
|
|
||||||
|
do k=1,N_st
|
||||||
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine all_two_rdm_dm_nstates_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes two-rdm
|
||||||
|
!
|
||||||
|
! Default should be 1,N_det,0,1
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(in) :: u_t(N_st,N_det)
|
||||||
|
|
||||||
|
|
||||||
|
PROVIDE N_int
|
||||||
|
|
||||||
|
select case (N_int)
|
||||||
|
case (1)
|
||||||
|
call all_two_rdm_dm_nstates_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (2)
|
||||||
|
call all_two_rdm_dm_nstates_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (3)
|
||||||
|
call all_two_rdm_dm_nstates_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (4)
|
||||||
|
call all_two_rdm_dm_nstates_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case default
|
||||||
|
call all_two_rdm_dm_nstates_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
end select
|
||||||
|
end
|
||||||
|
|
||||||
|
BEGIN_TEMPLATE
|
||||||
|
|
||||||
|
subroutine all_two_rdm_dm_nstates_work_$N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes $v_t = H | u_t \\rangle$ and $s_t = S^2 | u_t \\rangle$
|
||||||
|
!
|
||||||
|
! Default should be 1,N_det,0,1
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
|
double precision, intent(in) :: u_t(N_st,N_det)
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
|
||||||
|
integer :: i,j,k,l
|
||||||
|
integer :: k_a, k_b, l_a, l_b, m_a, m_b
|
||||||
|
integer :: istate
|
||||||
|
integer :: krow, kcol, krow_b, kcol_b
|
||||||
|
integer :: lrow, lcol
|
||||||
|
integer :: mrow, mcol
|
||||||
|
integer(bit_kind) :: spindet($N_int)
|
||||||
|
integer(bit_kind) :: tmp_det($N_int,2)
|
||||||
|
integer(bit_kind) :: tmp_det2($N_int,2)
|
||||||
|
integer(bit_kind) :: tmp_det3($N_int,2)
|
||||||
|
integer(bit_kind), allocatable :: buffer(:,:)
|
||||||
|
integer :: n_doubles
|
||||||
|
integer, allocatable :: doubles(:)
|
||||||
|
integer, allocatable :: singles_a(:)
|
||||||
|
integer, allocatable :: singles_b(:)
|
||||||
|
integer, allocatable :: idx(:), idx0(:)
|
||||||
|
integer :: maxab, n_singles_a, n_singles_b, kcol_prev
|
||||||
|
integer*8 :: k8
|
||||||
|
|
||||||
|
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
|
||||||
|
allocate(idx0(maxab))
|
||||||
|
|
||||||
|
do i=1,maxab
|
||||||
|
idx0(i) = i
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Prepare the array of all alpha single excitations
|
||||||
|
! -------------------------------------------------
|
||||||
|
|
||||||
|
PROVIDE N_int nthreads_davidson
|
||||||
|
!!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
|
||||||
|
! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, &
|
||||||
|
! !$OMP psi_bilinear_matrix_columns, &
|
||||||
|
! !$OMP psi_det_alpha_unique, psi_det_beta_unique,&
|
||||||
|
! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
|
||||||
|
! !$OMP psi_bilinear_matrix_transp_rows, &
|
||||||
|
! !$OMP psi_bilinear_matrix_transp_columns, &
|
||||||
|
! !$OMP psi_bilinear_matrix_transp_order, N_st, &
|
||||||
|
! !$OMP psi_bilinear_matrix_order_transp_reverse, &
|
||||||
|
! !$OMP psi_bilinear_matrix_columns_loc, &
|
||||||
|
! !$OMP psi_bilinear_matrix_transp_rows_loc, &
|
||||||
|
! !$OMP istart, iend, istep, irp_here, v_t, s_t, &
|
||||||
|
! !$OMP ishift, idx0, u_t, maxab) &
|
||||||
|
! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,&
|
||||||
|
! !$OMP lcol, lrow, l_a, l_b, &
|
||||||
|
! !$OMP buffer, doubles, n_doubles, &
|
||||||
|
! !$OMP tmp_det2, idx, l, kcol_prev, &
|
||||||
|
! !$OMP singles_a, n_singles_a, singles_b, &
|
||||||
|
! !$OMP n_singles_b, k8)
|
||||||
|
|
||||||
|
! Alpha/Beta double excitations
|
||||||
|
! =============================
|
||||||
|
|
||||||
|
allocate( buffer($N_int,maxab), &
|
||||||
|
singles_a(maxab), &
|
||||||
|
singles_b(maxab), &
|
||||||
|
doubles(maxab), &
|
||||||
|
idx(maxab))
|
||||||
|
|
||||||
|
kcol_prev=-1
|
||||||
|
|
||||||
|
ASSERT (iend <= N_det)
|
||||||
|
ASSERT (istart > 0)
|
||||||
|
ASSERT (istep > 0)
|
||||||
|
|
||||||
|
!!$OMP DO SCHEDULE(dynamic,64)
|
||||||
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
if (kcol /= kcol_prev) then
|
||||||
|
call get_all_spin_singles_$N_int( &
|
||||||
|
psi_det_beta_unique, idx0, &
|
||||||
|
tmp_det(1,2), N_det_beta_unique, &
|
||||||
|
singles_b, n_singles_b)
|
||||||
|
endif
|
||||||
|
kcol_prev = kcol
|
||||||
|
|
||||||
|
! Loop over singly excited beta columns
|
||||||
|
! -------------------------------------
|
||||||
|
|
||||||
|
do i=1,n_singles_b
|
||||||
|
lcol = singles_b(i)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
|
||||||
|
|
||||||
|
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
idx(j) = l_a
|
||||||
|
l_a = l_a+1
|
||||||
|
enddo
|
||||||
|
j = j-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_$N_int( &
|
||||||
|
buffer, idx, tmp_det(1,1), j, &
|
||||||
|
singles_a, n_singles_a )
|
||||||
|
|
||||||
|
! Loop over alpha singles
|
||||||
|
! -----------------------
|
||||||
|
|
||||||
|
do k = 1,n_singles_a
|
||||||
|
l_a = singles_a(k)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
!call i_H_j_double_alpha_beta(tmp_det,tmp_det2,$N_int,hij)
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
! !$OMP END DO
|
||||||
|
|
||||||
|
! !$OMP DO SCHEDULE(dynamic,64)
|
||||||
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
|
|
||||||
|
! Single and double alpha exitations
|
||||||
|
! ===================================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
! Initial determinant is at k_b in beta-major representation
|
||||||
|
! ----------------------------------------------------------------------
|
||||||
|
|
||||||
|
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||||
|
ASSERT (k_b <= N_det)
|
||||||
|
|
||||||
|
spindet(1:$N_int) = tmp_det(1:$N_int,1)
|
||||||
|
|
||||||
|
! Loop inside the beta column to gather all the connected alphas
|
||||||
|
lcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||||
|
do i=1,N_det_alpha_unique
|
||||||
|
if (l_a > N_det) exit
|
||||||
|
lcol = psi_bilinear_matrix_columns(l_a)
|
||||||
|
if (lcol /= kcol) exit
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
idx(i) = l_a
|
||||||
|
l_a = l_a+1
|
||||||
|
enddo
|
||||||
|
i = i-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_and_doubles_$N_int( &
|
||||||
|
buffer, idx, spindet, i, &
|
||||||
|
singles_a, doubles, n_singles_a, n_doubles )
|
||||||
|
|
||||||
|
! Compute Hij for all alpha singles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
do i=1,n_singles_a
|
||||||
|
l_a = singles_a(i)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
! increment the alpha/beta part for single excitations
|
||||||
|
call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4)
|
||||||
|
! increment the alpha/alpha part for single excitations
|
||||||
|
call off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4)
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
! Compute Hij for all alpha doubles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
do i=1,n_doubles
|
||||||
|
l_a = doubles(i)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
call off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
! Single and double beta excitations
|
||||||
|
! ==================================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
spindet(1:$N_int) = tmp_det(1:$N_int,2)
|
||||||
|
|
||||||
|
! Initial determinant is at k_b in beta-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||||
|
ASSERT (k_b <= N_det)
|
||||||
|
|
||||||
|
! Loop inside the alpha row to gather all the connected betas
|
||||||
|
lrow = psi_bilinear_matrix_transp_rows(k_b)
|
||||||
|
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
|
||||||
|
do i=1,N_det_beta_unique
|
||||||
|
if (l_b > N_det) exit
|
||||||
|
lrow = psi_bilinear_matrix_transp_rows(l_b)
|
||||||
|
if (lrow /= krow) exit
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
|
||||||
|
idx(i) = l_b
|
||||||
|
l_b = l_b+1
|
||||||
|
enddo
|
||||||
|
i = i-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_and_doubles_$N_int( &
|
||||||
|
buffer, idx, spindet, i, &
|
||||||
|
singles_b, doubles, n_singles_b, n_doubles )
|
||||||
|
|
||||||
|
! Compute Hij for all beta singles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
do i=1,n_singles_b
|
||||||
|
l_b = singles_b(i)
|
||||||
|
ASSERT (l_b <= N_det)
|
||||||
|
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
|
||||||
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
! increment the alpha/beta part for single excitations
|
||||||
|
call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4)
|
||||||
|
! increment the beta /beta part for single excitations
|
||||||
|
call off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Compute Hij for all beta doubles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
do i=1,n_doubles
|
||||||
|
l_b = doubles(i)
|
||||||
|
ASSERT (l_b <= N_det)
|
||||||
|
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
call off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
! Diagonal contribution
|
||||||
|
! =====================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
double precision, external :: diag_wee_mat_elem, diag_S_mat_elem
|
||||||
|
|
||||||
|
double precision :: c_1(N_states),c_2(N_states)
|
||||||
|
do l = 1, N_states
|
||||||
|
c_1(l) = u_t(l,k_a)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4)
|
||||||
|
|
||||||
|
end do
|
||||||
|
!!$OMP END DO
|
||||||
|
deallocate(buffer, singles_a, singles_b, doubles, idx)
|
||||||
|
!!$OMP END PARALLEL
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
SUBST [ N_int ]
|
||||||
|
|
||||||
|
1;;
|
||||||
|
2;;
|
||||||
|
3;;
|
||||||
|
4;;
|
||||||
|
N_int;;
|
||||||
|
|
||||||
|
END_TEMPLATE
|
||||||
|
|
83
src/two_body_rdm/all_states_2_rdm.irp.f
Normal file
83
src/two_body_rdm/all_states_2_rdm.irp.f
Normal file
@ -0,0 +1,83 @@
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, all_states_act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)]
|
||||||
|
implicit none
|
||||||
|
double precision, allocatable :: state_weights(:)
|
||||||
|
BEGIN_DOC
|
||||||
|
! all_states_act_two_rdm_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs
|
||||||
|
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
|
||||||
|
END_DOC
|
||||||
|
allocate(state_weights(N_states))
|
||||||
|
state_weights = 1.d0/dble(N_states)
|
||||||
|
integer :: ispin
|
||||||
|
! condition for alpha/beta spin
|
||||||
|
ispin = 1
|
||||||
|
all_states_act_two_rdm_alpha_alpha_mo = 0.D0
|
||||||
|
call orb_range_all_states_two_rdm(all_states_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, all_states_act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)]
|
||||||
|
implicit none
|
||||||
|
double precision, allocatable :: state_weights(:)
|
||||||
|
BEGIN_DOC
|
||||||
|
! all_states_act_two_rdm_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs
|
||||||
|
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
|
||||||
|
END_DOC
|
||||||
|
allocate(state_weights(N_states))
|
||||||
|
state_weights = 1.d0/dble(N_states)
|
||||||
|
integer :: ispin
|
||||||
|
! condition for alpha/beta spin
|
||||||
|
ispin = 2
|
||||||
|
all_states_act_two_rdm_beta_beta_mo = 0.d0
|
||||||
|
call orb_range_all_states_two_rdm(all_states_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, all_states_act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)]
|
||||||
|
implicit none
|
||||||
|
double precision, allocatable :: state_weights(:)
|
||||||
|
BEGIN_DOC
|
||||||
|
! all_states_act_two_rdm_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs
|
||||||
|
! = <Psi| a^{\dagger}_{i,alpha} a^{\dagger}_{j,beta} a_{l,beta} a_{k,alpha} |Psi>
|
||||||
|
END_DOC
|
||||||
|
allocate(state_weights(N_states))
|
||||||
|
state_weights = 1.d0/dble(N_states)
|
||||||
|
integer :: ispin
|
||||||
|
! condition for alpha/beta spin
|
||||||
|
print*,''
|
||||||
|
print*,''
|
||||||
|
print*,''
|
||||||
|
print*,'providint all_states_act_two_rdm_alpha_beta_mo '
|
||||||
|
ispin = 3
|
||||||
|
print*,'ispin = ',ispin
|
||||||
|
all_states_act_two_rdm_alpha_beta_mo = 0.d0
|
||||||
|
call orb_range_all_states_two_rdm(all_states_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, all_states_act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! all_states_act_two_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices
|
||||||
|
! The active part of the two-electron energy can be computed as:
|
||||||
|
!
|
||||||
|
! \sum_{i,j,k,l = 1, n_act_orb} all_states_act_two_rdm_spin_trace_mo(i,j,k,l) * < ii jj | kk ll >
|
||||||
|
!
|
||||||
|
! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l)
|
||||||
|
END_DOC
|
||||||
|
double precision, allocatable :: state_weights(:)
|
||||||
|
allocate(state_weights(N_states))
|
||||||
|
state_weights = 1.d0/dble(N_states)
|
||||||
|
integer :: ispin
|
||||||
|
! condition for alpha/beta spin
|
||||||
|
ispin = 4
|
||||||
|
all_states_act_two_rdm_spin_trace_mo = 0.d0
|
||||||
|
integer :: i
|
||||||
|
|
||||||
|
call orb_range_all_states_two_rdm(all_states_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
495
src/two_body_rdm/all_states_routines.irp.f
Normal file
495
src/two_body_rdm/all_states_routines.irp.f
Normal file
@ -0,0 +1,495 @@
|
|||||||
|
subroutine orb_range_all_states_two_rdm(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_0,N_st,sze)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! if ispin == 1 :: alpha/alpha 2rdm
|
||||||
|
! == 2 :: beta /beta 2rdm
|
||||||
|
! == 3 :: alpha/beta 2rdm
|
||||||
|
! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba))
|
||||||
|
!
|
||||||
|
! Assumes that the determinants are in psi_det
|
||||||
|
!
|
||||||
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
|
||||||
|
double precision, intent(in) :: u_0(sze,N_st)
|
||||||
|
|
||||||
|
integer :: k
|
||||||
|
double precision, allocatable :: u_t(:,:)
|
||||||
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
|
||||||
|
allocate(u_t(N_st,N_det))
|
||||||
|
do k=1,N_st
|
||||||
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
||||||
|
enddo
|
||||||
|
call dtranspose( &
|
||||||
|
u_0, &
|
||||||
|
size(u_0, 1), &
|
||||||
|
u_t, &
|
||||||
|
size(u_t, 1), &
|
||||||
|
N_det, N_st)
|
||||||
|
|
||||||
|
call orb_range_all_states_two_rdm_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,1,N_det,0,1)
|
||||||
|
deallocate(u_t)
|
||||||
|
|
||||||
|
do k=1,N_st
|
||||||
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_all_states_two_rdm_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes two-rdm
|
||||||
|
!
|
||||||
|
! Default should be 1,N_det,0,1
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
|
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
|
||||||
|
double precision, intent(in) :: u_t(N_st,N_det)
|
||||||
|
|
||||||
|
integer :: k
|
||||||
|
|
||||||
|
PROVIDE N_int
|
||||||
|
|
||||||
|
select case (N_int)
|
||||||
|
case (1)
|
||||||
|
call orb_range_all_states_two_rdm_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (2)
|
||||||
|
call orb_range_all_states_two_rdm_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (3)
|
||||||
|
call orb_range_all_states_two_rdm_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (4)
|
||||||
|
call orb_range_all_states_two_rdm_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case default
|
||||||
|
call orb_range_all_states_two_rdm_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
end select
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_TEMPLATE
|
||||||
|
subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes the two rdm for the N_st vectors |u_t>
|
||||||
|
! if ispin == 1 :: alpha/alpha 2rdm
|
||||||
|
! == 2 :: beta /beta 2rdm
|
||||||
|
! == 3 :: alpha/beta 2rdm
|
||||||
|
! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba))
|
||||||
|
! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb
|
||||||
|
! Default should be 1,N_det,0,1 for istart,iend,ishift,istep
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
|
double precision, intent(in) :: u_t(N_st,N_det)
|
||||||
|
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
|
||||||
|
|
||||||
|
integer :: i,j,k,l
|
||||||
|
integer :: k_a, k_b, l_a, l_b, m_a, m_b
|
||||||
|
integer :: istate
|
||||||
|
integer :: krow, kcol, krow_b, kcol_b
|
||||||
|
integer :: lrow, lcol
|
||||||
|
integer :: mrow, mcol
|
||||||
|
integer(bit_kind) :: spindet($N_int)
|
||||||
|
integer(bit_kind) :: tmp_det($N_int,2)
|
||||||
|
integer(bit_kind) :: tmp_det2($N_int,2)
|
||||||
|
integer(bit_kind) :: tmp_det3($N_int,2)
|
||||||
|
integer(bit_kind), allocatable :: buffer(:,:)
|
||||||
|
integer :: n_doubles
|
||||||
|
integer, allocatable :: doubles(:)
|
||||||
|
integer, allocatable :: singles_a(:)
|
||||||
|
integer, allocatable :: singles_b(:)
|
||||||
|
integer, allocatable :: idx(:), idx0(:)
|
||||||
|
integer :: maxab, n_singles_a, n_singles_b, kcol_prev
|
||||||
|
integer*8 :: k8
|
||||||
|
double precision,allocatable :: c_contrib(:)
|
||||||
|
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
integer(bit_kind) :: orb_bitmask($N_int)
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
else
|
||||||
|
print*,'Wrong parameter for ispin in general_two_rdm_dm_nstates_work'
|
||||||
|
print*,'ispin = ',ispin
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
|
||||||
|
PROVIDE N_int
|
||||||
|
|
||||||
|
call list_to_bitstring( orb_bitmask, list_orb, norb, N_int)
|
||||||
|
|
||||||
|
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
|
||||||
|
allocate(idx0(maxab))
|
||||||
|
|
||||||
|
do i=1,maxab
|
||||||
|
idx0(i) = i
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Prepare the array of all alpha single excitations
|
||||||
|
! -------------------------------------------------
|
||||||
|
|
||||||
|
PROVIDE N_int nthreads_davidson
|
||||||
|
!!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
|
||||||
|
! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, &
|
||||||
|
! !$OMP psi_bilinear_matrix_columns, &
|
||||||
|
! !$OMP psi_det_alpha_unique, psi_det_beta_unique,&
|
||||||
|
! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
|
||||||
|
! !$OMP psi_bilinear_matrix_transp_rows, &
|
||||||
|
! !$OMP psi_bilinear_matrix_transp_columns, &
|
||||||
|
! !$OMP psi_bilinear_matrix_transp_order, N_st, &
|
||||||
|
! !$OMP psi_bilinear_matrix_order_transp_reverse, &
|
||||||
|
! !$OMP psi_bilinear_matrix_columns_loc, &
|
||||||
|
! !$OMP psi_bilinear_matrix_transp_rows_loc, &
|
||||||
|
! !$OMP istart, iend, istep, irp_here, v_t, s_t, &
|
||||||
|
! !$OMP ishift, idx0, u_t, maxab) &
|
||||||
|
! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,&
|
||||||
|
! !$OMP lcol, lrow, l_a, l_b, &
|
||||||
|
! !$OMP buffer, doubles, n_doubles, &
|
||||||
|
! !$OMP tmp_det2, idx, l, kcol_prev, &
|
||||||
|
! !$OMP singles_a, n_singles_a, singles_b, &
|
||||||
|
! !$OMP n_singles_b, k8)
|
||||||
|
|
||||||
|
! Alpha/Beta double excitations
|
||||||
|
! =============================
|
||||||
|
|
||||||
|
allocate( buffer($N_int,maxab), &
|
||||||
|
singles_a(maxab), &
|
||||||
|
singles_b(maxab), &
|
||||||
|
doubles(maxab), &
|
||||||
|
idx(maxab),c_contrib(N_st))
|
||||||
|
|
||||||
|
kcol_prev=-1
|
||||||
|
|
||||||
|
ASSERT (iend <= N_det)
|
||||||
|
ASSERT (istart > 0)
|
||||||
|
ASSERT (istep > 0)
|
||||||
|
|
||||||
|
!!$OMP DO SCHEDULE(dynamic,64)
|
||||||
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
if (kcol /= kcol_prev) then
|
||||||
|
call get_all_spin_singles_$N_int( &
|
||||||
|
psi_det_beta_unique, idx0, &
|
||||||
|
tmp_det(1,2), N_det_beta_unique, &
|
||||||
|
singles_b, n_singles_b)
|
||||||
|
endif
|
||||||
|
kcol_prev = kcol
|
||||||
|
|
||||||
|
! Loop over singly excited beta columns
|
||||||
|
! -------------------------------------
|
||||||
|
|
||||||
|
do i=1,n_singles_b
|
||||||
|
lcol = singles_b(i)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
|
||||||
|
|
||||||
|
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
idx(j) = l_a
|
||||||
|
l_a = l_a+1
|
||||||
|
enddo
|
||||||
|
j = j-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_$N_int( &
|
||||||
|
buffer, idx, tmp_det(1,1), j, &
|
||||||
|
singles_a, n_singles_a )
|
||||||
|
|
||||||
|
! Loop over alpha singles
|
||||||
|
! -----------------------
|
||||||
|
|
||||||
|
if(alpha_beta.or.spin_trace)then
|
||||||
|
do k = 1,n_singles_a
|
||||||
|
l_a = singles_a(k)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
c_contrib = 0.d0
|
||||||
|
do l= 1, N_st
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_contrib(l) = c_1(l) * c_2(l)
|
||||||
|
enddo
|
||||||
|
call orb_range_off_diagonal_double_to_two_rdm_ab_dm_all_states(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
! !$OMP END DO
|
||||||
|
|
||||||
|
! !$OMP DO SCHEDULE(dynamic,64)
|
||||||
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
|
|
||||||
|
! Single and double alpha exitations
|
||||||
|
! ===================================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
! Initial determinant is at k_b in beta-major representation
|
||||||
|
! ----------------------------------------------------------------------
|
||||||
|
|
||||||
|
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||||
|
ASSERT (k_b <= N_det)
|
||||||
|
|
||||||
|
spindet(1:$N_int) = tmp_det(1:$N_int,1)
|
||||||
|
|
||||||
|
! Loop inside the beta column to gather all the connected alphas
|
||||||
|
lcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||||
|
do i=1,N_det_alpha_unique
|
||||||
|
if (l_a > N_det) exit
|
||||||
|
lcol = psi_bilinear_matrix_columns(l_a)
|
||||||
|
if (lcol /= kcol) exit
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
idx(i) = l_a
|
||||||
|
l_a = l_a+1
|
||||||
|
enddo
|
||||||
|
i = i-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_and_doubles_$N_int( &
|
||||||
|
buffer, idx, spindet, i, &
|
||||||
|
singles_a, doubles, n_singles_a, n_doubles )
|
||||||
|
|
||||||
|
! Compute Hij for all alpha singles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
do i=1,n_singles_a
|
||||||
|
l_a = singles_a(i)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
c_contrib = 0.d0
|
||||||
|
do l= 1, N_st
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_contrib(l) = c_1(l) * c_2(l)
|
||||||
|
enddo
|
||||||
|
if(alpha_beta.or.spin_trace.or.alpha_alpha)then
|
||||||
|
! increment the alpha/beta part for single excitations
|
||||||
|
call orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
! increment the alpha/alpha part for single excitations
|
||||||
|
call orb_range_off_diagonal_single_to_two_rdm_aa_dm_all_states(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
endif
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
! Compute Hij for all alpha doubles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
if(alpha_alpha.or.spin_trace)then
|
||||||
|
do i=1,n_doubles
|
||||||
|
l_a = doubles(i)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
c_contrib = 0.d0
|
||||||
|
do l= 1, N_st
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_contrib(l) += c_1(l) * c_2(l)
|
||||||
|
enddo
|
||||||
|
call orb_range_off_diagonal_double_to_two_rdm_aa_dm_all_states(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
! Single and double beta excitations
|
||||||
|
! ==================================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
spindet(1:$N_int) = tmp_det(1:$N_int,2)
|
||||||
|
|
||||||
|
! Initial determinant is at k_b in beta-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||||
|
ASSERT (k_b <= N_det)
|
||||||
|
|
||||||
|
! Loop inside the alpha row to gather all the connected betas
|
||||||
|
lrow = psi_bilinear_matrix_transp_rows(k_b)
|
||||||
|
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
|
||||||
|
do i=1,N_det_beta_unique
|
||||||
|
if (l_b > N_det) exit
|
||||||
|
lrow = psi_bilinear_matrix_transp_rows(l_b)
|
||||||
|
if (lrow /= krow) exit
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
|
||||||
|
idx(i) = l_b
|
||||||
|
l_b = l_b+1
|
||||||
|
enddo
|
||||||
|
i = i-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_and_doubles_$N_int( &
|
||||||
|
buffer, idx, spindet, i, &
|
||||||
|
singles_b, doubles, n_singles_b, n_doubles )
|
||||||
|
|
||||||
|
! Compute Hij for all beta singles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
do i=1,n_singles_b
|
||||||
|
l_b = singles_b(i)
|
||||||
|
ASSERT (l_b <= N_det)
|
||||||
|
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
|
||||||
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
|
c_contrib = 0.d0
|
||||||
|
do l= 1, N_st
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_contrib(l) = c_1(l) * c_2(l)
|
||||||
|
enddo
|
||||||
|
if(alpha_beta.or.spin_trace.or.beta_beta)then
|
||||||
|
! increment the alpha/beta part for single excitations
|
||||||
|
call orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
! increment the beta /beta part for single excitations
|
||||||
|
call orb_range_off_diagonal_single_to_two_rdm_bb_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Compute Hij for all beta doubles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
if(beta_beta.or.spin_trace)then
|
||||||
|
do i=1,n_doubles
|
||||||
|
l_b = doubles(i)
|
||||||
|
ASSERT (l_b <= N_det)
|
||||||
|
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
|
c_contrib = 0.d0
|
||||||
|
do l= 1, N_st
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_contrib(l) = c_1(l) * c_2(l)
|
||||||
|
enddo
|
||||||
|
call orb_range_off_diagonal_double_to_two_rdm_bb_dm_all_states(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
! Diagonal contribution
|
||||||
|
! =====================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
double precision, external :: diag_wee_mat_elem, diag_S_mat_elem
|
||||||
|
|
||||||
|
double precision :: c_1(N_states),c_2(N_states)
|
||||||
|
c_contrib = 0.d0
|
||||||
|
do l = 1, N_st
|
||||||
|
c_1(l) = u_t(l,k_a)
|
||||||
|
c_contrib(l) = c_1(l) * c_1(l)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call orb_range_diagonal_contrib_to_all_two_rdm_dm_all_states(tmp_det,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
|
||||||
|
end do
|
||||||
|
!!$OMP END DO
|
||||||
|
deallocate(buffer, singles_a, singles_b, doubles, idx)
|
||||||
|
!!$OMP END PARALLEL
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
SUBST [ N_int ]
|
||||||
|
|
||||||
|
1;;
|
||||||
|
2;;
|
||||||
|
3;;
|
||||||
|
4;;
|
||||||
|
N_int;;
|
||||||
|
|
||||||
|
END_TEMPLATE
|
||||||
|
|
87
src/two_body_rdm/orb_range_2_rdm.irp.f
Normal file
87
src/two_body_rdm/orb_range_2_rdm.irp.f
Normal file
@ -0,0 +1,87 @@
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
|
||||||
|
implicit none
|
||||||
|
double precision, allocatable :: state_weights(:)
|
||||||
|
BEGIN_DOC
|
||||||
|
! state_av_act_two_rdm_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs
|
||||||
|
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
|
||||||
|
END_DOC
|
||||||
|
allocate(state_weights(N_states))
|
||||||
|
state_weights = 1.d0/dble(N_states)
|
||||||
|
integer :: ispin
|
||||||
|
! condition for alpha/beta spin
|
||||||
|
ispin = 1
|
||||||
|
state_av_act_two_rdm_alpha_alpha_mo = 0.D0
|
||||||
|
call orb_range_two_rdm_state_av(state_av_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
|
||||||
|
implicit none
|
||||||
|
double precision, allocatable :: state_weights(:)
|
||||||
|
BEGIN_DOC
|
||||||
|
! state_av_act_two_rdm_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs
|
||||||
|
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
|
||||||
|
END_DOC
|
||||||
|
allocate(state_weights(N_states))
|
||||||
|
state_weights = 1.d0/dble(N_states)
|
||||||
|
integer :: ispin
|
||||||
|
! condition for alpha/beta spin
|
||||||
|
ispin = 2
|
||||||
|
state_av_act_two_rdm_beta_beta_mo = 0.d0
|
||||||
|
call orb_range_two_rdm_state_av(state_av_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
|
||||||
|
implicit none
|
||||||
|
double precision, allocatable :: state_weights(:)
|
||||||
|
BEGIN_DOC
|
||||||
|
! state_av_act_two_rdm_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs
|
||||||
|
! = <Psi| a^{\dagger}_{i,alpha} a^{\dagger}_{j,beta} a_{l,beta} a_{k,alpha} |Psi>
|
||||||
|
END_DOC
|
||||||
|
allocate(state_weights(N_states))
|
||||||
|
state_weights = 1.d0/dble(N_states)
|
||||||
|
integer :: ispin
|
||||||
|
! condition for alpha/beta spin
|
||||||
|
print*,''
|
||||||
|
print*,''
|
||||||
|
print*,''
|
||||||
|
print*,'providint state_av_act_two_rdm_alpha_beta_mo '
|
||||||
|
ispin = 3
|
||||||
|
print*,'ispin = ',ispin
|
||||||
|
state_av_act_two_rdm_alpha_beta_mo = 0.d0
|
||||||
|
call orb_range_two_rdm_state_av(state_av_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! state_av_act_two_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices
|
||||||
|
! The active part of the two-electron energy can be computed as:
|
||||||
|
!
|
||||||
|
! \sum_{i,j,k,l = 1, n_act_orb} state_av_act_two_rdm_spin_trace_mo(i,j,k,l) * < ii jj | kk ll >
|
||||||
|
!
|
||||||
|
! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l)
|
||||||
|
END_DOC
|
||||||
|
double precision, allocatable :: state_weights(:)
|
||||||
|
allocate(state_weights(N_states))
|
||||||
|
state_weights = 1.d0/dble(N_states)
|
||||||
|
integer :: ispin
|
||||||
|
! condition for alpha/beta spin
|
||||||
|
ispin = 4
|
||||||
|
state_av_act_two_rdm_spin_trace_mo = 0.d0
|
||||||
|
integer :: i
|
||||||
|
double precision :: wall_0,wall_1
|
||||||
|
call wall_time(wall_0)
|
||||||
|
print*,'providing the state average TWO-RDM ...'
|
||||||
|
call orb_range_two_rdm_state_av(state_av_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
|
||||||
|
call wall_time(wall_1)
|
||||||
|
print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0
|
||||||
|
END_PROVIDER
|
||||||
|
|
85
src/two_body_rdm/orb_range_2_rdm_openmp.irp.f
Normal file
85
src/two_body_rdm/orb_range_2_rdm_openmp.irp.f
Normal file
@ -0,0 +1,85 @@
|
|||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
|
||||||
|
implicit none
|
||||||
|
double precision, allocatable :: state_weights(:)
|
||||||
|
BEGIN_DOC
|
||||||
|
! state_av_act_two_rdm_openmp_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs
|
||||||
|
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
|
||||||
|
END_DOC
|
||||||
|
allocate(state_weights(N_states))
|
||||||
|
state_weights = 1.d0/dble(N_states)
|
||||||
|
integer :: ispin
|
||||||
|
! condition for alpha/beta spin
|
||||||
|
ispin = 1
|
||||||
|
state_av_act_two_rdm_openmp_alpha_alpha_mo = 0.D0
|
||||||
|
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
|
||||||
|
implicit none
|
||||||
|
double precision, allocatable :: state_weights(:)
|
||||||
|
BEGIN_DOC
|
||||||
|
! state_av_act_two_rdm_openmp_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs
|
||||||
|
! = <Psi| a^{\dagger}_i a^{\dagger}_j a_l a_k |Psi>
|
||||||
|
END_DOC
|
||||||
|
allocate(state_weights(N_states))
|
||||||
|
state_weights = 1.d0/dble(N_states)
|
||||||
|
integer :: ispin
|
||||||
|
! condition for alpha/beta spin
|
||||||
|
ispin = 2
|
||||||
|
state_av_act_two_rdm_openmp_beta_beta_mo = 0.d0
|
||||||
|
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_beta_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
|
||||||
|
implicit none
|
||||||
|
double precision, allocatable :: state_weights(:)
|
||||||
|
BEGIN_DOC
|
||||||
|
! state_av_act_two_rdm_openmp_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs
|
||||||
|
! = <Psi| a^{\dagger}_{i,alpha} a^{\dagger}_{j,beta} a_{l,beta} a_{k,alpha} |Psi>
|
||||||
|
END_DOC
|
||||||
|
allocate(state_weights(N_states))
|
||||||
|
state_weights = 1.d0/dble(N_states)
|
||||||
|
integer :: ispin
|
||||||
|
! condition for alpha/beta spin
|
||||||
|
print*,''
|
||||||
|
print*,''
|
||||||
|
print*,''
|
||||||
|
print*,'providint state_av_act_two_rdm_openmp_alpha_beta_mo '
|
||||||
|
ispin = 3
|
||||||
|
print*,'ispin = ',ispin
|
||||||
|
state_av_act_two_rdm_openmp_alpha_beta_mo = 0.d0
|
||||||
|
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_alpha_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! state_av_act_two_rdm_openmp_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices
|
||||||
|
! The active part of the two-electron energy can be computed as:
|
||||||
|
!
|
||||||
|
! \sum_{i,j,k,l = 1, n_act_orb} state_av_act_two_rdm_openmp_spin_trace_mo(i,j,k,l) * < ii jj | kk ll >
|
||||||
|
!
|
||||||
|
! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l)
|
||||||
|
END_DOC
|
||||||
|
double precision, allocatable :: state_weights(:)
|
||||||
|
allocate(state_weights(N_states))
|
||||||
|
state_weights = 1.d0/dble(N_states)
|
||||||
|
integer :: ispin
|
||||||
|
! condition for alpha/beta spin
|
||||||
|
ispin = 4
|
||||||
|
state_av_act_two_rdm_openmp_spin_trace_mo = 0.d0
|
||||||
|
integer :: i
|
||||||
|
double precision :: wall_0,wall_1
|
||||||
|
call wall_time(wall_0)
|
||||||
|
print*,'providing the state average TWO-RDM ...'
|
||||||
|
call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
|
||||||
|
call wall_time(wall_1)
|
||||||
|
print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0
|
||||||
|
END_PROVIDER
|
||||||
|
|
498
src/two_body_rdm/orb_range_routines.irp.f
Normal file
498
src/two_body_rdm/orb_range_routines.irp.f
Normal file
@ -0,0 +1,498 @@
|
|||||||
|
subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_0,N_st,sze)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! if ispin == 1 :: alpha/alpha 2rdm
|
||||||
|
! == 2 :: beta /beta 2rdm
|
||||||
|
! == 3 :: alpha/beta 2rdm
|
||||||
|
! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba))
|
||||||
|
!
|
||||||
|
! Assumes that the determinants are in psi_det
|
||||||
|
!
|
||||||
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
double precision, intent(in) :: u_0(sze,N_st),state_weights(N_st)
|
||||||
|
|
||||||
|
integer :: k
|
||||||
|
double precision, allocatable :: u_t(:,:)
|
||||||
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
|
||||||
|
allocate(u_t(N_st,N_det))
|
||||||
|
do k=1,N_st
|
||||||
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
||||||
|
enddo
|
||||||
|
call dtranspose( &
|
||||||
|
u_0, &
|
||||||
|
size(u_0, 1), &
|
||||||
|
u_t, &
|
||||||
|
size(u_t, 1), &
|
||||||
|
N_det, N_st)
|
||||||
|
|
||||||
|
|
||||||
|
call orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1)
|
||||||
|
deallocate(u_t)
|
||||||
|
|
||||||
|
do k=1,N_st
|
||||||
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes two-rdm
|
||||||
|
!
|
||||||
|
! Default should be 1,N_det,0,1
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
|
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st)
|
||||||
|
|
||||||
|
integer :: k
|
||||||
|
|
||||||
|
PROVIDE N_int
|
||||||
|
|
||||||
|
select case (N_int)
|
||||||
|
case (1)
|
||||||
|
call orb_range_two_rdm_state_av_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (2)
|
||||||
|
call orb_range_two_rdm_state_av_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (3)
|
||||||
|
call orb_range_two_rdm_state_av_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (4)
|
||||||
|
call orb_range_two_rdm_state_av_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case default
|
||||||
|
call orb_range_two_rdm_state_av_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
end select
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_TEMPLATE
|
||||||
|
subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes the two rdm for the N_st vectors |u_t>
|
||||||
|
! if ispin == 1 :: alpha/alpha 2rdm
|
||||||
|
! == 2 :: beta /beta 2rdm
|
||||||
|
! == 3 :: alpha/beta 2rdm
|
||||||
|
! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba))
|
||||||
|
! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb
|
||||||
|
! In any cases, the state average weights will be used with an array state_weights
|
||||||
|
! Default should be 1,N_det,0,1 for istart,iend,ishift,istep
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
|
double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st)
|
||||||
|
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
|
||||||
|
integer :: i,j,k,l
|
||||||
|
integer :: k_a, k_b, l_a, l_b, m_a, m_b
|
||||||
|
integer :: istate
|
||||||
|
integer :: krow, kcol, krow_b, kcol_b
|
||||||
|
integer :: lrow, lcol
|
||||||
|
integer :: mrow, mcol
|
||||||
|
integer(bit_kind) :: spindet($N_int)
|
||||||
|
integer(bit_kind) :: tmp_det($N_int,2)
|
||||||
|
integer(bit_kind) :: tmp_det2($N_int,2)
|
||||||
|
integer(bit_kind) :: tmp_det3($N_int,2)
|
||||||
|
integer(bit_kind), allocatable :: buffer(:,:)
|
||||||
|
integer :: n_doubles
|
||||||
|
integer, allocatable :: doubles(:)
|
||||||
|
integer, allocatable :: singles_a(:)
|
||||||
|
integer, allocatable :: singles_b(:)
|
||||||
|
integer, allocatable :: idx(:), idx0(:)
|
||||||
|
integer :: maxab, n_singles_a, n_singles_b, kcol_prev
|
||||||
|
integer*8 :: k8
|
||||||
|
double precision :: c_average
|
||||||
|
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
integer(bit_kind) :: orb_bitmask($N_int)
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
else
|
||||||
|
print*,'Wrong parameter for ispin in general_two_rdm_state_av_work'
|
||||||
|
print*,'ispin = ',ispin
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
PROVIDE N_int
|
||||||
|
|
||||||
|
call list_to_bitstring( orb_bitmask, list_orb, norb, N_int)
|
||||||
|
|
||||||
|
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
|
||||||
|
allocate(idx0(maxab))
|
||||||
|
|
||||||
|
do i=1,maxab
|
||||||
|
idx0(i) = i
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Prepare the array of all alpha single excitations
|
||||||
|
! -------------------------------------------------
|
||||||
|
|
||||||
|
PROVIDE N_int nthreads_davidson
|
||||||
|
!!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
|
||||||
|
! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, &
|
||||||
|
! !$OMP psi_bilinear_matrix_columns, &
|
||||||
|
! !$OMP psi_det_alpha_unique, psi_det_beta_unique,&
|
||||||
|
! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
|
||||||
|
! !$OMP psi_bilinear_matrix_transp_rows, &
|
||||||
|
! !$OMP psi_bilinear_matrix_transp_columns, &
|
||||||
|
! !$OMP psi_bilinear_matrix_transp_order, N_st, &
|
||||||
|
! !$OMP psi_bilinear_matrix_order_transp_reverse, &
|
||||||
|
! !$OMP psi_bilinear_matrix_columns_loc, &
|
||||||
|
! !$OMP psi_bilinear_matrix_transp_rows_loc, &
|
||||||
|
! !$OMP istart, iend, istep, irp_here, v_t, s_t, &
|
||||||
|
! !$OMP ishift, idx0, u_t, maxab) &
|
||||||
|
! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,&
|
||||||
|
! !$OMP lcol, lrow, l_a, l_b, &
|
||||||
|
! !$OMP buffer, doubles, n_doubles, &
|
||||||
|
! !$OMP tmp_det2, idx, l, kcol_prev, &
|
||||||
|
! !$OMP singles_a, n_singles_a, singles_b, &
|
||||||
|
! !$OMP n_singles_b, k8)
|
||||||
|
|
||||||
|
! Alpha/Beta double excitations
|
||||||
|
! =============================
|
||||||
|
|
||||||
|
allocate( buffer($N_int,maxab), &
|
||||||
|
singles_a(maxab), &
|
||||||
|
singles_b(maxab), &
|
||||||
|
doubles(maxab), &
|
||||||
|
idx(maxab))
|
||||||
|
|
||||||
|
kcol_prev=-1
|
||||||
|
|
||||||
|
ASSERT (iend <= N_det)
|
||||||
|
ASSERT (istart > 0)
|
||||||
|
ASSERT (istep > 0)
|
||||||
|
|
||||||
|
!!$OMP DO SCHEDULE(dynamic,64)
|
||||||
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
if (kcol /= kcol_prev) then
|
||||||
|
call get_all_spin_singles_$N_int( &
|
||||||
|
psi_det_beta_unique, idx0, &
|
||||||
|
tmp_det(1,2), N_det_beta_unique, &
|
||||||
|
singles_b, n_singles_b)
|
||||||
|
endif
|
||||||
|
kcol_prev = kcol
|
||||||
|
|
||||||
|
! Loop over singly excited beta columns
|
||||||
|
! -------------------------------------
|
||||||
|
|
||||||
|
do i=1,n_singles_b
|
||||||
|
lcol = singles_b(i)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
|
||||||
|
|
||||||
|
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
idx(j) = l_a
|
||||||
|
l_a = l_a+1
|
||||||
|
enddo
|
||||||
|
j = j-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_$N_int( &
|
||||||
|
buffer, idx, tmp_det(1,1), j, &
|
||||||
|
singles_a, n_singles_a )
|
||||||
|
|
||||||
|
! Loop over alpha singles
|
||||||
|
! -----------------------
|
||||||
|
|
||||||
|
if(alpha_beta.or.spin_trace)then
|
||||||
|
do k = 1,n_singles_a
|
||||||
|
l_a = singles_a(k)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
c_average = 0.d0
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_average += c_1(l) * c_2(l) * state_weights(l)
|
||||||
|
enddo
|
||||||
|
call orb_range_off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
! !$OMP END DO
|
||||||
|
|
||||||
|
! !$OMP DO SCHEDULE(dynamic,64)
|
||||||
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
|
|
||||||
|
! Single and double alpha exitations
|
||||||
|
! ===================================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
! Initial determinant is at k_b in beta-major representation
|
||||||
|
! ----------------------------------------------------------------------
|
||||||
|
|
||||||
|
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||||
|
ASSERT (k_b <= N_det)
|
||||||
|
|
||||||
|
spindet(1:$N_int) = tmp_det(1:$N_int,1)
|
||||||
|
|
||||||
|
! Loop inside the beta column to gather all the connected alphas
|
||||||
|
lcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||||
|
do i=1,N_det_alpha_unique
|
||||||
|
if (l_a > N_det) exit
|
||||||
|
lcol = psi_bilinear_matrix_columns(l_a)
|
||||||
|
if (lcol /= kcol) exit
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
idx(i) = l_a
|
||||||
|
l_a = l_a+1
|
||||||
|
enddo
|
||||||
|
i = i-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_and_doubles_$N_int( &
|
||||||
|
buffer, idx, spindet, i, &
|
||||||
|
singles_a, doubles, n_singles_a, n_doubles )
|
||||||
|
|
||||||
|
! Compute Hij for all alpha singles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
do i=1,n_singles_a
|
||||||
|
l_a = singles_a(i)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
c_average = 0.d0
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_average += c_1(l) * c_2(l) * state_weights(l)
|
||||||
|
enddo
|
||||||
|
if(alpha_beta.or.spin_trace.or.alpha_alpha)then
|
||||||
|
! increment the alpha/beta part for single excitations
|
||||||
|
call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
! increment the alpha/alpha part for single excitations
|
||||||
|
call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
endif
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
! Compute Hij for all alpha doubles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
if(alpha_alpha.or.spin_trace)then
|
||||||
|
do i=1,n_doubles
|
||||||
|
l_a = doubles(i)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
c_average = 0.d0
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_average += c_1(l) * c_2(l) * state_weights(l)
|
||||||
|
enddo
|
||||||
|
call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
! Single and double beta excitations
|
||||||
|
! ==================================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
spindet(1:$N_int) = tmp_det(1:$N_int,2)
|
||||||
|
|
||||||
|
! Initial determinant is at k_b in beta-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||||
|
ASSERT (k_b <= N_det)
|
||||||
|
|
||||||
|
! Loop inside the alpha row to gather all the connected betas
|
||||||
|
lrow = psi_bilinear_matrix_transp_rows(k_b)
|
||||||
|
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
|
||||||
|
do i=1,N_det_beta_unique
|
||||||
|
if (l_b > N_det) exit
|
||||||
|
lrow = psi_bilinear_matrix_transp_rows(l_b)
|
||||||
|
if (lrow /= krow) exit
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
|
||||||
|
idx(i) = l_b
|
||||||
|
l_b = l_b+1
|
||||||
|
enddo
|
||||||
|
i = i-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_and_doubles_$N_int( &
|
||||||
|
buffer, idx, spindet, i, &
|
||||||
|
singles_b, doubles, n_singles_b, n_doubles )
|
||||||
|
|
||||||
|
! Compute Hij for all beta singles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
do i=1,n_singles_b
|
||||||
|
l_b = singles_b(i)
|
||||||
|
ASSERT (l_b <= N_det)
|
||||||
|
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
|
||||||
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
|
c_average = 0.d0
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_average += c_1(l) * c_2(l) * state_weights(l)
|
||||||
|
enddo
|
||||||
|
if(alpha_beta.or.spin_trace.or.beta_beta)then
|
||||||
|
! increment the alpha/beta part for single excitations
|
||||||
|
call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
! increment the beta /beta part for single excitations
|
||||||
|
call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Compute Hij for all beta doubles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
if(beta_beta.or.spin_trace)then
|
||||||
|
do i=1,n_doubles
|
||||||
|
l_b = doubles(i)
|
||||||
|
ASSERT (l_b <= N_det)
|
||||||
|
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
|
c_average = 0.d0
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_average += c_1(l) * c_2(l) * state_weights(l)
|
||||||
|
enddo
|
||||||
|
call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
! Diagonal contribution
|
||||||
|
! =====================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
double precision, external :: diag_wee_mat_elem, diag_S_mat_elem
|
||||||
|
|
||||||
|
double precision :: c_1(N_states),c_2(N_states)
|
||||||
|
c_average = 0.d0
|
||||||
|
do l = 1, N_states
|
||||||
|
c_1(l) = u_t(l,k_a)
|
||||||
|
c_average += c_1(l) * c_1(l) * state_weights(l)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call orb_range_diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
|
||||||
|
end do
|
||||||
|
!!$OMP END DO
|
||||||
|
deallocate(buffer, singles_a, singles_b, doubles, idx)
|
||||||
|
!!$OMP END PARALLEL
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
SUBST [ N_int ]
|
||||||
|
|
||||||
|
1;;
|
||||||
|
2;;
|
||||||
|
3;;
|
||||||
|
4;;
|
||||||
|
N_int;;
|
||||||
|
|
||||||
|
END_TEMPLATE
|
||||||
|
|
568
src/two_body_rdm/orb_range_routines_openmp.irp.f
Normal file
568
src/two_body_rdm/orb_range_routines_openmp.irp.f
Normal file
@ -0,0 +1,568 @@
|
|||||||
|
subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_weights,ispin,u_0,N_st,sze)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! if ispin == 1 :: alpha/alpha 2rdm
|
||||||
|
! == 2 :: beta /beta 2rdm
|
||||||
|
! == 3 :: alpha/beta 2rdm
|
||||||
|
! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba))
|
||||||
|
!
|
||||||
|
! Assumes that the determinants are in psi_det
|
||||||
|
!
|
||||||
|
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze
|
||||||
|
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
double precision, intent(in) :: u_0(sze,N_st),state_weights(N_st)
|
||||||
|
|
||||||
|
integer :: k
|
||||||
|
double precision, allocatable :: u_t(:,:)
|
||||||
|
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
|
||||||
|
allocate(u_t(N_st,N_det))
|
||||||
|
do k=1,N_st
|
||||||
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
||||||
|
enddo
|
||||||
|
call dtranspose( &
|
||||||
|
u_0, &
|
||||||
|
size(u_0, 1), &
|
||||||
|
u_t, &
|
||||||
|
size(u_t, 1), &
|
||||||
|
N_det, N_st)
|
||||||
|
|
||||||
|
call orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1)
|
||||||
|
deallocate(u_t)
|
||||||
|
|
||||||
|
do k=1,N_st
|
||||||
|
call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes two-rdm
|
||||||
|
!
|
||||||
|
! Default should be 1,N_det,0,1
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
|
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st)
|
||||||
|
|
||||||
|
integer :: k
|
||||||
|
|
||||||
|
PROVIDE N_int
|
||||||
|
|
||||||
|
select case (N_int)
|
||||||
|
case (1)
|
||||||
|
call orb_range_two_rdm_state_av_openmp_work_1(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (2)
|
||||||
|
call orb_range_two_rdm_state_av_openmp_work_2(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (3)
|
||||||
|
call orb_range_two_rdm_state_av_openmp_work_3(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case (4)
|
||||||
|
call orb_range_two_rdm_state_av_openmp_work_4(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
case default
|
||||||
|
call orb_range_two_rdm_state_av_openmp_work_N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
end select
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_TEMPLATE
|
||||||
|
subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||||
|
use bitmasks
|
||||||
|
use omp_lib
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Computes the two rdm for the N_st vectors |u_t>
|
||||||
|
! if ispin == 1 :: alpha/alpha 2rdm
|
||||||
|
! == 2 :: beta /beta 2rdm
|
||||||
|
! == 3 :: alpha/beta 2rdm
|
||||||
|
! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba))
|
||||||
|
! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb
|
||||||
|
! In any cases, the state average weights will be used with an array state_weights
|
||||||
|
! Default should be 1,N_det,0,1 for istart,iend,ishift,istep
|
||||||
|
END_DOC
|
||||||
|
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||||
|
double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st)
|
||||||
|
integer, intent(in) :: dim1,norb,list_orb(norb),ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
|
||||||
|
integer(omp_lock_kind) :: lock_2rdm
|
||||||
|
integer :: i,j,k,l
|
||||||
|
integer :: k_a, k_b, l_a, l_b
|
||||||
|
integer :: krow, kcol
|
||||||
|
integer :: lrow, lcol
|
||||||
|
integer(bit_kind) :: spindet($N_int)
|
||||||
|
integer(bit_kind) :: tmp_det($N_int,2)
|
||||||
|
integer(bit_kind) :: tmp_det2($N_int,2)
|
||||||
|
integer(bit_kind) :: tmp_det3($N_int,2)
|
||||||
|
integer(bit_kind), allocatable :: buffer(:,:)
|
||||||
|
integer :: n_doubles
|
||||||
|
integer, allocatable :: doubles(:)
|
||||||
|
integer, allocatable :: singles_a(:)
|
||||||
|
integer, allocatable :: singles_b(:)
|
||||||
|
integer, allocatable :: idx(:), idx0(:)
|
||||||
|
integer :: maxab, n_singles_a, n_singles_b, kcol_prev
|
||||||
|
double precision :: c_average
|
||||||
|
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
integer(bit_kind) :: orb_bitmask($N_int)
|
||||||
|
integer :: list_orb_reverse(mo_num)
|
||||||
|
integer, allocatable :: keys(:,:)
|
||||||
|
double precision, allocatable :: values(:)
|
||||||
|
integer :: nkeys,sze_buff
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
else
|
||||||
|
print*,'Wrong parameter for ispin in general_two_rdm_state_av_openmp_work'
|
||||||
|
print*,'ispin = ',ispin
|
||||||
|
stop
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
PROVIDE N_int
|
||||||
|
|
||||||
|
call list_to_bitstring( orb_bitmask, list_orb, norb, N_int)
|
||||||
|
sze_buff = norb ** 3 + 6 * norb
|
||||||
|
list_orb_reverse = -1000
|
||||||
|
do i = 1, norb
|
||||||
|
list_orb_reverse(list_orb(i)) = i
|
||||||
|
enddo
|
||||||
|
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
|
||||||
|
allocate(idx0(maxab))
|
||||||
|
|
||||||
|
do i=1,maxab
|
||||||
|
idx0(i) = i
|
||||||
|
enddo
|
||||||
|
call omp_init_lock(lock_2rdm)
|
||||||
|
|
||||||
|
! Prepare the array of all alpha single excitations
|
||||||
|
! -------------------------------------------------
|
||||||
|
|
||||||
|
PROVIDE N_int nthreads_davidson elec_alpha_num
|
||||||
|
!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
|
||||||
|
!$OMP SHARED(psi_bilinear_matrix_rows, N_det,lock_2rdm,&
|
||||||
|
!$OMP psi_bilinear_matrix_columns, &
|
||||||
|
!$OMP psi_det_alpha_unique, psi_det_beta_unique,&
|
||||||
|
!$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
|
||||||
|
!$OMP psi_bilinear_matrix_transp_rows, &
|
||||||
|
!$OMP psi_bilinear_matrix_transp_columns, &
|
||||||
|
!$OMP psi_bilinear_matrix_transp_order, N_st, &
|
||||||
|
!$OMP psi_bilinear_matrix_order_transp_reverse, &
|
||||||
|
!$OMP psi_bilinear_matrix_columns_loc, &
|
||||||
|
!$OMP psi_bilinear_matrix_transp_rows_loc,elec_alpha_num, &
|
||||||
|
!$OMP istart, iend, istep, irp_here,list_orb_reverse, n_states, state_weights, dim1, &
|
||||||
|
!$OMP ishift, idx0, u_t, maxab, alpha_alpha,beta_beta,alpha_beta,spin_trace,ispin,big_array,sze_buff,orb_bitmask) &
|
||||||
|
!$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,c_1, c_2, &
|
||||||
|
!$OMP lcol, lrow, l_a, l_b, &
|
||||||
|
!$OMP buffer, doubles, n_doubles, &
|
||||||
|
!$OMP tmp_det2, idx, l, kcol_prev, &
|
||||||
|
!$OMP singles_a, n_singles_a, singles_b, &
|
||||||
|
!$OMP n_singles_b, nkeys, keys, values, c_average)
|
||||||
|
|
||||||
|
! Alpha/Beta double excitations
|
||||||
|
! =============================
|
||||||
|
nkeys = 0
|
||||||
|
allocate( keys(4,sze_buff), values(sze_buff))
|
||||||
|
allocate( buffer($N_int,maxab), &
|
||||||
|
singles_a(maxab), &
|
||||||
|
singles_b(maxab), &
|
||||||
|
doubles(maxab), &
|
||||||
|
idx(maxab))
|
||||||
|
|
||||||
|
kcol_prev=-1
|
||||||
|
|
||||||
|
ASSERT (iend <= N_det)
|
||||||
|
ASSERT (istart > 0)
|
||||||
|
ASSERT (istep > 0)
|
||||||
|
|
||||||
|
!$OMP DO SCHEDULE(dynamic,64)
|
||||||
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
if (kcol /= kcol_prev) then
|
||||||
|
call get_all_spin_singles_$N_int( &
|
||||||
|
psi_det_beta_unique, idx0, &
|
||||||
|
tmp_det(1,2), N_det_beta_unique, &
|
||||||
|
singles_b, n_singles_b)
|
||||||
|
endif
|
||||||
|
kcol_prev = kcol
|
||||||
|
|
||||||
|
! Loop over singly excited beta columns
|
||||||
|
! -------------------------------------
|
||||||
|
|
||||||
|
do i=1,n_singles_b
|
||||||
|
lcol = singles_b(i)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
|
||||||
|
|
||||||
|
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
idx(j) = l_a
|
||||||
|
l_a = l_a+1
|
||||||
|
enddo
|
||||||
|
j = j-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_$N_int( &
|
||||||
|
buffer, idx, tmp_det(1,1), j, &
|
||||||
|
singles_a, n_singles_a )
|
||||||
|
|
||||||
|
! Loop over alpha singles
|
||||||
|
! -----------------------
|
||||||
|
|
||||||
|
if(alpha_beta.or.spin_trace)then
|
||||||
|
do k = 1,n_singles_a
|
||||||
|
l_a = singles_a(k)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
c_average = 0.d0
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_average += c_1(l) * c_2(l) * state_weights(l)
|
||||||
|
enddo
|
||||||
|
if(alpha_beta)then
|
||||||
|
! only ONE contribution
|
||||||
|
if (nkeys+1 .ge. size(values)) then
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
endif
|
||||||
|
else if (spin_trace)then
|
||||||
|
! TWO contributions
|
||||||
|
if (nkeys+2 .ge. size(values)) then
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
call orb_range_off_diag_double_to_two_rdm_ab_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
|
||||||
|
!$OMP DO SCHEDULE(dynamic,64)
|
||||||
|
do k_a=istart+ishift,iend,istep
|
||||||
|
|
||||||
|
|
||||||
|
! Single and double alpha exitations
|
||||||
|
! ===================================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
! Initial determinant is at k_b in beta-major representation
|
||||||
|
! ----------------------------------------------------------------------
|
||||||
|
|
||||||
|
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||||
|
ASSERT (k_b <= N_det)
|
||||||
|
|
||||||
|
spindet(1:$N_int) = tmp_det(1:$N_int,1)
|
||||||
|
|
||||||
|
! Loop inside the beta column to gather all the connected alphas
|
||||||
|
lcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||||
|
do i=1,N_det_alpha_unique
|
||||||
|
if (l_a > N_det) exit
|
||||||
|
lcol = psi_bilinear_matrix_columns(l_a)
|
||||||
|
if (lcol /= kcol) exit
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
idx(i) = l_a
|
||||||
|
l_a = l_a+1
|
||||||
|
enddo
|
||||||
|
i = i-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_and_doubles_$N_int( &
|
||||||
|
buffer, idx, spindet, i, &
|
||||||
|
singles_a, doubles, n_singles_a, n_doubles )
|
||||||
|
|
||||||
|
! Compute Hij for all alpha singles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
do i=1,n_singles_a
|
||||||
|
l_a = singles_a(i)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||||
|
c_average = 0.d0
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_average += c_1(l) * c_2(l) * state_weights(l)
|
||||||
|
enddo
|
||||||
|
if(alpha_beta.or.spin_trace.or.alpha_alpha)then
|
||||||
|
! increment the alpha/beta part for single excitations
|
||||||
|
if (nkeys+ 2 * elec_alpha_num .ge. sze_buff) then
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
endif
|
||||||
|
call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
! increment the alpha/alpha part for single excitations
|
||||||
|
if (nkeys+4 * elec_alpha_num .ge. sze_buff ) then
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
endif
|
||||||
|
call orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
endif
|
||||||
|
|
||||||
|
enddo
|
||||||
|
|
||||||
|
|
||||||
|
! Compute Hij for all alpha doubles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
if(alpha_alpha.or.spin_trace)then
|
||||||
|
do i=1,n_doubles
|
||||||
|
l_a = doubles(i)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
lrow = psi_bilinear_matrix_rows(l_a)
|
||||||
|
ASSERT (lrow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
c_average = 0.d0
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_average += c_1(l) * c_2(l) * state_weights(l)
|
||||||
|
enddo
|
||||||
|
if (nkeys+4 .ge. sze_buff) then
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
endif
|
||||||
|
call orb_range_off_diag_double_to_two_rdm_aa_dm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
! Single and double beta excitations
|
||||||
|
! ==================================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
spindet(1:$N_int) = tmp_det(1:$N_int,2)
|
||||||
|
|
||||||
|
! Initial determinant is at k_b in beta-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||||
|
ASSERT (k_b <= N_det)
|
||||||
|
|
||||||
|
! Loop inside the alpha row to gather all the connected betas
|
||||||
|
lrow = psi_bilinear_matrix_transp_rows(k_b)
|
||||||
|
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
|
||||||
|
do i=1,N_det_beta_unique
|
||||||
|
if (l_b > N_det) exit
|
||||||
|
lrow = psi_bilinear_matrix_transp_rows(l_b)
|
||||||
|
if (lrow /= krow) exit
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
|
||||||
|
idx(i) = l_b
|
||||||
|
l_b = l_b+1
|
||||||
|
enddo
|
||||||
|
i = i-1
|
||||||
|
|
||||||
|
call get_all_spin_singles_and_doubles_$N_int( &
|
||||||
|
buffer, idx, spindet, i, &
|
||||||
|
singles_b, doubles, n_singles_b, n_doubles )
|
||||||
|
|
||||||
|
! Compute Hij for all beta singles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
do i=1,n_singles_b
|
||||||
|
l_b = singles_b(i)
|
||||||
|
ASSERT (l_b <= N_det)
|
||||||
|
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
|
||||||
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
|
c_average = 0.d0
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_average += c_1(l) * c_2(l) * state_weights(l)
|
||||||
|
enddo
|
||||||
|
if(alpha_beta.or.spin_trace.or.beta_beta)then
|
||||||
|
! increment the alpha/beta part for single excitations
|
||||||
|
if (nkeys+2 * elec_alpha_num .ge. sze_buff ) then
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
endif
|
||||||
|
call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
! increment the beta /beta part for single excitations
|
||||||
|
if (nkeys+4 * elec_alpha_num .ge. sze_buff) then
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
endif
|
||||||
|
call orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
|
||||||
|
! Compute Hij for all beta doubles
|
||||||
|
! ----------------------------------
|
||||||
|
|
||||||
|
if(beta_beta.or.spin_trace)then
|
||||||
|
do i=1,n_doubles
|
||||||
|
l_b = doubles(i)
|
||||||
|
ASSERT (l_b <= N_det)
|
||||||
|
|
||||||
|
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||||
|
ASSERT (lcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||||
|
c_average = 0.d0
|
||||||
|
do l= 1, N_states
|
||||||
|
c_1(l) = u_t(l,l_a)
|
||||||
|
c_2(l) = u_t(l,k_a)
|
||||||
|
c_average += c_1(l) * c_2(l) * state_weights(l)
|
||||||
|
enddo
|
||||||
|
if (nkeys+4 .ge. sze_buff) then
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
endif
|
||||||
|
call orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
ASSERT (l_a <= N_det)
|
||||||
|
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
! Diagonal contribution
|
||||||
|
! =====================
|
||||||
|
|
||||||
|
|
||||||
|
! Initial determinant is at k_a in alpha-major representation
|
||||||
|
! -----------------------------------------------------------------------
|
||||||
|
|
||||||
|
krow = psi_bilinear_matrix_rows(k_a)
|
||||||
|
ASSERT (krow <= N_det_alpha_unique)
|
||||||
|
|
||||||
|
kcol = psi_bilinear_matrix_columns(k_a)
|
||||||
|
ASSERT (kcol <= N_det_beta_unique)
|
||||||
|
|
||||||
|
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||||
|
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||||
|
|
||||||
|
double precision, external :: diag_wee_mat_elem, diag_S_mat_elem
|
||||||
|
|
||||||
|
double precision :: c_1(N_states),c_2(N_states)
|
||||||
|
c_average = 0.d0
|
||||||
|
do l = 1, N_states
|
||||||
|
c_1(l) = u_t(l,k_a)
|
||||||
|
c_average += c_1(l) * c_1(l) * state_weights(l)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
call orb_range_diag_to_all_two_rdm_dm_buffer(tmp_det,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
nkeys = 0
|
||||||
|
|
||||||
|
end do
|
||||||
|
!$OMP END DO
|
||||||
|
deallocate(buffer, singles_a, singles_b, doubles, idx, keys, values)
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
SUBST [ N_int ]
|
||||||
|
|
||||||
|
1;;
|
||||||
|
2;;
|
||||||
|
3;;
|
||||||
|
4;;
|
||||||
|
N_int;;
|
||||||
|
|
||||||
|
END_TEMPLATE
|
||||||
|
|
||||||
|
|
||||||
|
subroutine update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm)
|
||||||
|
use omp_lib
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: nkeys,dim1
|
||||||
|
integer, intent(in) :: keys(4,nkeys)
|
||||||
|
double precision, intent(in) :: values(nkeys)
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
|
||||||
|
integer(omp_lock_kind),intent(inout):: lock_2rdm
|
||||||
|
integer :: i,h1,h2,p1,p2
|
||||||
|
call omp_set_lock(lock_2rdm)
|
||||||
|
do i = 1, nkeys
|
||||||
|
h1 = keys(1,i)
|
||||||
|
h2 = keys(2,i)
|
||||||
|
p1 = keys(3,i)
|
||||||
|
p2 = keys(4,i)
|
||||||
|
big_array(h1,h2,p1,p2) += values(i)
|
||||||
|
enddo
|
||||||
|
call omp_unset_lock(lock_2rdm)
|
||||||
|
|
||||||
|
end
|
||||||
|
|
269
src/two_body_rdm/routines_compute_2rdm.irp.f
Normal file
269
src/two_body_rdm/routines_compute_2rdm.irp.f
Normal file
@ -0,0 +1,269 @@
|
|||||||
|
|
||||||
|
|
||||||
|
subroutine diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the DIAGONAL PART of the alpha/beta two body rdm IN CHEMIST NOTATIONS
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2)
|
||||||
|
double precision, intent(in) :: c_1(N_states)
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate
|
||||||
|
double precision :: c_1_bis
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
do istate = 1, N_states
|
||||||
|
c_1_bis = c_1(istate) * c_1(istate)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(j,2)
|
||||||
|
big_array(h1,h1,h2,h2,istate) += c_1_bis
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the DIAGONAL PART of ALL THREE two body rdm IN CHEMIST NOTATIONS
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2)
|
||||||
|
double precision, intent(in) :: c_1(N_states)
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate
|
||||||
|
double precision :: c_1_bis
|
||||||
|
BEGIN_DOC
|
||||||
|
! no factor 1/2 have to be taken into account as the permutations are already taken into account
|
||||||
|
END_DOC
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
do istate = 1, N_states
|
||||||
|
c_1_bis = c_1(istate) * c_1(istate)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(j,2)
|
||||||
|
big_array_ab(h1,h1,h2,h2,istate) += c_1_bis
|
||||||
|
enddo
|
||||||
|
do j = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(j,1)
|
||||||
|
big_array_aa(h1,h1,h2,h2,istate) += 0.5d0 * c_1_bis
|
||||||
|
big_array_aa(h1,h2,h2,h1,istate) -= 0.5d0 * c_1_bis
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h1 = occ(i,2)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(j,2)
|
||||||
|
big_array_bb(h1,h1,h2,h2,istate) += 0.5d0 * c_1_bis
|
||||||
|
big_array_bb(h1,h2,h2,h1,istate) -= 0.5d0 * c_1_bis
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for DOUBLE EXCITATIONS IN CHEMIST NOTATIONS
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
double precision, intent(in) :: c_1(N_states),c_2(N_states)
|
||||||
|
integer :: i,j,h1,h2,p1,p2,istate
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
call get_double_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
h2 = exc(1,1,2)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
p2 = exc(1,2,2)
|
||||||
|
do istate = 1, N_states
|
||||||
|
big_array(h1,p1,h2,p2,istate) += c_1(istate) * phase * c_2(istate)
|
||||||
|
! big_array(p1,h1,p2,h2,istate) += c_1(istate) * phase * c_2(istate)
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
double precision, intent(in) :: c_1(N_states),c_2(N_states)
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
do istate = 1, N_states
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(i,2)
|
||||||
|
big_array(h1,p1,h2,h2,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
do istate = 1, N_states
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(i,1)
|
||||||
|
big_array(h2,h2,h1,p1,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS
|
||||||
|
END_DOC
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
double precision, intent(in) :: c_1(N_states),c_2(N_states)
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
do istate = 1, N_states
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(i,1)
|
||||||
|
big_array(h1,p1,h2,h2,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase
|
||||||
|
big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase
|
||||||
|
|
||||||
|
big_array(h2,h2,h1,p1,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase
|
||||||
|
big_array(h2,p1,h1,h2,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
double precision, intent(in) :: c_1(N_states),c_2(N_states)
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
return
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
do istate = 1, N_states
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(i,2)
|
||||||
|
big_array(h1,p1,h2,h2,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase
|
||||||
|
big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase
|
||||||
|
|
||||||
|
big_array(h2,h2,h1,p1,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase
|
||||||
|
big_array(h2,p1,h1,h2,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for DOUBLE EXCITATIONS IN CHEMIST NOTATIONS
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
|
||||||
|
double precision, intent(in) :: c_1(N_states),c_2(N_states)
|
||||||
|
integer :: i,j,h1,h2,p1,p2,istate
|
||||||
|
integer :: exc(0:2,2)
|
||||||
|
double precision :: phase
|
||||||
|
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 =exc(1,1)
|
||||||
|
h2 =exc(2,1)
|
||||||
|
p1 =exc(1,2)
|
||||||
|
p2 =exc(2,2)
|
||||||
|
!print*,'h1,p1,h2,p2',h1,p1,h2,p2,c_1(istate) * phase * c_2(istate)
|
||||||
|
do istate = 1, N_states
|
||||||
|
big_array(h1,p1,h2,p2,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate)
|
||||||
|
big_array(h1,p2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate)
|
||||||
|
|
||||||
|
big_array(h2,p2,h1,p1,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate)
|
||||||
|
big_array(h2,p1,h1,p2,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate)
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for DOUBLE EXCITATIONS
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,dim2,dim3,dim4
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
|
||||||
|
double precision, intent(in) :: c_1(N_states),c_2(N_states)
|
||||||
|
integer :: i,j,h1,h2,p1,p2,istate
|
||||||
|
integer :: exc(0:2,2)
|
||||||
|
double precision :: phase
|
||||||
|
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 =exc(1,1)
|
||||||
|
h2 =exc(2,1)
|
||||||
|
p1 =exc(1,2)
|
||||||
|
p2 =exc(2,2)
|
||||||
|
!print*,'h1,p1,h2,p2',h1,p1,h2,p2,c_1(istate) * phase * c_2(istate)
|
||||||
|
do istate = 1, N_states
|
||||||
|
big_array(h1,p1,h2,p2,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate)
|
||||||
|
big_array(h1,p2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate)
|
||||||
|
|
||||||
|
big_array(h2,p2,h1,p1,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate)
|
||||||
|
big_array(h2,p1,h1,p2,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate)
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
660
src/two_body_rdm/routines_compute_2rdm_all_states.irp.f
Normal file
660
src/two_body_rdm/routines_compute_2rdm_all_states.irp.f
Normal file
@ -0,0 +1,660 @@
|
|||||||
|
|
||||||
|
subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm_all_states(det_1,c_1,N_st,big_array,dim1,orb_bitmask)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,N_st
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
double precision, intent(in) :: c_1(N_st)
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
do istate = 1, N_st
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(j,2)
|
||||||
|
big_array(h1,h2,h1,h2,istate) += c_1(istate)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm_all_states(det_1,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,N_st,ispin
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
double precision, intent(in) :: c_1(N_st)
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate
|
||||||
|
integer(bit_kind) :: det_1_act(N_int,2)
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
do i = 1, N_int
|
||||||
|
det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i))
|
||||||
|
det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i))
|
||||||
|
enddo
|
||||||
|
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int)
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
integer :: i1,i2
|
||||||
|
if(alpha_beta)then
|
||||||
|
do istate = 1, N_st
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
i1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
i2 = occ(j,2)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
big_array(h1,h2,h1,h2,istate) += c_1(istate)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else if (alpha_alpha)then
|
||||||
|
do istate = 1, N_st
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
i1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(1)
|
||||||
|
i2 = occ(j,1)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate)
|
||||||
|
big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else if (beta_beta)then
|
||||||
|
do istate = 1, N_st
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
i1 = occ(i,2)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
i2 = occ(j,2)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate)
|
||||||
|
big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else if(spin_trace)then
|
||||||
|
! 0.5 * (alpha beta + beta alpha)
|
||||||
|
do istate = 1, N_st
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
i1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
i2 = occ(j,2)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate)
|
||||||
|
big_array(h2,h1,h2,h1,istate) += 0.5d0 * c_1(istate)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
i1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(1)
|
||||||
|
i2 = occ(j,1)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate)
|
||||||
|
big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
i1 = occ(i,2)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
i2 = occ(j,2)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate)
|
||||||
|
big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 3 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,N_st,ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1(N_st)
|
||||||
|
integer :: i,j,h1,h2,p1,p2,istate
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
call get_double_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
h2 = exc(1,1,2)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
p2 = exc(1,2,2)
|
||||||
|
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
|
||||||
|
p2 = list_orb_reverse(p2)
|
||||||
|
do istate = 1, N_st
|
||||||
|
if(alpha_beta)then
|
||||||
|
big_array(h1,h2,p1,p2,istate) += c_1(istate) * phase
|
||||||
|
else if(spin_trace)then
|
||||||
|
big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate) * phase
|
||||||
|
big_array(p1,p2,h1,h2,istate) += 0.5d0 * c_1(istate) * phase
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 3 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,N_st,ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1(N_st)
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if(alpha_beta)then
|
||||||
|
do istate = 1, N_st
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(i,2)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
big_array(h1,h2,p1,h2,istate) += c_1(istate) * phase
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(i,1)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
big_array(h2,h1,h2,p1,istate) += c_1(istate) * phase
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
else if(spin_trace)then
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do istate = 1, N_st
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(i,2)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase
|
||||||
|
big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do istate = 1, N_st
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(i,1)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase
|
||||||
|
big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 1 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,N_st,ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1(N_st)
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if(alpha_alpha.or.spin_trace)then
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do istate = 1, N_st
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(i,1)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase
|
||||||
|
big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase
|
||||||
|
|
||||||
|
big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase
|
||||||
|
big_array(h2,h1,p1,h2,istate) -= 0.5d0 * c_1(istate) * phase
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 2 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,N_st,ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1(N_st)
|
||||||
|
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,istate,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if(beta_beta.or.spin_trace)then
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
return
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do istate = 1, N_st
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(i,2)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase
|
||||||
|
big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase
|
||||||
|
|
||||||
|
big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase
|
||||||
|
big_array(h2,h1,p1,h2,istate) -= 0.5d0 * c_1(istate) * phase
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 1 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,N_st,ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1(N_st)
|
||||||
|
|
||||||
|
integer :: i,j,h1,h2,p1,p2,istate
|
||||||
|
integer :: exc(0:2,2)
|
||||||
|
double precision :: phase
|
||||||
|
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 =exc(1,1)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
h2 =exc(2,1)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
p1 =exc(1,2)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
p2 =exc(2,2)
|
||||||
|
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
|
||||||
|
p2 = list_orb_reverse(p2)
|
||||||
|
if(alpha_alpha.or.spin_trace)then
|
||||||
|
do istate = 1, N_st
|
||||||
|
big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate) * phase
|
||||||
|
big_array(h1,h2,p2,p1,istate) -= 0.5d0 * c_1(istate) * phase
|
||||||
|
|
||||||
|
big_array(h2,h1,p2,p1,istate) += 0.5d0 * c_1(istate) * phase
|
||||||
|
big_array(h2,h1,p1,p2,istate) -= 0.5d0 * c_1(istate) * phase
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 2 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: dim1,N_st,ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1(N_st)
|
||||||
|
|
||||||
|
integer :: i,j,h1,h2,p1,p2,istate
|
||||||
|
integer :: exc(0:2,2)
|
||||||
|
double precision :: phase
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
|
||||||
|
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 =exc(1,1)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
h2 =exc(2,1)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
p1 =exc(1,2)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
p2 =exc(2,2)
|
||||||
|
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
|
||||||
|
p2 = list_orb_reverse(p2)
|
||||||
|
do istate = 1, N_st
|
||||||
|
if(beta_beta.or.spin_trace)then
|
||||||
|
big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate)* phase
|
||||||
|
big_array(h1,h2,p2,p1,istate) -= 0.5d0 * c_1(istate)* phase
|
||||||
|
|
||||||
|
big_array(h2,h1,p2,p1,istate) += 0.5d0 * c_1(istate)* phase
|
||||||
|
big_array(h2,h1,p1,p2,istate) -= 0.5d0 * c_1(istate)* phase
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
670
src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f
Normal file
670
src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f
Normal file
@ -0,0 +1,670 @@
|
|||||||
|
|
||||||
|
subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,orb_bitmask)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(j,2)
|
||||||
|
big_array(h1,h2,h1,h2) += c_1
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,ispin
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2
|
||||||
|
integer(bit_kind) :: det_1_act(N_int,2)
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
do i = 1, N_int
|
||||||
|
det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i))
|
||||||
|
det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i))
|
||||||
|
enddo
|
||||||
|
|
||||||
|
!print*,'ahah'
|
||||||
|
!call debug_det(det_1_act,N_int)
|
||||||
|
!pause
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
BEGIN_DOC
|
||||||
|
! no factor 1/2 have to be taken into account as the permutations are already taken into account
|
||||||
|
END_DOC
|
||||||
|
call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int)
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
integer :: i1,i2
|
||||||
|
if(alpha_beta)then
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
i1 = occ(i,1)
|
||||||
|
! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle
|
||||||
|
i2 = occ(j,2)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
big_array(h1,h2,h1,h2) += c_1
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else if (alpha_alpha)then
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
i1 = occ(i,1)
|
||||||
|
! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle
|
||||||
|
do j = 1, n_occ_ab(1)
|
||||||
|
i2 = occ(j,1)
|
||||||
|
! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
big_array(h1,h2,h1,h2) += 0.5d0 * c_1
|
||||||
|
big_array(h1,h2,h2,h1) -= 0.5d0 * c_1
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else if (beta_beta)then
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
i1 = occ(i,2)
|
||||||
|
! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
i2 = occ(j,2)
|
||||||
|
! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
big_array(h1,h2,h1,h2) += 0.5d0 * c_1
|
||||||
|
big_array(h1,h2,h2,h1) -= 0.5d0 * c_1
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else if(spin_trace)then
|
||||||
|
! 0.5 * (alpha beta + beta alpha)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
i1 = occ(i,1)
|
||||||
|
! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
i2 = occ(j,2)
|
||||||
|
! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
big_array(h1,h2,h1,h2) += 0.5d0 * (c_1 )
|
||||||
|
big_array(h2,h1,h2,h1) += 0.5d0 * (c_1 )
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!stop
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
i1 = occ(i,1)
|
||||||
|
! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle
|
||||||
|
do j = 1, n_occ_ab(1)
|
||||||
|
i2 = occ(j,1)
|
||||||
|
! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
big_array(h1,h2,h1,h2) += 0.5d0 * c_1
|
||||||
|
big_array(h1,h2,h2,h1) -= 0.5d0 * c_1
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
i1 = occ(i,2)
|
||||||
|
! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
i2 = occ(j,2)
|
||||||
|
! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
big_array(h1,h2,h1,h2) += 0.5d0 * c_1
|
||||||
|
big_array(h1,h2,h2,h1) -= 0.5d0 * c_1
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 3 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
integer :: i,j,h1,h2,p1,p2
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
!print*,''
|
||||||
|
!do i = 1, mo_num
|
||||||
|
! print*,'list_orb',i,list_orb_reverse(i)
|
||||||
|
!enddo
|
||||||
|
call get_double_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
!print*,'h1',h1
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
!print*,'passed h1 = ',h1
|
||||||
|
h2 = exc(1,1,2)
|
||||||
|
!print*,'h2',h2
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
!print*,'passed h2 = ',h2
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
!print*,'p1',p1
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
!print*,'passed p1 = ',p1
|
||||||
|
p2 = exc(1,2,2)
|
||||||
|
!print*,'p2',p2
|
||||||
|
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
|
||||||
|
p2 = list_orb_reverse(p2)
|
||||||
|
!print*,'passed p2 = ',p2
|
||||||
|
if(alpha_beta)then
|
||||||
|
big_array(h1,h2,p1,p2) += c_1 * phase
|
||||||
|
else if(spin_trace)then
|
||||||
|
big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase
|
||||||
|
big_array(p1,p2,h1,h2) += 0.5d0 * c_1 * phase
|
||||||
|
!print*,'h1,h2,p1,p2',h1,h2,p1,p2
|
||||||
|
!print*,'',big_array(h1,h2,p1,p2)
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 3 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if(alpha_beta)then
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(i,2)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
big_array(h1,h2,p1,h2) += c_1 * phase
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(i,1)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
big_array(h2,h1,h2,p1) += c_1 * phase
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
else if(spin_trace)then
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(i,2)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
|
||||||
|
big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(i,1)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
|
||||||
|
big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 1 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if(alpha_alpha.or.spin_trace)then
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(i,1)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
|
||||||
|
big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase
|
||||||
|
|
||||||
|
big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
|
||||||
|
big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 2 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if(beta_beta.or.spin_trace)then
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
return
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(i,2)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase
|
||||||
|
big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase
|
||||||
|
|
||||||
|
big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase
|
||||||
|
big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 1 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: dim1,ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
|
||||||
|
integer :: i,j,h1,h2,p1,p2
|
||||||
|
integer :: exc(0:2,2)
|
||||||
|
double precision :: phase
|
||||||
|
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 =exc(1,1)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
h2 =exc(2,1)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
p1 =exc(1,2)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
p2 =exc(2,2)
|
||||||
|
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
|
||||||
|
p2 = list_orb_reverse(p2)
|
||||||
|
if(alpha_alpha.or.spin_trace)then
|
||||||
|
big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase
|
||||||
|
big_array(h1,h2,p2,p1) -= 0.5d0 * c_1 * phase
|
||||||
|
|
||||||
|
big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase
|
||||||
|
big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 2 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: dim1,ispin
|
||||||
|
double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
|
||||||
|
integer :: i,j,h1,h2,p1,p2
|
||||||
|
integer :: exc(0:2,2)
|
||||||
|
double precision :: phase
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
|
||||||
|
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 =exc(1,1)
|
||||||
|
if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
h2 =exc(2,1)
|
||||||
|
if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
p1 =exc(1,2)
|
||||||
|
if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
p2 =exc(2,2)
|
||||||
|
if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return
|
||||||
|
p2 = list_orb_reverse(p2)
|
||||||
|
if(beta_beta.or.spin_trace)then
|
||||||
|
big_array(h1,h2,p1,p2) += 0.5d0 * c_1* phase
|
||||||
|
big_array(h1,h2,p2,p1) -= 0.5d0 * c_1* phase
|
||||||
|
|
||||||
|
big_array(h2,h1,p2,p1) += 0.5d0 * c_1* phase
|
||||||
|
big_array(h2,h1,p1,p2) -= 0.5d0 * c_1* phase
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
807
src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f
Normal file
807
src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f
Normal file
@ -0,0 +1,807 @@
|
|||||||
|
subroutine orb_range_diag_to_all_two_rdm_dm_buffer(det_1,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: ispin,sze_buff
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2)
|
||||||
|
integer(bit_kind), intent(in) :: orb_bitmask(N_int)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
double precision, intent(out) :: values(sze_buff)
|
||||||
|
integer , intent(out) :: keys(4,sze_buff)
|
||||||
|
integer , intent(inout):: nkeys
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2
|
||||||
|
integer(bit_kind) :: det_1_act(N_int,2)
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
do i = 1, N_int
|
||||||
|
det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i))
|
||||||
|
det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i))
|
||||||
|
enddo
|
||||||
|
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int)
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
integer :: i1,i2
|
||||||
|
if(alpha_beta)then
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
i1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
i2 = occ(j,2)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = c_1
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = h1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else if (alpha_alpha)then
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
i1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(1)
|
||||||
|
i2 = occ(j,1)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = h1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = -0.5d0 * c_1
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = h2
|
||||||
|
keys(4,nkeys) = h1
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else if (beta_beta)then
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
i1 = occ(i,2)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
i2 = occ(j,2)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = h1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = -0.5d0 * c_1
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = h2
|
||||||
|
keys(4,nkeys) = h1
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
else if(spin_trace)then
|
||||||
|
! 0.5 * (alpha beta + beta alpha)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
i1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
i2 = occ(j,2)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = h1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = h2
|
||||||
|
keys(4,nkeys) = h1
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
i1 = occ(i,1)
|
||||||
|
do j = 1, n_occ_ab(1)
|
||||||
|
i2 = occ(j,1)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = h1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = -0.5d0 * c_1
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = h2
|
||||||
|
keys(4,nkeys) = h1
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
i1 = occ(i,2)
|
||||||
|
do j = 1, n_occ_ab(2)
|
||||||
|
i2 = occ(j,2)
|
||||||
|
h1 = list_orb_reverse(i1)
|
||||||
|
h2 = list_orb_reverse(i2)
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = h1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = -0.5d0 * c_1
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = h2
|
||||||
|
keys(4,nkeys) = h1
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine orb_range_off_diag_double_to_two_rdm_ab_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 3 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: ispin,sze_buff
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
double precision, intent(out) :: values(sze_buff)
|
||||||
|
integer , intent(out) :: keys(4,sze_buff)
|
||||||
|
integer , intent(inout):: nkeys
|
||||||
|
integer :: i,j,h1,h2,p1,p2
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
call get_double_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
if(list_orb_reverse(h1).lt.0)return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
h2 = exc(1,1,2)
|
||||||
|
if(list_orb_reverse(h2).lt.0)return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
if(list_orb_reverse(p1).lt.0)return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
p2 = exc(1,2,2)
|
||||||
|
if(list_orb_reverse(p2).lt.0)return
|
||||||
|
p2 = list_orb_reverse(p2)
|
||||||
|
if(alpha_beta)then
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = p2
|
||||||
|
else if(spin_trace)then
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = p2
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = p1
|
||||||
|
keys(2,nkeys) = p2
|
||||||
|
keys(3,nkeys) = h1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 3 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: ispin,sze_buff
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
double precision, intent(out) :: values(sze_buff)
|
||||||
|
integer , intent(out) :: keys(4,sze_buff)
|
||||||
|
integer , intent(inout):: nkeys
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if(alpha_beta)then
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
if(list_orb_reverse(h1).lt.0)return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
if(list_orb_reverse(p1).lt.0)return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(i,2)
|
||||||
|
if(list_orb_reverse(h2).lt.0)return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
if(list_orb_reverse(h1).lt.0)return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
if(list_orb_reverse(p1).lt.0)return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(i,1)
|
||||||
|
if(list_orb_reverse(h2).lt.0)return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
else if(spin_trace)then
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
if(list_orb_reverse(h1).lt.0)return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
if(list_orb_reverse(p1).lt.0)return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(i,2)
|
||||||
|
if(list_orb_reverse(h2).lt.0)return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = h2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
if(list_orb_reverse(h1).lt.0)return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
if(list_orb_reverse(p1).lt.0)return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
!print*,'****************'
|
||||||
|
!print*,'****************'
|
||||||
|
!print*,'h1,p1',h1,p1
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(i,1)
|
||||||
|
if(list_orb_reverse(h2).lt.0)return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
! print*,'h2 = ',h2
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = h2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 1 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: ispin,sze_buff
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
double precision, intent(out) :: values(sze_buff)
|
||||||
|
integer , intent(out) :: keys(4,sze_buff)
|
||||||
|
integer , intent(inout):: nkeys
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if(alpha_alpha.or.spin_trace)then
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
! Mono alpha
|
||||||
|
h1 = exc(1,1,1)
|
||||||
|
if(list_orb_reverse(h1).lt.0)return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,1)
|
||||||
|
if(list_orb_reverse(p1).lt.0)return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(1)
|
||||||
|
h2 = occ(i,1)
|
||||||
|
if(list_orb_reverse(h2).lt.0)return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = - 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = h2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = h2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = - 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
enddo
|
||||||
|
else
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 2 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: ispin,sze_buff
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
double precision, intent(out) :: values(sze_buff)
|
||||||
|
integer , intent(out) :: keys(4,sze_buff)
|
||||||
|
integer , intent(inout):: nkeys
|
||||||
|
|
||||||
|
integer :: occ(N_int*bit_kind_size,2)
|
||||||
|
integer :: n_occ_ab(2)
|
||||||
|
integer :: i,j,h1,h2,p1
|
||||||
|
integer :: exc(0:2,2,2)
|
||||||
|
double precision :: phase
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
|
||||||
|
call get_single_excitation(det_1,det_2,exc,phase,N_int)
|
||||||
|
if(beta_beta.or.spin_trace)then
|
||||||
|
if (exc(0,1,1) == 1) then
|
||||||
|
return
|
||||||
|
else
|
||||||
|
! Mono beta
|
||||||
|
h1 = exc(1,1,2)
|
||||||
|
if(list_orb_reverse(h1).lt.0)return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
p1 = exc(1,2,2)
|
||||||
|
if(list_orb_reverse(p1).lt.0)return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
do i = 1, n_occ_ab(2)
|
||||||
|
h2 = occ(i,2)
|
||||||
|
if(list_orb_reverse(h2).lt.0)return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = - 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = h2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = h2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = - 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = h2
|
||||||
|
enddo
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine orb_range_off_diag_double_to_two_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 1 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: ispin,sze_buff
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
double precision, intent(out) :: values(sze_buff)
|
||||||
|
integer , intent(out) :: keys(4,sze_buff)
|
||||||
|
integer , intent(inout):: nkeys
|
||||||
|
|
||||||
|
|
||||||
|
integer :: i,j,h1,h2,p1,p2
|
||||||
|
integer :: exc(0:2,2)
|
||||||
|
double precision :: phase
|
||||||
|
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 =exc(1,1)
|
||||||
|
if(list_orb_reverse(h1).lt.0)return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
h2 =exc(2,1)
|
||||||
|
if(list_orb_reverse(h2).lt.0)return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
p1 =exc(1,2)
|
||||||
|
if(list_orb_reverse(p1).lt.0)return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
p2 =exc(2,2)
|
||||||
|
if(list_orb_reverse(p2).lt.0)return
|
||||||
|
p2 = list_orb_reverse(p2)
|
||||||
|
if(alpha_alpha.or.spin_trace)then
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = p2
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = - 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = p2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = - 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = p2
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
||||||
|
subroutine orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
|
||||||
|
use bitmasks
|
||||||
|
BEGIN_DOC
|
||||||
|
! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for
|
||||||
|
!
|
||||||
|
! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another
|
||||||
|
!
|
||||||
|
! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
|
||||||
|
!
|
||||||
|
! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation
|
||||||
|
!
|
||||||
|
! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
|
||||||
|
!
|
||||||
|
! ispin determines which spin-spin component of the two-rdm you will update
|
||||||
|
!
|
||||||
|
! ispin == 1 :: alpha/ alpha
|
||||||
|
! ispin == 2 :: beta / beta
|
||||||
|
! ispin == 3 :: alpha/ beta
|
||||||
|
! ispin == 4 :: spin traced <=> total two-rdm
|
||||||
|
!
|
||||||
|
! here, only ispin == 2 or 4 will do something
|
||||||
|
END_DOC
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: ispin,sze_buff
|
||||||
|
integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
|
||||||
|
integer, intent(in) :: list_orb_reverse(mo_num)
|
||||||
|
double precision, intent(in) :: c_1
|
||||||
|
double precision, intent(out) :: values(sze_buff)
|
||||||
|
integer , intent(out) :: keys(4,sze_buff)
|
||||||
|
integer , intent(inout):: nkeys
|
||||||
|
|
||||||
|
integer :: i,j,h1,h2,p1,p2
|
||||||
|
integer :: exc(0:2,2)
|
||||||
|
double precision :: phase
|
||||||
|
logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
|
||||||
|
logical :: is_integer_in_string
|
||||||
|
alpha_alpha = .False.
|
||||||
|
beta_beta = .False.
|
||||||
|
alpha_beta = .False.
|
||||||
|
spin_trace = .False.
|
||||||
|
if( ispin == 1)then
|
||||||
|
alpha_alpha = .True.
|
||||||
|
else if(ispin == 2)then
|
||||||
|
beta_beta = .True.
|
||||||
|
else if(ispin == 3)then
|
||||||
|
alpha_beta = .True.
|
||||||
|
else if(ispin == 4)then
|
||||||
|
spin_trace = .True.
|
||||||
|
endif
|
||||||
|
|
||||||
|
call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
|
||||||
|
h1 =exc(1,1)
|
||||||
|
if(list_orb_reverse(h1).lt.0)return
|
||||||
|
h1 = list_orb_reverse(h1)
|
||||||
|
h2 =exc(2,1)
|
||||||
|
if(list_orb_reverse(h2).lt.0)return
|
||||||
|
h2 = list_orb_reverse(h2)
|
||||||
|
p1 =exc(1,2)
|
||||||
|
if(list_orb_reverse(p1).lt.0)return
|
||||||
|
p1 = list_orb_reverse(p1)
|
||||||
|
p2 =exc(2,2)
|
||||||
|
if(list_orb_reverse(p2).lt.0)return
|
||||||
|
p2 = list_orb_reverse(p2)
|
||||||
|
if(beta_beta.or.spin_trace)then
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = p2
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = - 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h1
|
||||||
|
keys(2,nkeys) = h2
|
||||||
|
keys(3,nkeys) = p2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = p2
|
||||||
|
keys(4,nkeys) = p1
|
||||||
|
|
||||||
|
nkeys += 1
|
||||||
|
values(nkeys) = - 0.5d0 * c_1 * phase
|
||||||
|
keys(1,nkeys) = h2
|
||||||
|
keys(2,nkeys) = h1
|
||||||
|
keys(3,nkeys) = p1
|
||||||
|
keys(4,nkeys) = p2
|
||||||
|
endif
|
||||||
|
end
|
||||||
|
|
62
src/two_body_rdm/two_rdm.irp.f
Normal file
62
src/two_body_rdm/two_rdm.irp.f
Normal file
@ -0,0 +1,62 @@
|
|||||||
|
BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)]
|
||||||
|
&BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo, (mo_num,mo_num,mo_num,mo_num,N_states)]
|
||||||
|
&BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! two_rdm_alpha_beta(i,j,k,l) = <Psi| a^{dagger}_{j,alpha} a^{dagger}_{l,beta} a_{k,beta} a_{i,alpha} | Psi>
|
||||||
|
! 1 1 2 2 = chemist notations
|
||||||
|
! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
integer :: dim1,dim2,dim3,dim4
|
||||||
|
double precision :: cpu_0,cpu_1
|
||||||
|
dim1 = mo_num
|
||||||
|
dim2 = mo_num
|
||||||
|
dim3 = mo_num
|
||||||
|
dim4 = mo_num
|
||||||
|
two_rdm_alpha_beta_mo = 0.d0
|
||||||
|
two_rdm_alpha_alpha_mo= 0.d0
|
||||||
|
two_rdm_beta_beta_mo = 0.d0
|
||||||
|
print*,'providing two_rdm_alpha_beta ...'
|
||||||
|
call wall_time(cpu_0)
|
||||||
|
call all_two_rdm_dm_nstates(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1))
|
||||||
|
call wall_time(cpu_1)
|
||||||
|
print*,'two_rdm_alpha_beta provided in',dabs(cpu_1-cpu_0)
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)]
|
||||||
|
&BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)]
|
||||||
|
&BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)]
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! two_rdm_alpha_beta_mo_physicist,(i,j,k,l) = <Psi| a^{dagger}_{k,alpha} a^{dagger}_{l,beta} a_{j,beta} a_{i,alpha} | Psi>
|
||||||
|
! 1 2 1 2 = physicist notations
|
||||||
|
! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
integer :: i,j,k,l,istate
|
||||||
|
double precision :: cpu_0,cpu_1
|
||||||
|
two_rdm_alpha_beta_mo_physicist = 0.d0
|
||||||
|
print*,'providing two_rdm_alpha_beta_mo_physicist ...'
|
||||||
|
call wall_time(cpu_0)
|
||||||
|
do istate = 1, N_states
|
||||||
|
do i = 1, mo_num
|
||||||
|
do j = 1, mo_num
|
||||||
|
do k = 1, mo_num
|
||||||
|
do l = 1, mo_num
|
||||||
|
! 1 2 1 2 1 1 2 2
|
||||||
|
two_rdm_alpha_beta_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_beta_mo(i,l,j,k,istate)
|
||||||
|
two_rdm_alpha_alpha_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_alpha_mo(i,l,j,k,istate)
|
||||||
|
two_rdm_beta_beta_mo_physicist(l,k,i,j,istate) = two_rdm_beta_beta_mo(i,l,j,k,istate)
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
call wall_time(cpu_1)
|
||||||
|
print*,'two_rdm_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0)
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
Loading…
Reference in New Issue
Block a user