9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-04 02:48:24 +01:00
This commit is contained in:
Anthony Scemama 2019-06-25 16:46:14 +02:00
parent 328ab2dadf
commit 26be853c18
12 changed files with 2126 additions and 2220 deletions

View File

@ -1,104 +1,151 @@
! -*- F90 -*-
BEGIN_PROVIDER[real*8, bielec_PQxx, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)]
&BEGIN_PROVIDER[real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)]
BEGIN_DOC
! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active
! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active
! indices are unshifted orbital numbers
! all integrals are read from files
END_DOC
implicit none
integer :: i,j,p,q,indx,kk
real*8 :: hhh
logical :: lread
BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_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
double precision, allocatable :: integrals_array(:,:)
real*8 :: mo_two_e_integral
allocate(integrals_array(mo_num,mo_num))
bielec_PQxx = 0.d0
do i=1,n_core_orb
ii=list_core(i)
do j=i,n_core_orb
jj=list_core(j)
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map)
do p=1,mo_num
do q=1,mo_num
bielec_PQxx(p,q,i,j)=integrals_array(p,q)
bielec_PQxx(p,q,j,i)=integrals_array(p,q)
end do
end do
end do
do j=1,n_act_orb
jj=list_act(j)
j3=j+n_core_orb
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map)
do p=1,mo_num
do q=1,mo_num
bielec_PQxx(p,q,i,j3)=integrals_array(p,q)
bielec_PQxx(p,q,j3,i)=integrals_array(p,q)
end do
end do
end do
end do
do i=1,n_core_orb+n_act_orb
do j=1,n_core_orb+n_act_orb
do p=1,mo_num
do q=1,mo_num
bielec_PQxx(p,q,i,j)=0.D0
bielec_PxxQ(p,i,j,q)=0.D0
end do
end do
end do
end do
open(unit=12,form='formatted',status='old',file='bielec_PQxx.tmp')
lread=.true.
indx=0
do while (lread)
read(12,*,iostat=kk) p,q,i,j,hhh
if (kk.ne.0) then
lread=.false.
else
! stored with p.le.q, i.le.j
bielec_PQxx(p,q,i,j)=hhh
bielec_PQxx(q,p,i,j)=hhh
bielec_PQxx(q,p,j,i)=hhh
bielec_PQxx(p,q,j,i)=hhh
indx+=1
end if
end do
close(12)
write(6,*) ' read ',indx,' integrals PQxx into core '
open(unit=12,form='formatted',status='old',file='bielec_PxxQ.tmp')
lread=.true.
indx=0
do while (lread)
read(12,*,iostat=kk) p,i,j,q,hhh
if (kk.ne.0) then
lread=.false.
else
! stored with (ip).le.(jq)
bielec_PxxQ(p,i,j,q)=hhh
bielec_PxxQ(q,j,i,p)=hhh
indx+=1
end if
end do
write(6,*) ' read ',indx,' integrals PxxQ into core '
close(12)
write(6,*) ' provided integrals (PQ|xx) and (Px|xQ) '
! (ij|pq)
do i=1,n_act_orb
ii=list_act(i)
i3=i+n_core_orb
do j=i,n_act_orb
jj=list_act(j)
j3=j+n_core_orb
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map)
do p=1,mo_num
do q=1,mo_num
bielec_PQxx(p,q,i3,j3)=integrals_array(p,q)
bielec_PQxx(p,q,j3,i3)=integrals_array(p,q)
end do
end do
end do
end do
write(6,*) ' provided integrals (PQ|xx) '
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
! inegrals read from file
END_DOC
implicit none
integer :: i,j,k,p,t,u,v,kk,indx
real*8 :: hhh
logical :: lread
write(6,*) ' reading integrals bielecCI '
do i=1,n_act_orb
do j=1,n_act_orb
do k=1,n_act_orb
do p=1,mo_num
bielecCI(i,k,j,p)=0.D0
end do
end do
end do
end do
BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_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
allocate(integrals_array(mo_num,mo_num))
bielec_PxxQ = 0.d0
do i=1,n_core_orb
ii=list_core(i)
do j=i,n_core_orb
jj=list_core(j)
call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map)
do p=1,mo_num
do q=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_orb
call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map)
do p=1,mo_num
do q=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
open(unit=12,form='formatted',status='old',file='bielecCI.tmp')
lread=.true.
indx=0
do while (lread)
read(12,*,iostat=kk) i,j,k,p,hhh
if (kk.ne.0) then
lread=.false.
else
bielecCI(i,j,k,p)=hhh
bielecCI(j,i,k,p)=hhh
indx+=1
end if
end do
write(6,*) ' read ',indx,' integrals (aa|aP) into core '
close(12)
write(6,*) ' provided integrals (tu|xP) '
! (ip|qj)
do i=1,n_act_orb
ii=list_act(i)
i3=i+n_core_orb
do j=i,n_act_orb
jj=list_act(j)
j3=j+n_core_orb
call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map)
do p=1,mo_num
do q=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
write(6,*) ' provided integrals (Px|xQ) '
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, allocatable :: integrals_array(:)
real*8 :: mo_two_e_integral
allocate(integrals_array(mo_num))
do i=1,n_act_orb
t=list_act(i)
do j=1,n_act_orb
u=list_act(j)
do k=1,n_act_orb
v=list_act(k)
! (tu|vp)
call get_mo_two_e_integrals(t,u,v,mo_num,integrals_array,mo_integrals_map)
do p=1,mo_num
bielecCI(i,k,j,p)=integrals_array(p)
end do
end do
end do
end do
write(6,*) ' provided integrals (tu|xP) '
END_PROVIDER

View File

@ -1,118 +0,0 @@
! -*- F90 -*-
BEGIN_PROVIDER[real*8, bielec_PQxxtmp, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)]
&BEGIN_PROVIDER[real*8, bielec_PxxQtmp, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)]
&BEGIN_PROVIDER[integer, num_PQxx_written]
&BEGIN_PROVIDER[integer, num_PxxQ_written]
BEGIN_DOC
! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active
! 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_array1(:,:)
double precision, allocatable :: integrals_array2(:,:)
real*8 :: mo_two_e_integral
allocate(integrals_array1(mo_num,mo_num))
allocate(integrals_array2(mo_num,mo_num))
do i=1,n_core_orb+n_act_orb
do j=1,n_core_orb+n_act_orb
do p=1,mo_num
do q=1,mo_num
bielec_PQxxtmp(p,q,i,j)=0.D0
bielec_PxxQtmp(p,i,j,q)=0.D0
end do
end do
end do
end do
do i=1,n_core_orb
ii=list_core(i)
do j=i,n_core_orb
jj=list_core(j)
! (ij|pq)
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map)
! (ip|qj)
call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map)
do p=1,mo_num
do q=1,mo_num
bielec_PQxxtmp(p,q,i,j)=integrals_array1(p,q)
bielec_PQxxtmp(p,q,j,i)=integrals_array1(p,q)
bielec_PxxQtmp(p,i,j,q)=integrals_array2(p,q)
bielec_PxxQtmp(p,j,i,q)=integrals_array2(q,p)
end do
end do
end do
do j=1,n_act_orb
jj=list_act(j)
j3=j+n_core_orb
! (ij|pq)
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map)
! (ip|qj)
call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map)
do p=1,mo_num
do q=1,mo_num
bielec_PQxxtmp(p,q,i,j3)=integrals_array1(p,q)
bielec_PQxxtmp(p,q,j3,i)=integrals_array1(p,q)
bielec_PxxQtmp(p,i,j3,q)=integrals_array2(p,q)
bielec_PxxQtmp(p,j3,i,q)=integrals_array2(q,p)
end do
end do
end do
end do
do i=1,n_act_orb
ii=list_act(i)
i3=i+n_core_orb
do j=i,n_act_orb
jj=list_act(j)
j3=j+n_core_orb
! (ij|pq)
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map)
! (ip|qj)
call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map)
do p=1,mo_num
do q=1,mo_num
bielec_PQxxtmp(p,q,i3,j3)=integrals_array1(p,q)
bielec_PQxxtmp(p,q,j3,i3)=integrals_array1(p,q)
bielec_PxxQtmp(p,i3,j3,q)=integrals_array2(p,q)
bielec_PxxQtmp(p,j3,i3,q)=integrals_array2(q,p)
end do
end do
end do
end do
write(6,*) ' provided integrals (PQ|xx) '
write(6,*) ' provided integrals (Px|xQ) '
!!$ write(6,*) ' 1 1 1 2 = ',bielec_PQxxtmp(2,2,2,3),bielec_PxxQtmp(2,2,2,3)
END_PROVIDER
BEGIN_PROVIDER[real*8, bielecCItmp, (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, allocatable :: integrals_array1(:)
real*8 :: mo_two_e_integral
allocate(integrals_array1(mo_num))
do i=1,n_act_orb
t=list_act(i)
do j=1,n_act_orb
u=list_act(j)
do k=1,n_act_orb
v=list_act(k)
! (tu|vp)
call get_mo_two_e_integrals(t,u,v,mo_num,integrals_array1,mo_integrals_map)
do p=1,mo_num
bielecCItmp(i,k,j,p)=integrals_array1(p)
end do
end do
end do
end do
write(6,*) ' provided integrals (tu|xP) '
END_PROVIDER

View File

@ -0,0 +1,273 @@
BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_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,pp
real*8 :: d(n_act_orb)
bielec_PQxx_no(:,:,:,:) = bielec_PQxx(:,:,:,:)
do j=1,mo_num
do k=1,n_core_orb+n_act_orb
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielec_PQxx_no(list_act(q),j,k,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielec_PQxx_no(list_act(p),j,k,l)=d(p)
end do
end do
end do
end do
! 2nd quarter
do j=1,mo_num
do k=1,n_core_orb+n_act_orb
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielec_PQxx_no(j,list_act(q),k,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielec_PQxx_no(j,list_act(p),k,l)=d(p)
end do
end do
end do
end do
! 3rd quarter
do j=1,mo_num
do k=1,mo_num
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielec_PQxx_no(j,k,n_core_orb+q,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielec_PQxx_no(j,k,n_core_orb+p,l)=d(p)
end do
end do
end do
end do
! 4th quarter
do j=1,mo_num
do k=1,mo_num
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielec_PQxx_no(j,k,l,n_core_orb+q)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielec_PQxx_no(j,k,l,n_core_orb+p)=d(p)
end do
end do
end do
end do
write(6,*) ' transformed PQxx'
END_PROVIDER
BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_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,pp
real*8 :: d(n_act_orb)
bielec_PxxQ_no(:,:,:,:) = bielec_PxxQ(:,:,:,:)
do j=1,mo_num
do k=1,n_core_orb+n_act_orb
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielec_PxxQ_no(list_act(q),k,l,j)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielec_PxxQ_no(list_act(p),k,l,j)=d(p)
end do
end do
end do
end do
! 2nd quarter
do j=1,mo_num
do k=1,n_core_orb+n_act_orb
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielec_PxxQ_no(j,k,l,list_act(q))*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielec_PxxQ_no(j,k,l,list_act(p))=d(p)
end do
end do
end do
end do
! 3rd quarter
do j=1,mo_num
do k=1,mo_num
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielec_PxxQ_no(j,n_core_orb+q,l,k)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielec_PxxQ_no(j,n_core_orb+p,l,k)=d(p)
end do
end do
end do
end do
! 4th quarter
do j=1,mo_num
do k=1,mo_num
do l=1,n_core_orb+n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielec_PxxQ_no(j,l,n_core_orb+q,k)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielec_PxxQ_no(j,l,n_core_orb+p,k)=d(p)
end do
end do
end do
end do
write(6,*) ' transformed PxxQ '
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,pp
real*8 :: d(n_act_orb)
bielecCI_no(:,:,:,:) = bielecCI(:,:,:,:)
do j=1,n_act_orb
do k=1,n_act_orb
do l=1,mo_num
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielecCI_no(q,j,k,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielecCI_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,mo_num
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielecCI_no(j,q,k,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielecCI_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,mo_num
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielecCI_no(j,k,q,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielecCI_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
pp=n_act_orb-p+1
do q=1,n_act_orb
d(pp)+=bielecCI_no(j,k,l,list_act(q))*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
bielecCI_no(j,k,l,list_act(p))=d(p)
end do
end do
end do
end do
write(6,*) ' transformed tuvP '
END_PROVIDER

View File

@ -1,177 +1,216 @@
! -*- F90 -*-
use bitmasks ! you need to include the bitmasks_module.f90 features
use bitmasks
BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ]
&BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ]
BEGIN_DOC
! the first-order density matrix in the basis of the starting MOs
! the second-order density matrix in the basis of the starting MOs
! matrices 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>
!
END_DOC
implicit none
integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart
integer :: ierr
integer(bit_kind), allocatable :: det_mu(:,:)
integer(bit_kind), allocatable :: det_mu_ex(:,:)
integer(bit_kind), allocatable :: det_mu_ex1(:,:)
integer(bit_kind), allocatable :: det_mu_ex11(:,:)
integer(bit_kind), allocatable :: det_mu_ex12(:,:)
integer(bit_kind), allocatable :: det_mu_ex2(:,:)
integer(bit_kind), allocatable :: det_mu_ex21(:,:)
integer(bit_kind), allocatable :: det_mu_ex22(:,:)
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
allocate(det_mu(N_int,2))
allocate(det_mu_ex(N_int,2))
allocate(det_mu_ex1(N_int,2))
allocate(det_mu_ex11(N_int,2))
allocate(det_mu_ex12(N_int,2))
allocate(det_mu_ex2(N_int,2))
allocate(det_mu_ex21(N_int,2))
allocate(det_mu_ex22(N_int,2))
write(6,*) ' providing density matrices D0 and P0 '
! set all to zero
do t=1,n_act_orb
do u=1,n_act_orb
D0tu(u,t)=0.D0
do v=1,n_act_orb
do x=1,n_act_orb
P0tuvx(x,v,u,t)=0.D0
end do
end do
end do
end do
! first loop: we apply E_tu, once for D_tu, once for -P_tvvu
do mu=1,n_det
call det_extract(det_mu,mu,N_int)
do istate=1,n_states
cI_mu(istate)=psi_coef(mu,istate)
end do
do t=1,n_act_orb
ipart=list_act(t)
do u=1,n_act_orb
ihole=list_act(u)
! apply E_tu
call det_copy(det_mu,det_mu_ex1,N_int)
call det_copy(det_mu,det_mu_ex2,N_int)
call do_spinfree_mono_excitation(det_mu,det_mu_ex1 &
BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ]
BEGIN_DOC
! the first-order density matrix in the basis of the starting MOs
! matrices 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
!
END_DOC
implicit none
integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart
integer :: ierr
integer(bit_kind) :: det_mu(N_int,2)
integer(bit_kind) :: det_mu_ex(N_int,2)
integer(bit_kind) :: det_mu_ex1(N_int,2)
integer(bit_kind) :: det_mu_ex2(N_int,2)
real*8 :: phase1,phase2,term
integer :: nu1,nu2
integer :: ierr1,ierr2
real*8 :: cI_mu(N_states)
write(6,*) ' providing density matrices D0 and P0 '
D0tu = 0.d0
! first loop: we apply E_tu, once for D_tu, once for -P_tvvu
do mu=1,n_det
call det_extract(det_mu,mu,N_int)
do istate=1,n_states
cI_mu(istate)=psi_coef(mu,istate)
end do
do t=1,n_act_orb
ipart=list_act(t)
do u=1,n_act_orb
ihole=list_act(u)
! apply E_tu
call det_copy(det_mu,det_mu_ex1,N_int)
call det_copy(det_mu,det_mu_ex2,N_int)
call do_spinfree_mono_excitation(det_mu,det_mu_ex1 &
,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2)
! det_mu_ex1 is in the list
if (nu1.ne.-1) then
! det_mu_ex1 is in the list
if (nu1.ne.-1) then
do istate=1,n_states
term=cI_mu(istate)*psi_coef(nu1,istate)*phase1
D0tu(t,u)+=term
! and we fill P0_tvvu
do v=1,n_act_orb
P0tuvx(t,v,v,u)-=term
end do
term=cI_mu(istate)*psi_coef(nu1,istate)*phase1
D0tu(t,u)+=term
end do
end if
! det_mu_ex2 is in the list
if (nu2.ne.-1) then
end if
! det_mu_ex2 is in the list
if (nu2.ne.-1) then
do istate=1,n_states
term=cI_mu(istate)*psi_coef(nu2,istate)*phase2
D0tu(t,u)+=term
do v=1,n_act_orb
P0tuvx(t,v,v,u)-=term
end do
term=cI_mu(istate)*psi_coef(nu2,istate)*phase2
D0tu(t,u)+=term
end do
end if
end do
end do
end if
end do
! now we do the double excitation E_tu E_vx |0>
do mu=1,n_det
call det_extract(det_mu,mu,N_int)
do istate=1,n_states
cI_mu(istate)=psi_coef(mu,istate)
end do
do v=1,n_act_orb
ipart=list_act(v)
do x=1,n_act_orb
ihole=list_act(x)
! apply E_vx
call det_copy(det_mu,det_mu_ex1,N_int)
call det_copy(det_mu,det_mu_ex2,N_int)
call do_spinfree_mono_excitation(det_mu,det_mu_ex1 &
,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2)
! we apply E_tu to the first resultant determinant, thus E_tu E_vx |0>
if (ierr1.eq.1) then
do t=1,n_act_orb
jpart=list_act(t)
do u=1,n_act_orb
jhole=list_act(u)
call det_copy(det_mu_ex1,det_mu_ex11,N_int)
call det_copy(det_mu_ex1,det_mu_ex12,N_int)
call do_spinfree_mono_excitation(det_mu_ex1,det_mu_ex11 &
,det_mu_ex12,nu11,nu12,jhole,jpart,phase11,phase12,ierr11,ierr12)
if (nu11.ne.-1) then
do istate=1,n_states
P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu11,istate) &
*phase11*phase1
end do
end if
if (nu12.ne.-1) then
do istate=1,n_states
P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu12,istate) &
*phase12*phase1
end do
end if
end do
end do
end if
! we apply E_tu to the second resultant determinant
if (ierr2.eq.1) then
do t=1,n_act_orb
jpart=list_act(t)
do u=1,n_act_orb
jhole=list_act(u)
call det_copy(det_mu_ex2,det_mu_ex21,N_int)
call det_copy(det_mu_ex2,det_mu_ex22,N_int)
call do_spinfree_mono_excitation(det_mu_ex2,det_mu_ex21 &
,det_mu_ex22,nu21,nu22,jhole,jpart,phase21,phase22,ierr21,ierr22)
if (nu21.ne.-1) then
do istate=1,n_states
P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu21,istate) &
*phase21*phase2
end do
end if
if (nu22.ne.-1) then
do istate=1,n_states
P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu22,istate) &
*phase22*phase2
end do
end if
end do
end do
end if
end do
end do
end do
! we average by just dividing by the number of states
do x=1,n_act_orb
do v=1,n_act_orb
D0tu(v,x)*=1.0D0/dble(N_states)
do u=1,n_act_orb
do t=1,n_act_orb
P0tuvx(t,u,v,x)*=0.5D0/dble(N_states)
end do
end do
end do
end do
end do
end do
! we average by just dividing by the number of states
do x=1,n_act_orb
do v=1,n_act_orb
D0tu(v,x)*=1.0D0/dble(N_states)
end do
end do
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
! matrices 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>
!
END_DOC
implicit none
integer :: t,u,v,x,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
write(6,*) ' providing density matrices D0 and P0 '
P0tuvx = 0.d0
! first loop: we apply E_tu, once for D_tu, once for -P_tvvu
do mu=1,n_det
call det_extract(det_mu,mu,N_int)
do istate=1,n_states
cI_mu(istate)=psi_coef(mu,istate)
end do
do t=1,n_act_orb
ipart=list_act(t)
do u=1,n_act_orb
ihole=list_act(u)
! apply E_tu
call det_copy(det_mu,det_mu_ex1,N_int)
call det_copy(det_mu,det_mu_ex2,N_int)
call do_spinfree_mono_excitation(det_mu,det_mu_ex1 &
,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2)
! det_mu_ex1 is in the list
if (nu1.ne.-1) then
do istate=1,n_states
term=cI_mu(istate)*psi_coef(nu1,istate)*phase1
! and we fill P0_tvvu
do v=1,n_act_orb
P0tuvx(t,v,v,u)-=term
end do
end do
end if
! det_mu_ex2 is in the list
if (nu2.ne.-1) then
do istate=1,n_states
term=cI_mu(istate)*psi_coef(nu2,istate)*phase2
do v=1,n_act_orb
P0tuvx(t,v,v,u)-=term
end do
end do
end if
end do
end do
end do
! now we do the double excitation E_tu E_vx |0>
do mu=1,n_det
call det_extract(det_mu,mu,N_int)
do istate=1,n_states
cI_mu(istate)=psi_coef(mu,istate)
end do
do v=1,n_act_orb
ipart=list_act(v)
do x=1,n_act_orb
ihole=list_act(x)
! apply E_vx
call det_copy(det_mu,det_mu_ex1,N_int)
call det_copy(det_mu,det_mu_ex2,N_int)
call do_spinfree_mono_excitation(det_mu,det_mu_ex1 &
,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2)
! we apply E_tu to the first resultant determinant, thus E_tu E_vx |0>
if (ierr1.eq.1) then
do t=1,n_act_orb
jpart=list_act(t)
do u=1,n_act_orb
jhole=list_act(u)
call det_copy(det_mu_ex1,det_mu_ex11,N_int)
call det_copy(det_mu_ex1,det_mu_ex12,N_int)
call do_spinfree_mono_excitation(det_mu_ex1,det_mu_ex11&
,det_mu_ex12,nu11,nu12,jhole,jpart,phase11,phase12,ierr11,ierr12)
if (nu11.ne.-1) then
do istate=1,n_states
P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu11,istate)&
*phase11*phase1
end do
end if
if (nu12.ne.-1) then
do istate=1,n_states
P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu12,istate)&
*phase12*phase1
end do
end if
end do
end do
end if
! we apply E_tu to the second resultant determinant
if (ierr2.eq.1) then
do t=1,n_act_orb
jpart=list_act(t)
do u=1,n_act_orb
jhole=list_act(u)
call det_copy(det_mu_ex2,det_mu_ex21,N_int)
call det_copy(det_mu_ex2,det_mu_ex22,N_int)
call do_spinfree_mono_excitation(det_mu_ex2,det_mu_ex21&
,det_mu_ex22,nu21,nu22,jhole,jpart,phase21,phase22,ierr21,ierr22)
if (nu21.ne.-1) then
do istate=1,n_states
P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu21,istate)&
*phase21*phase2
end do
end if
if (nu22.ne.-1) then
do istate=1,n_states
P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu22,istate)&
*phase22*phase2
end do
end if
end do
end do
end if
end do
end do
end do
! we average by just dividing by the number of states
do x=1,n_act_orb
do v=1,n_act_orb
do u=1,n_act_orb
do t=1,n_act_orb
P0tuvx(t,u,v,x)*=0.5D0/dble(N_states)
end do
end do
end do
end do
END_PROVIDER

View File

@ -1,131 +1,130 @@
! -*- F90 -*-
use bitmasks ! you need to include the bitmasks_module.f90 features
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
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
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
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
! if (found) then
! if (nu.eq.-1) then
! write(6,*) ' image not found in the list, thus nu = ',nu
! else
! write(6,*) ' found in the list as No ',nu,' phase = ',phase
! end if
! end if
end if
!
! we found the new string, the phase, and possibly the number in the list
!
end subroutine do_signed_mono_excitation
end do
end if
end do
! if (found) then
! if (nu.eq.-1) then
! write(6,*) ' image not found in the list, thus nu = ',nu
! else
! write(6,*) ' found in the list as No ',nu,' phase = ',phase
! end if
! end if
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_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
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
end subroutine do_spinfree_mono_excitation
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

View File

@ -7,58 +7,13 @@
write(6,*) ' generating natural orbitals '
write(6,*)
write(6,*)
call trf_to_natorb
write(6,*) ' all data available ! '
write(6,*) ' writing out files '
open(unit=12,file='D0tu.dat',form='formatted',status='unknown')
do p=1,n_act_orb
do q=1,n_act_orb
if (abs(D0tu(p,q)).gt.1.D-12) then
write(12,'(2i8,E20.12)') p,q,D0tu(p,q)
end if
end do
end do
close(12)
call trf_to_natorb
real*8 :: approx,np,nq,nr,ns
logical :: lpq,lrs,lps,lqr
open(unit=12,file='P0tuvx.dat',form='formatted',status='unknown')
do p=1,n_act_orb
np=D0tu(p,p)
do q=1,n_act_orb
lpq=p.eq.q
nq=D0tu(q,q)
do r=1,n_act_orb
lqr=q.eq.r
nr=D0tu(r,r)
do s=1,n_act_orb
lrs=r.eq.s
lps=p.eq.s
approx=0.D0
if (lpq.and.lrs) then
if (lqr) then
! pppp
approx=0.5D0*np*(np-1.D0)
else
! pprr
approx=0.5D0*np*nr
end if