lukasplevac/easyconfigs-it4i
1
0
Fork 0
mirror of https://code.it4i.cz/sccs/easyconfigs-it4i.git synced 2025-04-17 04:00:49 +01:00
Code Issues Packages Projects Releases Wiki Activity
easyconfigs-it4i/m/MRCC/mrcc_files/sacc.f
Lukas Krupcik eb1ea94130 merge master
2024-07-25 10:27:17 +02:00

870 lines
29 KiB
Fortran
Executable File
Raw Blame History

************************************************************************
subroutine saccif(nva,nvb,noa,nob,nconf,trec,nstr,nmax,nnir,
$isympv,isympo,istr,nactm,norm)
************************************************************************
* Interface to the spin adapted CC code *
************************************************************************
#include "MRCCCOMMON"
integer nva,nvb,noa,nob,nmax,is(0:nmax+4,nmax+4),nconf,trec,nstr
integer nnir,isympv,isympo,istr,nactm,iss,i,nv,no
real*8 v,norm
C Memory addresses
is(1,1)=imem !t1a
is(0,1)=is(1,1)+nva*noa !t1b
is(2,2)=is(0,1)+nvb*nob !t2aa
is(0,2)=is(2,2)+nva*nva*noa*noa !t2bb
is(1,2)=is(0,2)+nvb*nvb*nob*nob !t2ab
is(3,3)=is(1,2)+nva*nvb*noa*nob !t3aaa
is(0,3)=is(3,3)+nva*nva*nva*noa*noa*noa !t3bbb
is(2,3)=is(0,3)+nvb*nvb*nvb*nob*nob*nob !t3aab
is(1,3)=is(2,3)+nva*nva*nvb*noa*noa*nob !t3abb
is(4,4)=is(1,3)+nva*nvb*nvb*noa*nob*nob !t4aaaa
is(3,4)=is(4,4)+nva*nva*nva*nva*noa*noa*noa*noa !t4aaab
is(2,4)=is(3,4)+nva*nva*nva*nvb*noa*noa*noa*nob !t4aabb
is(1,4)=is(2,4)+nva*nva*nvb*nvb*noa*noa*nob*nob !t4abbb
is(0,4)=is(1,4)+nva*nvb*nvb*nvb*noa*nob*nob*nob !t4bbbb
iss= is(0,4)+nvb*nvb*nvb*nvb*nob*nob*nob*nob !scratch
if(sacc.eq.2) then
iss=is(4,4)
is(3,4)=iss
is(2,4)=iss
is(1,4)=iss
is(0,4)=iss
endif
C Convert string-based cluster amplitudes to spin-orbital-based ones
call dfillzero(dcore(is(1,1)),iss-is(1,1))
call strtot(nva,nvb,noa,nob,dcore(iss),nconf,trec,nstr,nmax,
$nnir,isympv,isympo,istr,nactm,is,.true.,op,iss)
c $nnir,isympv,isympo,istr,nactm,is,.true.,2)
c $nnir,isympv,isympo,istr,nactm,is,.true.,4) !szemet
call tasym(nva,noa,dcore(is(2,2)))
call tasym(nvb,nob,dcore(is(0,2)))
C Spin-adaptation
if(sacc.gt.0) then
c call Miriam(nva,nvb,noa,nob,dcore(is(1,1)),dcore(is(0,1)),
c $dcore(is(2,2)),dcore(is(0,2)),dcore(is(1,2)),dcore(is(3,3)),
c $dcore(is(0,3)),dcore(is(2,3)),dcore(is(1,3)),dcore(is(4,4)),
c $dcore(is(3,4)),dcore(is(2,4)),dcore(is(1,4)),dcore(is(0,4)),
c $dcore(iss),norm,sacc)
else
nv=nva+nvb
no=noa+nob
call t3asym3(nva,noa,dcore(is(3,3)))
call t3asym3(nvb,nob,dcore(is(0,3)))
call t3asymaab(nva,nvb,noa,nob,dcore(is(2,3)))
call t3asymabb(nva,nvb,noa,nob,dcore(is(1,3)))
call ptcorr(nva,nvb,noa,nob,dcore(is(1,1)),dcore(is(0,1)),
$dcore(is(2,2)),dcore(is(0,2)),dcore(is(1,2)),dcore(is(3,3)),
$dcore(is(0,3)),dcore(is(2,3)),dcore(is(1,3)),nv,no,nbasis,
$dcore(iss),dcore(iss+nv*no),dcore(iss+nv*no+nv**2*no**2),
$dcore(iss+nv*no+nv**2*no**2+nv**3*no**3), !int
$dcore(iss+nv*no+nv**2*no**2+nv**3*no**3+nbasis**4), !e
$dcore(iss+nv*no+nv**2*no**2+nv**3*no**3+nbasis**4+nbasis),!vint
$dcore(iss+nv*no+nv**2*no**2+nv**3*no**3+nbasis**4+nbasis+
$(nbasis/2)**4)) !h
endif
C Convert back
if(sacc.lt.0) return
call strtot(nva,nvb,noa,nob,dcore(iss),nconf,trec,nstr,nmax,
$nnir,isympv,isympo,istr,nactm,is,.false.,min(op,4),iss)
C
return
end
C
************************************************************************
subroutine strtot(nva,nvb,noa,nob,v,nconf,trec,nstr,nmax,nnir,
$isympv,isympo,istr,nactm,is,log,nexmax,ioffs)
************************************************************************
* Convert string-based cluster amplitudes to spin-orbital-based ones *
************************************************************************
#include "MRCCCOMMON"
integer nva,nvb,noa,nob,nnir,nmax,nactm,i,j,k,nex,ii,jj,nn,iis,mm
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),ioffs
integer n1,n2,n3,n4,nn1,nn2,nn3,nn4,isum,nexmax
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
integer iactv,iacto,iactva,iactoa,iactvb,iactob
integer is(0:nmax+4,nmax+4)
integer nstr(nnir,0:nactm,0:nmax,4),istr(nnir,0:nactm,0:nmax,4)
integer isympv(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2)
integer isympo(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2)
integer isymv,isymo,isymva,isymvb,isymoa,isymob,irv,iro
integer nactvintal,nactointal,nactvintbe,nactointbe,nactvirtal
integer nactoccal,nactvirtbe,nactoccbe
integer nampvirtal,nampvirtbe,nampoccal,nampoccbe
integer iva(nmax),ivb(nmax),ioa(nmax),iob(nmax)
real*8 v(*)
logical log
C
write(iout,*) 'Converting cluster amplitudes...'
C Loop over excitations
do nex=1,nexmax
do iactv=max(0,nex-mrop),min(nactv,nex)
do iacto=max(0,nex-mrop),min(nacto,nex)
do i1=0,nex
do iactva=max(0,iactv-nactvb),min(nactva,i1,iactv)
iactvb=iactv-iactva
do iactoa=max(0,iacto-nactob),min(nactoa,i1,iacto)
iactob=iacto-iactoa
nn=nconf(iactva,iactvb,iactoa,iactob,i1,nex)
if(nn.gt.0) then
if(log) then
call getlst(scrfile1,
$trec(iactva,iactvb,iactoa,iactob,i1,nex),v,nn)
else
call dfillzero(v,nn)
endif
nampvirtal=i1
nampvirtbe=nex-nampvirtal
nampoccal=i1
nampoccbe=nex-nampoccal
C Increments
isum=1
do i=1,nampvirtal
iva(i)=isum
isum=isum*nva
enddo
do i=1,nampvirtbe
ivb(i)=isum
isum=isum*nvb
enddo
do i=1,nampoccal
ioa(i)=isum
isum=isum*noa
enddo
do i=1,nampoccbe
iob(i)=isum
isum=isum*nob
enddo
C
ii=1
do ir=1,nir
isymv=isympair(isym,ir,1)
isymo=isympair(isym,ir,2)
do irv=1,isympv(0,isymv,iactva,iactvb,nampvirtal,
$nampvirtbe,1)
isymva=isympv(irv,isymv,iactva,iactvb,nampvirtal,nampvirtbe,1)
isymvb=isympv(irv,isymv,iactva,iactvb,nampvirtal,nampvirtbe,2)
n1=nstr(isymva,iactva,nampvirtal,1)
n2=nstr(isymvb,iactvb,nampvirtbe,2)
k=n1*n2
do iro=1,isympo(0,isymo,iactoa,iactob,nampoccal,
$nampoccbe,1)
isymoa=isympo(iro,isymo,iactoa,iactob,nampoccal,nampoccbe,1)
isymob=isympo(iro,isymo,iactoa,iactob,nampoccal,nampoccbe,2)
n3=nstr(isymoa,iactoa,nampoccal,3)
n4=nstr(isymob,iactob,nampoccbe,4)
call strread(nn1,nn2,nn3,nn4,n1,n2,n3,n4,nampvirtal,nampvirtbe,
$nampoccal,nampoccbe,isymva,isymvb,isymoa,isymob,iactva,iactvb,
$iactoa,iactob,nnir,nactm,nmax,istr,v(nn),mm,ioffs+nn)
call strtot1(nampvirtal,nampvirtbe,nampoccal,nampoccbe,n1,n2,n3,
$n4,icore(nn1),icore(nn2),icore(nn3),icore(nn4),v(ii),
$dcore(is(i1,nex)),iva,ivb,ioa,iob,log)
ii=ii+n3*n4*k
enddo
enddo
enddo
if(.not.log) call putlst(tfile,
c if(.not.log) call putlst(scrfile1, !szemet
$trec(iactva,iactvb,iactoa,iactob,i1,nex),v,nn)
endif
enddo
enddo
enddo
enddo
enddo
enddo
C
return
end
C
************************************************************************
subroutine strtot1(nva,nvb,noa,nob,nvstral,nvstrbe,nostral,
$nostrbe,istrva,istrvb,istroa,istrob,tstr,tspo,iva,ivb,ioa,iob,log)
************************************************************************
* Convert string-based cluster amplitudes to spin-orbital-based ones *
************************************************************************
#include "MRCCCOMMON"
integer nva,nvb,noa,nob,nvstral,nvstrbe,nostral,nostrbe,ii
integer i,ivstral,ivstrbe,iostral,iostrbe,isum1,isum2,isum3,isum4
integer iva(*),ivb(*),ioa(*),iob(*)
integer istrva(nva,nvstral),istrvb(nvb,nvstrbe)
integer istroa(noa,nostral),istrob(nob,nostrbe)
real*8 tstr(*),tspo(*)
logical log
C
ii=0
if(log) then
do iostrbe=1,nostrbe
isum1=1
do i=1,nob
isum1=isum1+iob(i)*(istrob(i,iostrbe)-1)
enddo
do iostral=1,nostral
isum2=isum1
do i=1,noa
isum2=isum2+ioa(i)*(istroa(i,iostral)-1)
enddo
do ivstrbe=1,nvstrbe
isum3=isum2
do i=1,nvb
isum3=isum3+ivb(i)*(istrvb(i,ivstrbe)-1)
enddo
do ivstral=1,nvstral
isum4=isum3
do i=1,nva
isum4=isum4+iva(i)*(istrva(i,ivstral)-1)
enddo
ii=ii+1
tspo(isum4)=tstr(ii)
enddo
enddo
enddo
enddo
else
do iostrbe=1,nostrbe
isum1=1
do i=1,nob
isum1=isum1+iob(i)*(istrob(i,iostrbe)-1)
enddo
do iostral=1,nostral
isum2=isum1
do i=1,noa
isum2=isum2+ioa(i)*(istroa(i,iostral)-1)
enddo
do ivstrbe=1,nvstrbe
isum3=isum2
do i=1,nvb
isum3=isum3+ivb(i)*(istrvb(i,ivstrbe)-1)
enddo
do ivstral=1,nvstral
isum4=isum3
do i=1,nva
isum4=isum4+iva(i)*(istrva(i,ivstral)-1)
enddo
ii=ii+1
tstr(ii)=tspo(isum4)
enddo
enddo
enddo
enddo
endif
C
return
end
C
************************************************************************
subroutine tasym(nv,no,t)
************************************************************************
* Antisymmetrize T2 amplitudes *
************************************************************************
implicit none
integer nv,no,a,b,i,j
real*8 t(nv,nv,no,no),sum
C
do a=1,nv
do b=1,nv
do i=1,no
do j=1,no
sum=t(a,b,i,j)
if(sum.ne.0.d0) then
t(b,a,i,j)=-sum
t(a,b,j,i)=-sum
t(b,a,j,i)=sum
endif
enddo
enddo
enddo
enddo
C
return
end
C
************************************************************************
subroutine t3asym3(nv,no,t)
************************************************************************
* Antisymmetrize T3 amplitudes *
************************************************************************
implicit none
integer nv,no,a,b,c,i,j,k
real*8 t(nv,nv,nv,no,no,no),sum
C
do a=1,nv
do b=1,nv
do c=1,nv
do i=1,no
do j=1,no
do k=1,no
sum=t(a,b,c,i,j,k)
if(sum.ne.0.d0) then
t(a,b,c,i,j,k)=sum
t(a,b,c,j,k,i)=sum
t(a,b,c,k,i,j)=sum
t(a,b,c,j,i,k)=-sum
t(a,b,c,k,j,i)=-sum
t(a,b,c,i,k,j)=-sum
t(b,c,a,i,j,k)=sum
t(b,c,a,j,k,i)=sum
t(b,c,a,k,i,j)=sum
t(b,c,a,j,i,k)=-sum
t(b,c,a,k,j,i)=-sum
t(b,c,a,i,k,j)=-sum
t(c,a,b,i,j,k)=sum
t(c,a,b,j,k,i)=sum
t(c,a,b,k,i,j)=sum
t(c,a,b,j,i,k)=-sum
t(c,a,b,k,j,i)=-sum
t(c,a,b,i,k,j)=-sum
t(b,a,c,i,j,k)=-sum
t(b,a,c,j,k,i)=-sum
t(b,a,c,k,i,j)=-sum
t(b,a,c,j,i,k)=sum
t(b,a,c,k,j,i)=sum
t(b,a,c,i,k,j)=sum
t(c,b,a,i,j,k)=-sum
t(c,b,a,j,k,i)=-sum
t(c,b,a,k,i,j)=-sum
t(c,b,a,j,i,k)=sum
t(c,b,a,k,j,i)=sum
t(c,b,a,i,k,j)=sum
t(a,c,b,i,j,k)=-sum
t(a,c,b,j,k,i)=-sum
t(a,c,b,k,i,j)=-sum
t(a,c,b,j,i,k)=sum
t(a,c,b,k,j,i)=sum
t(a,c,b,i,k,j)=sum
endif
enddo
enddo
enddo
enddo
enddo
enddo
C
return
end
C
************************************************************************
subroutine t3asymaab(nva,nvb,noa,nob,t)
************************************************************************
* Antisymmetrize T3 amplitudes *
************************************************************************
implicit none
integer nva,nvb,noa,nob,a,b,c,i,j,k
real*8 t(nva,nva,nvb,noa,noa,nob),sum
C
do a=1,nva
do b=1,nva
do c=1,nvb
do i=1,noa
do j=1,noa
do k=1,nob
sum=t(a,b,c,i,j,k)
if(sum.ne.0.d0) then
t(b,a,c,i,j,k)=-sum
t(a,b,c,j,i,k)=-sum
t(b,a,c,j,i,k)=sum
endif
enddo
enddo
enddo
enddo
enddo
enddo
C
return
end
C
************************************************************************
subroutine t3asymabb(nva,nvb,noa,nob,t)
************************************************************************
* Antisymmetrize T3 amplitudes *
************************************************************************
implicit none
integer nva,nvb,noa,nob,a,b,c,i,j,k
real*8 t(nva,nvb,nvb,noa,nob,nob),sum
C
do a=1,nva
do b=1,nvb
do c=1,nvb
do i=1,noa
do j=1,nob
do k=1,nob
sum=t(a,b,c,i,j,k)
if(sum.ne.0.d0) then
t(a,c,b,i,j,k)=-sum
t(a,b,c,i,k,j)=-sum
t(a,c,b,i,k,j)=sum
endif
enddo
enddo
enddo
enddo
enddo
enddo
C
return
end
C
************************************************************************
subroutine ptcorr(nva,nvb,noa,nob,t1a,t1b,t2aa,t2bb,t2ab,t3aaa,
$t3bbb,t3aab,t3abb,nv,no,nb,t1,t2,t3,int,ee,vint,h)
************************************************************************
* Test routine for PT corrections *
************************************************************************
#include "MRCCCOMMON"
integer nva,nvb,noa,nob,nv,no,nb,a,b,c,i,j,k,l,sa,sb,sc,si,sj,sk
integer sl,aa,bb,cc,ii,jj,kk,ll,orbno,orbv,orbo
real*8 t1a(nva,noa),t1b(nvb,nob),t2aa(nva,nva,noa,noa),ee(*),h(*)
real*8 t2bb(nvb,nvb,nob,nob),t2ab(nva,nvb,noa,nob),t1(nv,no),sum
real*8 t3aaa(nva,nva,nva,noa,noa,noa),t2(nv,nv,no,no)
real*8 t3bbb(nvb,nvb,nvb,nob,nob,nob),int(nb,nb,nb,nb)
real*8 t3aab(nva,nva,nvb,noa,noa,nob),vint(nb/2,nb/2,nb/2,nb/2)
real*8 t3abb(nva,nvb,nvb,noa,nob,nob)
real*8 t3(nv,nv,nv,no,no,no)
C
call dfillzero(int,nb**4)
call dfillzero(vint,(nb/2)**4)
call dfillzero(t1,nv*no)
call dfillzero(t2,nv**2*no**2)
call dfillzero(t3,nv**3*no**3)
C Read integrals
rewind(inp)
read(inp,*)
read(inp,*)
read(inp,*)
1004 read(inp,2004) sum,i,j,k,l
C Two-electron part
if(l.ne.0) then
vint(i,k,j,l)=sum
vint(l,j,k,i)=sum
vint(j,l,i,k)=sum
vint(k,i,l,j)=sum
vint(j,k,i,l)=sum
vint(l,i,k,j)=sum
vint(i,l,j,k)=sum
vint(k,j,l,i)=sum
goto 1004
endif
C One-electron part
if(l.eq.0.and.i.ne.0) then
if(i.eq.j) h(i)=sum
goto 1004
endif
C Integral list
do i=1,nb
ii=orbno(i,icore(iabsmem),nb,si)
ee(i)=h(ii)
do j=1,nb
jj=orbno(j,icore(iabsmem),nb,sj)
do k=1,nb
kk=orbno(k,icore(iabsmem),nb,sk)
do l=1,nb
ll=orbno(l,icore(iabsmem),nb,sl)
sum=0.d0
if(si.eq.sk.and.sj.eq.sl) sum=sum+vint(ii,jj,kk,ll)
if(si.eq.sl.and.sj.eq.sk) sum=sum-vint(ii,jj,ll,kk)
int(i,j,k,l)=sum
enddo
enddo
enddo
enddo
C Orbital energies
do i=1,nb
sum=0.d0
do j=1,nocc
sum=sum+int(i,j,i,j)
enddo
ee(i)=ee(i)+sum
enddo
C T1
do a=1,nv
aa=orbv(a,sa)
do i=1,no
ii=orbo(i,si)
if(sa.eq.si) then
if(sa.eq.1) t1(a,i)=t1a(aa,ii)
if(sa.eq.0) t1(a,i)=t1b(aa,ii)
endif
enddo
enddo
C T2
do a=1,nv
aa=orbv(a,sa)
do b=1,nv
bb=orbv(b,sb)
do i=1,no
ii=orbo(i,si)
do j=1,no
jj=orbo(j,sj)
if(sa+sb.eq.si+sj) then
if(sa.eq.1.and.sb.eq.1.and.si.eq.1.and.sj.eq.1)
$ t2(a,b,i,j)=t2aa(aa,bb,ii,jj)
if(sa.eq.0.and.sb.eq.0.and.si.eq.0.and.sj.eq.0)
$ t2(a,b,i,j)=t2bb(aa,bb,ii,jj)
if(sa.eq.1.and.sb.eq.0.and.si.eq.1.and.sj.eq.0)
$ t2(a,b,i,j)=t2ab(aa,bb,ii,jj)
if(sa.eq.0.and.sb.eq.1.and.si.eq.0.and.sj.eq.1)
$ t2(a,b,i,j)=t2ab(bb,aa,jj,ii)
if(sa.eq.1.and.sb.eq.0.and.si.eq.0.and.sj.eq.1)
$ t2(a,b,i,j)=-t2ab(aa,bb,jj,ii)
if(sa.eq.0.and.sb.eq.1.and.si.eq.1.and.sj.eq.0)
$ t2(a,b,i,j)=-t2ab(bb,aa,ii,jj)
endif
enddo
enddo
enddo
enddo
C T3
do a=1,nv
aa=orbv(a,sa)
do b=1,nv
bb=orbv(b,sb)
do c=1,nv
cc=orbv(c,sc)
do i=1,no
ii=orbo(i,si)
do j=1,no
jj=orbo(j,sj)
do k=1,no
kk=orbo(k,sk)
if(sa+sb+sc.eq.si+sj+sk) then
C aaa
if(sa.eq.1.and.sb.eq.1.and.sc.eq.1.and.
$ si.eq.1.and.sj.eq.1.and.sk.eq.1)
$t3(a,b,c,i,j,k)=t3aaa(aa,bb,cc,ii,jj,kk)
C bbb
if(sa.eq.0.and.sb.eq.0.and.sc.eq.0.and.
$ si.eq.0.and.sj.eq.0.and.sk.eq.0)
$t3(a,b,c,i,j,k)=t3bbb(aa,bb,cc,ii,jj,kk)
C aab
if(sa.eq.1.and.sb.eq.1.and.sc.eq.0.and.
$ si.eq.1.and.sj.eq.1.and.sk.eq.0)
$t3(a,b,c,i,j,k)=t3aab(aa,bb,cc,ii,jj,kk)
if(sa.eq.1.and.sb.eq.1.and.sc.eq.0.and.
$ si.eq.1.and.sj.eq.0.and.sk.eq.1)
$t3(a,b,c,i,j,k)=-t3aab(aa,bb,cc,ii,kk,jj)
if(sa.eq.1.and.sb.eq.1.and.sc.eq.0.and.
$ si.eq.0.and.sj.eq.1.and.sk.eq.1)
$t3(a,b,c,i,j,k)=t3aab(aa,bb,cc,jj,kk,ii)
if(sa.eq.1.and.sb.eq.0.and.sc.eq.1.and.
$ si.eq.1.and.sj.eq.1.and.sk.eq.0)
$t3(a,b,c,i,j,k)=-t3aab(aa,cc,bb,ii,jj,kk)
if(sa.eq.1.and.sb.eq.0.and.sc.eq.1.and.
$ si.eq.1.and.sj.eq.0.and.sk.eq.1)
$t3(a,b,c,i,j,k)=t3aab(aa,cc,bb,ii,kk,jj)
if(sa.eq.1.and.sb.eq.0.and.sc.eq.1.and.
$ si.eq.0.and.sj.eq.1.and.sk.eq.1)
$t3(a,b,c,i,j,k)=-t3aab(aa,cc,bb,jj,kk,ii)
if(sa.eq.0.and.sb.eq.1.and.sc.eq.1.and.
$ si.eq.1.and.sj.eq.1.and.sk.eq.0)
$t3(a,b,c,i,j,k)=t3aab(bb,cc,aa,ii,jj,kk)
if(sa.eq.0.and.sb.eq.1.and.sc.eq.1.and.
$ si.eq.1.and.sj.eq.0.and.sk.eq.1)
$t3(a,b,c,i,j,k)=-t3aab(bb,cc,aa,ii,kk,jj)
if(sa.eq.0.and.sb.eq.1.and.sc.eq.1.and.
$ si.eq.0.and.sj.eq.1.and.sk.eq.1)
$t3(a,b,c,i,j,k)=t3aab(bb,cc,aa,jj,kk,ii)
C abb
if(sa.eq.1.and.sb.eq.0.and.sc.eq.0.and.
$ si.eq.1.and.sj.eq.0.and.sk.eq.0)
$t3(a,b,c,i,j,k)=t3abb(aa,bb,cc,ii,jj,kk)
if(sa.eq.1.and.sb.eq.0.and.sc.eq.0.and.
$ si.eq.0.and.sj.eq.1.and.sk.eq.0)
$t3(a,b,c,i,j,k)=-t3abb(aa,bb,cc,jj,ii,kk)
if(sa.eq.1.and.sb.eq.0.and.sc.eq.0.and.
$ si.eq.0.and.sj.eq.0.and.sk.eq.1)
$t3(a,b,c,i,j,k)=t3abb(aa,bb,cc,kk,ii,jj)
if(sa.eq.0.and.sb.eq.1.and.sc.eq.0.and.
$ si.eq.1.and.sj.eq.0.and.sk.eq.0)
$t3(a,b,c,i,j,k)=-t3abb(bb,aa,cc,ii,jj,kk)
if(sa.eq.0.and.sb.eq.1.and.sc.eq.0.and.
$ si.eq.0.and.sj.eq.1.and.sk.eq.0)
$t3(a,b,c,i,j,k)=t3abb(bb,aa,cc,jj,ii,kk)
if(sa.eq.0.and.sb.eq.1.and.sc.eq.0.and.
$ si.eq.0.and.sj.eq.0.and.sk.eq.1)
$t3(a,b,c,i,j,k)=-t3abb(bb,aa,cc,kk,ii,jj)
if(sa.eq.0.and.sb.eq.0.and.sc.eq.1.and.
$ si.eq.1.and.sj.eq.0.and.sk.eq.0)
$t3(a,b,c,i,j,k)=t3abb(cc,aa,bb,ii,jj,kk)
if(sa.eq.0.and.sb.eq.0.and.sc.eq.1.and.
$ si.eq.0.and.sj.eq.1.and.sk.eq.0)
$t3(a,b,c,i,j,k)=-t3abb(cc,aa,bb,jj,ii,kk)
if(sa.eq.0.and.sb.eq.0.and.sc.eq.1.and.
$ si.eq.0.and.sj.eq.0.and.sk.eq.1)
$t3(a,b,c,i,j,k)=t3abb(cc,aa,bb,kk,ii,jj)
endif
enddo
enddo
enddo
enddo
enddo
enddo
C
call mp2(nv,no,nb,int,ee)
call ccener(nv,no,nb,t1,t2,int)
call part(nv,no,nb,t1,t2,int,ee)
C
2004 format(e20.12,4i3)
C
return
end
C
************************************************************************
integer function orbno(i,absind,nb,sp)
************************************************************************
* Serial number of orbitals *
************************************************************************
#include "MRCCCOMMON"
integer i,nb,absind(nb,-3:0),sp
C
if(i.gt.nocc) then
C Virtual
if(i.le.nocc+nvirtal) then
orbno=absind(i-nocc,-3)
sp=1
endif
if(i.gt.nocc+nvirtal) then
orbno=absind(i-nocc-nvirtal,-2)
sp=0
endif
else
C Occupied
if(i.le.nal) then
orbno=absind(i,-1)
sp=1
endif
if(i.gt.nal) then
orbno=absind(i-nal,0)
sp=0
endif
endif
C
return
end
C
************************************************************************
integer function orbv(i,sp)
************************************************************************
* Serial number of orbitals *
************************************************************************
#include "MRCCCOMMON"
integer i,sp
C
if(i.le.nvirtal) then
orbv=i
sp=1
else
orbv=i-nvirtal
sp=0
endif
C
return
end
C
************************************************************************
integer function orbo(i,sp)
************************************************************************
* Serial number of orbitals *
************************************************************************
#include "MRCCCOMMON"
integer i,sp
C
if(i.le.nal) then
orbo=i
sp=1
else
orbo=i-nal
sp=0
endif
C
return
end
C
************************************************************************
subroutine part(nv,no,nb,t1,t2,int,ee)
************************************************************************
* CCSD[T]/CCSD(T) correction *
************************************************************************
#include "MRCCCOMMON"
integer nv,no,nb,a,b,c,d,e,f,i,j,k,l,m,n
real*8 t1(no+1:nb,no),t2(no+1:nb,no+1:nb,no,no),corr,sum,ee(*)
real*8 int(nb,nb,nb,nb)
C
corr=0.d0
do a=no+1,nb
do b=no+1,nb
do c=no+1,nb
do i=1,no
do k=1,no
do m=1,no
sum=0.d0
do l=1,no
sum=sum+int(l,c,k,m)*t2(a,b,i,l)
sum=sum-int(l,c,i,m)*t2(a,b,k,l)
sum=sum-int(l,c,k,i)*t2(a,b,m,l)
sum=sum-int(l,a,k,m)*t2(c,b,i,l)
sum=sum+int(l,a,i,m)*t2(c,b,k,l)
sum=sum+int(l,a,k,i)*t2(c,b,m,l)
sum=sum-int(l,b,k,m)*t2(a,c,i,l)
sum=sum+int(l,b,i,m)*t2(a,c,k,l)
sum=sum+int(l,b,k,i)*t2(a,c,m,l)
enddo
corr=corr+sum**2/(ee(i)+ee(k)+ee(m)-ee(a)-ee(b)-ee(c))
enddo
enddo
enddo
enddo
enddo
enddo
write(6,"('CCSD[T]: ',f18.12)") corr/36.d0
C
write(6,*)
corr=0.d0
C Diagram 3
sum=0.d0
do b=no+1,nb
do a=no+1,b-1
do c=no+1,nb
do i=1,no
do j=1,no
do m=1,no
do k=1,m-1
do l=1,no
sum=sum+int(k,m,j,c)*int(l,c,k,m)*t2(a,b,i,j)*t2(a,b,i,l)/
$(ee(i)+ee(k)+ee(m)-ee(a)-ee(b)-ee(c))
enddo
enddo
enddo
enddo
enddo
enddo
enddo
enddo
corr=corr+sum
write(6,"('Diagram 3: ',f18.12)") sum
C Diagram 4
sum=0.d0
do a=no+1,nb
do b=no+1,nb
do e=no+1,nb
do c=no+1,e-1
do d=no+1,nb
do j=1,no
do i=1,j-1
do k=1,no
sum=sum+int(b,k,c,e)*int(c,e,d,k)*t2(a,b,i,j)*t2(a,d,i,j)/
$(ee(i)+ee(j)+ee(k)-ee(a)-ee(c)-ee(e))
enddo
enddo
enddo
enddo
enddo
enddo
enddo
enddo
corr=corr+sum
write(6,"('Diagram 4: ',f18.12)") sum
C Diagram 5
sum=0.d0
do a=no+1,nb
do b=no+1,nb
do c=no+1,nb
do d=no+1,nb
do i=1,no
do j=1,no
do k=1,no
do l=1,no
sum=sum-int(k,l,j,c)*int(b,c,d,l)*t2(a,b,i,j)*t2(a,d,i,k)/
$(ee(i)+ee(k)+ee(l)-ee(a)-ee(b)-ee(c))
enddo
enddo
enddo
enddo
enddo
enddo
enddo
enddo
corr=corr+2.d0*sum
write(6,"('Diagram 5: ',f18.12)") sum
C
write(6,"('CCSD[T]: ',f18.12)") corr
write(6,"('CCSD[T]: ',f18.12)") ecc+corr
stop
C
return
end
C
************************************************************************
subroutine mp2(nv,no,nb,int,ee)
************************************************************************
* MP2 correction *
************************************************************************
#include "MRCCCOMMON"
integer nv,no,nb,a,b,i,j
real*8 sum,int(nb,nb,nb,nb),ee(*)
C
write(6,*)
C Diagram 1
sum=0.d0
do b=no+1,nb
do a=no+1,b-1
do j=1,no
do i=1,j-1
sum=sum+int(a,b,i,j)*int(i,j,a,b)/(ee(i)+ee(j)-ee(a)-ee(b))
enddo
enddo
enddo
enddo
C
write(6,"('MP2: ',f18.12)") sum
write(6,"('MP2: ',f18.12)") eref+sum
C
return
end
C
************************************************************************
subroutine ccener(nv,no,nb,t1,t2,int)
************************************************************************
* CC energy *
************************************************************************
#include "MRCCCOMMON"
integer nv,no,nb,a,b,i,j
real*8 t1(no+1:nb,no),t2(no+1:nb,no+1:nb,no,no),corr,sum
real*8 int(nb,nb,nb,nb)
C
write(6,*)
corr=0.d0
C Diagram 1
sum=0.d0
do a=no+1,nb
do b=no+1,nb
do i=1,no
do j=1,no
sum=sum+int(a,b,i,j)*t1(a,i)*t1(b,j)
enddo
enddo
enddo
enddo
corr=corr+sum/2.d0
write(6,"('Diagram 1: ',f18.12)") sum/2.d0
C Diagram 2
sum=0.d0
do a=no+1,nb
do b=no+1,a-1
do i=1,no
do j=1,i-1
sum=sum+int(a,b,i,j)*t2(a,b,i,j)
enddo
enddo
enddo
enddo
corr=corr+sum
write(6,"('Diagram 2: ',f18.12)") sum
C
write(6,"('CC energy: ',f18.12)") corr
write(6,"('CC energy: ',f18.12)") eref+corr
C
return
end
C
Reference in New Issue View Git Blame Copy Permalink