scemama/qp_plugins_scemama
1
0
Fork 0
mirror of https://gitlab.com/scemama/qp_plugins_scemama.git synced 2024-12-23 04:43:38 +01:00
Code Issues Releases Wiki Activity
a264f8bb6f
qp_plugins_scemama/devel/casscf/hessian.irp.f

540 lines
15 KiB
Fortran
Raw Blame History

use bitmasks
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
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 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+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3) &
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* &
bielec_pxxq_no(aa,x3,v3,aa))
do y=1,n_act_orb
t3-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx)
end do
end do
end do
term=t1+t2+t3
else
bb=list_virt(b)
! ta/tb b/=a
term=occnum(tt)*Fipq(aa,bb)
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+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3) &
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) &
*bielec_pxxq_no(aa,x3,v3,bb))
end do
end do
end if
else
! ta/ub t/=u
uu=list_act(u)
bb=list_virt(b)
term=0.D0
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+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,bb,v3,x3) &
+(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) &
*bielec_pxxq_no(aa,x3,v3,bb))
end do
end do
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
BEGIN_PROVIDER [double precision, hessmat, (nMonoEx,nMonoEx)]
implicit none
integer :: i,j,t,u,a,b
integer :: indx,indx_tmp, jndx, jndx_tmp
integer :: ustart,bstart
real*8 :: hessmat_itju
real*8 :: hessmat_itja
real*8 :: hessmat_itua
real*8 :: hessmat_iajb
real*8 :: hessmat_iatb
real*8 :: hessmat_taub
! c-a c-v a-v
! c-a | X X X
! c-v | X X
! a-v | X
provide mo_two_e_integrals_in_map
hessmat = 0.d0
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat,n_c_a_prov,list_idx_c_a,n_core_inact_orb,n_act_orb,mat_idx_c_a) &
!$OMP PRIVATE(indx_tmp,indx,i,t,j,u,ustart,jndx)
!$OMP DO
!!!! < Core-active| H |Core-active >
! Core-active excitations
do indx_tmp = 1, n_c_a_prov
indx = list_idx_c_a(1,indx_tmp)
i = list_idx_c_a(2,indx_tmp)
t = list_idx_c_a(3,indx_tmp)
! Core-active excitations
do j = 1, n_core_inact_orb
if (i.eq.j) then
ustart=t
else
ustart=1
end if
do u=ustart,n_act_orb
jndx = mat_idx_c_a(j,u)
hessmat(jndx,indx) = hessmat_itju(i,t,j,u)
hessmat(indx,jndx) = hessmat(jndx,indx)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP END PARALLEL
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat,n_c_a_prov,n_c_v_prov,list_idx_c_a,list_idx_c_v) &
!$OMP PRIVATE(indx_tmp,jndx_tmp,indx,i,t,j,a,jndx)
!$OMP DO
!!!! < Core-active| H |Core-VIRTUAL >
! Core-active excitations
do indx_tmp = 1, n_c_a_prov
indx = list_idx_c_a(1,indx_tmp)
i = list_idx_c_a(2,indx_tmp)
t = list_idx_c_a(3,indx_tmp)
! Core-VIRTUAL excitations
do jndx_tmp = 1, n_c_v_prov
jndx = list_idx_c_v(1,jndx_tmp)
j = list_idx_c_v(2,jndx_tmp)
a = list_idx_c_v(3,jndx_tmp)
hessmat(jndx,indx) = hessmat_itja(i,t,j,a)
hessmat(indx,jndx) = hessmat(jndx,indx)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP END PARALLEL
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat,n_c_a_prov,n_a_v_prov,list_idx_c_a,list_idx_a_v) &
!$OMP PRIVATE(indx_tmp,jndx_tmp,indx,i,t,u,a,jndx)
!$OMP DO
!!!! < Core-active| H |ACTIVE-VIRTUAL >
! Core-active excitations
do indx_tmp = 1, n_c_a_prov
indx = list_idx_c_a(1,indx_tmp)
i = list_idx_c_a(2,indx_tmp)
t = list_idx_c_a(3,indx_tmp)
! ACTIVE-VIRTUAL excitations
do jndx_tmp = 1, n_a_v_prov
jndx = list_idx_a_v(1,jndx_tmp)
u = list_idx_a_v(2,jndx_tmp)
a = list_idx_a_v(3,jndx_tmp)
hessmat(jndx,indx) = hessmat_itua(i,t,u,a)
hessmat(indx,jndx) = hessmat(jndx,indx)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP END PARALLEL
if(hess_cv_cv)then
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat,n_c_v_prov,list_idx_c_v,n_core_inact_orb,n_virt_orb,mat_idx_c_v) &
!$OMP PRIVATE(indx_tmp,indx,i,a,j,b,bstart,jndx)
!$OMP DO
!!!!! < Core-VIRTUAL | H |Core-VIRTUAL >
! Core-VIRTUAL excitations
do indx_tmp = 1, n_c_v_prov
indx = list_idx_c_v(1,indx_tmp)
i = list_idx_c_v(2,indx_tmp)
a = list_idx_c_v(3,indx_tmp)
! Core-VIRTUAL excitations
do j = 1, n_core_inact_orb
if (i.eq.j) then
bstart=a
else
bstart=1
end if
do b=bstart,n_virt_orb
jndx = mat_idx_c_v(j,b)
hessmat(jndx,indx) = hessmat_iajb(i,a,j,b)
hessmat(indx,jndx) = hessmat(jndx,indx)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP END PARALLEL
endif
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat,n_c_v_prov,n_a_v_prov,list_idx_c_v,list_idx_a_v) &
!$OMP PRIVATE(indx_tmp,jndx_tmp,indx,i,a,t,b,jndx)
!$OMP DO
!!!! < Core-VIRTUAL | H |Active-VIRTUAL >
! Core-VIRTUAL excitations
do indx_tmp = 1, n_c_v_prov
indx = list_idx_c_v(1,indx_tmp)
i = list_idx_c_v(2,indx_tmp)
a = list_idx_c_v(3,indx_tmp)
! Active-VIRTUAL excitations
do jndx_tmp = 1, n_a_v_prov
jndx = list_idx_a_v(1,jndx_tmp)
t = list_idx_a_v(2,jndx_tmp)
b = list_idx_a_v(3,jndx_tmp)
hessmat(jndx,indx) = hessmat_iatb(i,a,t,b)
hessmat(indx,jndx) = hessmat(jndx,indx)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP END PARALLEL
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat,n_a_v_prov,list_idx_a_v,n_act_orb,n_virt_orb,mat_idx_a_v) &
!$OMP PRIVATE(indx_tmp,indx,t,a,u,b,bstart,jndx)
!$OMP DO
!!!! < Active-VIRTUAL | H |Active-VIRTUAL >
! Active-VIRTUAL excitations
do indx_tmp = 1, n_a_v_prov
indx = list_idx_a_v(1,indx_tmp)
t = list_idx_a_v(2,indx_tmp)
a = list_idx_a_v(3,indx_tmp)
! Active-VIRTUAL excitations
do u=t,n_act_orb
if (t.eq.u) then
bstart=a
else
bstart=1
end if
do b=bstart,n_virt_orb
jndx = mat_idx_a_v(u,b)
hessmat(jndx,indx) = hessmat_taub(t,a,u,b)
hessmat(indx,jndx) = hessmat(jndx,indx)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP END PARALLEL
END_PROVIDER
Reference in New Issue View Git Blame Copy Permalink