mirror of
https://github.com/pfloos/quack
synced 2024-11-20 04:52:42 +01:00
add S2
This commit is contained in:
parent
d738e335ba
commit
866ed94153
180
src/LR/S2_expval.f90
Normal file
180
src/LR/S2_expval.f90
Normal file
@ -0,0 +1,180 @@
|
||||
subroutine S2_expval(ispin,nBas,nC,nO,nV,nR,nS,nSa,nSb,nSt,maxS,c,S,Omega,XpY,XmY,S2)
|
||||
|
||||
! Compute <S**2> for linear response excited states
|
||||
|
||||
implicit none
|
||||
include 'parameters.h'
|
||||
|
||||
! Input variables
|
||||
|
||||
|
||||
integer,intent(in) :: ispin
|
||||
integer,intent(in) :: nBas
|
||||
integer,intent(in) :: nC(nspin)
|
||||
integer,intent(in) :: nO(nspin)
|
||||
integer,intent(in) :: nV(nspin)
|
||||
integer,intent(in) :: nR(nspin)
|
||||
integer,intent(in) :: nS(nspin)
|
||||
integer,intent(in) :: nSa
|
||||
integer,intent(in) :: nSb
|
||||
integer,intent(in) :: nSt
|
||||
integer,intent(in) :: maxS
|
||||
double precision,intent(in) :: c(nBas,nBas,nspin)
|
||||
double precision,intent(in) :: S(nBas,nBas)
|
||||
double precision,intent(in) :: Omega(nSt)
|
||||
double precision,intent(in) :: XpY(nSt,nSt)
|
||||
double precision,intent(in) :: XmY(nSt,nSt)
|
||||
|
||||
! Local variables
|
||||
|
||||
integer :: m
|
||||
integer :: ia,i,a
|
||||
double precision :: S2_exact
|
||||
double precision :: S2_gs
|
||||
double precision,allocatable :: Xa(:,:), Xb(:,:), Ya(:,:), Yb(:,:)
|
||||
double precision,allocatable :: Xat(:,:),Xbt(:,:),Yat(:,:),Ybt(:,:)
|
||||
double precision,allocatable :: OO(:,:), OV(:,:), VO(:,:), VV(:,:)
|
||||
double precision,allocatable :: OOt(:,:),OVt(:,:),VOt(:,:),VVt(:,:)
|
||||
double precision,external :: trace_matrix
|
||||
|
||||
! Output variables
|
||||
|
||||
double precision,intent(out) :: S2(maxS)
|
||||
|
||||
! Memory allocation
|
||||
|
||||
allocate(OO(nO(1)-nC(1),nO(2)-nC(2)), OV(nO(1)-nC(1),nV(2)-nR(2)), VO(nV(1)-nR(1),nO(2)-nC(2)), VV(nV(1)-nR(1),nV(2)-nR(2)), &
|
||||
OOt(nO(2)-nC(2),nO(1)-nC(1)),OVt(nV(2)-nR(2),nO(1)-nC(1)),VOt(nO(2)-nC(2),nV(1)-nR(1)),VVt(nV(2)-nR(2),nV(1)-nR(1)))
|
||||
|
||||
! Overlap matrix between spin-up and spin-down orbitals
|
||||
|
||||
OO(:,:) = matmul(transpose(c(:,nC(1)+1:nO(1) ,1)),matmul(S,c(:,nC(2)+1:nO(2) ,2)))
|
||||
OV(:,:) = matmul(transpose(c(:,nC(1)+1:nO(1) ,1)),matmul(S,c(:,nO(2)+1:nBas-nR(2),2)))
|
||||
VO(:,:) = matmul(transpose(c(:,nO(1)+1:nBas-nR(1),1)),matmul(S,c(:,nC(2)+1:nO(2) ,2)))
|
||||
VV(:,:) = matmul(transpose(c(:,nO(1)+1:nBas-nR(1),1)),matmul(S,c(:,nO(2)+1:nBas-nR(2),2)))
|
||||
|
||||
OOt(:,:) = transpose(OO(:,:))
|
||||
OVt(:,:) = transpose(OV(:,:))
|
||||
VOt(:,:) = transpose(VO(:,:))
|
||||
VVt(:,:) = transpose(VV(:,:))
|
||||
|
||||
!-------------------------!
|
||||
! <S**2> for ground state !
|
||||
!-------------------------!
|
||||
|
||||
S2_exact = dble(nO(1) - nO(2))/2d0*(dble(nO(1) - nO(2))/2d0 + 1d0)
|
||||
S2_gs = S2_exact + dble(nO(2)) - sum(OO(:,:)**2)
|
||||
|
||||
!------------------------------------------!
|
||||
! <S**2> for spin-conserved-excited states !
|
||||
!------------------------------------------!
|
||||
|
||||
if(ispin == 1) then
|
||||
|
||||
allocate(Xa(nO(1)-nC(1),nV(1)-nR(1)), Ya(nO(1)-nC(1),nV(1)-nR(1)), Xb(nO(2)-nC(2),nV(2)-nR(2)), Yb(nO(2)-nC(2),nV(2)-nR(2)), &
|
||||
Xat(nV(1)-nR(1),nO(1)-nC(1)),Yat(nV(1)-nR(1),nO(1)-nC(1)),Xbt(nV(2)-nR(2),nO(2)-nC(2)),Ybt(nV(2)-nR(2),nO(2)-nC(2)))
|
||||
|
||||
do m=1,maxS
|
||||
|
||||
ia = 0
|
||||
do i=nC(1)+1,nO(1)
|
||||
do a=1,nV(1)-nR(1)
|
||||
ia = ia + 1
|
||||
Xa(i,a) = 0.5d0*(XpY(m,ia) + XmY(m,ia))
|
||||
Ya(i,a) = 0.5d0*(XpY(m,ia) - XmY(m,ia))
|
||||
end do
|
||||
end do
|
||||
|
||||
ia = 0
|
||||
do i=nC(2)+1,nO(2)
|
||||
do a=1,nV(2)-nR(2)
|
||||
ia = ia + 1
|
||||
Xb(i,a) = 0.5d0*(XpY(m,nSa+ia) + XmY(m,nSa+ia))
|
||||
Yb(i,a) = 0.5d0*(XpY(m,nSa+ia) - XmY(m,nSa+ia))
|
||||
end do
|
||||
end do
|
||||
|
||||
Xat(:,:) = transpose(Xa(:,:))
|
||||
Xbt(:,:) = transpose(Xb(:,:))
|
||||
Yat(:,:) = transpose(Ya(:,:))
|
||||
Ybt(:,:) = transpose(Yb(:,:))
|
||||
|
||||
S2(m) = S2_gs &
|
||||
+ trace_matrix(nV(1),matmul(Xat,matmul(OO,matmul(OOt,Xa)))) &
|
||||
+ trace_matrix(nV(2),matmul(Xbt,matmul(OOt,matmul(OO,Xb)))) &
|
||||
- trace_matrix(nO(1),matmul(Xa,matmul(VO,matmul(VOt,Xat)))) &
|
||||
- trace_matrix(nO(2),matmul(Xb,matmul(OVt,matmul(OV,Xbt)))) &
|
||||
- 2d0*trace_matrix(nO(1),matmul(OO,matmul(Xb,matmul(VVt,Xat)))) &
|
||||
|
||||
- 2d0*trace_matrix(nV(2),matmul(OVt,matmul(Xa,matmul(VO,Yb)))) &
|
||||
- 2d0*trace_matrix(nV(1),matmul(VO,matmul(Xb,matmul(OVt,Ya)))) &
|
||||
|
||||
- trace_matrix(nV(1),matmul(Yat,matmul(OO,matmul(OOt,Ya)))) &
|
||||
- trace_matrix(nV(2),matmul(Ybt,matmul(OOt,matmul(OO,Yb)))) &
|
||||
+ trace_matrix(nO(1),matmul(Ya,matmul(VO,matmul(VOt,Yat)))) &
|
||||
+ trace_matrix(nO(2),matmul(Yb,matmul(OVt,matmul(OV,Ybt)))) &
|
||||
+ 2d0*trace_matrix(nO(1),matmul(Ya,matmul(VV,matmul(Ybt,OOt))))
|
||||
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
!------------------------------------------!
|
||||
! <S**2> for spin-conserved-excited states !
|
||||
!------------------------------------------!
|
||||
|
||||
if(ispin == 2) then
|
||||
|
||||
allocate(Xa(nO(1)-nC(1),nV(2)-nR(2)), Ya(nO(1)-nC(1),nV(2)-nR(2)), Xb(nO(2)-nC(2),nV(1)-nR(1)), Yb(nO(2)-nC(2),nV(1)-nR(1)), &
|
||||
Xat(nV(2)-nR(2),nO(1)-nC(1)),Yat(nV(2)-nR(2),nO(1)-nC(1)),Xbt(nV(1)-nR(1),nO(2)-nC(2)),Ybt(nV(1)-nR(1),nO(2)-nC(2)))
|
||||
|
||||
do m=1,maxS
|
||||
|
||||
ia = 0
|
||||
do i=nC(1)+1,nO(1)
|
||||
do a=1,nV(2)-nR(2)
|
||||
ia = ia + 1
|
||||
Xa(i,a) = 0.5d0*(XpY(m,ia) + XmY(m,ia))
|
||||
Ya(i,a) = 0.5d0*(XpY(m,ia) - XmY(m,ia))
|
||||
end do
|
||||
end do
|
||||
|
||||
ia = 0
|
||||
do i=nC(2)+1,nO(2)
|
||||
do a=1,nV(1)-nR(1)
|
||||
ia = ia + 1
|
||||
Xb(i,a) = 0.5d0*(XpY(m,nSa+ia) + XmY(m,nSa+ia))
|
||||
Yb(i,a) = 0.5d0*(XpY(m,nSa+ia) - XmY(m,nSa+ia))
|
||||
end do
|
||||
end do
|
||||
|
||||
Xat(:,:) = transpose(Xa(:,:))
|
||||
Xbt(:,:) = transpose(Xb(:,:))
|
||||
Yat(:,:) = transpose(Ya(:,:))
|
||||
Ybt(:,:) = transpose(Yb(:,:))
|
||||
|
||||
S2(m) = S2_gs + dble(nO(2) - nO(1)) + 1d0
|
||||
|
||||
S2(m) = S2(m) &
|
||||
|
||||
+ trace_matrix(nV(1),matmul(Xbt,matmul(OOt,matmul(OO,Xb)))) &
|
||||
- trace_matrix(nO(2),matmul(Xb,matmul(VO,matmul(VOt,Xbt)))) &
|
||||
+ trace_matrix(nO(2),matmul(Xb,VO))**2 &
|
||||
+ trace_matrix(nV(2),matmul(Yat,matmul(OO,matmul(OOt,Ya)))) &
|
||||
+ trace_matrix(nO(1),matmul(Ya,matmul(OVt,matmul(OV,Yat)))) &
|
||||
+ trace_matrix(nO(1),matmul(Ya,OVt))**2 &
|
||||
- 2d0*trace_matrix(nO(2),matmul(Xb,VO))*trace_matrix(nO(1),matmul(Ya,OVt)) &
|
||||
|
||||
+ trace_matrix(nV(2),matmul(Xat,matmul(OO,matmul(OOt,Xa)))) &
|
||||
- trace_matrix(nO(1),matmul(Xa,matmul(OVt,matmul(OV,Xat)))) &
|
||||
+ trace_matrix(nO(1),matmul(Xa,OVt))**2 &
|
||||
+ trace_matrix(nV(1),matmul(Ybt,matmul(OOt,matmul(OO,Yb)))) &
|
||||
- trace_matrix(nO(2),matmul(Yb,matmul(VO,matmul(VOt,Ybt)))) &
|
||||
+ trace_matrix(nV(1),matmul(Ybt,VOt))**2 &
|
||||
- 2d0*trace_matrix(nO(1),matmul(Xa,OVt))*trace_matrix(nO(2),matmul(Yb,VO))
|
||||
|
||||
end do
|
||||
|
||||
end if
|
||||
|
||||
end subroutine
|
||||
Loading…
Reference in New Issue
Block a user