mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-17 12:10:50 +01:00
1771 lines
74 KiB
Fortran
Executable File
1771 lines
74 KiB
Fortran
Executable File
************************************************************************
|
|
subroutine pertcorr(nstr,nconf,trec,intrec,imed,icmem,v,nmax,norm,
|
|
$isympv,isympo,ita,tarec,iwa,isa,isw,istr,test,wspcb,wspca,wsmax,
|
|
$intn,nactm,ntcase,earec,econf,erec,denrec,trec2,erec2,tcase,
|
|
$itypa,itypb,imedsyma,imedsymb,l2map,ioffs)
|
|
************************************************************************
|
|
* This subroutine calculates perturbative corrections *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nstr,intrec,imed,icmem,nmax,nactm,isympv,i,j,k,nn,ii,ioffs
|
|
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 isympo,ita,tarec,iwa(*),isa,isw,istr,wspcb,wspca,wsmax
|
|
integer intn,ntcase,earec,econf,erec,denrec,trec2,erec2
|
|
integer tcase,itypa,itypb,imedsyma,imedsymb,l2map
|
|
integer iactv,iacto,iactva,iactvb,iactoa,iactob
|
|
real*8 v(*),norm,test,corr1,corr2,sum
|
|
C Construct T_n amplitudes
|
|
c pertroute=1
|
|
c call step(nstr,nconf,trec,intrec,imed,icore(icoupmem),v,nmax,
|
|
c $norm,isympv,isympo,ita,tarec,iwa,isa,isw,istr,test,wspcb,wspca,
|
|
c $wsmax,intn,nactmax,ntcase,earec,econf,erec,denrec,trec2,erec2
|
|
c $,tcase,itypa,itypb,imedsyma,imedsymb,l2map,ioffs)
|
|
c pertroute=2
|
|
C
|
|
call coninp(trec,nstr,nmax,icore(icoupmem),v(nbasis+1),isympv,
|
|
$isympo,nir,nconf,ita,tarec,iwa,isa,iwa(nir**6+1),tfile,wspca,
|
|
$wspcb,nactmax,imedsyma,imedsymb,icore(istrecmem),icore(itransmem),
|
|
$icore(iarcmem),wsmax,intrec,ntcase,tcase,v,v(nvirtal+1),
|
|
$v(nvirt+1),v(nvirt+nal+1),corr1,corr2,nvirtal,nvirtbe,
|
|
$ioffs+nbasis+1)
|
|
if(pert.eq.3) return
|
|
C Energy diagrams
|
|
if(lfvo.or.op.ge.5.or.conver.eq.2) then
|
|
ii=2
|
|
do i=(op-mod(op,2))/2-2,1,-1
|
|
pertroute=(op-ii-2)+4
|
|
call step(nstr,nconf,trec,intrec,imed,icore(icoupmem),v,nmax,
|
|
$norm,isympv,isympo,ita,tarec,iwa,isa,isw,istr,test,wspcb,wspca,
|
|
$wsmax,intn,nactmax,ntcase,earec,econf,erec,denrec,trec2,erec2
|
|
$,tcase,itypa,itypb,imedsyma,imedsymb,l2map,ioffs)
|
|
ii=ii+2
|
|
enddo
|
|
C
|
|
if(mod(op,2).ne.0) then
|
|
do i=1,(op-1)/2-1
|
|
ii=0
|
|
do j=1,(op-1)/2
|
|
if(i.eq.j) then
|
|
if(j.gt.1) then
|
|
pertroute=(op-ii-1)+4+op
|
|
call step(nstr,nconf,trec,intrec,imed,icore(icoupmem),v,nmax,
|
|
$norm,isympv,isympo,ita,tarec,iwa,isa,isw,istr,test,wspcb,wspca,
|
|
$wsmax,intn,nactmax,ntcase,earec,econf,erec,denrec,trec2,erec2
|
|
$,tcase,itypa,itypb,imedsyma,imedsymb,l2map,ioffs)
|
|
endif
|
|
ii=ii+1
|
|
else
|
|
if(j.gt.1) then
|
|
pertroute=(op-ii-2)+4
|
|
call step(nstr,nconf,trec,intrec,imed,icore(icoupmem),v,nmax,
|
|
$norm,isympv,isympo,ita,tarec,iwa,isa,isw,istr,test,wspcb,wspca,
|
|
$wsmax,intn,nactmax,ntcase,earec,econf,erec,denrec,trec2,erec2
|
|
$,tcase,itypa,itypb,imedsyma,imedsymb,l2map,ioffs)
|
|
endif
|
|
ii=ii+2
|
|
endif
|
|
enddo
|
|
enddo
|
|
else
|
|
do i=1,op/2-1
|
|
ii=1
|
|
do j=1,op/2-1
|
|
if(i.eq.j) then
|
|
if(op-ii.gt.3) then
|
|
pertroute=(op-ii-1)+4+op
|
|
call step(nstr,nconf,trec,intrec,imed,icore(icoupmem),v,nmax,
|
|
$norm,isympv,isympo,ita,tarec,iwa,isa,isw,istr,test,wspcb,wspca,
|
|
$wsmax,intn,nactmax,ntcase,earec,econf,erec,denrec,trec2,erec2
|
|
$,tcase,itypa,itypb,imedsyma,imedsymb,l2map,ioffs)
|
|
ii=ii+1
|
|
endif
|
|
else
|
|
if(op-ii.gt.2) then
|
|
pertroute=(op-ii-2)+4
|
|
call step(nstr,nconf,trec,intrec,imed,icore(icoupmem),v,nmax,
|
|
$norm,isympv,isympo,ita,tarec,iwa,isa,isw,istr,test,wspcb,wspca,
|
|
$wsmax,intn,nactmax,ntcase,earec,econf,erec,denrec,trec2,erec2
|
|
$,tcase,itypa,itypb,imedsyma,imedsymb,l2map,ioffs)
|
|
ii=ii+2
|
|
endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
endif
|
|
C
|
|
close(scrfile5,status='delete')
|
|
endif
|
|
C
|
|
pertroute=0
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine coninp(trec,nstr,nmax,icmem,v,isympv,isympo,nnir,nconf,
|
|
$ita,tarec,iwa,isa,iwan,file3,wspc1,wspc2,nactm,imedsyma,imedsymb,
|
|
$irec,itr,iarc,wsmax,intrec,ntcase,tcase,faaal,faabe,fiial,fiibe,
|
|
$corr1,corr2,nva,nvb,ioffs)
|
|
************************************************************************
|
|
* This subroutine initializes variables for contractions *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nnir,nactm,trec,wsmax,intrec,icmem,isympv,isympo,ita
|
|
integer iwan(nnir,nnir,nnir,nnir),file3,wspc1,wspc2,imedsyma,nem
|
|
integer irec(nnir,0:nactm,0:nmax,4),itr,iarc(0:nactm,0:nmax,4),nva
|
|
integer ntcase(0:1),tcase(2,(2*nactm+1)**2,0:nmax),imedsymb,nvb,i
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),iift
|
|
integer tarec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),mscr1
|
|
integer nstr(nnir,0:nactm,0:nmax,4),ninter1,ninter2,mfst2,icadd
|
|
integer nvirtnew,noccnew,nnewsym,noldsym,nampsym,mfst1,nptype,imm
|
|
integer nvirtnewact,noccnewact,nvirtnewal,nvirtnewbe,noccnewal,iqf
|
|
integer noccnewbe,nvirtnewalact,nvirtnewbeact,noccnewalact,icd
|
|
integer noccnewbeact,ntnewlen,icad,mmm,ioal,iobe,ift,nnn,dsmax
|
|
integer iorba,iorbb,ileva,ilevb,iwa,isa,nvirtnewsyma,nvirtnewsymb
|
|
integer nsyma11,nsyma22,nnr,iuca(nva),iucb(nvb),itad,isp,nem1,nem2
|
|
integer mscr2,itc,ioffs,intadd,dbladd,xyzomp
|
|
integer*8 nnam,ii8
|
|
real*8 v(*),sumva,sumvb,faaal,faabe,fiial,fiibe,fct,corr1,corr2
|
|
real*8 sum1,sum2,id11,id22
|
|
logical log,lcalc,lcalcn,lcalcs,lcalcsn,lhg,lhgn,lhg2
|
|
C
|
|
open(scrfile5,status='unknown',access='direct',recl=irecln)
|
|
C Initialize variables
|
|
corr1=0.d0
|
|
corr2=0.d0
|
|
nnr=nrr-nr4
|
|
nnn=nnr-nr5
|
|
nvirtnew=op
|
|
noccnew=op
|
|
nnewsym=1
|
|
noldsym=1
|
|
nampsym=mult(nnewsym,noldsym)
|
|
C
|
|
lhg=op.ge.5.or.pert.ge.3.or.conver.eq.2.or.lfvo
|
|
lhgn=.not.lhg
|
|
lhg2=(pert.eq.1.and.((op.ge.5.and.mod(op,2).eq.1).or.
|
|
$ conver.eq.2)).or.
|
|
$ (pert.eq.2.and.(op.ge.5.or.conver.eq.2)).or.
|
|
$ pert.eq.3.or.
|
|
$ (pert.eq.4.and.mod(op,2).eq.1).or.
|
|
$ pert.ge.5.or.
|
|
$ lfvo
|
|
lcalc=(multip.ne.2.and.nal.eq.nbe.and.nactva.eq.nactvb.and.
|
|
$nactoa.eq.nactob.and.rhf)
|
|
#if defined (OMP)
|
|
xyzomp=xyzsiz1
|
|
#else
|
|
xyzomp=1
|
|
#endif
|
|
lcalcn=.not.lcalc
|
|
C
|
|
iift=intadd(ioffs)
|
|
icadd=iift
|
|
iift=iift+(nactm+1)**4*(nmax+1)**2
|
|
dsmax=16*(iimed+5)*wsmax/12
|
|
icore(iift)=dsmax/16
|
|
iift=iift+1
|
|
imm=iift
|
|
iift=iift+dsmax+1
|
|
itad=iift
|
|
iift=iift+(op-1)*wsmax+1
|
|
ift=dbladd(iift+2)-ioffs+2
|
|
call ampadd(op-2,nconf,icore(icadd),nmax,nactm,ift,nem2)
|
|
nem1=0
|
|
if(lhg) then
|
|
if(lhg2)
|
|
$call ampadd(op-1,nconf,icore(icadd),nmax,nactm,ift+nem2,nem1)
|
|
iqf=1
|
|
else
|
|
iqf=2
|
|
endif
|
|
if(locno.eq.3) iqf=3
|
|
nem=nem1+nem2
|
|
nnam=0
|
|
isp=0
|
|
C Reading formula tape
|
|
do nptype=1,ntcase(op)
|
|
nvirtnewact=tcase(1,nptype,op)
|
|
noccnewact= tcase(2,nptype,op)
|
|
C Loop over spin cases of new intermediates (cluster amplitudes)
|
|
do nvirtnewal=0,op
|
|
nvirtnewbe=nvirtnew-nvirtnewal
|
|
noccnewal=nvirtnewal
|
|
noccnewbe=nvirtnewbe
|
|
do nvirtnewalact=max(0,nvirtnewact-nactvb,
|
|
$nvirtnewact-nvirtnewbe,nvirtnewal+nactva-nvirtal),
|
|
$min(nactva,nvirtnewal,nvirtnewact,
|
|
$nvirtbe-nactvb+nvirtnewact-nvirtnewbe)
|
|
nvirtnewbeact=nvirtnewact-nvirtnewalact
|
|
do noccnewalact=max(0,noccnewact-nactob,
|
|
$noccnewact-noccnewbe,noccnewal+nactoa-nal),
|
|
$min(nactoa,noccnewal,noccnewact,nbe-nactob+noccnewact-noccnewbe)
|
|
noccnewbeact=noccnewact-noccnewalact
|
|
call occlen(nmax,nstr(1,0,0,3),nnir,isympo,nactm,ntnewlen,
|
|
$noccnewalact,noccnewbeact,noccnewal,noccnewbe,iwan)
|
|
C
|
|
call slengt8(nmax,nstr,nnir,isympv,isympo,nactm,ii8,nampsym,
|
|
$nvirtnewalact,nvirtnewbeact,nvirtnewal,nvirtnewbe,noccnewalact,
|
|
$noccnewbeact,noccnewal,noccnewbe)
|
|
if(ii8.ne.0.and.(lcalcn.or.nvirtnewal.lt.nvirtnewbe
|
|
$.or.(nvirtnewal.eq.nvirtnewbe.and.nvirtnewalact.lt.nvirtnewbeact)
|
|
$.or.(nvirtnewal.eq.nvirtnewbe.and.nvirtnewalact.eq.nvirtnewbeact
|
|
$.and.noccnewalact.le.noccnewbeact))) then
|
|
lcalcs=lcalc.and.nvirtnewal.eq.nvirtnewbe.and.
|
|
$nvirtnewalact.eq.nvirtnewbeact.and.noccnewalact.eq.noccnewbeact
|
|
lcalcsn=.not.lcalcs
|
|
C
|
|
isp=isp+1
|
|
write(iout,"(' Spin case',i3,' Alpha:',i3,' Beta:',i3)") isp,
|
|
$nvirtnewal,nvirtnewbe
|
|
write(iout,*) 'Number of excitations: ',ii8
|
|
if(lcalc.and.(nvirtnewal.ne.nvirtnewbe.or.nvirtnewalact.ne.
|
|
$nvirtnewbeact.or.noccnewalact.ne.noccnewbeact)) ii8=2*ii8
|
|
nnam=nnam+ii8
|
|
C
|
|
ecc=0.d0
|
|
#if defined (OMP)
|
|
eref=dble(ifltln)*dble(xyzsiz1*(nem+iqf*ntnewlen))
|
|
#else
|
|
eref=dble(ifltln)*dble(nem+iqf*ntnewlen)
|
|
#endif
|
|
icad=intadd(ioffs+ift)!+xyzomp*(nem+iqf*ntnewlen))
|
|
do ir=1,nir
|
|
mmm=noccnewal*nstr(ir,noccnewalact,noccnewal,3)
|
|
eref=eref+dble(iintln*mmm)
|
|
icad=icad+mmm
|
|
enddo
|
|
do ir=1,nir
|
|
mmm=noccnewbe*nstr(ir,noccnewbeact,noccnewbe,4)
|
|
eref=eref+dble(iintln*mmm)
|
|
icad=icad+mmm
|
|
enddo
|
|
C
|
|
mfst2=dbladd(icad)-ioffs+2
|
|
mscr2=mfst2
|
|
icad=intadd(mfst2+ioffs)
|
|
call ifillzero(icore(imm),dsmax+1)
|
|
C
|
|
call coninu(icore(icadd),nstr,nmax,icmem,v,isympv,isympo,nnir,
|
|
$nconf,ita,tarec,iwa,isa,file3,wspc1,wspc2,nactm,imedsyma,imedsymb,
|
|
$irec,itr,iarc,wsmax,intrec,ntcase,tcase,mscr2,nnewsym,nampsym,
|
|
$icd,mfst2,ninter2,lcalcs,lcalcsn,noldsym,nptype,nvirtnewact,
|
|
$noccnewact,nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,
|
|
$nvirtnewalact,nvirtnewbeact,noccnewalact,noccnewbeact,icad,lhg,
|
|
$lhg2,icore(imm),ioffs)
|
|
call putint(scrfile5,1,icore(imm),dsmax+1)
|
|
C
|
|
id11=ecc
|
|
id22=eref
|
|
itc=0
|
|
log=.true.
|
|
do while(log)
|
|
call getint(scrfile5,1,icore(imm),dsmax+1)
|
|
call ifillzero(icore(itad),(op-1)*wsmax+1)
|
|
mscr1=mscr2
|
|
mfst1=mscr1
|
|
ecc=id11
|
|
eref=id22
|
|
icad=intadd(mfst1+ioffs)
|
|
call coninl(trec,nstr,nmax,icmem,v,isympv,isympo,nnir,nconf,
|
|
$ita,tarec,iwa,isa,file3,wspc1,wspc2,nactm,imedsyma,imedsymb,
|
|
$irec,itr,iarc,wsmax,intrec,ntcase,tcase,mscr1,nnewsym,nampsym,
|
|
$icd,mfst1,ninter1,.false.,.true.,noldsym,nptype,nvirtnewact,
|
|
$noccnewact,nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,
|
|
$nvirtnewalact,nvirtnewbeact,noccnewalact,noccnewbeact,icad,nnr,
|
|
$nnn,icore(imm),lcalc,icore(itad),log,itc,ioffs)
|
|
C Contraction
|
|
iorbb=0
|
|
ilevb=0
|
|
sumvb=0.d0
|
|
nvirtnewsymb=1
|
|
sum2=0.d0
|
|
maxmem=max(maxmem,(8.d0*dble(mscr1+ioffs-imem-2)+
|
|
$8.d0*ecc+eref)/8.d0)
|
|
#if defined (OMP)
|
|
ompmem=max(ompmem,(8.d0*dble(mscr1+ioffs-imem-2)+
|
|
$8.d0*ecc+eref)/8.d0+dble(xyzsize)*ecc)
|
|
#endif
|
|
#if defined (MPI)
|
|
if(lcalc.and.lhg)maxmem=max(maxmem,dble(mscr2)+2.d0*dble(mpibfl))
|
|
#endif
|
|
enddo !while
|
|
C
|
|
endif !ntnewlen
|
|
enddo !noccnewalact
|
|
enddo !nvirtnewalact
|
|
enddo !nvirtnewal
|
|
enddo !ntcase
|
|
write(iout,*) 'Number of',op,'-fold excitations: ',nnam
|
|
#if defined (MPI)
|
|
if(lcalcn.and.lhg)
|
|
$maxmem=max(maxmem,dble(ift+nem)+2.d0*dble(mpibfl))
|
|
#endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine coninu(trec,nstr,nmax,icmem,v,isympv,isympo,nnir,nconf,
|
|
$ita,tarec,iwa,isa,file3,wspc1,wspc2,nactm,imedsyma,imedsymb,irec,
|
|
$itr,iarc,wsmax,intrec,ntcase,tcase,mscr,nnewsym,nampsym,icd,mfst,
|
|
$ninter,lcalc,lcalcn,noldsym,nptype,nvirtnewact,noccnewact,
|
|
$nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,nvirtnewalact,
|
|
$nvirtnewbeact,noccnewalact,noccnewbeact,icad,lhg,lhg2,imm,ioffs)
|
|
************************************************************************
|
|
* This subroutine initializes variables for contractions *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nnir,nactm,i,j,k,m,iamprec,ii,incs,jj,ncoma,ncomb,ilv
|
|
integer nstr(nnir,0:nactm,0:nmax,4),n1,n2,n3,n4,nmem,wsmax,ical1
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),nlim
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),file3
|
|
integer icmem(nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,4),inewadd
|
|
integer isa(*),wspc1(0:wsmax,*),intrec(*),isave1,isig11,isig12
|
|
integer wspc2(0:wsmax,*),ircold,ircnew,nsyma,imedsyma(*),ical2
|
|
integer ntoldlen,namplen,ia1,ia2,ntoldleno,iwa(*),nampsym,iwn
|
|
integer nvintoldal,nvintoldbe,nsymw,nointoldal,nointoldbe,isave2
|
|
integer nvirtoldbelen,noccoldbelen,incold(nnir),ntcase(0:1),npt
|
|
integer nvirtnewbelen,noccnewbelen,nampvirtlen,ir1,isymi,nptype
|
|
integer nampocclen,ntampvirtal,ntampvirtbe,ntampoccal,ntampoccbe
|
|
integer isympv(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2),imm
|
|
integer isympo(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2),ioffs
|
|
integer ira,nvirtnewsym,noccnewsym,irav,nvirtnewsyma,nvirtnewsymb
|
|
integer irao,noccnewsyma,noccnewsymb,ntampsym,noldsym,nn1,nn2,nn3
|
|
integer ntampsymv,ntampsymo,irtv,ntampsymva,ntampsymvb,noccoldlen
|
|
integer nvirtoldsyma,nvirtoldsymb,nvirtoldsym,irto,imedsymb(*)
|
|
integer ntampsymoa,ntampsymob,noccoldsyma,irt,nvirtoldlen,nintold
|
|
integer tarec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer ita(nnir,nnir,nnir,nnir),noccoldsymb,noccoldsym,intadd
|
|
integer iwo,iaddo(0:wsmax),nnewsym,tcase(2,(2*nactm+1)**2,0:nmax)
|
|
integer nvirtnewact,noccnewact,nampoccalact,nampoccbeact,dbladd
|
|
integer nvintoldact,nointoldact,nvirtoldact,noccoldact,anstr
|
|
integer nvintoldalact,nointoldalact,nvintoldbeact,nointoldbeact
|
|
integer nvirtoldalact,noccoldalact,nvirtoldbeact,noccoldbeact
|
|
integer ntampvirtact,ntampoccact,ntampvirtalact,ntampvirtbeact
|
|
integer nampvirtact,nampoccact,nampvirtalact,nampvirtbeact
|
|
integer nvirtnewalact,nvirtnewbeact,noccnewalact,noccnewbeact
|
|
integer ntampoccalact,ntampoccbeact,irec(nnir,0:nactm,0:nmax,4)
|
|
integer nampvirtal,nampvirtbe,nampoccal,nampoccbe,aicmem
|
|
integer nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,aisympv
|
|
integer nvirtoldal,noccoldal,nvirtoldbe,noccoldbe,aisympo
|
|
integer nvirtnew,noccnew,nvintold,itr(2,0:nactm,0:nmax,4)
|
|
integer nointold,nvirtold,noccold,iarc(0:nactm,0:nmax,4)
|
|
integer ninter,icad,icd,mscr,mmm,mfst
|
|
integer iw,i5,i6,i7,i8,i9,i10,ire1,ire2,ile1
|
|
real*8 v(*),faaal,faabe,fiial,fiibe,maxmemo,nopmaxo
|
|
logical log,lcalc,lcalcn,lcalcs,lcalcsn,lhg,lhg2
|
|
C
|
|
ninter=0
|
|
nlim=ntcase(op-2)
|
|
if(lhg.and.lhg2) nlim=nlim+ntcase(op-1)
|
|
C
|
|
rewind(ftfile)
|
|
do i=1,op-3
|
|
do j=1,ntcase(i)
|
|
nn1=0
|
|
call skip1(nn1,ftfile)
|
|
enddo
|
|
enddo
|
|
do npt=1,nlim
|
|
read(ftfile,*) n1
|
|
do nn1=1,n1
|
|
read(ftfile,*) j,j,nvirtnew,noccnew,nvintold,nointold,nvirtold,
|
|
$noccold,namp,ical1,isig11,isave1,j,j,nampvirtact,nampoccact,
|
|
$nvintoldact,nointoldact,nvirtoldact,noccoldact
|
|
if(namp.ne.op.or.
|
|
$nampvirtact+nvintoldact-nvirtoldact.ne.nvirtnewact.or.
|
|
$nampoccact+nointoldact-noccoldact.ne.noccnewact) then
|
|
if(isave1.ne.0) then
|
|
ii=1
|
|
call skip1(ii,ftfile)
|
|
endif
|
|
else
|
|
nintold=nvintold+nointold
|
|
ntampvirtact=iabs(nampvirtact-nvirtoldact)
|
|
ntampoccact=iabs(nampoccact-noccoldact)
|
|
read(ftfile,*) n2
|
|
call ifillzero(iaddo,wsmax+1)
|
|
do nn2=1,n2
|
|
read(ftfile,*) j,j,j,j,j,j,j,j,j,ical2,isig12,isave2,j,j,
|
|
$j,j,j,j,j,j
|
|
if(isave2.eq.2) then
|
|
nn3=2
|
|
call skip1(nn3,ftfile)
|
|
endif
|
|
c if(ical2.le.iimed) then
|
|
c if(intn(ical2).eq.7.or.intn(ical2).eq.8.or.intn(ical2).eq.11)
|
|
call imedret(scrfile2,0,wspc2(0,ical1),intfile,intrec(ical2),
|
|
$isig12,iaddo,v(mscr),nmax,2,1,1.d0,wspc2(0,ical1),wspc1(0,ical2),
|
|
$nactmax,0,0,ical2,nconf,trec,nconf,trec,0,0,wsmax,2,isave2,1,
|
|
$imedsyma(ical2))
|
|
c endif
|
|
enddo
|
|
C Loop over spin cases of old intermediates
|
|
do iwo=1,wspc2(0,ical1)
|
|
nvintoldal=wspc2((iwo-1)*12+1,ical1)
|
|
nointoldal=wspc2((iwo-1)*12+2,ical1)
|
|
nvirtoldal=wspc2((iwo-1)*12+3,ical1)
|
|
noccoldal=wspc2((iwo-1)*12+4,ical1)
|
|
nvintoldalact=wspc2((iwo-1)*12+5,ical1)
|
|
nointoldalact=wspc2((iwo-1)*12+6,ical1)
|
|
nvintoldbeact=wspc2((iwo-1)*12+7,ical1)
|
|
nointoldbeact=wspc2((iwo-1)*12+8,ical1)
|
|
nvirtoldalact=wspc2((iwo-1)*12+9,ical1)
|
|
noccoldalact=wspc2((iwo-1)*12+10,ical1)
|
|
nvirtoldbeact=nvirtoldact-nvirtoldalact
|
|
noccoldbeact=noccoldact-noccoldalact
|
|
ircold=wspc2((iwo-1)*12+11,ical1)
|
|
ntoldlen=wspc2((iwo-1)*12+12,ical1)
|
|
ntoldleno=ntoldlen
|
|
nvintoldbe=nvintold-nvintoldal
|
|
nointoldbe=nointold-nointoldal
|
|
nvirtoldbe=nvirtold-nvirtoldal
|
|
noccoldbe=noccold-noccoldal
|
|
call fwspc(iaddo,nvintoldal,nointoldal,nvirtoldal,noccoldal,
|
|
$nvintoldalact,nointoldalact,nvintoldbeact,nointoldbeact,
|
|
$nvirtoldalact,noccoldalact,ia1,ia2)
|
|
if(ia1.gt.0) then
|
|
ntampvirtal=nvirtnewal-nvintoldal
|
|
ntampvirtbe=nvirtnewbe-nvintoldbe
|
|
ntampoccal=noccnewal-nointoldal
|
|
ntampoccbe=noccnewbe-nointoldbe
|
|
ntampvirtalact=nvirtnewalact-nvintoldalact
|
|
ntampvirtbeact=nvirtnewbeact-nvintoldbeact
|
|
ntampoccalact=noccnewalact-nointoldalact
|
|
ntampoccbeact=noccnewbeact-nointoldbeact
|
|
nampvirtal=ntampvirtal+nvirtoldal
|
|
nampvirtbe=ntampvirtbe+nvirtoldbe
|
|
nampoccal=ntampoccal+noccoldal
|
|
nampoccbe=ntampoccbe+noccoldbe
|
|
nampvirtalact=ntampvirtalact+nvirtoldalact
|
|
nampvirtbeact=ntampvirtbeact+nvirtoldbeact
|
|
nampoccalact=ntampoccalact+noccoldalact
|
|
nampoccbeact=ntampoccbeact+noccoldbeact
|
|
C
|
|
if(ntampvirtal.ge.0.and.
|
|
$ntampvirtbe.ge.0.and.ntampoccal.ge.0.and.ntampoccbe.ge.0.and.
|
|
$ntampvirtalact.ge.0.and.ntampvirtbeact.ge.0.and.
|
|
$ntampvirtalact+ntampvirtbeact.eq.ntampvirtact.and.
|
|
$ntampoccalact.ge.0.and.ntampoccbeact.ge.0.and.
|
|
$ntampoccalact+ntampoccbeact.eq.ntampoccact.and.
|
|
$nampvirtal.ge.0.and.nampvirtbe.ge.0.and.
|
|
$nampvirtal+nampvirtbe.eq.nvirtnew.and.nampvirtalact.ge.0.and.
|
|
$nampvirtalact.le.min(nactva,nampvirtal).and.nampvirtbeact.ge.0
|
|
$.and.nampvirtbeact.le.min(nactvb,nampvirtbe).and.
|
|
$nampoccalact.ge.0.and.nampoccalact.le.min(nactoa,nampoccal).and.
|
|
$nampoccbeact.ge.0.and.nampoccbeact.le.min(nactob,nampoccbe).and.
|
|
c $nvintoldal.ge.max(0,nvirtoldal+nvirtnewal-min(minvirtal,op-1),
|
|
c $nvintold-min(nvintoldbe,nvirtnewbe)).and.
|
|
c $nvintoldal.le.min(nvintold,nvirtnewal,
|
|
c $min(minvirtbe,op-1)-nvirtoldbe+nvirtnewbe+nvintold).and.
|
|
$nvintoldalact.ge.0.and.nvintoldbeact.ge.0.and.
|
|
$nvintoldalact.le.min(nvintoldal,nvirtnewalact,nactva).and.
|
|
$nvintoldbeact.le.min(nvintoldbe,nvirtnewbeact,nactvb).and.
|
|
$nvintoldalact+nvintoldbeact.ge.nvintoldact.and.
|
|
c $nointoldal.ge.max(0,noccoldal+noccnewal-minoccal,
|
|
c $nointold-min(nointoldbe,noccnewbe)).and.
|
|
c $nointoldal.le.min(nointold,noccnewal,
|
|
c $minoccbe-noccoldbe+noccnewbe+nointold).and.
|
|
$nointoldalact.ge.0.and.nointoldbeact.ge.0.and.
|
|
$nointoldalact.le.min(nointoldal,noccnewalact,nactoa).and.
|
|
$nointoldbeact.le.min(nointoldbe,noccnewbeact,nactob).and.
|
|
$nointoldalact+nointoldbeact.ge.nointoldact) then
|
|
C
|
|
iamprec=trec(nampvirtalact,nampvirtbeact,
|
|
$nampoccalact,nampoccbeact,nampvirtal,nampvirtal+nampvirtbe)
|
|
namplen=nconf(nampvirtalact,nampvirtbeact,nampoccalact,
|
|
$nampoccbeact,nampvirtal,nvirtnew)
|
|
if(iamprec.gt.0.and.namplen.gt.0.and.(lcalcn.or.
|
|
$nampvirtal.lt.nampvirtbe.or.(nampvirtal.eq.nampvirtbe.and.
|
|
$nampvirtalact.lt.nampvirtbeact).or.(nampvirtal.eq.nampvirtbe.and.
|
|
$nampvirtalact.eq.nampvirtbeact.and.nampoccalact.le.nampoccbeact))
|
|
$) then
|
|
lcalcs=lcalc.and.nampvirtal.eq.nampvirtbe.and.
|
|
$nampvirtalact.eq.nampvirtbeact.and.nampoccalact.eq.nampoccbeact
|
|
lcalcsn=.not.lcalcs
|
|
C
|
|
ninter=ninter+1
|
|
icd=icad
|
|
C Addresses of integer arrays
|
|
icore(icd+1)=anstr(1,ntampvirtalact,ntampvirtal,1)
|
|
icore(icd+2)=anstr(1,ntampvirtbeact,ntampvirtbe,2)
|
|
icore(icd+3)=anstr(1,ntampoccalact,ntampoccal,3)
|
|
icore(icd+4)=anstr(1,ntampoccbeact,ntampoccbe,4)
|
|
icore(icd+5)=aicmem(1,1,nvintoldalact,ntampvirtalact,
|
|
$nvintoldal,ntampvirtal,1)
|
|
icore(icd+6)=aicmem(1,1,nvintoldbeact,ntampvirtbeact,
|
|
$nvintoldbe,ntampvirtbe,2)
|
|
icore(icd+7)=aicmem(1,1,nointoldalact,ntampoccalact,
|
|
$nointoldal,ntampoccal,3)
|
|
icore(icd+8)=aicmem(1,1,nointoldbeact,ntampoccbeact,
|
|
$nointoldbe,ntampoccbe,4)
|
|
icore(icd+9)=anstr(1,nvintoldalact,nvintoldal,1)
|
|
icore(icd+10)=0 !Not used
|
|
icore(icd+11)=anstr(1,nointoldalact,nointoldal,3)
|
|
icore(icd+12)=anstr(1,nampvirtalact,nampvirtal,1)
|
|
icore(icd+13)=anstr(1,nampvirtbeact,nampvirtbe,2)
|
|
icore(icd+14)=anstr(1,nampoccalact,nampoccal,3)
|
|
icore(icd+15)=aisympo(0,1,nointoldalact,nointoldbeact,
|
|
$nointoldal,nointoldbe,1)
|
|
icore(icd+16)=aisympo(0,1,nointoldalact,nointoldbeact,
|
|
$nointoldal,nointoldbe,2)
|
|
icore(icd+17)=aicmem(1,1,nvirtoldalact,ntampvirtalact,
|
|
$nvirtoldal,ntampvirtal,1)
|
|
icore(icd+18)=aicmem(1,1,nvirtoldbeact,ntampvirtbeact,
|
|
$nvirtoldbe,ntampvirtbe,2)
|
|
icore(icd+19)=aicmem(1,1,noccoldalact,ntampoccalact,
|
|
$noccoldal,ntampoccal,3)
|
|
icore(icd+20)=aicmem(1,1,noccoldbeact,ntampoccbeact,
|
|
$noccoldbe,ntampoccbe,4)
|
|
icore(icd+21)=iamprec
|
|
icore(icd+22)=namplen
|
|
icore(icd+23)=anstr(1,nampoccalact,nampoccal,3)
|
|
icore(icd+24)=anstr(1,nvirtoldalact,nvirtoldal,1)
|
|
icore(icd+25)=anstr(1,nvirtoldbeact,nvirtoldbe,2)
|
|
icore(icd+26)=anstr(1,noccoldalact,noccoldal,3)
|
|
icore(icd+40)=iarc(nvintoldalact,nvintoldal,1)
|
|
icore(icd+41)=iarc(ntampvirtalact,ntampvirtal,1)
|
|
icore(icd+42)=iarc(nvintoldbeact,nvintoldbe,2)
|
|
icore(icd+43)=iarc(ntampvirtbeact,ntampvirtbe,2)
|
|
icore(icd+46)=nvintoldal
|
|
icore(icd+47)=ntampvirtal
|
|
icore(icd+48)=nvintoldbe
|
|
icore(icd+49)=ntampvirtbe
|
|
icad=icad+51
|
|
C Combinations
|
|
icore(icd+34)=icad+1
|
|
call comb(nvirtnewal,nvirtnewalact,icore(icad+1),ilv,nvintoldal,
|
|
$nvintoldalact,0,ncoma,isa)
|
|
eref=eref+dble(iintln*ncoma*(nvirtnewal+1))
|
|
icore(icd+44)=ncoma
|
|
icore(icd+35)=icad+1
|
|
call comb(nvirtnewbe,nvirtnewbeact,icore(icad+1),ilv,nvintoldbe,
|
|
$nvintoldbeact,0,ncomb,isa)
|
|
eref=eref+dble(iintln*ncomb*(nvirtnewbe+1))
|
|
icore(icd+45)=ncomb
|
|
C Trans vectors
|
|
icore(icd+36)=icad+1
|
|
mmm=itr(2,nvintoldalact,nvintoldal,1)
|
|
eref=eref+dble(iintln*mmm)
|
|
icore(icd+37)=icad+1
|
|
mmm=itr(2,ntampvirtalact,ntampvirtal,1)
|
|
eref=eref+dble(iintln*mmm)
|
|
icore(icd+38)=icad+1
|
|
mmm=itr(2,nvintoldbeact,nvintoldbe,2)
|
|
eref=eref+dble(iintln*mmm)
|
|
icore(icd+39)=icad+1
|
|
mmm=itr(2,ntampvirtbeact,ntampvirtbe,2)
|
|
eref=eref+dble(iintln*mmm)
|
|
C Length of summation indices
|
|
icore(icd+30)=icad+1
|
|
icad=icad+nir
|
|
icore(icd+50)=icad+1
|
|
icad=icad+nir
|
|
C Memory addresses of old intermediates
|
|
icore(icd+31)=icad+1
|
|
icad=icad+nir**6
|
|
C Addresses of summation indices
|
|
icore(icd+32)=icad+1
|
|
call occlen(nmax,nstr(1,0,0,3),nnir,isympo,nactm,i,nointoldalact,
|
|
$nointoldbeact,nointoldal,nointoldbe,icore(icore(icd+32)))
|
|
icad=icad+nir**2
|
|
icore(icd+51)=icad+1
|
|
call occlen(nmax,nstr,nnir,isympv,nactm,i,nvintoldalact,
|
|
$nvintoldbeact,nvintoldal,nvintoldbe,icore(icore(icd+51)))
|
|
icad=icad+nir**2
|
|
C Addresses of cluster amplitudes
|
|
icore(icd+33)=icad+1
|
|
eref=eref+dble(iintln*nir**4)
|
|
C Addresses of real arrays
|
|
icore(icd+27)=dbladd(icad)-ioffs+3
|
|
icore(icd+28)=0
|
|
if(lcalcsn) icore(icd+28)=1
|
|
icore(icd+29)=icore(icd+27)
|
|
eref=eref+dble(ifltln*ntoldlen)
|
|
mscr=icore(icd+29)
|
|
icad=intadd(mscr+ioffs)
|
|
C Read old intermediates
|
|
isig12=1
|
|
maxmemo=maxmem
|
|
nopmaxo=nopmax
|
|
maxmem=0.d0
|
|
nopmax=0.d0
|
|
call transposition(nmax,nnir,nactm,nstr,icmem,isympv,isympo,
|
|
$icore(icore(icd+31)),i,v(icore(icd+27)),isig12,ntoldlen,
|
|
$ntoldleno,namp,scrfile2,0,ircold,ita,0,icore(icore(icd+30)),
|
|
$noldsym,nnewsym,nvintoldal,nvintoldbe,nointoldal,nointoldbe,
|
|
$nvintoldalact,nvintoldbeact,nointoldalact,nointoldbeact,
|
|
$0 ,0 ,nointoldalact,nointoldbeact,
|
|
$nvintoldalact,nvintoldbeact,0 ,0 ,
|
|
$nvirtoldalact,nvirtoldbeact,noccoldalact,noccoldbeact,
|
|
$nvirtoldalact,nvirtoldbeact,noccoldalact,noccoldbeact,
|
|
$icore(icore(icd+50)),.true.,icore(icore(icd+31)),incold,
|
|
$nvintoldal,nvintoldbe,0 ,0 ,0 ,0 ,
|
|
$nointoldal,nointoldbe,nvirtoldal,nvirtoldbe,noccoldal,noccoldbe,
|
|
$2,nintold,nvintold,nointold,nvirtoldal,nvirtoldbe,noccoldal,
|
|
$noccoldbe,.false.,.false.,ical1,imm,i,0,ioffs+icore(icd+27),
|
|
$.false.,1)
|
|
nopmax=max(nopmaxo,(8.d0*dble(icore(icd+27)+ioffs-imem-2)
|
|
$+eref)/8.d0+nopmax)
|
|
maxmem=max(maxmemo,(8.d0*dble(icore(icd+27)+ioffs-imem-2)
|
|
$+eref)/8.d0+maxmem)
|
|
do isymi=1,nir
|
|
ecc=max(ecc,dble(icore(icore(icd+30)-1+isymi)))
|
|
enddo
|
|
C Sign of intermediate
|
|
if(mod(nvintoldbe*ntampvirtal+nointoldbe*ntampoccal+
|
|
$nvirtoldbe*ntampvirtal+noccoldbe*ntampoccal,2).ne.0)
|
|
$isig12=-isig12
|
|
endif !ircnew
|
|
endif
|
|
endif !ia1
|
|
enddo !iwo
|
|
endif !namp
|
|
enddo !npt
|
|
enddo !nn1
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine coninl(trec,nstr,nmax,icmem,v,isympv,isympo,nnir,nconf,
|
|
$ita,tarec,iwa,isa,file3,wspc1,wspc2,nactm,imedsyma,imedsymb,irec,
|
|
$itr,iarc,wsmax,intrec,ntcase,tcase,mscr,nnewsym,nampsym,icd,mfst,
|
|
$ninter,lcalc,lcalcn,noldsym,nptype,nvirtnewact,noccnewact,
|
|
$nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,nvirtnewalact,
|
|
$nvirtnewbeact,noccnewalact,noccnewbeact,icad,nnr,nnn,imm,lc,itad,
|
|
$logi,itc,ioffs)
|
|
************************************************************************
|
|
* This subroutine initializes variables for contractions *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nnir,nactm,i,j,k,m,iamprec,ii,incs,jj,ncoma,ncomb,ilv
|
|
integer nstr(nnir,0:nactm,0:nmax,4),n1,n2,n3,n4,nmem,wsmax,ical1
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),icado
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),file3
|
|
integer icmem(nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,4),imm,itad
|
|
integer isa(*),wspc1(0:wsmax,*),intrec(*),isave1,isig11,isig12
|
|
integer wspc2(0:wsmax,*),ircold,ircnew,nsyma,imedsyma(*),ical2
|
|
integer ntoldlen,namplen,ia1,ia2,ntoldleno,iwa(*),nampsym,iwn,itc
|
|
integer nvintoldal,nvintoldbe,nsymw,nointoldal,nointoldbe,isave2
|
|
integer nvirtoldbelen,noccoldbelen,incold(nnir),ntcase(0:1),npt
|
|
integer nvirtnewbelen,noccnewbelen,nampvirtlen,ir1,isymi,nptype
|
|
integer nampocclen,ntampvirtal,ntampvirtbe,ntampoccal,ntampoccbe
|
|
integer isympv(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2),ival
|
|
integer isympo(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2),ivbe
|
|
integer ira,nvirtnewsym,noccnewsym,irav,nvirtnewsyma,nvirtnewsymb
|
|
integer irao,noccnewsyma,noccnewsymb,ntampsym,noldsym,nn1,nn2,nn3
|
|
integer ntampsymv,ntampsymo,irtv,ntampsymva,ntampsymvb,noccoldlen
|
|
integer nvirtoldsyma,nvirtoldsymb,nvirtoldsym,irto,imedsymb(*)
|
|
integer ntampsymoa,ntampsymob,noccoldsyma,irt,nvirtoldlen,anstr
|
|
integer tarec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer ita(nnir,nnir,nnir,nnir),noccoldsymb,noccoldsym,nnr,nnn
|
|
integer iwo,iaddo(0:wsmax),nnewsym,tcase(2,(2*nactm+1)**2,0:nmax)
|
|
integer nvirtnewact,noccnewact,nampoccalact,nampoccbeact,iampad
|
|
integer nvintoldact,nointoldact,nvirtoldact,noccoldact,ioffs
|
|
integer nvintoldalact,nointoldalact,nvintoldbeact,nointoldbeact
|
|
integer nvirtoldalact,noccoldalact,nvirtoldbeact,noccoldbeact
|
|
integer ntampvirtact,ntampoccact,ntampvirtalact,ntampvirtbeact
|
|
integer nampvirtact,nampoccact,nampvirtalact,nampvirtbeact,intadd
|
|
integer nvirtnewalact,nvirtnewbeact,noccnewalact,noccnewbeact
|
|
integer ntampoccalact,ntampoccbeact,irec(nnir,0:nactm,0:nmax,4)
|
|
integer nampvirtal,nampvirtbe,nampoccal,nampoccbe,dbladd,aicmem
|
|
integer nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,aisympo
|
|
integer nvirtoldal,noccoldal,nvirtoldbe,noccoldbe,aisympv
|
|
integer nvirtnew,noccnew,nvintold,itr(2,0:nactm,0:nmax,4)
|
|
integer nointold,nvirtold,noccold,iarc(0:nactm,0:nmax,4)
|
|
integer ninter,icad,icd,mscr,mmm,mfst,ninter3,mscr3,mfst3
|
|
integer iw,i5,i6,i7,i8,i9,i10,ire1,ire2,ile1,icd3,itc1
|
|
real*8 v(*),faaal,faabe,fiial,fiibe
|
|
logical log,lcalc,lcalcn,lcalcs,lcalcsn,lc,ldir,logi
|
|
C
|
|
ninter=0
|
|
logi=.false.
|
|
C
|
|
rewind(ftfile)
|
|
do i=1,op-1
|
|
do j=1,ntcase(i)
|
|
nn1=0
|
|
call skip1(nn1,ftfile)
|
|
enddo
|
|
enddo
|
|
do i=1,nptype-1
|
|
nn1=0
|
|
call skip1(nn1,ftfile)
|
|
enddo
|
|
itc1=0
|
|
read(ftfile,*) n1
|
|
do nn1=1,n1
|
|
read(ftfile,*) j,j,nvirtnew,noccnew,nvintold,nointold,nvirtold,
|
|
$noccold,namp,ical1,isig11,isave1,j,j,nvirtnewact,noccnewact,
|
|
$nvintoldact,nointoldact,nvirtoldact,noccoldact
|
|
ntampvirtact=iabs(nvirtnewact-nvirtoldact)
|
|
ntampoccact=iabs(noccnewact-noccoldact)
|
|
ldir=.true.
|
|
if(isave1.gt.0) then
|
|
nn2=1
|
|
call skip11(nn2,ftfile,ldir)
|
|
endif
|
|
C Loop over spin cases of old intermediates
|
|
do iwo=1,wspc2(0,ical1)
|
|
nvintoldal=wspc2((iwo-1)*12+1,ical1)
|
|
nointoldal=wspc2((iwo-1)*12+2,ical1)
|
|
nvirtoldal=wspc2((iwo-1)*12+3,ical1)
|
|
noccoldal=wspc2((iwo-1)*12+4,ical1)
|
|
nvintoldalact=wspc2((iwo-1)*12+5,ical1)
|
|
nointoldalact=wspc2((iwo-1)*12+6,ical1)
|
|
nvintoldbeact=wspc2((iwo-1)*12+7,ical1)
|
|
nointoldbeact=wspc2((iwo-1)*12+8,ical1)
|
|
nvirtoldalact=wspc2((iwo-1)*12+9,ical1)
|
|
noccoldalact=wspc2((iwo-1)*12+10,ical1)
|
|
nvirtoldbeact=nvirtoldact-nvirtoldalact
|
|
noccoldbeact=noccoldact-noccoldalact
|
|
ircold=wspc2((iwo-1)*12+11,ical1)
|
|
ntoldlen=wspc2((iwo-1)*12+12,ical1)
|
|
ntoldleno=ntoldlen
|
|
nvintoldbe=nvintold-nvintoldal
|
|
nointoldbe=nointold-nointoldal
|
|
nvirtoldbe=nvirtold-nvirtoldal
|
|
noccoldbe=noccold-noccoldal
|
|
C
|
|
ntampvirtal=nvirtnewal-nvirtoldal
|
|
ntampvirtbe=nvirtnewbe-nvirtoldbe
|
|
ntampoccal=noccnewal-noccoldal
|
|
ntampoccbe=noccnewbe-noccoldbe
|
|
ntampvirtalact=nvirtnewalact-nvirtoldalact
|
|
ntampvirtbeact=nvirtnewbeact-nvirtoldbeact
|
|
ntampoccalact=noccnewalact-noccoldalact
|
|
ntampoccbeact=noccnewbeact-noccoldbeact
|
|
nampvirtal=ntampvirtal+nvintoldal
|
|
nampvirtbe=ntampvirtbe+nvintoldbe
|
|
nampoccal=nampvirtal
|
|
nampoccbe=nampvirtbe
|
|
nampvirtalact=ntampvirtalact+nvintoldalact
|
|
nampvirtbeact=ntampvirtbeact+nvintoldbeact
|
|
nampoccalact=ntampoccalact+nointoldalact
|
|
nampoccbeact=ntampoccbeact+nointoldbeact
|
|
nampvirtact=nampvirtalact+nampvirtbeact
|
|
nampoccact=nampoccalact+nampoccbeact
|
|
C
|
|
if(ntampvirtal.ge.0.and.
|
|
$ntampvirtbe.ge.0.and.ntampoccal.ge.0.and.ntampoccbe.ge.0.and.
|
|
$ntampvirtalact.ge.0.and.ntampvirtbeact.ge.0.and.
|
|
$ntampvirtalact+ntampvirtbeact.eq.ntampvirtact.and.
|
|
$ntampoccalact.ge.0.and.ntampoccbeact.ge.0.and.
|
|
$ntampoccalact+ntampoccbeact.eq.ntampoccact.and.
|
|
$nampvirtal.ge.0.and.nampvirtbe.ge.0.and.
|
|
$nampvirtal+nampvirtbe.eq.namp.and.nampvirtalact.ge.0.and.
|
|
$nampvirtalact.le.min(nactva,nampvirtal).and.nampvirtbeact.ge.0
|
|
$.and.nampvirtbeact.le.min(nactvb,nampvirtbe).and.
|
|
$nampoccalact.ge.0.and.nampoccalact.le.min(nactoa,nampoccal).and.
|
|
$nampoccbeact.ge.0.and.nampoccbeact.le.min(nactob,nampoccbe).and.
|
|
$nvintoldalact.ge.0.and.nvintoldbeact.ge.0.and.
|
|
$nvintoldalact.le.min(nvintoldal,nampvirtalact,nactva).and.
|
|
$nvintoldbeact.le.min(nvintoldbe,nampvirtbeact,nactvb).and.
|
|
$nvintoldalact+nvintoldbeact.ge.nvintoldact.and.
|
|
$nointoldalact.ge.0.and.nointoldbeact.ge.0.and.
|
|
$nointoldalact.le.min(nointoldal,nampoccalact,nactoa).and.
|
|
$nointoldbeact.le.min(nointoldbe,nampoccbeact,nactob).and.
|
|
$nointoldalact+nointoldbeact.ge.nointoldact) then
|
|
C
|
|
iamprec=trec(nampvirtalact,nampvirtbeact,
|
|
$nampoccalact,nampoccbeact,nampvirtal,namp)
|
|
namplen=nconf(nampvirtalact,nampvirtbeact,nampoccalact,
|
|
$nampoccbeact,nampvirtal,namp)
|
|
if(iamprec.gt.0.and.namplen.gt.0.and.
|
|
$(lcalcn.or.nampvirtal.lt.nampvirtbe.or.(nampvirtal.eq.nampvirtbe
|
|
$.and.nampvirtalact.lt.nampvirtbeact).or.(nampvirtal.eq.nampvirtbe
|
|
$.and.nampvirtalact.eq.nampvirtbeact.and.nampoccalact.le.
|
|
$nampoccbeact)).and.
|
|
$(lcalcn.or.nampvirtal.ne.nampvirtbe.or.nampvirtalact.ne.
|
|
$nampvirtbeact.or.nampoccalact.ne.nampoccbeact.or.
|
|
$nvirtnewal.lt.nvirtnewbe.or.(nvirtnewal.eq.nvirtnewbe.and.
|
|
$nvirtnewalact.lt.nvirtnewbeact).or.(nvirtnewal.eq.nvirtnewbe.and.
|
|
$nvirtnewalact.eq.nvirtnewbeact.and.noccnewalact.le.noccnewbeact))
|
|
$) then
|
|
lcalcs=lcalc.and.nampvirtal.eq.nampvirtbe.and.nampvirtalact.eq.
|
|
$nampvirtbeact.and.nampoccalact.eq.nampoccbeact.and.
|
|
$nvirtnewal.eq.nvirtnewbe.and.nvirtnewalact.eq.nvirtnewbeact.and.
|
|
$noccnewalact.eq.noccnewbeact
|
|
lcalcsn=.not.lcalcs
|
|
itc1=itc1+1
|
|
if(itc1.gt.itc.or.conver.ne.2) then
|
|
itc=itc+1
|
|
if(conver.eq.2) logi=.true.
|
|
C
|
|
ninter=ninter+1
|
|
icado=icad
|
|
icd=icad
|
|
C Addresses of integer arrays
|
|
icore(icd+1)=anstr(1,ntampvirtalact,ntampvirtal,1)
|
|
icore(icd+2)=anstr(1,ntampvirtbeact,ntampvirtbe,2)
|
|
icore(icd+3)=anstr(1,ntampoccalact,ntampoccal,3)
|
|
icore(icd+4)=anstr(1,ntampoccbeact,ntampoccbe,4)
|
|
icore(icd+5)=aicmem(1,1,nvintoldalact,ntampvirtalact,
|
|
$nvintoldal,ntampvirtal,1)
|
|
icore(icd+6)=aicmem(1,1,nvintoldbeact,ntampvirtbeact,
|
|
$nvintoldbe,ntampvirtbe,2)
|
|
icore(icd+7)=aicmem(1,1,nointoldalact,ntampoccalact,
|
|
$nointoldal,ntampoccal,3)
|
|
icore(icd+8)=aicmem(1,1,nointoldbeact,ntampoccbeact,
|
|
$nointoldbe,ntampoccbe,4)
|
|
icore(icd+9)=anstr(1,nvintoldalact,nvintoldal,1)
|
|
icore(icd+10)=anstr(1,nvintoldbeact,nvintoldbe,2)
|
|
icore(icd+11)=anstr(1,nointoldalact,nointoldal,3)
|
|
icore(icd+12)=anstr(1,nampvirtalact,nampvirtal,1)
|
|
icore(icd+13)=anstr(1,nampvirtbeact,nampvirtbe,2)
|
|
icore(icd+14)=anstr(1,nampoccalact,nampoccal,3)
|
|
icore(icd+15)=aisympv(0,1,nvintoldalact,nvintoldbeact,
|
|
$nvintoldal,nvintoldbe,1)
|
|
icore(icd+16)=aisympv(0,1,nvintoldalact,nvintoldbeact,
|
|
$nvintoldal,nvintoldbe,2)
|
|
icore(icd+17)=noldsym
|
|
icore(icd+19)=aicmem(1,1,noccoldalact,ntampoccalact,
|
|
$noccoldal,ntampoccal,3)
|
|
icore(icd+20)=aicmem(1,1,noccoldbeact,ntampoccbeact,
|
|
$noccoldbe,ntampoccbe,4)
|
|
icore(icd+21)=iamprec
|
|
icore(icd+22)=namplen
|
|
icore(icd+23)=anstr(1,noccnewalact,noccnewal,3)
|
|
icore(icd+24)=anstr(1,nvirtoldalact,nvirtoldal,1)
|
|
icore(icd+25)=anstr(1,nvirtoldbeact,nvirtoldbe,2)
|
|
icore(icd+26)=anstr(1,noccoldalact,noccoldal,3)
|
|
icore(icd+40)=iarc(nvirtoldalact,nvirtoldal,1)
|
|
icore(icd+41)=iarc(ntampvirtalact,ntampvirtal,1)
|
|
icore(icd+42)=iarc(nvirtoldbeact,nvirtoldbe,2)
|
|
icore(icd+43)=iarc(ntampvirtbeact,ntampvirtbe,2)
|
|
icore(icd+46)=nvirtoldal
|
|
icore(icd+47)=ntampvirtal
|
|
icore(icd+48)=nvirtoldbe
|
|
icore(icd+49)=ntampvirtbe
|
|
icore(icd+50)=namp
|
|
icad=icad+53
|
|
C Combinations
|
|
icore(icd+34)=icad+1
|
|
call comb(nvirtnewal,nvirtnewalact,icore(icad+1),ilv,nvirtoldal,
|
|
$nvirtoldalact,0,ncoma,isa)
|
|
eref=eref+dble(iintln*ncoma*(nvirtnewal+1))
|
|
icore(icd+44)=ncoma
|
|
icore(icd+35)=icad+1
|
|
call comb(nvirtnewbe,nvirtnewbeact,icore(icad+1),ilv,nvirtoldbe,
|
|
$nvirtoldbeact,0,ncomb,isa)
|
|
eref=eref+dble(iintln*ncomb*(nvirtnewbe+1))
|
|
icore(icd+45)=ncomb
|
|
C Trans vectors
|
|
icore(icd+36)=icad+1
|
|
mmm=itr(2,nvirtoldalact,nvirtoldal,1)
|
|
eref=eref+dble(iintln*mmm)
|
|
icore(icd+37)=icad+1
|
|
mmm=itr(2,ntampvirtalact,ntampvirtal,1)
|
|
eref=eref+dble(iintln*mmm)
|
|
icore(icd+38)=icad+1
|
|
mmm=itr(2,nvirtoldbeact,nvirtoldbe,2)
|
|
eref=eref+dble(iintln*mmm)
|
|
icore(icd+39)=icad+1
|
|
mmm=itr(2,ntampvirtbeact,ntampvirtbe,2)
|
|
eref=eref+dble(iintln*mmm)
|
|
C Length of summation indices
|
|
icore(icd+30)=icad+1
|
|
do isymi=1,nir
|
|
call slength(nmax,nstr,nnir,isympv,isympo,nactm,incs,isymi,
|
|
$nvintoldalact,nvintoldbeact,nvintoldal,nvintoldbe,nointoldalact,
|
|
$nointoldbeact,nointoldal,nointoldbe,isympair)
|
|
icore(icad+isymi)=incs
|
|
ecc=max(ecc,dble(incs))
|
|
enddo
|
|
icad=icad+nir
|
|
C Memory addresses of old intermediates
|
|
icore(icd+31)=icad+1
|
|
if(nvintold+nvirtold.eq.op.and.ldir) then
|
|
call occleni(nmax,nstr,nnir,isympo,nactm,noccoldalact,
|
|
$noccoldbeact,noccoldal,noccoldbe,icore(icore(icd+30)),ntoldlen,
|
|
$icore(icore(icd+31)))
|
|
icad=icad+nir**3
|
|
else
|
|
call nlength(nmax,nstr,nnir,isympv,isympo,nactm,nvirtoldalact,
|
|
$nvirtoldbeact,nvirtoldal,nvirtoldbe,noccoldalact,noccoldbeact,
|
|
$noccoldal,noccoldbe,icore(icore(icd+30)),ntoldlen,noldsym,
|
|
$icore(icore(icd+31)))
|
|
icad=icad+nir**5
|
|
endif
|
|
ntoldlen=ntoldlen-1
|
|
icore(icd+18)=ntoldlen
|
|
C Addresses of summation indices
|
|
icore(icd+32)=icad+1
|
|
eref=eref+dble(iintln*nir**4)
|
|
C Addresses of cluster amplitudes
|
|
icore(icd+33)=icad+1
|
|
eref=eref+dble(iintln*nir**4)
|
|
C Addresses of real arrays
|
|
icore(icd+27)=dbladd(icad)-ioffs+3
|
|
icore(icd+28)=icore(icd+27)+ioffs
|
|
eref=eref+dble(ifltln*ntoldlen)
|
|
C Sign of intermediate
|
|
isig12=isig11
|
|
if(mod(nvintoldbe*ntampvirtal+nointoldbe*ntampoccal+
|
|
$nvirtoldbe*ntampvirtal+noccoldbe*ntampoccal,2).ne.0)
|
|
$isig12=-isig12
|
|
C Construct intermediates with many virtual indices
|
|
call cint(nstr,nconf,trec,intrec,icmem,v(icore(icd+27)),nmax,
|
|
$isympv,isympo,ita,tarec,iwa,isa,icore(icore(icd+31)),wspc2,wspc1,
|
|
$wsmax,nactmax,ntcase,imedsyma,imedsymb,irec,itr,iarc,nnr,nnn,
|
|
$nptype,iaddo,ical1,nvintoldal,nointoldal,nvirtoldal,noccoldal,
|
|
$nvintoldalact,nointoldalact,nvintoldbeact,nointoldbeact,
|
|
$nvirtoldalact,noccoldalact,log,noldsym,nir,nvirtoldbe,
|
|
$nvirtoldbeact,ninter3,mscr3,mfst3,icd3,imm,lc,isig12,itad,ldir,
|
|
$ntoldlen,ioffs+icore(icd+27))
|
|
if(log) then
|
|
if(ninter3.gt.0) then
|
|
icore(icd+28)=icore(icd+27)+ioffs
|
|
eref=eref+dble(ifltln*mscr3)
|
|
icore(icd+51)=mfst3
|
|
icore(icd+52)=ninter3
|
|
icore(icd+53)=icd3
|
|
do isymi=1,nir
|
|
ecc=max(ecc,dble(icore(icore(icd+30)-1+isymi)+ntoldlen))
|
|
enddo
|
|
else
|
|
icore(icd+52)=0
|
|
endif
|
|
if(locno.gt.0) ecc=max(ecc,dble(2*nal**(noccnewal-1)),
|
|
$dble(2*nbe**(noccnewbe-1)*nstr(1,noccnewalact,noccnewal,3)))
|
|
C Read amplitudes
|
|
iampad=icore(icd+28)
|
|
call tread(itad,namplen,iampad,lc,nampvirtalact,
|
|
$nampvirtbeact,nampoccalact,nampoccbeact,nampvirtal,namp)
|
|
icore(icd+29)=icore(icd+28)-ioffs
|
|
eref=eref+dble(ifltln*namplen)
|
|
icore(icd+28)=iampad
|
|
mscr=icore(icd+29)
|
|
icad=intadd(mscr+ioffs)
|
|
else
|
|
icad=icado
|
|
ninter=ninter-1
|
|
endif !ia1
|
|
if(conver.eq.2) return
|
|
endif
|
|
endif !iamprec
|
|
endif
|
|
enddo !iwo
|
|
enddo !nn1
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine ampadd(i,nconf,trec,nmax,nactm,ift,ii)
|
|
************************************************************************
|
|
* Memory addresses of cluster amplitudes *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nactm,i,ii,ift
|
|
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 iactv,iacto,iactva,iactoa,iactvb,iactob
|
|
C
|
|
call ifillzero(trec(0,0,0,0,0,i),(nactm+1)**4+(nmax+1))
|
|
ii=ift
|
|
do iactv=max(0,i-mrop),min(nactv,i)
|
|
do iacto=max(0,i-mrop),min(nacto,i)
|
|
do i1=0,i
|
|
do iactva=max(0,iactv-nactvb),min(nactva,i1,iactv)
|
|
iactvb=iactv-iactva
|
|
do iactoa=max(0,iacto-nactob),min(nactoa,i1,iacto)
|
|
iactob=iacto-iactoa
|
|
trec(iactva,iactvb,iactoa,iactob,i1,i)=ii
|
|
ii=ii+nconf(iactva,iactvb,iactoa,iactob,i1,i)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii=ii-ift
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine occlen(nmax,nstr,nnir,isympo,nactm,nlen,nn5,nn6,nn7,
|
|
$nn8,ita)
|
|
************************************************************************
|
|
* This subroutine calculates the length of indices running over strings*
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nnir,nactm,isum,nmax,nn5,nn6,nn7,nn8,nlen,isymao
|
|
integer nstr(nnir,0:nactm,0:nmax,2),irao,isymaoa,isymaob
|
|
integer isympo(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2)
|
|
integer ita(nnir,nnir)
|
|
C
|
|
nlen=0
|
|
do isymao=1,nir
|
|
isum=0
|
|
do irao=1,isympo(0,isymao,nn5,nn6,nn7,nn8,1)
|
|
isymaoa=isympo(irao,isymao,nn5,nn6,nn7,nn8,1)
|
|
isymaob=isympo(irao,isymao,nn5,nn6,nn7,nn8,2)
|
|
ita(isymaoa,isymaob)=isum
|
|
isum=isum+nstr(isymaoa,nn5,nn7,1)*nstr(isymaob,nn6,nn8,2)
|
|
enddo
|
|
nlen=max(nlen,isum)
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine cint(nstr,nconf,trec,intrec,icmem,v,nmax,isympv,isympo,
|
|
$ita,tarec,iwa,isa,iwan,wspc2,wspc1,wsmax,nactm,ntcase,imedsyma,
|
|
$imedsymb,irec,itr,iarc,nnr,nnn,nptype,iaddo,ical1,nvintoldal,
|
|
$nointoldal,nvirtoldal,noccoldal,nvintoldalact,nointoldalact,
|
|
$nvintoldbeact,nointoldbeact,nvirtoldalact,noccoldalact,log,
|
|
$noldsym,nnir,nvirtoldbe,nvirtoldbeact,ninter,mscr,mfst3,icd,imm,
|
|
$lcalc,isig11,itad,ldir,nnnn,ioffs)
|
|
************************************************************************
|
|
* This subroutine performs one CC iteration step *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nactm,ita(*),nnir,nstr(nnir,0:nactm,0:nmax,4),i,k,l,m
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),icl1
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),j,iwan
|
|
integer intrec(*),isympv,isympo,iwa(*),file,wsmax,isa,ninter,mscr
|
|
integer iadd2(0:wsmax),nn,ntcase(0:1),imedsyma(*),icmem,ii,jj,irec
|
|
integer n1,n2,n3,n4,nn1,nn2,nn3,nn4,ical1,isave1,nptype,itr,iarc,n
|
|
integer nvintnew2,nointnew2,nvirtnew2,noccnew2,nvintold2,nointold2
|
|
integer nvirtold2,noccold2,namp2,ical2,isig12,isave2,nlist,mfst3
|
|
integer ical3,isig13,isave3,nnr,nnn,iaddo(0:wsmax),noldsym,icd
|
|
integer nvintnew2a,nointnew2a,nvirtnew2a,noccnew2a,file2,icad
|
|
integer nvintold2a,nointold2a,nvirtold2a,noccold2a,imm,isig11
|
|
integer nvintnew3a,nointnew3a,nvirtnew3a,noccnew3a,imedsymb(*)
|
|
integer nvintold3a,nointold3a,nvirtold3a,noccold3a,noccoldalact
|
|
integer nvintoldal,nointoldal,nvirtoldal,noccoldal,nvintoldalact
|
|
integer nointoldalact,nvintoldbeact,nointoldbeact,nvirtoldalact
|
|
integer wspc2(0:wsmax,13),wspc1(0:wsmax,13),tarec,nvirtoldbe
|
|
integer nvirtoldbeact,itad,nnnn,ioffs,intadd,dbladd
|
|
real*8 v(*),maxmemo
|
|
logical log,lcalc,ldir
|
|
C
|
|
log=.false.
|
|
icad=intadd(ioffs)
|
|
mfst3=dbladd(icad)-ioffs+3
|
|
mscr=mfst3
|
|
icad=intadd(mfst3+ioffs)
|
|
ninter=0
|
|
C Construct intermediates with many virtual indices
|
|
rewind(ftfile)
|
|
do i=1,op-1
|
|
do j=1,ntcase(i)
|
|
nn1=0
|
|
call skip1(nn1,ftfile)
|
|
enddo
|
|
enddo
|
|
do i=1,nptype-1
|
|
nn1=0
|
|
call skip1(nn1,ftfile)
|
|
enddo
|
|
read(ftfile,*) n1
|
|
do nn1=1,n1
|
|
read(ftfile,*)j,j,j,j,j,j,j,j,j,icl1,j,isave1,j,j,j,j,j,j,j,j
|
|
if(icl1.eq.ical1) then
|
|
call ifillzero(iaddo,wsmax+1)
|
|
if(isave1.gt.0) then
|
|
read(ftfile,*) n2
|
|
do nn2=1,n2
|
|
read(ftfile,*) nvintnew2,nointnew2,nvirtnew2,noccnew2,
|
|
$nvintold2,nointold2,nvirtold2,noccold2,namp2,ical2,isig12,isave2,
|
|
$nvintnew2a,nointnew2a,nvirtnew2a,noccnew2a,nvintold2a,nointold2a,
|
|
$nvirtold2a,noccold2a
|
|
if(isave2.gt.0.and.nvintnew2+nvirtnew2.eq.op.and.ldir)
|
|
$then
|
|
read(ftfile,*) n3
|
|
call ifillzero(iadd2,wsmax+1)
|
|
do nn3=1,n3
|
|
read(ftfile,*) j,j,j,j,j,j,j,j,j,ical3,isig13,isave3,
|
|
$nvintnew3a,nointnew3a,nvirtnew3a,noccnew3a,j,j,j,j
|
|
nn4=3
|
|
if(isave3.gt.0) call skip1(nn4,ftfile)
|
|
maxmemo=maxmem
|
|
maxmem=0.d0
|
|
call imedret(scrfile3,0,wspc2(0,ical2),intfile,intrec(ical3),
|
|
$isig13,iadd2,v(mscr),nmax,2,1,1.d0,wspc2(0,ical2),wspc1(0,ical3),
|
|
$nactmax,0,0,ical3,nconf,trec,nconf,trec,nvintnew3a+nvirtnew3a,
|
|
$nointnew3a+noccnew3a,wsmax,3,isave3,1,imedsyma(ical3))
|
|
maxmem=max(maxmemo,(8.d0*dble(mscr+ioffs-imem-3)+
|
|
$eref)/8.d0+maxmem)
|
|
enddo
|
|
call coninx(trec,nstr,nmax,icmem,nvintnew2,nointnew2,nvirtnew2,
|
|
$noccnew2,nvintold2,nointold2,nvirtold2,noccold2,namp2,isig12,
|
|
$scrfile2,0,scrfile3,0,iadd2,v,intrec(ical2),isympv,isympo,nir,
|
|
$nconf,ita,tarec,iwa,isa,iwan,tfile,wspc2(0,ical1),wspc2(0,ical2),
|
|
$wspc1(0,ical2),wsmax,nvintnew2a,nointnew2a,nvirtnew2a,noccnew2a,
|
|
$nvintold2a,nointold2a,nvirtold2a,noccold2a,nactmax,tarec,trec,
|
|
$nconf,1,1,noldsym,imedsymb(ical2),2,irec,itr,iarc,
|
|
$icore(mosymmem+nbasis),nbasis,nvirtal,nvirtbe,nnr,nnn,nvintoldal,
|
|
$nointoldal,nvirtoldal,noccoldal,nvintoldalact,nointoldalact,
|
|
$nvintoldbeact,nointoldbeact,nvirtoldalact,noccoldalact,log,ninter,
|
|
$mscr,mfst3,icd,icad,ical2,imm,lcalc,isig11,itad,nnnn,ioffs)
|
|
else
|
|
if(isave2.gt.0) then
|
|
nn3=2
|
|
call skip1(nn3,ftfile)
|
|
endif
|
|
call imrmem(intfile,intrec(ical2),isig11,isig12,v,wspc1(0,ical2),
|
|
$nvintoldal,nointoldal,nvirtoldal,noccoldal,nvintoldalact,
|
|
$nointoldalact,nvintoldbeact,nointoldbeact,nvirtoldalact,
|
|
$noccoldalact,log,iaddo)
|
|
endif
|
|
enddo
|
|
endif
|
|
return
|
|
else
|
|
if(isave1.gt.0) then
|
|
nn2=1
|
|
call skip1(nn2,ftfile)
|
|
endif
|
|
endif
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine coninx(trec,nstr,nmax,icmem,nvintnew1,nointnew1,
|
|
$nvirtnew1,noccnew1,nvintold1,nointold1,nvirtold1,noccold1,namp1,
|
|
$isig11,file1,irec1,file2,irec2,iaddo,v,intrec,isympv,isympo,nnir,
|
|
$nconf,ita,tarec,iwa,isa,iwan,file3,wspc1,wspc2,wspca,wsmax,
|
|
$nvintnewact,nointnewact,nvirtnewact,noccnewact,nvintoldact,
|
|
$nointoldact,nvirtoldact,noccoldact,nactm,earec,erec,econf,itypa,
|
|
$itypb,nnewsym,noldsym,ilev,irec,itr,iarc,mosym,nb,nva,nvb,nnr,nnn,
|
|
$nvintnewal,nointnewal,nvirtnewal,noccnewal,nvintnewalact,
|
|
$nointnewalact,nvintnewbeact,nointnewbeact,nvirtnewalact,
|
|
$noccnewalact,log,ninter,mscr,mfst3,icd,icad,ical,imm,lcalc,isigo,
|
|
$itad,nnnn,ioffs)
|
|
************************************************************************
|
|
* This subroutine initializes variables for contractions and performs *
|
|
* transpositions if it is necessary *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nnir,nactm,i,j,k,m,iamprec,ii,ilev,icad,ical,iadd,imm
|
|
integer nstr(nnir,0:nactm,0:nmax,4),isa(*),n1,n2,n3,n4,wsmax,nnnn
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),mmm
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),file3
|
|
integer icmem(nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,4),inewadd
|
|
integer nvintnew1,nointnew1,nvirtnew1,noccnew1,nvintold1,nointold1
|
|
integer nvirtold1,noccold1,namp1,isig11,isig12,ilv,isigo,ioffs
|
|
integer file1,file2,irec1,irec2,ircold,ircnew,intrec,nsyma,anstr
|
|
integer ntoldlen,namplen,ia1,ia2,ntoldleno,mfst3,mscr,aicmem
|
|
integer nvintoldal,nvintoldbe,nsymw,nointoldal,nointoldbe,ninter
|
|
integer nvirtoldbelen,noccoldbelen,incold(nnir),icd,aisympo
|
|
integer nsumvirtallen,nsumvirtbelen,nsumoccallen,nsumoccbelen,jj
|
|
integer nvirtnewbelen,noccnewbelen,nampvirtlen,kk,ir1,isymi,isyma
|
|
integer nampocclen,ntampvirtal,ntampvirtbe,ntampoccal,ntampoccbe
|
|
integer isympv(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2),ncoma
|
|
integer isympo(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2),ncomb
|
|
integer ira,nvirtnewsym,noccnewsym,irav,nvirtnewsyma,nvirtnewsymb
|
|
integer irao,noccnewsyma,noccnewsymb,nsumsym,ntampsym,noldsym
|
|
integer ntampsymv,ntampsymo,irtv,ntampsymva,ntampsymvb,noccoldlen
|
|
integer nvirtoldsyma,nvirtoldsymb,nvirtoldsym,irto,itypa,itypb
|
|
integer ntampsymoa,ntampsymob,noccoldsyma,irt,nvirtoldlen
|
|
integer tarec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer ita(nnir,nnir,nnir,nnir),noccoldsymb,noccoldsym,ntnewlen
|
|
integer iwa(nnir,nnir,nnir,nnir,nnir,nnir),ioldadd,aisympv,dbladd
|
|
integer iwan(nnir,nnir,nnir,nnir,nnir),nampsym,j1,j2,j3,j4,n,iwn
|
|
integer wspc1(0:1),wspc2(0:1),wspca(0:1),iwo,iaddo(0:1),nnewsym
|
|
integer nvintnewact,nointnewact,nvirtnewact,noccnewact,mosym,nb
|
|
integer nvintoldact,nointoldact,nvirtoldact,noccoldact,nnr,nnn
|
|
integer nvintoldalact,nointoldalact,nvintoldbeact,nointoldbeact
|
|
integer nvirtoldalact,noccoldalact,nvirtoldbeact,noccoldbeact
|
|
integer ntampvirtact,ntampoccact,nsumvirtact,nsumoccact,nva,nvb
|
|
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,irec(nnir,0:nactm,0:nmax,4)
|
|
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,itad,iampad
|
|
integer nampvirtal,nampvirtbe,nampoccal,nampoccbe,intadd
|
|
integer nvintnewal,nvintnewbe,nointnewal,nointnewbe
|
|
integer nvirtnewal,nvirtnewbe,noccnewal,noccnewbe
|
|
integer nsumvirt,nsumocc,nvirtoldal,noccoldal,nvirtoldbe,noccoldbe
|
|
integer nvintnew,nointnew,nintnew,nvirtnew,noccnew,nvintold
|
|
integer nointold,nintold,nvirtold,noccold,itr(2,0:nactm,0:nmax,4)
|
|
integer iarc(0:nactm,0:nmax,4),lc,iaddold
|
|
real*8 v(*),imsg,maxmemo,nopmaxo
|
|
logical log,lcalc
|
|
C Initialize variables
|
|
nvintnew=nvintnew1
|
|
nointnew=nointnew1
|
|
nintnew=nvintnew+nointnew
|
|
nvirtnew=nvirtnew1
|
|
noccnew=noccnew1
|
|
C
|
|
nvintold=nvintold1
|
|
nointold=nointold1
|
|
nintold=nvintold+nointold
|
|
nvirtold=nvirtold1
|
|
noccold=noccold1
|
|
nampsym=mult(nnewsym,noldsym)
|
|
C
|
|
nsumvirt=nvintold-nvintnew
|
|
nsumocc=nointold-nointnew
|
|
nsum=nsumvirt+nsumocc
|
|
ntampvirtact=iabs(nvirtnewact-nvirtoldact)
|
|
ntampoccact=iabs(noccnewact-noccoldact)
|
|
C Loop over spin cases of intermediates
|
|
call fwspc(wspca,nvintnewal,nointnewal,nvirtnewal,noccnewal,
|
|
$nvintnewalact,nointnewalact,nvintnewbeact,nointnewbeact,
|
|
$nvirtnewalact,noccnewalact,ircnew,ntnewlen)
|
|
if(ntnewlen.ne.0) then
|
|
nvirtnewbeact=nvirtnewact-nvirtnewalact
|
|
noccnewbeact=noccnewact-noccnewalact
|
|
nvintnewbe=nvintnew-nvintnewal
|
|
nointnewbe=nointnew-nointnewal
|
|
nvirtnewbe=nvirtnew-nvirtnewal
|
|
noccnewbe=noccnew-noccnewal
|
|
C
|
|
do iwo=1,wspc2(0)
|
|
nvintoldal=wspc2((iwo-1)*12+1)
|
|
nointoldal=wspc2((iwo-1)*12+2)
|
|
nvirtoldal=wspc2((iwo-1)*12+3)
|
|
noccoldal=wspc2((iwo-1)*12+4)
|
|
nvintoldalact=wspc2((iwo-1)*12+5)
|
|
nointoldalact=wspc2((iwo-1)*12+6)
|
|
nvintoldbeact=wspc2((iwo-1)*12+7)
|
|
nointoldbeact=wspc2((iwo-1)*12+8)
|
|
nvirtoldalact=wspc2((iwo-1)*12+9)
|
|
noccoldalact=wspc2((iwo-1)*12+10)
|
|
nvirtoldbeact=nvirtoldact-nvirtoldalact
|
|
noccoldbeact=noccoldact-noccoldalact
|
|
ircold=wspc2((iwo-1)*12+11)
|
|
ntoldlen=wspc2((iwo-1)*12+12)
|
|
ntoldleno=ntoldlen
|
|
nvintoldbe=nvintold-nvintoldal
|
|
nointoldbe=nointold-nointoldal
|
|
nvirtoldbe=nvirtold-nvirtoldal
|
|
noccoldbe=noccold-noccoldal
|
|
call fwspc(iaddo,nvintoldal,nointoldal,nvirtoldal,noccoldal,
|
|
$nvintoldalact,nointoldalact,nvintoldbeact,nointoldbeact,
|
|
$nvirtoldalact,noccoldalact,ia1,ia2)
|
|
if(ia1.gt.0) then
|
|
nsumvirtal=nvintoldal-nvintnewal
|
|
nsumvirtbe=nvintoldbe-nvintnewbe
|
|
nsumoccal=nointoldal-nointnewal
|
|
nsumoccbe=nointoldbe-nointnewbe
|
|
nsumvirtalact=nvintoldalact-nvintnewalact
|
|
nsumvirtbeact=nvintoldbeact-nvintnewbeact
|
|
nsumoccalact=nointoldalact-nointnewalact
|
|
nsumoccbeact=nointoldbeact-nointnewbeact
|
|
ntampvirtal=nvirtnewal-nvirtoldal
|
|
ntampvirtbe=nvirtnewbe-nvirtoldbe
|
|
ntampoccal=noccnewal-noccoldal
|
|
ntampoccbe=noccnewbe-noccoldbe
|
|
ntampvirtalact=nvirtnewalact-nvirtoldalact
|
|
ntampvirtbeact=nvirtnewbeact-nvirtoldbeact
|
|
ntampoccalact=noccnewalact-noccoldalact
|
|
ntampoccbeact=noccnewbeact-noccoldbeact
|
|
nampvirtal=ntampvirtal+nsumvirtal
|
|
nampvirtbe=ntampvirtbe+nsumvirtbe
|
|
nampoccal=nampvirtal
|
|
nampoccbe=nampvirtbe
|
|
nampvirtalact=ntampvirtalact+nsumvirtalact
|
|
nampvirtbeact=ntampvirtbeact+nsumvirtbeact
|
|
nampoccalact=ntampoccalact+nsumoccalact
|
|
nampoccbeact=ntampoccbeact+nsumoccbeact
|
|
nampvirtact=nampvirtalact+nampvirtbeact
|
|
nampoccact=nampoccalact+nampoccbeact
|
|
C
|
|
if(ntampvirtal.ge.0.and.
|
|
$ntampvirtbe.ge.0.and.ntampoccal.ge.0.and.ntampoccbe.ge.0.and.
|
|
$ntampvirtalact.ge.0.and.ntampvirtbeact.ge.0.and.
|
|
$ntampvirtalact+ntampvirtbeact.eq.ntampvirtact.and.
|
|
$ntampoccalact.ge.0.and.ntampoccbeact.ge.0.and.
|
|
$ntampoccalact+ntampoccbeact.eq.ntampoccact.and.
|
|
$nampvirtal.ge.0.and.nampvirtbe.ge.0.and.
|
|
$nampvirtal+nampvirtbe.eq.iabs(namp1).and.nampvirtalact.ge.0.and.
|
|
$nampvirtalact.le.min(nactva,nampvirtal).and.nampvirtbeact.ge.0
|
|
$.and.nampvirtbeact.le.min(nactvb,nampvirtbe).and.
|
|
$nampoccalact.ge.0.and.nampoccalact.le.min(nactoa,nampoccal).and.
|
|
$nampoccbeact.ge.0.and.nampoccbeact.le.min(nactob,nampoccbe).and.
|
|
$nsumvirtal.ge.max(0,nvirtoldal+nampvirtal-min(minvirtal,op-1),
|
|
$nsumvirt-min(nvintoldbe,nampvirtbe)).and.
|
|
$nsumvirtal.le.min(nvintoldal,nsumvirt,nampvirtal,
|
|
$min(minvirtbe,op-1)-nvirtoldbe+nampvirtbe+nsumvirt).and.
|
|
$nsumvirtalact.ge.0.and.nsumvirtbeact.ge.0.and.
|
|
$nsumvirtalact.le.min(nsumvirtal,nampvirtalact,nactva).and.
|
|
$nsumvirtbeact.le.min(nsumvirtbe,nampvirtbeact,nactvb).and.
|
|
$nvintoldalact+nvintoldbeact.ge.nvintoldact.and.
|
|
$nsumoccal.ge.max(0,noccoldal+nampoccal-minoccal,
|
|
$nsumocc-min(nointoldbe,nampoccbe)).and.
|
|
$nsumoccal.le.min(nointoldal,nsumocc,nampoccal,
|
|
$minoccbe-noccoldbe+nampoccbe+nsumocc).and.
|
|
$nsumoccalact.ge.0.and.nsumoccbeact.ge.0.and.
|
|
$nsumoccalact.le.min(nsumoccal,nampoccalact,nactoa).and.
|
|
$nsumoccbeact.le.min(nsumoccbe,nampoccbeact,nactob).and.
|
|
$nointoldalact+nointoldbeact.ge.nointoldact.and.
|
|
$nsumvirtbe.ge.0.and.nsumoccbe.ge.0) then
|
|
C
|
|
iamprec=trec(nampvirtalact,nampvirtbeact,
|
|
$nampoccalact,nampoccbeact,nampvirtal,iabs(namp1))
|
|
namplen=nconf(nampvirtalact,nampvirtbeact,nampoccalact,
|
|
$nampoccbeact,nampvirtal,iabs(namp1))
|
|
if(iamprec.gt.0.and.namplen.gt.0) then
|
|
C
|
|
ninter=ninter+1
|
|
log=.true.
|
|
icd=icad
|
|
C Addresses of integer arrays
|
|
icore(icd+1)=anstr(1,ntampvirtalact,ntampvirtal,1)
|
|
icore(icd+2)=anstr(1,ntampvirtbeact,ntampvirtbe,2)
|
|
icore(icd+3)=anstr(1,ntampoccalact,ntampoccal,3)
|
|
icore(icd+4)=anstr(1,ntampoccbeact,ntampoccbe,4)
|
|
icore(icd+5)=aicmem(1,1,nsumvirtalact,ntampvirtalact,
|
|
$nsumvirtal,ntampvirtal,1)
|
|
icore(icd+6)=aicmem(1,1,nsumvirtbeact,ntampvirtbeact,
|
|
$nsumvirtbe,ntampvirtbe,2)
|
|
icore(icd+7)=aicmem(1,1,nsumoccalact,ntampoccalact,
|
|
$nsumoccal,ntampoccal,3)
|
|
icore(icd+8)=aicmem(1,1,nsumoccbeact,ntampoccbeact,
|
|
$nsumoccbe,ntampoccbe,4)
|
|
icore(icd+9)=anstr(1,nsumvirtalact,nsumvirtal,1)
|
|
icore(icd+10)=anstr(1,nsumvirtbeact,nsumvirtbe,2)
|
|
icore(icd+11)=anstr(1,nsumoccalact,nsumoccal,3)
|
|
icore(icd+12)=anstr(1,nampvirtalact,nampvirtal,1)
|
|
icore(icd+13)=anstr(1,nampvirtbeact,nampvirtbe,2)
|
|
icore(icd+14)=anstr(1,nampoccalact,nampoccal,3)
|
|
icore(icd+15)=aisympv(0,1,nsumvirtalact,nsumvirtbeact,
|
|
$nsumvirtal,nsumvirtbe,1)
|
|
icore(icd+16)=aisympv(0,1,nsumvirtalact,nsumvirtbeact,
|
|
$nsumvirtal,nsumvirtbe,2)
|
|
icore(icd+17)=nampsym
|
|
icore(icd+18)=0
|
|
icore(icd+19)=aicmem(1,1,noccoldalact,ntampoccalact,
|
|
$noccoldal,ntampoccal,3)
|
|
icore(icd+20)=aicmem(1,1,noccoldbeact,ntampoccbeact,
|
|
$noccoldbe,ntampoccbe,4)
|
|
icore(icd+21)=iamprec
|
|
icore(icd+22)=namplen
|
|
icore(icd+23)=anstr(1,noccnewalact,noccnewal,3)
|
|
icore(icd+24)=anstr(1,nvirtoldalact,nvirtoldal,1)
|
|
icore(icd+25)=anstr(1,nvirtoldbeact,nvirtoldbe,2)
|
|
icore(icd+26)=anstr(1,noccoldalact,noccoldal,3)
|
|
icore(icd+40)=iarc(nvirtoldalact,nvirtoldal,1)
|
|
icore(icd+41)=iarc(ntampvirtalact,ntampvirtal,1)
|
|
icore(icd+42)=iarc(nvirtoldbeact,nvirtoldbe,2)
|
|
icore(icd+43)=iarc(ntampvirtbeact,ntampvirtbe,2)
|
|
icore(icd+46)=nvirtoldal
|
|
icore(icd+47)=ntampvirtal
|
|
icore(icd+48)=nvirtoldbe
|
|
icore(icd+49)=ntampvirtbe
|
|
icad=icad+52
|
|
C Combinations
|
|
icore(icd+34)=icad+1
|
|
call comb(nvirtnewal,nvirtnewalact,icore(icad+1),ilv,nvirtoldal,
|
|
$nvirtoldalact,0,ncoma,isa)
|
|
eref=eref+dble(iintln*ncoma*(nvirtnewal+1))
|
|
icore(icd+44)=ncoma
|
|
icore(icd+35)=icad+1
|
|
call comb(nvirtnewbe,nvirtnewbeact,icore(icad+1),ilv,nvirtoldbe,
|
|
$nvirtoldbeact,0,ncomb,isa)
|
|
eref=eref+dble(iintln*ncomb*(nvirtnewbe+1))
|
|
icore(icd+45)=ncomb
|
|
C Trans vectors
|
|
icore(icd+36)=icad+1
|
|
mmm=itr(2,nvirtoldalact,nvirtoldal,1)
|
|
eref=eref+dble(iintln*mmm)
|
|
icore(icd+37)=icad+1
|
|
mmm=itr(2,ntampvirtalact,ntampvirtal,1)
|
|
eref=eref+dble(iintln*mmm)
|
|
icore(icd+38)=icad+1
|
|
mmm=itr(2,nvirtoldbeact,nvirtoldbe,2)
|
|
eref=eref+dble(iintln*mmm)
|
|
icore(icd+39)=icad+1
|
|
mmm=itr(2,ntampvirtbeact,ntampvirtbe,2)
|
|
eref=eref+dble(iintln*mmm)
|
|
C Length of summation indices
|
|
icore(icd+30)=icad+1
|
|
icad=icad+nir
|
|
C Length of new free indices
|
|
icore(icd+51)=icad+1
|
|
icad=icad+nir
|
|
C Addresses of summation indices
|
|
icore(icd+32)=icad+1
|
|
eref=eref+dble(iintln*nir**4)
|
|
C Addresses of cluster amplitudes
|
|
icore(icd+33)=icad+1
|
|
eref=eref+dble(iintln*nir**4)
|
|
C Memory addresses of old intermediates
|
|
icore(icd+31)=icad+1
|
|
icad=icad+nir**6
|
|
iadd=icore(icd+31)
|
|
C Transposition of old intermediate
|
|
icore(icd+27)=dbladd(iadd+nir**6)+1
|
|
lc=0
|
|
if(lcalc) lc=1
|
|
maxmemo=maxmem
|
|
nopmaxo=nopmax
|
|
maxmem=0.d0
|
|
nopmax=0.d0
|
|
iaddold=iadd
|
|
call transposition(nmax,nnir,nactm,nstr,icmem,isympv,isympo,
|
|
$icore(icore(icd+31)),iwan,dcore(icore(icd+27)),isig12,ntoldlen,
|
|
$ntoldleno,iabs(namp1),file2,irec2,ircold,ita,0,
|
|
$icore(icore(icd+51)),
|
|
$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,
|
|
$icore(icore(icd+30)),.true.,icore(icore(icd+31)),incold,
|
|
$nsumvirtal,nsumvirtbe,nsumoccal,nsumoccbe,nvintnewal,nvintnewbe,
|
|
$nointnewal,nointnewbe,nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,
|
|
$nintnew,nintold,nvintold,nointold,nvirtoldal,nvirtoldbe,noccoldal,
|
|
$noccoldbe,.false.,.true.,ical,imm,iadd,lc,icore(icd+27),.false.,1)
|
|
nopmax=max(nopmaxo,(8.d0*dble(icore(icd+27)-imem)+
|
|
$eref)/8.d0+nopmax)
|
|
maxmem=max(maxmemo,(8.d0*dble(icore(icd+27)-imem)+
|
|
$eref)/8.d0+maxmem)
|
|
do isymi=1,nir
|
|
ecc=max(ecc,dble(icore(icore(icd+30)-1+isymi)+nnnn))
|
|
enddo
|
|
if(sign(1,iaddold)*sign(1,iadd).lt.0) then
|
|
iadd=-iadd
|
|
icad=icad-nir**6
|
|
icore(icd+31)=iadd
|
|
icore(icd+27)=dbladd(iadd+nir**6)+1
|
|
icore(icd+28)=dbladd(icad)+1
|
|
if(lcalc.and.lc.eq.1) icore(icd+18)=1
|
|
if(lc.eq.2) icore(icd+18)=lc
|
|
ntoldlen=icore(iadd+nir**6)
|
|
else
|
|
icore(icd+28)=icore(icd+27)
|
|
eref=eref+dble(ifltln*ntoldlen)
|
|
icore(iadd+nir**6)=ntoldlen
|
|
endif
|
|
C Addresses of real arrays
|
|
iampad=icore(icd+28)
|
|
ii=namplen
|
|
call tread(itad,namplen,iampad,lcalc,nampvirtalact,nampvirtbeact,
|
|
$nampoccalact,nampoccbeact,nampvirtal,iabs(namp1))
|
|
icore(icd+52)=icore(icd+28)-ioffs+3
|
|
eref=eref+dble(ifltln*namplen)
|
|
icore(icd+29)=icore(icd+52)+1
|
|
mscr=icore(icd+29)
|
|
icad=intadd(mscr+ioffs)
|
|
C Read amplitudes
|
|
icore(icd+28)=iampad
|
|
C Sign of intermediate
|
|
if(mod(nsumvirtbe*ntampvirtal+nsumoccbe*ntampoccal+
|
|
$nvirtoldbe*ntampvirtal+noccoldbe*ntampoccal,2).ne.0)
|
|
$isig12=-isig12
|
|
v(icore(icd+52))=imsg(isigo)*imsg(isig11*isig12)
|
|
endif
|
|
endif
|
|
endif !ia1.gt.0
|
|
enddo !iwo
|
|
endif !ntnewlen
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine imrmem(file,irec,isg1,isg2,v,wspc,n1,n2,n3,n4,n5,n6,n7,
|
|
$n8,n9,n10,log,iadd)
|
|
************************************************************************
|
|
* This subroutine retrieves intermediates *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer wspc,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,ile,file,irec,ire,isg1
|
|
integer iadd(0:1),ia1,ia2,isg2,i
|
|
real*8 v(*),imsg,ssg
|
|
logical log
|
|
C
|
|
call fwspc(wspc,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,ire,ile)
|
|
if(ile.gt.0) then
|
|
ssg=imsg(isg1)*imsg(isg2)
|
|
log=.true.
|
|
call fwspc(iadd,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,ia1,ia2)
|
|
if(ia1.gt.0) then
|
|
else
|
|
call wiadd(iadd,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,ile)
|
|
endif
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
real*8 function imsg(isig)
|
|
************************************************************************
|
|
* Sign of intermediates *
|
|
************************************************************************
|
|
implicit none
|
|
integer isig
|
|
C
|
|
imsg=dble(isig)
|
|
if(iabs(isig).ne.1) then
|
|
if(iabs(isig).le.4) then
|
|
imsg=1.d0/dble(isig)
|
|
else
|
|
if(iabs(isig).eq.5) imsg=dsign(2.d0,imsg)
|
|
endif
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine occleni(nmax,nstr,nnir,isympo,nactm,nn5,nn6,nn7,nn8,
|
|
$incnew,nlen,iwan)
|
|
************************************************************************
|
|
* This subroutine calculates the length of indices running over strings*
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nnir,nactm,isum,nmax,nn5,nn6,nn7,nn8
|
|
integer nstr(nnir,0:nactm,0:nmax,4),irao,isymaoa,isymaob,j1
|
|
integer isympo(0:nnir,nnir,0:nactm,0:nactm,0:nmax,0:nmax,2)
|
|
integer ira,incnew(8),nlen,iwan(nnir,nnir,nnir),isymi,isyma
|
|
C
|
|
nlen=0
|
|
do ir=1,nir
|
|
isum=1
|
|
do ira=1,nir
|
|
isymi=isympair(ir,ira,1)
|
|
isyma=isympair(ir,ira,2)
|
|
j1=incnew(isymi)
|
|
do irao=1,isympo(0,isyma,nn5,nn6,nn7,nn8,1)
|
|
isymaoa=isympo(irao,isyma,nn5,nn6,nn7,nn8,1)
|
|
isymaob=isympo(irao,isyma,nn5,nn6,nn7,nn8,2)
|
|
iwan(isymi,isymaoa,isymaob)=isum
|
|
isum=isum+j1*nstr(isymaoa,nn5,nn7,3)*nstr(isymaob,nn6,nn8,4)
|
|
enddo
|
|
enddo
|
|
nlen=max(nlen,isum)
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine fwspd(wspc,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,in,ire,ile)
|
|
************************************************************************
|
|
* Give back the memory address of an intermediate *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer wspc(0:1),n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,in(4),ire,ile,i,j
|
|
C
|
|
ile=0
|
|
j=0
|
|
do i=1,wspc(0)
|
|
if(wspc(j+ 1).eq.n1.and.
|
|
$ wspc(j+ 2).eq.n2.and.
|
|
$ wspc(j+ 3).eq.n3.and.
|
|
$ wspc(j+ 4).eq.n4.and.
|
|
$ wspc(j+ 5).eq.n5.and.
|
|
$ wspc(j+ 6).eq.n6.and.
|
|
$ wspc(j+ 7).eq.n7.and.
|
|
$ wspc(j+ 8).eq.n8.and.
|
|
$ wspc(j+ 9).eq.n9.and.
|
|
$ wspc(j+10).eq.n10.and.
|
|
$ wspc(j+11).eq.in(1).and.
|
|
$ wspc(j+12).eq.in(2).and.
|
|
$ wspc(j+13).eq.in(3).and.
|
|
$ wspc(j+14).eq.in(4).and.
|
|
$ wspc(j+15).eq.ire) then
|
|
ile=wspc(j+16)
|
|
return
|
|
endif
|
|
j=j+16
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine diadd(iadd,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,in,ire,ile)
|
|
************************************************************************
|
|
* Write in iadd array *
|
|
************************************************************************
|
|
implicit none
|
|
integer iadd(0:16),n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,in(4),ire,ile,i
|
|
integer iz
|
|
C
|
|
iz=0
|
|
i=iadd(iz)
|
|
if(ile.eq.0.or.i.ge.iadd(iz-1)) return
|
|
iadd(iz)=i+1
|
|
i=i*16
|
|
iadd(i+ 1)= n1
|
|
iadd(i+ 2)= n2
|
|
iadd(i+ 3)= n3
|
|
iadd(i+ 4)= n4
|
|
iadd(i+ 5)= n5
|
|
iadd(i+ 6)= n6
|
|
iadd(i+ 7)= n7
|
|
iadd(i+ 8)= n8
|
|
iadd(i+ 9)= n9
|
|
iadd(i+10)=n10
|
|
iadd(i+11)=in(1)
|
|
iadd(i+12)=in(2)
|
|
iadd(i+13)=in(3)
|
|
iadd(i+14)=in(4)
|
|
iadd(i+15)=ire
|
|
iadd(i+16)=ile
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine tread(itad,namplen,iampad,lcalc,nampvirtalact,
|
|
$nampvirtbeact,nampoccalact,nampoccbeact,nampvirtal,nam)
|
|
************************************************************************
|
|
* Give back the memory address of cluster amplitudes *
|
|
************************************************************************
|
|
implicit none
|
|
integer itad,namplen,iampad,nampvirtalact,nampvirtbeact,i,j
|
|
integer nampoccalact,nampoccbeact,nampvirtal,nam
|
|
logical lcalc
|
|
C
|
|
call fwspc(itad,nampvirtalact,nampvirtbeact,nampoccalact,
|
|
$nampoccbeact,nampvirtal,nam,0,0,0,0,i,j)
|
|
if((nampvirtal.eq.nam.or.nampvirtal.eq.0).and.i.eq.0.and.lcalc)
|
|
$call fwspc(itad,nampvirtbeact,nampvirtalact,nampoccbeact,
|
|
$nampoccalact,nam-nampvirtal,nam,0,0,0,0,i,j)
|
|
if(i.eq.0) then
|
|
call wiadd(itad,nampvirtalact,nampvirtbeact,nampoccalact,
|
|
$nampoccbeact,nampvirtal,nam,0,0,0,0,iampad)
|
|
else
|
|
namplen=0
|
|
iampad=i
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine skip11(ilev,file,log)
|
|
************************************************************************
|
|
* This subroutine reads the unused lines from the formula-file. *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer n,i,isave,nn,ilev,file
|
|
logical log
|
|
C
|
|
ilev=ilev+1
|
|
read(file,*) n
|
|
do nn=1,n
|
|
read(file,*) i,i,i,i,i,i,i,i,i,i,i,isave,i,i,i,i,i,i,i,i
|
|
if(isave.eq.0.and.nn.eq.1) log=.false.
|
|
if(isave.gt.0) call skip2(ilev,file)
|
|
enddo
|
|
ilev=ilev-1
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine slengt8(nmax,nstr,nnir,isympv,isympo,nactm,isum,ssym,
|
|
$nn1,nn2,nn3,nn4,nn5,nn6,nn7,nn8)
|
|
************************************************************************
|
|
* This subroutine calculates the length of indices running over strings*
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nnir,nactm,nmax,nn1,nn2,nn3,nn4,nn5,nn6,nn7,nn8
|
|
integer nstr(nnir,0:nactm,0:nmax,4),irao,isymaoa,isymaob,ssym
|
|
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,isymav,isymao,irav,isymava,isymavb
|
|
integer*8 isum,nn
|
|
C
|
|
isum=0
|
|
do ira=1,nir
|
|
isymav=isympair(ssym,ira,1)
|
|
isymao=isympair(ssym,ira,2)
|
|
do irav=1,isympv(0,isymav,nn1,nn2,nn3,nn4,1)
|
|
isymava=isympv(irav,isymav,nn1,nn2,nn3,nn4,1)
|
|
isymavb=isympv(irav,isymav,nn1,nn2,nn3,nn4,2)
|
|
nn=nstr(isymava,nn1,nn3,1)*nstr(isymavb,nn2,nn4,2)
|
|
do irao=1,isympo(0,isymao,nn5,nn6,nn7,nn8,1)
|
|
isymaoa=isympo(irao,isymao,nn5,nn6,nn7,nn8,1)
|
|
isymaob=isympo(irao,isymao,nn5,nn6,nn7,nn8,2)
|
|
isum=isum+nstr(isymaoa,nn5,nn7,3)*nstr(isymaob,nn6,nn8,4)*nn
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
integer function anstr(n1,n2,n3,n4)
|
|
************************************************************************
|
|
* Address of nstr wrt icore *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer n1,n2,n3,n4
|
|
C
|
|
anstr=iconfmem+(n4-1)*(oo+1)*(nactmax+1)*nir+n3*(nactmax+1)*nir+
|
|
$n2*nir+n1-1
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
integer function aicmem(n1,n2,n3,n4,n5,n6,n7)
|
|
************************************************************************
|
|
* Address of nstr wrt icore *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer n1,n2,n3,n4,n5,n6,n7
|
|
C
|
|
aicmem=icoupmem+(n7-1)*(oo+1)**2*(nactmax+1)**2*nir**2+
|
|
$ n6 *(oo+1) *(nactmax+1)**2*nir**2+
|
|
$ n5 *(nactmax+1)**2*nir**2+
|
|
$ n4 *(nactmax+1) *nir**2+
|
|
$ n3 *nir**2+
|
|
$ (n2-1) *nir +n1-1
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
integer function aisympo(n1,n2,n3,n4,n5,n6,n7)
|
|
************************************************************************
|
|
* Address of nstr wrt icore *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer n1,n2,n3,n4,n5,n6,n7
|
|
C
|
|
aisympo=isympmem+(oo+1)**2*nir*(nir+1)*2*(nactmax+1)**2+
|
|
$ (n7-1)*(oo+1)**2*(nactmax+1)**2*nir*(nir+1)+
|
|
$ n6 *(oo+1) *(nactmax+1)**2*nir*(nir+1)+
|
|
$ n5 *(nactmax+1)**2*nir*(nir+1)+
|
|
$ n4 *(nactmax+1) *nir*(nir+1)+
|
|
$ n3 *nir*(nir+1)+
|
|
$ (n2-1) *(nir+1)+n1
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
integer function aisympv(n1,n2,n3,n4,n5,n6,n7)
|
|
************************************************************************
|
|
* Address of nstr wrt icore *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer n1,n2,n3,n4,n5,n6,n7
|
|
C
|
|
aisympv=isympmem+(n7-1)*(oo+1)**2*(nactmax+1)**2*nir*(nir+1)+
|
|
$ n6 *(oo+1) *(nactmax+1)**2*nir*(nir+1)+
|
|
$ n5 *(nactmax+1)**2*nir*(nir+1)+
|
|
$ n4 *(nactmax+1) *nir*(nir+1)+
|
|
$ n3 *nir*(nir+1)+
|
|
$ (n2-1) *(nir+1)+n1
|
|
C
|
|
return
|
|
end
|
|
C
|