LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2025-01-02 16:45:38 +01:00
Code Releases Activity

Merge branch 'dev-lct' into master

Browse Source
This commit is contained in:
Anthony Scemama 2019-10-21 15:06:09 +02:00 committed by GitHub
commit af01bbe2d5
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
80 changed files with 10552 additions and 884 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
ocaml/qp_tunnel.ml
View File

@ -10,7 +10,6 @@ let localport = 42379
let in_time_sum = ref 1.e-9
and in_size_sum = ref 0.
let () =
let open Command_line in
begin

2
src/becke_numerical_grid/integration_radial.irp.f
View File

@ -64,7 +64,7 @@
enddo
! Ga-Kr
do i = 31, 36
do i = 31, 100
alpha_knowles(i) = 7.d0
enddo

39
src/bitmask/bitmasks.irp.f
View File

@ -443,15 +443,6 @@ BEGIN_PROVIDER [ integer(bit_kind), cas_bitmask, (N_int,2,N_cas_bitmask) ]
END_PROVIDER
BEGIN_PROVIDER [ integer, n_core_inact_orb ]
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
BEGIN_DOC
@ -465,6 +456,20 @@ END_PROVIDER
END_PROVIDER
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
BEGIN_DOC
@ -550,19 +555,3 @@ END_PROVIDER
enddo
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
src/bitmask/bitmasks_routines.irp.f
View File

@ -33,7 +33,7 @@ subroutine bitstring_to_list( string, list, n_elements, Nint)
use bitmasks
implicit none
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
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: string(Nint)
@ -213,3 +213,34 @@ subroutine print_spindet(string,Nint)
print *, trim(output(1))
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

483
src/bitmask/core_inact_act_virt.irp.f
View File

@ -1,246 +1,383 @@
use bitmasks
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
BEGIN_DOC
! inact_bitmask : Bitmask of the inactive orbitals which are supposed to be doubly excited
! 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
! Number of core MOs
END_DOC
logical :: exists
integer :: j,i
integer :: i
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
if(mo_class(i) == 'Core')then
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
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
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
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
endif
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')
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]
BEGIN_PROVIDER [ integer, n_core_inact_orb ]
implicit none
BEGIN_DOC
! dimensions for the allocation of list_inact, list_virt, list_core and list_act
! n_core + n_inact
END_DOC
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, n_inact_act_orb ]
implicit none
BEGIN_DOC
! n_inact + n_act
END_DOC
n_inact_act_orb = (n_inact_orb+n_act_orb)
END_PROVIDER
BEGIN_PROVIDER [integer, dim_list_core_orb]
implicit none
BEGIN_DOC
! dimensions for the allocation of list_core.
! it is at least 1
END_DOC
dim_list_core_orb = max(n_core_orb,1)
END_PROVIDER
BEGIN_PROVIDER [integer, dim_list_inact_orb]
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)
dim_list_virt_orb = max(n_virt_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
BEGIN_PROVIDER [ integer, list_inact, (dim_list_inact_orb)]
&BEGIN_PROVIDER [ integer, list_virt, (dim_list_virt_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, n_core_inact_act_orb ]
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)
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
! inact_bitmask : Bitmask of the inactive orbitals which are supposed to be doubly excited
! 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
! Bitmask identifying the core/inactive/active/virtual/deleted MOs
END_DOC
logical :: exists
integer :: j,i
integer :: n_core_orb_tmp, n_inact_orb_tmp, n_act_orb_tmp, n_virt_orb_tmp,n_del_orb_tmp
integer :: list_core_tmp(N_int*bit_kind_size)
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
if(n_core_orb.ne.0)then
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.ne.0)then
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.ne.0)then
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.ne.0)then
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.ne.0)then
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
BEGIN_PROVIDER [integer, n_inact_act_orb ]
BEGIN_PROVIDER [ integer, list_core , (dim_list_core_orb) ]
&BEGIN_PROVIDER [ integer, list_core_reverse, (mo_num) ]
implicit none
n_inact_act_orb = (n_inact_orb+n_act_orb)
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_act, (n_inact_act_orb)]
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
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
print *, 'Inactive MOs:'
print *, list_inact(1:n_inact_orb)
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
itmp = 0
do i = 1, n_inact_orb
itmp += 1
list_inact_act(itmp) = list_inact(i)
enddo
do i = 1, n_act_orb
itmp += 1
list_inact_act(itmp) = list_act(i)
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, n_core_inact_act_orb ]
implicit none
n_core_inact_act_orb = (n_core_orb + n_inact_orb + n_act_orb)
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)]
&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
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)
list_inact_reverse = 0
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(occ_inact(i)) = i
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
View 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
View File

@ -0,0 +1,4 @@
cipsi
selectors_full
generators_fluid
two_body_rdm

5
src/casscf/README.rst Normal file
View File

@ -0,0 +1,5 @@
======
casscf
======
|CASSCF| program with the CIPSI algorithm.

6
src/casscf/bavard.irp.f Normal file
View File

@ -0,0 +1,6 @@
! -*- F90 -*-
BEGIN_PROVIDER [logical, bavard]
! bavard=.true.
bavard=.false.
END_PROVIDER

155
src/casscf/bielec.irp.f Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View File

@ -0,0 +1,3 @@
subroutine driver_optorb
implicit none
end

57
src/casscf/get_energy.irp.f Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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

1
src/cipsi/NEED
View File

@ -3,3 +3,4 @@ zmq
mpi
davidson_undressed
iterations
two_body_rdm

1
src/cipsi/cipsi.irp.f
View File

@ -13,6 +13,7 @@ subroutine run_cipsi
rss = memory_of_double(N_states)*4.d0
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))
double precision :: hf_energy_ref

0
src/cipsi/lock_2rdm.irp.f Normal file
View File

183
src/cipsi/pert_rdm_providers.irp.f Normal file
View 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

13
src/cipsi/pt2_stoch_routines.irp.f
View File

@ -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
endif
if (N_det < max(4,N_states)) then
if (N_det <= max(4,N_states)) then
pt2=0.d0
variance=0.d0
norm=0.d0
@ -719,6 +719,15 @@ END_PROVIDER
double precision :: rss
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)
call check_mem(rss,irp_here)
@ -754,7 +763,7 @@ END_PROVIDER
end if
pt2_n_0(1) += 1
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 do
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

1
src/cipsi/run_selection_slave.irp.f
View File

@ -61,7 +61,6 @@ subroutine run_selection_slave(thread,iproc,energy)
! Only first time
bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2)
call create_selection_buffer(bsize, bsize*2, buf)
! call create_selection_buffer(N, N*2, buf2)
buffer_ready = .True.
else
ASSERT (N == buf%N)

32
src/cipsi/selection.irp.f
View File

@ -1,3 +1,4 @@
use bitmasks
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(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :)
logical, allocatable :: banned(:,:,:), bannedOrb(:,:)
double precision, allocatable :: coef_fullminilist_rev(:,:)
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)), &
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)
fullminilist(1:N_int,1:2,i) = psi_det_sorted(1:N_int,1:2,fullinteresting(i))
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)
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)
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
enddo
if(s1 /= s2) monoBdo = .false.
enddo
deallocate(fullminilist,minilist)
if(pert_2rdm)then
deallocate(coef_fullminilist_rev)
endif
enddo
enddo
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
logical, external :: detEq
double precision, allocatable :: values(:)
integer, allocatable :: keys(:,:)
integer :: nkeys
if(sp == 3) then
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
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
@ -735,7 +766,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
end do
end
subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting)
use bitmasks
implicit none

1
src/cipsi/stochastic_cipsi.irp.f
View File

@ -12,6 +12,7 @@ subroutine run_stochastic_cipsi
double precision, external :: memory_of_double
PROVIDE H_apply_buffer_allocated N_generators_bitmask
N_iter = 1
threshold_generators = 1.d0
SOFT_TOUCH threshold_generators

223
src/cipsi/update_2rdm.irp.f Normal file
View 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

32
src/cisd/cisd.irp.f
View File

@ -46,34 +46,6 @@ program cisd
END_DOC
read_wf = .False.
SOFT_TOUCH read_wf
call run
end
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)
call only_act_bitmask
call run_cisd
end

42
src/cisd/cisd_routine.irp.f Normal file
View 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

2
src/davidson/u0_wee_u0.irp.f
View File

@ -6,7 +6,7 @@ BEGIN_PROVIDER [ double precision, psi_energy_two_e, (N_states) ]
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)
do i=N_det+1,N_states
psi_energy(i) = 0.d0
psi_energy_two_e(i) = 0.d0
enddo
END_PROVIDER

23
src/density_for_dft/density_for_dft.irp.f
View File

@ -106,12 +106,31 @@ END_PROVIDER
BEGIN_PROVIDER [double precision, one_e_dm_average_mo_for_dft, (mo_num,mo_num)]
implicit none
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
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
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_beta_ao_for_dft, (ao_num,ao_num,N_states) ]
BEGIN_DOC

609
src/determinants/two_e_density_matrix.irp.pouet Normal file
View 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

2
src/dft_one_e/e_xc_general.irp.f
View File

@ -15,7 +15,7 @@ prefix = ""
for f in functionals:
print """
%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 "
print """
else

4
src/dft_one_e/pot_general.irp.f
View File

@ -17,8 +17,8 @@ prefix = ""
for f in functionals:
print """
%sif (trim(exchange_functional) == '%s') then
potential_x_alpha_ao = potential_x_alpha_ao_%s
potential_x_beta_ao = potential_x_beta_ao_%s"""%(prefix, f, f, f)
potential_x_alpha_ao = ( 1.d0 - HF_exchange ) * potential_x_alpha_ao_%s
potential_x_beta_ao = ( 1.d0 - HF_exchange ) * potential_x_beta_ao_%s"""%(prefix, f, f, f)
prefix = "else "
print """
else

1
src/dft_utils_in_r/mo_in_r.irp.f
View File

@ -32,6 +32,7 @@
! k = 1 : x, k= 2, y, k 3, z
END_DOC
integer :: m
print*,'mo_num,n_points_final_grid',mo_num,n_points_final_grid
mos_grad_in_r_array = 0.d0
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)

28
src/dft_utils_one_e/ec_lyp_2.irp.f Normal file
View 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

19
src/dft_utils_one_e/ec_scan.irp.f
View File

@ -38,6 +38,8 @@ double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2)
! correlation energy 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
rs = (cst_43 * pi * rho)**(-cst_13)
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
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)
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
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)
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
@ -98,3 +96,4 @@ double precision function beta_rs(rs)
beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs)
end

100
src/dft_utils_one_e/ec_scan_2.irp.f Normal file
View 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

2
src/fci/class.irp.f
View File

@ -1,10 +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 FCI case, all those are always false
END_DOC
do_only_1h1p = .False.
do_only_cas = .False.
do_ddci = .False.
END_PROVIDER

1
src/generators_cas/generators.irp.f
View File

@ -55,6 +55,7 @@ END_PROVIDER
nongen(inongen) = i
endif
enddo
ASSERT (m == 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, :)

1
src/generators_fluid/NEED Normal file
View File

@ -0,0 +1 @@
determinants

0
src/generators_fluid/README.rst Normal file
View File

23
src/generators_fluid/extract_cas.irp.f Normal file
View 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
View 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
View 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
View 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
View 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

21
src/mo_two_e_ints/EZFIO.cfg
View File

@ -11,24 +11,3 @@ interface: ezfio,provider,ocaml
default: 1.e-15
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
View 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

150
src/mo_two_e_ints/mo_bi_integrals.irp.f
View File

@ -22,16 +22,13 @@ end
BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ]
use map_module
implicit none
integer(bit_kind) :: mask_ijkl(N_int,4)
integer(bit_kind) :: mask_ijk(N_int,3)
BEGIN_DOC
! If True, the map of MO two-electron integrals is provided
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
mo_two_e_integrals_in_map = .True.
@ -49,106 +46,28 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ]
print *, '---------------------------------'
print *, ''
call wall_time(wall_1)
call cpu_time(cpu_1)
if(no_vvvv_integrals)then
integer :: i,j,k,l
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 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
call four_idx_novvvv
else
call add_integrals_to_map(full_ijkl_bitmask_4)
endif
! call four_index_transform_zmq(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_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)
call wall_time(wall_2)
call cpu_time(cpu_2)
integer*8 :: get_mo_map_size, mo_map_size
mo_map_size = get_mo_map_size()
print*,'Molecular integrals provided'
endif
double precision, external :: map_mb
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
call ezfio_set_work_empty(.False.)
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(key_kind),allocatable :: buffer_i(:)
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 :: 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,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 )
character*(2048) :: output(1)
print *, 'i'
call bitstring_to_str( output(1), mask_ijkl(1,1), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijkl(i,1))
@ -213,9 +128,6 @@ subroutine add_integrals_to_map(mask_ijkl)
return
endif
print*, 'j'
call bitstring_to_str( output(1), mask_ijkl(1,2), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijkl(i,2))
@ -224,9 +136,6 @@ subroutine add_integrals_to_map(mask_ijkl)
return
endif
print*, 'k'
call bitstring_to_str( output(1), mask_ijkl(1,3), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijkl(i,3))
@ -235,9 +144,6 @@ subroutine add_integrals_to_map(mask_ijkl)
return
endif
print*, 'l'
call bitstring_to_str( output(1), mask_ijkl(1,4), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijkl(i,4))
@ -247,14 +153,12 @@ subroutine add_integrals_to_map(mask_ijkl)
endif
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+&
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
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 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)
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
@ -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,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 )
character*(2048) :: output(1)
print*, 'i'
call bitstring_to_str( output(1), mask_ijk(1,1), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijk(i,1))
@ -516,9 +410,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk)
return
endif
print*, 'j'
call bitstring_to_str( output(1), mask_ijk(1,2), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijk(i,2))
@ -527,9 +418,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk)
return
endif
print*, 'k'
call bitstring_to_str( output(1), mask_ijk(1,3), N_int )
print *, trim(output(1))
j = 0
do i = 1, N_int
j += popcnt(mask_ijk(i,3))

53
src/nuclei/atomic_radii.irp.f
View File

@ -50,7 +50,58 @@ BEGIN_PROVIDER [ double precision, slater_bragg_radii, (0:100)]
slater_bragg_radii(33) = 1.15d0
slater_bragg_radii(34) = 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

17
src/selectors_full/selectors.irp.f
View File

@ -38,22 +38,6 @@ END_PROVIDER
END_DOC
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 k=1,N_int
psi_selectors(k,1,i) = psi_det_sorted(k,1,i)
@ -66,7 +50,6 @@ END_PROVIDER
enddo
enddo
! endif
END_PROVIDER

2
src/tools/print_wf.irp.f
View File

@ -51,7 +51,7 @@ subroutine routine
if(degree == 0)then
print*,'Reference determinant '
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,1),psi_det(1,1,i),N_int,hij)
delta_e = hii - h00

1
src/two_body_rdm/NEED Normal file
View File

@ -0,0 +1 @@
davidson_undressed

8
src/two_body_rdm/README.rst Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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