mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-26 00:11:21 +01:00
4204 lines
161 KiB
Fortran
Executable File
4204 lines
161 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,xyzomp
|
|
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 defined (OMP)
|
|
xyzomp=xyzsiz1
|
|
#else
|
|
xyzomp=1
|
|
#endif
|
|
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
|
|
call getlst(scrfile4,ircold,v(1),noldlen)
|
|
if(mod(navbe2*naval1+naobe2*naoal1,2).ne.0)
|
|
$call add(v(1),v(1),noldlen,0,-1,1.d0,1.d0)
|
|
call getlst(scrfile1,trec(iactva3,iactvb3,iactoa3,iactob3,naval3),
|
|
$v(noldlen+1),namplen)
|
|
read(tafile,rec=tarec(iactva3,iactvb3,iactoa3,iactob3,naval3)) ita
|
|
C
|
|
ii1=1
|
|
call dfillzero(v(noldlen+namplen+1),xyzomp*namplen)
|
|
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 asym1(nstr,nmax,nnir,isympv,isympo,ita,nactm,icmem,
|
|
$ii1,inc2,isym1,isym2,naval1,naoal1,navbe1,naobe1,naval2,
|
|
$naoal2,navbe2,naobe2,naval3,naoal3,navbe3,naobe3,iactva1,iactoa1,
|
|
$iactvb1,iactob1,iactva2,iactoa2,iactvb2,iactob2,iactva3,iactoa3,
|
|
$iactvb3,iactob3,v,v(noldlen+1),namplen)
|
|
enddo
|
|
#if defined (OMP)
|
|
call ompred(v(noldlen+1),namplen)
|
|
#endif
|
|
call putlst(scrfile1,trec(iactva3,iactvb3,iactoa3,iactob3,naval3),
|
|
$v(noldlen+1),namplen)
|
|
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 asym(wold,wnew,inc,coupsval,coupsvbe,coupsoal,coupsobe,
|
|
$nvaal,nvabe,noaal,noabe,nvoalo,nvobeo,nooalo,nvsalo,nvsbeo,nosalo,
|
|
$nosbeo,namplen)
|
|
************************************************************************
|
|
* This subroutine antisymmetrizes amplitudes *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer*1 isgnval,isgnvbe,isgnoal,isgnobe
|
|
integer n1,n2,ivstral,ivstrbe,ifvsal,nn1,nn2,ivsalad,ifvsbe,ifosal
|
|
integer iostral,iostrbe,ivstr,iostr,ivaal,ivabe,ioaal,ioabe,iivobe
|
|
integer iosbe,iosal,ivsbe,ivsal,ivoal,ivobe,nooalo,noobeo,ifosbe
|
|
integer nvsal,nvsbe,nosal,nosbe,nvoal,nvobe,inc,ii1,ii2,ii3,ii4
|
|
integer i,ii,nvsalo,nvsbeo,nosalo,nvoalo,nvobeo,nosbeo,namplen
|
|
integer nvaal,nvabe,noaal,noabe,ivo,iosbead,iosalad,ivsbead
|
|
integer coupsval(*),coupsoal(*),coupsvbe(*),coupsobe(*)
|
|
real*8 wold(*)
|
|
#if defined (OMP)
|
|
real*8 wnew(namplen,0:xyzsize)
|
|
#else
|
|
real*8 wnew(*)
|
|
#endif
|
|
C
|
|
nn2=nvsalo*nvsbeo
|
|
nn1=nn2*nosalo
|
|
n2=nvoalo*nvobeo
|
|
n1=n2*nooalo
|
|
C$OMP PARALLEL
|
|
C$OMP& DEFAULT(PRIVATE)
|
|
C$OMP& SHARED(wold,inc,coupsval,coupsvbe,coupsoal,coupsobe,nvaal)
|
|
C$OMP& SHARED(nvabe,noaal,noabe,nvoalo,nvobeo,nooalo,nvsalo,nvsbeo)
|
|
C$OMP& SHARED(nosalo,n1,n2,nn1,nn2,xyzsize,wnew)
|
|
#if defined (OMP)
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
xyzcount=0
|
|
#endif
|
|
ii=0
|
|
do ioabe=1,noabe
|
|
ifosbe=coupsobe(ioabe)
|
|
nosbe=coupsobe(noabe+ioabe)
|
|
do ioaal=1,noaal
|
|
ifosal=coupsoal(ioaal)
|
|
nosal=coupsoal(noaal+ioaal)
|
|
do ivabe=1,nvabe
|
|
ifvsbe=coupsvbe(ivabe)
|
|
nvsbe=coupsvbe(nvabe+ivabe)
|
|
do ivaal=1,nvaal
|
|
ifvsal=coupsval(ivaal)
|
|
nvsal=coupsval(nvaal+ivaal)
|
|
#if defined (OMP)
|
|
if(thrd.eq.xyzcount) then
|
|
#endif
|
|
C
|
|
ii1=ifosbe
|
|
do iosbe=1,nosbe
|
|
ii1=ii1+1
|
|
iosbead=ii+n1*(coupsobe(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=coupsobe(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(coupsoal(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=coupsoal(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+nvoalo*(coupsvbe(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=coupsvbe(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nvsalo
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+coupsval(ii4)
|
|
ii4=ii4+1
|
|
ivstral=coupsval(ii4)
|
|
isgnval=isgnvbe*isign(1,ivstral)
|
|
ivstral=ivstrbe+iabs(ivstral)
|
|
#if defined (OMP)
|
|
wnew(ivstral,thrd)=wnew(ivstral,thrd)+isgnval*wold(ivsalad)
|
|
#else
|
|
wnew(ivstral)=wnew(ivstral)+isgnval*wold(ivsalad)
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
#if defined (OMP)
|
|
endif
|
|
if(xyzcount.eq.xyzsize) then
|
|
xyzcount=0
|
|
else
|
|
xyzcount=xyzcount+1
|
|
endif
|
|
#endif
|
|
ii=ii+inc
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C$OMP END PARALLEL
|
|
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
|
|
call getlst(ampfile,irec,v(1),namplen)
|
|
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)
|
|
call dfillzero(v(namplen+ii1),inc1*inc2)
|
|
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
|
|
call reso(v(ii),v(namplen+ii2),inc2,
|
|
$icore(icmem(isymva2,isymva1,iactva2,iactva1,naval2,naval1,1)),
|
|
$icore(icmem(isymvb2,isymvb1,iactvb2,iactvb1,navbe2,navbe1,2)),
|
|
$icore(icmem(isymoa2,isymoa1,iactoa2,iactoa1,naoal2,naoal1,3)),
|
|
$icore(icmem(isymob2,isymob1,iactob2,iactob1,naobe2,naobe1,4)),
|
|
$nvstral1,nvstrbe1,nostral1,nostrbe1,
|
|
$nvstral2,nvstrbe2,nostral2,nostrbe2,
|
|
$nvstral3,nvstrbe3,nostral3,nostrbe3)
|
|
C
|
|
ii2=ii2+nvstral2*nvstrbe2*nostral2*nostrbe2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii1=ii1+nvstral1*nvstrbe1*nostral1*nostrbe1*inc2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C Skip old amplitudes
|
|
ii1=ii1-1
|
|
do i=1,ii1
|
|
v(i)=v(i+namplen)
|
|
enddo
|
|
namplen=ii1
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine reso(wold,wnew,inc,coupsval,coupsvbe,coupsoal,coupsobe,
|
|
$nvaal,nvabe,noaal,noabe,nvoalo,nvobeo,nooalo,noobeo,nvsalo,nvsbeo,
|
|
$nosalo,nosbeo)
|
|
************************************************************************
|
|
* This subroutine resolves restrictions in ampliptudes *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer*1 isgnval,isgnvbe,isgnoal,isgnobe
|
|
integer n1,n2,ivstral,ivstrbe,ifvsal,nn1,nn2,ivsalad,ifvsbe,ifosal
|
|
integer iostral,iostrbe,ivstr,iostr,ivaal,ivabe,ioaal,ioabe,iivobe
|
|
integer iosbe,iosal,ivsbe,ivsal,ivoal,ivobe,nooalo,noobeo,ifosbe
|
|
integer nvsal,nvsbe,nosal,nosbe,nvoal,nvobe,inc,ii1,ii2,ii3,ii4
|
|
integer i,ii,nvsalo,nvsbeo,nosalo,nosbeo,nvoalo,nvobeo
|
|
integer nvaal,nvabe,noaal,noabe,ivo,iosbead,iosalad,ivsbead
|
|
integer coupsval(*),coupsoal(*),coupsvbe(*),coupsobe(*)
|
|
real*8 wnew(nvsalo*nvsbeo*nosalo*nosbeo),wold(*)
|
|
C
|
|
nn2=nvsalo*nvsbeo
|
|
nn1=nn2*nosalo
|
|
n2=nvoalo*nvobeo
|
|
n1=n2*nooalo
|
|
C$OMP PARALLEL
|
|
C$OMP& DEFAULT(PRIVATE)
|
|
C$OMP& SHARED(wold,inc,coupsval,coupsvbe,coupsoal,coupsobe,nvaal)
|
|
C$OMP& SHARED(nvabe,noaal,noabe,nvoalo,nvobeo,nooalo,noobeo,nvsalo)
|
|
C$OMP& SHARED(nvsbeo,nosalo,nosbeo,n1,n2,nn1,nn2,xyzsize,wnew)
|
|
#if defined (OMP)
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
xyzcount=0
|
|
#endif
|
|
ii=0
|
|
do ioabe=1,noabe
|
|
ifosbe=coupsobe(ioabe)
|
|
nosbe=coupsobe(noabe+ioabe)
|
|
do ioaal=1,noaal
|
|
ifosal=coupsoal(ioaal)
|
|
nosal=coupsoal(noaal+ioaal)
|
|
do ivabe=1,nvabe
|
|
ifvsbe=coupsvbe(ivabe)
|
|
nvsbe=coupsvbe(nvabe+ivabe)
|
|
do ivaal=1,nvaal
|
|
ifvsal=coupsval(ivaal)
|
|
nvsal=coupsval(nvaal+ivaal)
|
|
#if defined (OMP)
|
|
if(thrd.eq.xyzcount) then
|
|
#endif
|
|
C
|
|
ii1=ifosbe
|
|
do iosbe=1,nosbe
|
|
ii1=ii1+1
|
|
iosbead=ii+n1*(coupsobe(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=coupsobe(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(coupsoal(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=coupsoal(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+nvoalo*(coupsvbe(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=coupsvbe(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nvsalo
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+coupsval(ii4)
|
|
ii4=ii4+1
|
|
ivstral=coupsval(ii4)
|
|
isgnval=isgnvbe*isign(1,ivstral)
|
|
ivstral=ivstrbe+iabs(ivstral)
|
|
wnew(ivsalad)=isgnval*wold(ivstral)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
#if defined (OMP)
|
|
endif
|
|
if(xyzcount.eq.xyzsize) then
|
|
xyzcount=0
|
|
else
|
|
xyzcount=xyzcount+1
|
|
endif
|
|
#endif
|
|
ii=ii+inc
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C$OMP END PARALLEL
|
|
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,scspe)
|
|
************************************************************************
|
|
* 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,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,xyzomp
|
|
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(*),scspe
|
|
logical log,log1(4),ladd
|
|
#if defined (OMP)
|
|
xyzomp=xyzsiz1
|
|
#else
|
|
xyzomp=1
|
|
#endif
|
|
c write(6,*) 'conlam'
|
|
c write(6,*) '@ ',nvintnew1,
|
|
c $nointnew1,nvirtnew1,noccnew1,nvintold1,nointold1,nvirtold1,
|
|
c $noccold1,namp1,' ',file3
|
|
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
|
|
c do nampoccal=nsumoccal,min(nal,namp,namp-nsumoccbe)
|
|
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
|
|
call getlst(file2,irec2+ircold,v,ntoldlen)
|
|
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 Skip old intermediate
|
|
do i=xyzomp*ntnewlen+ntoldlen,xyzomp*ntnewlen+1,-1
|
|
v(i)=v(i-xyzomp*ntnewlen)
|
|
enddo
|
|
C Read amplitudes
|
|
call dfillzero(v,xyzomp*ntnewlen)
|
|
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
|
|
call getlst(file3,iamprec,v(xyzomp*ntnewlen+ntoldlen+1),namplen)
|
|
nmem=xyzomp*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=xyzomp*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,
|
|
$xyzomp*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
|
|
call contract2(v(inewadd),v(ioldadd),v,v(nmem),isa,nvirtnewallen,
|
|
$nvirtnewbelen,noccnewallen,noccnewbelen,nsyma,incnew(isymi),
|
|
$nsumlen,ntnewlen)
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
#if defined (OMP)
|
|
call ompred(v,ntnewlen)
|
|
#endif
|
|
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,scspe)
|
|
endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif !ia1.gt.0
|
|
enddo !iw
|
|
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,0,0,1,
|
|
$nnewsym,scspe)
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine contract2(wnew,wold,t,v,isa,nvaal,nvabe,noaal,noabe,
|
|
$nsyma,nin,nsuml,ntnewlen)
|
|
************************************************************************
|
|
* This subroutine evaluates the contractions between lambda amplitudes *
|
|
* and intermediates *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer*1 isgnval,isgnvbe,isgnoal,isgnobe
|
|
integer ivstral,ivstrbe,iostral,iostrbe,ivstr,iostr,iivobe,nn1,nn2
|
|
integer iosbe,iosal,ivsbe,ivsal,ivsalad,ifvsal,ivsbead,ifvsbe,inc
|
|
integer ivo,ioo,ifooal,ifoobe,ifvoal,ifvobe,iosalad,ifosal,nn3,n3
|
|
integer nv,no,n1,n2,isa(*),ivaal,ivabe,ioaal,ioabe,iosbead,itadd
|
|
integer nvsal,nvsbe,nosal,nosbe,nsyma,isc,nvaa,nvab,noaa,noab
|
|
integer i,ii,jj,nvsalo,nosbeo,nvaal,nvabe,noaal,noabe,nava,naoa
|
|
integer coupsval,coupsvbe,coupsoal,coupsobe,nin,nsuml,ntnewlen
|
|
integer ii1,ii2,ii3,ii4,iii
|
|
real*8 wold,t(*)
|
|
#if defined (OMP)
|
|
real*8 wnew(ntnewlen,0:xyzsize),v(nsuml,0:xyzsize)
|
|
#else
|
|
real*8 wnew(ntnewlen),v(nsuml)
|
|
#endif
|
|
C
|
|
C$OMP PARALLEL DO
|
|
C$OMP& DEFAULT(PRIVATE)
|
|
C$OMP& SHARED(icore,wold,t,isa,nvaal,nvabe,noaal,noabe,nsyma,nin,nsuml)
|
|
C$OMP& SHARED(wnew,v)
|
|
#if defined (OMP)
|
|
do iii=1,nvaal*nvabe*noaal*noabe
|
|
call ompind(iii,nvaal,nvabe,noaal,noabe,ivaal,ivabe,ioaal,ioabe)
|
|
noab=noabe+ioabe
|
|
noaa=noaal+ioaal
|
|
nvab=nvabe+ivabe
|
|
inc=(iii-1)*nin+1
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
#else
|
|
inc=1
|
|
do ioabe=1,noabe
|
|
noab=noabe+ioabe
|
|
do ioaal=1,noaal
|
|
noaa=noaal+ioaal
|
|
do ivabe=1,nvabe
|
|
nvab=nvabe+ivabe
|
|
do ivaal=1,nvaal
|
|
#endif
|
|
nvaa=nvaal+ivaal
|
|
C Unpack cluster amplitudes
|
|
#if defined (OMP)
|
|
call dfillzer1(v(1,thrd),nsuml)
|
|
#else
|
|
call dfillzer1(v,nsuml)
|
|
#endif
|
|
ii=0
|
|
jj=0
|
|
do isc=1,nsyma
|
|
ii=ii+1
|
|
coupsval=isa(ii)
|
|
ii=ii+1
|
|
coupsvbe=isa(ii)
|
|
ii=ii+1
|
|
coupsoal=isa(ii)
|
|
ii=ii+1
|
|
coupsobe=isa(ii)
|
|
ii=ii+1
|
|
nn1=isa(ii)
|
|
ii=ii+1
|
|
nn2=isa(ii)
|
|
ii=ii+1
|
|
nn3=isa(ii)
|
|
ii=ii+1
|
|
itadd=isa(ii)
|
|
ii=ii+1
|
|
n1=isa(ii)
|
|
ii=ii+1
|
|
n2=isa(ii)
|
|
ii=ii+1
|
|
n3=isa(ii)
|
|
ifvsal=coupsval+icore(coupsval+ivaal)
|
|
nvsal=icore(coupsval+nvaa)
|
|
ifvsbe=coupsvbe+icore(coupsvbe+ivabe)
|
|
nvsbe=icore(coupsvbe+nvab)
|
|
ifosal=coupsoal+icore(coupsoal+ioaal)
|
|
nosal=icore(coupsoal+noaa)
|
|
ii1=coupsobe+icore(coupsobe+ioabe)
|
|
do iosbe=1,icore(coupsobe+noab)
|
|
ii1=ii1+1
|
|
iosbead=jj+n1*(icore(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=icore(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=itadd+(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(icore(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=icore(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+n3*(icore(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=icore(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nn3
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+icore(ii4)
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
#if defined (OMP)
|
|
v(ivsalad,thrd)=
|
|
$isgnvbe*isign(1,ivstral)*t(ivstrbe+iabs(ivstral))
|
|
#else
|
|
v(ivsalad)=
|
|
$isgnvbe*isign(1,ivstral)*t(ivstrbe+iabs(ivstral))
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii=ii+1
|
|
jj=jj+isa(ii)
|
|
enddo
|
|
#if defined (OMP)
|
|
call matmul2(wnew(inc,thrd),wold,v(1,thrd),nin,nsuml)
|
|
#else
|
|
call matmul2(wnew(inc),wold,v,nin,nsuml)
|
|
#endif
|
|
#if (!OMP)
|
|
inc=inc+nin
|
|
enddo
|
|
enddo
|
|
enddo
|
|
#endif
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine matmul2(v1,mat,v2,n,m)
|
|
************************************************************************
|
|
* Vectorized matrix-vector product *
|
|
************************************************************************
|
|
implicit none
|
|
integer m,n,i,j,mm
|
|
real*8 v1(n),mat(*),v2(m),sum
|
|
C
|
|
mm=0
|
|
do j=1,m
|
|
sum=v2(j)
|
|
if(sum.ne.0.d0) then
|
|
do i=1,n
|
|
v1(i)=v1(i)+mat(mm+i)*sum
|
|
enddo
|
|
endif
|
|
mm=mm+n
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine contract3(wnew,t,v,isa,isw,nvaal,nvabe,noaal,noabe,
|
|
$nsyma,nsymw,nsuml,ntnewl)
|
|
************************************************************************
|
|
* This subroutine evaluates the contractions between cluster amplitudes*
|
|
* and intermediates containing both the integral list and lambda vertex*
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer*1 isgnval,isgnvbe,isgnoal,isgnobe
|
|
integer ivstral,ivstrbe,iostral,iostrbe,ivstr,iostr,iivobe,nn1,n3
|
|
integer iosbe,iosal,ivsbe,ivsal,ivoal,ivobe,iooal,ioobe,iioobe
|
|
integer nvoal,nvobe,nooal,noobe,ivsalad,ifvsal,ivsbead,ifvsbe,iii
|
|
integer ivo,ioo,ifooal,ifoobe,ifvoal,ifvobe,iosalad,ifosal
|
|
integer ii1,ii2,ii3,ii4,nsuml,ntnewl
|
|
integer nv,no,n1,n2,isa(*),isw(*),ivaal,ivabe,ioaal,ioabe,nsymw
|
|
integer nvsal,nvsbe,nosal,nosbe,nsyma,isc,nvaa,nvab,noaa,noab
|
|
integer i,ii,jj,nvsalo,nosbeo,nvaal,nvabe,noaal,noabe,nava,naoa
|
|
integer coupsval,coupsvbe,coupsoal,coupsobe,nin,nvn,non
|
|
integer coupwval,coupwoal,coupwvbe,coupwobe,nn2,nn3,nn4
|
|
integer nvoa,nvna,iosbead,itadd,no1,no2,no3,no4
|
|
real*8 t(*)
|
|
#if defined (OMP)
|
|
real*8 wnew(ntnewl,0:xyzsize),v(nsuml,0:xyzsize)
|
|
#else
|
|
real*8 wnew(ntnewl),v(nsuml)
|
|
#endif
|
|
C
|
|
C$OMP PARALLEL DO
|
|
C$OMP& DEFAULT(PRIVATE)
|
|
C$OMP& SHARED(icore,t,isa,isw,nvaal,nvabe,noaal,noabe,nsyma,nsymw)
|
|
C$OMP& SHARED(nsuml,ntnewl,wnew,v)
|
|
#if defined (OMP)
|
|
do iii=1,nvaal*nvabe*noaal*noabe
|
|
call ompind(iii,nvaal,nvabe,noaal,noabe,ivaal,ivabe,ioaal,ioabe)
|
|
noab=noabe+ioabe
|
|
noaa=noaal+ioaal
|
|
nvab=nvabe+ivabe
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
#else
|
|
do ioabe=1,noabe
|
|
noab=noabe+ioabe
|
|
do ioaal=1,noaal
|
|
noaa=noaal+ioaal
|
|
do ivabe=1,nvabe
|
|
nvab=nvabe+ivabe
|
|
do ivaal=1,nvaal
|
|
#endif
|
|
nvaa=nvaal+ivaal
|
|
C Unpack cluster amplitudes
|
|
#if defined (OMP)
|
|
call dfillzer1(v(1,thrd),nsuml)
|
|
#else
|
|
call dfillzer1(v,nsuml)
|
|
#endif
|
|
ii=0
|
|
jj=0
|
|
do isc=1,nsyma
|
|
ii=ii+1
|
|
coupsval=isa(ii)
|
|
ii=ii+1
|
|
coupsvbe=isa(ii)
|
|
ii=ii+1
|
|
coupsoal=isa(ii)
|
|
ii=ii+1
|
|
coupsobe=isa(ii)
|
|
ii=ii+1
|
|
nn1=isa(ii)
|
|
ii=ii+1
|
|
nn2=isa(ii)
|
|
ii=ii+1
|
|
nn3=isa(ii)
|
|
ii=ii+1
|
|
itadd=isa(ii)
|
|
ii=ii+1
|
|
n1=isa(ii)
|
|
ii=ii+1
|
|
n2=isa(ii)
|
|
ii=ii+1
|
|
n3=isa(ii)
|
|
ifvsal=coupsval+icore(coupsval+ivaal)
|
|
nvsal=icore(coupsval+nvaa)
|
|
ifvsbe=coupsvbe+icore(coupsvbe+ivabe)
|
|
nvsbe=icore(coupsvbe+nvab)
|
|
ifosal=coupsoal+icore(coupsoal+ioaal)
|
|
nosal=icore(coupsoal+noaa)
|
|
ii1=coupsobe+icore(coupsobe+ioabe)
|
|
do iosbe=1,icore(coupsobe+noab)
|
|
ii1=ii1+1
|
|
iosbead=jj+n1*(icore(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=icore(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=itadd+(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(icore(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=icore(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+n3*(icore(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=icore(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nn3
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+icore(ii4)
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
#if defined (OMP)
|
|
v(ivsalad,thrd)=
|
|
$isgnvbe*isign(1,ivstral)*t(ivstrbe+iabs(ivstral))
|
|
#else
|
|
v(ivsalad)=
|
|
$isgnvbe*isign(1,ivstral)*t(ivstrbe+iabs(ivstral))
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii=ii+1
|
|
jj=jj+isa(ii)
|
|
enddo
|
|
C Loop over symmetry cases of new (old) intermediates
|
|
ii=0
|
|
do isc=1,nsymw
|
|
ii=ii+1
|
|
n2=isw(ii)
|
|
ii=ii+1
|
|
no1=isw(ii)
|
|
ii=ii+1
|
|
no2=isw(ii)
|
|
ii=ii+1
|
|
no3=isw(ii)
|
|
ii=ii+1
|
|
no4=isw(ii)
|
|
ii=ii+1
|
|
n1=isw(ii)
|
|
ii=ii+1
|
|
nn1=isw(ii)
|
|
ii=ii+1
|
|
nn2=isw(ii)
|
|
ii=ii+1
|
|
nn3=isw(ii)
|
|
ii=ii+1
|
|
nn4=isw(ii)
|
|
ii=ii+1
|
|
coupwval=isw(ii)
|
|
ii=ii+1
|
|
coupwvbe=isw(ii)
|
|
ii=ii+1
|
|
coupwoal=isw(ii)
|
|
ii=ii+1
|
|
coupwobe=isw(ii)
|
|
ifvoal=coupwval+icore(coupwval+ivaal)
|
|
nvoal=icore(coupwval+nvaa)
|
|
ifvobe=coupwvbe+icore(coupwvbe+ivabe)
|
|
nvobe=icore(coupwvbe+nvab)
|
|
ifooal=coupwoal+icore(coupwoal+ioaal)
|
|
nooal=icore(coupwoal+noaa)
|
|
ii3=coupwobe+icore(coupwobe+ioabe)
|
|
do ioobe=1,icore(coupwobe+noab)
|
|
ii3=ii3+1
|
|
iioobe=n2+(icore(ii3)-1)*no1
|
|
ii3=ii3+1
|
|
iostrbe=icore(ii3)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=n1+(iabs(iostrbe)-1)*nn1
|
|
ii4=ifooal
|
|
do iooal=1,nooal
|
|
ii4=ii4+1
|
|
ioo=iioobe+(icore(ii4)-1)*no2
|
|
ii4=ii4+1
|
|
iostral=icore(ii4)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostral=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii1=ifvobe
|
|
do ivobe=1,nvobe
|
|
ii1=ii1+1
|
|
iivobe=ioo+(icore(ii1)-1)*no3
|
|
ii1=ii1+1
|
|
ivstrbe=icore(ii1)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostral+(iabs(ivstrbe)-1)*nn3
|
|
ii2=ifvoal
|
|
do ivoal=1,nvoal
|
|
ii2=ii2+1
|
|
ivo=iivobe+(icore(ii2)-1)*no4
|
|
ii2=ii2+1
|
|
ivstral=icore(ii2)
|
|
isgnval=isgnvbe*isign(1,ivstral)
|
|
#if defined (OMP)
|
|
call matmul1(wnew(ivo,thrd),
|
|
$t(ivstrbe+(iabs(ivstral)-1)*nn4),v(1,thrd),no4,nsuml,isgnval)
|
|
#else
|
|
call matmul1(wnew(ivo),
|
|
$t(ivstrbe+(iabs(ivstral)-1)*nn4),v,no4,nsuml,isgnval)
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
#if (!OMP)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
#endif
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine contract31(wnew,t,v,isa,isw,nvaal,nvabe,noaal,noabe,
|
|
$nsyma,nsymw,nsuml,ntnewl)
|
|
************************************************************************
|
|
* This subroutine evaluates the contractions between cluster amplitudes*
|
|
* and intermediates containing both the integral list and lambda vertex*
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer*1 isgnval,isgnvbe,isgnoal,isgnobe
|
|
integer ivstral,ivstrbe,iostral,iostrbe,ivstr,iostr,iivobe,nn1,n3
|
|
integer iosbe,iosal,ivsbe,ivsal,ivoal,ivobe,iooal,ioobe,iioobe
|
|
integer nvoal,nvobe,nooal,noobe,ivsalad,ifvsal,ivsbead,ifvsbe,iii
|
|
integer ivo,ioo,ifooal,ifoobe,ifvoal,ifvobe,iosalad,ifosal
|
|
integer ii1,ii2,ii3,ii4,nsuml,ntnewl
|
|
integer nv,no,n1,n2,isa(*),isw(*),ivaal,ivabe,ioaal,ioabe,nsymw
|
|
integer nvsal,nvsbe,nosal,nosbe,nsyma,isc,nvaa,nvab,noaa,noab
|
|
integer i,ii,jj,nvsalo,nosbeo,nvaal,nvabe,noaal,noabe,nava,naoa
|
|
integer coupsval,coupsvbe,coupsoal,coupsobe,nin,nvn,non
|
|
integer coupwval,coupwoal,coupwvbe,coupwobe,nn2,nn3,nn4
|
|
integer nvoa,nvna,iosbead,itadd,no1,no2,no3,no4
|
|
real*8 t(*)
|
|
#if defined (OMP)
|
|
real*8 wnew(ntnewl,0:xyzsize),v(nsuml,0:xyzsize)
|
|
#else
|
|
real*8 wnew(ntnewl),v(nsuml)
|
|
#endif
|
|
C
|
|
thrd=0
|
|
C$OMP PARALLEL
|
|
C$OMP& DEFAULT(PRIVATE)
|
|
C$OMP& SHARED(icore,t,isa,isw,nvaal,nvabe,noaal,noabe,nsyma,nsymw)
|
|
C$OMP& SHARED(nsuml,ntnewl,wnew,v,mpisize,mpicount)
|
|
#if defined (OMP)
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
#endif
|
|
#if defined (MPI) || defined (OMP)
|
|
xyzcount=0
|
|
#endif
|
|
do ioabe=1,noabe
|
|
noab=noabe+ioabe
|
|
do ioaal=1,noaal
|
|
noaa=noaal+ioaal
|
|
do ivabe=1,nvabe
|
|
nvab=nvabe+ivabe
|
|
do ivaal=1,nvaal
|
|
#if defined (MPI)
|
|
if(mpicount+thrd.eq.xyzcount) then
|
|
#elif defined (OMP)
|
|
if(thrd.eq.xyzcount) then
|
|
#endif
|
|
nvaa=nvaal+ivaal
|
|
C Unpack cluster amplitudes
|
|
#if defined (OMP)
|
|
v(1:nsuml,thrd)=0.d0
|
|
#else
|
|
v(1:nsuml)=0.d0
|
|
#endif
|
|
ii=0
|
|
jj=0
|
|
do isc=1,nsyma
|
|
ii=ii+1
|
|
coupsval=isa(ii)
|
|
ii=ii+1
|
|
coupsvbe=isa(ii)
|
|
ii=ii+1
|
|
coupsoal=isa(ii)
|
|
ii=ii+1
|
|
coupsobe=isa(ii)
|
|
ii=ii+1
|
|
nn1=isa(ii)
|
|
ii=ii+1
|
|
nn2=isa(ii)
|
|
ii=ii+1
|
|
nn3=isa(ii)
|
|
ii=ii+1
|
|
itadd=isa(ii)
|
|
ii=ii+1
|
|
n1=isa(ii)
|
|
ii=ii+1
|
|
n2=isa(ii)
|
|
ii=ii+1
|
|
n3=isa(ii)
|
|
ifvsal=coupsval+icore(coupsval+ivaal)
|
|
nvsal=icore(coupsval+nvaa)
|
|
ifvsbe=coupsvbe+icore(coupsvbe+ivabe)
|
|
nvsbe=icore(coupsvbe+nvab)
|
|
ifosal=coupsoal+icore(coupsoal+ioaal)
|
|
nosal=icore(coupsoal+noaa)
|
|
ii1=coupsobe+icore(coupsobe+ioabe)
|
|
do iosbe=1,icore(coupsobe+noab)
|
|
ii1=ii1+1
|
|
iosbead=jj+n1*(icore(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=icore(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=itadd+(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(icore(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=icore(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+n3*(icore(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=icore(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nn3
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+icore(ii4)
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
#if defined (OMP)
|
|
v(ivsalad,thrd)=
|
|
$isgnvbe*isign(1,ivstral)*t(ivstrbe+iabs(ivstral))
|
|
#else
|
|
v(ivsalad)=
|
|
$isgnvbe*isign(1,ivstral)*t(ivstrbe+iabs(ivstral))
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii=ii+1
|
|
jj=jj+isa(ii)
|
|
enddo
|
|
C Loop over symmetry cases of new (old) intermediates
|
|
ii=0
|
|
do isc=1,nsymw
|
|
ii=ii+1
|
|
n2=isw(ii)
|
|
ii=ii+1
|
|
no1=isw(ii)
|
|
ii=ii+1
|
|
no2=isw(ii)
|
|
ii=ii+1
|
|
no3=isw(ii)
|
|
ii=ii+1
|
|
no4=isw(ii)
|
|
ii=ii+1
|
|
n1=isw(ii)
|
|
ii=ii+1
|
|
nn1=isw(ii)
|
|
ii=ii+1
|
|
nn2=isw(ii)
|
|
ii=ii+1
|
|
nn3=isw(ii)
|
|
ii=ii+1
|
|
nn4=isw(ii)
|
|
ii=ii+1
|
|
coupwval=isw(ii)
|
|
ii=ii+1
|
|
coupwvbe=isw(ii)
|
|
ii=ii+1
|
|
coupwoal=isw(ii)
|
|
ii=ii+1
|
|
coupwobe=isw(ii)
|
|
ifvoal=coupwval+icore(coupwval+ivaal)
|
|
nvoal=icore(coupwval+nvaa)
|
|
ifvobe=coupwvbe+icore(coupwvbe+ivabe)
|
|
nvobe=icore(coupwvbe+nvab)
|
|
ifooal=coupwoal+icore(coupwoal+ioaal)
|
|
nooal=icore(coupwoal+noaa)
|
|
ii3=coupwobe+icore(coupwobe+ioabe)
|
|
do ioobe=1,icore(coupwobe+noab)
|
|
ii3=ii3+1
|
|
iioobe=n2+(icore(ii3)-1)*no1
|
|
ii3=ii3+1
|
|
iostrbe=icore(ii3)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=n1+(iabs(iostrbe)-1)*nn1
|
|
ii4=ifooal
|
|
do iooal=1,nooal
|
|
ii4=ii4+1
|
|
ioo=iioobe+(icore(ii4)-1)*no2
|
|
ii4=ii4+1
|
|
iostral=icore(ii4)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostral=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii1=ifvobe
|
|
do ivobe=1,nvobe
|
|
ii1=ii1+1
|
|
iivobe=ioo+(icore(ii1)-1)*no3
|
|
ii1=ii1+1
|
|
ivstrbe=icore(ii1)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostral+(iabs(ivstrbe)-1)*nn3
|
|
ii2=ifvoal
|
|
do ivoal=1,nvoal
|
|
ii2=ii2+1
|
|
ivo=iivobe+(icore(ii2)-1)*no4
|
|
ii2=ii2+1
|
|
ivstral=icore(ii2)
|
|
isgnval=isgnvbe*isign(1,ivstral)
|
|
#if defined (OMP)
|
|
call matmul1(wnew(ivo,thrd),
|
|
$t(ivstrbe+(iabs(ivstral)-1)*nn4),v(1,thrd),no4,nsuml,isgnval)
|
|
#else
|
|
call matmul1(wnew(ivo),
|
|
$t(ivstrbe+(iabs(ivstral)-1)*nn4),v,no4,nsuml,isgnval)
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
#if defined (MPI) || defined (OMP)
|
|
endif
|
|
if(xyzcount.eq.mpisize) then
|
|
xyzcount=0
|
|
else
|
|
xyzcount=xyzcount+1
|
|
endif
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C$OMP END PARALLEL
|
|
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,lpar,
|
|
$ioffs,irec4,ilev,scspe)
|
|
************************************************************************
|
|
* This subroutine contracts an L-T intermediate with an integral list *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nnir,nactm,i,j,k,m,iamprec,ii,isig13,irec4,ilev
|
|
integer isa(nnir**4,nnir,nnir),file3
|
|
integer nstr(nnir,0:nactm,0:nmax,4),isw(*),n1,n2,n3,n4,nmem,wsmax
|
|
integer icmem(nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,4)
|
|
integer inewadd,nointnewbelen,ioccnewlen,irec3
|
|
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 kk,ir1,isymi,isyma,ntampocc,nsumlena
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax),nsuml
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax),nintnewl
|
|
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**4,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,nsla
|
|
integer nampvirtal,nampvirtbe,nampoccal,nampoccbe,nsymi,nsumleni
|
|
integer nvintoldallen,nvintoldbelen,nointoldallen
|
|
integer nointoldbelen,nn,mmm,nsymts,n2newlen,isft,xyzomp
|
|
integer nsslen(nir)
|
|
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(*),scspe
|
|
logical lint,ladd,lout,lasm,incore,lpar
|
|
C Initialize variables
|
|
c write(6,*) 'conint'
|
|
c write(6,*) 'iaddo',(iaddo(i),i=1,iaddo(0)*12)
|
|
#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
|
|
c write(6,*) 't elott',nvintold,nointold,nvirtold,noccold,
|
|
c $nvintoldact,nointoldact,nvirtoldact,noccoldact
|
|
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,iconj(nampsym))
|
|
c write(6,*) 'noldsym',noldsym,nnewsym,nampsym,' ',wspci(0)
|
|
C
|
|
nsumvirt=nsumvirt1
|
|
nsumocc=nsumocc1
|
|
nsum=nsumvirt+nsumocc
|
|
C Loop over spin cases of integral list/T vertex
|
|
do iwi=1,wspci(0)
|
|
c write(6,*) 'iwi',iwi,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
|
|
c call resolve(ntoldlen,nstr,nmax,v,nnir,isympv,isympo,ita,
|
|
c $tarec,nactm,icmem,nvintoldal,nointoldal,nvintoldbe,nointoldbe,
|
|
c $nvintoldalact,nointoldalact,nvintoldbeact,nointoldbeact,
|
|
c $nvirtoldal,noccoldal,nvirtoldbe,noccoldbe,nvirtoldalact,
|
|
c $noccoldalact,nvirtoldbeact,noccoldbeact,ircold,ioadd)
|
|
c call putlst(scrfile5,1,v(1),ntoldlen)
|
|
endif
|
|
C Loop over spin cases of old intermediate
|
|
do iw2=1,wspc2(0)
|
|
c write(6,*) 'iw2',iw2,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
|
|
c write(6,*) 'wspc2',nsumvirtal,nsumoccal,ntampvirtal,ntampoccal,
|
|
c $nsumvirtalact,nsumoccalact,nsumvirtbeact,nsumoccbeact,
|
|
c $ntampvirtalact,ntampoccalact,
|
|
c $' ',iamprec,namplen,' ',ia1
|
|
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)
|
|
c write(6,*) 'ntnewlen',ivintnewal,iointnewal,ivirtnewal,ioccnewal,
|
|
c $ivintnewalact,iointnewalact,ivintnewbeact,iointnewbeact,
|
|
c $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,dsympair)
|
|
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,csympair)
|
|
incold(isyma)=incs
|
|
enddo
|
|
C Length of free indices of lower vertex
|
|
nsumleni=0
|
|
do isymi=1,nir
|
|
call slength(nmax,nstr,nnir,isympv,isympo,nactm,incs,isymi,
|
|
$nvintoldalact,nvintoldbeact,nvintoldal,nvintoldbe,nointoldalact,
|
|
$nointoldbeact,nointoldal,nointoldbe,dsympair)
|
|
incnts(isymi)=incs
|
|
nsumleni=max(nsumleni,incs)
|
|
enddo
|
|
C Addresses of summation indices
|
|
do ir=1,nir
|
|
call tlength(nmax,nstr,nnir,isympv,isympo,nactm,jj,ir,
|
|
$nvintoldalact,nvintoldbeact,nvintoldal,nvintoldbe,
|
|
$nointoldalact,nointoldbeact,nointoldal,nointoldbe,isw,1,0,
|
|
$dsympair)
|
|
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,csympair)
|
|
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
|
|
C
|
|
n2newlen=inewadd-1
|
|
call getlst(file3,irec3+ircold,v(xyzomp*n2newlen+1),ntoldlen) !amplitude
|
|
c write(6,*) 'old',file3,irec3,ircold,ntoldlen,trecmax
|
|
c write(6,*) 'old',(v(xyzomp*n2newlen+i),i=1,ntoldlen)
|
|
call dfillzero(v,xyzomp*n2newlen)
|
|
call getlst(file2,irec4+iamprec,v(xyzomp*n2newlen+ntoldlen+1),
|
|
$namplen) !old
|
|
c write(6,*) 'amp',(v(xyzomp*n2newlen+ntoldlen+i),i=1,namplen),iamprec,
|
|
c $irec4,file2
|
|
nmem=xyzomp*n2newlen+ntoldlen+namplen+1
|
|
read(tafile,rec=itarec) ita
|
|
c write(6,*) 'n2newlen',n2newlen,ntoldlen,namplen,(v(i),i=1,
|
|
c $xyzomp*n2newlen+ntoldlen+namplen+10)
|
|
C Addresses of indices of old intermediate
|
|
nsla=0
|
|
do nsumsym=1,nir
|
|
do nsymts=1,nir
|
|
ntampsym=mult(nampsym,iconj(nsymts))
|
|
isyma=mult(mult(nsumsym,iconj(noldsym)),ntampsym)
|
|
nsumlen=incsum(nsymts)
|
|
nsumlena=incold(isyma)*nsumlen
|
|
nsla=max(nsla,nsumlena)
|
|
if(nsumlena.gt.0) then
|
|
ioldadd=iwa2(nsymts,ntampsym)+1
|
|
isft=1
|
|
if(lout) then
|
|
ioldadd=ioldadd-1
|
|
isft=0
|
|
endif
|
|
call tlength(nmax,nstr,nir,isympv,isympo,nactm,inco,
|
|
$ntampsym,ntampvirtalact,ntampvirtbeact,ntampvirtal,ntampvirtbe,
|
|
$ntampoccalact,ntampoccbeact,ntampoccal,ntampoccbe,
|
|
$ita2(1,nsymts,nsumsym),nsumlen,ioldadd,csympair)
|
|
call tlength(nmax,nstr,nir,isympv,isympo,nactm,inco,
|
|
$isyma,nvirtnewalact,nvirtnewbeact,nvirtnewal,nvirtnewbe,
|
|
$noccnewalact,noccnewbeact,noccnewal,noccnewbe,
|
|
$isa(1,nsymts,nsumsym),nsumlen,isft,dsympair)
|
|
endif
|
|
enddo
|
|
enddo
|
|
C
|
|
if(lpar) then
|
|
call contract6(v,v(xyzomp*n2newlen+ntoldlen+1),
|
|
$v(xyzomp*n2newlen+1),v(nmem),isw,isa,icore,nnir,
|
|
$mult,nirmax,noldsym,ita,nampsym,incsum,incold,iwa,lout,ita2,
|
|
$nstr(1,nvirtoldalact,nvirtoldal,1),
|
|
$nstr(1,nvirtoldbeact,nvirtoldbe,2),
|
|
$nstr(1,noccoldalact,noccoldal,3),
|
|
$nstr(1,noccoldbeact,noccoldbe,4),incnts,nr2,nr3,nr4,nr5,nrr,
|
|
$icmem(1,1,nvintoldalact,nvirtoldalact,nvintoldal,nvirtoldal,1),
|
|
$icmem(1,1,nvintoldbeact,nvirtoldbeact,nvintoldbe,nvirtoldbe,2),
|
|
$icmem(1,1,nointoldalact,noccoldalact,nointoldal,noccoldal,3),
|
|
$icmem(1,1,nointoldbeact,noccoldbeact,nointoldbe,noccoldbe,4),
|
|
$nstr(1,nvintoldalact,nvintoldal,1),
|
|
$nstr(1,nvintoldbeact,nvintoldbe,2),
|
|
$nstr(1,nointoldalact,nointoldal,3),
|
|
$nstr(1,nvintoldalact+nvirtoldalact,nvintoldal+nvirtoldal,1),
|
|
$nstr(1,nvintoldbeact+nvirtoldbeact,nvintoldbe+nvirtoldbe,2),
|
|
$nstr(1,nointoldalact+noccoldalact,nointoldal+noccoldal,3),
|
|
$isympv(0,1,nvintoldalact,nvintoldbeact,nvintoldal,nvintoldbe,1),
|
|
$isympv(0,1,nvintoldalact,nvintoldbeact,nvintoldal,nvintoldbe,2),
|
|
$isympv(0,1,nvirtnewalact,nvirtnewbeact,nvirtnewal,nvirtnewbe,1),
|
|
$isympv(0,1,nvirtnewalact,nvirtnewbeact,nvirtnewal,nvirtnewbe,2),
|
|
$icmem(1,1,nvirtnewalact,nvirtoldalact,nvirtnewal,nvirtoldal,1),
|
|
$icmem(1,1,nvirtnewbeact,nvirtoldbeact,nvirtnewbe,nvirtoldbe,2),
|
|
$icmem(1,1,noccnewalact,noccoldalact,noccnewal,noccoldal,3),
|
|
$icmem(1,1,noccnewbeact,noccoldbeact,noccnewbe,noccoldbe,4),
|
|
$nstr(1,nvirtnewalact,nvirtnewal,1),
|
|
$nstr(1,nvirtnewbeact,nvirtnewbe,2),
|
|
$nstr(1,noccnewalact,noccnewal,3),
|
|
$nstr(1,ntampvirtalact,ntampvirtal,1),
|
|
$nstr(1,ntampvirtbeact,ntampvirtbe,2),
|
|
$nstr(1,ntampoccalact,ntampoccal,3),nsla+nsumleni,n2newlen,
|
|
$xyzsize,mpisize,rank,iconj,nconj)
|
|
else
|
|
call contract61(v,v(xyzomp*n2newlen+ntoldlen+1),
|
|
$v(xyzomp*n2newlen+1),v(nmem),isw,isa,icore,nnir,
|
|
$mult,nirmax,noldsym,ita,nampsym,incsum,incold,iwa,lout,ita2,
|
|
$nstr(1,nvirtoldalact,nvirtoldal,1),
|
|
$nstr(1,nvirtoldbeact,nvirtoldbe,2),
|
|
$nstr(1,noccoldalact,noccoldal,3),
|
|
$nstr(1,noccoldbeact,noccoldbe,4),incnts,nr2,nr3,nr4,nr5,nrr,
|
|
$icmem(1,1,nvintoldalact,nvirtoldalact,nvintoldal,nvirtoldal,1),
|
|
$icmem(1,1,nvintoldbeact,nvirtoldbeact,nvintoldbe,nvirtoldbe,2),
|
|
$icmem(1,1,nointoldalact,noccoldalact,nointoldal,noccoldal,3),
|
|
$icmem(1,1,nointoldbeact,noccoldbeact,nointoldbe,noccoldbe,4),
|
|
$nstr(1,nvintoldalact,nvintoldal,1),
|
|
$nstr(1,nvintoldbeact,nvintoldbe,2),
|
|
$nstr(1,nointoldalact,nointoldal,3),
|
|
$nstr(1,nvintoldalact+nvirtoldalact,nvintoldal+nvirtoldal,1),
|
|
$nstr(1,nvintoldbeact+nvirtoldbeact,nvintoldbe+nvirtoldbe,2),
|
|
$nstr(1,nointoldalact+noccoldalact,nointoldal+noccoldal,3),
|
|
$isympv(0,1,nvintoldalact,nvintoldbeact,nvintoldal,nvintoldbe,1),
|
|
$isympv(0,1,nvintoldalact,nvintoldbeact,nvintoldal,nvintoldbe,2),
|
|
$isympv(0,1,nvirtnewalact,nvirtnewbeact,nvirtnewal,nvirtnewbe,1),
|
|
$isympv(0,1,nvirtnewalact,nvirtnewbeact,nvirtnewal,nvirtnewbe,2),
|
|
$icmem(1,1,nvirtnewalact,nvirtoldalact,nvirtnewal,nvirtoldal,1),
|
|
$icmem(1,1,nvirtnewbeact,nvirtoldbeact,nvirtnewbe,nvirtoldbe,2),
|
|
$icmem(1,1,noccnewalact,noccoldalact,noccnewal,noccoldal,3),
|
|
$icmem(1,1,noccnewbeact,noccoldbeact,noccnewbe,noccoldbe,4),
|
|
$nstr(1,nvirtnewalact,nvirtnewal,1),
|
|
$nstr(1,nvirtnewbeact,nvirtnewbe,2),
|
|
$nstr(1,noccnewalact,noccnewal,3),
|
|
$nstr(1,ntampvirtalact,ntampvirtal,1),
|
|
$nstr(1,ntampvirtbeact,ntampvirtbe,2),
|
|
$nstr(1,ntampoccalact,ntampoccal,3),nsla+nsumleni,n2newlen,
|
|
$xyzsize,mpisize,rank,iconj,nconj,mpicount)
|
|
endif
|
|
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
|
|
write(iout,*) 'Warning! Executing out-of-core algorithm!'
|
|
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
|
|
c write(6,*) 'new',(v(i),i=1,ntnewlen)
|
|
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 !lint
|
|
C Transpose integral list
|
|
c #if defined(OMP)
|
|
c if(.not.lasm) n2newlen=xyzomp*ntnewlen
|
|
c #else
|
|
c if(.not.lasm) n2newlen=ntnewlen
|
|
c #endif
|
|
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,dsympair)
|
|
C Read L-T intermediate
|
|
c write(6,*) 'file2',file2
|
|
call getlst(file2,iamprec,v(xyzomp*n2newlen+ntoldlen+1),namplen)
|
|
c write(6,*) 'amp',(v(xyzomp*n2newlen+ntoldlen+i),i=1,namplen),iamprec
|
|
nmem=xyzomp*n2newlen+ntoldlen+namplen+1
|
|
C
|
|
c write(6,*) 'ntoldlen',ntoldlen
|
|
call conin4(v,v(xyzomp*n2newlen+1),
|
|
$v(xyzomp*n2newlen+ntoldlen+1),v(nmem),
|
|
$n2newlen,nstr,isympv,isympo,lpar,lasm,nnir,
|
|
$nactm,nmax,nmem,isa,isw,iwan,iwa,nvirtnewalact,nvirtnewal,
|
|
$nvirtnewbeact,nvirtnewbe,noccnewalact,noccnewal,noccnewbeact,
|
|
$noccnewbe,icmem,ita2,incnew,nvintnewalact,nvintnewbeact,
|
|
$ivirtnewalact,ivirtnewbeact,nointnewalact,nointnewbeact,
|
|
$ioccnewalact,ioccnewbeact,nvintnewal,nvintnewbe,nointnewal,
|
|
$nointnewbe,ivirtnewal,ivirtnewbe,ioccnewal,ioccnewbe,ita,
|
|
$nvirtoldalact,nvirtoldbeact,ntampvirtalact,ntampvirtbeact,
|
|
$noccoldalact,noccoldbeact,ntampoccalact,ntampoccbeact,ntoldlen,
|
|
$nvirtoldal,nvirtoldbe,noccoldal,noccoldbe,ntampvirtal,ntampvirtbe,
|
|
$ntampoccal,ntampoccbe,noldsym,nampsym,incsum,xyzomp)
|
|
#if defined (OMP)
|
|
call ompred(v,n2newlen)
|
|
#endif
|
|
C Sign of intermediate
|
|
c write(6,*) 'new',(v(i),i=1,n2newlen)
|
|
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 Antisymmetrize new intermediate
|
|
c if(.not.lasm) then
|
|
c call dfillzero(v(n2newlen+1),ntnewlen)
|
|
c call tlength(nmax,nstr,nnir,isympv,isympo,nactm,inco,nnewsym,
|
|
c $ivirtnewalact,ivirtnewbeact,ivirtnewal,ivirtnewbe,ioccnewalact,
|
|
c $ioccnewbeact,ioccnewal,ioccnewbe,ita,1,0,dsympair)
|
|
c call ishift(ita,nir**4)
|
|
c ii1=1
|
|
c do ir=1,nir
|
|
c isymi=isympair(nnewsym,ir,1)
|
|
c isyma=isympair(nnewsym,ir,2)
|
|
c call asym1(nstr,nmax,nnir,isympv,isympo,ita,nactm,icmem,ii1,
|
|
c $incnew(isymi),isyma,isymi,nvirtnewal,noccnewal,nvirtnewbe,
|
|
c $noccnewbe,nvintnewal,nointnewal,nvintnewbe,nointnewbe,ivirtnewal,
|
|
c $ioccnewal,ivirtnewbe,ioccnewbe,nvirtnewalact,noccnewalact,
|
|
c $nvirtnewbeact,noccnewbeact,nvintnewalact,nointnewalact,
|
|
c $nvintnewbeact,nointnewbeact,ivirtnewalact,ioccnewalact,
|
|
c $ivirtnewbeact,ioccnewbeact,v,v(n2newlen+1))
|
|
c enddo
|
|
c call dcp(v(n2newlen+1),v,ntnewlen)
|
|
c if(mod(nvintnewbe*nvirtnewal+nointnewbe*noccnewal,2).ne.0)
|
|
c $isig12=-isig12
|
|
c endif
|
|
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,scspe)
|
|
endif !irecnew
|
|
endif !ia1
|
|
enddo !iw2
|
|
enddo !iwi
|
|
C
|
|
if(isave.eq.2) then
|
|
i=1
|
|
if(d2route.or.dsroute.or.dtroute) i=ilev
|
|
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,i,0,1,
|
|
$nnewsym,scspe)
|
|
#if defined (MPI)
|
|
if(.not.lpar) call imedsync(intfile,intrec,wspca,v)
|
|
#endif
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine contract4(wnew,wold,t,v,vscr,isa,isw,nvaal,nvabe,noaal,
|
|
$noabe,nsyma,nin,nslen,nsymi,lasm,nsuml,nl)
|
|
************************************************************************
|
|
* This subroutine evaluates the contractions between L-T intermediates *
|
|
* and integrals *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer*1 isgnval,isgnvbe,isgnoal,isgnobe
|
|
integer ivstral,ivstrbe,iostral,iostrbe,ivstr,iostr,iivobe,nn1,nn2
|
|
integer iosbe,iosal,ivsbe,ivsal,ivsalad,ifvsal,ivsbead,ifvsbe,inc
|
|
integer ivo,ioo,ifooal,ifoobe,ifvoal,ifvobe,iosalad,ifosal,nn3,n3
|
|
integer nv,no,n1,n2,isa(*),ivaal,ivabe,ioaal,ioabe,iosbead,itadd
|
|
integer nvsal,nvsbe,nosal,nosbe,nsyma,isc,nvaa,nvab,noaa,noab,nl
|
|
integer i,ii,jj,nvsalo,nosbeo,nvaal,nvabe,noaal,noabe,nava,naoa
|
|
integer coupsval,coupsvbe,coupsoal,coupsobe,nin,nslen,isw(*),nsymi
|
|
integer ii1,ii2,ii3,ii4,nsuml
|
|
real*8 wold,t(*)
|
|
logical lasm
|
|
#if defined (OMP)
|
|
real*8 wnew(nl,0:xyzsize),v(nslen,0:xyzsize),vscr(nin,0:xyzsize)
|
|
#else
|
|
real*8 wnew(nl),v(nslen),vscr(nin)
|
|
#endif
|
|
C
|
|
C$OMP PARALLEL
|
|
C$OMP& DEFAULT(PRIVATE)
|
|
C$OMP& SHARED(wold,t,isa,isw,nvaal,nvabe,noaal,noabe,nsyma,v,vscr)
|
|
C$OMP& SHARED(nin,nslen,nsymi,lasm,nsuml,icore,xyzsize,wnew)
|
|
#if defined (OMP)
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
xyzcount=0
|
|
#endif
|
|
if(lasm) then
|
|
inc=1
|
|
do ioabe=1,noabe
|
|
noab=noabe+ioabe
|
|
do ioaal=1,noaal
|
|
noaa=noaal+ioaal
|
|
do ivabe=1,nvabe
|
|
nvab=nvabe+ivabe
|
|
do ivaal=1,nvaal
|
|
nvaa=nvaal+ivaal
|
|
#if defined (OMP)
|
|
if(thrd.eq.xyzcount) then
|
|
#endif
|
|
C Unpack cluster amplitudes
|
|
#if defined (OMP)
|
|
call dfillzer1(v(1,thrd),nslen)
|
|
#else
|
|
call dfillzer1(v,nslen)
|
|
#endif
|
|
ii=0
|
|
jj=1
|
|
do isc=1,nsyma
|
|
ii=ii+1
|
|
coupsval=isa(ii)
|
|
ii=ii+1
|
|
coupsvbe=isa(ii)
|
|
ii=ii+1
|
|
coupsoal=isa(ii)
|
|
ii=ii+1
|
|
coupsobe=isa(ii)
|
|
ii=ii+1
|
|
nn1=isa(ii)
|
|
ii=ii+1
|
|
nn2=isa(ii)
|
|
ii=ii+1
|
|
nn3=isa(ii)
|
|
ii=ii+1
|
|
itadd=isa(ii)
|
|
ii=ii+1
|
|
n1=isa(ii)
|
|
ii=ii+1
|
|
n2=isa(ii)
|
|
ii=ii+1
|
|
n3=isa(ii)
|
|
ifvsal=coupsval+icore(coupsval+ivaal)
|
|
nvsal=icore(coupsval+nvaa)
|
|
ifvsbe=coupsvbe+icore(coupsvbe+ivabe)
|
|
nvsbe=icore(coupsvbe+nvab)
|
|
ifosal=coupsoal+icore(coupsoal+ioaal)
|
|
nosal=icore(coupsoal+noaa)
|
|
ii1=coupsobe+icore(coupsobe+ioabe)
|
|
do iosbe=1,icore(coupsobe+noab)
|
|
ii1=ii1+1
|
|
iosbead=jj+n1*(icore(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=icore(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=itadd+(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(icore(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=icore(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+n3*(icore(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=icore(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nn3
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+(icore(ii4)-1)*nsuml
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
#if defined (OMP)
|
|
call dcps(t(ivstrbe+(iabs(ivstral)-1)*nsuml),
|
|
$v(ivsalad,thrd),nsuml,isgnvbe*isign(1,ivstral))
|
|
#else
|
|
call dcps(t(ivstrbe+(iabs(ivstral)-1)*nsuml),
|
|
$v(ivsalad),nsuml,isgnvbe*isign(1,ivstral))
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii=ii+1
|
|
jj=jj+isa(ii)
|
|
enddo
|
|
#if defined (OMP)
|
|
call matmul2(wnew(inc,thrd),wold,v(1,thrd),nin,nslen)
|
|
#else
|
|
call matmul2(wnew(inc),wold,v,nin,nslen)
|
|
#endif
|
|
#if defined (OMP)
|
|
endif
|
|
if(xyzcount.eq.xyzsize) then
|
|
xyzcount=0
|
|
else
|
|
xyzcount=xyzcount+1
|
|
endif
|
|
#endif
|
|
inc=inc+nin
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
else
|
|
do ioabe=1,noabe
|
|
noab=noabe+ioabe
|
|
do ioaal=1,noaal
|
|
noaa=noaal+ioaal
|
|
do ivabe=1,nvabe
|
|
nvab=nvabe+ivabe
|
|
do ivaal=1,nvaal
|
|
nvaa=nvaal+ivaal
|
|
#if defined (OMP)
|
|
if(thrd.eq.xyzcount) then
|
|
C Unpack cluster amplitudes
|
|
call dfillzer1(v(1,thrd),nslen)
|
|
#else
|
|
call dfillzer1(v,nslen)
|
|
#endif
|
|
ii=0
|
|
jj=1
|
|
do isc=1,nsyma
|
|
ii=ii+1
|
|
coupsval=isa(ii)
|
|
ii=ii+1
|
|
coupsvbe=isa(ii)
|
|
ii=ii+1
|
|
coupsoal=isa(ii)
|
|
ii=ii+1
|
|
coupsobe=isa(ii)
|
|
ii=ii+1
|
|
nn1=isa(ii)
|
|
ii=ii+1
|
|
nn2=isa(ii)
|
|
ii=ii+1
|
|
nn3=isa(ii)
|
|
ii=ii+1
|
|
itadd=isa(ii)
|
|
ii=ii+1
|
|
n1=isa(ii)
|
|
ii=ii+1
|
|
n2=isa(ii)
|
|
ii=ii+1
|
|
n3=isa(ii)
|
|
ifvsal=coupsval+icore(coupsval+ivaal)
|
|
nvsal=icore(coupsval+nvaa)
|
|
ifvsbe=coupsvbe+icore(coupsvbe+ivabe)
|
|
nvsbe=icore(coupsvbe+nvab)
|
|
ifosal=coupsoal+icore(coupsoal+ioaal)
|
|
nosal=icore(coupsoal+noaa)
|
|
ii1=coupsobe+icore(coupsobe+ioabe)
|
|
do iosbe=1,icore(coupsobe+noab)
|
|
ii1=ii1+1
|
|
iosbead=jj+n1*(icore(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=icore(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=itadd+(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(icore(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=icore(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+n3*(icore(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=icore(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nn3
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+(icore(ii4)-1)*nsuml
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
#if defined (OMP)
|
|
call dcps(t(ivstrbe+(iabs(ivstral)-1)*nsuml),
|
|
$v(ivsalad,thrd),nsuml,isgnvbe*isign(1,ivstral))
|
|
#else
|
|
call dcps(t(ivstrbe+(iabs(ivstral)-1)*nsuml),
|
|
$v(ivsalad),nsuml,isgnvbe*isign(1,ivstral))
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii=ii+1
|
|
jj=jj+isa(ii)
|
|
enddo
|
|
#if defined (OMP)
|
|
call dfillzer1(vscr(1,thrd),nin)
|
|
call matmul2(vscr(1,thrd),wold,v(1,thrd),nin,nslen)
|
|
#else
|
|
call dfillzer1(vscr,nin)
|
|
call matmul2(vscr,wold,v,nin,nslen)
|
|
#endif
|
|
C Antisymmetrize new intermediate
|
|
ii=0
|
|
jj=0
|
|
do isc=1,nsymi
|
|
ii=ii+1
|
|
coupsval=isw(ii)
|
|
ii=ii+1
|
|
coupsvbe=isw(ii)
|
|
ii=ii+1
|
|
coupsoal=isw(ii)
|
|
ii=ii+1
|
|
coupsobe=isw(ii)
|
|
ii=ii+1
|
|
nn1=isw(ii)
|
|
ii=ii+1
|
|
nn2=isw(ii)
|
|
ii=ii+1
|
|
nn3=isw(ii)
|
|
ii=ii+1
|
|
itadd=isw(ii)
|
|
ii=ii+1
|
|
n1=isw(ii)
|
|
ii=ii+1
|
|
n2=isw(ii)
|
|
ii=ii+1
|
|
n3=isw(ii)
|
|
ifvsal=coupsval+icore(coupsval+ivaal)
|
|
nvsal=icore(coupsval+nvaa)
|
|
ifvsbe=coupsvbe+icore(coupsvbe+ivabe)
|
|
nvsbe=icore(coupsvbe+nvab)
|
|
ifosal=coupsoal+icore(coupsoal+ioaal)
|
|
nosal=icore(coupsoal+noaa)
|
|
ii1=coupsobe+icore(coupsobe+ioabe)
|
|
do iosbe=1,icore(coupsobe+noab)
|
|
ii1=ii1+1
|
|
iosbead=jj+n1*(icore(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=icore(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=itadd+(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(icore(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=icore(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+n3*(icore(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=icore(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nn3
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+icore(ii4)
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
isgnval=isgnvbe*isign(1,ivstral)
|
|
ivstral=ivstrbe+iabs(ivstral)
|
|
#if defined (OMP)
|
|
wnew(ivstral,thrd)=wnew(ivstral,thrd)+isgnval*vscr(ivsalad,thrd)
|
|
#else
|
|
wnew(ivstral)=wnew(ivstral)+isgnval*vscr(ivsalad)
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii=ii+1
|
|
jj=jj+isw(ii)
|
|
enddo
|
|
#if defined (OMP)
|
|
endif
|
|
if(xyzcount.eq.xyzsize) then
|
|
xyzcount=0
|
|
else
|
|
xyzcount=xyzcount+1
|
|
endif
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
C$OMP END PARALLEL
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine contract41(wnew,wold,t,v,vscr,isa,isw,nvaal,nvabe,
|
|
$noaal,noabe,nsyma,nin,nslen,nsymi,lasm,nsuml,nl)
|
|
************************************************************************
|
|
* This subroutine evaluates the contractions between L-T intermediates *
|
|
* and integrals *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer*1 isgnval,isgnvbe,isgnoal,isgnobe
|
|
integer ivstral,ivstrbe,iostral,iostrbe,ivstr,iostr,iivobe,nn1,nn2
|
|
integer iosbe,iosal,ivsbe,ivsal,ivsalad,ifvsal,ivsbead,ifvsbe,inc
|
|
integer ivo,ioo,ifooal,ifoobe,ifvoal,ifvobe,iosalad,ifosal,nn3,n3
|
|
integer nv,no,n1,n2,isa(*),ivaal,ivabe,ioaal,ioabe,iosbead,itadd
|
|
integer nvsal,nvsbe,nosal,nosbe,nsyma,isc,nvaa,nvab,noaa,noab,nl
|
|
integer i,ii,jj,nvsalo,nosbeo,nvaal,nvabe,noaal,noabe,nava,naoa
|
|
integer coupsval,coupsvbe,coupsoal,coupsobe,nin,nslen,isw(*),nsymi
|
|
integer ii1,ii2,ii3,ii4,nsuml
|
|
real*8 wold,t(*)
|
|
logical lasm
|
|
#if defined (OMP)
|
|
real*8 wnew(nl,0:xyzsize),v(nslen,0:xyzsize),vscr(nin,0:xyzsize)
|
|
#else
|
|
real*8 wnew(nl),v(nslen),vscr(nin)
|
|
#endif
|
|
C
|
|
thrd=0
|
|
C$OMP PARALLEL
|
|
C$OMP& DEFAULT(PRIVATE)
|
|
C$OMP& SHARED(wold,t,isa,isw,nvaal,nvabe,noaal,noabe,nsyma,v,vscr)
|
|
C$OMP& SHARED(nin,nslen,nsymi,lasm,nsuml,icore,xyzsize,wnew)
|
|
C$OMP& SHARED(mpisize,mpicount)
|
|
#if defined (OMP)
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
#endif
|
|
#if defined (MPI) || defined (OMP)
|
|
xyzcount=0
|
|
#endif
|
|
if(lasm) then
|
|
inc=1
|
|
do ioabe=1,noabe
|
|
noab=noabe+ioabe
|
|
do ioaal=1,noaal
|
|
noaa=noaal+ioaal
|
|
do ivabe=1,nvabe
|
|
nvab=nvabe+ivabe
|
|
do ivaal=1,nvaal
|
|
#if defined (MPI)
|
|
if(mpicount+thrd.eq.xyzcount) then
|
|
#elif defined (OMP)
|
|
if(thrd.eq.xyzcount) then
|
|
#endif
|
|
nvaa=nvaal+ivaal
|
|
C Unpack cluster amplitudes
|
|
#if defined (OMP)
|
|
v(1:nslen,thrd)=0.d0
|
|
#else
|
|
v(1:nslen)=0.d0
|
|
#endif
|
|
ii=0
|
|
jj=1
|
|
do isc=1,nsyma
|
|
ii=ii+1
|
|
coupsval=isa(ii)
|
|
ii=ii+1
|
|
coupsvbe=isa(ii)
|
|
ii=ii+1
|
|
coupsoal=isa(ii)
|
|
ii=ii+1
|
|
coupsobe=isa(ii)
|
|
ii=ii+1
|
|
nn1=isa(ii)
|
|
ii=ii+1
|
|
nn2=isa(ii)
|
|
ii=ii+1
|
|
nn3=isa(ii)
|
|
ii=ii+1
|
|
itadd=isa(ii)
|
|
ii=ii+1
|
|
n1=isa(ii)
|
|
ii=ii+1
|
|
n2=isa(ii)
|
|
ii=ii+1
|
|
n3=isa(ii)
|
|
ifvsal=coupsval+icore(coupsval+ivaal)
|
|
nvsal=icore(coupsval+nvaa)
|
|
ifvsbe=coupsvbe+icore(coupsvbe+ivabe)
|
|
nvsbe=icore(coupsvbe+nvab)
|
|
ifosal=coupsoal+icore(coupsoal+ioaal)
|
|
nosal=icore(coupsoal+noaa)
|
|
ii1=coupsobe+icore(coupsobe+ioabe)
|
|
do iosbe=1,icore(coupsobe+noab)
|
|
ii1=ii1+1
|
|
iosbead=jj+n1*(icore(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=icore(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=itadd+(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(icore(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=icore(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+n3*(icore(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=icore(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nn3
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+(icore(ii4)-1)*nsuml
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
#if defined (OMP)
|
|
call dcps(t(ivstrbe+(iabs(ivstral)-1)*nsuml),
|
|
$v(ivsalad,thrd),nsuml,isgnvbe*isign(1,ivstral))
|
|
#else
|
|
call dcps(t(ivstrbe+(iabs(ivstral)-1)*nsuml),
|
|
$v(ivsalad),nsuml,isgnvbe*isign(1,ivstral))
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii=ii+1
|
|
jj=jj+isa(ii)
|
|
enddo
|
|
#if defined (OMP)
|
|
call matmul2(wnew(inc,thrd),wold,v(1,thrd),nin,nslen)
|
|
#else
|
|
call matmul2(wnew(inc),wold,v,nin,nslen)
|
|
#endif
|
|
#if defined (MPI) || defined (OMP)
|
|
endif
|
|
if(xyzcount.eq.mpisize) then
|
|
xyzcount=0
|
|
else
|
|
xyzcount=xyzcount+1
|
|
endif
|
|
#endif
|
|
inc=inc+nin
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
else
|
|
do ioabe=1,noabe
|
|
noab=noabe+ioabe
|
|
do ioaal=1,noaal
|
|
noaa=noaal+ioaal
|
|
do ivabe=1,nvabe
|
|
nvab=nvabe+ivabe
|
|
do ivaal=1,nvaal
|
|
#if defined (MPI)
|
|
if(mpicount+thrd.eq.xyzcount) then
|
|
#elif defined (OMP)
|
|
if(thrd.eq.xyzcount) then
|
|
#endif
|
|
nvaa=nvaal+ivaal
|
|
C Unpack cluster amplitudes
|
|
#if defined (OMP)
|
|
v(1:nslen,thrd)=0.d0
|
|
#else
|
|
v(1:nslen)=0.d0
|
|
#endif
|
|
ii=0
|
|
jj=1
|
|
do isc=1,nsyma
|
|
ii=ii+1
|
|
coupsval=isa(ii)
|
|
ii=ii+1
|
|
coupsvbe=isa(ii)
|
|
ii=ii+1
|
|
coupsoal=isa(ii)
|
|
ii=ii+1
|
|
coupsobe=isa(ii)
|
|
ii=ii+1
|
|
nn1=isa(ii)
|
|
ii=ii+1
|
|
nn2=isa(ii)
|
|
ii=ii+1
|
|
nn3=isa(ii)
|
|
ii=ii+1
|
|
itadd=isa(ii)
|
|
ii=ii+1
|
|
n1=isa(ii)
|
|
ii=ii+1
|
|
n2=isa(ii)
|
|
ii=ii+1
|
|
n3=isa(ii)
|
|
ifvsal=coupsval+icore(coupsval+ivaal)
|
|
nvsal=icore(coupsval+nvaa)
|
|
ifvsbe=coupsvbe+icore(coupsvbe+ivabe)
|
|
nvsbe=icore(coupsvbe+nvab)
|
|
ifosal=coupsoal+icore(coupsoal+ioaal)
|
|
nosal=icore(coupsoal+noaa)
|
|
ii1=coupsobe+icore(coupsobe+ioabe)
|
|
do iosbe=1,icore(coupsobe+noab)
|
|
ii1=ii1+1
|
|
iosbead=jj+n1*(icore(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=icore(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=itadd+(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(icore(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=icore(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+n3*(icore(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=icore(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nn3
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+(icore(ii4)-1)*nsuml
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
#if defined (OMP)
|
|
call dcps(t(ivstrbe+(iabs(ivstral)-1)*nsuml),
|
|
$v(ivsalad,thrd),nsuml,isgnvbe*isign(1,ivstral))
|
|
#else
|
|
call dcps(t(ivstrbe+(iabs(ivstral)-1)*nsuml),
|
|
$v(ivsalad),nsuml,isgnvbe*isign(1,ivstral))
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii=ii+1
|
|
jj=jj+isa(ii)
|
|
enddo
|
|
#if defined (OMP)
|
|
call dfillzer1(vscr(1,thrd),nin)
|
|
call matmul2(vscr(1,thrd),wold,v(1,thrd),nin,nslen)
|
|
#else
|
|
call dfillzer1(vscr,nin)
|
|
call matmul2(vscr,wold,v,nin,nslen)
|
|
#endif
|
|
C Antisymmetrize new intermediate
|
|
ii=0
|
|
jj=0
|
|
do isc=1,nsymi
|
|
ii=ii+1
|
|
coupsval=isw(ii)
|
|
ii=ii+1
|
|
coupsvbe=isw(ii)
|
|
ii=ii+1
|
|
coupsoal=isw(ii)
|
|
ii=ii+1
|
|
coupsobe=isw(ii)
|
|
ii=ii+1
|
|
nn1=isw(ii)
|
|
ii=ii+1
|
|
nn2=isw(ii)
|
|
ii=ii+1
|
|
nn3=isw(ii)
|
|
ii=ii+1
|
|
itadd=isw(ii)
|
|
ii=ii+1
|
|
n1=isw(ii)
|
|
ii=ii+1
|
|
n2=isw(ii)
|
|
ii=ii+1
|
|
n3=isw(ii)
|
|
ifvsal=coupsval+icore(coupsval+ivaal)
|
|
nvsal=icore(coupsval+nvaa)
|
|
ifvsbe=coupsvbe+icore(coupsvbe+ivabe)
|
|
nvsbe=icore(coupsvbe+nvab)
|
|
ifosal=coupsoal+icore(coupsoal+ioaal)
|
|
nosal=icore(coupsoal+noaa)
|
|
ii1=coupsobe+icore(coupsobe+ioabe)
|
|
do iosbe=1,icore(coupsobe+noab)
|
|
ii1=ii1+1
|
|
iosbead=jj+n1*(icore(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=icore(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=itadd+(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(icore(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=icore(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+n3*(icore(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=icore(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nn3
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+icore(ii4)
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
isgnval=isgnvbe*isign(1,ivstral)
|
|
ivstral=ivstrbe+iabs(ivstral)
|
|
#if defined (OMP)
|
|
wnew(ivstral,thrd)=wnew(ivstral,thrd)+isgnval*vscr(ivsalad,thrd)
|
|
#else
|
|
wnew(ivstral)=wnew(ivstral)+isgnval*vscr(ivsalad)
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii=ii+1
|
|
jj=jj+isw(ii)
|
|
enddo
|
|
#if defined (MPI) || defined (OMP)
|
|
endif
|
|
if(xyzcount.eq.mpisize) then
|
|
xyzcount=0
|
|
else
|
|
xyzcount=xyzcount+1
|
|
endif
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
C$OMP END PARALLEL
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine dcps(a,b,n,s)
|
|
************************************************************************
|
|
* Copies s*a to b *
|
|
************************************************************************
|
|
implicit none
|
|
integer n,i,s
|
|
real*8 a(*),b(*)
|
|
C
|
|
if(s.lt.0) then
|
|
do i=1,n
|
|
b(i)=-a(i)
|
|
enddo
|
|
else
|
|
do i=1,n
|
|
b(i)=a(i)
|
|
enddo
|
|
endif
|
|
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,nao1+naoal2-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)
|
|
c write(6,*) 'nn',nn,naval,' ',naval2,naoal2
|
|
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
|
|
c write(6,*) 'iw',iw,trec(iactval,iactvbe,iactoal,iactobe,naval)
|
|
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 asym1(nstr,nmax,nnir,isympv,isympo,ita,nactm,icmem,
|
|
$ii1,inc2,isym1,isym2,naval1,naoal1,navbe1,naobe1,naval2,
|
|
$naoal2,navbe2,naobe2,naval3,naoal3,navbe3,naobe3,iactva1,iactoa1,
|
|
$iactvb1,iactob1,iactva2,iactoa2,iactvb2,iactob2,iactva3,iactoa3,
|
|
$iactvb3,iactob3,vold,vnew,namplen)
|
|
************************************************************************
|
|
* This subroutine antisymmetrizes amplitudes *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nnir,ii,nmax,nactm,ii1,ii2,inc2,isym1,isym2,i,namplen
|
|
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
|
|
integer nvstral1,nvstrbe1,nostral1,nostrbe1,ir1
|
|
integer nvstral2,nvstrbe2,nostral2,nostrbe2,ir2
|
|
integer nvstral3,nvstrbe3,nostral3,nostrbe3,ir3
|
|
integer naval1,naoal1,navbe1,naobe1,naval2,naoal2,navbe2,naobe2
|
|
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 icmem(nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,4)
|
|
real*8 vnew(*),vold(*)
|
|
C
|
|
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
|
|
c write(6,*) 'asym',isymva2,isymva1,iactva2,iactva1,naval2,naval1
|
|
c write(6,*) 'asym',isymvb2,isymvb1,iactvb2,iactvb1,navbe2,navbe1
|
|
c write(6,*) 'asym',isymoa2,isymoa1,iactoa2,iactoa1,naoal2,naoal1
|
|
c write(6,*) 'asym',isymob2,isymob1,iactob2,iactob1,naobe2,naobe1
|
|
call asym(vold(ii2),vnew(ii),inc2,
|
|
$icore(icmem(isymva2,isymva1,iactva2,iactva1,naval2,naval1,1)),
|
|
$icore(icmem(isymvb2,isymvb1,iactvb2,iactvb1,navbe2,navbe1,2)),
|
|
$icore(icmem(isymoa2,isymoa1,iactoa2,iactoa1,naoal2,naoal1,3)),
|
|
$icore(icmem(isymob2,isymob1,iactob2,iactob1,naobe2,naobe1,4)),
|
|
$nvstral1,nvstrbe1,nostral1,nostrbe1,nvstral2,nvstrbe2,nostral2,
|
|
$nvstral3,nvstrbe3,nostral3,nostrbe3,namplen)
|
|
C
|
|
ii2=ii2+nvstral2*nvstrbe2*nostral2*nostrbe2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii1=ii1+nvstral1*nvstrbe1*nostral1*nostrbe1*inc2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine contract6(wnew,wold,t,v,isa,isw,icore,nir,mult,
|
|
$nirmax,nampsym,ita,noldsym,incsu2,incold,iwa,lout,ita2,nsttva,
|
|
$nsttvb,nsttoa,nsttob,incsum,nr2,nr3,nr4,nr5,nrr,icsva,icsvb,icsoa,
|
|
$icsob,nstsva,nstsvb,nstsoa,nstava,nstavb,nstaoa,isymp1,isymp2,
|
|
$isymp3,isymp4,icnva,icnvb,icnoa,icnob,nstnva,nstnvb,nstnoa,nstova,
|
|
$nstovb,nstooa,nsla,nl,xyzsize,mpisize,rank,iconj,nconj)
|
|
************************************************************************
|
|
* This subroutine evaluates the contractions between cluster amplitudes*
|
|
* and intermediates *
|
|
************************************************************************
|
|
implicit none
|
|
integer i,nir,isa,isw(nir**4,nir,nir),ivaal,ivabe,ioaal,nvaa
|
|
integer nvaal,nvabe,noaal,noabe,nsuml,nsumlena,isyma,nsttoa(nir)
|
|
integer isymp4(0:nir,nir),ioabe,icore,inewadd,incsum(nir),nrr,iss
|
|
integer irss,noab,nn,irs,isymp1(0:nir,nir),nr2,nr3,nr4,nr5
|
|
integer isumsym(nir),nsumsym,nirmax,mult(nirmax,nirmax),nampsym,nl
|
|
integer isymp2(0:nir,nir),ita,nstsva(nir),nstsvb(nir),nstsoa(nir)
|
|
integer nstava(nir),nstavb(nir),nstaoa(nir),icsob(nir,nir)
|
|
integer icsva(nir,nir),icsvb(nir,nir),icsoa(nir,nir),nvab,noaa
|
|
integer ntampsymvb,inco,ntampsymoa,ntampsymob,nsymt1,nsymt2
|
|
integer nsymts,ntampsym,noldsym,nsumlen,incsu2(nir),incold(nir)
|
|
integer icnva(nir,nir),icnvb(nir,nir),isymp3(0:nir,nir)
|
|
integer ntampsymva,ita2(nir**4,nir,nir),nsttva(nir),nsttvb(nir)
|
|
integer icnoa(nir,nir),icnob(nir,nir),nstnva(nir),nstnvb(nir)
|
|
integer nstnoa(nir),nstova(nir),nstovb(nir),nstooa(nir),ns1,ns2
|
|
integer is1,isumsy1(0:nir,nir),irs1,iwa(nir,nir,nir),nsttob(nir)
|
|
integer nsla,xyzsize,mpisize,xyzcount,rank,iconj(nirmax),thrd
|
|
integer nconj(nirmax)
|
|
real*8 wold(*),t
|
|
logical lout
|
|
#if defined (OMP)
|
|
integer OMP_GET_THREAD_NUM
|
|
real*8 wnew(nl,0:xyzsize),v(nsla,0:xyzsize)
|
|
#else
|
|
real*8 wnew(nl),v(nsla)
|
|
#endif
|
|
C
|
|
do nsumsym=1,nir
|
|
is1=0
|
|
do nsymts=1,nir
|
|
ntampsym=mult(noldsym,iconj(nsymts))
|
|
isyma=mult(mult(nsumsym,iconj(nampsym)),ntampsym)
|
|
nsumlen=incsu2(nsymts)
|
|
nsumlena=incold(isyma)*nsumlen
|
|
if(nsumlena.gt.0) then
|
|
is1=is1+1
|
|
isumsy1(is1,nsumsym)=nsymts
|
|
endif
|
|
enddo
|
|
isumsy1(0,nsumsym)=is1
|
|
enddo
|
|
C
|
|
iss=0
|
|
do i=1,nir
|
|
if(incsum(i).gt.0) then
|
|
iss=iss+1
|
|
isumsym(iss)=i
|
|
endif
|
|
enddo
|
|
if(iss.eq.0) return
|
|
ns1=mult(noldsym,nampsym)
|
|
C$OMP PARALLEL
|
|
C$OMP& DEFAULT(PRIVATE)
|
|
C$OMP& SHARED(wold,t,isa,isw,icore,nir,mult,nirmax,nampsym,ita,isumsy1)
|
|
C$OMP& SHARED(noldsym,incsu2,incold,iwa,lout,ita2,nsttva,nsttvb,nsttoa)
|
|
C$OMP& SHARED(nsttob,incsum,nr2,nr3,nr4,nr5,nrr,icsva,icsvb,icsoa,icsob)
|
|
C$OMP& SHARED(nstsva,nstsvb,nstsoa,nstava,nstavb,nstaoa,isymp1,isymp2)
|
|
C$OMP& SHARED(isymp3,isymp4,icnva,icnvb,icnoa,icnob,nstnva,nstnvb,iss)
|
|
C$OMP& SHARED(nstnoa,nstova,nstovb,nstooa,nsla,nl,xyzsize,ns1)
|
|
C$OMP& SHARED(isumsym,iconj,nconj,wnew,v)
|
|
#if defined (OMP)
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
xyzcount=0
|
|
#endif
|
|
C Loop over symmetry cases of summation indices
|
|
do ntampsymob=1,nir
|
|
noabe=nsttob(ntampsymob)
|
|
do ioabe=1,noabe
|
|
noab=noabe+ioabe
|
|
do ntampsymoa=1,nir
|
|
nsymt1=mult(ntampsymoa,ntampsymob)
|
|
noaal=nsttoa(ntampsymoa)
|
|
do ioaal=1,noaal
|
|
noaa=noaal+ioaal
|
|
do ntampsymvb=1,nir
|
|
nsymt2=iconj(mult(ntampsymvb,nsymt1))
|
|
nvabe=nsttvb(ntampsymvb)
|
|
do ivabe=1,nvabe
|
|
nvab=nvabe+ivabe
|
|
do irss=1,iss
|
|
nsumsym=isumsym(irss)
|
|
ns2=mult(ns1,iconj(nsumsym))
|
|
ntampsymva=iconj(mult(mult(nsumsym,nsymt2),nampsym))
|
|
nsuml=incsum(nsumsym)
|
|
nvaal=nsttva(ntampsymva)
|
|
do ivaal=1,nvaal
|
|
nvaa=nvaal+ivaal
|
|
#if defined (OMP)
|
|
if(thrd.eq.xyzcount) then
|
|
#endif
|
|
C Unpack cluster amplitudes
|
|
c write(6,"(100i3)") nsumsym,ntampsymva,ntampsymvb,ntampsymoa,
|
|
c $ntampsymob
|
|
call tdeco(isymp1,isymp2,nir,ita,isa,nsumsym,nsuml,ntampsymva,
|
|
$ntampsymvb,ntampsymoa,ntampsymob,mult,nirmax,icsva,icsvb,icsoa,
|
|
$icsob,nstsva,nstsvb,nstsoa,nstava,nstavb,nstaoa,nvaa,nvab,noaa,
|
|
#if defined (OMP)
|
|
$noab,ivaal,ivabe,ioaal,ioabe,v(1,thrd),t,icore,nr2,nr3,nrr,nconj)
|
|
#else
|
|
$noab,ivaal,ivabe,ioaal,ioabe,v,t,icore,nr2,nr3,nrr,nconj)
|
|
#endif
|
|
if(lout) then
|
|
C Unpack LT intermediates
|
|
nsumlena=incold(ns2)
|
|
inewadd=iwa(nsumsym,1,ns2)
|
|
c if(mult(ns2,mult(iconj(ntampsymva),ntampsymoa)).ne.1) stop
|
|
call tdeco(isymp3,isymp4,nir,ita2(1,1,nsumsym),
|
|
$isw(1,1,nsumsym),ns2,nsumlena,ntampsymva,ntampsymvb,
|
|
$ntampsymoa,ntampsymob,mult,nirmax,icnva,icnvb,icnoa,icnob,nstnva,
|
|
$nstnvb,nstnoa,nstova,nstovb,nstooa,nvaa,nvab,noaa,noab,ivaal,
|
|
#if defined (OMP)
|
|
$ivabe,ioaal,ioabe,v(nsuml+1,thrd),wold,icore,nr2,nr3,nrr,iconj)
|
|
#else
|
|
$ivabe,ioaal,ioabe,v(nsuml+1),wold,icore,nr2,nr3,nrr,iconj)
|
|
#endif
|
|
C Contraction
|
|
#if defined (OMP)
|
|
call matmul4(wnew(inewadd,thrd),v(1,thrd),v(nsuml+1,thrd),nsuml,
|
|
$nsumlena)
|
|
#else
|
|
call matmul4(wnew(inewadd),v,v(nsuml+1),nsuml,nsumlena)
|
|
#endif
|
|
else
|
|
do irs1=1,isumsy1(0,nsumsym)
|
|
nsymts=isumsy1(irs1,nsumsym)
|
|
isyma=mult(ns2,iconj(nsymts))
|
|
nsumlen=incsu2(nsymts)
|
|
nsumlena=incold(isyma)*nsumlen
|
|
inewadd=iwa(nsumsym,nsymts,isyma)
|
|
C Unpack LT intermediates
|
|
call wdeco(isymp3,isymp4,nir,ita2(1,nsymts,nsumsym),
|
|
$isw(1,nsymts,nsumsym),isyma,nsumlena,ntampsymva,ntampsymvb,
|
|
$ntampsymoa,ntampsymob,mult,nirmax,icnva,icnvb,icnoa,icnob,nstnva,
|
|
$nstnvb,nstnoa,nstova,nstovb,nstooa,nvaa,nvab,noaa,noab,ivaal,
|
|
#if defined (OMP)
|
|
$ivabe,ioaal,ioabe,v(nsuml+1,thrd),wold,icore,nr2,nr3,nrr,nsumlen,
|
|
$iconj)
|
|
#else
|
|
$ivabe,ioaal,ioabe,v(nsuml+1),wold,icore,nr2,nr3,nrr,nsumlen,iconj)
|
|
#endif
|
|
C Contraction
|
|
#if defined (OMP)
|
|
call matmul4(wnew(inewadd,thrd),v(1,thrd),v(nsuml+1,thrd),nsuml,
|
|
$nsumlena)
|
|
#else
|
|
call matmul4(wnew(inewadd),v,v(nsuml+1),nsuml,nsumlena)
|
|
#endif
|
|
enddo
|
|
endif
|
|
#if defined (OMP)
|
|
endif
|
|
if(xyzcount.eq.xyzsize) then
|
|
xyzcount=0
|
|
else
|
|
xyzcount=xyzcount+1
|
|
endif
|
|
#endif
|
|
C
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C$OMP END PARALLEL
|
|
#if defined (OMP)
|
|
call ompred(wnew,nl)
|
|
#endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine contract61(wnew,wold,t,v,isa,isw,icore,nir,mult,
|
|
$nirmax,nampsym,ita,noldsym,incsu2,incold,iwa,lout,ita2,nsttva,
|
|
$nsttvb,nsttoa,nsttob,incsum,nr2,nr3,nr4,nr5,nrr,icsva,icsvb,icsoa,
|
|
$icsob,nstsva,nstsvb,nstsoa,nstava,nstavb,nstaoa,isymp1,isymp2,
|
|
$isymp3,isymp4,icnva,icnvb,icnoa,icnob,nstnva,nstnvb,nstnoa,nstova,
|
|
$nstovb,nstooa,nsla,nl,xyzsize,mpisize,rank,iconj,nconj,mpicount)
|
|
************************************************************************
|
|
* This subroutine evaluates the contractions between cluster amplitudes*
|
|
* and intermediates *
|
|
************************************************************************
|
|
implicit none
|
|
integer i,nir,isa,isw(nir**4,nir,nir),ivaal,ivabe,ioaal,nvaa
|
|
integer nvaal,nvabe,noaal,noabe,nsuml,nsumlena,isyma,nsttoa(nir)
|
|
integer isymp4(0:nir,nir),ioabe,icore,inewadd,incsum(nir),nrr,iss
|
|
integer irss,noab,nn,irs,isymp1(0:nir,nir),nr2,nr3,nr4,nr5
|
|
integer isumsym(nir),nsumsym,nirmax,mult(nirmax,nirmax),nampsym,nl
|
|
integer isymp2(0:nir,nir),ita,nstsva(nir),nstsvb(nir),nstsoa(nir)
|
|
integer nstava(nir),nstavb(nir),nstaoa(nir),icsob(nir,nir)
|
|
integer icsva(nir,nir),icsvb(nir,nir),icsoa(nir,nir),nvab,noaa
|
|
integer ntampsymvb,inco,ntampsymoa,ntampsymob,nsymt1,nsymt2
|
|
integer nsymts,ntampsym,noldsym,nsumlen,incsu2(nir),incold(nir)
|
|
integer icnva(nir,nir),icnvb(nir,nir),isymp3(0:nir,nir)
|
|
integer ntampsymva,ita2(nir**4,nir,nir),nsttva(nir),nsttvb(nir)
|
|
integer icnoa(nir,nir),icnob(nir,nir),nstnva(nir),nstnvb(nir)
|
|
integer nstnoa(nir),nstova(nir),nstovb(nir),nstooa(nir),ns1,ns2
|
|
integer is1,isumsy1(0:nir,nir),irs1,iwa(nir,nir,nir),nsttob(nir)
|
|
integer nsla,xyzsize,mpisize,xyzcount,rank,iconj(nirmax),thrd
|
|
integer nconj(nirmax),mpicount
|
|
real*8 wold(*),t
|
|
logical lout
|
|
#if defined (OMP)
|
|
integer OMP_GET_THREAD_NUM
|
|
real*8 wnew(nl,0:xyzsize),v(nsla,0:xyzsize)
|
|
#else
|
|
real*8 wnew(nl),v(nsla)
|
|
#endif
|
|
C
|
|
do nsumsym=1,nir
|
|
is1=0
|
|
do nsymts=1,nir
|
|
ntampsym=mult(noldsym,iconj(nsymts))
|
|
isyma=mult(mult(nsumsym,iconj(nampsym)),ntampsym)
|
|
nsumlen=incsu2(nsymts)
|
|
nsumlena=incold(isyma)*nsumlen
|
|
if(nsumlena.gt.0) then
|
|
is1=is1+1
|
|
isumsy1(is1,nsumsym)=nsymts
|
|
endif
|
|
enddo
|
|
isumsy1(0,nsumsym)=is1
|
|
enddo
|
|
C
|
|
iss=0
|
|
do i=1,nir
|
|
if(incsum(i).gt.0) then
|
|
iss=iss+1
|
|
isumsym(iss)=i
|
|
endif
|
|
enddo
|
|
if(iss.eq.0) return
|
|
ns1=mult(noldsym,nampsym)
|
|
thrd=0
|
|
C$OMP PARALLEL
|
|
C$OMP& DEFAULT(PRIVATE)
|
|
C$OMP& SHARED(wold,t,isa,isw,icore,nir,mult,nirmax,nampsym,ita,isumsy1)
|
|
C$OMP& SHARED(noldsym,incsu2,incold,iwa,lout,ita2,nsttva,nsttvb,nsttoa)
|
|
C$OMP& SHARED(nsttob,incsum,nr2,nr3,nr4,nr5,nrr,icsva,icsvb,icsoa,icsob)
|
|
C$OMP& SHARED(nstsva,nstsvb,nstsoa,nstava,nstavb,nstaoa,isymp1,isymp2)
|
|
C$OMP& SHARED(isymp3,isymp4,icnva,icnvb,icnoa,icnob,nstnva,nstnvb,iss)
|
|
C$OMP& SHARED(nstnoa,nstova,nstovb,nstooa,nsla,nl,xyzsize,ns1)
|
|
C$OMP& SHARED(isumsym,iconj,nconj,wnew,v,rank,mpisize,mpicount)
|
|
#if defined (OMP)
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
#endif
|
|
#if defined (MPI) || defined (OMP)
|
|
xyzcount=0
|
|
#endif
|
|
C Loop over symmetry cases of summation indices
|
|
do ntampsymob=1,nir
|
|
noabe=nsttob(ntampsymob)
|
|
do ioabe=1,noabe
|
|
noab=noabe+ioabe
|
|
do ntampsymoa=1,nir
|
|
nsymt1=mult(ntampsymoa,ntampsymob)
|
|
noaal=nsttoa(ntampsymoa)
|
|
do ioaal=1,noaal
|
|
noaa=noaal+ioaal
|
|
do ntampsymvb=1,nir
|
|
nsymt2=iconj(mult(ntampsymvb,nsymt1))
|
|
nvabe=nsttvb(ntampsymvb)
|
|
do ivabe=1,nvabe
|
|
nvab=nvabe+ivabe
|
|
do irss=1,iss
|
|
nsumsym=isumsym(irss)
|
|
ns2=mult(ns1,iconj(nsumsym))
|
|
ntampsymva=iconj(mult(mult(nsumsym,nsymt2),nampsym))
|
|
nsuml=incsum(nsumsym)
|
|
nvaal=nsttva(ntampsymva)
|
|
do ivaal=1,nvaal
|
|
#if defined (MPI)
|
|
if(mpicount+thrd.eq.xyzcount) then
|
|
#elif defined (OMP)
|
|
if(thrd.eq.xyzcount) then
|
|
#endif
|
|
nvaa=nvaal+ivaal
|
|
C Unpack cluster amplitudes
|
|
c write(6,"(100i3)") nsumsym,ntampsymva,ntampsymvb,ntampsymoa,
|
|
c $ntampsymob
|
|
call tdeco(isymp1,isymp2,nir,ita,isa,nsumsym,nsuml,ntampsymva,
|
|
$ntampsymvb,ntampsymoa,ntampsymob,mult,nirmax,icsva,icsvb,icsoa,
|
|
$icsob,nstsva,nstsvb,nstsoa,nstava,nstavb,nstaoa,nvaa,nvab,noaa,
|
|
#if defined (OMP)
|
|
$noab,ivaal,ivabe,ioaal,ioabe,v(1,thrd),t,icore,nr2,nr3,nrr,nconj)
|
|
#else
|
|
$noab,ivaal,ivabe,ioaal,ioabe,v,t,icore,nr2,nr3,nrr,nconj)
|
|
#endif
|
|
if(lout) then
|
|
C Unpack LT intermediates
|
|
nsumlena=incold(ns2)
|
|
inewadd=iwa(nsumsym,1,ns2)
|
|
c if(mult(ns2,mult(iconj(ntampsymva),ntampsymoa)).ne.1) stop
|
|
call tdeco(isymp3,isymp4,nir,ita2(1,1,nsumsym),
|
|
$isw(1,1,nsumsym),ns2,nsumlena,ntampsymva,ntampsymvb,
|
|
$ntampsymoa,ntampsymob,mult,nirmax,icnva,icnvb,icnoa,icnob,nstnva,
|
|
$nstnvb,nstnoa,nstova,nstovb,nstooa,nvaa,nvab,noaa,noab,ivaal,
|
|
#if defined (OMP)
|
|
$ivabe,ioaal,ioabe,v(nsuml+1,thrd),wold,icore,nr2,nr3,nrr,iconj)
|
|
#else
|
|
$ivabe,ioaal,ioabe,v(nsuml+1),wold,icore,nr2,nr3,nrr,iconj)
|
|
#endif
|
|
C Contraction
|
|
#if defined (OMP)
|
|
call matmul4(wnew(inewadd,thrd),v(1,thrd),v(nsuml+1,thrd),nsuml,
|
|
$nsumlena)
|
|
#else
|
|
call matmul4(wnew(inewadd),v,v(nsuml+1),nsuml,nsumlena)
|
|
#endif
|
|
else
|
|
do irs1=1,isumsy1(0,nsumsym)
|
|
nsymts=isumsy1(irs1,nsumsym)
|
|
isyma=mult(ns2,iconj(nsymts))
|
|
nsumlen=incsu2(nsymts)
|
|
nsumlena=incold(isyma)*nsumlen
|
|
inewadd=iwa(nsumsym,nsymts,isyma)
|
|
C Unpack LT intermediates
|
|
call wdeco(isymp3,isymp4,nir,ita2(1,nsymts,nsumsym),
|
|
$isw(1,nsymts,nsumsym),isyma,nsumlena,ntampsymva,ntampsymvb,
|
|
$ntampsymoa,ntampsymob,mult,nirmax,icnva,icnvb,icnoa,icnob,nstnva,
|
|
$nstnvb,nstnoa,nstova,nstovb,nstooa,nvaa,nvab,noaa,noab,ivaal,
|
|
#if defined (OMP)
|
|
$ivabe,ioaal,ioabe,v(nsuml+1,thrd),wold,icore,nr2,nr3,nrr,nsumlen,
|
|
$iconj)
|
|
#else
|
|
$ivabe,ioaal,ioabe,v(nsuml+1),wold,icore,nr2,nr3,nrr,nsumlen,iconj)
|
|
#endif
|
|
C Contraction
|
|
#if defined (OMP)
|
|
call matmul4(wnew(inewadd,thrd),v(1,thrd),v(nsuml+1,thrd),nsuml,
|
|
$nsumlena)
|
|
#else
|
|
call matmul4(wnew(inewadd),v,v(nsuml+1),nsuml,nsumlena)
|
|
#endif
|
|
enddo
|
|
endif
|
|
#if defined (MPI) || defined (OMP)
|
|
endif
|
|
if(xyzcount.eq.mpisize) then
|
|
xyzcount=0
|
|
else
|
|
xyzcount=xyzcount+1
|
|
endif
|
|
#endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C$OMP END PARALLEL
|
|
#if defined (OMP)
|
|
call ompred(wnew,nl)
|
|
#endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine matmul4(mat,v1,v2,n,m)
|
|
************************************************************************
|
|
* Vectorized vector-vector product *
|
|
************************************************************************
|
|
implicit none
|
|
integer m,n,i,j,mm
|
|
real*8 mat(*),v1(n),v2(m),sum
|
|
C
|
|
mm=0
|
|
do j=1,m
|
|
sum=v2(j)
|
|
if(sum.ne.0.d0) then
|
|
do i=mm+1,mm+n
|
|
mat(i)=mat(i)+v1(i-mm)*sum
|
|
enddo
|
|
endif
|
|
mm=mm+n
|
|
enddo
|
|
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,scr5,iot,xyzomp
|
|
real*8 vold(*),v(*)
|
|
logical incore
|
|
#if defined (OMP)
|
|
real*8 vnew(ntnewlen,0:xyzsize)
|
|
xyzomp=xyzsiz1
|
|
#else
|
|
real*8 vnew(ntnewlen)
|
|
xyzomp=1
|
|
#endif
|
|
iot=iout
|
|
scr5=scrfile5
|
|
C Save old intermediate
|
|
if(.not.incore) then
|
|
rewind(scrfile5)
|
|
jj=0
|
|
do ir=1,nir
|
|
isymi=isympair(nnewsym,ir,1)
|
|
isyma=isympair(nnewsym,ir,2)
|
|
do irn=1,nir
|
|
isym2=isympair(isymi,irn,1)
|
|
isym1=isympair(isymi,irn,2)
|
|
ile1=inc1(isym1)
|
|
ile2=inc2(isym2)
|
|
inci=ile1*ile2
|
|
if(inci.gt.0) then
|
|
do i=1,incold(isyma)
|
|
write(scrfile5) (v(jj+j),j=1,inci)
|
|
jj=jj+inci
|
|
enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
rewind(scrfile5)
|
|
endif
|
|
call dfillzero(vnew,xyzomp*ntnewlen)
|
|
C Loop over symmetry cases
|
|
C$OMP PARALLEL
|
|
C$OMP& DEFAULT(PRIVATE)
|
|
C$OMP& SHARED(nstr,nmax,nnir,isympv,isympo,ita,nactm,icmem,naobe1)
|
|
C$OMP& SHARED(nnewsym,naval2,naoal2,navbe2,naobe2,naval1,naoal1,navbe1)
|
|
C$OMP& SHARED(naval3,naoal3,navbe3,naobe3,iactva2,iactoa2,iactvb2)
|
|
C$OMP& SHARED(iactva1,iactoa1,iactvb1,iactob1,iactva3,iactoa3,iactvb3)
|
|
C$OMP& SHARED(vold,incold,inc2,inc1,incore,ntnewlen,maxlen,iot,mult)
|
|
C$OMP& SHARED(xyzsize,iactob2,iactob3,scr5,nir,isympair,icore)
|
|
C$OMP& SHARED(dsympair,vnew)
|
|
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,dsympair)
|
|
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
|
|
if(inci.gt.0) then
|
|
if(incore) then
|
|
kkk=incold(isyma)
|
|
else
|
|
if(inci.gt.maxlen) then
|
|
write(iout,*) 'Insufficient memory!'
|
|
call mrccend(1)
|
|
endif
|
|
maxinc=min(incold(isyma),(maxlen-mod(maxlen,inci))/inci)
|
|
k=mod(incold(isyma),maxinc)
|
|
if(k.ne.0) then
|
|
kk=k
|
|
k=maxinc-k
|
|
else
|
|
kk=maxinc
|
|
endif
|
|
ndist=(incold(isyma)+k)/maxinc
|
|
endif
|
|
C
|
|
nsht=0
|
|
do idist=1,ndist
|
|
if(.not.incore) then
|
|
if(idist.eq.ndist) then
|
|
kkk=kk
|
|
else
|
|
kkk=maxinc
|
|
endif
|
|
ioldadd=1
|
|
C$OMP MASTER
|
|
jj=0
|
|
do i=1,kkk
|
|
read(scrfile5) (vold(jj+j),j=1,inci)
|
|
jj=jj+inci
|
|
enddo
|
|
C$OMP END MASTER
|
|
C$OMP BARRIER
|
|
endif
|
|
C
|
|
ii1=ioldadd
|
|
do ir1=1,nir
|
|
isymv1=dsympair(isym1,ir1,1)
|
|
isymo1=dsympair(isym1,ir1,2)
|
|
C$OMP BARRIER
|
|
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)
|
|
C$OMP BARRIER
|
|
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
|
|
C$OMP BARRIER
|
|
do ir2=1,nir
|
|
isymv2=dsympair(isym2,ir2,1)
|
|
isymo2=dsympair(isym2,ir2,2)
|
|
C$OMP BARRIER
|
|
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)
|
|
C$OMP BARRIER
|
|
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=inewadd+nsht+ita(isymva3,isymvb3,isymoa3,isymob3)
|
|
C
|
|
C$OMP BARRIER
|
|
#if defined (OMP)
|
|
call asyw(vold(ii2),vnew(ii,0),ile2,
|
|
#else
|
|
call asyw(vold(ii2),vnew(ii),ile2,
|
|
#endif
|
|
$icore(icmem(isymva2,isymva1,iactva2,iactva1,naval2,naval1,1)),
|
|
$icore(icmem(isymvb2,isymvb1,iactvb2,iactvb1,navbe2,navbe1,2)),
|
|
$icore(icmem(isymoa2,isymoa1,iactoa2,iactoa1,naoal2,naoal1,3)),
|
|
$icore(icmem(isymob2,isymob1,iactob2,iactob1,naobe2,naobe1,4)),
|
|
$nvstral1,nvstrbe1,nostral1,nostrbe1,nvstral2,nvstrbe2,nostral2,
|
|
$nvstral3,nvstrbe3,nostral3,incn,inci,kkk,xyzsize,ntnewlen)
|
|
C
|
|
ii2=ii2+nvstral2*nvstrbe2*nostral2*nostrbe2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii1=ii1+nvstral1*nvstrbe1*nostral1*nostrbe1*ile2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
nsht=nsht+incn*kkk
|
|
enddo
|
|
ioldadd=ioldadd+inci*incold(isyma)
|
|
endif
|
|
C
|
|
enddo
|
|
inewadd=inewadd+incn*incold(isyma)
|
|
endif
|
|
enddo
|
|
C$OMP END PARALLEL
|
|
#if defined (OMP)
|
|
call ompred(vnew,ntnewlen)
|
|
#endif
|
|
if(incore) then
|
|
call dcp(vnew,vold,ntnewlen)
|
|
else
|
|
close(scrfile5,status='delete')
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine asyw(wold,wnew,inc,coupsval,coupsvbe,coupsoal,coupsobe,
|
|
$nvaal,nvabe,noaal,noabe,nvoalo,nvobeo,nooalo,nvsalo,nvsbeo,nosalo,
|
|
$incn,inci,nn,xyzsize,ntnewlen)
|
|
************************************************************************
|
|
* This subroutine antisymmetrizes intermediates *
|
|
************************************************************************
|
|
implicit none
|
|
integer*1 isgnval,isgnvbe,isgnoal,isgnobe
|
|
integer n1,n2,ivstral,ivstrbe,ifvsal,nn1,nn2,ivsalad,ifvsbe,ifosal
|
|
integer iostral,iostrbe,ivstr,iostr,ivaal,ivabe,ioaal,ioabe,iivobe
|
|
integer iosbe,iosal,ivsbe,ivsal,ivoal,ivobe,nooalo,noobeo,ifosbe
|
|
integer nvsal,nvsbe,nosal,nosbe,nvoal,nvobe,inc,nn,mmm,incn,inci
|
|
integer i,ii,nvsalo,nvsbeo,nosalo,nvoalo,nvobeo,ii1,ii2,ii3,ii4
|
|
integer nvaal,nvabe,noaal,noabe,ivo,iosbead,iosalad,ivsbead,iii
|
|
integer coupsval(*),coupsoal(*),coupsvbe(*),coupsobe(*),xyzsize
|
|
integer thrd,ntnewlen
|
|
real*8 wold(*)
|
|
#if defined (OMP)
|
|
real*8 wnew(ntnewlen,0:xyzsize)
|
|
integer xyzcount,OMP_GET_THREAD_NUM
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
xyzcount=0
|
|
#else
|
|
real*8 wnew(ntnewlen)
|
|
#endif
|
|
C
|
|
mmm=nn-1
|
|
nn2=nvsalo*nvsbeo
|
|
nn1=nn2*nosalo
|
|
n2=nvoalo*nvobeo
|
|
n1=n2*nooalo
|
|
ii=0
|
|
do ioabe=1,noabe
|
|
ifosbe=coupsobe(ioabe)
|
|
nosbe=coupsobe(noabe+ioabe)
|
|
do ioaal=1,noaal
|
|
ifosal=coupsoal(ioaal)
|
|
nosal=coupsoal(noaal+ioaal)
|
|
do ivabe=1,nvabe
|
|
ifvsbe=coupsvbe(ivabe)
|
|
nvsbe=coupsvbe(nvabe+ivabe)
|
|
do ivaal=1,nvaal
|
|
ifvsal=coupsval(ivaal)
|
|
nvsal=coupsval(nvaal+ivaal)
|
|
#if defined (OMP)
|
|
if(thrd.eq.xyzcount) then
|
|
#endif
|
|
C
|
|
ii1=ifosbe
|
|
do iosbe=1,nosbe
|
|
ii1=ii1+1
|
|
iosbead=ii+n1*(coupsobe(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=coupsobe(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(coupsoal(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=coupsoal(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+nvoalo*(coupsvbe(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=coupsvbe(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nvsalo
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+coupsval(ii4)
|
|
ii4=ii4+1
|
|
ivstral=coupsval(ii4)
|
|
isgnval=isgnvbe*isign(1,ivstral)
|
|
ivstral=ivstrbe+iabs(ivstral)
|
|
do i=0,mmm
|
|
#if defined (OMP)
|
|
wnew(ivstral,thrd)=wnew(ivstral,thrd)+isgnval*wold(i*inci+ivsalad)
|
|
#else
|
|
wnew(ivstral)=wnew(ivstral)+isgnval*wold(i*inci+ivsalad)
|
|
#endif
|
|
ivstral=ivstral+incn
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
#if defined (OMP)
|
|
endif
|
|
if(xyzcount.eq.xyzsize) then
|
|
xyzcount=0
|
|
else
|
|
xyzcount=xyzcount+1
|
|
endif
|
|
#endif
|
|
ii=ii+inc
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine resolw(nstr,nmax,vold,vnew,nnir,isympv,isympo,ita,nactm
|
|
$,icmem,naval2,naoal2,navbe2,naobe2,iactva2,iactoa2,iactvb2,iactob2
|
|
$,naval1,naoal1,navbe1,naobe1,iactva1,iactoa1,iactvb1,iactob1,
|
|
$incold,nnewsym,inc2,inc1,file,irec,ntoldlen,maxold)
|
|
************************************************************************
|
|
* This subroutine resolves restrictions in intermediates *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nnir,ii,nmax,nactm,i,j,k,l,ii1,ii2,ii3,iw,maxold,maxlen
|
|
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,kk
|
|
integer nvstral2,nvstrbe2,nostral2,nostrbe2,ir2,isym1,nnewsym,kkk
|
|
integer nvstral3,nvstrbe3,nostral3,nostrbe3,ir3,isym2,inci,maxinc
|
|
integer naval1,naoal1,navbe1,naobe1,naval2,naoal2,navbe2,naobe2
|
|
integer naval3,naoal3,navbe3,naobe3,inc2(*),inc1(*),incold(*)
|
|
integer iactva1,iactoa1,iactvb1,iactob1,ioldadd,inewadd,isymi,isht
|
|
integer iactva2,iactoa2,iactvb2,iactob2,isyma,incn,irn,ile2,ile1
|
|
integer iactva3,iactoa3,iactvb3,iactob3,file,ntoldlen,ndist,idist
|
|
integer nstr(nnir,0:nactm,0:nmax,4),ita(nnir,nnir,nnir,nnir),ifrec
|
|
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 icmem(nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,4),inewadd0
|
|
real*8 vold(*),vnew(*)
|
|
C
|
|
maxlen=maxold-mod(maxold,ibufln)-ibufln
|
|
naval3=naval1+naval2
|
|
navbe3=navbe1+navbe2
|
|
naoal3=naoal1+naoal2
|
|
naobe3=naobe1+naobe2
|
|
iactva3=iactva1+iactva2
|
|
iactvb3=iactvb1+iactvb2
|
|
iactoa3=iactoa1+iactoa2
|
|
iactob3=iactob1+iactob2
|
|
C Loop over symmetry cases
|
|
ioldadd=0
|
|
inewadd=1
|
|
do irn=1,nir
|
|
isymi=isympair(nnewsym,irn,1)
|
|
isyma=isympair(nnewsym,irn,2)
|
|
call tlength(nmax,nstr,nnir,isympv,isympo,nactm,incn,isymi,
|
|
$iactva3,iactvb3,naval3,navbe3,iactoa3,iactob3,naoal3,naobe3,ita,1,
|
|
$0,dsympair)
|
|
if(incn*incold(isyma).gt.0) then
|
|
if(incn.gt.maxlen) then
|
|
write(iout,*) 'Insufficient memory!'
|
|
call mrccend(1)
|
|
endif
|
|
maxinc=min(incold(isyma),(maxlen-mod(maxlen,incn))/incn)
|
|
c maxinc=min(incold(isyma),5) !szemet
|
|
k=mod(incold(isyma),maxinc)
|
|
if(k.ne.0) then
|
|
kk=k
|
|
k=maxinc-k
|
|
else
|
|
kk=maxinc
|
|
endif
|
|
ndist=(incold(isyma)+k)/maxinc
|
|
do idist=1,ndist
|
|
if(idist.eq.ndist) then
|
|
kkk=kk
|
|
else
|
|
kkk=maxinc
|
|
endif
|
|
ifrec=irec+(ioldadd-mod(ioldadd,ibufln))/ibufln
|
|
isht=mod(ioldadd,ibufln)+1
|
|
call getlst(file,ifrec,vold,isht-1+kkk*incn)
|
|
ioldadd=ioldadd+kkk*incn
|
|
inewadd0=inewadd
|
|
do ir=1,nir
|
|
isym2=isympair(isymi,ir,1)
|
|
isym1=isympair(isymi,ir,2)
|
|
ile2=inc2(isym2)
|
|
ile1=inc1(isym1)
|
|
inci=ile1*ile2
|
|
ii1=inewadd0+(idist-1)*maxinc*inci
|
|
do ir1=1,nir
|
|
isymv1=dsympair(isym1,ir1,1)
|
|
isymo1=dsympair(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=dsympair(isym2,ir2,1)
|
|
isymo2=dsympair(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=isht+ita(isymva3,isymvb3,isymoa3,isymob3)
|
|
C
|
|
call resw(vold(ii),vnew(ii2),ile2,
|
|
$icore(icmem(isymva2,isymva1,iactva2,iactva1,naval2,naval1,1)),
|
|
$icore(icmem(isymvb2,isymvb1,iactvb2,iactvb1,navbe2,navbe1,2)),
|
|
$icore(icmem(isymoa2,isymoa1,iactoa2,iactoa1,naoal2,naoal1,3)),
|
|
$icore(icmem(isymob2,isymob1,iactob2,iactob1,naobe2,naobe1,4)),
|
|
$nvstral1,nvstrbe1,nostral1,nostrbe1,
|
|
$nvstral2,nvstrbe2,nostral2,nostrbe2,
|
|
$nvstral3,nvstrbe3,nostral3,nostrbe3,incn,inci,kkk)
|
|
C
|
|
ii2=ii2+nvstral2*nvstrbe2*nostral2*nostrbe2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii1=ii1+nvstral1*nvstrbe1*nostral1*nostrbe1*ile2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
inewadd0=inewadd0+inci*incold(isyma)
|
|
enddo
|
|
enddo
|
|
endif
|
|
do ir=1,nir
|
|
isym2=isympair(isymi,ir,1)
|
|
isym1=isympair(isymi,ir,2)
|
|
inewadd=inewadd+inc1(isym1)*inc2(isym2)*incold(isyma)
|
|
enddo
|
|
c ioldadd=ioldadd+incn*incold(isyma)
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine resw(wold,wnew,inc,coupsval,coupsvbe,coupsoal,coupsobe,
|
|
$nvaal,nvabe,noaal,noabe,nvoalo,nvobeo,nooalo,noobeo,nvsalo,nvsbeo,
|
|
$nosalo,nosbeo,incn,inci,nn)
|
|
************************************************************************
|
|
* This subroutine resolves restrictions in intermediates *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer*1 isgnval,isgnvbe,isgnoal,isgnobe
|
|
integer n1,n2,ivstral,ivstrbe,ifvsal,nn1,nn2,ivsalad,ifvsbe,ifosal
|
|
integer iostral,iostrbe,ivstr,iostr,ivaal,ivabe,ioaal,ioabe,iivobe
|
|
integer iosbe,iosal,ivsbe,ivsal,ivoal,ivobe,nooalo,noobeo,ifosbe
|
|
integer nvsal,nvsbe,nosal,nosbe,nvoal,nvobe,inc,incn,inci,nn,mmm
|
|
integer i,ii,nvsalo,nvsbeo,nosalo,nosbeo,nvoalo,nvobeo,ii1,ii2,ii3
|
|
integer nvaal,nvabe,noaal,noabe,ivo,iosbead,iosalad,ivsbead,ii4
|
|
integer coupsval(*),coupsoal(*),coupsvbe(*),coupsobe(*)
|
|
real*8 wnew(*),wold(*)
|
|
C
|
|
mmm=nn-1
|
|
nn2=nvsalo*nvsbeo
|
|
nn1=nn2*nosalo
|
|
n2=nvoalo*nvobeo
|
|
n1=n2*nooalo
|
|
ii=0
|
|
do ioabe=1,noabe
|
|
ifosbe=coupsobe(ioabe)
|
|
nosbe=coupsobe(noabe+ioabe)
|
|
do ioaal=1,noaal
|
|
ifosal=coupsoal(ioaal)
|
|
nosal=coupsoal(noaal+ioaal)
|
|
do ivabe=1,nvabe
|
|
ifvsbe=coupsvbe(ivabe)
|
|
nvsbe=coupsvbe(nvabe+ivabe)
|
|
do ivaal=1,nvaal
|
|
ifvsal=coupsval(ivaal)
|
|
nvsal=coupsval(nvaal+ivaal)
|
|
C
|
|
ii1=ifosbe
|
|
do iosbe=1,nosbe
|
|
ii1=ii1+1
|
|
iosbead=ii+n1*(coupsobe(ii1)-1)
|
|
ii1=ii1+1
|
|
iostrbe=coupsobe(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=(iabs(iostrbe)-1)*nn1
|
|
ii2=ifosal
|
|
do iosal=1,nosal
|
|
ii2=ii2+1
|
|
iosalad=iosbead+n2*(coupsoal(ii2)-1)
|
|
ii2=ii2+1
|
|
iostral=coupsoal(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=iostrbe+(iabs(iostral)-1)*nn2
|
|
ii3=ifvsbe
|
|
do ivsbe=1,nvsbe
|
|
ii3=ii3+1
|
|
ivsbead=iosalad+nvoalo*(coupsvbe(ii3)-1)
|
|
ii3=ii3+1
|
|
ivstrbe=coupsvbe(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=iostr+(iabs(ivstrbe)-1)*nvsalo
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+coupsval(ii4)
|
|
ii4=ii4+1
|
|
ivstral=coupsval(ii4)
|
|
isgnval=isgnvbe*isign(1,ivstral)
|
|
ivstral=ivstrbe+iabs(ivstral)
|
|
do i=0,mmm
|
|
wnew(i*inci+ivsalad)=isgnval*wold(i*incn+ivstral)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii=ii+inc
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
#if defined (OMP)
|
|
************************************************************************
|
|
subroutine ompind(ii1,nvaal,nvabe,noaal,noabe,ivaal,ivabe,ioaal,
|
|
$ioabe)
|
|
************************************************************************
|
|
* Indices from a composite index *
|
|
************************************************************************
|
|
implicit none
|
|
integer nvaal,nvabe,noaal,noabe,ivaal,ivabe,ioaal,ioabe
|
|
integer ii1,ii2,ii3
|
|
C
|
|
ivaal=mod(ii1,nvaal)
|
|
if(ivaal.eq.0) ivaal=nvaal
|
|
ioabe=mod(ii1,nvaal*nvabe*noaal)
|
|
if(ioabe.eq.0) then
|
|
ioabe=ii1/(nvaal*nvabe*noaal)
|
|
else
|
|
ioabe=(ii1-ioabe)/(nvaal*nvabe*noaal)+1
|
|
endif
|
|
ii2=ii1-(ioabe-1)*nvaal*nvabe*noaal
|
|
ioaal=mod(ii2,nvaal*nvabe)
|
|
if(ioaal.eq.0) then
|
|
ioaal=ii2/(nvaal*nvabe)
|
|
else
|
|
ioaal=(ii2-ioaal)/(nvaal*nvabe)+1
|
|
endif
|
|
ii3=ii2-(ioaal-1)*nvaal*nvabe
|
|
ivabe=mod(ii3,nvaal)
|
|
if(ivabe.eq.0) then
|
|
ivabe=ii3/nvaal
|
|
else
|
|
ivabe=(ii3-ivabe)/nvaal+1
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
#endif
|
|
************************************************************************
|
|
subroutine conin4(wnew,wold,t,vscr,n2newlen,nstr,isympv,isympo,
|
|
$lpar,lasm,
|
|
$nnir,nactm,nmax,nmem,isa,isw,iwan,iwa,nvirtnewalact,nvirtnewal,
|
|
$nvirtnewbeact,nvirtnewbe,noccnewalact,noccnewal,noccnewbeact,
|
|
$noccnewbe,icmem,ita2,incnew,nvintnewalact,nvintnewbeact,
|
|
$ivirtnewalact,ivirtnewbeact,nointnewalact,nointnewbeact,
|
|
$ioccnewalact,ioccnewbeact,nvintnewal,nvintnewbe,nointnewal,
|
|
$nointnewbe,ivirtnewal,ivirtnewbe,ioccnewal,ioccnewbe,ita,
|
|
$nvirtoldalact,nvirtoldbeact,ntampvirtalact,ntampvirtbeact,
|
|
$noccoldalact,noccoldbeact,ntampoccalact,ntampoccbeact,ntoldlen,
|
|
$nvirtoldal,nvirtoldbe,noccoldal,noccoldbe,ntampvirtal,ntampvirtbe,
|
|
$ntampoccal,ntampoccbe,noldsym,nampsym,incsum,xyzomp)
|
|
************************************************************************
|
|
* Initialize variables for contract4 *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
c implicit none
|
|
integer n2newlen,nnir,nactm,nmax,inewadd,ioldadd,nmem,nsuml,i
|
|
integer noltlen,isa,isw(*),ita,isyma,ntampsym,iwa(nnir,nnir,nnir),
|
|
$nvirtnewsyma,nvirtnewalact,nvirtnewal,nvirtnewsymb,nvirtnewbeact,
|
|
$nvirtnewbe,noccnewsyma,noccnewalact,noccnewal,noccnewsymb,
|
|
$noccnewbeact,noccnewbe,nsyma,nintnewl,nsymi,icmem,ita2,isymi,
|
|
$nvintnewalact,nvintnewbeact,nvintnewallen,nvirtoldall,noccoldall,
|
|
$nvintnewbelen,ivirtnewalact,noldsym,incsum(*),nampsym,
|
|
$ivirtnewbeact,ivirtnewlen,nointnewalact,nointnewbeact,
|
|
$nointnewallen,nointnewbelen,ioccnewalact,
|
|
$ioccnewbeact,ioccnewlen,nvintnewal,nvintnewbe,nointnewal,
|
|
$nointnewbe,ivirtnewal,ivirtnewbe,ioccnewal,ioccnewbe,noltsym,
|
|
$nvirtoldalact,nvirtoldbeact,ntampvirtalact,ntampvirtbeact,
|
|
$noccoldalact,noccoldbeact,ntampoccalact,ntampoccbeact,itadd,
|
|
$ntoldlen,nvirtoldal,nvirtoldbe,noccoldal,noccoldbe,ntampvirtal,
|
|
$ntampvirtbe,ntampoccal,ntampoccbe,nsumsym,incnew(*),xyzomp
|
|
integer nvirtoldbelen,ntampvirtlen,noccoldbelen,ntampocclen,ir1
|
|
integer nstr(nnir,0:nactm,0:nmax,4),ira,irav,irao,nvirtnewsym
|
|
integer iwan(nnir,nnir,nnir,nnir,nnir),noccnewsym,inco,irr
|
|
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)
|
|
real*8 wnew(*),wold(*),vscr(*),t(*)
|
|
logical lpar,lasm
|
|
C
|
|
itadd=2
|
|
C Loop over symmetry cases of old intermediate
|
|
do irr=1,nnir
|
|
nsumsym=isympair(nampsym,irr,1)
|
|
ntampsym=isympair(nampsym,irr,2)
|
|
nsuml=incsum(nsumsym)
|
|
if(nsuml.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,nsuml,0,
|
|
$dsympair)
|
|
do ir1=1,nnir
|
|
noltsym=isympair(ntampsym,ir1,1)
|
|
isyma=isympair(ntampsym,ir1,2)
|
|
isymi=mult(mult(nsumsym,noltsym),noldsym)
|
|
nintnewl=incnew(isymi)
|
|
if(nintnewl.gt.0) then
|
|
ioldadd=iwa(isymi,nsumsym,noltsym)
|
|
C Loop over symmetry cases of new intermediate
|
|
do ira=1,nnir
|
|
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,nvirtoldall,
|
|
$nvirtoldbelen,nvirtnewsyma,nvirtnewsymb,ntampvirtalact,
|
|
$ntampvirtbeact,ntampvirtlen,noccoldalact,noccoldbeact,
|
|
$noccoldall,noccoldbelen,noccnewsyma,noccnewsymb,ntampoccalact,
|
|
$ntampoccbeact,ntampocclen,itadd,0,nvirtnewal,
|
|
$nvirtnewalact,nvirtnewbe,nvirtnewbeact,noccnewal,noccnewalact,
|
|
$noccnewbe,noccnewbeact,nsuml,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,nintnewl,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
|
|
if(nsuml*noltlen.gt.0) then
|
|
if(lpar) then
|
|
call contract4(wnew(inewadd),wold(ioldadd),t,vscr(1),
|
|
$vscr(xyzomp*nsuml*noltlen+1),isa,isw,
|
|
$nstr(nvirtnewsyma,nvirtnewalact,nvirtnewal,1),
|
|
$nstr(nvirtnewsymb,nvirtnewbeact,nvirtnewbe,2),
|
|
$nstr(noccnewsyma,noccnewalact,noccnewal,3),
|
|
$nstr(noccnewsymb,noccnewbeact,noccnewbe,4),nsyma,nintnewl,
|
|
$nsuml*noltlen,nsymi,lasm,nsuml,n2newlen)
|
|
else
|
|
call contract41(wnew(inewadd),wold(ioldadd),t,vscr(1),
|
|
$vscr(xyzomp*nsuml*noltlen+1),isa,isw,
|
|
$nstr(nvirtnewsyma,nvirtnewalact,nvirtnewal,1),
|
|
$nstr(nvirtnewsymb,nvirtnewbeact,nvirtnewbe,2),
|
|
$nstr(noccnewsyma,noccnewalact,noccnewal,3),
|
|
$nstr(noccnewsymb,noccnewbeact,noccnewbe,4),nsyma,nintnewl,
|
|
$nsuml*noltlen,nsymi,lasm,nsuml,n2newlen)
|
|
endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
enddo
|
|
itadd=itadd+inco
|
|
endif !nsuml
|
|
enddo !ir
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine wdeco(isymp1,isymp2,nir,ita,isa,nsumsym,nsuml,
|
|
$ntampsymva,ntampsymvb,ntampsymoa,ntampsymob,mult,nirmax,icsva,
|
|
$icsvb,icsoa,icsob,nstsva,nstsvb,nstsoa,nstava,nstavb,nstaoa,nvaa,
|
|
$nvab,noaa,noab,ivaal,ivabe,ioaal,ioabe,v,t,icore,nr2,nr3,nrr,
|
|
$nsumlen,iconj)
|
|
************************************************************************
|
|
* Unpack the lambda indices of an LT intermediate (variant of tdeco) *
|
|
************************************************************************
|
|
implicit none
|
|
integer*1 isgnvbe,isgnoal,isgnobe
|
|
integer nir,isa(*),nsumsym,nsuml,nsumob,ita(*),icore(*),nvaa,nvab
|
|
integer noaa,isymp1(0:nir,nir),isymp2(0:nir,nir),ivsalad,noab
|
|
integer nampob,nr2,nr3,nrr,navo,nsvo,irs,nsumsymva,nsumsymvb,nostr
|
|
integer nsumoa,nampoa,nampsymva,nampsymvb,ntampsymva,ntampsymvb
|
|
integer nsumsymoa,nsumsymob,nampsymoa,ntampsymoa,ntampsymob,nirmax
|
|
integer mult(nirmax,nirmax),icsva(nir,nir),icsvb(nir,nir),nosalad
|
|
integer icsoa(nir,nir),icsob(nir,nir),nstsva(*),nstsvb(*),ivstral
|
|
integer nstsoa(*),nstava(*),nstavb(*),nstaoa(*),coupsval,coupsvbe
|
|
integer coupsoal,coupsobe,nn3,n3,nvsal,ii1,ii2,ii3,ii4,ivaal,ivabe
|
|
integer ioaal,ioabe,iosbe,iosbead,iostrbe,iosal,nsyma1,nsyma2
|
|
integer iosalad,iostral,iostr,ivsbe,ivsbead,ivstrbe,ifvsal,ivsal
|
|
integer nsumlen,iconj(*)
|
|
real*8 v(*),t(*)
|
|
C
|
|
call dfillzer1(v,nsuml)
|
|
do nsumsymob=1,nir
|
|
nsyma1=mult(nsumsym,nsumsymob)
|
|
coupsobe=icsob(nsumsymob,ntampsymob)-1
|
|
nsumob=nsumsymob*nr3+nrr
|
|
nampob=mult(nsumsymob,ntampsymob)*nr3+nrr
|
|
ii1=coupsobe+icore(coupsobe+ioabe)
|
|
do iosbe=1,icore(coupsobe+noab)
|
|
ii1=ii1+1
|
|
iosbead=icore(ii1)-1
|
|
ii1=ii1+1
|
|
iostrbe=icore(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=iabs(iostrbe)-1
|
|
do nsumsymoa=1,nir
|
|
nampsymoa=mult(nsumsymoa,ntampsymoa)
|
|
nsyma2=mult(iconj(nsumsymoa),nsyma1)
|
|
navo=nstaoa(nampsymoa)*iostrbe
|
|
nsvo=nstsoa(nsumsymoa)*iosbead
|
|
coupsoal=icsoa(nsumsymoa,ntampsymoa)-1
|
|
nsumoa=nsumob+nsumsymoa*nr2
|
|
nampoa=nampob+nampsymoa*nr2
|
|
ii2=coupsoal+icore(coupsoal+ioaal)
|
|
do iosal=1,icore(coupsoal+noaa)
|
|
ii2=ii2+1
|
|
iosalad=nsvo+icore(ii2)-1
|
|
ii2=ii2+1
|
|
iostral=icore(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=navo+iabs(iostral)-1
|
|
do irs=1,isymp1(0,nsyma2)
|
|
nsumsymva=isymp1(irs,nsyma2)
|
|
nsumsymvb=isymp2(irs,nsyma2)
|
|
nampsymva=mult(nsumsymva,ntampsymva)
|
|
nampsymvb=mult(nsumsymvb,ntampsymvb)
|
|
n3=nstsva(nsumsymva)*nsumlen
|
|
nn3=nstava(nampsymva)*nsumlen
|
|
coupsval=icsva(nsumsymva,ntampsymva)-1
|
|
coupsvbe=icsvb(nsumsymvb,ntampsymvb)-1
|
|
nosalad=isa(nsumoa+nsumsymvb*nir+nsumsymva)+
|
|
$n3*(nstsvb(nsumsymvb)*iosalad-1)-nsumlen
|
|
nostr=ita(nampoa+nampsymvb*nir+nampsymva)+
|
|
$nn3*(nstavb(nampsymvb)*iostr-1)-nsumlen-1
|
|
ifvsal=coupsval+icore(coupsval+ivaal)
|
|
nvsal=icore(coupsval+nvaa)
|
|
ii3=coupsvbe+icore(coupsvbe+ivabe)
|
|
do ivsbe=1,icore(coupsvbe+nvab)
|
|
ii3=ii3+1
|
|
ivsbead=nosalad+n3*icore(ii3)
|
|
ii3=ii3+1
|
|
ivstrbe=icore(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=nostr+iabs(ivstrbe)*nn3
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+icore(ii4)*nsumlen
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
call dcps(t(ivstrbe+iabs(ivstral)*nsumlen),
|
|
$v(ivsalad),nsumlen,isgnvbe*isign(1,ivstral))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine tdeco(isymp1,isymp2,nir,ita,isa,nsumsym,nsuml,
|
|
$ntampsymva,ntampsymvb,ntampsymoa,ntampsymob,mult,nirmax,icsva,
|
|
$icsvb,icsoa,icsob,nstsva,nstsvb,nstsoa,nstava,nstavb,nstaoa,nvaa,
|
|
$nvab,noaa,noab,ivaal,ivabe,ioaal,ioabe,v,t,icore,nr2,nr3,nrr,
|
|
$iconj)
|
|
************************************************************************
|
|
* Unpack the indices of cluster amplitudes *
|
|
************************************************************************
|
|
implicit none
|
|
integer*1 isgnvbe,isgnoal,isgnobe
|
|
integer nir,isa(*),nsumsym,nsuml,nsumob,ita(*),icore(*),nvaa,nvab
|
|
integer noaa,isymp1(0:nir,nir),isymp2(0:nir,nir),ivsalad,noab
|
|
integer nampob,nr2,nr3,nrr,navo,nsvo,irs,nsumsymva,nsumsymvb,nostr
|
|
integer nsumoa,nampoa,nampsymva,nampsymvb,ntampsymva,ntampsymvb
|
|
integer nsumsymoa,nsumsymob,nampsymoa,ntampsymoa,ntampsymob,nirmax
|
|
integer mult(nirmax,nirmax),icsva(nir,nir),icsvb(nir,nir),nosalad
|
|
integer icsoa(nir,nir),icsob(nir,nir),nstsva(*),nstsvb(*),ivstral
|
|
integer nstsoa(*),nstava(*),nstavb(*),nstaoa(*),coupsval,coupsvbe
|
|
integer coupsoal,coupsobe,nn3,n3,nvsal,ii1,ii2,ii3,ii4,ivaal,ivabe
|
|
integer ioaal,ioabe,iosbe,iosbead,iostrbe,iosal,nsyma1,nsyma2
|
|
integer iosalad,iostral,iostr,ivsbe,ivsbead,ivstrbe,ifvsal,ivsal
|
|
integer iconj(*)
|
|
real*8 v(*),t(*)
|
|
C
|
|
call dfillzer1(v,nsuml)
|
|
do nsumsymob=1,nir
|
|
nsyma1=mult(nsumsym,nsumsymob)
|
|
coupsobe=icsob(nsumsymob,ntampsymob)-1
|
|
nsumob=nsumsymob*nr3+nrr
|
|
nampob=mult(nsumsymob,ntampsymob)*nr3+nrr
|
|
ii1=coupsobe+icore(coupsobe+ioabe)
|
|
do iosbe=1,icore(coupsobe+noab)
|
|
ii1=ii1+1
|
|
iosbead=icore(ii1)-1
|
|
ii1=ii1+1
|
|
iostrbe=icore(ii1)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=iabs(iostrbe)-1
|
|
do nsumsymoa=1,nir
|
|
nampsymoa=mult(nsumsymoa,ntampsymoa)
|
|
nsyma2=mult(nsumsymoa,iconj(nsyma1))
|
|
navo=nstaoa(nampsymoa)*iostrbe
|
|
c write(6,*) 'navo',navo,nstaoa(nampsymoa),iostrbe
|
|
nsvo=nstsoa(nsumsymoa)*iosbead
|
|
coupsoal=icsoa(nsumsymoa,ntampsymoa)-1
|
|
nsumoa=nsumob+nsumsymoa*nr2
|
|
nampoa=nampob+nampsymoa*nr2
|
|
ii2=coupsoal+icore(coupsoal+ioaal)
|
|
do iosal=1,icore(coupsoal+noaa)
|
|
ii2=ii2+1
|
|
iosalad=nsvo+icore(ii2)-1
|
|
ii2=ii2+1
|
|
iostral=icore(ii2)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostr=navo+iabs(iostral)-1
|
|
c write(6,*) 'iostr',iostr,navo,iostral
|
|
do irs=1,isymp1(0,nsyma2)
|
|
nsumsymva=isymp1(irs,nsyma2)
|
|
nsumsymvb=isymp2(irs,nsyma2)
|
|
nampsymva=mult(nsumsymva,ntampsymva)
|
|
nampsymvb=mult(nsumsymvb,ntampsymvb)
|
|
n3=nstsva(nsumsymva)
|
|
nn3=nstava(nampsymva)
|
|
coupsval=icsva(nsumsymva,ntampsymva)-1
|
|
coupsvbe=icsvb(nsumsymvb,ntampsymvb)-1
|
|
nosalad=isa(nsumoa+nsumsymvb*nir+nsumsymva)+
|
|
$n3*(nstsvb(nsumsymvb)*iosalad-1)
|
|
nostr=ita(nampoa+nampsymvb*nir+nampsymva)+
|
|
$nn3*(nstavb(nampsymvb)*iostr-1)-1
|
|
c write(6,*) 'tdeco',ita(nampoa+nampsymvb*nir+nampsymva),
|
|
c $nampsymva,nampsymvb,nampsymoa,mult(nsumsymob,ntampsymob)
|
|
ifvsal=coupsval+icore(coupsval+ivaal)
|
|
nvsal=icore(coupsval+nvaa)
|
|
ii3=coupsvbe+icore(coupsvbe+ivabe)
|
|
do ivsbe=1,icore(coupsvbe+nvab)
|
|
ii3=ii3+1
|
|
ivsbead=nosalad+n3*icore(ii3)
|
|
ii3=ii3+1
|
|
ivstrbe=icore(ii3)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
ivstrbe=nostr+iabs(ivstrbe)*nn3
|
|
ii4=ifvsal
|
|
do ivsal=1,nvsal
|
|
ii4=ii4+1
|
|
ivsalad=ivsbead+icore(ii4)
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
v(ivsalad)=
|
|
$isgnvbe*isign(1,ivstral)*t(ivstrbe+iabs(ivstral))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|