mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-16 03:38:05 +01:00
3985 lines
168 KiB
Fortran
Executable File
3985 lines
168 KiB
Fortran
Executable File
C Mit kell csinalni?
|
|
C 1) goldstone: Lambda legyen az utolso.
|
|
C 2) lhg-t rendbe rakni (pl. CCSDT-1a-nal nem kell L_1)
|
|
C 3) 7,8,11-es listat nem kell transponalni + mar bent van a memoriaban
|
|
C 4) IT intermedierek, amelyek csak a L-hoz kellenek, egyszer szamolni
|
|
C
|
|
C
|
|
************************************************************************
|
|
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,scspe,lcvs,ncvs,cvsorb,spsht,
|
|
$absind,strec,lf12)
|
|
************************************************************************
|
|
* 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),ncvs
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),cvsorb
|
|
integer isympo,ita,tarec,iwa(*),isa,isw,istr,wspcb,wspca,wsmax
|
|
integer intn,ntcase,earec,econf,erec,denrec,trec2,erec2,spsht,lf12
|
|
integer tcase,itypa,itypb,imedsyma,imedsymb,l2map,absind,strec
|
|
integer iactv,iacto,iactva,iactvb,iactoa,iactob
|
|
real*8 v(*),norm,test,corr1,corr2,corr3,corr4,sum,elam,c3,c4,scspe
|
|
character*128 mmm
|
|
character*1 str1,str2
|
|
logical lcvs
|
|
C
|
|
pertroute=-2
|
|
call rfock(v,v(nvirtal+1),v(nvirt+1),v(nvirt+nal+1),v(nbasis+1),
|
|
$intn,intrec,imed,wspca,wsmax,nstr,istr,nir,nmax,nactm)
|
|
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,icore(iabsmem),scspe,lf12.eq.1)
|
|
corr3=0.d0
|
|
corr4=0.d0
|
|
C CC(n-1)(n)_L energy
|
|
if(pert.eq.3) then
|
|
write(iout,*)
|
|
call scal2(op-2,corr1,scrfile1,lfile,nconf,trec,nmax,nactm)
|
|
call scal2(op-1,corr2,scrfile1,lfile,nconf,trec,nmax,nactm)
|
|
elam=ecc+corr1+corr2
|
|
if(op.le.4) then
|
|
call scal2(op-2,corr1,scrfile1,tfile,nconf,trec,nmax,nactm)
|
|
call scal2(op-1,corr2,scrfile1,tfile,nconf,trec,nmax,nactm)
|
|
endif
|
|
endif
|
|
C Energy diagrams
|
|
call szemet(scrfile1,nconf,nmax,nactm,trec,v,0,wspca,wsmax,trec,
|
|
$nconf,trec)
|
|
if(lfvo.or.op.ge.5.or.conver.eq.2) then
|
|
call savevec(tfile,scrfile5,trecmax,0,0)
|
|
call savevec(scrfile1,scrfile4,trecmax,0,0)
|
|
if(lfvo) write(iout,*)
|
|
C Eq. 21 or the last term of Eq. 24
|
|
ii=2
|
|
do i=(op-mod(op,2))/2-2,1,-1
|
|
pertroute=(op-ii-2)+4
|
|
call ddenom(op-ii,scrfile1,tfile,nconf,trec,v,nmax,nactm)
|
|
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,ndiis,ioffs,scspe,lcvs,
|
|
$ncvs,cvsorb,spsht,absind,strec,0)
|
|
ii=ii+2
|
|
enddo
|
|
call scal3(op-ii,corr1,c3,c4,scrfile1,scrfile5,nconf,trec,nmax,
|
|
$nactm,
|
|
$nstr,intrec,imed,v,norm,isympv,isympo,ita,tarec,iwa,isa,isw,istr,
|
|
$test,wspcb,wspca,wsmax,intn,ntcase,earec,econf,erec,denrec,trec2,
|
|
$erec2,tcase,itypa,itypb,imedsyma,imedsymb,l2map,ioffs,scspe,lcvs,
|
|
$ncvs,cvsorb,spsht,absind,strec)
|
|
corr3=corr3+c3
|
|
corr4=corr4+c4
|
|
C
|
|
if(mod(op,2).ne.0) then
|
|
C All terms but the last in Eq. 24
|
|
corr2=0.d0
|
|
do i=1,(op-1)/2-1
|
|
call savevec(scrfile4,scrfile1,trecmax,0,0)
|
|
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 ddenom(op-ii,scrfile1,tfile,nconf,trec,v,nmax,nactm)
|
|
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,ndiis,ioffs,scspe,lcvs,
|
|
$ncvs,cvsorb,spsht,absind,strec,0)
|
|
endif
|
|
ii=ii+1
|
|
else
|
|
if(j.gt.1) then
|
|
pertroute=(op-ii-2)+4
|
|
call ddenom(op-ii,scrfile1,tfile,nconf,trec,v,nmax,nactm)
|
|
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,ndiis,ioffs,scspe,lcvs,
|
|
$ncvs,cvsorb,spsht,absind,strec,0)
|
|
endif
|
|
ii=ii+2
|
|
endif
|
|
enddo
|
|
call scal3(op-ii,sum,c3,c4,scrfile1,scrfile5,nconf,trec,nmax,
|
|
$nactm,
|
|
$nstr,intrec,imed,v,norm,isympv,isympo,ita,tarec,iwa,isa,isw,istr,
|
|
$test,wspcb,wspca,wsmax,intn,ntcase,earec,econf,erec,denrec,trec2,
|
|
$erec2,tcase,itypa,itypb,imedsyma,imedsymb,l2map,ioffs,scspe,lcvs,
|
|
$ncvs,cvsorb,spsht,absind,strec)
|
|
corr2=corr2+sum
|
|
corr3=corr3+c3
|
|
corr4=corr4+c4
|
|
c write(6,*) 'corr2',corr2,ii
|
|
enddo
|
|
if(op.gt.3) then
|
|
corr1=corr1+corr2
|
|
corr2=0.d0
|
|
else
|
|
call scal2(2,corr2,scrfile4,scrfile5,nconf,trec,nmax,nactm)
|
|
c write(6,*) 'scal2a',2
|
|
endif
|
|
else
|
|
corr2=0.d0
|
|
do i=1,op/2-1
|
|
call savevec(scrfile4,scrfile1,trecmax,0,0)
|
|
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 ddenom(op-ii,scrfile1,tfile,nconf,trec,v,nmax,nactm)
|
|
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,ndiis,ioffs,scspe,lcvs,
|
|
$ncvs,cvsorb,spsht,absind,strec,0)
|
|
ii=ii+1
|
|
endif
|
|
else
|
|
if(op-ii.gt.2) then
|
|
pertroute=(op-ii-2)+4
|
|
call ddenom(op-ii,scrfile1,tfile,nconf,trec,v,nmax,nactm)
|
|
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,ndiis,ioffs,scspe,lcvs,
|
|
$ncvs,cvsorb,spsht,absind,strec,0)
|
|
ii=ii+2
|
|
endif
|
|
endif
|
|
enddo
|
|
call scal3(op-ii,sum,c3,c4,scrfile1,scrfile5,nconf,trec,nmax,
|
|
$nactm,
|
|
$nstr,intrec,imed,v,norm,isympv,isympo,ita,tarec,iwa,isa,isw,istr,
|
|
$test,wspcb,wspca,wsmax,intn,ntcase,earec,econf,erec,denrec,trec2,
|
|
$erec2,tcase,itypa,itypb,imedsyma,imedsymb,l2map,ioffs,scspe,lcvs,
|
|
$ncvs,cvsorb,spsht,absind,strec)
|
|
corr2=corr2+sum
|
|
corr3=corr3+c3
|
|
corr4=corr4+c4
|
|
enddo
|
|
endif
|
|
C
|
|
call savevec(scrfile5,tfile,trecmax,0,0)
|
|
close(scrfile5,status='delete')
|
|
endif
|
|
C
|
|
c write(6,"(a4,100f12.8)") 'corr',corr1,corr2,corr3,corr4
|
|
if(pert.ne.3.or.lfvo) then
|
|
if(lfvo) write(iout,*)
|
|
call timer
|
|
write(iout,*)
|
|
endif
|
|
if(op.eq.3) then
|
|
if(locno.eq.0) call prtenerg('CCSD[T]',ecc+corr2,.true.,.true.,
|
|
$.false.,lf12)
|
|
if(pert.ge.2) call prtenerg('CCSD(T)',ecc+corr1+corr2,.true.,
|
|
$.true.,.false.,lf12)
|
|
else if(op.eq.4) then
|
|
if(locno.eq.0)call prtenerg('CCSDT[Q]',ecc+corr1,.true.,.true.,
|
|
$.false.,lf12)
|
|
if(pert.ge.2) then
|
|
if(lfvo.and.ihf.eq.0) then
|
|
if(spatial)
|
|
$call prtenerg('CCSDT(Q)',ecc+corr1+corr2+corr3,.true.,.true.,
|
|
$.false.,lf12)
|
|
else
|
|
call prtenerg('CCSDT(Q)',ecc+corr1+corr2,.true.,.true.,
|
|
$.false.,lf12)
|
|
endif
|
|
if(lfvo)
|
|
$call prtenerg('CCSDT(Q)/A',ecc+corr1+corr2+corr3,.true.,.true.,
|
|
$.false.,lf12)
|
|
if(lfvo)
|
|
$call prtenerg('CCSDT(Q)/B',ecc+corr1+corr2+corr4,.true.,.true.,
|
|
$.false.,lf12)
|
|
endif
|
|
else if(op.eq.5) then
|
|
if(lfvo.and.ihf.eq.0) then
|
|
call prtenerg('CCSDTQ[P]',ecc+corr1+corr3,.true.,.true.,
|
|
$.false.,lf12)
|
|
else
|
|
call prtenerg('CCSDTQ[P]',ecc+corr1,.true.,.true.,.false.,lf12)
|
|
endif
|
|
if(pert.ge.2) then
|
|
if(lfvo.and.ihf.eq.0) then
|
|
if(spatial)
|
|
$call prtenerg('CCSDTQ(P)',ecc+corr1+corr2+corr3,.true.,.true.,
|
|
$.false.,lf12)
|
|
else
|
|
call prtenerg('CCSDTQ(P)',ecc+corr1+corr2,.true.,.true.,
|
|
$.false.,lf12)
|
|
endif
|
|
if(lfvo)
|
|
$call prtenerg('CCSDTQ(P)/A',ecc+corr1+corr2+corr3,.true.,.true.,
|
|
$.false.,lf12)
|
|
if(lfvo)
|
|
$call prtenerg('CCSDTQ(P)/B',ecc+corr1+corr2+corr4,.true.,.true.,
|
|
$.false.,lf12)
|
|
endif
|
|
else
|
|
write(str1,'(i1)') op-1
|
|
write(str2,'(i1)') op
|
|
mmm='CC(' // str1 // ')[' // str2 // ']'
|
|
if(lfvo.and.ihf.eq.0.and.mod(op,2).eq.1) then
|
|
call prtenerg(mmm,ecc+corr1+corr3,.true.,.true.,.false.,lf12)
|
|
else
|
|
call prtenerg(mmm,ecc+corr1,.true.,.true.,.false.,lf12)
|
|
endif
|
|
if(pert.ge.2) then
|
|
if(lfvo.and.ihf.eq.0) then
|
|
mmm='CC(' // str1 // ')(' // str2 // ')'
|
|
if(spatial) call prtenerg(mmm,ecc+corr1+corr2+corr3,.true.,
|
|
$.true.,.false.,lf12)
|
|
else
|
|
mmm='CC(' // str1 // ')(' // str2 // ')'
|
|
call prtenerg(mmm,ecc+corr1+corr2,.true.,.true.,.false.,
|
|
$lf12)
|
|
endif
|
|
if(lfvo) then
|
|
mmm='CC(' // str1 // ')(' // str2 // ')/A'
|
|
call prtenerg(mmm,ecc+corr1+corr2+corr3,.true.,.true.,
|
|
$.false.,lf12)
|
|
endif
|
|
if(lfvo) then
|
|
mmm='CC(' // str1 // ')(' // str2 // ')/B'
|
|
call prtenerg(mmm,ecc+corr1+corr2+corr4,.true.,.true.,
|
|
$.false.,lf12)
|
|
endif
|
|
endif
|
|
endif
|
|
if(pert.eq.3)
|
|
$call prtenerg(method2,elam,.true.,.true.,.false.,lf12)
|
|
C
|
|
pertroute=0
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine scalprf(i,sum,file1,nconf,trec,nmax,nactm,icadd,v,lc,
|
|
$vscr,tarec,ita,nnir,nnewsym,isympv,isympo,nstr)
|
|
************************************************************************
|
|
* Scalar product of two vectors, one of them is read from file *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nactm,i,m,n,k,file1,file2,ii,nn,nnir,ir1,nnewsym,irao
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),ira
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),irav
|
|
integer icadd(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer iactv,iacto,iactva,iactoa,iactvb,iactob,nvirtnewsyma
|
|
integer tarec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer ita(nnir,nnir,nnir,nnir),nvirtnewsym,noccnewsym,inewadd
|
|
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 nstr(nnir,0:nactm,0:nmax,4),nvirtnewsymb,nvirtnewbelen
|
|
integer noccnewsyma,noccnewsymb,noccnewbelen,nn1,nvirtnewallen
|
|
real*8 sum,sum1,v(*),vscr(*)
|
|
logical lc
|
|
C
|
|
sum=0.d0
|
|
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
|
|
ii=nconf(iactva,iactvb,iactoa,iactob,i1,i)
|
|
n= trec(iactva,iactvb,iactoa,iactob,i1,i)-1
|
|
nn=icadd(iactva,iactvb,iactoa,iactob,i1,i)-1
|
|
C
|
|
if(ii.gt.0.and.((.not.lc).or.i1.lt.i-i1.or.(i1.eq.i-i1
|
|
$.and.iactva.lt.iactvb).or.(i1.eq.i-i1.and.iactva.eq.iactvb.and.
|
|
$iactoa.le.iactob))) then
|
|
if(lc.and.i1.eq.i-i1.and.iactva.eq.iactvb.and.
|
|
$iactoa.eq.iactob) then
|
|
C
|
|
call getlst(file1,n+1,vscr,ii)
|
|
read(tafile,rec=tarec(iactva,iactvb,iactoa,iactob,i1,i)) ita
|
|
do ira=1,nir
|
|
nvirtnewsym=csympair(nnewsym,ira,1)
|
|
noccnewsym=csympair(nnewsym,ira,2)
|
|
do irav=1,isympv(0,nvirtnewsym,iactva,iactvb,i1,i-i1,1)
|
|
nvirtnewsyma=isympv(irav,nvirtnewsym,iactva,iactvb,i1,i-i1,1)
|
|
nvirtnewallen=nstr(nvirtnewsyma,iactva,i1,1)
|
|
nvirtnewsymb=isympv(irav,nvirtnewsym,iactva,iactvb,i1,i-i1,2)
|
|
nvirtnewbelen=nstr(nvirtnewsymb,iactvb,i-i1,2)
|
|
nvirtnewlen=nvirtnewallen*nvirtnewbelen
|
|
do irao=1,isympo(0,noccnewsym,iactoa,iactob,i1,i-i1,1)
|
|
noccnewsyma=isympo(irao,noccnewsym,iactoa,iactob,i1,i-i1,1)
|
|
noccnewallen=nstr(noccnewsyma,iactoa,i1,3)
|
|
noccnewsymb=isympo(irao,noccnewsym,iactoa,iactob,i1,i-i1,2)
|
|
noccnewbelen=nstr(noccnewsymb,iactob,i-i1,4)
|
|
noccnewlen=noccnewallen*noccnewbelen
|
|
nn1=nvirtnewlen*noccnewlen
|
|
if(nn1.gt.0.and.(nvirtnewsyma.lt.nvirtnewsymb.or.
|
|
$(nvirtnewsyma.eq.nvirtnewsymb.and.noccnewsyma.le.noccnewsymb)))
|
|
$then
|
|
C
|
|
inewadd=ita(nvirtnewsyma,nvirtnewsymb,noccnewsyma,noccnewsymb)
|
|
call scalprod(v(nn+inewadd),vscr(inewadd),nn1,sum1)
|
|
if(nvirtnewsyma.eq.nvirtnewsymb.and.
|
|
$noccnewsyma.eq.noccnewsymb) then
|
|
sum=sum+sum1
|
|
else
|
|
sum=sum+2.d0*sum1
|
|
endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
else
|
|
sum1=0.d0
|
|
m=ibufln
|
|
do k=1,ii
|
|
if(m.eq.ibufln) then
|
|
m=0
|
|
n=n+1
|
|
read(file1,rec=n) ibuf
|
|
endif
|
|
m=m+1
|
|
sum1=sum1+ibuf(m)*v(nn+k)
|
|
enddo
|
|
if((.not.lc).or.(i1.eq.i-i1.and.iactva.eq.iactvb
|
|
$.and.iactoa.eq.iactob)) then
|
|
sum=sum+sum1
|
|
else
|
|
sum=sum+2.d0*sum1
|
|
endif
|
|
endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
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,absind,scspe,lf12)
|
|
************************************************************************
|
|
* 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 nnr,iuca(nva),iucb(nvb),itad,isp,nem1,nem2,xyzomp
|
|
integer absind(nbasis,-3:0)
|
|
integer mscr2,itc,ioffs,intadd,dbladd,iwa,isa,ndu,ndl
|
|
integer*8 nnam,ii8,fact
|
|
real*8 v(*),faaal,faabe,fiial,fiibe,fct,corr1,corr2,facta,factb
|
|
real*8 sum1,sum2,scspe,tmp,tfact,tscalea(nal),tscaleb(nbe)
|
|
logical log,lcalc,lcalcn,lcalcs,lcalcsn,lhg,lhgn,lhg2,lf12
|
|
C
|
|
open(scrfile5,status='unknown',access='direct',recl=irecln)
|
|
C Initialize variables
|
|
if(lf12) then
|
|
open(scrfile7,file='F12INTE',form='unformatted')
|
|
read(scrfile7) !ecabs,emp2f12,ecoup
|
|
if(cs) then
|
|
read(scrfile7) tfact,tscalea
|
|
tscaleb=tscalea
|
|
else
|
|
read(scrfile7) tfact,tscalea,tscaleb
|
|
endif
|
|
close(scrfile7)
|
|
c write(6,"(100f9.5)") dble(op)
|
|
c tscalea=1.d0
|
|
c tscaleb=1.d0
|
|
c write(6,"(100f9.5)") tscalea
|
|
c write(6,"(100f9.5)") tscaleb
|
|
tscalea=tscalea*1.d0/dble(op)
|
|
tscaleb=tscaleb*1.d0/dble(op)
|
|
c write(6,"(100f9.5)") tscalea
|
|
c write(6,"(100f9.5)") tscaleb
|
|
endif
|
|
corr1=0.d0
|
|
corr2=0.d0
|
|
nnr=nrr-nr4
|
|
nnn=nnr-nr5
|
|
nvirtnew=op
|
|
noccnew=op
|
|
nnewsym=1
|
|
noldsym=1
|
|
nampsym=mult(nnewsym,iconj(noldsym))
|
|
C
|
|
pleft=pert.ne.3.and.leftroute
|
|
c write(6,*) 'lfvo',lfvo
|
|
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(locno.gt.0.and.lhg) then
|
|
write(iout,*)
|
|
$'The local approach is not implemented for the specified method!'
|
|
call mrccend(1)
|
|
endif
|
|
c szemet eleje
|
|
c lcalc=.false.
|
|
c szemet vege
|
|
#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.gt.0) iqf=3
|
|
nem=nem1+nem2
|
|
if(lcalcn) call dfillzero(v(ift),nem)
|
|
if(lhg.and.pert.le.3) call filezero(scrfile1,1,trecmax)
|
|
nnam=0
|
|
isp=0
|
|
C Loop over types of cluster amplitudes
|
|
do nptype=1,ntcase(op)
|
|
nvirtnewact=tcase(1,nptype,op)
|
|
noccnewact= tcase(2,nptype,op)
|
|
C Loop over spin cases of 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,csympair)
|
|
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
|
|
facta=1.d0
|
|
factb=1.d0
|
|
if(nvirtnewal.ne.0) facta=1.d0/dfloat(nvirtnewal)
|
|
if(nvirtnewbe.ne.0) factb=1.d0/dfloat(nvirtnewbe)
|
|
c facta=1.d0/dfloat(fact(nvirtnewal))
|
|
c factb=1.d0/dfloat(fact(nvirtnewbe))
|
|
c if(op.eq.3) then
|
|
c if(nvirtnewal.eq.0) factb=2.d0*factb
|
|
c if(nvirtnewbe.eq.0) facta=2.d0*facta
|
|
c endif
|
|
c if(op.eq.4) then
|
|
c if(nvirtnewal.le.1) factb=2.d0*factb
|
|
c if(nvirtnewbe.le.1) facta=2.d0*facta
|
|
c endif
|
|
call nconfout2(' Number of excitations: ',ii8)
|
|
call flush(iout)
|
|
if(lcalc.and.(nvirtnewal.ne.nvirtnewbe.or.nvirtnewalact.ne.
|
|
$nvirtnewbeact.or.noccnewalact.ne.noccnewbeact)) ii8=2*ii8
|
|
nnam=nnam+ii8
|
|
C
|
|
icad=intadd(ioffs+ift+xyzomp*(nem+iqf*ntnewlen))
|
|
ioal=icad
|
|
do ir=1,nir
|
|
mmm=noccnewal*nstr(ir,noccnewalact,noccnewal,3)
|
|
call getint(strfile,irec(ir,noccnewalact,noccnewal,3),
|
|
$icore(icad),mmm)
|
|
icad=icad+mmm
|
|
enddo
|
|
iobe=icad
|
|
do ir=1,nir
|
|
mmm=noccnewbe*nstr(ir,noccnewbeact,noccnewbe,4)
|
|
call getint(strfile,irec(ir,noccnewbeact,noccnewbe,4),
|
|
$icore(icad),mmm)
|
|
icad=icad+mmm
|
|
enddo
|
|
C
|
|
mfst2=dbladd(icad)-ioffs+2
|
|
mscr2=mfst2
|
|
icad=intadd(mfst2+ioffs)
|
|
call ifillzero(icore(imm),dsmax+1)
|
|
ndu=0
|
|
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,ift,ndu,scspe)
|
|
call putint(scrfile5,1,icore(imm),dsmax+1)
|
|
C
|
|
itc=0
|
|
log=.true.
|
|
do while(log)
|
|
call getint(scrfile5,1,icore(imm),dsmax+1)
|
|
call ifillzero(icore(itad),(op-1)*wsmax+1)
|
|
if(lcalc) call dfillzero(v(ift),nem)
|
|
mscr1=mscr2
|
|
mfst1=mscr1
|
|
ndl=ndu
|
|
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,ndl,scspe)
|
|
C Contraction
|
|
sum2=0.d0
|
|
call coninpp(v,mscr1,nstr(1,nvirtnewalact,nvirtnewal,1),
|
|
$nstr(1,nvirtnewbeact,nvirtnewbe,2),
|
|
$nstr(1,noccnewalact,noccnewal,3),nstr(1,noccnewbeact,noccnewbe,4),
|
|
$nnir,nnewsym,iwan,nampsym,nvirtnewal,nvirtnewbe,noccnewal,
|
|
$noccnewbe,icore(ioal),icore(iobe),nvirtal,nvirtbe,
|
|
$icore(mosymmem+nbasis),nbasis,icd,mfst1,ninter1,mfst2,ninter2,
|
|
$faaal,faabe,fiial,fiibe,ift+xyzomp*nem,ntnewlen,
|
|
$icore(iarc(nvirtnewalact,nvirtnewal,1)),
|
|
$icore(iarc(nvirtnewbeact,nvirtnewbe,2)),nnr,nnn,iuca,iucb,sum2,
|
|
$rank,lcalcsn,lhgn,iqf,ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,
|
|
$nr3,nr4,nr5,xyzsize,v(ift),nem,v(ift+xyzomp*nem),v(mscr1),ndl,
|
|
$iconj,locno,facta,factb,nal,nbe,dcore(umatmem),absind(1,-1),
|
|
$absind(1,0),mpisize,mpicount,lf12,tscalea,tscaleb)
|
|
c write(6,"(a4,f20.12)") 'sum2',sum2
|
|
#if defined (MPI)
|
|
call mpi_allreduce(sum2,tmp,1,MPI_DOUBLE_PRECISION,MPI_SUM,
|
|
& MPI_COMM_WORLD,MPIERR)
|
|
sum2=tmp
|
|
#endif
|
|
if(lhg) then
|
|
if(lcalc) then
|
|
#if defined (MPI)
|
|
call dcommunicate3(v(ift),nem,v(mscr2),v(mscr2+mpibfl))
|
|
#endif
|
|
call wrtfile(op-2,scrfile1,nconf,trec,nmax,nactm,icore(icadd),v,
|
|
$lcalc,lcalcs,v(mscr2),tarec,ita,nnir,nnewsym,isympv,isympo,nstr)
|
|
if(lhg2)
|
|
$call wrtfile(op-1,scrfile1,nconf,trec,nmax,nactm,icore(icadd),v,
|
|
$lcalc,lcalcs,v(mscr2),tarec,ita,nnir,nnewsym,isympv,isympo,nstr)
|
|
endif
|
|
else
|
|
if(lcalc) then
|
|
call scalprf(op-2,sum1,tfile,nconf,trec,nmax,nactm,icore(icadd),
|
|
$v,lcalcs,v(mscr2),tarec,ita,nnir,nnewsym,isympv,isympo,nstr)
|
|
#if defined (MPI)
|
|
call mpi_allreduce(sum1,tmp,1,MPI_DOUBLE_PRECISION,MPI_SUM,
|
|
& MPI_COMM_WORLD,MPIERR)
|
|
sum1=tmp
|
|
#endif
|
|
if(lcalcs) then
|
|
fct=1.d0
|
|
else
|
|
fct=2.d0
|
|
endif
|
|
corr1=corr1+fct*sum1
|
|
corr2=corr2+fct*sum2
|
|
else
|
|
corr2=corr2+sum2
|
|
endif
|
|
endif
|
|
c write(iout,"(' corr1 contribution: ',f18.12)") corr1
|
|
c write(iout,"(' corr2 contribution: ',f18.12)") corr2
|
|
enddo !while
|
|
C
|
|
if(pert.le.3) then
|
|
call timer
|
|
write(iout,"(1x,70('='))")
|
|
call flush(iout)
|
|
endif
|
|
endif !ntnewlen
|
|
enddo !noccnewalact
|
|
enddo !nvirtnewalact
|
|
enddo !nvirtnewal
|
|
enddo !ntcase
|
|
call nconfout1(op,nnam)
|
|
call flush(iout)
|
|
C
|
|
if(lcalcn) then
|
|
if(lhg) then
|
|
#if defined (MPI)
|
|
call dcommunicate3(v(ift),nem,v(ift+nem),v(ift+nem+mpibfl))
|
|
#endif
|
|
call wrtfile(op-2,scrfile1,nconf,trec,nmax,nactm,icore(icadd),v,
|
|
$lcalc,.false.,v(ift+nem),tarec,ita,nnir,nnewsym,isympv,isympo,
|
|
$nstr)
|
|
if(lhg2)
|
|
$call wrtfile(op-1,scrfile1,nconf,trec,nmax,nactm,icore(icadd),v,
|
|
$lcalc,.false.,v(ift+nem),tarec,ita,nnir,nnewsym,isympv,isympo,
|
|
$nstr)
|
|
else
|
|
call scalprf(op-2,corr1,tfile,nconf,trec,nmax,nactm,
|
|
$icore(icadd),v,lcalc,v(ift+nem),tarec,ita,nnir,nnewsym,isympv,
|
|
$isympo,nstr)
|
|
#if defined (MPI)
|
|
call mpi_allreduce(corr1,tmp,1,MPI_DOUBLE_PRECISION,MPI_SUM,
|
|
& MPI_COMM_WORLD,MPIERR)
|
|
corr1=tmp
|
|
#endif
|
|
endif
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine contractp(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,fiial,fiibe,ift,
|
|
$ntnewlen,sumva,nsyma22,nnr,nnn,iuca,iucb,corr,nvirtnewsyma,
|
|
$nvirtnewsymb,lcalcsn,lhgn,iqf,ioffs,icore,mult,nirmax,op,dcore,
|
|
$nrr,nr2,nr3,nr4,nr5,rank,thrd,xyzcount,vift,wnew,vmscr,iconj,
|
|
$locno,facta,factb,nal,nbe,umat,absa,absb,mpicount,mpisize,
|
|
$lf12,tscalea,tscaleb)
|
|
************************************************************************
|
|
* This subroutine evaluates the contractions between cluster amplitudes*
|
|
* and intermediates *
|
|
************************************************************************
|
|
implicit none
|
|
integer nstnva(*),nstnvb(*),nstnoa(*),nstnob(*),nnir,nnewsym,j,k,l
|
|
integer nampsym,nval,nvbe,noal,nobe,iuca(*),iucb(*),iostral,iold
|
|
integer istroa(noal,*),istrob(nobe,*),nva,nvb,mosym,nb,icdo,mfst1
|
|
integer ninter1,nnr,nnn,nsyma22,icd,mmm,i,iostrbe,iscr,mscr,iqf
|
|
integer noccnewsyma,noccnewsymb,noccnewbelen,nvstrbe,nampo,ioffs
|
|
integer iwan(*),istoa,istob,nsyma33,mfst2,ninter2,ift,ntnewlen
|
|
integer nvirtnewsyma,nvirtnewsymb,nampo1,nampo2,nampo3,ns1,intadd
|
|
integer nirmax,icore(*),mult(nirmax,nirmax),noccnewall,op,iconj(*)
|
|
integer nrr,nr2,nr3,nr4,nr5,rank,xyzcount,thrd,mpicount,mpisize
|
|
integer locno,nal,nbe,absa(*),absb(*)
|
|
real*8 v(*),fiial(*),fiibe(*),sumva,sumoa,sumob,corr,dcore(*)
|
|
real*8 vift(*),wnew(*),vmscr(*),facta,factb,umat(*),tscoa,tscob
|
|
real*8 tscalea(nal),tscaleb(nbe)
|
|
logical lcalcsn,log1,log2,lhgn,lf12
|
|
C
|
|
c write(6,"(100f9.5)") tscalea,tscaleb
|
|
#if defined (MPI)
|
|
if(mpicount+thrd.eq.xyzcount) then
|
|
#elif defined (OMP)
|
|
if(thrd.eq.xyzcount) then
|
|
#endif
|
|
log1=nvirtnewsyma.eq.nvirtnewsymb
|
|
log2=lcalcsn.or.nvirtnewsyma.ne.nvirtnewsymb
|
|
call dfillzer1(vift,iqf*ntnewlen)
|
|
C Lower diagrams
|
|
icd=icdo
|
|
c icore(icd+29)=mfst1
|
|
do mmm=1,ninter1
|
|
if(mmm.eq.1) then
|
|
icd=intadd(mfst1+ioffs)
|
|
else
|
|
icd=intadd(icore(icd+29)+ioffs)
|
|
endif
|
|
if(lhgn.and.icore(icd+50).eq.op-1) then
|
|
k=1+ntnewlen
|
|
else
|
|
k=1
|
|
endif
|
|
if(locno.gt.0.and.icore(icd+54).eq.0) k=1+2*ntnewlen
|
|
c write(6,*) 'c1'
|
|
if(icore(icd+52).gt.0) then
|
|
call contractpl(vift(k),vmscr,dcore(icore(icd+28)-1),
|
|
$vmscr(icore(icd+18)+1),
|
|
$icore(icore(icd+32)),icore(icore(icd+1)),icore(icore(icd+2)),
|
|
$icore(icore(icd+3)),icore(icore(icd+4)),icore(icore(icd+5)),
|
|
$icore(icore(icd+6)),icore(icore(icd+7)),icore(icore(icd+8)),
|
|
$icore(icore(icd+9)),icore(icore(icd+10)),icore(icore(icd+11)),
|
|
$icore(icore(icd+12)),icore(icore(icd+13)),icore(icore(icd+14)),
|
|
$icore(icore(icd+15)),icore(icore(icd+16)),icore(icore(icd+19)),
|
|
$icore(icore(icd+20)),icore(icore(icd+23)),icore(icore(icd+24)),
|
|
$icore(icore(icd+25)),icore(icore(icd+26)),nnir,
|
|
$icore(icore(icd+33)),icore(icore(icd+31)),iwan,
|
|
$icore(icore(icd+30)),nampsym,nval,nvbe,iuca,iucb,
|
|
$icore(icore(icd+34)),icore(icore(icd+35)),icore(icd+44),
|
|
$icore(icd+45),icore(icore(icd+36)),icore(icore(icd+37)),
|
|
$icore(icore(icd+38)),icore(icore(icd+39)),icore(icore(icd+40)),
|
|
$icore(icore(icd+41)),icore(icore(icd+42)),icore(icore(icd+43)),
|
|
$nva,nvb,icore(icd+46),icore(icd+47),icore(icd+48),icore(icd+49),
|
|
$mosym,nb,nnr,nnn,nsyma22,log2,icore(icd+51),icore(icd+52),
|
|
$icore(icd+53),icore(icd+17),icore(icd+18),v(icore(icd+27)),
|
|
$ioffs+icore(icd+27),icore,mult,nirmax,nrr,nr2,nr3,nr4,dcore,nr5,
|
|
$iconj)
|
|
else
|
|
call contractpl(vift(k),v(icore(icd+27)),dcore(icore(icd+28)-1),
|
|
$vmscr,
|
|
$icore(icore(icd+32)),icore(icore(icd+1)),icore(icore(icd+2)),
|
|
$icore(icore(icd+3)),icore(icore(icd+4)),icore(icore(icd+5)),
|
|
$icore(icore(icd+6)),icore(icore(icd+7)),icore(icore(icd+8)),
|
|
$icore(icore(icd+9)),icore(icore(icd+10)),icore(icore(icd+11)),
|
|
$icore(icore(icd+12)),icore(icore(icd+13)),icore(icore(icd+14)),
|
|
$icore(icore(icd+15)),icore(icore(icd+16)),icore(icore(icd+19)),
|
|
$icore(icore(icd+20)),icore(icore(icd+23)),icore(icore(icd+24)),
|
|
$icore(icore(icd+25)),icore(icore(icd+26)),nnir,
|
|
$icore(icore(icd+33)),icore(icore(icd+31)),iwan,
|
|
$icore(icore(icd+30)),nampsym,nval,nvbe,iuca,iucb,
|
|
$icore(icore(icd+34)),icore(icore(icd+35)),icore(icd+44),
|
|
$icore(icd+45),icore(icore(icd+36)),icore(icore(icd+37)),
|
|
$icore(icore(icd+38)),icore(icore(icd+39)),icore(icore(icd+40)),
|
|
$icore(icore(icd+41)),icore(icore(icd+42)),icore(icore(icd+43)),
|
|
$nva,nvb,icore(icd+46),icore(icd+47),icore(icd+48),icore(icd+49),
|
|
$mosym,nb,nnr,nnn,nsyma22,log2,icore(icd+51),icore(icd+52),
|
|
$icore(icd+53),icore(icd+17),icore(icd+18),v(icore(icd+27)),
|
|
$ioffs+icore(icd+27),icore,mult,nirmax,nrr,nr2,nr3,nr4,dcore,nr5,
|
|
$iconj)
|
|
endif
|
|
enddo
|
|
c write(6,*) 'c2'
|
|
if(lhgn) call add3(vift,vift(1+ntnewlen),ntnewlen)
|
|
if(locno.gt.0) call add3(vift(1+ntnewlen),vift(1+2*ntnewlen),
|
|
$ntnewlen)
|
|
C Denominators
|
|
istob=0
|
|
do noccnewsymb=1,nnir
|
|
noccnewbelen=nstnob(noccnewsymb)
|
|
nampo=(noccnewsymb-1)*nnir
|
|
nampo1=1-noccnewbelen
|
|
ns1=noccnewsymb-nnir
|
|
nsyma33=mult(nsyma22,noccnewsymb)
|
|
do iostrbe=0,noccnewbelen-1
|
|
nampo2=nampo1+iostrbe
|
|
istob=istob+1
|
|
sumob=sumva
|
|
do i=1,nobe
|
|
sumob=sumob+fiibe(istrob(i,istob))
|
|
enddo
|
|
if(lf12) then
|
|
tscob=0.d0
|
|
do i=1,nobe
|
|
tscob=tscob+tscaleb(istrob(i,istob))
|
|
enddo
|
|
endif
|
|
istoa=0
|
|
do noccnewsyma=1,nnir
|
|
noccnewall=nstnoa(noccnewsyma)
|
|
if(noccnewsyma.ne.nsyma33) then
|
|
istoa=istoa+noccnewall
|
|
else
|
|
nvstrbe=iostrbe*noccnewall+iwan(nampo+noccnewsyma)
|
|
if(log2.or.noccnewsyma.eq.noccnewsymb) then
|
|
do iostral=1,noccnewall
|
|
istoa=istoa+1
|
|
sumoa=sumob
|
|
do i=1,noal
|
|
sumoa=sumoa+fiial(istroa(i,istoa))
|
|
enddo
|
|
if(lf12) then
|
|
tscoa=tscob
|
|
do i=1,noal
|
|
tscoa=tscoa+tscalea(istroa(i,istoa))
|
|
enddo
|
|
sumoa=sumoa/tscoa
|
|
endif
|
|
i=nvstrbe+iostral
|
|
vift(i)=vift(i)/sumoa
|
|
enddo
|
|
elseif(log1.and.noccnewsyma.lt.noccnewsymb)then
|
|
nampo3=nampo2+iwan(noccnewsyma*nnir+ns1)
|
|
do iostral=1,noccnewall
|
|
istoa=istoa+1
|
|
sumoa=sumob
|
|
do i=1,noal
|
|
sumoa=sumoa+fiial(istroa(i,istoa))
|
|
enddo
|
|
if(lf12) then
|
|
tscoa=tscob
|
|
do i=1,noal
|
|
tscoa=tscoa+tscalea(istroa(i,istoa))
|
|
enddo
|
|
sumoa=sumoa/tscoa
|
|
endif
|
|
i=nvstrbe+iostral
|
|
j=nampo3+iostral*noccnewbelen
|
|
if(lhgn) vift(j+ntnewlen)=vift(i+ntnewlen)
|
|
vift(i)=vift(i)/sumoa
|
|
vift(j)=vift(i)
|
|
enddo
|
|
endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C Localized methods (No symmetry!)
|
|
if(locno.gt.0) then
|
|
c if(.true.) then !szemet
|
|
noccnewbelen=nstnob(1)
|
|
noccnewall= nstnoa(1)
|
|
if(nobe.eq.0) then
|
|
ns1=noal-1
|
|
call dfillzer1(vmscr(1),2*nal**ns1)
|
|
do iostral=1,noccnewall
|
|
sumoa=vift(iostral)
|
|
sumob=vift(ntnewlen+iostral)
|
|
do i=1,noal
|
|
k=0
|
|
l=1
|
|
do j=1,noal
|
|
if(j.ne.i) then
|
|
k=k+1
|
|
l=l+(istroa(j,iostral)-1)*nal**(ns1-k)
|
|
endif
|
|
enddo
|
|
vmscr(l)=vmscr(l)+
|
|
$(-1.d0)**(i-1)*umat(absa(istroa(i,iostral)))*sumoa
|
|
vmscr(nal**ns1+l)=vmscr(nal**ns1+l)+
|
|
$(-1.d0)**(i-1)*umat(absa(istroa(i,iostral)))*sumob
|
|
enddo
|
|
enddo
|
|
sumob=0.d0
|
|
call scalprod2(vmscr(1),vmscr(nal**ns1+1),nal**ns1,sumob)
|
|
corr=corr+facta*sumob
|
|
else
|
|
istoa=0
|
|
ns1=nobe-1
|
|
call dfillzer1(vmscr(1),2*nbe**ns1*noccnewall)
|
|
do iostrbe=1,noccnewbelen
|
|
do iostral=1,noccnewall
|
|
istoa=istoa+1
|
|
sumoa=vift(istoa)
|
|
sumob=vift(ntnewlen+istoa)
|
|
do i=1,nobe
|
|
k=0
|
|
l=(iostral-1)*nbe**ns1+1
|
|
do j=1,nobe
|
|
if(j.ne.i) then
|
|
k=k+1
|
|
l=l+(istrob(j,iostrbe)-1)*nbe**(ns1-k)
|
|
endif
|
|
enddo
|
|
vmscr(l)=vmscr(l)+
|
|
$(-1.d0)**(i-1)*umat(absb(istrob(i,iostrbe)))*sumoa
|
|
vmscr(nbe**ns1*noccnewall+l)=vmscr(nbe**ns1*noccnewall+l)+
|
|
$(-1.d0)**(i-1)*umat(absb(istrob(i,iostrbe)))*sumob
|
|
enddo
|
|
enddo
|
|
enddo
|
|
sumob=0.d0
|
|
call scalprod2(vmscr(1),vmscr(nbe**ns1*noccnewall+1),
|
|
$ nbe**ns1*noccnewall,sumob)
|
|
corr=corr+factb*sumob
|
|
endif
|
|
else
|
|
if(lhgn) call scalprod2(vift,vift(1+ntnewlen),ntnewlen,corr)
|
|
C Upper diagrams
|
|
icd=icdo
|
|
c icore(icd+29)=mfst2
|
|
do mmm=1,ninter2
|
|
c write(6,*) 'c3',mmm
|
|
if(mmm.eq.1) then
|
|
icd=intadd(mfst2+ioffs)
|
|
else
|
|
icd=intadd(icore(icd+29)+ioffs)
|
|
endif
|
|
call contractpu(wnew(icore(icd+21)),v(icore(icd+27)),vift,vmscr,
|
|
$icore(icore(icd+32)),icore(icore(icd+1)),icore(icore(icd+2)),
|
|
$icore(icore(icd+3)),icore(icore(icd+4)),icore(icore(icd+5)),
|
|
$icore(icore(icd+6)),icore(icore(icd+7)),icore(icore(icd+8)),
|
|
$icore(icore(icd+9)),icore(icore(icd+11)),nstnva,nstnvb,nstnoa,
|
|
$icore(icore(icd+15)),icore(icore(icd+16)),icore(icore(icd+17)),
|
|
$icore(icore(icd+18)),icore(icore(icd+19)),icore(icore(icd+20)),
|
|
$icore(icore(icd+23)),icore(icore(icd+24)),icore(icore(icd+25)),
|
|
$icore(icore(icd+26)),nnir,iwan,icore(icore(icd+31)),
|
|
$icore(icore(icd+33)),icore(icore(icd+30)),nampsym,nval,nvbe,
|
|
$iuca,iucb,icore(icore(icd+34)),icore(icore(icd+35)),
|
|
$icore(icd+44),icore(icd+45),icore(icore(icd+36)),
|
|
$icore(icore(icd+37)),icore(icore(icd+38)),icore(icore(icd+39)),
|
|
$icore(icore(icd+40)),icore(icore(icd+41)),icore(icore(icd+42)),
|
|
$icore(icore(icd+43)),nva,nvb,icore(icd+46),icore(icd+47),
|
|
$icore(icd+48),icore(icd+49),mosym,nb,nnr,nsyma22,
|
|
$icore(icore(icd+12)),icore(icore(icd+13)),nnewsym,
|
|
$icore(icd+28).eq.1,icore(icore(icd+50)),icore(icore(icd+51)),nnn,
|
|
$nr2,nr3,nr4,nr5,nrr,mult,nirmax,icore,iconj)
|
|
c write(6,*) 'c4',mmm
|
|
enddo
|
|
endif
|
|
#if defined (MPI) || defined (OMP)
|
|
endif
|
|
if(xyzcount.eq.mpisize) then
|
|
xyzcount=0
|
|
else
|
|
xyzcount=xyzcount+1
|
|
endif
|
|
#endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine stranal(icom,str,n1,n2,is,isym1,isym2,mosym,iarc1,
|
|
$iarc2,nv,itr1,itr2,istr1,istr2,str1,mult,nirmax)
|
|
************************************************************************
|
|
* Analyze strings *
|
|
************************************************************************
|
|
implicit none
|
|
integer*1 is
|
|
integer n1,n2,icom(0:n1+n2),str(*),str1(n1),str2(n2),isym1
|
|
integer i,ii,mosym(*),iarc1,iarc2,nv,itr1,itr2,istr1,istr2,isym2
|
|
integer mult,nirmax
|
|
C
|
|
is=icom(0)
|
|
ii=0
|
|
do i=1,n1+n2
|
|
if(icom(i).eq.1) then
|
|
ii=ii+1
|
|
str1(ii)=str(i)
|
|
endif
|
|
enddo
|
|
c write(6,*) 'stranal1'
|
|
call stranal1(str1,n1,mosym,iarc1,nv,itr1,isym1,istr1,mult,nirmax)
|
|
ii=0
|
|
do i=1,n1+n2
|
|
if(icom(i).eq.0) then
|
|
ii=ii+1
|
|
str2(ii)=str(i)
|
|
endif
|
|
enddo
|
|
c write(6,*) 'stranal2'
|
|
call stranal1(str2,n2,mosym,iarc2,nv,itr2,isym2,istr2,mult,nirmax)
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine stranal1(str,n,mosym,iarc,nv,itr,ism,istr,mult,nirmax)
|
|
************************************************************************
|
|
* Analyze strings *
|
|
************************************************************************
|
|
implicit none
|
|
integer str(*),n,nv,mosym(*),iarc(0:nv,0:n),itr(*),ism,istr,i
|
|
integer nirmax,mult(nirmax,nirmax)
|
|
C
|
|
c write(6,*) 'str',(str(i),i=1,n)
|
|
istr=1
|
|
ism=1
|
|
do i=1,n
|
|
c write(6,*) 'iarc1',iarc(6,2)
|
|
istr=istr+iarc(str(i)-1,i)
|
|
ism=mult(ism,mosym(str(i)))
|
|
c write(6,*) 'ism',str(i),mosym(str(i))
|
|
c write(6,*) 'stranal1',str(i),iarc(str(i)-1,i)
|
|
enddo
|
|
c write(6,*) 'stranal2',istr,itr(istr)
|
|
istr=itr(istr)
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine contractpl(wnew,wold,t,v,isa,nsttva,nsttvb,nsttoa,
|
|
$nsttob,icsva,icsvb,icsoa,icsob,nstsva,nstsvb,nstsoa,nstava,nstavb,
|
|
$nstaoa,isymp1,isymp2,icnoa,icnob,nstnoa,nstova,nstovb,nstooa,nnir,
|
|
$ita,iwa,iwan,incsum,nampsym,nval,nvbe,istral,istrbe,icoma,icomb,
|
|
$ncoma,ncomb,itolda,itampa,itoldb,itampb,idolda,idampa,idoldb,
|
|
$idampb,nva,nvb,noal,ntal,nobe,ntbe,mosym,nb,nnr,nnn,nsyma22,log,
|
|
$mfst3,ninter3,icdo,nnewsym,ntoldlen,ww,ioffs,icore,mult,nirmax,
|
|
$nrr,nr2,nr3,nr4,dcore,nr5,iconj)
|
|
************************************************************************
|
|
* This subroutine evaluates the contractions between cluster amplitudes*
|
|
* and intermediates *
|
|
************************************************************************
|
|
implicit none
|
|
integer*1 isgnval,isgnvbe,isgnoal,isgnobe,isgnvb1
|
|
integer ivstral,ivstrbe,iostral,iostrbe,ivstr,iostr,iivobe,n3,nnn
|
|
integer iosbe,iosal,ivsbe,ivsal,ivoal,ivobe,iooal,ioobe,iioobe,nb
|
|
integer nvoal,nvobe,nooal,noobe,ivsalad,ifvsal,ivsbead,ifvsbe,n44
|
|
integer ivo,ioo,iosalad,nnir,no2,no3,nvoa,nvna,iosbead,mfst3,icdo
|
|
integer nv,no,n1,n2,ivaal,ivabe,ioaal,ioabe,nsymw,ncoma,ninter3,i
|
|
integer nvsal,nvsbe,nosal,nosbe,isc,nvaa,nvab,noaa,noab,nsumoa
|
|
integer coupsval,coupsvbe,coupsoal,coupsobe,nin,nvn,non,nampoa
|
|
integer coupwval,coupwoal,coupwvbe,coupwobe,nn2,nn3,nampob,ii1,ii2
|
|
integer icsva(nnir,nnir),icsvb(nnir,nnir),icsoa(nnir,nnir),nsumob
|
|
integer icnob(nnir,nnir),nsumvb,nsumss,incsum(nnir),navo,naoa
|
|
integer nsttva(nnir),nsttvb(nnir),nsttoa(nnir),nsttob(nnir),noabe
|
|
integer nstsva(nnir),nstsvb(nnir),nstsoa(nnir),nval,nvbe,noaal
|
|
integer nstava(nnir),nstavb(nnir),nstaoa(nnir),istral(*),j,nnewsym
|
|
integer nstnoa(nnir),istrbe(*),icsob(nnir,nnir),ita(*),nvabe,ioffs
|
|
integer nstova(nnir),nstovb(nnir),nstooa(nnir),icoma(0:nval,*)
|
|
integer isa(*),isymp1(0:nnir,nnir),isymp2(0:nnir,nnir),ncomb,ii3
|
|
integer nsumsym,nampsym,nsyma1,nsyma2,nsyma3,irs,icma,icmb,ii4
|
|
integer nosalad,nostr,nnr,nsyma22,nivo1,nivo2,nosbeo,ir3,ir4,nr5
|
|
integer nsumsymva,nsumsymvb,nsumoccallen,nampoccallen,ntoldlen
|
|
integer nampsymva,nampsymvb,ntampsymva,ntampsymvb,nsumsymoa,nsuml
|
|
integer nampsymoa,ntampsymoa,ntampsymob,nsumsymob,nvstrbe,iconj(*)
|
|
integer nvirtoldsyma,nvirtoldsymb,noccoldsymb,icomb(0:nvbe,*)
|
|
integer nvirtoldbelen,noccnewsyma,noccnewsymb,noccoldsyma
|
|
integer iwan(*),iwa(*),nsymt1,nsymt2,noal,ntal,nobe,ntbe
|
|
integer itolda(*),itampa(*),itoldb(*),itampb(*),nva,nvb
|
|
integer idolda(nva,noal),idampa(nva,ntal),idoldb(nvb,nobe)
|
|
integer icnoa(nnir,nnir),nsvo,idampb(nvb,ntbe),mosym(nb,4)
|
|
integer ista(noal),istb(nobe),nsums1,nvirtoldalle1,noccoldall
|
|
integer nirmax,icore(*),mult(nirmax,nirmax),nrr,nr2,nr3,nr4
|
|
real*8 wnew(*),wold(*),t(*),v(*),ww,dcore(*)
|
|
logical log
|
|
c write(6,*) 'contractpl'
|
|
C
|
|
do icmb=1,ncomb
|
|
c write(6,*) 'icmb',icmb,nobe,ntbe
|
|
call stranal(icomb(0,icmb),istrbe,nobe,ntbe,isgnvb1,
|
|
$nvirtoldsymb,ntampsymvb,mosym(1,2),idoldb,idampb,nvb,itoldb,
|
|
$itampb,iivobe,ivabe,istb,mult,nirmax)
|
|
iivobe=iivobe-1
|
|
nvabe=nsttvb(ntampsymvb)
|
|
nvirtoldbelen=nstovb(nvirtoldsymb)
|
|
nsumvb=nnr+nvirtoldsymb*nr2
|
|
nvab=nvabe+ivabe
|
|
do icma=1,ncoma
|
|
c write(6,*) 'icma',icma,noal,ntal
|
|
call stranal(icoma(0,icma),istral,noal,ntal,isgnval,
|
|
$nvirtoldsyma,ntampsymva,mosym(1,1),idolda,idampa,nva,itolda,
|
|
$itampa,ivo,ivaal,ista,mult,nirmax)
|
|
isgnval=isgnvb1*isgnval
|
|
ivo=ivo-1
|
|
nsymt1=mult(ntampsymva,ntampsymvb)
|
|
nvaa=nsttva(ntampsymva)+ivaal
|
|
nvirtoldalle1=nstova(nvirtoldsyma)
|
|
nsums1=nsumvb+nvirtoldsyma*nnir
|
|
c write(6,*) 'nvirtoldsyma',nvirtoldsyma,ntampsymva,nsyma22,
|
|
c $mult(nvirtoldsyma,ntampsymva)
|
|
C Construct intermediates with many virtual indices
|
|
if(ninter3.gt.0) then
|
|
nsums1=-nr2-nnir
|
|
ir3=nnir
|
|
ir4=nr2
|
|
ivo=0
|
|
iivobe=0
|
|
nvirtoldalle1=1
|
|
nvirtoldbelen=1
|
|
call contractpx(ww,v,nnewsym,iwa,noal,nobe,nva,nvb,mosym,nb,nnn,
|
|
$mfst3,ninter3,icdo,ista,istb,nvirtoldsyma,nvirtoldsymb,nsums1,
|
|
$ntoldlen,wold,ioffs,icore,mult,nirmax,nrr,nr2,nr3,nr4,nnir,dcore,
|
|
$nr5,iconj)
|
|
else
|
|
ir3=nr3
|
|
ir4=nr4
|
|
endif
|
|
C Loops over occupied fixed strings of cluster amplitudes
|
|
do ntampsymob=1,nnir
|
|
nsymt2=mult(ntampsymob,nsymt1)
|
|
noabe=nsttob(ntampsymob)
|
|
do ioabe=1,noabe
|
|
noab=noabe+ioabe
|
|
do nsumsym=1,nnir
|
|
nsuml=incsum(nsumsym)
|
|
if(nsuml.gt.0) then
|
|
nsumss=nsumsym+nsums1
|
|
ntampsymoa=mult(mult(nsumsym,nsymt2),nampsym)
|
|
no3=nvirtoldalle1*nsuml
|
|
no2=nvirtoldbelen*no3
|
|
nivo1=ivo*nsuml+iivobe*no3
|
|
noaal=nsttoa(ntampsymoa)
|
|
do ioaal=1,noaal
|
|
noaa=noaal+ioaal
|
|
C Unpack cluster amplitudes
|
|
call dfillzer1(v,nsuml)
|
|
do nsumsymob=1,nnir
|
|
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,nnir
|
|
nampsymoa=mult(nsumsymoa,ntampsymoa)
|
|
nsyma2=mult(nsumsymoa,nsyma1)
|
|
nsumoccallen=nstsoa(nsumsymoa)
|
|
nampoccallen=nstaoa(nampsymoa)
|
|
navo=nampoccallen*iostrbe
|
|
nsvo=nsumoccallen*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)
|
|
nn3=nstava(nampsymva)
|
|
coupsval=icsva(nsumsymva,ntampsymva)-1
|
|
coupsvbe=icsvb(nsumsymvb,ntampsymvb)-1
|
|
nosalad=isa(nsumoa+nsumsymvb*nnir+nsumsymva)+
|
|
$n3*(nstsvb(nsumsymvb)*iosalad-1)
|
|
nostr=ita(nampoa+nampsymvb*nnir+nampsymva)+
|
|
$nn3*(nstavb(nampsymvb)*iostr-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)
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
v(ivsalad)=
|
|
$isgnvbe*isign(1,ivstral)*t(ivstrbe+iabs(ivstral))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C Loops over occupied strings of old intermediates
|
|
do noccoldsymb=1,nnir
|
|
noccnewsymb=mult(noccoldsymb,ntampsymob)
|
|
noccnewsyma=mult(noccnewsymb,nsyma22)
|
|
if(log.or.noccnewsyma.le.noccnewsymb) then
|
|
noccoldsyma=mult(noccnewsyma,iconj(ntampsymoa))
|
|
coupwobe=icnob(noccoldsymb,ntampsymob)-1
|
|
noccoldall=nstooa(noccoldsyma)
|
|
n44=nstnoa(noccnewsyma)
|
|
coupwoal=icnoa(noccoldsyma,ntampsymoa)-1
|
|
nampoa=iwan((noccnewsymb-1)*nnir+noccnewsyma)-n44
|
|
nsumoa=nivo1+iwa(nsumss+noccoldsymb*ir4+noccoldsyma*ir3)
|
|
c write(6,*) 'm1',nivo1,iwa(nsumss+noccoldsymb*ir4+noccoldsyma*ir3),
|
|
c $nsumss+noccoldsymb*ir4+noccoldsyma*ir3
|
|
c write(6,*) 'm2',nsumsym,nvirtoldsyma,noccoldsyma
|
|
c write(6,*)'m3',mult(mult(nsumsym,iconj(nvirtoldsyma)),noccoldsyma)
|
|
c write(6,*)'nsyma22,noccnewsyma',nsyma22,noccnewsyma
|
|
c write(6,*)'nsumsym',nsumsym,ntampsymva,ntampsymoa
|
|
c write(6,*)'nampsym',mult(mult(iconj(nsumsym),iconj(ntampsymva)),
|
|
c $ntampsymoa)
|
|
ii3=coupwobe+icore(coupwobe+ioabe)
|
|
do ioobe=1,icore(coupwobe+noab)
|
|
ii3=ii3+1
|
|
iioobe=icore(ii3)-1
|
|
ii3=ii3+1
|
|
iostrbe=icore(ii3)
|
|
isgnobe=isgnval*isign(1,iostrbe)
|
|
nivo2=nsumoa+iioobe*noccoldall*no2
|
|
nvstrbe=nampoa+iabs(iostrbe)*n44
|
|
ii4=coupwoal+icore(coupwoal+ioaal)
|
|
do iooal=1,icore(coupwoal+noaa)
|
|
ii4=ii4+1
|
|
ioo=icore(ii4)-1
|
|
ii4=ii4+1
|
|
iostral=icore(ii4)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
call matmul5(wnew(nvstrbe+iabs(iostral)),
|
|
$wold(nivo2+ioo*no2),v,nsuml,isgnoal)
|
|
enddo
|
|
enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine contractpu(wnew,wold,t,v,isa,nsttva,nsttvb,nsttoa,
|
|
$nsttob,icsva,icsvb,icsoa,icsob,nstsva,nstsoa,nstava,nstavb,
|
|
$nstaoa,isymp1,isymp2,icnva,icnvb,icnoa,icnob,nstnoa,nstova,nstovb,
|
|
$nstooa,nnir,ita,iwa,iwan,incsum,nampsym,nval,nvbe,istral,istrbe,
|
|
$icoma,icomb,ncoma,ncomb,itolda,itampa,itoldb,itampb,idolda,idampa,
|
|
$idoldb,idampb,nva,nvb,noal,ntal,nobe,ntbe,mosym,nb,nnr,nsyma22,
|
|
$nstnva,nstnvb,nnewsym,lcalcsn,incnew,iwn,nnn,nr2,nr3,nr4,nr5,nrr,
|
|
$mult,nirmax,icore,iconj)
|
|
************************************************************************
|
|
* This subroutine evaluates the contractions between cluster amplitudes*
|
|
* and intermediates *
|
|
************************************************************************
|
|
implicit none
|
|
integer*1 isgnval,isgnvbe,isgnoal,isgnobe,isgnvb1,isgnva1
|
|
integer ivstral,ivstrbe,iostral,iostrbe,ivstr,iostr,iivobe,n3,nss
|
|
integer iosbe,iosal,ivsbe,ivsal,ivoal,ivobe,iooal,ioobe,iioobe,nb
|
|
integer nvoal,nvobe,nooal,noobe,ivsalad,ifvsal,ivsbead,ifvsbe,n44
|
|
integer ivo,ioo,iosalad,nnir,no2,no3,nvoa,nvna,iosbead,nampsymob
|
|
integer nv,no,n1,n2,ivaal,ivabe,ioaal,ioabe,nsymw,ncoma,iwn(*)
|
|
integer nvsal,nvsbe,nosal,nosbe,isc,nvaa,nvab,noaa,noab,nsumoa
|
|
integer coupsoal,coupsobe,nin,nvn,non,nampoa,incnew(*),nnn,ii3,ii4
|
|
integer coupwval,coupwoal,coupwvbe,coupwobe,nn2,nn3,nampob,ii1,ii2
|
|
integer icsva(nnir,nnir),icsvb(nnir,nnir),icsoa(nnir,nnir),nsumob
|
|
integer icnob(nnir,nnir),nsumvb,nsumss,incsum(nnir),navo,naoa
|
|
integer icnva(nnir,nnir),icnvb(nnir,nnir),icnoa(nnir,nnir),nsvo
|
|
integer nsttva(*),nsttvb(*),nsttoa(*),nsttob(*),noabe,nstaoa(*)
|
|
integer nstsva(*),nstsoa(*),nval,nvbe,noaal,nstava(*),nstavb(*)
|
|
integer nstnoa(*),istrbe,icsob(nnir,nnir),ita(*),nvabe,istral
|
|
integer nstova(*),nstovb(*),nstooa(*),icoma(0:nval,*),nsumsym
|
|
integer isa(*),isymp1(0:nnir,nnir),isymp2(0:nnir,nnir),ncomb,icma
|
|
integer nosalad,nostr,nnr,nsyma22,nivo1,nivo2,nosbeo,nampsym,irs
|
|
integer nsumsymva,nsumsymvb,nsumoccallen,nampoccallen,nav1,nsyma3
|
|
integer nampsymvb,ntampsymva,ntampsymvb,nsumsymoa,nsv1,nsyma1
|
|
integer nampsymoa,ntampsymoa,ntampsymob,nsumsymob,nvstrbe,nsyma2
|
|
integer nvirtoldsyma,nvirtoldsymb,noccoldsymb,icomb(0:nvbe,*),ns2
|
|
integer nvirtoldbelen,noccnewsyma,noccnewsymb,noccoldsyma,iconj(*)
|
|
integer iwan(*),iwa(*),nsymt1,nsymt2,noal,ntal,nobe,ntbe,nsma1
|
|
integer itolda(*),itampa(*),itoldb(*),itampb(*),nva,nvb,na2,icmb
|
|
integer idolda(nva,noal),idampa(nva,ntal),idoldb(nvb,nobe),nsvb
|
|
integer idampb(nvb,ntbe),mosym(nb,4),nvirtnewsyma,incn,ns1,ns3,ns4
|
|
integer ifosal,nvaal,nnewsym,nvirtnewsymb,ns5,i,nsuml,noccoldall
|
|
integer nstnva(*),nstnvb(*),nampvb,nivobe,ista(noal),istb(nobe)
|
|
integer noccnewall,nr2,nr3,nr4,nr5,nrr,nirmax,mult(nirmax,nirmax)
|
|
integer icore(*)
|
|
real*8 wnew(*),wold(*),t(*),v(*)
|
|
logical lcalcsn,log
|
|
C
|
|
c write(6,*) 'contractpu'
|
|
c write(6,*) 'lociwa',loc(iwa)
|
|
do icmb=1,ncomb
|
|
c write(6,*) 'icmb',icmb,nobe,ntbe
|
|
call stranal(icomb(0,icmb),istrbe,nobe,ntbe,isgnvb1,nsumsymvb,
|
|
$ntampsymvb,mosym(1,2),idoldb,idampb,nvb,itoldb,itampb,ivsbead,
|
|
$ivabe,istb,mult,nirmax)
|
|
ivsbead=ivsbead-1
|
|
nvabe=nsttvb(ntampsymvb)
|
|
nvab=nvabe+ivabe
|
|
ns1=(nsumsymvb-1)*nnir
|
|
do icma=1,ncoma
|
|
c write(6,*) 'icma',icma,noal,ntal
|
|
call stranal(icoma(0,icma),istral,noal,ntal,isgnva1,nsumsymva,
|
|
$ntampsymva,mosym(1,1),idolda,idampa,nva,itolda,itampa,ivsalad,
|
|
$ivaal,ista,mult,nirmax)
|
|
isgnva1=isgnvb1*isgnva1
|
|
nsymt1=mult(ntampsymva,ntampsymvb)
|
|
nvaal=nsttva(ntampsymva)
|
|
nvaa=nvaal+ivaal
|
|
nsma1=mult(nsumsymva,nsumsymvb)
|
|
ns5=nsma1*nnir+nnn
|
|
incn=incnew(nsma1)
|
|
ns3=iwn(ns1+nsumsymva)+ivsbead*nstsva(nsumsymva)+ivsalad-1
|
|
C
|
|
do ntampsymob=1,nnir
|
|
nsymt2=mult(mult(ntampsymob,nsymt1),nsma1)
|
|
noabe=nsttob(ntampsymob)
|
|
do ioabe=1,noabe
|
|
noab=noabe+ioabe
|
|
do nsumsym=1,nnir
|
|
nsuml=incsum(nsumsym)
|
|
if(nsuml.gt.0) then
|
|
ns4=nsumsym+ns5
|
|
nsumss=incn*nsuml
|
|
nss=ns3*nsuml-nsumss
|
|
ntampsymoa=mult(mult(nsumsym,nsymt2),nampsym)
|
|
c ntampsymoa=mult(mult(iconj(nsumsym),nsymt2),nampsym)
|
|
c write(6,*) 'ntampsymva,ntampsymoa',ntampsymva,ntampsymoa
|
|
noaal=nsttoa(ntampsymoa)
|
|
do ioaal=1,noaal
|
|
noaa=noaal+ioaal
|
|
c write(6,*) 'u1'
|
|
C Unpack cluster amplitudes
|
|
call dfillzer1(v,nsuml)
|
|
do irs=1,isymp1(0,iconj(nsumsym))
|
|
nsumsymoa=isymp1(irs,iconj(nsumsym))
|
|
nsumsymob=isymp2(irs,iconj(nsumsym))
|
|
nampsymoa=mult(nsumsymoa,ntampsymoa)
|
|
nampsymob=mult(nsumsymob,ntampsymob)
|
|
na2=nstaoa(nampsymoa)
|
|
ns2=nstsoa(nsumsymoa)
|
|
coupsoal=icsoa(nsumsymoa,ntampsymoa)-1
|
|
coupsobe=icsob(nsumsymob,ntampsymob)-1
|
|
nosalad=isa((nsumsymob-1)*nnir+nsumsymoa)-ns2
|
|
nostr=ita((nampsymob-1)*nnir+nampsymoa)-na2
|
|
ifosal=coupsoal+icore(coupsoal+ioaal)
|
|
nosal=icore(coupsoal+noaa)
|
|
ii3=coupsobe+icore(coupsobe+ioabe)
|
|
do iosbe=1,icore(coupsobe+noab)
|
|
ii3=ii3+1
|
|
iosbead=nosalad+ns2*icore(ii3)
|
|
ii3=ii3+1
|
|
iostrbe=icore(ii3)
|
|
isgnobe=isgnva1*isign(1,iostrbe)
|
|
iostrbe=nostr+na2*iabs(iostrbe)
|
|
ii4=ifosal
|
|
do iosal=1,nosal
|
|
ii4=ii4+1
|
|
iosalad=iosbead+icore(ii4)
|
|
ii4=ii4+1
|
|
iostral=icore(ii4)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
v(iosalad)=isgnoal*t(iostrbe+iabs(iostral))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c write(6,*) 'u2'
|
|
C Loop over symmetry cases of new (old) intermediates
|
|
do noccoldsymb=1,nnir
|
|
noccnewsymb=mult(noccoldsymb,ntampsymob)
|
|
nsyma1=mult(noccnewsymb,iconj(nnewsym))
|
|
coupwobe=icnob(noccoldsymb,ntampsymob)-1
|
|
nampob=noccnewsymb*nr3+nrr
|
|
nsumob=noccoldsymb*nr5+ns4
|
|
ii3=coupwobe+icore(coupwobe+ioabe)
|
|
c write(6,*) 'u21',noccnewsymb,nnewsym,nsyma1
|
|
do ioobe=1,icore(coupwobe+noab)
|
|
ii3=ii3+1
|
|
iioobe=icore(ii3)-1
|
|
ii3=ii3+1
|
|
iostrbe=icore(ii3)
|
|
isgnobe=isign(1,iostrbe)
|
|
iostrbe=iabs(iostrbe)-1
|
|
do noccoldsyma=1,nnir
|
|
noccnewsyma=mult(noccoldsyma,ntampsymoa)
|
|
log=noccnewsyma.le.noccnewsymb
|
|
nsyma2=mult(noccnewsyma,nsyma1)
|
|
noccoldall=nstooa(noccoldsyma)
|
|
c write(6,*) 'noccoldsyma,noccoldall',noccoldsyma,noccoldall
|
|
noccnewall=nstnoa(noccnewsyma)
|
|
coupwoal=icnoa(noccoldsyma,ntampsymoa)-1
|
|
nampoa=nampob+noccnewsyma*nr2
|
|
nsumoa=nsumob+noccoldsyma*nr4
|
|
ii4=coupwoal+icore(coupwoal+ioaal)
|
|
navo=iostrbe*noccnewall
|
|
nsvo=iioobe*noccoldall
|
|
do iooal=1,icore(coupwoal+noaa)
|
|
ii4=ii4+1
|
|
ioo=nsvo+icore(ii4)-1
|
|
ii4=ii4+1
|
|
iostral=icore(ii4)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
iostral=navo+iabs(iostral)-1
|
|
do nvirtoldsymb=1,nnir
|
|
nvirtnewsymb=mult(nvirtoldsymb,ntampsymvb)
|
|
nvirtnewsyma=mult(nvirtnewsymb,nsyma2)
|
|
if(lcalcsn.or.nvirtnewsyma.lt.
|
|
$nvirtnewsymb.or.(nvirtnewsyma.eq.nvirtnewsymb.and.log)) then
|
|
nvirtoldsyma=mult(nvirtnewsyma,iconj(ntampsymva))
|
|
coupwvbe=icnvb(nvirtoldsymb,ntampsymvb)-1
|
|
coupwval=icnva(nvirtoldsyma,ntampsymva)-1
|
|
nn3=nstnva(nvirtnewsyma)
|
|
no3=nstova(nvirtoldsyma)*nsumss
|
|
nampvb=iwan(nampoa+nvirtnewsymb*nnir+nvirtnewsyma)+
|
|
$(iostral*nstnvb(nvirtnewsymb)-1)*nn3-1
|
|
nsumvb=nss+iwa(nsumoa+nvirtoldsymb*nr3+nvirtoldsyma*nr2)+
|
|
$ioo*nstovb(nvirtoldsymb)*no3
|
|
c write(6,*) 'nsumvb',nss,
|
|
c $iwa(nsumoa+nvirtoldsymb*nr3+nvirtoldsyma*nr2),
|
|
c $nsumoa+nvirtoldsymb*nr3+nvirtoldsyma*nr2,
|
|
c $loc(iwa(nsumoa+nvirtoldsymb*nr3+nvirtoldsyma*nr2)),
|
|
c $nvirtoldsyma,nvirtoldsymb,noccoldsyma,noccoldsymb,
|
|
c $nsumsymva,nsumsymvb,nsumsym
|
|
c if(mult(mult(nsumsymva,iconj(nsumsym)),
|
|
c $ mult(iconj(nvirtoldsyma),noccoldsyma)).ne.1) then
|
|
c write(6,*) 'allat'
|
|
c write(6,*) nsumsymva,nsumsym,nvirtoldsyma,noccoldsyma
|
|
c stop
|
|
c endif
|
|
C 1 2 2 1 1 1
|
|
ii1=coupwvbe+icore(coupwvbe+ivabe)
|
|
c write(6,*) 'ivobe',icore(coupwvbe+nvab)
|
|
do ivobe=1,icore(coupwvbe+nvab)
|
|
ii1=ii1+1
|
|
iivobe=icore(ii1)-1
|
|
ii1=ii1+1
|
|
ivstrbe=icore(ii1)
|
|
isgnvbe=isgnoal*isign(1,ivstrbe)
|
|
nivobe=nsumvb+iivobe*no3
|
|
nvstrbe=nampvb+iabs(ivstrbe)*nn3
|
|
ii2=coupwval+icore(coupwval+ivaal)
|
|
c write(6,*) 'ivoal',icore(coupwval+nvaa)
|
|
do ivoal=1,icore(coupwval+nvaa)
|
|
ii2=ii2+1
|
|
ivo=nivobe+icore(ii2)*nsumss
|
|
ii2=ii2+1
|
|
ivstral=icore(ii2)
|
|
isgnval=isgnvbe*isign(1,ivstral)
|
|
c write(6,*) 'matmul5',nvstrbe,iabs(ivstral),ivo,nsuml
|
|
call matmul5(wnew(nvstrbe+
|
|
$iabs(ivstral)),wold(ivo),v,nsuml,isgnval)
|
|
enddo
|
|
enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c write(6,*) 'u3'
|
|
enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
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,
|
|
$ift,ndu,scspe)
|
|
************************************************************************
|
|
* 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,ift
|
|
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),ndu
|
|
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,aicmem
|
|
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,anstr,aisympo
|
|
integer nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,aisympv
|
|
integer nvirtoldal,noccoldal,nvirtoldbe,noccoldbe
|
|
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,ioal,iobe
|
|
integer iw,i5,i6,i7,i8,i9,i10,ire1,ire2,ile1
|
|
real*8 v(*),faaal,faabe,fiial,fiibe,scspe
|
|
logical log,lcalc,lcalcn,lcalcs,lcalcsn,lhg,lhg2
|
|
C
|
|
c write(6,*) 'coninu'
|
|
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),.false.,scspe)
|
|
c endif
|
|
enddo
|
|
c write(6,"(99i3)") j,j,nvirtnew,noccnew,nvintold,nointold,nvirtold,
|
|
c $noccold,namp,ical1,isig11,isave1,j,j,nampvirtact,nampoccact,
|
|
c $nvintoldact,nointoldact,nvirtoldact,noccoldact
|
|
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.
|
|
$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.
|
|
$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
|
|
c write(6,*) 'coninu',ninter
|
|
c $,' ',nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,' ',
|
|
c $nampvirtal,nampvirtbe,' ',nvintoldal,nointoldal,nvirtoldal,
|
|
c $noccoldal,' ',lcalcn
|
|
c write(6,"(100i2)")
|
|
c $nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,
|
|
c $nvintoldal,nointoldal,nvirtoldal,noccoldal,
|
|
c $nampvirtal,nampvirtbe
|
|
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-ift+1
|
|
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)
|
|
icad=icad+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)
|
|
icad=icad+ncomb*(nvirtnewbe+1)
|
|
icore(icd+45)=ncomb
|
|
C Trans vectors
|
|
icore(icd+36)=icad+1
|
|
mmm=itr(2,nvintoldalact,nvintoldal,1)
|
|
call getint(strfile,itr(1,nvintoldalact,nvintoldal,1),
|
|
$icore(icad+1),mmm)
|
|
icad=icad+mmm
|
|
icore(icd+37)=icad+1
|
|
mmm=itr(2,ntampvirtalact,ntampvirtal,1)
|
|
call getint(strfile,itr(1,ntampvirtalact,ntampvirtal,1),
|
|
$icore(icad+1),mmm)
|
|
icad=icad+mmm
|
|
icore(icd+38)=icad+1
|
|
mmm=itr(2,nvintoldbeact,nvintoldbe,2)
|
|
call getint(strfile,itr(1,nvintoldbeact,nvintoldbe,2),
|
|
$icore(icad+1),mmm)
|
|
icad=icad+mmm
|
|
icore(icd+39)=icad+1
|
|
mmm=itr(2,ntampvirtbeact,ntampvirtbe,2)
|
|
call getint(strfile,itr(1,ntampvirtbeact,ntampvirtbe,2),
|
|
$icore(icad+1),mmm)
|
|
icad=icad+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
|
|
read(tafile,rec=tarec(nampvirtalact,nampvirtbeact,nampoccalact,
|
|
$nampoccbeact,nampvirtal,nvirtnew)) ita
|
|
call icp(ita,icore(icore(icd+33)),nir**4)
|
|
icad=icad+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)+ntoldlen
|
|
mscr=icore(icd+29)
|
|
icad=intadd(mscr+ioffs)
|
|
C Read old intermediates
|
|
isig12=1
|
|
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)
|
|
c write(6,*) 'incsum',icore(icore(icd+30)+3)
|
|
c write(6,*) 'iwa',icore(icore(icd+31)+20),
|
|
c $loc(icore(icore(icd+31)+20))
|
|
c write(6,*) 'lociwa',loc(icore(icore(icd+31)))
|
|
do isymi=1,nir
|
|
ndu=max(ndu,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
|
|
call add(v(icore(icd+27)),v(1),ntoldlen,0,isig11*isig12,1.d0,
|
|
$scspe)
|
|
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,ndl,scspe)
|
|
************************************************************************
|
|
* 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),ndl
|
|
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),itc1
|
|
integer ninter,icad,icd,mscr,mmm,mfst,ninter3,mscr3,mfst3,icd3
|
|
integer iw,i5,i6,i7,i8,i9,i10,ire1,ire2,ile1,wspc3(0:wsmax)
|
|
real*8 v(*),faaal,faabe,fiial,fiibe,scspe
|
|
logical log,lcalc,lcalcn,lcalcs,lcalcsn,lc,ldir,logi
|
|
C
|
|
c write(6,*) 'coninl'
|
|
ninter=0
|
|
logi=.false.
|
|
C
|
|
rewind(ftfile)
|
|
if(pleft) call readlab('LEFT ')
|
|
c if(pert.ne.3.and.densroute) call readlab('DENS ')
|
|
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
|
|
c write(6,*) 'ical1',ical1
|
|
if(pleft) then
|
|
namp=iabs(namp)
|
|
call rospc(wspc2(0,ical1),wspc3,nvirtoldact,noccoldact,wsmax
|
|
$)
|
|
c ???
|
|
else
|
|
call icp(wspc2(0,ical1),wspc3,wsmax+1)
|
|
endif
|
|
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,wspc3(0)
|
|
nvintoldal=wspc3((iwo-1)*12+1)
|
|
nointoldal=wspc3((iwo-1)*12+2)
|
|
nvirtoldal=wspc3((iwo-1)*12+3)
|
|
noccoldal=wspc3((iwo-1)*12+4)
|
|
nvintoldalact=wspc3((iwo-1)*12+5)
|
|
nointoldalact=wspc3((iwo-1)*12+6)
|
|
nvintoldbeact=wspc3((iwo-1)*12+7)
|
|
nointoldbeact=wspc3((iwo-1)*12+8)
|
|
nvirtoldalact=wspc3((iwo-1)*12+9)
|
|
noccoldalact=wspc3((iwo-1)*12+10)
|
|
nvirtoldbeact=nvirtoldact-nvirtoldalact
|
|
noccoldbeact=noccoldact-noccoldalact
|
|
ircold=wspc3((iwo-1)*12+11)
|
|
ntoldlen=wspc3((iwo-1)*12+12)
|
|
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 write(6,*) 'spcas1',nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,
|
|
c $nvirtnewalact,nvirtnewbeact,noccnewalact,noccnewbeact,' ',
|
|
c $nvirtoldal,nvirtoldbe,noccoldal,noccoldbe,
|
|
c $nvirtoldalact,nvirtoldbeact,noccoldalact,noccoldbeact
|
|
c write(6,*) 'spcas',ntampvirtal,ntampvirtbe,nvintoldal,nvintoldbe,
|
|
c $nampvirtal,nampvirtbe,namp,nampvirtal+nampvirtbe.eq.namp,ical1
|
|
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
|
|
if(locno.gt.0) then
|
|
ndl=max(ndl,2*nbe**(noccnewbe-1)*nstr(1,noccnewalact,noccnewal,3))
|
|
ndl=max(ndl,2*nal**(noccnewal-1))
|
|
endif
|
|
ninter=ninter+1
|
|
icado=icad
|
|
icd=icad
|
|
c write(6,*) 'spcas2',nvirtnewal,nvirtnewbe,noccnewal,noccnewbe,
|
|
c $nvirtnewalact,nvirtnewbeact,noccnewalact,noccnewbeact,' ',
|
|
c $nvirtoldal,nvirtoldbe,noccoldal,noccoldbe,
|
|
c $nvirtoldalact,nvirtoldbeact,noccoldalact,noccoldbeact
|
|
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
|
|
icore(icd+54)=nvintoldal+nointoldal+nvintoldbe+nointoldbe
|
|
icad=icad+54
|
|
C Combinations
|
|
icore(icd+34)=icad+1
|
|
call comb(nvirtnewal,nvirtnewalact,icore(icad+1),ilv,nvirtoldal,
|
|
$nvirtoldalact,0,ncoma,isa)
|
|
icad=icad+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)
|
|
icad=icad+ncomb*(nvirtnewbe+1)
|
|
icore(icd+45)=ncomb
|
|
C Trans vectors
|
|
icore(icd+36)=icad+1
|
|
mmm=itr(2,nvirtoldalact,nvirtoldal,1)
|
|
call getint(strfile,itr(1,nvirtoldalact,nvirtoldal,1),
|
|
$icore(icad+1),mmm)
|
|
icad=icad+mmm
|
|
icore(icd+37)=icad+1
|
|
mmm=itr(2,ntampvirtalact,ntampvirtal,1)
|
|
call getint(strfile,itr(1,ntampvirtalact,ntampvirtal,1),
|
|
$icore(icad+1),mmm)
|
|
icad=icad+mmm
|
|
icore(icd+38)=icad+1
|
|
mmm=itr(2,nvirtoldbeact,nvirtoldbe,2)
|
|
call getint(strfile,itr(1,nvirtoldbeact,nvirtoldbe,2),
|
|
$icore(icad+1),mmm)
|
|
icad=icad+mmm
|
|
icore(icd+39)=icad+1
|
|
mmm=itr(2,ntampvirtbeact,ntampvirtbe,2)
|
|
call getint(strfile,itr(1,ntampvirtbeact,ntampvirtbe,2),
|
|
$icore(icad+1),mmm)
|
|
icad=icad+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,dsympair)
|
|
icore(icad+isymi)=incs
|
|
ndl=max(ndl,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)),dsympair)
|
|
icad=icad+nir**3
|
|
c write(6,*) 'ldir1',icore(icore(icd+31)+32),ldir
|
|
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
|
|
c write(6,*) 'ldir2',icore(icore(icd+31)+32),ldir
|
|
endif
|
|
ntoldlen=ntoldlen-1
|
|
icore(icd+18)=ntoldlen
|
|
c write(6,*) 'coninu33',icore(icore(icd+31)+32)
|
|
C Addresses of summation indices
|
|
icore(icd+32)=icad+1
|
|
do ir=1,nir
|
|
call tlength(nmax,nstr,nnir,isympv,isympo,nactm,jj,ir,
|
|
$nvintoldalact,nvintoldbeact,nvintoldal,nvintoldbe,nointoldalact,
|
|
$nointoldbeact,nointoldal,nointoldbe,icore(icore(icd+32)),1,0,
|
|
$dsympair)
|
|
enddo
|
|
icad=icad+nir**4
|
|
C Addresses of cluster amplitudes
|
|
icore(icd+33)=icad+1
|
|
read(tafile,rec=tarec(nampvirtalact,nampvirtbeact,nampoccalact,
|
|
$nampoccbeact,nampvirtal,namp)) ita
|
|
call icp(ita,icore(icore(icd+33)),nir**4)
|
|
icad=icad+nir**4
|
|
C Addresses of real arrays
|
|
icore(icd+27)=dbladd(icad)-ioffs+3
|
|
icore(icd+28)=icore(icd+27)+ntoldlen+ioffs-2
|
|
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
|
|
c write(6,*) 'cint elott'
|
|
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,
|
|
$ioffs+icore(icd+27),ndl,ntoldlen,wspc3,nvirtoldact,noccoldact,
|
|
$scspe)
|
|
c write(6,*) 'cint utan'
|
|
if(log) then
|
|
if(ninter3.gt.0) then
|
|
icore(icd+28)=icore(icd+27)+mscr3+ioffs+2
|
|
icore(icd+51)=mfst3
|
|
icore(icd+52)=ninter3
|
|
icore(icd+53)=icd3
|
|
do isymi=1,nir
|
|
ndl=max(ndl,icore(icore(icd+30)-1+isymi)+ntoldlen)
|
|
enddo
|
|
else
|
|
icore(icd+52)=0
|
|
endif
|
|
C Read amplitudes
|
|
iampad=icore(icd+28)
|
|
call tread(itad,namplen,iampad,lc,nampvirtalact,
|
|
$nampvirtbeact,nampoccalact,nampoccbeact,nampvirtal,namp)
|
|
call getlst(file3,iamprec,dcore(iampad),namplen)
|
|
icore(icd+29)=icore(icd+28)+namplen-ioffs+2
|
|
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 opstrb1(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,sumva,sumvb,iorba,iorbb,ileva,ilevb,arca,arcb,nsyma,
|
|
$nsymb,nsyma11,nsyma22,nnr,nnn,iuca,iucb,corr,lcalcsn,lhgn,iqf,
|
|
$ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank,thrd,
|
|
$xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,nal,nbe,
|
|
$umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
************************************************************************
|
|
* This subroutine generates operator strings *
|
|
************************************************************************
|
|
implicit none
|
|
integer nstnva,nstnvb,nstnoa,nstnob,nnir,nnewsym,iwan,nampsym,nb
|
|
integer nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,mosym(nb,4),mscr
|
|
integer mfst1,ninter1,mfst2,ninter2,ift,ntnewlen,nsyma,nsymb,icdo
|
|
integer iuca(nval),iucb(nvbe),ileva,ilevb,iorba,iorbb,iqf,ioffs
|
|
integer nnr,nnn,arca(0:nva,0:nval),arcb(0:nvb,0:nvbe),nsyma11,thrd
|
|
integer nsyma22,i,j,nirmax,icore,mult(nirmax,nirmax),op,iconj
|
|
integer nrr,nr2,nr3,nr4,nr5,rank,xyzcount,mpicount,mpisize
|
|
integer locno,nal,nbe,absa(*),absb(*)
|
|
real*8 facta,factb,umat(*),tscalea(nal),tscaleb(nbe)
|
|
real*8 v,faaal(*),faabe(*),fiial(*),fiibe(*),corr,dcore,vift
|
|
real*8 sumva,sumvb,sumoa,sumob,wnew,vmscr
|
|
logical lcalcsn,lhgn,lf12
|
|
C
|
|
if(ilevb.eq.nvbe) then
|
|
nsyma11=mult(nsymb,nnewsym)
|
|
iorba=0
|
|
ileva=0
|
|
sumva=sumvb
|
|
nsyma=1
|
|
call opstra1(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,sumva,sumvb,iorba,iorbb,ileva,ilevb,arca,arcb,nsyma,
|
|
$nsymb,nsyma11,nsyma22,nnr,nnn,iuca,iucb,corr,lcalcsn,lhgn,iqf,
|
|
$ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank,thrd,
|
|
$xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,nal,nbe,
|
|
$umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
c write(6,*) 'opstra1 utan2'
|
|
else
|
|
iorbb=iorbb+1
|
|
if(arcb(iorbb,ilevb).gt.0) then
|
|
call opstrb2(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,sumva,sumvb,iorba,iorbb,ileva,ilevb,arca,arcb,nsyma,
|
|
$nsymb,nsyma11,nsyma22,nnr,nnn,iuca,iucb,corr,lcalcsn,lhgn,iqf,
|
|
$ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank,thrd,
|
|
$xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,nal,nbe,
|
|
$umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
endif
|
|
if(arcb(iorbb,ilevb+1).gt.0) then
|
|
ilevb=ilevb+1
|
|
iucb(ilevb)=iorbb
|
|
nsymb=mult(nsymb,mosym(iorbb,2))
|
|
sumvb=sumvb-faabe(iorbb)
|
|
call opstrb2(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,sumva,sumvb,iorba,iorbb,ileva,ilevb,arca,arcb,nsyma,
|
|
$nsymb,nsyma11,nsyma22,nnr,nnn,iuca,iucb,corr,lcalcsn,lhgn,iqf,
|
|
$ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank,thrd,
|
|
$xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,nal,nbe,
|
|
$umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
sumvb=sumvb+faabe(iorbb)
|
|
nsymb=mult(nsymb,mosym(iorbb,2))
|
|
ilevb=ilevb-1
|
|
endif
|
|
iorbb=iorbb-1
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine opstrb2(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,sumva,sumvb,iorba,iorbb,ileva,ilevb,arca,arcb,nsyma,
|
|
$nsymb,nsyma11,nsyma22,nnr,nnn,iuca,iucb,corr,lcalcsn,lhgn,iqf,
|
|
$ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank,thrd,
|
|
$xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,nal,nbe,
|
|
$umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
************************************************************************
|
|
* This subroutine generates operator strings *
|
|
************************************************************************
|
|
c #include "MRCCCOMMON"
|
|
implicit none
|
|
integer nstnva,nstnvb,nstnoa,nstnob,nnir,nnewsym,iwan,nampsym,nb
|
|
integer nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,mosym(nb,4),mscr
|
|
integer mfst1,ninter1,mfst2,ninter2,ift,ntnewlen,nsyma,nsymb,icdo
|
|
integer iuca(nval),iucb(nvbe),ileva,ilevb,iorba,iorbb,iqf,ioffs
|
|
integer nnr,nnn,arca(0:nva,0:nval),arcb(0:nvb,0:nvbe),nsyma11
|
|
integer nsyma22,icore,mult,nirmax,op,nrr,nr2,nr3,nr4,nr5,iconj
|
|
integer rank,xyzcount,thrd,mpicount,mpisize
|
|
integer locno,nal,nbe,absa(*),absb(*)
|
|
real*8 facta,factb,umat(*),tscalea(nal),tscaleb(nbe)
|
|
real*8 v,faaal(*),faabe(*),fiial(*),fiibe(*),corr,dcore,vift
|
|
real*8 sumva,sumvb,wnew,vmscr
|
|
logical lcalcsn,lhgn,lf12
|
|
C
|
|
call opstrb1(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,sumva,sumvb,iorba,iorbb,ileva,ilevb,arca,arcb,nsyma,
|
|
$nsymb,nsyma11,nsyma22,nnr,nnn,iuca,iucb,corr,lcalcsn,lhgn,iqf,
|
|
$ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank,thrd,
|
|
$xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,nal,nbe,
|
|
$umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine opstra1(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,sumva,sumvb,iorba,iorbb,ileva,ilevb,arca,arcb,nsyma,
|
|
$nsymb,nsyma11,nsyma22,nnr,nnn,iuca,iucb,corr,lcalcsn,lhgn,iqf,
|
|
$ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank,thrd,
|
|
$xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,nal,nbe,
|
|
$umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
************************************************************************
|
|
* This subroutine generates operator strings *
|
|
************************************************************************
|
|
implicit none
|
|
integer nstnva,nstnvb,nstnoa,nstnob,nnir,nnewsym,iwan,nampsym,nb
|
|
integer nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,mosym(nb,4),mscr
|
|
integer mfst1,ninter1,mfst2,ninter2,ift,ntnewlen,nsyma,nsymb,icdo
|
|
integer iuca(nval),iucb(nvbe),ileva,ilevb,iorba,iorbb,iqf,ioffs
|
|
integer nnr,nnn,arca(0:nva,0:nval),arcb(0:nvb,0:nvbe),nsyma11
|
|
integer nsyma22,nirmax,icore,mult(nirmax,nirmax),op,iconj(*)
|
|
integer nrr,nr2,nr3,nr4,nr5,rank,xyzcount,thrd,mpicount,mpisize
|
|
integer locno,nal,nbe,absa(*),absb(*)
|
|
real*8 facta,factb,umat(*),tscalea(nal),tscaleb(nbe)
|
|
real*8 v,faaal(*),faabe(*),fiial(*),fiibe(*),corr,dcore,vift
|
|
real*8 sumva,sumvb,wnew,vmscr
|
|
logical lcalcsn,lhgn,lf12
|
|
C
|
|
c write(6,*) 'nsyma',nsyma
|
|
if(ileva.eq.nval) then
|
|
nsyma22=mult(nsyma,nsyma11)
|
|
call contractp(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,fiial,fiibe,ift,
|
|
$ntnewlen,sumva,nsyma22,nnr,nnn,iuca,iucb,corr,nsyma,nsymb,lcalcsn,
|
|
$lhgn,iqf,ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,
|
|
$rank,thrd,xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,nal,
|
|
$nbe,umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
c write(6,*) 'contractp utan'
|
|
else
|
|
iorba=iorba+1
|
|
if(arca(iorba,ileva).gt.0) then
|
|
call opstra2(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,sumva,sumvb,iorba,iorbb,ileva,ilevb,arca,arcb,nsyma,
|
|
$nsymb,nsyma11,nsyma22,nnr,nnn,iuca,iucb,corr,lcalcsn,lhgn,iqf,
|
|
$ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank,thrd,
|
|
$xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,nal,nbe,
|
|
$umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
c write(6,*) 'opstra2 utan1'
|
|
endif
|
|
if(arca(iorba,ileva+1).gt.0) then
|
|
ileva=ileva+1
|
|
iuca(ileva)=iorba
|
|
nsyma=mult(nsyma,mosym(iorba,1))
|
|
c write(6,*) 'iorba,mosym(iorba,1),nsyma',
|
|
c $ iorba,mosym(iorba,1),nsyma
|
|
sumva=sumva-faaal(iorba)
|
|
call opstra2(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,sumva,sumvb,iorba,iorbb,ileva,ilevb,arca,arcb,nsyma,
|
|
$nsymb,nsyma11,nsyma22,nnr,nnn,iuca,iucb,corr,lcalcsn,lhgn,iqf,
|
|
$ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank,thrd,
|
|
$xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,nal,nbe,
|
|
$umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
c write(6,*) 'opstra2 utan2'
|
|
sumva=sumva+faaal(iorba)
|
|
c write(6,*) 'opstra2 utan3',nsyma,mosym(iorba,1),iorba
|
|
nsyma=mult(nsyma,iconj(mosym(iorba,1)))
|
|
c write(6,*) 'opstra2 utan4'
|
|
ileva=ileva-1
|
|
endif
|
|
iorba=iorba-1
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine opstra2(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,sumva,sumvb,iorba,iorbb,ileva,ilevb,arca,arcb,nsyma,
|
|
$nsymb,nsyma11,nsyma22,nnr,nnn,iuca,iucb,corr,lcalcsn,lhgn,iqf,
|
|
$ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank,thrd,
|
|
$xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,nal,nbe,
|
|
$umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
************************************************************************
|
|
* This subroutine generates operator strings *
|
|
************************************************************************
|
|
implicit none
|
|
integer nstnva,nstnvb,nstnoa,nstnob,nnir,nnewsym,iwan,nampsym,nb
|
|
integer nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,mosym(nb,4),mscr
|
|
integer mfst1,ninter1,mfst2,ninter2,ift,ntnewlen,nsyma,nsymb,icdo
|
|
integer iuca(nval),iucb(nvbe),ileva,ilevb,iorba,iorbb,iqf,ioffs
|
|
integer nnr,nnn,arca(0:nva,0:nval),arcb(0:nvb,0:nvbe),nsyma11
|
|
integer nsyma22,icore,mult,nirmax,op,nrr,nr2,nr3,nr4,nr5,iconj
|
|
integer rank,xyzcount,thrd,mpicount,mpisize,absa(*),absb(*)
|
|
integer locno,nal,nbe
|
|
real*8 facta,factb,umat(*),tscalea(nal),tscaleb(nbe)
|
|
real*8 v,faaal(*),faabe(*),fiial(*),fiibe(*),corr,dcore,vift
|
|
real*8 sumva,sumvb,wnew,vmscr
|
|
logical lcalcsn,lhgn,lf12
|
|
C
|
|
call opstra1(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,sumva,sumvb,iorba,iorbb,ileva,ilevb,arca,arcb,nsyma,
|
|
$nsymb,nsyma11,nsyma22,nnr,nnn,iuca,iucb,corr,lcalcsn,lhgn,iqf,
|
|
$ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank,thrd,
|
|
$xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,nal,nbe,
|
|
$umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine add3(v1,v2,n)
|
|
************************************************************************
|
|
* v1 = v1 + v2 *
|
|
************************************************************************
|
|
implicit none
|
|
integer n,i
|
|
real*8 v1(*),v2(*)
|
|
C
|
|
do i=1,n
|
|
v1(i)=v1(i)+v2(i)
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine scalprod2(v1,v2,n,s)
|
|
************************************************************************
|
|
* Vectorized scalar product *
|
|
************************************************************************
|
|
implicit none
|
|
integer n,i
|
|
real*8 s,v1(*),v2(*)
|
|
C
|
|
do i=1,n
|
|
s=s+v1(i)*v2(i)
|
|
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,ioffs,ndl,nnnn,wspc3,nvirtoldact,
|
|
$noccoldact,scspe)
|
|
************************************************************************
|
|
* 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,nnnn
|
|
integer nvirtoldbeact,itad,ioffs,intadd,dbladd,ndl,wspc3(0:wsmax)
|
|
integer nvirtoldact,noccoldact
|
|
real*8 v(*),scspe
|
|
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)
|
|
if(pleft) call readlab('LEFT ')
|
|
c if(pert.ne.3.and.densroute) call readlab('DENS ')
|
|
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)
|
|
c write(6,*) 'cint ical1',icl1,isave1
|
|
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
|
|
c write(6,*) 'cint isave2',isave2,ldir,nvintnew2,nvirtnew2,op
|
|
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)
|
|
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),.false.,
|
|
$scspe)
|
|
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,ioffs,ndl,nnnn)
|
|
else
|
|
if(isave2.gt.0) then
|
|
nn3=2
|
|
call skip1(nn3,ftfile)
|
|
endif
|
|
if(pleft) then
|
|
call rospc(wspc1(0,ical2),wspc3,nvirtoldact,noccoldact,wsmax)
|
|
else
|
|
call icp(wspc1(0,ical2),wspc3,wsmax+1)
|
|
endif
|
|
call imrmem(intfile,intrec(ical2),isig11,isig12,v,wspc3,
|
|
$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,ioffs,ndl,nnnn)
|
|
************************************************************************
|
|
* 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,ioffs
|
|
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,intadd
|
|
integer file1,file2,irec1,irec2,ircold,ircnew,intrec,nsyma,dbladd
|
|
integer ntoldlen,namplen,ia1,ia2,ntoldleno,mfst3,mscr,anstr,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
|
|
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,ndl,nnnn
|
|
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
|
|
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,iconj(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)
|
|
icad=icad+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)
|
|
icad=icad+ncomb*(nvirtnewbe+1)
|
|
icore(icd+45)=ncomb
|
|
C Trans vectors
|
|
icore(icd+36)=icad+1
|
|
mmm=itr(2,nvirtoldalact,nvirtoldal,1)
|
|
call getint(strfile,itr(1,nvirtoldalact,nvirtoldal,1),
|
|
$icore(icad+1),mmm)
|
|
icad=icad+mmm
|
|
icore(icd+37)=icad+1
|
|
mmm=itr(2,ntampvirtalact,ntampvirtal,1)
|
|
call getint(strfile,itr(1,ntampvirtalact,ntampvirtal,1),
|
|
$icore(icad+1),mmm)
|
|
icad=icad+mmm
|
|
icore(icd+38)=icad+1
|
|
mmm=itr(2,nvirtoldbeact,nvirtoldbe,2)
|
|
call getint(strfile,itr(1,nvirtoldbeact,nvirtoldbe,2),
|
|
$icore(icad+1),mmm)
|
|
icad=icad+mmm
|
|
icore(icd+39)=icad+1
|
|
mmm=itr(2,ntampvirtbeact,ntampvirtbe,2)
|
|
call getint(strfile,itr(1,ntampvirtbeact,ntampvirtbe,2),
|
|
$icore(icad+1),mmm)
|
|
icad=icad+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
|
|
do ir=1,nir
|
|
call tlength(nmax,nstr,nnir,isympv,isympo,nactm,jj,ir,
|
|
$nsumvirtalact,nsumvirtbeact,nsumvirtal,nsumvirtbe,nsumoccalact,
|
|
$nsumoccbeact,nsumoccal,nsumoccbe,icore(icore(icd+32)),1,0,
|
|
$dsympair)
|
|
enddo
|
|
icad=icad+nir**4
|
|
C Addresses of cluster amplitudes
|
|
icore(icd+33)=icad+1
|
|
icad=icad+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
|
|
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)
|
|
do isymi=1,nir
|
|
ndl=max(ndl,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)+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)+namplen-ioffs+3
|
|
icore(icd+29)=icore(icd+52)+1
|
|
mscr=icore(icd+29)
|
|
icad=intadd(mscr+ioffs)
|
|
C Read amplitudes
|
|
read(tafile,rec=tarec(nampvirtalact,nampvirtbeact,nampoccalact,
|
|
$nampoccbeact,nampvirtal,iabs(namp1))) ita
|
|
call icp(ita,icore(icore(icd+33)),nir**4)
|
|
call getlst(file3,iamprec,dcore(icore(icd+28)),namplen)
|
|
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 contractpx(v,vscr,nnewsym,iwan,nval,nvbe,nva,nvb,mosym,
|
|
$nb,nnn,mfst3,ninter3,icdo,ista,istb,nvirtnewsyma,nvirtnewsymb,
|
|
$nampva,ntoldlen,wnew,ioffs,icore,mult,nirmax,nrr,nr2,nr3,nr4,nnir,
|
|
$dcore,nr5,iconj)
|
|
************************************************************************
|
|
* This subroutine evaluates the contractions between cluster amplitudes*
|
|
* and intermediates *
|
|
************************************************************************
|
|
implicit none
|
|
integer nnewsym,iwan,nval,nvbe,nva,nvb,icd,mosym,nb,nnn,mfst3,i
|
|
integer ninter3,icdo,istb,nvirtnewsymb,ista,ntoldlen,nampva,mmm
|
|
integer nvirtnewsyma,nsym22,ioffs,intadd,nr5,iconj(*)
|
|
integer nirmax,icore(*),mult(nirmax,nirmax),nrr,nr2,nr3,nr4,nnir
|
|
real*8 v(*),wnew(*),vscr,dcore(*)
|
|
C
|
|
call dfillzer1(wnew,ntoldlen)
|
|
nsym22=mult(nvirtnewsyma,mult(nvirtnewsymb,nnewsym))
|
|
C
|
|
icd=icdo
|
|
icore(icd+29)=mfst3
|
|
do mmm=1,ninter3
|
|
icd=intadd(icore(icd+29)+ioffs)
|
|
call contractpi(wnew,dcore(icore(icd+27)),dcore(icore(icd+28)-1),
|
|
$vscr,icore(icore(icd+32)),icore(icore(icd+1)),icore(icore(icd+2)),
|
|
$icore(icore(icd+3)),icore(icore(icd+4)),icore(icore(icd+5)),
|
|
$icore(icore(icd+6)),icore(icore(icd+7)),icore(icore(icd+8)),
|
|
$icore(icore(icd+9)),icore(icore(icd+10)),icore(icore(icd+11)),
|
|
$icore(icore(icd+12)),icore(icore(icd+13)),icore(icore(icd+14)),
|
|
$icore(icore(icd+15)),icore(icore(icd+16)),icore(icore(icd+19)),
|
|
$icore(icore(icd+20)),icore(icore(icd+23)),icore(icore(icd+24)),
|
|
$icore(icore(icd+25)),icore(icore(icd+26)),nnir,
|
|
$icore(icore(icd+33)),icore(icore(icd+31)),iwan,
|
|
$icore(icore(icd+30)),icore(icd+17),nval,nvbe,ista,istb,
|
|
$icore(icore(icd+34)),icore(icore(icd+35)),icore(icd+44),
|
|
$icore(icd+45),icore(icore(icd+36)),icore(icore(icd+37)),
|
|
$icore(icore(icd+38)),icore(icore(icd+39)),icore(icore(icd+40)),
|
|
$icore(icore(icd+41)),icore(icore(icd+42)),icore(icore(icd+43)),
|
|
$nva,nvb,icore(icd+46),icore(icd+47),icore(icd+48),icore(icd+49),
|
|
$mosym,nb,nnn,nsym22,nampva,icore(icore(icd+51)),icore(icd+18),
|
|
$v(icore(icd+52)),nrr,nr2,nr3,nr4,nr5,mult,nirmax,icore,iconj)
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine contractpi(wnew,wold,t,v,isa,nsttva,nsttvb,nsttoa,
|
|
$nsttob,icsva,icsvb,icsoa,icsob,nstsva,nstsvb,nstsoa,nstava,nstavb,
|
|
$nstaoa,isymp1,isymp2,icnoa,icnob,nstnoa,nstova,nstovb,nstooa,nnir,
|
|
$ita,iwa,iwan,incsum,nampsym,nval,nvbe,istrva,istrvb,icoma,icomb,
|
|
$ncoma,ncomb,itolda,itampa,itoldb,itampb,idolda,idampa,idoldb,
|
|
$idampb,nva,nvb,noal,ntal,nobe,ntbe,mosym,nb,nnn,nsym22,nampva,
|
|
$incnew,idi,ssg,nrr,nr2,nr3,nr4,nr5,mult,nirmax,icore,iconj)
|
|
************************************************************************
|
|
* This subroutine evaluates the contractions between cluster amplitudes*
|
|
* and intermediates *
|
|
************************************************************************
|
|
implicit none
|
|
integer*1 isgnval,isgnvbe,isgnoal,isgnobe,isgnvb1
|
|
integer ivstral,ivstrbe,iostral,iostrbe,ivstr,iostr,iivobe,n3,nb
|
|
integer iosbe,iosal,ivsbe,ivsal,ivobe,iooal,ioobe,iioobe,nnir,idi
|
|
integer ivsalad,ifvsal,ivsbead,ifvsbe,ivo,ioo,iosalad,nv,no,n2
|
|
integer ivaal,ivabe,ioaal,ioabe,nval,nvbe,icmb,nvsal,nosal,nvaa
|
|
integer nvab,noaa,noab,nsumoa,i,ii,nvabe,noaal,noabe,nsumob,icma
|
|
integer coupsval,coupsvbe,coupsoal,coupsobe,nampoa,coupwoal,ntbe
|
|
integer iosbead,no2,no3,no4,icsob(nnir,nnir),ita(*),coupwobe,nn2
|
|
integer icsva(nnir,nnir),icsvb(nnir,nnir),icsoa(nnir,nnir),navo
|
|
integer icnob(nnir,nnir),nsumvb,incsum(nnir),nsvo,nn3,nn4,nampob
|
|
integer icnoa(nnir,nnir),nstnoa(*),mosym(nb,4),nva,nvb,noal,ntal
|
|
integer nsttva(*),nsttvb(*),nsttoa(*),nsttob(*),ncoma,ncomb,nobe
|
|
integer nstsva(*),nstsvb(*),nstsoa(*),icoma(0:nval,*),nampva
|
|
integer nstava(*),nstavb(*),nstaoa(*),icomb(0:nvbe,*),iivob2
|
|
integer nstova(*),nstovb(*),nstooa(*),idolda,idampa,idoldb,idampb
|
|
integer isa(*),isymp1(0:nnir,nnir),isymp2(0:nnir,nnir),nsumva
|
|
integer istrva,istrvb,itolda,itampa,itoldb,itampb,nsym22,ii1,ii2
|
|
integer nsumsym,nampsym,nsyma1,nsyma2,nsyma3,irs,nosalad,nostr
|
|
integer nsumsymva,nsumsymvb,nsumoccallen,nampoccallen,nnn,nivobe
|
|
integer nampsymva,nampsymvb,ntampsymva,ntampsymvb,nsumsymoa
|
|
integer nampsymoa,ntampsymoa,ntampsymob,nsumsymob,nvstrbe,ii3,ii4
|
|
integer nvirtoldsyma,nvirtoldsymb,noccoldsymb,isymi,incnew(*)
|
|
integer nvirtoldbelen,noccnewsyma,noccnewsymb,noccoldsyma,iconj(*)
|
|
integer iwan(*),iwa(*),nsymt1,nsymt2,noccnewsym,nsumv1
|
|
integer nrr,nr2,nr3,nr4,nr5,nirmax,mult(nirmax,nirmax)
|
|
integer ista(noal),istb(nobe),ir1,ir2,ir3,ir4,ir5,ir6,icore(*)
|
|
integer nvirtoldall,nsuml,noccoldall,noccnewall
|
|
real*8 wnew(*),wold(*),t(*),v(*),ssg
|
|
C
|
|
ir1=nnir
|
|
ir2=nr2
|
|
ir3=nr3
|
|
ir4=nr4
|
|
ir5=nr5
|
|
ir6=1
|
|
if(idi.eq.1) then
|
|
ir1=nr2
|
|
ir2=nnir
|
|
ir3=nr4
|
|
ir4=nr3
|
|
else if(idi.eq.2) then
|
|
ir5=1
|
|
ir6=nr5
|
|
endif
|
|
C
|
|
do icmb=1,ncomb
|
|
c write(6,*) 'icmb',icmb,nobe,ntbe
|
|
call stranal(icomb(0,icmb),istrvb,nobe,ntbe,isgnvb1,
|
|
$nvirtoldsymb,ntampsymvb,mosym(1,2),idoldb,idampb,nvb,itoldb,
|
|
$itampb,iivobe,ivabe,istb,mult,nirmax)
|
|
iivobe=iivobe-1
|
|
nvabe=nsttvb(ntampsymvb)
|
|
nvirtoldbelen=nstovb(nvirtoldsymb)
|
|
nsumvb=nnn+nvirtoldsymb*ir2
|
|
nvab=nvabe+ivabe
|
|
do icma=1,ncoma
|
|
c write(6,*) 'icma',icma,noal,ntal
|
|
call stranal(icoma(0,icma),istrva,noal,ntal,isgnval,
|
|
$nvirtoldsyma,ntampsymva,mosym(1,1),idolda,idampa,nva,itolda,
|
|
$itampa,ivo,ivaal,ista,mult,nirmax)
|
|
isgnval=isgnvb1*isgnval
|
|
ivo=ivo-1
|
|
nsymt1=mult(ntampsymva,ntampsymvb)
|
|
nvaa=nsttva(ntampsymva)+ivaal
|
|
nvirtoldall=nstova(nvirtoldsyma)
|
|
no3=nvirtoldall*nvirtoldbelen
|
|
nsumva=nsumvb+nvirtoldsyma*ir1
|
|
iivob2=iivobe*nvirtoldall+ivo
|
|
C Loops over occupied fixed strings of cluster amplitudes
|
|
do ntampsymob=1,nnir
|
|
nsymt2=mult(ntampsymob,nsymt1)
|
|
noabe=nsttob(ntampsymob)
|
|
do ioabe=1,noabe
|
|
noab=noabe+ioabe
|
|
do nsumsym=1,nnir
|
|
nsuml=incsum(nsumsym)
|
|
if(nsuml.gt.0) then
|
|
ntampsymoa=mult(mult(nsumsym,nsymt2),nampsym)
|
|
noaal=nsttoa(ntampsymoa)
|
|
nsumv1=nsumva+nsumsym*ir5
|
|
do ioaal=1,noaal
|
|
noaa=noaal+ioaal
|
|
C Unpack cluster amplitudes
|
|
call dfillzer1(v,nsuml)
|
|
do nsumsymob=1,nnir
|
|
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,nnir
|
|
nampsymoa=mult(nsumsymoa,ntampsymoa)
|
|
nsyma2=mult(nsumsymoa,nsyma1)
|
|
nsumoccallen=nstsoa(nsumsymoa)
|
|
nampoccallen=nstaoa(nampsymoa)
|
|
navo=nampoccallen*iostrbe
|
|
nsvo=nsumoccallen*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)
|
|
nn3=nstava(nampsymva)
|
|
coupsval=icsva(nsumsymva,ntampsymva)-1
|
|
coupsvbe=icsvb(nsumsymvb,ntampsymvb)-1
|
|
nosalad=isa(nsumoa+nsumsymvb*nnir+nsumsymva)+
|
|
$n3*(nstsvb(nsumsymvb)*iosalad-1)
|
|
nostr=ita(nampoa+nampsymvb*nnir+nampsymva)+
|
|
$nn3*(nstavb(nampsymvb)*iostr-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)
|
|
ii4=ii4+1
|
|
ivstral=icore(ii4)
|
|
v(ivsalad)=
|
|
$isgnvbe*isign(1,ivstral)*t(ivstrbe+iabs(ivstral))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
call smult(v,nsuml,ssg)
|
|
C Loop over symmetry cases of new (old) intermediates
|
|
if(idi.eq.2) then
|
|
do noccoldsymb=1,nnir
|
|
noccnewsymb=mult(noccoldsymb,ntampsymob)
|
|
nsyma3=mult(noccnewsymb,nsym22)
|
|
coupwobe=icnob(noccoldsymb,ntampsymob)-1
|
|
nampob=nampva+noccnewsymb*nr2
|
|
nsumob=nsumv1+noccoldsymb*ir4
|
|
ii3=coupwobe+icore(coupwobe+ioabe)
|
|
do ioobe=1,icore(coupwobe+noab)
|
|
ii3=ii3+1
|
|
iioobe=(icore(ii3)-1)*no3
|
|
ii3=ii3+1
|
|
iostrbe=icore(ii3)
|
|
isgnobe=isgnval*isign(1,iostrbe)
|
|
iostrbe=iabs(iostrbe)-1
|
|
do noccoldsyma=1,nnir
|
|
noccnewsyma=mult(noccoldsyma,ntampsymoa)
|
|
isymi=mult(iconj(noccnewsyma),nsyma3)
|
|
noccoldall=nstooa(noccoldsyma)
|
|
noccnewall=nstnoa(noccnewsyma)
|
|
coupwoal=icnoa(noccoldsyma,ntampsymoa)-1
|
|
nn4=incnew(isymi)
|
|
no4=nn4*nsuml
|
|
no2=no3*no4
|
|
nivobe=iwa(nsumob+noccoldsyma*ir3+isymi*ir6)+
|
|
$(iioobe*noccoldall+iivob2)*no4-no2
|
|
nvstrbe=iwan(nampob+noccnewsyma*nnir+isymi)+
|
|
$(iostrbe*noccnewall-1)*nn4
|
|
ii4=coupwoal+icore(coupwoal+ioaal)
|
|
do iooal=1,icore(coupwoal+noaa)
|
|
ii4=ii4+1
|
|
ioo=nivobe+icore(ii4)*no2
|
|
ii4=ii4+1
|
|
iostral=icore(ii4)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
call matmul11(wnew(nvstrbe+iabs(iostral)*nn4),
|
|
$wold(ioo),v,nn4,nsuml,isgnoal)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
else
|
|
do noccoldsymb=1,nnir
|
|
noccnewsymb=mult(noccoldsymb,ntampsymob)
|
|
nsyma3=mult(noccnewsymb,nsym22)
|
|
coupwobe=icnob(noccoldsymb,ntampsymob)-1
|
|
nampob=nampva+noccnewsymb*nr2
|
|
nsumob=nsumv1+noccoldsymb*ir4
|
|
ii3=coupwobe+icore(coupwobe+ioabe)
|
|
do ioobe=1,icore(coupwobe+noab)
|
|
ii3=ii3+1
|
|
iioobe=(icore(ii3)-1)*no3
|
|
ii3=ii3+1
|
|
iostrbe=icore(ii3)
|
|
isgnobe=isgnval*isign(1,iostrbe)
|
|
iostrbe=iabs(iostrbe)-1
|
|
do noccoldsyma=1,nnir
|
|
noccnewsyma=mult(noccoldsyma,ntampsymoa)
|
|
isymi=mult(iconj(noccnewsyma),nsyma3)
|
|
noccoldall=nstooa(noccoldsyma)
|
|
noccnewall=nstnoa(noccnewsyma)
|
|
coupwoal=icnoa(noccoldsyma,ntampsymoa)-1
|
|
nn4=incnew(isymi)
|
|
no4=nn4*nsuml
|
|
no2=no3*no4
|
|
nivobe=iwa(nsumob+noccoldsyma*ir3+isymi*ir6)+
|
|
$(iioobe*noccoldall+iivob2)*no4-no2
|
|
nvstrbe=iwan(nampob+noccnewsyma*nnir+isymi)+
|
|
$(iostrbe*noccnewall-1)*nn4
|
|
ii4=coupwoal+icore(coupwoal+ioaal)
|
|
do iooal=1,icore(coupwoal+noaa)
|
|
ii4=ii4+1
|
|
ioo=nivobe+icore(ii4)*no2
|
|
ii4=ii4+1
|
|
iostral=icore(ii4)
|
|
isgnoal=isgnobe*isign(1,iostral)
|
|
call matmul1(wnew(nvstrbe+iabs(iostral)*nn4),
|
|
$wold(ioo),v,nn4,nsuml,isgnoal)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
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
|
|
call getadd(file,irec+ire,v,ile,ssg)
|
|
else
|
|
call wiadd(iadd,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,ile)
|
|
call getlst(file,irec+ire,v,ile)
|
|
c write(6,*) 'imrmem',file,irec+ire,irec,ire
|
|
c write(6,"(4f14.8)") (v(i),i=1,ile)
|
|
call smultp(v,ile,ssg)
|
|
endif
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine getadd(ifile,irec,vec,ilength,ssg)
|
|
************************************************************************
|
|
* This subroutine reads from a direct access file *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer ifile,irec,ilength,isg,nrec,i,j,ifile1
|
|
real*8 vec(*),ssg
|
|
C
|
|
if(ilength.eq.0) return
|
|
if(ifile.ne.intfile.and.irec.ge.recmax) then
|
|
write(iout,*) 'Unable to handle unit ',ifile, '!'
|
|
write(iout,*) 'File is too large!'
|
|
endif
|
|
j=mod(irec,recmax)
|
|
ifile1=ifile+(irec-j)/recmax
|
|
nrec=0
|
|
1007 continue
|
|
if(j.gt.recmax) then
|
|
ifile1=ifile1+1
|
|
j=1
|
|
endif
|
|
read(ifile1,rec=j) ibuf
|
|
C$OMP PARALLEL DO
|
|
C$OMP& DEFAULT(SHARED)
|
|
do i=1,min(ibufln,ilength-nrec)
|
|
vec(nrec+i)=vec(nrec+i)+ssg*ibuf(i)
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
nrec=nrec+ibufln
|
|
j=j+1
|
|
if(nrec.lt.ilength) goto 1007
|
|
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,isp)
|
|
************************************************************************
|
|
* 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
|
|
integer isp(nirmax,nirmax,2)
|
|
C
|
|
nlen=0
|
|
do ir=1,nir
|
|
isum=1
|
|
do ira=1,nir
|
|
isymi=isp(ir,ira,1)
|
|
isyma=isp(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 smult(v,n,s)
|
|
************************************************************************
|
|
* v = s * v *
|
|
************************************************************************
|
|
implicit none
|
|
integer n,i
|
|
real*8 v(*),s
|
|
C
|
|
if(s.eq.1.d0) return
|
|
do i=1,n
|
|
v(i)=s*v(i)
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine smultp(v,n,s)
|
|
************************************************************************
|
|
* v = s * v (parallelized) *
|
|
************************************************************************
|
|
implicit none
|
|
integer n,i
|
|
real*8 v(*),s
|
|
C
|
|
if(s.eq.1.d0) return
|
|
C$OMP PARALLEL DO
|
|
C$OMP& DEFAULT(SHARED)
|
|
do i=1,n
|
|
v(i)=s*v(i)
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine tread(itad,namplen,iampad,lcalc,nampvirtalact,
|
|
$nampvirtbeact,nampoccalact,nampoccbeact,nampvirtal,nam)
|
|
************************************************************************
|
|
* Return 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 wrtfile(i,file1,nconf,trec,nmax,nactm,icadd,v,lc,lcs,
|
|
$vscr,tarec,ita,nnir,nnewsym,isympv,isympo,nstr)
|
|
************************************************************************
|
|
* Write intermediate to files *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nactm,i,m,n,k,file1,file2,ii,nn,nnir,ir1,nnewsym,irao
|
|
integer nconf(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),ira
|
|
integer trec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax),irav
|
|
integer icadd(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer iactv,iacto,iactva,iactoa,iactvb,iactob,nvirtnewsyma
|
|
integer tarec(0:nactm,0:nactm,0:nactm,0:nactm,0:nmax,0:nmax)
|
|
integer ita(nnir,nnir,nnir,nnir),nvirtnewsym,noccnewsym,inewadd
|
|
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 nstr(nnir,0:nactm,0:nmax,4),nvirtnewsymb,nvirtnewbelen
|
|
integer noccnewsyma,noccnewsymb,noccnewbelen,nn1,nvirtnewallen
|
|
real*8 v(*),vscr(*)
|
|
logical lc,lcs
|
|
C
|
|
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
|
|
ii=nconf(iactva,iactvb,iactoa,iactob,i1,i)
|
|
n= trec(iactva,iactvb,iactoa,iactob,i1,i)
|
|
nn=icadd(iactva,iactvb,iactoa,iactob,i1,i)
|
|
if(ii.gt.0) then
|
|
if(lc.and.lcs.and.i1.eq.i-i1.and.iactva.eq.iactvb
|
|
$.and.iactoa.eq.iactob) then
|
|
read(tafile,rec=tarec(iactva,iactvb,iactoa,iactob,i1,i)) ita
|
|
C
|
|
do ira=1,nir
|
|
nvirtnewsym=csympair(nnewsym,ira,1)
|
|
noccnewsym=csympair(nnewsym,ira,2)
|
|
do irav=1,isympv(0,nvirtnewsym,iactva,iactvb,i1,i-i1,1)
|
|
nvirtnewsyma=isympv(irav,nvirtnewsym,iactva,iactvb,i1,i-i1,1)
|
|
nvirtnewallen=nstr(nvirtnewsyma,iactva,i1,1)
|
|
nvirtnewsymb=isympv(irav,nvirtnewsym,iactva,iactvb,i1,i-i1,2)
|
|
nvirtnewbelen=nstr(nvirtnewsymb,iactvb,i-i1,2)
|
|
nvirtnewlen=nvirtnewallen*nvirtnewbelen
|
|
do irao=1,isympo(0,noccnewsym,iactoa,iactob,i1,i-i1,1)
|
|
noccnewsyma=isympo(irao,noccnewsym,iactoa,iactob,i1,i-i1,1)
|
|
noccnewallen=nstr(noccnewsyma,iactoa,i1,3)
|
|
noccnewsymb=isympo(irao,noccnewsym,iactoa,iactob,i1,i-i1,2)
|
|
noccnewbelen=nstr(noccnewsymb,iactob,i-i1,4)
|
|
noccnewlen=noccnewallen*noccnewbelen
|
|
nn1=nvirtnewlen*noccnewlen
|
|
if(nn1.gt.0.and.(nvirtnewsyma.lt.nvirtnewsymb.or.
|
|
$(nvirtnewsyma.eq.nvirtnewsymb.and.noccnewsyma.lt.noccnewsymb)))
|
|
$then
|
|
inewadd=ita(nvirtnewsyma,nvirtnewsymb,noccnewsyma,noccnewsymb)
|
|
k =ita(nvirtnewsymb,nvirtnewsyma,noccnewsymb,noccnewsyma)
|
|
call transpcs(v(nn-1+inewadd),v(nn-1+k),nvirtnewallen,
|
|
$nvirtnewbelen,noccnewallen,noccnewbelen)
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
else
|
|
if(lc) then
|
|
call transpc(nstr,nmax,nir,isympv,isympo,ita,tarec,v(nn),vscr,
|
|
$i1,i-i1,i1,i-i1,i,iactva,iactvb,iactoa,iactob,nactmax,1)
|
|
call getput(file1,
|
|
$trec(iactvb,iactva,iactob,iactoa,i-i1,i),vscr,ii)
|
|
endif
|
|
endif
|
|
call getput(file1,n,v(nn),ii)
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine scal2(i,sum,file1,file2,nconf,trec,nmax,nactm)
|
|
************************************************************************
|
|
* Calculate scalar product of two vectors which are read from files *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nactm,i,m,n,k,file1,file2,ii
|
|
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
|
|
real*8 sum
|
|
C
|
|
sum=0.d0
|
|
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
|
|
ii=nconf(iactva,iactvb,iactoa,iactob,i1,i)
|
|
n= trec(iactva,iactvb,iactoa,iactob,i1,i)-1
|
|
if(ii.gt.0) then
|
|
m=ibufln
|
|
do k=1,ii
|
|
if(m.eq.ibufln) then
|
|
m=0
|
|
n=n+1
|
|
read(file1,rec=n) ibuf
|
|
read(file2,rec=n) ibuf1
|
|
endif
|
|
m=m+1
|
|
sum=sum+ibuf1(m)*ibuf(m)
|
|
enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine ddenom(i,file1,file2,nconf,trec,v,nmax,nactm)
|
|
************************************************************************
|
|
* Devision by energy denominators *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer i,nmax,nactm,j,k,nn,file1,file2
|
|
integer iactv,iacto,iactva,iactvb,iactoa,iactob
|
|
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)
|
|
real*8 v(*)
|
|
C
|
|
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
|
|
nn=nconf(iactva,iactvb,iactoa,iactob,i1,i)
|
|
k= trec(iactva,iactvb,iactoa,iactob,i1,i)
|
|
if(nn.gt.0) then
|
|
call getlst(file1,k,v(1),nn)
|
|
call getlst(mpfile,k,v(nn+1),nn)
|
|
C$OMP PARALLEL DO
|
|
C$OMP& DEFAULT(SHARED)
|
|
do j=1,nn
|
|
v(j)=v(j)/v(nn+j)
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
call putlst(file2,k,v(1),nn)
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine slengt8(nmax,nstr,nnir,isympv,isympo,nactm,isum,ssym,
|
|
$nn1,nn2,nn3,nn4,nn5,nn6,nn7,nn8,isp)
|
|
************************************************************************
|
|
* 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 isp(nirmax,nirmax,2)
|
|
integer*8 isum,nn
|
|
C
|
|
isum=0
|
|
do ira=1,nir
|
|
isymav=isp(ssym,ira,1)
|
|
isymao=isp(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
|
|
************************************************************************
|
|
subroutine coninpp(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,arca,arcb,nnr,nnn,iuca,iucb,corr,rank,
|
|
$lcalcsn,lhgn,iqf,ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,
|
|
$nr5,xyzsize,wnew,nem,vift,vmscr,ndl,iconj,locno,facta,factb,nal,
|
|
$nbe,umat,absa,absb,mpisize,mpicount,lf12,tscalea,tscaleb)
|
|
************************************************************************
|
|
* This subroutine initializes variables for contractions (for OMP) *
|
|
************************************************************************
|
|
implicit none
|
|
integer nstnva,nstnvb,nstnoa,nstnob,nnir,nnewsym,iwan,nampsym,nb
|
|
integer nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,mosym(nb,4),mscr
|
|
integer mfst1,ninter1,mfst2,ninter2,ift,ntnewlen,nsyma,nsymb,icdo
|
|
integer iuca(nval),iucb(nvbe),ileva,ilevb,iorba,iorbb,iqf,ioffs
|
|
integer nnr,nnn,arca(0:nva,0:nval),arcb(0:nvb,0:nvbe),nsyma11
|
|
integer nsyma22,i,j,nirmax,icore,mult(nirmax,nirmax),op,nem,ndl
|
|
integer nrr,nr2,nr3,nr4,nr5,rank,xyzcount,xyzsize,iconj,thrd
|
|
integer locno,nal,nbe,absa(*),absb(*),mpicount,mpisize
|
|
real*8 facta,factb,umat(*),tscalea(nal),tscaleb(nbe)
|
|
real*8 v,faaal(*),faabe(*),fiial(*),fiibe(*),corr,dcore
|
|
real*8 sumva,sumvb
|
|
logical lcalcsn,lhgn,lf12
|
|
#if defined (OMP)
|
|
real*8 wnew(nem,0:xyzsize),vift(iqf*ntnewlen,0:xyzsize)
|
|
real*8 vmscr(ndl,0:xyzsize)
|
|
integer OMP_GET_THREAD_NUM
|
|
call dfillzero(wnew(1,1),xyzsize*nem)
|
|
#else
|
|
real*8 wnew(nem),vift(iqf*ntnewlen),vmscr(ndl)
|
|
#endif
|
|
if(ninter1.eq.0) return
|
|
thrd=0
|
|
C
|
|
C$OMP PARALLEL
|
|
C$OMP& DEFAULT(NONE)
|
|
C$OMP& PRIVATE(iuca,iucb)
|
|
C$OMP& PRIVATE(thrd,iorba,iorbb,ileva,ilevb,sumva,sumvb,nsyma,nsymb)
|
|
C$OMP& PRIVATE(xyzcount,nsyma11,nsyma22)
|
|
C$OMP& SHARED(mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,nnewsym,iwan,nem)
|
|
C$OMP& SHARED(nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,mosym)
|
|
C$OMP& SHARED(nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial)
|
|
C$OMP& SHARED(fiibe,ift,ntnewlen,arca,arcb,nnr,nnn,lcalcsn,lhgn,iqf)
|
|
C$OMP& SHARED(ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank)
|
|
C$OMP& SHARED(v,iconj,locno,facta,factb,nal,nbe,umat,absa,absb)
|
|
C$OMP& SHARED(wnew,vift,vmscr,mpisize,mpicount,lf12,tscalea,tscaleb)
|
|
C$OMP& REDUCTION(+:corr)
|
|
#if defined (OMP)
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
#endif
|
|
#if defined (MPI) || defined (OMP)
|
|
xyzcount=0
|
|
#endif
|
|
iorbb=0
|
|
ilevb=0
|
|
sumvb=0.d0
|
|
nsymb=1
|
|
call opstrb1(v,mscr,nstnva,nstnvb,nstnoa,nstnob,nnir,
|
|
$nnewsym,iwan,nampsym,nval,nvbe,noal,nobe,istroa,istrob,nva,nvb,
|
|
$mosym,nb,icdo,mfst1,ninter1,mfst2,ninter2,faaal,faabe,fiial,fiibe,
|
|
$ift,ntnewlen,sumva,sumvb,iorba,iorbb,ileva,ilevb,arca,arcb,nsyma,
|
|
$nsymb,nsyma11,nsyma22,nnr,nnn,iuca,iucb,corr,lcalcsn,lhgn,iqf,
|
|
$ioffs,icore,mult,nirmax,op,dcore,nrr,nr2,nr3,nr4,nr5,rank,thrd,
|
|
#if defined (OMP)
|
|
$xyzcount,vift(1,thrd),wnew(1,thrd),vmscr(1,thrd),iconj,
|
|
$locno,facta,factb,
|
|
#else
|
|
$xyzcount,vift,wnew,vmscr,iconj,locno,facta,factb,
|
|
#endif
|
|
$nal,nbe,umat,absa,absb,mpicount,mpisize,lf12,tscalea,tscaleb)
|
|
C$OMP END PARALLEL
|
|
#if defined (OMP)
|
|
call ompred(wnew,nem)
|
|
#endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine scal3(i,sum,c3,c4,file1,file2,nconf,trec,nmax,nactm,
|
|
$nstr,intrec,imed,v,norm,isympv,isympo,ita,tarec,iwa,isa,isw,istr,
|
|
$test,wspcb,wspca,wsmax,intn,ntcase,earec,econf,erec,denrec,trec2,
|
|
$erec2,tcase,itypa,itypb,imedsyma,imedsymb,l2map,ioffs,scspe,lcvs,
|
|
$ncvs,cvsorb,spsht,absind,strec)
|
|
************************************************************************
|
|
* Calculate scalar product of two vectors which are read from files *
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer nmax,nactm,i,m,n,k,file1,file2,ii,nconf,trec,iactv,iacto
|
|
integer iactva,iactoa,iactvb,iactob,nstr,intrec,imed,isympv,ncvs
|
|
integer isympo,ita,tarec,iwa,isa,isw,istr,wspcb,wspca,wsmax,cvsorb
|
|
integer intn,ntcase,earec,econf,erec,denrec,trec2,erec2,tcase
|
|
integer itypa,itypb,imedsyma,imedsymb,l2map,ioffs,spsht,absind
|
|
integer strec
|
|
real*8 sum,sum1,v,c3,c4,norm,test,scspe
|
|
logical lcvs
|
|
C
|
|
call scal2(i,sum,file1,file2,nconf,trec,nmax,nactm)
|
|
c3=0.d0
|
|
c4=0.d0
|
|
if(lfvo.and.op.ge.4) write(iout,
|
|
$"(' T_',i1,'^+ contribution [au]: ',f22.12)")i,sum
|
|
C Extra diagrams for ROHF
|
|
if(lfvo.and.op.ge.4.and.i.eq.3) then
|
|
C T_1^+ * T_2^+
|
|
call savevec(file1,tfile,trecmax,0,0)
|
|
rohfdiag=1
|
|
pertroute=2+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,ndiis,ioffs,scspe,lcvs,
|
|
$ncvs,cvsorb,spsht,absind,strec,0)
|
|
rohfdiag=0
|
|
call scal2(2,c3,scrfile1,file2,nconf,trec,nmax,nactm)
|
|
write(iout,
|
|
$"(' T_1^+ * T_2^+ contribution [au]: ',f22.12)") c3
|
|
C T_1^+ * <ab||ij>
|
|
call ddenom(3,tfile,tfile,nconf,trec,v,nmax,nactm)
|
|
pertroute=1+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,ndiis,ioffs,scspe,lcvs,
|
|
$ncvs,cvsorb,spsht,absind,strec,0)
|
|
call scal2(1,c4,scrfile1,file2,nconf,trec,nmax,nactm)
|
|
write(iout,
|
|
$"(' T_1^+ * <ab||ij> contribution [au]: ',f22.12)") c4
|
|
C T_2^+ * f_ai
|
|
rohfdiag=2
|
|
pertroute=2+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,ndiis,ioffs,scspe,lcvs,
|
|
$ncvs,cvsorb,spsht,absind,strec,0)
|
|
rohfdiag=0
|
|
call scal2(2,sum1,scrfile1,file2,nconf,trec,nmax,nactm)
|
|
c4=c4+sum1
|
|
write(iout,
|
|
$"(' T_2^+ * f_ai contribution [au]: ',f22.12)") sum1
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|