mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-16 19:50:50 +01:00
1249 lines
54 KiB
Fortran
Executable File
1249 lines
54 KiB
Fortran
Executable File
************************************************************************
|
|
subroutine anti(nconf,trec,nstr,nmax,v,nnir,isympv,isympo,ita,
|
|
$tarec,nactm,icmem,wspc,nvintnew1,nointnew1,nvirtnew1,noccnew1,
|
|
$nvirtnewact,noccnewact,iadd,iaddo)
|
|
************************************************************************
|
|
* This subroutine antisymmetrizes amplitudes *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nnir,ii,nmax,nactm,i,j,k,l,ii1,ii2,ii3,inc2,ssym,iw,iadd
|
|
integer isymv1,isymo1,isymva1,isymvb1,isymoa1,isymob1,irv1,iro1
|
|
integer isymv2,isymo2,isymva2,isymvb2,isymoa2,isymob2,irv2,iro2
|
|
integer isymv3,isymo3,isymva3,isymvb3,isymoa3,isymob3,irv3,iro3
|
|
integer nvstral1,nvstrbe1,nostral1,nostrbe1,ir1,namplen,nvintnew1
|
|
integer nvstral2,nvstrbe2,nostral2,nostrbe2,ir2,wspc(0:1),ircold
|
|
integer nvstral3,nvstrbe3,nostral3,nostrbe3,ir3,nointnew1,noldlen
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax),isym1
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax),isym2
|
|
integer naval1,naoal1,navbe1,naobe1,nvirtnew1,noccnew1,iaddo
|
|
integer naval2,naoal2,navbe2,naobe2,nvirtnewact,noccnewact,icmem
|
|
integer naval3,naoal3,navbe3,naobe3
|
|
integer iactva1,iactoa1,iactvb1,iactob1
|
|
integer iactva2,iactoa2,iactvb2,iactob2
|
|
integer iactva3,iactoa3,iactvb3,iactob3
|
|
integer nstr(nnir,0:nactm,0:nmax,4),ita(nnir,nnir,nnir,nnir)
|
|
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 tarec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax)
|
|
real*8 v(*)
|
|
C
|
|
if(iroot.eq.1.or.((zroute.or.(eomgrad.and.l3route)).and.
|
|
$(.not.osc))) then
|
|
ssym=1
|
|
else
|
|
ssym=isym
|
|
endif
|
|
if(ptroute) ssym=ptsym(1)
|
|
C Loop over spin cases of intermediates
|
|
do iw=1,wspc(0)
|
|
naval2= wspc((iw-1)*12+1)
|
|
naoal2= wspc((iw-1)*12+2)
|
|
naval1= wspc((iw-1)*12+3)
|
|
naoal1= wspc((iw-1)*12+4)
|
|
iactva2=wspc((iw-1)*12+5)
|
|
iactoa2=wspc((iw-1)*12+6)
|
|
iactvb2=wspc((iw-1)*12+7)
|
|
iactob2=wspc((iw-1)*12+8)
|
|
iactva1=wspc((iw-1)*12+9)
|
|
iactoa1=wspc((iw-1)*12+10)
|
|
ircold= wspc((iw-1)*12+11)
|
|
noldlen=wspc((iw-1)*12+12)
|
|
navbe2= nvintnew1-naval2
|
|
naobe2= nointnew1-naoal2
|
|
navbe1= nvirtnew1-naval1
|
|
naobe1= noccnew1-naoal1
|
|
iactvb1=nvirtnewact-iactva1
|
|
iactob1=noccnewact-iactoa1
|
|
naval3=naval1+naval2
|
|
navbe3=navbe1+navbe2
|
|
naoal3=naoal1+naoal2
|
|
naobe3=naobe1+naobe2
|
|
iactva3=iactva1+iactva2
|
|
iactvb3=iactvb1+iactvb2
|
|
iactoa3=iactoa1+iactoa2
|
|
iactob3=iactob1+iactob2
|
|
call fwspc(iaddo,naval2,naoal2,naval1,naoal1,iactva2,iactoa2,
|
|
$iactvb2,iactob2,iactva1,iactoa1,k,l)
|
|
if(iactva3.le.nactva.and.iactoa3.le.nactoa.and.
|
|
$ iactvb3.le.nactvb.and.iactob3.le.nactob.and.k.gt.0.and.
|
|
$ naval3.eq.naoal3) then
|
|
namplen=nconf(iactva3,iactvb3,iactoa3,iactob3,naval3)
|
|
if(namplen.gt.0) then
|
|
read(tafile,rec=tarec(iactva3,iactvb3,iactoa3,iactob3,naval3)) ita
|
|
C
|
|
maxmem=max(maxmem,dble(noldlen+namplen))
|
|
c if(noldlen+namplen.gt.maxcor)
|
|
c $write(6,*) 'C1 ',8.d0*dble(noldlen+namplen)/dble(twoto20)
|
|
ii1=1
|
|
do ir=1,nir
|
|
isym2=isympair(ssym,ir,1)
|
|
isym1=isympair(ssym,ir,2)
|
|
call slength(nmax,nstr,nnir,isympv,isympo,nactm,inc2,isym2,
|
|
$iactva2,iactvb2,naval2,navbe2,iactoa2,iactob2,naoal2,naobe2,
|
|
$isympair)
|
|
enddo
|
|
call fwspc(iadd,0,0,naval3,naoal3,0,0,0,0,iactva3,iactoa3,k,l)
|
|
if(k.eq.0)
|
|
$call wiadd(iadd,0,0,naval3,naoal3,0,0,0,0,iactva3,iactoa3,namplen)
|
|
endif
|
|
endif
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine resolve(namplen,nstr,nmax,v,nnir,isympv,isympo,ita,
|
|
$tarec,nactm,icmem,naval2,naoal2,navbe2,naobe2,iactva2,iactoa2,
|
|
$iactvb2,iactob2,naval1,naoal1,navbe1,naobe1,iactva1,iactoa1,
|
|
$iactvb1,iactob1,irec,iwa)
|
|
************************************************************************
|
|
* This subroutine resolves restrictions in ampliptudes *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nnir,ii,nmax,nactm,i,j,k,l,ii1,ii2,ii3,inc2,ssym,iw,inc1
|
|
integer isymv1,isymo1,isymva1,isymvb1,isymoa1,isymob1,irv1,iro1
|
|
integer isymv2,isymo2,isymva2,isymvb2,isymoa2,isymob2,irv2,iro2
|
|
integer isymv3,isymo3,isymva3,isymvb3,isymoa3,isymob3,irv3,iro3
|
|
integer nvstral1,nvstrbe1,nostral1,nostrbe1,ir1,namplen,irec
|
|
integer nvstral2,nvstrbe2,nostral2,nostrbe2,ir2,isym1
|
|
integer nvstral3,nvstrbe3,nostral3,nostrbe3,ir3,isym2
|
|
integer naval1,naoal1,navbe1,naobe1,naval2,naoal2,navbe2,naobe2
|
|
integer naval3,naoal3,navbe3,naobe3,iwa(nnir,2)
|
|
integer iactva1,iactoa1,iactvb1,iactob1
|
|
integer iactva2,iactoa2,iactvb2,iactob2
|
|
integer iactva3,iactoa3,iactvb3,iactob3
|
|
integer nstr(nnir,0:nactm,0:nmax,4),ita(nnir,nnir,nnir,nnir)
|
|
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 tarec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax)
|
|
integer icmem(nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,4)
|
|
real*8 v(*)
|
|
C
|
|
ssym=1 !Only for T vertices
|
|
naval3=naval1+naval2
|
|
navbe3=navbe1+navbe2
|
|
naoal3=naoal1+naoal2
|
|
naobe3=naobe1+naobe2
|
|
iactva3=iactva1+iactva2
|
|
iactvb3=iactvb1+iactvb2
|
|
iactoa3=iactoa1+iactoa2
|
|
iactob3=iactob1+iactob2
|
|
read(tafile,rec=tarec(iactva3,iactvb3,iactoa3,iactob3,naval3)) ita
|
|
C
|
|
ii1=1
|
|
do ir=1,nir
|
|
isym2=isympair(ssym,ir,1)
|
|
isym1=isympair(ssym,ir,2)
|
|
call slength(nmax,nstr,nnir,isympv,isympo,nactm,inc2,isym2,
|
|
$iactva2,iactvb2,naval2,navbe2,iactoa2,iactob2,naoal2,naobe2,
|
|
$isympair)
|
|
call slength(nmax,nstr,nnir,isympv,isympo,nactm,inc1,isym1,
|
|
$iactva1,iactvb1,naval1,navbe1,iactoa1,iactob1,naoal1,naobe1,
|
|
$isympair)
|
|
iwa(isym1,1)=ii1
|
|
iwa(isym1,2)=inc2
|
|
do ir1=1,nir
|
|
isymv1=isympair(isym1,ir1,1)
|
|
isymo1=isympair(isym1,ir1,2)
|
|
do irv1=1,isympv(0,isymv1,iactva1,iactvb1,naval1,navbe1,1)
|
|
isymva1=isympv(irv1,isymv1,iactva1,iactvb1,naval1,navbe1,1)
|
|
isymvb1=isympv(irv1,isymv1,iactva1,iactvb1,naval1,navbe1,2)
|
|
nvstral1=nstr(isymva1,iactva1,naval1,1)
|
|
nvstrbe1=nstr(isymvb1,iactvb1,navbe1,2)
|
|
do iro1=1,isympo(0,isymo1,iactoa1,iactob1,naoal1,naobe1,1)
|
|
isymoa1=isympo(iro1,isymo1,iactoa1,iactob1,naoal1,naobe1,1)
|
|
isymob1=isympo(iro1,isymo1,iactoa1,iactob1,naoal1,naobe1,2)
|
|
nostral1=nstr(isymoa1,iactoa1,naoal1,3)
|
|
nostrbe1=nstr(isymob1,iactob1,naobe1,4)
|
|
C
|
|
ii2=ii1
|
|
do ir2=1,nir
|
|
isymv2=isympair(isym2,ir2,1)
|
|
isymo2=isympair(isym2,ir2,2)
|
|
do irv2=1,isympv(0,isymv2,iactva2,iactvb2,naval2,
|
|
$navbe2,1)
|
|
isymva2=isympv(irv2,isymv2,iactva2,iactvb2,naval2,navbe2,1)
|
|
isymvb2=isympv(irv2,isymv2,iactva2,iactvb2,naval2,navbe2,2)
|
|
nvstral2=nstr(isymva2,iactva2,naval2,1)
|
|
nvstrbe2=nstr(isymvb2,iactvb2,navbe2,2)
|
|
isymva3=mult(isymva1,isymva2)
|
|
isymvb3=mult(isymvb1,isymvb2)
|
|
nvstral3=nstr(isymva3,iactva3,naval3,1)
|
|
nvstrbe3=nstr(isymvb3,iactvb3,navbe3,2)
|
|
do iro2=1,isympo(0,isymo2,iactoa2,iactob2,naoal2,
|
|
$naobe2,1)
|
|
isymoa2=isympo(iro2,isymo2,iactoa2,iactob2,naoal2,naobe2,1)
|
|
isymob2=isympo(iro2,isymo2,iactoa2,iactob2,naoal2,naobe2,2)
|
|
nostral2=nstr(isymoa2,iactoa2,naoal2,3)
|
|
nostrbe2=nstr(isymob2,iactob2,naobe2,4)
|
|
isymoa3=mult(isymoa1,isymoa2)
|
|
isymob3=mult(isymob1,isymob2)
|
|
nostral3=nstr(isymoa3,iactoa3,naoal3,3)
|
|
nostrbe3=nstr(isymob3,iactob3,naobe3,4)
|
|
ii=ita(isymva3,isymvb3,isymoa3,isymob3)
|
|
C
|
|
ii2=ii2+nvstral2*nvstrbe2*nostral2*nostrbe2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii1=ii1+nvstral1*nvstrbe1*nostral1*nostrbe1*inc2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
maxmem=max(maxmem,dble(ii1+namplen))
|
|
c if(ii1+namplen.gt.maxcor)
|
|
c $write(6,*) 'Resolve',8.d0*dble(ii1+namplen)/dble(twoto20),
|
|
c $naval2,naoal2,navbe2,naobe2,naval1,naoal1,navbe1,naobe1
|
|
C Skip old amplitudes
|
|
ii1=ii1-1
|
|
namplen=ii1
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine conlam(trec,nstr,nmax,icmem,nvintnew1,nointnew1,
|
|
$nvirtnew1,noccnew1,nvintold1,nointold1,nvirtold1,noccold1,namp1,
|
|
$isig11,file1,irec1,file2,irec2,iadd,iaddo,ladd,v,isave,intrec,
|
|
$isympv,isympo,nnir,nconf,ita,tarec,iwa,isa,isw,iwan,file3,wspc1,
|
|
$wspc2,wspca,wsmax,nvintnewact,nointnewact,nvirtnewact,noccnewact,
|
|
$nvintoldact,nointoldact,nvirtoldact,noccoldact,nactm,earec,
|
|
$erec,econf,nnewsym,noldsym)
|
|
************************************************************************
|
|
* This subroutine contracts a lambda vertex with an intermediate *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nnir,nactm,i,j,k,m,in(4),itrp,itin(8),iamprec
|
|
integer nstr(nnir,0:nactm,0:nmax,4),isum,isa(*),n1,n2,n3,n4,nmem
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),is1
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer icmem,isa1,isa2,nvirtoldbelen,noccoldbelen,ifo
|
|
integer nvintnew1,nointnew1,nvirtnew1,noccnew1,nvintold1,nointold1
|
|
integer nvirtold1,noccold1,namp1,isig11,isig12,albeo(4),alben(4)
|
|
integer file1,file2,irec1,irec2,ircold,ircnew,isave,intrec,nsyma
|
|
integer iadd(0:1),ntoldlen,namplen,nsumnew,ia1,ia2,ntoldleno,is4
|
|
integer wsmax,iadda(0:wsmax),itinlen,iscro(nmax+2),iscrn(nmax+2)
|
|
integer nvintoldal,nvintoldbe,nvintoldallen,nvintoldbelen,ii,nsymw
|
|
integer nointoldal,nointoldbe,nointoldallen,nointoldbelen,isw(*)
|
|
integer nsumvirtallen,nsumvirtbelen,nvintnewallen,nvintnewbelen,jj
|
|
integer nvirtnewbelen,nsumoccallen,nsumoccbelen,nointnewallen,ifn
|
|
integer nointnewbelen,noccnewbelen,nampvirtlen,inco,incn,kk,incs
|
|
integer nampocclen,ntampvirtal,ntampvirtbe,ntampoccal,ntampoccbe
|
|
integer isympv(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2),isa3
|
|
integer isympo(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2),isa4
|
|
integer inewadd,ir1,isymi,isyma,iri,nintnewsymv,nintnewsymo,iriv
|
|
integer nintnewsymva,nintnewsymvb,irio,nintnewsymoa,nintnewsymob
|
|
integer ira,nvirtnewsym,noccnewsym,irav,nvirtnewsyma,nvirtnewsymb
|
|
integer irao,noccnewsyma,noccnewsymb,nsumsym,ntampsym,irs,nsumsymv
|
|
integer nsumsymo,irsv,nsumsymva,nsumsymvb,nintoldsymva,itadd,is2
|
|
integer nintoldsymvb,nintoldsymv,irso,nsumsymoa,nsumsymob,noldsym
|
|
integer nintoldsymoa,nintoldsymob,nintoldsymo,nintoldsym,irt,is3
|
|
integer ntampsymv,ntampsymo,irtv,ntampsymva,ntampsymvb,nampsymva
|
|
integer nampsymvb,nvirtoldsyma,nvirtoldsymb,nvirtoldsym,irto
|
|
integer ntampsymoa,ntampsymob,nampsymoa,nampsymob,noccoldsyma
|
|
integer tarec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer ita(nnir,nnir,nnir,nnir),noccoldsymb,noccoldsym,ntnewlen
|
|
integer j1,j2,j3,j4,ism1,ism2,ism3,ism4,n,isumsym(4),file3,ioldadd
|
|
integer iwa(nnir,nnir),incsum(nnir),isumact(4),nvirtnewallen
|
|
integer iwan(nnir,nnir,nnir,nnir,nnir),incnew(nnir),nampsym
|
|
integer wspc1(0:1),wspc2(0:1),wspca(0:1),iw,iaddo(0:1),nnewsym
|
|
integer nvintnewact,nointnewact,nvirtnewact,noccnewact
|
|
integer nvintoldact,nointoldact,nvirtoldact,noccoldact
|
|
integer nvintoldalact,nointoldalact,nvintoldbeact,nointoldbeact
|
|
integer nvirtoldalact,noccoldalact,nvirtoldbeact,noccoldbeact
|
|
integer nampvirtactmax,nampoccactmax,nampvirtactmin,nampoccactmin
|
|
integer nampvirtact,nampoccact,nampvirtalact,nampvirtbeact
|
|
integer nampoccalact,nampoccbeact,nsumvirtalact,nsumvirtbeact
|
|
integer ntampvirtalact,ntampvirtbeact,nvintnewalact,nvintnewbeact
|
|
integer nvirtnewalact,nvirtnewbeact,noccnewalact,noccnewbeact
|
|
integer nsumoccalact,ntampoccalact,nsumoccbeact,ntampoccbeact
|
|
integer earec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer nointnewalact,nointnewbeact
|
|
integer econf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer erec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer nsumvirtal,nsumvirtbe,nsumoccal,nsumoccbe
|
|
integer nampvirtal,nampvirtbe,nampoccal,nampoccbe
|
|
integer nvintnewal,nvintnewbe,nointnewal,nointnewbe
|
|
integer nvirtnewal,nvirtnewbe,noccnewal,noccnewbe
|
|
integer nsumvirt,nsumocc,nvirtoldal,noccoldal,nvirtoldbe,noccoldbe
|
|
c
|
|
integer nvintnew,nointnew,nintnew,nvirtnew,noccnew,nvintold
|
|
integer nointold,nintold,nvirtold,noccold
|
|
c
|
|
real*8 v(*)
|
|
logical log,log1(4),ladd
|
|
C Initialize variables
|
|
if(isave.eq.2) call ifillzero(iadda,wsmax+1)
|
|
nvintnew=nvintnew1
|
|
nointnew=nointnew1
|
|
nintnew=nvintnew+nointnew
|
|
nvirtnew=nvirtnew1
|
|
noccnew=noccnew1
|
|
C
|
|
nvintold=nvintold1
|
|
nointold=nointold1
|
|
nintold=nvintold+nointold
|
|
nvirtold=nvirtold1
|
|
noccold=noccold1
|
|
C
|
|
namp=iabs(namp1)
|
|
nampsym=mult(nnewsym,noldsym)
|
|
C
|
|
nsumvirt=nvirtold
|
|
nsumocc=noccold
|
|
nsum=nsumvirt+nsumocc
|
|
nampvirtactmax=min(nactv,nsumvirt+nvirtnewact)
|
|
nampoccactmax=min(nacto,nsumocc+noccnewact)
|
|
nampvirtactmin=nvirtoldact+nvirtnewact
|
|
nampoccactmin=noccoldact+noccnewact
|
|
if(left) then !c3 ?
|
|
nampvirtactmax=nampvirtactmin
|
|
nampoccactmax=nampoccactmin
|
|
endif
|
|
C Loop over spin cases of intermediates
|
|
do iw=1,wspc2(0)
|
|
nvintoldal=wspc2((iw-1)*12+1)
|
|
nointoldal=wspc2((iw-1)*12+2)
|
|
nvirtoldal=wspc2((iw-1)*12+3)
|
|
noccoldal=wspc2((iw-1)*12+4)
|
|
nvintoldalact=wspc2((iw-1)*12+5)
|
|
nointoldalact=wspc2((iw-1)*12+6)
|
|
nvintoldbeact=wspc2((iw-1)*12+7)
|
|
nointoldbeact=wspc2((iw-1)*12+8)
|
|
nvirtoldalact=wspc2((iw-1)*12+9)
|
|
noccoldalact=wspc2((iw-1)*12+10)
|
|
nvirtoldbeact=nvirtoldact-nvirtoldalact
|
|
noccoldbeact=noccoldact-noccoldalact
|
|
ircold=wspc2((iw-1)*12+11)
|
|
ntoldlen=wspc2((iw-1)*12+12)
|
|
ntoldleno=ntoldlen
|
|
nvintoldbe=nvintold-nvintoldal
|
|
nointoldbe=nointold-nointoldal
|
|
nvirtoldbe=nvirtold-nvirtoldal
|
|
noccoldbe=noccold-noccoldal
|
|
if(ladd) then
|
|
ia1=1
|
|
else
|
|
call fwspc(iaddo,nvintoldal,nointoldal,nvirtoldal,noccoldal,
|
|
$nvintoldalact,nointoldalact,nvintoldbeact,nointoldbeact,
|
|
$nvirtoldalact,noccoldalact,ia1,ia2)
|
|
endif
|
|
if(ia1.gt.0) then
|
|
nvintnewal=nvintoldal
|
|
nvintnewbe=nvintoldbe
|
|
nointnewal=nointoldal
|
|
nointnewbe=nointoldbe
|
|
nvintnewalact=nvintoldalact
|
|
nvintnewbeact=nvintoldbeact
|
|
nointnewalact=nointoldalact
|
|
nointnewbeact=nointoldbeact
|
|
nsumvirtal=nvirtoldal
|
|
nsumvirtbe=nvirtoldbe
|
|
nsumoccal=noccoldal
|
|
nsumoccbe=noccoldbe
|
|
nsumvirtalact=nvirtoldalact
|
|
nsumvirtbeact=nvirtoldbeact
|
|
nsumoccalact=noccoldalact
|
|
nsumoccbeact=noccoldbeact
|
|
do nampvirtal=nsumvirtal,min(nvirtal,namp,namp-nsumvirtbe)
|
|
nampvirtbe=namp-nampvirtal
|
|
ntampvirtal=nampvirtal-nsumvirtal
|
|
ntampvirtbe=nampvirtbe-nsumvirtbe
|
|
nvirtnewal=ntampvirtal
|
|
nvirtnewbe=ntampvirtbe
|
|
nampoccal=nampvirtal
|
|
nampoccbe=namp-nampoccal
|
|
ntampoccal=nampoccal-nsumoccal
|
|
ntampoccbe=nampoccbe-nsumoccbe
|
|
noccnewal=ntampoccal
|
|
noccnewbe=ntampoccbe
|
|
do nampvirtact=nampvirtactmin,nampvirtactmax
|
|
do nampoccact=nampoccactmin,nampoccactmax
|
|
do nampvirtalact=max(0,nampvirtact-nactvb,
|
|
$nsumvirtalact,nampvirtact-
|
|
$ntampvirtbe-nsumvirtbeact),min(nampvirtact-nsumvirtbeact,
|
|
$nactva,nampvirtact,nampvirtal,ntampvirtal+nsumvirtalact)
|
|
nampvirtbeact=nampvirtact-nampvirtalact
|
|
ntampvirtalact=nampvirtalact-nsumvirtalact
|
|
ntampvirtbeact=nampvirtbeact-nsumvirtbeact
|
|
nvirtnewalact=ntampvirtalact
|
|
nvirtnewbeact=ntampvirtbeact
|
|
do nampoccalact=max(0,nampoccact-nactob,
|
|
$nsumoccalact,
|
|
$nampoccact-ntampoccbe-nsumoccbeact),min(nampoccact-nsumoccbeact,
|
|
$nactoa,nampoccact,nampoccal,ntampoccal+nsumoccalact)
|
|
nampoccbeact=nampoccact-nampoccalact
|
|
if((iroot.eq.1.or.(zroute.and.(.not.osc)).or.(osc.and.l3route))
|
|
$.and.(.not.l1route).and.(.not.d1route)) then
|
|
iamprec=trec(nampvirtalact,nampvirtbeact,
|
|
$nampoccalact,nampoccbeact,nampvirtal,namp)
|
|
namplen=nconf(nampvirtalact,nampvirtbeact,nampoccalact,
|
|
$nampoccbeact,nampvirtal,namp)
|
|
else
|
|
iamprec=erec(nampvirtalact,nampvirtbeact,
|
|
$nampoccalact,nampoccbeact,nampvirtal,namp)
|
|
namplen=econf(nampvirtalact,nampvirtbeact,nampoccalact,
|
|
$nampoccbeact,nampvirtal,namp)
|
|
endif
|
|
if(iamprec.gt.0) then
|
|
ntampoccalact=nampoccalact-nsumoccalact
|
|
ntampoccbeact=nampoccbeact-nsumoccbeact
|
|
noccnewalact=ntampoccalact
|
|
noccnewbeact=ntampoccbeact
|
|
call fwspc(wspc1,nvintnewal,nointnewal,nvirtnewal,noccnewal,
|
|
$nvintnewalact,nointnewalact,nvintnewbeact,nointnewbeact,
|
|
$nvirtnewalact,noccnewalact,ircnew,ntnewlen)
|
|
C
|
|
if(ircnew.gt.0) then
|
|
C
|
|
ntoldlen=ntoldleno !If the intermediate has been skipped
|
|
C Length of new/old free indices
|
|
do isymi=1,nir
|
|
call slength(nmax,nstr,nnir,isympv,isympo,nactm,incs,isymi,
|
|
$nvintnewalact,nvintnewbeact,nvintnewal,nvintnewbe,nointnewalact,
|
|
$nointnewbeact,nointnewal,nointnewbe,isympair)
|
|
incnew(isymi)=incs
|
|
enddo
|
|
C Length of summation (=old fixed) indices
|
|
do isymi=1,nir
|
|
call slength(nmax,nstr,nnir,isympv,isympo,nactm,incs,isymi,
|
|
$nsumvirtalact,nsumvirtbeact,nsumvirtal,nsumvirtbe,nsumoccalact,
|
|
$nsumoccbeact,nsumoccal,nsumoccbe,isympair)
|
|
incsum(isymi)=incs
|
|
enddo
|
|
C Memory addresses of old intermediates
|
|
inewadd=1
|
|
do ir1=1,nir
|
|
isymi=isympair(noldsym,ir1,1)
|
|
isyma=isympair(noldsym,ir1,2)
|
|
isum=incsum(isyma)
|
|
inco=incnew(isymi)
|
|
iwa(isymi,isyma)=inewadd
|
|
inewadd=inewadd+isum*inco
|
|
enddo
|
|
C Read amplitudes
|
|
if((iroot.eq.1.or.(zroute.and.(.not.osc)).or.(osc.and.l3route))
|
|
$.and.(.not.l1route).and.(.not.d1route)) then
|
|
read(tafile,rec=tarec(nampvirtalact,nampvirtbeact,nampoccalact,
|
|
$nampoccbeact,nampvirtal,namp)) ita
|
|
else
|
|
read(tafile,rec=earec(nampvirtalact,nampvirtbeact,nampoccalact,
|
|
$nampoccbeact,nampvirtal,namp)) ita
|
|
endif
|
|
nmem=ntnewlen+ntoldlen+namplen+1
|
|
C Memory addresses of new intermediates
|
|
call nlength(nmax,nstr,nnir,isympv,isympo,nactm,nvirtnewalact,
|
|
$nvirtnewbeact,nvirtnewal,nvirtnewbe,noccnewalact,noccnewbeact,
|
|
$noccnewal,noccnewbe,incnew,inewadd,nnewsym,iwan)
|
|
C Loop over symmetry cases of cluster amplitudes
|
|
do ir=1,nir
|
|
nsumsym=isympair(nampsym,ir,1)
|
|
ntampsym=isympair(nampsym,ir,2)
|
|
isymi=mult(nnewsym,ntampsym)
|
|
ioldadd=ntnewlen+iwa(isymi,nsumsym)
|
|
do irt=1,nir
|
|
ntampsymv=isympair(ntampsym,irt,1)
|
|
ntampsymo=isympair(ntampsym,irt,2)
|
|
do irtv=1,isympv(0,ntampsymv,ntampvirtalact,ntampvirtbeact,
|
|
$ntampvirtal,ntampvirtbe,1)
|
|
ntampsymva=isympv(irtv,ntampsymv,ntampvirtalact,
|
|
$ntampvirtbeact,ntampvirtal,ntampvirtbe,1)
|
|
ntampsymvb=isympv(irtv,ntampsymv,ntampvirtalact,
|
|
$ntampvirtbeact,ntampvirtal,ntampvirtbe,2)
|
|
nvirtnewallen=nstr(ntampsymva,ntampvirtalact,ntampvirtal,1)
|
|
nvirtnewbelen=nstr(ntampsymvb,ntampvirtbeact,ntampvirtbe,2)
|
|
c nvirtnewlen=nvirtnewallen*nvirtnewbelen
|
|
do irto=1,isympo(0,ntampsymo,ntampoccalact,ntampoccbeact,
|
|
$ntampoccal,ntampoccbe,1)
|
|
ntampsymoa=isympo(irto,ntampsymo,ntampoccalact,
|
|
$ntampoccbeact,ntampoccal,ntampoccbe,1)
|
|
ntampsymob=isympo(irto,ntampsymo,ntampoccalact,
|
|
$ntampoccbeact,ntampoccal,ntampoccbe,2)
|
|
noccnewallen=nstr(ntampsymoa,ntampoccalact,ntampoccal,3)
|
|
noccnewbelen=nstr(ntampsymob,ntampoccbeact,ntampoccbe,4)
|
|
c noccnewlen=noccnewallen*noccnewbelen
|
|
C Loop over symmetry cases of summation indices
|
|
call sumsym(nstr,nmax,icmem,isympv,isympo,nnir,ita,nactm,isa,
|
|
$nsumsym,nsyma,nsumlen,nsumvirtalact,nsumvirtbeact,nsumvirtallen,
|
|
$nsumvirtbelen,ntampsymva,ntampsymvb,nampvirtalact,nampvirtbeact,
|
|
$nampvirtlen,nsumoccalact,nsumoccbeact,nsumoccallen,nsumoccbelen,
|
|
$ntampsymoa,ntampsymob,nampoccalact,nampoccbeact,nampocclen,
|
|
$ntnewlen,ntoldlen,ntampvirtal,ntampvirtalact,ntampvirtbe,
|
|
$ntampvirtbeact,ntampoccal,ntampoccalact,ntampoccbe,ntampoccbeact,1
|
|
$,nsumvirtal,nsumvirtbe,nsumoccal,nsumoccbe,nampvirtal,nampvirtbe,
|
|
$nampoccal,nampoccbe)
|
|
if(nsumlen.gt.0) then
|
|
inewadd=iwan(isymi,ntampsymva,ntampsymvb,ntampsymoa,ntampsymob)
|
|
C Contraction
|
|
maxmem=max(maxmem,dble(nmem+nsumlen))
|
|
c if(nmem+nsumlen.gt.maxcor)
|
|
c $write(6,*) 'C2 ',8.d0*dble(nmem+nsumlen)/dble(twoto20)
|
|
#if defined (OMP)
|
|
ompmem=max(ompmem,dble(nmem)+dble(nsumlen)+
|
|
$ dble(xyzsize)*dble(incnew(isymi)*nvirtnewallen*
|
|
$nvirtnewbelen*noccnewallen*noccnewbelen+nsumlen))
|
|
#endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C Sign of intermediate
|
|
isig12=1
|
|
if(mod(nsumvirtbe*ntampvirtal+nsumoccbe*ntampoccal,2).ne.0)
|
|
$isig12=-isig12
|
|
C Save intermediate
|
|
call savenew(nmem,ntnewlen,wspca,isave,iadd,nvintnewalact,
|
|
$nointnewalact,nvintnewbeact,nointnewbeact,nvirtnewalact,
|
|
$noccnewalact,intrec,v,iadda,isig11,isig12,irec1,ircnew,file1,
|
|
$.false.,nampvirtalact,nampvirtbeact,nampoccalact,nampoccbeact,
|
|
$nvirtnewbeact,noccnewbeact,wspc1,nstr,nmax,isympv,isympo,ita,
|
|
$earec,tarec,nampvirtal,nampvirtbe,nampoccal,nampoccbe,nvintnewal,
|
|
$nvintnewbe,nointnewal,nointnewbe,nvirtnewal,nvirtnewbe,noccnewal,
|
|
$noccnewbe)
|
|
endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif !ia1.gt.0
|
|
enddo !iw
|
|
if(isave.eq.2) then
|
|
call imedret(file1,irec1,wspc1,intfile,intrec,isig11,iadd,v,
|
|
$nmax,2,1,1.d0,wspc1,wspca,nactmax,0,0,1,i,i,i,i,i,i,wsmax,0,0,1,
|
|
$nnewsym)
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine anti1(nconf,econf,trec,erec,nstr,nmax,v,nnir,isympv,
|
|
$isympo,ita,tarec,earec,nactm,icmem,wspc,nvintnew1,nointnew1,
|
|
$nvirtnew1,noccnew1,nvirtnewact,noccnewact,iadd,iaddo)
|
|
************************************************************************
|
|
* Initializes variables for anti *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nstr,nmax,nnir,isympv,isympo,ita,ii
|
|
integer nactm,icmem,wspc,nvintnew1,nointnew1,nvirtnew1,noccnew1
|
|
integer nvirtnewact,noccnewact,iadd,iaddo
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer econf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer erec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer tarec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer earec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
real*8 v
|
|
C
|
|
ii=nvintnew1+nvirtnew1
|
|
if((iroot.gt.1.and.(((.not.zroute).and.(.not.l3route)).or.osc))
|
|
$.or.ptroute) then
|
|
call anti(econf(0,0,0,0,0,ii),erec(0,0,0,0,0,ii),nstr,nmax,
|
|
$v,nnir,isympv,isympo,ita,earec(0,0,0,0,0,ii),nactm,icmem,
|
|
$wspc,nvintnew1,nointnew1,nvirtnew1,noccnew1,nvirtnewact,
|
|
$noccnewact,iadd,iaddo)
|
|
else
|
|
call anti(nconf(0,0,0,0,0,ii),trec(0,0,0,0,0,ii),nstr,nmax,
|
|
$v,nnir,isympv,isympo,ita,tarec(0,0,0,0,0,ii),nactm,icmem,
|
|
$wspc,nvintnew1,nointnew1,nvirtnew1,noccnew1,nvirtnewact,
|
|
$noccnewact,iadd,iaddo)
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine conint(nstr,nmax,icmem,nvintnew1,nointnew1,nvirtnew1,
|
|
$noccnew1,nsumvirt1,nsumocc1,ntampvirt,ntampocc,isig11,file1,
|
|
$irec1,file2,irec2,iadd,iaddo,ladd,v,isave,intrec,isympv,isympo,
|
|
$nnir,ita,iwa,isa,isw,iwan,wspc1,wspc2,wspca,wsmax,nvintnewact,
|
|
$nointnewact,nvirtnewact,noccnewact,nsumvirtact,nsumoccact,
|
|
$ntampvirtact,ntampoccact,nactm,nvintold1,nointold1,nvirtold1,
|
|
$noccold1,nvintoldact1,nointoldact1,nvirtoldact1,noccoldact1,wspci,
|
|
$lint,nconf,trec,tarec,ita2,lasm,nnewsym,nampsym,file3,irec3,
|
|
$ioffs)
|
|
************************************************************************
|
|
* This subroutine contracts an L-T intermediate with an integral list *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nnir,nactm,i,j,k,m,iamprec,ii,isig13,isw(*),file3
|
|
integer nstr(nnir,0:nactm,0:nmax,4),isa(*),n1,n2,n3,n4,nmem,wsmax
|
|
integer icmem,inewadd,nointnewbelen,ioccnewlen,irec3,nvirtnewallen
|
|
integer nvintnew1,nointnew1,nvirtnew1,noccnew1,nvintold1,nointold1
|
|
integer nvirtold1,noccold1,isig11,isig12,iadda(0:wsmax),irsv,irtv
|
|
integer file1,file2,irec1,irec2,ircold,ircnew,isave,intrec,nsyma
|
|
integer iadd(0:1),ntoldlen,ia1,ia2,ntoldleno,itadd,ntampvirt,iw2
|
|
integer nvintoldal,nvintoldbe,nsymw,nointoldal,nointoldbe,ioffs
|
|
integer nvirtoldbelen,noccoldbelen,nsumoccalact,nsumoccbeact,inco
|
|
integer nsumvirtallen,nsumvirtbelen,nsumoccallen,nsumoccbelen,jj
|
|
integer nvirtnewbelen,noccnewbelen,kk,ir1,isymi,isyma,ntampocc
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax)
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax)
|
|
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 ira,nvirtnewsym,noccnewsym,irav,nvirtnewsyma,nvirtnewsymb
|
|
integer irao,noccnewsyma,noccnewsymb,nsumsym,irs,nsumsymv,ntampsym
|
|
integer nsumsymo,nsumsymva,nsumsymvb,nsumsymoa,nsumsymob,noldsym
|
|
integer nvirtoldsyma,nvirtoldsymb,nvirtoldsym,irto,noccoldsyma,irt
|
|
integer ita(nnir,nnir,nnir,nnir),noccoldsymb,noccoldsym,ntnewlen
|
|
integer ita2(nnir,nnir,nnir,nnir),incnts(nnir),iwa2(nnir,nnir)
|
|
integer iwa(nnir,nnir,nnir),incnew(nnir),wspci(0:1),ntampoccbe
|
|
integer iwan(nnir,nnir,nnir,nnir,nnir),j1,j2,j3,j4,n,irso,noltsym
|
|
integer wspc1(0:1),wspc2(0:1),wspca(0:1),iwi,iaddo(0:1),nnewsym
|
|
integer nvintnewact,nointnewact,nvirtnewact,noccnewact,ioldadd
|
|
integer nvintoldact,nointoldact,nvirtoldact,noccoldact,noltlen
|
|
integer nvintoldalact,nointoldalact,nvintoldbeact,nointoldbeact
|
|
integer nvirtoldalact,noccoldalact,nvirtoldbeact,noccoldbeact,incs
|
|
integer nsumvirtact,nsumoccact,nsumvirtalact,nsumvirtbeact !,tarec
|
|
integer tarec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax)
|
|
integer nvintnewalact,nvintnewbeact,nointnewalact,nointnewbeact
|
|
integer nvirtnewalact,nvirtnewbeact,noccnewalact,noccnewbeact
|
|
integer nsumvirt1,nsumocc1,ntampvirtact,ntampoccact,incsum(nnir)
|
|
integer ntampvirtlen,ntampocclen,nampsym,ntampvirtal,ntampoccal
|
|
integer incold(nnir),ntampvirtalact,ntampoccalact,ntampvirtbeact
|
|
integer ntampoccbeact,namplen,ntampvirtbe,nvintoldact1,isgnlt
|
|
integer nointoldact1,nvirtoldact1,noccoldact1,ioadd(nnir,2)
|
|
integer nsumvirtal,nsumvirtbe,nsumoccal,nsumoccbe,itarec
|
|
integer nampvirtal,nampvirtbe,nampoccal,nampoccbe,nsymi,nsumleni
|
|
integer nvintoldallen,nvintoldbelen,nvirtoldlen,nointoldallen
|
|
integer nointoldbelen,noccoldlen,nsumlena,nn,mmm,nsymts,n2newlen
|
|
integer nnsyma(nir),newmem(nir),nnslen(nir),nsslen(nir),xyzomp
|
|
integer ivintnewal,ivintnewbe,ivirtnewal,ivirtnewbe,ivintnewalact
|
|
integer ivintnewbeact,ivirtnewalact,ivirtnewbeact,iointnewal
|
|
integer iointnewbe,ioccnewal,ioccnewbe,iointnewalact,iointnewbeact
|
|
integer ioccnewalact,ioccnewbeact,ii1,nvintnewallen,nvintnewbelen
|
|
integer nvintnewal,nvintnewbe,nointnewal,nointnewbe,ivirtnewlen
|
|
integer nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,nointnewallen
|
|
integer nsumvirt,nsumocc,nvirtoldal,noccoldal,nvirtoldbe,noccoldbe
|
|
c
|
|
integer nvintnew,nointnew,nintnew,nvirtnew,noccnew,nvintold
|
|
integer nointold,nintold,nvirtold,noccold
|
|
c
|
|
real*8 v(*)
|
|
logical lint,ladd,lout,lasm,incore
|
|
C Initialize variables
|
|
#if defined (OMP)
|
|
xyzomp=xyzsiz1
|
|
#else
|
|
xyzomp=1
|
|
#endif
|
|
if(isave.eq.2) call ifillzero(iadda,wsmax+1)
|
|
nvintnew=nvintnew1
|
|
nointnew=nointnew1
|
|
nintnew=nvintnew+nointnew
|
|
nvirtnew=nvirtnew1
|
|
noccnew=noccnew1
|
|
C
|
|
lout=.false.
|
|
if(lint) then
|
|
if(nvintold1+nointold1.eq.0) lout=.true.
|
|
isgnlt=-1
|
|
nvintold=nvintnew1-nvintold1
|
|
nointold=nointnew1-nointold1
|
|
nvirtold=nvirtold1-nvirtnew1
|
|
noccold=noccold1-noccnew1
|
|
nvintoldact=nvintnewact-nvintoldact1
|
|
nointoldact=nointnewact-nointoldact1
|
|
nvirtoldact=nvirtoldact1-nvirtnewact
|
|
noccoldact=noccoldact1-noccnewact
|
|
call tspcase(nvintold,nointold,nvirtold,noccold,nvintoldact,
|
|
$nointoldact,nvirtoldact,noccoldact,wspci,wsmax,nconf,trec,nmax,
|
|
$nactm)
|
|
else
|
|
isgnlt=1
|
|
nvintold=nvintold1
|
|
nointold=nointold1
|
|
nvirtold=nvirtold1
|
|
noccold=noccold1
|
|
nvintoldact=nvintoldact1
|
|
nointoldact=nointoldact1
|
|
nvirtoldact=nvirtoldact1
|
|
noccoldact=noccoldact1
|
|
endif
|
|
nintold=nvintold+nointold
|
|
noldsym=mult(nnewsym,nampsym)
|
|
C
|
|
nsumvirt=nsumvirt1
|
|
nsumocc=nsumocc1
|
|
nsum=nsumvirt+nsumocc
|
|
C Loop over spin cases of integral list/T vertex
|
|
do iwi=1,wspci(0)
|
|
if(iwi*12.le.wsmax) then
|
|
nvintoldal=wspci((iwi-1)*12+1)
|
|
nointoldal=wspci((iwi-1)*12+2)
|
|
nvirtoldal=wspci((iwi-1)*12+3)
|
|
noccoldal=wspci((iwi-1)*12+4)
|
|
nvintoldalact=wspci((iwi-1)*12+5)
|
|
nointoldalact=wspci((iwi-1)*12+6)
|
|
nvintoldbeact=wspci((iwi-1)*12+7)
|
|
nointoldbeact=wspci((iwi-1)*12+8)
|
|
nvirtoldalact=wspci((iwi-1)*12+9)
|
|
noccoldalact=wspci((iwi-1)*12+10)
|
|
ircold=wspci((iwi-1)*12+11)
|
|
ntoldlen=wspci((iwi-1)*12+12)
|
|
else
|
|
read(scrfile6) nvintoldal,nointoldal,nvirtoldal,noccoldal,
|
|
$nvintoldalact,nointoldalact,nvintoldbeact,nointoldbeact,
|
|
$nvirtoldalact,noccoldalact,ircold,ntoldlen
|
|
endif
|
|
nvirtoldbeact=nvirtoldact-nvirtoldalact
|
|
noccoldbeact=noccoldact-noccoldalact
|
|
ntoldleno=ntoldlen
|
|
nvintoldbe=nvintold-nvintoldal
|
|
nointoldbe=nointold-nointoldal
|
|
nvirtoldbe=nvirtold-nvirtoldal
|
|
noccoldbe=noccold-noccoldal
|
|
isig13=1
|
|
if(lint) then
|
|
ntoldlen=nconf(nvintoldalact+nvirtoldalact,nvintoldbeact+
|
|
$nvirtoldbeact,nointoldalact+noccoldalact,nointoldbeact+
|
|
$noccoldbeact,nvintoldal+nvirtoldal)
|
|
ircold=trec(nvintoldalact+nvirtoldalact,nvintoldbeact+
|
|
$nvirtoldbeact,nointoldalact+noccoldalact,nointoldbeact+
|
|
$noccoldbeact,nvintoldal+nvirtoldal)
|
|
itarec=tarec(nvintoldalact+nvirtoldalact,nvintoldbeact+
|
|
$nvirtoldbeact,nointoldalact+noccoldalact,nointoldbeact+
|
|
$noccoldbeact,nvintoldal+nvirtoldal)
|
|
C Unpack cluster amplitudes
|
|
if(mod(nvirtold*nvirtnew+noccold*noccnew !szemet
|
|
$+nvintold*nsumvirt+nointold*nsumocc,2).ne.0) isig13=-isig13
|
|
if(mod(nvintoldbe*nvirtoldal+nointoldbe*noccoldal,2).ne.0)
|
|
$isig13=-isig13
|
|
endif
|
|
C Loop over spin cases of old intermediate
|
|
do iw2=1,wspc2(0)
|
|
nsumvirtal=wspc2((iw2-1)*12+1)
|
|
nsumoccal=wspc2((iw2-1)*12+2)
|
|
ntampvirtal=wspc2((iw2-1)*12+3)
|
|
ntampoccal=wspc2((iw2-1)*12+4)
|
|
nsumvirtalact=wspc2((iw2-1)*12+5)
|
|
nsumoccalact=wspc2((iw2-1)*12+6)
|
|
nsumvirtbeact=wspc2((iw2-1)*12+7)
|
|
nsumoccbeact=wspc2((iw2-1)*12+8)
|
|
ntampvirtalact=wspc2((iw2-1)*12+9)
|
|
ntampoccalact=wspc2((iw2-1)*12+10)
|
|
ntampvirtbeact=ntampvirtact-ntampvirtalact
|
|
ntampoccbeact=ntampoccact-ntampoccalact
|
|
iamprec=wspc2((iw2-1)*12+11)
|
|
namplen=wspc2((iw2-1)*12+12)
|
|
nsumvirtbe=nsumvirt-nsumvirtal
|
|
nsumoccbe=nsumocc-nsumoccal
|
|
ntampvirtbe=ntampvirt-ntampvirtal
|
|
ntampoccbe=ntampocc-ntampoccal
|
|
if(ladd) then
|
|
ia1=1
|
|
else
|
|
call fwspc(iaddo,nsumvirtal,nsumoccal,ntampvirtal,ntampoccal
|
|
$,nsumvirtalact,nsumoccalact,nsumvirtbeact,nsumoccbeact,
|
|
$ntampvirtalact,ntampoccalact,ia1,ia2)
|
|
endif
|
|
if(ia1.gt.0) then
|
|
nvintnewal=nvintoldal-isign(nsumvirtal,isgnlt)
|
|
nvintnewbe=nvintoldbe-isign(nsumvirtbe,isgnlt)
|
|
nvirtnewal=ntampvirtal-nvirtoldal
|
|
nvirtnewbe=ntampvirtbe-nvirtoldbe
|
|
nvintnewalact=nvintoldalact-isign(nsumvirtalact,isgnlt)
|
|
nvintnewbeact=nvintoldbeact-isign(nsumvirtbeact,isgnlt)
|
|
nvirtnewalact=ntampvirtalact-nvirtoldalact
|
|
nvirtnewbeact=ntampvirtbeact-nvirtoldbeact
|
|
nointnewal=nointoldal-isign(nsumoccal,isgnlt)
|
|
nointnewbe=nointoldbe-isign(nsumoccbe,isgnlt)
|
|
noccnewal=ntampoccal-noccoldal
|
|
noccnewbe=ntampoccbe-noccoldbe
|
|
nointnewalact=nointoldalact-isign(nsumoccalact,isgnlt)
|
|
nointnewbeact=nointoldbeact-isign(nsumoccbeact,isgnlt)
|
|
noccnewalact=ntampoccalact-noccoldalact
|
|
noccnewbeact=ntampoccbeact-noccoldbeact
|
|
if(lint.or.lasm) then
|
|
ivintnewal=nvintnewal
|
|
ivintnewbe=nvintnewbe
|
|
ivirtnewal=nvirtnewal
|
|
ivirtnewbe=nvirtnewbe
|
|
ivintnewalact=nvintnewalact
|
|
ivintnewbeact=nvintnewbeact
|
|
ivirtnewalact=nvirtnewalact
|
|
ivirtnewbeact=nvirtnewbeact
|
|
iointnewal=nointnewal
|
|
iointnewbe=nointnewbe
|
|
ioccnewal=noccnewal
|
|
ioccnewbe=noccnewbe
|
|
iointnewalact=nointnewalact
|
|
iointnewbeact=nointnewbeact
|
|
ioccnewalact=noccnewalact
|
|
ioccnewbeact=noccnewbeact
|
|
else
|
|
ivintnewal=0
|
|
ivintnewbe=0
|
|
ivirtnewal=nvintnewal+nvirtnewal
|
|
ivirtnewbe=nvintnewbe+nvirtnewbe
|
|
ivintnewalact=0
|
|
ivintnewbeact=0
|
|
ivirtnewalact=nvintnewalact+nvirtnewalact
|
|
ivirtnewbeact=nvintnewbeact+nvirtnewbeact
|
|
iointnewal=0
|
|
iointnewbe=0
|
|
ioccnewal=nointnewal+noccnewal
|
|
ioccnewbe=nointnewbe+noccnewbe
|
|
iointnewalact=0
|
|
iointnewbeact=0
|
|
ioccnewalact=nointnewalact+noccnewalact
|
|
ioccnewbeact=nointnewbeact+noccnewbeact
|
|
nintnew=nvintnewal+nvintnewbe+nointnewal+nointnewbe
|
|
endif
|
|
call fwspc(wspc1,ivintnewal,iointnewal,ivirtnewal,ioccnewal,
|
|
$ivintnewalact,iointnewalact,ivintnewbeact,iointnewbeact,
|
|
$ivirtnewalact,ioccnewalact,ircnew,ntnewlen)
|
|
call fwspc(wspca,ivintnewal,iointnewal,ivirtnewal,ioccnewal,
|
|
$ivintnewalact,iointnewalact,ivintnewbeact,iointnewbeact,
|
|
$ivirtnewalact,ioccnewalact,i,j)
|
|
C
|
|
if(ircnew.gt.0.and.i.gt.0.and.j.gt.0.and.nvintnewal.ge.0
|
|
$.and.nvintnewbe.ge.0.and.nvirtnewal.ge.0.and.nvirtnewbe.ge.0.and.
|
|
$nvintnewalact.ge.0.and.nvintnewbeact.ge.0.and.nvirtnewalact.ge.0.
|
|
$and.nvirtnewbeact.ge.0.and.nointnewal.ge.0.and.nointnewbe.ge.0.
|
|
$and.noccnewal.ge.0.and.noccnewbe.ge.0.and.nointnewalact.ge.0.and.
|
|
$nointnewbeact.ge.0.and.noccnewalact.ge.0.and.noccnewbeact.ge.0)
|
|
$then
|
|
isig12=isig13
|
|
C Contract a T vertex with a L-T intermediate
|
|
if(lint) then
|
|
C Length of summation indices
|
|
do isymi=1,nir
|
|
call slength(nmax,nstr,nnir,isympv,isympo,nactm,incs,isymi,
|
|
$nsumvirtalact,nsumvirtbeact,nsumvirtal,nsumvirtbe,nsumoccalact,
|
|
$nsumoccbeact,nsumoccal,nsumoccbe,isympair)
|
|
incsum(isymi)=incs
|
|
enddo
|
|
C Length of new fixed indices
|
|
do isyma=1,nir
|
|
call slength(nmax,nstr,nnir,isympv,isympo,nactm,incs,isyma,
|
|
$nvirtnewalact,nvirtnewbeact,nvirtnewal,nvirtnewbe,noccnewalact,
|
|
$noccnewbeact,noccnewal,noccnewbe,isympair)
|
|
incold(isyma)=incs
|
|
enddo
|
|
C Length of free indices of lower vertex
|
|
do isymi=1,nir
|
|
call slength(nmax,nstr,nnir,isympv,isympo,nactm,incs,isymi,
|
|
$nvintoldalact,nvintoldbeact,nvintoldal,nvintoldbe,nointoldalact,
|
|
$nointoldbeact,nointoldal,nointoldbe,isympair)
|
|
incnts(isymi)=incs
|
|
enddo
|
|
C Memory addresses for lambdas/old intermediates (upper)
|
|
inewadd=1
|
|
do ir=1,nir
|
|
isymi=isympair(nampsym,ir,1)
|
|
isyma=isympair(nampsym,ir,2)
|
|
call slength(nmax,nstr,nnir,isympv,isympo,nactm,incs,isyma,
|
|
$ntampvirtalact,ntampvirtbeact,ntampvirtal,ntampvirtbe,
|
|
$ntampoccalact,ntampoccbeact,ntampoccal,ntampoccbe,isympair)
|
|
iwa2(isymi,isyma)=inewadd
|
|
inewadd=inewadd+incs*incsum(isymi)
|
|
enddo
|
|
C Memory addresses of new intermediates (before antisymmetrization)
|
|
inewadd=1
|
|
do ir=1,nir
|
|
isymi=isympair(nnewsym,ir,1)
|
|
isyma=isympair(nnewsym,ir,2)
|
|
do ir1=1,nir
|
|
nsymts=isympair(isymi,ir1,1)
|
|
nsumsym=isympair(isymi,ir1,2)
|
|
iwa(nsymts,nsumsym,isyma)=inewadd
|
|
inewadd=inewadd+incold(isyma)*incnts(nsymts)*incsum(nsumsym)
|
|
enddo
|
|
enddo
|
|
n2newlen=inewadd-1
|
|
nmem=xyzomp*n2newlen+ntoldlen+namplen+1
|
|
read(tafile,rec=itarec) ita
|
|
C Loop over symmetry cases of summation indices
|
|
do noltsym=1,nir
|
|
nsymts=mult(noltsym,noldsym)
|
|
C
|
|
do ira=1,nir
|
|
nvirtoldsym=isympair(noltsym,ira,1)
|
|
noccoldsym= isympair(noltsym,ira,2)
|
|
do irav=1,isympv(0,nvirtoldsym,nvirtoldalact,nvirtoldbeact,
|
|
$nvirtoldal,nvirtoldbe,1)
|
|
nvirtoldsyma=isympv(irav,nvirtoldsym,nvirtoldalact,nvirtoldbeact,
|
|
$nvirtoldal,nvirtoldbe,1)
|
|
nvirtoldsymb=isympv(irav,nvirtoldsym,nvirtoldalact,nvirtoldbeact,
|
|
$nvirtoldal,nvirtoldbe,2)
|
|
do irao=1,isympo(0,noccoldsym,noccoldalact,noccoldbeact,
|
|
$noccoldal,noccoldbe,1)
|
|
noccoldsyma=isympo(irao,noccoldsym,noccoldalact,noccoldbeact,
|
|
$noccoldal,noccoldbe,1)
|
|
noccoldsymb=isympo(irao,noccoldsym,noccoldalact,noccoldbeact,
|
|
$noccoldal,noccoldbe,2)
|
|
C Summation indices for amplitudes (lower)
|
|
call sumsym(nstr,nmax,icmem,isympv,isympo,nnir,ita,nactm,isw,
|
|
$nsymts,nsymi,nsumleni,nvintoldalact,nvintoldbeact,nvintoldallen,
|
|
$nvintoldbelen,nvirtoldsyma,nvirtoldsymb,nvintoldalact+
|
|
$nvirtoldalact,nvintoldbeact+nvirtoldbeact,nvirtoldlen,
|
|
$nointoldalact,nointoldbeact,nointoldallen,nointoldbelen,
|
|
$noccoldsyma,noccoldsymb,nointoldalact+noccoldalact,nointoldbeact+
|
|
$noccoldbeact,noccoldlen,n2newlen,0,nvirtoldal,nvirtoldalact
|
|
$,nvirtoldbe,nvirtoldbeact,noccoldal,noccoldalact,noccoldbe,
|
|
$noccoldbeact,1,nvintoldal,nvintoldbe,nointoldal,nointoldbe,
|
|
$nvintoldal+nvirtoldal,nvintoldbe+nvirtoldbe,nointoldal+noccoldal,
|
|
$nointoldbe+noccoldbe)
|
|
C Summation indices for lambdas/old intermediates (upper)
|
|
nsyma=0
|
|
mmm=0
|
|
do nsumsym=1,nir
|
|
ntampsym=mult(nampsym,nsumsym)
|
|
isyma=mult(noltsym,ntampsym)
|
|
nsumlen=incsum(nsumsym)
|
|
nsumlena=incold(isyma)
|
|
if(nsumlena*nsumlen.gt.0) then
|
|
nsyma=nsyma+1
|
|
inewadd=iwa(nsymts,nsumsym,isyma)
|
|
ioldadd=n2newlen+iwa2(nsumsym,ntampsym)+1
|
|
if(lout) ioldadd=ioldadd-1
|
|
C Address of L-T intermediate
|
|
call tlength(nmax,nstr,nnir,isympv,isympo,nactm,inco,
|
|
$ntampsym,ntampvirtalact,ntampvirtbeact,ntampvirtal,ntampvirtbe,
|
|
$ntampoccalact,ntampoccbeact,ntampoccal,ntampoccbe,ita2,nsumlen,0)
|
|
C
|
|
call sumsym(nstr,nmax,icmem,isympv,isympo,nnir,ita2,nactm,
|
|
$isa(mmm*12+1),isyma,nn,nsumlena,nvirtnewalact,nvirtnewbeact,
|
|
$nvirtnewallen,nvirtnewbelen,nvirtoldsyma,nvirtoldsymb,
|
|
$ntampvirtalact,ntampvirtbeact,nvirtoldlen,noccnewalact,
|
|
$noccnewbeact,noccnewallen,noccnewbelen,noccoldsyma,noccoldsymb,
|
|
$ntampoccalact,ntampoccbeact,noccoldlen,ioldadd,ntoldlen,
|
|
$nvirtoldal,nvirtoldalact,nvirtoldbe,nvirtoldbeact,noccoldal,
|
|
$noccoldalact,noccoldbe,noccoldbeact,nsumlen,nvirtnewal,nvirtnewbe,
|
|
$noccnewal,noccnewbe,ntampvirtal,ntampvirtbe,ntampoccal,ntampoccbe)
|
|
nnsyma(nsyma)=nn
|
|
newmem(nsyma)=inewadd
|
|
nnslen(nsyma)=nsumlen*nsumlena
|
|
nsslen(nsyma)=nsumlen
|
|
mmm=mmm+nn
|
|
endif
|
|
enddo
|
|
C Contraction
|
|
if(nsyma.gt.0) then
|
|
if(lout) then
|
|
maxmem=max(maxmem,dble(nmem+nsumleni+nnslen(1)))
|
|
#if defined (OMP)
|
|
ompmem=max(ompmem,dble(nmem+nsumleni+nnslen(1))+
|
|
$dble(xyzsize)*dble(nsumleni*nnslen(1)+nsumleni+nnslen(1)))
|
|
#endif
|
|
c if(nmem+nsumleni+nnslen(1).gt.maxcor)
|
|
c $write(6,*) 'C3 ',8.d0*dble(nmem+nsumleni+nnslen(1))/
|
|
c $dble(twoto20)
|
|
else
|
|
do ii1=1,nsyma
|
|
maxmem=max(maxmem,dble(nmem+nsumleni+nnslen(ii1)))
|
|
#if defined (OMP)
|
|
ompmem=max(ompmem,dble(nmem+nsumleni+nnslen(ii1))+
|
|
$dble(xyzsize)*dble(n2newlen+nsumleni+nnslen(ii1)))
|
|
#endif
|
|
c if(nmem+nsumleni+nnslen(ii1).gt.maxcor)
|
|
c $write(6,*) 'C3 ',8.d0*dble(nmem+nsumleni+nnslen(ii1))/
|
|
c $dble(twoto20)
|
|
enddo
|
|
endif
|
|
endif
|
|
enddo !irao
|
|
enddo !irav
|
|
enddo !ira
|
|
enddo !noltsym
|
|
C Antisymmetrize new intermediate
|
|
if(.not.lout) then
|
|
if(n2newlen+xyzomp*ntnewlen.le.maxcor) then
|
|
incore=.true.
|
|
ii=1
|
|
jj=n2newlen+1
|
|
else
|
|
incore=.false.
|
|
ii=xyzomp*ntnewlen+1
|
|
jj=1
|
|
endif
|
|
nopmax=max(nopmax,dble(n2newlen+ntnewlen))
|
|
#if defined (OMP)
|
|
ompmem=max(ompmem,dble(n2newlen)+dble(xyzsize)*dble(ntnewlen))
|
|
#endif
|
|
call asymw(nstr,nmax,nnir,isympv,isympo,ita,nactm,icmem,nnewsym,
|
|
$nvintoldal,nointoldal,nvintoldbe,nointoldbe,nsumvirtal,nsumoccal,
|
|
$nsumvirtbe,nsumoccbe,nvintnewal,nointnewal,nvintnewbe,nointnewbe,
|
|
$nvintoldalact,nointoldalact,nvintoldbeact,nointoldbeact,
|
|
$nsumvirtalact,nsumoccalact,nsumvirtbeact,nsumoccbeact,
|
|
$nvintnewalact,nointnewalact,nvintnewbeact,nointnewbeact,v(ii),
|
|
$v(jj),incold,incnts,incsum,incore,ntnewlen,v,
|
|
$maxcor-xyzomp*ntnewlen)
|
|
endif
|
|
C Sign of intermediate
|
|
if(mod(nvirtnewbe*nvirtoldal+noccnewbe*noccoldal+
|
|
$nsumvirtal*nvintoldbe+nsumoccal*nointoldbe,2).ne.0) isig12=-isig12
|
|
C Contract an integral list with a L-T intermediate
|
|
else
|
|
C Transpose integral list
|
|
if(.not.lasm) n2newlen=ntnewlen
|
|
call transposition(nmax,nnir,nactm,nstr,icmem,isympv,isympo,iwa,
|
|
$iwan,v,isig12,ntoldlen,ntoldleno,1,intfile,irec2,ircold,ita,
|
|
$n2newlen,incnew,noldsym,nnewsym,nvintoldal,nvintoldbe,nointoldal,
|
|
$nointoldbe,nvintoldalact,nvintoldbeact,nointoldalact,nointoldbeact
|
|
$,nvintnewalact,nvintnewbeact,nointnewalact,nointnewbeact,
|
|
$nsumvirtalact,nsumvirtbeact,nsumoccalact,nsumoccbeact,
|
|
$nvirtoldalact,nvirtoldbeact,noccoldalact,noccoldbeact,
|
|
$nvirtnewalact,nvirtnewbeact,noccnewalact,noccnewbeact,incsum,
|
|
$.false.,iwa,incold,nsumvirtal,nsumvirtbe,nsumoccal,nsumoccbe,
|
|
$nvintnewal,nvintnewbe,nointnewal,nointnewbe,nvirtnewal,nvirtnewbe,
|
|
$noccnewal,noccnewbe,nintnew,nintold,nvintold,nointold,nvirtoldal,
|
|
$nvirtoldbe,noccoldal,noccoldbe,lasm,.false.,0,i,i,0,ioffs,.true.,
|
|
$xyzomp)
|
|
if(.not.lasm) call tlength(nmax,nstr,nnir,isympv,isympo,nactm,
|
|
$inco,nnewsym,ivirtnewalact,ivirtnewbeact,ivirtnewal,ivirtnewbe,
|
|
$ioccnewalact,ioccnewbeact,ioccnewal,ioccnewbe,ita2,1,0)
|
|
C Read L-T intermediate
|
|
nmem=xyzomp*n2newlen+ntoldlen+namplen+1
|
|
itadd=2
|
|
C Loop over symmetry cases of old intermediate
|
|
do ir=1,nir
|
|
nsumsym=isympair(nampsym,ir,1)
|
|
ntampsym=isympair(nampsym,ir,2)
|
|
nsumlen=incsum(nsumsym)
|
|
if(nsumlen.gt.0) then
|
|
C Address of L-T intermediate
|
|
call tlength(nmax,nstr,nnir,isympv,isympo,nactm,inco,ntampsym,
|
|
$ntampvirtalact,ntampvirtbeact,ntampvirtal,ntampvirtbe,
|
|
$ntampoccalact,ntampoccbeact,ntampoccal,ntampoccbe,ita,nsumlen,0)
|
|
do ir1=1,nir
|
|
noltsym=isympair(ntampsym,ir1,1)
|
|
isyma=isympair(ntampsym,ir1,2)
|
|
isymi=mult(mult(nsumsym,noltsym),noldsym)
|
|
nintnewlen=incnew(isymi)
|
|
if(nintnewlen.gt.0) then
|
|
ioldadd=n2newlen+iwa(isymi,nsumsym,noltsym)
|
|
C Loop over symmetry cases of new intermediate
|
|
do ira=1,nir
|
|
nvirtnewsym=isympair(isyma,ira,1)
|
|
noccnewsym=isympair(isyma,ira,2)
|
|
do irav=1,isympv(0,nvirtnewsym,nvirtnewalact,
|
|
$nvirtnewbeact,nvirtnewal,nvirtnewbe,1)
|
|
nvirtnewsyma=isympv(irav,nvirtnewsym,nvirtnewalact,nvirtnewbeact,
|
|
$nvirtnewal,nvirtnewbe,1)
|
|
nvirtnewsymb=isympv(irav,nvirtnewsym,nvirtnewalact,nvirtnewbeact,
|
|
$nvirtnewal,nvirtnewbe,2)
|
|
do irao=1,isympo(0,noccnewsym,noccnewalact,
|
|
$noccnewbeact,noccnewal,noccnewbe,1)
|
|
noccnewsyma=isympo(irao,noccnewsym,noccnewalact,noccnewbeact,
|
|
$noccnewal,noccnewbe,1)
|
|
noccnewsymb=isympo(irao,noccnewsym,noccnewalact,noccnewbeact,
|
|
$noccnewal,noccnewbe,2)
|
|
C Loop over symmetry cases of summation indices
|
|
call sumsym(nstr,nmax,icmem,isympv,isympo,nnir,ita,nactm,isa,
|
|
$noltsym,nsyma,noltlen,nvirtoldalact,nvirtoldbeact,nvirtoldallen,
|
|
$nvirtoldbelen,nvirtnewsyma,nvirtnewsymb,ntampvirtalact,
|
|
$ntampvirtbeact,ntampvirtlen,noccoldalact,noccoldbeact,
|
|
$noccoldallen,noccoldbelen,noccnewsyma,noccnewsymb,ntampoccalact,
|
|
$ntampoccbeact,ntampocclen,n2newlen+itadd,ntoldlen,nvirtnewal,
|
|
$nvirtnewalact,nvirtnewbe,nvirtnewbeact,noccnewal,noccnewalact,
|
|
$noccnewbe,noccnewbeact,nsumlen,nvirtoldal,nvirtoldbe,noccoldal,
|
|
$noccoldbe,ntampvirtal,ntampvirtbe,ntampoccal,ntampoccbe)
|
|
if(lasm) then
|
|
inewadd=
|
|
$iwan(isymi,nvirtnewsyma,nvirtnewsymb,noccnewsyma,noccnewsymb)
|
|
else
|
|
inewadd=1
|
|
C Loop over symmetry cases of fixed labels of integral
|
|
call sumsym(nstr,nmax,icmem,isympv,isympo,nnir,ita2,nactm,isw,
|
|
$isymi,nsymi,nintnewlen,nvintnewalact,nvintnewbeact,nvintnewallen,
|
|
$nvintnewbelen,nvirtnewsyma,nvirtnewsymb,ivirtnewalact,
|
|
$ivirtnewbeact,ivirtnewlen,nointnewalact,nointnewbeact,
|
|
$nointnewallen,nointnewbelen,noccnewsyma,noccnewsymb,ioccnewalact,
|
|
$ioccnewbeact,ioccnewlen,1,0,nvirtnewal,
|
|
$nvirtnewalact,nvirtnewbe,nvirtnewbeact,noccnewal,noccnewalact,
|
|
$noccnewbe,noccnewbeact,1,nvintnewal,nvintnewbe,nointnewal,
|
|
$nointnewbe,ivirtnewal,ivirtnewbe,ioccnewal,ioccnewbe)
|
|
endif
|
|
C Contraction
|
|
maxmem=max(maxmem,dble(nmem+nsumlen*noltlen+nintnewlen))
|
|
c if(nmem+nsumlen*noltlen+nintnewlen.gt.maxcor)
|
|
c $write(6,*) 'C4 ',8.d0*dble(nmem+nsumlen*noltlen+nintnewlen)/
|
|
c $dble(twoto20)
|
|
#if defined (OMP)
|
|
if(lasm) then
|
|
ompmem=max(ompmem,dble(nmem+nsumlen*noltlen+nintnewlen)+
|
|
$dble(xyzsize)*dble(nsumlen*noltlen+nintnewlen+
|
|
$nintnewlen*nstr(nvirtnewsyma,nvirtnewalact,nvirtnewal,1)*
|
|
$nstr(nvirtnewsymb,nvirtnewbeact,nvirtnewbe,2)*
|
|
$nstr(noccnewsyma,noccnewalact,noccnewal,3)*
|
|
$nstr(noccnewsymb,noccnewbeact,noccnewbe,4)))
|
|
else
|
|
ompmem=max(ompmem,dble(nmem+nsumlen*noltlen+nintnewlen)+
|
|
$dble(xyzsize)*dble(nsumlen*noltlen+nintnewlen+n2newlen))
|
|
endif
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
enddo
|
|
itadd=itadd+inco*nsumlen
|
|
endif !nsumlen
|
|
enddo !ir
|
|
C Sign of intermediate
|
|
if(mod(nvirtoldbe*nvirtnewal+noccoldbe*noccnewal,2).ne.0)
|
|
$isig12=-isig12
|
|
if(.not.lasm.and.mod(nvintnewbe*nvirtnewal+nointnewbe*noccnewal,
|
|
$2).ne.0) isig12=-isig12
|
|
endif !lint
|
|
C Save intermediate
|
|
call savenew(nmem,ntnewlen,wspca,isave,iadd,ivintnewalact,
|
|
$iointnewalact,ivintnewbeact,iointnewbeact,ivirtnewalact,
|
|
$ioccnewalact,intrec,v(1),iadda,isig11,isig12,irec1,ircnew,file1,
|
|
$.false.,1,1,1,1,ivirtnewbeact,ioccnewbeact,wspc1,nstr,nmax,isympv,
|
|
$isympo,ita,i,i,0,0,0,0,ivintnewal,
|
|
$ivintnewbe,iointnewal,iointnewbe,ivirtnewal,ivirtnewbe,ioccnewal,
|
|
$ioccnewbe)
|
|
endif !irecnew
|
|
endif !ia1
|
|
enddo !iw2
|
|
enddo !iwi
|
|
C
|
|
if(isave.eq.2)
|
|
$call imedret(file1,irec1,wspc1,intfile,intrec,isig11,iadd,v,
|
|
$nmax,2,1,1.d0,wspc1,wspca,nactmax,0,0,1,i,i,i,i,i,i,wsmax,1,0,1,
|
|
$nnewsym)
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine tspcase(nav2,nao2,nav1,nao1,iactv2,iacto2,iactv1,iacto1
|
|
$,wspc,wsmax,nconf,trec,nmax,nactm)
|
|
************************************************************************
|
|
* Set up spin cases for cluster amplitudes *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nactm,wsmax,wspc(0:wsmax),iw,nn,iactvbe1,iactobe1
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax)
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax)
|
|
integer nav2,nao2,nav1,nao1,iactv2,iacto2,iactv1,iacto1
|
|
integer naval2,naoal2,naval1,naoal1,iactval2,iactoal2,iactval1
|
|
integer iactoal1,navbe2,naobe2,navbe1,iactvbe2,iactobe2
|
|
integer naval,navbe,naobe,iactval,iactoal,iactvbe,iactobe
|
|
C
|
|
rewind(scrfile6)
|
|
call ifillzero(wspc(0),wsmax+1)
|
|
iw=0
|
|
do naval2=max(0,nav2-nvirtbe),min(nvirtal,nav2)
|
|
navbe2=nav2-naval2
|
|
do naoal2=max(0,nao2-nbe),min(nal,nao2)
|
|
naobe2=nao2-naoal2
|
|
do iactval2=max(0,iactv2-nactvb),min(naval2,iactv2,nactva)
|
|
iactvbe2=iactv2-iactval2
|
|
do iactoal2=max(0,iacto2-nactob),min(naoal2,iacto2,nactoa)
|
|
iactobe2=iacto2-iactoal2
|
|
do naval1=max(0,nav1-nvirtbe,nav1+navbe2-nvirtbe),
|
|
$min(nav1,nvirtal-naval2)
|
|
navbe1=nav1-naval1
|
|
naval=naval1+naval2
|
|
navbe=navbe1+navbe2
|
|
naoal1=naval-naoal2
|
|
do iactval1=max(0,iactv1+iactvbe2-nactvb),
|
|
$min(naval1,iactv1,nactva,nactva-iactval2)
|
|
iactvbe1=iactv1-iactval1
|
|
iactval=iactval1+iactval2
|
|
iactvbe=iactvbe1+iactvbe2
|
|
do iactoal1=max(0,iacto1+iactobe2-nactob),
|
|
$min(naoal1,iacto1,nactoa,nactoa-iactoal2)
|
|
iactobe1=iacto1-iactoal1
|
|
iactoal=iactoal1+iactoal2
|
|
iactobe=iactobe1+iactobe2
|
|
nn=nconf(iactval,iactvbe,iactoal,iactobe,naval)
|
|
if(nn.gt.0) then
|
|
iw=iw+1
|
|
if(iw*12.le.wsmax) then
|
|
wspc((iw-1)*12+1)=naval2
|
|
wspc((iw-1)*12+2)=naoal2
|
|
wspc((iw-1)*12+3)=naval1
|
|
wspc((iw-1)*12+4)=naoal1
|
|
wspc((iw-1)*12+5)=iactval2
|
|
wspc((iw-1)*12+6)=iactoal2
|
|
wspc((iw-1)*12+7)=iactvbe2
|
|
wspc((iw-1)*12+8)=iactobe2
|
|
wspc((iw-1)*12+9)=iactval1
|
|
wspc((iw-1)*12+10)=iactoal1
|
|
wspc((iw-1)*12+11)=trec(iactval,iactvbe,iactoal,iactobe,naval)
|
|
wspc((iw-1)*12+12)=nn
|
|
else
|
|
write(scrfile6) naval2,naoal2,naval1,naoal1,iactval2,iactoal2,
|
|
$iactvbe2,iactobe2,iactval1,iactoal1,
|
|
$trec(iactval,iactvbe,iactoal,iactobe,naval),nn
|
|
endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
wspc(0)=iw
|
|
rewind(scrfile6)
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine asymw(nstr,nmax,nnir,isympv,isympo,ita,nactm,icmem,
|
|
$nnewsym,naval2,naoal2,navbe2,naobe2,naval1,naoal1,navbe1,naobe1,
|
|
$naval3,naoal3,navbe3,naobe3,iactva2,iactoa2,iactvb2,iactob2,
|
|
$iactva1,iactoa1,iactvb1,iactob1,iactva3,iactoa3,iactvb3,iactob3,
|
|
$vold,vnew,incold,inc2,inc1,incore,ntnewlen,v,maxlen)
|
|
************************************************************************
|
|
* This subroutine antisymmetrizes free labels of intermediates *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nnir,ii,jj,nmax,nactm,ii1,nnewsym,i,ile2,isymi,isyma,incn
|
|
integer ir1,incold(nnir),inc1(nnir),inc2(nnir),isym1,isym2,ile1,j
|
|
integer naval1,naoal1,navbe1,naobe1,naval2,naoal2,navbe2,naobe2,kk
|
|
integer naval3,naoal3,navbe3,naobe3,inewadd,ioldadd,irn,nostrbe1,k
|
|
integer iactva1,iactoa1,iactvb1,iactob1,isymv1,isymo1,irv1,isymva1
|
|
integer iactva2,iactoa2,iactvb2,iactob2,isymvb1,nvstral1,nvstrbe1
|
|
integer iactva3,iactoa3,iactvb3,iactob3,isymoa1,isymob1,nostral1
|
|
integer nstr(nnir,0:nactm,0:nmax,4),ita(nnir,nnir,nnir,nnir),ii2
|
|
integer isympv(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2),ir2
|
|
integer isympo(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2),iii
|
|
integer icmem(nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,4),iro1,kkk
|
|
integer isymv2,isymo2,irv2,isymva2,isymvb2,nvstral2,isymva3,inci
|
|
integer isymvb3,nvstral3,nvstrbe3,iro2,isymoa2,isymob2,nostral2
|
|
integer nostrbe2,isymoa3,isymob3,nostral3,nostrbe3,nvstrbe2,idist
|
|
integer ntnewlen,maxlen,maxinc,ndist,nsht
|
|
real*8 vnew(*),vold(*),v(*)
|
|
logical incore
|
|
C Loop over symmetry cases
|
|
ndist=1
|
|
ioldadd=1
|
|
inewadd=1
|
|
do ir=1,nir
|
|
isymi=isympair(nnewsym,ir,1)
|
|
isyma=isympair(nnewsym,ir,2)
|
|
call tlength(nmax,nstr,nnir,isympv,isympo,nactm,incn,isymi,
|
|
$iactva3,iactvb3,naval3,navbe3,iactoa3,iactob3,naoal3,naobe3,ita,1,
|
|
$0)
|
|
if(incold(isyma).gt.0) then
|
|
do irn=1,nir
|
|
isym2=isympair(isymi,irn,1)
|
|
isym1=isympair(isymi,irn,2)
|
|
ile1=inc1(isym1)
|
|
ile2=inc2(isym2)
|
|
inci=ile1*ile2
|
|
maxmem=max(maxmem,dble(ntnewlen+ile1*ile2))
|
|
c if(ntnewlen+ile1*ile2
|
|
c $.gt.maxcor)
|
|
c $write(6,*) 'C31',8.d0*dble(ntnewlen+ile1*ile2)/dble(twoto20)
|
|
enddo
|
|
endif
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|