mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-18 12:40:58 +01:00
13271 lines
390 KiB
Fortran
13271 lines
390 KiB
Fortran
************************************************************************
|
|
subroutine uccsdpt(iimem,imem,maxcor,icore,dcore,irecln,iibufln,
|
|
$ ibufln,gbasfile,ifcfile,diisfile,errfile,ccmem,
|
|
$ iout,nbsetmax)
|
|
************************************************************************
|
|
* Performs open-shell CCSD(T) calculations. *
|
|
************************************************************************
|
|
implicit none
|
|
integer nb,i,nal,nval,nvbe,dblalloc,imem1,ibmat,ifa,ifb,diskspace
|
|
integer ita1,itb1,ita2,itb2,itm2,inta1,intb1,inta2,intb2,intm2,nbe
|
|
integer ifaae,ifbae,ifami,ifbmi,ifame,ifbme,memwmebj,memwmnij
|
|
integer memwabmnij,memwbamebj,memwabbamebj,ifaadr,nqmin,floor
|
|
integer nfa,nfb,intalloc,ifbadr,irecaadr,irecbadr,ifmadr,irecmadr
|
|
integer nfm,lt,incore,memdflist,ccmaxit,verb,iea,ieb,q,minmem
|
|
integer incoret,irecjab,j,naobasis,nbfread(10),icore(*),ibufln
|
|
integer gbasfile,iimem,imem,irecln,maxcor,nvirt,nbasis,nocc
|
|
integer dfnbasis,locno,ncore,ifcfile,iout,errfile,diisfile,iibufln
|
|
integer ccmem(8),t_minmem,mem_used,mem_used_t
|
|
integer itscalea,itscaleb,iepba,nbsetmax,nbf(nbsetmax)
|
|
integer iepaa,iepbb,iepab,read_ied_from_localccrestart
|
|
real*8 eccs,eccp,ecabs,tfact,ets,emp2,rcor
|
|
real*8 et,dlog10,ltol,dminmem,tprtol,itol,dcore(*),ecc,eref,tol
|
|
character*3 uminmem,qro
|
|
character*4 cctol,dfbasis_cor,cscr4,localcc,talg
|
|
character*5 scftype,scftype_print,ovirt
|
|
character*6 core,ied_str
|
|
character*8 dfintran,ccmxit,ccsdalg,cscr8
|
|
character*13 rohftype
|
|
character*16 calctype,restartfile,cscr16
|
|
common/memcom/ imem1
|
|
logical error,dfcalc,restart,ltpr,lcorr,lf12,lf12s,lmp3,lxsp
|
|
|
|
c local
|
|
real*8 emp2full,eppl_correction,emp2_correction,et_corrected
|
|
real*8 cmp2ss,cmp2os,cmp3,eccsdpt
|
|
integer iuia,iuib,iquad,icmoa,icmob,nquad,iscr,dfnbasis_full
|
|
integer is1,is2,is3,ios,dhyb,ied
|
|
character*5 ovirtrun
|
|
character*8 cscr
|
|
character*15 met
|
|
character*16 naf,laptol,tprint
|
|
logical indocc,lnaf,lno,qscale_ccsd,qscale_pt
|
|
|
|
error=.false.
|
|
c call mrccini
|
|
C Allocate memory
|
|
c call memalloc
|
|
write(iout,*)
|
|
|
|
c {{{ Setting calculation parameters
|
|
c DF calculation?
|
|
call getkey('dfbasis_cor',11,dfbasis_cor,4)
|
|
dfcalc=.false.
|
|
if (dfbasis_cor.ne.'none') dfcalc=.true.
|
|
|
|
c Local calculation?
|
|
call getkey('localcc',7,localcc,4)
|
|
|
|
call getkey('dfintran',8,dfintran,8)
|
|
|
|
call getkey('calc',4,calctype,16)
|
|
|
|
c
|
|
call lowercase(calctype,calctype,16)
|
|
if(trim(calctype).eq.'mp3') then
|
|
lmp3 = .true.
|
|
else
|
|
lmp3 = .false.
|
|
end if
|
|
call getvar('dhyb ',dhyb)
|
|
if(dhyb .eq. 3) then
|
|
c double-hybrid DFT
|
|
call getvar('cmp2s ',cmp2os)
|
|
call getvar('cmp2t ',cmp2ss)
|
|
call getvar('cmp3 ',cmp3)
|
|
end if
|
|
|
|
c F12
|
|
lf12=.false.
|
|
if(trim(calctype).eq.'ccsd(t)-f12') then
|
|
calctype='ccsd(t) '
|
|
lf12=.true.
|
|
else if(trim(calctype).eq.'ccsd-f12') then
|
|
calctype='ccsd '
|
|
lf12=.true.
|
|
endif
|
|
c if(lf12) then !szemet
|
|
c lf12s=.true. !szemet
|
|
c lf12=.false. !szemet
|
|
c endif !szemet
|
|
|
|
c call lowercase(calctype,calctype,16)
|
|
|
|
c (T) algorithm?
|
|
if (trim(calctype).eq.'ccsd(t)') call getkey('talg',4,talg,4)
|
|
c if (localcc.ne.'off ') talg='lapl'
|
|
if (localcc.eq.'off '.and.talg.eq.'lapl') then
|
|
c $ (talg.ne.'occ '.and.talg.ne.'virt')) then
|
|
c write(iout,"(' Only talg=occ is implemented!')")
|
|
write(iout,"(' talg=lapl is not implemented!')")
|
|
write(iout,"(' Warning: switching to talg=occ!')")
|
|
talg='occ '
|
|
endif
|
|
|
|
c Setting several keywords and variables
|
|
call getkey('cctol',5,cctol,4)
|
|
read(cctol,*) i
|
|
tol=10.d0**(-i)
|
|
call getkey('scftype',7,scftype,5)
|
|
scftype_print=scftype
|
|
call getkey('qro',3,qro,3)
|
|
if (qro.eq.'on ') scftype_print='qro '
|
|
call getkey('rohftype',8,rohftype,13)
|
|
call getkey('ccmaxit',7,ccmxit,8)
|
|
read(ccmxit,*) ccmaxit
|
|
if(lmp3) ccmaxit = 1
|
|
call getkey('verbosity',9,cscr4,4)
|
|
read(cscr4,"(i4)") verb
|
|
call getkey('ccsdalg',7,ccsdalg,8)
|
|
call getvar('ncore ',ncore)
|
|
call getkey('core',4,core,6) ! Frozen core?
|
|
if(core.eq.'corr ') ncore=0
|
|
call getvar('eref ',eref)
|
|
if (trim(localcc).ne.'off') then
|
|
call getkey('lccrest',7,cscr8,8)
|
|
call getkey('lccoporder',10,cscr16,16) ! Frozen core?
|
|
! Local CC calculation, read domain number to be able to name UCCSDREST file
|
|
ied = read_ied_from_localccrestart(trim(cscr16).eq.'lccfirst')
|
|
if (trim(cscr16).eq.'trffirst') ied=ied+1 ! Previous, completed domain is given in file
|
|
else
|
|
ied=-1
|
|
endif ! localcc
|
|
|
|
call getkey('ccsdrest',8,cscr4,4)
|
|
restart=.false.
|
|
if (trim(cscr4).eq.'ccsd') then
|
|
if (ied.gt.0) then
|
|
write(ied_str,"(i6)") ied
|
|
restartfile='UCCSDREST.' // adjustl(trim(ied_str))
|
|
else
|
|
restartfile='UCCSDREST'
|
|
endif !ied
|
|
inquire(file=restartfile,exist=restart)
|
|
if (.not.restart) then
|
|
write(iout,"(' WARNING: restart keyword is set but there is no')")
|
|
write(iout,"(9x,' restart file: ',16a)") restartfile
|
|
write(iout,"(9x,' Starting new iteration!')")
|
|
endif
|
|
endif
|
|
call getkey('tprint',6,tprint,16)
|
|
if(tprint.ne.'off ') then
|
|
ltpr=.true.
|
|
read(tprint,*) tprtol
|
|
else
|
|
ltpr=.false.
|
|
tprtol=0.d0
|
|
endif
|
|
|
|
call uppercase(scftype,scftype,5)
|
|
if (verb.gt.2) write(iout,*) trim(scftype) //
|
|
&' reference wavefunction.'
|
|
call lowercase(scftype,scftype,5)
|
|
|
|
c Setting parameters of the basis
|
|
rewind(55)
|
|
c NAF?
|
|
call getkey('naf_cor',7,naf,16)
|
|
c NO?
|
|
call getkey('ovirt',5,ovirtrun,5)
|
|
lno = (ovirtrun.eq.'mp2 ' .or. ovirtrun.eq.'ppl ')
|
|
$ .and. localcc.eq.'off ' .and.
|
|
$ dfintran.eq.'drpa '
|
|
lnaf = naf.ne.'off ' .and. localcc.eq.'off '
|
|
lcorr = lno .or. lnaf
|
|
if((lno.or.lnaf) .and. localcc.eq.'off ' .and.
|
|
$ dfintran.eq.'drpa ') then
|
|
open(ifcfile, file = 'iface', status = 'old')
|
|
rewind(ifcfile)
|
|
read(ifcfile, *)
|
|
met = ' '
|
|
do while(met .ne. 'MP2 ')
|
|
read(ifcfile, 7596, iostat = ios)
|
|
$ cscr, met, is1, is2, is3, emp2full
|
|
if(ios .ne. 0) then
|
|
write(iout, *)
|
|
$ 'Error: MP2 energy not found in file iface!'
|
|
call mrccend(1)
|
|
end if
|
|
end do
|
|
close(ifcfile)
|
|
end if
|
|
7596 format(a8,1x,a15,1x,3(i2,1x),1pe23.15)
|
|
if(lf12) then
|
|
qscale_ccsd = .false.
|
|
qscale_pt = .true.
|
|
else if(trim(ovirtrun).eq.'ppl') then !lno) then
|
|
qscale_ccsd = .true.
|
|
qscale_pt = .true.
|
|
else if(lno.or.lnaf) then
|
|
qscale_ccsd = .false.
|
|
qscale_pt = .true.
|
|
else
|
|
qscale_ccsd = .false.
|
|
qscale_pt = .false.
|
|
end if
|
|
eppl_correction = 0.d0
|
|
open(ifcfile ,status='unknown',file='iface',position='append')
|
|
|
|
itscalea=imem
|
|
itscaleb=imem
|
|
iepaa=imem
|
|
iepbb=imem
|
|
iepab=imem
|
|
iepba=imem
|
|
|
|
write(iout,'(x)',advance='no')
|
|
c If local calculation
|
|
if (localcc.ne.'off ') then
|
|
locno=3
|
|
c Reading basis dimensions from fort.55
|
|
read(55,*) nb,i,nal,i,dfnbasis
|
|
dfnbasis_full = dfnbasis
|
|
nval=nb-nal
|
|
read(55,*) !irrep
|
|
read(55,*) !symm borders
|
|
read(55,*)
|
|
read(55,*)
|
|
read(55,*)
|
|
do i=1,nb
|
|
do j=1,nb
|
|
read(55,*) !focka
|
|
enddo
|
|
enddo
|
|
read(55,*) !nuc repulsion
|
|
read(55,*) nbe,nvbe,i
|
|
c Checking if the center LMO is doubly occupied
|
|
indocc=.true.
|
|
if (i.eq.0) indocc=.false.
|
|
c naf='off '
|
|
c Setting parameters for Laplace-transformed (T) correction
|
|
if (localcc.ne.'off '.and.(talg.eq.'lapl'.or.talg.eq.'lato'))then
|
|
call getkey('laptol',6,laptol,16)
|
|
read(laptol,*) ltol
|
|
nqmin=1
|
|
if (ltol.lt.1.d0) nqmin=floor(-dlog10(ltol))+1
|
|
c nqmin=1 !szemet
|
|
endif !localcc, talg=lapl
|
|
|
|
write(iout,"('Local ')",advance='no')
|
|
|
|
c If canonical calculation
|
|
else !localcc=off
|
|
c Read basis dimensions
|
|
call getkey('ovirt',5,ovirt,5)
|
|
locno=0
|
|
if(dfintran .eq. 'ovirt') then
|
|
call getvar('nbf ',nbf)
|
|
call getvar('nal ',nal)
|
|
call getvar('nbe ',nbe)
|
|
nocc=nal+nbe-2*ncore
|
|
nb=nbf(1)-ncore
|
|
if(ovirt.ne.'off ') read(55,*) nb,nocc
|
|
nbasis=2*nb
|
|
nvirt=nbasis-nocc
|
|
nal=nal-ncore
|
|
nbe=nbe-ncore
|
|
nval=nb-nal
|
|
nvbe=nb-nbe
|
|
naobasis=nbf(1)
|
|
dfnbasis=nbf(3)
|
|
|
|
else ! dfintran=drpa
|
|
open(55, file = '55')
|
|
read(55,*) nb, nocc, iscr, iscr, dfnbasis, nal, nbe, nval, nvbe
|
|
close(55)
|
|
|
|
call getvar('nbf ',nbf)
|
|
naobasis=nbf(1)
|
|
nbasis=2*nb
|
|
dfnbasis_full=nbf(3)
|
|
end if
|
|
|
|
itscalea=imem
|
|
itscaleb=imem
|
|
iepaa=imem
|
|
iepbb=imem
|
|
iepab=imem
|
|
iepba=imem
|
|
if(qscale_ccsd.or.qscale_pt) then
|
|
itscalea=dblalloc(nal)
|
|
itscaleb=dblalloc(nbe)
|
|
iepaa=dblalloc(nal*nal)
|
|
iepbb=dblalloc(nbe*nbe)
|
|
iepab=dblalloc(nal*nbe)
|
|
iepba=dblalloc(nal*nbe)
|
|
endif
|
|
|
|
if (verb.gt.2) then
|
|
if(lf12) then
|
|
write(iout,"('Explicitly correlated ')",advance='no')
|
|
else
|
|
write(iout,"('Canonical ')",advance='no')
|
|
endif
|
|
endif
|
|
|
|
endif !localcc
|
|
|
|
if(.not.dfcalc) dfnbasis=0
|
|
|
|
c Printing information about the calculation
|
|
if (dfcalc) write(iout,"('DF-')",advance='no')
|
|
|
|
call uppercase(calctype,calctype,16)
|
|
write(iout,"(2a)") trim(calctype) // ' calculation.'
|
|
call lowercase(calctype,calctype,16)
|
|
|
|
if (verb.gt.2) then
|
|
write(iout,"(' Number of correlated alpha electrons: ', i5)")
|
|
&nal
|
|
write(iout,"(' Number of correlated beta electrons: ', i5)")
|
|
&nbe
|
|
write(iout,"(' Number of virtual alpha orbitals: ', i5)")
|
|
&nval
|
|
write(iout,"(' Number of virtual beta orbitals: ', i5)")
|
|
&nvbe
|
|
if (dfcalc) then
|
|
write(iout,"(' Number of auxiliary basis functions: ', i5)")
|
|
&dfnbasis
|
|
endif
|
|
endif
|
|
call flush(6)
|
|
c }}}
|
|
|
|
c Memory needed for arrays stored in core
|
|
if (localcc.ne.'off ') then
|
|
incore=nal+nbe+2*(nval*nal+nvbe*nbe+nval*(nval-1)*nal*(nal-1)/4+
|
|
&nvbe*(nvbe-1)*nbe*(nbe-1)/4+nval*nvbe*nal*nbe)+(nal+nval)**2+
|
|
&(nbe+nvbe)**2+ccmaxit**2+nval**2+nvbe**2+nal**2+nbe**2+nal*nval+
|
|
&nvbe*nbe+nval+1+2*(nvbe+1)+(nval+1)*nval/2+2*((nvbe+1)*nvbe/2)
|
|
|
|
iuia=dblalloc(nal)
|
|
iuib=dblalloc(nbe)
|
|
|
|
else !localcc=off
|
|
incore=2*(nval*nal+nvbe*nbe+nval*(nval-1)*nal*(nal-1)/4+
|
|
&nvbe*(nvbe-1)*nbe*(nbe-1)/4+nval*nvbe*nal*nbe)+(nal+nval)**2+
|
|
&(nbe+nvbe)**2+ccmaxit**2+nval**2+nvbe**2+nal**2+nbe**2+nal*nval+
|
|
&nvbe*nbe+nval+1+2*(nvbe+1)+(nval+1)*nval/2+2*((nvbe+1)*nvbe/2)
|
|
|
|
iuia=1
|
|
iuib=1
|
|
|
|
endif !localcc
|
|
|
|
c Size of every T amplitude
|
|
lt=nval*nal+nvbe*nbe+nval*(nval-1)*nal*(nal-1)/4+
|
|
&nvbe*(nvbe-1)*nbe*(nbe-1)/4+nval*nvbe*nal*nbe
|
|
|
|
c {{{ Checking the allocated memory
|
|
c walmnij
|
|
call memcheck(memwmnij(nal,nval),maxcor-imem+imem1-incore,iout,
|
|
&error)
|
|
c wbemnij
|
|
call memcheck(memwmnij(nbe,nvbe),maxcor-imem+imem1-incore,iout,
|
|
&error)
|
|
c wabmnij
|
|
call memcheck(memwabmnij(nal,nval,nbe,nvbe),
|
|
&maxcor-imem+imem1-incore,iout,error)
|
|
c walmebj
|
|
call memcheck(memwmebj(nal,nval,nbe,nvbe),
|
|
&maxcor-imem+imem1-incore,iout,error)
|
|
c wbemebj
|
|
call memcheck(memwmebj(nbe,nvbe,nal,nval),
|
|
&maxcor-imem+imem1-incore,iout,error)
|
|
c wbamebj
|
|
call memcheck(memwbamebj(nal,nval,nbe,nvbe),
|
|
&maxcor-imem+imem1-incore,iout,error)
|
|
c wabmebj
|
|
call memcheck(memwbamebj(nbe,nvbe,nal,nval),
|
|
&maxcor-imem+imem1-incore,iout,error)
|
|
c wabbamebj
|
|
call memcheck(memwabbamebj(nal,nval,nbe,nvbe),
|
|
&maxcor-imem+imem1-incore,iout,error)
|
|
c wbaabmebj
|
|
call memcheck(memwabbamebj(nbe,nvbe,nal,nval),
|
|
&maxcor-imem+imem1-incore,iout,error)
|
|
c Allocating memory address arrays
|
|
ifaadr=intalloc(nval+1)
|
|
ifbadr=intalloc(nvbe+1)
|
|
ifmadr=intalloc(nvbe+1)
|
|
minmem=max(memwabbamebj(nbe,nvbe,nal,nval),
|
|
& memwabbamebj(nal,nval,nbe,nvbe),
|
|
& memwbamebj(nbe,nvbe,nal,nval),
|
|
& memwbamebj(nal,nval,nbe,nvbe),
|
|
& memwmebj(nbe,nvbe,nal,nval),
|
|
& memwmebj(nal,nval,nbe,nvbe),
|
|
& memwabmnij(nal,nval,nbe,nvbe),
|
|
& memwmnij(nbe,nvbe),
|
|
& memwmnij(nal,nval))
|
|
c All Wabef spin cases
|
|
call minmemnf(nal,nbe,nval,nvbe,icore(ifaadr),icore(ifbadr),
|
|
&icore(ifmadr),dfnbasis,minmem,ccsdalg)
|
|
c DF assembly
|
|
if (dfcalc) then
|
|
minmem=max(memdflist(nal,nval,nbe,nvbe,dfnbasis,
|
|
&icore(ifaadr),icore(ifbadr),icore(ifmadr),nval,nvbe,nvbe,'x',
|
|
&ccsdalg),minmem+incore)
|
|
else
|
|
minmem=minmem+incore
|
|
endif
|
|
c {{{ Calculating required disk space
|
|
diskspace=nval*(nval-1)*nal*(nal-1)/4 !abijaa
|
|
& +nvbe*(nvbe-1)*nbe*(nbe-1)/4 !abijbb
|
|
& +nval*nvbe*nal*nbe !abijab
|
|
& +nval*nal**2*(nal-1)/2 !aijkaa
|
|
& +nvbe*nbe**2*(nbe-1)/2 !aijkbb
|
|
& +nval*nbe**2*nal !aijkab
|
|
& +nvbe*nal**2*nbe !aijkba
|
|
& +nval**2*(nval-1)*nal/2 !iabcaa
|
|
& +nvbe**2*(nvbe-1)*nbe/2 !iabcbb
|
|
& +nbe*nval**2*nvbe !iabcba
|
|
& +nal*nvbe**2*nval !iabcab
|
|
& +nal**2*nval**2 !iabjaa
|
|
& +nbe**2*nvbe**2 !iabjbb
|
|
c & +2*nal*nbe*nval*nvbe !iabjab,iabjba
|
|
& +nal**2*nvbe**2 !iabjabba
|
|
& +nbe**2*nval**2 !iabjbaab
|
|
& +(nal*(nal-1)/2)*(nal*(nal-1)/2+1)/2 !ijklaa
|
|
& +(nbe*(nbe-1)/2)*(nbe*(nbe-1)/2+1)/2 !ijklab
|
|
& +nal*nbe*(nal*nbe+1)/2 !ijklab
|
|
if (ccsdalg.ne.'dfdirect') then
|
|
diskspace=diskspace+(nval*(nval-1)/2)*(nval*(nval-1)/2+1)/2 !abcdaa
|
|
& +(nvbe*(nvbe-1)/2)*(nvbe*(nvbe-1)/2+1)/2 !abcdbb
|
|
& +nval*nvbe*(nval*nvbe+1)/2 !abcdab
|
|
else !ccsdalg.eq.dfdirect
|
|
diskspace=diskspace+(nval*(nval+1)/2 !Jab
|
|
& +nvbe*(nvbe+1)/2 !JAB
|
|
& +nval*nal !Jai
|
|
& +nvbe*nbe !JAI
|
|
& +nal*(nal+1)/2 !Jij
|
|
& +nbe*(nbe+1)/2)*dfnbasis !JIJ
|
|
endif
|
|
c }}}
|
|
c Writing minimum memory and disk requirement
|
|
ccmem(5)=minmem
|
|
call memconv(minmem,dminmem,uminmem)
|
|
write(iout,"(' Minimal memory requirement for CCSD:',f7.2,3a)")
|
|
&dminmem,uminmem
|
|
call memcheck(minmem,maxcor-imem+imem1,iout,error)
|
|
if (error) call mrccend(1)
|
|
call memconv(diskspace,dminmem,uminmem)
|
|
write(iout,"(' Disk space requirement for CCSD:',4x,f7.2,3a)")
|
|
&dminmem,uminmem
|
|
c (T) correction
|
|
if (trim(calctype).eq.'ccsd(t)') then
|
|
if (talg.eq.'lapl') then
|
|
minmem = t_minmem(nal,nbe,nval,nvbe,4,dfnbasis,talg,
|
|
$ mem_used_t)
|
|
ccmem(8)=min(mem_used_t,maxcor-imem+imem1)
|
|
else
|
|
incoret=nval*nal+nvbe*nbe+nval*(nval-1)*nal*(nal-1)/4+
|
|
&nvbe*(nvbe-1)*nbe*(nbe-1)/4+nval*nvbe*nal*nbe+(nal+nval)**2+
|
|
&(nbe+nvbe)**2
|
|
c taaa
|
|
minmem=nval*nval*nal*(nal-1)/2+nval*(nval-1)*nal*nal/2+
|
|
&nval*nval*(nval-1)/2+nval*(nval-1)*(nval-2)/6+
|
|
&nval*(nval-1)*(nval-2)/6+nval*nal*nal*(nal-1)/2+
|
|
&nval*(nval-1)*nal*(nal-1)/4+3*nval*nval*(nval-1)/2
|
|
c tbbb
|
|
minmem=max(minmem,nvbe*nvbe*nbe*(nbe-1)/2+
|
|
&nvbe*(nvbe-1)*nbe*nbe/2+
|
|
&nvbe*nvbe*(nvbe-1)/2+nvbe*(nvbe-1)*(nvbe-2)/6+
|
|
&nvbe*(nvbe-1)*(nvbe-2)/6+nvbe*nbe*nbe*(nbe-1)/2+
|
|
&nvbe*(nvbe-1)*nbe*(nbe-1)/4+3*nvbe*nvbe*(nvbe-1)/2)
|
|
c tabb
|
|
minmem=max(minmem,nvbe*nvbe*nbe*(nbe-1)/2+
|
|
&nvbe*(nvbe-1)*nbe*nbe/2+nval*nvbe*nal*nbe+nvbe**2*nval+
|
|
&nval*nvbe*(nvbe-1)/2+nval*nvbe*(nvbe-1)/2+nvbe*nbe*nbe*(nbe-1)/2+
|
|
&nval*nbe*nal*nbe+nvbe*nal*nbe*nal+nvbe*(nvbe-1)*nbe*(nbe-1)/4+
|
|
&nval*nvbe*nal*nbe+nvbe**2*nval+
|
|
&2*(nvbe**2*(nvbe-1)/2+nval**2*nvbe))
|
|
c tbaa
|
|
minmem=max(minmem,nval*nval*nal*(nal-1)/2+
|
|
&nval*(nval-1)*nal*nal/2+nvbe*nval*nbe*nal+nval**2*nvbe+
|
|
&nvbe*nval*(nval-1)/2+nvbe*nval*(nval-1)/2+nval*nal*nal*(nal-1)/2+
|
|
&nvbe*nal*nbe*nal+nval*nbe*nal*nbe+nval*(nval-1)*nal*(nal-1)/4+
|
|
&nvbe*nval*nbe*nal+nval**2*nvbe+
|
|
&2*(nval**2*(nval-1)/2+nvbe**2*nval))
|
|
minmem=minmem+incoret
|
|
endif
|
|
call memconv(minmem,dminmem,uminmem)
|
|
ccmem(7)=minmem
|
|
write(iout,"(' Minimal memory requirement for (T):',1x,f7.2,3a)")
|
|
&dminmem,uminmem
|
|
call memcheck(minmem,maxcor-imem+imem1,iout,error)
|
|
if (error) call mrccend(1)
|
|
if (talg.ne.'lapl') then
|
|
diskspace=nval**2*(nval-1)*nal/2 !abciaa
|
|
& +nvbe**2*(nvbe-1)*nbe/2
|
|
& +nval*nvbe*nval*nbe*2
|
|
& +nvbe*nval*nvbe*nal*2
|
|
& +nval*nal**2*(nal-1)/2
|
|
& +nvbe*nbe**2*(nbe-1)/2
|
|
& +nval*nbe*nal*nbe
|
|
& +nvbe*nal*nbe*nal
|
|
& +nval*(nval-1)*nal*(nal-1)/4
|
|
& +nvbe*(nvbe-1)*nbe*(nbe-1)/4
|
|
& +nval*nvbe*nal*nbe
|
|
else !talg.eq.lapl
|
|
diskspace=(nval*(nval+1)/2 !Jab
|
|
& +nvbe*(nvbe+1)/2 !JAB
|
|
& +nval*nal !Jai
|
|
& +nvbe*nbe !JAI
|
|
& +nal*(nal+1)/2 !Jij
|
|
& +nbe*(nbe+1)/2)*dfnbasis !JIJ
|
|
endif
|
|
call memconv(diskspace,dminmem,uminmem)
|
|
write(iout,"(' Disk space requirement for (T):',5x,f7.2,3a)")
|
|
&dminmem,uminmem
|
|
endif
|
|
c }}}
|
|
|
|
c {{{ Calculating the batch sizes of Wabef intermediates
|
|
c Calculating nfa,nfb,nfm
|
|
mem_used=0
|
|
c walabef
|
|
if (nval.gt.1) then
|
|
call nfblc(nfa,icore(ifaadr),nal,nval,nbe,nvbe,iout,maxcor,imem,
|
|
&imem1,incore,dfnbasis,dfcalc,'a',error,ccsdalg,mem_used)
|
|
else
|
|
nfa=0
|
|
endif
|
|
c wbeabef
|
|
if (nvbe.gt.1) then
|
|
call nfblc(nfb,icore(ifbadr),nbe,nvbe,nal,nval,iout,maxcor,imem,
|
|
&imem1,incore,dfnbasis,dfcalc,'b',error,ccsdalg,mem_used)
|
|
else
|
|
nfb=0
|
|
endif
|
|
c wababef
|
|
if (nval.gt.0.and.nvbe.gt.0) then
|
|
call nfabblc(nfm,icore(ifmadr),nal,nval,nbe,nvbe,iout,maxcor,imem,
|
|
&imem1,incore,dfnbasis,dfcalc,'m',error,ccsdalg,mem_used)
|
|
else
|
|
nfm=0
|
|
endif
|
|
if (error) then
|
|
write(iout,*) 'Insufficient memory for CCSD iteration.
|
|
&Allocate more memory in MINP!'
|
|
call mrccend(1)
|
|
endif
|
|
ccmem(6)=mem_used
|
|
|
|
call intdealloc(ifaadr)
|
|
|
|
c Allocating recadr
|
|
if (nval.gt.1) then
|
|
irecaadr=intalloc(nfa*(nfa+1)/2)
|
|
endif
|
|
if (nvbe.gt.1) then
|
|
irecbadr=intalloc(nfb*(nfb+1)/2)
|
|
endif
|
|
if (nval.gt.0.and.nvbe.gt.0) then
|
|
irecmadr=intalloc(nfm*(nfm+1)/2)
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
irecjab=intalloc(nfm*(nfm+1)/2)
|
|
else
|
|
irecjab=irecmadr
|
|
endif
|
|
endif
|
|
c }}}
|
|
|
|
c {{{ Assembling DF integrals
|
|
if (dfcalc) then
|
|
|
|
c Allocating fadr
|
|
if (nval.gt.1) then
|
|
ifaadr=intalloc(nfa+1)
|
|
endif
|
|
if (nvbe.gt.1) then
|
|
ifbadr=intalloc(nfb+1)
|
|
endif
|
|
if (nval.gt.0.and.nvbe.gt.0) then
|
|
ifmadr=intalloc(nfm+1)
|
|
endif
|
|
|
|
c Building fadr
|
|
if (nval.gt.1) then
|
|
call fadrbld(nfa,nval,icore(ifaadr))
|
|
endif
|
|
if (nvbe.gt.1) then
|
|
call fadrbld(nfb,nvbe,icore(ifbadr))
|
|
endif
|
|
if (nval.gt.0.and.nvbe.gt.0) then
|
|
call fadrbld(nfm,nvbe,icore(ifmadr))
|
|
endif
|
|
|
|
c Checking the allocated memory for DF
|
|
call memcheck(memdflist(nal,nval,nbe,nvbe,dfnbasis_full,
|
|
&icore(ifaadr),icore(ifbadr),icore(ifmadr),nfa,nfb,nfm,'x',
|
|
&ccsdalg),maxcor-imem+imem1,iout,error)
|
|
|
|
if (error) then
|
|
write(iout,*) 'Insufficient memory for DF assembly.
|
|
&Allocate more memory in MINP!'
|
|
call mrccend(1)
|
|
endif
|
|
|
|
c DF integrals
|
|
write(iout,*)
|
|
write(iout,"(' Assembling four center integrals...')", !release
|
|
&advance='no')
|
|
|
|
if(naf.ne.'off ' .and. localcc.eq.'off ') then
|
|
call jpq2aibj_uccsd(nal,nbe,nval,nvbe,dfnbasis_full,
|
|
& dcore(imem),iout,imem,imem1,maxcor,icore(ifaadr),
|
|
& icore(ifbadr),icore(ifmadr),icore(irecaadr),
|
|
& icore(irecbadr),icore(irecmadr),icore(irecjab),irecln,
|
|
$ nfa,nfb,nfm,localcc,error,ccsdalg)
|
|
end if
|
|
|
|
|
|
itol=0.d0 ! not used in this case
|
|
call jpq2pqrs_openshell(nal,nbe,nval,nvbe,dfnbasis,dcore(imem),
|
|
&iout,imem,imem1,maxcor,icore(ifaadr),icore(ifbadr),icore(ifmadr),
|
|
&icore(irecaadr),icore(irecbadr),icore(irecmadr),icore(irecjab),
|
|
&irecln,nfa,nfb,nfm,localcc,ccsdalg,'ccsd',itol,0)
|
|
write(iout,"(' Done!')")
|
|
flush(iout)
|
|
call timer
|
|
|
|
endif !DFcalc
|
|
c }}}
|
|
|
|
c {{{ Allocating memory for arrays stored in core
|
|
c if (localcc.ne.'off ') then
|
|
c call intdealloc(imem1+nal+nbe+(nfa*(nfa+1)+nfb*(nfb+1)+
|
|
c &2*nfm*(nfm+1))/2)
|
|
c else !localcc=off
|
|
c call intdealloc(imem1+(nfa*(nfa+1)+nfb*(nfb+1)+2*nfm*(nfm+1))/2)
|
|
c endif !localcc
|
|
c call intdealloc(irecjab)
|
|
c Allocating and building faadr,fbadr,fmadr
|
|
if (.not.dfcalc) then
|
|
ifaadr=imem; ifbadr=imem; ifmadr=imem
|
|
if (nval.gt.1) ifaadr=intalloc(nfa+1)
|
|
if (nvbe.gt.1) ifbadr=intalloc(nfb+1)
|
|
if (nval.gt.0.and.nvbe.gt.0) ifmadr=intalloc(nfm+1)
|
|
if (nval.gt.1) call fadrbld(nfa,nval,icore(ifaadr))
|
|
if (nvbe.gt.1) call fadrbld(nfb,nvbe,icore(ifbadr))
|
|
if (nval.gt.0.and.nvbe.gt.0) call fadrbld(nfm,nvbe,icore(ifmadr))
|
|
endif !.not.dfcalc
|
|
ita1=dblalloc(nval*nal)
|
|
itb1=dblalloc(nvbe*nbe)
|
|
ita2=dblalloc(nval*(nval-1)*nal*(nal-1)/4)
|
|
itb2=dblalloc(nvbe*(nvbe-1)*nbe*(nbe-1)/4)
|
|
itm2=dblalloc(nval*nvbe*nal*nbe)
|
|
ifa=dblalloc((nal+nval)**2)
|
|
ifb=dblalloc((nbe+nvbe)**2)
|
|
inta1=dblalloc(nval*nal)
|
|
intb1=dblalloc(nvbe*nbe)
|
|
inta2=dblalloc(nval*(nval-1)*nal*(nal-1)/4)
|
|
intb2=dblalloc(nvbe*(nvbe-1)*nbe*(nbe-1)/4)
|
|
intm2=dblalloc(nval*nvbe*nal*nbe)
|
|
ibmat=dblalloc(ccmaxit**2)
|
|
ifaae=dblalloc(nval**2)
|
|
ifbae=dblalloc(nvbe**2)
|
|
ifami=dblalloc(nal**2)
|
|
ifbmi=dblalloc(nbe**2)
|
|
ifame=dblalloc(nal*nval)
|
|
ifbme=dblalloc(nbe*nvbe)
|
|
|
|
c }}}
|
|
|
|
c Calling UCCSD iterations
|
|
call uccsdmain(imem1,nb,nval,nvbe,lt,dcore(ibmat),dcore(ita1),
|
|
&dcore(itb1),dcore(ita2),dcore(itb2),dcore(itm2),dcore(inta1),
|
|
&dcore(intb1),dcore(inta2),dcore(intb2),dcore(intm2),dcore(ifa),
|
|
&dcore(ifb),dcore(ifaae),dcore(ifbae),dcore(ifami),dcore(ifbmi),
|
|
&dcore(ifame),dcore(ifbme),icore(ifaadr),nfa,icore(irecaadr),
|
|
&icore(ifbadr),nfb,icore(irecbadr),icore(ifmadr),nfm,
|
|
&icore(irecmadr),icore(irecjab),dcore(iuia),dcore(iuib),
|
|
&dcore(imem),icore(iimem),ccmaxit,dfcalc,localcc,indocc,naf,error,
|
|
&scftype,rohftype,ccsdalg,restart,calctype,talg,naobasis,ltpr,
|
|
&tprtol,verb,irecln,ibufln,nal,nbe,tol,diisfile,errfile,imem,
|
|
&maxcor,dfnbasis,ecc,eref,iout,iibufln,dcore,qro,lno,lnaf,emp2full,
|
|
&lf12,qscale_pt,tfact,dcore(itscalea),
|
|
$dcore(itscaleb),dcore(iepaa),dcore(iepbb),dcore(iepab),
|
|
$dcore(iepba),qscale_ccsd,eccs,eccp,ecabs,eppl_correction,lmp3,
|
|
$ovirtrun,emp2,cmp2ss,cmp2os,cmp3,dhyb,ied)
|
|
|
|
emp2_correction = emp2full - (eref + emp2)
|
|
if (error) then
|
|
write(iout,*)' Error during the execution of the CCSD iteration!'
|
|
call mrccend(1)
|
|
endif
|
|
if (localcc.ne.'off ') then
|
|
call prtenergc('CCSD ',ecc,eref,3) ! Saving CCSD energy
|
|
else if(trim(calctype).ne.'mp2') then
|
|
if(lcorr) then
|
|
call prtenergc('CCSD ',
|
|
$ ecc+eref+emp2_correction+eppl_correction,eref,3) ! Saving CCSD energy
|
|
else
|
|
call prtenergc('CCSD ',ecc+eref,eref,3) ! Saving CCSD energy
|
|
endif
|
|
endif
|
|
|
|
c {{{ (T) correction
|
|
if (trim(calctype).eq.'ccsd(t)') then
|
|
call dbldealloc(inta1)
|
|
if (talg.eq.'lapl') then
|
|
icmoa=dblalloc(nal**2)
|
|
icmob=dblalloc(nbe**2)
|
|
else
|
|
icmoa=imem
|
|
icmob=imem
|
|
endif
|
|
c {{{ Getting Laplace quadrature
|
|
if (localcc.ne.'off '.and.(talg.eq.'lapl'.or.talg.eq.'lato'))
|
|
&then
|
|
iea=dblalloc(nal+nval)
|
|
ieb=dblalloc(nbe+nvbe)
|
|
|
|
c Getting orbit energies
|
|
call getfockdiagonal(dcore(ifa),nal,nval,dcore(iea))
|
|
call getfockdiagonal(dcore(ifb),nbe,nvbe,dcore(ieb))
|
|
|
|
c Printing tolerance
|
|
if (verb.gt.3)
|
|
& write(iout,"(' Laplace treshold, nquadmin:',es10.2,i4)")
|
|
& ltol,nqmin
|
|
|
|
c Reading quadrature
|
|
call laplace(max(nval*nal,nvbe*nbe)**3,nquad,dcore(imem),
|
|
&dcore(iea),dcore(iea+nal),nval,nal,dcore(ieb),dcore(ieb+nbe),
|
|
&nvbe,nbe,3,3,ltol,gbasfile,iout,dcore(imem),nqmin,0.d0,0,
|
|
$dcore(imem))
|
|
|
|
call dcopy(nquad*nb*2,dcore(imem),1,dcore(imem+nquad*nb*2),1)
|
|
call dcopy(nquad*nb*2,dcore(imem+nquad*nb*2),1,dcore(iea),1)
|
|
call dbldealloc(iea)
|
|
iquad=dblalloc(nquad*(nal+nval+nbe+nvbe))
|
|
if (verb.gt.2)
|
|
& write(iout,"(' No. of quadrature points for Laplace-transform:'
|
|
& ,i4)") nquad
|
|
|
|
c Reading cmo
|
|
open(111,file='laplbas',form='unformatted')
|
|
read(111) dcore(icmoa:icmoa+nal**2-1)
|
|
if (nbe.gt.0) read(111) dcore(icmob:icmob+nbe**2-1)
|
|
close(111)
|
|
else !talg=occ
|
|
iquad=imem
|
|
nquad=0
|
|
endif !talg=lapl
|
|
c }}}
|
|
|
|
C Calculate (T)-XSP correction
|
|
lxsp=.false.!lf12 !szemet
|
|
if(lxsp) call xspcor(nal,nbe,nval,nvbe,dcore(ita2),dcore(itb2),
|
|
$dcore(itm2),121,iout,rcor)
|
|
c Calling perturbative (T) correction
|
|
call tcorr(maxcor,imem,imem1,nal,nbe,nval,nvbe,nquad,dfnbasis,
|
|
&dcore(ita1),dcore(itb1),dcore(ita2),dcore(itb2),dcore(itm2),
|
|
&dcore(ifa),dcore(ifb),dcore(iuia),dcore(iuib),dcore(iquad),
|
|
&dcore(icmoa),dcore(icmob),dcore(imem),dcore,et,iout,scftype,talg,
|
|
&localcc,error,ita1,ecc,qro,indocc,eref,ibufln,irecln,restart,ets,
|
|
$dcore(itscalea),dcore(itscaleb),qscale_pt,eppl_correction
|
|
$,dcore(iepaa),dcore(iepbb),dcore(iepab),dcore(iepba),ied,verb)
|
|
|
|
c End of (T) correction calculation
|
|
write(iout,*)
|
|
if (error) then
|
|
write(iout,*) ' Error during the (T) correction calculation!'
|
|
call mrccend(1)
|
|
else
|
|
if (localcc.ne.'off ') then
|
|
write(iout,"(' (T) energy contribution [au]:',f22.12)") et
|
|
write(iout,
|
|
& "(' CCSD(T) energy contribution [au]:',f18.12)") ecc+et
|
|
call prtenergc('CCSD(T) ',ecc+et,eref,3)
|
|
|
|
else !localcc=off
|
|
if(lf12) then
|
|
write(iout,"(' (T) correction [au]: ',13x,f25.12)")
|
|
$ et
|
|
else
|
|
write(iout,"(' (T) correction [au]: ',13x,f25.12)")
|
|
$ et
|
|
endif
|
|
if(qscale_pt) then
|
|
if(lf12) then
|
|
write(iout,"(' (T*) correction [au]: ',13x,
|
|
& f25.12)")tfact*et
|
|
else
|
|
write(iout,"(' (T*) correction [au]: ',13x,
|
|
& f25.12)")(emp2full-eref)/emp2*et !tfact*et
|
|
end if
|
|
write(iout,"(' (T+) correction [au]: ',13x,
|
|
& f25.12)")ets
|
|
if(lxsp) write(iout,"(' (T)-xSP correction [au]: ',
|
|
& 13x,f25.12)") et+rcor
|
|
c write(iout,"(' Scaled (T) correction [au]: ',13x,f25.12)")
|
|
c $ ets
|
|
end if
|
|
|
|
if(lf12) then
|
|
write(iout,
|
|
& "(' CCSD(F12*)(T) correlation energy [au]: ',f28.12)")
|
|
$ ecc+et
|
|
if(qscale_pt) then
|
|
write(iout,
|
|
& "(' CCSD(F12*)(T*) correlation energy [au]: ',f28.12)")
|
|
$ ecc+tfact*et
|
|
write(iout,
|
|
& "(' CCSD(F12*)(T+) correlation energy [au]: ',f28.12)")
|
|
$ ecc+ets
|
|
if(lxsp) write(iout,
|
|
& "(' CCSD(F12*)(T)-xSP correlation energy [au]:',f26.12)")
|
|
$ ecc+et+rcor
|
|
c et=ets
|
|
end if
|
|
if(lcorr) then
|
|
write(iout,
|
|
& "(' CCSD(F12*)(T) corr. energy + MP2 [au]: ',f28.12)")
|
|
$ ecc+et+(emp2full-(eref-ecabs+emp2))
|
|
if(qscale_pt) then
|
|
write(iout,
|
|
& "(' CCSD(F12*)(T*) corr. energy + MP2 [au]: ',f28.12)")
|
|
$ ecc+tfact*et+(emp2full-(eref-ecabs+emp2))
|
|
write(iout,
|
|
& "(' CCSD(F12*)(T+) corr. energy + MP2 [au]: ',f28.12)")
|
|
$ ecc+ets+(emp2full-(eref-ecabs+emp2))
|
|
endif
|
|
endif
|
|
|
|
et_corrected = et + ecc
|
|
|
|
write(iout,"(' Total CCSD(F12*)(T) energy [au]: ',
|
|
& f34.12)") eref+ecc+et
|
|
eccsdpt = eref + ecc + et
|
|
if(qscale_pt) then
|
|
write(iout,"(' Total CCSD(F12*)(T*) energy [au]: ',
|
|
& f34.12)") eref+ecc+tfact*et
|
|
write(iout,"(' Total CCSD(F12*)(T+) energy [au]: ',
|
|
& f34.12)") eref+ecc+ets
|
|
eccsdpt = eref + ecc + ets
|
|
|
|
end if
|
|
if(lcorr) then
|
|
write(iout,"(' Total CCSD(F12*)(T) energy + MP2 [au]: ',
|
|
& f28.12)") eref+ecc+et+(emp2full-(eref-ecabs+emp2))
|
|
eccsdpt=eref+ecc+et+(emp2full-(eref-ecabs+emp2))
|
|
if(qscale_pt) then
|
|
write(iout,"(' Total CCSD(F12*)(T*) energy + MP2 [au]: ',
|
|
& f28.12)") eref+ecc+tfact*et+(emp2full-(eref-ecabs+emp2))
|
|
write(iout,"(' Total CCSD(F12*)(T+) energy + MP2 [au]: ',
|
|
& f28.12)") eref+ecc+ets+(emp2full-(eref-ecabs+emp2))
|
|
eccsdpt=eref+ecc+ets+(emp2full-(eref-ecabs+emp2))
|
|
|
|
endif
|
|
endif
|
|
if(lxsp) then
|
|
eccsdpt = eref + ecc + et +rcor
|
|
write(iout,"(' Total CCSD(F12*)(T)-xSP energy [au]:',
|
|
& f32.12)") eccsdpt
|
|
endif
|
|
|
|
call prtenergc('CCSD(T) ',eccsdpt,eref,3)
|
|
|
|
else
|
|
|
|
write(iout,
|
|
$"(' CCSD(T) correlation energy [au]: ',13x,f19.12)")ecc+et
|
|
et_corrected = ecc + et
|
|
if(lcorr) then
|
|
write(iout,
|
|
$ "(' CCSD(T) correlation energy + MP2 correction [au]:',
|
|
$ f19.12)") ecc + et + (emp2full - (eref + emp2))
|
|
et_corrected = ecc + et + (emp2full - (eref + emp2))
|
|
end if
|
|
if(lcorr.and.qscale_pt) then
|
|
if(qscale_ccsd) then
|
|
write(iout,
|
|
$ "(' CCSD(T+) correlation en. + MP2 + PPL corr. [au]: ',
|
|
$ f19.12)") ecc+ets+(emp2full-(eref+emp2))+eppl_correction
|
|
et_corrected = ecc+ets+(emp2full-(eref+emp2))+
|
|
$ eppl_correction
|
|
else
|
|
write(iout,
|
|
$ "(' CCSD(T+) correlation en. + MP2 correction [au]: ',
|
|
$ f19.12)") ecc+ets+(emp2full-(eref+emp2))
|
|
et_corrected = ecc+ets+(emp2full-(eref+emp2))
|
|
end if
|
|
end if
|
|
|
|
|
|
write(iout,"(' Total CCSD(T) energy [au]: ',14x,
|
|
$ f25.12)") eref+ecc+et
|
|
eccsdpt = eref + ecc + et
|
|
if(lcorr)
|
|
$ write(iout,"(' Total CCSD(T) energy + MP2 correction [au]: ',
|
|
$ 4x,f19.12)") eref+ecc+et+(emp2full-(eref+emp2))
|
|
if(lcorr.and.qscale_pt) then
|
|
if(qscale_ccsd) then
|
|
write(iout,
|
|
$ "(' Total CCSD(T+) energy + MP2 + PPL corr. [au]: ',
|
|
$ f19.12)")eref+ecc+ets+(emp2full-(eref+emp2))+eppl_correction
|
|
else
|
|
write(iout,
|
|
$ "(' Total CCSD(T+) energy + MP2 correction [au]: ',
|
|
$ f19.12)")eref+ecc+ets+(emp2full-(eref+emp2))
|
|
end if
|
|
if(lcorr) ecc = ecc + (emp2full - (eref + emp2)) +
|
|
$ eppl_correction
|
|
write(iout,*)
|
|
end if
|
|
et_corrected = et_corrected + eref
|
|
call prtenergc('CCSD(T) ',et_corrected,eref,3)
|
|
c call prtenergc('CCSD(T) ',ecc+et+eref,eref,3)
|
|
|
|
endif !lf12
|
|
|
|
endif !localcc
|
|
endif !error
|
|
|
|
|
|
endif ! (T)
|
|
c }}}
|
|
|
|
c {{{ Deleting files
|
|
open(16,file='UCCSD_RES',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='abijaa',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='abijbb',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='abijab',form='unformatted')
|
|
close(16,status='delete')
|
|
if(lnaf .and. dfintran.eq.'drpa ') then
|
|
open(16,file='abijaa_nonaf',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='abijbb_nonaf',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='abijab_nonaf',form='unformatted')
|
|
close(16,status='delete')
|
|
endif
|
|
open(16,file='aijkaa',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='aijkbb',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='aijkab',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='aijkba',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='iabcaa',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='iabcab',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='iabcba',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='iabcbb',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='UCCSDREST',form='unformatted')
|
|
close(16,status='delete')
|
|
if (dfcalc) then
|
|
open(16,file='DFINT_AB',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='DFINT_ABb',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='DFINT_AI',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='DFINT_AIb',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='DFINT_IJ',form='unformatted')
|
|
close(16,status='delete')
|
|
open(16,file='DFINT_IJb',form='unformatted')
|
|
close(16,status='delete')
|
|
endif !dfcalc
|
|
if (talg.eq.'lapl') then
|
|
open(16,file='laplbas',form='unformatted')
|
|
close(16,status='delete')
|
|
endif
|
|
|
|
close(ifcfile,status='keep')
|
|
close(55,status='keep')
|
|
c }}}
|
|
|
|
flush(6)
|
|
return
|
|
end
|
|
|
|
C
|
|
************************************************************************
|
|
subroutine uccsdmain(imem1,nb,nval,nvbe,lt,bmat,ta1,
|
|
&tb1,ta2,tb2,tm2,newta1,
|
|
&newtb1,newta2,newtb2,newtm2,fa,
|
|
&fb,faae,fbae,fami,fbmi,
|
|
&fame,fbme,faadr,nfa,recaadr,
|
|
&fbadr,nfb,recbadr,fmadr,nfm,
|
|
&recmadr,recjab,uia,uib,scr,iscr,ccmaxit,
|
|
&dfcalc,localcc,indocc,naf,error,scftype,rohftype,ccsdalg,restart,
|
|
&calctype,talg,naobasis,ltpr,tprtol,verb,irecln,ibufln,nal,nbe,tol,
|
|
&diisfile,errfile,imem,maxcor,dfnbasis,ecc,eref,iout,iibufln,dcore,
|
|
&qro,lno,lnaf,emp2full,lf12,qscale_pt,tfact,
|
|
$tscalea,tscaleb,
|
|
&epaa,epbb,epab,epba,qscale,eccs,eccp,ecabs,eppl_correction,lmp3,
|
|
$ovirtrun,emp2,cmp2ss,cmp2os,cmp3,dhyb,ied)
|
|
************************************************************************
|
|
* Performs the open-shell CCSD iteration. *
|
|
************************************************************************
|
|
implicit none
|
|
integer i,j,k,l,p,q,r,s,a,b,nb,verb,irecln,ibufln,nal,nbe,errfile
|
|
integer nval,nvbe,f,e,m,n,c,d,nn,mn,ij,ji,jji,diisfile,imem,maxcor
|
|
integer ef,ab,bba,aab,me,nff,ae,fm,fmn,en,mi,nef,mni,ai,bj,men,mef
|
|
integer aij,mbe,ejm,abi,aj,bi,bc,jk,ik,abc,ac,ca,cb,kj,ki,lt,abij
|
|
integer abijab,ijj,aijk,mnef,mebj,imem1,dfnbasis,nit,iout,iibufln
|
|
integer nblc,f0,fx,mb,ma,ncab,maba,ijbab,jbabsize,ijabb,iwork
|
|
integer maab,abcd,abef,irec,ccmaxit,nfa,nfb,nfm,ijaab,iscr(*)
|
|
integer faadr(nfa+1),fbadr(nfb+1),fmadr(nfm+1),ijaba,efmln,efmtile
|
|
integer recaadr((nfa+1)*nfa/2),recind,naobasis,dhyb
|
|
integer recbadr((nfb+1)*nfb/2),recmadr((nfm+1)*nfm/2)
|
|
integer ipuff,ipuf1,ipuf2,ipuf3,ipuf4,ipuf5,recjab(nfm*(nfm+1)/2)
|
|
|
|
real*8 sum,eccold,et,est,ddot,norm,dnrm2,scr(*),decc,et1,tprtol
|
|
real*8 ta1(nval,nal),tb1(nvbe,nbe),tm2(nvbe*nval,nbe*nal),tol
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),bmat(ccmaxit**2),ecc
|
|
real*8 tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),fbae(nvbe,nvbe),emp2
|
|
real*8 newta1(nval,nal),newtb1(nvbe,nbe),faae(nval,nval),eref
|
|
real*8 ecabs,emp2f12,tfact,ets,ecoup,cmp2ss,cmp2os,cmp3
|
|
real*8 newta2(nval*(nval-1)/2,nal*(nal-1)/2),fami(nal,nal)
|
|
real*8 newtb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),fb(nbe+nvbe,nbe+nvbe)
|
|
real*8 newtm2(nval*nvbe,nal*nbe),fa(nal+nval,nal+nval)
|
|
real*8 fbmi(nbe,nbe),fame(nval,nal),fbme(nvbe,nbe)
|
|
real*8 tscalea(nal),tscaleb(nbe),eccs,eccp,et1s
|
|
real*8 epaa(nal,nal),epbb(nbe,nbe),epab(nal,nbe),epba(nbe,nal)
|
|
real*8 emp2full,eppl,eppl_os,eppl_ss,eppls_os,eppls_ss,epplij
|
|
real*8,pointer::jaab(:,:),jbab(:,:,:),jbabtri(:,:)
|
|
character*5 ovirtrun
|
|
|
|
logical error,dfcalc,restart,ltpr,lnaf,lno,lf12,qscale,lmp3
|
|
logical qscale_pt
|
|
|
|
character*4 localcc,talg
|
|
character*5 scftype
|
|
character*16 calctype
|
|
character*8 ccsdalg
|
|
character*13 rohftype
|
|
|
|
c local
|
|
integer ied
|
|
real*8 uia(nal),uib(nbe)
|
|
real*8 e_ppl,eppl_correction,ecc_os,ecc_ss,epplc,eccsc
|
|
real*8 emp2ss,emp2os,emp3
|
|
character*5 dfintran
|
|
character*16 naf
|
|
character*32 dft
|
|
logical indocc,lcorr
|
|
c ovirt
|
|
integer lrec,intadd,ivabc,iuab,iwab,iabcdaa1,iabcdaa2,dbladd
|
|
integer eftile,iabcdtile
|
|
c real*8,allocatable::vabc(:,:,:),uab(:,:),wab(:)
|
|
real*8,pointer::vabc(:,:,:),uab(:,:),wab(:)
|
|
real*8,pointer::abcdtile(:)
|
|
logical ial,jal,kal,lal,iocc,jocc,locc,kocc,converged
|
|
c integer,allocatable::abcdaa2_rec(:,:),abcdaa1_rec(:,:)
|
|
integer,pointer :: abcdaa1_rec(:,:),abcdaa2_rec(:,:)
|
|
|
|
c spin contamination
|
|
integer iuoa,iuob,iuva,iuvb,dblalloc
|
|
integer is_iJ,is_aJ,is_Bi
|
|
real*8 dcore(*),scf_s2
|
|
character*3 qro
|
|
character*7 scfiguess
|
|
character*8 cmpgrp
|
|
logical forward
|
|
|
|
c {{{ Iterface for pointers
|
|
interface
|
|
subroutine rpoint1d(egydim,haromdim,dim1)
|
|
implicit none
|
|
integer dim1
|
|
real*8,target :: egydim(dim1)
|
|
real*8, pointer :: haromdim(:)
|
|
end subroutine
|
|
subroutine rpoint2d(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
real*8,target :: egydim(dim1,dim2)
|
|
real*8, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
subroutine rpoint3d(egydim,haromdim,dim1,dim2,dim3)
|
|
implicit none
|
|
integer dim1,dim2,dim3
|
|
real*8,target :: egydim(dim1,dim2,dim3)
|
|
real*8, pointer :: haromdim(:,:,:)
|
|
end subroutine
|
|
subroutine rpoint2i(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
integer,target :: egydim(dim1,dim2)
|
|
integer, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
end interface
|
|
c }}}
|
|
|
|
ets=0.d0
|
|
|
|
c {{{ Building abcd lists
|
|
if (.not.dfcalc) then
|
|
ivabc=1
|
|
iuab=ivabc+nvbe**3
|
|
iwab=iuab+nvbe**2
|
|
iabcdaa1=intadd(iwab+nvbe**2)
|
|
iabcdaa2=iabcdaa1+nvbe**2
|
|
iabcdtile=dbladd(iabcdaa2+nvbe**2)
|
|
|
|
call rpoint3d(scr(ivabc),vabc,nvbe,nvbe,nvbe)
|
|
call rpoint2d(scr(iuab),uab,nvbe,nvbe)
|
|
call rpoint1d(scr(iwab),wab,nvbe*nvbe)
|
|
call rpoint2i(iscr(intadd(nvbe**3+2*nvbe**2+1)),abcdaa1_rec,
|
|
&nvbe,nvbe)
|
|
call rpoint2i(iscr(intadd(nvbe**3+2*nvbe**2+1)+nvbe**2),
|
|
&abcdaa2_rec,nvbe,nvbe)
|
|
call rpoint1d(scr(iabcdtile),abcdtile,1)
|
|
|
|
c vvvva
|
|
c (a<b)<(e<f)
|
|
if (nval.gt.1) then
|
|
|
|
open(16,file='abcda',access='direct',recl=irecln)
|
|
open(918,file='abcdaa1',access='direct',recl=irecln,
|
|
$ status='OLD')
|
|
open(919,file='abcdaa2',access='direct',recl=irecln,
|
|
$ status='OLD')
|
|
rewind 900
|
|
do
|
|
read(900,*,END=971) e,f,a
|
|
abcdaa2_rec(e,f)=a
|
|
enddo
|
|
971 continue
|
|
c close(900,STATUS='DELETE')
|
|
c beolvasashoz szukseges fajl, ujrainditaskor nem szabad kitorolni
|
|
|
|
rewind 903
|
|
do
|
|
read(903,*,END=975) e,f,a
|
|
abcdaa1_rec(e,f)=a
|
|
enddo
|
|
975 continue
|
|
c close(903,STATUS='DELETE')
|
|
c beolvasashoz szukseges fajl, ujrainditaskor nem szabad kitorolni
|
|
|
|
recind=0
|
|
irec=1
|
|
do i=1,nfa
|
|
c
|
|
do f0=1,i-1
|
|
call rpoint1d(scr(iabcdtile),abcdtile,eftile(f0,i,faadr,nfa))
|
|
|
|
abef=0
|
|
do f=faadr(i),faadr(i+1)-1 !kk
|
|
|
|
do e=1,f
|
|
lrec=abcdaa1_rec(f,e)
|
|
|
|
call getlst_rz(918,lrec,wab,e**2,iibufln)
|
|
|
|
do a=1,e
|
|
do b=1,e
|
|
vabc(a,e,b)=wab(e*(a-1)+b) !(ea)(bf)
|
|
vabc(e,a,b)=wab(e*(a-1)+b)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
do e=1,f-1
|
|
lrec=abcdaa2_rec(f,e)
|
|
call getlst_rz(919,lrec,wab,e*f,iibufln)
|
|
do a=1,e
|
|
do b=1,f
|
|
vabc(e,a,b)=wab((b-1)*e+a)
|
|
vabc(a,e,b)=wab((b-1)*e+a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
do e=1,f-1 !ll
|
|
|
|
do b=faadr(f0),faadr(f0+1)-1 !f.ge.b , jj.le.kk
|
|
do a=1,b-1
|
|
abef=abef+1
|
|
abcdtile(abef)=vabc(a,e,b)-vabc(b,e,a)
|
|
enddo
|
|
enddo
|
|
|
|
enddo
|
|
|
|
enddo
|
|
|
|
recind=recind+1
|
|
recaadr(recind)=irec
|
|
|
|
call putlst(16,irec,abcdtile,abef)
|
|
|
|
if (mod(abef,irecln/8).ne.0) then
|
|
irec=irec+abef/(irecln/8)+1
|
|
else
|
|
irec=irec+abef/(irecln/8)
|
|
endif
|
|
|
|
enddo
|
|
|
|
call rpoint1d(scr(iabcdtile),abcdtile,eftile(i,i,faadr,nfa))
|
|
abef=0
|
|
do f=faadr(i),faadr(i+1)-1
|
|
|
|
do e=1,f
|
|
lrec=abcdaa1_rec(f,e)
|
|
c write(*,*) abcdaa1_rec(f,e),f,e
|
|
call getlst_rz(918,lrec,wab,e**2,iibufln)
|
|
|
|
do a=1,e
|
|
do b=1,e
|
|
vabc(a,e,b)=wab(e*(a-1)+b) !(ea)(bf)
|
|
vabc(e,a,b)=wab(e*(a-1)+b)
|
|
enddo
|
|
enddo
|
|
|
|
enddo
|
|
|
|
do e=1,f-1
|
|
lrec=abcdaa2_rec(f,e)
|
|
call getlst_rz(919,lrec,wab,e*f,iibufln)
|
|
do b=1,f
|
|
do a=1,e
|
|
vabc(e,a,b)=wab((b-1)*e+a)
|
|
vabc(a,e,b)=wab((b-1)*e+a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
do e=1,f-1
|
|
do b=faadr(i),f
|
|
do a=1,ncab(f,b,e,b-1)
|
|
abef=abef+1
|
|
abcdtile(abef)=vabc(a,e,b)-vabc(b,e,a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
enddo
|
|
|
|
recind=recind+1
|
|
recaadr(recind)=irec
|
|
|
|
call putlst(16,irec,abcdtile,abef)
|
|
|
|
if (mod(abef,irecln/8).ne.0) then
|
|
irec=irec+abef/(irecln/8)+1
|
|
else
|
|
irec=irec+abef/(irecln/8)
|
|
endif
|
|
|
|
enddo
|
|
|
|
close(16)
|
|
c close(918,status='delete')
|
|
c close(919,status='delete')
|
|
endif !nval>1
|
|
|
|
c vvvvb
|
|
c (a<b)<(e<f)
|
|
|
|
rewind 901
|
|
do
|
|
read(901,*,END=972) e,f,a
|
|
abcdaa2_rec(e,f)=a
|
|
enddo
|
|
972 continue
|
|
c close(901,STATUS='DELETE')
|
|
|
|
rewind 902
|
|
do
|
|
read(902,*,END=973) e,f,a
|
|
abcdaa1_rec(e,f)=a
|
|
enddo
|
|
973 continue
|
|
c close(902,STATUS='DELETE')
|
|
|
|
|
|
if (nvbe.gt.1) then
|
|
|
|
open(16,file='abcdb',access='direct',recl=irecln)
|
|
open(918,file='abcdbb1',access='direct',recl=irecln,
|
|
$ status='OLD')
|
|
open(919,file='abcdbb2',access='direct',recl=irecln,
|
|
$ status='OLD')
|
|
|
|
recind=0
|
|
irec=1
|
|
do i=1,nfb
|
|
|
|
do f0=1,i-1
|
|
call rpoint1d(scr(iabcdtile),abcdtile,eftile(f0,i,fbadr,nfb))
|
|
|
|
abef=0
|
|
do f=fbadr(i),fbadr(i+1)-1
|
|
do e=1,f
|
|
lrec=abcdaa1_rec(f,e)
|
|
call getlst_rz(918,lrec,wab,e**2,iibufln)
|
|
|
|
do a=1,e
|
|
do b=1,e
|
|
vabc(a,e,b)=wab(e*(a-1)+b) !(ea)(bf)
|
|
vabc(e,a,b)=wab(e*(a-1)+b)
|
|
enddo
|
|
enddo
|
|
|
|
enddo
|
|
!abcdaa2
|
|
do e=1,f-1
|
|
lrec=abcdaa2_rec(f,e)
|
|
call getlst_rz(919,lrec,wab,e*f,iibufln)
|
|
do a=1,e
|
|
do b=1,f
|
|
vabc(e,a,b)=wab((b-1)*e+a)
|
|
vabc(a,e,b)=wab((b-1)*e+a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
do e=1,f-1
|
|
do b=fbadr(f0),fbadr(f0+1)-1
|
|
do a=1,b-1
|
|
abef=abef+1
|
|
abcdtile(abef)=vabc(a,e,b)-vabc(b,e,a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
recind=recind+1
|
|
recbadr(recind)=irec
|
|
|
|
call putlst(16,irec,abcdtile,abef)
|
|
if (mod(abef,irecln/8).ne.0) then
|
|
irec=irec+abef/(irecln/8)+1
|
|
else
|
|
irec=irec+abef/(irecln/8)
|
|
endif
|
|
|
|
enddo
|
|
|
|
call rpoint1d(scr(iabcdtile),abcdtile,eftile(i,i,fbadr,nfb))
|
|
abef=0
|
|
do f=fbadr(i),fbadr(i+1)-1
|
|
|
|
do e=1,f
|
|
lrec=abcdaa1_rec(f,e)
|
|
call getlst_rz(918,lrec,wab,e**2,iibufln)
|
|
do a=1,e
|
|
do b=1,e
|
|
vabc(a,e,b)=wab(e*(a-1)+b) !(ea)(bf)
|
|
vabc(e,a,b)=wab(e*(a-1)+b)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
do e=1,f-1
|
|
lrec=abcdaa2_rec(f,e)
|
|
call getlst_rz(919,lrec,wab,e*f,iibufln)
|
|
do a=1,e
|
|
do b=1,f
|
|
vabc(e,a,b)=wab((b-1)*e+a)
|
|
vabc(a,e,b)=wab((b-1)*e+a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
do e=1,f-1
|
|
do b=fbadr(i),f
|
|
do a=1,ncab(f,b,e,b-1)
|
|
abef=abef+1
|
|
abcdtile(abef)=vabc(a,e,b)-vabc(b,e,a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
recind=recind+1
|
|
recbadr(recind)=irec
|
|
call putlst(16,irec,abcdtile,abef)
|
|
if (mod(abef,irecln/8).ne.0) then
|
|
irec=irec+abef/(irecln/8)+1
|
|
else
|
|
irec=irec+abef/(irecln/8)
|
|
endif
|
|
|
|
enddo
|
|
|
|
close(16)
|
|
c close(918,status='delete')
|
|
c close(919,status='delete')
|
|
endif !nvbe>1
|
|
|
|
c vvvvab
|
|
c (a,b)<(e,f)
|
|
if (nval.gt.0.and.nvbe.gt.0) then
|
|
open(16,file='abcdm',access='direct',recl=irecln)
|
|
open(910,file='abcdab',access='direct',recl=8*nval,
|
|
$ status='OLD')
|
|
|
|
recind=0
|
|
irec=1
|
|
do i=1,nfm
|
|
|
|
do f0=1,i-1
|
|
call rpoint1d(scr(iabcdtile),abcdtile,
|
|
&efmtile(f0,i,fmadr,nfm,nval))
|
|
|
|
abef=0
|
|
do f=fmadr(i),fmadr(i+1)-1
|
|
do e=1,nval
|
|
|
|
do b=fmadr(f0),fmadr(f0+1)-1
|
|
read(910,rec=(((f-1)*f/2+b)*nval+e))
|
|
$ (uab(a,b),a=1,nval)
|
|
enddo
|
|
|
|
do b=fmadr(f0),fmadr(f0+1)-1
|
|
do a=1,nval
|
|
abef=abef+1
|
|
abcdtile(abef)=uab(a,b)
|
|
enddo
|
|
enddo
|
|
|
|
enddo
|
|
enddo
|
|
|
|
recind=recind+1
|
|
recmadr(recind)=irec
|
|
|
|
call putlst(16,irec,abcdtile,abef)
|
|
|
|
if (mod(abef,irecln/8).ne.0) then
|
|
irec=irec+abef/(irecln/8)+1
|
|
else
|
|
irec=irec+abef/(irecln/8)
|
|
endif
|
|
|
|
enddo
|
|
|
|
call rpoint1d(scr(iabcdtile),abcdtile,
|
|
&efmtile(i,i,fmadr,nfm,nval))
|
|
abef=0
|
|
do f=fmadr(i),fmadr(i+1)-1
|
|
do e=1,nval
|
|
|
|
do b=fmadr(i),f
|
|
read(910,rec=(((f-1)*f/2+b)*nval+e))
|
|
$ (uab(a,b),a=1,nval)
|
|
enddo
|
|
|
|
do b=fmadr(i),f
|
|
do a=1,ncab(f,b,e,nval)
|
|
abef=abef+1
|
|
abcdtile(abef)=uab(a,b)
|
|
enddo
|
|
enddo
|
|
|
|
enddo
|
|
enddo
|
|
|
|
recind=recind+1
|
|
recmadr(recind)=irec
|
|
|
|
call putlst(16,irec,abcdtile,abef)
|
|
|
|
if (mod(abef,irecln/8).ne.0) then
|
|
irec=irec+abef/(irecln/8)+1
|
|
else
|
|
irec=irec+abef/(irecln/8)
|
|
endif
|
|
|
|
enddo
|
|
|
|
close(16)
|
|
c close(910,status='delete')
|
|
endif !nval>0,nvbe>0
|
|
|
|
endif !not dfcalc
|
|
c }}}
|
|
|
|
c {{{ Reading Fock, Ui if localcc
|
|
if (localcc.ne.'off ') then
|
|
rewind(55)
|
|
read(55,*)
|
|
read(55,*)
|
|
read(55,*)
|
|
read(55,*)
|
|
read(55,*)
|
|
|
|
read(55,*) uia(1:nal)
|
|
do j=1,nb
|
|
do i=1,nb
|
|
read(55,*) fa(i,j)
|
|
enddo
|
|
enddo
|
|
if (nbe.gt.0) then
|
|
read(55,*) !nuclear repulsion
|
|
read(55,*) !beta dimensions
|
|
read(55,*) uib(1:nbe)
|
|
do j=1,nbe+nvbe
|
|
do i=1,nbe+nvbe
|
|
read(55,*) fb(i,j)
|
|
enddo
|
|
enddo
|
|
endif !nbe.gt.0
|
|
endif !localcc=on }}}
|
|
|
|
c {{{ Building the Fock matrix, if not localcc
|
|
if (localcc.eq.'off ') then
|
|
call getkey('dfintran', 8, dfintran, 5)
|
|
if(dfintran .eq. 'drpa ') then
|
|
open(555, file = '55')
|
|
rewind(555)
|
|
|
|
read(555,*)
|
|
read(555,*)
|
|
read(555,*)
|
|
read(555,*)
|
|
read(555,*)
|
|
read(555,*)
|
|
|
|
do i = 1, nal + nval
|
|
do j = 1, nal + nval
|
|
read(555,*) fa(j, i)
|
|
end do
|
|
end do
|
|
|
|
do i = 1, nbe + nvbe
|
|
do j = 1, nbe + nvbe
|
|
read(555,*) fb(j, i)
|
|
end do
|
|
end do
|
|
|
|
close(555)
|
|
|
|
else
|
|
c {{{ Read Fock matrix if natural orbitals are used
|
|
call getkey('ovirt',5,ovirtrun,5) !RZ 2019.10.31.
|
|
if(ovirtrun.eq.'ovos '.or.ovirtrun.eq.'mp2 ')then !RZ |
|
|
!RZ V
|
|
OPEN(70,
|
|
& FILE='FOCK.MP2',
|
|
& STATUS='OLD',
|
|
& FORM='UNFORMATTED')
|
|
|
|
|
|
rewind 70
|
|
|
|
fa=0.d0
|
|
read(70) (scr(i),i=1,nal+nval)
|
|
do i=1,nal+nval
|
|
fa(i,i)=scr(i)
|
|
enddo
|
|
|
|
|
|
fb=0.d0
|
|
read(70) (scr(i),i=1,nbe+nvbe)
|
|
do i=1,nbe+nvbe
|
|
fb(i,i)=scr(i)
|
|
enddo !RZ A
|
|
c }}} !RZ |
|
|
else !RZ 2019.10.31.
|
|
c a,a
|
|
ipuf1=(naobasis)**2+1
|
|
ipuf2=ipuf1+(naobasis)**2
|
|
ipuf3=ipuf2+(naobasis)**2
|
|
ipuf4=ipuf3+(naobasis)**2
|
|
ipuf5=ipuf4+(naobasis)**2
|
|
c Read MO coefficients
|
|
open(16,file='MOCOEF',form='unformatted')
|
|
c alpha
|
|
call readmo(scr(ipuf2),scr(ipuf2),scr(ipuf1),16,
|
|
&naobasis,nb)
|
|
c beta
|
|
if (trim(scftype).eq.'rohf'.and.trim(rohftype).eq.'standard') then
|
|
scr(ipuf2:ipuf3-1)=scr(ipuf1:ipuf2-1)
|
|
else
|
|
call readmo(scr(ipuf3),scr(ipuf3),scr(ipuf2),16,
|
|
&naobasis,nb)
|
|
endif
|
|
close(16)
|
|
|
|
c Read Fock-matrix (AO)
|
|
open(16,file='FOCK',form='unformatted')
|
|
c alpha
|
|
call roeint(scr(ipuf4),scr(ipuf4),scr(ipuf3),16,naobasis)
|
|
c beta
|
|
if (trim(scftype).eq.'rohf'.and.trim(rohftype).eq.'standard') then
|
|
scr(ipuf4:ipuf5-1)=scr(ipuf3:ipuf4-1)
|
|
else
|
|
call roeint(scr(ipuf5),scr(ipuf5),scr(ipuf4),16,naobasis)
|
|
endif
|
|
close(16)
|
|
c Transform the Fock-matrix to MO basis
|
|
c alpha
|
|
call dsymm('l','l',naobasis,nb,1.d0,scr(ipuf3),naobasis,
|
|
&scr(ipuf1),naobasis,0.d0,scr,naobasis)
|
|
call dgemm('t','n',nb,nb,naobasis,1.d0,scr(ipuf1),
|
|
&naobasis,scr,naobasis,0.d0,fa,nb)
|
|
c beta
|
|
call dsymm('l','l',naobasis,nb,1.d0,scr(ipuf4),naobasis,
|
|
&scr(ipuf2),naobasis,0.d0,scr,naobasis)
|
|
call dgemm('t','n',nb,nb,naobasis,1.d0,scr(ipuf2),
|
|
&naobasis,scr,naobasis,0.d0,fb,nb)
|
|
|
|
end if
|
|
end if
|
|
endif !.not.localcc
|
|
c }}}
|
|
|
|
C Print reference energy
|
|
write(iout,*)
|
|
if (localcc.eq.'off ')
|
|
$ write(iout,"(' Reference energy [au]:',15x,f23.12)") eref
|
|
|
|
if (.not.restart) then
|
|
c {{{ Initialize T amplitudes
|
|
c alpha
|
|
if (nal.gt.0.and.nval.gt.0) then
|
|
call fockme('t',fa,nal,nval,ta1)
|
|
do i=1,nal
|
|
do a=1,nval
|
|
ta1(a,i)=ta1(a,i)/(fa(i,i)-fa(a+nal,a+nal))
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
if (nal.gt.1.and.nval.gt.1) then
|
|
open(16,file='abijaa',form='unformatted')
|
|
read(16) scr(1:nval*(nval-1)/2*nal*(nal-1)/2)
|
|
do j=1,nal
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
ta2(ab,ij)=scr((ij-1)*nval*(nval-1)/2+ab)
|
|
&/(fa(i,i)+fa(j,j)-fa(a+nal,a+nal)-fa(b+nal,b+nal))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
close(16)
|
|
endif
|
|
c beta
|
|
if (nbe.gt.0.and.nvbe.gt.0) then
|
|
call fockme('t',fb,nbe,nvbe,tb1)
|
|
do i=1,nbe
|
|
do a=1,nvbe
|
|
tb1(a,i)=tb1(a,i)/(fb(i,i)-fb(a+nbe,a+nbe))
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
if (nbe.gt.1.and.nvbe.gt.1) then
|
|
open(16,file='abijbb',form='unformatted')
|
|
read(16) scr(1:nvbe*(nvbe-1)/2*nbe*(nbe-1)/2)
|
|
do j=1,nbe
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
tb2(ab,ij)=scr((ij-1)*nvbe*(nvbe-1)/2+ab)
|
|
&/(fb(i,i)+fb(j,j)-fb(a+nbe,a+nbe)-fb(b+nbe,b+nbe))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
close(16)
|
|
endif
|
|
|
|
c mixed
|
|
if (nal.gt.0.and.nbe.gt.0.and.nval.gt.0.and.nvbe.gt.0) then
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) scr(1:nval*nvbe*nal*nbe)
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
ij=(j-1)*nal+i
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
ab=(b-1)*nval+a
|
|
tm2(ab,ij)=scr((ij-1)*nvbe*nval+ab)/
|
|
&(fa(i,i)+fb(j,j)-fa(a+nal,a+nal)-fb(b+nbe,b+nbe))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
close(16)
|
|
endif
|
|
c }}}
|
|
|
|
c {{{ Calculating MP2 energy
|
|
lcorr = lno .or. lnaf
|
|
call dcopy(lt,ta1,1,newta1,1)
|
|
if (localcc.ne.'off ') then
|
|
call locccenergy(nal,nbe,nval,nvbe,ta1,tb1,fa,fb,ta2,tb2,
|
|
&newtm2,tm2,uia,uib,emp2,scr,indocc,naf,.true.,et1)
|
|
c Saving local MP2 contribution
|
|
else !localcc=off
|
|
call ccenergy(nal,nbe,nval,nvbe,ta1,newta2,tb1,newtb2,
|
|
&newtm2,fa,fb,scr,emp2,.true.,et1,lnaf,.false.,emp2os,emp2ss,
|
|
$.false.)
|
|
endif !localcc
|
|
else !if restart
|
|
c Read t amplitudes from file
|
|
call managerestart('r','ccsd',nit,emp2,et1,ecc,ecc,ta1,tb1,ta2,
|
|
& tb2,tm2,0,nal,nbe,nval,nvbe,ecc,ied)
|
|
endif !restart
|
|
write(iout,"(' MP2 correlation energy [au]:',f32.12)") emp2
|
|
c if (verb.gt.3) then
|
|
c call tanalytics(ltpr,ta1,tb1,ta2,tb2,tm2,nal,nval,nbe,nvbe,iout,
|
|
c $ tprtol,scr,0)
|
|
c endif
|
|
if (localcc.ne.'off ') then
|
|
call prtenergc('MP2 ',emp2,eref,3)
|
|
else
|
|
write(iout,"(' Total MP2 energy [au]: ',f32.12)") eref+emp2
|
|
if(lcorr) write(iout, "(' MP2 correction [au]: ',f32.12)")
|
|
$ emp2full - (eref + emp2)
|
|
endif
|
|
if(trim(calctype).eq.'mp2') then
|
|
ecc=ecc_os+ecc_ss
|
|
write(iout,*)
|
|
call prtenergc('MP2 ',emp2+eref,eref,3)
|
|
return
|
|
end if
|
|
!}}}
|
|
|
|
c {{{ Spin contamination
|
|
if (scftype.eq.'rohf'.and.qro.eq.'off') then
|
|
scf_s2 = 0.5d0 * dble(nal - nbe)
|
|
scf_s2 = scf_s2 * (scf_s2 + 1.d0)
|
|
elseif (scftype.eq.'uhf '.or.qro.eq.'on ') then
|
|
call getkey('scfiguess',9,scfiguess,7)
|
|
if (trim(scfiguess).ne.'off') then
|
|
call getvar('scf_s2 ',scf_s2)
|
|
else
|
|
if (verb.ge.3)
|
|
$ write(iout,
|
|
$ "(' SCF <S^2> value not available since scfiguess=off')")
|
|
endif !scfiguess
|
|
endif
|
|
|
|
c Projected spin contamination
|
|
call getvar('cmpgrp ',cmpgrp)
|
|
if (localcc.ne.'off '.or.
|
|
$ (scftype.eq.'uhf '.and.trim(cmpgrp).eq.'C1')) then
|
|
is_iJ = dblalloc(nal*nbe)
|
|
is_aJ = dblalloc(nval*nbe)
|
|
is_Bi = dblalloc(nal*nvbe)
|
|
iwork = dblalloc(max(nbe+max(nval,nbe), !tai
|
|
$ nal+max(nvbe,nal), !tAI
|
|
$ nval+nvbe)) !tm2
|
|
call projected_spin_cont(nal,nbe,nval,nvbe,dcore(is_iJ),
|
|
$ dcore(is_aJ),dcore(is_Bi),ta1,tb1,tm2,iout,scf_s2,
|
|
$ uia,uib,localcc,indocc,dcore(iwork),newtm2,.false.)
|
|
call dbldealloc(is_iJ)
|
|
endif
|
|
|
|
if (scftype.eq.'rohf'.and.
|
|
$ (localcc.ne.'off '.or.trim(cmpgrp).eq.'C1')) then
|
|
iuoa=dblalloc(nal**2)
|
|
iuob=dblalloc(nbe**2)
|
|
iuva=dblalloc(nval**2)
|
|
iuvb=dblalloc(nvbe**2)
|
|
iwork=dblalloc(2*max(nal,nvbe)**2)
|
|
call spin_contamination(nal,nbe,nval,nvbe,ta1,tb1,ta2,tb2,tm2,
|
|
$ newta1,newtb1,newta2,newtb2,newtm2,dcore(iuoa),dcore(iuob),
|
|
$ dcore(iuva),dcore(iuvb),dcore(iwork),forward,iout,scf_s2,
|
|
$ localcc,indocc,.false.)
|
|
call dbldealloc(iuoa)
|
|
endif !scftype.eq.rohf }}}
|
|
|
|
if (lmp3) then
|
|
c temporarily zero t1 for MP3 until all off-diag Fock diagrams are programmed:
|
|
ta1=0.d0
|
|
tb1=0.d0
|
|
endif
|
|
|
|
if(lf12.or.qscale.or.qscale_pt) then
|
|
open(800,file='F12INTE',form='unformatted')
|
|
open(801,file='F12INT1',form='unformatted')
|
|
open(802,file='F12INT2',form='unformatted')
|
|
read(800) ecabs,emp2f12,ecoup
|
|
read(800) tfact,tscalea,tscaleb,((epaa(i,j),j=1,i-1),i=1,nal),
|
|
$((epbb(i,j),j=1,i-1),i=1,nbe),epab
|
|
call fillup(epaa,nal)
|
|
call fillup(epbb,nbe)
|
|
epba=transpose(epab)
|
|
c write(*,*) epaa
|
|
c write(*,*) epbb
|
|
c write(*,*) epab
|
|
end if
|
|
if(lf12) then
|
|
write(iout,"(' CABS singles correction [au]: ',f28.12)") ecabs
|
|
eref=eref+ecabs
|
|
write(iout,"(' Corrected reference energy [au]:',f28.12)") eref
|
|
write(iout,"(' MP2-F12 contribution [au]: ',f32.12)") emp2f12
|
|
c if(lf12s) then
|
|
c eref=eref-ecabs
|
|
cc ecoup=ecoup+emp2
|
|
c endif
|
|
endif
|
|
c Preparing for iterations
|
|
converged = .false.
|
|
if(lmp3) then
|
|
ecc=0.d0
|
|
write(iout,*)
|
|
write(iout,"(' Calculating MP3 energy...')")
|
|
else if (.not.restart) then
|
|
ecc=0.d0
|
|
write(iout,*)
|
|
write(iout,"(' Starting CCSD iterations...')")
|
|
else !if restart
|
|
if (nit.le.0) goto 1000 ! go to (T) calculation
|
|
write(iout,*)
|
|
write(iout,
|
|
&"(' Restarting CCSD iterations from iteration',i4,'...')") nit
|
|
endif !restart
|
|
write(iout,*)
|
|
if(.not.lmp3) then
|
|
write(iout,"(21x,'Residual norm',5x,
|
|
&'Correlation energy [au]')")
|
|
write(iout,"(x,61('-'))")
|
|
end if
|
|
if (.not.restart) nit=0
|
|
restart=.false. ! if restart=ccsd amplitudes are already read, if restart=(t) we already jumped to 1000
|
|
|
|
C Starting iteration
|
|
do
|
|
2000 eccold=ecc
|
|
nit=nit+1
|
|
newta1=0.d0; newtb1=0.d0
|
|
newta2=0.d0; newtb2=0.d0; newtm2=0.d0
|
|
|
|
if(lf12) then
|
|
rewind(800)
|
|
read(800)
|
|
read(800)
|
|
rewind(801)
|
|
rewind(802)
|
|
endif
|
|
|
|
eppl_os=0.d0
|
|
eppls_os=0.d0
|
|
eppl_ss=0.d0
|
|
eppls_ss=0.d0
|
|
epplij=0.d0
|
|
|
|
c Constructing the intermediates
|
|
|
|
if(.not.lmp3) then
|
|
c {{{ Various one electron intermediates
|
|
c F(ae)
|
|
c falae
|
|
if (nval.gt.0) then
|
|
do e=1,nval
|
|
do a=1,nval
|
|
if (a.ne.e) then
|
|
faae(a,e)=fa(a+nal,e+nal)
|
|
else
|
|
faae(a,e)=0.d0
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
if (nal.gt.0) then
|
|
|
|
call dgemm('n','n',nval,nval,nal,-0.5d0,
|
|
&ta1,nval,fa(1,nal+1),nal+nval,1.d0,faae,nval)
|
|
endif !nal>0
|
|
|
|
endif !nval>0
|
|
|
|
c fbeae
|
|
if (nvbe.gt.0) then
|
|
do e=1,nvbe
|
|
do a=1,nvbe
|
|
if (a.ne.e) then
|
|
fbae(a,e)=fb(a+nbe,e+nbe)
|
|
else
|
|
fbae(a,e)=0.d0
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
if (nbe.gt.0) then
|
|
call dgemm('n','n',nvbe,nvbe,nbe,-0.5d0,
|
|
&tb1,nvbe,fb(1,nbe+1),nbe+nvbe,1.d0,fbae,nvbe)
|
|
endif !nbe>0
|
|
endif !nvbe>0
|
|
|
|
c F(mi)
|
|
c falmi
|
|
if (nal.gt.0) then
|
|
do i=1,nal
|
|
do m=1,nal
|
|
if (m.ne.i) then
|
|
fami(m,i)=fa(m,i)
|
|
else
|
|
fami(m,i)=0.d0
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
if (nval.gt.0) then
|
|
call dgemm('n','n',nal,nal,nval,0.5d0,
|
|
&fa(1,nal+1),nal+nval,ta1,nval,1.d0,fami,nal)
|
|
endif !nval>0
|
|
endif !nal>0
|
|
|
|
c fbemi
|
|
if (nbe.gt.0) then
|
|
do i=1,nbe
|
|
do m=1,nbe
|
|
if (m.ne.i) then
|
|
fbmi(m,i)=fb(m,i)
|
|
else
|
|
fbmi(m,i)=0.d0
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
if (nvbe.gt.0) then
|
|
call dgemm('n','n',nbe,nbe,nvbe,0.5d0,
|
|
&fb(1,nbe+1),nbe+nvbe,tb1,nvbe,1.d0,fbmi,nbe)
|
|
endif !nvbe>0
|
|
endif !nbe>0
|
|
|
|
c F(me)
|
|
c falme
|
|
do m=1,nal
|
|
do e=1,nval
|
|
fame(e,m)=fa(m,e+nal)
|
|
enddo
|
|
enddo
|
|
|
|
c fbeme
|
|
do m=1,nbe
|
|
do e=1,nvbe
|
|
fbme(e,m)=fb(m,e+nbe)
|
|
enddo
|
|
enddo
|
|
c }}}
|
|
end if ! lmp3
|
|
|
|
if(qscale) then
|
|
eccs=0.d0
|
|
eccp=0.d0
|
|
et1s=0.d0
|
|
endif
|
|
eppl=0.d0
|
|
c W(abef)
|
|
c a,a,a,a
|
|
open(799, file='QFACTS', form='unformatted')
|
|
if (nal.gt.0.and.nval.gt.1) then
|
|
call wabefbld(nal,nval,nfa,faadr,recaadr,ta1,newta1,ta2,
|
|
&newta2,faae,scr,'iabcaa','abcda',irecln,ccsdalg,dfnbasis,
|
|
&'DFINT_AB ',.false.,tscalea,epaa,eccs,eccp,'abijaa',fa,eppl,
|
|
c &'DFINT_AB ',qscale,tscalea,epaa,eccs,eccp,'abijaa',fa,eppl,
|
|
$eppl_ss,eppls_ss,epplij,lmp3)
|
|
endif
|
|
|
|
c b,b,b,b
|
|
if (nbe.gt.0.and.nvbe.gt.1) then
|
|
call wabefbld(nbe,nvbe,nfb,fbadr,recbadr,tb1,newtb1,tb2,
|
|
&newtb2,fbae,scr,'iabcbb','abcdb',irecln,ccsdalg,dfnbasis,
|
|
&'DFINT_ABb',.false.,tscaleb,epbb,eccs,eccp,'abijbb',fb,eppl,
|
|
c &'DFINT_ABb',qscale,tscaleb,epbb,eccs,eccp,'abijbb',fb,eppl,
|
|
$eppl_ss,eppls_ss,epplij,lmp3)
|
|
endif
|
|
close(799)
|
|
|
|
c {{{ a,b,a,b
|
|
maba=nbe*nval
|
|
maab=nal*nvbe
|
|
ma=max(nbe*nval,nal*nvbe)
|
|
ab=nval*nvbe
|
|
|
|
if (nal.gt.0.and.nbe.gt.0.and.nval.gt.0.and.nvbe.gt.0) then
|
|
open(16,file='iabcba',form='unformatted')
|
|
open(17,file='iabcab',form='unformatted')
|
|
open(20,file='abcdm',access='direct',recl=irecln)
|
|
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
c Reading Jab
|
|
nblc=efmln(1,fmadr,nfm,nval)
|
|
ijaab=nblc*(ma+max(ab*2+nblc,nal*nbe+nbe,ab+nal*nbe))+1
|
|
ijbab=ijaab+dfnbasis*nval*(nval+1)/2
|
|
call rpoint2d(scr(ijaab),jaab,dfnbasis,nval*(nval+1)/2)
|
|
open(21,file='DFINT_AB',form='unformatted')
|
|
read(21) jaab
|
|
close(21)
|
|
endif !ccsdalg
|
|
|
|
do k=1,nfm
|
|
f0=fmadr(k)
|
|
fx=fmadr(k+1)-fmadr(k)
|
|
|
|
nblc=fx*nval
|
|
if(.not.lmp3) then
|
|
c iabcba
|
|
|
|
do i=1,nblc
|
|
read(16) scr((i-1)*maba+1:i*maba)
|
|
enddo
|
|
|
|
c newta1 (1)/6
|
|
call maefinp(scr,nbe,nval,nblc,scr(nblc*maba+1))
|
|
|
|
call efmiexpm2(tm2,nval,nvbe,nal,nbe,f0,fx,nblc,scr(nblc*maba+1))
|
|
|
|
if (nbe.gt.0) then
|
|
call dgemm('n','n',nval,nal,nbe*nblc,1.d0,scr,nval,
|
|
&scr(nblc*maba+1),nbe*nblc,1.d0,newta1,nval)
|
|
endif
|
|
|
|
c newtm2 (2)/7
|
|
if (nbe.gt.0) then
|
|
call dgemm('t','n',nal,nbe*nblc,nval,1.d0,ta1,nval,scr,nval,0.d0,
|
|
&scr(nblc*maba+1),nal)
|
|
endif
|
|
|
|
call ijabadd(scr(nblc*maba+1),nal,nbe,nval,nvbe,f0,fx,newtm2)
|
|
|
|
c falae (3)/3
|
|
call amefinp(scr,nval,nbe,nval,fx,scr(nblc*maba+1))
|
|
|
|
call vectblc(tb1,nvbe,nbe,f0,fx,scr(nblc*maba+1))
|
|
call dgemv('n',nval**2,nbe*fx,1.d0,scr,nval**2,scr(nblc*maba+1),
|
|
&1,1.d0,faae,1)
|
|
|
|
call aemfinp(scr,nval,nval,nbe,fx,scr(nblc*maba+1))
|
|
|
|
end if ! lmp3
|
|
|
|
c Reading abcdab
|
|
|
|
ipuff=ma*nblc+ab*nblc*2+1
|
|
abef=1
|
|
do i=1,k-1
|
|
if (ccsdalg.ne.'dfdirect') then
|
|
call getlst(20,recmadr(k*(k-1)/2+i),scr(ipuff),
|
|
&efmtile(i,k,fmadr,nfm,nval))
|
|
call abcd1(scr(ipuff),efmln(i,fmadr,nfm,nval),
|
|
&efmln(k,fmadr,nfm,nval),scr(ma*nblc+1),nval*nvbe,
|
|
&efmln(k,fmadr,nfm,nval),abef)
|
|
else !ccsdalg.eq.dfdirect
|
|
open(21,file='DFINT_ABbuccsd',access='direct',recl=irecln)
|
|
c Read JAB
|
|
jbabsize=(fmadr(i+1)-fmadr(i))*(fmadr(k+1)-fmadr(k))
|
|
call rpoint3d(scr(ijbab),jbab,dfnbasis,fmadr(i+1)-fmadr(i),
|
|
& fmadr(k+1)-fmadr(k))
|
|
call getlst(21,recjab(k*(k-1)/2+i),jbab,
|
|
& jbabsize*dfnbasis)
|
|
c Assemble square tile
|
|
call dgemm('t','n',nval*(nval+1)/2,jbabsize,dfnbasis,1.d0,
|
|
&jaab,dfnbasis,jbab,dfnbasis,0.d0,scr(ipuff),nval*(nval+1)/2)
|
|
c Place tile
|
|
call abcd1direct(scr(ipuff),scr(ma*nblc+1),nval*nvbe,abef,fmadr,
|
|
& nval,nvbe,i,k)
|
|
close(21)
|
|
endif !ccsdalg
|
|
|
|
abef=abef+efmln(i,fmadr,nfm,nval)
|
|
enddo
|
|
|
|
if (ccsdalg.ne.'dfdirect') then
|
|
call getlst(20,recmadr(k*(k-1)/2+k),scr(ipuff),
|
|
&(efmln(k,fmadr,nfm,nval)+1)*efmln(k,fmadr,nfm,nval)/2)
|
|
|
|
call abcd2(scr(ipuff),efmln(k,fmadr,nfm,nval),
|
|
&efmln(k,fmadr,nfm,nval),scr(ma*nblc+1),nval*nvbe,
|
|
&efmln(k,fmadr,nfm,nval),abef)
|
|
else !ccsdalg.eq.dfdirect
|
|
cc Read JAB
|
|
open(21,file='DFINT_ABbuccsd',access='direct',recl=irecln)
|
|
jbabsize=(fmadr(k+1)-fmadr(k)+1)*(fmadr(k+1)-fmadr(k))/2
|
|
call rpoint2d(scr(ijbab),jbabtri,dfnbasis,jbabsize)
|
|
call getlst(21,recjab(k*(k-1)/2+k),jbabtri,
|
|
& jbabsize*dfnbasis)
|
|
c Assemble square tile
|
|
call dgemm('t','n',nval*(nval+1)/2,jbabsize,dfnbasis,1.d0,
|
|
&jaab,dfnbasis,jbabtri,dfnbasis,0.d0,scr(ipuff),nval*(nval+1)/2)
|
|
c Place tile
|
|
call abcd2direct(scr(ipuff),scr(ma*nblc+1),nval*nvbe,abef,fmadr,
|
|
&nval,nvbe,k)
|
|
close(21)
|
|
endif !ccsdalg
|
|
|
|
abef=abef+efmln(k,fmadr,nfm,nval)
|
|
|
|
do i=k+1,nfm
|
|
if (ccsdalg.ne.'dfdirect') then
|
|
call getlst(20,recmadr(i*(i-1)/2+k),scr(ipuff),
|
|
&efmtile(k,i,fmadr,nfm,nval))
|
|
|
|
call abcd3(scr(ipuff),efmln(k,fmadr,nfm,nval),
|
|
&efmln(i,fmadr,nfm,nval),scr(ma*nblc+1),nval*nvbe,
|
|
&efmln(k,fmadr,nfm,nval),abef)
|
|
else !ccsdalg.eq.dfdirect
|
|
open(21,file='DFINT_ABbuccsd',access='direct',recl=irecln)
|
|
c Read JAB
|
|
jbabsize=(fmadr(k+1)-fmadr(k))*(fmadr(i+1)-fmadr(i))
|
|
call rpoint3d(scr(ijbab),jbab,dfnbasis,fmadr(k+1)-fmadr(k),
|
|
& fmadr(i+1)-fmadr(i))
|
|
call getlst(21,recjab(i*(i-1)/2+k),jbab,
|
|
& jbabsize*dfnbasis)
|
|
c Assemble square tile
|
|
call dgemm('t','n',nval*(nval+1)/2,jbabsize,dfnbasis,1.d0,
|
|
&jaab,dfnbasis,jbab,dfnbasis,0.d0,scr(ipuff),nval*(nval+1)/2)
|
|
c Place tile
|
|
call abcd3direct(scr(ipuff),scr(ma*nblc+1),nval*nvbe,abef,fmadr,
|
|
&nval,nvbe,i,k)
|
|
close(21)
|
|
endif !ccsdalg
|
|
|
|
abef=abef+efmln(i,fmadr,nfm,nval)
|
|
enddo
|
|
close(21)
|
|
|
|
c if(qscale) then
|
|
c open(543,file='UCCSD_RES',form='unformatted')
|
|
c write(543) newtm2
|
|
c call taumbld2(tm2,ta1,tb1,nval,nvbe,nal,nbe,f0,fx,
|
|
c &scr((ma+ab)*nblc+1))
|
|
c ij=nal*nbe
|
|
c call dgemm('n','n',ab,ij,nblc,1.d0,
|
|
c &scr(ma*nblc+1),ab,scr((ma+ab)*nblc+1),nblc,0.d0,newtm2,ab)
|
|
c call scaleppl_ab(nal,nbe,nval,nvbe,fa,fb,newtm2,
|
|
c $scr((ma+ab)*nblc+1),tscalea,tscaleb,epab,eccs,eccp,eppl,epplc,
|
|
c $eccsc,epplij)
|
|
c eppl_os=eppl_os+epplc
|
|
c eppls_os=eppls_os+eccsc
|
|
c rewind(543)
|
|
c read(543) newtm2
|
|
c close(543)
|
|
c endif
|
|
|
|
if(.not.lmp3) then
|
|
if (nbe.gt.0) then
|
|
call dgemm('n','n',nvbe,nval*nblc,nbe,-1.d0,tb1,nvbe,scr,nbe,
|
|
&0.d0,scr(ma*nblc+ab*nblc+1),nvbe)
|
|
endif
|
|
|
|
call vxyzswadd(scr(ma*nblc+nval*nvbe*nblc+1),nvbe,nval,nval,
|
|
&fx,scr(ma*nblc+1))
|
|
|
|
c iabcab
|
|
do i=1,nblc
|
|
read(17) scr((i-1)*maab+1:i*maab)
|
|
enddo
|
|
|
|
if (nbe.gt.0) then
|
|
call dgemm('n','n',nval,nvbe*nblc,nal,-1.d0,ta1,nval,scr,nal,
|
|
&1.d0,scr(ma*nblc+1),nval)
|
|
endif
|
|
end if ! lmp3
|
|
|
|
c newtm2 (2)/5
|
|
call taumbld2(tm2,ta1,tb1,nval,nvbe,nal,nbe,f0,fx,
|
|
&scr((ma+ab)*nblc+1))
|
|
|
|
ij=nal*nbe
|
|
call dgemm('n','n',ab,ij,nblc,1.d0,
|
|
&scr(ma*nblc+1),ab,scr((ma+ab)*nblc+1),nblc,1.d0,newtm2,ab)
|
|
|
|
if(.not.lmp3) then
|
|
c newtb1 (1)/6
|
|
call maefinp(scr,nal,nvbe,nblc,scr(nblc*maab+1))
|
|
|
|
call efmiexpm1(tm2,nval,nvbe,nal,nbe,f0,fx,nblc,scr(nblc*maab+1))
|
|
if (nbe.gt.0) then
|
|
call dgemm('n','n',nvbe,nbe,nal*nblc,1.d0,scr,nvbe,
|
|
&scr(nblc*maab+1),nal*nblc,1.d0,newtb1,nvbe)
|
|
endif
|
|
|
|
c newtm2 (2)/7
|
|
if (nbe.gt.0) then
|
|
call dgemm('t','n',nbe,nal*nblc,nvbe,1.d0,tb1,nvbe,scr,nvbe,0.d0,
|
|
&scr(nblc*maab+1),nbe)
|
|
endif
|
|
|
|
call jiabadd(scr(nblc*maab+1),nbe,nal,nval,nvbe,f0,fx,newtm2)
|
|
|
|
c fbeae (3)/3
|
|
call amfeinp(scr,nvbe,nal,nval,fx,scr(nblc*maab+1))
|
|
|
|
call dgemv('t',nval*nal,nvbe*fx,1.d0,scr,nval*nal,
|
|
&ta1,1,1.d0,fbae(1,f0),1)
|
|
|
|
end if ! lmp3
|
|
|
|
enddo
|
|
|
|
close(16)
|
|
close(17)
|
|
close(20)
|
|
endif !nval>0,nvbe>0
|
|
c }}}
|
|
|
|
c W(mnij)
|
|
c a,a,a,a
|
|
if (nal.gt.1) then
|
|
call wmnijbld(nal,nval,ta1,newta1,ta2,newta2,faae,fame,fami,
|
|
&scr,'aijkaa','ijklaa','abijaa',lf12,qscale,tscalea,epaa,lmp3)
|
|
endif !nal>1
|
|
|
|
c b,b,b,b
|
|
if (nbe.gt.1) then
|
|
call wmnijbld(nbe,nvbe,tb1,newtb1,tb2,newtb2,fbae,fbme,fbmi,
|
|
&scr,'aijkbb','ijklbb','abijbb',lf12,qscale,tscaleb,epbb,lmp3)
|
|
endif
|
|
|
|
c {{{ a,b,a,b
|
|
if (nal.gt.0.and.nbe.gt.0) then
|
|
if(lmp3) then
|
|
call dfillzero(scr, (nal*nbe)**2)
|
|
else
|
|
if (nval.gt.0) then
|
|
aijk=nval*nal*nbe**2
|
|
open(16,file='aijkab',form='unformatted')
|
|
read(16) scr(1:aijk)
|
|
close(16)
|
|
aijk=max(nval*nal*nbe**2,nal**2*nbe**2)
|
|
|
|
c fbemi (4)/3
|
|
mi=nbe**2
|
|
call yzvxrea(scr,nval,nbe,nal,nbe,scr(aijk+1))
|
|
call dgemv('t',nal*nval,mi,1.d0,
|
|
&scr(aijk+1),nal*nval,ta1,1,1.d0,fbmi,1)
|
|
|
|
c newtm2 (2)/8
|
|
aij=nval*nal*nbe
|
|
call vxyzsw(scr,nval,nbe,nal,nbe,scr(aijk+1))
|
|
|
|
c newtb1 (1)/7
|
|
men=nal*nbe*nval
|
|
call vxyzsw(tm2,nval,nvbe,nal,nbe,scr(aijk*2+1))
|
|
call dgemm('n','t',nvbe,nbe,men,-1.d0,
|
|
&scr(aijk*2+1),nvbe,scr(aijk+1),nbe,1.d0,newtb1,nvbe)
|
|
|
|
C Add F12 contribution
|
|
if(lf12) then
|
|
read(802) scr(aijk*2+1:aijk*2+nbe*nval*nal*nbe)
|
|
call daxpy(nbe*nval*nal*nbe,1.d0,scr(aijk*2+1),1,scr(aijk+1),1)
|
|
endif
|
|
C F12 end
|
|
call dgemm('n','n',nvbe,aij,nbe,-1.d0,
|
|
&tb1,nvbe,scr(aijk+1),nbe,0.d0,scr(aijk*2+1),nvbe)
|
|
|
|
call vxyzswadd(scr(aijk*2+1),nvbe,nval,nal,nbe,newtm2)
|
|
|
|
c wabmnij (6)/2
|
|
mni=nbe**2*nal
|
|
call dgemm('t','n',nal,mni,nval,1.d0,
|
|
&ta1,nval,scr,nval,0.d0,scr(aijk+1),nal)
|
|
|
|
call vtrp(scr(aijk+1),nal*nbe,nal*nbe,scr)
|
|
|
|
endif !nval>0
|
|
end if ! lmp3
|
|
c wabmnij (6)/1
|
|
ik=(nal*nbe)**2
|
|
open(16,file='ijklab',form='unformatted')
|
|
read(16) scr(ik+1:ik+(nbe*nal+1)*nbe*nal/2)
|
|
close(16)
|
|
|
|
call ijkladd(scr,scr(ik+1),nbe*nal)
|
|
|
|
if(.not.lmp3) then
|
|
if (nvbe.gt.0) then
|
|
aijk=nvbe*nal**2*nbe
|
|
open(16,file='aijkba',form='unformatted')
|
|
read(16) scr(ik+1:ik+aijk)
|
|
close(16)
|
|
|
|
c fami (4)/3
|
|
mi=nal**2
|
|
call yzvxrea(scr(ik+1),nvbe,nal,nbe,nal,scr(ik+aijk+1))
|
|
call dgemv('t',nbe*nvbe,mi,1.d0,
|
|
&scr(ik+aijk+1),nbe*nvbe,tb1,1,1.d0,fami,1)
|
|
|
|
c newta1 (1)/7
|
|
if (nval.gt.0) then
|
|
men=nal*nbe*nvbe
|
|
call vxyzdsw(scr(ik+1),nvbe,nal,nbe,nal,scr(ik+aijk+1))
|
|
call dgemm('n','t',nval,nal,men,-1.d0,
|
|
&tm2,nval,scr(ik+aijk+1),nal,1.d0,newta1,nval)
|
|
endif !nval>0
|
|
|
|
c wabmnij (6)/2
|
|
mni=nal**2*nbe
|
|
call dgemm('t','n',mni,nbe,nvbe,1.d0,
|
|
&scr(ik+1),nvbe,tb1,nvbe,1.d0,scr,mni)
|
|
|
|
C Add F12 contribution
|
|
if(lf12) then
|
|
read(802) scr(ik+1:ik+nal*nvbe*nal*nbe)
|
|
call daxpy(nal*nvbe*nal*nbe,1.d0,scr(ik+1),1,scr(ik+aijk+1),1)
|
|
endif
|
|
C F12 end
|
|
|
|
c newtm2 (2)/8
|
|
if (nval.gt.0) then
|
|
aij=nvbe*nal*nbe
|
|
call dgemm('n','n',nval,aij,nal,-1.d0,
|
|
&ta1,nval,scr(ik+aijk+1),nal,1.d0,newtm2,nval)
|
|
endif !nval>0
|
|
endif !nvbe>0
|
|
end if ! lmp3
|
|
|
|
c wabmnij (6)/3
|
|
if (nval.gt.0.and.nvbe.gt.0) then
|
|
ef=nval*nvbe
|
|
mn=nal*nbe
|
|
mnef=mn*ef
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) scr(ik+1:ik+mnef)
|
|
close(16)
|
|
|
|
c newtm2 (2)/1
|
|
c if(qscale) then
|
|
c call scaleabij_ab(nal,nbe,nval,nvbe,newtm2,scr(ik+1),tscalea,
|
|
c &tscaleb,epab)
|
|
c else
|
|
call daxpy(mnef,1.d0,scr(ik+1),1,newtm2,1)
|
|
c endif
|
|
|
|
if(.not.lmp3) then
|
|
call taumbld(tm2,ta1,tb1,nval,nvbe,nal,nbe,scr(ik+mnef+1))
|
|
call dgemm('t','n',mn,mn,ef,1.d0,
|
|
&scr(ik+1),ef,scr(ik+mnef+1),ef,1.d0,scr,mn)
|
|
|
|
c falae (3)/4
|
|
fmn=nvbe*nal*nbe
|
|
call tautmbld(tm2,ta1,tb1,nval,nvbe,nal,nbe,scr(ik+mnef+1))
|
|
call dgemm('n','t',nval,nval,fmn,-1.d0,
|
|
&scr(ik+mnef+1),nval,scr(ik+1),nval,1.d0,faae,nval)
|
|
|
|
c fbeae (3)/4
|
|
fmn=nval*nal*nbe
|
|
call tautmbld2(tm2,ta1,tb1,nval,nvbe,nal,nbe,scr(ik+mnef*2+1))
|
|
call vxyzsw(scr(ik+1),nval,nvbe,nal,nbe,scr(ik+mnef+1))
|
|
call dgemm('n','t',nvbe,nvbe,fmn,-1.d0,
|
|
&scr(ik+mnef*2+1),nvbe,scr(ik+mnef+1),nvbe,1.d0,fbae,nvbe)
|
|
|
|
c falmi (4)/4
|
|
nef=nbe*nval*nvbe
|
|
call vxyzrea(scr(ik+1),nval,nvbe,nal,nbe,scr(ik+mnef+1))
|
|
call tautmbld3(tm2,ta1,tb1,nval,nvbe,nal,nbe,scr(ik+mnef*2+1))
|
|
call dgemm('n','t',nal,nal,nef,1.d0,
|
|
&scr(ik+mnef+1),nal,scr(ik+mnef*2+1),nal,1.d0,fami,nal)
|
|
|
|
c fbemi (4)/4
|
|
nef=nal*nvbe*nval
|
|
call tautmbld(tm2,ta1,tb1,nval,nvbe,nal,nbe,scr(ik+mnef+1))
|
|
call dgemm('t','n',nbe,nbe,nef,1.d0,
|
|
&scr(ik+1),nef,scr(ik+mnef+1),nef,1.d0,fbmi,nbe)
|
|
|
|
c falme (5)/2
|
|
me=nval*nal
|
|
nff=nvbe*nbe
|
|
call vxyzext(scr(ik+1),nval,nvbe,nal,nbe,scr(ik+mnef+1))
|
|
call dgemv('n',me,nff,1.d0,scr(ik+mnef+1),me,tb1,1,1.d0,fame,1)
|
|
c fbeme (5)/2
|
|
me=nvbe*nbe
|
|
nff=nval*nal
|
|
call vxyzext(scr(ik+1),nval,nvbe,nal,nbe,scr(ik+mnef+1))
|
|
call dgemv('t',nff,me,1.d0,scr(ik+mnef+1),nff,ta1,1,1.d0,fbme,1)
|
|
|
|
C Add F12 contribution
|
|
if(lf12) then
|
|
read(802) scr(ik+1:ik+nal*nbe*nal*nbe)
|
|
call daxpy(nal*nbe*nal*nbe,1.d0,scr(ik+1),1,scr,1)
|
|
endif
|
|
C F12 end
|
|
end if ! lmp3
|
|
|
|
c newtm2 (2)/4
|
|
ab=nval*nvbe
|
|
ij=nal*nbe
|
|
call taumbld(tm2,ta1,tb1,nval,nvbe,nal,nbe,scr(ik+1))
|
|
call dgemm('n','n',ab,ij,ij,1.d0,
|
|
&scr(ik+1),ab,scr,ij,1.d0,newtm2,ab)
|
|
|
|
endif !nval>0,nvbe>0
|
|
endif !nal>0,nbe>0
|
|
c }}}
|
|
|
|
c {{{ W(mbej)
|
|
c a,a,a,a
|
|
if (nal.gt.0.and.nval.gt.0) then
|
|
mebj=(nal*nval)**2
|
|
open(16,file='iabjaa',form='unformatted')
|
|
read(16) scr(1:mebj)
|
|
close(16)
|
|
|
|
if(.not.lmp3) then
|
|
c ta1 (1)/5
|
|
ai=nval*nal
|
|
call vtrp(ta1,nval,nal,scr(mebj+1))
|
|
call dgemv('t',ai,ai,-1.d0,scr,ai,scr(mebj+1),1,1.d0,newta1,1)
|
|
|
|
c ta2 (2)/6b
|
|
call ttbld(ta1,ta1,nval,nal,nval,nal,scr(mebj+1))
|
|
call dgemm('n','n',ai,ai,ai,1.d0,
|
|
&scr(mebj+1),ai,scr,ai,0.d0,scr(mebj*2+1),ai)
|
|
|
|
call abijfold(scr(mebj*2+1),nval,nal,nval,nal,newta2)
|
|
end if ! lmp3
|
|
scr(1:mebj)=-scr(1:mebj)
|
|
|
|
if(.not.lmp3) then
|
|
c walmebj (8)/3
|
|
ejm=nval*nal*nal
|
|
aijk=nval*nal**3
|
|
if (nal.gt.1.and.nval.gt.0) then
|
|
open(16,file='aijkaa',form='unformatted')
|
|
read(16) scr(mebj+aijk+1:mebj+aijk+nval*nal**2*(nal-1)/2)
|
|
close(16)
|
|
|
|
call yzxxunb(scr(mebj+aijk+1),nval,nal,nal,nal,scr(mebj+1))
|
|
call dgemm('n','t',ejm,nval,nal,-1.d0,scr(mebj+1),
|
|
&ejm,ta1,nval,0.d0,scr(mebj+aijk+1),ejm)
|
|
|
|
call ejmbrea(scr(mebj+aijk+1),nval,nal,nal,nval,scr)
|
|
endif !nal>0,nval>1
|
|
|
|
c walmebj (8)/2
|
|
if (nval.gt.1) then
|
|
f0=0
|
|
fx=0
|
|
mb=nval*nal
|
|
mebj=nval*nval*nal*nal
|
|
scr(mebj+1:mebj*2)=0.d0
|
|
|
|
open(16,file='iabcaa',form='unformatted')
|
|
do while (f0.lt.nval)
|
|
fx=int((dsqrt(dble(f0**2)+
|
|
&4.d0*dble(maxcor-imem+imem1-mebj*2)/dble(mb))-f0)/2.d0)
|
|
if (f0+fx.gt.nval) fx=nval-f0
|
|
|
|
do c=0,fx-1
|
|
do b=1,f0+c
|
|
read(16) scr(mebj*2+c*mb*(f0+fx)+(b-1)*mb+1:
|
|
& mebj*2+c*mb*(f0+fx)+b*mb)
|
|
enddo
|
|
scr(mebj*2+mb*((f0+fx)*c+(f0+c))+1:
|
|
&mebj*2+mb*((f0+fx)*c+(f0+c)+1))=0.d0
|
|
enddo
|
|
|
|
call rectfold(scr(mebj*2+1),f0,fx,mb)
|
|
|
|
call dgemm('n','n',(f0+fx)*mb,nal,fx,-1.d0,scr(mebj*2+1),
|
|
&(f0+fx)*mb,ta1(f0+1,1),nval,1.d0,scr(mebj+1),mb*nval)
|
|
|
|
do b=1,fx
|
|
call dgemm('n','n',mb,nal,f0,1.d0,
|
|
&scr(mebj*2+(b-1)*(f0+fx)*mb+1),mb,ta1,nval,1.d0,
|
|
&scr(mebj+(f0+b-1)*mb+1),mb*nval)
|
|
enddo
|
|
|
|
f0=f0+fx
|
|
enddo
|
|
|
|
close(16)
|
|
|
|
call mebjreadd(scr(mebj+1),nal,nval,nval,nal,scr)
|
|
|
|
endif !nval>1
|
|
|
|
c walmebj (8)/4
|
|
mnef=nval*nval*nal*nal
|
|
abij=nval*(nval-1)*nal*(nal-1)/4
|
|
open(16,file='abijaa',form='unformatted')
|
|
read(16) scr(mebj+mnef+1:mebj+mnef+abij)
|
|
close(16)
|
|
|
|
call vzext(scr(mebj+mnef+1),nval,nval,nal,nal,scr(mebj+1))
|
|
call tttbld(ta2,nval,nval,nal,nal,ta1,ta1,scr(mebj+mnef+1))
|
|
|
|
me=nval*nal
|
|
call dgemm('t','n',me,me,me,-1.d0,
|
|
&scr(mebj+1),me,scr(mebj+mnef+1),me,1.d0,scr,me)
|
|
|
|
if (nvbe.gt.0.and.nbe.gt.0) then
|
|
mnef=nval*nvbe*nal*nbe
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) scr(mebj+mnef+1:mebj+mnef*2)
|
|
close(16)
|
|
|
|
me=nval*nal
|
|
call vzsw(scr(mebj+mnef+1),nval,nvbe,nal,nbe,scr(mebj+1))
|
|
call bfjnrea(tm2,nval,nvbe,nal,nbe,scr(mebj+mnef+1))
|
|
|
|
nff=nbe*nvbe
|
|
call dgemm('t','n',me,me,nff,0.5d0,
|
|
&scr(mebj+1),nff,scr(mebj+mnef+1),nff,1.d0,scr,me)
|
|
|
|
endif !nvbe>0,nbe>0
|
|
end if ! lmp3
|
|
|
|
c newta2 (2)/6a
|
|
ai=nval*nal
|
|
call xxyyext2(ta2,nval,nval,nal,nal,scr(mebj+1))
|
|
call dgemm('n','n',ai,ai,ai,1.d0,
|
|
&scr(mebj+1),ai,scr,ai,0.d0,scr(mebj+ai**2+1),ai)
|
|
|
|
call abijfold(scr(mebj+ai**2+1),nval,nal,nval,nal,newta2)
|
|
|
|
c newtm2 (2)/6a
|
|
if (nvbe.gt.0.and.nbe.gt.0) then
|
|
ai=nval*nal
|
|
bj=nvbe*nbe
|
|
call vxyzrea(tm2,nval,nvbe,nal,nbe,scr(mebj+1))
|
|
call dgemm('t','n',ai,bj,ai,1.d0,
|
|
&scr,ai,scr(mebj+1),ai,0.d0,scr(mebj+ai*bj+1),ai)
|
|
|
|
call vxyzextadd(scr(mebj+ai*bj+1),nval,nal,nvbe,nbe,newtm2)
|
|
|
|
endif !nvbe>0,nbe>0
|
|
endif !nval>0,nal>0
|
|
|
|
c b,b,b,b
|
|
if (nvbe.gt.0.and.nbe.gt.0) then
|
|
mebj=(nbe*nvbe)**2
|
|
open(16,file='iabjbb',form='unformatted')
|
|
read(16) scr(1:mebj)
|
|
close(16)
|
|
|
|
if(.not.lmp3) then
|
|
c tb1 (1)/5
|
|
ai=nvbe*nbe
|
|
call vtrp(tb1,nvbe,nbe,scr(mebj+1))
|
|
call dgemv('t',ai,ai,-1.d0,scr,ai,scr(mebj+1),1,1.d0,newtb1,1)
|
|
|
|
c tb2 (2)/6b
|
|
call ttbld(tb1,tb1,nvbe,nbe,nvbe,nbe,scr(mebj+1))
|
|
call dgemm('n','n',ai,ai,ai,1.d0,
|
|
&scr(mebj+1),ai,scr,ai,0.d0,scr(mebj*2+1),ai)
|
|
|
|
call abijfold(scr(mebj*2+1),nvbe,nbe,nvbe,nbe,newtb2)
|
|
end if ! lmp3
|
|
scr(1:mebj)=-scr(1:mebj)
|
|
|
|
if(.not.lmp3) then
|
|
c wbemebj (8)/3
|
|
ejm=nvbe*nbe*nbe
|
|
aijk=nvbe*nbe**3
|
|
if (nbe.gt.1.and.nvbe.gt.0) then
|
|
open(16,file='aijkbb',form='unformatted')
|
|
read(16) scr(mebj+aijk+1:mebj+aijk+nvbe*nbe**2*(nbe-1)/2)
|
|
close(16)
|
|
|
|
call yzxxunb(scr(mebj+aijk+1),nvbe,nbe,nbe,nbe,scr(mebj+1))
|
|
call dgemm('n','t',ejm,nvbe,nbe,-1.d0,scr(mebj+1),
|
|
&ejm,tb1,nvbe,0.d0,scr(mebj+aijk+1),ejm)
|
|
|
|
call ejmbrea(scr(mebj+aijk+1),nvbe,nbe,nbe,nvbe,scr)
|
|
endif !nbe>1,nvbe>0
|
|
|
|
c wbemebj (8)/2
|
|
if (nvbe.gt.1) then
|
|
f0=0
|
|
fx=0
|
|
mb=nvbe*nbe
|
|
mebj=nvbe*nvbe*nbe*nbe
|
|
scr(mebj+1:mebj*2)=0.d0
|
|
|
|
open(16,file='iabcbb',form='unformatted')
|
|
|
|
do while (f0.lt.nvbe)
|
|
fx=int((dsqrt(dble(f0**2)+
|
|
&4.d0*dble(maxcor-imem+imem1-mebj*2)/dble(mb))-f0)/2.d0)
|
|
if (f0+fx.gt.nvbe) fx=nvbe-f0
|
|
|
|
do c=0,fx-1
|
|
do b=1,f0+c
|
|
read(16) scr(mebj*2+c*mb*(f0+fx)+(b-1)*mb+1:
|
|
& mebj*2+c*mb*(f0+fx)+b*mb)
|
|
enddo
|
|
scr(mebj*2+mb*((f0+fx)*c+(f0+c))+1:
|
|
&mebj*2+mb*((f0+fx)*c+(f0+c)+1))=0.d0
|
|
enddo
|
|
|
|
call rectfold(scr(mebj*2+1),f0,fx,mb)
|
|
|
|
call dgemm('n','n',(f0+fx)*mb,nbe,fx,-1.d0,scr(mebj*2+1),
|
|
&(f0+fx)*mb,tb1(f0+1,1),nvbe,1.d0,scr(mebj+1),mb*nvbe)
|
|
|
|
do b=1,fx
|
|
call dgemm('n','n',mb,nbe,f0,1.d0,
|
|
&scr(mebj*2+(b-1)*(f0+fx)*mb+1),mb,tb1,nvbe,1.d0,
|
|
&scr(mebj+(f0+b-1)*mb+1),mb*nvbe)
|
|
enddo
|
|
|
|
f0=f0+fx
|
|
enddo
|
|
|
|
close(16)
|
|
|
|
call mebjreadd(scr(mebj+1),nbe,nvbe,nvbe,nbe,scr)
|
|
|
|
endif !nvbe>1
|
|
|
|
c wbemebj (8)/4
|
|
mnef=nvbe*nvbe*nbe*nbe
|
|
abij=nvbe*(nvbe-1)*nbe*(nbe-1)/4
|
|
open(16,file='abijbb',form='unformatted')
|
|
read(16) scr(mebj+mnef+1:mebj+mnef+abij)
|
|
close(16)
|
|
|
|
call vzext(scr(mebj+mnef+1),nvbe,nvbe,nbe,nbe,scr(mebj+1))
|
|
call tttbld(tb2,nvbe,nvbe,nbe,nbe,tb1,tb1,scr(mebj+mnef+1))
|
|
|
|
me=nvbe*nbe
|
|
call dgemm('t','n',me,me,me,-1.d0,
|
|
&scr(mebj+1),me,scr(mebj+mnef+1),me,1.d0,scr,me)
|
|
|
|
if (nval.gt.0.and.nal.gt.0) then
|
|
mnef=nval*nvbe*nal*nbe
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) scr(mebj+mnef+1:mebj+mnef*2)
|
|
close(16)
|
|
|
|
me=nvbe*nbe
|
|
call vzsw(scr(mebj+mnef+1),nval,nvbe,nal,nbe,scr(mebj+1))
|
|
nff=nal*nval
|
|
call vxyzrea(tm2,nval,nvbe,nal,nbe,scr(mebj+mnef+1))
|
|
call dgemm('n','n',me,me,nff,0.5d0,
|
|
&scr(mebj+1),me,scr(mebj+mnef+1),nff,1.d0,scr,me)
|
|
|
|
endif !nval>0,nal>0
|
|
end if ! lmp3
|
|
|
|
c newtb2 (2)/6a
|
|
ai=nvbe*nbe
|
|
call xxyyext2(tb2,nvbe,nvbe,nbe,nbe,scr(mebj+1))
|
|
call dgemm('n','n',ai,ai,ai,1.d0,
|
|
&scr(mebj+1),ai,scr,ai,0.d0,scr(mebj+ai**2+1),ai)
|
|
|
|
call abijfold(scr(mebj+ai**2+1),nvbe,nbe,nvbe,nbe,newtb2)
|
|
|
|
c newtm2 (2)/6a
|
|
if (nval.gt.0.and.nal.gt.0) then
|
|
ai=nval*nal
|
|
bj=nvbe*nbe
|
|
call yzvxrea(tm2,nval,nvbe,nal,nbe,scr(mebj+1))
|
|
call dgemm('n','n',ai,bj,bj,1.d0,
|
|
&scr(mebj+1),ai,scr,bj,0.d0,scr(mebj+ai*bj+1),ai)
|
|
|
|
call vxyzextadd(scr(mebj+ai*bj+1),nval,nal,nvbe,nbe,newtm2)
|
|
|
|
endif !nval>0,nal>0
|
|
endif !nvbe>0,nbe>0
|
|
|
|
c a,b,a,b
|
|
if (nval.gt.0.and.nal.gt.0.and.nvbe.gt.0.and.nbe.gt.0) then
|
|
mebj=nbe*nvbe*nval*nal
|
|
|
|
c Read abijab and transpose to iaBJ
|
|
!open(16,file='iabjab',form='unformatted')
|
|
!read(16) scr(1:mebj)
|
|
!close(16)
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) scr(mebj+1:2*mebj)
|
|
call vxyzrea(scr(mebj+1),nval,nvbe,nal,nbe,scr)
|
|
close(16)
|
|
|
|
if(.not.lmp3) then
|
|
c newtb1 (1)/5
|
|
ai=nvbe*nbe
|
|
bj=nval*nal
|
|
call vtrp(ta1,nval,nal,scr(mebj+1))
|
|
call dgemv('t',bj,ai,1.d0,scr,
|
|
&bj,scr(mebj+1),1,1.d0,newtb1,1)
|
|
|
|
c newtm2 (2)/6b
|
|
ai=nval*nal
|
|
bj=nvbe*nbe
|
|
call ttbld(ta1,ta1,nval,nal,nval,nal,scr(mebj+1))
|
|
call dgemm('n','n',ai,bj,ai,-1.d0,
|
|
&scr(mebj+1),ai,scr,ai,0.d0,scr(mebj+ai**2+1),ai)
|
|
c
|
|
call vxyzextadd(scr(mebj+ai**2+1),nval,nal,nvbe,nbe,newtm2)
|
|
|
|
c Reading aijkab
|
|
c scr(1:mebj)=-scr(1:mebj)
|
|
aijk=nval*nal*nbe**2
|
|
open(16,file='aijkab',form='unformatted')
|
|
read(16) scr(mebj+1:mebj+aijk)
|
|
close(16)
|
|
|
|
c wabmebj (8)/3
|
|
ejm=nval*nal*nbe
|
|
call dgemm('n','t',ejm,nvbe,nbe,-1.d0,
|
|
&scr(mebj+1),ejm,tb1,nvbe,0.d0,scr(mebj+aijk+1),ejm)
|
|
|
|
call ejmbrea(scr(mebj+aijk+1),nval,nbe,nal,nvbe,scr)
|
|
|
|
c wabmebj (8)/2
|
|
f0=0
|
|
fx=0
|
|
mb=nal*nvbe
|
|
mebj=nal*nvbe*nval*nbe
|
|
scr(mebj+1:mebj*2)=0.d0
|
|
|
|
open(16,file='iabcab',form='unformatted')
|
|
|
|
do while (f0.lt.nvbe)
|
|
fx=(maxcor-imem+imem1-mebj*2)/(mb*nval)
|
|
if (fx.gt.nvbe-f0) fx=nvbe-f0
|
|
|
|
do i=1,fx
|
|
do e=1,nval
|
|
read(16) scr(mebj*2+(i-1)*nval*mb+(e-1)*mb+1:
|
|
& mebj*2+(i-1)*nval*mb+e*mb)
|
|
enddo
|
|
enddo
|
|
|
|
call dgemm('n','n',mb*nval,nbe,fx,1.d0,scr(mebj*2+1),mb*nval,
|
|
&tb1(f0+1,1),nvbe,1.d0,scr(mebj+1),mb*nval)
|
|
|
|
f0=f0+fx
|
|
enddo
|
|
|
|
close(16)
|
|
|
|
call mebjreadd(scr(mebj+1),nal,nvbe,nval,nbe,scr)
|
|
|
|
c wabmebj (8)/4
|
|
mnef=nval*nvbe*nal*nbe
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) scr(mebj+mnef+1:mebj+mnef*2)
|
|
close(16)
|
|
|
|
call vzsw(scr(mebj+mnef+1),nval,nvbe,nal,nbe,scr(mebj+1))
|
|
call tttbld(tb2,nvbe,nvbe,nbe,nbe,tb1,tb1,
|
|
&scr(mebj+mnef+1))
|
|
|
|
me=nval*nal
|
|
bj=nbe*nvbe
|
|
call dgemm('t','n',me,bj,bj,-1.d0,
|
|
&scr(mebj+1),bj,scr(mebj+mnef+1),bj,1.d0,scr,me)
|
|
|
|
mnef=nval**2*nal**2
|
|
open(16,file='abijaa',form='unformatted')
|
|
read(16) scr(mebj+mnef+1:mebj+mnef+nval*(nval-1)*nal*(nal-1)/4)
|
|
close(16)
|
|
|
|
call vzext(scr(mebj+mnef+1),nval,nval,nal,nal,scr(mebj+1))
|
|
call vxyzrea(tm2,nval,nvbe,nal,nbe,scr(mebj+mnef+1))
|
|
|
|
call dgemm('t','n',me,bj,me,0.5d0,
|
|
&scr(mebj+1),me,scr(mebj+mnef+1),me,1.d0,scr,me)
|
|
|
|
end if ! lmp3
|
|
|
|
c contracting wmebj
|
|
c newtb2 (2)/6a
|
|
ai=nvbe*nbe
|
|
me=nval*nal
|
|
call vxyzrea(tm2,nval,nvbe,nal,nbe,scr(mebj+1))
|
|
call dgemm('t','n',ai,ai,me,1.d0,
|
|
&scr(mebj+1),me,scr,me,0.d0,scr(mebj+ai*me+1),ai)
|
|
|
|
call abijfold(scr(mebj+ai*me+1),nvbe,nbe,nvbe,nbe,newtb2)
|
|
|
|
ai=nval*nal
|
|
bj=nvbe*nbe
|
|
call xxyyext2(ta2,nval,nval,nal,nal,scr(mebj+1))
|
|
call dgemm('n','n',ai,bj,ai,1.d0,
|
|
&scr(mebj+1),ai,scr,ai,0.d0,scr(mebj+ai**2+1),ai)
|
|
|
|
call vxyzextadd(scr(mebj+ai**2+1),nval,nal,nvbe,nbe,newtm2)
|
|
|
|
endif !nval>0,nal>0,nvbe>0,nbe>0
|
|
|
|
c b,a,b,a
|
|
if (nval.gt.0.and.nal.gt.0.and.nvbe.gt.0.and.nbe.gt.0) then
|
|
mebj=nbe*nvbe*nval*nal
|
|
!open(16,file='iabjba',form='unformatted')
|
|
!read(16) scr(1:mebj)
|
|
!close(16)
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) scr(mebj+1:2*mebj)
|
|
close(16)
|
|
call bfjnrea(scr(mebj+1),nval,nvbe,nal,nbe,scr)
|
|
c if (.not.dfcalc) scr(1:mebj)=-scr(1:mebj)
|
|
|
|
if(.not.lmp3) then
|
|
c newta1 (1)/5
|
|
ai=nval*nal
|
|
bj=nvbe*nbe
|
|
call vtrp(tb1,nvbe,nbe,scr(mebj+1))
|
|
call dgemv('t',bj,ai,1.d0,scr,bj,scr(mebj+1),1,1.d0,newta1,1)
|
|
|
|
c newtm2 (2)/6b
|
|
call ttbld(tb1,tb1,nvbe,nbe,nvbe,nbe,scr(mebj+1))
|
|
call dgemm('t','t',ai,bj,bj,-1.d0,
|
|
&scr,bj,scr(mebj+1),bj,0.d0,scr(mebj+nvbe**2*nbe**2+1),ai)
|
|
|
|
call vxyzextadd
|
|
&(scr(mebj+nvbe**2*nbe**2+1),nval,nal,nvbe,nbe,newtm2)
|
|
|
|
c Reading aijkba
|
|
aijk=nvbe*nbe*nal**2
|
|
open(16,file='aijkba',form='unformatted')
|
|
read(16) scr(mebj+1:mebj+aijk)
|
|
close(16)
|
|
|
|
c wbamebj (8)/3
|
|
ejm=nvbe*nal*nbe
|
|
call dgemm('n','t',ejm,nval,nal,-1.d0,
|
|
&scr(mebj+1),ejm,ta1,nval,0.d0,scr(mebj+aijk+1),ejm)
|
|
|
|
call ejmbrea(scr(mebj+aijk+1),nvbe,nal,nbe,nval,scr)
|
|
|
|
c wbamebj (8)/2
|
|
f0=0
|
|
fx=0
|
|
mb=nbe*nval
|
|
mebj=nbe*nval*nvbe*nal
|
|
scr(mebj+1:mebj*2)=0.d0
|
|
|
|
open(16,file='iabcba',form='unformatted')
|
|
|
|
do while (f0.lt.nvbe)
|
|
fx=(maxcor-imem+imem1-mebj*2)/(mb*nval)
|
|
if (fx.gt.nvbe-f0) fx=nvbe-f0
|
|
|
|
do i=1,fx
|
|
do e=1,nval
|
|
read(16) scr(mebj*2+(i-1)*nval*mb+(e-1)*mb+1:
|
|
& mebj*2+(i-1)*nval*mb+e*mb)
|
|
enddo
|
|
enddo
|
|
|
|
do b=1,fx
|
|
call dgemm('n','n',mb,nal,nval,1.d0,scr(mebj*2+(b-1)*mb*nval+1),
|
|
&mb,ta1,nval,1.d0,scr(mebj+(f0+b-1)*mb+1),mb*nvbe)
|
|
enddo
|
|
|
|
f0=f0+fx
|
|
enddo
|
|
|
|
close(16)
|
|
|
|
call mebjreadd(scr(mebj+1),nbe,nval,nvbe,nal,scr)
|
|
|
|
c wbamebj (8)/4
|
|
mnef=nval*nvbe*nal*nbe
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) scr(mebj+mnef+1:mebj+mnef*2)
|
|
close(16)
|
|
|
|
call vzsw(scr(mebj+mnef+1),nval,nvbe,nal,nbe,scr(mebj+1))
|
|
call tttbld(ta2,nval,nval,nal,nal,ta1,ta1,
|
|
&scr(mebj+mnef+1))
|
|
|
|
me=nvbe*nbe
|
|
bj=nal*nval
|
|
call dgemm('n','n',me,bj,bj,-1.d0,
|
|
&scr(mebj+1),me,scr(mebj+mnef+1),bj,1.d0,scr,me)
|
|
|
|
mnef=nvbe**2*nbe**2
|
|
open(16,file='abijbb',form='unformatted')
|
|
read(16) scr(mebj+mnef+1:mebj+mnef+nvbe*(nvbe-1)*nbe*(nbe-1)/4)
|
|
close(16)
|
|
|
|
call vzext(scr(mebj+mnef+1),nvbe,nvbe,nbe,nbe,scr(mebj+1))
|
|
call bfjnrea(tm2,nval,nvbe,nal,nbe,scr(mebj+mnef+1))
|
|
call dgemm('t','n',me,bj,me,0.5d0,
|
|
&scr(mebj+1),me,scr(mebj+mnef+1),me,1.d0,scr,me)
|
|
end if ! lmp3
|
|
|
|
c newta2
|
|
ai=nval*nal
|
|
call yzvxrea(tm2,nval,nvbe,nal,nbe,scr(mebj+1))
|
|
me=nvbe*nbe
|
|
call dgemm('n','n',ai,ai,me,1.d0,
|
|
&scr(mebj+1),ai,scr,me,0.d0,scr(mebj+ai*me+1),ai)
|
|
|
|
call abijfold(scr(mebj+ai*me+1),nval,nal,nval,nal,newta2)
|
|
|
|
c newtm2
|
|
ai=nval*nal
|
|
bj=nvbe*nbe
|
|
call xxyyext2(tb2,nvbe,nvbe,nbe,nbe,scr(mebj+1))
|
|
call dgemm('t','t',ai,bj,bj,1.d0,
|
|
&scr,bj,scr(mebj+1),bj,0.d0,scr(mebj+bj*bj+1),ai)
|
|
|
|
call vxyzextadd(scr(mebj+bj*bj+1),nval,nal,nvbe,nbe,newtm2)
|
|
|
|
endif !nval>0,nal>0,nvbe>0,nbe>0
|
|
|
|
c a,b,b,a
|
|
if (nal.gt.0.and.nvbe.gt.0) then
|
|
mebj=nal*nvbe*nvbe*nal
|
|
open(16,file='iabjabba',form='unformatted')
|
|
read(16) scr(1:mebj)
|
|
close(16)
|
|
c if (.not.dfcalc) scr(1:mebj)=-scr(1:mebj)
|
|
|
|
if(.not.lmp3) then
|
|
c newtm2 (2)/6b
|
|
if (nval.gt.0.and.nbe.gt.0) then
|
|
aj=nval*nbe
|
|
bi=nvbe*nal
|
|
call ttbld(tb1,ta1,nvbe,nbe,nval,nal,scr(mebj+1))
|
|
call dgemm('n','n',aj,bi,bi,1.d0,
|
|
&scr(mebj+1),aj,scr,bi,0.d0,scr(mebj+aj*bi+1),aj)
|
|
|
|
call yzvxreaadd(scr(mebj+aj*bi+1),nval,nbe,nvbe,nal,newtm2)
|
|
|
|
endif !nval>0,nbe>0
|
|
|
|
if (nbe.gt.0) then
|
|
aijk=nvbe*nbe*nal**2
|
|
open(16,file='aijkba',form='unformatted')
|
|
read(16) scr(mebj+aijk+1:mebj+aijk*2)
|
|
close(16)
|
|
|
|
ejm=nvbe*nal*nal
|
|
call yzvxsw(scr(mebj+aijk+1),nvbe,nal,nbe,nal,scr(mebj+1))
|
|
call dgemm('n','t',ejm,nvbe,nbe,1.d0,
|
|
&scr(mebj+1),ejm,tb1,nvbe,0.d0,scr(mebj+aijk+1),ejm)
|
|
|
|
call ejmbrea(scr(mebj+aijk+1),nvbe,nal,nal,nvbe,scr)
|
|
|
|
endif !nbe>0
|
|
|
|
c wabbamebj (8)/2
|
|
if (nval.gt.0) then
|
|
f0=0
|
|
fx=0
|
|
mb=nal*nvbe
|
|
mebj=nal*nvbe*nvbe*nal
|
|
scr(mebj+1:mebj*2)=0.d0
|
|
|
|
open(16,file='iabcab',form='unformatted')
|
|
|
|
do while (f0.lt.nvbe)
|
|
fx=(maxcor-imem+imem1-mebj*2)/(mb*nval)
|
|
if (fx.gt.nvbe-f0) fx=nvbe-f0
|
|
|
|
do i=1,fx
|
|
do e=1,nval
|
|
read(16) scr(mebj*2+(i-1)*nval*mb+(e-1)*mb+1:
|
|
& mebj*2+(i-1)*nval*mb+e*mb)
|
|
enddo
|
|
enddo
|
|
|
|
do b=1,fx
|
|
call dgemm('n','n',mb,nal,nval,-1.d0,scr(mebj*2+(b-1)*mb*nval+1),
|
|
&mb,ta1,nval,1.d0,scr(mebj+(f0+b-1)*mb+1),mb*nvbe)
|
|
enddo
|
|
|
|
f0=f0+fx
|
|
enddo
|
|
|
|
close(16)
|
|
|
|
call mebjreadd(scr(mebj+1),nal,nvbe,nvbe,nal,scr)
|
|
|
|
endif !nval>0
|
|
end if ! lmp3
|
|
|
|
c wabbamebj (8)/4
|
|
if (nval.gt.0.and.nbe.gt.0) then
|
|
if(.not.lmp3) then
|
|
mnef=nval*nvbe*nal*nbe
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) scr(mebj+mnef+1:mebj+mnef*2)
|
|
close(16)
|
|
|
|
call vvoorea(scr(mebj+mnef+1),nval,nvbe,nal,nbe,scr(mebj+1))
|
|
call ttabbabld(tm2,nval,nvbe,nal,nbe,ta1,tb1,
|
|
&scr(mebj+mnef+1))
|
|
me=nvbe*nal
|
|
nff=nbe*nval
|
|
call dgemm('n','n',me,me,nff,1.d0,
|
|
&scr(mebj+1),me,scr(mebj+mnef+1),nff,1.d0,scr,me)
|
|
end if ! lmp3
|
|
|
|
c newtm2 (2)/6a
|
|
aj=nval*nbe
|
|
bi=nvbe*nal
|
|
call vovorea(tm2,nval,nvbe,nal,nbe,scr(mebj+1))
|
|
call dgemm('t','n',aj,bi,bi,1.d0,
|
|
&scr(mebj+1),bi,scr,bi,0.d0,scr(mebj+aj*bi+1),aj)
|
|
|
|
call yzvxreaadd(scr(mebj+aj*bi+1),nval,nbe,nvbe,nal,newtm2)
|
|
|
|
endif !nval>0,nbe>0
|
|
endif !nvbe>0,nal>0
|
|
|
|
c b,a,a,b
|
|
if (nbe.gt.0.and.nval.gt.0) then
|
|
mebj=nbe*nval*nval*nbe
|
|
open(16,file='iabjbaab',form='unformatted')
|
|
read(16) scr(1:mebj)
|
|
close(16)
|
|
c if (.not.dfcalc) scr(1:mebj)=-scr(1:mebj)
|
|
|
|
if(.not.lmp3) then
|
|
c newtm2 (2)/6b
|
|
if (nvbe.gt.0.and.nal.gt.0) then
|
|
aj=nval*nbe
|
|
bi=nvbe*nal
|
|
call ttbld(ta1,tb1,nval,nal,nvbe,nbe,scr(mebj+1))
|
|
call dgemm('t','t',aj,bi,aj,1.d0,
|
|
&scr,aj,scr(mebj+1),bi,0.d0,scr(mebj+aj*bi+1),aj)
|
|
|
|
call yzvxreaadd(scr(mebj+aj*bi+1),nval,nbe,nvbe,nal,newtm2)
|
|
|
|
endif !nvbe>0,nal>0
|
|
|
|
if (nal.gt.0) then
|
|
aijk=nval*nal*nbe**2
|
|
open(16,file='aijkab',form='unformatted')
|
|
read(16) scr(mebj+aijk+1:mebj+aijk*2)
|
|
close(16)
|
|
|
|
ejm=nval*nbe*nbe
|
|
call yzvxsw(scr(mebj+aijk+1),nval,nbe,nal,nbe,scr(mebj+1))
|
|
call dgemm('n','t',ejm,nval,nal,1.d0,
|
|
&scr(mebj+1),ejm,ta1,nval,0.d0,scr(mebj+aijk+1),ejm)
|
|
|
|
call ejmbrea(scr(mebj+aijk+1),nval,nbe,nbe,nval,scr)
|
|
|
|
endif !nal>0
|
|
|
|
c wbaabmebj (8)/2
|
|
if (nvbe.gt.0) then
|
|
f0=0
|
|
fx=0
|
|
mb=nbe*nval
|
|
mebj=nbe*nval*nval*nbe
|
|
scr(mebj+1:mebj*2)=0.d0
|
|
|
|
open(16,file='iabcba',form='unformatted')
|
|
|
|
do while (f0.lt.nvbe)
|
|
fx=(maxcor-imem+imem1-mebj*2)/(mb*nval)
|
|
if (fx.gt.nvbe-f0) fx=nvbe-f0
|
|
|
|
do i=1,fx
|
|
do e=1,nval
|
|
read(16) scr(mebj*2+(i-1)*nval*mb+(e-1)*mb+1:
|
|
& mebj*2+(i-1)*nval*mb+e*mb)
|
|
enddo
|
|
enddo
|
|
|
|
call dgemm('n','n',mb*nval,nbe,fx,-1.d0,scr(mebj*2+1),
|
|
&mb*nval,tb1(f0+1,1),nvbe,1.d0,scr(mebj+1),mb*nval)
|
|
|
|
f0=f0+fx
|
|
enddo
|
|
|
|
close(16)
|
|
|
|
call mebjreadd(scr(mebj+1),nbe,nval,nval,nbe,scr)
|
|
|
|
endif !nvbe>0
|
|
end if ! lmp3
|
|
|
|
c wbaabmebj (8)/4
|
|
if (nvbe.gt.0.and.nal.gt.0) then
|
|
if(.not.lmp3) then
|
|
mnef=nval*nvbe*nal*nbe
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) scr(mebj+mnef+1:mebj+mnef*2)
|
|
close(16)
|
|
|
|
call vvoorea(scr(mebj+mnef+1),nval,nvbe,nal,nbe,scr(mebj+1))
|
|
call ttbaabbld(tm2,nvbe,nval,nbe,nal,tb1,ta1,
|
|
&scr(mebj+mnef+1))
|
|
nff=nvbe*nal
|
|
me=nbe*nval
|
|
call dgemm('t','n',me,me,nff,1.d0,
|
|
&scr(mebj+1),nff,scr(mebj+mnef+1),nff,1.d0,scr,me)
|
|
end if ! lmp3
|
|
|
|
aj=nval*nbe
|
|
bi=nvbe*nal
|
|
call vzrea(tm2,nval,nvbe,nal,nbe,scr(mebj+1))
|
|
call dgemm('t','n',aj,bi,aj,1.d0,
|
|
&scr,aj,scr(mebj+1),aj,0.d0,scr(mebj+aj*bi+1),aj)
|
|
|
|
call yzvxreaadd(scr(mebj+aj*bi+1),nval,nbe,nvbe,nal,newtm2)
|
|
|
|
endif !nvbe>0,nal>0
|
|
endif !nbe>0,nval>0
|
|
c }}}
|
|
|
|
c Calculating the new amplitudes
|
|
|
|
if(.not.lmp3) then
|
|
c {{{ T1
|
|
c alpha
|
|
if (nal.gt.0.and.nval.gt.0) then
|
|
do i=1,nal
|
|
do a=1,nval
|
|
newta1(a,i)=newta1(a,i)+fa(a+nal,i)
|
|
enddo
|
|
enddo
|
|
|
|
call dgemm('n','n',nval,nal,nval,1.d0,
|
|
&faae,nval,ta1,nval,1.d0,newta1,nval)
|
|
|
|
C Add F12 contribution
|
|
if(lf12) then
|
|
read(801) scr(1:nal*nal)
|
|
call daxpy(nal*nal,1.d0,scr,1,fami,1)
|
|
read(801) scr(1:nval*nal)
|
|
call daxpy(nval*nal,1.d0,scr,1,newta1,1)
|
|
endif
|
|
C F12 end
|
|
|
|
call dgemm('n','n',nval,nal,nal,-1.d0,
|
|
&ta1,nval,fami,nal,1.d0,newta1,nval)
|
|
|
|
ai=nval*nal
|
|
call xxyyext(ta2,nval,nval,nal,nal,scr)
|
|
call dgemv('t',ai,ai,1.d0,scr,ai,fame,1,1.d0,newta1,1)
|
|
|
|
if (nvbe.gt.0.and.nbe.gt.0) then
|
|
call vxyzext(tm2,nval,nvbe,nal,nbe,scr)
|
|
call dgemv('n',ai,nbe*nvbe,1.d0,
|
|
&scr,ai,fbme,1,1.d0,newta1,1)
|
|
endif !nvbe>0,nbe>0
|
|
|
|
do i=1,nal
|
|
do a=1,nval
|
|
newta1(a,i)=newta1(a,i)/(fa(i,i)-fa(a+nal,a+nal))
|
|
enddo
|
|
enddo
|
|
endif !nval>0,nal>0
|
|
|
|
c beta
|
|
if (nvbe.gt.0.and.nbe.gt.0) then
|
|
do i=1,nbe
|
|
do a=1,nvbe
|
|
newtb1(a,i)=newtb1(a,i)+fb(a+nbe,i)
|
|
enddo
|
|
enddo
|
|
|
|
call dgemm('n','n',nvbe,nbe,nvbe,1.d0,
|
|
&fbae,nvbe,tb1,nvbe,1.d0,newtb1,nvbe)
|
|
|
|
C Add F12 contribution
|
|
if(lf12) then
|
|
read(801) scr(1:nbe*nbe)
|
|
call daxpy(nbe*nbe,1.d0,scr,1,fbmi,1)
|
|
read(801) scr(1:nvbe*nbe)
|
|
call daxpy(nvbe*nbe,1.d0,scr,1,newtb1,1)
|
|
endif
|
|
C F12 end
|
|
|
|
call dgemm('n','n',nvbe,nbe,nbe,-1.d0,
|
|
&tb1,nvbe,fbmi,nbe,1.d0,newtb1,nvbe)
|
|
|
|
ai=nvbe*nbe
|
|
call xxyyext(tb2,nvbe,nvbe,nbe,nbe,scr)
|
|
call dgemv('t',ai,ai,1.d0,scr,ai,fbme,1,1.d0,newtb1,1)
|
|
|
|
if (nval.gt.0.and.nal.gt.0) then
|
|
bj=nval*nal
|
|
call vxyzext(tm2,nval,nvbe,nal,nbe,scr)
|
|
call dgemv('t',bj,ai,1.d0,
|
|
&scr,bj,fame,1,1.d0,newtb1,1)
|
|
endif !nval>0,nal>0
|
|
|
|
do i=1,nbe
|
|
do a=1,nvbe
|
|
newtb1(a,i)=
|
|
&newtb1(a,i)/(fb(i,i)-fb(a+nbe,a+nbe))
|
|
enddo
|
|
enddo
|
|
endif !nvbe>0,nbe>0
|
|
c }}}
|
|
end if ! lmp3
|
|
|
|
c {{{ T2
|
|
if(.not.lmp3) then
|
|
c FFmj
|
|
c alpha
|
|
if (nval.gt.0.and.nal.gt.0) then
|
|
call dgemm('t','n',nal,nal,nval,0.5d0,
|
|
&fame,nval,ta1,nval,1.d0,fami,nal)
|
|
c FFbe
|
|
c alpha
|
|
call dgemm('n','t',nval,nval,nal,-0.5d0,
|
|
&ta1,nval,fame,nval,1.d0,faae,nval)
|
|
endif !nval>0,nal>0
|
|
c FFmj
|
|
c beta
|
|
if (nvbe.gt.0.and.nbe.gt.0) then
|
|
call dgemm('t','n',nbe,nbe,nvbe,0.5d0,
|
|
&fbme,nvbe,tb1,nvbe,1.d0,fbmi,nbe)
|
|
c FFbe
|
|
c beta
|
|
call dgemm('n','t',nvbe,nvbe,nbe,-0.5d0,
|
|
&tb1,nvbe,fbme,nvbe,1.d0,fbae,nvbe)
|
|
endif !nvbe>0,nbe>0
|
|
|
|
c Alpha
|
|
c newta2ab
|
|
if (nal.gt.1.and.nval.gt.1) then
|
|
abij=nal*(nal-1)*nval**2/2+1
|
|
call xxyyunb(ta2,nval,nval,nal,nal,scr(abij))
|
|
aij=nval*nal*(nal-1)/2
|
|
call dgemm('n','n',nval,aij,nval,1.d0,
|
|
&faae,nval,scr(abij),nval,0.d0,scr,nval)
|
|
|
|
call abfold(scr,nval,nval,nal,nal,newta2)
|
|
|
|
c newta2ij
|
|
abi=nal*nval*(nval-1)/2
|
|
call yyxxunb(ta2,nval,nval,nal,nal,scr(abi*nal+1))
|
|
call dgemm('n','n',abi,nal,nal,-1.d0,
|
|
&scr(abi*nal+1),abi,fami,nal,0.d0,scr,abi)
|
|
|
|
ij=0
|
|
do j=1,nal
|
|
do i=1,j-1
|
|
ij=ij+1
|
|
ijj=(j-1)*nal*nval*(nval-1)/2+(i-1)*nval*(nval-1)/2
|
|
jji=(i-1)*nal*nval*(nval-1)/2+(j-1)*nval*(nval-1)/2
|
|
do ab=1,nval*(nval-1)/2
|
|
newta2(ab,ij)=newta2(ab,ij)+scr(ijj+ab)-scr(jji+ab)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C Add F12 contribution
|
|
if(lf12) then
|
|
abij=nal*(nal-1)*nval*(nval-1)/4
|
|
read(800) scr(1:abij)
|
|
call daxpy(abij,1.d0,scr,1,newta2,1)
|
|
endif
|
|
C F12 end
|
|
else
|
|
newta2=0.d0
|
|
endif !nal>1,nval>1
|
|
|
|
end if ! lmp3
|
|
|
|
do j=1,nal
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
newta2(ab,ij)=newta2(ab,ij)
|
|
&/(fa(i,i)+fa(j,j)-fa(a+nal,a+nal)-fa(b+nal,b+nal))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c Beta
|
|
if (nbe.gt.1.and.nvbe.gt.1) then
|
|
if(.not.lmp3) then
|
|
c newtb2abij
|
|
abij=nbe*(nbe-1)*nvbe**2/2+1
|
|
cc newtb2ab
|
|
aij=nvbe*nbe*(nbe-1)/2
|
|
call xxyyunb(tb2,nvbe,nvbe,nbe,nbe,scr(abij))
|
|
call dgemm('n','n',nvbe,aij,nvbe,1.d0,
|
|
&fbae,nvbe,scr(abij),nvbe,0.d0,scr,nvbe)
|
|
|
|
call abfold(scr,nvbe,nvbe,nbe,nbe,newtb2)
|
|
c newtb2ij
|
|
abi=nbe*nvbe*(nvbe-1)/2
|
|
call yyxxunb(tb2,nvbe,nvbe,nbe,nbe,scr(abi*nbe+1))
|
|
call dgemm('n','n',abi,nbe,nbe,-1.d0,
|
|
&scr(abi*nbe+1),abi,fbmi,nbe,0.d0,scr,abi)
|
|
|
|
ij=0
|
|
do j=1,nbe
|
|
do i=1,j-1
|
|
ij=ij+1
|
|
ijj=(j-1)*nbe*nvbe*(nvbe-1)/2+(i-1)*nvbe*(nvbe-1)/2
|
|
jji=(i-1)*nbe*nvbe*(nvbe-1)/2+(j-1)*nvbe*(nvbe-1)/2
|
|
do ab=1,nvbe*(nvbe-1)/2
|
|
newtb2(ab,ij)=newtb2(ab,ij)+scr(ijj+ab)-scr(jji+ab)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C Add F12 contribution
|
|
if(lf12) then
|
|
abij=nbe*(nbe-1)*nvbe*(nvbe-1)/4
|
|
read(800) scr(1:abij)
|
|
call daxpy(abij,1.d0,scr,1,newtb2,1)
|
|
endif
|
|
C F12 end
|
|
|
|
end if ! lmp3
|
|
|
|
do j=1,nbe
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
newtb2(ab,ij)=newtb2(ab,ij)
|
|
&/(fb(i,i)+fb(j,j)-fb(a+nbe,a+nbe)-fb(b+nbe,b+nbe))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
else
|
|
newtb2=0.d0
|
|
endif !nvbe>1,nbe>1
|
|
|
|
c Mixed
|
|
c newtm2ab
|
|
if (nval.gt.0.and.nal.gt.0.and.nvbe.gt.0.and.nbe.gt.0) then
|
|
if(.not.lmp3) then
|
|
aij=nval*nal*nbe
|
|
call vxyzsw(tm2,nval,nvbe,nal,nbe,scr(nvbe*aij+1))
|
|
call dgemm('n','n',nvbe,aij,nvbe,1.d0,
|
|
&fbae,nvbe,scr(nvbe*aij+1),nvbe,0.d0,scr,nvbe)
|
|
|
|
call vxyzswadd(scr,nvbe,nval,nal,nbe,newtm2)
|
|
|
|
aij=nvbe*nal*nbe
|
|
call dgemm('n','n',nval,aij,nval,1.d0,
|
|
&faae,nval,tm2,nval,1.d0,newtm2,nval)
|
|
|
|
c newtm2ij
|
|
abi=nval*nvbe*nbe
|
|
call yzvxsw(tm2,nval,nvbe,nal,nbe,scr(abi*nal+1))
|
|
call dgemm('n','n',abi,nal,nal,-1.d0,
|
|
&scr(abi*nal+1),abi,fami,nal,0.d0,scr,abi)
|
|
|
|
call yzvxswadd(scr,nval,nvbe,nbe,nal,newtm2)
|
|
|
|
abi=nval*nvbe*nal
|
|
call dgemm('n','n',abi,nbe,nbe,-1.d0,
|
|
&tm2,abi,fbmi,nbe,1.d0,newtm2,abi)
|
|
C Add F12 contribution
|
|
if(lf12) then
|
|
abij=nal*nbe*nval*nvbe
|
|
read(800) scr(1:abij)
|
|
call daxpy(abij,1.d0,scr,1,newtm2,1)
|
|
endif
|
|
C F12 end
|
|
|
|
end if ! lmp3
|
|
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
ij=(j-1)*nal+i
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
ab=(b-1)*nval+a
|
|
newtm2(ab,ij)=newtm2(ab,ij)/
|
|
&(fa(i,i)+fb(j,j)-fa(a+nal,a+nal)-fb(b+nbe,b+nbe))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif !nval>0,nvbe>0,nal>0,nbe>0
|
|
c }}}
|
|
|
|
c Executing DIIS
|
|
if(.not.lmp3) then
|
|
ta1=newta1-ta1; tb1=newtb1-tb1
|
|
ta2=newta2-ta2; tb2=newtb2-tb2; tm2=newtm2-tm2
|
|
end if
|
|
|
|
norm=dnrm2(lt,ta1,1)
|
|
|
|
if(.not.lmp3) then
|
|
call diis(nit,lt,newta1,ta1,ccmaxit,diisfile,errfile,8,bmat,scr)
|
|
|
|
c Updating the amplitudes
|
|
call dcopy(lt,newta1,1,ta1,1)
|
|
end if
|
|
|
|
c Calculating the CCSD energy
|
|
call ccenergy(nal,nbe,nval,nvbe,ta1,newta2,tb1,newtb2,
|
|
&newtm2,fa,fb,scr,ecc,.false.,et1,.false.,lf12,ecc_os,ecc_ss,lmp3)
|
|
|
|
if(lmp3) then
|
|
converged = .true.
|
|
exit
|
|
end if
|
|
|
|
call dcopy(lt,ta1,1,newta1,1)
|
|
|
|
c End of iteration step
|
|
if(.not.lmp3) write(iout,"(' Iteration',i3,x,f20.12,3x,f20.12)")
|
|
$nit,norm,ecc
|
|
|
|
c Save t amplitudes of iteration
|
|
if (.not.(norm.le.tol*10.d0.and.dabs(ecc-eccold).le.tol)) then
|
|
call managerestart('w','ccsd',nit,emp2,et1,ecc,ecc,ta1,tb1,ta2,
|
|
& tb2,tm2,0,nal,nbe,nval,nvbe,ecc,ied)
|
|
endif
|
|
c Checking convergence
|
|
if((norm.le.tol*10.d0.and.dabs(ecc-eccold).le.tol)
|
|
&.or.nit.ge.ccmaxit) then
|
|
converged = .true.
|
|
exit
|
|
end if
|
|
enddo
|
|
|
|
c Calculating the CCSD energy with integrals in complete auxiliary basis
|
|
if(lnaf) then
|
|
call ccenergy(nal,nbe,nval,nvbe,ta1,newta2,tb1,newtb2,
|
|
& newtm2,fa,fb,scr,ecc,.false.,et1,.true.,lf12,ecc_os,ecc_ss,lmp3)
|
|
end if
|
|
|
|
c Calculating PPL energy contribution {{{
|
|
eppl_os=0.d0
|
|
eppls_os=0.d0
|
|
eppl_ss=0.d0
|
|
eppls_ss=0.d0
|
|
epplij=0.d0
|
|
newta1=0.d0
|
|
newtb1=0.d0
|
|
newta2=0.d0
|
|
newtb2=0.d0
|
|
c newtm2=0.d0
|
|
|
|
c W(abef)
|
|
c a,a,a,a
|
|
open(799, file='QFACTS', form='unformatted')
|
|
if (nal.gt.0.and.nval.gt.1) then
|
|
call wabefbld(nal,nval,nfa,faadr,recaadr,ta1,newta1,ta2,
|
|
&newta2,faae,scr,'iabcaa','abcda',irecln,ccsdalg,dfnbasis,
|
|
&'DFINT_AB ',qscale,tscalea,epaa,eccs,eccp,'abijaa',fa,eppl,
|
|
$eppl_ss,eppls_ss,epplij,.true.)
|
|
endif
|
|
|
|
c b,b,b,b
|
|
if (nbe.gt.0.and.nvbe.gt.1) then
|
|
call wabefbld(nbe,nvbe,nfb,fbadr,recbadr,tb1,newtb1,tb2,
|
|
&newtb2,fbae,scr,'iabcbb','abcdb',irecln,ccsdalg,dfnbasis,
|
|
&'DFINT_ABb',qscale,tscaleb,epbb,eccs,eccp,'abijbb',fb,eppl,
|
|
$eppl_ss,eppls_ss,epplij,.true.)
|
|
endif
|
|
close(799)
|
|
|
|
c {{{ a,b,a,b
|
|
maba=nbe*nval
|
|
maab=nal*nvbe
|
|
ma=max(nbe*nval,nal*nvbe)
|
|
ab=nval*nvbe
|
|
|
|
if (nal.gt.0.and.nbe.gt.0.and.nval.gt.0.and.nvbe.gt.0) then
|
|
open(16,file='iabcba',form='unformatted')
|
|
open(17,file='iabcab',form='unformatted')
|
|
open(20,file='abcdm',access='direct',recl=irecln)
|
|
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
c Reading Jab
|
|
nblc=efmln(1,fmadr,nfm,nval)
|
|
ijaab=nblc*(ma+max(ab*2+nblc,nal*nbe+nbe,ab+nal*nbe))+1
|
|
ijbab=ijaab+dfnbasis*nval*(nval+1)/2
|
|
call rpoint2d(scr(ijaab),jaab,dfnbasis,nval*(nval+1)/2)
|
|
open(21,file='DFINT_AB',form='unformatted')
|
|
read(21) jaab
|
|
close(21)
|
|
endif !ccsdalg
|
|
|
|
do k=1,nfm
|
|
f0=fmadr(k)
|
|
fx=fmadr(k+1)-fmadr(k)
|
|
|
|
nblc=fx*nval
|
|
|
|
c Reading abcdab
|
|
|
|
ipuff=ma*nblc+ab*nblc*2+1
|
|
abef=1
|
|
do i=1,k-1
|
|
if (ccsdalg.ne.'dfdirect') then
|
|
call getlst(20,recmadr(k*(k-1)/2+i),scr(ipuff),
|
|
&efmtile(i,k,fmadr,nfm,nval))
|
|
call abcd1(scr(ipuff),efmln(i,fmadr,nfm,nval),
|
|
&efmln(k,fmadr,nfm,nval),scr(ma*nblc+1),nval*nvbe,
|
|
&efmln(k,fmadr,nfm,nval),abef)
|
|
else !ccsdalg.eq.dfdirect
|
|
open(21,file='DFINT_ABbuccsd',access='direct',recl=irecln)
|
|
c Read JAB
|
|
jbabsize=(fmadr(i+1)-fmadr(i))*(fmadr(k+1)-fmadr(k))
|
|
call rpoint3d(scr(ijbab),jbab,dfnbasis,fmadr(i+1)-fmadr(i),
|
|
& fmadr(k+1)-fmadr(k))
|
|
call getlst(21,recjab(k*(k-1)/2+i),jbab,
|
|
& jbabsize*dfnbasis)
|
|
c Assemble square tile
|
|
call dgemm('t','n',nval*(nval+1)/2,jbabsize,dfnbasis,1.d0,
|
|
&jaab,dfnbasis,jbab,dfnbasis,0.d0,scr(ipuff),nval*(nval+1)/2)
|
|
c Place tile
|
|
call abcd1direct(scr(ipuff),scr(ma*nblc+1),nval*nvbe,abef,fmadr,
|
|
& nval,nvbe,i,k)
|
|
close(21)
|
|
endif !ccsdalg
|
|
|
|
abef=abef+efmln(i,fmadr,nfm,nval)
|
|
enddo
|
|
|
|
if (ccsdalg.ne.'dfdirect') then
|
|
call getlst(20,recmadr(k*(k-1)/2+k),scr(ipuff),
|
|
&(efmln(k,fmadr,nfm,nval)+1)*efmln(k,fmadr,nfm,nval)/2)
|
|
|
|
call abcd2(scr(ipuff),efmln(k,fmadr,nfm,nval),
|
|
&efmln(k,fmadr,nfm,nval),scr(ma*nblc+1),nval*nvbe,
|
|
&efmln(k,fmadr,nfm,nval),abef)
|
|
else !ccsdalg.eq.dfdirect
|
|
cc Read JAB
|
|
open(21,file='DFINT_ABbuccsd',access='direct',recl=irecln)
|
|
jbabsize=(fmadr(k+1)-fmadr(k)+1)*(fmadr(k+1)-fmadr(k))/2
|
|
call rpoint2d(scr(ijbab),jbabtri,dfnbasis,jbabsize)
|
|
call getlst(21,recjab(k*(k-1)/2+k),jbabtri,
|
|
& jbabsize*dfnbasis)
|
|
c Assemble square tile
|
|
call dgemm('t','n',nval*(nval+1)/2,jbabsize,dfnbasis,1.d0,
|
|
&jaab,dfnbasis,jbabtri,dfnbasis,0.d0,scr(ipuff),nval*(nval+1)/2)
|
|
c Place tile
|
|
call abcd2direct(scr(ipuff),scr(ma*nblc+1),nval*nvbe,abef,fmadr,
|
|
&nval,nvbe,k)
|
|
close(21)
|
|
endif !ccsdalg
|
|
|
|
abef=abef+efmln(k,fmadr,nfm,nval)
|
|
|
|
do i=k+1,nfm
|
|
if (ccsdalg.ne.'dfdirect') then
|
|
call getlst(20,recmadr(i*(i-1)/2+k),scr(ipuff),
|
|
&efmtile(k,i,fmadr,nfm,nval))
|
|
|
|
call abcd3(scr(ipuff),efmln(k,fmadr,nfm,nval),
|
|
&efmln(i,fmadr,nfm,nval),scr(ma*nblc+1),nval*nvbe,
|
|
&efmln(k,fmadr,nfm,nval),abef)
|
|
else !ccsdalg.eq.dfdirect
|
|
open(21,file='DFINT_ABbuccsd',access='direct',recl=irecln)
|
|
c Read JAB
|
|
jbabsize=(fmadr(k+1)-fmadr(k))*(fmadr(i+1)-fmadr(i))
|
|
call rpoint3d(scr(ijbab),jbab,dfnbasis,fmadr(k+1)-fmadr(k),
|
|
& fmadr(i+1)-fmadr(i))
|
|
call getlst(21,recjab(i*(i-1)/2+k),jbab,
|
|
& jbabsize*dfnbasis)
|
|
c Assemble square tile
|
|
call dgemm('t','n',nval*(nval+1)/2,jbabsize,dfnbasis,1.d0,
|
|
&jaab,dfnbasis,jbab,dfnbasis,0.d0,scr(ipuff),nval*(nval+1)/2)
|
|
c Place tile
|
|
call abcd3direct(scr(ipuff),scr(ma*nblc+1),nval*nvbe,abef,fmadr,
|
|
&nval,nvbe,i,k)
|
|
close(21)
|
|
endif !ccsdalg
|
|
|
|
abef=abef+efmln(i,fmadr,nfm,nval)
|
|
enddo
|
|
close(21)
|
|
|
|
if(qscale) then
|
|
open(543,file='UCCSD_RES',form='unformatted')
|
|
write(543) newtm2
|
|
call taumbld2(tm2,ta1,tb1,nval,nvbe,nal,nbe,f0,fx,
|
|
&scr((ma+ab)*nblc+1))
|
|
ij=nal*nbe
|
|
call dgemm('n','n',ab,ij,nblc,1.d0,
|
|
&scr(ma*nblc+1),ab,scr((ma+ab)*nblc+1),nblc,0.d0,newtm2,ab)
|
|
call scaleppl_ab(nal,nbe,nval,nvbe,fa,fb,newtm2,
|
|
$scr((ma+ab)*nblc+1),tscalea,tscaleb,epab,eccs,eccp,eppl,epplc,
|
|
$eccsc,epplij)
|
|
eppl_os=eppl_os+epplc
|
|
eppls_os=eppls_os+eccsc
|
|
rewind(543)
|
|
read(543) newtm2
|
|
close(543)
|
|
endif
|
|
|
|
cc newtm2 (2)/5
|
|
c call taumbld2(tm2,ta1,tb1,nval,nvbe,nal,nbe,f0,fx,
|
|
c &scr((ma+ab)*nblc+1))
|
|
c
|
|
c ij=nal*nbe
|
|
c call dgemm('n','n',ab,ij,nblc,1.d0,
|
|
c &scr(ma*nblc+1),ab,scr((ma+ab)*nblc+1),nblc,1.d0,newtm2,ab)
|
|
|
|
enddo
|
|
|
|
close(16)
|
|
close(17)
|
|
close(20)
|
|
endif !nval>0,nvbe>0
|
|
c }}}
|
|
|
|
c End of PPL energy contribution }}}
|
|
|
|
|
|
c Calculating the scaled CCSD energy
|
|
e_ppl = eppl
|
|
eppl_correction = eccs
|
|
c if(qscale) then
|
|
c eccs=eccs+ecc
|
|
c eccp=eccp+ecc
|
|
cc eccs=eccs+ecc+emp2f12+ecoup
|
|
cc eccp=eccp+ecc+emp2f12+ecoup
|
|
cc call sccenergy_v1(nal,nbe,nval,nvbe,ta1,newta2,tb1,
|
|
cc &newtb2,newtm2,fa,fb,scr,eccs,eccp,et1s,scr,scr,scr,scr,scr,
|
|
cc &tscalea,tscaleb,epaa,epbb,epab)
|
|
cc call sccenergy_v2(nal,nbe,nval,nvbe,ta1,newta2,tb1,
|
|
cc &newtb2,newtm2,fa,fb,scr,eccs,eccp,et1s,scr,scr,scr,scr,scr,
|
|
cc &tscalea,tscaleb,epaa,epbb,epab,emp2f12+ecoup)
|
|
c endif
|
|
|
|
c End of iteration
|
|
c Calculating local energy contribution of the central LMO
|
|
if (localcc.ne.'off ') then
|
|
call locccenergy(nal,nbe,nval,nvbe,ta1,tb1,
|
|
&fa,fb,ta2,tb2,newtm2,tm2,uia,uib,decc,scr,indocc,naf,.false.,et1)
|
|
ecc=decc
|
|
endif ! localcc
|
|
|
|
c Save converged t amplitudes
|
|
call managerestart('w','ccsd',0,emp2,et1,ecc,ecc,ta1,tb1,ta2,
|
|
& tb2,tm2,0,nal,nbe,nval,nvbe,ecc,ied)
|
|
1000 continue
|
|
if (restart.and.nit.le.0) then
|
|
! Restarted from converged CC calculation
|
|
norm=0.d0
|
|
eccold=ecc
|
|
decc=ecc
|
|
converged=.true.
|
|
endif
|
|
|
|
c {{{ Deleting files
|
|
c close(900,status='delete')
|
|
c close(901,status='delete')
|
|
c close(902,status='delete')
|
|
c close(903,status='delete')
|
|
open(diisfile,file='fort.18')
|
|
close(diisfile,status="delete")
|
|
open(errfile,file='fort.19')
|
|
close(errfile,status="delete")
|
|
open(16,file='abcda')
|
|
close(16,status='delete')
|
|
open(16,file='abcdb')
|
|
close(16,status='delete')
|
|
open(16,file='abcdm')
|
|
close(16,status='delete')
|
|
open(16,file='ijklaa')
|
|
close(16,status='delete')
|
|
open(16,file='ijklbb')
|
|
close(16,status='delete')
|
|
open(16,file='ijklab')
|
|
close(16,status='delete')
|
|
open(16,file='iabjaa')
|
|
close(16,status='delete')
|
|
open(16,file='iabjbb')
|
|
close(16,status='delete')
|
|
open(16,file='iabjbaab')
|
|
close(16,status='delete')
|
|
open(16,file='iabjabba')
|
|
close(16,status='delete')
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
open(16,file='DFINT_ABbuccsd')
|
|
close(16,status='delete')
|
|
end if
|
|
if(lf12) then
|
|
close(800,status='delete')
|
|
close(801,status='delete')
|
|
close(802,status='delete')
|
|
endif
|
|
c }}}
|
|
|
|
c {{{ Deleting files
|
|
if (trim(naf).ne.'off' .and. trim(localcc).ne.'off') then
|
|
open(16,file='ajb')
|
|
close(16,status='delete')
|
|
endif
|
|
if (trim(calctype).eq.'ccsd'.or.talg.eq.'lapl') then
|
|
open(16,file='iabcaa')
|
|
close(16,status='delete')
|
|
open(16,file='iabcbb')
|
|
close(16,status='delete')
|
|
open(16,file='iabcab')
|
|
close(16,status='delete')
|
|
open(16,file='iabcba')
|
|
close(16,status='delete')
|
|
open(16,file='aijkaa')
|
|
close(16,status='delete')
|
|
open(16,file='aijkbb')
|
|
close(16,status='delete')
|
|
open(16,file='aijkab')
|
|
close(16,status='delete')
|
|
open(16,file='aijkba')
|
|
close(16,status='delete')
|
|
open(16,file='abijaa')
|
|
close(16,status='delete')
|
|
open(16,file='abijbb')
|
|
close(16,status='delete')
|
|
open(16,file='abijab')
|
|
close(16,status='delete')
|
|
endif !ccsd.or.talg.eq.lapl }}}
|
|
|
|
c {{{ Printing results
|
|
write(iout,*)
|
|
if (.not. converged) then !norm.gt.tol*10.d0.or.dabs(ecc-eccold).gt.tol) then
|
|
if (localcc.ne.'off ') write(iout,"(' Local')",advance='no')
|
|
write(iout,
|
|
& "(' CCSD iteration failed to converge in',i3,' steps.')")
|
|
$ nit
|
|
write(iout,*)
|
|
if (localcc.ne.'off ') then
|
|
ecc=decc
|
|
write(iout,"(' CCSD energy contribution [au]:',f21.12)")
|
|
& decc
|
|
write(iout,"(18x,'Warning: iteration did not converge!')")
|
|
else !localcc=off
|
|
if(lf12) then
|
|
write(iout,"(' CCSD(F12*) correlation energy [au]:',
|
|
$ f31.12)") ecc
|
|
write(iout,"(' Total CCSD(F12*) energy [au]:',f37.12)")
|
|
$ eref+ecc
|
|
else
|
|
write(iout,"(' CCSD correlation energy [au]:',f22.12)")
|
|
$ ecc
|
|
write(iout,"(' Total CCSD energy [au]:',f28.12)")
|
|
$ eref+ecc
|
|
endif
|
|
write(iout,
|
|
&"(18x,'Warning: iteration did not converge!')")
|
|
endif
|
|
c Print amplitude analytics, even if iteration did not converge
|
|
call tanalytics(ltpr,ta1,tb1,ta2,tb2,tm2,nal,nval,nbe,nvbe,
|
|
$ iout,tprtol,scr,0)
|
|
c Stop with error as CCSD iteration did not converge
|
|
call mrccend(1)
|
|
|
|
else !iteration converged
|
|
if (localcc.ne.'off ') write(iout,"(' Local')",advance='no')
|
|
if(.not.lmp3) then
|
|
if (nit.gt.0) then
|
|
write(iout,"(' CCSD iteration has converged in',i3,
|
|
$ ' steps.')") nit
|
|
else
|
|
write(iout,"(' CCSD iteration had already converged ')")
|
|
endif
|
|
end if ! lmp3
|
|
|
|
write(iout,*)
|
|
if (localcc.ne.'off ') then
|
|
! local
|
|
ecc=decc
|
|
write(iout,"(' T1 contribution [au]: ',f21.12)") et1
|
|
write(iout,"(' CCSD energy contribution [au]:',f21.12)")
|
|
& decc
|
|
|
|
else !localcc=off
|
|
|
|
call getkey('dft', 3, dft, 32)
|
|
if(lmp3.and.trim(dft).ne.'off') write(iout, '(2a)')
|
|
$ ' Warning: Third-order singles contribution is ' //
|
|
$ 'not calculated.'
|
|
|
|
write(iout,"(' T1 contribution [au]: ',
|
|
$ 14x,f22.12)") et1
|
|
c if(qscale)
|
|
c $ write(iout,"(' T1 contribution (scaled) [au]: ',
|
|
c $ 14x,f22.12)") et1s
|
|
|
|
if(trim(ovirtrun).eq.'ppl') then
|
|
! print PPL contribution
|
|
write(iout,"(' PPL energy contribution [au]: ',
|
|
$ 14x,f22.12)") eppl
|
|
if(qscale) write(iout,
|
|
$ "(' Scaled PPL energy contribution [au]: ',
|
|
$ 10x,f22.12)") eppl + eppl_correction
|
|
|
|
c if(qscale) write(iout,"(' Pair scaled PPL contribution [au]: ',
|
|
c $10x,f22.12)") eppl+eccp !epplij
|
|
|
|
write(iout,*)
|
|
|
|
write(iout,"(' OS-PPL energy contribution [au]: ',
|
|
$ 8x,f22.12)") eppl_os
|
|
if(qscale)write(iout,
|
|
$ "(' Scaled OS-PPL energy contribution [au]:',
|
|
$ 8x,f22.12)") eppls_os
|
|
write(iout,"(' SS-PPL energy contribution [au]: ',
|
|
$ 8x,f22.12)") eppl_ss
|
|
if(qscale)write(iout,
|
|
$ "(' Scaled SS-PPL energy contribution [au]:',
|
|
$ 8x,f22.12)") eppls_ss
|
|
write(iout,*)
|
|
end if
|
|
|
|
if(lf12) then
|
|
! CCSD(F12*)
|
|
c write(iout,"(' T1 contribution [au]: ',
|
|
c $ f33.12)") et1
|
|
write(iout,"(' CCSD(F12*) correlation energy [au]: ',
|
|
$ f31.12)") ecc
|
|
if(lcorr)
|
|
$ write(iout,"(' CCSD(F12*) correlation energy + MP2 [au]: ',
|
|
$ f25.12)") ecc+(emp2full-(eref-ecabs+emp2))
|
|
write(iout,"(' Total CCSD(F12*) energy [au]: ',f38.12)")
|
|
$ eref+ecc
|
|
if(lcorr)
|
|
$ write(iout,"(' Total CCSD(F12*) energy + MP2 corr. [au]: ',
|
|
$f27.12)") eref+ecc + (emp2full - (eref-ecabs + emp2))
|
|
else if(.not.lmp3) then
|
|
! CCSD
|
|
write(iout,"(' Opposite spin CCSD energy [au]: ',
|
|
$ 12x,f22.12)") ecc_os
|
|
write(iout,"(' Same spin CCSD energy [au]: ',
|
|
$ 12x,f22.12)") ecc_ss
|
|
write(iout,"(' CCSD correlation energy [au]: ',
|
|
$ 16x,f22.12)") ecc
|
|
|
|
! MP2 and PPL corrections
|
|
if(lcorr) write(iout,
|
|
$ "(' CCSD correlation energy + MP2 correction [au]: ',
|
|
$ f22.12)") ecc + (emp2full - (eref + emp2))
|
|
if(lcorr.and.qscale) write(iout,
|
|
$ "(' CCSD correlation energy + MP2 + PPL corr. [au]:',
|
|
$ f22.12)") ecc + (emp2full - (eref + emp2)) +
|
|
$ eppl_correction
|
|
|
|
! total energies
|
|
write(iout,"(' Total CCSD energy [au]: ',16x,f28.12)")
|
|
$ eref+ecc
|
|
if(lcorr) write(iout,
|
|
$ "(' Total CCSD energy + MP2 correction [au]: ',
|
|
$ 6x,f22.12)") eref + ecc + (emp2full - (eref + emp2))
|
|
if(lcorr.and.qscale) write(iout,
|
|
$ "(' Total CCSD energy + MP2 + PPL corr. [au]: ',
|
|
$ f22.12)") eref + ecc + (emp2full - (eref + emp2)) +
|
|
$ eppl_correction
|
|
|
|
else if(lmp3) then
|
|
! MP3
|
|
emp3=ecc-emp2
|
|
|
|
c write(iout,"(' Opposite spin MP3 energy [au]: ',12x,f22.12)")
|
|
c $ ecc_os
|
|
c write(iout,"(' Same spin MP3 energy [au]: ',12x,f22.12)")
|
|
c $ ecc_ss
|
|
|
|
write(iout,"(' MP3 correlation energy [au]: ',
|
|
$ 16x,f22.12)") ecc
|
|
|
|
! MP2 and PPL corrections
|
|
if(lcorr) write(iout,
|
|
$ "(' MP3 correlation energy + MP2 correction [au]: ',
|
|
$ f22.12)") ecc + (emp2full - (eref + emp2))
|
|
if(lcorr.and.qscale) write(iout,
|
|
$ "(' MP3 correlation energy + MP2 + PPL corr. [au]: ',
|
|
$ f22.12)") ecc + (emp2full - (eref + emp2)) +
|
|
$ eppl_correction
|
|
|
|
if(dhyb.eq.0) then
|
|
! total MP3
|
|
write(iout,"(' Total MP3 energy [au]: ',16x,
|
|
$ f28.12)") eref+ecc
|
|
|
|
elseif(dhyb.eq.3) then
|
|
! DH-DFT
|
|
c warning FOCK is not overwritten with HF mx for DH3 DFT (dhyb.eq.3), t1 is always 0 in this case
|
|
write(iout,"(' KS energy + MP3 correction [au]: ',
|
|
$ 16x,f20.12)")
|
|
$ eref+cmp2ss*emp2ss+cmp2os*emp2os+cmp3*emp3
|
|
end if
|
|
|
|
! total MP3 with corrections
|
|
if(lcorr) write(iout,
|
|
$ "(' Total MP3 energy + MP2 correction [au]: ',
|
|
$ 6x,f22.12)") eref + ecc + (emp2full - (eref + emp2))
|
|
if(lcorr.and.qscale) write(iout,
|
|
$ "(' Total MP3 energy + MP2 + PPL corr. [au]: ',
|
|
$ f22.12)") eref + ecc + (emp2full - (eref + emp2)) +
|
|
$ eppl_correction
|
|
endif
|
|
|
|
endif !localcc }}}
|
|
endif !converged
|
|
|
|
c {{{ Spin contamination
|
|
c Projected spin contamination
|
|
if (localcc.ne.'off '.or.
|
|
$ (scftype.eq.'uhf '.and.trim(cmpgrp).eq.'C1')) then
|
|
is_iJ = dblalloc(nal*nbe)
|
|
is_aJ = dblalloc(nval*nbe)
|
|
is_Bi = dblalloc(nal*nvbe)
|
|
iwork = dblalloc(max(nbe+max(nval,nbe), !tai
|
|
$ nal+max(nvbe,nal), !tAI
|
|
$ nval+nvbe))
|
|
call projected_spin_cont(nal,nbe,nval,nvbe,dcore(is_iJ),
|
|
$ dcore(is_aJ),dcore(is_Bi),ta1,tb1,tm2,iout,scf_s2,
|
|
$ uia,uib,localcc,indocc,dcore(iwork),newtm2,.true.)
|
|
call dbldealloc(is_iJ)
|
|
endif
|
|
if (scftype.eq.'rohf'.and.
|
|
$ (localcc.ne.'off '.or.trim(cmpgrp).eq.'C1')) then
|
|
iuoa=dblalloc(nal**2)
|
|
iuob=dblalloc(nbe**2)
|
|
iuva=dblalloc(nval**2)
|
|
iuvb=dblalloc(nvbe**2)
|
|
iwork=dblalloc(2*max(nal,nbe)**2)
|
|
call spin_contamination(nal,nbe,nval,nvbe,ta1,tb1,ta2,tb2,tm2,
|
|
$ newta1,newtb1,newta2,newtb2,newtm2,dcore(iuoa),dcore(iuob),
|
|
$ dcore(iuva),dcore(iuvb),dcore(iwork),forward,iout,scf_s2,
|
|
$ localcc,indocc,.true.)
|
|
call dbldealloc(iuoa)
|
|
endif !scftype.eq.rohf }}}
|
|
|
|
c Amplitude analytics
|
|
if(.not.lmp3)
|
|
$call tanalytics(ltpr,ta1,tb1,ta2,tb2,tm2,nal,nval,nbe,nvbe,iout,
|
|
$ tprtol,scr,0)
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine tcorr(maxcor,imem,imem1,nal,nbe,nval,nvbe,nquad,
|
|
&dfnbasis,ta1,tb1,ta2,tb2,tm2,fa,fb,uia,uib,quad,cmoa,cmob,scr,
|
|
&dcore,et,iout,scftype,talg,localcc,error,ita1ccsd,ecc,qro,
|
|
&indocc,eref,ibufln,irecln,restart,ets,tscalea,tscaleb,qscale,
|
|
$eppl_correction,epaa,epbb,epab,epba,ied,verb)
|
|
************************************************************************
|
|
* Performs the perturbative (T) correction for open-shell CCSD(T) *
|
|
* calculations. *
|
|
************************************************************************
|
|
|
|
implicit none
|
|
integer nal,nbe,nval,nvbe,recln,f0,nblc0,ma,fx,maxcor,imem,imem1
|
|
integer nblc,ef,i,c,iout,pr,total,prold,it2list1,it2list2,its,it
|
|
integer iw,ivooo,ivvoo,dblalloc,it3,iw3,it3u,iw3u,icmo,ifullt3
|
|
integer itcmo1,itcmo2,ifullt3buff,dfnbasis,nquad,ilcmo,itcmo3
|
|
integer ijab,ijai,it2jkad,it2ikad,it2ijad,it2kbcl,it2jbcl,it2ibcl
|
|
integer itm2list,ivoooab,ivoooba,ivvooab,iabcii,ifullw3,ijabb
|
|
integer ifullw3buff,ijaia,ijaib,iw3sum,it2iabl,iw3fornorm,ijaba
|
|
integer it2ikad2,it2ijad2,iabjk,iab1j,iabij,q,icmoa,icmob,iquad
|
|
integer ifa,ifb,ita1,itb1,ita2,itb2,itm2,ita1ccsd,iabc1,iabc1m
|
|
integer iabcj,iabcjbuff,iabcjm,iabi1,ldofquad,irecln,ibufln
|
|
integer recperocc,irest,icurrent,verb,first_quad
|
|
|
|
real*8 et,ddot,quad(nal+nval+nbe+nvbe,nquad),ecc,eref,ets
|
|
real*8 ta1(nval,nal),tb1(nvbe,nbe),cmoa(nal,nal),cmob(nbe,nbe)
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),tscalea(nal)
|
|
real*8 tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),tscaleb(nbe)
|
|
real*8 tm2(nval*nvbe,nal*nbe),fa(nal+nval,nal+nval),scr(*)
|
|
real*8 fb(nbe+nvbe,nbe+nvbe),dcore(*),dbg !dbg: debug
|
|
real*8 epaa(nal,nal),epbb(nbe,nbe),epab(nal,nbe),epba(nbe,nal)
|
|
real*8,pointer::cmoap(:,:),cmobp(:,:),quadp(:,:),fap(:,:),fbp(:,:)
|
|
real*8,pointer::ta1p(:,:),tb1p(:,:),ta2p(:,:),tb2p(:,:),tm2p(:,:)
|
|
real*8 eppl_correction
|
|
logical error,inmemory(18),restart,qscale
|
|
|
|
character*3 qro
|
|
character*4 talg
|
|
character*5 scftype
|
|
character*32 dft
|
|
|
|
c local
|
|
integer ied
|
|
logical indocc
|
|
real*8 uia(nal),uib(nbe)
|
|
character*4 localcc
|
|
cc debug
|
|
c integer j
|
|
c real*8 etaaa,etbbb,etbba
|
|
c real*8 etabb,etbaa
|
|
c real*8 etaab
|
|
|
|
c {{{ Interface for pointer
|
|
interface
|
|
subroutine rpoint2d(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
real*8,target :: egydim(dim1,dim2)
|
|
real*8, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
end interface
|
|
c }}}
|
|
|
|
write(iout,*)
|
|
write(iout,"(' Calculation of (T) correction...')")
|
|
c Read t amplitudes if restart
|
|
irest=0
|
|
icurrent=0
|
|
if (restart)
|
|
& call managerestart('r','(t) ',i,scr,scr,ecc,et,ta1,tb1,ta2,tb2,
|
|
& tm2,irest,nal,nbe,nval,nvbe,ets,ied)
|
|
|
|
c {{{ Checking the allocated memory
|
|
|
|
c a,a,a,a
|
|
call memcheck(nval*nal*nval+nval*nval*(nval-1)/2,
|
|
&maxcor-imem+imem1,iout,error)
|
|
|
|
c b,b,b,b
|
|
call memcheck(nvbe*nbe*nvbe+nvbe*nvbe*(nvbe-1)/2,
|
|
&maxcor-imem+imem1,iout,error)
|
|
|
|
c a,b,a,b
|
|
call memcheck(nval*nbe*nval+nval**2*nvbe,maxcor-imem+imem1,iout,
|
|
&error)
|
|
|
|
c b,a,b,a
|
|
call memcheck(nvbe*nal*nvbe+nvbe**2*nval,maxcor-imem+imem1,iout,
|
|
&error)
|
|
|
|
c Return if insufficient memory
|
|
if (error) then
|
|
write(iout,*)
|
|
write(iout,*) 'Insufficient memory for integral reordering in
|
|
&(T) correction.'
|
|
write(iout,*) 'Allocate more memory in MINP!'
|
|
call mrccend(1)
|
|
endif
|
|
c }}}
|
|
|
|
c {{{ Reordering the abci integral lists
|
|
if (talg.eq.'occ '.or.talg.eq.'virt') then
|
|
c a,a,a,a
|
|
if (nval.gt.1.and.nal.gt.0) then
|
|
recln=nval*nval*(nval-1)/2
|
|
recperocc=recln/ibufln
|
|
if (mod(recln,ibufln).gt.0) recperocc=recperocc+1
|
|
open(16,file='iabcaa',form='unformatted')
|
|
c open(17,file='abciaaaa',access='direct',recl=8*recln)
|
|
open(17,file='abciaaaa',access='direct',recl=irecln)
|
|
|
|
f0=1
|
|
nblc0=0
|
|
ma=nal*nval
|
|
do while (f0.le.nval)
|
|
|
|
fx=(3-2*f0+int(dsqrt(dble((2*f0-3)**2)+dble(8*(maxcor-imem+imem1
|
|
&-recln))/dble(ma))))/2
|
|
if (fx.gt.nval-f0+1) fx=nval-f0+1
|
|
|
|
nblc=((2*f0+fx-3)*fx)/2
|
|
|
|
do ef=1,nblc
|
|
read(16) scr((ef-1)*ma+1:ef*ma)
|
|
enddo
|
|
|
|
if (f0.eq.1) then
|
|
do i=1,nal
|
|
scr(nblc*ma+1:nblc*ma+recln)=0.d0
|
|
|
|
do c=1,nval
|
|
do ef=1,nblc
|
|
scr(nblc*ma+(c-1)*nval*(nval-1)/2+nblc0+ef)=
|
|
&scr((ef-1)*nal*nval+(c-1)*nal+i)
|
|
enddo
|
|
enddo
|
|
|
|
c write(17,rec=i) scr(ma*nblc+1:ma*nblc+recln)
|
|
call putlst(17,(i-1)*recperocc+1,scr(ma*nblc+1),recln)
|
|
enddo
|
|
|
|
else
|
|
do i=1,nal
|
|
call getlst(17,(i-1)*recperocc+1,scr(ma*nblc+1),recln)
|
|
c read(17,rec=i) scr(ma*nblc+1:ma*nblc+recln)
|
|
|
|
do c=1,nval
|
|
do ef=1,nblc
|
|
scr(nblc*ma+(c-1)*nval*(nval-1)/2+nblc0+ef)=
|
|
&scr((ef-1)*nal*nval+(c-1)*nal+i)
|
|
enddo
|
|
enddo
|
|
|
|
c write(17,rec=i) scr(ma*nblc+1:ma*nblc+recln)
|
|
call putlst(17,(i-1)*recperocc+1,scr(ma*nblc+1),recln)
|
|
c if (mod(recln,irecln/8).ne.0) then
|
|
c irec=irec+recln/(irecln/8)+1
|
|
c else
|
|
c irec=irec+recln/(irecln/8)
|
|
c endif
|
|
enddo
|
|
endif
|
|
|
|
nblc0=nblc0+nblc
|
|
f0=f0+fx
|
|
|
|
enddo
|
|
|
|
close(17)
|
|
close(16,status='delete')
|
|
endif !nval>1
|
|
|
|
c b,b,b,b
|
|
if (nvbe.gt.1.and.nbe.gt.0) then
|
|
recln=nvbe**2*(nvbe-1)/2
|
|
recperocc=recln/ibufln
|
|
if (mod(recln,ibufln).gt.0) recperocc=recperocc+1
|
|
open(16,file='iabcbb',form='unformatted')
|
|
c open(17,file='abcibbbb',access='direct',recl=8*recln)
|
|
open(17,file='abcibbbb',access='direct',recl=irecln)
|
|
|
|
f0=1
|
|
nblc0=0
|
|
c irec=1
|
|
ma=nbe*nvbe
|
|
do while (f0.le.nvbe)
|
|
|
|
fx=(3-2*f0+int(dsqrt(dble((2*f0-3)**2)+dble(8*(maxcor-imem+imem1
|
|
&-recln))/dble(ma))))/2
|
|
if (fx.gt.nvbe-f0+1) fx=nvbe-f0+1
|
|
|
|
nblc=((2*f0+fx-3)*fx)/2
|
|
|
|
do ef=1,nblc
|
|
read(16) scr((ef-1)*ma+1:ef*ma)
|
|
enddo
|
|
|
|
if (f0.eq.1) then
|
|
do i=1,nbe
|
|
scr(nblc*ma+1:nblc*ma+recln)=0.d0
|
|
|
|
do c=1,nvbe
|
|
do ef=1,nblc
|
|
scr(nblc*ma+(c-1)*nvbe*(nvbe-1)/2+nblc0+ef)=
|
|
&scr((ef-1)*nbe*nvbe+(c-1)*nbe+i)
|
|
enddo
|
|
enddo
|
|
|
|
c write(17,rec=i) scr(ma*nblc+1:ma*nblc+recln)
|
|
call putlst(17,(i-1)*recperocc+1,scr(ma*nblc+1),recln)
|
|
c if (mod(recln,irecln/8).ne.0) then
|
|
c irec=irec+recln/(irecln/8)+1
|
|
c else
|
|
c irec=irec+recln/(irecln/8)
|
|
c endif
|
|
enddo
|
|
|
|
else
|
|
do i=1,nbe
|
|
call getlst(17,(i-1)*recperocc+1,scr(ma*nblc+1),recln)
|
|
c read(17,rec=i) scr(ma*nblc+1:ma*nblc+recln)
|
|
|
|
do c=1,nvbe
|
|
do ef=1,nblc
|
|
scr(nblc*ma+(c-1)*nvbe*(nvbe-1)/2+nblc0+ef)=
|
|
&scr((ef-1)*nbe*nvbe+(c-1)*nbe+i)
|
|
enddo
|
|
enddo
|
|
|
|
c write(17,rec=i) scr(ma*nblc+1:ma*nblc+recln)
|
|
call putlst(17,(i-1)*recperocc+1,scr(ma*nblc+1),recln)
|
|
c if (mod(recln,irecln/8).ne.0) then
|
|
c irec=irec+recln/(irecln/8)+1
|
|
c else
|
|
c irec=irec+recln/(irecln/8)
|
|
c endif
|
|
enddo
|
|
endif
|
|
|
|
nblc0=nblc0+nblc
|
|
f0=f0+fx
|
|
|
|
enddo
|
|
|
|
close(17)
|
|
close(16,status='delete')
|
|
endif !nvbe>1
|
|
|
|
c a,b,a,b
|
|
if (nval.gt.0.and.nvbe.gt.0.and.nbe.gt.0) then
|
|
recln=nval**2*nvbe
|
|
recperocc=recln/ibufln
|
|
if (mod(recln,ibufln).gt.0) recperocc=recperocc+1
|
|
open(16,file='iabcba',form='unformatted') !(b,a,a,b)
|
|
c open(17,file='abciabab',access='direct',recl=8*recln) !(a,b,a,b)
|
|
open(17,file='abciabab',access='direct',recl=irecln) !(a,b,a,b)
|
|
c open(20,file='abcibaab',access='direct',recl=8*recln) !(b,a,a,b),e<->f
|
|
open(20,file='abcibaab',access='direct',recl=irecln) !(b,a,a,b),e<->f
|
|
|
|
f0=1
|
|
nblc0=0
|
|
ma=nbe*nval
|
|
do while (f0.le.nvbe)
|
|
|
|
fx=(maxcor-imem+imem1-2*recln)/(ma*nval)
|
|
if (fx.gt.nvbe-f0+1) fx=nvbe-f0+1
|
|
|
|
nblc=fx*nval
|
|
|
|
do ef=1,nblc
|
|
read(16) scr((ef-1)*ma+1:ef*ma)
|
|
enddo
|
|
|
|
if (f0.eq.1) then
|
|
c abciab
|
|
do i=1,nbe
|
|
scr(nblc*ma+1:nblc*ma+recln)=0.d0
|
|
|
|
do c=1,nval
|
|
do ef=1,nblc
|
|
scr(nblc*ma+(c-1)*nval*nvbe+nblc0+ef)=
|
|
&scr((ef-1)*nbe*nval+(c-1)*nbe+i)
|
|
enddo
|
|
enddo
|
|
|
|
c write(17,rec=i) scr(ma*nblc+1:ma*nblc+recln)
|
|
call putlst(17,(i-1)*recperocc+1,scr(ma*nblc+1),recln)
|
|
|
|
c abcibaab
|
|
call vxyzsw(scr(ma*nblc+1),nval,nvbe,nval,1,
|
|
&scr(ma*nblc+recln+1))
|
|
|
|
c write(20,rec=i) scr(ma*nblc+recln+1:ma*nblc+recln*2)
|
|
call putlst(20,(i-1)*recperocc+1,scr(ma*nblc+recln+1),recln)
|
|
enddo
|
|
|
|
else
|
|
do i=1,nbe
|
|
c read(17,rec=i) scr(ma*nblc+1:ma*nblc+recln)
|
|
call getlst(17,(i-1)*recperocc+1,scr(ma*nblc+1),recln)
|
|
|
|
c abciab
|
|
do c=1,nval
|
|
do ef=1,nblc
|
|
scr(nblc*ma+(c-1)*nval*nvbe+nblc0+ef)=
|
|
&scr((ef-1)*nbe*nval+(c-1)*nbe+i)
|
|
enddo
|
|
enddo
|
|
|
|
c write(17,rec=i) scr(ma*nblc+1:ma*nblc+recln)
|
|
call putlst(17,(i-1)*recperocc+1,scr(ma*nblc+1),recln)
|
|
|
|
c abcibaab
|
|
call vxyzsw(scr(ma*nblc+1),nval,nvbe,nval,1,
|
|
&scr(ma*nblc+recln+1))
|
|
|
|
c write(20,rec=i) scr(ma*nblc+recln+1:ma*nblc+recln*2)
|
|
call putlst(20,(i-1)*recperocc+1,scr(ma*nblc+recln+1),recln)
|
|
enddo
|
|
endif
|
|
|
|
nblc0=nblc0+nblc
|
|
f0=f0+fx
|
|
|
|
enddo
|
|
|
|
close(17)
|
|
close(16,status='delete')
|
|
close(20)
|
|
endif !nval>0,nvbe>0
|
|
|
|
c b,a,b,a (switching e<-->f)
|
|
if (nvbe.gt.0.and.nval.gt.0) then
|
|
recln=nvbe**2*nval
|
|
recperocc=recln/ibufln
|
|
if (mod(recln,ibufln).gt.0) recperocc=recperocc+1
|
|
open(16,file='iabcab',form='unformatted') !(a,b,a,b)
|
|
c open(17,file='abciabba',access='direct',recl=8*recln) !(a,b,b,a)!!!!!!
|
|
open(17,file='abciabba',access='direct',recl=irecln) !(a,b,b,a)!!!!!!
|
|
c open(20,file='abcibaba',access='direct',recl=8*recln) !(b,a,b,a)
|
|
open(20,file='abcibaba',access='direct',recl=irecln) !(b,a,b,a)
|
|
|
|
f0=1
|
|
nblc0=0
|
|
ma=nal*nvbe
|
|
do while (f0.le.nvbe)
|
|
|
|
fx=(maxcor-imem+imem1-2*recln)/(ma*nval)
|
|
if (fx.gt.nvbe-f0+1) fx=nvbe-f0+1
|
|
|
|
nblc=fx*nval
|
|
|
|
do ef=1,nblc
|
|
read(16) scr((ef-1)*ma+1:ef*ma)
|
|
enddo
|
|
|
|
if (f0.eq.1) then
|
|
c abciba
|
|
do i=1,nal
|
|
scr(nblc*ma+1:nblc*ma+recln)=0.d0
|
|
|
|
do c=1,nvbe
|
|
do ef=1,nblc
|
|
scr(nblc*ma+(c-1)*nval*nvbe+nblc0+ef)=
|
|
&scr((ef-1)*nal*nvbe+(c-1)*nal+i)
|
|
enddo
|
|
enddo
|
|
|
|
c write(17,rec=i) scr(ma*nblc+1:ma*nblc+recln)
|
|
call putlst(17,(i-1)*recperocc+1,scr(ma*nblc+1),recln)
|
|
|
|
c abcibaba
|
|
call vxyzsw(scr(nblc*ma+1),nval,nvbe,nvbe,1,
|
|
&scr(nblc*ma+recln+1))
|
|
|
|
c write(20,rec=i) scr(ma*nblc+recln+1:ma*nblc+recln*2)
|
|
call putlst(20,(i-1)*recperocc+1,scr(ma*nblc+recln+1),recln)
|
|
enddo
|
|
|
|
else
|
|
do i=1,nal
|
|
c abciba
|
|
c read(17,rec=i) scr(ma*nblc+1:ma*nblc+recln)
|
|
call getlst(17,(i-1)*recperocc+1,scr(ma*nblc+1),recln)
|
|
|
|
do c=1,nvbe
|
|
do ef=1,nblc
|
|
scr(nblc*ma+(c-1)*nval*nvbe+nblc0+ef)=
|
|
&scr((ef-1)*nal*nvbe+(c-1)*nal+i)
|
|
enddo
|
|
enddo
|
|
|
|
c write(17,rec=i) scr(ma*nblc+1:ma*nblc+recln)
|
|
call putlst(17,(i-1)*recperocc+1,scr(ma*nblc+1),recln)
|
|
|
|
c abcibaba
|
|
call vxyzsw(scr(ma*nblc+1),nval,nvbe,nvbe,1,
|
|
&scr(ma*nblc+recln+1))
|
|
|
|
c write(20,rec=i) scr(ma*nblc+recln+1:ma*nblc+recln*2)
|
|
call putlst(20,(i-1)*recperocc+1,scr(ma*nblc+recln+1),recln)
|
|
enddo
|
|
endif
|
|
|
|
nblc0=nblc0+nblc
|
|
f0=f0+fx
|
|
|
|
enddo
|
|
|
|
close(17)
|
|
close(16,status='delete')
|
|
close(20)
|
|
endif !nval>0,nvbe>0
|
|
endif !localcc
|
|
c }}}
|
|
|
|
c Initializing the percentage tracker
|
|
if (localcc.eq.'off ') then
|
|
total=nal*(nal-1)*(nal-2)/6+nbe*(nbe-1)*(nbe-2)/6+
|
|
&nal*nbe*(nbe-1)/2+nbe*nal*(nal-1)/2
|
|
else !localcc.ne.off
|
|
if (talg.eq.'occ ') then
|
|
total=nal**2*(nal-1)/2+nbe**2*(nbe-1)/2+nal*nbe*(nbe-1)/2+
|
|
&nbe*nal*(nal-1)/2+nal*nal*nbe+nbe*nbe*nal
|
|
elseif (talg.eq.'lapl') then
|
|
total=(nal-1)*(nal-2)/2+nbe*(nbe-1)/2+(nal-1)*nbe
|
|
if (indocc) ! (total = 2*total would also work)
|
|
&total=total+(nbe-1)*(nbe-2)/2+nal*(nal-1)/2+(nbe-1)*nal
|
|
total=total*nquad
|
|
endif
|
|
endif
|
|
|
|
c Calculating the (T) correction
|
|
if (restart) then
|
|
write(iout, "(' Restarting (T) calculation from ', i3,'%...')")
|
|
& int(dble(100)*irest/total)
|
|
else
|
|
et=0.d0
|
|
ets=0.d0
|
|
endif
|
|
pr=0
|
|
prold=0
|
|
write(iout,"(i4,'% done.')") 1
|
|
if (localcc.ne.'off ') then
|
|
c {{{ (T) correction with CIM
|
|
if (talg.eq.'occ '.or.talg.eq.'virt') then
|
|
c aaa
|
|
if (nval.gt.2.and.nal.gt.2) then
|
|
it2list1=dblalloc(nval*nval*nal*(nal-1)/2)
|
|
it2list2=dblalloc(nval*(nval-1)*nal*nal/2)
|
|
its= dblalloc(nval*nval*(nval-1)/2)
|
|
iw= dblalloc(nval*(nval-1)*(nval-2)/6)
|
|
it= dblalloc(nval*(nval-1)*(nval-2)/6)
|
|
ivooo= dblalloc(nval*nal*nal*(nal-1)/2)
|
|
ivvoo= dblalloc(nval*(nval-1)*nal*(nal-1)/4)
|
|
icmo= dblalloc(nal**2)
|
|
it3= dblalloc(nval*(nval-1)*(nval-2)*nal**2*(nal-1)/12)
|
|
iw3= dblalloc(nval*(nval-1)*(nval-2)*nal**2*(nal-1)/12)
|
|
it3u= dblalloc(nval*(nval-1)*(nval-2)*nal*(nal-1)/12)
|
|
iw3u= dblalloc(nval*(nval-1)*(nval-2)*nal*(nal-1)/12)
|
|
|
|
call loccimtaaa(nal,nbe,nval,nvbe,ta1,tb1,ta2,tb2,fa,fb,
|
|
&dcore(it2list1),dcore(it2list2),dcore(its),dcore(iw),dcore(it),
|
|
&dcore(ivooo),dcore(ivvoo),dcore(it3),dcore(iw3),dcore(it3u),
|
|
&dcore(iw3u),uia,
|
|
&dcore(imem),
|
|
&'aijkaa','abijaa','abciaaaa',et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln)
|
|
call dbldealloc(it2list1)
|
|
endif !nval>2,nal>2
|
|
c bbb
|
|
c et=0.d0
|
|
if (nvbe.gt.2.and.nbe.gt.2.and.indocc) then
|
|
it2list1=dblalloc(nvbe*nvbe*nbe*(nbe-1)/2)
|
|
it2list2=dblalloc(nvbe*(nvbe-1)*nbe*nbe/2)
|
|
its= dblalloc(nvbe*nvbe*(nvbe-1)/2)
|
|
iw= dblalloc(nvbe*(nvbe-1)*(nvbe-2)/6)
|
|
it= dblalloc(nvbe*(nvbe-1)*(nvbe-2)/6)
|
|
ivooo= dblalloc(nvbe*nbe*nbe*(nbe-1)/2)
|
|
ivvoo= dblalloc(nvbe*(nvbe-1)*nbe*(nbe-1)/4)
|
|
icmo= dblalloc(nbe**2)
|
|
it3= dblalloc(nvbe*(nvbe-1)*(nvbe-2)*nbe**2*(nbe-1)/12)
|
|
iw3= dblalloc(nvbe*(nvbe-1)*(nvbe-2)*nbe**2*(nbe-1)/12)
|
|
it3u= dblalloc(nvbe*(nvbe-1)*(nvbe-2)*nbe*(nbe-1)/12)
|
|
iw3u= dblalloc(nvbe*(nvbe-1)*(nvbe-2)*nbe*(nbe-1)/12)
|
|
|
|
call loccimtaaa(nbe,nal,nvbe,nval,tb1,ta1,tb2,ta2,fb,fa,
|
|
&dcore(it2list1),dcore(it2list2),dcore(its),dcore(iw),dcore(it),
|
|
&dcore(ivooo),dcore(ivvoo),dcore(it3),dcore(iw3),dcore(it3u),
|
|
&dcore(iw3u),uib,
|
|
&dcore(imem),
|
|
&'aijkbb','abijbb','abcibbbb',et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln)
|
|
call dbldealloc(it2list1)
|
|
endif !nvbe>2,nbe>2
|
|
c abb
|
|
c et=0.d0
|
|
if (nval.gt.0.and.nvbe.gt.1.and.nal.gt.0.and.nbe.gt.1) then
|
|
it2list1=dblalloc(nvbe*nvbe*nbe*(nbe-1)/2)
|
|
it2list2=dblalloc(nvbe*(nvbe-1)*nbe**2/2)
|
|
itm2list=dblalloc(nval*nvbe*nal*nbe)
|
|
its=dblalloc(nval*nvbe**2)
|
|
iw=dblalloc(nval*nvbe*(nvbe-1)/2)
|
|
it=dblalloc(nval*nvbe*(nvbe-1)/2)
|
|
ivooo=dblalloc(nvbe*nbe*nbe*(nbe-1)/2)
|
|
ivoooab=dblalloc(nval*nbe*nal*nbe)
|
|
ivoooba=dblalloc(nvbe*nal*nbe*nal)
|
|
ivvoo=dblalloc(nvbe*(nvbe-1)*nbe*(nbe-1)/4)
|
|
ivvooab=dblalloc(nvbe*nbe*nval*nal)
|
|
iabcii=dblalloc(nval*nvbe**2*nal)
|
|
c ifullt3=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
c ifullt3buff=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
c ifullw3=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
c ifullw3buff=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
call loccimtabb(nal,nbe,nval,nvbe,ta1,tb1,tb2,tm2,fa,fb,
|
|
&dcore(it2list1),dcore(it2list2),dcore(itm2list),dcore(its),
|
|
&dcore(iw),dcore(it),dcore(ivooo),dcore(ivoooab),dcore(ivoooba),
|
|
&dcore(ivvoo),dcore(ivvooab),
|
|
&cmoa,cmob,dcore(iabcii),dcore(imem),
|
|
&'aijkbb','aijkab','aijkba','abijbb','abijab','abciabba','abcibbbb'
|
|
&,'abciabab',
|
|
&uia,uib,et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln)
|
|
call dbldealloc(it2list1)
|
|
endif !nval>0,nvbe>1,nal>0,nbe>1
|
|
c bba
|
|
c et=0.d0
|
|
if (nbe.gt.1.and.nvbe.gt.1.and.nal.gt.0.and.nval.gt.0.and.
|
|
& indocc) then
|
|
it2list1=dblalloc(nvbe*nvbe*nbe*(nbe-1)/2)
|
|
it2list2=dblalloc(nvbe*(nvbe-1)*nbe**2/2)
|
|
itm2list=dblalloc(nvbe*nval*nbe*nal)
|
|
its=dblalloc(nval*nvbe**2)
|
|
iw=dblalloc(nval*nvbe*(nvbe-1)/2)
|
|
it=dblalloc(nval*nvbe*(nvbe-1)/2)
|
|
ivooo=dblalloc(nvbe*nbe*nbe*(nbe-1)/2)
|
|
ivoooab=dblalloc(nval*nbe*nal*nbe)
|
|
ivoooba=dblalloc(nvbe*nal*nbe*nal)
|
|
ivvoo=dblalloc(nvbe*(nvbe-1)*nbe*(nbe-1)/4)
|
|
ivvooab=dblalloc(nval*nal*nvbe*nbe)
|
|
iabcii=dblalloc(nval*nvbe**2*nal)
|
|
c ifullt3=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
c ifullt3buff=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
c ifullw3=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
c ifullw3buff=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
call loccimtbba(nal,nbe,nval,nvbe,ta1,tb1,tb2,tm2,fa,fb,
|
|
&dcore(it2list1),dcore(it2list2),dcore(itm2list),dcore(its),
|
|
&dcore(iw),dcore(it),dcore(ivooo),dcore(ivoooab),dcore(ivoooba),
|
|
&dcore(ivvoo),dcore(ivvooab),
|
|
&cmoa,cmob,dcore(iabcii),dcore(imem),
|
|
&'aijkbb','aijkab','aijkba','abijbb','abijab','abciabba','abcibbbb'
|
|
&,'abciabab',
|
|
&uia,uib,et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln)
|
|
call dbldealloc(it2list1)
|
|
endif !nbe>1,nvbe>1,nal>0,nval>0
|
|
c beta<->alpha in tm2 and abijab so calling routines with opposite spin is possible
|
|
call vxyzdsw(tm2,nval,nvbe,nal,nbe,dcore(imem))
|
|
call dcopy(nval*nvbe*nal*nbe,dcore(imem),1,tm2,1)
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) scr(1:nval*nvbe*nal*nbe)
|
|
close(16,status='delete')
|
|
call vxyzdsw(scr,nval,nvbe,nal,nbe,scr(nval*nvbe*nal*nbe+1))
|
|
open(17,file='abijba',form='unformatted')
|
|
write(17) scr(nval*nvbe*nal*nbe+1:nval*nvbe*nal*nbe*2)
|
|
close(17)
|
|
c baa
|
|
c et=0.d0
|
|
if (nvbe.gt.0.and.nval.gt.1.and.nbe.gt.0.and.nal.gt.1.and.
|
|
& indocc) then
|
|
it2list1=dblalloc(nval*nval*nal*(nal-1)/2)
|
|
it2list2=dblalloc(nval*(nval-1)*nal**2/2)
|
|
itm2list=dblalloc(nvbe*nval*nbe*nal)
|
|
its=dblalloc(nvbe*nval**2)
|
|
iw=dblalloc(nvbe*nval*(nval-1)/2)
|
|
it=dblalloc(nvbe*nval*(nval-1)/2)
|
|
ivooo=dblalloc(nval*nal*nal*(nal-1)/2)
|
|
ivoooab=dblalloc(nvbe*nal*nbe*nal)
|
|
ivoooba=dblalloc(nval*nbe*nal*nbe)
|
|
ivvoo=dblalloc(nval*(nval-1)*nal*(nal-1)/4)
|
|
ivvooab=dblalloc(nval*nal*nvbe*nbe)
|
|
iabcii=dblalloc(nvbe*nval**2*nbe)
|
|
c ifullt3=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
c ifullt3buff=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
c ifullw3=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
c ifullw3buff=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
call loccimtabb(nbe,nal,nvbe,nval,tb1,ta1,ta2,tm2,fb,fa,
|
|
&dcore(it2list1),dcore(it2list2),dcore(itm2list),dcore(its),
|
|
&dcore(iw),dcore(it),dcore(ivooo),dcore(ivoooab),dcore(ivoooba),
|
|
&dcore(ivvoo),dcore(ivvooab),
|
|
&cmob,cmoa,dcore(iabcii),dcore(imem),
|
|
&'aijkaa','aijkba','aijkab','abijaa','abijba','abcibaab','abciaaaa'
|
|
&,'abcibaba',
|
|
&uib,uia,et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln)
|
|
call dbldealloc(it2list1)
|
|
endif !nval>0,nvbe>1,nal>0,nbe>1
|
|
c aab
|
|
c et=0.d0
|
|
if (nal.gt.1.and.nval.gt.1.and.nbe.gt.0.and.nvbe.gt.0) then
|
|
it2list1=dblalloc(nval*nval*nal*(nal-1)/2)
|
|
it2list2=dblalloc(nval*(nval-1)*nal**2/2)
|
|
itm2list=dblalloc(nval*nvbe*nal*nbe)
|
|
its=dblalloc(nvbe*nval**2)
|
|
iw=dblalloc(nvbe*nval*(nval-1)/2)
|
|
it=dblalloc(nvbe*nval*(nval-1)/2)
|
|
ivooo=dblalloc(nval*nal*nal*(nal-1)/2)
|
|
ivoooab=dblalloc(nvbe*nal*nbe*nal)
|
|
ivoooba=dblalloc(nval*nbe*nal*nbe)
|
|
ivvoo=dblalloc(nval*(nval-1)*nal*(nal-1)/4)
|
|
ivvooab=dblalloc(nvbe*nbe*nval*nal)
|
|
iabcii=dblalloc(nvbe*nval**2*nbe)
|
|
c ifullt3=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
c ifullt3buff=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
c ifullw3=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
c ifullw3buff=dblalloc(nval*nvbe*(nvbe-1)*nal*nbe**2/2)
|
|
call loccimtbba(nbe,nal,nvbe,nval,tb1,ta1,ta2,tm2,fb,fa,
|
|
&dcore(it2list1),dcore(it2list2),dcore(itm2list),dcore(its),
|
|
&dcore(iw),dcore(it),dcore(ivooo),dcore(ivoooab),dcore(ivoooba),
|
|
&dcore(ivvoo),dcore(ivvooab),
|
|
&cmob,cmoa,dcore(iabcii),dcore(imem),
|
|
&'aijkaa','aijkba','aijkab','abijaa','abijba','abcibaab','abciaaaa'
|
|
&,'abcibaba',
|
|
&uib,uia,et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln)
|
|
call dbldealloc(it2list1)
|
|
endif !nal>1,nval>1,nbe>0,nvbe>0
|
|
endif !talg=occ
|
|
c }}}
|
|
|
|
c {{{ (T) correction with Laplace-transform
|
|
************************************************************************
|
|
* inmemory: 1-fa, 2-ta1, 3-ta2, 4-jaba, 5-jaia, 6-voooaa, *
|
|
* 7-voooab, 8-voooba, 9-tm2 *
|
|
* *
|
|
* 10-fb, 11-tb1, 12-tb2, 13-jabb, 14-jaib, 15-vooobb, *
|
|
* 16-voooba, 17-voooab, 18-tm2 *
|
|
************************************************************************
|
|
if (talg.eq.'lapl') then
|
|
ldofquad=nal+nval+nbe+nvbe
|
|
quad=dsqrt(quad)
|
|
c Preparing for Laplace loop
|
|
!Read and unpack Jab
|
|
ijaba=dblalloc(dfnbasis*nval**2)
|
|
call read_and_proc_dfint(dcore(ijaba),dfnbasis,nval,dcore(imem),
|
|
& 'DFINT_AB ',nval,'up')
|
|
!Read and unpack JAB
|
|
if (nbe.gt.0) then
|
|
ijabb=dblalloc(dfnbasis*nvbe**2)
|
|
call read_and_proc_dfint(dcore(ijabb),dfnbasis,nvbe,dcore(imem),
|
|
& 'DFINT_ABb',nvbe,'up')
|
|
endif !nbe.gt.0
|
|
!Read and transpose Jai
|
|
ijaia=dblalloc(nval*nal*dfnbasis)
|
|
call read_and_proc_dfint(dcore(ijaia),dfnbasis,nval,dcore(imem),
|
|
& 'DFINT_AI ',nal,'tr')
|
|
!Read and transpose JAI
|
|
if (nbe.gt.0) then
|
|
ijaib=dblalloc(nvbe*nbe*dfnbasis)
|
|
call read_and_proc_dfint(dcore(ijaib),dfnbasis,nvbe,dcore(imem),
|
|
& 'DFINT_AIb',nbe,'tr')
|
|
endif !nbe.gt.0
|
|
!Allocate memory for aijk
|
|
ivoooab=dblalloc(nval*nbe*nal*nbe)
|
|
ivoooba=dblalloc(nvbe*nal*nbe*nal)
|
|
ivooo=imem
|
|
! Skip already completed quadrature points
|
|
first_quad=1
|
|
do while(icurrent+total/nquad.le.irest.and.total.gt.0)
|
|
if (verb.gt.3)write(iout,"(' Quad. point',i3,' already done')")
|
|
$ first_quad
|
|
icurrent=icurrent+total/nquad
|
|
first_quad=first_quad+1
|
|
enddo
|
|
if (verb.gt.3.and.first_quad.gt.1)
|
|
$ write(iout,*)' Starting Laplace quadarture loop at',
|
|
$ first_quad
|
|
do q=first_quad,nquad !Loop for Laplace quadrature
|
|
inmemory=.false.
|
|
c aaa
|
|
if (nal.gt.2.and.nval.gt.2) then
|
|
ivooo= dblalloc(nval*nal*nal*(nal-1)/2)
|
|
it2jkad=dblalloc(nval**2)
|
|
it2ikad=dblalloc(nval**2)
|
|
it2ijad=dblalloc(nval**2)
|
|
it2kbcl=dblalloc(nval*(nval-1)*nal/2)
|
|
it2jbcl=dblalloc(nval*(nval-1)*nal/2)
|
|
it2ibcl=dblalloc(nval*(nval-1)*nal/2)
|
|
iabjk= dblalloc(nval**2*nal)
|
|
iabij= dblalloc(nval**2)
|
|
its= dblalloc(nval*nval*(nval-1)/2)
|
|
iw= dblalloc(nval*(nval-1)*(nval-2)/6)
|
|
it= dblalloc(nval*(nval-1)*(nval-2)/6)
|
|
|
|
call loclapltaaa(nal,nbe,nval,nvbe,q,nquad,dfnbasis,ta1,ta2,
|
|
&fa,cmoa,quad,dcore(ivooo),dcore(iabjk),dcore(iabij),dcore(its),
|
|
&dcore(iw),dcore(it),dcore(it2jkad),dcore(it2ikad),dcore(it2ijad),
|
|
&dcore(it2kbcl),dcore(it2jbcl),dcore(it2ibcl),dcore(ijaba),
|
|
&dcore(ijaia),dcore(imem),'DFINT_IJ ',et,maxcor,imem,imem1,iout,
|
|
&error,pr,total,prold,ldofquad,inmemory,irest,icurrent,ied,
|
|
&first_quad)
|
|
call dbldealloc(it2jkad)
|
|
endif !nal>2, nval>2
|
|
c aab
|
|
if (nbe.gt.0.and.nvbe.gt.0.and.nal.gt.1.and.nval.gt.1) then
|
|
call vxyzdsw(tm2,nval,nvbe,nal,nbe,dcore(imem)) !Transpose tm2 for spin mirroring
|
|
call dcopy(nval*nvbe*nal*nbe,dcore(imem),1,tm2,1)
|
|
if (.not.inmemory(6)) ivooo=dblalloc(nval*nal*nal*(nal-1)/2)
|
|
it2iabl=dblalloc(nvbe*nval*nal)
|
|
it2kbcl=dblalloc(nval*(nval-1)*nal/2)
|
|
it2jbcl=dblalloc(nval*(nval-1)*nal/2)
|
|
it2jkad=dblalloc(nval**2)
|
|
its=dblalloc(nvbe*nval**2)
|
|
iw=dblalloc(nvbe*nval*(nval-1)/2)
|
|
it=dblalloc(nvbe*nval*(nval-1)/2)
|
|
iabc1=dblalloc(nval**2*(nval-1)/2)
|
|
iabc1m=dblalloc(nvbe**2*nval)
|
|
iabcj=dblalloc(nval**2*(nval-1)/2)
|
|
iabcjbuff=dblalloc(max(nval**3,nvbe**2*nval))
|
|
iabcjm=dblalloc(nvbe**2*nval)
|
|
iabjk=dblalloc(nval**2)
|
|
iabi1=dblalloc(nvbe*nval*nbe)
|
|
iabij=dblalloc(nvbe*nval*nbe)
|
|
|
|
call loclapltbba(nbe,nal,nvbe,nval,dfnbasis,q,nquad,
|
|
&quad(nal+nval+1,1),quad(1,1),tb1,ta1,ta2,tm2,fb,fa,
|
|
&dcore(ijabb),
|
|
&dcore(ijaba),dcore(ijaib),dcore(ijaia),dcore(it2iabl),
|
|
&dcore(it2kbcl),dcore(it2jbcl),dcore(it2jkad),dcore(its),
|
|
&dcore(iw),dcore(it),dcore(ivooo),dcore(ivoooba),dcore(ivoooab),
|
|
&dcore(iabc1),dcore(iabc1m),dcore(iabcj),dcore(iabcjm),
|
|
&dcore(iabcjbuff),dcore(iabjk),dcore(iabi1),dcore(iabij),cmob,cmoa,
|
|
&dcore(imem),'DFINT_IJb','DFINT_IJ ',et,maxcor,imem,imem1,iout,
|
|
&error,pr,total,prold,inmemory(10),inmemory,irest,icurrent,ied,
|
|
&first_quad)
|
|
call dbldealloc(it2iabl)
|
|
if (.not.
|
|
& (nbe.gt.0.and.nvbe.gt.0.and.nal.gt.1.and.nval.gt.1.and.indocc))
|
|
& then
|
|
call vxyzdsw(tm2,nvbe,nval,nbe,nal,dcore(imem))
|
|
call dcopy(nval*nvbe*nal*nbe,dcore(imem),1,tm2,1)
|
|
endif
|
|
endif !nal>0,nval>0,nbe>1,nvbe>1,indocc
|
|
c baa
|
|
if (nbe.gt.0.and.nvbe.gt.0.and.nal.gt.1.and.nval.gt.1.and.indocc)
|
|
& then
|
|
if (.not.(nbe.gt.0.and.nvbe.gt.0.and.nal.gt.1.and.nval.gt.1))then
|
|
call vxyzdsw(tm2,nval,nvbe,nal,nbe,dcore(imem))
|
|
call dcopy(nval*nvbe*nal*nbe,dcore(imem),1,tm2,1)
|
|
endif
|
|
if (.not.inmemory(6)) ivooo=dblalloc(nval*nal*nal*(nal-1)/2)
|
|
it2iabl=dblalloc(nvbe*nval*nal)
|
|
it2kbcl=dblalloc(nval*(nval-1)*nal/2)
|
|
it2jbcl=dblalloc(nval*(nval-1)*nal/2)
|
|
it2jkad=dblalloc(nval**2)
|
|
its=dblalloc(nvbe*nval**2)
|
|
iw=dblalloc(nvbe*nval*(nval-1)/2)
|
|
it=dblalloc(nvbe*nval*(nval-1)/2)
|
|
iabjk=dblalloc(nval**2)
|
|
iab1j=dblalloc(nvbe*nval*nal)
|
|
iabcii=dblalloc(nvbe*nval**2)
|
|
|
|
call loclapltabb(nbe,nal,nvbe,nval,q,dfnbasis,nquad,
|
|
&quad(nal+nval+1,1),quad(1,1),tb1,ta1,ta2,tm2,fb,fa,
|
|
&dcore(ijabb),dcore(ijaba),dcore(ijaib),dcore(ijaia),
|
|
&dcore(it2iabl),dcore(it2kbcl),dcore(it2jbcl),dcore(it2jkad),
|
|
&dcore(its),dcore(iw),dcore(it),dcore(ivooo),dcore(ivoooba),
|
|
&dcore(ivoooab),dcore(iabjk),dcore(iab1j),cmob,cmoa,dcore(iabcii),
|
|
&dcore(imem),'DFINT_IJb','DFINT_IJ ',et,maxcor,imem,imem1,iout,
|
|
&error,pr,total,prold,inmemory(10),inmemory,irest,icurrent,ied,
|
|
&first_quad)
|
|
call dbldealloc(it2iabl)
|
|
call vxyzdsw(tm2,nvbe,nval,nbe,nal,dcore(imem))
|
|
call dcopy(nval*nvbe*nal*nbe,dcore(imem),1,tm2,1)
|
|
endif !nbe>0,nvbe>0,nal>1,nval>1,indocc
|
|
call dbldealloc(ivooo)
|
|
c abb
|
|
if (nal.gt.0.and.nval.gt.0.and.nbe.gt.1.and.nvbe.gt.1) then
|
|
ivooo=dblalloc(nvbe*nbe*nbe*(nbe-1)/2)
|
|
it2iabl=dblalloc(nval*nvbe*nbe)
|
|
it2kbcl=dblalloc(nvbe*(nvbe-1)*nbe/2)
|
|
it2jbcl=dblalloc(nvbe*(nvbe-1)*nbe/2)
|
|
it2jkad=dblalloc(nvbe**2)
|
|
its=dblalloc(nval*nvbe**2)
|
|
iw=dblalloc(nval*nvbe*(nvbe-1)/2)
|
|
it=dblalloc(nval*nvbe*(nvbe-1)/2)
|
|
iabjk=dblalloc(nvbe**2)
|
|
iab1j=dblalloc(nval*nvbe*nbe)
|
|
iabcii=dblalloc(nval*nvbe**2)
|
|
|
|
call loclapltabb(nal,nbe,nval,nvbe,q,dfnbasis,nquad,quad(1,1),
|
|
&quad(nal+nval+1,1),ta1,tb1,tb2,tm2,fa,fb,dcore(ijaba),
|
|
&dcore(ijabb),dcore(ijaia),dcore(ijaib),dcore(it2iabl),
|
|
&dcore(it2kbcl),dcore(it2jbcl),dcore(it2jkad),dcore(its),dcore(iw),
|
|
&dcore(it),dcore(ivooo),dcore(ivoooab),dcore(ivoooba),dcore(iabjk),
|
|
&dcore(iab1j),cmoa,cmob,dcore(iabcii),dcore(imem),'DFINT_IJ ',
|
|
&'DFINT_IJb',et,maxcor,imem,imem1,iout,error,pr,total,prold,
|
|
&inmemory,inmemory(10),irest,icurrent,ied,first_quad)
|
|
call dbldealloc(it2iabl)
|
|
endif !nal>0,nval>0,nbe>1,nvbe>1
|
|
c bba
|
|
if (nal.gt.0.and.nval.gt.0.and.nbe.gt.1.and.nvbe.gt.1.and.indocc)
|
|
& then
|
|
if (.not.inmemory(15)) ivooo=dblalloc(nvbe*nbe*nbe*(nbe-1)/2)
|
|
it2iabl=dblalloc(nval*nvbe*nbe)
|
|
it2kbcl=dblalloc(nvbe*(nvbe-1)*nbe/2)
|
|
it2jbcl=dblalloc(nvbe*(nvbe-1)*nbe/2)
|
|
it2jkad=dblalloc(nvbe**2)
|
|
its=dblalloc(nval*nvbe**2)
|
|
iw=dblalloc(nval*nvbe*(nvbe-1)/2)
|
|
it=dblalloc(nval*nvbe*(nvbe-1)/2)
|
|
iabc1=dblalloc(nvbe**2*(nvbe-1)/2)
|
|
iabc1m=dblalloc(nval**2*nvbe)
|
|
iabcj=dblalloc(nvbe**2*(nvbe-1)/2)
|
|
iabcjbuff=dblalloc(max(nvbe**3,nval**2*nvbe))
|
|
iabcjm=dblalloc(nval**2*nvbe)
|
|
iabjk=dblalloc(nvbe**2)
|
|
iabi1=dblalloc(nval*nvbe*nal)
|
|
iabij=dblalloc(nval*nvbe*nal)
|
|
|
|
call loclapltbba(nal,nbe,nval,nvbe,dfnbasis,q,nquad,
|
|
&quad(1,1),quad(nal+nval+1,1),ta1,tb1,tb2,tm2,fa,fb,
|
|
&dcore(ijaba),
|
|
&dcore(ijabb),dcore(ijaia),dcore(ijaib),dcore(it2iabl),
|
|
&dcore(it2kbcl),dcore(it2jbcl),dcore(it2jkad),dcore(its),
|
|
&dcore(iw),dcore(it),dcore(ivooo),dcore(ivoooab),dcore(ivoooba),
|
|
&dcore(iabc1),dcore(iabc1m),dcore(iabcj),dcore(iabcjm),
|
|
&dcore(iabcjbuff),dcore(iabjk),dcore(iabi1),dcore(iabij),cmoa,cmob,
|
|
&dcore(imem),'DFINT_IJ ','DFINT_IJb',et,maxcor,imem,imem1,iout,
|
|
&error,pr,total,prold,inmemory,inmemory(10),irest,icurrent,ied,
|
|
&first_quad)
|
|
call dbldealloc(it2iabl)
|
|
endif !nal>0,nval>0,nbe>1,nvbe>1,indocc
|
|
c bbb
|
|
if (nbe.gt.2.and.nvbe.gt.2.and.indocc) then
|
|
if (.not.inmemory(15)) ivooo= dblalloc(nvbe*nbe*nbe*(nbe-1)/2)
|
|
it2jkad=dblalloc(nvbe**2)
|
|
it2ikad=dblalloc(nvbe**2)
|
|
it2ijad=dblalloc(nvbe**2)
|
|
it2kbcl=dblalloc(nvbe*(nvbe-1)*nbe/2)
|
|
it2jbcl=dblalloc(nvbe*(nvbe-1)*nbe/2)
|
|
it2ibcl=dblalloc(nvbe*(nvbe-1)*nbe/2)
|
|
iabjk= dblalloc(nvbe**2*nbe)
|
|
iabij= dblalloc(nvbe**2)
|
|
its= dblalloc(nvbe*nvbe*(nvbe-1)/2)
|
|
iw= dblalloc(nvbe*(nvbe-1)*(nvbe-2)/6)
|
|
it= dblalloc(nvbe*(nvbe-1)*(nvbe-2)/6)
|
|
|
|
call loclapltaaa(nbe,nal,nvbe,nval,q,nquad,dfnbasis,tb1,tb2,
|
|
&fb,cmob,quad(nal+nval+1,1),dcore(ivooo),dcore(iabjk),
|
|
&dcore(iabij),dcore(its),dcore(iw),dcore(it),dcore(it2jkad),
|
|
&dcore(it2ikad),dcore(it2ijad),dcore(it2kbcl),dcore(it2jbcl),
|
|
&dcore(it2ibcl),dcore(ijabb),dcore(ijaib),dcore(imem),'DFINT_IJb',
|
|
&et,maxcor,imem,imem1,iout,error,pr,total,prold,ldofquad,
|
|
&inmemory(10),irest,icurrent,ied,first_quad)
|
|
call dbldealloc(it2jkad)
|
|
endif !nbe>2, nvbe>2, indocc
|
|
call dbldealloc(ivooo)
|
|
enddo !q
|
|
call dbldealloc(ijaba) !Memory allocated for Laplace loop
|
|
endif !talg.eq.lapl
|
|
c }}}
|
|
|
|
else !localcc=off
|
|
|
|
call getkey('dft', 3, dft, 32)
|
|
|
|
if (trim(scftype).eq.'uhf'.and.trim(dft).eq.'off') then
|
|
if (nal.gt.2.and.nval.gt.2.and.irest.lt.nal*(nal-1)*(nal-2)/6)
|
|
& then
|
|
call taaauhf(nal,nbe,nval,nvbe,ta1,tb1,ta2,tb2,fa,fb,scr,'aijkaa',
|
|
&'abijaa','abciaaaa',et,maxcor,imem,imem1,iout,error,pr,
|
|
&total,prold,ibufln,irecln,irest,icurrent,ets,qscale,tscalea,epaa)
|
|
else
|
|
icurrent=icurrent+nal*(nal-1)*(nal-2)/6
|
|
endif
|
|
|
|
if (nbe.gt.2.and.nvbe.gt.2.and.
|
|
& irest.lt.icurrent+nbe*(nbe-1)*(nbe-2)/6) then
|
|
call taaauhf(nbe,nal,nvbe,nval,tb1,ta1,tb2,ta2,fb,fa,scr,'aijkbb',
|
|
&'abijbb','abcibbbb',et,maxcor,imem,imem1,iout,error,pr,
|
|
&total,prold,ibufln,irecln,irest,icurrent,ets,qscale,tscaleb,epbb)
|
|
else
|
|
icurrent=icurrent+nbe*(nbe-1)*(nbe-2)/6
|
|
endif
|
|
|
|
else ! scftype.eq.'rohf'.or.qro.eq.'on'.or.dft.ne.'off'
|
|
if (nal.gt.2.and.nval.gt.2.and.irest.lt.nal*(nal-1)*(nal-2)/6)
|
|
& then
|
|
call taaarohf(nal,nbe,nval,nvbe,ta1,tb1,ta2,tb2,fa,fb,scr,'aijkaa'
|
|
&,'abijaa','abciaaaa',et,maxcor,imem,imem1,iout,error,pr,
|
|
&total,prold,ibufln,irecln,irest,icurrent,ets,qscale,tscalea,epaa)
|
|
else
|
|
icurrent=icurrent+nal*(nal-1)*(nal-2)/6
|
|
endif
|
|
|
|
if (nbe.gt.2.and.nvbe.gt.2.and.
|
|
& irest.lt.icurrent+nbe*(nbe-1)*(nbe-2)/6) then
|
|
call taaarohf(nbe,nal,nvbe,nval,tb1,ta1,tb2,ta2,fb,fa,scr,'aijkbb'
|
|
&,'abijbb','abcibbbb',et,maxcor,imem,imem1,iout,error,pr,
|
|
&total,prold,ibufln,irecln,irest,icurrent,ets,qscale,tscaleb,epbb)
|
|
else
|
|
icurrent=icurrent+nbe*(nbe-1)*(nbe-2)/6
|
|
endif
|
|
|
|
endif !uhf
|
|
c ABB
|
|
if (nvbe.gt.1.and.nval.gt.0.and.nbe.gt.1.and.nal.gt.0.and.
|
|
& irest.lt.icurrent+nal*nbe*(nbe-1)/2) then
|
|
|
|
if (trim(scftype).eq.'uhf'.and.trim(dft).eq.'off') then
|
|
call tabbuhf(nal,nbe,nval,nvbe,ta1,tb1,tb2,tm2,fa,fb,scr,
|
|
&'aijkbb','aijkab','aijkba','abijbb','abijab','abciabba','abcibbbb'
|
|
&,'abciabab',et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln,irest,icurrent,ets,qscale,tscalea,
|
|
&tscaleb,epab,epbb,verb)
|
|
|
|
else ! scftype.eq.'rohf'.or.qro.eq.'on'.or.dft.ne.'off'
|
|
call tabbrohf(nal,nbe,nval,nvbe,ta1,tb1,tb2,tm2,fa,fb,scr,
|
|
&'aijkbb','aijkab','aijkba','abijbb','abijab','abciabba','abcibbbb'
|
|
&,'abciabab',et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln,irest,icurrent,ets,qscale,tscalea,
|
|
&tscaleb,epab,epbb,verb)
|
|
|
|
endif !uhf
|
|
|
|
else
|
|
icurrent=icurrent+nal*nbe*(nbe-1)/2
|
|
endif !nvbe>1,nval>0
|
|
|
|
c Deleting files
|
|
open(16,file='abciabab')
|
|
close(16,status='delete')
|
|
c AAB
|
|
c Reordering abij integral, tm2 amplitude
|
|
if (nval.gt.1.and.nvbe.gt.0.and.nal.gt.1.and.nbe.gt.0.and.
|
|
& irest.lt.icurrent+nbe*nal*(nal-1)/2) then
|
|
call vxyzdsw(tm2,nval,nvbe,nal,nbe,scr)
|
|
call dcopy(nval*nvbe*nal*nbe,scr,1,tm2,1)
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) scr(1:nval*nvbe*nal*nbe)
|
|
close(16,status='delete')
|
|
call vxyzdsw(scr,nval,nvbe,nal,nbe,scr(nval*nvbe*nal*nbe+1))
|
|
open(17,file='abijba',form='unformatted')
|
|
write(17) scr(nval*nvbe*nal*nbe+1:nval*nvbe*nal*nbe*2)
|
|
close(17)
|
|
|
|
|
|
c Calculating correction
|
|
if (trim(scftype).eq.'uhf'.and.trim(dft).eq.'off') then
|
|
|
|
call tabbuhf(nbe,nal,nvbe,nval,tb1,ta1,ta2,tm2,fb,fa,scr,
|
|
&'aijkaa','aijkba','aijkab','abijaa','abijba','abcibaab','abciaaaa'
|
|
&,'abcibaba',et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln,irest,icurrent,ets,qscale,tscaleb,
|
|
&tscalea,epba,epaa,verb)
|
|
|
|
else ! scftype.eq.'rohf'.or.qro.eq.'on'.or.dft.ne.'off'
|
|
call tabbrohf(nbe,nal,nvbe,nval,tb1,ta1,ta2,tm2,fb,fa,scr,
|
|
&'aijkaa','aijkba','aijkab','abijaa','abijba','abcibaab','abciaaaa'
|
|
&,'abcibaba',et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln,irest,icurrent,ets,qscale,tscaleb,
|
|
&tscalea,epba,epaa,verb)
|
|
|
|
endif ! uhf
|
|
|
|
else
|
|
icurrent=icurrent+nbe*nal*(nal-1)/2
|
|
endif !nval>1,nvbe>0
|
|
endif !local
|
|
ets=ets/3.d0
|
|
c
|
|
write(iout,"(i4,'% done.')") 100
|
|
|
|
c {{{ Deleting files
|
|
open(16,file='aijkaa')
|
|
close(16,status='delete')
|
|
open(16,file='aijkbb')
|
|
close(16,status='delete')
|
|
open(16,file='aijkab')
|
|
close(16,status='delete')
|
|
open(16,file='aijkba')
|
|
close(16,status='delete')
|
|
open(16,file='abijaa')
|
|
close(16,status='delete')
|
|
open(16,file='abijbb')
|
|
close(16,status='delete')
|
|
open(16,file='abijba')
|
|
close(16,status='delete')
|
|
open(16,file='abciaaaa')
|
|
close(16,status='delete')
|
|
open(16,file='abcibbbb')
|
|
close(16,status='delete')
|
|
open(16,file='abcibaab')
|
|
close(16,status='delete')
|
|
open(16,file='abciabba')
|
|
close(16,status='delete')
|
|
open(16,file='abcibaba')
|
|
close(16,status='delete')
|
|
c }}}
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine taaauhf(nal,nbe,nval,nvbe,ta1,tb1,ta2,tb2,fa,fb,scr,
|
|
&aijkaa,abijaa,abciaaaa,et,maxcor,imem,imem1,iout,error,pr,
|
|
&total,prold,ibufln,irecln,irest,icurrent,ets,qscale,tscalea,epaa)
|
|
************************************************************************
|
|
#include "uccsd_taaa_beg.f"
|
|
|
|
c W(a,a,a)
|
|
c UHF
|
|
scr(iw+abc)=scr(it+abc)+scr(ivvoo+(jk-1)*ef+bc)*ta1(a,i)
|
|
&-scr(ivvoo+(ik-1)*ef+bc)*ta1(a,j)
|
|
&+scr(ivvoo+(ij-1)*ef+bc)*ta1(a,k)
|
|
&-scr(ivvoo+(jk-1)*ef+ac)*ta1(b,i)
|
|
&+scr(ivvoo+(ik-1)*ef+ac)*ta1(b,j)
|
|
&-scr(ivvoo+(ij-1)*ef+ac)*ta1(b,k)
|
|
&+scr(ivvoo+(jk-1)*ef+ab)*ta1(c,i)
|
|
&-scr(ivvoo+(ik-1)*ef+ab)*ta1(c,j)
|
|
&+scr(ivvoo+(ij-1)*ef+ab)*ta1(c,k)
|
|
|
|
#include "uccsd_taaa_end.f"
|
|
|
|
************************************************************************
|
|
subroutine taaarohf(nal,nbe,nval,nvbe,ta1,tb1,ta2,tb2,fa,fb,scr,
|
|
&aijkaa,abijaa,abciaaaa,et,maxcor,imem,imem1,iout,error,pr,
|
|
&total,prold,ibufln,irecln,irest,icurrent,ets,qscale,tscalea,epaa)
|
|
************************************************************************
|
|
#include "uccsd_taaa_beg.f"
|
|
|
|
c W(a,a,a)
|
|
c ROHF
|
|
scr(iw+abc)=scr(it+abc)+scr(ivvoo+(jk-1)*ef+bc)*ta1(a,i)
|
|
&-scr(ivvoo+(ik-1)*ef+bc)*ta1(a,j)
|
|
&+scr(ivvoo+(ij-1)*ef+bc)*ta1(a,k)
|
|
&-scr(ivvoo+(jk-1)*ef+ac)*ta1(b,i)
|
|
&+scr(ivvoo+(ik-1)*ef+ac)*ta1(b,j)
|
|
&-scr(ivvoo+(ij-1)*ef+ac)*ta1(b,k)
|
|
&+scr(ivvoo+(jk-1)*ef+ab)*ta1(c,i)
|
|
&-scr(ivvoo+(ik-1)*ef+ab)*ta1(c,j)
|
|
&+scr(ivvoo+(ij-1)*ef+ab)*ta1(c,k)
|
|
&+ta2(bc,jk)*fa(a+nal,i)
|
|
&-ta2(bc,ik)*fa(a+nal,j)
|
|
&+ta2(bc,ij)*fa(a+nal,k)
|
|
&-ta2(ac,jk)*fa(b+nal,i)
|
|
&+ta2(ac,ik)*fa(b+nal,j)
|
|
&-ta2(ac,ij)*fa(b+nal,k)
|
|
&+ta2(ab,jk)*fa(c+nal,i)
|
|
&-ta2(ab,ik)*fa(c+nal,j)
|
|
&+ta2(ab,ij)*fa(c+nal,k)
|
|
|
|
#include "uccsd_taaa_end.f"
|
|
|
|
************************************************************************
|
|
subroutine tabbuhf(nal,nbe,nval,nvbe,ta1,tb1,tb2,tm2,fa,fb,scr,
|
|
&aijkbb,aijkab,aijkba,abijbb,abijab,abciabba,abcibbbb,abciabab,
|
|
&et,maxcor,imem,imem1,iout,error,pr,total,prold,ibufln,irecln,
|
|
&irest,icurrent,ets,qscale,tscalea,tscaleb,epab,epbb,verb)
|
|
************************************************************************
|
|
|
|
#include "uccsd_tabb_beg.f"
|
|
|
|
c W(a,b,b)
|
|
c UHF
|
|
scr(iw+abc)=scr(it+abc)
|
|
&+scr(ivvoo+(jk-1)*nvbe*(nvbe-1)/2+bc)*ta1(a,i)
|
|
&+scr(ivvooab+(ik-1)*nval*nvbe+ac)*tb1(b,j)
|
|
&-scr(ivvooab+(ij-1)*nval*nvbe+ac)*tb1(b,k)
|
|
&-scr(ivvooab+(ik-1)*nval*nvbe+ab)*tb1(c,j)
|
|
&+scr(ivvooab+(ij-1)*nval*nvbe+ab)*tb1(c,k)
|
|
|
|
#include "uccsd_tabb_end.f"
|
|
|
|
************************************************************************
|
|
subroutine tabbrohf(nal,nbe,nval,nvbe,ta1,tb1,tb2,tm2,fa,fb,scr,
|
|
&aijkbb,aijkab,aijkba,abijbb,abijab,abciabba,abcibbbb,abciabab,
|
|
&et,maxcor,imem,imem1,iout,error,pr,total,prold,ibufln,irecln,
|
|
&irest,icurrent,ets,qscale,tscalea,tscaleb,epab,epbb,verb)
|
|
************************************************************************
|
|
|
|
#include "uccsd_tabb_beg.f"
|
|
|
|
c W(a,b,b)
|
|
c ROHF
|
|
scr(iw+abc)=scr(it+abc)
|
|
&+scr(ivvoo+(jk-1)*nvbe*(nvbe-1)/2+bc)*ta1(a,i)
|
|
&+scr(ivvooab+(ik-1)*nval*nvbe+ac)*tb1(b,j)
|
|
&-scr(ivvooab+(ij-1)*nval*nvbe+ac)*tb1(b,k)
|
|
&-scr(ivvooab+(ik-1)*nval*nvbe+ab)*tb1(c,j)
|
|
&+scr(ivvooab+(ij-1)*nval*nvbe+ab)*tb1(c,k)
|
|
|
|
&+tb2(bc,jk)*fa(a+nal,i)
|
|
&+tm2(ac,ik)*fb(b+nbe,j)
|
|
&-tm2(ac,ij)*fb(b+nbe,k)
|
|
&-tm2(ab,ik)*fb(c+nbe,j)
|
|
&+tm2(ab,ij)*fb(c+nbe,k)
|
|
|
|
#include "uccsd_tabb_end.f"
|
|
|
|
************************************************************************
|
|
subroutine loccimtaaa(nal,nbe,nval,nvbe,ta1,tb1,ta2,tb2,fa,fb,
|
|
&t2list1,t2list2,ts,w,t,
|
|
&vooo,vvoo,t3,w3,t3u,w3u,ui,scr,
|
|
&aijkaa,abijaa,abciaaaa,et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln)
|
|
************************************************************************
|
|
|
|
implicit none
|
|
|
|
integer nal,nbe,nval,nvbe,imem,maxcor,imem1,iout,i,j,k,a,b,c,abc
|
|
integer iabci,recln,kmax,ii,jj,dimt3u,ibufln,irecln,recperocc
|
|
integer kmin,jk,ij,ni,ef,ik,ac,ab,bc,pr,prold,total
|
|
|
|
real*8 scr(*),tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),ta1(nval,nal)
|
|
real*8 tb1(nvbe,nbe),ddot,et,fa(nal+nval,nal+nval)
|
|
real*8 fb(nbe+nvbe,nbe+nvbe),t2list1(nval**2,nal*(nal-1)/2)
|
|
real*8 t2list2(nval*(nval-1)/2,nal**2),ts(nval,nval*(nval-1)/2)
|
|
real*8 w(nval*(nval-1)*(nval-2)/6),t(nval*(nval-1)*(nval-2)/6)
|
|
real*8 vooo(nval,nal,nal*(nal-1)/2),djk,dik
|
|
real*8 vvoo(nval*(nval-1)/2,nal*(nal-1)/2),ui(nal)
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2)
|
|
real*8 t3u(nval*(nval-1)*(nval-2)*nal*(nal-1)/12)
|
|
real*8 w3u(nval*(nval-1)*(nval-2)*nal*(nal-1)/12)
|
|
real*8,pointer::abci(:,:)
|
|
real*8 t3(nval*(nval-1)*(nval-2)/6,nal*(nal-1)/2,nal)
|
|
real*8 w3(nval*(nval-1)*(nval-2)/6,nal*(nal-1)/2,nal),cmo(nal,nal)
|
|
c real*8 fullt3(nval*(nval-1)*(nval-2)/6,nal,nal,nal)
|
|
c real*8 tcmo1(nval*(nval-1)*(nval-2)/6,nal,nal,nal)
|
|
c real*8 tcmo2(nval*(nval-1)*(nval-2)/6,nal,nal,nal)
|
|
c real*8 fullt3u(nval*(nval-1)*(nval-2)/6,nal,nal,nal)
|
|
c real*8 t3trafozva(nval*(nval-1)*(nval-2)/6,nal,nal,nal)
|
|
|
|
logical error
|
|
|
|
character*6 aijkaa,abijaa
|
|
character*8 abciaaaa
|
|
|
|
c {{{ Interface for pointer
|
|
interface
|
|
subroutine rpoint2d(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
real*8,target :: egydim(dim1,dim2)
|
|
real*8, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
end interface
|
|
c }}}
|
|
|
|
recln=nval*nval*(nval-1)/2
|
|
dimt3u=nval*(nval-1)*(nval-2)*nal*(nal-1)/12
|
|
recperocc=recln/ibufln
|
|
if (mod(recln,ibufln).gt.0.) recperocc=recperocc+1
|
|
t3=0.d0
|
|
w3=0.d0
|
|
|
|
c Checking the allocated memory
|
|
if (3*recln.gt.maxcor-imem+imem1) then
|
|
|
|
write(*,*)
|
|
write(iout,*) 'Insufficient memory!'
|
|
write(iout,"(' Requested: ',f6.2,' GB')")
|
|
&dble((3*recln)*8)/dble(1024**3)
|
|
write(iout,"(' Available: ',f6.2,' GB')")
|
|
&dble((maxcor-imem+imem1)*8)/dble(1024**3)
|
|
write(*,*)
|
|
error=.true.
|
|
return
|
|
|
|
endif
|
|
|
|
call xxyyunb(ta2,nval,nval,nal,nal,t2list1)
|
|
call yyxxunb(ta2,nval,nval,nal,nal,t2list2)
|
|
|
|
open(16,file=aijkaa,form='unformatted')
|
|
read(16) vooo
|
|
close(16)
|
|
|
|
open(16,file=abijaa,form='unformatted')
|
|
read(16) vvoo
|
|
close(16)
|
|
|
|
open(16,file=abciaaaa,access='direct',recl=irecln)
|
|
|
|
kmax=0
|
|
kmin=0
|
|
|
|
c Loop for k
|
|
c debug
|
|
do k=1,nal
|
|
c do k=1,1
|
|
|
|
c Reading a vvvo block if necessary
|
|
if (k.gt.kmax) then
|
|
ni=(maxcor-imem+imem1)/recln
|
|
ni=ni-2
|
|
if (ni.gt.nal-kmax) ni=nal-kmax
|
|
call rpoint2d(scr,abci,recln,ni+2)
|
|
|
|
do i=1,ni
|
|
call getlst(16,(kmax+i-1)*recperocc+1,abci(1,i),recln)
|
|
c read(16,rec=kmax+i) abci(1:recln,i)
|
|
enddo
|
|
|
|
kmin=kmax+1
|
|
kmax=kmax+ni
|
|
endif
|
|
|
|
c Loop for j
|
|
c debug
|
|
do j=1,nal
|
|
c do j=4,4
|
|
|
|
if (j.ne.k) then
|
|
if (j.lt.k) then
|
|
jk=(k-1)*(k-2)/2+j
|
|
djk=1.d0
|
|
else
|
|
jk=(j-1)*(j-2)/2+k
|
|
djk=-1.d0
|
|
endif
|
|
|
|
c Checking if the record needed for j is in the memory
|
|
if (j.lt.kmin.or.j.gt.kmax) then
|
|
call getlst(16,(j-1)*recperocc+1,abci(1,ni+1),recln)
|
|
c read(16,rec=j) abci(1:recln,ni+1)
|
|
jj=ni+1
|
|
else
|
|
jj=j-kmin+1
|
|
endif
|
|
|
|
c Loop for i
|
|
c debug
|
|
do i=1,j-1
|
|
c do i=2,2
|
|
|
|
if (i.ne.k) then
|
|
ij=(j-1)*(j-2)/2+i
|
|
if (i.lt.k) then
|
|
ik=(k-1)*(k-2)/2+i
|
|
dik=1.d0
|
|
else
|
|
ik=(i-1)*(i-2)/2+k
|
|
dik=-1.d0
|
|
endif
|
|
|
|
c Checking if the record needed for i is in the memory
|
|
if (i.lt.kmin.or.i.gt.kmax) then
|
|
call getlst(16,(i-1)*recperocc+1,abci(1,ni+2),recln)
|
|
c read(16,rec=i) abci(1:recln,ni+2)
|
|
ii=ni+2
|
|
else
|
|
ii=i-kmin+1
|
|
endif
|
|
|
|
c Building T,W
|
|
call taaabuildcim(nal,nval,i,j,k,ta1,ta2,t2list1,t2list2,
|
|
&vooo,abci(1,ii),abci(1,jj),abci(1,k-kmin+1),vvoo,fa,djk,dik,ij,ik,
|
|
&jk,t,ts,w)
|
|
|
|
c Placing T and W in their arrays
|
|
t3(1:nval*(nval-1)*(nval-2)/6,ij,k)=t
|
|
w3(1:nval*(nval-1)*(nval-2)/6,ij,k)=w
|
|
|
|
endif !i.ne.k
|
|
enddo
|
|
endif !j.ne.k
|
|
enddo
|
|
|
|
c Monitoring percentage
|
|
pr=pr+nal*(nal-1)/2
|
|
if (dble(pr).ge.dble(prold)+0.25d0*dble(total).and.pr.ne.total)
|
|
&then
|
|
write(iout,"(i4,'% done.')") int(100.d0*dble(pr)/dble(total))
|
|
prold=pr
|
|
endif
|
|
|
|
enddo
|
|
close(16)
|
|
|
|
c Generating full t3 (local debugging)
|
|
c call t3extract(w3,nval*(nval-1)*(nval-2)/6,nal*(nal-1)/2,nal,
|
|
c &fullt3) !local debugging routine
|
|
c write(*,*) 't3'
|
|
c write(*,*) t3
|
|
|
|
c Reading CMO
|
|
c open(111,file='laplbas',form='unformatted')
|
|
c read(111) cmo
|
|
c close(111)
|
|
c cmo=0.d0
|
|
c do i=1,nal
|
|
c cmo(i,i)=1.d0
|
|
c enddo
|
|
|
|
c transforming i index
|
|
c do k=1,nal
|
|
c do j=1,nal
|
|
c call dgemm('n','n',nval*(nval-1)*(nval-2)/6,nal,nal,1.d0,
|
|
c &fullt3(1,1,j,k),nval*(nval-1)*(nval-2)/6,cmo,nal,0.d0,
|
|
c &tcmo1(1,1,j,k),nval*(nval-1)*(nval-2)/6)
|
|
c enddo
|
|
c enddo
|
|
c write(*,*) 'tcmo1'
|
|
c write(*,*) tcmo1
|
|
|
|
c transforming j index
|
|
c do k=1,nal
|
|
c call dgemm('n','n',nval*(nval-1)*(nval-2)/6*nal,nal,nal,1.d0,
|
|
c &tcmo1(1,1,1,k),nval*(nval-1)*(nval-2)/6*nal,cmo,nal,0.d0,
|
|
c &tcmo2(1,1,1,k),
|
|
c &nval*(nval-1)*(nval-2)/6*nal)
|
|
c enddo
|
|
c write(*,*) 'tcmo2'
|
|
c write(*,*) tcmo2
|
|
|
|
c transforming k index
|
|
c call dgemm('n','n',nval*(nval-1)*(nval-2)/6*nal**2,nal,nal,1.d0,
|
|
c &tcmo2,nval*(nval-1)*(nval-2)/6*nal**2,cmo,nal,0.d0,fullt3u,
|
|
c &nval*(nval-1)*(nval-2)/6*nal**2)
|
|
c writing fullt3u
|
|
c do k=1,nal
|
|
c do j=1,nal
|
|
c if (j.ne.k) then
|
|
c do i=1,j-1
|
|
c if (i.ne.k) then
|
|
c write(6,"(56es20.10,3i3)")
|
|
c &fullt3u(1:nval*(nval-1)*(nval-2)/6,i,j,k),i,j,k
|
|
c endif
|
|
c enddo
|
|
c endif
|
|
c enddo
|
|
c enddo
|
|
|
|
c do k=1,nal
|
|
c do j=1,nal
|
|
c do i=1,j-1
|
|
c write(*,*) fullt3u(1:nval*(nval-1)*(nval-2)/6,ij,k)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
c open(66,file='t3trafozva',form='unformatted')
|
|
c write(66) fullt3u
|
|
c close(66)
|
|
cc Generating full t3 (local debugging)
|
|
c call t3extract(w3,nval*(nval-1)*(nval-2)/6,nal*(nal-1)/2,nal,
|
|
c &fullt3) !local debugging routine
|
|
cc write(*,*) 't3'
|
|
cc write(*,*) t3
|
|
c
|
|
cc Reading CMO
|
|
c open(111,file='laplbas',form='unformatted')
|
|
c read(111) cmo
|
|
c close(111)
|
|
cc cmo=0.d0
|
|
cc do i=1,nal
|
|
cc cmo(i,i)=1.d0
|
|
cc enddo
|
|
c
|
|
cc transforming i index
|
|
c do k=1,nal
|
|
c do j=1,nal
|
|
c call dgemm('n','n',nval*(nval-1)*(nval-2)/6,nal,nal,1.d0,
|
|
c &fullt3(1,1,j,k),nval*(nval-1)*(nval-2)/6,cmo,nal,0.d0,
|
|
c &tcmo1(1,1,j,k),nval*(nval-1)*(nval-2)/6)
|
|
c enddo
|
|
c enddo
|
|
cc write(*,*) 'tcmo1'
|
|
cc write(*,*) tcmo1
|
|
c
|
|
cc transforming j index
|
|
c do k=1,nal
|
|
c call dgemm('n','n',nval*(nval-1)*(nval-2)/6*nal,nal,nal,1.d0,
|
|
c &tcmo1(1,1,1,k),nval*(nval-1)*(nval-2)/6*nal,cmo,nal,0.d0,
|
|
c &tcmo2(1,1,1,k),
|
|
c &nval*(nval-1)*(nval-2)/6*nal)
|
|
c enddo
|
|
cc write(*,*) 'tcmo2'
|
|
cc write(*,*) tcmo2
|
|
c
|
|
cc transforming k index
|
|
c call dgemm('n','n',nval*(nval-1)*(nval-2)/6*nal**2,nal,nal,1.d0,
|
|
c &tcmo2,nval*(nval-1)*(nval-2)/6*nal**2,cmo,nal,0.d0,fullt3u,
|
|
c &nval*(nval-1)*(nval-2)/6*nal**2)
|
|
c open(66,file='t3trafozva',form='unformatted')
|
|
c read(66) t3trafozva
|
|
c close(66,status='delete')
|
|
c write(*,*) 'cimes energia: ',(1.d0/6.d0)*
|
|
c &ddot(nal**2*nval*(nval-1)*(nval-2)/6,fullt3u,1,t3trafozva,1)
|
|
c call dgemv('n',nval*(nval-1)*(nval-2)/6*nal**2,nal,1.d0,tcmo2,
|
|
c &nval*(nval-1)*(nval-2)/6*nal**2,ui,1,0.d0,fullt3u,1)
|
|
|
|
|
|
|
|
c Calculating the energy contribution
|
|
c t3*u
|
|
call dgemv('n',dimt3u,nal,1.d0,t3,dimt3u,ui,1,0.d0,t3u,1)
|
|
|
|
c w3*u
|
|
call dgemv('n',dimt3u,nal,1.d0,w3,dimt3u,ui,1,0.d0,w3u,1)
|
|
|
|
c t3u*w3u
|
|
et=et+(1.d0/3.d0)*ddot(dimt3u,t3u,1,w3u,1)
|
|
|
|
c write(*,*) 'CIM ENERGY:',et
|
|
c call prtenergc('CCSD(T) ',et)
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine loclapltaaa(nal,nbe,nval,nvbe,q,nquad,dfnbasis,ta1,ta2,
|
|
&fa,cmo,quad,vooo,abjk,abij,
|
|
&ts,w,t,t2jkad,t2ikad,t2ijad,t2kbcl,
|
|
&t2jbcl,t2ibcl,jab,jai,
|
|
&scr,
|
|
&dfint_ij,et,maxcor,imem,
|
|
&imem1,iout,error,
|
|
&pr,total,prold,ldofquad,inmemory,irest,icurrent,ied,first_quad)
|
|
************************************************************************
|
|
|
|
implicit none
|
|
|
|
integer nal,nbe,nval,nvbe,imem,maxcor,imem1,iout,i,j,a,b,c,abc
|
|
integer iabci,recln,kmax,ii,jj,nquad,dfnbasis,q,ipuff
|
|
integer kmin,jk,ij,ni,ef,ik,ac,ab,bc,pr,prold,total,d,ad,l
|
|
integer ldofquad,irest,icurrent,ied,first_quad
|
|
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),ta1(nval,nal)
|
|
real*8 fa(nal+nval,nal+nval),cmo(nal,nal),t2ijad(nval,nval)
|
|
real*8 jab(dfnbasis,nval,nval),abij(nval,nval)
|
|
real*8 jai(dfnbasis,nval,nal),t2jkad(nval,nval),t2ikad(nval,nval)
|
|
real*8 ts(nval,nval*(nval-1)/2),abjk(nval,nal,nval)
|
|
real*8 w(nval*(nval-1)*(nval-2)/6),t(nval*(nval-1)*(nval-2)/6)
|
|
real*8 vooo(nval,nal,nal*(nal-1)/2),quad(ldofquad,nquad)
|
|
real*8 t2kbcl(nval*(nval-1)/2,nal),t2jbcl(nval*(nval-1)/2,nal)
|
|
real*8 ddot,et,t2ibcl(nval*(nval-1)/2,nal),scr(*)
|
|
real*8,pointer::abci(:,:)
|
|
|
|
logical error,inmemory(9)
|
|
|
|
character*9 dfint_ij
|
|
|
|
c debug
|
|
real*8 etdbg
|
|
|
|
c {{{ Interface for pointer
|
|
interface
|
|
subroutine rpoint2d(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
real*8,target :: egydim(dim1,dim2)
|
|
real*8, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
end interface
|
|
c }}}
|
|
|
|
c {{{ Checking the allocated memory
|
|
recln=nval*nval*(nval-1)/2
|
|
if (3*recln.gt.maxcor-imem+imem1-nval**3) then
|
|
|
|
write(*,*)
|
|
write(iout,*) 'Insufficient memory!'
|
|
write(iout,"(' Requested: ',f6.2,' GB')")
|
|
&dble((4*recln)*8)/1024**3
|
|
write(iout,"(' Available: ',f6.2,' GB')")
|
|
&dble((maxcor-imem+imem1)*8)/1024**3
|
|
write(*,*)
|
|
error=.true.
|
|
return
|
|
|
|
endif
|
|
c }}}
|
|
|
|
call trf2laplbasisaaa(nal,nval,dfnbasis,q,nquad,cmo,fa,ta1,ta2,
|
|
&jab,jai,vooo,quad,scr,dfint_ij,imem,
|
|
&imem1,maxcor,iout,ldofquad,inmemory,error,first_quad)
|
|
|
|
c Building (aj|bk)-(bj|ak)
|
|
call dgemm('t','n',nval*nal,nval,dfnbasis,1.d0,jai,dfnbasis,
|
|
&jai(1,1,1),dfnbasis,0.d0,abjk,nval*nal)
|
|
do b=1,nval
|
|
do j=1,nal
|
|
do a=1,b-1
|
|
abjk(a,j,b)=abjk(b,j,a)-abjk(a,j,b)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c Building abciaaaa
|
|
ni=(maxcor-imem+imem1-nval**3)/recln
|
|
if (ni.gt.nal) then
|
|
ni=nal
|
|
call rpoint2d(scr,abci,recln,ni+1)
|
|
ipuff=ni+1
|
|
else
|
|
ni=ni-3
|
|
call rpoint2d(scr,abci,recln,ni+3)
|
|
ipuff=ni+3
|
|
endif
|
|
|
|
c Assemble <ab||ci> for ni blocks
|
|
do i=1,ni
|
|
call dgemm('t','n',nval**2,nval,dfnbasis,1.d0,jab,dfnbasis,
|
|
&jai(1,1,i),dfnbasis,0.d0,abci(1,ipuff),nval**2)
|
|
abc=1
|
|
do c=1,nval
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
abci(abc,i)=abci((b-1)*nval**2+(c-1)*nval+a,ipuff)
|
|
&-abci((a-1)*nval**2+(c-1)*nval+b,ipuff)
|
|
abc=abc+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo !i
|
|
c Building t^k'_bcl'
|
|
t2kbcl(1:nval*(nval-1)/2,1)=0.d0
|
|
do l=2,nal
|
|
t2kbcl(1:nval*(nval-1)/2,l)=
|
|
&-ta2(1:nval*(nval-1)/2,(l-1)*(l-2)/2+1) !placing -tbckl instead of tbclk
|
|
enddo
|
|
|
|
c {{{ Loop for occupied indeces
|
|
do j=3,nal
|
|
|
|
jk=(j-1)*(j-2)/2+1
|
|
c Checking if the <ab||cj> record needed for j is in the memory
|
|
if (j.gt.ni) then
|
|
c If not then assemble <ab||cj>
|
|
call dgemm('t','n',nval**2,nval,dfnbasis,1.d0,jab,dfnbasis,
|
|
&jai(1,1,j),dfnbasis,0.d0,abci(1,ipuff),nval**2)
|
|
abc=1
|
|
do c=1,nval
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
abci(abc,ni+1)=abci((b-1)*nval**2+(c-1)*nval+a,ipuff)
|
|
&-abci((a-1)*nval**2+(c-1)*nval+b,ipuff)
|
|
abc=abc+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
jj=ni+1
|
|
else
|
|
jj=j
|
|
endif
|
|
c Building t^j'k'_ad
|
|
ad=1
|
|
do d=1,nval
|
|
t2jkad(d,d)=0.d0
|
|
do a=1,d-1
|
|
t2jkad(a,d)=ta2(ad,jk)/quad(nal+d,q)
|
|
t2jkad(d,a)=-ta2(ad,jk)/quad(nal+a,q)
|
|
ad=ad+1
|
|
enddo
|
|
enddo
|
|
c Building t^j'_bcl'
|
|
t2jbcl(1:nval*(nval-1)/2,j)=0.d0
|
|
do l=1,nal
|
|
if (l.gt.j) then
|
|
t2jbcl(1:nval*(nval-1)/2,l)=
|
|
&-ta2(1:nval*(nval-1)/2,(l-1)*(l-2)/2+j) !placing -tbcjl instead of tbclj
|
|
elseif (l.lt.j) then
|
|
t2jbcl(1:nval*(nval-1)/2,l)=
|
|
&ta2(1:nval*(nval-1)/2,(j-1)*(j-2)/2+l)
|
|
endif
|
|
enddo
|
|
|
|
do i=2,j-1
|
|
|
|
ij=(j-1)*(j-2)/2+i
|
|
ik=(i-1)*(i-2)/2+1
|
|
c Checking if the record needed for i is in the memory
|
|
if (i.gt.ni) then
|
|
c Assemble <ab||ci>
|
|
call dgemm('t','n',nval**2,nval,dfnbasis,1.d0,jab,dfnbasis,
|
|
&jai(1,1,i),dfnbasis,0.d0,abci(1,ipuff),nval**2)
|
|
abc=1
|
|
do c=1,nval
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
abci(abc,ni+2)=abci((b-1)*nval**2+(c-1)*nval+a,ipuff)
|
|
&-abci((a-1)*nval**2+(c-1)*nval+b,ipuff)
|
|
abc=abc+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ii=ni+2
|
|
else
|
|
ii=i
|
|
endif
|
|
c Building t^i'k'_ad
|
|
ad=1
|
|
do d=1,nval
|
|
t2ikad(d,d)=0.d0
|
|
do a=1,d-1
|
|
t2ikad(a,d)=ta2(ad,ik)/quad(nal+d,q)
|
|
t2ikad(d,a)=-ta2(ad,ik)/quad(nal+a,q)
|
|
ad=ad+1
|
|
enddo
|
|
enddo
|
|
ad=1
|
|
do d=1,nval
|
|
t2ijad(d,d)=0.d0
|
|
do a=1,d-1
|
|
t2ijad(a,d)=ta2(ad,ij)/quad(nal+d,q)
|
|
t2ijad(d,a)=-ta2(ad,ij)/quad(nal+a,q)
|
|
ad=ad+1
|
|
enddo
|
|
enddo
|
|
c Building t^i'_bcl'
|
|
t2ibcl(1:nval*(nval-1)/2,i)=0.d0
|
|
do l=1,nal
|
|
if (l.gt.i) then
|
|
t2ibcl(1:nval*(nval-1)/2,l)=
|
|
&-ta2(1:nval*(nval-1)/2,(l-1)*(l-2)/2+i) !placing -tbcil instead of tbcli
|
|
elseif (l.lt.i) then
|
|
t2ibcl(1:nval*(nval-1)/2,l)=
|
|
&ta2(1:nval*(nval-1)/2,(i-1)*(i-2)/2+l)
|
|
endif
|
|
enddo
|
|
c Building (ai|bj)-(bi|aj)
|
|
call dgemm('t','n',nval,nval,dfnbasis,1.d0,jai(1,1,i),dfnbasis,
|
|
&jai(1,1,j),dfnbasis,0.d0,abij,nval)
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
abij(a,b)=abij(a,b)-abij(b,a)
|
|
enddo
|
|
enddo
|
|
c }}}
|
|
|
|
icurrent = icurrent + 1
|
|
if (icurrent.le.irest) cycle
|
|
|
|
c Building T,W
|
|
call taaabuild(nal,nval,i,j,1,ta1,ta2,t2jkad,t2ikad,t2ijad,
|
|
&t2kbcl,t2jbcl,t2ibcl,
|
|
&vooo,abci(1,ii),abci(1,jj),abci(1,1),abjk,abij,fa,ij,ik,
|
|
&jk,t,ts,w)
|
|
|
|
c Calculating energy contribuiton
|
|
et=et-(1.d0/3.d0)*ddot(nval*(nval-1)*(nval-2)/6,t,1,w,1)
|
|
call managerestart('w','(t)2',-1,scr,scr,scr,et,scr,scr,scr,
|
|
& scr,scr,icurrent,0,0,0,0,scr,ied)
|
|
enddo !i
|
|
enddo !j
|
|
c Monitoring percentage
|
|
pr=icurrent
|
|
if (dble(pr).ge.dble(prold)+0.25d0*dble(total).and.pr.ne.total)
|
|
&then
|
|
write(iout,"(i4,'% done.')") int(100.d0*dble(pr)/dble(total))
|
|
prold=pr
|
|
endif
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine trf2laplbasisaaa(nal,nval,dfnbasis,q,nquad,
|
|
&cmo,fa,ta1,ta2,jab,jai,aijk,quad,scr,dfint_ij,imem,imem1,
|
|
&maxcor,iout,ldofquad,inmemory,error,first_quad)
|
|
************************************************************************
|
|
|
|
implicit none
|
|
integer nal,nval,dfnbasis,q,ilcmo,ijab,ijai,abdim,aidim,nquad
|
|
integer i,a,b,ab,p,imem,imem1,maxcor,iout,c,ac,bc,ijaiscr
|
|
integer ijdim,iaijk,ijij,iaijkscr,ijijscr,ijijscr2,ij,j,jk,k
|
|
integer iaibj,iabbuff1,iabbuff2,ita2scr,bpq,illcmo,ldofquad
|
|
integer first_quad
|
|
|
|
real*8 cmo(nal,nal),quad(ldofquad,nquad),scr(*),tmp
|
|
real*8 fa(nval+nal,nval+nal)
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),ta1(nval,nal)
|
|
real*8 jai(dfnbasis,nval,nal),s,lfa,lfb
|
|
real*8 jab(dfnbasis,nval,nval)
|
|
real*8 aijk(nval,nal,nal*(nal-1)/2)
|
|
real*8,pointer::lcmo(:,:),jaiscr(:,:,:)
|
|
real*8,pointer::jab2(:,:,:),abcipuff(:,:),abicscr(:,:,:,:)
|
|
real*8,pointer::abcscr(:,:,:)
|
|
real*8,pointer::jijscr(:,:,:),aijkscr(:,:,:,:)
|
|
real*8,pointer::aibj(:,:,:,:),jijscr2(:,:),invlcmo(:,:)
|
|
real*8,pointer::abbuff1(:,:),jij(:,:,:),llcmo(:,:)
|
|
real*8,pointer::abbuff2(:,:),ta2scr(:,:)
|
|
|
|
logical error,inmemory(9)
|
|
character*9 dfint_ij
|
|
character*4 t1file,aibjfile
|
|
|
|
c {{{ Interfaces for pointers
|
|
interface
|
|
subroutine rpoint2d(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
real*8,target :: egydim(dim1,dim2)
|
|
real*8, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
subroutine rpoint3d(egydim,haromdim,dim1,dim2,dim3)
|
|
implicit none
|
|
integer dim1,dim2,dim3
|
|
real*8,target :: egydim(dim1,dim2,dim3)
|
|
real*8, pointer :: haromdim(:,:,:)
|
|
end subroutine
|
|
subroutine rpoint4d(egydim,haromdim,dim1,dim2,dim3,dim4)
|
|
implicit none
|
|
integer dim1,dim2,dim3,dim4
|
|
real*8,target :: egydim(dim1,dim2,dim3,dim4)
|
|
real*8, pointer :: haromdim(:,:,:,:)
|
|
end subroutine
|
|
end interface
|
|
c }}}
|
|
|
|
c {{{ Integral assembly
|
|
abdim=nval*(nval+1)/2
|
|
aidim=nval*nal
|
|
ijdim=nal*(nal+1)/2
|
|
ilcmo=1
|
|
ijaiscr=ilcmo+nal**2
|
|
|
|
call rpoint2d(scr(ilcmo),lcmo,nal,nal)
|
|
|
|
c 1) Read Jai, transform occupied index, multiply with laplace factors, transpose
|
|
if (.not.inmemory(5)) then !Jai is not in memory
|
|
c Multiply UiI with laplace factors
|
|
if (q.eq.first_quad) then
|
|
do i=1,nal
|
|
lcmo(i,1:nal)=cmo(i,1:nal)*quad(i,q)
|
|
enddo
|
|
else !q.gt.first_quad
|
|
do i=1,nal
|
|
do j=1,nal
|
|
s=0.d0
|
|
do k=1,nal
|
|
s=s+cmo(k,i)*cmo(k,j)*quad(k,q)/quad(k,q-1)
|
|
enddo
|
|
lcmo(i,j)=s
|
|
enddo
|
|
enddo
|
|
endif ! q.eq.first_equad
|
|
call rpoint3d(scr(ijaiscr),jaiscr,dfnbasis,nval,nal)
|
|
do a=1,nval
|
|
lfa=quad(nal+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quad(nal+a,q-1)
|
|
jaiscr(1:dfnbasis,a,1:nal)=jai(1:dfnbasis,a,1:nal)*lfa
|
|
enddo
|
|
call dgemm('n','n',dfnbasis*nval,nal,nal,1.d0,jaiscr,
|
|
& dfnbasis*nval,lcmo,nal,0.d0,jai,dfnbasis*nval)
|
|
inmemory(5)=.true.
|
|
endif !Jai is not in memory
|
|
|
|
c 2) Read Jij, assemble <a,i||i<j>
|
|
ijij=ilcmo+nal**2
|
|
iaijkscr=ijij+dfnbasis*nal**2
|
|
ijijscr=ijij+dfnbasis*nal**2
|
|
ijijscr2=ijijscr+dfnbasis*nal**2
|
|
|
|
call rpoint3d(scr(ijij),jij,dfnbasis,nal,nal)
|
|
call rpoint3d(scr(ijijscr),jijscr,dfnbasis,nal,nal)
|
|
call rpoint2d(scr(ijijscr2),jijscr2,dfnbasis,ijdim)
|
|
call rpoint2d(scr(ijijscr2),invlcmo,nal,nal)
|
|
call rpoint4d(scr(iaijkscr),aijkscr,nval,nal,nal,nal)
|
|
|
|
if (.not.inmemory(6)) then
|
|
c Multiply cmo with UI,i for Jij
|
|
do i=1,nal
|
|
lcmo(i,1:nal)=cmo(i,1:nal)*quad(i,q)
|
|
enddo
|
|
open(16,file=trim(dfint_ij),form='unformatted')
|
|
read(16) jijscr2
|
|
close(16)
|
|
|
|
ij=1
|
|
do j=1,nal
|
|
do i=1,j
|
|
jij(1:dfnbasis,i,j)=jijscr2(1:dfnbasis,ij)
|
|
if (j.ne.i)
|
|
& jij(1:dfnbasis,j,i)=jijscr2(1:dfnbasis,ij)
|
|
ij=ij+1
|
|
enddo
|
|
enddo
|
|
|
|
call dgemm('n','n',dfnbasis*nal,nal,nal,1.d0,jij,dfnbasis*nal,
|
|
& lcmo,nal,0.d0,jijscr,dfnbasis*nal)
|
|
|
|
c Creating invlcmo
|
|
do i=1,nal
|
|
invlcmo(i,1:nal)=cmo(i,1:nal)/quad(i,q)
|
|
enddo
|
|
c Creating J^P_\tilde i \bar j
|
|
do j=1,nal
|
|
call dgemm('n','n',dfnbasis,nal,nal,1.d0,jijscr(1,1,j),dfnbasis,
|
|
& invlcmo,nal,0.d0,jij(1,1,j),dfnbasis)
|
|
enddo
|
|
|
|
call dgemm('t','n',aidim,nal**2,dfnbasis,1.d0,jai,dfnbasis,jij,
|
|
& dfnbasis,0.d0,aijkscr,aidim)
|
|
|
|
jk=1
|
|
do k=1,nal
|
|
do j=1,k-1
|
|
do i=1,nal
|
|
aijk(1:nval,i,jk)=aijkscr(1:nval,j,i,k)-aijkscr(1:nval,k,i,j)
|
|
enddo
|
|
jk=jk+1
|
|
enddo
|
|
enddo
|
|
inmemory(6)=.true.
|
|
endif !abijk is not in memory
|
|
|
|
c 3) Read Jab, multiply with laplace factors
|
|
if (.not.inmemory(4)) then !Jab is not in memory
|
|
do a=1,nval
|
|
lfa=quad(nal+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quad(nal+a,q-1)
|
|
jab(1:dfnbasis,a,1:nval)=jab(1:dfnbasis,a,1:nval)*lfa
|
|
enddo
|
|
inmemory(4)=.true.
|
|
endif !Jab is not in memory
|
|
c }}}
|
|
|
|
iabbuff1=ilcmo+nal**2
|
|
iabbuff2=iabbuff1+nal**2
|
|
ita2scr=iabbuff2+nal**2
|
|
call rpoint2d(scr(iabbuff1),abbuff1,nal,nal)
|
|
call rpoint2d(scr(iabbuff2),abbuff2,nal,nal)
|
|
call rpoint2d(scr(ita2scr),ta2scr,nval*(nval-1)/2,nal*(nal-1)/2)
|
|
|
|
if (q.gt.first_quad) then
|
|
do i=1,nal
|
|
do j=1,nal
|
|
s=0.d0
|
|
do k=1,nal
|
|
s=s+cmo(k,i)*cmo(k,j)*quad(k,q)/quad(k,q-1)
|
|
enddo
|
|
lcmo(i,j)=s
|
|
enddo
|
|
enddo
|
|
else !q.eq.first_quad
|
|
do i=1,nal
|
|
lcmo(i,1:nal)=cmo(i,1:nal)*quad(i,q)
|
|
enddo
|
|
endif ! q.gt.first_quad
|
|
c Transfrom all indeces of ta2 to Laplace basis
|
|
if (.not.inmemory(3)) then !ta2 is not in memory
|
|
ab=1
|
|
do b=1,nval
|
|
lfb=quad(nal+b,q)
|
|
if (q.gt.first_quad) lfb=lfb/quad(nal+b,q-1)
|
|
do a=1,b-1
|
|
lfa=quad(nal+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quad(nal+a,q-1)
|
|
|
|
c 6.1) Transform one occupied index
|
|
call yyxxunbtr(ta2,nval,nal,ab,abbuff1)
|
|
call dgemm('n','n',nal,nal,nal,1.d0,abbuff1,nal,lcmo,nal,0.d0,
|
|
& abbuff2,nal)
|
|
c 6.3) Transform other occupied index
|
|
call dgemm('t','n',nal,nal,nal,lfa*lfb,lcmo,nal,abbuff2,nal,
|
|
& 0.d0,abbuff1,nal)
|
|
|
|
c 6.5) Place ta2
|
|
ij=1
|
|
do j=1,nal
|
|
do i=1,j-1
|
|
ta2(ab,ij)=abbuff1(i,j)
|
|
ij=ij+1
|
|
enddo
|
|
enddo
|
|
ab=ab+1
|
|
enddo
|
|
enddo
|
|
inmemory(3)=.true.
|
|
endif !ta2 is not in memory
|
|
c ta1
|
|
if (.not.inmemory(2)) then !ta1 is not in memory
|
|
call rpoint2d(scr(iabbuff1),abbuff1,nval,nal)
|
|
do a=1,nval
|
|
lfa=quad(nal+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quad(nal+a,q-1)
|
|
abbuff1(a,1:nal)=ta1(a,1:nal)*lfa
|
|
enddo
|
|
call dgemm('n','n',nval,nal,nal,1.d0,abbuff1,nval,lcmo,nal,0.d0,
|
|
& ta1,nval)
|
|
inmemory(2)=.true.
|
|
endif !ta1 is not in memory
|
|
c Fa
|
|
if (.not.inmemory(1)) then !Fa is not in memory
|
|
do a=1,nval
|
|
lfa=quad(nal+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quad(nal+a,q-1)
|
|
abbuff1(a,1:nal)=fa(nal+a,1:nal)*lfa
|
|
enddo
|
|
call dgemm('n','n',nval,nal,nal,1.d0,abbuff1,nval,lcmo,nal,0.d0,
|
|
& fa(nal+1,1),nval+nal)
|
|
inmemory(1)=.true.
|
|
endif !Fa is not in memory
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine taaabuild(nal,nval,i,j,k,ta1,ta2,t2jkad,t2ikad,t2ijad,
|
|
&t2kbcl,t2jbcl,t2ibcl,
|
|
&aijk,abci,abcj,abck,abjk,abij,fa,ij,ik,jk,t3,ts3,w3)
|
|
|
|
implicit none
|
|
|
|
integer nal,nval,i,j,k,ij,ik,jk,ef,a,b,c,ac,ab,abc,bc
|
|
real*8 ta1(nval,nal),ta2(nval*(nval-1)/2,nal*(nal-1)/2)
|
|
real*8 t2ikad(nval,nval),abij(nval,nval)
|
|
real*8 t2jkad(nval,nval),abjk(nval,nal,nval)
|
|
real*8 aijk(nval,nal,nal*(nal-1)/2),abci(nval*(nval-1)/2,nval)
|
|
real*8 abcj(nval*(nval-1)/2,nval),abck(nval*(nval-1)/2,nval)
|
|
real*8 t2ijad(nval,nval)
|
|
real*8 t3(nval*(nval-1)*(nval-2)/6),ts3(nval,nval*(nval-1)/2)
|
|
real*8 w3(nval*(nval-1)*(nval-2)/6),fa(nal+nval,nal+nval)
|
|
real*8 t2kbcl(nval*(nval-1)/2,nal),t2jbcl(nval*(nval-1)/2,nal)
|
|
real*8 t2ibcl(nval*(nval-1)/2,nal)
|
|
|
|
ef=nval*(nval-1)/2
|
|
|
|
call dgemm('n','t',nval,ef,nval,-1.d0,
|
|
&t2jkad,nval,abci,ef,0.d0,ts3,nval)
|
|
call dgemm('n','t',nval,ef,nval,1.d0,
|
|
&t2ikad,nval,abcj,ef,1.d0,ts3,nval)
|
|
call dgemm('n','t',nval,ef,nval,1.d0,
|
|
&t2ijad,nval,abck,ef,1.d0,ts3,nval)
|
|
|
|
c voooa
|
|
call dgemm('n','t',nval,ef,nal,1.d0,
|
|
&aijk(1,1,jk),nval,t2ibcl,ef,1.d0,ts3,nval)
|
|
call dgemm('n','t',nval,ef,nal,-1.d0,
|
|
&aijk(1,1,ik),nval,t2jbcl,ef,1.d0,ts3,nval)
|
|
call dgemm('n','t',nval,ef,nal,-1.d0,
|
|
&aijk(1,1,ij),nval,t2kbcl,ef,1.d0,ts3,nval)
|
|
|
|
c Antisymmetrizing and building Waaa
|
|
|
|
C$OMP PARALLEL DO Schedule(Dynamic) Default(Shared)
|
|
C$OMP& PRIVATE(abc,a,b,c,ac,ab,bc)
|
|
do c=1,nval
|
|
do b=1,c-1
|
|
bc=(c-1)*(c-2)/2+b
|
|
do a=1,b-1
|
|
ac=(c-1)*(c-2)/2+a
|
|
ab=(b-1)*(b-2)/2+a
|
|
abc=(c-1)*(c-2)*(c-3)/6+(b-1)*(b-2)/2+a
|
|
c T(a,a,a)
|
|
t3(abc)=ts3(a,bc)-ts3(b,ac)+ts3(c,ab)
|
|
c W(a,a,a)
|
|
c ROHF
|
|
w3(abc)=t3(abc)-abjk(b,j,c)*ta1(a,i)
|
|
& +abjk(b,i,c)*ta1(a,j)
|
|
& +abij(b,c)*ta1(a,k)
|
|
& +abjk(a,j,c)*ta1(b,i)
|
|
& -abjk(a,i,c)*ta1(b,j)
|
|
& -abij(a,c)*ta1(b,k)
|
|
& -abjk(a,j,b)*ta1(c,i)
|
|
& +abjk(a,i,b)*ta1(c,j)
|
|
& +abij(a,b)*ta1(c,k)
|
|
&
|
|
& -ta2(bc,jk)*fa(nal+a,i)
|
|
& +ta2(bc,ik)*fa(nal+a,j)
|
|
& +ta2(bc,ij)*fa(nal+a,k)
|
|
& +ta2(ac,jk)*fa(nal+b,i)
|
|
& -ta2(ac,ik)*fa(nal+b,j)
|
|
& -ta2(ac,ij)*fa(nal+b,k)
|
|
& -ta2(ab,jk)*fa(nal+c,i)
|
|
& +ta2(ab,ik)*fa(nal+c,j)
|
|
& +ta2(ab,ij)*fa(nal+c,k)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
|
|
return
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine taaabuildcim(nal,nval,i,j,k,ta1,ta2,ta2list1,ta2list2,
|
|
&aijk,abci,abcj,abck,abij,fa,djk,dik,ij,ik,jk,t3,ts3,w3)
|
|
|
|
implicit none
|
|
|
|
integer nal,nval,i,j,k,ij,ik,jk,ef,a,b,c,ac,ab,abc,bc
|
|
real*8 djk,dik,ta1(nval,nal),ta2(nval*(nval-1)/2,nal*(nal-1)/2)
|
|
real*8 ta2list1(nval,nval,nal*(nal-1)/2)
|
|
real*8 ta2list2(nval*(nval-1)/2,nal,nal)
|
|
real*8 aijk(nval,nal,nal*(nal-1)/2),abci(nval*(nval-1)/2,nval)
|
|
real*8 abcj(nval*(nval-1)/2,nval),abck(nval*(nval-1)/2,nval)
|
|
real*8 abij(nval*(nval-1)/2,nal*(nal-1)/2)
|
|
real*8 t3(nval*(nval-1)*(nval-2)/6),ts3(nval,nval*(nval-1)/2)
|
|
real*8 w3(nval*(nval-1)*(nval-2)/6),fa(nal+nval,nal+nval)
|
|
|
|
ef=nval*(nval-1)/2
|
|
|
|
call dgemm('n','t',nval,ef,nval,djk,
|
|
&ta2list1(1,1,jk),nval,abci,ef,0.d0,ts3,nval)
|
|
|
|
call dgemm('n','t',nval,ef,nval,-dik,
|
|
&ta2list1(1,1,ik),nval,abcj,ef,
|
|
&1.d0,ts3,nval)
|
|
c
|
|
call dgemm('n','t',nval,ef,nval,1.d0,
|
|
&ta2list1(1,1,ij),nval,abck,
|
|
&ef,1.d0,ts3,nval)
|
|
c
|
|
c voooa
|
|
call dgemm('n','t',nval,ef,nal,-djk,
|
|
&aijk(1,1,jk),nval,ta2list2(1,1,i),
|
|
&ef,1.d0,ts3,nval)
|
|
|
|
call dgemm('n','t',nval,ef,nal,dik,
|
|
&aijk(1,1,ik),nval,ta2list2(1,1,j),
|
|
&ef,1.d0,ts3,nval)
|
|
|
|
call dgemm('n','t',nval,ef,nal,-1.d0,
|
|
&aijk(1,1,ij),nval,ta2list2(1,1,k),
|
|
&ef,1.d0,ts3,nval)
|
|
|
|
c Antisymmetrizing and building Waaa
|
|
|
|
C$OMP PARALLEL DO Schedule(Dynamic) Default(Shared)
|
|
C$OMP& PRIVATE(abc,a,b,c,ac,ab,bc)
|
|
do c=1,nval
|
|
do b=1,c-1
|
|
bc=(c-1)*(c-2)/2+b
|
|
do a=1,b-1
|
|
ac=(c-1)*(c-2)/2+a
|
|
ab=(b-1)*(b-2)/2+a
|
|
abc=(c-1)*(c-2)*(c-3)/6+(b-1)*(b-2)/2+a
|
|
|
|
c T(a,a,a)
|
|
t3(abc)=ts3(a,bc)-ts3(b,ac)+ts3(c,ab)
|
|
|
|
c W(a,a,a)
|
|
c ROHF
|
|
w3(abc)=t3(abc)+djk*abij(bc,jk)*ta1(a,i)
|
|
c w3(abc)=djk*abij(bc,jk)*ta1(a,i)
|
|
& -dik*abij(bc,ik)*ta1(a,j)
|
|
& +abij(bc,ij)*ta1(a,k)
|
|
& -djk*abij(ac,jk)*ta1(b,i)
|
|
& +dik*abij(ac,ik)*ta1(b,j)
|
|
& -abij(ac,ij)*ta1(b,k)
|
|
& +djk*abij(ab,jk)*ta1(c,i)
|
|
& -dik*abij(ab,ik)*ta1(c,j)
|
|
& +abij(ab,ij)*ta1(c,k)
|
|
&
|
|
& +djk*ta2(bc,jk)*fa(a+nal,i)
|
|
& -dik*ta2(bc,ik)*fa(a+nal,j)
|
|
& +ta2(bc,ij)*fa(a+nal,k)
|
|
& -djk*ta2(ac,jk)*fa(b+nal,i)
|
|
& +dik*ta2(ac,ik)*fa(b+nal,j)
|
|
& -ta2(ac,ij)*fa(b+nal,k)
|
|
& +djk*ta2(ab,jk)*fa(c+nal,i)
|
|
& -dik*ta2(ab,ik)*fa(c+nal,j)
|
|
& +ta2(ab,ij)*fa(c+nal,k)
|
|
|
|
c debug t -> w
|
|
t3(abc)=t3(abc)/
|
|
&(fa(i,i)+fa(j,j)+fa(k,k)
|
|
&-fa(a+nal,a+nal)-fa(b+nal,b+nal)-fa(c+nal,c+nal))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
|
|
return
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine loccimtabb(nal,nbe,nval,nvbe,ta1,tb1,tb2,tm2,fa,fb,
|
|
&t2list1,t2list2,tm2list,ts,w,t,vooo,voooab,voooba,vvoo,vvooab,
|
|
&cmoa,cmob,abcii,scr,
|
|
&aijkbb,aijkab,aijkba,abijbb,abijab,abciabba,abcibbbb,abciabab,
|
|
&uia,uib,et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln)
|
|
************************************************************************
|
|
implicit none
|
|
|
|
integer it2list1,it2list2,itm2list,its,iw,it,ivooo,ivoooab,ivoooba
|
|
integer ivvoo,ivvooab,iabci,recln,reciln,maxcor,imem,imem1,nal,nbe
|
|
integer nval,nvbe,nk,ni,kmax,kmin,i,j,k,a,b,c,ab,bc,abc,ikab,ijba
|
|
integer ikbb,ijaa,jk,ik,ki,ij,ji,ac,iout,pr,prold,total,reclnm,jj
|
|
integer kk,ibufln,irecln,recperoccbb,recperoccab,recperoccba
|
|
|
|
real*8 scr(*),tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),ta1(nval,nal)
|
|
real*8 tb1(nvbe,nbe),ddot,et,fa(nal+nval,nal+nval),dnrm2
|
|
real*8 fb(nbe+nvbe,nbe+nvbe),uia(nal),uib(nbe)
|
|
real*8 tm2(nval*nvbe,nal*nbe),t2list1(nvbe,nvbe,nbe*(nbe-1)/2)
|
|
real*8 t2list2(nvbe*(nvbe-1)/2,nbe,nbe),tm2list(nval,nvbe,nbe,nal)
|
|
real*8 ts(nval,nvbe,nvbe),w(nval*nvbe*(nvbe-1)/2),cmob(nbe,nbe)
|
|
real*8 t(nval*nvbe*(nvbe-1)/2),voooab(nval,nbe,nal,nbe)
|
|
real*8 vooo(nvbe,nbe,nbe*(nbe-1)/2),voooba(nvbe,nal,nbe,nal)
|
|
real*8 vvoo(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),cmoa(nal,nal)
|
|
real*8 vvooab(nval,nvbe,nal,nbe),abcii(nval,nvbe,nvbe,nal)
|
|
c real*8 fullt3(nval*nvbe*(nvbe-1)/2,nbe,nbe,nal)
|
|
c real*8 fullt3buff(nval*nvbe*(nvbe-1)/2,nbe,nbe,nal)
|
|
c real*8 fullw3(nval*nvbe*(nvbe-1)/2,nbe,nbe,nal)
|
|
c real*8 fullw3buff(nval*nvbe*(nvbe-1)/2,nbe,nbe,nal)
|
|
real*8,pointer::abcibeta(:,:),abcimixed(:,:)
|
|
real*8,allocatable::t3(:,:,:),w3(:,:,:)
|
|
|
|
character*6 aijkbb,aijkab,aijkba,abijbb,abijab
|
|
character*8 abcibbbb,abciabab,abciabba
|
|
|
|
logical error
|
|
|
|
c {{{ Interfaces for pointers
|
|
interface
|
|
subroutine rpoint2d(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
real*8,target :: egydim(dim1,dim2)
|
|
real*8, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
end interface
|
|
c }}}
|
|
|
|
allocate(t3(nval*nvbe*(nvbe-1)/2,nbe*(nbe-1)/2,nal))
|
|
allocate(w3(nval*nvbe*(nvbe-1)/2,nbe*(nbe-1)/2,nal))
|
|
t3=0.d0
|
|
w3=0.d0
|
|
its=0
|
|
iw=its+nvbe**2*nval
|
|
iw=0
|
|
it=iw+nval*nvbe*(nvbe-1)/2
|
|
it=0
|
|
ivooo=it+nval*nvbe*(nvbe-1)/2
|
|
ivooo=0
|
|
ivoooab=ivooo+nvbe*nbe*nbe*(nbe-1)/2
|
|
ivoooba=ivoooab+nval*nbe*nal*nbe
|
|
ivoooba=0
|
|
ivvoo=ivoooba+nvbe*nal*nbe*nal
|
|
ivvoo=0
|
|
ivvooab=ivvoo+nvbe*(nvbe-1)*nbe*(nbe-1)/4
|
|
ivvooab=0
|
|
iabci=ivvooab+nval*nvbe*nal*nbe
|
|
iabci=1
|
|
recln=nvbe**2*nval
|
|
reclnm=nval**2*nvbe
|
|
recperoccba=recln/ibufln
|
|
if (mod(recln,ibufln).gt.0) recperoccba=recperoccba+1
|
|
recperoccab=reclnm/ibufln
|
|
if (mod(reclnm,ibufln).gt.0) recperoccab=recperoccab+1
|
|
|
|
c Checking the allocated memory
|
|
if (iabci+nvbe**2*(nvbe-1)/2+nval**2*nvbe+recln.gt.
|
|
&maxcor-imem+imem1) then
|
|
|
|
write(*,*)
|
|
write(iout,*) 'Insufficient memory!'
|
|
write(iout,"(' Requested: ',f6.2,' GB')")
|
|
&dble((iabci+nvbe**2*(nvbe-1)/2+nval**2*nvbe+recln)*8)/
|
|
&dble(1024**3)
|
|
write(iout,"(' Available: ',f6.2,' GB')")
|
|
&dble((maxcor-imem+imem1)*8)/dble(1024**3)
|
|
write(*,*)
|
|
error=.true.
|
|
return
|
|
|
|
endif
|
|
|
|
c call xxyyunb(tb2,nvbe,nvbe,nbe,nbe,scr(it2list1+1))
|
|
call xxyyunb(tb2,nvbe,nvbe,nbe,nbe,t2list1)
|
|
c call yyxxunb(tb2,nvbe,nvbe,nbe,nbe,scr(it2list2+1))
|
|
call yyxxunb(tb2,nvbe,nvbe,nbe,nbe,t2list2)
|
|
c call yzvxsw(tm2,nval,nvbe,nal,nbe,scr(itm2list+1))
|
|
call yzvxsw(tm2,nval,nvbe,nal,nbe,tm2list)
|
|
|
|
|
|
if (nbe.gt.1.and.nvbe.gt.0) then
|
|
open(16,file=aijkbb,form='unformatted')
|
|
read(16) vooo
|
|
close(16)
|
|
endif !nbe>1,nvbe>0
|
|
|
|
open(16,file=aijkab,form='unformatted')
|
|
read(16) voooab
|
|
close(16)
|
|
|
|
open(16,file=aijkba,form='unformatted')
|
|
read(16) voooba
|
|
close(16)
|
|
|
|
open(16,file=abijbb,form='unformatted')
|
|
read(16) vvoo
|
|
close(16)
|
|
|
|
open(16,file=abijab,form='unformatted')
|
|
read(16) vvooab
|
|
close(16)
|
|
c
|
|
nk=(maxcor-imem+imem1-recln)/
|
|
&(nvbe**2*(nvbe-1)/2+nval**2*nvbe)
|
|
if (nk.lt.nbe) nk=nk-2
|
|
if (nk.gt.nbe) nk=nbe
|
|
|
|
reciln=nvbe**2*(nvbe-1)/2
|
|
recperoccbb=reciln/ibufln
|
|
if (mod(reciln,ibufln).gt.0) recperoccbb=recperoccbb+1
|
|
if (nk.lt.nbe) then
|
|
|
|
ikbb=iabci+nk*(reciln+nval**2*nvbe)
|
|
ikab=ikbb+reciln
|
|
ijaa=ikab+nval**2*nvbe
|
|
ijba=ijaa+reciln
|
|
call rpoint2d(scr(iabci),abcibeta,reciln,nk+2)
|
|
call rpoint2d(scr(iabci+(nk+2)*reciln),abcimixed,reclnm,nk+2)
|
|
else
|
|
call rpoint2d(scr(iabci),abcibeta,reciln,nk)
|
|
call rpoint2d(scr(iabci+nk*reciln),abcimixed,reclnm,nk)
|
|
endif
|
|
|
|
open(16,file=abciabba,access='direct',recl=irecln)
|
|
open(17,file=abcibbbb,access='direct',recl=irecln)
|
|
open(20,file=abciabab,access='direct',recl=irecln)
|
|
|
|
|
|
do i=1,nk
|
|
c read(17,rec=i) scr(iabci+(i-1)*reciln+1:
|
|
c &iabci+i*reciln)
|
|
c read(17,rec=i) abcibeta(1:reciln,i)
|
|
call getlst(17,(i-1)*recperoccbb+1,abcibeta(1,i),reciln)
|
|
enddo
|
|
|
|
do i=1,nk
|
|
c read(20,rec=i) scr(iabci+nk*reciln+(i-1)*nval**2*nvbe+1:
|
|
c &iabci+nk*reciln+i*nval**2*nvbe)
|
|
c read(20,rec=i) abcimixed(1:reclnm,i)
|
|
call getlst(20,(i-1)*recperoccab+1,abcimixed(1,i),reclnm)
|
|
c write(*,*) 'abcimixed,i',i
|
|
c write(*,*) abcimixed(1:reclnm,i)
|
|
enddo
|
|
|
|
c temporary: read all of vVVo
|
|
do i=1,nal
|
|
c read(16,rec=i) abcii(1:nval,1:nvbe,1:nvbe,i)
|
|
call getlst(16,(i-1)*recperoccba+1,abcii(1,1,1,i),recln)
|
|
enddo
|
|
|
|
do i=1,nal
|
|
|
|
jk=0
|
|
do k=1,nbe
|
|
ik=(k-1)*nal+i
|
|
ki=(i-1)*nbe+k
|
|
kk=k
|
|
c Reading vvvob and vvvoab records for k
|
|
if (k.gt.nk) then
|
|
kk=nk+1
|
|
c read(17,rec=k) scr(ikbb+1:ikab)
|
|
c read(17,rec=k) abcibeta(1:reciln,kk)
|
|
call getlst(17,(k-1)*recperoccbb+1,abcibeta(1,kk),reciln)
|
|
c read(20,rec=k) abcimixed(1:reclnm,kk)
|
|
call getlst(20,(k-1)*recperoccab+1,abcimixed(1,kk),reclnm)
|
|
endif
|
|
|
|
do j=1,k-1
|
|
jk=jk+1
|
|
ij=(j-1)*nal+i
|
|
ji=(i-1)*nbe+j
|
|
jj=j
|
|
c Reading vvvoa and vvvoba records for i
|
|
c
|
|
if (j.gt.nk) then
|
|
jj=nk+2
|
|
c read(17,rec=j) scr(ijaa+1:ijba)
|
|
c read(20,rec=j) scr(ijba+1:ijba+nval**2*nvbe)
|
|
c read(17,rec=j) abcibeta(1:reciln,jj)
|
|
call getlst(17,(j-1)*recperoccbb+1,abcibeta(1,jj),reciln)
|
|
c read(20,rec=j) abcimixed(1:reclnm,jj)
|
|
call getlst(20,(j-1)*recperoccab+1,abcimixed(1,jj),reclnm)
|
|
endif
|
|
|
|
c Building T,W
|
|
call tabbbuildcim(nal,nbe,nval,nvbe,i,j,k,ij,ik,jk,fa,fb,
|
|
&ta1,tb1,
|
|
&tb2,tm2,
|
|
&t2list1,
|
|
&t2list2,tm2list,t,w,ts,abcii(1,1,1,i),abcibeta(1,jj),
|
|
&abcibeta(1,kk),abcimixed(1,jj),abcimixed(1,kk),vooo,voooab,voooba,
|
|
&vvoo,vvooab)
|
|
|
|
c placing t3,w3
|
|
t3(1:nvbe*(nvbe-1)*nval/2,jk,i)=t
|
|
w3(1:nvbe*(nvbe-1)*nval/2,jk,i)=w
|
|
|
|
enddo
|
|
enddo
|
|
c Monitoring percentage
|
|
pr=pr+nbe*(nbe-1)/2
|
|
if (dble(pr).ge.dble(prold)+0.25d0*dble(total).and.pr.ne.total)
|
|
&then
|
|
write(iout,"(i4,'% done.')") int(100.d0*dble(pr)/dble(total))
|
|
prold=pr
|
|
endif
|
|
enddo
|
|
close(16)
|
|
close(17)
|
|
close(20)
|
|
|
|
call dgemv('n',nval*nvbe*(nvbe-1)*nbe*(nbe-1)/4,nal,1.d0,t3,
|
|
&nval*nvbe*(nvbe-1)*nbe*(nbe-1)/4,uia,1,0.d0,scr(iabci+1),1)
|
|
|
|
call dgemv('n',nval*nvbe*(nvbe-1)*nbe*(nbe-1)/4,nal,1.d0,w3,
|
|
&nval*nvbe*(nvbe-1)*nbe*(nbe-1)/4,uia,1,0.d0,
|
|
&scr(iabci+nval*nvbe*(nvbe-1)*nbe*(nbe-1)/4+1),1)
|
|
|
|
et=et+(1.d0/3.d0)*
|
|
&ddot(nval*nvbe*(nvbe-1)*nbe*(nbe-1)/4,scr(iabci+1),1,
|
|
&scr(iabci+nval*nvbe*(nvbe-1)*nbe*(nbe-1)/4+1),1)
|
|
|
|
c write(*,*) 'CIMES ABB: ',et
|
|
c call prtenergc('CCSD(T) ',et)
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine loccimtbba(nal,nbe,nval,nvbe,ta1,tb1,tb2,tm2,fa,fb,
|
|
&t2list1,t2list2,tm2list,ts,w,t,vooo,voooab,voooba,vvoo,vvooab,
|
|
&cmoa,cmob,abcii,scr,
|
|
&aijkbb,aijkab,aijkba,abijbb,abijab,abciabba,abcibbbb,abciabab,
|
|
&uia,uib,et,maxcor,imem,imem1,iout,error,
|
|
&pr,total,prold,ibufln,irecln)
|
|
************************************************************************
|
|
implicit none
|
|
|
|
integer it2list1,it2list2,itm2list,its,iw,it,ivooo,ivoooab,ivoooba
|
|
integer ivvoo,ivvooab,iabci,recln,reciln,maxcor,imem,imem1,nal,nbe
|
|
integer nval,nvbe,nk,ni,kmax,kmin,i,j,k,a,b,c,ab,bc,abc,ikab,ijba
|
|
integer ikbb,ijaa,jk,ik,ki,ij,ji,ac,iout,pr,prold,total,reclnm,jj
|
|
integer kk,ibufln,irecln,recperoccbb,recperoccab,recperoccba
|
|
|
|
real*8 scr(*),tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),ta1(nval,nal)
|
|
real*8 tb1(nvbe,nbe),ddot,et,fa(nal+nval,nal+nval),dnrm2,djk
|
|
real*8 fb(nbe+nvbe,nbe+nvbe),uia(nal),uib(nbe)
|
|
real*8 tm2(nval*nvbe,nal*nbe),t2list1(nvbe,nvbe,nbe*(nbe-1)/2)
|
|
real*8 t2list2(nvbe*(nvbe-1)/2,nbe,nbe),tm2list(nval,nvbe,nbe,nal)
|
|
real*8 ts(nval,nvbe,nvbe),w(nval*nvbe*(nvbe-1)/2),cmob(nbe,nbe)
|
|
real*8 t(nval*nvbe*(nvbe-1)/2),voooab(nval,nbe,nal,nbe)
|
|
real*8 vooo(nvbe,nbe,nbe*(nbe-1)/2),voooba(nvbe,nal,nbe,nal)
|
|
real*8 vvoo(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),cmoa(nal,nal)
|
|
real*8 vvooab(nval,nvbe,nal,nbe),abcii(nval,nvbe,nvbe,nal)
|
|
c real*8 fullt3(nval*nvbe*(nvbe-1)/2,nbe,nbe,nal)
|
|
c real*8 fullt3buff(nval*nvbe*(nvbe-1)/2,nbe,nbe,nal)
|
|
c real*8 fullw3(nval*nvbe*(nvbe-1)/2,nbe,nbe,nal)
|
|
c real*8 fullw3buff(nval*nvbe*(nvbe-1)/2,nbe,nbe,nal)
|
|
real*8,pointer::abcibeta(:,:),abcimixed(:,:)
|
|
real*8,allocatable::t3(:,:,:,:),w3(:,:,:,:)
|
|
|
|
character*6 aijkbb,aijkab,aijkba,abijbb,abijab
|
|
character*8 abcibbbb,abciabab,abciabba
|
|
|
|
logical error
|
|
|
|
c {{{ Interfaces for pointers
|
|
interface
|
|
subroutine rpoint2d(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
real*8,target :: egydim(dim1,dim2)
|
|
real*8, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
end interface
|
|
c }}}
|
|
|
|
allocate(t3(nval*nvbe*(nvbe-1)/2,nal,nbe,nbe))
|
|
allocate(w3(nval*nvbe*(nvbe-1)/2,nal,nbe,nbe))
|
|
t3=0.d0
|
|
w3=0.d0
|
|
its=0
|
|
iw=its+nvbe**2*nval
|
|
iw=0
|
|
it=iw+nval*nvbe*(nvbe-1)/2
|
|
it=0
|
|
ivooo=it+nval*nvbe*(nvbe-1)/2
|
|
ivooo=0
|
|
ivoooab=ivooo+nvbe*nbe*nbe*(nbe-1)/2
|
|
ivoooba=ivoooab+nval*nbe*nal*nbe
|
|
ivoooba=0
|
|
ivvoo=ivoooba+nvbe*nal*nbe*nal
|
|
ivvoo=0
|
|
ivvooab=ivvoo+nvbe*(nvbe-1)*nbe*(nbe-1)/4
|
|
ivvooab=0
|
|
iabci=ivvooab+nval*nvbe*nal*nbe
|
|
iabci=1
|
|
recln=nvbe**2*nval
|
|
reclnm=nval**2*nvbe
|
|
recperoccba=recln/ibufln
|
|
if (mod(recln,ibufln).gt.0) recperoccba=recperoccba+1
|
|
recperoccab=reclnm/ibufln
|
|
if (mod(reclnm,ibufln).gt.0) recperoccab=recperoccab+1
|
|
|
|
c Checking the allocated memory
|
|
if (iabci+nvbe**2*(nvbe-1)/2+nval**2*nvbe+recln.gt.
|
|
&maxcor-imem+imem1) then
|
|
|
|
write(*,*)
|
|
write(iout,*) 'Insufficient memory!'
|
|
write(iout,"(' Requested: ',f6.2,' GB')")
|
|
&dble((iabci+nvbe**2*(nvbe-1)/2+nval**2*nvbe+recln)*8)/1024**3
|
|
write(iout,"(' Available: ',f6.2,' GB')")
|
|
&dble((maxcor-imem+imem1)*8)/1024**3
|
|
write(*,*)
|
|
error=.true.
|
|
return
|
|
|
|
endif
|
|
|
|
c call xxyyunb(tb2,nvbe,nvbe,nbe,nbe,scr(it2list1+1))
|
|
call xxyyunb(tb2,nvbe,nvbe,nbe,nbe,t2list1)
|
|
c call yyxxunb(tb2,nvbe,nvbe,nbe,nbe,scr(it2list2+1))
|
|
call yyxxunb(tb2,nvbe,nvbe,nbe,nbe,t2list2)
|
|
c call yzvxsw(tm2,nval,nvbe,nal,nbe,scr(itm2list+1))
|
|
call yzvxsw(tm2,nval,nvbe,nal,nbe,tm2list)
|
|
|
|
|
|
if (nbe.gt.1.and.nvbe.gt.0) then
|
|
open(16,file=aijkbb,form='unformatted')
|
|
read(16) vooo
|
|
close(16)
|
|
endif !nbe>1,nvbe>0
|
|
|
|
open(16,file=aijkab,form='unformatted')
|
|
read(16) voooab
|
|
close(16)
|
|
|
|
open(16,file=aijkba,form='unformatted')
|
|
read(16) voooba
|
|
close(16)
|
|
|
|
open(16,file=abijbb,form='unformatted')
|
|
read(16) vvoo
|
|
close(16)
|
|
|
|
open(16,file=abijab,form='unformatted')
|
|
read(16) vvooab
|
|
close(16)
|
|
c
|
|
nk=(maxcor-imem+imem1-recln)/
|
|
&(nvbe**2*(nvbe-1)/2+nval**2*nvbe)
|
|
if (nk.lt.nbe) nk=nk-2
|
|
if (nk.gt.nbe) nk=nbe
|
|
|
|
reciln=nvbe**2*(nvbe-1)/2
|
|
recperoccbb=reciln/ibufln
|
|
if (mod(reciln,ibufln).gt.0) recperoccbb=recperoccbb+1
|
|
if (nk.lt.nbe) then
|
|
|
|
ikbb=iabci+nk*(reciln+nval**2*nvbe)
|
|
ikab=ikbb+reciln
|
|
ijaa=ikab+nval**2*nvbe
|
|
ijba=ijaa+reciln
|
|
call rpoint2d(scr(iabci),abcibeta,reciln,nk+2)
|
|
call rpoint2d(scr(iabci+(nk+2)*reciln),abcimixed,reclnm,nk+2)
|
|
else
|
|
call rpoint2d(scr(iabci),abcibeta,reciln,nk)
|
|
call rpoint2d(scr(iabci+nk*reciln),abcimixed,reclnm,nk)
|
|
endif
|
|
|
|
c open(16,file=abciabba,access='direct',recl=8*recln)
|
|
open(16,file=abciabba,access='direct',recl=irecln)
|
|
c open(17,file=abcibbbb,access='direct',recl=8*reciln)
|
|
open(17,file=abcibbbb,access='direct',recl=irecln)
|
|
c open(20,file=abciabab,access='direct',recl=8*nval**2*nvbe)
|
|
open(20,file=abciabab,access='direct',recl=irecln)
|
|
|
|
|
|
do i=1,nk
|
|
c read(17,rec=i) scr(iabci+(i-1)*reciln+1:
|
|
c &iabci+i*reciln)
|
|
call getlst(17,(i-1)*recperoccbb+1,abcibeta(1,i),reciln)
|
|
c read(17,rec=i) abcibeta(1:reciln,i)
|
|
enddo
|
|
|
|
do i=1,nk
|
|
c read(20,rec=i) scr(iabci+nk*reciln+(i-1)*nval**2*nvbe+1:
|
|
c &iabci+nk*reciln+i*nval**2*nvbe)
|
|
c read(20,rec=i) abcimixed(1:reclnm,i)
|
|
call getlst(20,(i-1)*recperoccab+1,abcimixed(1,i),reclnm)
|
|
c write(*,*) 'abcimixed,i',i
|
|
c write(*,*) abcimixed(1:reclnm,i)
|
|
enddo
|
|
|
|
c temporary: read all of vVVo
|
|
do i=1,nal
|
|
call getlst(16,(i-1)*recperoccba+1,abcii(1,1,1,i),recln)
|
|
c read(16,rec=i) abcii(1:nval,1:nvbe,1:nvbe,i)
|
|
enddo
|
|
|
|
|
|
c jk=0
|
|
do k=1,nbe
|
|
kk=k
|
|
c Reading vvvob and vvvoab records for k
|
|
if (k.gt.nk) then
|
|
kk=nk+1
|
|
c read(17,rec=k) scr(ikbb+1:ikab)
|
|
c read(17,rec=k) abcibeta(1:reciln,kk)
|
|
call getlst(17,(k-1)*recperoccbb+1,abcibeta(1,kk),reciln)
|
|
c read(20,rec=k) abcimixed(1:reclnm,kk)
|
|
call getlst(20,(k-1)*recperoccab+1,abcimixed(1,kk),reclnm)
|
|
endif
|
|
|
|
do j=1,nbe
|
|
if (k.ne.j) then
|
|
if (k.gt.j) then
|
|
jk=(k-1)*(k-2)/2+j
|
|
djk=1.d0
|
|
else
|
|
jk=(j-1)*(j-2)/2+k
|
|
djk=-1.d0
|
|
endif
|
|
jj=j
|
|
c Reading vvvoa and vvvoba records for i
|
|
c
|
|
if (j.gt.nk) then
|
|
jj=nk+2
|
|
c read(17,rec=j) scr(ijaa+1:ijba)
|
|
c read(20,rec=j) scr(ijba+1:ijba+nval**2*nvbe)
|
|
c read(17,rec=j) abcibeta(1:reciln,jj)
|
|
call getlst(17,(j-1)*recperoccbb+1,abcibeta(1,jj),reciln)
|
|
c read(20,rec=j) abcimixed(1:reclnm,jj)
|
|
call getlst(20,(j-1)*recperoccab+1,abcimixed(1,jj),reclnm)
|
|
endif
|
|
do i=1,nal
|
|
ik=(k-1)*nal+i
|
|
ki=(i-1)*nbe+k
|
|
ij=(j-1)*nal+i
|
|
ji=(i-1)*nbe+j
|
|
|
|
c Building T,W
|
|
call tbbabuildcim(nal,nbe,nval,nvbe,i,j,k,ij,ik,jk,djk,fa,fb,
|
|
&ta1,tb1,
|
|
&tb2,tm2,
|
|
&t2list1,
|
|
&t2list2,tm2list,t,w,ts,abcii(1,1,1,i),abcibeta(1,jj),
|
|
&abcibeta(1,kk),abcimixed(1,jj),abcimixed(1,kk),vooo,voooab,voooba,
|
|
&vvoo,vvooab)
|
|
|
|
c placing t3,w3
|
|
t3(1:nvbe*(nvbe-1)*nval/2,i,j,k)=t
|
|
w3(1:nvbe*(nvbe-1)*nval/2,i,j,k)=w
|
|
|
|
enddo
|
|
endif !k.ne.j
|
|
enddo
|
|
c Monitoring percentage
|
|
pr=pr+nal*nbe
|
|
if (dble(pr).ge.dble(prold)+0.25d0*dble(total).and.pr.ne.total)
|
|
&then
|
|
write(iout,"(i4,'% done.')") int(100.d0*dble(pr)/dble(total))
|
|
prold=pr
|
|
endif
|
|
enddo
|
|
|
|
close(16)
|
|
close(17)
|
|
close(20)
|
|
|
|
c Calculating energy contribution
|
|
call dgemv('n',nval*nvbe*(nvbe-1)*nbe*nal/2,nbe,1.d0,t3,
|
|
&nval*nvbe*(nvbe-1)*nbe*nal/2,uib,1,0.d0,scr(iabci+1),1)
|
|
|
|
call dgemv('n',nval*nvbe*(nvbe-1)*nbe*nal/2,nbe,1.d0,w3,
|
|
&nval*nvbe*(nvbe-1)*nbe*nal/2,uib,1,0.d0,
|
|
&scr(iabci+nval*nvbe*(nvbe-1)*nbe*nal/2+1),1)
|
|
|
|
et=et+(1.d0/3.d0)*
|
|
&ddot(nval*nvbe*(nvbe-1)*nbe*nal/2,scr(iabci+1),1,
|
|
&scr(iabci+nval*nvbe*(nvbe-1)*nbe*nal/2+1),1)
|
|
|
|
c call prtenergc('CCSD(T) ',et,0.d0,3)
|
|
|
|
return
|
|
end
|
|
************************************************************************
|
|
subroutine loclapltabb(nal,nbe,nval,nvbe,q,dfnbasis,nquad,quada,
|
|
&quadb,ta1,tb1,tb2,tm2,fa,fb,jaba,jabb,jaia,jaib,t2iabl,t2kbcl,
|
|
&t2jbcl,
|
|
&t2jkad,
|
|
&ts,w,t,vooo,voooab,voooba,abjk,ab1j,
|
|
&cmoa,cmob,abcii,scr,
|
|
&dfint_ija,dfint_ijb,
|
|
&et,maxcor,imem,imem1,iout,error,pr,total,prold,
|
|
&inmemorya,inmemoryb,irest,icurrent,ied,first_quad)
|
|
************************************************************************
|
|
implicit none
|
|
|
|
integer it2list1,it2list2,itm2list,its,iw,it,ivooo,ivoooab,ivoooba
|
|
integer recln,reciln,maxcor,imem,imem1,nal,nbe,irest,icurrent,ied
|
|
integer nval,nvbe,nk,ni,kmax,kmin,i,j,k,a,b,c,ab,bc,abc,ikab,ijba
|
|
integer ikbb,ijaa,jk,ik,ki,ij,ji,ac,iout,pr,prold,total,reclnm,jj
|
|
integer kk,q,nquad,dfnbasis,l,d,ad,iabcibuff,iabciab,iabciabbuff
|
|
integer first_quad
|
|
|
|
real*8 scr(*),tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),ta1(nval,nal)
|
|
real*8 tb1(nvbe,nbe),ddot,et,fa(nal+nval,nal+nval),dnrm2,lfc
|
|
real*8 fb(nbe+nvbe,nbe+nvbe)
|
|
real*8 tm2(nval,nvbe,nal,nbe),ab1j(nvbe,nbe,nval)
|
|
real*8 ts(nval,nvbe,nvbe),w(nval*nvbe*(nvbe-1)/2),cmob(nbe,nbe)
|
|
real*8 t(nval*nvbe*(nvbe-1)/2),voooab(nval,nbe,nal,nbe)
|
|
real*8 vooo(nvbe,nbe,nbe*(nbe-1)/2),voooba(nvbe,nal,nbe,nal)
|
|
real*8 cmoa(nal,nal)
|
|
real*8 abcii(nval,nvbe,nvbe)
|
|
real*8 quada(nal+nval+nbe+nvbe,nquad),jaib(dfnbasis,nvbe,nbe)
|
|
real*8 quadb(nbe+nvbe+nal+nval,nquad),jaia(dfnbasis,nval,nal)
|
|
real*8 t2iabl(nval,nvbe,nbe),t2kbcl(nvbe*(nvbe-1)/2,nbe)
|
|
real*8 t2jbcl(nvbe*(nvbe-1)/2,nbe),t2jkad(nvbe,nvbe)
|
|
real*8 jabb(dfnbasis,nvbe,nvbe),abjk(nvbe,nvbe)
|
|
real*8 jaba(dfnbasis,nval,nval)
|
|
real*8,pointer::abcibeta(:,:),abcimixed(:,:),abciibuff(:,:,:)
|
|
real*8,pointer::abcibuff(:,:,:),abci(:,:,:),abciab(:,:,:,:)
|
|
real*8,pointer::abciabbuff(:,:,:)
|
|
|
|
character*9 dfint_ija,dfint_ijb
|
|
|
|
logical error,inmemorya(9),inmemoryb(9)
|
|
|
|
c {{{ Interfaces for pointers
|
|
interface
|
|
subroutine rpoint2d(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
real*8,target :: egydim(dim1,dim2)
|
|
real*8, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
subroutine rpoint3d(egydim,haromdim,dim1,dim2,dim3)
|
|
implicit none
|
|
integer dim1,dim2,dim3
|
|
real*8,target :: egydim(dim1,dim2,dim3)
|
|
real*8, pointer :: haromdim(:,:,:)
|
|
end subroutine
|
|
subroutine rpoint4d(egydim,haromdim,dim1,dim2,dim3,dim4)
|
|
implicit none
|
|
integer dim1,dim2,dim3,dim4
|
|
real*8,target :: egydim(dim1,dim2,dim3,dim4)
|
|
real*8, pointer :: haromdim(:,:,:,:)
|
|
end subroutine
|
|
end interface
|
|
c }}}
|
|
|
|
recln=nvbe**2*nval
|
|
reclnm=nval**2*nvbe
|
|
reciln=nvbe**2*(nvbe-1)/2
|
|
c {{{ Checking the allocated memory
|
|
if (3*(nvbe**2*(nvbe-1)/2+nval**2*nvbe)+recln.gt.
|
|
&maxcor-imem+imem1) then
|
|
write(*,*)
|
|
write(iout,*) 'Insufficient memory!'
|
|
write(iout,"(' Requested: ',f6.2,' GB')")
|
|
&dble((3*(nvbe**2*(nvbe-1)/2+nval**2*nvbe)+recln)*8)/1024**3
|
|
write(iout,"(' Available: ',f6.2,' GB')")
|
|
&dble((maxcor-imem+imem1)*8)/1024**3
|
|
write(*,*)
|
|
error=.true.
|
|
return
|
|
endif
|
|
c }}}
|
|
|
|
|
|
c {{{ Loop for Laplace quadrature
|
|
c Transforming to local basis
|
|
call trf2laplbasisabb(nal,nbe,nval,nvbe,dfnbasis,q,nquad,cmoa,
|
|
&cmob,quada,quadb,jaba,jabb,jaia,jaib,fa,fb,ta1,tb1,tb2,tm2,vooo,
|
|
&voooab,voooba,dfint_ija,dfint_ijb,
|
|
&scr,inmemorya,inmemoryb,first_quad)
|
|
|
|
c Assembling aB1J
|
|
call dgemm('t','n',nvbe*nbe,nval,dfnbasis,1.d0,jaib,dfnbasis,
|
|
&jaia(1,1,1),dfnbasis,0.d0,ab1j,nvbe*nbe)
|
|
c Assembling (\bar B C|\bar a\bar i') for one i
|
|
call rpoint3d(scr,abciibuff,nvbe,nvbe,nval)
|
|
call dgemm('t','n',nvbe**2,nval,dfnbasis,1.d0,jabb,dfnbasis,
|
|
&jaia(1,1,1),dfnbasis,0.d0,abciibuff,nvbe**2)
|
|
do c=1,nvbe
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
abcii(a,b,c)=abciibuff(b,c,a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c Build t^i'_aBL
|
|
do l=1,nbe
|
|
t2iabl(1:nval,1:nvbe,l)=
|
|
&tm2(1:nval,1:nvbe,1,l)
|
|
enddo
|
|
|
|
c Calculating memory for abci integrals
|
|
ni=(maxcor-imem+imem1-nvbe**3-nval**2*nvbe)/
|
|
&(nvbe**2*(nvbe-1)/2+nval**2*nvbe)
|
|
if (ni.ge.nbe) then
|
|
ni=nbe
|
|
iabcibuff=1+nvbe*(nvbe-1)*nvbe*ni/2
|
|
iabciab=iabcibuff+nvbe**3
|
|
iabciabbuff=iabciab+nval**2*nvbe*ni
|
|
call rpoint3d(scr,abci,nvbe*(nvbe-1)/2,nvbe,ni)
|
|
call rpoint3d(scr(iabcibuff),abcibuff,nvbe,nvbe,nvbe)
|
|
call rpoint4d(scr(iabciab),abciab,nval,nvbe,nval,ni)
|
|
call rpoint3d(scr(iabciabbuff),abciabbuff,nval,nval,nvbe)
|
|
else
|
|
ni=ni-2
|
|
iabcibuff=1+nvbe*(nvbe-1)*nvbe*(ni+2)/2
|
|
iabciab=iabcibuff+nvbe**3
|
|
iabciabbuff=iabciab+nval*nvbe*nval*(ni+2)
|
|
call rpoint3d(scr,abci,nvbe*(nvbe-1)/2,nvbe,ni+2)
|
|
call rpoint3d(scr(iabcibuff),abcibuff,nvbe,nvbe,nvbe)
|
|
call rpoint4d(scr(iabciab),abciab,nval,nvbe,nval,ni+2)
|
|
call rpoint3d(scr(iabciabbuff),abciabbuff,nval,nval,nvbe)
|
|
endif
|
|
|
|
c Assemble <AB||CK> for ni blocks
|
|
do i=1,ni
|
|
call dgemm('t','n',nvbe**2,nvbe,dfnbasis,1.d0,jabb,dfnbasis,
|
|
&jaib(1,1,i),dfnbasis,0.d0,abcibuff,nvbe**2)
|
|
do c=1,nvbe
|
|
lfc=quadb(nbe+c,q)
|
|
ab=1
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
abci(ab,c,i)=(abcibuff(a,c,b)-abcibuff(b,c,a))/lfc
|
|
ab=ab+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c Assemble <aB||cI> for ni blocks
|
|
do i=1,ni
|
|
call dgemm('t','n',nval**2,nvbe,dfnbasis,1.d0,jaba,dfnbasis,
|
|
&jaib(1,1,i),dfnbasis,0.d0,abciabbuff,nval**2)
|
|
do c=1,nval
|
|
lfc=quada(nal+c,q)
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
abciab(a,b,c,i)=abciabbuff(a,c,b)/lfc
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c}}}
|
|
|
|
c {{{ Loop for occupied indeces
|
|
jk=0
|
|
do k=2,nbe
|
|
ik=(k-1)*nal+1
|
|
ki=k
|
|
kk=k
|
|
|
|
c Checking if record k is in the memory
|
|
if (k.gt.ni) then
|
|
kk=ni+1
|
|
c If not then assemble <AB||CK>
|
|
call dgemm('t','n',nvbe**2,nvbe,dfnbasis,1.d0,jabb,dfnbasis,
|
|
&jaib(1,1,k),dfnbasis,0.d0,abcibuff,nvbe**2)
|
|
do c=1,nvbe
|
|
lfc=quadb(nbe+c,q)
|
|
ab=1
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
abci(ab,c,kk)=(abcibuff(a,c,b)-abcibuff(b,c,a))/lfc
|
|
ab=ab+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c and <aB||cK>
|
|
call dgemm('t','n',nval**2,nvbe,dfnbasis,1.d0,jaba,dfnbasis,
|
|
&jaib(1,1,k),dfnbasis,0.d0,abciabbuff,nval**2)
|
|
do c=1,nval
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
abciab(a,b,c,kk)=abciabbuff(a,c,b)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif !k.gt.ni
|
|
c Building t^K'_BCL'
|
|
t2kbcl(1:nvbe*(nvbe-1)/2,k)=0.d0
|
|
do l=1,nbe
|
|
if (l.gt.k) then
|
|
t2kbcl(1:nvbe*(nvbe-1)/2,l)=
|
|
&-tb2(1:nvbe*(nvbe-1)/2,(l-1)*(l-2)/2+k) !placing -tlbck instead of tkbcl
|
|
elseif (l.lt.k) then
|
|
t2kbcl(1:nvbe*(nvbe-1)/2,l)=
|
|
&tb2(1:nvbe*(nvbe-1)/2,(k-1)*(k-2)/2+l)
|
|
endif
|
|
enddo
|
|
|
|
do j=1,k-1
|
|
jk=jk+1
|
|
ij=(j-1)*nal+1
|
|
ji=j
|
|
jj=j
|
|
|
|
c Checking if record j is in the memory
|
|
if (j.gt.ni) then
|
|
jj=ni+2
|
|
c If not then assemble <AB||CJ>
|
|
call dgemm('t','n',nvbe**2,nvbe,dfnbasis,1.d0,jabb,dfnbasis,
|
|
&jaib(1,1,j),dfnbasis,0.d0,abcibuff,nvbe**2)
|
|
do c=1,nvbe
|
|
lfc=quadb(nbe+c,q)
|
|
ab=1
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
abci(ab,c,jj)=(abcibuff(a,c,b)-abcibuff(b,c,a))/lfc
|
|
ab=ab+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c and <aB||cJ>
|
|
call dgemm('t','n',nval**2,nvbe,dfnbasis,1.d0,jaba,dfnbasis,
|
|
&jaib(1,1,j),dfnbasis,0.d0,abciabbuff,nval**2)
|
|
do c=1,nval
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
abciab(a,b,c,jj)=abciabbuff(a,c,b)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
c Building t^J'_BCL'
|
|
t2jbcl(1:nvbe*(nvbe-1)/2,j)=0.d0
|
|
do l=1,nbe
|
|
if (l.gt.j) then
|
|
t2jbcl(1:nvbe*(nvbe-1)/2,l)=
|
|
&-tb2(1:nvbe*(nvbe-1)/2,(l-1)*(l-2)/2+j) !placing -tlbcj instead of tjbcl
|
|
elseif (l.lt.j) then
|
|
t2jbcl(1:nvbe*(nvbe-1)/2,l)=
|
|
&tb2(1:nvbe*(nvbe-1)/2,(j-1)*(j-2)/2+l)
|
|
endif
|
|
enddo
|
|
c Building t^J'K'_\bar AD
|
|
ad=1
|
|
do d=1,nvbe
|
|
t2jkad(d,d)=0.d0
|
|
do a=1,d-1
|
|
t2jkad(a,d)=tb2(ad,jk)/quadb(nbe+d,q)
|
|
t2jkad(d,a)=-tb2(ad,jk)/quadb(nbe+a,q)
|
|
ad=ad+1
|
|
enddo
|
|
enddo
|
|
c Building <AB||JK>
|
|
call dgemm('t','n',nvbe,nvbe,dfnbasis,1.d0,jaib(1,1,j),dfnbasis,
|
|
&jaib(1,1,k),dfnbasis,0.d0,abjk,nvbe)
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
abjk(a,b)=abjk(a,b)-abjk(b,a)
|
|
enddo
|
|
enddo
|
|
c }}}
|
|
|
|
icurrent = icurrent + 1
|
|
if (icurrent.le.irest) cycle
|
|
|
|
c Building T,W
|
|
call tabbbuild(nal,nbe,nval,nvbe,j,k,ij,ik,jk,fa,fb,
|
|
&ta1,tb1,
|
|
&tb2,tm2,t2iabl,t2kbcl,t2jbcl,t2jkad,
|
|
&t,w,ts,abcii,abci(1,1,jj),
|
|
&abci(1,1,kk),abciab(1,1,1,jj),abciab(1,1,1,kk),vooo,voooab,voooba,
|
|
&abjk,ab1j)
|
|
|
|
c Calculating energy contribution
|
|
et=et-(1.d0/3.d0)*ddot(nval*nvbe*(nvbe-1)/2,t,1,w,1)
|
|
c etdbg=etdbg+(1.d0/3.d0)*ddot(nval*nvbe*(nvbe-1)/2,t,1,w,1)
|
|
call managerestart('w','(t)2',-1,scr,scr,scr,et,scr,scr,scr,scr,
|
|
& scr,icurrent,0,0,0,0,scr,ied)
|
|
enddo
|
|
enddo
|
|
c Monitoring percentage
|
|
pr=icurrent
|
|
if (dble(pr).ge.dble(prold)+0.25d0*dble(total).and.pr.ne.total)
|
|
&then
|
|
write(iout,"(i4,'% done.')") int(100.d0*dble(pr)/dble(total))
|
|
prold=pr
|
|
endif
|
|
return
|
|
end
|
|
|
|
|
|
subroutine trf2laplbasisabb(nal,nbe,nval,nvbe,dfnbasis,q,nquad,
|
|
&cmoa,cmob,quada,quadb,jaba,
|
|
&jabb,jaia,jaib,fa,fb,ta1,tb1,tb2,tm2,aijkbb,
|
|
&aijkab,
|
|
&aijkba,
|
|
&dfint_ija,dfint_ijb,
|
|
&scr,inmemorya,inmemoryb,first_quad)
|
|
|
|
implicit none
|
|
integer nal,nbe,nval,nvbe,dfnbasis,q,nquad,ilcmoa,ilcmob
|
|
integer ijaibuff,iaibj,iabbuff1,aibdim,a,p,j,i,ab,b,k,ij,aiadim
|
|
integer iabbuff2,ijij,ijadim,iaijkscr,ijijscr,ijijscr2,ijbdim,jk
|
|
integer abbdim,iabci,iabciscr,c,abadim,first_quad
|
|
|
|
real*8 ta1(nval,nal),lfa,s,lfb
|
|
real*8 quada(nal+nval+nbe+nvbe,nquad),cmoa(nal,nal),cmob(nbe,nbe)
|
|
real*8 quadb(nal+nval+nbe+nvbe,nquad),scr(*),tb1(nvbe,nbe)
|
|
real*8 jaib(dfnbasis,nvbe,nbe),jaia(dfnbasis,nval,nal)
|
|
real*8 fa(nal+nval,nal+nval)
|
|
real*8 tm2(nval,nvbe,nal,nbe),aijkba(nvbe,nal,nbe,nal)
|
|
real*8 fb(nbe+nvbe,nbe+nvbe),tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2)
|
|
real*8 aijkab(nval,nbe,nal,nbe),aijkbb(nvbe,nbe,nbe*(nbe-1)/2)
|
|
real*8 jabb(dfnbasis,nvbe,nvbe),jaba(dfnbasis,nval,nval)
|
|
real*8,pointer::lcmoa(:,:),lcmob(:,:),abbuff1(:,:)
|
|
real*8,pointer::jaibuff(:,:,:),aibj(:,:,:,:),abbuff2(:,:)
|
|
real*8,pointer::jij(:,:,:),jijscr(:,:,:),jijscr2(:,:),abci(:,:)
|
|
real*8,pointer::invlcmo(:,:),aijkscr(:,:,:,:)
|
|
real*8,pointer::abciscr(:,:,:,:),abci2(:,:,:)
|
|
|
|
character*9 dfint_aib,dfint_aia,dfint_ija,dfint_ijb,dfint_abb
|
|
character*9 dfint_aba
|
|
logical inmemorya(9),inmemoryb(9)
|
|
|
|
c {{{ Interfaces for pointers
|
|
interface
|
|
subroutine rpoint2d(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
real*8,target :: egydim(dim1,dim2)
|
|
real*8, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
subroutine rpoint3d(egydim,haromdim,dim1,dim2,dim3)
|
|
implicit none
|
|
integer dim1,dim2,dim3
|
|
real*8,target :: egydim(dim1,dim2,dim3)
|
|
real*8, pointer :: haromdim(:,:,:)
|
|
end subroutine
|
|
subroutine rpoint4d(egydim,haromdim,dim1,dim2,dim3,dim4)
|
|
implicit none
|
|
integer dim1,dim2,dim3,dim4
|
|
real*8,target :: egydim(dim1,dim2,dim3,dim4)
|
|
real*8, pointer :: haromdim(:,:,:,:)
|
|
end subroutine
|
|
end interface
|
|
c }}}
|
|
|
|
abadim=nval*(nval+1)/2
|
|
abbdim=nvbe*(nvbe+1)/2
|
|
aibdim=nvbe*nbe
|
|
aiadim=nval*nal
|
|
ijadim=nal*(nal+1)/2
|
|
ijbdim=nbe*(nbe+1)/2
|
|
|
|
ilcmoa=1
|
|
ilcmob=ilcmoa+nal**2
|
|
ijaibuff=ilcmob+nbe**2
|
|
call rpoint2d(scr(ilcmoa),lcmoa,nal,nal)
|
|
call rpoint2d(scr(ilcmob),lcmob,nbe,nbe)
|
|
call rpoint3d(scr(ijaibuff),jaibuff,dfnbasis,nvbe,nbe)
|
|
|
|
c {{{ Integral assembly
|
|
c 0.b) Multiply UiIb with laplace factors
|
|
|
|
c 1) Read Jaib, transform occupied index, multiply with laplace factors, transpose
|
|
if (.not.inmemoryb(5)) then
|
|
if (q.gt.first_quad) then
|
|
do i=1,nbe
|
|
do j=1,nbe
|
|
s=0.d0
|
|
do k=1,nbe
|
|
s=s+cmob(k,i)*cmob(k,j)*quadb(k,q)/quadb(k,q-1)
|
|
enddo
|
|
lcmob(i,j)=s
|
|
enddo
|
|
enddo
|
|
else !q.eq.first_quad
|
|
do i=1,nbe
|
|
lcmob(i,1:nbe)=cmob(i,1:nbe)*quadb(i,q)
|
|
enddo
|
|
endif
|
|
do a=1,nvbe
|
|
lfa=quadb(nbe+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quadb(nbe+a,q-1)
|
|
jaibuff(1:dfnbasis,a,1:nbe)=jaib(1:dfnbasis,a,1:nbe)*lfa
|
|
enddo
|
|
call dgemm('n','n',dfnbasis*nvbe,nbe,nbe,1.d0,jaibuff,
|
|
& dfnbasis*nvbe,lcmob,nbe,0.d0,jaib,dfnbasis*nvbe)
|
|
inmemoryb(5)=.true.
|
|
endif !JAI not in memory
|
|
|
|
c 2) Read Jaia
|
|
call rpoint3d(scr(ijaibuff),jaibuff,dfnbasis,nval,nal)
|
|
if (.not.inmemorya(5)) then
|
|
if (q.gt.first_quad) then
|
|
do i=1,nal
|
|
do j=1,nal
|
|
s=0.d0
|
|
do k=1,nal
|
|
s=s+cmoa(k,i)*cmoa(k,j)*quada(k,q)/quada(k,q-1)
|
|
enddo
|
|
lcmoa(i,j)=s
|
|
enddo
|
|
enddo
|
|
else !q=1
|
|
do i=1,nal
|
|
lcmoa(i,1:nal)=cmoa(i,1:nal)*quada(i,q)
|
|
enddo
|
|
endif
|
|
do a=1,nval
|
|
lfa=quada(nal+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quada(nal+a,q-1)
|
|
jaibuff(1:dfnbasis,a,1:nal)=jaia(1:dfnbasis,a,1:nal)*lfa
|
|
enddo
|
|
call dgemm('n','n',dfnbasis*nval,nal,nal,1.d0,jaibuff,
|
|
& dfnbasis*nval,lcmoa,nal,0.d0,jaia,dfnbasis*nval)
|
|
inmemorya(5)=.true.
|
|
endif !Jai is not in memory
|
|
|
|
c 2) Read and expand Jij
|
|
ijij=ilcmob+nbe**2
|
|
iaijkscr=ijij+dfnbasis*nal**2
|
|
ijijscr=ijij+dfnbasis*nal**2
|
|
ijijscr2=ijijscr+dfnbasis*nal**2
|
|
call rpoint3d(scr(ijij),jij,dfnbasis,nal,nal)
|
|
call rpoint3d(scr(ijijscr),jijscr,dfnbasis,nal,nal)
|
|
call rpoint2d(scr(ijijscr2),jijscr2,dfnbasis,ijadim)
|
|
call rpoint2d(scr(ijijscr2),invlcmo,nal,nal)
|
|
call rpoint4d(scr(iaijkscr),aijkscr,nvbe,nbe,nal,nal)
|
|
if (.not.inmemorya(8)) then
|
|
!Multiply CMO with Laplace factors
|
|
do i=1,nal
|
|
lcmoa(i,1:nal)=cmoa(i,1:nal)*quada(i,q)
|
|
enddo
|
|
open(16,file=trim(dfint_ija),form='unformatted')
|
|
read(16) jijscr2
|
|
close(16)
|
|
ij=1
|
|
do j=1,nal
|
|
do i=1,j
|
|
jij(1:dfnbasis,i,j)=jijscr2(1:dfnbasis,ij)
|
|
if (j.ne.i)
|
|
& jij(1:dfnbasis,j,i)=jijscr2(1:dfnbasis,ij)
|
|
ij=ij+1
|
|
enddo
|
|
enddo
|
|
c Creating J^P_i \bar j
|
|
call dgemm('n','n',dfnbasis*nal,nal,nal,1.d0,jij,dfnbasis*nal,
|
|
& lcmoa,nal,0.d0,jijscr,dfnbasis*nal)
|
|
c Creating invlcmo
|
|
do i=1,nal
|
|
invlcmo(i,1:nal)=cmoa(i,1:nal)/quada(i,q)
|
|
enddo
|
|
c Creating J^P_\tilde i \bar j
|
|
do j=1,nal
|
|
call dgemm('n','n',dfnbasis,nal,nal,1.d0,jijscr(1,1,j),dfnbasis,
|
|
& invlcmo,nal,0.d0,jij(1,1,j),dfnbasis)
|
|
enddo
|
|
|
|
c Assemble <A,\tilde i,\bar J \bar k>
|
|
call dgemm('t','n',aibdim,nal**2,dfnbasis,1.d0,jaib,dfnbasis,jij,
|
|
& dfnbasis,0.d0,aijkscr,aibdim)
|
|
do k=1,nal
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
aijkba(1:nvbe,i,j,k)=aijkscr(1:nvbe,j,i,k)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
inmemorya(8)=.true.
|
|
inmemoryb(7)=.true.
|
|
endif !aijkba is not in memory
|
|
|
|
c 2) Read JIJ
|
|
iaijkscr=ijij+dfnbasis*nbe**2
|
|
ijijscr=ijij+dfnbasis*nbe**2
|
|
ijijscr2=ijijscr+dfnbasis*nbe**2
|
|
call rpoint3d(scr(ijij),jij,dfnbasis,nbe,nbe)
|
|
call rpoint3d(scr(ijijscr),jijscr,dfnbasis,nbe,nbe)
|
|
call rpoint2d(scr(ijijscr2),jijscr2,dfnbasis,ijbdim)
|
|
call rpoint2d(scr(ijijscr2),invlcmo,nbe,nbe)
|
|
call rpoint4d(scr(iaijkscr),aijkscr,nval,nal,nbe,nbe)
|
|
if (.not.inmemorya(7).or..not.inmemoryb(6)) then
|
|
!Multiply CMO with Laplace factors
|
|
do i=1,nbe
|
|
lcmob(i,1:nbe)=cmob(i,1:nbe)*quadb(i,q)
|
|
enddo
|
|
open(16,file=trim(dfint_ijb),form='unformatted')
|
|
read(16) jijscr2
|
|
close(16)
|
|
ij=1
|
|
do j=1,nbe
|
|
do i=1,j
|
|
jij(1:dfnbasis,i,j)=jijscr2(1:dfnbasis,ij)
|
|
if (j.ne.i)
|
|
& jij(1:dfnbasis,j,i)=jijscr2(1:dfnbasis,ij)
|
|
ij=ij+1
|
|
enddo
|
|
enddo
|
|
c Creating J^P_I \bar J
|
|
call dgemm('n','n',dfnbasis*nbe,nbe,nbe,1.d0,jij,dfnbasis*nbe,
|
|
& lcmob,nbe,0.d0,jijscr,dfnbasis*nbe)
|
|
c Creating invlcmo
|
|
do i=1,nbe
|
|
invlcmo(i,1:nbe)=cmob(i,1:nbe)/quadb(i,q)
|
|
enddo
|
|
c Creating J^P_\tilde I \bar J
|
|
do j=1,nbe
|
|
call dgemm('n','n',dfnbasis,nbe,nbe,1.d0,jijscr(1,1,j),dfnbasis,
|
|
& invlcmo,nbe,0.d0,jij(1,1,j),dfnbasis)
|
|
enddo
|
|
endif !aijkab or aijkbb is not in memory
|
|
|
|
if (.not.inmemorya(7)) then
|
|
c Assemble <a,\tilde I,\bar j \bar K>
|
|
call dgemm('t','n',aiadim,nbe**2,dfnbasis,1.d0,jaia,dfnbasis,jij,
|
|
& dfnbasis,0.d0,aijkscr,aiadim)
|
|
do k=1,nbe
|
|
do j=1,nal
|
|
do i=1,nbe
|
|
aijkab(1:nval,i,j,k)=aijkscr(1:nval,j,i,k)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
inmemorya(7)=.true.
|
|
inmemoryb(8)=.true.
|
|
endif !abijkab is not in memory
|
|
|
|
c Assemle <A, \tilde I,\bar J \bar K>
|
|
if (.not.inmemoryb(6)) then
|
|
call rpoint4d(scr(iaijkscr),aijkscr,nvbe,nbe,nbe,nbe)
|
|
call dgemm('t','n',aibdim,nbe**2,dfnbasis,1.d0,jaib,dfnbasis,jij,
|
|
& dfnbasis,0.d0,aijkscr,aibdim)
|
|
jk=1
|
|
do k=1,nbe
|
|
do j=1,k-1
|
|
do i=1,nbe
|
|
aijkbb(1:nvbe,i,jk)=aijkscr(1:nvbe,j,i,k)-aijkscr(1:nvbe,k,i,j)
|
|
enddo
|
|
jk=jk+1
|
|
enddo
|
|
enddo
|
|
inmemoryb(6)=.true.
|
|
endif !abijkbb is not in memory
|
|
|
|
c 3) Read JAB, multiply with laplace factors
|
|
if (.not.inmemoryb(4)) then
|
|
do a=1,nvbe
|
|
lfa=quadb(nbe+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quadb(nbe+a,q-1)
|
|
jabb(1:dfnbasis,a,1:nvbe)=jabb(1:dfnbasis,a,1:nvbe)*lfa
|
|
enddo
|
|
inmemoryb(4)=.true.
|
|
endif !JAB is not in memory
|
|
|
|
c Jab is done in aaa spincase
|
|
if (.not.inmemorya(4)) then
|
|
c Read Jab, multiply with laplace factors
|
|
do a=1,nval
|
|
lfa=quada(nal+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quada(nal+a,q-1)
|
|
jaba(1:dfnbasis,a,1:nval)=jaba(1:dfnbasis,a,1:nval)*lfa
|
|
enddo
|
|
inmemorya(4)=.true.
|
|
endif !Jab is not in memory
|
|
c }}}
|
|
|
|
c lcmoa/q-1
|
|
if (q.gt.first_quad) then
|
|
do i=1,nal
|
|
do j=1,nal
|
|
s=0.d0
|
|
do k=1,nal
|
|
s=s+cmoa(k,i)*cmoa(k,j)*quada(k,q)/quada(k,q-1)
|
|
enddo
|
|
lcmoa(i,j)=s
|
|
enddo
|
|
enddo
|
|
else !q.eq.first_quad
|
|
do i=1,nal
|
|
lcmoa(i,1:nal)=cmoa(i,1:nal)*quada(i,q)
|
|
enddo
|
|
endif
|
|
c lcmob/q-1
|
|
if (q.gt.first_quad) then
|
|
do i=1,nbe
|
|
do j=1,nbe
|
|
s=0.d0
|
|
do k=1,nbe
|
|
s=s+cmob(k,i)*cmob(k,j)*quadb(k,q)/quadb(k,q-1)
|
|
enddo
|
|
lcmob(i,j)=s
|
|
enddo
|
|
enddo
|
|
else !q.eq.first_quad
|
|
do i=1,nbe
|
|
lcmob(i,1:nbe)=cmob(i,1:nbe)*quadb(i,q)
|
|
enddo
|
|
endif
|
|
c tb2 is done in bbb spincase
|
|
iabbuff1=ilcmob+nbe**2
|
|
iabbuff2=iabbuff1+nbe**2
|
|
call rpoint2d(scr(iabbuff1),abbuff1,nbe,nbe)
|
|
call rpoint2d(scr(iabbuff2),abbuff2,nbe,nbe)
|
|
if (.not.inmemoryb(3)) then
|
|
c 6) Transfrom all indeces of tb2 to Laplace basis
|
|
ab=1
|
|
do b=1,nvbe
|
|
lfb=quadb(nbe+b,q)
|
|
if (q.gt.first_quad) lfb=lfb/quadb(nbe+b,q-1)
|
|
do a=1,b-1
|
|
lfa=quadb(nbe+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quadb(nbe+a,q-1)
|
|
|
|
c 6.1) Transform one occupied index
|
|
call yyxxunbtr(tb2,nvbe,nbe,ab,abbuff1)
|
|
call dgemm('n','n',nbe,nbe,nbe,1.d0,abbuff1,nbe,lcmob,nbe,0.d0,
|
|
& abbuff2,nbe)
|
|
c 6.3) Transform other occupied index
|
|
call dgemm('t','n',nbe,nbe,nbe,lfa*lfb,lcmob,nbe,abbuff2,nbe,
|
|
& 0.d0,abbuff1,nbe)
|
|
|
|
c 6.5) Place tb2
|
|
ij=1
|
|
do j=1,nbe
|
|
do i=1,j-1
|
|
tb2(ab,ij)=abbuff1(i,j)
|
|
ij=ij+1
|
|
enddo
|
|
enddo
|
|
ab=ab+1
|
|
enddo
|
|
enddo
|
|
inmemoryb(3)=.true.
|
|
endif !tb2 is not in memory
|
|
|
|
iabbuff2=iabbuff1+nal*nbe
|
|
call rpoint2d(scr(iabbuff1),abbuff1,nal,nbe)
|
|
call rpoint2d(scr(iabbuff2),abbuff2,nal,nbe)
|
|
if (.not.inmemorya(9)) then
|
|
c Transfrom all indeces of tm2 to Laplace basis
|
|
do b=1,nvbe
|
|
lfb=quadb(nbe+b,q)
|
|
if (q.gt.first_quad) lfb=lfb/quadb(nbe+b,q-1)
|
|
do a=1,nval
|
|
lfa=quada(nal+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quada(nal+a,q-1)
|
|
|
|
c Copy tm2 to abbuff1
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
abbuff1(i,j)=tm2(a,b,i,j)
|
|
enddo
|
|
enddo
|
|
|
|
c 6.1) Transform beta occupied index
|
|
call dgemm('n','n',nal,nbe,nbe,1.d0,abbuff1,nal,lcmob,nbe,
|
|
& 0.d0,abbuff2,nal)
|
|
c 6.3) Transform alpha occupied index
|
|
call dgemm('t','n',nal,nbe,nal,lfa*lfb,lcmoa,nal,abbuff2,nal,
|
|
& 0.d0,abbuff1,nal)
|
|
|
|
c 6.5) Place tb2
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
tm2(a,b,i,j)=abbuff1(i,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
inmemorya(9)=.true.
|
|
inmemoryb(9)=.true.
|
|
endif !tm2 is not in memory
|
|
|
|
c ta1
|
|
if (.not.inmemorya(2)) then
|
|
call rpoint2d(scr(iabbuff1),abbuff1,nval,nal)
|
|
do a=1,nval
|
|
lfa=quada(nal+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quada(nal+a,q-1)
|
|
abbuff1(a,1:nal)=ta1(a,1:nal)*lfa
|
|
enddo
|
|
call dgemm('n','n',nval,nal,nal,1.d0,abbuff1,nval,lcmoa,nal,0.d0,
|
|
& ta1,nval)
|
|
inmemorya(2)=.true.
|
|
endif !ta1 is not in memory
|
|
|
|
c tb1
|
|
if (.not.inmemoryb(2)) then
|
|
call rpoint2d(scr(iabbuff1),abbuff1,nvbe,nbe)
|
|
do a=1,nvbe
|
|
lfa=quadb(nbe+a,q)
|
|
if (q.ne.first_quad) lfa=lfa/quadb(nbe+a,q-1)
|
|
abbuff1(a,1:nbe)=tb1(a,1:nbe)*lfa
|
|
enddo
|
|
call dgemm('n','n',nvbe,nbe,nbe,1.d0,abbuff1,nvbe,lcmob,nbe,0.d0,
|
|
& tb1,nvbe)
|
|
inmemoryb(2)=.true.
|
|
endif !tb1 is not in memory
|
|
|
|
c Fa
|
|
if (.not.inmemorya(1)) then
|
|
call rpoint2d(scr(iabbuff1),abbuff1,nval,nal)
|
|
do a=1,nval
|
|
lfa=quada(nal+a,q)
|
|
if (q.gt.first_quad) lfa=lfa/quada(nal+a,q-1)
|
|
abbuff1(a,1:nal)=fa(nal+a,1:nal)*lfa
|
|
enddo
|
|
call dgemm('n','n',nval,nal,nal,1.d0,abbuff1,nval,lcmoa,nal,0.d0,
|
|
& fa(nal+1,1),nal+nval)
|
|
inmemorya(1)=.true.
|
|
endif !Fa is not in memory
|
|
|
|
c Fa is done in spincase bbb
|
|
c Fb
|
|
if (.not.inmemoryb(1)) then
|
|
call rpoint2d(scr(iabbuff1),abbuff1,nvbe,nbe)
|
|
do a=1,nvbe
|
|
lfa=quadb(nbe+a,q)
|
|
if (q.ne.first_quad) lfa=lfa/quadb(nbe+a,q-1)
|
|
abbuff1(a,1:nbe)=fb(nbe+a,1:nbe)*lfa
|
|
enddo
|
|
call dgemm('n','n',nvbe,nbe,nbe,1.d0,abbuff1,nvbe,lcmob,nbe,0.d0,
|
|
& fb(nbe+1,1),nbe+nvbe)
|
|
inmemoryb(1)=.true.
|
|
endif !Fb is not in memory
|
|
|
|
return
|
|
end
|
|
************************************************************************
|
|
subroutine loclapltbba(nal,nbe,nval,nvbe,dfnbasis,q,nquad,quada,
|
|
&quadb,ta1,tb1,tb2,tm2,fa,fb,jaba,jabb,jaia,jaib,t2iabl,t2kbcl,
|
|
&t2jbcl,t2jkad,ts,w,t,vooo,voooab,voooba,abc1,abc1m,abcj,abcjm,
|
|
&abcjbuffscr,abjk,abi1,abij,cmoa,cmob,scr,dfint_ija,dfint_ijb,et,
|
|
&maxcor,imem,imem1,iout,error,pr,total,prold,inmemorya,inmemoryb,
|
|
&irest,icurrent,ied,first_quad)
|
|
************************************************************************
|
|
implicit none
|
|
|
|
integer recln,reciln,maxcor,imem,imem1,nal,nbe,ied,first_quad
|
|
integer nval,nvbe,nk,ni,kmax,kmin,i,j,k,a,b,c,ab,bc,abc,ikab,ijba
|
|
integer ikbb,ijaa,jk,ik,ki,ij,ji,ac,iout,pr,prold,total,reclnm,jj
|
|
integer kk,q,nquad,dfnbasis,l,d,ad,iabcibuff,ii,irest,icurrent
|
|
|
|
real*8 scr(*),tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),ta1(nval,nal)
|
|
real*8 tb1(nvbe,nbe),ddot,et,fa(nal+nval,nal+nval),dnrm2
|
|
real*8 fb(nbe+nvbe,nbe+nvbe),lfc,tm2(nval,nvbe,nal,nbe)
|
|
real*8 ts(nval,nvbe,nvbe),w(nval*nvbe*(nvbe-1)/2),cmob(nbe,nbe)
|
|
real*8 t(nval*nvbe*(nvbe-1)/2),voooab(nval,nbe,nal,nbe)
|
|
real*8 vooo(nvbe,nbe,nbe*(nbe-1)/2),voooba(nvbe,nal,nbe,nal)
|
|
real*8 cmoa(nal,nal),abi1(nval,nal,nvbe),jaba(dfnbasis,nval,nval)
|
|
real*8 quada(nal+nval+nbe+nvbe,nquad),jaib(dfnbasis,nvbe,nbe)
|
|
real*8 quadb(nbe+nvbe+nal+nval,nquad),jaia(dfnbasis,nval,nal)
|
|
real*8 t2iabl(nval,nvbe,nbe),t2kbcl(nvbe*(nvbe-1)/2,nbe)
|
|
real*8 t2jbcl(nvbe*(nvbe-1)/2,nbe),t2jkad(nvbe,nvbe)
|
|
real*8 jabb(dfnbasis,nvbe,nvbe),abij(nval,nal,nvbe)
|
|
real*8 abc1(nvbe*(nvbe-1)/2,nvbe),abc1m(nval,nvbe,nval)
|
|
real*8 abcj(nvbe*(nvbe-1)/2,nvbe),abcjm(nval,nvbe,nval)
|
|
real*8 abcjbuffscr(max(nvbe**3,nval**2*nvbe)),abjk(nvbe,nvbe)
|
|
real*8,pointer::abcibuff(:,:,:),abci(:,:,:,:),abc1buff(:,:,:)
|
|
real*8,pointer::abcjbuff(:,:,:)
|
|
|
|
logical error,inmemorya(9),inmemoryb(9)
|
|
|
|
character*9 dfint_ija,dfint_ijb
|
|
c debug
|
|
real*8 etbba
|
|
c {{{ Interfaces for pointers
|
|
interface
|
|
subroutine rpoint2d(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
real*8,target :: egydim(dim1,dim2)
|
|
real*8, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
subroutine rpoint3d(egydim,haromdim,dim1,dim2,dim3)
|
|
implicit none
|
|
integer dim1,dim2,dim3
|
|
real*8,target :: egydim(dim1,dim2,dim3)
|
|
real*8, pointer :: haromdim(:,:,:)
|
|
end subroutine
|
|
subroutine rpoint4d(egydim,haromdim,dim1,dim2,dim3,dim4)
|
|
implicit none
|
|
integer dim1,dim2,dim3,dim4
|
|
real*8,target :: egydim(dim1,dim2,dim3,dim4)
|
|
real*8, pointer :: haromdim(:,:,:,:)
|
|
end subroutine
|
|
end interface
|
|
c }}}
|
|
|
|
c {{{ Pre loop
|
|
recln=nvbe**2*nval
|
|
reclnm=nval**2*nvbe
|
|
reciln=nvbe**2*(nvbe-1)/2
|
|
|
|
c Checking the allocated memory
|
|
if (nvbe**2*(nvbe-1)/2+nval**2*nvbe+recln.gt.
|
|
&maxcor-imem+imem1) then
|
|
|
|
write(*,*)
|
|
write(iout,*) 'Insufficient memory!'
|
|
write(iout,"(' Requested: ',f6.2,' GB')")
|
|
&dble((nvbe**2*(nvbe-1)/2+nval**2*nvbe+recln)*8)/1024**3
|
|
write(iout,"(' Available: ',f6.2,' GB')")
|
|
&dble((maxcor-imem+imem1)*8)/1024**3
|
|
write(*,*)
|
|
error=.true.
|
|
return
|
|
|
|
endif
|
|
|
|
c Loop for Laplace quadrature
|
|
c do q=1,nquad
|
|
call trf2laplbasisabb(nal,nbe,nval,nvbe,dfnbasis,q,nquad,cmoa,
|
|
&cmob,quada,quadb,jaba,jabb,jaia,jaib,fa,fb,ta1,tb1,tb2,tm2,vooo,
|
|
&voooab,voooba,dfint_ija,dfint_ijb,
|
|
&scr,inmemorya,inmemoryb,first_quad)
|
|
|
|
ni=(maxcor-imem+imem1)/recln
|
|
if (ni.gt.nal) then
|
|
ni=nal
|
|
iabcibuff=1+nval*nvbe**2*ni
|
|
call rpoint4d(scr,abci,nval,nvbe,nvbe,ni)
|
|
call rpoint3d(scr(iabcibuff),abcibuff,nvbe,nvbe,nval)
|
|
else
|
|
ni=ni-2
|
|
iabcibuff=1+nval*nvbe**2*(ni+1)
|
|
call rpoint4d(scr,abci,nval,nvbe,nvbe,ni+1)
|
|
call rpoint3d(scr(iabcibuff),abcibuff,nvbe,nvbe,nval)
|
|
endif
|
|
|
|
c Assemble <aB||i1>
|
|
call dgemm('t','n',nval*nal,nvbe,dfnbasis,1.d0,jaia,dfnbasis,
|
|
&jaib(1,1,1),dfnbasis,0.d0,abi1,nval*nal)
|
|
c Assemble <AB||C1>
|
|
call rpoint3d(scr,abc1buff,nvbe,nvbe,nvbe)
|
|
call dgemm('t','n',nvbe**2,nvbe,dfnbasis,1.d0,jabb,dfnbasis,
|
|
&jaib(1,1,1),dfnbasis,0.d0,abc1buff,nvbe**2)
|
|
do c=1,nvbe
|
|
lfc=quadb(nbe+c,q)
|
|
ab=1
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
abc1(ab,c)=(abc1buff(a,c,b)-abc1buff(b,c,a))/lfc
|
|
ab=ab+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c Assemble <aB||c1>
|
|
call rpoint3d(scr,abc1buff,nval,nval,nvbe)
|
|
call dgemm('t','n',nval**2,nvbe,dfnbasis,1.d0,jaba,dfnbasis,
|
|
&jaib(1,1,1),dfnbasis,0.d0,abc1buff,nval**2)
|
|
do c=1,nval
|
|
lfc=quada(nal+c,q)
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
abc1m(a,b,c)=abc1buff(a,c,b)/lfc
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c Assembling (\bar B C|\bar a\bar i') for ni blocks
|
|
do i=1,ni
|
|
call dgemm('t','n',nvbe**2,nval,dfnbasis,1.d0,jabb,dfnbasis,
|
|
&jaia(1,1,i),dfnbasis,0.d0,abcibuff,nvbe**2)
|
|
do c=1,nvbe
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
abci(a,b,c,i)=abcibuff(b,c,a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c Building t^K'_BCL'
|
|
t2kbcl(1:nvbe*(nvbe-1)/2,1)=0.d0
|
|
do l=2,nbe
|
|
t2kbcl(1:nvbe*(nvbe-1)/2,l)=
|
|
&-tb2(1:nvbe*(nvbe-1)/2,(l-1)*(l-2)/2+1) !placing -tbcjl instead of tbclj
|
|
enddo
|
|
c}}}
|
|
|
|
c {{{ Do i j
|
|
do j=2,nbe
|
|
jk=(j-1)*(j-2)/2+1
|
|
c Assemble <AB||CJ>
|
|
call rpoint3d(abcjbuffscr,abcjbuff,nvbe,nvbe,nvbe)
|
|
call dgemm('t','n',nvbe**2,nvbe,dfnbasis,1.d0,jabb,dfnbasis,
|
|
&jaib(1,1,j),dfnbasis,0.d0,abcjbuff,nvbe**2)
|
|
do c=1,nvbe
|
|
lfc=quadb(nbe+c,q)
|
|
ab=1
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
abcj(ab,c)=(abcjbuff(a,c,b)-abcjbuff(b,c,a))/lfc
|
|
ab=ab+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c Assemble <aB||cJ>
|
|
call rpoint3d(abcjbuffscr,abcjbuff,nval,nval,nvbe)
|
|
call dgemm('t','n',nval**2,nvbe,dfnbasis,1.d0,jaba,dfnbasis,
|
|
&jaib(1,1,j),dfnbasis,0.d0,abcjbuff,nval**2)
|
|
do c=1,nval
|
|
lfc=quada(nal+c,q)
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
abcjm(a,b,c)=abcjbuff(a,c,b)/lfc
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c Building t^J'_BCL'
|
|
t2jbcl(1:nvbe*(nvbe-1)/2,j)=0.d0
|
|
do l=1,nbe
|
|
if (l.gt.j) then
|
|
t2jbcl(1:nvbe*(nvbe-1)/2,l)=
|
|
&-tb2(1:nvbe*(nvbe-1)/2,(l-1)*(l-2)/2+j) !placing -tbcjl instead of tbclj
|
|
elseif (l.lt.j) then
|
|
t2jbcl(1:nvbe*(nvbe-1)/2,l)=
|
|
&tb2(1:nvbe*(nvbe-1)/2,(j-1)*(j-2)/2+l)
|
|
endif
|
|
enddo
|
|
c Building t^J'K'_\bar AD
|
|
ad=1
|
|
do d=1,nvbe
|
|
t2jkad(d,d)=0.d0
|
|
do a=1,d-1
|
|
t2jkad(a,d)=tb2(ad,jk)/quadb(nbe+d,q)
|
|
t2jkad(d,a)=-tb2(ad,jk)/quadb(nbe+a,q)
|
|
ad=ad+1
|
|
enddo
|
|
enddo
|
|
c Building <AB||JK>
|
|
call dgemm('t','n',nvbe,nvbe,dfnbasis,1.d0,jaib(1,1,j),dfnbasis,
|
|
&jaib(1,1,1),dfnbasis,0.d0,abjk,nvbe)
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
abjk(a,b)=abjk(a,b)-abjk(b,a)
|
|
enddo
|
|
enddo
|
|
c Assemble <aB||iJ>
|
|
call dgemm('t','n',nval*nal,nvbe,dfnbasis,1.d0,jaia,dfnbasis,
|
|
&jaib(1,1,j),dfnbasis,0.d0,abij,nval*nal)
|
|
|
|
do i=1,nal
|
|
ik=i
|
|
ki=(i-1)*nbe+1
|
|
ij=(j-1)*nal+i
|
|
ji=(i-1)*nbe+j
|
|
ii=i
|
|
if (i.gt.ni) then
|
|
ii=ni+1
|
|
c Assembling (\bar B C|\bar a\bar i') for one i
|
|
call dgemm('t','n',nvbe**2,nval,dfnbasis,1.d0,jabb,dfnbasis,
|
|
&jaia(1,1,i),dfnbasis,0.d0,abcibuff,nvbe**2)
|
|
do c=1,nvbe
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
abci(a,b,c,ni+1)=abcibuff(b,c,a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
c Build t^i'_aBL
|
|
do l=1,nbe
|
|
t2iabl(1:nval,1:nvbe,l)=
|
|
&tm2(1:nval,1:nvbe,i,l)
|
|
enddo
|
|
c }}}
|
|
|
|
icurrent = icurrent + 1
|
|
if (icurrent.le.irest) cycle
|
|
|
|
c Building T,W
|
|
call tbbabuild(nal,nbe,nval,nvbe,i,j,ij,ik,jk,fa,fb,ta1,tb1,
|
|
&tb2,tm2,t2kbcl,t2jbcl,t2jkad,t2iabl,t,w,ts,abci(1,1,1,ii),abcj,
|
|
&abc1,abcjm,abc1m,vooo,voooab,voooba,abjk,abi1,abij)
|
|
|
|
et=et-(1.d0/3.d0)*ddot(nval*nvbe*(nvbe-1)/2,t,1,w,1)
|
|
call managerestart('w','(t)2',-1,scr,scr,scr,et,scr,scr,scr,scr,
|
|
& scr,icurrent,0,0,0,0,scr,ied)
|
|
enddo
|
|
enddo
|
|
c Monitoring percentage
|
|
pr=icurrent
|
|
if (dble(pr).ge.dble(prold)+0.25d0*dble(total).and.pr.ne.total)
|
|
&then
|
|
write(iout,"(i4,'% done.')") int(100.d0*dble(pr)/dble(total))
|
|
prold=pr
|
|
endif
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine tbbabuild(nal,nbe,nval,nvbe,i,j,ij,ik,jk,fa,fb,ta1,tb1,
|
|
&tb2,tm2,t2kbcl,t2jbcl,t2jkad,t2iabl,t,w,ts,abcii,abcibetaj,
|
|
&abcibetak,abcimixedj,abcimixedk,vooo,voooab,voooba,abjk,abi1,abij)
|
|
************************************************************************
|
|
implicit none
|
|
|
|
integer nal,nbe,nval,nvbe,i,j,ef,cd,ab,a,b,c,abc,bc,ac,ij,ik,jk
|
|
|
|
real*8 tm2(nval*nvbe,nal*nbe),abcibetaj(nvbe**2*(nvbe-1)/2)
|
|
real*8 abcibetak(nvbe**2*(nvbe-1)/2),abcimixedj(nval**2*nvbe)
|
|
real*8 abcimixedk(nval**2*nvbe)
|
|
real*8 t(nval*nvbe*(nvbe-1)/2)
|
|
real*8 w(nval*nvbe*(nvbe-1)/2),ts(nval,nvbe,nvbe),ta1(nval,nal)
|
|
real*8 voooab(nval,nbe,nal,nbe),tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2)
|
|
real*8 vooo(nvbe,nbe,nbe*(nbe-1)/2),voooba(nvbe,nal,nbe,nal)
|
|
real*8 tb1(nvbe,nbe),abcii(nval,nvbe,nvbe)
|
|
real*8 fa(nval+nal,nval+nal)
|
|
real*8 fb(nvbe+nbe,nvbe+nbe)
|
|
real*8 abjk(nvbe,nvbe)
|
|
real*8 t2kbcl(nvbe*(nvbe-1)/2,nbe),t2jkad(nvbe,nvbe)
|
|
real*8 t2jbcl(nvbe*(nvbe-1)/2,nbe),t2iabl(nval,nvbe,nbe)
|
|
real*8 abi1(nval,nal,nvbe),abij(nval,nal,nvbe)
|
|
|
|
cd=nval*nvbe
|
|
ef=nvbe*(nvbe-1)/2
|
|
|
|
c Calculating tabb
|
|
call dgemm('n','t',nval,ef,nvbe,-1.d0,tm2(1,ik),
|
|
&nval,abcibetaj,ef,0.d0,t,nval)
|
|
c vvvob k
|
|
call dgemm('n','t',nval,ef,nvbe,1.d0,tm2(1,ij),nval,
|
|
&abcibetak,ef,1.d0,t,nval)
|
|
c vvvoba i
|
|
call dgemm('n','t',cd,nvbe,nvbe,1.d0,
|
|
&abcii,cd,t2jkad,
|
|
&nvbe,0.d0,ts,cd)
|
|
c vvvoab j
|
|
call dgemm('n','n',cd,nvbe,nval,1.d0,
|
|
&abcimixedj,cd,tm2(1,ik),nval,1.d0,
|
|
&ts,cd)
|
|
c vvvoab k
|
|
call dgemm('n','n',cd,nvbe,nval,-1.d0,
|
|
&abcimixedk,cd,tm2(1,ij),nval,1.d0,
|
|
&ts,cd)
|
|
|
|
c vooo
|
|
call dgemm('n','t',nval,ef,nbe,1.d0,
|
|
&voooab(1,1,i,1),nval,
|
|
&t2jbcl,ef,1.d0,t,nval)
|
|
|
|
call dgemm('n','t',nval,ef,nbe,-1.d0,
|
|
&voooab(1,1,i,j),nval,
|
|
&t2kbcl,ef,1.d0,t,nval)
|
|
|
|
call dgemm('n','t',cd,nvbe,nbe,-1.d0,
|
|
&t2iabl,cd,vooo(1,1,jk),nvbe,1.d0,ts,cd)
|
|
|
|
call dgemm('n','t',cd,nvbe,nal,-1.d0,tm2(1,(j-1)*nal+1),
|
|
&cd,voooba(1,1,1,i),nvbe,1.d0,ts,cd)
|
|
|
|
call dgemm('n','t',cd,nvbe,nal,1.d0,tm2(1,1),
|
|
&cd,voooba(1,1,j,i),nvbe,1.d0,ts,cd)
|
|
|
|
c
|
|
C$OMP PARALLEL DO Schedule(Dynamic) Default(Shared)
|
|
C$OMP& PRIVATE(abc,a,b,c,ac,ab,bc)
|
|
do c=1,nvbe
|
|
do b=1,c-1
|
|
bc=(c-1)*(c-2)/2+b
|
|
do a=1,nval
|
|
ab=(b-1)*nval+a
|
|
ac=(c-1)*nval+a
|
|
abc=((c-1)*(c-2)/2+b-1)*nval+a
|
|
|
|
t(abc)=t(abc)+ts(a,b,c)-ts(a,c,b)
|
|
|
|
c W(a,b,b)
|
|
c ROHF
|
|
w(abc)=t(abc)
|
|
&+abjk(b,c)*ta1(a,i)
|
|
&+abi1(a,i,c)*tb1(b,j)
|
|
&-abij(a,i,c)*tb1(b,1)
|
|
&-abi1(a,i,b)*tb1(c,j)
|
|
&+abij(a,i,b)*tb1(c,1)
|
|
|
|
&-tb2(bc,jk)*fa(a+nal,i)
|
|
&+tm2(ac,ik)*fb(b+nbe,j)
|
|
&-tm2(ac,ij)*fb(b+nbe,1)
|
|
&-tm2(ab,ik)*fb(c+nbe,j)
|
|
&+tm2(ab,ij)*fb(c+nbe,1)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
|
|
return
|
|
end subroutine
|
|
************************************************************************
|
|
subroutine tabbbuild(nal,nbe,nval,nvbe,j,k,ij,ik,jk,fa,fb,
|
|
&ta1,tb1,
|
|
&tb2,tm2,t2iabl,t2kbcl,t2jbcl,t2jkad,
|
|
&t,w,ts,abcii,abcibetaj,
|
|
&abcibetak,abcimixedj,abcimixedk,vooo,voooab,voooba,abjk,ab1j)
|
|
************************************************************************
|
|
implicit none
|
|
|
|
integer nal,nbe,nval,nvbe,j,k,ef,cd,ab,a,b,c,abc,bc,ac,ij,ik,jk
|
|
|
|
real*8 tm2(nval*nvbe,nal*nbe),abcibetaj(nvbe**2*(nvbe-1)/2)
|
|
real*8 abcibetak(nvbe**2*(nvbe-1)/2),abcimixedj(nval**2*nvbe)
|
|
real*8 abcimixedk(nval**2*nvbe),ab1j(nvbe,nbe,nval)
|
|
real*8 t(nval*nvbe*(nvbe-1)/2)
|
|
real*8 w(nval*nvbe*(nvbe-1)/2),ts(nval,nvbe,nvbe),ta1(nval,nal)
|
|
real*8 voooab(nval,nbe,nal,nbe),tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2)
|
|
real*8 vooo(nvbe,nbe,nbe*(nbe-1)/2),voooba(nvbe,nal,nbe,nal)
|
|
real*8 tb1(nvbe,nbe)
|
|
real*8 fa(nval+nal,nval+nal)
|
|
real*8 fb(nvbe+nbe,nvbe+nbe)
|
|
real*8 abcii(nval*nvbe**2)
|
|
real*8 t2iabl(nval,nvbe,nbe)
|
|
real*8 t2kbcl(nvbe*(nvbe-1)/2,nbe),t2jbcl(nvbe*(nvbe-1)/2,nbe)
|
|
real*8 t2jkad(nvbe,nvbe),abjk(nvbe,nvbe)
|
|
|
|
cd=nval*nvbe
|
|
ef=nvbe*(nvbe-1)/2
|
|
|
|
c Calculating tabb
|
|
call dgemm('n','t',nval,ef,nvbe,-1.d0,tm2(1,ik),
|
|
&nval,abcibetaj,ef,0.d0,t,nval)
|
|
cc vvvob k
|
|
call dgemm('n','t',nval,ef,nvbe,1.d0,tm2(1,ij),nval,
|
|
&abcibetak,ef,1.d0,t,nval)
|
|
cc vvvoba i
|
|
call dgemm('n','t',cd,nvbe,nvbe,-1.d0,
|
|
&abcii,cd,t2jkad,nvbe,0.d0,ts,cd)
|
|
c vvvoab j
|
|
call dgemm('n','n',cd,nvbe,nval,1.d0,
|
|
&abcimixedj,cd,tm2(1,ik),nval,1.d0,ts,cd)
|
|
c vvvoab k
|
|
call dgemm('n','n',cd,nvbe,nval,-1.d0,
|
|
&abcimixedk,cd,tm2(1,ij),nval,1.d0,ts,cd)
|
|
|
|
c vooo
|
|
c debug
|
|
call dgemm('n','t',nval,ef,nbe,1.d0,
|
|
&voooab(1,1,1,k),nval,
|
|
&t2jbcl,ef,1.d0,t,nval)
|
|
|
|
call dgemm('n','t',nval,ef,nbe,-1.d0,
|
|
&voooab(1,1,1,j),nval,t2kbcl,ef,1.d0,t,nval)
|
|
|
|
call dgemm('n','t',cd,nvbe,nbe,1.d0,
|
|
&t2iabl,cd,vooo(1,1,jk),nvbe,1.d0,ts,cd)
|
|
|
|
call dgemm('n','t',cd,nvbe,nal,-1.d0,tm2(1,(j-1)*nal+1),
|
|
&cd,voooba(1,1,k,1),nvbe,1.d0,ts,cd)
|
|
|
|
call dgemm('n','t',cd,nvbe,nal,1.d0,tm2(1,(k-1)*nal+1),
|
|
&cd,voooba(1,1,j,1),nvbe,1.d0,ts,cd)
|
|
|
|
c
|
|
C$OMP PARALLEL DO Schedule(Dynamic) Default(Shared)
|
|
C$OMP& PRIVATE(abc,a,b,c,ac,ab,bc)
|
|
do c=1,nvbe
|
|
do b=1,c-1
|
|
bc=(c-1)*(c-2)/2+b
|
|
do a=1,nval
|
|
ab=(b-1)*nval+a
|
|
ac=(c-1)*nval+a
|
|
abc=((c-1)*(c-2)/2+b-1)*nval+a
|
|
|
|
t(abc)=t(abc)+ts(a,b,c)-ts(a,c,b)
|
|
|
|
c W(a,b,b)
|
|
c ROHF
|
|
w(abc)=t(abc)
|
|
&+abjk(b,c)*ta1(a,1)
|
|
&+ab1j(c,k,a)*tb1(b,j)
|
|
&-ab1j(c,j,a)*tb1(b,k)
|
|
&-ab1j(b,k,a)*tb1(c,j)
|
|
&+ab1j(b,j,a)*tb1(c,k)
|
|
|
|
&+tb2(bc,jk)*fa(a+nal,1)
|
|
&+tm2(ac,ik)*fb(b+nbe,j)
|
|
&-tm2(ac,ij)*fb(b+nbe,k)
|
|
&-tm2(ab,ik)*fb(c+nbe,j)
|
|
&+tm2(ab,ij)*fb(c+nbe,k)
|
|
|
|
|
|
c t(abc)=t(abc)/(fa(i,i)+fb(j,j)+fb(k,k)
|
|
c &-fa(a+nal,a+nal)-fb(b+nbe,b+nbe)-fb(c+nbe,c+nbe))
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
|
|
return
|
|
end subroutine
|
|
|
|
subroutine tabbextract(t3,nal,nbe,nval,nvbe,fullt3)
|
|
|
|
implicit none
|
|
integer nal,nbe,nvbe,nval,i,k,j,jk
|
|
real*8 t3(nval*nvbe*(nvbe-1)/2,nbe*(nbe-1)/2,nal)
|
|
real*8 fullt3(nval*nvbe*(nvbe-1)/2,nbe,nbe,nal)
|
|
|
|
do i=1,nal
|
|
jk=1
|
|
do k=1,nbe
|
|
fullt3(1:nval*nvbe*(nvbe-1)/2,k,k,i)=0.d0
|
|
do j=1,k-1
|
|
fullt3(1:nval*nvbe*(nvbe-1)/2,j,k,i)=
|
|
&t3(1:nval*nvbe*(nvbe-1)/2,jk,i)
|
|
fullt3(1:nval*nvbe*(nvbe-1)/2,k,j,i)=
|
|
&-t3(1:nval*nvbe*(nvbe-1)/2,jk,i)
|
|
jk=jk+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine tabbbuildcim(nal,nbe,nval,nvbe,i,j,k,ij,ik,jk,fa,fb,
|
|
&ta1,tb1,
|
|
&tb2,tm2,
|
|
&t2list1,
|
|
&t2list2,tm2list,t,w,ts,abcii,abcibetaj,
|
|
&abcibetak,abcimixedj,abcimixedk,vooo,voooab,voooba,vvoo,vvooab)
|
|
************************************************************************
|
|
implicit none
|
|
|
|
integer nal,nbe,nval,nvbe,i,j,k,ef,cd,ab,a,b,c,abc,bc,ac,ij,ik,jk
|
|
|
|
real*8 tm2(nval*nvbe,nal*nbe),abcibetaj(nvbe**2*(nvbe-1)/2)
|
|
real*8 abcibetak(nvbe**2*(nvbe-1)/2),abcimixedj(nval**2*nvbe)
|
|
real*8 abcimixedk(nval**2*nvbe),t2list1(nvbe,nvbe,nbe*(nbe-1)/2)
|
|
real*8 t2list2(nvbe*(nvbe-1)/2,nbe,nbe),t(nval*nvbe*(nvbe-1)/2)
|
|
real*8 w(nval*nvbe*(nvbe-1)/2),ts(nval,nvbe,nvbe),ta1(nval,nal)
|
|
real*8 voooab(nval,nbe,nal,nbe),tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2)
|
|
real*8 vooo(nvbe,nbe,nbe*(nbe-1)/2),voooba(nvbe,nal,nbe,nal)
|
|
real*8 vvoo(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),tb1(nvbe,nbe)
|
|
real*8 vvooab(nval,nvbe,nal,nbe),fa(nval+nal,nval+nal)
|
|
real*8 fb(nvbe+nbe,nvbe+nbe),tm2list(nval,nvbe,nbe,nal)
|
|
real*8 abcii(nval*nvbe**2)
|
|
|
|
cd=nval*nvbe
|
|
ef=nvbe*(nvbe-1)/2
|
|
|
|
c Calculating tabb
|
|
call dgemm('n','t',nval,ef,nvbe,-1.d0,tm2(1,ik),
|
|
c &nval,abcibeta(1,jj),ef,0.d0,t,nval)
|
|
&nval,abcibetaj,ef,0.d0,t,nval)
|
|
ccc vvvob k
|
|
call dgemm('n','t',nval,ef,nvbe,1.d0,tm2(1,ij),nval,
|
|
c &abcibeta(1,kk),ef,1.d0,t,nval)
|
|
&abcibetak,ef,1.d0,t,nval)
|
|
ccc vvvoba i
|
|
call dgemm('n','t',cd,nvbe,nvbe,-1.d0,
|
|
&abcii,cd,t2list1(1,1,jk),
|
|
&nvbe,0.d0,ts,cd)
|
|
cc vvvoab j
|
|
call dgemm('n','n',cd,nvbe,nval,1.d0,
|
|
c &abcimixed(1,jj),cd,tm2(1,ik),nval,1.d0,
|
|
&abcimixedj,cd,tm2(1,ik),nval,1.d0,
|
|
&ts,cd)
|
|
c vvvoab k
|
|
call dgemm('n','n',cd,nvbe,nval,-1.d0,
|
|
c &abcimixed(1,kk),cd,tm2(1,ij),nval,1.d0,
|
|
&abcimixedk,cd,tm2(1,ij),nval,1.d0,
|
|
&ts,cd)
|
|
|
|
c vooo
|
|
c debug
|
|
call dgemm('n','t',nval,ef,nbe,1.d0,
|
|
&voooab(1,1,i,k),nval,
|
|
&t2list2(1,1,j),ef,1.d0,t,nval)
|
|
|
|
call dgemm('n','t',nval,ef,nbe,-1.d0,
|
|
&voooab(1,1,i,j),nval,
|
|
&t2list2(1,1,k),ef,1.d0,t,nval)
|
|
|
|
call dgemm('n','t',cd,nvbe,nbe,1.d0,
|
|
&tm2list(1,1,1,i),cd,
|
|
&vooo(1,1,jk),nvbe,1.d0,ts,cd)
|
|
|
|
call dgemm('n','t',cd,nvbe,nal,-1.d0,tm2(1,(j-1)*nal+1),
|
|
&cd,voooba(1,1,k,i),nvbe,1.d0,ts,cd)
|
|
|
|
call dgemm('n','t',cd,nvbe,nal,1.d0,tm2(1,(k-1)*nal+1),
|
|
&cd,voooba(1,1,j,i),nvbe,1.d0,ts,cd)
|
|
|
|
c
|
|
C$OMP PARALLEL DO Schedule(Dynamic) Default(Shared)
|
|
C$OMP& PRIVATE(abc,a,b,c,ac,ab,bc)
|
|
do c=1,nvbe
|
|
do b=1,c-1
|
|
bc=(c-1)*(c-2)/2+b
|
|
do a=1,nval
|
|
ab=(b-1)*nval+a
|
|
ac=(c-1)*nval+a
|
|
abc=((c-1)*(c-2)/2+b-1)*nval+a
|
|
|
|
t(abc)=t(abc)+ts(a,b,c)-ts(a,c,b)
|
|
|
|
c W(a,b,b)
|
|
c ROHF
|
|
w(abc)=t(abc)
|
|
&+vvoo(bc,jk)*ta1(a,i)
|
|
&+vvooab(a,c,i,k)*tb1(b,j)
|
|
&-vvooab(a,c,i,j)*tb1(b,k)
|
|
&-vvooab(a,b,i,k)*tb1(c,j)
|
|
&+vvooab(a,b,i,j)*tb1(c,k)
|
|
|
|
&+tb2(bc,jk)*fa(a+nal,i)
|
|
&+tm2(ac,ik)*fb(b+nbe,j)
|
|
&-tm2(ac,ij)*fb(b+nbe,k)
|
|
&-tm2(ab,ik)*fb(c+nbe,j)
|
|
&+tm2(ab,ij)*fb(c+nbe,k)
|
|
|
|
t(abc)=t(abc)/(fa(i,i)+fb(j,j)+fb(k,k)
|
|
&-fa(a+nal,a+nal)-fb(b+nbe,b+nbe)-fb(c+nbe,c+nbe))
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
|
|
return
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine tbbabuildcim(nal,nbe,nval,nvbe,i,j,k,ij,ik,jk,djk,fa,
|
|
&fb,
|
|
&ta1,tb1,
|
|
&tb2,tm2,
|
|
&t2list1,
|
|
&t2list2,tm2list,t,w,ts,abcii,abcibetaj,
|
|
&abcibetak,abcimixedj,abcimixedk,vooo,voooab,voooba,vvoo,vvooab)
|
|
************************************************************************
|
|
implicit none
|
|
|
|
integer nal,nbe,nval,nvbe,i,j,k,ef,cd,ab,a,b,c,abc,bc,ac,ij,ik,jk
|
|
|
|
real*8 tm2(nval*nvbe,nal*nbe),abcibetaj(nvbe**2*(nvbe-1)/2)
|
|
real*8 abcibetak(nvbe**2*(nvbe-1)/2),abcimixedj(nval**2*nvbe)
|
|
real*8 abcimixedk(nval**2*nvbe),t2list1(nvbe,nvbe,nbe*(nbe-1)/2)
|
|
real*8 t2list2(nvbe*(nvbe-1)/2,nbe,nbe),t(nval*nvbe*(nvbe-1)/2)
|
|
real*8 w(nval*nvbe*(nvbe-1)/2),ts(nval,nvbe,nvbe),ta1(nval,nal)
|
|
real*8 voooab(nval,nbe,nal,nbe),tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2)
|
|
real*8 vooo(nvbe,nbe,nbe*(nbe-1)/2),voooba(nvbe,nal,nbe,nal)
|
|
real*8 vvoo(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),tb1(nvbe,nbe)
|
|
real*8 vvooab(nval,nvbe,nal,nbe),fa(nval+nal,nval+nal)
|
|
real*8 fb(nvbe+nbe,nvbe+nbe),tm2list(nval,nvbe,nbe,nal)
|
|
real*8 abcii(nval*nvbe**2),djk
|
|
|
|
cd=nval*nvbe
|
|
ef=nvbe*(nvbe-1)/2
|
|
|
|
c Calculating tabb
|
|
call dgemm('n','t',nval,ef,nvbe,-1.d0,tm2(1,ik),
|
|
c &nval,abcibeta(1,jj),ef,0.d0,t,nval)
|
|
&nval,abcibetaj,ef,0.d0,t,nval)
|
|
ccc vvvob k
|
|
call dgemm('n','t',nval,ef,nvbe,1.d0,tm2(1,ij),nval,
|
|
c &abcibeta(1,kk),ef,1.d0,t,nval)
|
|
&abcibetak,ef,1.d0,t,nval)
|
|
ccc vvvoba i
|
|
call dgemm('n','t',cd,nvbe,nvbe,-djk,
|
|
&abcii,cd,t2list1(1,1,jk),
|
|
&nvbe,0.d0,ts,cd)
|
|
cc vvvoab j
|
|
call dgemm('n','n',cd,nvbe,nval,1.d0,
|
|
c &abcimixed(1,jj),cd,tm2(1,ik),nval,1.d0,
|
|
&abcimixedj,cd,tm2(1,ik),nval,1.d0,
|
|
&ts,cd)
|
|
c vvvoab k
|
|
call dgemm('n','n',cd,nvbe,nval,-1.d0,
|
|
c &abcimixed(1,kk),cd,tm2(1,ij),nval,1.d0,
|
|
&abcimixedk,cd,tm2(1,ij),nval,1.d0,
|
|
&ts,cd)
|
|
|
|
c vooo
|
|
c debug
|
|
call dgemm('n','t',nval,ef,nbe,1.d0,
|
|
&voooab(1,1,i,k),nval,
|
|
&t2list2(1,1,j),ef,1.d0,t,nval)
|
|
|
|
call dgemm('n','t',nval,ef,nbe,-1.d0,
|
|
&voooab(1,1,i,j),nval,
|
|
&t2list2(1,1,k),ef,1.d0,t,nval)
|
|
|
|
call dgemm('n','t',cd,nvbe,nbe,djk,
|
|
&tm2list(1,1,1,i),cd,
|
|
&vooo(1,1,jk),nvbe,1.d0,ts,cd)
|
|
|
|
call dgemm('n','t',cd,nvbe,nal,-1.d0,tm2(1,(j-1)*nal+1),
|
|
&cd,voooba(1,1,k,i),nvbe,1.d0,ts,cd)
|
|
|
|
call dgemm('n','t',cd,nvbe,nal,1.d0,tm2(1,(k-1)*nal+1),
|
|
&cd,voooba(1,1,j,i),nvbe,1.d0,ts,cd)
|
|
|
|
c
|
|
C$OMP PARALLEL DO Schedule(Dynamic) Default(Shared)
|
|
C$OMP& PRIVATE(abc,a,b,c,ac,ab,bc)
|
|
do c=1,nvbe
|
|
do b=1,c-1
|
|
bc=(c-1)*(c-2)/2+b
|
|
do a=1,nval
|
|
ab=(b-1)*nval+a
|
|
ac=(c-1)*nval+a
|
|
abc=((c-1)*(c-2)/2+b-1)*nval+a
|
|
|
|
t(abc)=t(abc)+ts(a,b,c)-ts(a,c,b)
|
|
|
|
c W(a,b,b)
|
|
c ROHF
|
|
w(abc)=t(abc)
|
|
&+djk*vvoo(bc,jk)*ta1(a,i)
|
|
&+vvooab(a,c,i,k)*tb1(b,j)
|
|
&-vvooab(a,c,i,j)*tb1(b,k)
|
|
&-vvooab(a,b,i,k)*tb1(c,j)
|
|
&+vvooab(a,b,i,j)*tb1(c,k)
|
|
|
|
&+djk*tb2(bc,jk)*fa(a+nal,i)
|
|
&+tm2(ac,ik)*fb(b+nbe,j)
|
|
&-tm2(ac,ij)*fb(b+nbe,k)
|
|
&-tm2(ab,ik)*fb(c+nbe,j)
|
|
&+tm2(ab,ij)*fb(c+nbe,k)
|
|
|
|
t(abc)=t(abc)/(fa(i,i)+fb(j,j)+fb(k,k)
|
|
&-fa(a+nal,a+nal)-fb(b+nbe,b+nbe)-fb(c+nbe,c+nbe))
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
|
|
return
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine wabefbld(nal,nval,nfa,faadr,recaadr,ta1,newta1,ta2,
|
|
&newta2,faae,scr,iabc,abcd,irecln,ccsdalg,dfnbasis,dfint_ab,qscale,
|
|
&tscalea,epaa,eccs,eccp,abijaa,fa,eppl,eppl_ss,eppls_ss,epplij,
|
|
$lmp3)
|
|
************************************************************************
|
|
|
|
c Builds and contracts the Wabef intermediate, contracts some iabc terms
|
|
|
|
implicit none
|
|
|
|
integer k,f0,fx,ma,ab,nblc,ef,nal,nval,faadr(nfa+1),ipuff,i,eftile
|
|
integer recaadr(nfa*(nfa+1)/2),abef,nfa,efln,irecln,ij,off
|
|
integer dfnbasis,jaabsize,blocksize,f,fmax,finblock,b,e,efind
|
|
integer abind,a,ae,be
|
|
real*8 newta2(nval*(nval-1)/2,nal*(nal-1)/2),tscalea(nal),fa,eppl
|
|
real*8 faae(nval,nval),ta1(nval,nal),newta1(nval,nal),eccs,eccp
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),scr(*),epaa(nal,nal)
|
|
real*8 eppl_ss,eppls_ss,epplc,eccsc,epplij
|
|
real*8,pointer::jaab(:,:),block(:,:),pabef(:,:),jaabb(:,:)
|
|
character*6 iabc,abijaa
|
|
character*5 abcd
|
|
character*8 ccsdalg
|
|
character*9 dfint_ab
|
|
logical qscale,lmp3
|
|
|
|
c {{{ Interface for pointer
|
|
interface
|
|
subroutine rpoint2d(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
real*8,target :: egydim(dim1,dim2)
|
|
real*8, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
end interface
|
|
c }}}
|
|
|
|
open(16,file=iabc,form='unformatted')
|
|
open(17,file=abcd,access='direct',recl=irecln)
|
|
|
|
ma=nval*nal
|
|
ab=nval*(nval-1)/2
|
|
|
|
c Read Jab
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
jaabsize=nval*(nval+1)*dfnbasis/2
|
|
open(18,file=trim(dfint_ab),form='unformatted')
|
|
read(18) scr(1:jaabsize)
|
|
close(18)
|
|
call rpoint2d(scr,jaab,dfnbasis,nval*(nval+1)/2)
|
|
else
|
|
jaabsize=0
|
|
endif
|
|
|
|
do k=1,nfa
|
|
f0=faadr(k)
|
|
fx=faadr(k+1)-faadr(k)
|
|
fmax=faadr(k+1)-1
|
|
|
|
nblc=(2*f0+fx-3)*fx/2
|
|
blocksize=ab*nblc
|
|
if (nblc.gt.0) then
|
|
|
|
c Reading abcdaa
|
|
ipuff=jaabsize+ma*nblc+ab*nblc+1
|
|
abef=1
|
|
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
call rpoint2d(scr(jaabsize+ma*nblc+1),block,ab,nblc)
|
|
call rpoint2d(scr(ipuff),pabef,nval*(nval+1)/2,nval)
|
|
call rpoint2d(scr(ipuff+nval**2*(nval+1)/2),jaabb,dfnbasis,nval)
|
|
do f=f0,fmax
|
|
finblock=f-faadr(k)+1
|
|
do b=1,nval
|
|
if (b.le.f) then
|
|
jaabb(1:dfnbasis,b)=jaab(1:dfnbasis,f*(f-1)/2+b)
|
|
else
|
|
jaabb(1:dfnbasis,b)=jaab(1:dfnbasis,b*(b-1)/2+f)
|
|
endif
|
|
enddo
|
|
call dgemm('t','n',nval*(nval+1)/2,nval,dfnbasis,1.d0,jaab,
|
|
& dfnbasis,jaabb,dfnbasis,0.d0,
|
|
& pabef,nval*(nval+1)/2)
|
|
do e=1,f-1
|
|
efind=(2*f0+finblock-4)*(finblock-1)/2+e
|
|
abind=0
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
abind=abind+1
|
|
c Coulomb
|
|
if (a.le.e) then
|
|
ae=e*(e-1)/2+a
|
|
else
|
|
ae=a*(a-1)/2+e
|
|
endif
|
|
c Exchange
|
|
if (b.le.e) then
|
|
be=e*(e-1)/2+b
|
|
else
|
|
be=b*(b-1)/2+e
|
|
endif
|
|
block(abind,efind)=pabef(ae,b)-pabef(be,a)
|
|
enddo !a
|
|
enddo !b
|
|
enddo !e
|
|
enddo !f
|
|
else !ccsdalg.ne.dfdirect
|
|
do i=1,k-1
|
|
call getlst(17,recaadr(k*(k-1)/2+i),scr(ipuff),
|
|
& eftile(i,k,faadr,nfa))
|
|
|
|
call abcd1(scr(ipuff),efln(i,faadr,nfa),efln(k,faadr,nfa),
|
|
& scr(jaabsize+ma*nblc+1),nval*(nval-1)/2,efln(k,faadr,nfa),abef)
|
|
|
|
abef=abef+efln(i,faadr,nfa)
|
|
enddo
|
|
|
|
call getlst(17,recaadr(k*(k-1)/2+k),scr(ipuff),
|
|
& (efln(k,faadr,nfa)+1)*efln(k,faadr,nfa)/2)
|
|
|
|
call abcd2(scr(ipuff),efln(k,faadr,nfa),efln(k,faadr,nfa),
|
|
& scr(jaabsize+ma*nblc+1),nval*(nval-1)/2,efln(k,faadr,nfa),abef)
|
|
|
|
abef=abef+efln(k,faadr,nfa)
|
|
|
|
do i=k+1,nfa
|
|
call getlst(17,recaadr(i*(i-1)/2+k),scr(ipuff),
|
|
& eftile(k,i,faadr,nfa))
|
|
|
|
call abcd3(scr(ipuff),efln(k,faadr,nfa),efln(i,faadr,nfa),
|
|
& scr(jaabsize+ma*nblc+1),nval*(nval-1)/2,efln(k,faadr,nfa),abef)
|
|
|
|
abef=abef+efln(i,faadr,nfa)
|
|
enddo
|
|
endif !ccsdalg
|
|
|
|
if(qscale) then
|
|
open(543,file='UCCSD_RES',form='unformatted')
|
|
write(543) newta2
|
|
ij=nal*(nal-1)/2
|
|
call taubldefabcd(ta2,ta1,nval,nval,nal,nal,f0,fx,nblc,
|
|
&scr(jaabsize+nblc*ma+blocksize+1))
|
|
if(ij.gt.0)
|
|
& call dgemm('n','n',ab,ij,nblc,1.d0,scr(jaabsize+nblc*ma+1),ab,
|
|
&scr(jaabsize+nblc*ma+blocksize+1),nblc,0.d0,newta2,ab)
|
|
call scaleppl_aa(nal,nval,fa,newta2,
|
|
$scr(jaabsize+nblc*ma+blocksize+1),tscalea,epaa,eccs,eccp,abijaa,
|
|
$eppl,epplc,eccsc,epaa,epplij)
|
|
eppl_ss=eppl_ss+epplc
|
|
eppls_ss=eppls_ss+eccsc
|
|
rewind(543)
|
|
read(543) newta2
|
|
close(543)
|
|
endif
|
|
|
|
if(.not.lmp3) then
|
|
do ef=1,nblc
|
|
read(16) scr(jaabsize+(ef-1)*ma+1:jaabsize+ef*ma)
|
|
enddo
|
|
|
|
if (nal.gt.0) then
|
|
call dgemm('n','n',nval,nval*nblc,nal,-1.d0,ta1,nval,
|
|
&scr(jaabsize+1),nal,0.d0,scr(jaabsize+nblc*ma+blocksize+1),nval)
|
|
endif
|
|
|
|
call baeffold(scr(jaabsize+nblc*ma+blocksize+1),nval,nval,nblc,
|
|
&scr(jaabsize+nblc*ma+1))
|
|
end if
|
|
|
|
c newta2 (2)/5
|
|
ij=nal*(nal-1)/2
|
|
|
|
call taubldefabcd(ta2,ta1,nval,nval,nal,nal,f0,fx,nblc,
|
|
&scr(jaabsize+nblc*ma+blocksize+1))
|
|
|
|
if (ij.gt.0) then
|
|
call dgemm('n','n',ab,ij,nblc,1.d0,scr(jaabsize+nblc*ma+1),ab,
|
|
&scr(jaabsize+nblc*ma+blocksize+1),nblc,1.d0,newta2,ab)
|
|
endif
|
|
|
|
if(.not.lmp3) then
|
|
|
|
c newta1 (1)/6
|
|
call maefinp(scr(jaabsize+1),nal,nval,nblc,
|
|
&scr(jaabsize+ma*nblc+1))
|
|
|
|
call efmiexp(ta2,nval,nval,nal,nal,f0,fx,nblc,
|
|
&scr(jaabsize+ma*nblc+1))
|
|
|
|
if (nal.gt.0) then
|
|
call dgemm('n','n',nval,nal,nal*nblc,-1.d0,scr(jaabsize+1),nval,
|
|
&scr(jaabsize+ma*nblc+1),nal*nblc,1.d0,newta1,nval)
|
|
endif
|
|
|
|
c newta2 (2)/7
|
|
if (nal.gt.0) then
|
|
call dgemm('t','n',nal,nal*nblc,nval,1.d0,ta1,nval,
|
|
&scr(jaabsize+1),nval,0.d0,scr(jaabsize+ma*nblc+1),nal)
|
|
endif
|
|
|
|
call ijabfold(scr(jaabsize+ma*nblc+1),nal,nal,nval,nval,f0,fx,
|
|
&nblc,newta2)
|
|
|
|
c falae (3)/3
|
|
call rectfoldexp1(scr(jaabsize+1),nval,nal,nval,nval,f0,fx,nblc,
|
|
&scr(jaabsize+ma*nblc+1))
|
|
|
|
call vecblc(ta1,nval,nal,f0,fx,
|
|
& scr(jaabsize+ma*nblc+fx*ma*(fx+f0-1)+1))
|
|
if (nal.gt.0) then
|
|
call dgemv('t',nal*fx,nval*(f0+fx-1),1.d0,scr(jaabsize+ma*nblc+1),
|
|
&nal*fx,scr(jaabsize+ma*nblc+fx*ma*(fx+f0-1)+1),1,1.d0,faae,1)
|
|
endif
|
|
|
|
if (f0.gt.1) then
|
|
call rectfoldexp2(scr(jaabsize+1),nval,nal,nval,nval,f0,fx,nblc,
|
|
&scr(jaabsize+ma*nblc+1))
|
|
|
|
call vecblc(ta1,nval,nal,1,f0-1,
|
|
&scr(jaabsize+ma*nblc+fx*ma*(f0-1)+1))
|
|
call dgemv('t',nal*(f0-1),nval*fx,1.d0,
|
|
&scr(jaabsize+ma*nblc+1),nal*(f0-1),
|
|
&scr(jaabsize+ma*nblc+fx*ma*(f0-1)+1),1,1.d0,faae(1,f0),1)
|
|
endif
|
|
|
|
end if ! lmp3
|
|
endif !nblc>0
|
|
enddo
|
|
|
|
close(16)
|
|
close(17)
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine wmnijbld(nal,nval,ta1,newta1,ta2,newta2,faae,fame,fami,
|
|
&scr,aijkaa,ijklaa,abijaa,lf12,qscale,tscalea,epaa,lmp3)
|
|
************************************************************************
|
|
|
|
c Builds and contracts the Wmnij intermediate, contracts some integrals
|
|
|
|
implicit none
|
|
|
|
integer nal,nval,aijk,en,mi,aij,men,nn,ik,mn,ef,mnef,me,ab,ij,off
|
|
real*8 ta1(nval,nal),fami(nal,nal),newta1(nval,nal)
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),faae(nval,nval)
|
|
real*8 newta2(nval*(nval-1)/2,nal*(nal-1)/2),fame(nval,nal),scr(*)
|
|
real*8 tscalea,epaa
|
|
character*6 aijkaa,ijklaa,abijaa
|
|
logical lf12,qscale,lmp3
|
|
|
|
if(lmp3) then
|
|
call dfillzero(scr, (nal*(nal-1)/2)**2)
|
|
else
|
|
if (nval.gt.0) then
|
|
aijk=nval*nal**2*(nal-1)/2
|
|
open(16,file=aijkaa,form='unformatted')
|
|
read(16) scr(1:aijk)
|
|
close(16)
|
|
|
|
c falmi (4)/3
|
|
en=nal*nval
|
|
mi=nal**2
|
|
call yzxxext(scr,nval,nal,nal,nal,scr(aijk+1))
|
|
call dgemv('t',en,mi,1.d0,scr(aijk+1),en,ta1,1,1.d0,fami,1)
|
|
|
|
aij=nval*nal*(nal-1)/2
|
|
call yzxxsw(scr,nval,nal,nal,nal,scr(aijk+1))
|
|
c newta1 (1)/7
|
|
men=(nal*(nal-1)/2)*nval
|
|
call xxyyunb(ta2,nval,nval,nal,nal,scr(aijk*2+1))
|
|
call dgemm('n','t',nval,nal,men,1.d0,
|
|
&scr(aijk*2+1),nval,scr(aijk+1),nal,1.d0,newta1,nval)
|
|
|
|
C Add F12 contribution
|
|
if(lf12) then
|
|
read(802) scr(aijk*2+1:aijk*2+nal*aij)
|
|
call daxpy(nal*aij,-1.d0,scr(aijk*2+1),1,scr(aijk+1),1)
|
|
endif
|
|
C F12 end
|
|
|
|
c newta2 (2)/8
|
|
call dgemm('n','n',nval,aij,nal,1.d0,
|
|
&ta1,nval,scr(aijk+1),nal,0.d0,scr(aijk*2+1),nval)
|
|
|
|
call abfold(scr(aijk*2+1),nval,nval,nal,nal,newta2)
|
|
|
|
c walmnij (6)/2
|
|
nn=nal**2*(nal-1)/2
|
|
aijk=max(nval*nal**2*(nal-1)/2,(nal*(nal-1)/2)**2)
|
|
call dgemm('t','n',nal,nn,nval,1.d0,
|
|
&ta1,nval,scr,nval,0.d0,scr(aijk+1),nal)
|
|
|
|
call ijfold(scr(aijk+1),nal,nal,nal,nal,scr)
|
|
|
|
endif !nval>0
|
|
end if ! lmp3
|
|
|
|
c walmnij (6)/1
|
|
ik=(nal*(nal-1)/2)**2
|
|
open(16,file=ijklaa,form='unformatted')
|
|
read(16) scr(ik+1:ik+(nal*(nal-1)/2+1)*(nal*(nal-1)/2)/2)
|
|
close(16)
|
|
|
|
call ijkladd(scr,scr(ik+1),nal*(nal-1)/2)
|
|
|
|
c walmnij (6)/3
|
|
if (nval.gt.1) then
|
|
ij=nal*(nal-1)/2
|
|
mn=nal*(nal-1)/2
|
|
ef=nval*(nval-1)/2
|
|
mnef=mn*ef
|
|
open(16,file=abijaa,form='unformatted')
|
|
read(16) scr(ik+1:ik+mnef)
|
|
close(16)
|
|
|
|
c newta2 (2)/1
|
|
call daxpy(mnef,1.d0,scr(ik+1),1,newta2,1)
|
|
|
|
if(.not.lmp3) then
|
|
call taubld1(ta2,ta1,nval,nval,nal,nal,scr(ik+mnef+1))
|
|
call dgemm
|
|
&('t','n',mn,mn,ef,1.d0,scr(ik+1),ef,scr(ik+mnef+1),ef,1.d0,scr,mn)
|
|
c falae (3)/4
|
|
nn=nval*nal*(nal-1)/2
|
|
call xxyyunb(scr(ik+1),nval,nval,nal,nal,scr(ik+mnef+1))
|
|
call tautbld2(ta2,ta1,nval,nval,nal,nal,scr(ik+mnef+nval**2*mn+1))
|
|
call dgemm('n','t',nval,nval,nn,-1.d0,
|
|
&scr(ik+mnef+nval**2*mn+1),nval,scr(ik+mnef+1),
|
|
&nval,1.d0,faae,nval)
|
|
c falmi (4)/4
|
|
nn=nal*nval*(nval-1)/2
|
|
call yyxxunb(scr(ik+1),nval,nval,nal,nal,scr(ik+mnef+1))
|
|
call tautbld3(ta2,ta1,nval,nval,nal,nal,scr(ik+mnef+nal**2*ef+1))
|
|
call dgemm('t','n',nal,nal,nn,1.d0,
|
|
&scr(ik+mnef+1),nn,scr(ik+mnef+nal**2*ef+1),nn,1.d0,fami,nal)
|
|
c falme (5)/2
|
|
me=nval*nal
|
|
call xxyyext(scr(ik+1),nval,nval,nal,nal,scr(ik+mnef+1))
|
|
call dgemv('t',me,me,1.d0,scr(ik+mnef+1),me,ta1,1,1.d0,fame,1)
|
|
|
|
C Add F12 contribution
|
|
if(lf12) then
|
|
read(802) scr(ik+1:ik+ij*ij)
|
|
call daxpy(ij*ij,1.d0,scr(ik+1),1,scr,1)
|
|
endif
|
|
C F12 end
|
|
|
|
end if ! lmp3
|
|
c newta2 (2)/4
|
|
ab=nval*(nval-1)/2
|
|
call taubld1(ta2,ta1,nval,nval,nal,nal,scr(ik+1))
|
|
call dgemm('n','n',ab,ij,ij,1.d0,
|
|
&scr(ik+1),ab,scr,ij,1.d0,newta2,ab)
|
|
|
|
endif !nval>1
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine ccenergy(nal,nbe,nval,nvbe,ta1,newta2,tb1,newtb2,
|
|
&newtm2,fa,fb,scr,ecc,lmp2,et1,lnaf,lf12,ecc_os,ecc_ss,lmp3)
|
|
************************************************************************
|
|
c Calculates the CCSD correlation energy
|
|
|
|
implicit none
|
|
|
|
integer nal,nbe,nvbe,nval,ii,a,b,i,j,dhyb
|
|
real*8 ta1(nval,nal),tb1(nvbe,nbe),newtm2(nval*nvbe,nal*nbe),ecc
|
|
real*8 newta2(nval*(nval-1)/2,nal*(nal-1)/2),fa(nal+nval,nal+nval)
|
|
real*8 newtb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),fb(nbe+nvbe,nbe+nvbe)
|
|
real*8 scr(*),ddot,et1,ef12,ecabs,emp2f12,ecc_os,ecc_ss
|
|
character*4 localcc,dft
|
|
character*5 dfintran
|
|
logical lmp2,lnaf,lf12,lmp3
|
|
|
|
call getkey('localcc',7,localcc,4)
|
|
call getkey('dfintran',8,dfintran,5)
|
|
|
|
call getvar('dhyb ',dhyb)
|
|
|
|
ecc_os = 0.d0
|
|
ecc_ss = 0.d0
|
|
|
|
C F12 energy contribution
|
|
ef12=0.d0
|
|
if(lf12) then
|
|
rewind(800)
|
|
read(800) ecabs,emp2f12
|
|
read(800)
|
|
if(nal.gt.1.and.nval.gt.1) then
|
|
read(800) scr(1:nval*(nval-1)/2*nal*(nal-1)/2)
|
|
ef12=ef12+ddot((nval*(nval-1)/2)*(nal*(nal-1)/2),newta2,1,scr,1)
|
|
endif
|
|
if(nbe.gt.1.and.nvbe.gt.1) then
|
|
read(800) scr(1:nvbe*(nvbe-1)/2*nbe*(nbe-1)/2)
|
|
ef12=ef12+ddot((nvbe*(nvbe-1)/2)*(nbe*(nbe-1)/2),newtb2,1,scr,1)
|
|
endif
|
|
if(nal.gt.0.and.nval.gt.0.and.nbe.gt.0.and.nvbe.gt.0) then
|
|
read(800) scr(1:nval*nvbe*nal*nbe)
|
|
ef12=ef12+ddot(nval*nvbe*nal*nbe,newtm2,1,scr,1)
|
|
endif
|
|
if(nal.gt.1.and.nval.gt.1) then
|
|
read(800) scr(1:nval*(nval-1)/2*nal*(nal-1)/2)
|
|
ii=0
|
|
do j=1,nal
|
|
do i=1,j-1
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
ii=ii+1
|
|
ef12=ef12+scr(ii)*(ta1(a,i)*ta1(b,j)-ta1(b,i)*ta1(a,j))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
if(nbe.gt.1.and.nvbe.gt.1) then
|
|
read(800) scr(1:nvbe*(nvbe-1)/2*nbe*(nbe-1)/2)
|
|
ii=0
|
|
do j=1,nbe
|
|
do i=1,j-1
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
ii=ii+1
|
|
ef12=ef12+scr(ii)*(tb1(a,i)*tb1(b,j)-tb1(b,i)*tb1(a,j))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
if(nal.gt.0.and.nval.gt.0.and.nbe.gt.0.and.nvbe.gt.0) then
|
|
read(800) scr(1:nval*nvbe*nal*nbe)
|
|
ii=0
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
ii=ii+1
|
|
ef12=ef12+scr(ii)*ta1(a,i)*tb1(b,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
if(nal.gt.0.and.nval.gt.0) then
|
|
read(800) scr(1:nval*nal)
|
|
ef12=ef12+ddot(nval*nal,ta1,1,scr,1)
|
|
endif
|
|
if(nbe.gt.0.and.nvbe.gt.0) then
|
|
read(800) scr(1:nvbe*nbe)
|
|
ef12=ef12+ddot(nvbe*nbe,tb1,1,scr,1)
|
|
endif
|
|
else
|
|
ecabs=0.d0
|
|
emp2f12=0.d0
|
|
endif
|
|
C F12 end
|
|
c f*t1
|
|
if (.not.lmp3) then
|
|
call fockme('t',fa,nal,nval,scr)
|
|
call fockme('t',fb,nbe,nvbe,scr(nal*nval+1))
|
|
|
|
et1=
|
|
& ddot(nval*nal,ta1,1,scr,1)
|
|
&+ddot(nvbe*nbe,tb1,1,scr(nal*nval+1),1)
|
|
c et1=ecc
|
|
endif
|
|
if (lmp2) write(*,"(' T1 contributions [au]:',f38.12)") et1
|
|
|
|
c (t2+t1*t1)*<ab||ij>
|
|
c a,a
|
|
if (nal.gt.1.and.nval.gt.1) then
|
|
if (.not.(lmp2.or.lmp3))
|
|
$ call ttabld(ta1,ta1,nval,nal,nval,nal,newta2) !not needed for MP2
|
|
|
|
if(lnaf .and. localcc.eq.'off ' .and. dfintran.eq.'drpa ') then
|
|
open(16,file='abijaa_nonaf',form='unformatted')
|
|
else
|
|
open(16,file='abijaa',form='unformatted')
|
|
end if
|
|
read(16) scr(1:nval*(nval-1)/2*nal*(nal-1)/2)
|
|
close(16)
|
|
|
|
ecc_ss=ecc_ss+
|
|
&ddot((nval*(nval-1)/2)*(nal*(nal-1)/2),newta2,1,scr,1)
|
|
endif
|
|
|
|
c b,b
|
|
if (nbe.gt.1.and.nvbe.gt.1) then
|
|
if (.not.(lmp2.or.lmp3))
|
|
$ call ttabld(tb1,tb1,nvbe,nbe,nvbe,nbe,newtb2) !not needed for MP2
|
|
|
|
if(lnaf .and. localcc.eq.'off ' .and. dfintran.eq.'drpa ') then
|
|
open(16,file='abijbb_nonaf',form='unformatted')
|
|
else
|
|
open(16,file='abijbb',form='unformatted')
|
|
end if
|
|
read(16) scr(1:nvbe*(nvbe-1)/2*nbe*(nbe-1)/2)
|
|
close(16)
|
|
|
|
ecc_ss=ecc_ss
|
|
&+ddot((nvbe*(nvbe-1)/2)*(nbe*(nbe-1)/2),newtb2,1,scr,1)
|
|
endif
|
|
|
|
c a,b
|
|
if (nal.gt.0.and.nbe.gt.0.and.nval.gt.0.and.nvbe.gt.0) then
|
|
if (.not.(lmp2.or.lmp3))
|
|
$ call ttmbld(ta1,tb1,nval,nal,nvbe,nbe,newtm2) !not needed for MP2
|
|
|
|
if(lnaf .and. localcc.eq.'off ' .and. dfintran.eq.'drpa ') then
|
|
open(16,file='abijab_nonaf',form='unformatted')
|
|
else
|
|
open(16,file='abijab',form='unformatted')
|
|
end if
|
|
read(16) scr(1:nvbe*nval*nal*nbe)
|
|
close(16)
|
|
|
|
ecc_os=ecc_os
|
|
&+ddot(nvbe*nval*nal*nbe,newtm2,1,scr,1)
|
|
endif
|
|
|
|
if (lmp2) then
|
|
write(*,"(' Same spin MP2 energy [au]: ',f29.12)") ecc_ss
|
|
write(*,"(' Opposite spin MP2 energy [au]: ',f29.12)") ecc_os
|
|
end if
|
|
|
|
call getkey('dft',3,dft,4)
|
|
if(trim(dft).ne.'off'.and.(lmp2.or.lmp3).and.dhyb.ge.1) then
|
|
ecc=ecc_os+ecc_ss
|
|
else
|
|
ecc=et1+ecc_os+ecc_ss
|
|
end if
|
|
|
|
ecc=ecc+emp2f12+ef12
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine sccenergy_v2(nal,nbe,nval,nvbe,ta1,newta2,tb1,newtb2,
|
|
&newtm2,fa,fb,scr,eccs,eccp,et1s,faa,fbb,inta2,intb2,intm2,tscalea,
|
|
&tscaleb,epaa,epbb,epab,ef12)
|
|
************************************************************************
|
|
c Calculates the CCSD correlation energy
|
|
|
|
implicit none
|
|
|
|
integer nal,nbe,nvbe,nval,ii,a,b,i,j,ab,ij
|
|
real*8 ta1(nval,nal),tb1(nvbe,nbe),newtm2(nval,nvbe,nal,nbe),eccs
|
|
real*8 newta2(nval*(nval-1)/2,nal*(nal-1)/2),fa(nal+nval,nal+nval)
|
|
real*8 newtb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),fb(nbe+nvbe,nbe+nvbe)
|
|
real*8 scr(*),ddot,et1s,eccp,faa(nval,nal),fbb(nvbe,nbe),tmp,ef12
|
|
real*8 inta2(nval*(nval-1)/2,nal*(nal-1)/2)
|
|
real*8 intb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2)
|
|
real*8 intm2(nval,nvbe,nal,nbe),tscalea(nal),tscaleb(nbe)
|
|
real*8 epaa(nal,nal),epbb(nbe,nbe),epab(nal,nbe)
|
|
C F12 end
|
|
c f*t1
|
|
c tscalea=1.d0
|
|
c tscaleb=1.d0
|
|
et1s=0.d0
|
|
call fockme('t',fa,nal,nval,faa)
|
|
do i=1,nal
|
|
tmp=0.d0
|
|
do a=1,nval
|
|
c tmp=tmp+ta1(a,i)*faa(a,i)
|
|
tmp=tmp+faa(a,i)*(ta1(a,i)-faa(a,i)/(fa(i,i)-fa(a+nal,a+nal)))
|
|
enddo
|
|
et1s=et1s+tscalea(i)*tmp
|
|
enddo
|
|
call fockme('t',fb,nbe,nvbe,fbb)
|
|
do i=1,nbe
|
|
tmp=0.d0
|
|
do a=1,nvbe
|
|
c tmp=tmp+tb1(a,i)*fbb(a,i)
|
|
tmp=tmp+fbb(a,i)*(tb1(a,i)-fbb(a,i)/(fb(i,i)-fb(a+nbe,a+nbe)))
|
|
enddo
|
|
et1s=et1s+tscaleb(i)*tmp
|
|
enddo
|
|
|
|
eccs=ef12+et1s
|
|
eccp=ef12+et1s
|
|
|
|
c (t2+t1*t1)*<ab||ij>
|
|
c a,a
|
|
if (nal.gt.1.and.nval.gt.1) then
|
|
call ttabld(ta1,ta1,nval,nal,nval,nal,newta2)
|
|
|
|
open(16,file='abijaa',form='unformatted')
|
|
read(16) inta2
|
|
close(16)
|
|
|
|
do j=1,nal
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
tmp=0.d0
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
c tmp=tmp+newta2(ab,ij)*inta2(ab,ij)
|
|
tmp=tmp+inta2(ab,ij)*(newta2(ab,ij)-inta2(ab,ij)
|
|
&/(fa(i,i)+fa(j,j)-fa(a+nal,a+nal)-fa(b+nal,b+nal)))
|
|
enddo
|
|
enddo
|
|
eccs=eccs+(tscalea(i)+tscalea(j))*tmp/2.d0
|
|
eccp=eccp+epaa(i,j)*tmp
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
c b,b
|
|
if (nbe.gt.1.and.nvbe.gt.1) then
|
|
call ttabld(tb1,tb1,nvbe,nbe,nvbe,nbe,newtb2)
|
|
|
|
open(16,file='abijbb',form='unformatted')
|
|
read(16) intb2
|
|
close(16)
|
|
|
|
do j=1,nbe
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
tmp=0.d0
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
c tmp=tmp+newtb2(ab,ij)*intb2(ab,ij)
|
|
tmp=tmp+intb2(ab,ij)*(newtb2(ab,ij)-intb2(ab,ij)
|
|
&/(fb(i,i)+fb(j,j)-fb(a+nbe,a+nbe)-fb(b+nbe,b+nbe)))
|
|
enddo
|
|
enddo
|
|
eccs=eccs+(tscaleb(i)+tscaleb(j))*tmp/2.d0
|
|
eccp=eccp+epbb(i,j)*tmp
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
c a,b
|
|
if (nal.gt.0.and.nbe.gt.0.and.nval.gt.0.and.nvbe.gt.0) then
|
|
call ttmbld(ta1,tb1,nval,nal,nvbe,nbe,newtm2)
|
|
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) intm2
|
|
close(16)
|
|
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
tmp=0.d0
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
c tmp=tmp+newtm2(a,b,i,j)*intm2(a,b,i,j)
|
|
tmp=tmp+intm2(a,b,i,j)*(newtm2(a,b,i,j)-intm2(a,b,i,j)
|
|
&/(fa(i,i)+fb(j,j)-fa(a+nal,a+nal)-fb(b+nbe,b+nbe)))
|
|
enddo
|
|
enddo
|
|
eccs=eccs+(tscalea(i)+tscaleb(j))*tmp/2.d0
|
|
eccp=eccp+epab(i,j)*tmp
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine sccenergy_v1(nal,nbe,nval,nvbe,ta1,newta2,tb1,newtb2,
|
|
&newtm2,fa,fb,scr,eccs,eccp,et1s,faa,fbb,inta2,intb2,intm2,tscalea,
|
|
&tscaleb,epaa,epbb,epab)
|
|
************************************************************************
|
|
c Calculates the CCSD correlation energy
|
|
|
|
implicit none
|
|
|
|
integer nal,nbe,nvbe,nval,ii,a,b,i,j,ab,ij
|
|
real*8 ta1(nval,nal),tb1(nvbe,nbe),newtm2(nval,nvbe,nal,nbe),eccs
|
|
real*8 newta2(nval*(nval-1)/2,nal*(nal-1)/2),fa(nal+nval,nal+nval)
|
|
real*8 newtb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),fb(nbe+nvbe,nbe+nvbe)
|
|
real*8 scr(*),ddot,et1s,eccp,faa(nval,nal),fbb(nvbe,nbe),tmp
|
|
real*8 inta2(nval*(nval-1)/2,nal*(nal-1)/2)
|
|
real*8 intb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2)
|
|
real*8 intm2(nval,nvbe,nal,nbe),tscalea(nal),tscaleb(nbe)
|
|
real*8 epaa(nal,nal),epbb(nbe,nbe),epab(nal,nbe)
|
|
C F12 end
|
|
c f*t1
|
|
et1s=0.d0
|
|
call fockme('t',fa,nal,nval,faa)
|
|
do i=1,nal
|
|
tmp=0.d0
|
|
do a=1,nval
|
|
tmp=tmp+ta1(a,i)*faa(a,i)
|
|
enddo
|
|
et1s=et1s+tscalea(i)*tmp
|
|
enddo
|
|
call fockme('t',fb,nbe,nvbe,fbb)
|
|
do i=1,nbe
|
|
tmp=0.d0
|
|
do a=1,nvbe
|
|
tmp=tmp+tb1(a,i)*fbb(a,i)
|
|
enddo
|
|
et1s=et1s+tscaleb(i)*tmp
|
|
enddo
|
|
|
|
eccs=et1s
|
|
eccp=et1s
|
|
|
|
c (t2+t1*t1)*<ab||ij>
|
|
c a,a
|
|
if (nal.gt.1.and.nval.gt.1) then
|
|
call ttabld(ta1,ta1,nval,nal,nval,nal,newta2)
|
|
|
|
open(16,file='abijaa',form='unformatted')
|
|
read(16) inta2
|
|
close(16)
|
|
|
|
do j=1,nal
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
tmp=0.d0
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
tmp=tmp+newta2(ab,ij)*inta2(ab,ij)
|
|
enddo
|
|
enddo
|
|
eccs=eccs+(tscalea(i)+tscalea(j))*tmp/2.d0
|
|
eccp=eccp+epaa(i,j)*tmp
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
c b,b
|
|
if (nbe.gt.1.and.nvbe.gt.1) then
|
|
call ttabld(tb1,tb1,nvbe,nbe,nvbe,nbe,newtb2)
|
|
|
|
open(16,file='abijbb',form='unformatted')
|
|
read(16) intb2
|
|
close(16)
|
|
|
|
do j=1,nbe
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
tmp=0.d0
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
tmp=tmp+newtb2(ab,ij)*intb2(ab,ij)
|
|
enddo
|
|
enddo
|
|
eccs=eccs+(tscaleb(i)+tscaleb(j))*tmp/2.d0
|
|
eccp=eccp+epbb(i,j)*tmp
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
c a,b
|
|
if (nal.gt.0.and.nbe.gt.0.and.nval.gt.0.and.nvbe.gt.0) then
|
|
call ttmbld(ta1,tb1,nval,nal,nvbe,nbe,newtm2)
|
|
|
|
open(16,file='abijab',form='unformatted')
|
|
read(16) intm2
|
|
close(16)
|
|
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
tmp=0.d0
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
tmp=tmp+newtm2(a,b,i,j)*intm2(a,b,i,j)
|
|
enddo
|
|
enddo
|
|
eccs=eccs+(tscalea(i)+tscaleb(j))*tmp/2.d0
|
|
eccp=eccp+epab(i,j)*tmp
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
return
|
|
end
|
|
************************************************************************
|
|
subroutine scaleabij_ab(nal,nbe,nval,nvbe,newtm2,intm2,tscalea,
|
|
&tscaleb,epab)
|
|
************************************************************************
|
|
implicit none
|
|
integer nal,nbe,nvbe,nval,ii,a,b,i,j,ab,ij
|
|
real*8 newtm2(nval,nvbe,nal,nbe),epab(nal,nbe),tmp
|
|
real*8 intm2(nval,nvbe,nal,nbe),tscalea(nal),tscaleb(nbe)
|
|
C
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
tmp=(tscalea(i)+tscaleb(j))/2.d0
|
|
c tmp=epab(i,j)
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
newtm2(a,b,i,j)=newtm2(a,b,i,j)+tmp*intm2(a,b,i,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine scaleabij_aa(nal,nval,newta2,inta2,tscalea,epaa)
|
|
************************************************************************
|
|
implicit none
|
|
integer nal,nval,ii,a,b,i,j,ab,ij
|
|
real*8 newta2(nval*(nval-1)/2,nal*(nal-1)/2),epaa(nal,nal),tmp
|
|
real*8 inta2(nval*(nval-1)/2,nal*(nal-1)/2),tscalea(nal)
|
|
C
|
|
do j=1,nal
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
tmp=(tscalea(i)+tscalea(j))/2.d0
|
|
c tmp=epaa(i,j)
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
newta2(ab,ij)=newta2(ab,ij)+tmp*inta2(ab,ij)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine scaleup_ab(nal,nbe,nval,nvbe,newtm2,tscalea,tscaleb,
|
|
$epab)
|
|
************************************************************************
|
|
implicit none
|
|
integer nal,nbe,nvbe,nval,ii,a,b,i,j,ab,ij
|
|
real*8 newtm2(nval,nvbe,nal,nbe),epab(nal,nbe),tmp
|
|
real*8 tscalea(nal),tscaleb(nbe)
|
|
C
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
tmp=(tscalea(i)+tscaleb(j))/2.d0
|
|
c tmp=epab(i,j)
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
newtm2(a,b,i,j)=tmp*newtm2(a,b,i,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine scaleup_aa(nal,nval,newta2,tscalea,epaa)
|
|
************************************************************************
|
|
implicit none
|
|
integer nal,nval,ii,a,b,i,j,ab,ij
|
|
real*8 newta2(nval*(nval-1)/2,nal*(nal-1)/2),epaa(nal,nal),tmp
|
|
real*8 tscalea(nal)
|
|
C
|
|
do j=1,nal
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
tmp=(tscalea(i)+tscalea(j))/2.d0
|
|
c tmp=epaa(i,j)
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
newta2(ab,ij)=tmp*newta2(ab,ij)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine scaledo_ab(nal,nbe,nval,nvbe,newtm2,tscalea,tscaleb,
|
|
$epab)
|
|
************************************************************************
|
|
implicit none
|
|
integer nal,nbe,nvbe,nval,ii,a,b,i,j,ab,ij
|
|
real*8 newtm2(nval,nvbe,nal,nbe),epab(nal,nbe),tmp
|
|
real*8 tscalea(nal),tscaleb(nbe)
|
|
C
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
tmp=(tscalea(i)+tscaleb(j))/2.d0
|
|
c tmp=epab(i,j)
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
newtm2(a,b,i,j)=newtm2(a,b,i,j)/tmp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine scaledo_aa(nal,nval,newta2,tscalea,epaa)
|
|
************************************************************************
|
|
implicit none
|
|
integer nal,nval,ii,a,b,i,j,ab,ij
|
|
real*8 newta2(nval*(nval-1)/2,nal*(nal-1)/2),epaa(nal,nal),tmp
|
|
real*8 tscalea(nal)
|
|
C
|
|
do j=1,nal
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
tmp=(tscalea(i)+tscalea(j))/2.d0
|
|
c tmp=epaa(i,j)
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
newta2(ab,ij)=newta2(ab,ij)/tmp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine scaleppl_ab(nal,nbe,nval,nvbe,fa,fb,newtm2,intm2,
|
|
$tscalea,tscaleb,epab,eccs,eccp,eppl,epplc,eccsc,epplij)
|
|
************************************************************************
|
|
implicit none
|
|
integer nal,nbe,nvbe,nval,ii,a,b,i,j,ab,ij
|
|
real*8 newtm2(nval,nvbe,nal,nbe),epab(nal,nbe),tmp,eppl,epplc
|
|
real*8 intm2(nval,nvbe,nal,nbe),tscalea(nal),tscaleb(nbe),eccsc
|
|
real*8 eccp,eccs,fa(nal+nval,nal+nval),fb(nbe+nvbe,nbe+nvbe)
|
|
real*8 epplij
|
|
|
|
real*8 qscalea(nal), qscaleb(nbe) !!! torolni
|
|
open(799, file='QFACTS', form='unformatted')
|
|
read(799) qscalea
|
|
read(799) qscalea
|
|
read(799) qscalea
|
|
read(799) qscaleb
|
|
close(799)
|
|
|
|
c write(*,*) 'scaleppl_ab'
|
|
C
|
|
open(544,file='abijab',form='unformatted')
|
|
read(544) intm2
|
|
close(544)
|
|
epplc=0.d0
|
|
eccsc=0.d0
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
tmp=0.d0
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
tmp=tmp+intm2(a,b,i,j)*newtm2(a,b,i,j)
|
|
&/(fa(i,i)+fb(j,j)-fa(a+nal,a+nal)-fb(b+nbe,b+nbe))
|
|
enddo
|
|
enddo
|
|
eccs=eccs+((tscalea(i)+tscaleb(j))/2.d0-1.d0)*tmp
|
|
eccp=eccp+(epab(i,j)-1.d0)*tmp
|
|
eppl=eppl+tmp
|
|
epplc=epplc+tmp
|
|
eccsc=eccsc+((qscalea(i)+qscaleb(j))/2.d0)*tmp
|
|
epplij=epplij+epab(i,j)*tmp
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine scaleppl_aa(nal,nval,fa,newta2,inta2,tscalea,epaa,eccs,
|
|
$eccp,abijaa,eppl,epplc,eccsc,epplij)
|
|
************************************************************************
|
|
implicit none
|
|
integer nal,nval,ii,a,b,i,j,ab,ij
|
|
real*8 newta2(nval*(nval-1)/2,nal*(nal-1)/2),epaa(nal,nal),tmp
|
|
real*8 inta2(nval*(nval-1)/2,nal*(nal-1)/2),tscalea(nal),epplc
|
|
real*8 eccp,eccs,fa(nal+nval,nal+nval),eppl,eccsc
|
|
real*8 epplij
|
|
character(len=6) abijaa
|
|
|
|
real*8 qscalea(nal) !!! torolni
|
|
read(799) qscalea
|
|
c write(*,*) qscalea
|
|
C
|
|
c write(*,*) 'scaleppl_aa'
|
|
|
|
open(544,file=abijaa,form='unformatted')
|
|
read(544) inta2
|
|
close(544)
|
|
epplc=0.d0
|
|
eccsc=0.d0
|
|
do j=1,nal
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
tmp=0.d0
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
tmp=tmp+inta2(ab,ij)*newta2(ab,ij)
|
|
$/(fa(i,i)+fa(j,j)-fa(a+nal,a+nal)-fa(b+nal,b+nal))
|
|
enddo
|
|
enddo
|
|
eccs=eccs+((tscalea(i)+tscalea(j))/2.d0-1.d0)*tmp
|
|
eccp=eccp+(epaa(i,j)-1.d0)*tmp
|
|
eppl=eppl+tmp
|
|
epplc=epplc+tmp
|
|
eccsc=eccsc+((qscalea(i)+qscalea(j))/2.d0)*tmp
|
|
epplij=epplij+epaa(i,j)*tmp
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine taubldefabcds(t2,t1,ne,nf,ni,nj,f0,fx,nblc,tau,tscalea,
|
|
$epaa)
|
|
|
|
c Builds tau(e<f,i<j) where f starts from f0 and ends at f0+fx.
|
|
|
|
implicit none
|
|
integer ne,nf,ni,nj,f0,fx,eff,ef,ij,e,f,i,j,nblc
|
|
real*8 t2(nf*(nf-1)/2,nj*(nj-1)/2),t1(nf,nj),tau(nblc,nj*(nj-1)/2)
|
|
real*8 tscalea(ni),epaa(ni,ni)
|
|
|
|
do j=1,nj
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
eff=1
|
|
do f=f0,f0+fx-1
|
|
do e=1,f-1
|
|
ef=(f-1)*(f-2)/2+e
|
|
tau(eff,ij)=(0.5d0*(tscalea(i)+tscalea(j))-1.d0)*(t2(ef,ij)+
|
|
c tau(eff,ij)=(epaa(i,j)-1.d0)*(t2(ef,ij)+
|
|
$t1(e,i)*t1(f,j)-t1(f,i)*t1(e,j))
|
|
eff=eff+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
************************************************************************
|
|
subroutine taumbld2s(t2,ta1,tb1,ne,nf,ni,nj,f0,fx,tau,tscalea,
|
|
$tscaleb,epab)
|
|
|
|
c Builds tau where f starts at f0 and ends at f0+fx.
|
|
|
|
implicit none
|
|
integer ne,nf,ni,nj,f0,fx,j,i,ef,ij,eff,e,f
|
|
real*8 t2(ne*nf,ni*nj),ta1(ne,ni),tb1(nf,nj),tau(fx*ne,ni*nj)
|
|
real*8 tscalea(ni),tscaleb(nj),epab(ni,nj)
|
|
|
|
do j=1,nj
|
|
do i=1,ni
|
|
ij=(j-1)*ni+i
|
|
do f=f0,f0+fx-1
|
|
do e=1,ne
|
|
ef=(f-1-f0+1)*ne+e
|
|
eff=(f-1)*ne+e
|
|
tau(ef,ij)=(0.5d0*(tscalea(i)+tscaleb(j))-1.d0)*(t2(eff,ij)+
|
|
c tau(ef,ij)=(epab(i,j)-1.d0)*(t2(eff,ij)+
|
|
$ta1(e,i)*tb1(f,j))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine locccenergy(nal,nbe,nval,nvbe,ta1,tb1,fa,fb,ta2,tb2,
|
|
&newtm2,tm2,uia,uib,ecc,scr,indocc,naf,lmp2,et1)
|
|
|
|
implicit none
|
|
integer nal,nbe,nval,nvbe,ifa,ifb,iabij,ittab,ittabu,itt,iabji
|
|
integer ittba,ittbau,iajb,j,ittajb
|
|
integer it2,iabijscr,it2abij,it2abiju,iut2,iabiju
|
|
|
|
real*8 ta1(nval,nal),tb1(nvbe,nbe),fa(nval+nal,nval+nal)
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),uia(nal),uib(nbe)
|
|
real*8 fb(nvbe+nbe,nvbe+nbe),ddot,scr(*),ecc,et1
|
|
real*8 newtm2(nval*nvbe,nal*nbe),tm2(nval*nvbe,nal*nbe)
|
|
real*8 tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2)
|
|
|
|
character*16 naf
|
|
|
|
logical indocc,lmp2
|
|
|
|
ecc=0.d0
|
|
c f*t1
|
|
c alpha
|
|
if (nal.gt.0.and.nval.gt.0) then
|
|
call loctf(nal,nval,fa,ta1,uia,scr,scr(nal*nval+1),
|
|
&scr(nal*nval+nval+1),ecc)
|
|
endif !nal>0,nval>0
|
|
|
|
c beta
|
|
if (nbe.gt.0.and.nvbe.gt.0.and.indocc) then
|
|
call loctf(nbe,nvbe,fb,tb1,uib,scr,scr(nbe*nvbe+1),
|
|
&scr(nbe*nvbe+nvbe+1),ecc)
|
|
endif !nbe>0,nvbe>0
|
|
et1=ecc
|
|
if (lmp2) write(*,"(' T1 contributions [au]:',f29.12)") et1
|
|
|
|
c t2*<ab||ij>
|
|
c alpha
|
|
if (naf.ne.'off ') then
|
|
open(700,file='ajb',form='unformatted')
|
|
rewind(700)
|
|
endif
|
|
if (nal.gt.1.and.nval.gt.1) then
|
|
if (naf.eq.'off ') then
|
|
iabijscr=1
|
|
iabiju=1
|
|
iabij=iabiju+max(nal*(nal-1)/2,nal)*nval*(nval-1)/2
|
|
iut2=iabiju+nal*nval*(nval-1)/2
|
|
it2=iut2+nal*nval*(nval-1)/2
|
|
|
|
c write(*,*) 'ecc sima elott',ecc
|
|
call loct2abij(nal,nval,scr(iabij),scr(it2),scr(iabijscr),
|
|
&ta1,ta2,uia,'abijaa',lmp2,ecc,
|
|
&scr(iabiju),scr(iut2))
|
|
c write(*,*) 'ecc sima utan',ecc
|
|
else !naf=on
|
|
iabij=1
|
|
iabijscr=iabij+nal*nval*(nval-1)/2
|
|
it2=iabij+nal*nval*(nval-1)/2
|
|
iut2=it2+nal**2*nval*(nval-1)/2
|
|
|
|
call locnaft2abij(nal,nval,scr(iabij),scr(it2),scr(iabijscr),
|
|
&scr(iut2),ta1,ta2,uia,lmp2,ecc)
|
|
c write(*,*) 'ecc naf utan',ecc
|
|
endif !naf
|
|
endif !nal>1,nval>1
|
|
c beta
|
|
if (nbe.gt.1.and.nvbe.gt.1) then
|
|
if (indocc) then
|
|
if (naf.eq.'off ') then
|
|
iabijscr=1
|
|
iabiju=1
|
|
iabij=iabiju+max(nbe*(nbe-1)/2,nbe)*nvbe*(nvbe-1)/2
|
|
iut2=iabiju+nbe*nvbe*(nvbe-1)/2
|
|
it2=iut2+nbe*nvbe*(nvbe-1)/2
|
|
|
|
call loct2abij(nbe,nvbe,scr(iabij),scr(it2),scr(iabijscr),
|
|
&tb1,tb2,uib,'abijbb',lmp2,ecc,
|
|
&scr(iabiju),scr(iut2))
|
|
else !naf=on
|
|
iabij=1
|
|
iabijscr=iabij+nbe*nvbe*(nvbe-1)/2
|
|
it2=iabij+nbe*nvbe*(nvbe-1)/2
|
|
iut2=it2+nbe**2*nvbe*(nvbe-1)/2
|
|
|
|
call locnaft2abij(nbe,nvbe,scr(iabij),scr(it2),scr(iabijscr),
|
|
&scr(iut2),tb1,tb2,uib,lmp2,ecc)
|
|
endif !naf
|
|
endif !indocc
|
|
endif !nbe>1,nvbe>1
|
|
|
|
c mixed
|
|
|
|
if (nal.gt.0.and.nbe.gt.0.and.nval.gt.0.and.nvbe.gt.0) then
|
|
if (naf.eq.'off ') then
|
|
c I beta
|
|
c write(*,*) 'ecc simamixb elott',ecc
|
|
c write(*,*) '*****************************vegyes*****************'
|
|
if (indocc) then
|
|
iabiju=1
|
|
iabij=iabiju+nval*nvbe*nal
|
|
iut2=iabiju+nval*nvbe*nal
|
|
call loct2abijmixb(nal,nbe,nval,nvbe,scr(iabij),ta1,tb1,tm2,
|
|
&newtm2,uib,'abijab',lmp2,ecc,scr(iabiju),scr(iut2))
|
|
endif !indocc
|
|
c write(*,*) 'ecc simamixb utan',ecc
|
|
c I alpha
|
|
iabijscr=1
|
|
iabiju=1
|
|
iabij=iabiju+nval*nvbe*nal*nbe
|
|
iut2=iabiju+nval*nvbe*nbe
|
|
|
|
call loct2abijmixa(nal,nbe,nval,nvbe,scr(iabij),ta1,tb1,tm2,
|
|
&newtm2,scr(iabijscr),uia,'abijab',lmp2,ecc,scr(iabiju),scr(iut2))
|
|
c write(*,*) 'ecc simamixa utan',ecc
|
|
|
|
else !naf=on
|
|
c I beta
|
|
c write(*,*) 'docc loccc ben: ',indocc
|
|
if (indocc) then
|
|
iabij=1
|
|
iut2=iabij+nal*nval*nvbe
|
|
|
|
call locnaft2abijmixb(nal,nbe,nval,nvbe,scr(iabij),ta1,tb1,tm2,
|
|
&newtm2,scr(iut2),uib,lmp2,ecc)
|
|
endif !indocc
|
|
c write(*,*) 'ecc nafmixb utan',ecc
|
|
|
|
c I alpha
|
|
iabij=1
|
|
iut2=iabij+nbe*nval*nvbe
|
|
it2abij=iut2+nbe*nval*nvbe !scr memory for temporary solution
|
|
|
|
call locnaft2abijmixa(nal,nbe,nval,nvbe,scr(iabij),ta1,tb1,tm2,
|
|
&newtm2,scr(iut2),uia,lmp2,ecc,scr(it2abij))
|
|
c write(*,*) 'ecc nafmixa utan',ecc
|
|
|
|
endif !naf
|
|
endif !nal>0,nbe>0,nval>0,nvbe>0
|
|
if (naf.ne.'off ') close(700)
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine locnaft2abijmixa(nal,nbe,nval,nvbe,abij,ta1,tb1,tm2,t2,
|
|
&ut2,uia,lmp2,ecc,scr)
|
|
|
|
implicit none
|
|
|
|
integer nal,nval,nbe,nvbe,j
|
|
real*8 abij(nval*nvbe,nbe),t2(nval*nvbe*nal*nbe),uia(nal)
|
|
real*8 ut2(nbe*nval*nvbe),ta1(nval,nal),tb1(nvbe,nbe)
|
|
real*8 tm2(nval*nvbe*nal*nbe),ddot,ecc,scr(nval*nvbe)
|
|
|
|
logical lmp2
|
|
|
|
c Read abij
|
|
do j=1,nbe
|
|
read(700) abij(1:nval*nvbe,j)
|
|
enddo
|
|
c do j=1,nbe
|
|
c write(*,*) 'naf ab abiju',j
|
|
c write(*,*) abij(1:nval*nvbe,j)
|
|
c enddo
|
|
|
|
c Build t2
|
|
if (lmp2) then
|
|
call yzvxsw(tm2,nval,nvbe,nal,nbe,t2)
|
|
else
|
|
call ttmbld2(ta1,tb1,tm2,nval,nal,nvbe,nbe,t2)
|
|
endif
|
|
|
|
c ui*t2
|
|
call dgemv('n',nval*nvbe*nbe,nal,1.d0,t2,
|
|
&nbe*nval*nvbe,uia,1,0.d0,ut2,1)
|
|
c write(*,*) 'naf ab ut2'
|
|
c write(*,*) ut2
|
|
|
|
c ut2*abiju
|
|
ecc=ecc+0.5d0*ddot(nval*nvbe*nbe,ut2,1,abij,1)
|
|
c write(*,*) 'ab contr: ',0.5d0*ddot(nval*nvbe*nbe,ut2,1,abij,1)
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine locnaft2abijmixb(nal,nbe,nval,nvbe,abij,ta1,tb1,tm2,t2,
|
|
&ut2,uib,lmp2,ecc)
|
|
|
|
implicit none
|
|
|
|
integer nal,nval,nbe,nvbe,j
|
|
real*8 abij(nval*nvbe,nal),t2(nval*nvbe*nal*nbe),uib(nbe)
|
|
real*8 ut2(nval*nvbe*nal),ta1(nval,nal),tb1(nvbe,nbe)
|
|
real*8 tm2(nval*nvbe*nal*nbe),ddot,ecc
|
|
|
|
logical lmp2
|
|
|
|
c Read abij
|
|
do j=1,nal
|
|
read(700) abij(1:nval*nvbe,j) !Szolni Petinek az ajb kiratasanal, mindig nval,nvbe,nocc legyen az indexsorrend
|
|
enddo
|
|
c do j=1,nal
|
|
c write(*,*) 'naf ba abiju',j
|
|
c write(*,*) abij(1:nval*nvbe,j)
|
|
c enddo
|
|
|
|
c Build t2
|
|
c if MP2 then tm2 is already in place
|
|
call dcopy(nval*nvbe*nal*nbe,tm2,1,t2,1)
|
|
if (.not.lmp2) call ttmbld(ta1,tb1,nval,nal,nvbe,nbe,t2)
|
|
c ui*t2
|
|
call dgemv('n',nval*nvbe*nal,nbe,1.d0,t2,
|
|
&nal*nval*nvbe,uib,1,0.d0,ut2,1)
|
|
|
|
c ut2*abiju
|
|
ecc=ecc+0.5d0*ddot(nval*nvbe*nal,ut2,1,abij,1)
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine loct2abijmixa(nal,nbe,nval,nvbe,abij,ta1,tb1,tm2,t2,
|
|
&abijscr,uia,abijname,lmp2,ecc,abiju,ut2)
|
|
|
|
implicit none
|
|
|
|
integer nal,nval,nbe,nvbe,j
|
|
real*8 abij(nval*nvbe*nal*nbe),t2(nval*nvbe*nal*nbe),uia(nal)
|
|
real*8 ta1(nval,nal),tb1(nvbe,nbe)
|
|
real*8 tm2(nval*nvbe*nal*nbe),ddot,abijscr(nval*nvbe*nal*nbe),ecc
|
|
real*8 abiju(nval*nvbe*nbe),ut2(nval*nvbe*nbe)
|
|
|
|
character*6 abijname
|
|
logical lmp2
|
|
|
|
c Read abij
|
|
open(16,file=abijname,form='unformatted')
|
|
read(16) abijscr
|
|
close(16)
|
|
call yzvxsw(abijscr,nval,nvbe,nal,nbe,abij)
|
|
c abij*u
|
|
call dgemv('n',nval*nvbe*nbe,nal,1.d0,abij,nval*nvbe*nbe,uia,1,
|
|
&0.d0,abiju,1)
|
|
c do j=1,nal
|
|
c write(*,*) 'sima ab abiju',j
|
|
c write(*,*) abiju((j-1)*nval*nvbe+1:j*nval*nvbe)
|
|
c enddo
|
|
|
|
c build t2
|
|
c if MP2 then tm2 is already in place
|
|
if (.not.lmp2) then
|
|
call ttmbld2(ta1,tb1,tm2,nval,nal,nvbe,nbe,t2)
|
|
else
|
|
call yzvxsw(tm2,nval,nvbe,nal,nbe,t2)
|
|
endif !lmp2
|
|
c u*t2
|
|
call dgemv('n',nval*nvbe*nbe,nal,1.d0,t2,nval*nvbe*nbe,uia,1,
|
|
&0.d0,ut2,1)
|
|
c write(*,*) 'sima ab ut2'
|
|
c write(*,*) ut2
|
|
c ut2*abiju
|
|
ecc=ecc+0.5d0*ddot(nval*nvbe*nbe,ut2,1,abiju,1)
|
|
c write(*,*) 'ab jarulek',+0.5d0*ddot(nval*nvbe*nbe,ut2,1,abiju,1)
|
|
|
|
cc t2*abij
|
|
c call dgemm('t','n',nal,nal,nval*nvbe*nbe,0.5d0,abij,
|
|
c &nval*nvbe*nbe,t2,nval*nvbe*nbe,0.d0,t2abij,nal)
|
|
c
|
|
cc t2abij*ui
|
|
c call dgemv('t',nal,nal,1.d0,t2abij,nal,uia,1,0.d0,
|
|
c &t2abiju,1)
|
|
c
|
|
cc ui*t2abiju
|
|
c ecc=ecc+ddot(nal,uia,1,t2abiju,1)
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine loct2abijmixb(nal,nbe,nval,nvbe,abij,
|
|
&ta1,tb1,tm2,t2,uib,abijname,lmp2,ecc,abiju,ut2)
|
|
|
|
implicit none
|
|
|
|
integer nal,nval,nbe,nvbe
|
|
real*8 abij(nval*nvbe*nal*nbe),t2(nval*nvbe*nal*nbe),uib(nbe)
|
|
real*8 ta1(nval,nal),tb1(nvbe,nbe)
|
|
real*8 tm2(nval*nvbe*nal*nbe),ddot,ecc,abiju(nval*nvbe*nal)
|
|
real*8 ut2(nval*nvbe*nal)
|
|
|
|
character*6 abijname
|
|
logical lmp2
|
|
|
|
c Read abij
|
|
open(16,file=abijname,form='unformatted')
|
|
read(16) abij
|
|
close(16)
|
|
c abij*u
|
|
call dgemv('n',nval*nvbe*nal,nbe,1.d0,abij,nval*nvbe*nal,uib,1,
|
|
&0.d0,abiju,1)
|
|
c write(*,*) 'sima abiju'
|
|
c write(*,*) abiju
|
|
c do j=1,nal
|
|
c write(*,*) 'sima ba abiju',j
|
|
c write(*,*) abiju((j-1)*nvbe*nval+1:j*nvbe*nval)
|
|
c enddo
|
|
|
|
c build t2
|
|
c if MP2 then tm2 is already in place
|
|
if (.not.lmp2) then
|
|
call ttmbld(ta1,tb1,nval,nal,nvbe,nbe,t2)
|
|
else !lmp2
|
|
call dcopy(nval*nvbe*nal*nbe,tm2,1,t2,1)
|
|
endif !lmp2
|
|
c u*t2
|
|
call dgemv('n',nval*nvbe*nal,nbe,1.d0,t2,nval*nvbe*nal,uib,1,
|
|
&0.d0,ut2,1)
|
|
c write(*,*) 'sima ba ut2'
|
|
c write(*,*) ut2
|
|
c ut2*abiju
|
|
ecc=ecc+0.5d0*ddot(nval*nvbe*nal,ut2,1,abiju,1)
|
|
c write(*,*) 'ma ba jarulek',0.5d0*ddot(nval*nvbe*nal,ut2,1,abiju,1)
|
|
|
|
cc t2*abij
|
|
c call dgemm('t','n',nbe,nbe,nval*nvbe*nal,0.5d0,abij,
|
|
c &nval*nvbe*nal,t2,nval*nvbe*nal,0.d0,t2abij,nbe)
|
|
c
|
|
cc t2abij*ui
|
|
c call dgemv('t',nbe,nbe,1.d0,t2abij,nbe,uib,1,0.d0,
|
|
c &t2abiju,1)
|
|
c
|
|
cc ui*t2abiju
|
|
c ecc=ecc+ddot(nbe,uib,1,t2abiju,1)
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine loctf(nal,nval,fock,tai,ui,fai,fa,ta,ecc)
|
|
|
|
implicit none
|
|
integer nal,nval
|
|
real*8 fai(nval,nal),fa(nval),ta(nval)
|
|
real*8 ecc,ddot,fock(nal+nval,nal+nval),tai(nval,nal),ui(nal)
|
|
|
|
! Extracting Fme
|
|
call fockme('t',fock,nal,nval,fai)
|
|
! fai to local basis
|
|
call dgemv('n',nval,nal,1.d0,fai,nval,ui,1,0.d0,fa,1)
|
|
! tai to local basis
|
|
call dgemv('n',nval,nal,1.d0,tai,nval,ui,1,0.d0,ta,1)
|
|
ecc=ecc+ddot(nval,fa,1,ta,1)
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine loct2abij(nal,nval,abij,t2,abijscr,
|
|
&ta1,ta2,ui,abijname,lmp2,ecc,abiju,ut2)
|
|
|
|
implicit none
|
|
|
|
integer nal,nval
|
|
real*8 abijscr(nal*(nal-1)*nval*(nval-1)/4),ui(nal)
|
|
real*8 abij(nval*(nval-1)*nal**2/2),t2(nval*(nval-1)*nal**2/2)
|
|
real*8 ta1(nval,nal)
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),ddot,ecc
|
|
real*8 abiju(nal*nval*(nval-1)/2),ut2(nal*nval*(nval-1)/2)
|
|
|
|
character*6 abijname
|
|
logical lmp2
|
|
|
|
c Reading abij
|
|
open(16,file=abijname,form='unformatted')
|
|
read(16) abijscr
|
|
close(16)
|
|
|
|
c Unpacking abij
|
|
call yyxxunb(abijscr,nval,nval,nal,nal,abij)
|
|
c abij*u
|
|
call dgemv('n',nval*(nval-1)*nal/2,nal,1.d0,abij,
|
|
&nval*(nval-1)*nal/2,ui,1,0.d0,abiju,1)
|
|
c write(*,*) 'sima aa/bb abiju',abiju
|
|
|
|
c Building t2
|
|
if (lmp2) then
|
|
call yyxxunb(ta2,nval,nval,nal,nal,t2)
|
|
else
|
|
call locttabld(ta1,ta1,ta2,nval,nal,nval,nal,t2)
|
|
endif
|
|
c u*t2
|
|
call dgemv('n',nval*(nval-1)*nal/2,nal,1.d0,t2,
|
|
&nval*(nval-1)*nal/2,ui,1,0.d0,ut2,1)
|
|
c write(*,*) 'sima aa/bb tu',ut2
|
|
|
|
c ut2*abiju
|
|
ecc=ecc+0.5d0*ddot(nval*(nval-1)*nal/2,ut2,1,abiju,1)
|
|
c write(*,*) 'sima aa/bb energia',
|
|
c $0.5d0*ddot(nval*(nval-1)*nal/2,ut2,1,abiju,1)
|
|
|
|
cc t2*abij
|
|
c call dgemm('t','n',nal,nal,nval*(nval-1)*nal/2,0.5d0,abij,
|
|
c &nval*(nval-1)*nal/2,t2,nval*(nval-1)*nal/2,0.d0,t2abij,nal)
|
|
c
|
|
cc t2abij*ui
|
|
c call dgemv('n',nal,nal,1.d0,t2abij,
|
|
c &nal,ui,1,0.d0,t2abiju,1)
|
|
c
|
|
cc ui*t2abiju
|
|
c ecc=ecc+ddot(nal,ui,1,t2abiju,1)
|
|
|
|
return
|
|
endsubroutine
|
|
|
|
************************************************************************
|
|
subroutine locnaft2abij(nal,nval,abij,t2,abijscr,
|
|
&ut2,ta1,ta2,ui,lmp2,ecc)
|
|
|
|
implicit none
|
|
|
|
integer nal,nval,j
|
|
real*8 abijscr(nval**2),abij(nal*nval*(nval-1)/2)
|
|
real*8 t2(nal*nval*(nval-1)/2),ta1(nval,nal)
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2)
|
|
real*8 ut2(nval*(nval-1)*nal/2),ddot,ecc,ui(nal)
|
|
|
|
logical lmp2
|
|
|
|
do j=1,nal
|
|
read(700) abij((j-1)*nval*(nval-1)/2+1:j*nval*(nval-1)/2)
|
|
enddo
|
|
c write(*,*) 'naf aa/bb abiju',abij
|
|
|
|
c Build t2
|
|
if (lmp2) then
|
|
call yyxxunb(ta2,nval,nval,nal,nal,t2)
|
|
else
|
|
call locttabld(ta1,ta1,ta2,nval,nal,nval,nal,t2)
|
|
endif
|
|
|
|
c ui*t2
|
|
call dgemv('n',nval*(nval-1)*nal/2,nal,1.d0,t2,
|
|
&nal*nval*(nval-1)/2,ui,1,0.d0,ut2,1)
|
|
c write(*,*) 'naf aa/bb t2u',ut2
|
|
|
|
c ut2*abiju
|
|
ecc=ecc-0.5d0*ddot(nval*(nval-1)*nal/2,ut2,1,abij,1) !sign is due to subroutien antisymm in ldrpa.f
|
|
c write(*,*) 'aa jarulek: ',
|
|
c & -0.5d0*ddot(nval*(nval-1)*nal/2,ut2,1,abij,1)
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine naftoabij(nal,nval,j,abij,abijscr)
|
|
|
|
implicit none
|
|
|
|
integer nal,nval,j,ab,a,b
|
|
real*8 abij(nval*(nval-1)/2,nal),abijscr(nval,nval)
|
|
|
|
ab=1
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
abij(ab,j)=abijscr(b,a)-abijscr(a,b)
|
|
ab=ab+1
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine tanalytics(ltpr,ta1,tb1,ta2,tb2,tm2,nal,nval,nbe,nvbe,
|
|
$ iout,tprtol,work,ncore)
|
|
* Performs amplitude analytics for open shell CCSD amplitudes
|
|
************************************************************************
|
|
implicit none
|
|
integer iout,nal,nval,nbe,nvbe,iisyev,ncore
|
|
real*8 t1max,t2max,ta1(nval,nal),tb1(nvbe,nbe),norma,normb,dnrm2
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),tm2(nval,nvbe,nal,nbe)
|
|
real*8 tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),work(*),tprtol
|
|
logical ltpr
|
|
c in stack
|
|
real*8 eigval(nal),mrtol
|
|
integer*4 isyev
|
|
equivalence(isyev,iisyev) !For Intel
|
|
|
|
mrtol=0.15d0
|
|
c Determining maximum T amplitudes
|
|
t1max=0.d0
|
|
t2max=0.d0
|
|
t1max=maxval(dabs(ta1))
|
|
t1max=max(t1max,maxval(dabs(tb1)))
|
|
t2max=maxval(dabs(ta2))
|
|
t2max=max(t2max,maxval(dabs(tb2)))
|
|
t2max=max(t2max,maxval(dabs(tm2)))
|
|
c T1 diagnostics
|
|
norma=dnrm2(nval*nal,ta1,1)
|
|
normb=dnrm2(nvbe*nbe,tb1,1)
|
|
c Build D1 matrix
|
|
if (nal.gt.0.and.nval.gt.0) then ! Alpha diagnostic
|
|
call t1diagnostic(nal,nval,ta1,work,eigval,isyev,iout) !alpha
|
|
write(iout,*)
|
|
write(iout,"(' Alpha T1 diagnostic: ',es14.3,6x,
|
|
$'D1 diagnostic: ',es14.3)")
|
|
$norma/dsqrt(dble(nal)),dsqrt(eigval(nal))
|
|
endif
|
|
|
|
if (nbe.gt.0.and.nvbe.gt.0) then ! Beta diagnostic
|
|
call t1diagnostic(nbe,nvbe,tb1,work,eigval,isyev,iout) !beta
|
|
write(iout,"(' Beta T1 diagnostic: ',es14.3,6x,
|
|
$'D1 diagnostic: ',es14.3)")
|
|
$normb/dsqrt(dble(nbe)),dsqrt(eigval(nbe))
|
|
endif
|
|
c Dominant cluster amplitudes
|
|
if (ltpr) then
|
|
write(iout,*)
|
|
write(iout,*) 'Dominant cluster amplitudes'
|
|
write(iout,"(' Printing threshold: ',1pe9.2)") tprtol
|
|
write(iout,*)
|
|
write(iout,"(' T1 alpha:')")
|
|
call t1dominant(nal,nval,ta1,ncore,tprtol,iout) !alpha
|
|
write(iout,*)
|
|
write(iout,"(' T1 beta:')")
|
|
call t1dominant(nbe,nvbe,tb1,ncore,tprtol,iout) !beta
|
|
write(iout,*)
|
|
write(iout,"(' T2 alpha:')")
|
|
call t2dominant(nal,nval,ta2,iout,ncore,tprtol)
|
|
write(iout,*)
|
|
write(iout,"(' T2 beta:')")
|
|
call t2dominant(nbe,nvbe,tb2,iout,ncore,tprtol)
|
|
write(iout,*)
|
|
write(iout,"(' T2 alpha-beta:')")
|
|
call tm2dominant(nal,nbe,nval,nvbe,tm2,iout,ncore,tprtol)
|
|
endif
|
|
|
|
if (max(t1max,t2max).gt.mrtol.or.ltpr) then
|
|
write(iout,*)
|
|
if (max(t1max,t2max).gt.mrtol)
|
|
$ write(iout,*) 'Warning: large CCSD amplitude found'
|
|
write(iout,"(' Largest T1 amplitude: ',1es9.2)") t1max
|
|
write(iout,"(' Largest T2 amplitude: ',1es9.2)") t2max
|
|
endif
|
|
|
|
|
|
return
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine t2dominant(nocc,nvirt,tt,iout,ncore,tprtol)
|
|
************************************************************************
|
|
implicit none
|
|
integer nocc,nvirt,iout,ncore,i,j,a,b,ij,ab
|
|
real*8 tt(nvirt*(nvirt-1)/2,nocc*(nocc-1)/2),tprtol
|
|
character*6 str6
|
|
character*40 str40
|
|
|
|
do j=1,nocc
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
do b=1,nvirt
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
if (dabs(tt(ab,ij)).gt.tprtol) then
|
|
write(str6,'(i6)') j+ncore
|
|
str40= ' ' // trim(adjustl(str6))
|
|
write(str6,'(i6)') i+ncore
|
|
str40=trim(str40) // ' ' // trim(adjustl(str6)) // ' -> '
|
|
write(str6,'(i6)') b+nocc+ncore
|
|
str40=trim(str40) // ' ' // trim(adjustl(str6))
|
|
write(str6,'(i6)') a+nocc+ncore
|
|
str40=trim(str40) // ' ' // trim(adjustl(str6))
|
|
write(iout,"(1es10.3,a40)") tt(ab,ij), str40
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end subroutine t2dominant
|
|
|
|
************************************************************************
|
|
subroutine tm2dominant(nal,nbe,nval,nvbe,tt,iout,ncore,tprtol)
|
|
************************************************************************
|
|
implicit none
|
|
integer nal,nbe,nval,nvbe,iout,ncore,i,j,a,b
|
|
real*8 tt(nval,nvbe,nal,nbe),tprtol
|
|
character*6 str6
|
|
character*40 str40
|
|
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
if (dabs(tt(a,b,i,j)).gt.tprtol) then
|
|
write(str6,'(i6)') i+ncore
|
|
str40= ' ' // trim(adjustl(str6))
|
|
write(str6,'(i6)') j+ncore
|
|
str40=trim(str40) // ' ' // trim(adjustl(str6)) // ' -> '
|
|
write(str6,'(i6)') a+nal+ncore
|
|
str40=trim(str40) // ' ' // trim(adjustl(str6))
|
|
write(str6,'(i6)') b+nbe+ncore
|
|
str40=trim(str40) // ' ' // trim(adjustl(str6))
|
|
write(iout,"(1es10.3,a40)") tt(a,b,i,j), str40
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end subroutine tm2dominant
|
|
|
|
************************************************************************
|
|
subroutine t1dominant(nocc,nvirt,t,ncore,tprtol,iout)
|
|
************************************************************************
|
|
implicit none
|
|
integer nocc,nvirt,ncore,i,a,iout
|
|
real*8 tprtol,t(nvirt,nocc)
|
|
character*6 str6
|
|
character*40 str40
|
|
|
|
do i=1,nocc
|
|
do a=1,nvirt
|
|
if (dabs(t(a,i)).gt.tprtol) then
|
|
write(str6,'(i6)') i+ncore
|
|
str40= ' ' // trim(adjustl(str6)) // ' -> '
|
|
write(str6,'(i6)') a+nocc+ncore
|
|
str40=trim(str40) // ' ' // trim(adjustl(str6))
|
|
write(iout,"(1es10.3,a40)") t(a,i), str40
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end subroutine t1dominant
|
|
|
|
************************************************************************
|
|
subroutine t1diagnostic(nal,nval,ta1,work,eigval,isyev,iout)
|
|
************************************************************************
|
|
implicit none
|
|
integer nal,nval,iout
|
|
real*8 ta1(nval,nal),eigval(nal),work(*)
|
|
integer*4 isyev
|
|
|
|
call dsyrk('u','t',nal,nval,1.d0,ta1,nval,0.d0,work,nal)
|
|
call dsyev('N','U',nal,work,nal,eigval,work(nal**2+1),20*nal,
|
|
$ isyev)
|
|
if(isyev.ne.0) then
|
|
write(iout,*) 'Fatal error at the D1 diagnostic evaluation'
|
|
eigval(nal)=0.d0
|
|
endif
|
|
|
|
return
|
|
end subroutine t1diagnostic
|
|
|
|
subroutine spin_contamination(nal,nbe,nval,nvbe,ata1,atb1,ata2,
|
|
$ atb2,atm2,ta1,tb1,ta2,tb2,tm2,uoa,uob,uva,uvb,work,forward,iout,
|
|
$ scf_s2,localcc,docc,delr2c)
|
|
implicit none
|
|
integer nal,nbe,nval,nvbe,a2len,b2len,iout
|
|
real*8 ta1(nval,nal),tb1(nvbe,nbe),tm2(nval,nvbe,nal,nbe)
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),scf_s2
|
|
real*8 tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),ddot
|
|
real*8 ata1(nval,nal),atb1(nvbe,nbe),atm2(nval,nvbe,nal,nbe)
|
|
real*8 ata2(nval*(nval-1)/2,nal*(nal-1)/2)
|
|
real*8 atb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),work
|
|
real*8 uoa(nal,nal),uob(nbe,nbe),uva(nval,nval),uvb(nvbe,nvbe)
|
|
character*4 localcc
|
|
logical forward,docc,delr2c
|
|
c stack
|
|
integer i,a,nsocc,ab,pj,ij,ar,p,r,b,j,aa,t,icmoa,icmob
|
|
real*8 norm,one_elec,two_elec,tmp,dab,dpj,dij,dar,one_elec_ai
|
|
real*8 t1_contrib,t1_norm,t2_norm,one_elec_loc,two_elec_loc
|
|
real*8 one_elec_ai_loc,dcmo,t1_contrib_loc
|
|
logical exists
|
|
|
|
if (localcc.ne.'off ') then
|
|
inquire(file='rLNO2cLNO',exist=exists)
|
|
if (.not.exists) return
|
|
open(301,file='rLNO2cLNO',form='unformatted',action='read',
|
|
$ status='old')
|
|
else ! localcc.eq.off
|
|
inquire(file='rMO2cMO',exist=exists)
|
|
if (.not.exists) return
|
|
open(301,file='rMO2cMO',form='unformatted',action='read',
|
|
$ status='old')
|
|
endif ! localcc
|
|
read(301) forward
|
|
do i=1,nal
|
|
read(301) (uoa(i,j),j=1,nal)
|
|
enddo
|
|
do i=1,nbe
|
|
read(301) (uob(i,j),j=1,nbe)
|
|
enddo
|
|
do i=1,nval
|
|
read(301) (uva(i,j),j=1,nval)
|
|
enddo
|
|
do i=1,nvbe
|
|
read(301) (uvb(i,j),j=1,nvbe)
|
|
enddo
|
|
if (delr2c) then
|
|
close(301,status='delete')
|
|
else
|
|
close(301)
|
|
endif
|
|
|
|
a2len = nval*(nval-1)/2*nal*(nal-1)/2
|
|
b2len = nvbe*(nvbe-1)/2*nbe*(nbe-1)/2
|
|
nsocc = nal-nbe
|
|
|
|
one_elec = 0.d0; two_elec = 0.d0; t1_contrib = 0.d0
|
|
if (localcc.ne.'off ') then
|
|
one_elec_loc = 0.d0; two_elec_loc = 0.d0; t1_contrib_loc = 0.d0
|
|
if (docc) then
|
|
icmoa = 1; icmob = 1
|
|
dcmo = 1.d0
|
|
else
|
|
icmoa = nbe + 1; icmob = 1
|
|
dcmo = 0.d0
|
|
endif
|
|
endif !localcc
|
|
|
|
call trf_amplitudes(nal,nbe,nval,nvbe,ata1,atb1,ata2,atb2,atm2,
|
|
$ta1,tb1,ta2,tb2,
|
|
$ tm2,uoa,uob,uva,uvb,work,forward)
|
|
|
|
t1_norm = ddot(nval*nal,ta1,1,ta1,1)
|
|
$ + ddot(nvbe*nbe,tb1,1,tb1,1)
|
|
t2_norm = ddot(a2len,ta2,1,ta2,1)
|
|
$ + ddot(b2len,tb2,1,tb2,1)
|
|
$ + ddot(nval*nvbe*nal*nbe,tm2,1,tm2,1)
|
|
norm = 1.d0 + t1_norm + t2_norm
|
|
|
|
c (\Delta^i_a)^2
|
|
do i=1,nbe
|
|
do a=1,nval
|
|
one_elec_ai = ta1(a,i) - tb1(nsocc+a,i)
|
|
t1_contrib = t1_contrib + one_elec_ai**2
|
|
do t=1,nsocc
|
|
one_elec_ai = one_elec_ai + tm2(a,t,nbe+t,i)
|
|
enddo
|
|
one_elec = one_elec + one_elec_ai**2
|
|
enddo
|
|
enddo
|
|
if (localcc.ne.'off '.and.docc) then
|
|
do a=1,nval
|
|
one_elec_ai_loc = ta1(a,icmoa) - dcmo * tb1(nsocc+a,icmob)
|
|
t1_contrib_loc = t1_contrib_loc + one_elec_ai_loc**2
|
|
do t=1,nsocc
|
|
one_elec_ai_loc = one_elec_ai_loc+dcmo*tm2(a,t,nbe+t,icmob)
|
|
enddo
|
|
one_elec_loc = one_elec_loc + one_elec_ai_loc**2
|
|
enddo
|
|
endif !localcc
|
|
|
|
c (\tilde \Delta^{pj}_{ab})
|
|
do j=1,nbe
|
|
do p=1,nal
|
|
if (p.lt.j) then
|
|
pj = (j-1)*(j-2)/2+p
|
|
dpj = 1.d0
|
|
elseif (p.gt.j) then
|
|
pj = (p-1)*(p-2)/2+j
|
|
dpj = -1.d0
|
|
else
|
|
pj = 1
|
|
dpj = 0.d0
|
|
endif
|
|
do b=1,nval
|
|
do a=1,nval
|
|
if (a.lt.b) then
|
|
ab = (b-1)*(b-2)/2+a
|
|
dab = 1.d0
|
|
elseif (a.gt.b) then
|
|
ab = (a-1)*(a-2)/2+b
|
|
dab = -1.d0
|
|
else
|
|
ab = 1
|
|
dab = 0.d0
|
|
endif
|
|
|
|
two_elec = two_elec +
|
|
$ (tm2(a,nsocc+b,p,j) - tm2(b,nsocc+a,p,j) -
|
|
$ dab * dpj * ta2(ab,pj))**2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
if (localcc.ne.'off ') then
|
|
do j=1,nbe
|
|
if (icmoa.lt.j) then
|
|
pj = (j-1)*(j-2)/2+icmoa
|
|
dpj = 1.d0
|
|
elseif (icmoa.gt.j) then
|
|
pj = (icmoa-1)*(icmoa-2)/2+j
|
|
dpj = -1.d0
|
|
else
|
|
pj = 1
|
|
dpj = 0.d0
|
|
endif
|
|
do b=1,nval
|
|
do a=1,nval
|
|
if (a.lt.b) then
|
|
ab = (b-1)*(b-2)/2+a
|
|
dab = 1.d0
|
|
elseif (a.gt.b) then
|
|
ab = (a-1)*(a-2)/2+b
|
|
dab = -1.d0
|
|
else
|
|
ab = 1
|
|
dab = 0.d0
|
|
endif
|
|
|
|
two_elec_loc = two_elec_loc +
|
|
$ (tm2(a,nsocc+b,icmoa,j)-tm2(b,nsocc+a,icmoa,j)-
|
|
$ dab * dpj * ta2(ab,pj))**2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif !localcc
|
|
c (\bar \Delta^{ij}_{ar})
|
|
do j=1,nbe
|
|
do i=1,nbe
|
|
if (i.lt.j) then
|
|
ij = (j-1)*(j-2)/2+i
|
|
dij = 1.d0
|
|
elseif (i.gt.j) then
|
|
ij = (i-1)*(i-2)/2+j
|
|
dij = -1.d0
|
|
else
|
|
ij = 1
|
|
dij = 0.d0
|
|
endif
|
|
do r=1,nvbe
|
|
do aa=1,nval
|
|
a = aa + nsocc
|
|
if (a.lt.r) then
|
|
ar = (r-1)*(r-2)/2+a
|
|
dar = 1.d0
|
|
elseif (a.gt.r) then
|
|
ar = (a-1)*(a-2)/2+r
|
|
dar = -1.d0
|
|
else
|
|
ar = 1
|
|
dar = 0.d0
|
|
endif
|
|
|
|
two_elec = two_elec +
|
|
$ (tm2(aa,r,i,j) - tm2(aa,r,j,i) -
|
|
$ dar * dij * tb2(ar,ij))**2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
if (localcc.ne.'off '.and.docc) then
|
|
do j=1,nbe
|
|
if (icmob.lt.j) then
|
|
ij = (j-1)*(j-2)/2+icmob
|
|
dij = 1.d0
|
|
elseif (icmob.gt.j) then
|
|
ij = (icmob-1)*(icmob-2)/2+j
|
|
dij = -1.d0
|
|
else
|
|
ij = 1
|
|
dij = 0.d0
|
|
endif
|
|
do r=1,nvbe
|
|
do aa=1,nval
|
|
a = aa + nsocc
|
|
if (a.lt.r) then
|
|
ar = (r-1)*(r-2)/2+a
|
|
dar = 1.d0
|
|
elseif (a.gt.r) then
|
|
ar = (a-1)*(a-2)/2+r
|
|
dar = -1.d0
|
|
else
|
|
ar = 1
|
|
dar = 0.d0
|
|
endif
|
|
|
|
two_elec_loc = two_elec_loc +
|
|
$ (tm2(aa,r,icmoa,j) - tm2(aa,r,j,icmob) -
|
|
$ dar * dij * tb2(ar,ij))**2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
two_elec = 0.25d0 * two_elec
|
|
if (localcc.ne.'off ') two_elec_loc = 0.25 * two_elec_loc
|
|
|
|
write(iout,*)
|
|
write(iout,"(' Wave function norms /T1, T2, total/ ',3f11.6)")
|
|
$t1_norm,t2_norm,norm
|
|
write(iout,"(' Linearized S^2 /1 el., 2 el., total, T1/',
|
|
$2x,f15.11,1x,f15.11,1x,f15.11,1x,f15.11)")
|
|
$ one_elec / norm,two_elec/norm, scf_s2+(one_elec+two_elec)/norm,
|
|
$ t1_contrib/norm
|
|
if (localcc.ne.'off ')
|
|
$write(iout,"(' Loc. lin. S^2 /1 el., 2 el., total, T1/ ' ,
|
|
$2x,f15.11,1x,f15.11,1x,f15.11,1x,f15.11)")
|
|
$ one_elec_loc/norm,two_elec_loc/norm,
|
|
$scf_s2+(one_elec_loc+two_elec_loc)/norm,t1_contrib_loc/norm
|
|
|
|
end subroutine spin_contamination
|
|
|
|
subroutine trf_amplitudes(nal,nbe,nval,nvbe,ata1,atb1,ata2,atb2,
|
|
$ atm2,newta1,newtb1,newta2,newtb2,
|
|
$ newtm2,uoa,uob,uva,uvb,work,forward)
|
|
c work has to be at least 2*max(nal,nvbe)**2 large
|
|
implicit none
|
|
integer nal,nbe,nval,nvbe,b,i,j,nso,ij
|
|
real*8 newta1(nval,nal),newtb1(nvbe,nbe),newtm2(nval,nvbe,nal,nbe)
|
|
real*8 newta2(nval*(nval-1)/2,nal*(nal-1)/2)
|
|
real*8 newtb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2)
|
|
real*8 ata1(nval,nal),atb1(nvbe,nbe),atm2(nval,nvbe,nal,nbe)
|
|
real*8 ata2(nval*(nval-1)/2,nal*(nal-1)/2)
|
|
real*8 atb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2)
|
|
real*8 work(*)
|
|
real*8 uoa(nal,nal),uob(nbe,nbe),uva(nval,nval),uvb(nvbe,nvbe)
|
|
logical forward
|
|
character ut1,ut2
|
|
c debug
|
|
integer a
|
|
|
|
if (forward) then
|
|
ut1 = 'n'
|
|
ut2 = 't'
|
|
else
|
|
ut1 = 't'
|
|
ut2 = 'n'
|
|
endif
|
|
nso=nal-nbe
|
|
|
|
c ta1
|
|
if (nval*nal.gt.0) then
|
|
call dgemm('n',ut1,nval,nal,nal,1.d0,ata1,nval,uoa,nal,0.d0,
|
|
$ newtm2,nval)
|
|
call dgemm(ut2,'n',nval,nal,nval,1.d0,uva,nval,newtm2,nval,0.d0,
|
|
$ newta1,nval)
|
|
endif !nval*nal.gt.0
|
|
c tb1
|
|
if (nvbe*nbe.gt.0) then
|
|
call dgemm('n',ut1,nvbe,nbe,nbe,1.d0,atb1,nvbe,uob,nbe,0.d0,
|
|
$ newtm2,nvbe)
|
|
call dgemm(ut2,'n',nvbe,nbe,nvbe,1.d0,uvb,nvbe,newtm2,nvbe,0.d0,
|
|
$ newtb1,nvbe)
|
|
endif !nvbe*nbe.gt.0
|
|
c ta2
|
|
if (nval.gt.1.and.nal.gt.1)
|
|
$ call trf_t2(nval,nal,ata2,newta2,work,uoa,uva,ut1,ut2)
|
|
c tb2
|
|
if (nvbe.gt.1.and.nbe.gt.1)
|
|
$ call trf_t2(nvbe,nbe,atb2,newtb2,work,uob,uvb,ut1,ut2)
|
|
c tm2
|
|
if (nval*nvbe*nal*nbe.gt.0) then
|
|
c Occupied indeces
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
|
|
ij=1
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
work(ij)=atm2(a,b,i,j)
|
|
ij=ij+1
|
|
enddo
|
|
enddo
|
|
c Transform beta occupied index
|
|
call dgemm('n',ut1,nal,nbe,nbe,1.d0,work,nal,uob,nbe,
|
|
& 0.d0,work(nal*nbe+1),nal)
|
|
c Transform alpha occupied index
|
|
call dgemm(ut2,'n',nal,nbe,nal,1.d0,uoa,nal,work(nal*nbe+1),nal,
|
|
& 0.d0,work,nal)
|
|
|
|
c Place tm2
|
|
ij=1
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
newtm2(a,b,i,j)=work(ij)
|
|
ij = ij + 1
|
|
enddo
|
|
enddo
|
|
enddo !a
|
|
enddo !b
|
|
|
|
c Virtual indices
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
c Transform beta virtual index
|
|
call dgemm('n',ut1,nval,nvbe,nvbe,1.d0,newtm2(1,1,i,j),nval,uvb,
|
|
$ nvbe,0.d0,work,nval)
|
|
c Transform alpha virtual index
|
|
call dgemm(ut2,'n',nval,nvbe,nval,1.d0,uva,nval,work,nval,
|
|
& 0.d0,newtm2(1,1,i,j),nval)
|
|
enddo !a
|
|
enddo !b
|
|
endif !nval*nvbe*nal*nbe.gt.0
|
|
|
|
return
|
|
end subroutine trf_amplitudes
|
|
|
|
subroutine trf_t2(nv,no,oldt2,newt2,work,uo,uv,ut1,ut2)
|
|
c work has to be at least 2*max(nv,no)**2 size
|
|
implicit none
|
|
integer nv,no,a,b,ab,i,j,ij
|
|
real*8 oldt2(nv*(nv-1)/2,no*(no-1)/2),work(*),uo(no,no),uv(nv,nv)
|
|
real*8 newt2(nv*(nv-1)/2,no*(no-1)/2)
|
|
logical forward
|
|
character ut1,ut2
|
|
|
|
c Transform occupied indeces
|
|
ab=1
|
|
do b=1,nv
|
|
do a=1,b-1
|
|
call yyxxunbtr(oldt2,nv,no,ab,work)
|
|
call dgemm('n',ut1,no,no,no,1.d0,work,no,uo,no,0.d0,
|
|
& work(no**2+1),no)
|
|
call dgemm(ut2,'n',no,no,no,1.d0,uo,no,work(no**2+1),no,
|
|
& 0.d0,work,no)
|
|
|
|
ij=1
|
|
do j=1,no
|
|
do i=1,j-1
|
|
newt2(ab,ij)=work((j-1)*no+i)
|
|
ij=ij+1
|
|
enddo
|
|
enddo
|
|
ab=ab+1
|
|
enddo
|
|
enddo
|
|
|
|
c Transform virtual indeces
|
|
ij=1
|
|
do i=1,no
|
|
do j=1,i-1
|
|
call xxyyunbtr(newt2,nv,no,ij,work)
|
|
call dgemm('n',ut1,nv,nv,nv,1.d0,work,nv,uv,nv,0.d0,
|
|
& work(nv**2+1),nv)
|
|
call dgemm(ut2,'n',nv,nv,nv,1.d0,uv,nv,work(nv**2+1),nv,
|
|
& 0.d0,work,nv)
|
|
|
|
ab=1
|
|
do b=1,nv
|
|
do a=1,b-1
|
|
newt2(ab,ij)=work((b-1)*nv+a)
|
|
ab=ab+1
|
|
enddo
|
|
enddo
|
|
ij=ij+1
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end subroutine trf_t2
|
|
|
|
subroutine projected_spin_cont(nal,nbe,nval,nvbe,s_iJ,s_aJ,
|
|
$ s_Bi,ta1,tb1,tm2,iout,scf_s2,uia,uib,localcc,docc,work,
|
|
$ newtm2,del_overlap)
|
|
implicit none
|
|
integer nal,nbe,nval,nvbe,i,a,b,j,iout
|
|
real*8 s_iJ(nal,nbe),s_aJ(nval,nbe),s_Bi(nvbe,nal),ta1(nval,nal)
|
|
real*8 tb1(nvbe,nbe),tm2(nval,nvbe,nal,nbe),S2T1,S2T2,ddot,scf_s2
|
|
real*8 uia(nal),uib(nbe),S2T1_loc,S2T2_loc,work(*)
|
|
real*8 newtm2(nval,nvbe,nal,nbe)
|
|
character*4 localcc
|
|
logical docc,exists,del_overlap
|
|
|
|
S2T1 = 0.d0; S2T2 = 0.d0; S2T1_loc = 0.d0; S2T2_loc = 0.d0
|
|
|
|
if (localcc.ne.'off ') then
|
|
inquire(file='S_LNO',exist=exists)
|
|
if (.not.exists) return
|
|
open(301,file="S_LNO",form="unformatted")
|
|
else !localcc.eq.off
|
|
inquire(file='S_MO',exist=exists)
|
|
if (.not.exists) return
|
|
open(301,file="S_MO",form="unformatted")
|
|
endif
|
|
rewind(301)
|
|
if (nal*nbe.ne.0) read(301) s_iJ
|
|
if (nval*nbe.ne.0) read(301) s_aJ
|
|
if (nvbe*nal.ne.0) read(301) s_Bi
|
|
if (del_overlap) then
|
|
close(301,status='delete')
|
|
else
|
|
close(301)
|
|
endif
|
|
|
|
c S2T1
|
|
do i=1,nal
|
|
do a=1,nval
|
|
S2T1 = S2T1 - ta1(a,i)*ddot(nbe,s_iJ(i,1),nal,s_aJ(a,1),nval)
|
|
enddo
|
|
enddo
|
|
if (localcc.ne.'off '.and.nval*nal*nbe.ne.0) then
|
|
call dgemv('n',nval,nal,1.d0,ta1,nval,uia,1,0.d0,work(nbe+1),1)
|
|
call dgemv('t',nval,nbe,1.d0,s_aJ,nval,work(nbe+1),1,0.d0,
|
|
$ work,1)
|
|
call dgemv('t',nal,nbe,1.d0,s_iJ,nal,uia,1,0.d0,work(nbe+1),1)
|
|
S2T1_loc = - ddot(nbe,work,1,work(nbe+1),1)
|
|
endif !localcc
|
|
do i=1,nbe
|
|
do a=1,nvbe
|
|
S2T1 = S2T1 - tb1(a,i)*ddot(nal,s_iJ(1,i),1,s_Bi(a,1),nvbe)
|
|
enddo
|
|
enddo
|
|
if (localcc.ne.'off '.and.docc.and.nvbe*nal*nbe.ne.0) then
|
|
call dgemv('n',nvbe,nbe,1.d0,tb1,nvbe,uib,1,0.d0,work(nal+1),1)
|
|
call dgemv('t',nvbe,nal,1.d0,s_Bi,nvbe,work(nal+1),1,0.d0,
|
|
$ work,1)
|
|
call dgemv('n',nal,nbe,1.d0,s_iJ,nal,uib,1,0.d0,work(nal+1),1)
|
|
S2T1_loc = S2T1_loc - ddot(nal,work,1,work(nal+1),1)
|
|
endif !localcc
|
|
|
|
c S2T1
|
|
do j=1,nbe
|
|
do i=1,nal
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
S2T2 = S2T2
|
|
$ - s_Bi(b,i) * s_aJ(a,j) * (tm2(a,b,i,j) + ta1(a,i)*tb1(b,j))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
if (localcc.ne.'off '.and.nval*nvbe*nal*nbe.ne.0) then
|
|
do j=1,nbe
|
|
call dgemv('n',nval*nvbe,nal,1.d0,tm2(1,1,1,j),nval*nvbe,uia,
|
|
$ 1,0.d0,newtm2(1,1,1,j),1)
|
|
enddo
|
|
call dgemv('n',nvbe,nal,1.d0,s_Bi,nvbe,uia,1,0.d0,work,1) ! S_Bi'
|
|
call dgemv('n',nval,nal,1.d0,ta1,nval,uia,1,0.d0,work(nvbe+1),1)!tai'
|
|
do j=1,nbe
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
S2T2_loc = S2T2_loc - 0.5d0 * work(b) * s_aJ(a,j)
|
|
$ * (newtm2(a,b,1,j) + work(nvbe+a)*tb1(b,j))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
if (docc) then
|
|
call dgemv('n',nval*nvbe*nal,nbe,1.d0,tm2,nval*nvbe*nal,uib,1,
|
|
$ 0.d0,newtm2,1)
|
|
call dgemv('n',nval,nbe,1.d0,s_aJ,nval,uib,1,0.d0,work,1) ! S_aJ'
|
|
call dgemv('n',nvbe,nbe,1.d0,tb1,nvbe,uib,1,0.d0,
|
|
$ work(nval+1),1)!tBJ'
|
|
do i=1,nal
|
|
do b=1,nvbe
|
|
do a=1,nval
|
|
S2T2_loc = S2T2_loc - 0.5d0 * work(a) * s_Bi(b,i)
|
|
$ * (newtm2(a,b,i,1) + ta1(a,i)*work(nval+b))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
endif !localcc
|
|
|
|
write(iout,*)
|
|
write(iout,"(' Projected S^2 / T1, T2, total/',
|
|
$2x,f10.6,1x,f10.6,1x,f10.6)")
|
|
$S2T1,S2T2,scf_s2+S2T1+S2T2
|
|
if (localcc.ne.'off ')
|
|
$write(iout,"(' Loc. proj. S^2 / T1, T2, total/',
|
|
$2x,f10.6,1x,f10.6,1x,f10.6)")
|
|
$S2T1_loc,S2T2_loc,scf_s2+S2T1_loc+S2T2_loc
|
|
|
|
return
|
|
end subroutine projected_spin_cont
|
|
|
|
************************************************************************
|
|
* Subroutines for array managment. *
|
|
************************************************************************
|
|
|
|
c {{{ Extracting routines
|
|
c Routines which take one or more hyper index (a<b) and turn it into
|
|
c separete indeces (a,b) or vice versa e.g. folding routines
|
|
|
|
subroutine yyxxunbtr(ta2,nval,nal,ab,list)
|
|
|
|
c Extracts one ab block (i,j,a<b)
|
|
|
|
implicit none
|
|
integer nval,nal,jj,j,i,ab
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),list(nal,nal),tmp
|
|
|
|
do j=1,nal
|
|
list(j,j)=0.d0
|
|
jj=(j-1)*(j-2)/2
|
|
do i=1,j-1
|
|
tmp=ta2(ab,jj+i)
|
|
list(i,j)=tmp
|
|
list(j,i)=-tmp
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end subroutine yyxxunbtr
|
|
|
|
subroutine xxyyunbtr(ta2,nval,nal,ij,list)
|
|
|
|
c Extracts one ij block (a,b,i<j)
|
|
|
|
implicit none
|
|
integer nval,nal,bb,b,a,ij
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),list(nval,nval),tmp
|
|
|
|
do b=1,nval
|
|
list(b,b)=0.d0
|
|
bb=(b-1)*(b-2)/2
|
|
do a=1,b-1
|
|
tmp=ta2(bb+a,ij)
|
|
list(a,b)=tmp
|
|
list(b,a)=-tmp
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end subroutine xxyyunbtr
|
|
|
|
subroutine t3extract(t3,nval3,nal2,nal,fullt3) !local debugging routine
|
|
|
|
implicit none
|
|
integer nval3,nal2,nal,k,ij,i,j
|
|
real*8 t3(nval3,nal2,nal),fullt3(nval3,nal,nal,nal)
|
|
|
|
do k=1,nal
|
|
ij=1
|
|
do j=1,nal
|
|
fullt3(1:nval3,j,j,k)=0.d0
|
|
do i=1,j-1
|
|
fullt3(1:nval3,i,j,k)=t3(1:nval3,ij,k)
|
|
fullt3(1:nval3,j,i,k)=-t3(1:nval3,ij,k)
|
|
ij=ij+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine xxyyext(mat,na,nb,ni,nj,list)
|
|
|
|
c (a<b,i<j)--->(b,j,a,i)
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,aa,bb,ii,jj,nn,jja,jjb,iia,iib
|
|
real*8 mat(((nb-1)*nb/2)*((nj-1)*nj/2)),list(nb*nj,ni*na),tmp
|
|
|
|
list=0.d0
|
|
|
|
nn=0
|
|
do jj=1,nj
|
|
do ii=1,jj-1
|
|
jja=(jj-1)*na
|
|
jjb=(jj-1)*nb
|
|
iia=(ii-1)*na
|
|
iib=(ii-1)*nb
|
|
do bb=1,nb
|
|
do aa=1,bb-1
|
|
nn=nn+1
|
|
tmp=mat(nn)
|
|
list(jjb+bb,iia+aa)=tmp
|
|
list(jjb+aa,iia+bb)=-tmp
|
|
list(iib+bb,jja+aa)=-tmp
|
|
list(iib+aa,jja+bb)=tmp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine xxyyext2(mat,na,ne,ni,nm,list)
|
|
|
|
c (a<e,i<m)--->(a,i,m,e)
|
|
|
|
implicit none
|
|
integer na,ne,ni,nm,nn,m,i,e,a
|
|
real*8 mat((ne*(ne-1)/2)*(nm*(nm-1)/2)),list(na,ni,nm,ne),tmp
|
|
|
|
list=0.d0
|
|
|
|
nn=1
|
|
do m=1,nm
|
|
do i=1,m-1
|
|
do e=1,ne
|
|
do a=1,e-1
|
|
tmp=mat(nn)
|
|
list(a,i,m,e)=tmp
|
|
list(e,i,m,a)=-tmp
|
|
list(a,m,i,e)=-tmp
|
|
list(e,m,i,a)=tmp
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine xxyyunb(mat,na,nb,ni,nj,list)
|
|
|
|
c (a<b,i<j)--->(a,b,i<j)
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,aa,bb,nn,ij,bba,aab
|
|
real*8 mat(((nb-1)*nb/2)*((nj-1)*nj/2)),list(nb*na,(nj-1)*nj/2)
|
|
real*8 tmp
|
|
|
|
list=0.d0
|
|
|
|
nn=1
|
|
do ij=1,(nj-1)*nj/2
|
|
do bb=1,nb
|
|
do aa=1,bb-1
|
|
bba=(bb-1)*na+aa
|
|
aab=(aa-1)*nb+bb
|
|
tmp=mat(nn)
|
|
list(bba,ij)=tmp
|
|
list(aab,ij)=-tmp
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine yyxxunb(mat,na,nb,ni,nj,list)
|
|
|
|
c (a<b,i<j)--->(a<b,i,j)
|
|
implicit none
|
|
integer na,nb,ni,nj,aa,bb,jj,ii,nn,ij
|
|
real*8 mat(((nb-1)*nb/2),((nj-1)*nj/2)),list(((nb-1)*nb/2),ni,nj)
|
|
|
|
nn=nb*(nb-1)/2
|
|
ij=0
|
|
do jj=1,nj
|
|
list(1:nn,jj,jj)=0.d0
|
|
do ii=1,jj-1
|
|
ij=ij+1
|
|
list(1:nn,ii,jj)=mat(1:nn,ij)
|
|
list(1:nn,jj,ii)=-mat(1:nn,ij)
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine yzxxext(mat,na,ni,nj,nk,list)
|
|
|
|
c (a,i,j<k)--->(a,j,k,i)
|
|
|
|
implicit none
|
|
integer na,ni,nj,nk,aa,ii,jj,kk,nn,jjk,kkj,iij,iik
|
|
real*8 mat(na*ni*nk*(nk-1)/2),list(na*nj,ni*nk),tmp
|
|
|
|
do ii=1,ni
|
|
do kk=1,nk
|
|
iik=(ii-1)*nk+kk
|
|
kkj=(kk-1)*na
|
|
do aa=1,na
|
|
list(kkj+aa,iik)=0.d0
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
nn=1
|
|
do kk=1,nk
|
|
kkj=(kk-1)*na
|
|
do jj=1,kk-1
|
|
jjk=(jj-1)*na
|
|
do ii=1,ni
|
|
iik=(ii-1)*nk+kk
|
|
iij=(ii-1)*nj+jj
|
|
do aa=1,na
|
|
tmp=mat(nn)
|
|
list(jjk+aa,iik)=tmp
|
|
list(kkj+aa,iij)=-tmp
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine yzxxunb(mat,na,ni,nj,nk,list)
|
|
|
|
c (a,i,j<k)--->(a,i,j,k)
|
|
|
|
implicit none
|
|
integer na,ni,nj,nk,kk,j,k
|
|
real*8 mat(na*ni,nk*(nk-1)/2),list(na*ni,nj,nk)
|
|
|
|
kk=1
|
|
do k=1,nk
|
|
list(1:na*ni,k,k)=0.d0
|
|
do j=1,k-1
|
|
list(1:na*ni,j,k)=mat(1:na*ni,kk)
|
|
list(1:na*ni,k,j)=-mat(1:na*ni,kk)
|
|
kk=kk+1
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine vzext(mat,ne,nf,nm,nn,list)
|
|
|
|
c (e<f,m<n)--->(n,f,m,e)
|
|
|
|
implicit none
|
|
integer ne,nf,nm,nn,fm,fn,em,en,ii,n,m,e,f
|
|
real*8 mat(nf*(nf-1)/2*nn*(nn-1)/2),list(nn,nf*nm,ne),tmp
|
|
|
|
list=0.d0
|
|
ii=1
|
|
do n=1,nn
|
|
do m=1,n-1
|
|
do f=1,nf
|
|
fm=(m-1)*nf+f
|
|
fn=(n-1)*nf+f
|
|
do e=1,f-1
|
|
em=(m-1)*ne+e
|
|
en=(n-1)*ne+e
|
|
tmp=mat(ii)
|
|
list(n,fm,e)=tmp
|
|
list(n,em,f)=-tmp
|
|
list(m,fn,e)=-tmp
|
|
list(m,en,f)=tmp
|
|
ii=ii+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine abfold(list,na,nb,ni,nj,mat)
|
|
|
|
c (a,b,i<j)--->(a<b,i<j)
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,ij,ab,ijj,a,b
|
|
real*8 list(na*nb*ni*(ni-1)/2),mat(na*(na-1)/2,ni*(ni-1)/2)
|
|
|
|
|
|
do ij=1,ni*(ni-1)/2
|
|
ab=0
|
|
ijj=(ij-1)*na**2
|
|
do b=1,na
|
|
do a=1,b-1
|
|
ab=ab+1
|
|
mat(ab,ij)=mat(ab,ij)+
|
|
&list(ijj+(b-1)*na+a)-list(ijj+(a-1)*na+b)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine abijfold(aibj,na,ni,nb,nj,newt2)
|
|
|
|
c (a,i,b,j)--->(a<b,i<j)
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,a,i,b,j,ij,ab
|
|
real*8 newt2(na*(na-1)/2,nj*(nj-1)/2),aibj(na,ni,nb,nj)
|
|
|
|
do j=1,nj
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
do b=1,nb
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
newt2(ab,ij)=newt2(ab,ij)+aibj(a,i,b,j)-aibj(b,i,a,j)
|
|
&-aibj(a,j,b,i)+aibj(b,j,a,i)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine ijfold(list,nj,ni,nm,nn,mat)
|
|
|
|
c (j,i,m<n)--->(m<n,i<j)
|
|
|
|
implicit none
|
|
integer nj,ni,nm,nn,j,i,ij,mn
|
|
real*8 list(nj,ni,nm*(nm-1)/2),mat(nm*(nm-1)/2,nj*(nj-1)/2)
|
|
|
|
|
|
do j=1,nj
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
do mn=1,nm*(nm-1)/2
|
|
mat(mn,ij)=list(i,j,mn)-list(j,i,mn)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine baeffold(baef,nb,na,nef,abef)
|
|
|
|
c (b,a,e<f)--->(a<b,e<f)
|
|
|
|
implicit none
|
|
integer nb,na,ne,nf,ef,b,a,ab,nef
|
|
real*8 baef(nb,na,nef),abef(nb*(nb-1)/2,nef)
|
|
|
|
do ef=1,nef
|
|
do b=1,nb
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
abef(ab,ef)=abef(ab,ef)+baef(b,a,ef)-baef(a,b,ef)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine read_and_proc_dfint(dfint,dfnb,no,dfint_read,
|
|
& dfint_file,no2,mode)
|
|
implicit none
|
|
integer no,dfnb,m,n,mn,p,no2
|
|
real*8 dfint(dfnb,no,no2),dfint_read(dfnb,no*(no+1)/2)
|
|
real*8,pointer::dfint_readp(:,:,:)
|
|
character*9 dfint_file
|
|
character*2 mode
|
|
c {{{ Interface for pointer
|
|
interface
|
|
subroutine rpoint3d(egydim,haromdim,dim1,dim2,dim3)
|
|
implicit none
|
|
integer dim1,dim2,dim3
|
|
real*8,target :: egydim(dim1,dim2,dim3)
|
|
real*8, pointer :: haromdim(:,:,:)
|
|
end subroutine
|
|
end interface ! }}}
|
|
|
|
if (mode.eq.'up') then
|
|
open(16,file=trim(dfint_file),form='unformatted')
|
|
read(16) dfint_read
|
|
close(16)
|
|
mn=0
|
|
do m=1,no
|
|
do n=1,m
|
|
mn=mn+1
|
|
dfint(1:dfnb,n,m)=dfint_read(1:dfnb,mn)
|
|
if (m.ne.n) dfint(1:dfnb,m,n)=dfint_read(1:dfnb,mn)
|
|
enddo
|
|
enddo
|
|
elseif(mode.eq.'tr') then
|
|
call rpoint3d(dfint_read,dfint_readp,no2,no,dfnb)
|
|
open(16,file=trim(dfint_file),form='unformatted')
|
|
read(16) dfint_readp
|
|
close(16)
|
|
do p=1,dfnb
|
|
do m=1,no
|
|
do n=1,no2
|
|
dfint(p,m,n)=dfint_readp(n,m,p)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
else
|
|
write(*,*) 'unknown mode to read_and_proc_dfint: ',mode
|
|
call mrccend(1)
|
|
endif
|
|
return
|
|
end subroutine read_and_proc_dfint
|
|
c }}}
|
|
|
|
c {{{ Reordering routines
|
|
c Routines which permute the indices of an array
|
|
|
|
subroutine vzrea(mat,ne,nb,ni,nm,list)
|
|
|
|
c (e,b,i,m)--->(m,e,b,i)
|
|
|
|
implicit none
|
|
integer ne,nb,ni,nm,m
|
|
real*8 mat(ne*nb*ni,nm),list(nm,ne*nb*ni)
|
|
|
|
do m=1,nm
|
|
list(m,1:ne*nb*ni)=mat(1:ne*nb*ni,m)
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
|
|
subroutine vxyzext(mat,na,nb,ni,nj,list)
|
|
|
|
c (a,b,i,j)--->(a,i,b,j)
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,aa,b,i,j,nn,astart,bstart,a
|
|
real*8 mat(nb*na*ni*nj),list(na*ni,nb*nj)
|
|
|
|
list=0.d0
|
|
|
|
nn=0
|
|
do j=1,nj
|
|
do i=1,ni
|
|
astart=(i-1)*na
|
|
bstart=(j-1)*nb
|
|
do b=1,nb
|
|
do a=1,na
|
|
list(astart+a,bstart+b)=mat(nn+a)
|
|
enddo
|
|
nn=nn+na
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine vxyzrea(mat,na,nb,nc,ni,list)
|
|
|
|
c (a,b,c,i)--->(c,a,b,i)
|
|
|
|
implicit none
|
|
integer na,nb,nc,ni,aa,bb,cc,ii,jj,nn,iib
|
|
real*8 mat(na*nb*nc*ni),list(nc*na,nb*ni),tmp
|
|
|
|
list=0.d0
|
|
|
|
nn=1
|
|
do ii=1,ni
|
|
do cc=1,nc
|
|
do bb=1,nb
|
|
iib=(ii-1)*nb+bb
|
|
do aa=1,na
|
|
tmp=mat(nn)
|
|
list((aa-1)*nc+cc,iib)=tmp
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine yzvxrea(mat,na,ni,nj,nk,list)
|
|
|
|
c (a,i,j,k)--->(a,j,k,i)
|
|
|
|
implicit none
|
|
integer na,ni,nj,nk,k,j,i,nn,astart,kstart,a
|
|
real*8 mat(na*ni*nj*nk),list(na*nj,nk*ni)
|
|
|
|
nn=0
|
|
do k=1,nk
|
|
do j=1,nj
|
|
astart=(j-1)*na
|
|
do i=1,ni
|
|
kstart=(i-1)*nk
|
|
do a=1,na
|
|
list(astart+a,kstart+k)=mat(nn+a)
|
|
enddo
|
|
nn=nn+na
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine vxyzsw(mat,na,nb,ni,nj,list)
|
|
|
|
c (a,b,i,j)--->(b,a,i,j)
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,aa,bb,mn
|
|
real*8 mat(na,nb,ni*nj),list(nb,na,ni*nj)
|
|
|
|
mn=ni*nj
|
|
do bb=1,nb
|
|
do aa=1,na
|
|
list(bb,aa,1:mn)=mat(aa,bb,1:mn)
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine yzvxsw(mat,na,nb,nc,ni,list)
|
|
|
|
c (a,b,c,i)--->(a,b,i,c)
|
|
|
|
implicit none
|
|
integer na,nb,nc,ni,ab,nn,ii,cc,ic
|
|
real*8 mat(na*nb,nc*ni),list(na*nb,ni*nc)
|
|
|
|
nn=1
|
|
ab=na*nb
|
|
do ii=1,ni
|
|
do cc=1,nc
|
|
ic=(cc-1)*ni+ii
|
|
list(1:ab,ic)=mat(1:ab,nn)
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine vxyzdsw(mat,na,ni,nj,nk,list)
|
|
|
|
c (a,i,j,k)--->(i,a,k,j)
|
|
|
|
implicit none
|
|
integer na,ni,nj,nk,ai,jk,nn,aa,ii,jj,kk
|
|
real*8 mat(na*ni*nj*nk),list(na*ni,nj*nk)
|
|
|
|
nn=1
|
|
do kk=1,nk
|
|
do jj=1,nj
|
|
jk=(jj-1)*nk+kk
|
|
do ii=1,ni
|
|
do aa=1,na
|
|
ai=(aa-1)*ni+ii
|
|
list(ai,jk)=mat(nn)
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine yzxxsw(mat,na,ni,nj,nk,list)
|
|
|
|
c (a,i,j<k)--->(i,a,j<k)
|
|
|
|
implicit none
|
|
integer na,ni,nj,nk,nkk,aa,ii,nn
|
|
real*8 mat(na*ni,nk*(nk-1)/2),list(ni,na,nk*(nk-1)/2)
|
|
|
|
nkk=nk*(nk-1)/2
|
|
nn=1
|
|
do ii=1,ni
|
|
do aa=1,na
|
|
list(ii,aa,1:nkk)=mat(nn,1:nkk)
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine vovorea(mat,na,ni,nb,nj,list)
|
|
|
|
c (a,i,b,j)--->(b,i,a,j)
|
|
|
|
implicit none
|
|
integer na,ni,nb,nj,aa,nn,ib,aai,bb,ii
|
|
real*8 mat(na*ni*nb,nj),list(na*ni*nb,nj)
|
|
|
|
nn=1
|
|
do bb=1,nb
|
|
do ii=1,ni
|
|
do aa=1,na
|
|
aai=(aa-1)*ni*nb+(ii-1)*nb+bb
|
|
list(aai,1:nj)=mat(nn,1:nj)
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine vvoorea(mat,nf,ne,nm,nn,list)
|
|
|
|
c (f,e,m,n)--->(m,e,n,f)
|
|
|
|
implicit none
|
|
integer nf,ne,nm,nn,ii,m,e,n,f
|
|
real*8 mat(nf*ne*nm*nn),list(nm,ne,nn,nf)
|
|
|
|
ii=1
|
|
do n=1,nn
|
|
do m=1,nm
|
|
do e=1,ne
|
|
do f=1,nf
|
|
list(m,e,n,f)=mat(ii)
|
|
ii=ii+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine vzsw(mat,nj,ne,nb,nm,list)
|
|
|
|
c (j,e,b,m)--->(m,e,b,j)
|
|
|
|
implicit none
|
|
integer nj,ne,nb,nm,eb,m,nn
|
|
real*8 mat(nj,ne*nb*nm),list(nm,ne*nb,nj)
|
|
|
|
nn=1
|
|
do m=1,nm
|
|
do eb=1,ne*nb
|
|
list(m,eb,1:nj)=mat(1:nj,nn)
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine ejmbrea(mat,ne,nj,nm,nb,list)
|
|
|
|
c (e,j,m,b)--->(m,e,b,j)
|
|
|
|
implicit none
|
|
integer ne,nj,nm,nb,b,m,j,e,nn
|
|
real*8 mat(ne*nj*nm*nb),list(nm,ne,nb,nj)
|
|
|
|
nn=1
|
|
do b=1,nb
|
|
do m=1,nm
|
|
do j=1,nj
|
|
do e=1,ne
|
|
list(m,e,b,j)=list(m,e,b,j)+mat(nn)
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine bfjnrea(mat,nb,nf,nj,nn,list)
|
|
|
|
c (b,f,j,n)--->(n,f,b,j)
|
|
|
|
implicit none
|
|
integer nb,nf,nj,nn,j,f,b,n,ii
|
|
real*8 mat(nb*nf*nj*nn),list(nn,nf,nb,nj)
|
|
|
|
ii=1
|
|
list=0.d0
|
|
do n=1,nn
|
|
do j=1,nj
|
|
do f=1,nf
|
|
do b=1,nb
|
|
list(n,f,b,j)=mat(ii)
|
|
ii=ii+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine vtrp(mat,na,ni,tmat)
|
|
|
|
implicit none
|
|
integer na,ni,nn,a,i
|
|
real*8 mat(na*ni),tmat(ni,na)
|
|
|
|
nn=1
|
|
do i=1,ni
|
|
do a=1,na
|
|
tmat(i,a)=mat(nn)
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine relocatearray(length,array,destination,backward)
|
|
!DIR$ NOOPTIMIZE
|
|
!Relocate an array elementwise
|
|
implicit none
|
|
integer length,i
|
|
real*8 array(length),destination(length)
|
|
logical backward
|
|
|
|
if (backward) then
|
|
!$OMP CRITICAL (bw)
|
|
do i=1,length
|
|
destination(i)=array(i)
|
|
enddo
|
|
!$OMP END CRITICAL (bw)
|
|
else
|
|
!$OMP CRITICAL (fw)
|
|
do i=length,1,-1
|
|
destination(i)=array(i)
|
|
enddo
|
|
!$OMP END CRITICAL (fw)
|
|
endif
|
|
return
|
|
end subroutine relocatearray
|
|
c }}}
|
|
|
|
c {{{ Adding routines
|
|
c Routines which add together two arrays, with different index orders
|
|
|
|
subroutine vxyzextadd(mat,na,nb,ni,nj,list)
|
|
|
|
c (a,b,i,j)--->(a,i,b,j)
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,aa,bb,ii,jj,nn,iiia,iia,jjb
|
|
real*8 mat(nb*na*ni*nj),list(na*ni,nb*nj)
|
|
|
|
nn=1
|
|
do jj=1,nj
|
|
do ii=1,ni
|
|
iiia=(ii-1)*na
|
|
iia=ii*na
|
|
jjb=(jj-1)*nb
|
|
do bb=1,nb
|
|
list(iiia+1:iia,jjb+bb)=list(iiia+1:iia,jjb+bb)+mat(nn:nn+na)
|
|
nn=nn+na
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine yzvxreaadd(mat,na,ni,nj,nk,list)
|
|
|
|
c (a,i,j,k)--->(a,j,k,i)
|
|
|
|
implicit none
|
|
integer na,ni,nj,nk,kk,jj,ii,aa,nn,jja,iik,jjja
|
|
real*8 mat(na*ni*nj*nk),list(na*nj,nk*ni)
|
|
|
|
nn=1
|
|
do kk=1,nk
|
|
do jj=1,nj
|
|
jja=(jj-1)*na
|
|
jjja=jj*na
|
|
do ii=1,ni
|
|
iik=(ii-1)*nk
|
|
list(jja+1:jjja,iik+kk)=list(jja+1:jjja,iik+kk)+mat(nn:nn+na)
|
|
nn=nn+na
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine vxyzswadd(mat,na,nb,ni,nj,list)
|
|
|
|
c (a,b,i,j)--->(b,a,i,j)
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,aa,bb,mn
|
|
real*8 mat(na,nb,ni*nj),list(nb,na,ni*nj)
|
|
|
|
mn=ni*nj
|
|
do bb=1,nb
|
|
do aa=1,na
|
|
list(bb,aa,1:mn)=list(bb,aa,1:mn)+mat(aa,bb,1:mn)
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine yzvxswadd(mat,na,nb,nc,ni,list)
|
|
|
|
c (a,b,c,i)--->(a,b,i,c)
|
|
|
|
implicit none
|
|
integer na,nb,nc,ni,ab,nn,ii,cc,ic
|
|
real*8 mat(na*nb,nc*ni),list(na*nb,ni*nc)
|
|
|
|
nn=1
|
|
ab=na*nb
|
|
do ii=1,ni
|
|
do cc=1,nc
|
|
ic=(cc-1)*ni+ii
|
|
list(1:ab,ic)=list(1:ab,ic)+mat(1:ab,nn)
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine ttbld(ta,tb,ne,ni,na,nm,tt)
|
|
|
|
implicit none
|
|
integer ne,ni,na,nm,nn,a,i,m,e
|
|
real*8 ta(ne,ni),tb(na,nm),tt(na*ni*nm*ne)
|
|
|
|
nn=1
|
|
do e=1,ne
|
|
do m=1,nm
|
|
do i=1,ni
|
|
do a=1,na
|
|
tt(nn)=ta(e,i)*tb(a,m)
|
|
nn=nn+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine mebjreadd(mbej,nm,nb,ne,nj,mebj)
|
|
|
|
c (m,b,e,j)--->(m,e,b,j)
|
|
|
|
implicit none
|
|
integer nj,ne,nm,nb,b,m,e,j
|
|
real*8 mbej(nm,nb,ne,nj),mebj(nm,ne,nb,nj)
|
|
|
|
do j=1,nj
|
|
do b=1,nb
|
|
do e=1,ne
|
|
do m=1,nm
|
|
mebj(m,e,b,j)=mebj(m,e,b,j)+mbej(m,b,e,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine jiabadd(jiab,nj,ni,na,nb,f0,fx,abij)
|
|
|
|
c Adds (j,i,a,b)--->(a,b,i,j) where b starts from f0 and ends at f0+fx.
|
|
|
|
implicit none
|
|
integer nj,ni,na,nb,f0,fx,j,i,ji,ij,ef,a,b,ab
|
|
real*8 jiab(nj*ni,fx*na),abij(na*nb,ni*nj)
|
|
|
|
do j=1,nj
|
|
do i=1,ni
|
|
ij=(j-1)*ni+i
|
|
ji=(i-1)*nj+j
|
|
ef=1
|
|
do b=f0,f0+fx-1
|
|
do a=1,na
|
|
ab=(b-1)*na+a
|
|
abij(ab,ij)=abij(ab,ij)+jiab(ji,ef)
|
|
ef=ef+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine ijkladd(mnij,ijkl,ij)
|
|
|
|
c Adds ((i<j)<(k<l)) to (i<j,k<l).
|
|
|
|
implicit none
|
|
integer ij,i,j
|
|
real*8 mnij(ij,ij),ijkl(ij*(ij+1)/2),tmp
|
|
|
|
do i=1,ij
|
|
do j=1,i
|
|
tmp=ijkl(i*(i-1)/2+j)
|
|
mnij(j,i)=mnij(j,i)+tmp
|
|
if (i.ne.j) mnij(i,j)=mnij(i,j)+tmp
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
c }}}
|
|
|
|
c {{{ Tau building routines
|
|
c Routines which build some version of tau
|
|
|
|
subroutine ttmbld(ta,tb,na,ni,nb,nj,tt)
|
|
|
|
implicit none
|
|
integer na,ni,nb,nj,bij,b,i,j
|
|
real*8 ta(na,ni),tb(nb,nj),tt(na,nj*ni*nb)
|
|
|
|
do j=1,nj
|
|
do i=1,ni
|
|
do b=1,nb
|
|
bij=(j-1)*ni*nb+(i-1)*nb+b
|
|
tt(1:na,bij)=tt(1:na,bij)+ta(1:na,i)*tb(b,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine ttmbld2(ta,tb,tm,na,ni,nb,nj,tt)
|
|
|
|
implicit none
|
|
integer na,ni,nb,nj,bij,b,i,j,bji
|
|
real*8 ta(na,ni),tb(nb,nj),tt(na,nb,nj,ni),tm(na,nb,ni,nj)
|
|
|
|
do i=1,ni
|
|
do j=1,nj
|
|
do b=1,nb
|
|
tt(1:na,b,j,i)=tm(1:na,b,i,j)+ta(1:na,i)*tb(b,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine ttabld(ta,tb,na,ni,nb,nj,tt)
|
|
|
|
implicit none
|
|
integer na,ni,nb,nj,ij,b,i,j,a,ab
|
|
real*8 ta(na,ni),tb(nb,nj),tt(nb*(nb-1)/2,nj*(nj-1)/2)
|
|
|
|
do j=1,nj
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
do b=1,nb
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
tt(ab,ij)=tt(ab,ij)+ta(a,i)*tb(b,j)-ta(b,i)*tb(a,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine locttabld(ta,tb,ta2,na,ni,nb,nj,tt)
|
|
|
|
c Builds ta2+ta1*ta1 with a<b,i,j
|
|
|
|
implicit none
|
|
integer na,ni,nb,nj,ij,b,i,j,jj,a,ab,iij,ji,nn
|
|
real*8 ta(na,ni),tb(nb,nj),tt(nb*(nb-1)/2,nj**2)
|
|
real*8 ta2(na*(na-1)/2,ni*(ni-1)/2)
|
|
|
|
nn=nb*(nb-1)/2
|
|
do j=1,nj
|
|
jj=(j-1)*ni+j
|
|
tt(1:nn,jj)=0.d0
|
|
do i=1,j-1
|
|
ij=(j-1)*ni+i
|
|
ji=(i-1)*nj+j
|
|
iij=(j-1)*(j-2)/2+i
|
|
do b=1,nb
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
tt(ab,ij)=ta2(ab,iij)+ta(a,i)*tb(b,j)-ta(b,i)*tb(a,j)
|
|
enddo
|
|
enddo
|
|
tt(1:nn,ji)=-tt(1:nn,ij)
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine locttbabld(ta,tb,tm2,na,nb,ni,nj,tt)
|
|
|
|
c Builds tab2+ta*tb
|
|
|
|
implicit none
|
|
integer na,ni,nb,nj,a,b,i,j
|
|
real*8 ta(na,ni),tb(nb,nj),tt(na,nb,nj,ni),tm2(na,nb,ni,nj)
|
|
|
|
do i=1,ni
|
|
do j=1,nj
|
|
do b=1,nb
|
|
tt(1:na,b,j,i)=tm2(1:na,b,i,j)+ta(1:na,i)*tb(b,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine tttbld(t2,nf,nb,nj,nn,ta,tb,ttt)
|
|
|
|
implicit none
|
|
integer nf,nj,j,b,f,n,nb,nn
|
|
real*8 t2(nf*(nf-1)/2,nj*(nj-1)/2),ta(nf,nj),tb(nf,nj)
|
|
real*8 ttt(nn,nf,nb,nj),tmp
|
|
|
|
do n=1,nn
|
|
do j=1,n
|
|
do b=1,nb
|
|
do f=1,b
|
|
if (n.ne.j.and.b.ne.f) then
|
|
tmp=0.5d0*t2((b-1)*(b-2)/2+f,(n-1)*(n-2)/2+j)
|
|
ttt(n,f,b,j)=tmp+ta(f,j)*tb(b,n)
|
|
ttt(j,f,b,n)=-tmp+ta(f,n)*tb(b,j)
|
|
ttt(n,b,f,j)=-tmp+ta(b,j)*tb(f,n)
|
|
ttt(j,b,f,n)=tmp+ta(b,n)*tb(f,j)
|
|
elseif (n.ne.j.and.b.eq.f) then
|
|
ttt(n,b,b,j)=ta(b,j)*tb(b,n)
|
|
ttt(j,b,b,n)=ta(b,n)*tb(b,j)
|
|
elseif (n.eq.j.and.b.ne.f) then
|
|
ttt(n,f,b,n)=ta(f,n)*tb(b,n)
|
|
ttt(n,b,f,n)=ta(b,n)*tb(f,n)
|
|
elseif (n.eq.j.and.b.eq.f) then
|
|
ttt(n,b,b,n)=ta(b,n)*tb(b,n)
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine ttabbabld(t2,nf,nb,nj,nn,ta,tb,ttt)
|
|
|
|
implicit none
|
|
integer nf,nj,j,b,f,n,ii,nb,nn
|
|
real*8 t2(nf,nb,nj,nn),ta(nf,nj),tb(nb,nn)
|
|
real*8 ttt(nj*nf*nb*nn)
|
|
|
|
ii=1
|
|
do j=1,nj
|
|
do b=1,nb
|
|
do f=1,nf
|
|
do n=1,nn
|
|
ttt(ii)=0.5d0*t2(f,b,j,n)+ta(f,j)*tb(b,n)
|
|
ii=ii+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine ttbaabbld(t2,nf,nb,nj,nn,ta,tb,ttt)
|
|
|
|
implicit none
|
|
integer nf,nj,j,b,f,n,ii,nb,nn
|
|
real*8 t2(nb,nf,nn,nj),ta(nf,nj),tb(nb,nn)
|
|
real*8 ttt(nj*nf*nb*nn)
|
|
|
|
ii=1
|
|
do j=1,nj
|
|
do b=1,nb
|
|
do f=1,nf
|
|
do n=1,nn
|
|
ttt(ii)=0.5d0*t2(b,f,n,j)+ta(f,j)*tb(b,n)
|
|
ii=ii+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine taubld1(t2,t1,na,nb,ni,nj,tau)
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,j,i,a,b,bba,jji
|
|
real*8 t2(na*(na-1)/2,ni*(ni-1)/2),tau(na*(na-1)/2,ni*(ni-1)/2)
|
|
real*8 t1(na,ni)
|
|
|
|
do j=1,nj
|
|
do i=1,j-1
|
|
jji=(j-1)*(j-2)/2+i
|
|
do b=1,nb
|
|
do a=1,b-1
|
|
bba=(b-1)*(b-2)/2+a
|
|
tau(bba,jji)=t2(bba,jji)+
|
|
&t1(a,i)*t1(b,j)-t1(b,i)*t1(a,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine taubldefabcd(t2,t1,ne,nf,ni,nj,f0,fx,nblc,tau)
|
|
|
|
c Builds tau(e<f,i<j) where f starts from f0 and ends at f0+fx.
|
|
|
|
implicit none
|
|
integer ne,nf,ni,nj,f0,fx,eff,ef,ij,e,f,i,j,nblc
|
|
real*8 t2(nf*(nf-1)/2,nj*(nj-1)/2),t1(nf,nj),tau(nblc,nj*(nj-1)/2)
|
|
|
|
do j=1,nj
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
eff=1
|
|
do f=f0,f0+fx-1
|
|
do e=1,f-1
|
|
ef=(f-1)*(f-2)/2+e
|
|
tau(eff,ij)=t2(ef,ij)+t1(e,i)*t1(f,j)-t1(f,i)*t1(e,j)
|
|
eff=eff+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine taumbld(t2,ta1,tb1,na,nb,ni,nj,tau)
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,a,b,i,j,jji,bba
|
|
real*8 t2(na*nb,ni*nj),ta1(na,ni),tb1(nb,nj),tau(na*nb,ni*nj)
|
|
|
|
do j=1,nj
|
|
do i=1,ni
|
|
jji=(j-1)*ni+i
|
|
do b=1,nb
|
|
do a=1,na
|
|
bba=(b-1)*na+a
|
|
tau(bba,jji)=t2(bba,jji)+ta1(a,i)*tb1(b,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine taumbld2(t2,ta1,tb1,ne,nf,ni,nj,f0,fx,tau)
|
|
|
|
c Builds tau where f starts at f0 and ends at f0+fx.
|
|
|
|
implicit none
|
|
integer ne,nf,ni,nj,f0,fx,j,i,ef,ij,eff,e,f
|
|
real*8 t2(ne*nf,ni*nj),ta1(ne,ni),tb1(nf,nj),tau(fx*ne,ni*nj)
|
|
|
|
do j=1,nj
|
|
do i=1,ni
|
|
ij=(j-1)*ni+i
|
|
do f=f0,f0+fx-1
|
|
do e=1,ne
|
|
ef=(f-1-f0+1)*ne+e
|
|
eff=(f-1)*ne+e
|
|
tau(ef,ij)=t2(eff,ij)+ta1(e,i)*tb1(f,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine tautbld2(t2,t1,na,nb,ni,nj,taut)
|
|
|
|
c Builds tau tilde, with the first two indices unpacked.
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,a,b,i,j,bba,jji,ab,ba
|
|
real*8 t2(na*(na-1)/2,ni*(ni-1)/2),t1(na,ni)
|
|
real*8 taut(na*nb,ni*(ni-1)/2),tmp
|
|
|
|
do jji=1,nj*(nj-1)/2
|
|
do b=1,nb
|
|
taut((b-1)*na+b,jji)=0.d0
|
|
enddo
|
|
enddo
|
|
|
|
do j=1,nj
|
|
do i=1,j-1
|
|
jji=(j-1)*(j-2)/2+i
|
|
do b=1,nb
|
|
do a=1,b-1
|
|
bba=(b-1)*(b-2)/2+a
|
|
ba=(b-1)*na+a
|
|
ab=(a-1)*nb+b
|
|
tmp=t2(bba,jji)+
|
|
&0.5d0*(t1(a,i)*t1(b,j)-t1(b,i)*t1(a,j))
|
|
taut(ba,jji)=tmp
|
|
taut(ab,jji)=-tmp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine tautbld3(t2,t1,na,nb,ni,nj,taut)
|
|
|
|
c Builds tau tilde, with the last two indices unpacked.
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,a,b,i,j,bba,jji,ij,ji
|
|
real*8 t2(na*(na-1)/2,ni*(ni-1)/2),t1(na,ni)
|
|
real*8 taut(na*(na-1)/2,ni*nj),tmp
|
|
|
|
do j=1,nj
|
|
taut(1:nb*(nb-1)/2,(j-1)*nj+j)=0.d0
|
|
enddo
|
|
|
|
do j=1,nj
|
|
do i=1,j-1
|
|
jji=(j-1)*(j-2)/2+i
|
|
ji=(j-1)*ni+i
|
|
ij=(i-1)*nj+j
|
|
do b=1,nb
|
|
do a=1,b-1
|
|
bba=(b-1)*(b-2)/2+a
|
|
tmp=t2(bba,jji)+
|
|
&0.5d0*(t1(a,i)*t1(b,j)-t1(b,i)*t1(a,j))
|
|
taut(bba,ji)=tmp
|
|
taut(bba,ij)=-tmp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine tautmbld(t2,ta1,tb1,na,nb,ni,nj,taut)
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,a,b,i,j,jji,bba
|
|
real*8 t2(na*nb,ni*nj),ta1(na,ni),tb1(nb,nj),taut(na*nb,ni*nj)
|
|
|
|
do j=1,nj
|
|
do i=1,ni
|
|
jji=(j-1)*ni+i
|
|
do b=1,nb
|
|
do a=1,na
|
|
bba=(b-1)*na+a
|
|
taut(bba,jji)=t2(bba,jji)+
|
|
&0.5d0*ta1(a,i)*tb1(b,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine tautmbld2(t2,ta1,tb1,na,nb,ni,nj,taut)
|
|
|
|
c Builds tau tilde, with the first two indices switched.
|
|
|
|
implicit none
|
|
integer na,nb,ni,nj,a,b,i,j,jji,bba,aab
|
|
real*8 t2(na*nb,ni*nj),ta1(na,ni),tb1(nb,nj),taut(na*nb,ni*nj)
|
|
|
|
do j=1,nj
|
|
do i=1,ni
|
|
jji=(j-1)*ni+i
|
|
do a=1,na
|
|
do b=1,nb
|
|
bba=(b-1)*na+a
|
|
aab=(a-1)*nb+b
|
|
taut(aab,jji)=t2(bba,jji)+
|
|
&0.5d0*ta1(a,i)*tb1(b,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine tautmbld3(t2,ta1,tb1,na,nb,ni,nj,taut)
|
|
|
|
c Builds tau tilde, with i,a,b,j.
|
|
implicit none
|
|
integer na,nb,ni,nj,a,b,i,j,jji,bba,bj,ia
|
|
real*8 t2(na*nb,ni*nj),ta1(na,ni),tb1(nb,nj),taut(na*ni,nb*nj)
|
|
|
|
do j=1,nj
|
|
do b=1,nb
|
|
bj=(j-1)*nb+b
|
|
do a=1,na
|
|
bba=(b-1)*na+a
|
|
do i=1,ni
|
|
jji=(j-1)*ni+i
|
|
ia=(a-1)*ni+i
|
|
taut(ia,bj)=t2(bba,jji)+
|
|
&0.5d0*ta1(a,i)*tb1(b,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
c }}}
|
|
|
|
c {{{ Block managing routines
|
|
c Routines that deal with the batches of abef and abci type arrays
|
|
|
|
function eftile(i,j,faadr,nf)
|
|
|
|
c Returns the size of the i,j-th abcd tile.
|
|
|
|
implicit none
|
|
integer i,j,nf,faadr(nf+1),eftile
|
|
|
|
eftile=
|
|
&((faadr(i+1)-1)*(faadr(i+1)-2)/2-(faadr(i)-1)*(faadr(i)-2)/2)*
|
|
&((faadr(j+1)-1)*(faadr(j+1)-2)/2-(faadr(j)-1)*(faadr(j)-2)/2)
|
|
|
|
return
|
|
end
|
|
|
|
function efmtile(i,j,fmadr,nf,nval)
|
|
|
|
c Returns the size of the i,j-th abcd tile. (ab)
|
|
|
|
implicit none
|
|
integer i,j,nf,fmadr(nf+1),efmtile,nval
|
|
|
|
efmtile=(fmadr(i+1)-fmadr(i))*nval*(fmadr(j+1)-fmadr(j))*nval
|
|
|
|
return
|
|
end
|
|
|
|
subroutine minmemnf(nal,nbe,nval,nvbe,faadr,fbadr,
|
|
&fmadr,dfnbasis,minmem,ccsdalg)
|
|
|
|
implicit none
|
|
integer nal,nbe,nval,nvbe,faadr(nval+1),fbadr(nvbe+1),dfnbasis
|
|
integer fmadr(nvbe+1),minmem,nblc,i,f0,puffln,ma,ab,efln,eftile
|
|
integer efmln,efmtile,pufflndir
|
|
character*8 ccsdalg
|
|
|
|
nblc=1
|
|
c Alpha
|
|
pufflndir=
|
|
&nval**2*(nval+1)/2+nval*dfnbasis
|
|
puffln=0
|
|
faadr(1)=1
|
|
|
|
do i=2,nval+1
|
|
faadr(i)=faadr(i-1)+nblc
|
|
enddo
|
|
|
|
ma=nal*nval
|
|
ab=nval*(nval-1)/2
|
|
|
|
do f0=1,nval
|
|
puffln=efln(f0,faadr,nval)**2
|
|
do i=1,nval
|
|
if (eftile(f0,i,faadr,nval).gt.puffln) puffln=
|
|
&eftile(f0,i,faadr,nval)
|
|
enddo
|
|
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
minmem=max(minmem,max(
|
|
&efln(f0,faadr,nval)*(ma+ab)+pufflndir,
|
|
&efln(f0,faadr,nval)*(ma+ab+nval**2),
|
|
&efln(f0,faadr,nval)*(ma+ab+nal*(nal-1)/2),
|
|
&efln(f0,faadr,nval)*(ma+nal**2),
|
|
&efln(f0,faadr,nval)*ma+max(
|
|
&(faadr(f0+1)-faadr(f0))*(ma*(faadr(f0+1)-1)+nal),
|
|
&(faadr(f0+1)-faadr(f0))*ma*(faadr(f0)-1)+(faadr(f0)-1)*nal))
|
|
&+nval*(nval+1)*dfnbasis/2)
|
|
else
|
|
minmem=max(minmem,max(
|
|
&efln(f0,faadr,nval)*(ma+ab)+puffln,
|
|
&efln(f0,faadr,nval)*(ma+ab+nval**2),
|
|
&efln(f0,faadr,nval)*(ma+ab+nal*(nal-1)/2),
|
|
&efln(f0,faadr,nval)*(ma+nal**2),
|
|
&efln(f0,faadr,nval)*ma+max(
|
|
&(faadr(f0+1)-faadr(f0))*(ma*(faadr(f0+1)-1)+nal),
|
|
&(faadr(f0+1)-faadr(f0))*ma*(faadr(f0)-1)+(faadr(f0)-1)*nal)))
|
|
endif !ccsdalg
|
|
enddo
|
|
|
|
c Beta
|
|
pufflndir=
|
|
&nvbe**2*(nvbe+1)/2+nvbe*(nvbe+1)*dfnbasis/2+nvbe*dfnbasis
|
|
puffln=0
|
|
fbadr(1)=1
|
|
|
|
do i=2,nvbe+1
|
|
fbadr(i)=fbadr(i-1)+nblc
|
|
enddo
|
|
|
|
ma=nbe*nvbe
|
|
ab=nvbe*(nvbe-1)/2
|
|
|
|
do f0=1,nvbe
|
|
puffln=efln(f0,fbadr,nvbe)**2
|
|
do i=1,nvbe
|
|
if (eftile(f0,i,fbadr,nvbe).gt.puffln) puffln=
|
|
&eftile(f0,i,fbadr,nvbe)
|
|
enddo
|
|
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
minmem=max(minmem,max(
|
|
& efln(f0,fbadr,nvbe)*(ma+ab)+pufflndir,
|
|
& efln(f0,fbadr,nvbe)*(ma+ab+nvbe**2),
|
|
& efln(f0,fbadr,nvbe)*(ma+ab+nbe*(nbe-1)/2),
|
|
& efln(f0,fbadr,nvbe)*(ma+nbe**2),
|
|
& efln(f0,fbadr,nvbe)*ma+max(
|
|
& (fbadr(f0+1)-fbadr(f0))*(ma*(fbadr(f0+1)-1)+nbe),
|
|
& (fbadr(f0+1)-fbadr(f0))*ma*(fbadr(f0)-1)+(fbadr(f0)-1)*nbe)))
|
|
else
|
|
minmem=max(minmem,max(
|
|
& efln(f0,fbadr,nvbe)*(ma+ab)+puffln,
|
|
& efln(f0,fbadr,nvbe)*(ma+ab+nvbe**2),
|
|
& efln(f0,fbadr,nvbe)*(ma+ab+nbe*(nbe-1)/2),
|
|
& efln(f0,fbadr,nvbe)*(ma+nbe**2),
|
|
& efln(f0,fbadr,nvbe)*ma+max(
|
|
& (fbadr(f0+1)-fbadr(f0))*(ma*(fbadr(f0+1)-1)+nbe),
|
|
& (fbadr(f0+1)-fbadr(f0))*ma*(fbadr(f0)-1)+(fbadr(f0)-1)*nbe)))
|
|
endif !ccsdalg
|
|
enddo
|
|
|
|
c Mixed
|
|
fmadr(1)=1
|
|
|
|
do i=2,nvbe+1
|
|
fmadr(i)=fmadr(i-1)+1
|
|
enddo
|
|
|
|
ma=max(nbe*nval,nal*nvbe)
|
|
ab=nval*nvbe
|
|
|
|
do f0=1,nvbe
|
|
puffln=efmln(f0,fmadr,nvbe,nval)**2
|
|
do i=1,nvbe
|
|
if (efmtile(f0,i,fmadr,nvbe,nval).gt.puffln)
|
|
&puffln=efmtile(f0,i,fmadr,nvbe,nval)
|
|
enddo
|
|
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
minmem=max(minmem,max(
|
|
&efmln(f0,fmadr,nvbe,nval)*(ma+nal*nbe+nbe),
|
|
&efmln(f0,fmadr,nvbe,nval)*(ma+nval*nvbe*2)+puffln,
|
|
&efmln(f0,fmadr,nvbe,nval)*(ma+nval*nvbe+nal*nbe))+
|
|
&dfnbasis*nval*(nval+1)/2+dfnbasis)
|
|
else
|
|
minmem=max(minmem,max(
|
|
&efmln(f0,fmadr,nvbe,nval)*(ma+nal*nbe+nbe),
|
|
&efmln(f0,fmadr,nvbe,nval)*(ma+nval*nvbe*2)+puffln,
|
|
&efmln(f0,fmadr,nvbe,nval)*(ma+nval*nvbe+nal*nbe)))
|
|
endif
|
|
enddo
|
|
|
|
return
|
|
end subroutine
|
|
|
|
subroutine nfblc(nfa,faadr,nal,nval,nbe,nvbe,iout,maxcor,imem,
|
|
&imem1,incore,dfnbasis,dfcalc,spin,error,ccsdalg,mem_used)
|
|
|
|
c Returns the number of blocks needed for the <ab||ef> aa or bb list.
|
|
|
|
implicit none
|
|
integer nfa,rmdr,faadr(nval+1),iout,efln,eftile,ma,ab,puffln
|
|
integer nal,nval,f0,maxcor,imem,imem1,nblc,i,incore,dfnbasis
|
|
integer memdflist,nbe,nvbe,reqmem,mem_used,max_reqmem
|
|
|
|
logical error,dfcalc,fits_in_memory
|
|
character*1 spin
|
|
character*8 ccsdalg
|
|
|
|
nfa=0
|
|
puffln=0
|
|
reqmem=0
|
|
max_reqmem=0
|
|
do
|
|
nfa=nfa+1
|
|
if (nfa.gt.nval) then
|
|
call memcheck(max_reqmem,maxcor-imem+imem1,iout,error)
|
|
return
|
|
endif
|
|
fits_in_memory = .true.
|
|
max_reqmem=0
|
|
|
|
nblc=nval/nfa
|
|
rmdr=mod(nval,nfa)
|
|
faadr(1)=1
|
|
|
|
do i=2,nfa+1
|
|
if (i-1.le.rmdr) then
|
|
faadr(i)=faadr(i-1)+nblc+1
|
|
else
|
|
faadr(i)=faadr(i-1)+nblc
|
|
endif
|
|
enddo
|
|
|
|
ma=nal*nval
|
|
ab=nval*(nval-1)/2
|
|
|
|
do f0=1,nfa
|
|
puffln=efln(f0,faadr,nfa)**2
|
|
do i=1,nfa
|
|
if (eftile(f0,i,faadr,nfa).gt.puffln) puffln=
|
|
&eftile(f0,i,faadr,nfa)
|
|
enddo
|
|
c Checking if we have enough memory
|
|
if (.not.dfcalc) then
|
|
reqmem=incore+max(efln(f0,faadr,nfa)*(ma+ab)+puffln,
|
|
& efln(f0,faadr,nfa)*(ma+ab+nval**2),
|
|
& efln(f0,faadr,nfa)*(ma+ab+nal*(nal-1)/2),
|
|
& efln(f0,faadr,nfa)*(ma+nal**2),
|
|
& efln(f0,faadr,nfa)*ma+
|
|
& max((faadr(f0+1)-faadr(f0))*(ma*(faadr(f0+1)-1)+nal),
|
|
& (faadr(f0+1)-faadr(f0))*ma*(faadr(f0)-1)+(faadr(f0)-1)*nal))
|
|
else !dfcalc
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
puffln=nval**2*(nval+1)/2+nval*dfnbasis
|
|
reqmem=incore+max(efln(f0,faadr,nfa)*(ma+ab)+puffln,
|
|
& efln(f0,faadr,nfa)*(ma+ab+nval**2),
|
|
& efln(f0,faadr,nfa)*(ma+ab+nal*(nal-1)/2),
|
|
& efln(f0,faadr,nfa)*(ma+nal**2),
|
|
& efln(f0,faadr,nfa)*ma+max(
|
|
& (faadr(f0+1)-faadr(f0))*(ma*(faadr(f0+1)-1)+nal),
|
|
& (faadr(f0+1)-faadr(f0))*ma*(faadr(f0)-1)+(faadr(f0)-1)*nal))
|
|
& +dfnbasis*nval*(nval+1)/2 !jaab
|
|
else !ccsdalg.ne.dfdirect
|
|
reqmem=incore+max(efln(f0,faadr,nfa)*(ma+ab)+puffln,
|
|
& efln(f0,faadr,nfa)*(ma+ab+nval**2),
|
|
& efln(f0,faadr,nfa)*(ma+ab+nal*(nal-1)/2),
|
|
& efln(f0,faadr,nfa)*(ma+nal**2),
|
|
& efln(f0,faadr,nfa)*ma+max(
|
|
& (faadr(f0+1)-faadr(f0))*(ma*(faadr(f0+1)-1)+nal),
|
|
& (faadr(f0+1)-faadr(f0))*ma*(faadr(f0)-1)+(faadr(f0)-1)*nal))
|
|
endif !ccsdalg
|
|
reqmem=max(reqmem,memdflist(nal,nval,nbe,nvbe,dfnbasis,faadr,
|
|
& faadr,faadr,nfa,nfa,nfa,spin,ccsdalg))
|
|
endif !dfcalc
|
|
max_reqmem = max(reqmem,max_reqmem)
|
|
c Jump to next nfa if not enough memory
|
|
if (max_reqmem.gt.maxcor-imem+imem1) then
|
|
fits_in_memory = .false.
|
|
exit
|
|
endif
|
|
enddo
|
|
if (fits_in_memory) exit
|
|
enddo
|
|
mem_used = max(mem_used, max_reqmem)
|
|
|
|
return
|
|
end
|
|
|
|
subroutine fadrbld(nfa,nval,faadr)
|
|
|
|
c Builds the final fadr after, nfa is calculated.
|
|
|
|
implicit none
|
|
integer nfa,faadr(nfa+1),nblc,rmdr,nval,i
|
|
|
|
nblc=nval/nfa
|
|
rmdr=mod(nval,nfa)
|
|
faadr(1)=1
|
|
|
|
do i=2,nfa+1
|
|
if (i-1.le.rmdr) then
|
|
faadr(i)=faadr(i-1)+nblc+1
|
|
else
|
|
faadr(i)=faadr(i-1)+nblc
|
|
endif
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine nfabblc(nfm,fmadr,nal,nval,nbe,nvbe,iout,maxcor,imem,
|
|
&imem1,incore,dfnbasis,dfcalc,spin,error,ccsdalg,mem_used)
|
|
|
|
c Returns the number of blocks needed for the <ab||ef> ab list.
|
|
|
|
implicit none
|
|
integer nfm,nbe,nvbe,nal,nval,iout,maxcor,imem,imem1,fmadr(nvbe+1)
|
|
integer nblc,rmdr,efmln,efmtile,ma,ab,i,f0,puffln,incore,dfnbasis
|
|
integer memdflist,reqmem,mem_used,max_reqmem
|
|
|
|
logical error,dfcalc,fits_in_memory
|
|
character*1 spin
|
|
character*8 ccsdalg
|
|
|
|
nfm=0
|
|
reqmem=0
|
|
max_reqmem=0
|
|
do
|
|
nfm=nfm+1
|
|
if (nfm.gt.nvbe) then
|
|
call memcheck(reqmem,maxcor-imem+imem1,iout,error)
|
|
return
|
|
endif
|
|
fits_in_memory = .true.
|
|
max_reqmem = 0
|
|
|
|
nblc=nvbe/nfm
|
|
rmdr=mod(nvbe,nfm)
|
|
fmadr(1)=1
|
|
|
|
do i=2,nfm+1
|
|
if (i-1.le.rmdr) then
|
|
fmadr(i)=fmadr(i-1)+nblc+1
|
|
else
|
|
fmadr(i)=fmadr(i-1)+nblc
|
|
endif
|
|
enddo
|
|
|
|
ma=max(nbe*nval,nal*nvbe)
|
|
ab=nval*nvbe
|
|
|
|
do f0=1,nfm
|
|
puffln=efmln(f0,fmadr,nfm,nval)**2
|
|
do i=1,nfm
|
|
if (efmtile(f0,i,fmadr,nfm,nval).gt.puffln)
|
|
&puffln=efmtile(f0,i,fmadr,nfm,nval)
|
|
enddo
|
|
|
|
if (dfcalc) then
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
reqmem=incore+max(efmln(f0,fmadr,nfm,nval)*(ma+nal*nbe+nbe),
|
|
& efmln(f0,fmadr,nfm,nval)*(ma+nval*nvbe*2)+puffln,
|
|
& efmln(f0,fmadr,nfm,nval)*(ma+nval*nvbe+nal*nbe))
|
|
& +dfnbasis*nval*(nval+1)/2+dfnbasis*puffln/nval**2
|
|
elseif(trim(ccsdalg).eq.'disk') then
|
|
reqmem=incore+max(efmln(f0,fmadr,nfm,nval)*(ma+nal*nbe+nbe),
|
|
& efmln(f0,fmadr,nfm,nval)*(ma+nval*nvbe*2)+puffln,
|
|
& efmln(f0,fmadr,nfm,nval)*(ma+nval*nvbe+nal*nbe))
|
|
endif !ccsdalg
|
|
reqmem=max(reqmem,memdflist(nal,nval,nbe,nvbe,dfnbasis,fmadr,
|
|
& fmadr,fmadr,nfm,nfm,nfm,spin,ccsdalg))
|
|
else !.not.dfcalc
|
|
reqmem=incore+max(
|
|
&efmln(f0,fmadr,nfm,nval)*(ma+nal*nbe+nbe),
|
|
&efmln(f0,fmadr,nfm,nval)*(ma+nval*nvbe*2)+puffln,
|
|
&efmln(f0,fmadr,nfm,nval)*(ma+nval*nvbe+nal*nbe))
|
|
endif !dfcalc
|
|
max_reqmem = max(reqmem,max_reqmem)
|
|
if (max_reqmem.gt.maxcor-imem+imem1) then
|
|
fits_in_memory=.false.
|
|
exit
|
|
endif
|
|
enddo !i=1,nfm
|
|
if (fits_in_memory) exit
|
|
enddo
|
|
mem_used = max(mem_used, max_reqmem)
|
|
|
|
return
|
|
end
|
|
|
|
subroutine rectfold(rect,f0,fx,mb)
|
|
|
|
c Builds a rectangle from a trapezoid with height fx and bases f0, f0+fx
|
|
|
|
implicit none
|
|
integer f0,fx,mb,c,b
|
|
real*8 rect((f0+fx)*mb,fx)
|
|
|
|
do c=1,fx-1
|
|
do b=1,fx-c
|
|
rect((f0+c+b-1)*mb+1:(f0+c+b)*mb,c)=
|
|
&-rect((f0+c-1)*mb+1:(f0+c)*mb,c+b)
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine maefinp(mat,nm,na,nblc,puff)
|
|
|
|
c (m,a,e<f)--->(a,m,e<f) in place, with nblc e<f indices.
|
|
|
|
implicit none
|
|
integer nm,na,nblc,ef,a,m,am,ma
|
|
real*8 mat(nm*na,nblc),puff(nm*na)
|
|
|
|
c do ef=1,nblc
|
|
c do a=1,na
|
|
c do m=1,nm
|
|
c am=(m-1)*na+a
|
|
c puff(am)=mat((a-1)*nm+m,ef)
|
|
c enddo
|
|
c enddo
|
|
|
|
do ef=1,nblc
|
|
ma=1
|
|
do a=1,na
|
|
do m=1,nm
|
|
am=(m-1)*na+a
|
|
puff(am)=mat(ma,ef)
|
|
ma=ma+1
|
|
enddo
|
|
enddo
|
|
|
|
mat(1:nm*na,ef)=puff(1:nm*na)
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine efmiexp(t2,ne,nf,nm,ni,f0,fx,nblc,t2blc)
|
|
|
|
c Builds (e<f,m<i)--->(m,e<f,i) with f starting from f0 and ending at f0+fx-1.
|
|
|
|
implicit none
|
|
integer f0,fx,nblc,nf,ne,nm,ni,i,m,e,f,ef,eff,mi
|
|
real*8 t2(nf*(nf-1)/2,ni*(ni-1)/2),t2blc(nm,nblc,ni)
|
|
|
|
do i=1,ni
|
|
t2blc(i,1:nblc,i)=0.d0
|
|
enddo
|
|
|
|
c write(*,*) ni,nblc
|
|
c do i=1,ni
|
|
c do eff=1,nblc
|
|
c t2blc(i,eff,i)=0.d0
|
|
c enddo
|
|
c enddo
|
|
|
|
c t2blc=0.d0
|
|
|
|
do i=1,ni
|
|
do m=1,i-1
|
|
mi=(i-1)*(i-2)/2+m
|
|
ef=1
|
|
do f=f0,f0+fx-1
|
|
do e=1,f-1
|
|
eff=(f-1)*(f-2)/2+e
|
|
t2blc(m,ef,i)= t2(eff,mi)
|
|
t2blc(i,ef,m)=-t2(eff,mi)
|
|
ef=ef+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine efmiexpm1(t2,ne,nf,nm,ni,f0,fx,nblc,t2blc)
|
|
|
|
c Builds (e,f,m,i)--->(m,e,f,i) with f starting from f0 and ending at f0+fx.
|
|
|
|
implicit none
|
|
integer ne,nf,nm,ni,f0,fx,nblc,i,m,mi,ef,f,e
|
|
real*8 t2(ne*nf,nm*ni),t2blc(nm,nblc,ni)
|
|
|
|
do i=1,ni
|
|
ef=1
|
|
do f=f0,f0+fx-1
|
|
do e=1,ne
|
|
do m=1,nm
|
|
mi=(i-1)*nm+m
|
|
t2blc(m,ef,i)=t2((f-1)*ne+e,mi)
|
|
enddo
|
|
ef=ef+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine efmiexpm2(t2,ne,nf,ni,nm,f0,fx,nblc,t2blc)
|
|
|
|
c Builds (e,f,i,m)--->(m,e,f,i) with f starting from f0 and ending at f0+fx.
|
|
|
|
implicit none
|
|
integer ne,nf,nm,ni,f0,fx,nblc,i,m,im,f,e,ef
|
|
real*8 t2(ne*nf,nm*ni),t2blc(nm,nblc,ni)
|
|
|
|
do m=1,nm
|
|
do i=1,ni
|
|
im=(m-1)*ni+i
|
|
ef=1
|
|
do f=f0,f0+fx-1
|
|
do e=1,ne
|
|
t2blc(m,ef,i)=t2((f-1)*ne+e,im)
|
|
ef=ef+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine ijabfold(ijab,ni,nj,na,nb,f0,fx,nblc,abij)
|
|
|
|
c Folds (i,j,a<b)--->(a<b,i<j) with nblc a<b-s.
|
|
|
|
implicit none
|
|
integer ni,nj,na,nb,nblc,f0,fx,ef,eff,ij,i,j,f,e
|
|
real*8 ijab(ni,nj,nblc),abij(nb*(nb-1)/2,nj*(nj-1)/2)
|
|
|
|
do j=1,nj
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
ef=1
|
|
do f=f0,f0+fx-1
|
|
do e=1,f-1
|
|
eff=(f-1)*(f-2)/2+e
|
|
abij(eff,ij)=abij(eff,ij)+ijab(i,j,ef)-ijab(j,i,ef)
|
|
ef=ef+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine rectfoldexp1(amef,na,nm,ne,nf,f0,fx,nblc,rect)
|
|
|
|
c From (a,m,e<f) trapezoid builds (f,m,a,e) rectangle.
|
|
|
|
implicit none
|
|
integer na,nm,ne,nf,f0,fx,nblc,e,a,m,f,ef,fe
|
|
real*8 amef(na,nm,nblc),rect(fx,nm,na,f0+fx-1)
|
|
|
|
do e=1,f0+fx-1
|
|
do a=1,na
|
|
do m=1,nm
|
|
do f=f0,f0+fx-1
|
|
ef=(f-1)*(f-2)/2+e-(f0-2)*(f0-1)/2
|
|
fe=(e-1)*(e-2)/2+f-(f0-2)*(f0-1)/2
|
|
if (e.lt.f) then
|
|
rect(f-f0+1,m,a,e)= amef(a,m,ef)
|
|
elseif (e.gt.f) then
|
|
rect(f-f0+1,m,a,e)=-amef(a,m,fe)
|
|
else
|
|
rect(f-f0+1,m,a,e)=0.d0
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine rectfoldexp2(amef,na,nm,ne,nf,f0,fx,nblc,rect)
|
|
|
|
c From (a,m,e<f) trapezoid builds (m,e,a,f) rectangle.
|
|
|
|
implicit none
|
|
integer na,nm,ne,nf,f0,fx,nblc,e,a,m,f,ef
|
|
real*8 amef(na,nm,nblc), rect(f0-1,nm,na,fx)
|
|
|
|
do f=f0,f0+fx-1
|
|
do a=1,na
|
|
do m=1,nm
|
|
do e=1,f0-1
|
|
ef=(f-1)*(f-2)/2+e-(f0-2)*(f0-1)/2
|
|
rect(e,m,a,f-f0+1)=-amef(a,m,ef)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine vecblc(t1,nf,nm,f0,fx,vec)
|
|
|
|
c From t(f,m) vector builds vec(f,m) where f starts from f0 and ends at f0+fx-1.
|
|
|
|
implicit none
|
|
integer nf,nm,f0,fx,m,f
|
|
real*8 t1(nf,nm),vec(fx,nm)
|
|
|
|
do m=1,nm
|
|
do f=f0,f0+fx-1
|
|
vec(f-f0+1,m)=t1(f,m)
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine vectblc(t1,nf,nm,f0,fx,vec)
|
|
|
|
c From t(f,m) vector builds vec(m,f) where f starts from f0 and ends at f0+fx.
|
|
|
|
implicit none
|
|
integer nf,nm,f0,fx,m,f
|
|
real*8 t1(nf,nm),vec(nm,fx)
|
|
|
|
do m=1,nm
|
|
do f=f0,f0+fx-1
|
|
vec(m,f-f0+1)=t1(f,m)
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine ijabadd(ijab,ni,nj,na,nb,f0,fx,abij)
|
|
|
|
c Adds (i,j,a,b) to (a,b,i,j) where b starts from f0 and ends at f0+fx.
|
|
|
|
implicit none
|
|
integer ni,nj,na,nb,f0,fx,i,j,ij,ef,a,b,ab
|
|
real*8 ijab(ni*nj,fx*na),abij(na*nb,ni*nj)
|
|
|
|
do j=1,nj
|
|
do i=1,ni
|
|
ij=(j-1)*ni+i
|
|
ef=1
|
|
do b=f0,f0+fx-1
|
|
do a=1,na
|
|
ab=(b-1)*na+a
|
|
abij(ab,ij)=abij(ab,ij)+ijab(ij,ef)
|
|
ef=ef+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine amefinp(amef,na,nm,ne,fx,puff)
|
|
|
|
c (a,m,e,f)--->(a,e,m,f) in place.
|
|
|
|
implicit none
|
|
integer na,nm,ne,fx,i,f,e,m,a
|
|
real*8 amef(na*nm*ne*fx),puff(na*nm*ne)
|
|
|
|
i=1
|
|
do f=1,fx
|
|
do e=1,ne
|
|
do m=1,nm
|
|
do a=1,na
|
|
puff((m-1)*ne*na+(e-1)*na+a)=amef(i)
|
|
i=i+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
amef((f-1)*ne*nm*na+1:f*ne*nm*na)=puff(1:ne*nm*na)
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine aemfinp(aemf,na,ne,nm,fx,puff)
|
|
|
|
c (a,e,m,f)--->(m,a,e,f) in place.
|
|
|
|
implicit none
|
|
integer na,nm,ne,fx,i,a,e,f,m
|
|
real*8 aemf(na*nm*ne*fx),puff(na*nm*ne)
|
|
|
|
i=1
|
|
do f=1,fx
|
|
do m=1,nm
|
|
do e=1,ne
|
|
do a=1,na
|
|
puff((e-1)*na*nm+(a-1)*nm+m)=aemf(i)
|
|
i=i+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
aemf((f-1)*ne*na*nm+1:f*ne*na*nm)=puff(1:ne*na*nm)
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine amfeinp(amfe,na,nm,nf,fx,puff)
|
|
|
|
c (a,m,f,e)--->(f,m,a,e) in place.
|
|
|
|
implicit none
|
|
integer na,nm,nf,fx,e,f,m,a,i
|
|
real*8 amfe(na*nm*nf*fx),puff(na*nm*nf)
|
|
|
|
i=1
|
|
do e=1,fx
|
|
do f=1,nf
|
|
do m=1,nm
|
|
do a=1,na
|
|
puff((a-1)*nm*nf+(m-1)*nf+f)=amfe(i)
|
|
i=i+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
amfe((e-1)*nf*nm*na+1:e*nm*na*nf)=puff(1:nm*na*nf)
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine abcd1(puff,ni,nj,block,nab,nef,start)
|
|
|
|
c Places an abcd rectangle tile in its block.
|
|
|
|
implicit none
|
|
integer ni,nj,start,nab,nef,i,j
|
|
real*8 puff(ni,nj),block(nab*nef)
|
|
|
|
do j=1,nj
|
|
do i=1,ni
|
|
block((j-1)*nab+start+i-1)=puff(i,j)
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine abcd1direct(puff,block,nab,start,fmadr,nval,
|
|
&nvbe,i,k)
|
|
|
|
c Places an abcd triangle tile to its block.
|
|
|
|
implicit none
|
|
integer i,start,nab,fmadr(nvbe+1),k,f,b,ncab,nval,e,a,nvbe,finpuff
|
|
integer einpuff
|
|
real*8 puff(nval*(nval+1)/2,
|
|
&fmadr(i+1)-fmadr(i),fmadr(k+1)-fmadr(k))
|
|
real*8 block(nab,(fmadr(k+1)-fmadr(k))*nval),tmp
|
|
|
|
do f=fmadr(k),fmadr(k+1)-1
|
|
finpuff=f-fmadr(k)+1
|
|
do e=fmadr(i),fmadr(i+1)-1
|
|
einpuff=e-fmadr(i)+1
|
|
do b=1,nval
|
|
do a=1,b
|
|
tmp=puff(b*(b-1)/2+a,einpuff,finpuff)
|
|
block(start-1+(einpuff-1)*nval+a,(finpuff-1)*nval+b)=tmp
|
|
if (a.ne.b)
|
|
& block(start-1+(einpuff-1)*nval+b,(finpuff-1)*nval+a)=tmp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
|
|
subroutine abcd2(puff,ni,nj,block,nab,nef,start)
|
|
|
|
c Places an abcd triangle tile to its block.
|
|
|
|
implicit none
|
|
integer i,j,ni,nj,start,nab,nef
|
|
real*8 puff((nj+1)*nj/2),block(nab*nef),tmp
|
|
|
|
do j=1,nj
|
|
do i=1,j
|
|
tmp=puff((j-1)*j/2+i)
|
|
block((j-1)*nab+start+i-1)=tmp
|
|
if (j.ne.i) block((i-1)*nab+start+j-1)=tmp
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine abcd2direct(puff,block,nab,start,fmadr,nval,
|
|
&nvbe,k)
|
|
|
|
c Places an abcd triangle tile to its block.
|
|
|
|
implicit none
|
|
integer start,nab,fmadr(nvbe+1),k,f,b,ncab,nval,e,a,nvbe,finpuff
|
|
integer einpuff
|
|
real*8 puff(nval*(nval+1)/2,
|
|
&(fmadr(k+1)-fmadr(k)+1)*(fmadr(k+1)-fmadr(k))/2)
|
|
real*8 block(nab,(fmadr(k+1)-fmadr(k))*nval),tmp
|
|
|
|
do f=fmadr(k),fmadr(k+1)-1
|
|
finpuff=f-fmadr(k)+1
|
|
do e=fmadr(k),f
|
|
einpuff=e-fmadr(k)+1
|
|
do b=1,nval
|
|
do a=1,b
|
|
tmp=puff(b*(b-1)/2+a,finpuff*(finpuff-1)/2+einpuff)
|
|
block(start-1+(einpuff-1)*nval+a,(finpuff-1)*nval+b)=tmp
|
|
if (e.ne.f) then
|
|
block(start-1+(finpuff-1)*nval+a,(einpuff-1)*nval+b)=tmp
|
|
if (a.ne.b)
|
|
& block(start-1+(finpuff-1)*nval+b,(einpuff-1)*nval+a)=tmp
|
|
endif
|
|
if (a.ne.b)
|
|
& block(start-1+(einpuff-1)*nval+b,(finpuff-1)*nval+a)=tmp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine abcd3(puff,ni,nj,block,nab,nef,start)
|
|
|
|
c Transposes and places and abcd rectangle tile in its block.
|
|
|
|
implicit none
|
|
integer ni,nj,nab,nef,i,j,start
|
|
real*8 puff(ni,nj),block(nab*nef)
|
|
|
|
do j=1,nj
|
|
do i=1,ni
|
|
block((i-1)*nab+start+j-1)=puff(i,j)
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
subroutine abcd3direct(puff,block,nab,start,fmadr,nval,
|
|
&nvbe,i,k)
|
|
|
|
c Places an abcd triangle tile to its block.
|
|
|
|
implicit none
|
|
integer i,start,nab,fmadr(nvbe+1),k,f,b,ncab,nval,e,a,nvbe,finpuff
|
|
integer einpuff
|
|
real*8 puff(nval*(nval+1)/2,
|
|
&fmadr(k+1)-fmadr(k),fmadr(i+1)-fmadr(i))
|
|
real*8 block(nab,(fmadr(k+1)-fmadr(k))*nval),tmp
|
|
|
|
do f=fmadr(i),fmadr(i+1)-1
|
|
finpuff=f-fmadr(i)+1
|
|
do e=fmadr(k),fmadr(k+1)-1
|
|
einpuff=e-fmadr(k)+1
|
|
do b=1,nval
|
|
do a=1,b
|
|
tmp=puff(b*(b-1)/2+a,einpuff,finpuff)
|
|
block(start-1+(finpuff-1)*nval+b,(einpuff-1)*nval+a)=tmp
|
|
if (a.ne.b)
|
|
& block(start-1+(finpuff-1)*nval+a,(einpuff-1)*nval+b)=tmp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
return
|
|
end
|
|
c }}}
|
|
|
|
************************************************************************
|
|
* Miscellaneous subroutines *
|
|
************************************************************************
|
|
|
|
c {{{ Routines for determining memory requirements
|
|
|
|
function t_minmem(nal,nbe,nval,nvbe,nquad,dfnbasis,talg,mem_used)
|
|
implicit none
|
|
integer nal,nbe,nval,nvbe,nquad,incoret,t_minmem,dfnbasis,ijadim
|
|
integer abalen,ijalen,taaa_minmem,tabb_minmem,tbba_minmem
|
|
integer mem_used
|
|
character*4 talg
|
|
|
|
mem_used = 0
|
|
incoret = nval*nal+nvbe*nbe+nval*(nval-1)*nal*(nal-1)/4+
|
|
&nvbe*(nvbe-1)*nbe*(nbe-1)/4+nval*nvbe*nal*nbe+(nal+nval)**2+
|
|
&(nbe+nvbe)**2
|
|
if (talg.eq.'lapl') then
|
|
incoret = incoret + nval*nbe*nal*nbe + nvbe*nal*nbe*nal + !aijkab, aijkba
|
|
$ nquad*(nal+nval+nbe+nvbe) ! quadrature weights
|
|
t_minmem=incoret+max(taaa_minmem(nal,nval,dfnbasis,talg,mem_used),
|
|
$ taaa_minmem(nbe,nvbe,dfnbasis,talg,mem_used),
|
|
$ tabb_minmem(nal,nbe,nval,nvbe,dfnbasis,talg,mem_used),
|
|
$ tabb_minmem(nbe,nal,nvbe,nval,dfnbasis,talg,mem_used),
|
|
$ tbba_minmem(nal,nbe,nval,nvbe,dfnbasis,talg,mem_used),
|
|
$ tbba_minmem(nbe,nal,nvbe,nval,dfnbasis,talg,mem_used))
|
|
mem_used = mem_used + incoret
|
|
endif
|
|
|
|
return
|
|
end function t_minmem
|
|
|
|
function taaa_minmem(nal,nval,dfnbasis,talg,mem_used)
|
|
implicit none
|
|
integer taaa_minmem,nal,nval,dfnbasis,ijdim,ijlen,ablen,mem_used
|
|
character*4 talg
|
|
|
|
ijdim = nal*(nal+1)/2
|
|
ijlen = nal*(nal-1)/2
|
|
ablen = nval*(nval-1)/2
|
|
taaa_minmem =
|
|
$ nval*nal*nal*(nal-1)/2+nval**2+nval**2+nval**2+
|
|
$ nval*(nval-1)*nal/2+nval*(nval-1)*nal/2+nval*(nval-1)*nal/2+
|
|
$ nval**2*nal+nval**2+nval*nval*(nval-1)/2+
|
|
$ nval*(nval-1)*(nval-2)/6+nval*(nval-1)*(nval-2)/6 !fix part of taaa
|
|
mem_used=max(mem_used,taaa_minmem+nal*nval**2*(nval-1)/2+nval**3)
|
|
taaa_minmem = taaa_minmem+
|
|
$ max(nal**2+max(dfnbasis*nval*nal,dfnbasis*nal**2+
|
|
$ max(dfnbasis*nal**2+dfnbasis*ijdim,nval*nal**3),
|
|
$ max(2*nal**2+ablen*ijlen,nval*nal)),!trf2laplbasisaaa
|
|
$ 3*nval**2*(nval-1)/2+nval**3) ! abcis
|
|
|
|
return
|
|
end function taaa_minmem
|
|
|
|
function tabb_minmem(nal,nbe,nval,nvbe,dfnbasis,talg,mem_used)
|
|
implicit none
|
|
integer tabb_minmem,nal,nbe,nval,nvbe,dfnbasis,ijadim,ijbdim
|
|
integer mem_used
|
|
character*4 talg
|
|
|
|
ijadim = nal*(nal+1)/2
|
|
ijbdim = nbe*(nbe+1)/2
|
|
tabb_minmem =
|
|
$ nvbe*nbe*nbe*(nbe-1)/2+nval*nvbe*nbe+nvbe*(nvbe-1)*nbe/2+
|
|
$ nvbe*(nvbe-1)*nbe/2+nvbe**2+nval*nvbe**2+nval*nvbe*(nvbe-1)/2+
|
|
$ nval*nvbe*(nvbe-1)/2+nvbe**2+nval*nvbe*nbe+nval*nvbe**2 !fix part of tabb
|
|
mem_used = max(mem_used,tabb_minmem+nval**2*nvbe*(nbe+1))
|
|
tabb_minmem = tabb_minmem+
|
|
$ max(nal**2+nbe**2+max(dfnbasis*nvbe*nbe,dfnbasis*nval*nal,
|
|
$ max(dfnbasis*nal**2+dfnbasis*ijadim,nvbe*nbe*nal**2),!Jij
|
|
$ max(dfnbasis*nbe**2+dfnbasis*ijbdim,nval*nal*nbe**2),!JIJ
|
|
$ max(2*nbe**2,2*nal*nbe,nval*nbe,nvbe*nbe)), !trf2laplbasisabb
|
|
$ max(nvbe*nvbe*nval,3*nvbe**2*(nvbe-1)/2+nvbe**3+
|
|
$ 3*nval*nvbe*nval+nval**2*nvbe)) ! abcis
|
|
|
|
return
|
|
end function tabb_minmem
|
|
|
|
function tbba_minmem(nal,nbe,nval,nvbe,dfnbasis,talg,mem_used)
|
|
implicit none
|
|
integer tbba_minmem,nal,nbe,nval,nvbe,dfnbasis,ijadim,ijbdim
|
|
integer mem_used
|
|
character*4 talg
|
|
|
|
ijadim = nal*(nal+1)/2
|
|
ijbdim = nbe*(nbe+1)/2
|
|
tbba_minmem =
|
|
$ nvbe*nbe*nbe*(nbe-1)/2+nval*nvbe*nbe+nvbe*(nvbe-1)*nbe/2+
|
|
$ nvbe*(nvbe-1)*nbe/2+nvbe**2+nval*nvbe**2+nval*nvbe*(nvbe-1)/2+
|
|
$ nval*nvbe*(nvbe-1)/2+nvbe**2*(nvbe-1)/2+nval**2*nvbe+
|
|
$ nvbe**2*(nvbe-1)/2+max(nvbe**3,nval**2*nvbe)+nval**2*nvbe+
|
|
$ nvbe**2+nval*nvbe*nal+nval*nvbe*nal !fix part of tabb
|
|
mem_used = max(mem_used,tbba_minmem+nbe*nvbe**2*(nvbe-1)/2+
|
|
$ nvbe**3+nvbe**2*nval*(nal+1))
|
|
tbba_minmem = tbba_minmem+
|
|
$ max(nal**2+nbe**2+max(dfnbasis*nvbe*nbe,dfnbasis*nval*nal,
|
|
$ max(dfnbasis*nal**2+dfnbasis*ijadim,nvbe*nbe*nal**2),!Jij
|
|
$ max(dfnbasis*nbe**2+dfnbasis*ijbdim,nval*nal*nbe**2),!JIJ
|
|
$ max(2*nbe**2,2*nal*nbe,nval*nbe,nvbe*nbe)), !trf2laplbasisabb
|
|
$ max(nvbe**2*nval+2*nval*nvbe**2,nvbe**3,nval**2*nvbe)) ! abcis
|
|
|
|
return
|
|
end function tbba_minmem
|
|
|
|
function memwmnij(nal,nval)
|
|
|
|
c Returns the minimal required memory for calculating the Wmnij intermediate in words.
|
|
|
|
implicit none
|
|
integer nal,nval,memwmnij
|
|
|
|
memwmnij=max(nval*nal**2*(nal-1)/2+nval*nal**3, !falmi<-vooo*t1
|
|
&nval*nal**2*(nal-1)+nval**2*nal*(nal-1)/2, !nta2<-vooo*t1,nta1<-vooo*t2
|
|
&max(nval*nal**2*(nal-1)/2,(nal*(nal-1)/2)**2)+nal**3*(nal-1)/2, !wmnij<-vooo*t2
|
|
&(nal*(nal-1)/2)**2+max((nal*(nal-1)/2+1)*nal*(nal-1)/4, !o<o,o<o+...,wmnij<-oooo
|
|
&nval*(nval-1)*nal*(nal-1)/2, !wmnij<-tau*vvoo
|
|
&nval**2*nal*(nal-1)+nval*(nval-1)*nal*(nal-1)/4, !falae<-t2*vvoo
|
|
&nval*(nval-1)*nal**2+nval*(nval-1)*nal*(nal-1)/4, !falmi<-t2*vvoo
|
|
&nval**2*nal**2+nval*(nval-1)*nal*(nal-1)/4, !falme<-t1*vvoo
|
|
&nval*(nval-1)*nal*(nal-1)/4)) !nta2<-wmnij*tau
|
|
|
|
return
|
|
end
|
|
|
|
function memwabmnij(nal,nval,nbe,nvbe)
|
|
|
|
c Returns the minimal required memory for calculating the Wabmnij intermediate in words.
|
|
|
|
implicit none
|
|
integer nal,nval,nbe,nvbe,memwabmnij
|
|
|
|
memwabmnij=max(
|
|
&max(nval*nal*nbe**2,nal**2*nbe**2)+nval*nal*nbe**2
|
|
&+nval*nvbe*nal*nbe,
|
|
&max(nval*nal*nbe**2,nal**2*nbe**2)+nal**2*nbe**2,
|
|
&nal**2*nbe**2+2*nvbe*nbe*nal**2,
|
|
&nal**2*nbe**2+3*nval*nvbe*nal*nbe)
|
|
|
|
return
|
|
end
|
|
|
|
function memwmebj(nal,nval,nbe,nvbe)
|
|
|
|
c Returns the minimal required memory for calculating the Wmebj intermediate in words.
|
|
|
|
implicit none
|
|
integer nal,nval,nbe,nvbe,memwmebj
|
|
|
|
memwmebj=(nval*nal)**2+max((nval*nal)**2, !nt1<-t1*ovvo,nt2<-tt*ovvo
|
|
&nval*nal**3+nval*nal**2*(nal-1)/2, !Wmebj<-t1*vooo
|
|
&(nval*nal)**2+nval**2*nal, !wmebj<-t1*vvvo
|
|
&((nval*nal)**2)*2, !wmebj<-ttt*vvoo,nt2<-t2*Wmebj
|
|
&nval*nvbe*nal*nbe*2) !ntm2<-tm2*Wmebj
|
|
|
|
return
|
|
end
|
|
|
|
function memwbamebj(nal,nval,nbe,nvbe)
|
|
|
|
c Returns the minimal required memory for calculating the Wbamebj intermediate in words.
|
|
|
|
implicit none
|
|
integer nal,nval,nbe,nvbe,memwbamebj
|
|
|
|
memwbamebj=nbe*nvbe*nval*nal+max(
|
|
&nvbe*nbe, !nt1<-t1*ovvo
|
|
&(nvbe*nbe)**2+nval*nvbe*nal*nbe, !ntm2<-tt*ovvo
|
|
&nvbe*nbe*nal**2+nval*nvbe*nal*nbe, !Wmebj<-t1*vooo
|
|
&nvbe*nbe*nval, !Wmebj<-t1*vvvo
|
|
&nval*nvbe*nal*nbe+max(nval*nvbe*nal*nbe,(nval*nal)**2), !Wmebj<-tt*vvoo
|
|
&nval*nvbe*nal*nbe+(nval*nal)**2, !nta2<-Wmebj*t2
|
|
&(nvbe*nbe)**2+nval*nvbe*nal*nbe) !ntm2<-Wmebj*t2
|
|
|
|
return
|
|
end
|
|
|
|
function memwabbamebj(nal,nval,nbe,nvbe)
|
|
|
|
c Returns the min required memory for calculating the Wabbamebj intermediate in words.
|
|
|
|
implicit none
|
|
integer nal,nval,nbe,nvbe,memwabbamebj
|
|
|
|
memwabbamebj=nal**2*nvbe**2+max(nvbe*nval*nbe*nal, !ntm2<-tt*ovvo
|
|
&nvbe*nbe*nal**2+max(nvbe*nbe*nal**2,nal**2*nvbe**2), !Wmebj<-t1*vooo
|
|
&nval*nal*nvbe, !Wmebj<-t1*vvvo
|
|
&nval*nvbe*nal*nbe+max(nval*nvbe*nal*nbe,nal**2*nvbe**2), !Wmebj<-t2*vvoo
|
|
&nval*nvbe*nal*nbe*2) !ntm2<-t2*Wmebj
|
|
|
|
return
|
|
end
|
|
|
|
function memdflist(nal,nval,nbe,nvbe,dfnbasis,faadr,fbadr,fmadr,
|
|
&nfa,nfb,nfm,spin,ccsdalg)
|
|
|
|
c Returns the min required memory for assembling DF integs.
|
|
|
|
implicit none
|
|
integer nal,nval,nvbe,nbe,dfnbasis,abadim,abbdim,aiadim,aibdim
|
|
integer ijadim,ijbdim,ija,ijb,abefln,eftile,puffln,listln,abefaln
|
|
integer faadr(nfa+1),fbadr(nfb+1),fmadr(nfm+1),memdflist,i,j,k
|
|
integer efmtile,efln,efmln,nfa,nfb,nfm,abefmln,abefbln
|
|
|
|
character*1 spin
|
|
character*8 ccsdalg
|
|
|
|
ijadim=nal*(nal+1)/2
|
|
ija=nal*(nal-1)/2
|
|
ijb=nbe*(nbe-1)/2
|
|
ijbdim=nbe*(nbe+1)/2
|
|
abadim=nval*(nval+1)/2
|
|
abbdim=nvbe*(nvbe+1)/2
|
|
aiadim=nal*nval
|
|
aibdim=nbe*nvbe
|
|
|
|
abefln=0
|
|
abefaln=0
|
|
abefbln=0
|
|
abefmln=0
|
|
c Memory needed for abef
|
|
c alfa
|
|
if (nval.gt.1) then
|
|
if (spin.eq.'a'.or.spin.eq.'x') then
|
|
if (ccsdalg.ne.'dfdirect') then
|
|
do i=1,nfa
|
|
puffln=efln(i,faadr,nfa)**2
|
|
do j=1,nfa
|
|
if (eftile(i,j,faadr,nfa).gt.puffln) puffln=
|
|
& eftile(i,j,faadr,nfa)
|
|
enddo
|
|
listln=0
|
|
do k=faadr(i),faadr(i+1)-1
|
|
listln=listln+(k**3-3*k**2+4*k-2)/2
|
|
enddo
|
|
abefln=max(abefln,listln+puffln)
|
|
enddo
|
|
abefaln=abadim*nval+(nval**3-3*nval**2+4*nval-2)/2
|
|
endif
|
|
endif
|
|
endif
|
|
|
|
c beta
|
|
if (nvbe.gt.1) then
|
|
if (spin.eq.'b'.or.spin.eq.'x') then
|
|
if (ccsdalg.ne.'dfdirect') then
|
|
do i=1,nfb
|
|
puffln=efln(i,fbadr,nfb)**2
|
|
do j=1,nfb
|
|
if (eftile(i,j,fbadr,nfb).gt.puffln) puffln=
|
|
& eftile(i,j,fbadr,nfb)
|
|
enddo
|
|
|
|
listln=0
|
|
do k=fbadr(i),fbadr(i+1)-1
|
|
listln=listln+(k**3-3*k**2+4*k-2)/2
|
|
enddo
|
|
|
|
abefln=max(abefln,listln+puffln)
|
|
|
|
enddo
|
|
abefbln=abbdim*nvbe+(nvbe**3-3*nvbe**2+4*nvbe-2)/2
|
|
endif
|
|
endif
|
|
endif
|
|
|
|
c mixed
|
|
if (nval.gt.0.and.nvbe.gt.0) then
|
|
if (spin.eq.'m'.or.spin.eq.'x') then
|
|
if (ccsdalg.ne.'dfdirect') then
|
|
do i=1,nfm
|
|
puffln=efmln(i,fmadr,nfm,nval)**2
|
|
do j=1,nfm
|
|
if (efmtile(i,j,fmadr,nfm,nval).gt.puffln)
|
|
& puffln=efmtile(i,j,fmadr,nfm,nval)
|
|
enddo
|
|
|
|
listln=0
|
|
do k=1,fmadr(i),fmadr(i+1)-1
|
|
listln=listln+(nval**2*(2*k-1)+nval)/2
|
|
enddo
|
|
abefln=max(abefln,listln+puffln)
|
|
enddo
|
|
abefmln=abadim*nvbe+(nval**2*(2*nvbe-1)+nval)/2
|
|
endif !ccsdalg
|
|
endif
|
|
endif
|
|
|
|
memdflist=dfnbasis*(abadim+abbdim+aiadim+aibdim+ijadim+ijbdim)+ !<-Jab,Jai,Jij
|
|
&max(
|
|
&max(ijadim**2+ija*(ija-1)/2,ijbdim**2+ijb*(ijb-1)/2, !oooo,alfa,beta
|
|
&ijadim*ijbdim+nal*nbe*(nal*nbe-1)/2, !<-oooo,mixed
|
|
&aiadim*ijadim+nval*nal*ija,aibdim*ijbdim+nvbe*nbe*ijb, !<-vooo,alfa,beta
|
|
&aiadim*ijbdim+nval*nal*nbe**2,aibdim*ijadim+nvbe*nbe*nal**2, !<-vooo,mixed
|
|
&max(aiadim**2,abadim*ijadim)+nval**2*nal**2, !<-- vvoo,ovvo,alfa
|
|
&max(aibdim**2,abbdim*ijbdim)+nvbe**2*nbe**2, !<-- vvoo,ovvo,beta
|
|
&aiadim*aibdim+nal*nbe*nval*nvbe, !<-- vvoo mixed,ovvo,ab,ba
|
|
&abadim*ijbdim+nal*nbe*nval*nvbe,abbdim*ijadim+nal*nval*nvbe*nbe-
|
|
&dfnbasis*ijbdim), !<ovvo,abba,baab, delloc jbij
|
|
&dfnbasis*(aiadim+aibdim)+min(max(abadim*aibdim+nval*nvbe*nval*nbe,!<-in1
|
|
&abbdim*aiadim+nvbe*nvbe*nval*nal,
|
|
&abadim*aiadim+(nval*(nval-1)/2)*nval*nal,
|
|
&abbdim*aibdim+(nvbe*(nvbe-1)/2)*nvbe*nbe),
|
|
&max(dfnbasis*nval**2+max(2*nbe*nval**2, !<-in more blcs,baab,aaaa
|
|
&(nval-1)*nval*nal+2*nal*nval*(nval-1)),
|
|
& dfnbasis*nvbe**2+max(2*nal*nvbe**2, !<- abba,bbbb
|
|
&(nvbe-1)*nvbe*nbe+2*nbe*nvbe*(nvbe-1)))),
|
|
&max(abefaln, !mult.,writing seq. alfa
|
|
& abefbln, !beta
|
|
& abefmln, !mixed
|
|
&abefln)) !<- read seq, write direct
|
|
|
|
return
|
|
end
|
|
c }}}
|
|
|
|
c {{{ Other routines
|
|
c Routines which don't fit any category
|
|
|
|
subroutine fockme(n,fock,ni,na,fme)
|
|
|
|
c Extracts the virtual-occupied block of the Fock-matrix
|
|
|
|
implicit none
|
|
integer i,a,p,q,ni,na
|
|
real*8 fock(ni+na,ni+na),fme(ni*na)
|
|
character*1 n
|
|
|
|
if (n.eq.'n') then
|
|
do a=1,na
|
|
do i=1,ni
|
|
fme((a-1)*ni+i)=fock(i,a+ni)
|
|
enddo
|
|
enddo
|
|
elseif (n.eq.'t') then
|
|
do i=1,ni
|
|
do a=1,na
|
|
fme((i-1)*na+a)=fock(i,a+ni)
|
|
enddo
|
|
enddo
|
|
else
|
|
write(6,*) 'Parameter 1 was incorrect upon entry to fockme!'
|
|
endif
|
|
|
|
return
|
|
end
|
|
|
|
subroutine getfockdiagonal(fock,nocc,nvirt,oe)
|
|
|
|
implicit none
|
|
|
|
integer nocc,nvirt,p
|
|
real*8 fock(nocc+nvirt,nocc+nvirt),oe(nocc+nvirt)
|
|
|
|
do p=1,nocc+nvirt
|
|
oe(p)=fock(p,p)
|
|
enddo
|
|
|
|
return
|
|
end
|
|
|
|
************************************************************************
|
|
subroutine getlst_rz(ifile,irec,vec,ilength,iibufln)
|
|
************************************************************************
|
|
* Read an integer array from a direct access file *
|
|
* ifile - unit number *
|
|
* irec - record number in direct access file *
|
|
* vec - array to be read *
|
|
* ilength - length of the array *
|
|
************************************************************************
|
|
implicit none
|
|
integer ifile,irec,ilength,nrec,i,j,jrec,iibufln
|
|
real*8 vec(*)
|
|
C
|
|
c write(6,*) 'rec=',irec
|
|
c call flush(6)
|
|
|
|
if(ilength.eq.0) return
|
|
j=mod(ilength,iibufln)
|
|
nrec=(ilength-j)/iibufln-1
|
|
do jrec=0,nrec
|
|
|
|
read(ifile,rec=irec+jrec) (vec(jrec*iibufln+i),i=1,iibufln)
|
|
enddo
|
|
if(j.ne.0) read(ifile,rec=irec+nrec+1)
|
|
$(vec((nrec+1)*iibufln+i),i=1,j)
|
|
C
|
|
return
|
|
end
|
|
|
|
subroutine managerestart(readorwrite,calc,nit,emp2,et1,ecc,et,ta1,
|
|
& tb1,ta2,tb2,tm2,irest,nal,nbe,nval,nvbe,
|
|
& ets,ied)
|
|
implicit none
|
|
integer nit,nal,nbe,nval,nvbe,irest,ied
|
|
real*8 emp2,ecc,et,ta1(nal*nval),tb1(nbe*nvbe),ets,et1
|
|
real*8 ta2(nal*(nal-1)*nval*(nval-1)/4),tm2(nal*nbe*nval*nvbe)
|
|
real*8 tb2(nbe*(nbe-1)*nvbe*(nvbe-1)/4)
|
|
character*1 readorwrite
|
|
character*4 calc
|
|
character*6 ied_str
|
|
character*16 restartfile
|
|
|
|
if (ied.gt.0) then
|
|
write(ied_str,"(i6)") ied
|
|
restartfile='UCCSDREST.' // adjustl(trim(ied_str))
|
|
else
|
|
restartfile='UCCSDREST'
|
|
endif !ied
|
|
open(97,file=restartfile,form='unformatted')
|
|
rewind(97)
|
|
if (readorwrite.eq.'w') then
|
|
if (calc.eq.'ccsd') then
|
|
write(97) et1,emp2,ecc
|
|
write(97) ta1
|
|
write(97) tb1
|
|
write(97) ta2
|
|
write(97) tb2
|
|
write(97) tm2
|
|
write(97) nit
|
|
write(97) 0 !irest
|
|
write(97) 0.d0,0.d0 !et,ets
|
|
elseif (calc.eq.'(t) ') then
|
|
! This never runs
|
|
write(97) et1,emp2,ecc
|
|
write(97) ta1
|
|
write(97) tb1
|
|
write(97) ta2
|
|
write(97) tb2
|
|
write(97) tm2
|
|
write(97) nit
|
|
write(97) irest
|
|
write(97) et,ets
|
|
endif
|
|
elseif (readorwrite.eq.'r') then
|
|
if (calc.eq.'ccsd') then
|
|
read(97) et1,emp2,ecc
|
|
read(97) ta1
|
|
read(97) tb1
|
|
read(97) ta2
|
|
read(97) tb2
|
|
read(97) tm2
|
|
read(97) nit
|
|
elseif (calc.eq.'(t) ') then
|
|
read(97) et1,emp2,ecc
|
|
read(97) ta1
|
|
read(97) tb1
|
|
read(97) ta2
|
|
read(97) tb2
|
|
read(97) tm2
|
|
read(97) nit
|
|
read(97) irest
|
|
read(97) et,ets
|
|
endif
|
|
endif
|
|
close(97)
|
|
if (calc.eq.'(t)2') then
|
|
open(97,file=restartfile,form='unformatted',position='append')
|
|
backspace(97) !et,ets
|
|
backspace(97) !irest
|
|
backspace(97) !nit
|
|
if (readorwrite.eq.'w') then
|
|
write(97) nit
|
|
write(97) irest
|
|
write(97) et,ets
|
|
endif
|
|
close(97)
|
|
endif !(T)2
|
|
|
|
return
|
|
end subroutine managerestart
|
|
|
|
c {{{ function read_ied_from_localccrestart
|
|
integer function read_ied_from_localccrestart(lccfirst)
|
|
implicit none
|
|
integer idummy,nmet,idummylist(8)
|
|
real*8 rdummy,rdummylist(100)
|
|
character*16 cscr16
|
|
logical ldummy,lccfirst
|
|
if (.not.lccfirst) open(723,file='localcc.restart')
|
|
rewind(723)
|
|
call localccrestart('read',723,cscr16,cscr16,idummy,
|
|
$ldummy,idummy,idummy,idummy,read_ied_from_localccrestart,nmet,
|
|
$idummy,idummy,idummy,idummy,idummy,idummy,idummy,
|
|
$rdummylist,rdummylist,
|
|
$rdummylist,rdummy,rdummy,rdummy,rdummy,
|
|
$rdummy,rdummy,rdummy,rdummy,rdummy,
|
|
$rdummy,rdummy,rdummy,rdummy,idummylist,
|
|
$rdummy,rdummy,rdummy,rdummy,rdummy,rdummy,rdummy,rdummy)
|
|
if (.not.lccfirst) close(723)
|
|
return
|
|
end function read_ied_from_localccrestart
|
|
c }}}
|
|
c }}}
|
|
|
|
c {{{ subroutine rpoint1d rpoint2d rpoint3d rpoint4d
|
|
subroutine rpoint2i(egydim1,egydim2,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
integer,target :: egydim1(dim1,dim2)
|
|
integer, pointer :: egydim2(:,:)
|
|
egydim2 => egydim1(1:dim1,1:dim2)
|
|
end subroutine
|
|
c }}}
|
|
|
|
|
|
************************************************************************
|
|
subroutine ppl_ss(nal,nval,nfa,faadr,recaadr,ta1,newta1,ta2,
|
|
&newta2,faae,scr,iabc,abcd,irecln,ccsdalg,dfnbasis,dfint_ab,qscale,
|
|
&tscalea,epaa,eccs,eccp,abijaa,fa,eppl,eppl_ss,eppls_ss,epplij)
|
|
************************************************************************
|
|
|
|
c Builds and contracts the Wabef intermediate, contracts some iabc terms
|
|
|
|
implicit none
|
|
|
|
integer k,f0,fx,ma,ab,nblc,ef,nal,nval,faadr(nfa+1),ipuff,i,eftile
|
|
integer recaadr(nfa*(nfa+1)/2),abef,nfa,efln,irecln,ij,off
|
|
integer dfnbasis,jaabsize,blocksize,f,fmax,finblock,b,e,efind
|
|
integer abind,a,ae,be
|
|
real*8 newta2(nval*(nval-1)/2,nal*(nal-1)/2),tscalea(nal),fa,eppl
|
|
real*8 faae(nval,nval),ta1(nval,nal),newta1(nval,nal),eccs,eccp
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2),scr(*),epaa(nal,nal)
|
|
real*8 eppl_ss,eppls_ss,epplc,eccsc,epplij
|
|
real*8,pointer::jaab(:,:),block(:,:),pabef(:,:),jaabb(:,:)
|
|
character*6 iabc,abijaa
|
|
character*5 abcd
|
|
character*8 ccsdalg
|
|
character*9 dfint_ab
|
|
logical qscale
|
|
|
|
c {{{ Interface for pointer
|
|
interface
|
|
subroutine rpoint2d(egydim,haromdim,dim1,dim2)
|
|
implicit none
|
|
integer dim1,dim2
|
|
real*8,target :: egydim(dim1,dim2)
|
|
real*8, pointer :: haromdim(:,:)
|
|
end subroutine
|
|
end interface
|
|
c }}}
|
|
|
|
open(16,file=iabc,form='unformatted')
|
|
open(17,file=abcd,access='direct',recl=irecln)
|
|
|
|
ma=nval*nal
|
|
ab=nval*(nval-1)/2
|
|
|
|
c Read Jab
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
jaabsize=nval*(nval+1)*dfnbasis/2
|
|
open(18,file=trim(dfint_ab),form='unformatted')
|
|
read(18) scr(1:jaabsize)
|
|
close(18)
|
|
call rpoint2d(scr,jaab,dfnbasis,nval*(nval+1)/2)
|
|
else
|
|
jaabsize=0
|
|
endif
|
|
|
|
do k=1,nfa
|
|
f0=faadr(k)
|
|
fx=faadr(k+1)-faadr(k)
|
|
fmax=faadr(k+1)-1
|
|
|
|
nblc=(2*f0+fx-3)*fx/2
|
|
blocksize=ab*nblc
|
|
if (nblc.gt.0) then
|
|
|
|
c Reading abcdaa
|
|
ipuff=jaabsize+ma*nblc+ab*nblc+1
|
|
abef=1
|
|
|
|
if (ccsdalg.eq.'dfdirect') then
|
|
call rpoint2d(scr(jaabsize+ma*nblc+1),block,ab,nblc)
|
|
call rpoint2d(scr(ipuff),pabef,nval*(nval+1)/2,nval)
|
|
call rpoint2d(scr(ipuff+nval**2*(nval+1)/2),jaabb,dfnbasis,nval)
|
|
do f=f0,fmax
|
|
finblock=f-faadr(k)+1
|
|
do b=1,nval
|
|
if (b.le.f) then
|
|
jaabb(1:dfnbasis,b)=jaab(1:dfnbasis,f*(f-1)/2+b)
|
|
else
|
|
jaabb(1:dfnbasis,b)=jaab(1:dfnbasis,b*(b-1)/2+f)
|
|
endif
|
|
enddo
|
|
call dgemm('t','n',nval*(nval+1)/2,nval,dfnbasis,1.d0,jaab,
|
|
& dfnbasis,jaabb,dfnbasis,0.d0,
|
|
& pabef,nval*(nval+1)/2)
|
|
do e=1,f-1
|
|
efind=(2*f0+finblock-4)*(finblock-1)/2+e
|
|
abind=0
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
abind=abind+1
|
|
c Coulomb
|
|
if (a.le.e) then
|
|
ae=e*(e-1)/2+a
|
|
else
|
|
ae=a*(a-1)/2+e
|
|
endif
|
|
c Exchange
|
|
if (b.le.e) then
|
|
be=e*(e-1)/2+b
|
|
else
|
|
be=b*(b-1)/2+e
|
|
endif
|
|
block(abind,efind)=pabef(ae,b)-pabef(be,a)
|
|
enddo !a
|
|
enddo !b
|
|
enddo !e
|
|
enddo !f
|
|
else !ccsdalg.ne.dfdirect
|
|
do i=1,k-1
|
|
call getlst(17,recaadr(k*(k-1)/2+i),scr(ipuff),
|
|
& eftile(i,k,faadr,nfa))
|
|
|
|
call abcd1(scr(ipuff),efln(i,faadr,nfa),efln(k,faadr,nfa),
|
|
& scr(jaabsize+ma*nblc+1),nval*(nval-1)/2,efln(k,faadr,nfa),abef)
|
|
|
|
abef=abef+efln(i,faadr,nfa)
|
|
enddo
|
|
|
|
call getlst(17,recaadr(k*(k-1)/2+k),scr(ipuff),
|
|
& (efln(k,faadr,nfa)+1)*efln(k,faadr,nfa)/2)
|
|
|
|
call abcd2(scr(ipuff),efln(k,faadr,nfa),efln(k,faadr,nfa),
|
|
& scr(jaabsize+ma*nblc+1),nval*(nval-1)/2,efln(k,faadr,nfa),abef)
|
|
|
|
abef=abef+efln(k,faadr,nfa)
|
|
|
|
do i=k+1,nfa
|
|
call getlst(17,recaadr(i*(i-1)/2+k),scr(ipuff),
|
|
& eftile(k,i,faadr,nfa))
|
|
|
|
call abcd3(scr(ipuff),efln(k,faadr,nfa),efln(i,faadr,nfa),
|
|
& scr(jaabsize+ma*nblc+1),nval*(nval-1)/2,efln(k,faadr,nfa),abef)
|
|
|
|
abef=abef+efln(i,faadr,nfa)
|
|
enddo
|
|
endif !ccsdalg
|
|
|
|
c if(qscale) then
|
|
c open(543,file='UCCSD_RES',form='unformatted')
|
|
c write(543) newta2
|
|
c ij=nal*(nal-1)/2
|
|
c call taubldefabcd(ta2,ta1,nval,nval,nal,nal,f0,fx,nblc,
|
|
c &scr(jaabsize+nblc*ma+blocksize+1))
|
|
c if(ij.gt.0)
|
|
c & call dgemm('n','n',ab,ij,nblc,1.d0,scr(jaabsize+nblc*ma+1),ab,
|
|
c &scr(jaabsize+nblc*ma+blocksize+1),nblc,0.d0,newta2,ab)
|
|
c call scaleppl_aa(nal,nval,fa,newta2,
|
|
c $scr(jaabsize+nblc*ma+blocksize+1),tscalea,epaa,eccs,eccp,abijaa,
|
|
c $eppl,epplc,eccsc,epaa,epplij)
|
|
c eppl_ss=eppl_ss+epplc
|
|
c eppls_ss=eppls_ss+eccsc
|
|
c rewind(543)
|
|
c read(543) newta2
|
|
c close(543)
|
|
c endif
|
|
|
|
endif !nblc>0
|
|
enddo
|
|
|
|
close(16)
|
|
close(17)
|
|
|
|
return
|
|
end
|
|
***********************************************************************
|
|
subroutine xspcor(nal,nbe,nval,nvbe,ta2,tb2,tmtwo,scrfile1,iout,
|
|
$rcor)
|
|
***********************************************************************
|
|
* Calculate (T)-xSP correction
|
|
***********************************************************************
|
|
implicit none
|
|
integer nal,nbe,nval,nvbe,scrfile1,a,b,c,i,j,k,ij,ab,iout
|
|
c real*8 tatwo(nval,nval,nal,nal),tbtwo(nvbe,nvbe,nbe,nbe)
|
|
real*8,allocatable::tatwo(:,:,:,:),tbtwo(:,:,:,:)
|
|
real*8 tmp,e4iiia,e4iv,rcor
|
|
real*8,allocatable::zz_aa(:,:,:,:),zz_bb(:,:,:,:),zz_ab(:,:,:,:)
|
|
real*8,allocatable::vab_a(:,:),vab_b(:,:)
|
|
real*8,allocatable::vaaaa(:,:,:,:),vbbbb(:,:,:,:),vabab(:,:,:,:)
|
|
real*8,allocatable::vbaba(:,:,:,:),vabba(:,:,:,:),vbaab(:,:,:,:)
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2)
|
|
real*8 tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2)
|
|
real*8 tmtwo(nval,nvbe,nal,nbe)
|
|
C
|
|
write(iout,*)
|
|
write(iout,*) 'Calculation of xSP correction...'
|
|
allocate(tatwo(nval,nval,nal,nal),tbtwo(nvbe,nvbe,nbe,nbe))
|
|
tatwo=0.d0
|
|
do j=1,nal
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
do b=1,nval
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
tmp=ta2(ab,ij)
|
|
tatwo(a,b,i,j)= tmp
|
|
tatwo(a,b,j,i)=-tmp
|
|
tatwo(b,a,i,j)=-tmp
|
|
tatwo(b,a,j,i)= tmp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
tbtwo=0.d0
|
|
do j=1,nbe
|
|
do i=1,j-1
|
|
ij=(j-1)*(j-2)/2+i
|
|
do b=1,nvbe
|
|
do a=1,b-1
|
|
ab=(b-1)*(b-2)/2+a
|
|
tmp=tb2(ab,ij)
|
|
tbtwo(a,b,i,j)= tmp
|
|
tbtwo(a,b,j,i)=-tmp
|
|
tbtwo(b,a,i,j)=-tmp
|
|
tbtwo(b,a,j,i)= tmp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c write(6,*) 'tatwo'
|
|
c write(6,"(7f9.5)") tatwo
|
|
c write(6,*) 'tbtwo'
|
|
c write(6,"(7f9.5)") tbtwo
|
|
c write(6,*) 'tmtwo'
|
|
c write(6,"(7f9.5)") tmtwo
|
|
C
|
|
allocate(zz_aa(nval,nval,nal,nal))
|
|
allocate(zz_bb(nvbe,nvbe,nbe,nbe))
|
|
allocate(zz_ab(nval,nvbe,nal,nbe))
|
|
allocate(vab_a(nval,nval),vab_b(nvbe,nvbe))
|
|
allocate(vaaaa(nval,nal,nval,nal))
|
|
allocate(vbbbb(nvbe,nbe,nvbe,nbe))
|
|
allocate(vabab(nval,nbe,nval,nbe))
|
|
allocate(vbaba(nvbe,nal,nvbe,nal))
|
|
allocate(vabba(nval,nbe,nvbe,nal))
|
|
allocate(vbaab(nvbe,nal,nval,nbe))
|
|
open(scrfile1,file='F12XSP',form='unformatted')
|
|
read(scrfile1) zz_aa
|
|
read(scrfile1) zz_bb
|
|
read(scrfile1) zz_ab
|
|
read(scrfile1) vaaaa
|
|
read(scrfile1) vbbbb
|
|
read(scrfile1) vabab
|
|
read(scrfile1) vbaba
|
|
read(scrfile1) vabba
|
|
read(scrfile1) vbaab
|
|
read(scrfile1) vab_a
|
|
read(scrfile1) vab_b
|
|
close(scrfile1)
|
|
C
|
|
e4iiia=0.d0
|
|
e4iv=0.d0
|
|
do a=1,nval
|
|
do b=1,a-1
|
|
do i=1,nal
|
|
do j=1,i-1
|
|
C Term 4.IIIa
|
|
tmp=0.d0
|
|
do c=1,nval
|
|
tmp=tmp+vab_a(b,c)*tatwo(a,c,i,j) ! 4.IIIa 1
|
|
$ -vab_a(a,c)*tatwo(b,c,i,j)
|
|
do k=1,nal !4.IIIa 2
|
|
tmp=tmp-vaaaa(a,k,c,i)*tatwo(b,c,j,k)
|
|
$ +vaaaa(a,k,c,j)*tatwo(b,c,i,k)
|
|
$ +vaaaa(b,k,c,i)*tatwo(a,c,j,k)
|
|
$ -vaaaa(b,k,c,j)*tatwo(a,c,i,k)
|
|
enddo
|
|
enddo
|
|
do c=1,nvbe
|
|
do k=1,nbe !4.IIIa 2
|
|
tmp=tmp+vabba(a,k,c,i)*tmtwo(b,c,j,k)
|
|
$ -vabba(a,k,c,j)*tmtwo(b,c,i,k)
|
|
$ -vabba(b,k,c,i)*tmtwo(a,c,j,k)
|
|
$ +vabba(b,k,c,j)*tmtwo(a,c,i,k)
|
|
enddo
|
|
enddo
|
|
e4iiia=e4iiia+tatwo(a,b,i,j)*tmp
|
|
C Term 4.IV
|
|
e4iv=e4iv+zz_aa(a,b,i,j)*tatwo(a,b,i,j) ! 4.IV
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
do a=1,nvbe
|
|
do b=1,a-1
|
|
do i=1,nbe
|
|
do j=1,i-1
|
|
C Term 4.IIIa
|
|
tmp=0.d0
|
|
do c=1,nvbe
|
|
tmp=tmp+vab_b(b,c)*tbtwo(a,c,i,j) ! 4.IIIa 1
|
|
$ -vab_b(a,c)*tbtwo(b,c,i,j)
|
|
do k=1,nbe !4.IIIa 2
|
|
tmp=tmp-vbbbb(a,k,c,i)*tbtwo(b,c,j,k)
|
|
$ +vbbbb(a,k,c,j)*tbtwo(b,c,i,k)
|
|
$ +vbbbb(b,k,c,i)*tbtwo(a,c,j,k)
|
|
$ -vbbbb(b,k,c,j)*tbtwo(a,c,i,k)
|
|
enddo
|
|
enddo
|
|
do c=1,nval
|
|
do k=1,nal !4.IIIa 2
|
|
tmp=tmp+vbaab(a,k,c,i)*tmtwo(c,b,k,j)
|
|
$ -vbaab(a,k,c,j)*tmtwo(c,b,k,i)
|
|
$ -vbaab(b,k,c,i)*tmtwo(c,a,k,j)
|
|
$ +vbaab(b,k,c,j)*tmtwo(c,a,k,i)
|
|
enddo
|
|
enddo
|
|
e4iiia=e4iiia+tbtwo(a,b,i,j)*tmp
|
|
C Term 4.IV
|
|
e4iv=e4iv+zz_bb(a,b,i,j)*tbtwo(a,b,i,j) ! 4.IV
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
do a=1,nval
|
|
do b=1,nvbe
|
|
do i=1,nal
|
|
do j=1,nbe
|
|
C Term 4.IIIa
|
|
tmp=0.d0
|
|
do c=1,nval
|
|
tmp=tmp+vab_a(a,c)*tmtwo(c,b,i,j) ! 4.IIIa 1
|
|
do k=1,nal ! 4.IIIa 2
|
|
tmp=tmp-vaaaa(a,k,c,i)*tmtwo(c,b,k,j)
|
|
$ +vbaab(b,k,c,j)*tatwo(a,c,i,k)
|
|
enddo
|
|
enddo
|
|
do c=1,nvbe
|
|
tmp=tmp+vab_b(b,c)*tmtwo(a,c,i,j) ! 4.IIIa 1
|
|
do k=1,nbe ! 4.IIIa 2
|
|
tmp=tmp+vabba(a,k,c,i)*tbtwo(b,c,j,k)
|
|
$ -vbbbb(b,k,c,j)*tmtwo(a,c,i,k)
|
|
enddo
|
|
enddo
|
|
do c=1,nval
|
|
do k=1,nbe ! 4.IIIa 2
|
|
tmp=tmp-vabab(a,k,c,j)*tmtwo(c,b,i,k)
|
|
enddo
|
|
enddo
|
|
do c=1,nvbe
|
|
do k=1,nal ! 4.IIIa 2
|
|
tmp=tmp-vbaba(b,k,c,i)*tmtwo(a,c,k,j)
|
|
enddo
|
|
enddo
|
|
e4iiia=e4iiia+tmtwo(a,b,i,j)*tmp
|
|
C Term 4.IV
|
|
e4iv=e4iv+zz_ab(a,b,i,j)*tmtwo(a,b,i,j) ! 4.IV
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C
|
|
deallocate(zz_aa,zz_bb,zz_ab,vab_a,vab_b)
|
|
deallocate(vaaaa,vbbbb,vabab,vbaba,vabba,vbaab)
|
|
C
|
|
rcor=e4iiia+e4iv
|
|
write(iout,"(' E_4.IIIa [au]: ',f37.12)") e4iiia
|
|
write(iout,"(' E_4.IV [au]: ',f37.12)") e4iv
|
|
write(iout,"(' xSP correction [au]: ',f37.12)") rcor
|
|
call timer
|
|
C
|
|
return
|
|
end
|
|
C
|