mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-17 04:00:49 +01:00
5618 lines
207 KiB
Fortran
5618 lines
207 KiB
Fortran
************************************************************************
|
|
program prop
|
|
#include "MRCCCOMMON"
|
|
integer teintf(10),idscfa,idscfb,idscfaao,idscfbao,idscftao,ica,i
|
|
integer icb,is,intalloc,imoa,ica2,icb2,ipal,imob,isymat
|
|
integer dblalloc,ixdip,ifocka,ifockb,ida,idb,icoord
|
|
integer ifockmoa,ifockmob,iiprimea,iiprimeb,ixinta,ixintb
|
|
integer ixintrohf,ixintrohf2,ixintaoa,ixintaob,igmtx,igmtxuhf
|
|
integer igmtxrohf,idaoa,idaob,iipiv,iipivuhf,iipivrohf,iipivrohf2
|
|
integer iha,ihb,izvect,ixvect,nos,natoms
|
|
integer iatnum,isder,ihder,itdera,itderb,iwr,iwi,ivl,ivr,iwork
|
|
integer nbla,nblla,nblocka,nblva,nbllva,nblockva,ippq,nblock
|
|
integer ieoa,ieob,igrads,verbosity,iatsymbol,iatchg,ncent
|
|
integer iefield,irf,inatrange,idistc,ilcatoms,inmobasis
|
|
integer idfnmobasis,ixveca,ixvecb,imoadd,mnbasis,ida2
|
|
integer ixintfa,ixintfb,idb2,ixintfrohf,imem1,ciscont
|
|
integer itdera2,itderb2,nangmax,nprimmax,fockmem,dero,noeint
|
|
integer oroute,ialpha,ncontrmax,nsphermax,ncartmax,nmboys,ccontr
|
|
integer necpatoms,nbfshmax,iroute,ncd,ndim1,ndim2,ndim3,ijkls
|
|
integer nmax1,nmax2,nmax,maxm1,maxw,ig2aa,igaoa,ig2int,ig2int2
|
|
integer ivint2aa,igaob,igaoab,ig2bb,ig2ab,ivint2bb,ivint2ab,cmp2t
|
|
integer izmat,izcv,izloc,ixmat,locfit,idens2,ihmat2
|
|
real*8 itol,ctol,scfdtol,pggen(3,3,nirmax),chfx,fhfx,cmp2,cmp2s
|
|
real*8 scftol
|
|
character*4 cctol,cscr4,ccprog
|
|
character*5 scftype
|
|
character*6 core
|
|
character*8 qmmm,qmreg,popul,grdens,scfalg,embed,rism
|
|
character*15 c15
|
|
character*16 calctype,scfdamp
|
|
character*20 dfbasis_scf,bfbasis
|
|
character*32 dft,pcm
|
|
character*256 edisp,edisp_embed
|
|
logical ldfcisgrad,ldftdhfgrad,lgradd
|
|
common/memcom/ imem1
|
|
C
|
|
call mrccini
|
|
open(tedatfile,file='TEDAT',form='UNFORMATTED')
|
|
call intopenrsq(teintf)
|
|
C Allocate memory
|
|
call memalloc
|
|
C Propety calculation
|
|
call getkey('scftype',7,scftype,5)
|
|
call getkey('calc',4,calctype,16)
|
|
call getkey('cctol',5,cctol,4)
|
|
call getkey('ccprog',6,ccprog,4)
|
|
lgradd=.false.
|
|
ldfcisgrad=trim(ccprog).eq.'cis'.and.trim(calctype).eq.'cis'
|
|
ldftdhfgrad=trim(ccprog).eq.'cis'.and.trim(calctype).eq.'scf'
|
|
lgradd=ldfcisgrad.or.ldftdhfgrad
|
|
read(cctol,*) i
|
|
tol=10.d0**(-i)
|
|
call getkey('dens',4,cscr4,4)
|
|
read(cscr4,*) dens
|
|
call getkey('verbosity',9,cscr4,4)
|
|
read(cscr4,*) verbosity
|
|
call getkey('dft',3,dft,32)
|
|
call getkey('qmmm',4,qmmm,8)
|
|
call getkey('dfbasis_scf',11,dfbasis_scf,20)
|
|
call getkey('itol',4,cscr4,4)
|
|
read(cscr4,*) i
|
|
itol=10.d0**(-i)
|
|
call getkey('scfalg',6,scfalg,8)
|
|
if(scfalg.eq.'locfit1 ') then
|
|
locfit=1
|
|
elseif(scfalg.eq.'locfit2 ') then
|
|
locfit=2
|
|
else
|
|
locfit=0
|
|
endif
|
|
call getkey('embed',5,embed,8)
|
|
open(minpfile,file='MINP')
|
|
call getkeym('qmreg',5,qmreg,8)
|
|
if(trim(embed).ne.'off') then
|
|
call getkeym('embed',5,embed,8)
|
|
read(minpfile,*)
|
|
read(minpfile,*) dft
|
|
dft=adjustl(dft)
|
|
call lowercase(dft,dft,32)
|
|
call removed3(dft) !HB
|
|
if(trim(dft).eq.'hf') dft='off '
|
|
endif
|
|
close(minpfile)
|
|
#if defined (PCM)
|
|
call getkey('pcm',3,pcm,32)
|
|
#endif
|
|
C First UHF-test
|
|
c scftype='uhf '
|
|
C First ROHF-test
|
|
c scftype='rohf '
|
|
C
|
|
rewind(inp)
|
|
call getvar('nbasis ',nbasis)
|
|
call getvar('nbf ',nbf)
|
|
call getvar('nal ',nal)
|
|
call getvar('nbe ',nbe)
|
|
call getvar('ncore ',ncore)
|
|
call getvar('natoms ',natoms)
|
|
call getvar('ncent ',ncent)
|
|
call getvar('nbset ',nbset)
|
|
call getvar('nir ',nir)
|
|
call getkey('scfdtol',7,cscr4,4)
|
|
call getkey('popul',5,popul,8)
|
|
call getkey('grdens',6,grdens,8)
|
|
call getvar('pggen ',pggen)
|
|
call getvar('eref ',eref)
|
|
call getvar('chfx ',chfx)
|
|
call getvar('fhfx ',fhfx)
|
|
cmp2=1.d0
|
|
cmp2s=0.d0
|
|
cmp2t=0.d0
|
|
if(dft.ne.'off ') then
|
|
call getvar('cmp2 ',cmp2)
|
|
call getvar('cmp2s ',cmp2s)
|
|
call getvar('cmp2t ',cmp2t)
|
|
endif
|
|
call getenergy(ecc,c15)
|
|
dfnbasis=nbf(2) !SCF dfnbasis!!!
|
|
mnbasis=nbf(4)
|
|
c if(scftype.eq.'rohf ') then
|
|
if(nal.le.nbe) then
|
|
nocc=nal
|
|
nvirt=nbasis-nbe
|
|
nos=nbe-nal
|
|
else
|
|
nocc=nbe
|
|
nvirt=nbasis-nal
|
|
nos=nal-nbe
|
|
endif
|
|
read(cscr4,*) i
|
|
scfdtol=10.d0**(-i)
|
|
call getkey('itol',4,cscr4,4)
|
|
read(cscr4,*) i
|
|
ctol=min(10.d0**(-i),scfdtol/dfloat(dfnbasis*nocc))
|
|
c else
|
|
c nos=0
|
|
c endif
|
|
nvirtal=nbasis-nal
|
|
nvirtbe=nbasis-nbe
|
|
if(dfbasis_scf.ne.'none ') then
|
|
inmobasis=intalloc(max(nal,nbe))
|
|
idfnmobasis=intalloc(max(nal,nbe))
|
|
imoadd=intalloc(max(nal,nbe))
|
|
else
|
|
inmobasis=imem
|
|
idfnmobasis=imem
|
|
imoadd=imem
|
|
endif
|
|
ippq=imem
|
|
ipal=imem
|
|
igrads=dblalloc(3*natoms*8)
|
|
call dfillzero(dcore(igrads),3*natoms*8)
|
|
iefield=dblalloc(3*ncent)
|
|
ilcatoms=intalloc(natoms)
|
|
isymat=intalloc(natoms*nir)
|
|
call getvar('symat ',icore(isymat))
|
|
inatrange=intalloc(2*natoms*nbset)
|
|
call getvar('natrange ',icore(inatrange))
|
|
iatchg=dblalloc(ncent)
|
|
call getvar('atchg ',dcore(iatchg))
|
|
if(calctype.eq.'scf '.and.locfit.eq.1) then
|
|
i=nvirtal*nal
|
|
if(scftype.eq.'uhf ') i=i+nvirtbe*nbe
|
|
izmat=dblalloc(i)
|
|
i=nal*(nal-1)/2
|
|
if(scftype.eq.'uhf ') i=i+nbe*(nbe-1)/2
|
|
izloc=dblalloc(i)
|
|
i=nbasis*nbasis
|
|
if(scftype.eq.'uhf ') i=2*i
|
|
ixmat=dblalloc(i)
|
|
call ldfgrad_driver(dcore,icore,imem,iimem,scrfile6,mocoeffile,
|
|
&scrfile3,iout,maxcor,dcore(izmat),dcore(izloc),dcore(ixmat),chfx)
|
|
call dbldealloc(izmat)
|
|
endif
|
|
if(embed.ne.'off ') then
|
|
call setup_embed_grad(scfdamp,itol,scftol)
|
|
call embed_grad_driver(scfdamp,itol,scftol)
|
|
endif
|
|
C Orbital relaxation contribution to DF correlated density matrices
|
|
if(lgradd) then
|
|
ippq=dblalloc((nbasis+ncore)*(nbasis+ncore))
|
|
endif
|
|
iatsymbol=intalloc(ncent)
|
|
call getvar_c('atsymbol ',icore(iatsymbol))
|
|
if(calctype.ne.'scf '.and.
|
|
$ dfbasis_scf.ne.'none '.and.
|
|
$.not.lgradd) then
|
|
call getvar('nblascf ',nbla)
|
|
call getvar('nbllascf ',nblla)
|
|
call getvar('nblockascf',nblocka)
|
|
call getvar('nblvascf ',nblva)
|
|
call getvar('nbllvascf ',nbllva)
|
|
call getvar('nblockvasc',nblockva)
|
|
call getkey('core',4,core,6)
|
|
if(core.eq.'corr ') ncore=0
|
|
nal=nal-ncore
|
|
nbe=nbe-ncore
|
|
nbasis=nbasis-ncore
|
|
nvirtal=nbasis-nal
|
|
nvirtbe=nbasis-nbe
|
|
nocc=max(nal,nbe)
|
|
nvirt=max(nvirtal,nvirtbe)
|
|
ippq=dblalloc((nbasis+ncore)*(nbasis+ncore))
|
|
C Memory for DIIS
|
|
call setup_mp2_vars(scftol,itol,scfdamp)
|
|
|
|
call getkey('edisp',5,edisp,256)
|
|
call getkey('edisp_embed',11,edisp_embed,256)
|
|
izmat=dblalloc(nvirt*(nbasis-nvirt))
|
|
izcv=dblalloc(ncore*(nbasis-nvirt-ncore))
|
|
call mp2_gradient(scftol,itol,scfdamp,ncore,nbasis-nvirt,nvirt,
|
|
& dft,chfx,cmp2,natoms,ncent,dcore(izmat),dcore(izcv),
|
|
& dcore(iefield),dcore(igrads),icore(iatsymbol),
|
|
& dcore(iatchg),icore(inatrange))
|
|
call print_grad(ncent,natoms,icore(iatsymbol),dcore(iefield),
|
|
& dcore(igrads),iout,verbosity,densfile,dft,edisp,
|
|
& edisp_embed,pcm)
|
|
|
|
call mrccend(0)
|
|
endif
|
|
C SCF properties and gradients/SCF contribution to correlated grads
|
|
if(calctype.eq.'scf '.or.
|
|
$ calctype.eq.'mp2 '.or.
|
|
$ lgradd) then
|
|
call getvar('nbasis ',nbasis)
|
|
call getvar('nal ',nal)
|
|
call getvar('nbe ',nbe)
|
|
nocc=max(nal,nbe) !Extreme caution: restoring nocc, nbasis etc.!
|
|
ciscont=1
|
|
if(ldfcisgrad) ciscont=3
|
|
if(ldftdhfgrad) ciscont=4
|
|
idscfaao=dblalloc(nbasis**2*ciscont)
|
|
ica=dblalloc(nbasis**2*ciscont)
|
|
ixdip=dblalloc(nbasis**2)
|
|
ifocka=dblalloc(nbasis**2)
|
|
ieoa=dblalloc(nbasis)
|
|
if(locfit.eq.1) then
|
|
ica2=dblalloc(nbasis*nal)
|
|
else
|
|
ica2=ica
|
|
endif
|
|
if(scftype.eq.'uhf ') then
|
|
idscftao=dblalloc(nbasis**2)
|
|
icb=dblalloc(nbasis**2)
|
|
ifockb=dblalloc(nbasis**2)
|
|
ieob=dblalloc(nbasis)
|
|
if(locfit.eq.1) then
|
|
icb2=dblalloc(nbasis*nbe)
|
|
else
|
|
icb2=icb
|
|
endif
|
|
else
|
|
idscftao=idscfaao
|
|
icb=ica
|
|
icb2=ica2
|
|
if(trim(embed).eq.'sch') then
|
|
ifockb=dblalloc(nbasis**2)
|
|
else
|
|
ifockb=ifocka
|
|
endif
|
|
ieob=ieoa
|
|
endif
|
|
if(trim(dft).ne.'off'.or.
|
|
$dfbasis_scf.ne.'none ') then
|
|
imoa=dblalloc(nbasis*nal)
|
|
if(scftype.eq.'uhf ') then
|
|
imob=dblalloc(nbasis*nbe)
|
|
else
|
|
imob=imoa
|
|
endif
|
|
else
|
|
imoa=ica
|
|
imob=icb
|
|
endif
|
|
icoord=dblalloc(3*ncent)
|
|
isder=dblalloc(3*max(nbasis,mnbasis)**2)
|
|
ihder=dblalloc(3*max(nbasis,mnbasis)**2)
|
|
itdera=dblalloc(3*nbasis**2)
|
|
if(scftype.ne.'rhf ') then
|
|
idscfbao=dblalloc(nbasis**2)
|
|
itderb=dblalloc(3*nbasis**2)
|
|
else
|
|
idscfbao=idscfaao
|
|
itderb=itdera
|
|
endif
|
|
irf=dblalloc(nbasis**2)
|
|
is=dblalloc(nbasis**2)
|
|
idistc=dblalloc(natoms**2)
|
|
ixveca=imem
|
|
ixvecb=imem
|
|
c write(6,*) 'szemet!!! szemet!!! szemet!!! szemet!!! szemet!!!'
|
|
c calctype='mp2 '
|
|
if(dfbasis_scf.ne.'none ') then
|
|
if(.not.lgradd) then
|
|
ixveca=dblalloc(4*dfnbasis)
|
|
else
|
|
ixveca=dblalloc(4*max(nbf(2),nbf(3)))
|
|
endif
|
|
ixvecb=ixveca
|
|
if(scftype.ne.'rhf '.and.
|
|
$ calctype.ne.'scf ') ixvecb=dblalloc(4*dfnbasis)
|
|
endif
|
|
if(embed.ne.'off ') then
|
|
idens2=dblalloc(nbasis**2)
|
|
ica2=dblalloc(nbasis**2)
|
|
call calc_embed_grad(dcore(idscfaao),dcore(idscfbao),
|
|
&dcore(itdera),dcore(itderb),dcore(idens2),scftype,dcore(isder),
|
|
&dcore(ihder),dcore(ica),dcore(ica2),dfbasis_scf,ctol,
|
|
&dcore(ixveca),2,dcore(iefield),locfit,dcore(igrads),
|
|
&ncent,natoms,imem1,verbosity,chfx,calctype,lgradd,
|
|
&dcore(icoord),icore(iatsymbol),dcore(iatchg),itol,pcm)
|
|
call mrccend(0)
|
|
else
|
|
ihmat2=imem
|
|
call getkey('rism',4,rism,8)
|
|
if(rism.ne.'off ') ihmat2=dblalloc(nbasis*nbasis)
|
|
call scfgrad(dcore(imem),dcore(imem),dcore(idscfaao),
|
|
$dcore(idscfbao),dcore(idscftao),dcore(ica),dcore(icb),dcore(ica2),
|
|
$dcore(icb2),dcore(ixdip),dcore(ifocka),dcore(ifockb),dcore(ieoa),
|
|
$dcore(ieob),scftype,calctype,natoms,dcore(icoord),icore(iatchg),
|
|
$dcore(isder),dcore(ihder),dcore(itdera),dcore(itderb),
|
|
$dcore(igrads),verbosity,icore(iatsymbol),dft,ncent,dcore(iefield),
|
|
$qmmm,qmreg,dcore(irf),dcore(is),icore(inatrange),dcore(idistc),
|
|
$dcore(imoa),dcore(imob),dfbasis_scf,icore(idfnmobasis),
|
|
$dcore(ixveca),dcore(ixvecb),itol,scfalg,icore(imoadd),ctol,
|
|
$dcore(ippq),dcore(ipal),popul,mnbasis,icore(inatrange+3*2*natoms),
|
|
$icore(ilcatoms),icore(isymat),pggen,chfx,cmp2,grdens,
|
|
$icore(inmobasis),embed,ldfcisgrad,ciscont,ldftdhfgrad,lgradd,
|
|
$dcore(ihmat2),pcm)
|
|
call mrccend(0)
|
|
endif
|
|
endif
|
|
C No density fitting
|
|
idscfa=dblalloc(nbasis**2)
|
|
idscfaao=dblalloc(nbasis**2)
|
|
if(scftype.ne.'rhf ') then
|
|
idscfb=dblalloc(nbasis**2)
|
|
idscfbao=dblalloc(nbasis**2)
|
|
else
|
|
idscfb=idscfa
|
|
idscfbao=idscfaao
|
|
endif
|
|
ica=dblalloc(nbasis**2)
|
|
is=dblalloc(nbasis**2)
|
|
ixdip=dblalloc(nbasis**2)
|
|
ifocka=dblalloc(nbasis**2)
|
|
ida=dblalloc(nbasis**2)
|
|
ida2=dblalloc(nbasis**2)
|
|
ifockmoa=dblalloc(nbasis**2)
|
|
iiprimea=dblalloc(nbasis**2)
|
|
ixintaoa=dblalloc(nbasis**2)
|
|
if(scftype.eq.'uhf ') then
|
|
ixinta=dblalloc(nvirtal*nal+nvirtbe*nbe)
|
|
ixintb=ixinta+nvirtal*nal
|
|
ixintaob=dblalloc(nbasis**2)
|
|
ixintfa=dblalloc((nal-ncore)*ncore)
|
|
ixintfb=dblalloc((nbe-ncore)*ncore)
|
|
else
|
|
ixinta=dblalloc(nvirtal*nal)
|
|
ixintb=ixinta
|
|
ixintaob=ixintaoa
|
|
ixintfa=dblalloc((nal-ncore)*ncore)
|
|
ixintfb=ixintfa
|
|
endif
|
|
igmtx=dblalloc(nvirtal**2*nal**2)
|
|
idaoa=dblalloc(nbasis**2)
|
|
iipiv=intalloc(nvirtal*nal)
|
|
iha=dblalloc(nbasis**2)
|
|
izvect=dblalloc(nvirtal*nal+nvirtbe*nbe) !szemet
|
|
ixvect=dblalloc(nvirtal*nal+nvirtbe*nbe) !szemet
|
|
iwr=dblalloc((nocc+nos)*(nvirt+nos)-(nos*nos))
|
|
iwi=dblalloc((nocc+nos)*(nvirt+nos)-(nos*nos))
|
|
ivl=dblalloc((nocc+nos)*(nvirt+nos)-(nos*nos))
|
|
ivr=dblalloc((nocc+nos)*(nvirt+nos)-(nos*nos))
|
|
iwork=dblalloc(4*((nocc+nos)*(nvirt+nos)-(nos*nos)))
|
|
if(scftype.eq.'uhf ') then
|
|
idscftao=dblalloc(nbasis**2)
|
|
icb=dblalloc(nbasis**2)
|
|
ifockb=dblalloc(nbasis**2)
|
|
idb=dblalloc(nbasis**2)
|
|
idb2=dblalloc(nbasis**2)
|
|
ifockmob=dblalloc(nbasis**2)
|
|
iiprimeb=dblalloc(nbasis**2)
|
|
igmtxuhf=dblalloc((nvirtal*nal+nvirtbe*nbe)**2)
|
|
idaob=dblalloc(nbasis**2)
|
|
iipivuhf=intalloc(nvirtal*nal+nvirtbe*nbe)
|
|
ihb=dblalloc(nbasis**2)
|
|
else
|
|
idscftao=idscfaao
|
|
icb=ica
|
|
ifockb=ifocka
|
|
idb=ida
|
|
idb2=ida2
|
|
ifockmob=ifockmoa
|
|
iiprimeb=iiprimea
|
|
igmtxuhf=igmtx
|
|
idaob=idaoa
|
|
iipivuhf=iipiv
|
|
ihb=iha
|
|
endif
|
|
if(scftype.eq.'rohf ') then
|
|
ixintrohf=dblalloc((nvirt+nos)*(nocc+nos))
|
|
ixintrohf2=dblalloc((nvirt+nos)*(nocc+nos))
|
|
igmtxrohf=dblalloc((nvirt+nos)**2*(nocc+nos)**2)
|
|
iipivrohf=intalloc((nvirt+nos)*(nocc+nos))
|
|
iipivrohf2=intalloc((nvirt+nos)*(nocc+nos)-nos*nos)
|
|
ixintfrohf=dblalloc((nocc-ncore)*ncore)
|
|
else
|
|
ixintrohf=ixinta
|
|
ixintrohf2=ixinta
|
|
igmtxrohf=igmtx
|
|
iipivrohf=iipiv
|
|
iipivrohf2=iipiv
|
|
ixintfrohf=ixintfa
|
|
endif
|
|
icoord=dblalloc(3*ncent)
|
|
iatnum=intalloc(natoms)
|
|
isder=dblalloc(3*nbasis**2)
|
|
ihder=dblalloc(3*nbasis**2)
|
|
itdera=dblalloc(3*nbasis**2)
|
|
itdera2=dblalloc(3*nbasis**2)
|
|
if(scftype.ne.'rhf ') then
|
|
itderb=dblalloc(3*nbasis**2)
|
|
itderb2=dblalloc(3*nbasis**2)
|
|
else
|
|
itderb=itdera
|
|
itderb2=itdera2
|
|
endif
|
|
c memory needed for calling direct_fock_build
|
|
c subroutine direct_fock_build
|
|
call getvar('nangmax ',nangmax)
|
|
call getvar('nprimmax ',nprimmax)
|
|
fockmem=(nangmax+1)**2*natoms**2
|
|
call getkey('bfbasis',7,bfbasis,20)
|
|
if(bfbasis.ne.'none ') then
|
|
fockmem=fockmem+(9*nprimmax*(nangmax+1)*natoms*nbset)
|
|
else
|
|
fockmem=fockmem+((nangmax+1)*nprimmax*natoms*nbset)
|
|
endif
|
|
fockmem=fockmem+ncent
|
|
dero=1
|
|
noeint=5
|
|
oroute=0
|
|
ialpha=0
|
|
call getvar('ncontrmax ',ncontrmax)
|
|
call getvar('nsphermax ',nsphermax)
|
|
call getvar('ncartmax ',ncartmax)
|
|
if(oroute.lt.3.or.(ialpha.ne.2.and.oroute.ne.4)) then
|
|
fockmem=fockmem+3*((2*nangmax+1+2+dero))+9*(nangmax+4+dero)**2
|
|
$+3*(nangmax+3)**2+9*(nangmax+2)**2
|
|
$+noeint*(ncontrmax*nprimmax*nsphermax**2+2*nprimmax*nsphermax**2
|
|
$+ncontrmax**2*nsphermax**2+ncartmax**2+ncartmax*nsphermax
|
|
$+nbasis*(nbasis+1))
|
|
$+(2*nangmax+1+dero)**6+(nangmax+1)**6+ncartmax*nsphermax
|
|
$+nsphermax**2+6*(nangmax+2)**3+(2*nangmax+1+dero)**4
|
|
$+(2*nangmax+1+dero)**3
|
|
endif
|
|
c subroutine tedatr
|
|
call getvar('nmboys ',nmboys)
|
|
call getvar('necpatoms ',necpatoms)
|
|
call getvar('nbfshmax ',nbfshmax)
|
|
fockmem=fockmem+
|
|
c integer allocations
|
|
$(
|
|
$natoms*nbset+2*(nangmax+1)*natoms*nbset
|
|
$+nsphermax*ncontrmax*(nangmax+1)*natoms*nbset
|
|
$+2*ncontrmax*(nangmax+1)*natoms*nbset
|
|
$+2*(nangmax+1)*natoms*nbset+natoms*nbset+natoms+nbset+natoms
|
|
$+nprimmax*(nangmax+1)*necpatoms+necpatoms
|
|
$+(nangmax+1)*necpatoms+necpatoms+4*(nprimmax+1)
|
|
$+3*nbfshmax**2
|
|
$+(nangmax+1)*(2*nangmax+2)*(2*nangmax+1)**2
|
|
$)/2+1
|
|
c double precision allocations
|
|
$+(nangmax+1)*nprimmax*natoms*nbset
|
|
$+nprimmax*ncontrmax*(nangmax+1)*natoms*nbset+3*ncent
|
|
$+(nangmax+1)*ncartmax**2+nmboys+1+(nmboys+1)*1481
|
|
$+(nangmax+1)**2*natoms**2
|
|
$+(nangmax+1)*(3*ncartmax**2+1)+ncent
|
|
$+2*nprimmax*(nangmax+1)*necpatoms
|
|
$+3*(nangmax+1)**2*natoms**2+3*(natoms**2)*(nangmax+2)
|
|
$+(4*nangmax+1+dero)*nprimmax**2
|
|
$+(4*nangmax+1+dero)*nprimmax*max(nprimmax,(nangmax+1)*natoms)
|
|
$+4*nangmax*nprimmax*(nangmax+1)*natoms
|
|
c subroutine teint
|
|
iroute=2
|
|
ncd=3
|
|
ndim1=nbfshmax**2
|
|
if(iroute.eq.1) ndim1=(nbasis-1)*nbasis+1
|
|
ndim2=ndim1*nbfshmax
|
|
ndim3=nbfshmax*ndim2
|
|
i=3*ncd*ndim3
|
|
if(mod(i,2).eq.1) i=i+1
|
|
fockmem=fockmem+i/2
|
|
ijkls=nsphermax**4
|
|
ccontr=ncontrmax**4
|
|
fockmem=fockmem+3*ijkls*ccontr+3*ijkls*nprimmax
|
|
nmax1=2*nangmax
|
|
nmax2=2*nangmax
|
|
nmax=nmax2+nmax1
|
|
fockmem=fockmem+
|
|
$(
|
|
$(nmax1+1+1+1)**3*(nmax2+1+1+1)**3*(nmax+1+1+1+1+1)
|
|
$+max((nmax1+1+1+1)**3*(nangmax+1+1)**3
|
|
$,(nmax2+1+1+1)**3*(nangmax+1+1)**3)
|
|
$+3*ncartmax**2
|
|
$+3*ncartmax*nsphermax
|
|
$+3*nsphermax**2
|
|
$+(nmax2+1+1+1)**3*nsphermax**2*3
|
|
$+3*ijkls*ncontrmax*nprimmax
|
|
$+3*ijkls*ncontrmax**2*nprimmax
|
|
$+3*ijkls*ncontrmax**3*nprimmax
|
|
$+3*ijkls*ccontr
|
|
$)
|
|
c necpatoms
|
|
if(necpatoms.gt.0)
|
|
$fockmem=fockmem+
|
|
$(
|
|
$2*(12*(nangmax+1)+1)*(6*(nangmax+1)+1)+1+9*
|
|
$(nangmax+1)+3+max(2*((2*(nangmax+11)+1)+1)**2,3*(nangmax+1)*
|
|
$(2*(nangmax+11)+1)*(2*nangmax+12))
|
|
$)
|
|
c memory left
|
|
maxm1=maxcor-(imem-imem1)
|
|
c quantities with 4 index
|
|
if(scftype.ne.'uhf ') then
|
|
c maxw=min(nbasis,(maxm1-fockmem)/nbasis**3/5)
|
|
maxw=max(1,min(nbasis,(maxm1-fockmem)/nbasis**3/5,
|
|
$idnint(2147483600.d0/dble((nbasis+ncore)**3*ifltln))))
|
|
ig2aa=dblalloc(maxw*nbasis**3)
|
|
igaoa=dblalloc(maxw*nbasis**3)
|
|
ig2int=dblalloc(maxw*nbasis**3)
|
|
ig2int2=dblalloc(maxw*nbasis**3)
|
|
ivint2aa=dblalloc(maxw*nbasis**3)
|
|
igaob=igaoa
|
|
igaoab=igaoa
|
|
ig2bb=ig2aa
|
|
ig2ab=ig2aa
|
|
ivint2bb=ivint2aa
|
|
ivint2ab=ivint2aa
|
|
else
|
|
c maxw=max(1,min(nbasis,(maxm1-fockmem)/nbasis**3/10)
|
|
maxw=max(1,min(nbasis,(maxm1-fockmem)/nbasis**3/10,
|
|
$idnint(2147483600.d0/dble((nbasis+ncore)**3*ifltln))))
|
|
c maxw=9 !szemet
|
|
ig2aa=dblalloc(maxw*nbasis**3)
|
|
igaoa=dblalloc(maxw*nbasis**3)
|
|
igaob=dblalloc(maxw*nbasis**3)
|
|
igaoab=dblalloc(maxw*nbasis**3)
|
|
ivint2aa=dblalloc(maxw*nbasis**3)
|
|
ig2bb=dblalloc(maxw*nbasis**3)
|
|
ig2ab=dblalloc(maxw*nbasis**3)
|
|
ig2int=dblalloc(maxw*nbasis**3)
|
|
ig2int2=dblalloc(maxw*nbasis**3)
|
|
ivint2bb=dblalloc(maxw*nbasis**3)
|
|
ivint2ab=dblalloc(maxw*nbasis**3)
|
|
endif
|
|
if(maxw.lt.1) then
|
|
write(iout,*)
|
|
write(iout,*) 'Insufficient memory for gradient calculation!'
|
|
call mrccend(1)
|
|
endif
|
|
nblock=nbasis/maxw
|
|
if(mod(nbasis,maxw).ne.0) nblock=nblock+1
|
|
write(iout,*)
|
|
write(iout,*) 'Number of integral batches: ',nblock
|
|
call propcore(dcore(imem),dcore(imem),dcore(idscfa),dcore(idscfb),
|
|
$dcore(idscfaao),dcore(idscfbao),dcore(idscftao),dcore(ica),
|
|
$dcore(icb),dcore(is),dcore(ixdip),
|
|
$dcore(ifocka),dcore(ifockb),
|
|
$dcore(ida),dcore(ida2),dcore(idb),dcore(idb2),
|
|
$dcore(ifockmoa),dcore(ifockmob),
|
|
$dcore(iiprimea),dcore(iiprimeb),dcore(ixinta),dcore(ixintb),
|
|
$dcore(ixintrohf),dcore(ixintrohf2),dcore(ixintaoa),
|
|
$dcore(ixintaob),dcore(ixintfa),dcore(ixintfb),dcore(ixintfrohf),
|
|
$dcore(igmtx),dcore(igmtxuhf),dcore(igmtxrohf),dcore(idaoa),
|
|
$dcore(idaob),dcore(iha),dcore(ihb),icore(iipiv),icore(iipivuhf),
|
|
$icore(iipivrohf),icore(iipivrohf2),
|
|
$dcore(izvect),dcore(ixvect),scftype,core,calctype,nos,natoms,
|
|
$dcore(icoord),icore(iatnum),dcore(isder),dcore(ihder),
|
|
$dcore(itdera),dcore(itderb),dcore(iwr),dcore(iwi),dcore(ivl),
|
|
$dcore(ivr),dcore(iwork),dcore(igmtxrohf),dcore(ixintrohf),
|
|
$dcore(ixintrohf2),dcore(ig2aa),
|
|
$dcore(ig2bb),dcore(ig2ab),dcore(ivint2aa),dcore(ivint2bb),
|
|
$dcore(ivint2ab),maxw,dcore(ig2int),dcore(ig2int2),dcore(igaoa),
|
|
$dcore(igaob),dcore(igaoab),dcore(itdera2),dcore(itderb2),
|
|
$icore(ilcatoms),icore(isymat),pggen,dcore(iefield),
|
|
$icore(iatsymbol),grdens,dft,dcore(itdera),icore(inatrange),
|
|
$dcore(itdera2),dcore(iatchg),popul,ncent,qmmm) !HB
|
|
C
|
|
call mrccend(0)
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine dfprop(nbf,nvirt,nocc,dfnbasis,nbl,nbll,nblock,nblv,
|
|
$nbllv,nblockv,scrfile1,scrfile2,scrfile3,densfile,jai,eo,ev,ef,
|
|
$ppq,pab,scr,pij,nbasis,ncore,lip,xp,yia,scrfile4,irecln,ibufln,
|
|
$jpij,xli,scrfile5,ifltln,lap,pal,zal,diisfile,errfile,maxit,bmat,
|
|
$invbmat,pal0,wpq,cctol,ylm,fmo,pmuq,oeintfile,iout,
|
|
$angtobohr,natoms,dcore,icore,scftype,dfnmobasis,moadd,ctol,
|
|
$varsfile,nbset,maxmem,maxcor,imem,tedatfile,minpfile,dfnbasis_cor,
|
|
$dens,grads,lcatoms,symat,nir,chfx,fhfx,cmp2,cmp2s,cmp2t,dft,
|
|
$verbosity,nmobasis)
|
|
************************************************************************
|
|
* Driver for density-fitted gradient calculations
|
|
************************************************************************
|
|
implicit none
|
|
logical lconv
|
|
integer nbf,nvirt,nocc,dfnbasis,nbl,nbll,nblock,nblv,nbllv,natoms
|
|
integer scrfile1,scrfile2,scrfile3,scrfile4,densfile,nblockv,icore
|
|
integer nbasis,ncore,ibufln,irecln,scrfile5,ifltln,datoms,hailen
|
|
integer iblock,jblock,ifrst,jfrst,k,dens,nir,verbosity,r,igrad_tmp
|
|
integer ijdim,nb,nb2,nb3,ii,ij,nreca,p,q,pp,m,kfrst,diisfile,xyz
|
|
integer errfile,nit,maxit,f,oeintfile,iout,st,fs,rt,dfnmobasis(*)
|
|
integer moadd,varsfile,nbset,maxmem,maxcor,imem,tedatfile,minpfile
|
|
integer dfnbasis_cor,lcatoms(natoms),symat(natoms,nir),nmobasis(*)
|
|
real*8 jai(*),eo(nocc),zal(nvirt,ncore+nocc),er,dcore(*),tegrad(3)
|
|
real*8 pla(ncore+nocc,nvirt),limit,sum,er2,er3,res,angtobohr,chfx
|
|
real*8 ev(nvirt),jpij(*),dnrm2,ctol,grads(3,natoms,8),cmp2,fhfx
|
|
real*8 pij(nocc,nocc),pmuq(nbf,nbf),cmp2s,cmp2t
|
|
real*8 xli(*),fmo(nbf,nbf)
|
|
real*8 ppq(nbasis+ncore,nbasis+ncore),pab(nvirt,nvirt),scr(*),ei
|
|
real*8 ej,ef(ncore),yia(ncore+nocc,nvirt)
|
|
real*8 lip(nocc,ncore+nbasis),lap(nvirt,ncore+nbasis)
|
|
real*8 pal(nvirt,ncore+nocc),ylm(ncore+nocc,ncore+nocc)
|
|
real*8 bmat(maxit,maxit),invbmat(maxit+1,maxit+1)
|
|
real*8 pal0(nvirt,ncore+nocc)
|
|
real*8 wpq(nbasis+ncore,nbasis+ncore),xp(*),cctol,tol,finish
|
|
real*8 start,exc
|
|
character*5 scftype
|
|
character*16 cscr16
|
|
character*32 dft
|
|
ccc teszt integralokkal
|
|
cc real*8 gmtx(ncore+nocc,nvirt,ncore+nbasis,ncore+nbasis),sm
|
|
cc real*8 vintaa(ncore+nbasis,ncore+nbasis,ncore+nbasis,ncore+nbasis)
|
|
cc real*8 yiar(ncore+nocc,nvirt),zalr(nvirt,ncore+nocc)
|
|
cc real*8 ylmr(ncore+nocc,ncore+nocc)
|
|
C szemet: all-electron MP2 correlation energy with SCF integrals
|
|
integer i,j,a,b,c,l,n,s,dblalloc
|
|
|
|
c TDDFT szemet eleje, no exact exchange, core=corr !!!
|
|
c integer mult
|
|
c real*8 eref
|
|
c real*8,allocatable::amat(:,:),bbmat(:,:),fmat(:,:),wr(:),wi(:)
|
|
c real*8,allocatable::work(:)
|
|
c allocate(amat(nocc*nvirt,nocc*nvirt),wr(2*nocc*nvirt))
|
|
c allocate(bbmat(nocc*nvirt,nocc*nvirt),wi(2*nocc*nvirt))
|
|
c allocate(fmat(2*nocc*nvirt,2*nocc*nvirt),work(8*nocc*nvirt))
|
|
c open(scrfile4,file='MOCOEF',form='unformatted')
|
|
c call readmo(scr,scr,fmo,scrfile4,nbf,nbf)
|
|
c close(scrfile4)
|
|
c call getvar('eref ',eref)
|
|
c amat=0.d0
|
|
c mult=1 ! multiplicity
|
|
c if(mult.eq.1) then
|
|
c do i=1,nocc
|
|
c do a=1,nvirt
|
|
c pal=0.d0
|
|
c pal(a,i)=1.d0
|
|
c call labmconst(scrfile1,scrfile2,scrfile3,scrfile4,
|
|
c $scrfile5,scr,nbasis,ncore,nocc,nbl,nbll,nblock,nvirt,nblv,nbllv,
|
|
c $nblockv,dfnbasis,ifltln,ef,eo,ev,pal,jai,jai,jai,xp,xli,xli,
|
|
c $jpij,jpij,amat(1,(i-1)*nvirt+a),0.d0)
|
|
c enddo
|
|
c enddo
|
|
c endif
|
|
c if(trim(dft).ne.'off') then
|
|
c do i=1,nocc
|
|
c do a=1,nvirt
|
|
c pal=0.d0
|
|
c pal(a,i)=1.d0
|
|
c call dvxc(nbf,ncore+nocc,ncore+nocc,jai,jai,xli,xli,scrfile5,
|
|
c $dcore,iout,exc,dft,minpfile,1,ifltln,maxcor,imem,icore,
|
|
c $verbosity,2,grads(1,1,2),'vxcd',jpij,jpij,fmo,fmo,pal,pal,
|
|
c $amat(1,(i-1)*nvirt+a),amat(1,(i-1)*nvirt+a),2,0,1,1,mult)
|
|
c enddo
|
|
c enddo
|
|
c endif
|
|
c amat=0.5d0*amat
|
|
c bbmat=amat
|
|
c do i=1,nocc
|
|
c do a=1,nvirt
|
|
c amat((i-1)*nvirt+a,(i-1)*nvirt+a)=
|
|
c $ amat((i-1)*nvirt+a,(i-1)*nvirt+a)+ev(a)-eo(i)
|
|
c enddo
|
|
c enddo
|
|
c write(6,*) 'amat',nocc,nvirt
|
|
c write(6,"(10f9.5)") amat
|
|
c write(6,*) 'bmat'
|
|
c write(6,"(10f9.5)") bbmat
|
|
c fmat(1:nocc*nvirt,1:nocc*nvirt)=amat
|
|
c fmat(nocc*nvirt+1:2*nocc*nvirt,1:nocc*nvirt)=-bbmat
|
|
c fmat(1:nocc*nvirt,nocc*nvirt+1:2*nocc*nvirt)=bbmat
|
|
c fmat(nocc*nvirt+1:2*nocc*nvirt,nocc*nvirt+1:2*nocc*nvirt)=-amat
|
|
c call dgeev('n','n',2*nocc*nvirt,fmat,2*nocc*nvirt,wr,wi,wr,1,wr,1,
|
|
c $work,8*nocc*nvirt,i)
|
|
c do i=1,2*nvirt*nocc
|
|
c if(wr(i).gt.0.d0) then
|
|
c write(6,"(200f16.8)") wr(i),27.21138386d0*wr(i),wr(i)+eref
|
|
c endif
|
|
c enddo
|
|
c stop
|
|
c TDDFT szemet vege
|
|
|
|
C real*8 aibj(nvirt,nbll,nvirt,nbl),emp2
|
|
C read(scrfile1) jai
|
|
C call dsyrk('u','n',nvirt*nbll,dfnbasis,1.d0,jai,nvirt*nbll,0.d0,
|
|
C $aibj,nvirt*nbll)
|
|
C call filllo(aibj,nvirt*nbll)
|
|
C emp2=0.d0
|
|
C do i=1,nocc
|
|
C do j=1,nocc
|
|
C do a=1,nvirt
|
|
C do b=1,nvirt
|
|
C emp2=emp2+(2.d0*aibj(a,i,b,j)-aibj(a,j,b,i))*aibj(a,i,b,j)
|
|
C $/((eo(i)+eo(j)-ev(a)-ev(b)))
|
|
C enddo
|
|
C enddo
|
|
C enddo
|
|
C enddo
|
|
C write(6,"(' MP2 energy [au]: ',2f20.12)") emp2
|
|
c rt=1
|
|
C Assemble pitilde_pq
|
|
call dfillzero(ppq,(ncore+nbasis)**2)
|
|
c write(6,"('ncore',1000i10)") ncore
|
|
c write(6,"('nocc')")
|
|
c write(6,"(1000i10)") nocc
|
|
c write(6,"('nvirt')")
|
|
c write(6,"(1000i10)") nvirt
|
|
c write(6,"('nbasis')")
|
|
c write(6,"(1000i10)") nbasis
|
|
c write(6,"('dfnbasis')")
|
|
c write(6,"(1000i10)") dfnbasis
|
|
c write(6,"('nblock',1000i10)") nblock
|
|
c write(6,"('nbl',1000i10)") nbl
|
|
c write(6,"('nbll',1000i10)") nbll
|
|
c write(6,"('nblockv',1000i10)") nblockv
|
|
open(scrfile4,file='MOCOEF',form='unformatted')
|
|
call readmo(scr,scr,fmo,scrfile4,nbf,nbf)
|
|
close(scrfile4)
|
|
open(unit=densfile,file='CCDENSITIES',form='unformatted')
|
|
call roeint(scr,scr,pab,densfile,nvirt)
|
|
do i=1,nvirt
|
|
do j=1,nvirt
|
|
ppq(ncore+nocc+i,ncore+nocc+j)=pab(i,j) !dcore(ippq)
|
|
enddo
|
|
enddo
|
|
call roeint(scr,scr,pij,densfile,nocc)
|
|
do i=1,nocc
|
|
do j=1,nocc
|
|
ppq(ncore+i,ncore+j)=pij(i,j)
|
|
enddo
|
|
enddo
|
|
read(densfile) !gamma^PQ
|
|
|
|
call rtdmx(scr,scr,lap,densfile,nvirt,nbasis+ncore) !L"_ap ! dcore(ipab)
|
|
do a=1,nvirt
|
|
do l=1,ncore+nocc
|
|
pal0(a,l)=2d0*lap(a,l)
|
|
enddo
|
|
enddo
|
|
call rtdmx(scr,scr,lip,densfile,nocc,nbasis+ncore) !lip
|
|
do i=1,nocc
|
|
do a=1,nvirt
|
|
pal0(a,ncore+i)=pal0(a,ncore+i)-2d0*lip(i,ncore+nocc+a)
|
|
enddo
|
|
enddo
|
|
if(ncore.gt.0) then
|
|
do i=1,nocc
|
|
ei=eo(i)
|
|
do f=1,ncore
|
|
ej=ei-ef(f)
|
|
ppq(ncore+i,f)=2d0*lip(i,f)/ej
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
CAssemble A_lapq ptilde_pq
|
|
call lapqconst(scrfile1,scrfile2,scrfile3,scrfile4,
|
|
$scrfile5,scr,nbasis,ncore,nocc,nbl,nbll,nblock,nvirt,nblv,nbllv,
|
|
$nblockv,dfnbasis,ifltln,ef,eo,ev,ppq,jai,jai,jai,xp,xli,xli,xli,
|
|
$jpij,jpij,jai,yia,chfx)
|
|
C Calculate XC contribution
|
|
if(trim(dft).ne.'off') then
|
|
if(chfx.ne.fhfx) then
|
|
write(iout,*)
|
|
write(iout,*) 'Analyitc gradients are not implemented ' //
|
|
$'for double hybrid functionals'
|
|
write(iout,*) 'for which the DFT contribution to the ' //
|
|
$'energy is not stationary wrt'
|
|
write(iout,*) 'the variation of the MO coefficients.'
|
|
call mrccend(1)
|
|
endif
|
|
if(cmp2s+cmp2t.ne.0.d0) then
|
|
write(iout,*)
|
|
write(iout,*) 'Analyitc gradients are not implemented ' //
|
|
$'for spin-component-scaled'
|
|
write(iout,*) 'double hybrid functionals.'
|
|
call mrccend(1)
|
|
endif
|
|
call dvxc(nbf,ncore+nocc,ncore+nocc,jai,jai,xli,xli,scrfile5,
|
|
$dcore,iout,exc,dft,minpfile,1,ifltln,maxcor,imem,icore,0,
|
|
$2,grads(1,1,2),'vxcd',jpij,jpij,fmo,fmo,ppq,ppq,yia,yia,1,0,1,1,1)
|
|
endif
|
|
c write(6,"('Y_ia')")
|
|
c do a=1,nvirt
|
|
c write(6,"(1000f10.5)") (yia(l,a),l=1,ncore+nocc)
|
|
c enddo
|
|
do a=1,nvirt
|
|
ei=ev(a)
|
|
do l=1,ncore+nocc
|
|
if(l.gt.ncore) then
|
|
ej=ei-eo(l-ncore)
|
|
c write(6,"(1000f10.5)") ev(a),eo(l-ncore),ej
|
|
else
|
|
ej=ei-ef(l)
|
|
c write(6,"(1000f10.5)") ev(a),ef(l),ej
|
|
endif
|
|
pal0(a,l)=(pal0(a,l)-yia(l,a))/ej
|
|
pal(a,l)=pal0(a,l) !pal: dcore(ipab), yia: dcore(iyia), pal0: dcore(ipal)
|
|
enddo
|
|
enddo
|
|
|
|
nit=0
|
|
tol=cctol/(nvirt*(ncore+nocc))
|
|
lconv=.false.
|
|
write(iout,*)
|
|
write(iout,"(' Solution of the Z-vector equation:')")
|
|
write(iout,"(' Requested convergence: RMS ',5f13.10)") cctol
|
|
write(iout,"(' Max. dev.',5f13.10)") tol
|
|
write(iout,"(' No. of it. ',' RMS ',' Max. dev.')")
|
|
do while(.not.lconv.and.nit.lt.maxit)
|
|
nit=nit+1
|
|
|
|
C Assemble A_albm P_bm
|
|
call labmconst(scrfile1,scrfile2,scrfile3,scrfile4,
|
|
$scrfile5,scr,nbasis,ncore,nocc,nbl,nbll,nblock,nvirt,nblv,nbllv,
|
|
$nblockv,dfnbasis,ifltln,ef,eo,ev,pal,jai,jai,jai,xp,xli,xli,
|
|
$jpij,jpij,zal,chfx)
|
|
C Calculate XC contribution
|
|
if(trim(dft).ne.'off') then
|
|
call dvxc(nbf,ncore+nocc,ncore+nocc,jai,jai,xli,xli,scrfile5,
|
|
$dcore,iout,exc,dft,minpfile,1,ifltln,maxcor,imem,icore,0,
|
|
$2,grads(1,1,2),'vxcd',jpij,jpij,fmo,fmo,pal,pal,zal,zal,2,0,1,1,1)
|
|
endif
|
|
|
|
do a=1,nvirt
|
|
ei=ev(a)
|
|
do l=1,ncore+nocc
|
|
if(l.gt.ncore) then
|
|
ej=ei-eo(l-ncore)
|
|
else
|
|
ej=ei-ef(l)
|
|
endif
|
|
zal(a,l)=pal0(a,l)-zal(a,l)/ej
|
|
enddo
|
|
enddo
|
|
call dcopy(nvirt*(ncore+nocc),zal,1,dcore(imem),1)
|
|
call daxpy(nvirt*(ncore+nocc),-1.d0,pal,1,dcore(imem),1)
|
|
call diis(nit,nvirt*(ncore+nocc),zal,dcore(imem),10,diisfile,
|
|
$errfile,ifltln,bmat,invbmat)
|
|
|
|
er2=0.d0
|
|
do a=1,nvirt
|
|
do l=1,ncore+nocc
|
|
er=abs(pal(a,l)-zal(a,l))
|
|
if(er.gt.er2) er2=er
|
|
enddo
|
|
enddo
|
|
er=dnrm2(nvirt*(ncore+nocc),zal-pal,1)
|
|
write(iout,"(1i7,1f18.10,1f16.10)") nit,er,er2
|
|
do a=1,nvirt
|
|
do l=1,ncore+nocc
|
|
pal(a,l)=zal(a,l)
|
|
enddo
|
|
enddo
|
|
lconv=er.lt.cctol.and.er2.lt.tol!.or.dabs(res).lt.cctol
|
|
enddo
|
|
if(lconv) then
|
|
write(iout,"(' Iteration has converged in',i3,' steps.')") nit
|
|
else
|
|
write(iout,
|
|
$"(' Convergence not achieved in',i3,' iterations!')") nit
|
|
endif
|
|
call timer
|
|
|
|
C construct pi_pq
|
|
if(dens.gt.1) then
|
|
c construct W_pq
|
|
call dfillzero(wpq,nbf*nbf)
|
|
C add Pitilde_pq
|
|
do i=1,nocc
|
|
ei=eo(i)
|
|
do l=1,ncore+nocc
|
|
if(l.gt.ncore) then
|
|
ej=ei+eo(l-ncore)
|
|
else
|
|
ej=ei+ef(l)
|
|
endif
|
|
wpq(ncore+i,l)=ppq(ncore+i,l)*ej/2d0 !!! dcore(ipal)
|
|
enddo
|
|
enddo
|
|
do a=1,nvirt
|
|
ei=ev(a)
|
|
do b=1,nvirt
|
|
ej=ei+ev(b)
|
|
wpq(ncore+nocc+a,ncore+nocc+b)=ppq(ncore+nocc+a,ncore+nocc+b)
|
|
$*ej/2d0
|
|
enddo
|
|
enddo
|
|
C add P_al
|
|
do a=1,nvirt
|
|
ei=ev(a)
|
|
do l=1,ncore+nocc
|
|
if(l.gt.ncore) then
|
|
ej=ei+eo(l-ncore)
|
|
else
|
|
ej=ei+ef(l)
|
|
endif
|
|
wpq(ncore+nocc+a,l)=pal(a,l)*ej/2d0
|
|
enddo
|
|
enddo
|
|
C add A_lapq Pitilde_pq =Y_la
|
|
C add A_lapq pitilde_pq =Y_ia and A_labm P_bm =Z_al
|
|
call labmconst(scrfile1,scrfile2,scrfile3,scrfile4,
|
|
$scrfile5,scr,nbasis,ncore,nocc,nbl,nbll,nblock,nvirt,nblv,nbllv,
|
|
$nblockv,dfnbasis,ifltln,ef,eo,ev,pal,jai,jai,jai,xp,xli,xli,
|
|
$jpij,jpij,zal,chfx)
|
|
if(trim(dft).ne.'off') then
|
|
call dvxc(nbf,ncore+nocc,ncore+nocc,jai,jai,xli,xli,scrfile5,
|
|
$dcore,iout,exc,dft,minpfile,1,ifltln,maxcor,imem,icore,verbosity,
|
|
$2,grads(1,1,2),'vxcd',jpij,jpij,fmo,fmo,pal,pal,zal,zal,2,0,1,1,1)
|
|
endif
|
|
do l=1,ncore+nocc
|
|
do a=1,nvirt
|
|
wpq(l,ncore+nocc+a)=wpq(l,ncore+nocc+a)+(yia(l,a)+zal(a,l))/2d0
|
|
enddo
|
|
enddo
|
|
|
|
C add A_lmpq pi_pq
|
|
call lmpqconst(scrfile1,scrfile2,scrfile3,scrfile4,
|
|
$scrfile5,scr,nbasis,ncore,nocc,nbl,nbll,nblock,nvirt,nblv,nbllv,
|
|
$nblockv,dfnbasis,ifltln,ef,eo,ev,ppq,pal,jai,jai,jai,jai,xp,xli,
|
|
$xli,xli,xli,jpij,jai,ylm,chfx)
|
|
do l=1,ncore+nocc
|
|
do m=1,ncore+nocc
|
|
wpq(l,m)=wpq(l,m)+ylm(l,m)/2.d0
|
|
enddo
|
|
enddo
|
|
endif
|
|
C Construct Pi_pq
|
|
do a=1,nvirt
|
|
do l=1,ncore+nocc
|
|
ppq(ncore+nocc+a,l)=pal(a,l)
|
|
enddo
|
|
enddo
|
|
C Calculate XC contribution
|
|
if(trim(dft).ne.'off'.and.dens.gt.1) then
|
|
call dvxc(nbf,ncore+nocc,ncore+nocc,jai,jai,xli,xli,scrfile5,
|
|
$dcore,iout,exc,dft,minpfile,1,ifltln,maxcor,imem,icore,verbosity,
|
|
$2,grads(1,1,2),'grad',jpij,jpij,fmo,fmo,ppq,ppq,wpq,wpq,3,0,1,1,1)
|
|
call dscal(3*natoms,cmp2,grads(1,1,2),1)!Do not use grads before
|
|
endif
|
|
C SCF contribution
|
|
do i=1,ncore+nocc
|
|
ppq(i,i)=ppq(i,i)+1.d0
|
|
enddo
|
|
if(dens.gt.1) then
|
|
C add L"_aq
|
|
rewind(densfile)
|
|
read(densfile) !P_ab
|
|
read(densfile) !P_ij
|
|
read(densfile) !gamma^PQ
|
|
call rtdmx(scr,scr,lap,densfile,nvirt,nbasis+ncore) !L"_ap ! dcore(ipab)
|
|
do a=1,nvirt
|
|
do q=1,ncore+nbasis
|
|
wpq(ncore+nocc+a,q)=wpq(ncore+nocc+a,q)+lap(a,q)
|
|
enddo
|
|
enddo
|
|
|
|
c add L_iq
|
|
call rtdmx(scr,scr,lip,densfile,nocc,nbasis+ncore) !L_ip !dcore(ipab)
|
|
close(densfile)
|
|
do i=1,nocc
|
|
do q=1,ncore+nbasis
|
|
wpq(ncore+i,q)=wpq(ncore+i,q)+lip(i,q)
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
C Transform to AO basis
|
|
call dgemm('n','n',nbf,nbf,nbf,1.d0,fmo,nbf,ppq,nbf,0.d0,pmuq,nbf)
|
|
call dgemm('n','t',nbf,nbf,nbf,1.d0,pmuq,nbf,fmo,nbf,0.d0,ppq,nbf)
|
|
call dscal(nbf**2,2.d0,ppq,1) ! Total density: alpha + beta
|
|
C Symmetrize correlated one-prticle density
|
|
call symmat(ppq,nbf)
|
|
if(dens.eq.1) return
|
|
call dgemm('n','n',nbf,nbf,nbf,1.d0,fmo,nbf,wpq,nbf,0.d0,pmuq,nbf)
|
|
call dgemm('n','t',nbf,nbf,nbf,1.d0,pmuq,nbf,fmo,nbf,0.d0,wpq,nbf)
|
|
C Contribution of gamma and Gamma to Cartesian gradient
|
|
do i=1,nocc
|
|
nmobasis(i)=nbf
|
|
dfnmobasis(i)=dfnbasis_cor
|
|
enddo
|
|
write(iout,*)
|
|
write(iout,*)
|
|
$'Calculation of MP2 contribution to Cartesian gradient...'
|
|
lcatoms=1
|
|
c do datoms=1,natoms
|
|
c if(lcatoms(datoms).eq.1) then
|
|
c lcatoms(datoms)=0
|
|
c write(cscr16,'(i16)') datoms
|
|
c cscr16=adjustl(cscr16)
|
|
c write(iout,*) 'Calculation of Cartesian gradient for atom ' //
|
|
c $trim(cscr16)
|
|
c call direct_fock_build(ppq,ppq,dcore,dcore,dcore,100,
|
|
c $scftype,2,1,datoms,dcore,dcore,fmo(1,ncore+1),.true.,dcore,dcore,
|
|
c $dcore,tegrad,hailen,i,i,moadd,dfnmobasis,ctol,.false.,
|
|
c $dcore,0,1.d0,iout,varsfile,icore,dcore,nbset,oeintfile,nocc,
|
|
c $scrfile3,scrfile4,maxcor,imem,tedatfile,dfnbasis_cor,
|
|
c $nbasis,4,dcore,minpfile,.false.,1,dcore,irecln,1,.false.,0,0,0,
|
|
c $1.d0,ppq,1,dcore,0,0,nmobasis,i,i,i,i,i,i,i,0.d0,0.d0,0.d0,
|
|
c $.false.,grads,dcore,dcore,i,.false.,.false.,dcore,.false.,
|
|
c $.false.,0,i,.false.,dcore,dcore,.false.,nocc)
|
|
c do xyz=1,3
|
|
c grads(xyz,datoms,2)=grads(xyz,datoms,2)+cmp2*tegrad(xyz)
|
|
c enddo
|
|
cC Symmetry equivalent atoms
|
|
c lcatoms(symat(datoms,1:nir))=0
|
|
c endif
|
|
c enddo
|
|
|
|
igrad_tmp=dblalloc(3*natoms*8)
|
|
call dfillzero(dcore(igrad_tmp),3*natoms*8)
|
|
call direct_fock_build(ppq,ppq,dcore,dcore,dcore,100,
|
|
$scftype,2,1,datoms,dcore,dcore,fmo(1,ncore+1),.true.,dcore,dcore,
|
|
$dcore,tegrad,hailen,i,i,moadd,dfnmobasis,ctol,.false.,
|
|
$dcore,0,1.d0,iout,varsfile,icore,dcore,nbset,oeintfile,nocc,
|
|
$scrfile3,scrfile4,maxcor,imem,tedatfile,dfnbasis_cor,
|
|
$nbasis,4,dcore,minpfile,.false.,1,dcore,irecln,1,.false.,0,0,0,
|
|
$1.d0,ppq,1,dcore,0,0,nmobasis,i,i,i,i,i,i,i,0.d0,0.d0,0.d0,
|
|
$.true.,dcore(igrad_tmp),dcore,dcore,i,.false.,.false.,dcore,
|
|
$.false.,.false.,0,i,.false.,dcore,dcore,.false.,.false.,nocc)
|
|
call daxpy(3*natoms*8,cmp2,dcore(igrad_tmp),1,grads,1)
|
|
call dbldealloc(igrad_tmp)
|
|
C
|
|
return
|
|
end
|
|
C
|
|
***********************************************************************
|
|
subroutine lapqconst(scrfile1,scrfile2,scrfile3,scrfile4,
|
|
$scrfile5,scr,nbasis,ncore,nocc,nbl,nbll,nblock,nvirt,nblv,nbllv,
|
|
$nblockv,dfnbasis,ifltln,ef,eo,ev,ppq,jij,jai,jab,xp,xli,xla,xlm,
|
|
$jpij,jpab,jpab1,yia,chfx)
|
|
***********************************************************************
|
|
* Assemble four-center scf integrals (A_lapq) with a 2D matrix P_pq (P_pq=P_if+P_ij+P_ab) to construct matrix Y_la
|
|
***********************************************************************
|
|
implicit none
|
|
integer nb,nbl,nbll,iblock,nblock,nblv,nbllv,nblockv,ifrst,ijdim
|
|
integer dfnbasis,nocc,ncore,ii,j,ij,l,a,nvirt,m,k,kfrst,n,nb2,nb3
|
|
integer scrfile1,scrfile2,scrfile3,scrfile4,scrfile5,nbasis
|
|
integer jblock,jfrst,b,ifltln,i,p,pp
|
|
real*8 scr(*),ef(ncore),eo(nocc),ev(nvirt),chfx
|
|
real*8 ppq(nbasis+ncore,nbasis+ncore),jij(*)
|
|
real*8 jai(nvirt*nbl*dfnbasis),jab(*),xp(dfnbasis)
|
|
real*8 xli(dfnbasis,nbl,nocc),xla(*),xlm(dfnbasis,nbl,ncore+nocc)
|
|
real*8 jpij(dfnbasis,nbl,ncore+nocc),jpab(dfnbasis,nblv,nvirt)
|
|
real*8 jpab1(dfnbasis,nblv)
|
|
real*8 yia(ncore+nocc,nvirt)
|
|
real*8 ei,ej
|
|
C Calculate X^P
|
|
C Loop over I blocks in J^P_ij
|
|
!!!!!!!!Itt meg nincs figyelembeveve, hogy ppq(fi)=0
|
|
call dfillzero(xp,dfnbasis)
|
|
rewind(scrfile2)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
ijdim=(2*ifrst+nb+1)*nb/2
|
|
read(scrfile2) (jij(i),i=1,dfnbasis*ijdim) !dcore(ijai)
|
|
c write(6,*) (jij(i),i=1,dfnbasis*ijdim)
|
|
do ii=1,nb
|
|
i=ifrst+ii
|
|
do j=1,i
|
|
ij=(2*ifrst+ii)*(ii-1)/2+j
|
|
if(i.eq.j) then
|
|
scr(ij)=ppq(i,j)
|
|
else
|
|
scr(ij)=ppq(j,i)+ppq(i,j)
|
|
endif
|
|
enddo
|
|
enddo
|
|
call dgemv('n',dfnbasis,ijdim,1.d0,jij,dfnbasis,scr,1,1.d0,xp,1)! !dcore(ixp)
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('xp_i')")
|
|
c write(6,"(1000f10.5)") (xp(p),p=1,dfnbasis)
|
|
C Loop over A blocks in J^P_ab
|
|
rewind(scrfile3)
|
|
do iblock=1,nblockv
|
|
nb=nblv
|
|
if(iblock.eq.nblockv) nb=nbllv
|
|
ifrst=(iblock-1)*nblv
|
|
ijdim=(2*ifrst+nb+1)*nb/2
|
|
read(scrfile3) (jab(i),i=1,dfnbasis*ijdim) !!dcore(ijai)
|
|
c write(6,*) (jab(i),i=1,dfnbasis*ijdim)
|
|
do ii=1,nb
|
|
i=ifrst+ii
|
|
do j=1,i
|
|
ij=(2*ifrst+ii)*(ii-1)/2+j
|
|
if(i.eq.j) then
|
|
scr(ij)=ppq(ncore+nocc+i,ncore+nocc+j)
|
|
else
|
|
scr(ij)=2.d0*ppq(ncore+nocc+i,ncore+nocc+j)
|
|
endif
|
|
enddo
|
|
enddo
|
|
call dgemv('n',dfnbasis,ijdim,1.d0,jab,dfnbasis,scr,1,1.d0,xp,1)
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('xp')")
|
|
c write(6,"(1000f10.5)") (xp(p),p=1,dfnbasis)
|
|
C Assemble (la|pq)p_pq
|
|
rewind(scrfile1)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
read(scrfile1) (jai(i),i=1,nvirt*nb*dfnbasis)
|
|
c write(6,*) (jai(i),i=1,nvirt*nb*dfnbasis)
|
|
c read(scrfile1) (((jai(i,j,p),i=1,nvirt),j=1,nb),p=1,dfnbasis)
|
|
call dfillzero(scr,nb*nvirt)
|
|
call dgemv('n',nvirt*nb,dfnbasis,4.d0,jai,nvirt*nb,
|
|
$xp,1,1.d0,scr,1)
|
|
ii=0
|
|
do l=1,nb
|
|
do a=1,nvirt
|
|
ii=ii+1
|
|
yia(ifrst+l,a)=scr(ii)
|
|
enddo
|
|
enddo
|
|
c do l=1,nb
|
|
c do a=1,nvirt
|
|
c do p=1,dfnbasis
|
|
c yia(ifrst+l,a)=yia(ifrst+l,a)-4*
|
|
c $jai(a+(l-1)*nvirt+(p-1)*nvirt*nb)*xp(p)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
enddo
|
|
if(chfx.eq.0.d0) return
|
|
c kiirt
|
|
c write(6,"('y_ia_1')")
|
|
c do i=1,ncore+nocc
|
|
c write(6,"(1000f10.5)") (yia(i,j),j=1,nvirt)
|
|
c enddo
|
|
c Calculate X^P_li and X^P_lm
|
|
open(scrfile4,access='direct',recl=ifltln*nbl*dfnbasis)
|
|
if(ncore.gt.0) then
|
|
open(scrfile5,access='direct',recl=ifltln*nbl*dfnbasis)
|
|
endif
|
|
c open(scrfile5,access='direct',recl=irecln)
|
|
c nreca=mod(nbl*nvirt*dfnbasis,ibufln)
|
|
c if(nreca.eq.0) then
|
|
c nreca=nbl*nvirt*dfnbasis/ibufln
|
|
c else
|
|
c nreca=(nbl*nvirt*dfnbasis-nreca)/ibufln+1
|
|
c endif
|
|
rewind(scrfile2)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
ijdim=(2*ifrst+nb+1)*nb/2
|
|
read(scrfile2) (jij(i),i=1,dfnbasis*ijdim)
|
|
do ii=1,nb
|
|
i=ifrst+ii
|
|
do j=1,i
|
|
ij=(2*ifrst+ii)*(ii-1)/2+j
|
|
if(j.gt.ifrst) then
|
|
if(j.eq.i) then
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
else
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,
|
|
$jpij(1,j-ifrst,ifrst+ii),1)
|
|
endif
|
|
else
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
endif
|
|
enddo
|
|
enddo
|
|
call dgemm('n','t',dfnbasis*nb,nocc,ifrst+nb,1.d0,
|
|
$jpij,dfnbasis*nbl,ppq(ncore+1,1),ncore+nbasis,0.d0,
|
|
$xli,dfnbasis*nbl)
|
|
ckiirt
|
|
c write(6,"('xli_0')")
|
|
c do p=1,dfnbasis
|
|
c write(6,"(' ')")
|
|
c do l=1,nb
|
|
c write(6,"(1000f10.5)") (xli(p,l,i),i=1,nocc)
|
|
c enddo
|
|
c enddo
|
|
|
|
do i=1,nocc
|
|
write(scrfile4,rec=(iblock-1)*nocc+i) ((xli(p,l,i),p=1,
|
|
$dfnbasis),l=1,nb)
|
|
enddo
|
|
|
|
if(ncore.gt.0) then
|
|
ckiirt
|
|
c write(6,"('jpij')")
|
|
c do p=1,dfnbasis
|
|
c write(6,"(' ')")
|
|
c do l=1,nbl
|
|
c write(6,"(1000f10.5)") (jpij(p,l,i),i=1,ifrst+nb)
|
|
c enddo
|
|
c enddo
|
|
c write(6,"('ppq')")
|
|
c do i=1,nocc
|
|
c write(6,"(1000f10.5)") (ppq(ncore+i,j),j=1,ncore+nbasis)
|
|
c enddo
|
|
c call dgemm('n','n',dfnbasis*nb,ncore+nocc,ifrst+nb,1.d0,
|
|
c $jpij(1,1,ncore+1),dfnbasis*nbl,ppq(ncore+1,1),ncore+nbasis,0.d0,
|
|
c $xlm,dfnbasis*nbl)
|
|
call dgemm('n','n',dfnbasis*nb,ncore+nocc,ifrst+nb,1.d0,
|
|
$jpij,dfnbasis*nbl,ppq,ncore+nbasis,0.d0,
|
|
$xlm,dfnbasis*nbl) ! itt nem vettem figyelembe, hogy ppq_fi=0
|
|
do m=1,ncore+nocc
|
|
write(scrfile5,rec=(iblock-1)*(ncore+nocc)+m) ((xlm(p,l,m),p=1,
|
|
$dfnbasis),l=1,nb)
|
|
enddo
|
|
c kiirt
|
|
c write(6,"('xlm_core')")
|
|
c do p=1,dfnbasis
|
|
c write(6,"(' ')")
|
|
c do l=1,nbl
|
|
c write(6,"(1000f10.5)") (xlm(p,l,m),m=1,ncore+nocc)
|
|
c enddo
|
|
c enddo
|
|
|
|
endif
|
|
do k=1,iblock-1
|
|
kfrst=(k-1)*nbl
|
|
do i=1,nocc
|
|
read(scrfile4,rec=(k-1)*nocc+i) ((xli(p,l,i),p=1,dfnbasis),
|
|
$l=1,nbl)
|
|
enddo
|
|
call dfillzero(scr,dfnbasis*nbl*nocc)
|
|
do i=1,nbl
|
|
call dgemm('n','t',dfnbasis,nocc,nb,1.d0,
|
|
$jpij(1,1,kfrst+i),dfnbasis,
|
|
$ppq(ncore+1,ifrst+1),ncore+nbasis,
|
|
$1.d0,scr((i-1)*dfnbasis*nocc+1),dfnbasis)
|
|
enddo
|
|
ii=0
|
|
do j=1,nbl
|
|
do p=1,nocc
|
|
do pp=1,dfnbasis
|
|
ii=ii+1
|
|
xli(pp,j,p)=xli(pp,j,p)+scr(ii)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('xli_kieg')")
|
|
c do p=1,3
|
|
c write(6,"(' ')")
|
|
c do l=1,nbl
|
|
c write(6,"(1000f10.5)") (xli(p,l,i),i=1,nocc)
|
|
c enddo
|
|
c enddo
|
|
|
|
do i=1,nocc
|
|
write(scrfile4,rec=(k-1)*nocc+i) ((xli(p,l,i),p=1,dfnbasis),
|
|
$l=1,nbl)
|
|
enddo
|
|
if(ncore.gt.0) then
|
|
do m=1,ncore+nocc
|
|
read(scrfile5,rec=(k-1)*(ncore+nocc)+m) ((xlm(p,l,m),p=1,
|
|
$dfnbasis),l=1,nbl)
|
|
enddo
|
|
call dfillzero(scr,dfnbasis*nbl*(ncore+nocc))
|
|
do i=1,nbl
|
|
call dgemm('n','n',dfnbasis,ncore+nocc,nb,1.d0,
|
|
$jpij(1,1,kfrst+i),dfnbasis,
|
|
$ppq(ifrst+1,1),ncore+nbasis,
|
|
$1.d0,scr((i-1)*dfnbasis*(ncore+nocc)+1),dfnbasis) ! itt nem vettem figyelembe, hogy ppq_fi=0
|
|
enddo
|
|
ii=0
|
|
do j=1,nbl
|
|
do p=1,ncore+nocc
|
|
do pp=1,dfnbasis
|
|
ii=ii+1
|
|
xlm(pp,j,p)=xlm(pp,j,p)+scr(ii)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
do m=1,ncore+nocc
|
|
write(scrfile5,rec=(k-1)*(ncore+nocc)+m) ((xlm(p,l,m),p=1,
|
|
$dfnbasis),l=1,nbl)
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('xlm_core')")
|
|
c do p=1,dfnbasis
|
|
c write(6,"(' ')")
|
|
c do l=1,nbl
|
|
c write(6,"(1000f10.5)") (xlm(p,l,m),m=1,ncore+nocc)
|
|
c enddo
|
|
c enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
c Assemble the first part of (lq|pa)pi_pq and (lp|qa)pi_pq
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
rewind(scrfile1)
|
|
n=0
|
|
do jblock=1,nblock
|
|
nb2=nbl
|
|
if(jblock.eq.nblock) nb2=nbll
|
|
read(scrfile1) (jai(i),i=1,nvirt*nb2*dfnbasis)
|
|
if(ncore.eq.0) then
|
|
jfrst=(jblock-1)*nbl
|
|
do i=1,nb2
|
|
read(scrfile4,rec=(iblock-1)*nocc+jfrst+i) ((xli(k,l,i),
|
|
$k=1,dfnbasis),l=1,nb)
|
|
call dgemm('t','t',nb,nvirt,dfnbasis,2.d0*chfx,
|
|
$xli(1,1,i),dfnbasis,jai((i-1)*nvirt+1),nvirt*nb2,1.d0,
|
|
$yia(ifrst+1,1),nocc)
|
|
enddo
|
|
c kiirt
|
|
c write(6,"('y_ia_2')")
|
|
c do i=1,ncore+nocc
|
|
c write(6,"(1000f10.5)") (yia(i,j),j=1,nvirt)
|
|
c enddo
|
|
else
|
|
n=n+nb2
|
|
if(n.gt.ncore) then
|
|
if((ncore+nb2).gt.n) then
|
|
nb3=n-ncore
|
|
do i=1,nb3
|
|
read(scrfile4,rec=(iblock-1)*nocc+i) ((xli(k,l,i),
|
|
$k=1,dfnbasis),l=1,nbl)
|
|
call dgemm('t','t',nbl,nvirt,dfnbasis,chfx,
|
|
$xli(1,1,i),dfnbasis,jai((nb2-nb3+i-1)*nvirt+1),nvirt*nb2,1.d0,
|
|
$yia(ifrst+1,1),ncore+nocc)
|
|
c do a=1,nvirt
|
|
c do l=1,nb
|
|
c do p=1,dfnbasis
|
|
c yia(l,a)=yia(l,a)+xli(p,l,i)*jai(a,i,p)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
enddo
|
|
c write(6,"('y_ia_koz')")
|
|
c do i=1,ncore+nocc
|
|
c write(6,"(1000f10.5)") (yia(i,j),j=1,nvirt)
|
|
c enddo
|
|
|
|
else
|
|
jfrst=(jblock-1)*nbl-ncore
|
|
do i=1,nb2
|
|
read(scrfile4,rec=(iblock-1)*nocc+jfrst+i) ((xli(k,l,i),
|
|
$k=1,dfnbasis),l=1,nb)
|
|
call dgemm('t','t',nb,nvirt,dfnbasis,chfx,
|
|
$xli(1,1,i),dfnbasis,jai((i-1)*nvirt+1),nvirt*nb2,1.d0,
|
|
$yia(ifrst+1,1),ncore+nocc)
|
|
c do a=1,nvirt
|
|
c do l=ifrst+1,ifrst+nb
|
|
c do p=1,dfnbasis
|
|
c yia(l,a)=yia(l,a)+xli(p,l,i)*jai(a,i,p)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
enddo
|
|
endif
|
|
endif
|
|
jfrst=(jblock-1)*nbl
|
|
do m=1,nb2
|
|
read(scrfile5,rec=(iblock-1)*(ncore+nocc)+jfrst+m)
|
|
$((xlm(k,l,m),k=1,dfnbasis),l=1,nb)
|
|
ckiirt
|
|
c write(6,"('xlm_read')")
|
|
c do p=1,dfnbasis
|
|
c write(6,"(' ')")
|
|
c do l=1,nbl
|
|
c write(6,"(1000f10.5)") (xlm(p,l,i),i=1,ncore+nocc)
|
|
c enddo
|
|
c enddo
|
|
c write(6,"('jai')")
|
|
c write(6,"(1000f10.5)") jaii
|
|
c write(6,"(5i5)") m,ifrst,nb2
|
|
call dgemm('t','t',nb,nvirt,dfnbasis,chfx,
|
|
$xlm(1,1,m),dfnbasis,jai((m-1)*nvirt+1),nvirt*nb2,1.d0,
|
|
$yia(ifrst+1,1),ncore+nocc)
|
|
c do a=1,nvirt
|
|
c do l=ifrst+1,ifrst+nb
|
|
c do p=1,dfnbasis
|
|
c yia(l,a)=yia(l,a)-xlm(p,l,m)*jai((m-1)*nvirt+a)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
|
|
c kiirt
|
|
c write(6,"('y_ia_2')")
|
|
c do i=1,ncore+nocc
|
|
c write(6,"(1000f10.5)") (yia(i,j),j=1,nvirt)
|
|
c enddo
|
|
enddo
|
|
c kiirt
|
|
c write(6,"('y_ia_2')")
|
|
c do i=1,ncore+nocc
|
|
c write(6,"(1000f10.5)") (yia(i,j),j=1,nvirt)
|
|
c enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
close(scrfile5)
|
|
close(scrfile4)
|
|
c kiirt
|
|
c write(6,"('y_ia_i')")
|
|
c do i=1,ncore+nocc
|
|
c write(6,"(1000f10.5)") (yia(i,j),j=1,nvirt)
|
|
c enddo
|
|
c Calculate X^P_la and assemble the second part of (lq|pa)pi_pq and (lp|qa)pi_pq
|
|
rewind(scrfile1)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
read(scrfile1) (jai(i),i=1,nvirt*nb*dfnbasis) !dcore(ijai)
|
|
c read(scrfile1) (((jai3(i,j,p),i=1,nvirt),j=1,nb),p=1,dfnbasis) !dcore(ijai)
|
|
call dgemm('t','t',nb*dfnbasis,nvirt,nvirt,1.d0,
|
|
$jai,nvirt,ppq(ncore+nocc+1,ncore+nocc+1),ncore+nbasis,
|
|
$0.d0,xla,nb*dfnbasis) !dcore(ixlp)
|
|
rewind(scrfile3)
|
|
do jblock=1,nblockv
|
|
nb2=nblv
|
|
if(jblock.eq.nblockv) nb2=nbllv
|
|
jfrst=(jblock-1)*nblv
|
|
ijdim=(2*jfrst+nb2+1)*nb2/2
|
|
read(scrfile3) (jab(i),i=1,dfnbasis*ijdim) !dcore(ijai)
|
|
do ii=1,nb2
|
|
i=jfrst+ii
|
|
do j=1,i
|
|
ij=(2*jfrst+ii)*(ii-1)/2+j
|
|
if(j.gt.jfrst) then
|
|
if(j.eq.i) then
|
|
call dcopy(dfnbasis,jab((ij-1)*dfnbasis+1),1,jpab(1,ii,j),1)
|
|
else
|
|
call dcopy(dfnbasis,jab((ij-1)*dfnbasis+1),1,jpab(1,ii,j),1)
|
|
call dcopy(dfnbasis,jab((ij-1)*dfnbasis+1),1,
|
|
$jpab(1,j-jfrst,jfrst+ii),1)
|
|
endif
|
|
else
|
|
call dcopy(dfnbasis,jab((ij-1)*dfnbasis+1),1,jpab(1,ii,j),1)
|
|
endif
|
|
enddo
|
|
enddo
|
|
call dgemm('n','n',nb,jfrst+nb2,dfnbasis*nb2,2.d0*chfx,
|
|
$xla(jfrst*dfnbasis*nb+1),nb,jpab,dfnbasis*nblv,1.d0,
|
|
$yia(ifrst+1,1),ncore+nocc)
|
|
do k=1,jblock-1
|
|
kfrst=(k-1)*nblv
|
|
do a=1,nb2
|
|
do p=1,dfnbasis
|
|
do b=1,nblv
|
|
jpab1(p,b)=jpab(p,a,kfrst+b)
|
|
enddo
|
|
enddo
|
|
call dgemv('n',nb,dfnbasis*nblv,2.d0*chfx,
|
|
$xla(kfrst*dfnbasis*nb+1),nb,jpab1,1,1.d0,
|
|
$yia(ifrst+1,jfrst+a),1)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c kiirt
|
|
c write(6,"('y_ia')")
|
|
c do i=1,ncore+nocc
|
|
c write(6,"(1000f10.7)") (yia(i,j),j=1,nvirt)
|
|
c enddo
|
|
return
|
|
end
|
|
|
|
***********************************************************************
|
|
subroutine labmconst(scrfile1,scrfile2,scrfile3,scrfile4,
|
|
$scrfile5,scr,nbasis,ncore,nocc,nbl,nbll,nblock,nvirt,nblv,nbllv,
|
|
$nblockv,dfnbasis,ifltln,ef,eo,ev,pal,jij,jai,jab,xp,xlm,xam,
|
|
$jpab,jpij,zal,chfx)
|
|
***********************************************************************
|
|
* Assemble four-center scf integrals (A_labm) with a 2D matrix P_al (P_bm=P_af+P_ai) to construct matrix Z_al
|
|
***********************************************************************
|
|
implicit none
|
|
integer nb,nbl,nbll,iblock,nblock,nblv,nbllv,nblockv,ifrst,ijdim
|
|
integer dfnbasis,nocc,ncore,ii,j,ij,l,a,nvirt,m,k,kfrst,n,nb2,nb3
|
|
integer scrfile1,scrfile2,scrfile3,scrfile4,scrfile5,nbasis
|
|
integer jblock,jfrst,b,ifltln,i,p,pp
|
|
real*8 scr(*),ef(ncore),eo(nocc),ev(nvirt),pal(nvirt,ncore+nocc)
|
|
real*8 jij(*),jai(nvirt*nbl*dfnbasis),jab(*),xp(dfnbasis),chfx
|
|
real*8 xlm(*),xam(dfnbasis,nblv,ncore+nocc)
|
|
real*8 jpab(dfnbasis,nblv,nvirt),jpij(dfnbasis,nbl,ncore+nocc)
|
|
real*8 zal(nvirt,ncore+nocc),ei,ej
|
|
character(len=32) dft
|
|
C Calculate X^P
|
|
rewind(scrfile1)
|
|
call dfillzero(xp,dfnbasis)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
read(scrfile1) (jai(i),i=1,nvirt*nb*dfnbasis)
|
|
call dgemv('t',nvirt*nb,dfnbasis,1.d0,
|
|
$jai,nvirt*nb,pal(1,ifrst+1),1,1.d0,
|
|
$xp,1)
|
|
enddo
|
|
C Assemble 4(al|bm)P_bm
|
|
rewind(scrfile1)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
read(scrfile1) (jai(i),i=1,nvirt*nb*dfnbasis)
|
|
call dgemv('n',nvirt*nb,dfnbasis,4.d0,
|
|
$jai,nvirt*nb,xp,1,0.d0,
|
|
$zal(1,ifrst+1),1)
|
|
enddo
|
|
if(chfx.eq.0.d0) return
|
|
ckiirt
|
|
c write(6,"('Zal_1')")
|
|
c do a=1,nvirt
|
|
c write(6,"(100000f10.5)") (zal(a,l),l=1,ncore+nocc)
|
|
c enddo
|
|
|
|
C Calculate X^P_lm
|
|
rewind(scrfile1)
|
|
open(scrfile5,access='direct',recl=ifltln*nbl*dfnbasis)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
read(scrfile1) (jai(i),i=1,nvirt*nb*dfnbasis)
|
|
call dgemm('t','n',nb*dfnbasis,ncore+nocc,nvirt,1.d0,
|
|
$jai,nvirt,
|
|
$pal,nvirt,0.d0,
|
|
$xlm,nb*dfnbasis)
|
|
do m=1,ncore+nocc
|
|
write(scrfile5,rec=(iblock-1)*(ncore+nocc)+m)
|
|
$((xlm(l+(p-1)*nb+(m-1)*nb*dfnbasis),l=1,nb),p=1,dfnbasis)
|
|
enddo
|
|
enddo
|
|
C Assemble (am|bl)P_bm
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
c write(6,*) iblock,nb,ifrst
|
|
rewind(scrfile1)
|
|
do jblock=1,nblock
|
|
nb2=nbl
|
|
if(jblock.eq.nblock) nb2=nbll
|
|
jfrst=(jblock-1)*nbl
|
|
c write(6,*) jblock,nb2,jfrst
|
|
read(scrfile1) (jai(i),i=1,nvirt*nb2*dfnbasis)
|
|
do m=1,nb2
|
|
c write(6,*) jfrst+m
|
|
read(scrfile5,rec=(iblock-1)*(ncore+nocc)+jfrst+m)
|
|
$((xlm(l+(p-1)*nb+(m-1)*nb*dfnbasis),l=1,nb),p=1,dfnbasis)
|
|
call dgemm('n','t',nvirt,nb,dfnbasis,chfx,
|
|
$jai((m-1)*nvirt+1),nvirt*nb2,
|
|
$xlm((m-1)*nb*dfnbasis+1),nb,1.d0,
|
|
$zal(1,ifrst+1),nvirt)
|
|
c do a=1,nvirt
|
|
c do l=1,nb
|
|
c do p=1,dfnbasis
|
|
c zal(a,ifrst+l)=zal(a,ifrst+l)-
|
|
c $jai((p-1)*nvirt*nb2+(m-1)*nvirt+a)*
|
|
c $xlm(l+(p-1)*nb+(m-1)*nb*dfnbasis)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
enddo
|
|
c write(6,"('Zal_resz')")
|
|
c do a=1,nvirt
|
|
c write(6,"(100000f10.5)") (zal(a,l),l=1,ncore+nocc)
|
|
c enddo
|
|
enddo
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('Zal_2')")
|
|
c do a=1,nvirt
|
|
c write(6,"(100000f10.5)") (zal(a,l),l=1,ncore+nocc)
|
|
c enddo
|
|
|
|
c Calulate X^P_am
|
|
open(scrfile4,access='direct',recl=ifltln*nblv*dfnbasis)
|
|
rewind(scrfile3)
|
|
do iblock=1,nblockv
|
|
nb=nblv
|
|
if(iblock.eq.nblockv) nb=nbllv
|
|
ifrst=(iblock-1)*nblv
|
|
c write(6,"(1000i10)") iblock,ifrst,nb
|
|
ijdim=(2*ifrst+nb+1)*nb/2
|
|
read(scrfile3) (jab(i),i=1,dfnbasis*ijdim) !dcore(ijai)
|
|
do ii=1,nb
|
|
i=ifrst+ii
|
|
do j=1,i
|
|
ij=(2*ifrst+ii)*(ii-1)/2+j
|
|
if(j.gt.ifrst) then
|
|
if(j.eq.i) then
|
|
call dcopy(dfnbasis,jab((ij-1)*dfnbasis+1),1,jpab(1,ii,j),1)! dcore(ijpij)
|
|
else
|
|
call dcopy(dfnbasis,jab((ij-1)*dfnbasis+1),1,jpab(1,ii,j),1)
|
|
call dcopy(dfnbasis,jab((ij-1)*dfnbasis+1),1,
|
|
$jpab(1,j-ifrst,ifrst+ii),1)
|
|
endif
|
|
else
|
|
call dcopy(dfnbasis,jab((ij-1)*dfnbasis+1),1,jpab(1,ii,j),1)
|
|
endif
|
|
enddo
|
|
enddo
|
|
call dgemm('n','n',dfnbasis*nb,ncore+nocc,ifrst+nb,1.d0,
|
|
$jpab,dfnbasis*nblv,
|
|
$pal,nvirt,0.d0, !dcoe(ipab)
|
|
$xam,dfnbasis*nblv) !dcore(ixlp)
|
|
do i=1,ncore+nocc
|
|
write(scrfile4,rec=(iblock-1)*(ncore+nocc)+i) ((xam(p,a,i),p=1,
|
|
$dfnbasis),a=1,nb)
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('xam_0')")
|
|
c do p=1,3
|
|
c write(6,"(' ')")
|
|
c do a=1,nb
|
|
c write(6,"(1000f10.5)") (xam(p,a,i),i=1,ncore+nocc)
|
|
c enddo
|
|
c enddo
|
|
do k=1,iblock-1
|
|
kfrst=(k-1)*nblv
|
|
do i=1,ncore+nocc
|
|
read(scrfile4,rec=(k-1)*(ncore+nocc)+i) ((xam(p,a,i),
|
|
$p=1,dfnbasis),a=1,nblv)
|
|
enddo
|
|
ckiirt write(6,"('xam_read_0')")
|
|
c do p=1,3
|
|
c write(6,"(' ')")
|
|
c do a=1,nblv
|
|
c write(6,"(1000f10.5)") (xam(p,a,i),i=1,ncore+nocc)
|
|
c enddo
|
|
c enddo
|
|
call dfillzero(jij,dfnbasis*nblv*(ncore+nocc))
|
|
do b=1,nblv
|
|
call dgemm('n','n',dfnbasis,ncore+nocc,nb,1.d0,
|
|
$jpab(1,1,kfrst+b),dfnbasis,
|
|
$pal(ifrst+1,1),nvirt,0.d0,
|
|
$jij((b-1)*dfnbasis*(ncore+nocc)+1),dfnbasis)
|
|
enddo
|
|
|
|
ckiirt write(6,"('scr')")
|
|
c do p=1,3
|
|
c write(6,"(' ')")
|
|
c do b=1,nblv
|
|
c write(6,"(1000f10.5)") (scr((b-1)*dfnbasis*(ncore+nocc)+
|
|
c $(i-1)*dfnbasis+p),i=1,ncore+nocc)
|
|
c enddo
|
|
c enddo
|
|
ii=0
|
|
do a=1,nblv
|
|
do i=1,ncore+nocc
|
|
do pp=1,dfnbasis
|
|
ii=ii+1
|
|
xam(pp,a,i)=xam(pp,a,i)+jij(ii)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('xam_kieg')")
|
|
c do p=1,3
|
|
c write(6,"(' ')")
|
|
c do a=1,nblv
|
|
c write(6,"(1000f10.5)") (xam(p,a,i),i=1,ncore+nocc)
|
|
c enddo
|
|
c enddo
|
|
do i=1,ncore+nocc
|
|
write(scrfile4,rec=(k-1)*(ncore+nocc)+i)
|
|
$((xam(p,a,i),p=1,dfnbasis),a=1,nblv)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
ckiirt do iblock=1,nblockv
|
|
c ifrst=(iblock-1)*nblv
|
|
c nb=nblv
|
|
c if(iblock.eq.nblockv) nb=nbllv
|
|
c do i=1,ncore+nocc
|
|
c read(scrfile4,rec=(iblock-1)*(ncore+nocc)+i)
|
|
c $((xam(p,a,i),p=1,dfnbasis),a=1,nb)
|
|
c enddo
|
|
c write(6,"('xam')")
|
|
c do p=1,3
|
|
c write(6,"(' ')")
|
|
c do a=1,nb
|
|
c write(6,"(1000f10.5)") (xam(p,a,i),i=1,ncore+nocc)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
C Assemble (ab|ml)P_bm
|
|
do iblock=1,nblockv
|
|
nb=nblv
|
|
if(iblock.eq.nblockv) nb=nbllv
|
|
ifrst=(iblock-1)*nblv
|
|
c write(6,"(1000i10)") iblock,ifrst,nb
|
|
rewind(scrfile2)
|
|
do jblock=1,nblock
|
|
nb2=nbl
|
|
if(jblock.eq.nblock) nb2=nbll
|
|
jfrst=(jblock-1)*nbl
|
|
ijdim=(2*jfrst+nb2+1)*nb2/2
|
|
read(scrfile2) (jij(i),i=1,dfnbasis*ijdim) ! dcore(ijai)
|
|
do ii=1,nb2
|
|
i=jfrst+ii
|
|
do j=1,i
|
|
ij=(2*jfrst+ii)*(ii-1)/2+j
|
|
if(j.gt.jfrst) then
|
|
if(j.eq.i) then
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,
|
|
$jpij(1,ii,j),1) !dcore(ijpij)
|
|
else
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,
|
|
$jpij(1,ii,j),1)
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,
|
|
$jpij(1,j-jfrst,jfrst+ii),1)
|
|
endif
|
|
else
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
endif
|
|
enddo
|
|
enddo
|
|
do i=1,nb2
|
|
read(scrfile4,rec=(iblock-1)*(ncore+nocc)+jfrst+i)
|
|
$((xam(p,a,i),p=1,dfnbasis),a=1,nb) !dcore(xlp)
|
|
c call dgemm('t','n',nb,jfrst+nb2,dfnbasis,-1.d0,
|
|
c $xam(1,1,i),dfnbasis,
|
|
c $jpij(1,i,1),dfnbasis*nbl,1.d0,
|
|
c $zal(ifrst+1,1),nvirt)
|
|
do a=1,nb
|
|
do l=1,jfrst+nb2
|
|
do p=1,dfnbasis
|
|
zal(ifrst+a,l)=zal(ifrst+a,l)+chfx*xam(p,a,i)*jpij(p,i,l)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('Zal_0')")
|
|
c do a=1,nvirt
|
|
c write(6,"(100000f10.7)") (zal(a,l),l=1,ncore+nocc)
|
|
c enddo
|
|
do k=1,jblock-1
|
|
kfrst=(k-1)*nbl
|
|
do i=1,nbl
|
|
read(scrfile4,rec=(iblock-1)*(ncore+nocc)+kfrst+i)
|
|
$((xam(p,a,i),p=1,dfnbasis),a=1,nb) !dcore(xlp)
|
|
call dgemm('t','n',nb,nb2,dfnbasis,chfx,
|
|
$xam(1,1,i),dfnbasis,
|
|
$jpij(1,1,kfrst+i),dfnbasis,1.d0,
|
|
$zal(ifrst+1,jfrst+1),nvirt)
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('Zal_kieg')")
|
|
c do a=1,nvirt
|
|
c write(6,"(100000f10.5)") (zal(a,l),l=1,ncore+nocc)
|
|
c enddo
|
|
c do i=1,nb2
|
|
c do p=1,dfnbasis
|
|
c do j=1,nbl
|
|
c jpij1(j,p)=jpij(p,i,kfrst+j) !dcore(ijai)
|
|
c enddo
|
|
c enddo
|
|
c call dgemv('t',nb,dfnbasis*nbl,-1.d0,
|
|
c $xam(1,1,kfrst+1),dfnbasis,
|
|
c $jpij1,1,1.d0,
|
|
c $zal(ifrst+1,jfrst+i),1)
|
|
c enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
close(scrfile4)
|
|
close(scrfile5)
|
|
c write(6,"('Zal')")
|
|
c do a=1,nvirt
|
|
c write(6,"(100000f10.5)") (zal(a,l),l=1,ncore+nocc)
|
|
c enddo
|
|
return
|
|
end
|
|
***********************************************************************
|
|
subroutine lmpqconst(scrfile1,scrfile2,scrfile3,scrfile4,
|
|
$scrfile5,scr,nbasis,ncore,nocc,nbl,nbll,nblock,nvirt,nblv,nbllv,
|
|
$nblockv,dfnbasis,ifltln,ef,eo,ev,ppq,pal,jij,jai,jai3d,jab,xp,xla,
|
|
$xla2,xlm,xlm2,jpij,jpij1,ylm,chfx)
|
|
***********************************************************************
|
|
C Assemble four-center scf integrals (A_lmpq) with a 2D matrix P_pq (P_pq=P_if+P_ij+P_ab+P_al) to construct matrix Y_la
|
|
***********************************************************************
|
|
implicit none
|
|
integer nb,nbl,nbll,iblock,nblock,nblv,nbllv,nblockv,ifrst,ijdim
|
|
integer dfnbasis,nocc,ncore,ii,j,ij,l,a,nvirt,m,k,kfrst,n,nb2,nb3
|
|
integer scrfile1,scrfile2,scrfile3,scrfile4,scrfile5,nbasis
|
|
integer jblock,jfrst,b,ifltln,i,p,pp
|
|
real*8 jij(*),scr(*),ppq(nbasis+ncore,nbasis+ncore),xp(dfnbasis)
|
|
real*8 jab(*),jai(nvirt*nbl*dfnbasis),ylm(ncore+nocc,ncore+nocc)
|
|
real*8 jpij(dfnbasis,nbl,ncore+nocc),jai3d(nvirt,nbl,dfnbasis)
|
|
real*8 xlm(dfnbasis,nbl,ncore+nocc),chfx
|
|
real*8 xla2(*),xlm2(*)
|
|
real*8 xla(dfnbasis,nbl,nvirt)
|
|
real*8 jpij1(dfnbasis,nbl)
|
|
real*8 ef(ncore),eo(nocc),ev(nvirt)
|
|
real*8 ei,ej,pal(nvirt,ncore+nocc)
|
|
!!!!!!!!!!!!Nincs mindenhol figyelembe veve, hogy Y_lm szimmetrikus
|
|
C Calculate X^P
|
|
C Loop over I blocks in J^P_ij
|
|
!!!!!!!Itt meg nincs figyelembeveve, hogy ppq(fi)=0
|
|
call dfillzero(xp,dfnbasis)
|
|
rewind(scrfile2)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
ijdim=(2*ifrst+nb+1)*nb/2
|
|
read(scrfile2) (jij(i),i=1,dfnbasis*ijdim) !dcore(ijai)
|
|
do ii=1,nb
|
|
i=ifrst+ii
|
|
do j=1,i
|
|
ij=(2*ifrst+ii)*(ii-1)/2+j
|
|
if(i.eq.j) then
|
|
scr(ij)=ppq(i,j)
|
|
else
|
|
scr(ij)=2.d0*ppq(i,j)
|
|
endif
|
|
enddo
|
|
enddo
|
|
call dgemv('n',dfnbasis,ijdim,1.d0,jij,dfnbasis,scr,1,1.d0,xp,1)! !dcore(ixp)
|
|
enddo
|
|
C kiirt
|
|
c write(6,"('xp_ij')")
|
|
c write(6,"(1000f10.5)") (xp(p),p=1,dfnbasis)
|
|
C Loop over A blocks in J^P_ab
|
|
rewind(scrfile3)
|
|
do iblock=1,nblockv
|
|
nb=nblv
|
|
if(iblock.eq.nblockv) nb=nbllv
|
|
ifrst=(iblock-1)*nblv
|
|
ijdim=(2*ifrst+nb+1)*nb/2
|
|
read(scrfile3) (jab(i),i=1,dfnbasis*ijdim) !!dcore(ijai)
|
|
do ii=1,nb
|
|
i=ifrst+ii
|
|
do j=1,i
|
|
ij=(2*ifrst+ii)*(ii-1)/2+j
|
|
if(i.eq.j) then
|
|
scr(ij)=ppq(ncore+nocc+i,ncore+nocc+j)
|
|
else
|
|
scr(ij)=2.d0*ppq(ncore+nocc+i,ncore+nocc+j)
|
|
endif
|
|
enddo
|
|
enddo
|
|
call dgemv('n',dfnbasis,ijdim,1.d0,jab,dfnbasis,scr,1,1.d0,xp,1)
|
|
enddo
|
|
C kiirt
|
|
c write(6,"('xp_ab')")
|
|
c write(6,"(1000f10.5)") (xp(p),p=1,dfnbasis)
|
|
C Loop over I blocks in J^P_ai
|
|
rewind(scrfile1)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
read(scrfile1) (jai(i),i=1,nvirt*nb*dfnbasis)
|
|
call dgemv('t',nvirt*nb,dfnbasis,1.d0,
|
|
$jai,nvirt*nb,pal(1,ifrst+1),1,1.d0,
|
|
$xp,1)
|
|
enddo
|
|
C kiirt
|
|
c write(6,"('xp_ai')")
|
|
c write(6,"(1000f10.5)") (xp(p),p=1,dfnbasis)
|
|
C Assemble (lm|pq)p_pq
|
|
rewind(scrfile2)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
ijdim=(2*ifrst+nb+1)*nb/2
|
|
read(scrfile2) (jij(i),i=1,dfnbasis*ijdim) !dcore(ijai)
|
|
call dgemv('t',dfnbasis,ijdim,4.d0,jij,dfnbasis,
|
|
$xp,1,0.d0,scr,1)
|
|
c do i=1,ijdim
|
|
c scr(i)=0
|
|
c do p=1,dfnbasis
|
|
c scr(i)=scr(i)+4*jij(p+(i-1)*dfnbasis)*xp(p)
|
|
c enddo
|
|
c enddo
|
|
c kiirt
|
|
c write(6,"('scr')")
|
|
c write(6,"(1000f10.5)") (scr(ii),ii=1,ijdim)
|
|
do ii=1,nb
|
|
i=ifrst+ii
|
|
do j=1,i
|
|
ij=(2*ifrst+ii)*(ii-1)/2+j
|
|
if(i.eq.j) then
|
|
ylm(i,j)=scr(ij)
|
|
else
|
|
ylm(i,j)=scr(ij)
|
|
ylm(j,i)=scr(ij)
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
if(chfx.eq.0.d0) return
|
|
c kiirt
|
|
c write(6,"('Ylm_0')")
|
|
c do l=1,ncore+nocc
|
|
c write(6,"(100000f10.7)") (ylm(l,m),m=1,ncore+nocc)
|
|
c enddo
|
|
c Calculate X^P_lm and part of X^P_la
|
|
open(scrfile4,access='direct',recl=ifltln*nbl*dfnbasis)
|
|
open(scrfile5,access='direct',recl=ifltln*nbl*dfnbasis)
|
|
C Calculate part of X^P_lm
|
|
!!!!! a ket X^P_lm-et eloszor ossze lehetne adni, es utana szorozni
|
|
rewind(scrfile1)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
read(scrfile1) (jai(i),i=1,nvirt*nb*dfnbasis)
|
|
call dgemm('t','n',nb*dfnbasis,ncore+nocc,nvirt,1.d0,
|
|
$jai,nvirt,
|
|
$pal,nvirt,0.d0,
|
|
$xlm2,nb*dfnbasis)
|
|
C Assemble (la|nm)P_am
|
|
rewind(scrfile2)
|
|
do jblock=1,nblock
|
|
nb2=nbl
|
|
if(jblock.eq.nblock) nb2=nbll
|
|
jfrst=(jblock-1)*nbl
|
|
ijdim=(2*jfrst+nb2+1)*nb2/2
|
|
read(scrfile2) (jij(i),i=1,dfnbasis*ijdim) !dcore(ijai)
|
|
do ii=1,nb2
|
|
i=jfrst+ii
|
|
do j=1,i
|
|
ij=(2*jfrst+ii)*(ii-1)/2+j
|
|
if(j.gt.jfrst) then
|
|
if(j.eq.i) then
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
else
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,
|
|
$jpij(1,j-jfrst,jfrst+ii),1)
|
|
endif
|
|
else
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
endif
|
|
enddo
|
|
enddo
|
|
call dgemm('n','n',nb,jfrst+nb2,dfnbasis*nb2,chfx,
|
|
$xlm2(jfrst*dfnbasis*nb+1),nb,jpij,dfnbasis*nbl,1.d0,
|
|
$ylm(ifrst+1,1),ncore+nocc)
|
|
do k=1,jblock-1
|
|
kfrst=(k-1)*nbl
|
|
do i=1,nb2
|
|
do p=1,dfnbasis
|
|
do j=1,nbl
|
|
jpij1(p,j)=jpij(p,i,kfrst+j)
|
|
enddo
|
|
enddo
|
|
call dgemv('n',nb,dfnbasis*nbl,chfx,
|
|
$xlm2(kfrst*dfnbasis*nb+1),nb,jpij1,1,1.d0,
|
|
$ylm(ifrst+1,jfrst+i),1)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c write(6,"('Ylm_-1')")
|
|
c do l=1,ncore+nocc
|
|
c write(6,"(100000f10.5)") (ylm(l,m),m=1,ncore+nocc)
|
|
c enddo
|
|
c Calculate part of X^P_lm
|
|
rewind(scrfile2)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
ijdim=(2*ifrst+nb+1)*nb/2
|
|
read(scrfile2) (jij(i),i=1,dfnbasis*ijdim)
|
|
do ii=1,nb
|
|
i=ifrst+ii
|
|
do j=1,i
|
|
ij=(2*ifrst+ii)*(ii-1)/2+j
|
|
if(j.gt.ifrst) then
|
|
if(j.eq.i) then
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
else
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,
|
|
$jpij(1,j-ifrst,ifrst+ii),1)
|
|
endif
|
|
else
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
endif
|
|
enddo
|
|
enddo
|
|
call dgemm('n','t',dfnbasis*nb,ncore+nocc,ifrst+nb,1.d0,
|
|
$jpij,dfnbasis*nbl,ppq,ncore+nbasis,0.d0,
|
|
$xlm,dfnbasis*nbl) !!!itt nincs figyelembe veve, hogy X^P_lf=0
|
|
ckiirt
|
|
c write(6,"('xli_0')")
|
|
c do p=1,3!dfnbasis
|
|
c write(6,"(' ')")
|
|
c do l=1,nb
|
|
c write(6,"(1000f10.5)") (xlm(p,l,i),i=1,ncore+nocc)
|
|
c enddo
|
|
c enddo
|
|
if(ncore.gt.0) then
|
|
call dgemm('n','n',dfnbasis*nb,ncore+nocc,ifrst+nb,1.d0,
|
|
$jpij,dfnbasis*nbl,ppq,ncore+nbasis,1.d0,
|
|
$xlm,dfnbasis*nbl)
|
|
endif
|
|
do m=1,ncore+nocc
|
|
write(scrfile4,rec=(iblock-1)*(ncore+nocc)+m) ((xlm(p,l,m),p=1,
|
|
$dfnbasis),l=1,nb)
|
|
enddo
|
|
call dgemm('n','t',dfnbasis*nb,nvirt,ifrst+nb,1.d0,
|
|
$jpij,dfnbasis*nbl,pal,nvirt,0.d0,
|
|
$xla,dfnbasis*nbl)
|
|
ckiirt
|
|
c write(6,"('xla_0')")
|
|
c do p=1,3!dfnbasis
|
|
c write(6,"(' ')")
|
|
c do l=1,nb
|
|
c write(6,"(1000f10.5)")
|
|
c $(xla(p,l,a),a=1,nvirt)
|
|
c $(xla(p+(l-1)*dfnbasis+(a-1)*dfnbasis*nb),a=1,nvirt)
|
|
c enddo
|
|
c enddo
|
|
do a=1,nvirt
|
|
write(scrfile5,rec=(iblock-1)*nvirt+a)
|
|
$((xla(p,l,a),p=1,dfnbasis),l=1,nb)
|
|
c $((xla(p+(l-1)*dfnbasis+(a-1)*dfnbasis*nb),p=1,dfnbasis),l=1,nb)
|
|
enddo
|
|
do k=1,iblock-1
|
|
kfrst=(k-1)*nbl
|
|
do i=1,ncore+nocc
|
|
read(scrfile4,rec=(k-1)*(ncore+nocc)+i)
|
|
$ ((xlm(p,l,i),p=1,dfnbasis),l=1,nbl)
|
|
enddo
|
|
call dfillzero(scr,dfnbasis*nbl*(ncore+nocc))
|
|
do i=1,nbl
|
|
call dgemm('n','t',dfnbasis,ncore+nocc,nb,1.d0,
|
|
$jpij(1,1,kfrst+i),dfnbasis,
|
|
$ppq(1,ifrst+1),ncore+nbasis,
|
|
$1.d0,scr((i-1)*dfnbasis*(ncore+nocc)+1),dfnbasis)
|
|
enddo
|
|
ii=0
|
|
do j=1,nbl
|
|
do p=1,ncore+nocc
|
|
do pp=1,dfnbasis
|
|
ii=ii+1
|
|
xlm(pp,j,p)=xlm(pp,j,p)+scr(ii)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
if(ncore.gt.0) then
|
|
call dfillzero(scr,dfnbasis*nbl*(ncore+nocc))
|
|
do i=1,nbl
|
|
call dgemm('n','n',dfnbasis,ncore+nocc,nb,1.d0,
|
|
$jpij(1,1,kfrst+i),dfnbasis,
|
|
$ppq(ifrst+1,1),ncore+nbasis,
|
|
$1.d0,scr((i-1)*dfnbasis*(ncore+nocc)+1),dfnbasis) ! itt nem vettem figyelembe, hogy ppq_fi=0
|
|
enddo
|
|
ii=0
|
|
do j=1,nbl
|
|
do p=1,ncore+nocc
|
|
do pp=1,dfnbasis
|
|
ii=ii+1
|
|
xlm(pp,j,p)=xlm(pp,j,p)+scr(ii)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
do m=1,ncore+nocc
|
|
write(scrfile4,rec=(k-1)*(ncore+nocc)+m)
|
|
$((xlm(p,l,m),p=1,dfnbasis),l=1,nbl)
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('xli_kieg')")
|
|
c do p=1,3
|
|
c write(6,"(' ')")
|
|
c do l=1,nbl
|
|
c write(6,"(1000f10.5)") (xlm(p,l,i),i=1,ncore+nocc)
|
|
c enddo
|
|
c enddo
|
|
do a=1,nvirt
|
|
read(scrfile5,rec=(k-1)*nvirt+a)
|
|
$((xla(p,l,a),p=1,dfnbasis),l=1,nbl)
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('xla_0_read')")
|
|
c do p=1,3
|
|
c write(6,"(' ')")
|
|
c do l=1,nbl
|
|
c write(6,"(1000f10.5)") (xla(),i=1,nocc)
|
|
c enddo
|
|
c enddo
|
|
|
|
call dfillzero(scr,dfnbasis*nbl*nvirt)
|
|
do i=1,nbl
|
|
call dgemm('n','t',dfnbasis,nvirt,nb,1.d0,
|
|
$jpij(1,1,kfrst+i),dfnbasis,
|
|
$pal(1,ifrst+1),nvirt,
|
|
$1.d0,scr((i-1)*dfnbasis*nvirt+1),dfnbasis)
|
|
enddo
|
|
ii=0
|
|
do l=1,nbl
|
|
do a=1,nvirt
|
|
do p=1,dfnbasis
|
|
ii=ii+1
|
|
xla(p,l,a)=xla(p,l,a)+scr(ii)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('xla_kieg')")
|
|
c do p=1,3
|
|
c write(6,"(' ')")
|
|
c do l=1,nbl
|
|
c write(6,"(1000f10.5)")
|
|
c $(xla(p+(l-1)*dfnbasis+(a-1)*dfnbasis*nb),a=1,nvirt)
|
|
c $(xla(p,l,a),a=1,nvirt)
|
|
c enddo
|
|
c enddo
|
|
do a=1,nvirt
|
|
write(scrfile5,rec=(k-1)*nvirt+a)
|
|
c $((xla(p+(l-1)*dfnbasis+(a-1)*dfnbasis*nb),p=1,dfnbasis),l=1,nbl)
|
|
$((xla(p,l,a),p=1,dfnbasis),l=1,nbl)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c Assemble the first part of (lq|pm)pi_pq
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
rewind(scrfile2)
|
|
do jblock=1,nblock
|
|
nb2=nbl
|
|
if(jblock.eq.nblock) nb2=nbll
|
|
jfrst=(jblock-1)*nbl
|
|
ijdim=(2*jfrst+nb2+1)*nb2/2
|
|
read(scrfile2) (jij(i),i=1,dfnbasis*ijdim) !dcore(ijai)
|
|
do ii=1,nb2
|
|
i=jfrst+ii
|
|
do j=1,i
|
|
ij=(2*jfrst+ii)*(ii-1)/2+j
|
|
if(j.gt.jfrst) then
|
|
if(j.eq.i) then
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
else
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,
|
|
$jpij(1,j-jfrst,jfrst+ii),1)
|
|
endif
|
|
else
|
|
call dcopy(dfnbasis,jij((ij-1)*dfnbasis+1),1,jpij(1,ii,j),1)
|
|
endif
|
|
enddo
|
|
enddo
|
|
do i=1,ncore+nocc
|
|
read(scrfile4,rec=(iblock-1)*(ncore+nocc)+i)
|
|
$((xlm(p,l,i),p=1,dfnbasis),l=1,nb)
|
|
enddo
|
|
if(ncore.eq.0) then
|
|
do i=1,nb2
|
|
call dgemm('t','n',nb,jfrst+nb2,dfnbasis,2.d0*chfx,
|
|
$xlm(1,1,jfrst+i),dfnbasis,
|
|
$jpij(1,i,1),dfnbasis*nbl,1.d0,
|
|
$ylm(ifrst+1,1),ncore+nocc)
|
|
enddo
|
|
else
|
|
do i=1,nb2
|
|
call dgemm('t','n',nb,jfrst+nb2,dfnbasis,chfx,
|
|
$xlm(1,1,jfrst+i),dfnbasis,
|
|
$jpij(1,i,1),dfnbasis*nbl,1.d0,
|
|
$ylm(ifrst+1,1),ncore+nocc)
|
|
enddo
|
|
endif
|
|
c do l=1,nb
|
|
c do i=1,nb2
|
|
c do m=1,jfrst+nb2
|
|
c do p=1,dfnbasis
|
|
c ylm(ifrst+l,m)=ylm(ifrst+l,m)+n*
|
|
c $xlm(p,l,jfrst+i)*jpij(p,i,m)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
do k=1,jblock-1
|
|
kfrst=(k-1)*nbl
|
|
if(ncore.eq.0) then
|
|
do i=1,nbl
|
|
call dgemm('t','n',nb,nb2,dfnbasis,2.d0*chfx,
|
|
$xlm(1,1,kfrst+i),dfnbasis,
|
|
$jpij(1,1,kfrst+i),dfnbasis,1.d0,
|
|
$ylm(ifrst+1,jfrst+1),ncore+nocc)
|
|
enddo
|
|
else
|
|
do i=1,nbl
|
|
call dgemm('t','n',nb,nb2,dfnbasis,chfx,
|
|
$xlm(1,1,kfrst+i),dfnbasis,
|
|
$jpij(1,1,kfrst+i),dfnbasis,1.d0,
|
|
$ylm(ifrst+1,jfrst+1),ncore+nocc)
|
|
enddo
|
|
endif
|
|
c do i=1,nbl
|
|
c do m=1,nb2
|
|
c do p=1,dfnbasis
|
|
c ylm(ifrst+l,jfrst+m)=ylm(ifrst+l,jfrst+m)+n*
|
|
c $xlm(p,l,kfrst+i)*jpij(p,m,kfrst+i)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
c kiirt
|
|
c write(6,"('Ylm_2')")
|
|
c do l=1,ncore+nocc
|
|
c write(6,"(100000f10.5)") (ylm(l,m),m=1,ncore+nocc)
|
|
c enddo
|
|
C Assemble the second part of (lq|pm)pi_pq
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
do a=1,nvirt
|
|
read(scrfile5,rec=(iblock-1)*nvirt+a)
|
|
$((xla(p,l,a),p=1,dfnbasis),l=1,nb)
|
|
enddo
|
|
ckiirt
|
|
c write(6,"('xla_read')")
|
|
c do p=1,3
|
|
c write(6,"(' ')")
|
|
c do l=1,nb
|
|
c write(6,"(1000f10.5)")
|
|
c $(xla(p,l,a),a=1,nvirt)
|
|
c enddo
|
|
c enddo
|
|
|
|
rewind(scrfile1)
|
|
do jblock=1,nblock
|
|
nb2=nbl
|
|
if(jblock.eq.nblock) nb2=nbll
|
|
jfrst=(jblock-1)*nbl
|
|
read(scrfile1) (jai(i),i=1,nvirt*nb2*dfnbasis)
|
|
c read(scrfile1) (((jai3d(a,i,p),a=1,nvirt),i=1,nb2),p=1,dfnbasis)
|
|
do a=1,nvirt
|
|
c call dgemm('t','t',nb,nb2,dfnbasis,-1d0,
|
|
c $xla(1,1,a),dfnbasis,
|
|
c $jai3d(a,1,1),nvirt*nbl,1.d0,
|
|
c $ylm(ifrst+1,jfrst+1),ncore+nocc)
|
|
do l=1,nb
|
|
do m=1,nb2
|
|
do p=1,dfnbasis
|
|
ylm(ifrst+l,jfrst+m)=ylm(ifrst+l,jfrst+m)+chfx*
|
|
$xla(p,l,a)*jai(a+(m-1)*nvirt+(p-1)*nvirt*nb2)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c kiirt
|
|
c write(6,"('Ylm_3')")
|
|
c do l=1,ncore+nocc
|
|
c write(6,"(100000f10.5)") (ylm(l,m),m=1,ncore+nocc)
|
|
c enddo
|
|
close(scrfile4)
|
|
close(scrfile5)
|
|
c Calculate X^P_la and assemble the third part of (lq|pm)pi_pq
|
|
!!!!Lehetne az elozo X^P_la-hoz hozzaadni is
|
|
open(scrfile5,access='direct',recl=ifltln*nbl*dfnbasis)
|
|
rewind(scrfile1)
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
read(scrfile1) (jai(i),i=1,nvirt*nb*dfnbasis) !dcore(ijai)
|
|
call dgemm('t','t',nb*dfnbasis,nvirt,nvirt,1.d0,
|
|
$jai,nvirt,ppq(ncore+nocc+1,ncore+nocc+1),ncore+nbasis,
|
|
$0.d0,xla2,nb*dfnbasis) !dcore(ixlp)
|
|
c call dgemm('n','n',nvirt,nb*dfnbasis,nvirt,1.d0,
|
|
c $ppq(ncore+nocc+1,ncore+nocc+1),ncore+nbasis,jai,nvirt,
|
|
c $0.d0,xla2,nvirt)
|
|
do a=1,nvirt
|
|
write(scrfile5,rec=(iblock-1)*nvirt+a)
|
|
$((xla2(l+(p-1)*nb+(a-1)*nb*dfnbasis),p=1,dfnbasis),l=1,nb)
|
|
enddo
|
|
c do a=1,nvirt
|
|
c write(scrfile5,rec=(iblock-1)*nvirt+a)
|
|
c $((xla2(a,l,p),l=1,nb),p=1,dfnbasis)
|
|
c enddo
|
|
|
|
ckiirt
|
|
c write(6,"('xla_2')")
|
|
c do p=1,3!dfnbasis
|
|
c write(6,"(' ')")
|
|
c do l=1,nb
|
|
c write(6,"(1000f10.5)")
|
|
c $(xla2(l+(p-1)*nb+(a-1)*dfnbasis*nb),a=1,nvirt)
|
|
c enddo
|
|
c enddo
|
|
enddo
|
|
do iblock=1,nblock
|
|
nb=nbl
|
|
if(iblock.eq.nblock) nb=nbll
|
|
ifrst=(iblock-1)*nbl
|
|
do a=1,nvirt
|
|
read(scrfile5,rec=(iblock-1)*nvirt+a)
|
|
$((xla2(l+(p-1)*nb+(a-1)*nb*dfnbasis),p=1,dfnbasis),l=1,nb)
|
|
c $((xla2(a,l,p),l=1,nb),p=1,dfnbasis)
|
|
enddo
|
|
rewind(scrfile1)
|
|
do jblock=1,nblock
|
|
nb2=nbl
|
|
if(jblock.eq.nblock) nb2=nbll
|
|
jfrst=(jblock-1)*nbl
|
|
c read(scrfile1) (((jai3d(a,i,p),a=1,nvirt),i=1,nb2),p=1,dfnbasis)
|
|
c do a=1,nvirt
|
|
c call dgemm('n','t',nb,nb2,dfnbasis,-1d0,
|
|
c $xla2((a-1)*nb*dfnbasis),nbl,
|
|
c $jai3d(a,1,1),nvirt*nbl,1.d0,
|
|
c $ylm(ifrst+1,jfrst+1),ncore+nocc)
|
|
c enddo
|
|
read(scrfile1) (jai(i),i=1,nvirt*nb2*dfnbasis)
|
|
do l=1,nb
|
|
do m=1,nb2
|
|
do a=1,nvirt
|
|
do p=1,dfnbasis
|
|
ylm(ifrst+l,jfrst+m)=ylm(ifrst+l,jfrst+m)+2.d0*chfx*
|
|
$xla2(l+(p-1)*nb+(a-1)*nb*dfnbasis)*
|
|
$jai(a+(m-1)*nvirt+(p-1)*nvirt*nb2)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
c kiirt
|
|
c write(6,"('Ylm_4')")
|
|
c do l=1,ncore+nocc
|
|
c write(6,"(100000f10.5)") (ylm(l,m),m=1,ncore+nocc)
|
|
c enddo
|
|
return
|
|
end
|
|
************************************************************************
|
|
subroutine scfgrad(r8heap,i4heap,densa,densb,denst,ca,cb,ca2,cb2,
|
|
$xdip,focka,fockb,ea,eb,scftype,calctype,natoms,coord,atchg,sder,
|
|
$hder,tdera,tderb,grads,verbosity,atsymbol,dft,ncent,efield,qmmm,
|
|
$qmreg,rf,s,natrange,distc,moa,mob,dfbasis_scf,dfnmobasis,xveca,
|
|
$xvecb,itol,scfalg,moadd,ctol,ppqa,wpq,popul,mnbasis,mnatrange,
|
|
$lcatoms,symat,pggen,chfx,cmp2,grdens,nmobasis,embed,ldfcisgrad,
|
|
$ciscont,ldftdhfgrad,lgradd,ihmat2,pcm)
|
|
************************************************************************
|
|
* Driver for SCF property and gradient calculations
|
|
************************************************************************
|
|
use domain, only: domain_type
|
|
#include "MRCCCOMMON"
|
|
integer natoms,datoms,xyz,i,j,a,iatoms,verbosity,dero
|
|
integer natrange(2,natoms),ncent,scft,imem1,dfnmobasis(*),hailen
|
|
integer moadd(*),oroute,mnbasis,mnatrange(2,natoms),nmobasis(*)
|
|
integer lcatoms(natoms),symat(natoms,nir),ind(natoms),ciscont
|
|
real*8 dipx,dipy,dipz,sum,sum2,chfx,exc
|
|
real*8 r8heap(*),cmp2,clrhfx,csrhfx,omega,itol
|
|
real*8 denst(nbasis,nbasis),xdip(nbasis,nbasis),ea(nal),eb(nbe)
|
|
real*8 densa(nbasis,nbasis,ciscont),densb(nbasis,nbasis)
|
|
real*8 focka(nbasis,nbasis),fockb(nbasis,nbasis),s(nbasis,nbasis)
|
|
real*8 ca(nbasis,nbasis,ciscont),cb(nbasis,nbasis),efield(3,ncent)
|
|
real*8 ca2(nbasis,nocc),cb2(nbasis,nocc),ihmat2(nbasis,nbasis)
|
|
real*8 sder(nbasis,nbasis,3),hder(nbasis,nbasis,3),coord(3,ncent)
|
|
real*8 tdera(nbasis,nbasis,3),tderb(nbasis,nbasis,3),vnn,rab3
|
|
real*8 sum3,grads(3,natoms,8),tegrad(3),ddot,rf(nbasis,nbasis)
|
|
real*8 distc(natoms,natoms),moa(nal,nbasis),mob(nbe,nbasis),ctol
|
|
real*8 xveca(dfnbasis,0:3),xvecb(dfnbasis,0:3),ppqa(nbasis,nbasis)
|
|
real*8 wpq(nbasis,nbasis),pggen(3,3,nir),rscr(3),atchg(ncent)
|
|
integer*4 i4heap(*)
|
|
character*2 atsymbol(natoms)
|
|
character*5 scftype
|
|
character*8 scfalg,oniom!HB
|
|
character*8 qmmm,qmreg,dfalg,popul,grdens,embed
|
|
character*15 cscr15
|
|
character*16 calctype,cscr16
|
|
character*20 dfbasis_scf
|
|
character*32 dft,pcm
|
|
character*256 edisp,edisp_embed !HB
|
|
real*8 finalener,selfener
|
|
logical ldf,l3der,ldfcisgrad,ldftdhfgrad,lgradd
|
|
! ldfgrad
|
|
integer iatmo,inmoat,imoat,inatmo,iatdom,idfnmobasis,iuboys
|
|
integer imoadd,inmobasis,inatdom,iaoat,iatind,scftolint
|
|
integer locfit,inaoat,ialpha,idens2,idfatdom
|
|
integer iwork,iworkb,iya,iyb,ippqa,ippqb,imoa,imob
|
|
type(domain_type) dom
|
|
double precision scftol,excrad,dgetkey,lf_chfx
|
|
character*6 scftolval
|
|
integer dblalloc
|
|
logical lwdfn
|
|
! end ldfgrad
|
|
common/memcom/ imem1
|
|
|
|
interface
|
|
subroutine fock_der(nbasis,dfnbasis,nocc,densa,densb,dens2,
|
|
& xveca,scftype,dero,ca,ldf,dom,ctol,chfx,clrhfx,csrhfx,omega,
|
|
& itol,natoms,ncent,efield,grads,sder)
|
|
use domain, only: domain_type
|
|
implicit none
|
|
integer nbasis,dfnbasis,nocc,dero,ncent,natoms,locfit
|
|
double precision densa(nbasis,nbasis),densb(nbasis,nbasis)
|
|
double precision dens2(nbasis,nbasis),xveca(dfnbasis,4)
|
|
double precision, target :: ca(nbasis,nocc)
|
|
double precision, target :: sder(nbasis,nbasis,3)
|
|
double precision efield(3,ncent),grads(3,natoms,8)
|
|
double precision ctol,chfx,csrhfx,clrhfx,itol,omega
|
|
character*5 scftype
|
|
logical ldf
|
|
type(domain_type) dom
|
|
end subroutine
|
|
end interface
|
|
C
|
|
call getvar('coord ',coord)
|
|
call getvar('clrhfx ',clrhfx)
|
|
call getvar('csrhfx ',csrhfx)
|
|
call getvar('omega ',omega)
|
|
call getkey('oniom',5,oniom,8) !HB
|
|
if(qmmm.eq.'amber') then
|
|
call getenergy(finalener,cscr15)
|
|
call getvar('selfenergy',selfener)
|
|
endif
|
|
call getkey('scfalg',6,scfalg,8)
|
|
if(scfalg.eq.'locfit1 ') then
|
|
locfit=1
|
|
elseif(scfalg.eq.'locfit2 ') then
|
|
locfit=2
|
|
else
|
|
locfit=0
|
|
endif
|
|
call alloc_domains_prop(dom,natoms,nocc,dfnmobasis,nmobasis,
|
|
& moadd,locfit.gt.0,icore,imem)
|
|
ldf=dfbasis_scf.ne.'none '
|
|
if(scftype.eq.'rhf ') then
|
|
scft=1
|
|
else if(scftype.eq.'uhf ') then
|
|
scft=2
|
|
else
|
|
scft=3
|
|
endif
|
|
call props(nbasis,r8heap,i4heap,sder,hder,denst,rf,scftype,
|
|
& densa,densb,ca,cb,ciscont,dft,embed,dfbasis_scf,nal,nbe,moa,
|
|
& mob,focka,fockb,ea,eb,s,popul,mnbasis,nocc,natoms,atsymbol,
|
|
& atchg,ncent,natrange,mnatrange,distc,verbosity,coord,nfroz,
|
|
& xdip,dipx,dipy,dipz,qmreg,calctype,lgradd,grdens,ihmat2,
|
|
& ppqa)
|
|
if(dens.eq.1) return
|
|
C Calculate energy-weighted density matrix
|
|
if(lgradd) then
|
|
write(iout,*)
|
|
if(ldfcisgrad) then
|
|
write(iout,*) 'Calculation of CIS first-order properties...'
|
|
else
|
|
write(iout,*) 'Calculation of TDHF first-order properties...'
|
|
endif
|
|
open(scrfile1,file='CISGRAD',form='unformatted')
|
|
read(scrfile1)
|
|
read(scrfile1) ppqa ! total (HF+CIS+Z) density
|
|
close(scrfile1)
|
|
call calcmom(r8heap,i4heap,ppqa,xdip,nbasis,oeintfile,
|
|
$angtobohr,iout,1.d0,echesu*angtobohr,ecc,dipx,dipy,dipz)
|
|
call dcopy(nbasis**2,ca,1,xdip,1)
|
|
do a=nfroz+1,nal
|
|
call dscal(nbasis,ea(a),xdip(1,a),1)
|
|
enddo
|
|
call dgemm('n','t',nbasis,nbasis,nal-nfroz,1.d0,
|
|
$xdip(1,nfroz+1),nbasis,ca(1,nfroz+1,1),nbasis,1.d0,rf,nbasis)
|
|
else
|
|
if(trim(embed).eq.'sch') then
|
|
call getvar('nfroz ',nfroz)
|
|
open(scrfile1,file='HUZPROJ',form='unformatted')
|
|
call roeint(r8heap,i4heap,focka,scrfile1,nbasis)
|
|
call roeint(r8heap,i4heap,fockb,scrfile1,nbasis)
|
|
close(scrfile1)
|
|
call schewd(rf,focka,fockb,nbasis,nfroz,nal,ca,r8heap,
|
|
$r8heap(nal**2+1),ea)
|
|
else if(scftype.eq.'uhf ') then
|
|
call dcopy(nbasis**2,ca,1,xdip,1)
|
|
do a=nfroz+1,nal
|
|
call dscal(nbasis,ea(a),xdip(1,a),1)
|
|
enddo
|
|
call dgemm('n','t',nbasis,nbasis,nal-nfroz,0.5d0,
|
|
$xdip(1,nfroz+1),nbasis,ca(1,nfroz+1,1),nbasis,1.d0,rf,nbasis)
|
|
call dcopy(nbasis**2,cb,1,xdip,1)
|
|
do a=nfroz+1,nbe
|
|
call dscal(nbasis,eb(a),xdip(1,a),1)
|
|
enddo
|
|
call dgemm('n','t',nbasis,nbasis,nbe-nfroz,0.5d0,
|
|
$xdip(1,nfroz+1),nbasis,cb(1,nfroz+1),nbasis,1.d0,rf,nbasis)
|
|
elseif(locfit.eq.0) then
|
|
call dcopy(nbasis**2,ca,1,xdip,1)
|
|
do a=nfroz+1,nal
|
|
call dscal(nbasis,ea(a),xdip(1,a),1)
|
|
enddo
|
|
call dgemm('n','t',nbasis,nbasis,nal-nfroz,1.d0,
|
|
$xdip(1,nfroz+1),nbasis,ca(1,nfroz+1,1),nbasis,1.d0,rf,nbasis)
|
|
if(calctype.ne.'scf '.and..not.lgradd)
|
|
$call daxpy(nbasis**2,cmp2,wpq,1,rf,1)
|
|
endif
|
|
endif
|
|
if(ldf) then
|
|
do i=1,nocc
|
|
nmobasis(i)=nbasis
|
|
dfnmobasis(i)=dfnbasis
|
|
enddo
|
|
endif
|
|
C Calculate electric field
|
|
if(ncent.gt.natoms) then
|
|
write(iout,*)
|
|
write(iout,*)
|
|
write(iout,*)
|
|
$'Calculation of electric field at atomic centers...'
|
|
if(calctype.ne.'scf '.and..not.lgradd) then
|
|
call direct_fock_build(ppqa,densb,tdera,tderb,tderb,100,
|
|
$scftype,2,1,datoms,sder,hder,ca,.false.,dcore,dcore,dcore,tegrad,
|
|
$hailen,i,i,moadd,dfnmobasis,1.d0,.false.,xveca,0,chfx,
|
|
$iout,varsfile,icore,dcore,nbset,oeintfile,nocc,scrfile3,scrfile4,
|
|
$maxcor,imem,tedatfile,dfnbasis,nbasis,1,efield,minpfile,
|
|
$.false.,1,dcore,irecln,1,.false.,0,0,0,1.d0,ppqa,1,dcore,0,0,
|
|
$nmobasis,i,i,i,i,i,i,i,clrhfx,csrhfx,omega,.false.,grads,
|
|
$dcore,dcore,i,.false.,.false.,dcore,.false.,.false.,0,i,.false.,
|
|
$dcore,dcore,.false.,.false.,nocc)
|
|
else
|
|
call direct_fock_build(denst,densb,tdera,tderb,tderb,100,
|
|
$scftype,2,1,datoms,sder,hder,ca,.false.,dcore,dcore,dcore,tegrad,
|
|
$hailen,i,i,moadd,dfnmobasis,1.d0,.false.,xveca,0,chfx,
|
|
$iout,varsfile,icore,dcore,nbset,oeintfile,nocc,scrfile3,scrfile4,
|
|
$maxcor,imem,tedatfile,dfnbasis,nbasis,1,efield,minpfile,
|
|
$.false.,1,dcore,irecln,1,.false.,0,0,0,1.d0,denst,1,dcore,0,0,
|
|
$nmobasis,i,i,i,i,i,i,i,clrhfx,csrhfx,omega,.false.,grads,
|
|
$dcore,dcore,i,.false.,.false.,dcore,.false.,.false.,0,i,.false.,
|
|
$dcore,dcore,.false.,.false.,nocc)
|
|
endif
|
|
call timer
|
|
endif
|
|
C Cartesian gradient
|
|
write(iout,*)
|
|
write(iout,*)
|
|
write(iout,*) 'Calculation of SCF Cartesian gradients...'
|
|
write(iout,*)
|
|
if(locfit.gt.0) then
|
|
iuboys=dblalloc(2*nocc*nocc)
|
|
call locmo(ca,cb,dcore(iuboys),nbasis,nal,nbe,natoms,itol,
|
|
& scftype,iout,mocoeffile,scrfile3,scrfile6,dcore,imem)
|
|
call dbldealloc(iuboys)
|
|
CALL GETKEY('scftol',6,SCFTOLVAL,4)
|
|
READ (SCFTOLVAL, '(I4)') SCFTOLINT
|
|
scftol=10.0d0**dble(-scftolint)
|
|
lwdfn=.false.
|
|
ialpha=0
|
|
write(iout,*)
|
|
idens2=dblalloc(nbasis**2)
|
|
call ew_dens(nal,nbe,nbasis,dcore(idens2),ca,cb,ca2,cb2,rf,
|
|
& dcore,scrfile1,scftype)
|
|
if(scftype.eq.'rhf ') then
|
|
call motransp(nal,nbasis,moa,ca,.false.)
|
|
call dscal(nbasis*nal,dsqrt(2.d0),moa,1)
|
|
call dsyrk('u','n',nbasis,nal,2.0d0,ca,nbasis,0.d0,densa,
|
|
& nbasis)
|
|
call filllo(densa,nbasis)
|
|
elseif(scftype.eq.'uhf ') then
|
|
call motransp(nal,nbasis,moa,ca,.false.)
|
|
call motransp(nbe,nbasis,mob,cb,.false.)
|
|
call dsyrk('u','n',nbasis,nal,1.0d0,ca,nbasis,0.d0,densa,
|
|
& nbasis)
|
|
call filllo(densa,nbasis)
|
|
call dsyrk('u','n',nbasis,nbe,1.0d0,cb,nbasis,0.d0,densb,
|
|
& nbasis)
|
|
call filllo(densb,nbasis)
|
|
call dcopy(nbasis**2,densa,1,denst,1)
|
|
call daxpy(nbasis**2,1.0d0,densa,1,denst,1)
|
|
endif
|
|
else
|
|
idens2=imem
|
|
iatmo=imem
|
|
inmoat=imem
|
|
imoat=imem
|
|
inatmo=imem
|
|
iatdom=imem
|
|
idfnmobasis=imem
|
|
imoadd=imem
|
|
inmobasis=imem
|
|
inatdom=imem
|
|
iaoat=imem
|
|
inaoat=imem
|
|
iatind=imem
|
|
endif
|
|
C D3 gradient contribution
|
|
call getkey('edisp',5,edisp,256)
|
|
call getkey('edisp_embed',11,edisp_embed,256)
|
|
if(embed.eq.'off') then !HB
|
|
if(trim(edisp).ne.'off') then
|
|
open(scrfile1,file='dftd3_gradient')
|
|
rewind(scrfile1)
|
|
do datoms=1,natoms
|
|
read(scrfile1,*)
|
|
$ grads(1,datoms,6),grads(2,datoms,6),grads(3,datoms,6)
|
|
enddo
|
|
close(scrfile1)
|
|
c else
|
|
c call dfillzero(grads(1,1,6),3*natoms)
|
|
endif
|
|
else !HB
|
|
! D3 gradient correction of the full system (low-level method)
|
|
if(trim(edisp_embed).ne.'off') then
|
|
open(scrfile1,file='dftd3_grad_ab')
|
|
rewind(scrfile1)
|
|
do datoms=1,natoms
|
|
read(scrfile1,*)
|
|
$ grads(1,datoms,6),grads(2,datoms,6),grads(3,datoms,6)
|
|
enddo
|
|
close(scrfile1)
|
|
! D3 gradient correction of the active subsystem (low-level method)
|
|
open(minpfile,file='MINP')
|
|
call embedat(natoms,minpfile,ind,iout,'embed ',5)
|
|
close(minpfile)
|
|
open(scrfile1,file='dftd3_grad_a2')
|
|
rewind(scrfile1)
|
|
rscr=0.0d0
|
|
do datoms=1,natoms
|
|
if(ind(datoms).eq.1) then
|
|
read(scrfile1,*) rscr(1),rscr(2),rscr(3)
|
|
grads(1,datoms,6)=grads(1,datoms,6)-rscr(1)
|
|
grads(2,datoms,6)=grads(2,datoms,6)-rscr(2)
|
|
grads(3,datoms,6)=grads(3,datoms,6)-rscr(3)
|
|
endif
|
|
enddo
|
|
close(scrfile1)
|
|
endif
|
|
! D3 gradient correction of the active subsystem (high-level method)
|
|
if(trim(edisp).ne.'off') then
|
|
if(trim(edisp_embed).eq.'off') then
|
|
open(minpfile,file='MINP')
|
|
call embedat(natoms,minpfile,ind,iout,'embed ',5)
|
|
close(minpfile)
|
|
endif
|
|
open(scrfile1,file='dftd3_grad_a1')
|
|
rewind(scrfile1)
|
|
rscr=0.0d0
|
|
do datoms=1,natoms
|
|
if(ind(datoms).eq.1) then
|
|
read(scrfile1,*) rscr(1),rscr(2),rscr(3)
|
|
grads(1,datoms,6)=grads(1,datoms,6)+rscr(1)
|
|
grads(2,datoms,6)=grads(2,datoms,6)+rscr(2)
|
|
grads(3,datoms,6)=grads(3,datoms,6)+rscr(3)
|
|
endif
|
|
enddo
|
|
close(scrfile1)
|
|
endif
|
|
endif !HB
|
|
C Read PCM contribution to Cartesian gradient
|
|
#if defined (PCM)
|
|
if(trim(pcm).ne.'off') then
|
|
open (scrfile6,file='GRAD',status='old',form='unformatted')
|
|
read (scrfile6) ((grads(i,iatoms,7),i=1,3),iatoms=1,ncent)
|
|
close(scrfile6)
|
|
endif
|
|
#endif
|
|
C XC contribution
|
|
c call dfillzero(grads(1,1,5),3*natoms)
|
|
if(trim(dft).ne.'off') then
|
|
call dft_core(nbasis,nal,nbe,focka,fockb,moa,mob,
|
|
$scrfile5,dcore,iout,exc,dft,minpfile,scft,ifltln,maxcor,imem,
|
|
$imem1,icore,verbosity,1,grads(1,1,5),' ',densa,densb,1,1,0.d0,
|
|
$0)
|
|
if(locfit.ne.0) then
|
|
iwork=dblalloc(nbasis**2)
|
|
iya=dblalloc(nal*(nbasis-nal))
|
|
imoa=dblalloc(nal*nbasis)
|
|
ippqa=dblalloc(nbasis**2)
|
|
if(scftype=='uhf ') then
|
|
iyb=dblalloc(nbe*(nbasis-nbe))
|
|
iworkb=dblalloc(nbasis**2)
|
|
imob=dblalloc(nbe*nbasis)
|
|
ippqb=dblalloc(nbasis**2)
|
|
else
|
|
iyb=iya
|
|
iworkb=iwork
|
|
imob=imoa
|
|
ippqb=ippqa
|
|
endif
|
|
c call dft_dens(nal,nbe,nbasis,dcore(ippqa),dcore(ippqb),
|
|
c & scftype,scrfile5)
|
|
c call dscal(nbasis**2,0.125d0,dcore(ippqa),1)
|
|
open(unit=scrfile1,file='LAGRANGE',form='unformatted')
|
|
read(scrfile1) !zloc
|
|
read(scrfile1) dcore(imem:imem+nal*(nbasis-nal)-1)
|
|
call build_dens_dvxc(nal,nbasis-nal,nbasis,ca,dcore(imem),
|
|
& dcore(iwork),dcore(ippqa))
|
|
if(scftype=='uhf ') then
|
|
read(scrfile1) !xmat
|
|
read(scrfile1) !mo
|
|
read(scrfile1) !zloc beta
|
|
read(scrfile1) dcore(imem:imem+nbe*(nbasis-nbe)-1)
|
|
call build_dens_dvxc(nbe,nbasis-nbe,nbasis,cb,dcore(imem),
|
|
& dcore(iworkb),dcore(ippqa))
|
|
else
|
|
call dscal(nbasis**2,0.5d0,dcore(iwork),1)
|
|
endif
|
|
close(scrfile1)
|
|
call dvxc(nbasis,nal,nbe,focka,fockb,dcore(imoa),dcore(imob),
|
|
& scrfile5,dcore,iout,exc,dft,minpfile,scft,ifltln,maxcor,
|
|
& imem,icore,verbosity,2,grads(1,1,5),'grad',dcore(iwork),
|
|
& dcore(iworkb),ca,cb,dcore(ippqa),dcore(ippqb),
|
|
& dcore(iya),dcore(iyb),200,0,1,1,1)
|
|
call dbldealloc(iwork)
|
|
endif
|
|
endif
|
|
if(trim(embed).eq.'sch') then
|
|
call motransp(nal-nfroz,nbasis,moa,ca(1,nfroz+1,1),.false.)
|
|
call dscal(nbasis*(nal-nfroz),dsqrt(2.d0),moa,1)
|
|
call dft_core(nbasis,nal-nfroz,nbe-nfroz,focka,fockb,moa,mob,
|
|
$scrfile5,dcore,iout,exc,dft,minpfile,scft,ifltln,maxcor,imem,
|
|
$imem1,icore,verbosity,1,grads(1,1,5),'scl1',densa,densb,1,1,0.d0,
|
|
$0)
|
|
endif
|
|
C Calculate perturbation-independent intermediates in the case of DF-SCF
|
|
c write(6,*) 'szemet!!! szemet!!! szemet!!! szemet!!! szemet!!!'
|
|
c chfx=0.d0
|
|
l3der=ldf.and.(trim(calctype).eq.'scf'.or.
|
|
$ trim(calctype).eq.'mp2'.or.lgradd)
|
|
if(ldf.and.trim(calctype).ne.'mp2') then
|
|
if(l3der) then
|
|
dero=1
|
|
else
|
|
dero=0
|
|
write(iout,*) 'Calculation of perturbation-independent '
|
|
$// 'intermediates...'
|
|
endif
|
|
open(scrfile4,file='APQ',form='UNFORMATTED')
|
|
close(scrfile4,status='delete')
|
|
call getkey('dfalg',5,dfalg,8)
|
|
if((dfalg.eq.'invsqrt '.or.trim(scfalg).eq.'disk').and.
|
|
$.not.lgradd) then
|
|
open(scrfile4,file='DFINV',form='UNFORMATTED')
|
|
call rspmx(dcore(imem),dfnbasis,scrfile4)
|
|
call fillup(dcore(imem),dfnbasis)
|
|
c call roeint(dcore(imem+dfnbasis**2),dcore(imem+dfnbasis**2),
|
|
c $dcore(imem),scrfile4,dfnbasis)
|
|
call dsyrk('u','n',dfnbasis,dfnbasis,1.d0,dcore(imem),
|
|
$dfnbasis,0.d0,dcore(imem+2*dfnbasis**2),dfnbasis)
|
|
rewind(scrfile4)
|
|
write(scrfile4) ((dcore(imem+2*dfnbasis**2-1+
|
|
$dfnbasis*(i-1)+j),i=j,dfnbasis),j=1,dfnbasis)
|
|
c call woeint(dcore(imem),dcore(imem),dcore(imem+2*dfnbasis**2),
|
|
c $scrfile4,itol,dfnbasis)
|
|
close(scrfile4)
|
|
endif
|
|
call dfillzero(xveca,4*dfnbasis)
|
|
if(scftype.eq.'uhf ') then
|
|
if(calctype.ne.'scf ') then
|
|
call dfillzero(xvecb,dfnbasis)
|
|
else
|
|
call dcopy(nbasis**2,denst,1,densa,1)
|
|
chfx=0.5d0*chfx
|
|
endif
|
|
if(dabs(chfx).gt.ctol.or.calctype.ne.'scf ')
|
|
$ write(iout,*) 'Calculating alpha contribution...'
|
|
endif
|
|
if(calctype.ne.'scf '.and..not.lgradd) then
|
|
oroute=6
|
|
else
|
|
oroute=2
|
|
endif
|
|
if(locfit.gt.0) then
|
|
excrad=dgetkey('excrad_fin',10,16)
|
|
dom%excrad=excrad
|
|
ialpha=0
|
|
if(scftype=='rhf ') call dscal(nbasis*nocc,dsqrt(2.0d0),ca,1)
|
|
call build_domains_type(dcore,icore,imem,scrfile3,nbasis,nal,
|
|
& dom,ca,natoms,iimem,natrange,iout,dfnbasis,scrfile4,
|
|
& scftype,lwdfn,ialpha,locfit,scftol)
|
|
if(scftype=='rhf ') call dscal(nbasis*nocc,
|
|
& 1.0d0/dsqrt(2.0d0),ca,1)
|
|
endif
|
|
call direct_fock_build(densa,densb,tdera,tderb,dcore(idens2),!!!
|
|
$100,scftype,2,dero,1,sder,hder,ca,ldf,dcore,dcore,dcore,tegrad,
|
|
$hailen,dom%nmoat,dom%moat,dom%moadd,dom%dfnmobasis,ctol,.false.,
|
|
$xveca,0,chfx,
|
|
$iout,varsfile,icore,dcore,nbset,oeintfile,nal,scrfile3,scrfile4,
|
|
$maxcor,imem,tedatfile,dfnbasis,nbasis,oroute,efield,minpfile,
|
|
$.false.,1,dcore,irecln,1,.false.,0,0,0,1.d0,densa,1,rf,0,locfit,
|
|
$dom%nmobasis,dom%natdom,dom%atdom,dom%naoat,dom%aoat,
|
|
$dom%atind,i,i,clrhfx,csrhfx,omega,l3der,grads,
|
|
$dcore,dcore,i,.false.,.false.,dcore,.false.,.false.,0,i,.false.,
|
|
$dcore,dcore,.false.,.false.,nal)
|
|
if(locfit.eq.1) then
|
|
lf_chfx=chfx
|
|
if(scftype=='uhf ') lf_chfx=2.0d0*chfx
|
|
excrad=dgetkey('excrad',6,16)
|
|
dom%excrad=excrad
|
|
call dscal(nbasis*nocc,dsqrt(2.0d0),ca,1)
|
|
call build_domains_type(dcore,icore,imem,scrfile3,nbasis,nocc,
|
|
& dom,ca,natoms,iimem,natrange,iout,dfnbasis,scrfile4,
|
|
& scftype,lwdfn,ialpha,locfit,scftol)
|
|
call dscal(nbasis*nocc,1.0d0/dsqrt(2.0d0),ca,1)
|
|
call dfillzero(xveca,4*dfnbasis)
|
|
call direct_fock_build(densa,densb,tdera,tderb,dcore(idens2),
|
|
$100,scftype,2,dero,1,sder,hder,ca,ldf,dcore,dcore,dcore,tegrad,
|
|
$hailen,dom%nmoat,dom%moat,dom%moadd,dom%dfnmobasis,ctol,.false.,
|
|
$xveca,0,lf_chfx,
|
|
$iout,varsfile,icore,dcore,nbset,oeintfile,nal,scrfile3,scrfile4,
|
|
$maxcor,imem,tedatfile,dfnbasis,nbasis,oroute,efield,minpfile,
|
|
$.false.,1,dcore,irecln,1,.false.,0,0,0,1.d0,densa,1,ca2,0,locfit,
|
|
$dom%nmobasis,dom%natdom,dom%atdom,dom%naoat,dom%aoat,
|
|
$dom%atind,i,i,clrhfx,csrhfx,omega,l3der,grads,
|
|
$dcore,dcore,i,.false.,.false.,dcore,.false.,.false.,0,i,.true.,
|
|
$dcore,dcore,.false.,.false.,nal)
|
|
endif
|
|
if(lgradd) then
|
|
open(scrfile1,file='CISGRAD2',form='unformatted')
|
|
grads(1:3,1:natoms,3)=0.d0
|
|
write(scrfile1) grads
|
|
write(scrfile1) efield
|
|
close(scrfile1)
|
|
open(scrfile1,file='CISGRAD',form='unformatted')
|
|
read(scrfile1) rf ! E-weighted density
|
|
c read(scrfile1) dcore(imem:imem+nbasis**2-1) ! E-weighted density
|
|
c call daxpy(nbasis**2,-1.d0,rf,1,dcore(imem),1) !-HF
|
|
c call dcopy(nbasis**2,dcore(imem),1,rf,1)
|
|
read(scrfile1) dcore(imem:imem+nbasis**2-1) ! total density
|
|
call daxpy(nbasis**2,-1.d0,densa,1,dcore(imem),1) !-HF
|
|
call dcopy(nbasis**2,dcore(imem),1,ppqa,1)
|
|
read(scrfile1) densa(1:nbasis,1:nbasis,2)
|
|
read(scrfile1) densa(1:nbasis,1:nbasis,3)
|
|
read(scrfile1) ca(1:nbasis,1:nocc,2)
|
|
read(scrfile1) ca(1:nbasis,1:nocc,3)
|
|
read(scrfile1) i
|
|
if(ldftdhfgrad) then
|
|
read(scrfile1) ca(1:nbasis,1:nocc,4)
|
|
endif
|
|
close(scrfile1,status='delete')
|
|
if(i.eq.1) densa(1:nbasis,1:nbasis,2)=0.d0 ! triplet excitation
|
|
do i=1,nbasis
|
|
do j=1,i-1
|
|
densa(i,j,2)=(densa(i,j,2)+densa(j,i,2))/2.d0
|
|
densa(i,j,3)=(densa(i,j,3)+densa(j,i,3))/2.d0
|
|
rf(i,j)=(rf(i,j)+rf(j,i))/2.d0
|
|
enddo
|
|
enddo
|
|
xveca=0.d0
|
|
grads=0.d0
|
|
efield=0.d0
|
|
do i=1,nocc
|
|
dfnmobasis(i)=nbf(3)
|
|
enddo
|
|
call direct_fock_build(densa,densb,tdera,tderb,tderb,100,
|
|
$scftype,2,dero,1,sder,hder,ca,ldf,dcore,dcore,dcore,tegrad,
|
|
$hailen,i,i,moadd,dfnmobasis,ctol,.false.,xveca,0,chfx,
|
|
$iout,varsfile,icore,dcore,nbset,oeintfile,nal,scrfile3,scrfile4,
|
|
$maxcor,imem,tedatfile,nbf(3),nbasis,oroute,efield,minpfile,
|
|
$.false.,ciscont,dcore,irecln,ciscont,.false.,0,0,0,1.d0,ppqa,
|
|
$ciscont,rf,0,0,nmobasis,i,i,i,i,i,i,i,clrhfx,csrhfx,omega,
|
|
$l3der,grads,dcore,dcore,i,.false.,.false.,dcore,.true.,.false.,0,
|
|
$i,.false.,dcore,dcore,.false.,.false.,nal)
|
|
open(scrfile1,file='CISGRAD2',form='unformatted') ! HF contribution
|
|
read(scrfile1) dcore(imem:imem+3*natoms*7-1)
|
|
call daxpy(3*natoms*7,1.d0,dcore(imem),1,grads,1)
|
|
read(scrfile1) dcore(imem:imem+3*ncent-1)
|
|
call daxpy(3*ncent,1.d0,dcore(imem),1,efield,1)
|
|
close(scrfile1,status='delete')
|
|
endif
|
|
if(scftype.eq.'uhf '.and.(dabs(chfx).gt.ctol.or.
|
|
$calctype.ne.'scf ').and.nbe.gt.0) then
|
|
write(iout,*) 'Calculating beta contribution...'
|
|
if(calctype.ne.'scf ') then
|
|
call direct_fock_build(densb,densa,tderb,tdera,tderb,100,
|
|
$scftype,2,dero,1,sder,hder,cb,ldf,dcore,dcore,dcore,tegrad,
|
|
$hailen,i,i,moadd,dfnmobasis,ctol,.false.,xvecb,0,chfx,
|
|
$iout,varsfile,icore,dcore,nbset,oeintfile,nbe,scrfile3,scrfile4,
|
|
$maxcor,imem,tedatfile,dfnbasis,nbasis,oroute,efield,minpfile,
|
|
$.true.,1,dcore,irecln,1,.false.,0,0,0,1.d0,densb,1,rf,0,0,
|
|
$nmobasis,i,i,i,i,i,i,i,clrhfx,csrhfx,omega,l3der,grads,
|
|
$dcore,dcore,i,.false.,.false.,dcore,.false.,.false.,0,i,.false.,
|
|
$dcore,dcore,.false.,.false.,nbe)
|
|
else
|
|
if(locfit.gt.0) then
|
|
excrad=dgetkey('excrad_fin',10,16)
|
|
dom%excrad=excrad
|
|
call build_domains_type(dcore,icore,imem,scrfile3,
|
|
& nbasis,nbe,dom,cb,natoms,iimem,natrange,iout,
|
|
& dfnbasis,scrfile4,scftype,lwdfn,2,locfit,scftol)
|
|
endif
|
|
call direct_fock_build(densa,densb,tdera,tderb,tderb,100,
|
|
$scftype,2,dero,1,sder,hder,cb,ldf,dcore,dcore,dcore,tegrad,hailen,
|
|
$dom%nmoat,dom%moat,dom%moadd,dom%dfnmobasis,ctol,.false.,xvecb,2,
|
|
$chfx,iout,varsfile,icore,dcore,nbset,oeintfile,nbe,scrfile3,
|
|
$scrfile4,maxcor,imem,tedatfile,dfnbasis,nbasis,oroute,efield,
|
|
$minpfile,.false.,1,dcore,irecln,1,.false.,0,0,0,1.d0,densa,1,rf,0,
|
|
$locfit,dom%nmobasis,dom%natdom,dom%atdom,dom%naoat,dom%aoat,
|
|
$dom%atind,i,i,clrhfx,csrhfx,omega,l3der,grads,dcore,dcore,i,
|
|
$.false.,.false.,dcore,.false.,.false.,0,i,.false.,dcore,dcore,
|
|
$.false.,.false.,nbe)
|
|
if(locfit.eq.1) then
|
|
lf_chfx=chfx
|
|
if(scftype=='uhf ') lf_chfx=2.0d0*chfx
|
|
excrad=dgetkey('excrad',6,16)
|
|
dom%excrad=excrad
|
|
call build_domains_type(dcore,icore,imem,scrfile3,nbasis,
|
|
& nbe,dom,cb,natoms,iimem,natrange,iout,dfnbasis,
|
|
& scrfile4,scftype,lwdfn,2,locfit,scftol)
|
|
call dfillzero(xvecb,4*dfnbasis)
|
|
call direct_fock_build(densa,densb,tdera,tderb,tderb,100,
|
|
$scftype,2,dero,1,sder,hder,cb,ldf,dcore,dcore,dcore,tegrad,hailen,
|
|
$dom%nmoat,dom%moat,dom%moadd,dom%dfnmobasis,ctol,.false.,xvecb,2,
|
|
$lf_chfx,iout,varsfile,icore,dcore,nbset,oeintfile,nbe,scrfile3,
|
|
$scrfile4,maxcor,imem,tedatfile,dfnbasis,nbasis,oroute,efield,
|
|
$minpfile,.false.,1,dcore,irecln,1,.false.,0,0,0,1.d0,densa,1,cb2,
|
|
$0,locfit,dom%nmobasis,dom%natdom,dom%atdom,dom%naoat,dom%aoat,
|
|
$dom%atind,i,i,clrhfx,csrhfx,omega,l3der,grads,dcore,dcore,i,
|
|
$.false.,.false.,dcore,.false.,.false.,0,i,.true.,dcore,dcore,
|
|
$.false.,.false.,nbe)
|
|
endif
|
|
endif
|
|
else
|
|
close(scrfile3)
|
|
endif
|
|
if(.not.l3der) write(iout,*)
|
|
endif
|
|
C Other contributions
|
|
if(l3der.and.calctype.eq.'mp2 ') then
|
|
call mxsym(rf,nbasis)
|
|
call oe_grad_tedat(nbasis,natoms,grads,nocc,ca,ialpha,2,2,
|
|
& sder,hder,rf,ppqa,ppqa,efield,scftype,1,0,.true.,.false.,
|
|
& .true.,ldf,.true.,.false.,.false.)
|
|
call dscal(nbasis**2,2.0d0,ppqa,1)
|
|
call daxpy(nbasis**2,-1.0d0,densa,1,ppqa,1)
|
|
call fock_der(nbasis,dfnbasis,nocc,densa,densa,ppqa,xveca,
|
|
& scftype,1,ca,ldf,dom,ctol,chfx,clrhfx,csrhfx,omega,itol,
|
|
& natoms,ncent,efield,grads,sder)
|
|
c call print_grad(ncent,natoms,atsymbol,efield,grads,iout,
|
|
c & verbosity,scrfile6,dft,edisp,edisp_embed,pcm)
|
|
endif
|
|
lcatoms=1
|
|
do datoms=1,natoms
|
|
if(lcatoms(datoms).eq.1) then
|
|
lcatoms(datoms)=0
|
|
write(cscr16,'(i16)') datoms
|
|
cscr16=adjustl(cscr16)
|
|
if(.not.l3der) then
|
|
write(iout,*)
|
|
$'Calculation of Cartesian gradient for atom '//trim(cscr16)
|
|
call dfillzero(tdera,3*nbasis**2)
|
|
if(scftype.ne.'rhf ') call dfillzero(tderb,3*nbasis**2)
|
|
if(ldf) then
|
|
call dfillzero(xveca(1,1),3*dfnbasis)
|
|
if(scftype.eq.'uhf ') then
|
|
if(calctype.ne.'scf ')
|
|
$ call dfillzero(xvecb(1,1),3*dfnbasis)
|
|
write(iout,*) 'Calculating alpha contribution...'
|
|
endif
|
|
endif
|
|
if(calctype.ne.'scf ') then
|
|
oroute=5
|
|
else
|
|
oroute=3
|
|
endif
|
|
if(calctype.ne.'scf ') then
|
|
call direct_fock_build(densa,densb,tdera,tderb,tderb,100,
|
|
$scftype,2,1,datoms,sder,hder,ca,ldf,dcore,dcore,dcore,tegrad,
|
|
$hailen,i,i,moadd,dfnmobasis,ctol,.false.,xveca,0,chfx,
|
|
$iout,varsfile,icore,dcore,nbset,oeintfile,nal,scrfile3,scrfile4,
|
|
$maxcor,imem,tedatfile,dfnbasis,nbasis,oroute,efield,minpfile,
|
|
$.false.,1,dcore,irecln,1,.false.,0,0,0,1.d0,ppqa,1,dcore,0,0,
|
|
$nmobasis,i,i,i,i,i,i,i,clrhfx,csrhfx,omega,l3der,grads,
|
|
$dcore,dcore,i,.false.,.false.,dcore,.false.,.false.,0,i,.false.,
|
|
$dcore,dcore,.false.,.false.,nal)
|
|
else
|
|
call direct_fock_build(densa,densb,tdera,tderb,tderb,100,
|
|
$scftype,2,1,datoms,sder,hder,ca,ldf,dcore,dcore,dcore,tegrad,
|
|
$hailen,i,i,moadd,dfnmobasis,ctol,.false.,xveca,0,chfx,
|
|
$iout,varsfile,icore,dcore,nbset,oeintfile,nal,scrfile3,scrfile4,
|
|
$maxcor,imem,tedatfile,dfnbasis,nbasis,oroute,efield,minpfile,
|
|
$.false.,1,dcore,irecln,1,.false.,0,0,0,1.d0,denst,1,dcore,0,0,
|
|
$nmobasis,i,i,i,i,i,i,i,clrhfx,csrhfx,omega,l3der,grads,dcore,
|
|
$dcore,i,.false.,.false.,dcore,.false.,.false.,0,i,.false.,dcore,
|
|
$dcore,.false.,.false.,nal)
|
|
endif
|
|
if(ldf.and.scftype.eq.'uhf '.and.(dabs(chfx).gt.ctol.or.
|
|
$calctype.ne.'scf ').and.nbe.gt.0) then
|
|
write(iout,*) 'Calculating beta contribution...'
|
|
if(calctype.ne.'scf ') then
|
|
call direct_fock_build(densb,densa,tderb,tdera,tderb,
|
|
$100,scftype,2,1,datoms,sder,hder,cb,ldf,dcore,dcore,dcore,tegrad,
|
|
$hailen,i,i,moadd,dfnmobasis,ctol,.false.,xvecb,0,chfx,
|
|
$iout,varsfile,icore,dcore,nbset,oeintfile,nbe,scrfile3,scrfile4,
|
|
$maxcor,imem,tedatfile,dfnbasis,nbasis,oroute,efield,minpfile,
|
|
$.true.,1,dcore,irecln,1,.false.,0,0,0,1.d0,ppqa,1,dcore,0,0,
|
|
$nmobasis,i,i,i,i,i,i,i,clrhfx,csrhfx,omega,l3der,grads,dcore,
|
|
$dcore,i,.false.,.false.,dcore,.false.,.false.,0,i,.false.,dcore,
|
|
$dcore,.false.,.false.,nbe)
|
|
else
|
|
call direct_fock_build(densa,densb,tdera,tderb,tderb,
|
|
$100,scftype,2,1,datoms,sder,hder,cb,ldf,dcore,dcore,dcore,tegrad,
|
|
$hailen,i,i,moadd,dfnmobasis,ctol,.false.,xvecb,2,chfx,
|
|
$iout,varsfile,icore,dcore,nbset,oeintfile,nbe,scrfile3,scrfile4,
|
|
$maxcor,imem,tedatfile,dfnbasis,nbasis,oroute,efield,minpfile,
|
|
$.false.,1,dcore,irecln,1,.false.,0,0,0,1.d0,denst,1,dcore,0,0,
|
|
$nmobasis,i,i,i,i,i,i,i,clrhfx,csrhfx,omega,l3der,grads,dcore,
|
|
$dcore,i,.false.,.false.,dcore,.false.,.false.,0,i,.false.,dcore,
|
|
$dcore,.false.,.false.,nbe)
|
|
endif
|
|
else if(ldf) then
|
|
close(scrfile3)
|
|
endif
|
|
endif
|
|
do xyz=1,3
|
|
if(.not.l3der) then
|
|
if(ldf) then
|
|
do i=1,nbasis
|
|
tdera(i,i,xyz)=0.5d0*tdera(i,i,xyz)
|
|
enddo
|
|
endif
|
|
call mxsym(tdera(1,1,xyz),nbasis)
|
|
if(scftype.ne.'rhf ') then
|
|
if(ldf) then
|
|
do i=1,nbasis
|
|
tderb(i,i,xyz)=0.5d0*tderb(i,i,xyz)
|
|
enddo
|
|
endif
|
|
call mxsym(tderb(1,1,xyz),nbasis)
|
|
endif
|
|
C Core Hamiltonian derivative
|
|
if(calctype.eq.'scf ') then
|
|
sum=ddot(nbasis**2,denst,1,hder(1,1,xyz),1)
|
|
else
|
|
sum=ddot(nbasis**2,ppqa ,1,hder(1,1,xyz),1)
|
|
endif
|
|
C Two-electron integral derivatives
|
|
if(ldf.and.calctype.eq.'scf ') then
|
|
sum2=0.25d0*tegrad(xyz)
|
|
if(.not.l3der)
|
|
$ sum2=sum2+2.d0*ddot(dfnbasis,xveca,1,xveca(1,xyz),1)
|
|
else
|
|
sum2=ddot(nbasis**2,densa,1,tdera(1,1,xyz),1)
|
|
if(calctype.ne.'scf ')
|
|
$sum2=2.d0*ddot(nbasis**2,ppqa,1,tdera(1,1,xyz),1)-sum2
|
|
if(scftype.eq.'uhf ') sum2=
|
|
$ sum2+ddot(nbasis**2,densb,1,tderb(1,1,xyz),1)
|
|
endif
|
|
sum2=0.5d0*sum2
|
|
C Energy-weighted density, Q(nu,mu) (reorthonormalization gradient)
|
|
sum3=-2.d0*ddot(nbasis**2,sder(1,1,xyz),1,rf,1)
|
|
else
|
|
sum=0.d0
|
|
sum2=0.d0
|
|
sum3=0.d0
|
|
endif
|
|
C Vnn
|
|
vnn=0.d0
|
|
do iatoms=1,ncent
|
|
if(iatoms.ne.datoms) then
|
|
rab3=(dsqrt((coord(1,iatoms)-coord(1,datoms))**2+
|
|
$ (coord(2,iatoms)-coord(2,datoms))**2+
|
|
$ (coord(3,iatoms)-coord(3,datoms))**2))**3
|
|
if(dabs(rab3).gt.1d-12) vnn=vnn+atchg(iatoms)*
|
|
$ (coord(xyz,iatoms)-coord(xyz,datoms))/rab3
|
|
endif
|
|
enddo
|
|
vnn=vnn*atchg(datoms)
|
|
grads(xyz,datoms,1)=grads(xyz,datoms,1)+sum
|
|
grads(xyz,datoms,2)=grads(xyz,datoms,2)+sum2
|
|
grads(xyz,datoms,3)=grads(xyz,datoms,3)+sum3
|
|
if(lgradd) grads(xyz,datoms,3)=-0.5d0*grads(xyz,datoms,3)
|
|
grads(xyz,datoms,4)=grads(xyz,datoms,4)+vnn
|
|
grads(xyz,datoms,8)=grads(xyz,datoms,1)+grads(xyz,datoms,2)+
|
|
$ grads(xyz,datoms,3)+grads(xyz,datoms,4)+grads(xyz,datoms,5)+
|
|
$ grads(xyz,datoms,6)+grads(xyz,datoms,7)
|
|
enddo
|
|
C Symmetry equivalent atoms
|
|
do i=1,nir
|
|
iatoms=symat(datoms,i)
|
|
if(lcatoms(iatoms).eq.1) then
|
|
lcatoms(iatoms)=0
|
|
do j=1,8
|
|
call dgemv('n',3,3,1.d0,pggen(1,1,i),3,
|
|
$grads(1,datoms,j),1,0.d0,grads(1,iatoms,j),1)
|
|
enddo
|
|
call dgemv('n',3,3,1.d0,pggen(1,1,i),3,
|
|
$efield(1,datoms),1,0.d0,efield(1,iatoms),1)
|
|
endif
|
|
enddo
|
|
if(.not.l3der) then
|
|
call timer
|
|
write(iout,*)
|
|
endif
|
|
endif
|
|
enddo
|
|
call print_grad(ncent,natoms,atsymbol,efield,grads,iout,
|
|
& verbosity,scrfile6,dft,edisp,edisp_embed,pcm)
|
|
C Save electric fields and gradients for the MM program
|
|
if(qmmm.eq.'charmm ') then
|
|
open(scrfile1,file='efield.dat')
|
|
rewind(scrfile1)
|
|
do datoms=natoms+1,ncent
|
|
write(scrfile1,"(3e23.15)")
|
|
$ efield(1,datoms),efield(2,datoms),efield(3,datoms)
|
|
enddo
|
|
do datoms=1,natoms
|
|
write(scrfile1,"(3e23.15)")
|
|
$ grads(1,datoms,8),grads(2,datoms,8),grads(3,datoms,8)
|
|
enddo
|
|
close(scrfile1)
|
|
else if(qmmm.eq.'amber ') then
|
|
C Saving gradient, electric field and dipole moment for the
|
|
C MM program to mrcc_job.dat
|
|
call write_dat_file_for_amber(finalener,selfener,2,
|
|
$natoms,ncent,grads(1,1,8),efield,dipx,dipy,dipz)
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
C***********************************************************************
|
|
subroutine calcmom(r8heap,i4heap,denst,xdip,nbasis,oeintfile,
|
|
$angtobohr,iout,scal,todeb,ener,dipx,dipy,dipz)
|
|
C***********************************************************************
|
|
C Calculate multipole moments
|
|
C***********************************************************************
|
|
implicit none
|
|
integer nbasis,oeintfile,iout,i,j,k,ii
|
|
real*8 nucdip(3),nucsec(3,3),dipx,dipy,dipz,angtobohr,scal,todeb
|
|
real*8 dipxx,dipxy,dipxz,dipyy,dipyz,dipzz,qmtx(3,3),r8heap(*),nuc
|
|
real*8 denst(nbasis,nbasis),xdip(nbasis,nbasis),ddot,dipyzz,dipzzz
|
|
real*8 dipxxx,dipxxy,dipxxz,dipxyy,dipxyz,dipxzz,dipyyy,dipyyz
|
|
real*8 nucthi(3,3,3),oct(10),ener
|
|
integer*4 i4heap(*)
|
|
character(len=1) xyz(3)
|
|
data xyz /'x','y','z'/
|
|
C Get nuclear contributions to multipole moments
|
|
call getvar('nuc ',nuc)
|
|
call getvar('nucdip ',nucdip)
|
|
call getvar('nucsec ',nucsec)
|
|
call getvar('nucthi ',nucthi)
|
|
C Calculate expectation values and virial quotient
|
|
open(oeintfile,file='OEINT',form='UNFORMATTED')
|
|
read(oeintfile)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipy=scal*ddot(nbasis**2,denst,1,xdip,1)
|
|
close(oeintfile)
|
|
open(oeintfile,file='PRINT',form='UNFORMATTED')
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipx=scal*ddot(nbasis**2,denst,1,xdip,1)
|
|
dipy=dipy-dipx
|
|
dipz=ener-dipx-dipy-nuc
|
|
write(iout,*)
|
|
write(iout,"(' Kinetic energy [au]: ',f16.8)") dipx
|
|
write(iout,"(' Nuclear attraction [au]:',f16.8)") dipy
|
|
write(iout,"(' Electron repulsion [au]:',f16.8)") dipz
|
|
write(iout,"(' Nuclear repulsion [au]: ',f16.8)") nuc
|
|
write(iout,"(' Virial theorem (-V/T): ',f16.8)") (dipx-ener)/dipx
|
|
C Calculate dipole moment
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipx=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucdip(1)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipy=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucdip(2)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipz=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucdip(3)
|
|
write(iout,*)
|
|
write(iout,"(' Dipole moment [au]: ',f16.8)")
|
|
$dsqrt(dipx**2+dipy**2+dipz**2)
|
|
write(iout,"(' x=',f16.8,2x,'y=',f16.8,2x,'z=',f16.8)") dipx,
|
|
$dipy,dipz
|
|
write(iout,*)
|
|
write(iout,"(' Dipole moment [Debye]: ',f16.8)")
|
|
$todeb*dsqrt(dipx**2+dipy**2+dipz**2)
|
|
write(iout,"(' x=',f16.8,2x,'y=',f16.8,2x,'z=',f16.8)")
|
|
$todeb*dipx,todeb*dipy,todeb*dipz
|
|
C Calculate second moment
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipxx=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucsec(1,1)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipyy=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucsec(2,2)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipzz=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucsec(3,3)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipxy=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucsec(1,2)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipxz=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucsec(1,3)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipyz=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucsec(2,3)
|
|
C Build quadrupole-moment matrix
|
|
qmtx(1,1)=1.0d0*dipxx-0.5d0*dipyy-0.5d0*dipzz
|
|
qmtx(1,2)=1.5d0*dipxy
|
|
qmtx(2,1)=1.5d0*dipxy
|
|
qmtx(1,3)=1.5d0*dipxz
|
|
qmtx(3,1)=1.5d0*dipxz
|
|
qmtx(2,2)=1.0d0*dipyy-0.5d0*dipxx-0.5d0*dipzz
|
|
qmtx(2,3)=1.5d0*dipyz
|
|
qmtx(3,2)=1.5d0*dipyz
|
|
qmtx(3,3)=1.0d0*dipzz-0.5d0*dipxx-0.5d0*dipyy
|
|
write(iout,*)
|
|
write(iout,*) 'Quadrupole moment [au]: '
|
|
do i=1,3
|
|
write(iout,"(3f16.8)") (qmtx(i,j),j=1,3)
|
|
enddo
|
|
write(iout,*)
|
|
write(iout,*) 'Quadrupole moment [Debye*Ang]: '
|
|
do i=1,3
|
|
write(iout,"(3f16.8)") (angtobohr*todeb*qmtx(i,j),j=1,3)
|
|
enddo
|
|
C Calculate third moment
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipxxx=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucthi(1,1,1)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipxxy=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucthi(1,1,2)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipxxz=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucthi(1,1,3)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipxyy=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucthi(1,2,2)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipxyz=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucthi(1,2,3)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipxzz=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucthi(1,3,3)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipyyy=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucthi(2,2,2)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipyyz=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucthi(2,2,3)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipyzz=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucthi(2,3,3)
|
|
call roeint(r8heap,i4heap,xdip,oeintfile,nbasis)
|
|
dipzzz=-scal*ddot(nbasis**2,denst,1,xdip,1)+nucthi(3,3,3)
|
|
close(oeintfile)
|
|
C Build the elements of octapole-moment tensor
|
|
oct( 1)= dipxxx-1.5d0*(dipxyy+dipxzz)
|
|
oct( 2)=2.d0*dipxxy-0.5d0*(dipyyy+dipyzz)
|
|
oct( 3)=2.d0*dipxxz-0.5d0*(dipzzz+dipyyz)
|
|
oct( 4)=2.d0*dipxyy-0.5d0*(dipxxx+dipxzz)
|
|
oct( 5)= dipxyz
|
|
oct( 6)=2.d0*dipxzz-0.5d0*(dipxxx+dipxyy)
|
|
oct( 7)= dipyyy-1.5d0*(dipxxy+dipyzz)
|
|
oct( 8)=2.d0*dipyyz-0.5d0*(dipzzz+dipxxz)
|
|
oct( 9)=2.d0*dipyzz-0.5d0*(dipyyy+dipxxy)
|
|
oct(10)= dipzzz-1.5d0*(dipxxz+dipyyz)
|
|
write(iout,*)
|
|
write(iout,*) 'Octapole moment [au] [Debye*Ang^2]: '
|
|
ii=0
|
|
do i=1,3
|
|
do j=i,3
|
|
do k=j,3
|
|
ii=ii+1
|
|
write(iout,"(8x,a4,2x,2f16.8)") xyz(i)//xyz(j)//xyz(k)//'=',
|
|
$oct(ii),angtobohr**2*todeb*oct(ii)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C Save moments
|
|
open(oeintfile,file='MOMENT',form='UNFORMATTED')
|
|
write(oeintfile) dipx,dipy,dipz
|
|
write(oeintfile) qmtx
|
|
close(oeintfile)
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine griddens(nb,densa,densb,scftype,dft)
|
|
************************************************************************
|
|
* Calculate density on grid for external use
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer imem1,nb,iscf
|
|
real*8 tmp,densa(nb,nb),densb(nb,nb)
|
|
character*5 scftype
|
|
character*32 dft
|
|
common/memcom/ imem1
|
|
C
|
|
iscf=1
|
|
if(scftype.eq.'uhf ') iscf=2
|
|
call dft_core(nb,nb,nb,tmp,tmp,tmp,tmp,scrfile7,dcore,iout,tmp,
|
|
$dft,minpfile,iscf,ifltln,maxcor,imem,imem1,icore,2,0,tmp,'den2',
|
|
$densa,densb,1,1,0.d0,0)
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
real*8 function nucrepat(iatoms,natoms,coord,atchg)
|
|
************************************************************************
|
|
* Calculate atomic contribution to nuclear repulsion energy
|
|
************************************************************************
|
|
implicit none
|
|
integer natoms,iatoms,jatoms
|
|
real*8 coord(3,natoms),atchg(natoms),r
|
|
C
|
|
nucrepat=0.d0
|
|
do jatoms=1,natoms
|
|
r=dsqrt((coord(1,iatoms)-coord(1,jatoms))**2+
|
|
$ (coord(2,iatoms)-coord(2,jatoms))**2+
|
|
$ (coord(3,iatoms)-coord(3,jatoms))**2)
|
|
if(r.gt.1d-12) nucrepat=nucrepat+atchg(iatoms)*atchg(jatoms)/r
|
|
enddo
|
|
nucrepat=0.5d0*nucrepat
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine schewd(rf,fa,fb,nb,nf,no,ca,ep,sc,ea)
|
|
************************************************************************
|
|
* Calculate energy-weighted density matrix in the case of SCH embedding
|
|
************************************************************************
|
|
implicit none
|
|
integer nb,nf,no,i
|
|
real*8 rf(nb,nb),fa(nb,nb),fb(nb,nb),ca(nb,no),ep(no,no),sc(*)
|
|
real*8 ea(no)
|
|
C
|
|
c ep=0.d0
|
|
c do i=1,no
|
|
c ep(i,i)=ea(i)
|
|
c enddo
|
|
call dsymm('l','u',nb,nf,1.d0,fb,nb,ca,nb,0.d0,sc,nb)
|
|
call dgemm('t','n',no,nf,nb,1.d0,ca,nb,sc,nb,0.d0,ep,no)
|
|
call dsymm('l','u',nb,no-nf,1.d0,fa,nb,ca(1,nf+1),nb,0.d0,sc,nb)
|
|
call dgemm('t','n',no,no-nf,nb,1.d0,ca,nb,sc,nb,0d0,ep(1,nf+1),no)
|
|
c call dsymm('l','u',nb,nf,1.d0,fb,nb,ca,nb,0.d0,sc,nb)
|
|
c call dgemm('t','n',no-nf,nf,nb,1.d0,ca(1,nf+1),nb,sc,nb,0.d0,
|
|
c $ep(nf+1,1),no)
|
|
c call dsymm('l','u',nb,no-nf,1.d0,fa,nb,ca(1,nf+1),nb,0.d0,sc,nb)
|
|
c call dgemm('t','n',nf,no-nf,nb,1.d0,ca,nb,sc,nb,0d0,ep(1,nf+1),no)
|
|
call dgemm('n','t',no,nb,no,1.d0,ep,no,ca,nb,0.d0,sc,no)
|
|
call dgemm('n','n',nb,nb,no,1.d0,ca,nb,sc,no,0.d0,rf,nb)
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine espchargecalc(espcharge,natoms,ncent,coord,denst,
|
|
$atsymbol,atchg)
|
|
************************************************************************
|
|
C ESP charge calculation subroutine !GA
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer natoms,i,iatoms,jatoms
|
|
integer ncent,imem1
|
|
real*8 itol
|
|
real*8 denst(nbasis,nbasis)
|
|
real*8 coord(3,ncent)
|
|
real*8 atchg(ncent)
|
|
character*2 atsymbol(natoms)
|
|
real*8 expval,charge
|
|
integer espdim,nesppt,iesppt,iespptcoord,iesp
|
|
integer nangmax,ncontrmax,nprimmax,ncartmax,nsphermax
|
|
integer nmboys,inang,incontr,inprim,igexp,intalloc,info
|
|
integer igcoef,ictostr,inangmin,igcn,inshrange,iboysval,iccf
|
|
integer dblalloc,atnum(natoms)
|
|
integer nlayer,ilayer,ipiv,iespmat,iespvec
|
|
real*8 dist,dis1,dis2,tmp,amat(nbasis,nbasis,3)
|
|
real*8 ptdens,vdwlayer(4),uffradii(118)
|
|
logical cartg!GA_ESPcharge
|
|
character(len=4) citol
|
|
character*4 cval
|
|
character*8 espcharge
|
|
real*8 atomvdwr(natoms),maxdist,gridspc
|
|
common/memcom/ imem1
|
|
|
|
call getkey('itol',4,citol,4)
|
|
read(citol,*) i
|
|
itol=10.d0**(-i)
|
|
call getvar('atnum ',atnum)
|
|
call getvar('nbset ',nbset)
|
|
call getvar('natoms ',natoms)
|
|
call getvar('ncent ',ncent)
|
|
call getvar('nangmax ',nangmax)
|
|
call getvar('ncontrmax ',ncontrmax)
|
|
call getvar('nprimmax ',nprimmax)
|
|
call getvar('ncartmax ',ncartmax)
|
|
call getvar('nsphermax ',nsphermax)
|
|
call getvar('cartg ',cartg)
|
|
call getvar('nmboys ',nmboys)
|
|
|
|
inang=intalloc(natoms*nbset)
|
|
incontr=intalloc((nangmax+1)*natoms*nbset)
|
|
inprim=intalloc((nangmax+1)*natoms*nbset)
|
|
igexp=dblalloc((nangmax+1)*nprimmax*natoms*nbset)
|
|
igcoef=dblalloc(nprimmax*ncontrmax*(nangmax+1)*natoms*nbset)
|
|
ictostr=dblalloc((nangmax+1)*ncartmax**2)
|
|
inangmin=intalloc(natoms*nbset)
|
|
igcn=intalloc(2*ncontrmax*(nangmax+1)*natoms*nbset)
|
|
inshrange=intalloc(2*(nangmax+1)*natoms*nbset)
|
|
iboysval=dblalloc((nmboys+1)*1481)
|
|
iccf=dblalloc(nmboys+1)
|
|
call getvar('nang ',icore(inang))
|
|
call getvar('ncontr ',icore(incontr))
|
|
call getvar('nprim ',icore(inprim))
|
|
call getvar('gexp ',dcore(igexp))
|
|
call getvar('gcoef ',dcore(igcoef))
|
|
call getvar('ctostr ',dcore(ictostr))
|
|
call getvar('nangmin ',icore(inangmin))
|
|
call getvar('gcn ',icore(igcn))
|
|
call getvar('nshrange ',icore(inshrange))
|
|
call getvar('boysval ',dcore(iboysval))
|
|
call getvar('cf ',dcore(iccf))
|
|
|
|
C esppt generation
|
|
C uff radii for every elements as default if nothing else provided
|
|
C J.Am.Chem.Soc.,Vol.114,No.25,1992
|
|
uffradii=(/ 1.443D0,1.181D0, !H,He
|
|
$1.2255D0,1.3725D0,2.0415D0,1.9255D0,1.83D0,1.75D0,1.682D0,
|
|
$1.6215D0, !Li~Ne
|
|
$1.4915D0,1.5105D0,2.2495D0,2.1475D0,2.0735D0,2.0175D0,1.9735D0,
|
|
$1.934D0, !Na~Ar
|
|
$1.906D0,1.6995D0,1.6475D0,1.5875D0,1.572D0,1.5115D0,1.4805D0,
|
|
$1.456D0,1.436D0,
|
|
$1.417D0,1.7475D0,1.3815D0,2.1915D0,2.14D0,2.115D0,2.1025D0,
|
|
$2.0945D0,2.0705D0, !K~Kr(19~36)
|
|
$2.057D0,1.8205D0,1.6725D0,1.562D0,1.5825D0,1.526D0,1.499D0,
|
|
$1.4815D0,1.4645D0,1.4495D0,1.574D0,1.424D0,2.2315D0,2.196D0,
|
|
$2.21D0,2.235D0,2.25D0,2.202D0, !Rb~Xe(37~54)
|
|
$2.2585D0,1.8515D0,1.761D0,1.778D0,1.803D0,1.7875D0,1.7735D0,
|
|
$1.76D0,1.7465D0,1.684D0,1.7255D0,1.714D0,1.7045D0,1.6955D0,
|
|
$1.687D0,1.6775D0,1.82D0, !Cs~Lu(55~71)
|
|
$1.5705D0,1.585D0,1.5345D0,1.477D0,1.56D0,1.42D0,1.377D0,1.6465D0,
|
|
$1.3525D0,2.1735D0,2.1485D0,2.185D0,2.3545D0,2.375D0,2.3825D0, !Hf~Rn(72~86)
|
|
$2.45D0,1.8385D0,1.739D0,1.698D0,1.712D0,1.6975D0,1.712D0,1.712D0,
|
|
$1.6905D0,1.663D0,1.6695D0,1.6565D0,1.6495D0,
|
|
$1.643D0,1.637D0,1.624D0,1.618D0, !Fr~Lr(87~103)
|
|
$2.0D0,2.0D0,2.0D0,2.0D0,2.0D0,2.0D0,2.0D0,2.0D0,2.0D0,2.0D0,2.0D0,
|
|
$2.0D0,2.0D0,2.0D0,2.0D0 /) !Rf~(104~118)
|
|
C only for 1-18 atoms, from original paper, same as Multiwfn and Gaussian (probably)
|
|
C Breneman, C.M. and Wiberg, K.B. (1990),J. Comput. Chem., 11: 361-373.
|
|
if(espcharge.eq.'chelpg ') then
|
|
gridspc=0.3d0/angtobohr
|
|
maxdist=2.8d0/angtobohr
|
|
do iatoms=1,natoms
|
|
if (atnum(iatoms).ge.1.and.atnum(iatoms).le.2) then
|
|
atomvdwr(iatoms)=1.45D0/angtobohr
|
|
elseif (atnum(iatoms).ge.3.and.atnum(iatoms).le.6) then
|
|
atomvdwr(iatoms)=1.5D0/angtobohr
|
|
elseif (atnum(iatoms).ge.7.and.atnum(iatoms).le.10) then
|
|
atomvdwr(iatoms)=1.70D0/angtobohr
|
|
elseif (atnum(iatoms).ge.11.and.atnum(iatoms).le.18) then
|
|
atomvdwr(iatoms)=2D0/angtobohr
|
|
else
|
|
C atomvdwr(iatoms)=3D0/angtobohr
|
|
atomvdwr(iatoms)=uffradii(atnum(iatoms))/angtobohr/1.2D0
|
|
endif
|
|
enddo
|
|
call countCHELPGpt(natoms,coord,atomvdwr,
|
|
$nesppt,maxdist,gridspc,iout)
|
|
iespptcoord=dblalloc(3*nesppt)
|
|
C allocate(esppt(3,nesppt))
|
|
call getCHELPGpt(natoms,coord,atomvdwr,
|
|
$nesppt,dcore(iespptcoord),maxdist,gridspc)
|
|
iesp=dblalloc(nesppt)
|
|
C allocate(esp(nesppt))
|
|
endif
|
|
C MK point density 1 A**-2
|
|
C vdw from Gaussian and Multiwfn
|
|
if(espcharge.eq.'mk ') then
|
|
do iatoms=1,natoms
|
|
if (atnum(iatoms).ge.1.and.atnum(iatoms).le.2) then
|
|
atomvdwr(iatoms)=1.2D0/angtobohr
|
|
elseif (atnum(iatoms).eq.3) then
|
|
atomvdwr(iatoms)=1.37D0/angtobohr
|
|
elseif (atnum(iatoms).ge.4.and.atnum(iatoms).le.5) then
|
|
atomvdwr(iatoms)=1.45D0/angtobohr
|
|
elseif (atnum(iatoms).ge.6.and.atnum(iatoms).le.7) then
|
|
atomvdwr(iatoms)=1.50D0/angtobohr
|
|
elseif (atnum(iatoms).eq.8) then
|
|
atomvdwr(iatoms)=1.4D0/angtobohr
|
|
elseif (atnum(iatoms).eq.9) then
|
|
atomvdwr(iatoms)=1.35D0/angtobohr
|
|
elseif (atnum(iatoms).eq.10) then
|
|
atomvdwr(iatoms)=1.3D0/angtobohr
|
|
elseif (atnum(iatoms).eq.11) then
|
|
atomvdwr(iatoms)=1.57D0/angtobohr !Multiwfn
|
|
elseif (atnum(iatoms).ge.12.and.atnum(iatoms).le.13) then
|
|
atomvdwr(iatoms)=1.65D0/angtobohr !Multiwfn
|
|
elseif (atnum(iatoms).ge.14.and.atnum(iatoms).le.15) then
|
|
atomvdwr(iatoms)=1.8D0/angtobohr !Multiwfn
|
|
elseif (atnum(iatoms).eq.16) then
|
|
atomvdwr(iatoms)=1.75D0/angtobohr
|
|
elseif (atnum(iatoms).eq.17) then
|
|
atomvdwr(iatoms)=1.7D0/angtobohr
|
|
else
|
|
C atomvdwr(iatoms)=3D0/angtobohr
|
|
atomvdwr(iatoms)=uffradii(atnum(iatoms))/angtobohr/1.2D0
|
|
endif
|
|
enddo
|
|
ptdens=6D0*(angtobohr**2)
|
|
vdwlayer=(/1.4D0,1.6D0,1.8D0,2.0D0/)
|
|
nlayer=4
|
|
C count approx MK points
|
|
nesppt=0
|
|
do iatoms=1,natoms
|
|
do ilayer=1,nlayer
|
|
nesppt=nesppt+nint(4D0*pi*(atomvdwr(iatoms)*
|
|
$vdwlayer(ilayer))**2*ptdens)
|
|
enddo
|
|
enddo
|
|
iespptcoord=dblalloc(3*nesppt)
|
|
call getMKpt(natoms,coord,atomvdwr,
|
|
$nesppt,dcore(iespptcoord),vdwlayer,ptdens,nlayer)
|
|
iesp=dblalloc(nesppt)
|
|
endif
|
|
C! Calculate nuclear contribution to esp
|
|
C!$OMP PARALLEL DO &
|
|
C!$OMP SHARED(ngrid,natoms,coord,grid,atchg,mep) &
|
|
C!$OMP PRIVATE(igrid,tmp,iatoms,dist)
|
|
do iesppt=1,nesppt
|
|
tmp=0.d0
|
|
do iatoms=1,natoms
|
|
dist=dsqrt((coord(1,iatoms)-dcore(iespptcoord+iesppt*3-3))**2 +
|
|
$ (coord(2,iatoms)-dcore(iespptcoord+iesppt*3-2))**2 +
|
|
$ (coord(3,iatoms)-dcore(iespptcoord+iesppt*3-1))**2)
|
|
tmp=tmp+atchg(iatoms)/dist
|
|
enddo
|
|
C esp(iesppt)=tmp
|
|
dcore(iesp+iesppt-1)=tmp
|
|
enddo
|
|
C!$OMP END PARALLEL DO
|
|
do iesppt=1,nesppt
|
|
call nucatt(natoms,nangmax,ncontrmax,nprimmax,ncartmax,
|
|
$nsphermax,icore(inang),icore(inangmin),icore(incontr),
|
|
$icore(inprim),dcore(igexp),dcore(igcoef),coord,
|
|
$dcore(ictostr),nbasis,amat,dcore(imem),icore(igcn),
|
|
$icore(inshrange),cartg,dcore(iboysval),nmboys,
|
|
$dcore(iccf),itol,1.d0,1,dcore(iespptcoord+iesppt*3-3))
|
|
dcore(iesp+iesppt-1)=dcore(iesp+iesppt-1)
|
|
$ +expval(denst,amat,nbasis)
|
|
enddo
|
|
C Fitting of charges to represent esp
|
|
espdim=natoms+1
|
|
iespmat=dblalloc(espdim*espdim)
|
|
iespvec=dblalloc(espdim)
|
|
C Forming espmat
|
|
dcore(iespmat:iespmat+espdim*espdim-1)=0.D0
|
|
C espmat=0.D0
|
|
do iatoms=1,natoms
|
|
do jatoms=iatoms,natoms
|
|
do iesppt=1,nesppt
|
|
dis1=dsqrt((dcore(iespptcoord+iesppt*3-3)-coord(1,iatoms))**2+
|
|
$(dcore(iespptcoord+iesppt*3-2)-coord(2,iatoms))**2+
|
|
$(dcore(iespptcoord+iesppt*3-1)-coord(3,iatoms))**2)
|
|
dis2=dsqrt((dcore(iespptcoord+iesppt*3-3)-coord(1,jatoms))**2+
|
|
$(dcore(iespptcoord+iesppt*3-2)-coord(2,jatoms))**2+
|
|
$(dcore(iespptcoord+iesppt*3-1)-coord(3,jatoms))**2)
|
|
dcore(iespmat+(iatoms-1)*espdim+jatoms-1)=
|
|
$dcore(iespmat+(iatoms-1)*espdim+jatoms-1)+1.D0/dis1/dis2
|
|
enddo
|
|
dcore(iespmat+(jatoms-1)*espdim+iatoms-1)=
|
|
$ dcore(iespmat+(iatoms-1)*espdim+jatoms-1)
|
|
enddo
|
|
enddo
|
|
do iatoms=1,natoms
|
|
dcore(iespmat+(iatoms-1)*espdim+natoms)=1.D0
|
|
dcore(iespmat+natoms*espdim+iatoms-1)=1.D0
|
|
enddo
|
|
dcore(iespvec:iespvec+espdim-1)=0.D0
|
|
do iatoms=1,natoms
|
|
do iesppt=1,nesppt
|
|
dis1=dsqrt((dcore(iespptcoord+iesppt*3-3)-coord(1,iatoms))**2+
|
|
$(dcore(iespptcoord+iesppt*3-2)-coord(2,iatoms))**2+
|
|
$(dcore(iespptcoord+iesppt*3-1)-coord(3,iatoms))**2)
|
|
dcore(iespvec+iatoms-1)=dcore(iespvec+iatoms-1)+
|
|
$ dcore(iesp+iesppt-1)/dis1
|
|
enddo
|
|
enddo
|
|
call getkey('charge',6,cval,4)
|
|
read(cval,*) charge
|
|
dcore(iespvec+espdim-1)=charge
|
|
ipiv=dblalloc(espdim)
|
|
C general solution of Ax=b, results written in espvec
|
|
call dgetrf(espdim,espdim,dcore(iespmat),espdim,dcore(ipiv),info)
|
|
call dgetrs('N',espdim,1,dcore(iespmat),espdim,dcore(ipiv),
|
|
$dcore(iespvec),espdim,info)
|
|
|
|
if(espcharge.eq.'chelpg ') then
|
|
write(iout,*) 'CHELPG charges'
|
|
endif
|
|
if(espcharge.eq.'mk ') then
|
|
write(iout,*) 'MERZ-KOLLMAN charges'
|
|
endif
|
|
open(scrfile1,file="ATCHARGE",form='formatted')
|
|
do iatoms=1,natoms
|
|
write(iout,'(i4,A4,3f17.10)') iatoms,
|
|
$atsymbol(iatoms),dcore(iespvec+iatoms-1)
|
|
write(scrfile1,'(f17.10)') dcore(iespvec+iatoms-1)
|
|
enddo
|
|
close(scrfile1)
|
|
call intdealloc(inang)
|
|
return
|
|
end subroutine
|
|
C
|
|
************************************************************************
|
|
subroutine countCHELPGpt(natoms,coord,atomvdwr,
|
|
$ nesppt,maxdist,gridspc,iout)
|
|
************************************************************************
|
|
C Count CHELPG points
|
|
************************************************************************
|
|
implicit none
|
|
integer natoms,nesppt,nx,ny,nz,ix,iy,iz,iatoms,iout
|
|
real*8 coord(3,natoms),atomvdwr(natoms),dist(natoms)
|
|
real*8 maxdist,tmp(3),gridspc
|
|
real*8 xmin,xmax,ymin,ymax,zmin,zmax
|
|
xmin=minval(coord(1,:))-maxdist
|
|
xmax=maxval(coord(1,:))+maxdist
|
|
ymin=minval(coord(2,:))-maxdist
|
|
ymax=maxval(coord(2,:))+maxdist
|
|
zmin=minval(coord(3,:))-maxdist
|
|
zmax=maxval(coord(3,:))+maxdist
|
|
nx=int((xmax-xmin)/gridspc)+1
|
|
ny=int((ymax-ymin)/gridspc)+1
|
|
nz=int((zmax-zmin)/gridspc)+1
|
|
nesppt=0
|
|
do ix=0,nx
|
|
do iy=0,ny
|
|
do iz=0,nz
|
|
tmp(1)=xmin+ix*gridspc
|
|
tmp(2)=ymin+iy*gridspc
|
|
tmp(3)=zmin+iz*gridspc
|
|
do iatoms=1,natoms
|
|
dist(iatoms)=dsqrt( (coord(1,iatoms)-tmp(1))**2+
|
|
$(coord(2,iatoms)-tmp(2))**2+
|
|
$(coord(3,iatoms)-tmp(3))**2 )
|
|
if (dist(iatoms).le.atomvdwr(iatoms)) then
|
|
exit
|
|
endif
|
|
if (iatoms.eq.natoms.and.any(dist.le.maxdist)) then
|
|
nesppt=nesppt+1
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
write(iout,*)
|
|
write(iout,"(' Number of CHELPG points:',i10)") nesppt
|
|
end subroutine
|
|
C
|
|
************************************************************************
|
|
subroutine getCHELPGpt(natoms,coord,atomvdwr,
|
|
$ nesppt,esppt,maxdist,gridspc)
|
|
************************************************************************
|
|
C Set CHELPG points
|
|
************************************************************************
|
|
implicit none
|
|
integer natoms,nesppt,ix,iy,iz,nx,ny,nz,iatoms,iesppt
|
|
real*8 coord(3,natoms),atomvdwr(natoms),dist(natoms)
|
|
real*8 esppt(3,nesppt),maxdist,xmin,xmax,ymin,ymax,zmin
|
|
real*8 zmax,tmp(3),gridspc
|
|
|
|
xmin=minval(coord(1,:))-maxdist
|
|
xmax=maxval(coord(1,:))+maxdist
|
|
ymin=minval(coord(2,:))-maxdist
|
|
ymax=maxval(coord(2,:))+maxdist
|
|
zmin=minval(coord(3,:))-maxdist
|
|
zmax=maxval(coord(3,:))+maxdist
|
|
nx=int((xmax-xmin)/gridspc)+1
|
|
ny=int((ymax-ymin)/gridspc)+1
|
|
nz=int((zmax-zmin)/gridspc)+1
|
|
iesppt=0
|
|
do ix=0,nx
|
|
do iy=0,ny
|
|
do iz=0,nz
|
|
tmp(1)=xmin+ix*gridspc
|
|
tmp(2)=ymin+iy*gridspc
|
|
tmp(3)=zmin+iz*gridspc
|
|
do iatoms=1,natoms
|
|
dist(iatoms)=dsqrt( (coord(1,iatoms)-tmp(1))**2+
|
|
$(coord(2,iatoms)-tmp(2))**2+
|
|
$(coord(3,iatoms)-tmp(3))**2 )
|
|
if (dist(iatoms).le.atomvdwr(iatoms)) then
|
|
exit
|
|
endif
|
|
if (iatoms.eq.natoms.and.any(dist.le.maxdist)) then
|
|
iesppt=iesppt+1
|
|
esppt(1,iesppt)=tmp(1)
|
|
esppt(2,iesppt)=tmp(2)
|
|
esppt(3,iesppt)=tmp(3)
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine getMKpt(natoms,coord,atomvdwr,nesppt,esppt,
|
|
$vdwlayer,ptdens,nlayer)
|
|
************************************************************************
|
|
C Set MK points
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer natoms,nesppt,nlayer,save,nmaxsphpt,iatoms,iesppt,ilayer
|
|
integer ipt,ivert,nvert,nsphpt,nequ,nxy,ixy,j,i,jatoms
|
|
real*8 coord(3,natoms),atomvdwr(natoms),ESPpt(3,nesppt)
|
|
real*8 vdwlayer(4),ptdens,limit,tmp(3),innerlimit,radius
|
|
real*8 angz,scalexy,z,dist,angxy
|
|
integer isphpt,dblalloc
|
|
|
|
innerlimit=minval(vdwlayer)
|
|
C determine max number of points in sphere to allocate
|
|
nmaxsphpt=nint(4D0*pi*(maxval(atomvdwr)*maxval(vdwlayer))**2
|
|
$*ptdens)
|
|
isphpt=dblalloc(3*nmaxsphpt)
|
|
C create sphere for each atom and layer with correct density of points
|
|
iesppt=0
|
|
do iatoms=1,natoms
|
|
do ilayer=1,nlayer
|
|
radius=atomvdwr(iatoms)*vdwlayer(ilayer)
|
|
nsphpt=nint(4D0*pi*(radius**2)*ptdens)
|
|
nequ=int(dsqrt(nsphpt*pi))
|
|
nvert=nequ/2
|
|
ipt=0
|
|
do ivert=0,nvert
|
|
angz=dfloat(ivert)/nvert*pi
|
|
scalexy=dsin(angz)
|
|
z=dcos(angz)
|
|
nxy=int(nequ*scalexy)
|
|
if (nxy.eq.0) then
|
|
nxy=1
|
|
endif
|
|
do ixy=1,nxy
|
|
ipt=ipt+1
|
|
if (ipt.ge.nsphpt) then
|
|
nsphpt=ipt-1
|
|
return
|
|
endif
|
|
angxy=2D0*pi*ixy/nxy
|
|
dcore(isphpt+ipt*3-3)=dcos(angxy)*scalexy
|
|
dcore(isphpt+ipt*3-2)=dsin(angxy)*scalexy
|
|
dcore(isphpt+ipt*3-1)=z
|
|
enddo
|
|
enddo
|
|
nsphpt=ipt
|
|
C scale up and move speheres
|
|
do i=1,nsphpt
|
|
dcore(isphpt+i*3-3)=dcore(isphpt+i*3-3)*radius+
|
|
$coord(1,iatoms)
|
|
dcore(isphpt+i*3-2)=dcore(isphpt+i*3-2)*radius+
|
|
$coord(2,iatoms)
|
|
dcore(isphpt+i*3-1)=dcore(isphpt+i*3-1)*radius+
|
|
$coord(3,iatoms)
|
|
enddo
|
|
C Drop points which are too close to one of the atoms
|
|
do ipt=1,nsphpt
|
|
do j=1,3
|
|
tmp(j)=dcore(isphpt+ipt*3+j-4)
|
|
enddo
|
|
save=1
|
|
do jatoms=1,natoms
|
|
if (jatoms.eq.iatoms) then
|
|
cycle
|
|
endif
|
|
dist=(coord(1,jatoms)-tmp(1))**2+
|
|
$(coord(2,jatoms)-tmp(2))**2+
|
|
$(coord(3,jatoms)-tmp(3))**2
|
|
limit=(atomvdwr(jatoms)*innerlimit)**2
|
|
if (dist.lt.limit) then
|
|
save=0
|
|
exit
|
|
endif
|
|
enddo
|
|
if (save.eq.1) then
|
|
iesppt=iesppt+1
|
|
esppt(1,iesppt)=tmp(1)
|
|
esppt(2,iesppt)=tmp(2)
|
|
esppt(3,iesppt)=tmp(3)
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
nesppt=iesppt
|
|
call dbldealloc(isphpt)
|
|
write(iout,*)
|
|
write(iout,"(' Number of Merz-Kollman points:',i10)") nesppt
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine calc_embed_grad(densa,densb,tdera,tderb,dens2,scftype,
|
|
$sder,hder,ca,ca2,dfbasis_scf,ctol,xveca,oroute,efield,locfit,
|
|
$grads,ncent,natoms,imem1,verbosity,chfx,calctype,lgradd,coord,
|
|
$atsymbol,atchg,itol,pcm)
|
|
************************************************************************
|
|
* Embedding energy gradient
|
|
************************************************************************
|
|
use embed_grad, only: ll_chfx,ll_clrhfx,ll_csrhfx,nocc_a,nocc_b,
|
|
& omega,ll_dft,ncore,nval
|
|
use domain, only: domain_type
|
|
use common_mod, only: oeintfile,scrfile3,scrfile4,maxcor,imem,
|
|
& dcore,icore,tedatfile,dfnbasis,nbasis,minpfile,irecln,iout,
|
|
& nbset,varsfile,ifltln
|
|
implicit none
|
|
|
|
integer natoms,oroute,locfit,ncent,verbosity,imem1
|
|
double precision densa(nbasis,nbasis),densb(nbasis,nbasis)
|
|
double precision tdera(nbasis,nbasis,3),tderb(nbasis,nbasis,3)
|
|
double precision dens2(nbasis,nbasis),ca(nbasis,nbasis)
|
|
double precision sder(nbasis,nbasis,3),hder(nbasis*nbasis*3)
|
|
double precision ca2(nbasis,nbasis),ctol
|
|
double precision xveca(4*dfnbasis),grads(3,natoms,8)
|
|
double precision efield(3,ncent)
|
|
double precision coord(3,ncent),atchg(ncent),itol
|
|
logical lgradd
|
|
character*2 atsymbol(*)
|
|
character*5 scftype
|
|
character*16 calctype
|
|
character*32 pcm
|
|
character*20 dfbasis_scf
|
|
|
|
integer igrad_tmp,imoa,iwork,imem_old,iy,imult,ihder_dens
|
|
integer nvirt,nocc,i,xyz,datoms,dero,hailen
|
|
integer dblalloc
|
|
double precision chfx,csrhfx,clrhfx,exc,tegrad(3),devparr(2)
|
|
double precision nn_grad
|
|
character*32 dft,dft2
|
|
character*256 edisp,edisp_embed
|
|
logical ldf,l3der
|
|
type(domain_type) dom
|
|
|
|
interface
|
|
subroutine fock_der(nbasis,dfnbasis,nocc,densa,densb,dens2,
|
|
& xveca,scftype,dero,ca,ldf,dom,ctol,chfx,clrhfx,csrhfx,omega,
|
|
& itol,natoms,ncent,efield,grads,sder)
|
|
use domain, only: domain_type
|
|
implicit none
|
|
integer nbasis,dfnbasis,nocc,dero,ncent,natoms,locfit
|
|
double precision densa(nbasis,nbasis),densb(nbasis,nbasis)
|
|
double precision dens2(nbasis,nbasis),xveca(dfnbasis,4)
|
|
double precision, target :: ca(nbasis,nocc)
|
|
double precision, target :: sder(nbasis,nbasis,3)
|
|
double precision efield(3,ncent),grads(3,natoms,8)
|
|
double precision ctol,chfx,csrhfx,clrhfx,itol,omega
|
|
character*5 scftype
|
|
logical ldf
|
|
type(domain_type) dom
|
|
end subroutine
|
|
end interface
|
|
|
|
imem_old=imem
|
|
nocc=nocc_a+nocc_b
|
|
nvirt=nbasis-nocc
|
|
ldf=dfbasis_scf.ne.'none '
|
|
l3der=ldf.and.(trim(calctype).eq.'scf'.or.lgradd)
|
|
if(l3der) then
|
|
dero=1
|
|
else
|
|
dero=0
|
|
endif
|
|
devparr=1.0d0
|
|
call getkey('dft',3,dft,32)
|
|
|
|
call alloc_zero_domains(dom,natoms,nocc,nbasis,dfnbasis,icore,
|
|
& imem)
|
|
call dfillzero(grads,natoms*3*8)
|
|
call dfillzero(efield,ncent*3)
|
|
|
|
call dfillzero(densa,nbasis**2)
|
|
call dfillzero(dens2,nbasis**2)
|
|
|
|
call getvar('coord ',coord)
|
|
call getvar('clrhfx ',clrhfx)
|
|
call getvar('csrhfx ',csrhfx)
|
|
call getvar('omega ',omega)
|
|
call getkey('edisp',5,edisp,256)
|
|
call getkey('edisp_embed',11,edisp_embed,256)
|
|
|
|
c Reading MOs from disk
|
|
call read_from_disk('MOCOEF ',ca2,nbasis,.false.)
|
|
call read_from_disk('MOCOEF_AB ',ca ,nbasis,.false.)
|
|
|
|
c low level SCF energy gradient + low level Brillouin condition gradient
|
|
c + cor-val orthogonality condition gradient
|
|
c Tr{(D^Atilde+D^B)G_2(D^AB)} - 1/2*Tr{D^AB*G_2(D^AB)} + Tr{Dtilde*G_2(D^AB)}
|
|
|
|
c Dtilde: density from Brillouin condition and core-val orthogonality
|
|
c dens2 contains 2*Dtilde: shdens divides it by 2 in df3int
|
|
imult=dblalloc(max(nocc*nvirt,ncore*nval))
|
|
open(unit=scrfile3,file='LAGRANGE',form='unformatted')
|
|
if(ncore*(ncore-1)/2 > 0) read(scrfile3)
|
|
if(nval*(nval-1)/2 > 0) read(scrfile3)
|
|
read(scrfile3) dcore(imult:imult+nocc*nvirt-1)
|
|
call dgemm('n','n',nbasis,nocc,nvirt,1.0d0,ca(1,nocc+1),nbasis,
|
|
$ dcore(imult),nvirt,0.0d0,hder,nbasis)
|
|
call dsyr2k('u','n',nbasis,nocc,1.0d0,hder,nbasis,ca,nbasis,0.d0,
|
|
$ dens2,nbasis)
|
|
if(ncore*nval>0) then
|
|
imoa=dblalloc(nbasis*nbasis)
|
|
call read_from_disk('MOCOEF.LOC ',dcore(imoa),nbasis,
|
|
$ .false.)
|
|
read(scrfile3) dcore(imult:imult+ncore*nval-1)
|
|
call dgemm('n','n',nbasis,nval,ncore,1.0d0,dcore(imoa),nbasis,
|
|
$ dcore(imult),ncore,0.0d0,hder,nbasis)
|
|
call dsyr2k('u','n',nbasis,nval,1.0d0,hder,nbasis,
|
|
$ dcore(imoa+ncore*nbasis),nbasis,1.0d0,dens2,nbasis)
|
|
call dbldealloc(imoa)
|
|
endif
|
|
close(scrfile3)
|
|
call filllo(dens2,nbasis)
|
|
call dbldealloc(imult)
|
|
|
|
call dcopy(nbasis**2,dens2,1,hder,1)
|
|
|
|
c -1/2*D^{AB}
|
|
call dsyrk('u','n',nbasis,nocc,-2.0d0,ca,nbasis,1.0d0,dens2,
|
|
$ nbasis)
|
|
c +D^Atilde+D^B
|
|
call dsyrk('u','n',nbasis,nocc,4.0d0,ca2,nbasis,1.0d0,dens2,
|
|
$ nbasis)
|
|
call filllo(dens2,nbasis)
|
|
|
|
c D^{AB}
|
|
call dsyrk('u','n',nbasis,nocc,2.0d0,ca,nbasis,0.0d0,densa,
|
|
$ nbasis)
|
|
call filllo(densa,nbasis)
|
|
|
|
call fock_der(nbasis,dfnbasis,nocc,densa,densa,dens2,xveca,
|
|
& scftype,dero,ca,ldf,dom,ctol,ll_chfx,ll_clrhfx,ll_csrhfx,
|
|
& omega,itol,natoms,ncent,efield,grads,sder)
|
|
|
|
if(trim(ll_dft) .ne. 'off') then
|
|
c E^XC_2(D^AB)
|
|
imoa=dblalloc(nbasis*nocc)
|
|
call motransp(nocc,nbasis,dcore(imoa),ca,.false.)
|
|
call dscal(nbasis*nocc,dsqrt(2.0d0),dcore(imoa),1)
|
|
call dsyrk('u','n',nbasis,nocc,2.0d0,ca,nbasis,0.0d0,densa,
|
|
$ nbasis)
|
|
call filllo(densa,nbasis)
|
|
call dft_core(nbasis,nocc,nocc,tdera,tderb,dcore(imoa),
|
|
& dcore(imoa),scrfile4,dcore,iout,exc,ll_dft,minpfile,1,
|
|
& ifltln,maxcor,imem,imem1,icore,verbosity,1,grads(1,1,5),
|
|
& 'em1 ',densa,densa,1,1,0.d0,0)
|
|
|
|
c -Tr{(D^A-D^Atilde)*F^XC_2(D^AB)} + Tr{Dtilde*F^XC_2(D^AB)}
|
|
iwork=dblalloc(nbasis**2)
|
|
iy=dblalloc(nocc*(nbasis-nocc))
|
|
call dsyrk('u','n',nbasis,nocc_a,1.0d0,ca2(1,1+nocc_b),nbasis,
|
|
& 0.0d0,densa,nbasis)
|
|
call dsyrk('u','n',nbasis,nocc_a,-1.0d0,ca(1,1+nocc_b),nbasis,
|
|
& 1.0d0,densa,nbasis)
|
|
call filllo(densa,nbasis)
|
|
! hder contains 2*Dtilde and dvxc multiplies the density by 2 -> 0.25
|
|
call daxpy(nbasis**2,0.25d0,hder,1,densa,1)
|
|
|
|
call dvxc(nbasis,nocc,nocc,tdera,tderb,dcore(imoa),dcore(imoa),
|
|
& scrfile4,dcore,iout,exc,ll_dft,minpfile,1,ifltln,maxcor,
|
|
& imem,icore,verbosity,2,grads(1,1,5),'em1 ',densa,densa,
|
|
& ca,ca,dcore(iwork),dcore(iwork),dcore(iy),dcore(iy),200,
|
|
& 0,1,1,1)
|
|
|
|
c Tr{(D^A-D^Atilde)*F^XC_2(D^A)}
|
|
call dscal(nbasis**2,-0.5d0,densa,1) ! 0.5 factor: dvxc multiplies the density
|
|
call daxpy(nbasis**2,0.25d0,hder,1,densa,1)
|
|
call dvxc(nbasis,nocc_a,nocc_a,tdera,tderb,dcore(imoa),
|
|
& dcore(imoa),scrfile4,dcore,iout,exc,ll_dft,minpfile,1,
|
|
& ifltln,maxcor,imem,icore,verbosity,2,grads(1,1,5),'em1 ',
|
|
& densa,densa,ca(1,1+nocc_b),ca(1,1+nocc_b),
|
|
& dcore(iwork),dcore(iwork),dcore(iy),dcore(iy),200,0,1,1,1)
|
|
|
|
c -E_2^XC(D^A)
|
|
call motransp(nocc_a,nbasis,dcore(imoa),ca(1,1+nocc_b),.false.)
|
|
call dscal(nbasis*nocc_a,dsqrt(2.0d0),dcore(imoa),1)
|
|
call dsyrk('u','n',nbasis,nocc_a,2.0d0,ca(1,1+nocc_b),nbasis,
|
|
& 0.0d0,dens2,nbasis)
|
|
call filllo(dens2,nbasis)
|
|
igrad_tmp=dblalloc(3*natoms)
|
|
call dfillzero(dcore(igrad_tmp),3*natoms)
|
|
call dft_core(nbasis,nocc_a,nocc_a,tdera,tderb,dcore(imoa),
|
|
$ dcore(imoa),scrfile4,dcore,iout,exc,ll_dft,minpfile,1,
|
|
$ ifltln,maxcor,imem,imem1,icore,verbosity,1,
|
|
$ dcore(igrad_tmp),'em1 ',dens2,dens2,1,1,0.d0,0)
|
|
call daxpy(3*natoms,-1.0d0,dcore(igrad_tmp),1,grads(1,1,5),1)
|
|
|
|
call dbldealloc(imoa)
|
|
endif
|
|
|
|
c low level subsystem SCF energy gradient
|
|
c -Tr{D^Atilde*G_2(D^A)} + 1/2*Tr{D^A*G_2(D^A)} =
|
|
c -(Tr{D^Atilde*G_2(D^A)} - 1/2*Tr{D^A*G_2(D^A)})=
|
|
c -Tr{(D^Atilde-1/2D^A)*G_2(D^A)}
|
|
igrad_tmp=dblalloc(3*natoms*8)
|
|
call dfillzero(dcore(igrad_tmp),3*natoms*8)
|
|
|
|
call dsyrk('u','n',nbasis,nocc_a,2.0d0,ca(1,nocc_b+1),nbasis,
|
|
& 0.0d0,densa,nbasis)
|
|
call filllo(densa,nbasis)
|
|
|
|
call dsyrk('u','n',nbasis,nocc_a,4.0d0,ca2(1,nocc_b+1),nbasis,
|
|
& 0.0d0,dens2,nbasis)
|
|
call filllo(dens2,nbasis)
|
|
call daxpy(nbasis*nbasis,-1.0d0,densa,1,dens2,1)
|
|
|
|
call fock_der(nbasis,dfnbasis,nocc_a,densa,densa,dens2,xveca,
|
|
& scftype,dero,ca(1,1+nocc_b),ldf,dom,ctol,ll_chfx,ll_clrhfx,
|
|
& ll_csrhfx,omega,itol,natoms,ncent,efield,dcore(igrad_tmp),
|
|
& sder)
|
|
call daxpy(3*natoms*8,-1.0d0,dcore(igrad_tmp),1,grads,1)
|
|
|
|
call dbldealloc(igrad_tmp)
|
|
|
|
c Derivative of the constraints
|
|
ihder_dens=dblalloc(nbasis**2)
|
|
imult=dblalloc(nbasis**2)
|
|
open(unit=scrfile3,file='LAGRANGE',form='unformatted')
|
|
if(ncore*(ncore-1)/2 > 0) read(scrfile3)
|
|
if(nval*(nval-1)/2 > 0) read(scrfile3)
|
|
|
|
c Effective density for the core Hamiltonian derivative
|
|
c 1. Low level Brillouin condition
|
|
read(scrfile3) dcore(imult:imult+nocc*nvirt-1)
|
|
call dgemm('n','n',nbasis,nocc,nvirt,1.0d0,ca(1,nocc+1),nbasis,
|
|
$ dcore(imult),nvirt,0.0d0,hder,nbasis)
|
|
call dgemm('n','t',nbasis,nbasis,nocc,1.0d0,hder,nbasis,ca,nbasis,
|
|
$ 0.0d0,dcore(ihder_dens),nbasis)
|
|
! write(*,*) 'hder dens zmat'
|
|
! call prmx_ldf(dcore(ihder_dens),nbasis,nbasis,nbasis)
|
|
if(ncore*nval>0) then
|
|
imoa=dblalloc(nbasis*nbasis)
|
|
call read_from_disk('MOCOEF.LOC ',dcore(imoa),nbasis,
|
|
$ .false.)
|
|
read(scrfile3) dcore(imult:imult+ncore*nval-1)
|
|
call dgemm('n','n',nbasis,nval,ncore,1.0d0,dcore(imoa),nbasis,
|
|
$ dcore(imult),ncore,0.0d0,hder,nbasis)
|
|
call dgemm('n','t',nbasis,nbasis,nval,1.0d0,hder,nbasis,
|
|
$ dcore(imoa+ncore*nbasis),nbasis,1.0d0,dcore(ihder_dens),
|
|
$ nbasis)
|
|
call dbldealloc(imoa)
|
|
endif
|
|
call symmat(dcore(ihder_dens),nbasis)
|
|
c 2. SCF energy expression
|
|
call dsyrk('u','n',nbasis,nocc,2.0d0,ca2,nbasis,1.0d0,
|
|
$ dcore(ihder_dens),nbasis)
|
|
call filllo(dcore(ihder_dens),nbasis)
|
|
! write(*,*) 'hder ener'
|
|
! call prmx_ldf(dcore(ihder_dens),nbasis,nbasis,nbasis)
|
|
|
|
c orthogonality conditions, building the density which multiplies the
|
|
c derivative of the overlap matrix
|
|
c 1. orthogonality of low level MOs
|
|
read(scrfile3) dcore(imult:imult+nbasis**2-1)
|
|
call dgemm('n','t',nbasis,nbasis,nbasis,-0.5d0,dcore(imult),
|
|
& nbasis,ca,nbasis,0.0d0,dens2,nbasis)
|
|
call dgemm('n','n',nbasis,nbasis,nbasis,1.0d0,ca,nbasis,dens2,
|
|
& nbasis,0.0d0,densa,nbasis)
|
|
|
|
c 2. orthogonality of high level MOs
|
|
read(scrfile3) dcore(imult:imult+nocc_a**2-1)
|
|
call dgemm('n','t',nocc_a,nbasis,nocc_a,-0.5d0,dcore(imult),
|
|
& nocc_a,ca2(1,1+nocc_b),nbasis,0.0d0,dens2,nocc_a)
|
|
call dgemm('n','n',nbasis,nbasis,nocc_a,1.0d0,ca2(1,1+nocc_b),
|
|
& nbasis,dens2,nocc_a,1.0d0,densa,nbasis)
|
|
|
|
c 3. orthogonality of high and low level MOs
|
|
read(scrfile3) dcore(imult:imult+nocc_a*nocc_b-1)
|
|
call dgemm('n','n',nbasis,nocc_b,nocc_a,-0.25d0,ca2(1,1+nocc_b),
|
|
& nbasis,dcore(imult),nocc_a,0.0d0,dens2,nbasis)
|
|
call dsyr2k('u','n',nbasis,nocc_b,1.0d0,dens2,nbasis,ca,nbasis,
|
|
& 1.0d0,densa,nbasis)
|
|
call filllo(densa,nbasis)
|
|
|
|
! call symmat(densa,nbasis)
|
|
close(scrfile3)
|
|
|
|
call dbldealloc(imult)
|
|
|
|
c high level subsystem SCF energy gradient
|
|
c Tr{D^Atilde*G_1(D^Atilde)}
|
|
call dsyrk('u','n',nbasis,nocc_a,2.0d0,ca2(1,1+nocc_b),nbasis,
|
|
$ 0.0d0,dens2,nbasis)
|
|
call filllo(dens2,nbasis)
|
|
|
|
call dfillzero(xveca,4*dfnbasis)
|
|
call direct_fock_build(dens2,dens2,tdera,tderb,dens2,100,scftype,
|
|
$ 2,dero,1,sder,hder,ca2(1,nocc_b+1),ldf,dcore,dcore,dcore,
|
|
$ tegrad,hailen,dom%nmoat,dom%moat,dom%moadd,dom%dfnmobasis,
|
|
$ ctol,.false.,xveca,0,chfx,iout,varsfile,icore,dcore,nbset,
|
|
$ oeintfile,nocc_a,scrfile3,scrfile4,maxcor,imem,tedatfile,
|
|
$ dfnbasis,nbasis,oroute,efield,minpfile,.false.,1,dcore,
|
|
$ irecln,1,.false.,0,0,0,devparr,dcore(ihder_dens),1,densa,0,
|
|
$ locfit,dom%nmobasis,dom%natdom,dom%atdom,dom%naoat,dom%aoat,
|
|
$ dom%atind,i,i,clrhfx,csrhfx,omega,l3der,grads,dcore,dcore,
|
|
$ i,.false.,.false.,dcore,.false.,.false.,0,i,.false.,dcore,
|
|
$ dcore,.false.,nocc_a)
|
|
|
|
|
|
c dcore(ihder_dens:ihder_dens+8)=0.0d0
|
|
c call localization_gradient(natoms,dcore(ihder_dens),nocc,ca,0)
|
|
c write(*,'(3ES)') dcore(ihder_dens:ihder_dens+8)
|
|
call localization_gradient(natoms,grads(1,1,3),nocc,ca,0)
|
|
|
|
if(trim(dft).ne.'off') then
|
|
c E^XC_1(D^Atilde)
|
|
imoa=dblalloc(nbasis*nocc_a)
|
|
call motransp(nocc_a,nbasis,dcore(imoa),ca2(1,1+nocc_b),.false.)
|
|
call dscal(nbasis*nocc_a,dsqrt(2.0d0),dcore(imoa),1)
|
|
call dft_core(nbasis,nocc_a,nocc_a,tdera,tderb,dcore(imoa),
|
|
$ dcore(imoa),scrfile4,dcore,iout,exc,dft,minpfile,1,
|
|
$ ifltln,maxcor,imem,imem1,icore,verbosity,1,grads(1,1,5),
|
|
$ 'em3 ',dens2,dens2,1,1,0.d0,0)
|
|
call dbldealloc(imoa)
|
|
endif
|
|
|
|
call dbldealloc(imem_old)
|
|
do xyz=1,3
|
|
do datoms=1,ncent
|
|
grads(xyz,datoms,4)=grads(xyz,datoms,4)+
|
|
& nn_grad(coord,ncent,datoms,atchg,xyz)
|
|
enddo
|
|
enddo
|
|
if(lgradd) call dscal(3*natoms,-0.5d0,grads(1,1,3),1)
|
|
grads(:,:,8)=grads(:,:,1)+grads(:,:,2)+grads(:,:,3)+grads(:,:,4)+
|
|
$ grads(:,:,5)+grads(:,:,6)+grads(:,:,7)
|
|
|
|
dft2=ll_dft
|
|
if(ll_dft.eq.'off ') dft2=dft
|
|
call print_grad(ncent,natoms,atsymbol,efield,grads,iout,
|
|
& verbosity,scrfile3,dft2,edisp,edisp_embed,pcm)
|
|
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
double precision function nn_grad(coord,ncent,datoms,atchg,xyz)
|
|
************************************************************************
|
|
* Gradient of nuclear-nuclear repulsion
|
|
************************************************************************
|
|
implicit none
|
|
integer ncent,datoms,xyz
|
|
double precision coord(3,ncent),atchg(ncent)
|
|
|
|
integer iatoms
|
|
double precision rab3,vnn
|
|
|
|
vnn=0.d0
|
|
do iatoms=1,ncent
|
|
if(iatoms.ne.datoms) then
|
|
rab3=(dsqrt((coord(1,iatoms)-coord(1,datoms))**2+
|
|
$ (coord(2,iatoms)-coord(2,datoms))**2+
|
|
$ (coord(3,iatoms)-coord(3,datoms))**2))**3
|
|
if(dabs(rab3).gt.1d-12) vnn=vnn+atchg(iatoms)*
|
|
$ (coord(xyz,iatoms)-coord(xyz,datoms))/rab3
|
|
endif
|
|
enddo
|
|
nn_grad=vnn*atchg(datoms)
|
|
return
|
|
end function
|
|
|
|
************************************************************************
|
|
subroutine nucnuc_grad(coord,ncent,natoms,atchg,grads)
|
|
************************************************************************
|
|
* Nuclear-nuclear gradient
|
|
************************************************************************
|
|
implicit none
|
|
integer ncent,natoms
|
|
integer datoms,xyz,iatoms
|
|
double precision coord(3,ncent),atchg(ncent),grads(3,natoms),vnn
|
|
double precision rab3
|
|
|
|
do datoms=1,natoms
|
|
do xyz=1,3
|
|
vnn=0.d0
|
|
do iatoms=1,ncent
|
|
if(iatoms.ne.datoms) then
|
|
rab3=(dsqrt((coord(1,iatoms)-coord(1,datoms))**2+
|
|
$ (coord(2,iatoms)-coord(2,datoms))**2+
|
|
$ (coord(3,iatoms)-coord(3,datoms))**2))**3
|
|
if(dabs(rab3).gt.1d-12) vnn=vnn+atchg(iatoms)*
|
|
$ (coord(xyz,iatoms)-coord(xyz,datoms))/rab3
|
|
endif
|
|
enddo
|
|
grads(xyz,datoms)=grads(xyz,datoms)+vnn*atchg(datoms)
|
|
enddo
|
|
enddo
|
|
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine print_grad(ncent,natoms,atsymbol,efield,grads,iout,
|
|
& verbosity,scrfile6,dft,edisp,edisp_embed,pcm)
|
|
************************************************************************
|
|
* Printing gradient
|
|
************************************************************************
|
|
integer ncent,natoms,iout,verbosity,scrfile6
|
|
double precision efield(3,natoms),grads(3,natoms,8)
|
|
character*2 atsymbol(*)
|
|
character*32 dft,pcm
|
|
character*256 edisp,edisp_embed
|
|
|
|
integer datoms
|
|
|
|
write(iout,*)
|
|
write(iout,"(' Center Electric field [au]')")
|
|
write(iout,
|
|
$"(' x y z')")
|
|
do datoms=1,ncent
|
|
if(datoms.gt.natoms) atsymbol(datoms)=' '
|
|
write(iout,'(i5,1x,a3,3f17.10)') datoms,atsymbol(datoms),
|
|
$ efield(1,datoms),efield(2,datoms),efield(3,datoms)
|
|
enddo
|
|
write(iout,*)
|
|
C Print gradient
|
|
if(verbosity.ge.3) then
|
|
write(iout,*) 'Core Hamiltonian gradient [au]:'
|
|
do datoms=1,natoms
|
|
write(iout,'(i5,1x,a3,3f17.10)') datoms,atsymbol(datoms),
|
|
$ grads(1,datoms,1),grads(2,datoms,1),grads(3,datoms,1)
|
|
enddo
|
|
write(iout,*)
|
|
write(iout,*) 'Two-electron integral gradient [au]:'
|
|
do datoms=1,natoms
|
|
write(iout,'(i5,1x,a3,3f17.10)') datoms,atsymbol(datoms),
|
|
$ grads(1,datoms,2),grads(2,datoms,2),grads(3,datoms,2)
|
|
enddo
|
|
write(iout,*)
|
|
write(iout,*) 'Reorthonormalization gradient [au]:'
|
|
do datoms=1,natoms
|
|
write(iout,'(i5,1x,a3,3f17.10)') datoms,atsymbol(datoms),
|
|
$ grads(1,datoms,3),grads(2,datoms,3),grads(3,datoms,3)
|
|
enddo
|
|
write(iout,*)
|
|
write(iout,*) 'Nuclear repulsion gradient [au]:'
|
|
do datoms=1,natoms
|
|
write(iout,'(i5,1x,a3,3f17.10)') datoms,atsymbol(datoms),
|
|
$ grads(1,datoms,4),grads(2,datoms,4),grads(3,datoms,4)
|
|
enddo
|
|
write(iout,*)
|
|
if(trim(dft).ne.'off') then
|
|
write(iout,*) 'XC gradient [au]:'
|
|
do datoms=1,natoms
|
|
write(iout,'(i5,1x,a3,3f17.10)') datoms,atsymbol(datoms),
|
|
$ grads(1,datoms,5),grads(2,datoms,5),grads(3,datoms,5)
|
|
enddo
|
|
write(iout,*)
|
|
endif
|
|
if(trim(edisp).ne.'off'.or.trim(edisp_embed).ne.'off') then !HB
|
|
write(iout,*) 'D3 gradient [au]:'
|
|
do datoms=1,natoms
|
|
write(iout,'(i5,1x,a3,3f17.10)') datoms,atsymbol(datoms),
|
|
$ grads(1,datoms,6),grads(2,datoms,6),grads(3,datoms,6)
|
|
enddo
|
|
write(iout,*)
|
|
endif
|
|
#if defined (PCM)
|
|
if(trim(pcm).ne.'off') then
|
|
write(iout,*) 'PCM gradient [au]:'
|
|
do datoms=1,natoms
|
|
write(iout,'(i5,1x,a3,3f17.10)') datoms,atsymbol(datoms),
|
|
$ grads(1,datoms,7),grads(2,datoms,7),grads(3,datoms,7)
|
|
enddo
|
|
write(iout,*)
|
|
endif
|
|
#endif
|
|
endif
|
|
write(iout,*) 'Cartesian gradient [au]:'
|
|
open(scrfile6,file='GRAD',status='unknown',form='unformatted')
|
|
do datoms=1,natoms
|
|
write(iout,'(i5,1x,a3,3f17.10)') datoms,atsymbol(datoms),
|
|
$ grads(1,datoms,8),grads(2,datoms,8),grads(3,datoms,8)
|
|
write(scrfile6)
|
|
$ grads(1,datoms,8),grads(2,datoms,8),grads(3,datoms,8)
|
|
enddo
|
|
close(scrfile6)
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine localization_gradient(natoms,grads,nocc,mo,ialpha)
|
|
************************************************************************
|
|
* Calculates the gradient of the localization condtion (Boys only!)
|
|
************************************************************************
|
|
use common_mod, only: dcore,icore,iout,varsfile,imem,scrfile4
|
|
implicit none
|
|
integer natoms,nocc,ialpha
|
|
double precision grads(3,natoms),mo(*)
|
|
|
|
integer nangmax,ncontrmax,nprimmax,dero,iz,inatrange
|
|
integer ncartmax,nsphermax,nmboys,nbasis,nbfshmax
|
|
integer inang,incontr,inprim,igexp,igcoef,icoord,ictostr,icf,nbset
|
|
integer iboysval,iindarr,igcn,ipre,inshrange,inangmin
|
|
integer inzipr,inzjpr,inzkpr,inzlpr,inzint,iatnum,inbf,ispctostr
|
|
integer ithad,ithcf2,iscoord,irqqij,irqqkl,ihrec,iatchg,ncent,iebf
|
|
integer necpatoms,iecpn,iecpnang,iecpprim,iecpexp,iecpcoef,ispre
|
|
integer iecpatoms,nbfatmax
|
|
real*8 itol
|
|
logical cartg,lecp
|
|
|
|
integer dblalloc,intalloc
|
|
|
|
dero=1
|
|
iz=dblalloc(nocc*(nocc-1)/2)
|
|
open(varsfile,file='VARS',form='UNFORMATTED')
|
|
call tedatr(varsfile,natoms,nangmax,ncontrmax,nprimmax,ncartmax,
|
|
$ cartg,nsphermax,nmboys,nbasis,itol,nbfshmax,inang,incontr,
|
|
$ inprim,igexp,igcoef,icoord,ictostr,icf,iboysval,iindarr,igcn,
|
|
$ ipre,inshrange,inangmin,iatnum,icore,dcore,inzipr,inzjpr,
|
|
$ inzkpr,inzlpr,inzint,ithad,ithcf2,iscoord,irqqij,irqqkl,
|
|
$ ihrec,iout,dero,nbset,inbf,ispctostr,iatchg,ncent,iebf,
|
|
$ necpatoms,iecpn,iecpnang,iecpprim,iecpexp,iecpcoef,iecpatoms,
|
|
$ lecp,nbfatmax,ispre)
|
|
close(varsfile)
|
|
|
|
|
|
inatrange=intalloc(2*natoms*nbset)
|
|
call getvar('natrange ',icore(inatrange))
|
|
call dloc(nbasis,nocc,mo,dcore(iz),grads,natoms,nangmax,ncontrmax,
|
|
& nprimmax,ncartmax,nsphermax,icore(inang),icore(inangmin),
|
|
& icore(incontr),icore(inprim),dcore(igexp),dcore(igcoef),
|
|
& dcore(icoord),dcore(ictostr),icore(igcn),icore(inshrange),
|
|
& icore(inatrange),cartg,ialpha,dcore,imem,scrfile4)
|
|
call dbldealloc(iz)
|
|
end subroutine
|
|
|
|
|
|
************************************************************************
|
|
subroutine factor_dens(nbasis,nocc_p,nocc_m,dens2,sder,itol)
|
|
************************************************************************
|
|
* factorize a general symmteric matrix to A=P*P'-M*M' form where
|
|
* P and M are matrices constructed from the eigenvectors of A
|
|
* P=V*sqrt(w): where w contains the positive eigenvalues and V stores
|
|
* the corresponding eigenvectors
|
|
* M=V*sqtr(-w): same as P with the negative eigenvalues/eigenvectors
|
|
************************************************************************
|
|
use common_mod, only: dcore
|
|
implicit none
|
|
integer nbasis,nocc_p,nocc_m
|
|
double precision dens2(nbasis,nbasis),sder(nbasis,nbasis,3),itol
|
|
|
|
integer info,iw,iwork,lwork,i
|
|
integer dblalloc,intalloc
|
|
double precision w
|
|
|
|
call dcopy(nbasis**2,dens2,1,sder,1)
|
|
iw=dblalloc(nbasis)
|
|
call dsyev('v','u',nbasis,sder,nbasis,dcore(iw),dcore(iw),-1,info)
|
|
lwork=int(dcore(iw))
|
|
iwork=intalloc(lwork)
|
|
call dsyev('v','u',nbasis,sder,nbasis,dcore(iw),dcore(iwork),
|
|
& lwork,info)
|
|
|
|
nocc_p=0
|
|
nocc_m=0
|
|
do i=1,nbasis
|
|
w=dcore(iw+i-1)
|
|
if(dabs(w)>itol) then
|
|
if(w > 0.0d0) then
|
|
nocc_p=nocc_p+1
|
|
sder(:,nocc_p,3)=sder(:,i,1)*sqrt(w)
|
|
elseif(w < 0.0d0) then
|
|
nocc_m=nocc_m+1
|
|
sder(:,nocc_m,2)=sder(:,i,1)*sqrt(-w)
|
|
endif
|
|
endif
|
|
enddo
|
|
call dcopy(nbasis*nocc_p,sder(1,1,3),1,sder(1,1,1),1)
|
|
|
|
call dbldealloc(iw)
|
|
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine mp2_amat(nbasis,dfnbasis,ncore,nval,nvirt,amat,mo,dft,
|
|
& chfx,cmp2)
|
|
************************************************************************
|
|
* MP2 A matrix: The derivative of the full MP2 energy wrt the MOs
|
|
************************************************************************
|
|
use embed_grad, only: nocc_b
|
|
use common_mod, only: dcore,imem,scrfile1,scrfile1,scrfile2,
|
|
& scrfile3,scrfile4,scrfile5,densfile,ifltln
|
|
implicit none
|
|
integer nbasis,dfnbasis,ncore,nval,nvirt
|
|
double precision amat(nbasis-nocc_b,nbasis-nocc_b),chfx,cmp2
|
|
double precision mo(nbasis,nbasis)
|
|
character*32 dft
|
|
|
|
integer i,j,ii,jj,a,nocc,nocc2,imem_old,nf
|
|
integer ixp,iyia,ipal,ijai,ixlp,ijpij,ie,ief,ieo,iev,idens
|
|
integer nbla,nblla,nblocka,nblva,nbllva,nblockva
|
|
integer ipmat,itemp
|
|
integer dblalloc
|
|
|
|
imem_old=imem
|
|
|
|
open(scrfile1,file='DFINT_AI_SCF',form='unformatted')
|
|
open(scrfile2,file='DFINT_IJ_SCF',form='unformatted')
|
|
open(scrfile3,file='DFINT_AB_SCF',form='unformatted')
|
|
|
|
c In the case of regular MP2 gradient
|
|
c ncore -> core orbitals
|
|
c nval -> valence orbitals
|
|
c nocc -> core+valence orbitals
|
|
c nf -> Number of orbitals (occ+virt)
|
|
c nocc_b -> 0 (there is no environment)
|
|
|
|
c In the case of embedding:
|
|
c ncore -> core subsystem orbitals
|
|
c nval -> valence subsystem orbitals
|
|
c nocc -> core+valence subsystem orbitals
|
|
c nf -> Number of subsystem orbitals (occ+virt)
|
|
c nocc_b -> environment orbitals
|
|
|
|
c Warning! : The environment orbitals cannot be regarded as core
|
|
c orbitals because they do not contribute to the high level SCF
|
|
c density. Although they contribute to the high level Fock matrix
|
|
c through the embedding potential, they do not appear in the
|
|
c high level Coulomb, exchange or XC energies/matrices.
|
|
|
|
nf=nbasis-nocc_b
|
|
nocc=nval+ncore
|
|
nocc2=nocc+nocc_b
|
|
ipmat=dblalloc(nbasis*nbasis) ! MP2 density
|
|
itemp=dblalloc(nbasis*nbasis)
|
|
call dfillzero(amat,nf**2)
|
|
call dfillzero(dcore(ipmat),nbasis*nbasis)
|
|
|
|
c Reading the MP2 density matrix and storing it in ipmat
|
|
open(unit=densfile,file='CCDENSITIES',form='unformatted')
|
|
call roeint(dcore(imem),dcore(imem),dcore(itemp),densfile,nvirt)
|
|
call dscal(nvirt*nvirt,2.0d0,dcore(itemp),1)
|
|
call dlacpy('f',nvirt,nvirt,dcore(itemp),nvirt,
|
|
& dcore(ipmat+nocc2+nocc2*nbasis),nbasis)
|
|
|
|
call roeint(dcore(imem),dcore(imem),dcore(itemp),densfile,nval)
|
|
call dscal(nval*nval,2.0d0,dcore(itemp),1)
|
|
call dlacpy('f',nval,nval,dcore(itemp),nval,
|
|
& dcore(ipmat+ncore+nocc_b+(ncore+nocc_b)*nbasis),nbasis)
|
|
|
|
read(densfile) !gamma^PQ
|
|
|
|
c Reading the T dependent parts of the derivative of the Hylleraas func.
|
|
c Derivatives are wrt. the MO orbitals
|
|
call rtdmx(dcore(imem),dcore(imem),dcore(itemp),densfile,
|
|
& nvirt,nbasis) !L"_ap
|
|
do i=1,nvirt
|
|
do j=1,nf
|
|
amat(j,nocc+i)=amat(j,nocc+i)+
|
|
& 4.0d0*dcore(itemp+i-1+(j+nocc_b-1)*nvirt)
|
|
enddo
|
|
enddo
|
|
|
|
call rtdmx(dcore(imem),dcore(imem),dcore(itemp),densfile,
|
|
& nval,nbasis) !lip
|
|
do i=1,nval
|
|
do j=1,nf
|
|
amat(j,ncore+i)=amat(j,ncore+i)+
|
|
& 4.0d0*dcore(itemp+i-1+(j+nocc_b-1)*nval)
|
|
enddo
|
|
enddo
|
|
|
|
close(densfile)
|
|
|
|
call dbldealloc(itemp)
|
|
|
|
c Calculating the contribution from the derivative of the MO Fock matrix
|
|
c First step: calculating the contribution from the AO Fock matrix
|
|
c the virt-virt and occ-virt parts vanish because the Fock matrix
|
|
c does not depend on the virtual orbitals
|
|
call getvar('nblascf ',nbla)
|
|
call getvar('nbllascf ',nblla)
|
|
call getvar('nblockascf',nblocka)
|
|
call getvar('nblvascf ',nblva)
|
|
call getvar('nbllvascf ',nbllva)
|
|
call getvar('nblockvasc',nblockva)
|
|
|
|
ixp=dblalloc(dfnbasis)
|
|
iyia=dblalloc(max(nocc2*nvirt,nocc2*nocc2))
|
|
ijai=dblalloc(max(nvirt*nbla*dfnbasis,
|
|
$ nbla*nocc2*dfnbasis,nvirt*nblva*dfnbasis,
|
|
$ nocc2*nblva*dfnbasis,nbasis**2))
|
|
ixlp=dblalloc(max(nbla*nocc2*dfnbasis,nbla*nvirt*dfnbasis,
|
|
$ nblva*nocc2*dfnbasis))
|
|
ijpij=dblalloc(max(nbla*nbasis*dfnbasis,nblva*nvirt*dfnbasis))
|
|
|
|
c virt-occ part
|
|
call lapqconst(scrfile1,scrfile2,scrfile3,scrfile4,scrfile5,
|
|
$dcore(imem),nbasis-ncore-nocc_b,ncore+nocc_b,nval,nbla,nblla,
|
|
$nblocka,nvirt,nblva,nbllva,nblockva,dfnbasis,ifltln,dcore,
|
|
$dcore,dcore,dcore(ipmat),dcore(ijai),dcore(ijai),
|
|
$dcore(ijai),dcore(ixp),dcore(ixlp),dcore(ixlp),dcore(ixlp),
|
|
$dcore(ijpij),dcore(ijpij),dcore(ijai),dcore(iyia),chfx)
|
|
|
|
do i=1,nocc
|
|
do a=1,nvirt
|
|
amat(nocc+a,i)=amat(nocc+a,i)+
|
|
& dcore(iyia+nocc_b+i-1+(a-1)*nocc2)
|
|
enddo
|
|
enddo
|
|
|
|
c occ-occ part
|
|
ipal=dblalloc(nvirt*nocc)
|
|
call dfillzero(dcore(ipal),nvirt*nocc)
|
|
call lmpqconst(scrfile1,scrfile2,scrfile3,scrfile4,scrfile5,
|
|
$dcore(imem),nbasis-ncore,ncore,nval,nbla,nblla,nblocka,nvirt,
|
|
$nblva,nbllva,nblockva,dfnbasis,ifltln,dcore,dcore,
|
|
$dcore,dcore(ipmat),dcore(ipal),dcore(ijai),dcore(ijai),
|
|
$dcore(ijai),dcore(ijai),dcore(ixp),dcore(ixlp),dcore(ixlp),
|
|
$dcore(ixlp),dcore(ixlp),dcore(ijpij),dcore(ijai),dcore(iyia),chfx)
|
|
|
|
do i=1,nocc
|
|
do j=1,nocc
|
|
amat(i,j)=amat(i,j)+dcore(iyia+nocc_b+i-1+(nocc_b+j-1)*nocc2)
|
|
enddo
|
|
enddo
|
|
|
|
if(trim(dft).ne.'off') then
|
|
idens=dblalloc(nbasis*nbasis)
|
|
call dgemm('n','n',nbasis,nbasis,nbasis,1.0d0,mo,nbasis,
|
|
& dcore(ipmat),nbasis,0.0d0,dcore(ijai),nbasis)
|
|
call dgemm('n','t',nbasis,nbasis,nbasis,1.0d0,dcore(ijai),
|
|
& nbasis,mo,nbasis,0.0d0,dcore(idens),nbasis)
|
|
call symmat(dcore(idens),nbasis)
|
|
call dfillzero(dcore(ijai),nbasis**2)
|
|
call amat_embed_dft2(nbasis,ncore+nval,dcore(idens),mo,
|
|
& dcore(ijai),dft)
|
|
call dgemm('n','n',nbasis,nocc,nbasis,1.0d0,dcore(ijai),
|
|
& nbasis,mo,nbasis,0.0d0,dcore(idens),nbasis)
|
|
call dgemm('t','n',nbasis,nocc,nbasis,1.0d0,mo,nbasis,
|
|
& dcore(idens),nbasis,1.0d0,amat,nbasis)
|
|
call dbldealloc(idens)
|
|
endif
|
|
|
|
|
|
c Second step: Contributions from the MOs, only the diagonal blocks remain
|
|
ie=dblalloc(nbasis)
|
|
ief=ie+nocc_b
|
|
ieo=ief+ncore
|
|
iev=ieo+nval
|
|
open(unit=densfile,file='FOCK',form='unformatted')
|
|
read(densfile)
|
|
read(densfile) (dcore(ie+i-1),i=1,nbasis)
|
|
close(densfile)
|
|
c occ-occ part of 2*f*d
|
|
do i=ncore+1,nocc
|
|
ii=i+nocc_b
|
|
amat(i,i)=amat(i,i)+
|
|
& 2.0d0*dcore(ie+ii-1)*dcore(ipmat+ii-1+(ii-1)*nbasis)
|
|
do j=ncore+1,i-1
|
|
jj=j+nocc_b
|
|
amat(i,j)=amat(i,j)+
|
|
& 2.0d0*dcore(ie+ii-1)*dcore(ipmat+ii-1+(jj-1)*nbasis)
|
|
amat(j,i)=amat(j,i)+
|
|
& 2.0d0*dcore(ie+jj-1)*dcore(ipmat+jj-1+(ii-1)*nbasis)
|
|
enddo
|
|
enddo
|
|
|
|
c virt-virt part of 2*f*d
|
|
do i=nocc+1,nf
|
|
ii=i+nocc_b
|
|
amat(i,i)=amat(i,i)+
|
|
& 2.0d0*dcore(ie+ii-1)*dcore(ipmat+ii-1+(ii-1)*nbasis)
|
|
do j=nocc+1,i-1
|
|
jj=j+nocc_b
|
|
amat(i,j)=amat(i,j)+
|
|
& 2.0d0*dcore(ie+ii-1)*dcore(ipmat+ii-1+(jj-1)*nbasis)
|
|
amat(j,i)=amat(j,i)+
|
|
& 2.0d0*dcore(ie+jj-1)*dcore(ipmat+jj-1+(ii-1)*nbasis)
|
|
enddo
|
|
enddo
|
|
|
|
c write(*,*) 'cmp2',cmp2
|
|
if(cmp2.ne.1.0d0) call dscal(nf**2,cmp2,amat,1)
|
|
|
|
c Adding contribution from the HF energy
|
|
do i=1,nocc
|
|
amat(i,i)=amat(i,i)+4.0d0*dcore(ief+i-1)
|
|
enddo
|
|
|
|
c write(*,*) 'amat occ-occ'
|
|
c call prmx_ldf(amat,nbasis,nocc,nocc)
|
|
c
|
|
c write(*,*) 'amat virt-virt'
|
|
c call prmx_ldf(amat(1+nocc,1+nocc),nbasis,nvirt,nvirt)
|
|
c
|
|
c write(*,*) 'amat virt-occ'
|
|
c call prmx_ldf(amat(1+nocc,1),nbasis,nvirt,nocc)
|
|
|
|
close(scrfile1)
|
|
close(scrfile2)
|
|
close(scrfile3)
|
|
|
|
call dbldealloc(imem_old)
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine mp2_zvec(ncore2,nval2,nvirt2,amat,acv,zmat,zcv,dft,
|
|
& chfx,cmp2)
|
|
************************************************************************
|
|
* MP2 Z vector
|
|
************************************************************************
|
|
use common_mod, only: nbasis,dfnbasis,densfile,dcore,scfalg
|
|
use embed_grad, only: pcm,nocc_b
|
|
implicit none
|
|
integer ncore2,nval2,nvirt2
|
|
integer ncore,nval,nvirt
|
|
double precision amat(nbasis,nbasis),zmat(nvirt2,nval2+ncore2)
|
|
double precision zcv(ncore2,nval2),acv(*)
|
|
double precision cmp2,chfx
|
|
character*32 dft
|
|
|
|
integer i,j,ieig,ieo,iacv_ao,imo,nocc,nf
|
|
integer dblalloc
|
|
double precision clrhfx,csrhfx,omega
|
|
character*16 fock_file,mo_file
|
|
logical lcv
|
|
|
|
ncore=ncore2
|
|
nval=nval2
|
|
nvirt=nvirt2
|
|
nocc=ncore+nval
|
|
nf=nbasis-nocc_b
|
|
|
|
call getvar('clrhfx ',clrhfx)
|
|
call getvar('csrhfx ',csrhfx)
|
|
call getvar('omega ',omega)
|
|
|
|
fock_file='FOCK '
|
|
mo_file='MOCOEF '
|
|
imo=dblalloc(nbasis*nbasis)
|
|
call read_from_disk(mo_file,dcore(imo),nbasis,.false.)
|
|
call mp2_amat(nbasis,dfnbasis,ncore,nval,nvirt,amat,dcore(imo),
|
|
& dft,chfx,cmp2)
|
|
c core-valence separation part
|
|
lcv=ncore.gt.0
|
|
if(lcv) then
|
|
ieig=dblalloc(nbasis)
|
|
ieo=ieig+nocc_b
|
|
open(unit=densfile,file='FOCK',form='unformatted')
|
|
read(densfile)
|
|
read(densfile) (dcore(ieig+i-1),i=1,nbasis)
|
|
close(densfile)
|
|
do j=1,nval
|
|
do i=1,ncore
|
|
zcv(i,j)=-(amat(i,j+ncore)-amat(j+ncore,i))/
|
|
& (dcore(ieo+i-1)-dcore(ieo+j+ncore-1))
|
|
enddo
|
|
enddo
|
|
iacv_ao=dblalloc(nbasis*nocc)
|
|
call dfillzero(dcore(iacv_ao),nbasis*nocc)
|
|
call aloc_core_val(nbasis,dfnbasis,ncore,nval,zcv,
|
|
& dcore(imo+nocc_b*nbasis),scfalg,chfx,csrhfx,clrhfx,omega,
|
|
& pcm,dft,dcore(iacv_ao),fock_file)
|
|
call dgemm('t','n',nf,nocc,nbasis,1.0d0,
|
|
& dcore(imo+nocc_b*nbasis),nbasis,dcore(iacv_ao),nbasis,
|
|
& 0.0d0,acv,nf)
|
|
endif
|
|
call dbldealloc(imo)
|
|
call solve_bri(nbasis,zmat,amat,acv,fock_file,mo_file,lcv)
|
|
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine mp2_xmat(nbasis,dfnbasis,ncore,nocc,nvirt,zmat,zcv,
|
|
& xmat,acv)
|
|
************************************************************************
|
|
* Calculates the lagrange multiplier of the orthogonality condition
|
|
************************************************************************
|
|
use embed_grad, only: ll_dft,npos,ll_chfx,ll_clrhfx,ll_csrhfx,
|
|
& omega,pcm,ll_dft,nocc_b
|
|
use common_mod, only: dcore,imem,scfalg
|
|
implicit none
|
|
integer nbasis,dfnbasis,nocc,nvirt,ncore,nf
|
|
double precision zmat(nvirt,nocc),zcv(ncore,nocc-ncore)
|
|
double precision acv(nocc+nvirt,nocc)
|
|
double precision xmat(nocc+nvirt,nocc+nvirt) ! on input it is the A matrix
|
|
|
|
integer ifock,iatilde,imo
|
|
integer dblalloc
|
|
|
|
nf=nocc+nvirt
|
|
ifock=dblalloc(nbasis*nbasis)
|
|
imo=dblalloc(nbasis*nbasis)
|
|
iatilde=dblalloc(nbasis*nbasis)
|
|
call read_from_disk('FOCK ',dcore(ifock),nbasis,.true.)
|
|
call read_from_disk('MOCOEF ',dcore(imo),nbasis,.false.)
|
|
c Calculating Atilde
|
|
call build_atilde_embed(nbasis,dfnbasis,nocc,nvirt,zmat,
|
|
& dcore(imo+nocc_b*nbasis),dcore(ifock),npos,iatilde,ll_chfx,
|
|
& ll_csrhfx,ll_clrhfx,omega,pcm,ll_dft)
|
|
c transforming Atilde to MO basis and adding it to A
|
|
call dgemm('t','n',nf,nf,nbasis,1.0d0,dcore(imo+nocc_b*nbasis),
|
|
& nbasis,dcore(iatilde),nbasis,1.0d0,xmat,nf)
|
|
c Adding the core-valence separation contribution
|
|
if(ncore.gt.0) call daxpy(nf*nocc,1.0d0,acv,1,xmat,1)
|
|
|
|
c x=-0.5*(A+Atilde)
|
|
c In the code -2*Tr{x*S'} is calculated instead of Tr{x*S'}
|
|
c => we have to devide x by -2 => x=0.25*(A+Atilde)
|
|
call dscal(nf*nf,0.25d0,xmat,1)
|
|
call symmat(xmat,nf)
|
|
|
|
call dbldealloc(ifock)
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine mp2_grad(natoms,ncent,nbasis,dfnbasis,dfnbasis_cor,
|
|
& ncore,nocc,nvirt,zmat,zcv,xmat,mo,chfx,itol,cmp2,grads,efield,
|
|
& ctol,atsymbol,atchg,natrange)
|
|
************************************************************************
|
|
* Calculates the MP2 energy gradient from the Lagrange multipliers
|
|
************************************************************************
|
|
use domain, only: domain_type
|
|
use common_mod, only: dcore,icore,imem,densfile,iout,varsfile,
|
|
& oeintfile,scrfile3,scrfile4,scrfile5,nbset,maxcor,tedatfile,
|
|
& minpfile,irecln,ifltln,nbf,nfroz
|
|
implicit none
|
|
integer ncore,nocc,nvirt,nbasis,natoms,ncent,dfnbasis,dfnbasis_cor
|
|
integer natrange(2,natoms,*),verbosity
|
|
double precision zmat(nvirt,nocc),xmat(nbasis*nbasis)
|
|
double precision mo(nbasis,nocc+nvirt),zcv(ncore,nocc-ncore)
|
|
double precision grads(3,natoms,8),efield(3,natoms)
|
|
double precision chfx,cmp2,ctol,itol,atchg(ncent)
|
|
character*2 atsymbol(natoms)
|
|
|
|
integer imem_old,idens,idens2,ihder,isder,ixvec
|
|
integer igrad_tmp,icoord,iatchg,imoa,ifock,ixdip
|
|
integer nval,nf,ialpha,idummy,hailen,scft,imem1,datoms,xyz
|
|
integer irf,idscfaao,ieoa,ciscont,is,mnbasis,idistc,ihmat2
|
|
integer dblalloc
|
|
double precision csrhfx,clrhfx,omega
|
|
double precision dipx,dipy,dipz
|
|
double precision tegrad(3),exc
|
|
character*5 cscr4
|
|
character*5 scftype
|
|
character*8 embed,popul,qmreg,grdens,rism
|
|
character*16 calctype
|
|
character*20 dfbasis_scf
|
|
character*32 dft
|
|
type(domain_type) dom
|
|
logical ldf,lgradd
|
|
common/memcom/ imem1
|
|
|
|
interface
|
|
subroutine fock_der(nbasis,dfnbasis,nocc,densa,densb,dens2,
|
|
& xveca,scftype,dero,ca,ldf,dom,ctol,chfx,clrhfx,csrhfx,omega,
|
|
& itol,natoms,ncent,efield,grads,sder)
|
|
use domain, only: domain_type
|
|
implicit none
|
|
integer nbasis,dfnbasis,nocc,dero,ncent,natoms,locfit
|
|
double precision densa(nbasis,nbasis),densb(nbasis,nbasis)
|
|
double precision dens2(nbasis,nbasis),xveca(dfnbasis,4)
|
|
double precision, target :: ca(nbasis,nocc)
|
|
double precision, target :: sder(nbasis,nbasis,3)
|
|
double precision efield(3,ncent),grads(3,natoms,8)
|
|
double precision ctol,chfx,csrhfx,clrhfx,itol,omega
|
|
character*5 scftype
|
|
logical ldf
|
|
type(domain_type) dom
|
|
end subroutine
|
|
end interface
|
|
|
|
imem_old=imem
|
|
|
|
ialpha=0
|
|
ciscont=1
|
|
nval=nocc-ncore
|
|
nf=nocc+nvirt
|
|
call getkey('dfbasis_scf',11,dfbasis_scf,20)
|
|
call getkey('dft',3,dft,32)
|
|
call getkey('scftype',7,scftype,5)
|
|
call getvar('clrhfx ',clrhfx)
|
|
call getvar('csrhfx ',csrhfx)
|
|
call getvar('omega ',omega)
|
|
call getkey('embed',5,embed,8)
|
|
call getkey('popul',5,popul,8)
|
|
call getkey('calc',4,calctype,16)
|
|
call getkey('grdens',6,grdens,8)
|
|
open(minpfile,file='MINP')
|
|
call getkeym('qmreg',5,qmreg,8)
|
|
close(minpfile)
|
|
call getkey('verbosity',9,cscr4,4)
|
|
read(cscr4,*) verbosity
|
|
mnbasis=nbf(4)
|
|
call alloc_zero_domains(dom,natoms,nocc,nbasis,dfnbasis,icore,
|
|
& imem)
|
|
call dfillzero(grads,3*8*natoms)
|
|
idens=dblalloc(nbasis*nbasis)
|
|
|
|
c Transforming x to AO basis
|
|
call dgemm('n','n',nbasis,nf,nf,1.0d0,mo,nbasis,
|
|
& xmat,nf,0.0d0,dcore(idens),nbasis)
|
|
call dgemm('n','t',nbasis,nbasis,nf,1.0d0,dcore(idens),nbasis,
|
|
& mo,nbasis,0.0d0,xmat,nbasis)
|
|
|
|
c Building density matrices for gradient calculation
|
|
c 1.) In the Hylleraas functional the MP2 density multiplies the Fock matrix
|
|
c 2.) In the Brillouin condition the z multiplies the Fock matrix
|
|
c 3.) In the HF energy the HF density multiplies the Fock matrix
|
|
c 4.) The core-valence seapration multipleier multiples the Fock matrix
|
|
c
|
|
c Here we add together these contributions to idens2.
|
|
c In the case of embedding the density is an nf*nf matrix (in MO basis)
|
|
c because we do not have to take into account the environment orbitals.
|
|
c However, in AO basis its size is still nbasis*nbasis
|
|
|
|
idens2=dblalloc(nbasis*nbasis)
|
|
call dfillzero(dcore(idens2),nbasis*nbasis)
|
|
|
|
c Reading the MP2 density matrix
|
|
open(unit=densfile,file='CCDENSITIES',form='unformatted')
|
|
call roeint(dcore(imem),dcore(imem),dcore(idens),densfile,nvirt)
|
|
call dscal(nvirt*nvirt,2.0d0*cmp2,dcore(idens),1)
|
|
call dlacpy('f',nvirt,nvirt,dcore(idens),nvirt,
|
|
& dcore(idens2+nocc+nocc*nf),nf)
|
|
|
|
call roeint(dcore(imem),dcore(imem),dcore(idens),densfile,nval)
|
|
call dscal(nval*nval,2.0d0*cmp2,dcore(idens),1)
|
|
call dlacpy('f',nval,nval,dcore(idens),nval,
|
|
& dcore(idens2+ncore+ncore*nf),nf)
|
|
close(densfile)
|
|
|
|
c Adding the z multiplier (Brillouin condition)
|
|
call dlacpy('f',nvirt,nocc,zmat,nvirt,dcore(idens2+nocc),nf)
|
|
|
|
c Adding the core-valence separation multiplier
|
|
if(ncore.gt.0) then
|
|
call dlacpy('f',ncore,nval,zcv,ncore,dcore(idens2+ncore*nf),nf)
|
|
endif
|
|
|
|
c Transforming the density to AO basis
|
|
call dgemm('n','n',nbasis,nf,nf,1.0d0,mo,nbasis,
|
|
& dcore(idens2),nf,0.0d0,dcore(idens),nbasis)
|
|
call dgemm('n','t',nbasis,nbasis,nf,1.0d0,dcore(idens),nbasis,
|
|
& mo,nbasis,0.0d0,dcore(idens2),nbasis)
|
|
call symmat(dcore(idens2),nbasis)
|
|
|
|
c We save the SCF AO density to idens
|
|
call dsyrk('u','n',nbasis,nocc,2.0d0,mo,nbasis,0.0d0,dcore(idens),
|
|
& nbasis)
|
|
call filllo(dcore(idens),nbasis)
|
|
|
|
c Calculating properties
|
|
call daxpy(nbasis**2,1.0d0,dcore(idens),1,dcore(idens2),1)
|
|
isder=dblalloc(nbasis*nbasis*3)
|
|
ihder=dblalloc(nbasis*nbasis*3)
|
|
idscfaao=dblalloc(nbasis*nbasis*ciscont)
|
|
irf=dblalloc(nbasis*nbasis)
|
|
imoa=dblalloc(nbasis*nocc)
|
|
ifock=dblalloc(nbasis*nbasis*ciscont)
|
|
is=dblalloc(nbasis**2)
|
|
idistc=dblalloc(natoms**2)
|
|
icoord=dblalloc(3*natoms)
|
|
ixdip=dblalloc(nbasis**2)
|
|
ieoa=dblalloc(nocc)
|
|
ixdip=dblalloc(nbasis*nbasis)
|
|
call getvar('coord ',dcore(icoord))
|
|
call getkey('rism',4,rism,8)
|
|
ihmat2=imem
|
|
if(rism.ne.'off ') ihmat2=dblalloc(nbasis*nbasis)
|
|
call props(nbasis,dcore(imem),dcore(imem),dcore(isder),
|
|
& dcore(ihder),dcore(idscfaao),dcore(irf),scftype,
|
|
& dcore(idscfaao),dcore(idscfaao),mo,mo,ciscont,dft,
|
|
& embed,dfbasis_scf,nocc-ncore,nocc-ncore,dcore(imoa),
|
|
& dcore(imoa),dcore(ifock),dcore(ifock),dcore(ieoa),
|
|
& dcore(ieoa),dcore(is),popul,mnbasis,nocc-ncore,natoms,
|
|
& atsymbol,atchg,ncent,natrange,natrange(1,1,4),dcore(idistc),
|
|
& verbosity,dcore(icoord),nfroz,dcore(ixdip),dipx,dipy,dipz,
|
|
& qmreg,calctype,lgradd,grdens,dcore(ihmat2),dcore(idens2))
|
|
call daxpy(nbasis**2,-1.0d0,dcore(idens),1,dcore(idens2),1)
|
|
call dbldealloc(isder)
|
|
|
|
c Adding DFT contribution to gradient
|
|
if(trim(dft).ne.'off') then
|
|
c 1/2) SCF energy contribution
|
|
scft=3
|
|
if(scftype.eq.'rhf ') scft=1
|
|
if(scftype.eq.'uhf ') scft=2
|
|
ifock=dblalloc(nbasis*nbasis)
|
|
imoa=dblalloc(nbasis*nocc)
|
|
call motransp(nocc,nbasis,dcore(imoa),mo,.false.)
|
|
call dscal(nbasis*nocc,dsqrt(2.0d0),dcore(imoa),1)
|
|
call dft_core(nbasis,nocc,nocc,dcore(ifock),dcore(ifock),
|
|
& dcore(imoa),dcore(imoa),scrfile5,dcore,iout,exc,dft,
|
|
& minpfile,scft,ifltln,maxcor,imem,imem1,icore,0,1,
|
|
& grads(1,1,5),' ',dcore(idens),dcore(idens),1,1,0.d0,0)
|
|
|
|
c 2/2) KS matrix contribution (It comes from both the Hylleraas
|
|
c functional and the Brillouin condition)
|
|
igrad_tmp=dblalloc(3*natoms)
|
|
call dvxc(nbasis,nocc,nocc,dcore(ifock),dcore(ifock),
|
|
& dcore(imoa),dcore(imoa),scrfile5,dcore,iout,exc,dft,
|
|
& minpfile,scft,ifltln,maxcor,imem,icore,0,2,
|
|
& dcore(igrad_tmp),'grad',dcore(idens2),dcore(idens2),
|
|
& mo,mo,dcore(idens2),dcore(idens2),dcore,dcore,200,0,1,1,1)
|
|
call dscal(nbasis**2,0.5d0,dcore(idens2),1)
|
|
call daxpy(3*natoms,0.5d0,dcore(igrad_tmp),1,grads(1,1,2),1)
|
|
call dbldealloc(ifock)
|
|
endif
|
|
|
|
c Adding the SCF density to idens2
|
|
call daxpy(nbasis*nbasis,1.0d0,dcore(idens),1,dcore(idens2),1)
|
|
|
|
c Calculating one-electron integral gradients
|
|
ldf=dfbasis_scf.ne.'none '
|
|
isder=dblalloc(3*nbasis*nbasis)
|
|
ihder=dblalloc(3*nbasis*nbasis)
|
|
call oe_grad_tedat(nbasis,natoms,grads,nocc,mo,ialpha,2,2,
|
|
& dcore(isder),dcore(ihder),xmat,dcore(idens2),dcore(idens2),
|
|
& efield,scftype,1,0,.true.,.false.,.true.,ldf,.true.,.false.,
|
|
& .false.)
|
|
call dbldealloc(ihder)
|
|
|
|
c Calculating contribution from the MP2 amplitudes
|
|
dom%dfnmobasis=dfnbasis_cor ! we need the corr fitting basis set
|
|
igrad_tmp=dblalloc(3*natoms*8)
|
|
call dfillzero(dcore(igrad_tmp),3*natoms*8)
|
|
call direct_fock_build(dcore(idens2),dcore(idens2),dcore,dcore,
|
|
& dcore,100,scftype,2,1,idummy,dcore(isder),dcore,
|
|
& mo(1,ncore+1),.true.,dcore,dcore,dcore,tegrad,hailen,idummy,
|
|
& idummy,dom%moadd,dom%dfnmobasis,ctol,.false.,dcore,0,1.d0,
|
|
& iout,varsfile,icore,dcore,nbset,oeintfile,nval,scrfile3,
|
|
& scrfile4,maxcor,imem,tedatfile,dfnbasis_cor,nbasis,4,
|
|
& dcore,minpfile,.false.,1,dcore,irecln,1,.false.,0,0,0,
|
|
& 1.d0,dcore(idens2),1,dcore,0,0,dom%nmobasis,idummy,idummy,
|
|
& idummy,idummy,idummy,idummy,idummy,0.d0,0.d0,0.d0,.true.,
|
|
& dcore(igrad_tmp),dcore,dcore,idummy,.false.,.false.,dcore,
|
|
& .false.,.false.,0,idummy,.false.,dcore,dcore,.false.,
|
|
& .false.,nval)
|
|
call daxpy(3*natoms*8,cmp2,dcore(igrad_tmp),1,grads,1)
|
|
call dbldealloc(igrad_tmp)
|
|
dom%dfnmobasis=dfnbasis
|
|
|
|
c Calculating 2-electron integral gradient (Contributions from the SCF
|
|
c energy and the Fock matrix)
|
|
c Scaling density matrices for gradient calculation
|
|
call dscal(nbasis**2,2.0d0,dcore(idens2),1)
|
|
call daxpy(nbasis**2,-1.0d0,dcore(idens),1,dcore(idens2),1)
|
|
|
|
ixvec=dblalloc(4*dfnbasis)
|
|
call fock_der(nbasis,dfnbasis,nocc,dcore(idens),dcore(idens),
|
|
& dcore(idens2),dcore(ixvec),scftype,1,mo,ldf,dom,ctol,chfx,
|
|
& clrhfx,csrhfx,omega,itol,natoms,ncent,efield,grads,
|
|
& dcore(isder))
|
|
|
|
c Adding nuclear-nuclear repulsion gradient
|
|
icoord=dblalloc(3*ncent)
|
|
iatchg=dblalloc(ncent)
|
|
call getvar('coord ',dcore(icoord))
|
|
call getvar('atchg ',dcore(iatchg))
|
|
call nucnuc_grad(dcore(icoord),ncent,natoms,dcore(iatchg),
|
|
& grads(1,1,4))
|
|
|
|
c Summing up gradient contributions
|
|
do datoms=1,natoms
|
|
do xyz=1,3
|
|
grads(xyz,datoms,8)=grads(xyz,datoms,1)+grads(xyz,datoms,2)+
|
|
$ grads(xyz,datoms,3)+grads(xyz,datoms,4)+grads(xyz,datoms,5)+
|
|
$ grads(xyz,datoms,6)+grads(xyz,datoms,7)
|
|
enddo
|
|
enddo
|
|
|
|
call dbldealloc(imem_old)
|
|
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine mp2_gradient(scftol,itol,scfdamp,ncore,nocc,nvirt,dft,
|
|
& chfx,cmp2,natoms,ncent,zmat,zcv,efield,grads,atsymbol,atchg,
|
|
& natrange)
|
|
************************************************************************
|
|
* Driver routine for MP2 gradient calculation
|
|
************************************************************************
|
|
use common_mod, only: dcore,imem,nbasis,dfnbasis,mocoeffile,nbf
|
|
implicit none
|
|
integer ncore,nocc,nvirt,natoms,ncent,natrange(2,natoms,*)
|
|
double precision scftol,itol,chfx,cmp2
|
|
double precision efield(3,ncent),grads(3,natoms,8)
|
|
double precision zmat(nvirt*nocc),zcv(ncore*(nocc-ncore))
|
|
double precision atchg(ncent)
|
|
character*2 atsymbol(natoms)
|
|
character*16 scfdamp
|
|
character*32 dft
|
|
|
|
integer iamat,iacv,imo,imem_old
|
|
integer nval,ctol,i,nf
|
|
integer dblalloc
|
|
character*4 c4
|
|
|
|
imem_old=imem
|
|
nf=nocc+nvirt
|
|
nval=nocc-ncore
|
|
call getkey('cctol',5,c4,4)
|
|
read(c4,*) i
|
|
ctol=10.d0**(-i)
|
|
|
|
iamat=dblalloc(nbasis*nbasis) ! memory for the AO x matrix too
|
|
iacv=dblalloc(nf*nocc)
|
|
imo=dblalloc(nbasis*nbasis)
|
|
|
|
call mp2_zvec(ncore,nval,nvirt,dcore(iamat),dcore(iacv),
|
|
& zmat,zcv,dft,chfx,cmp2)
|
|
call mp2_xmat(nbasis,dfnbasis,ncore,nocc,nvirt,zmat,zcv,
|
|
& dcore(iamat),dcore(iacv))
|
|
call read_from_disk('MOCOEF ',dcore(imo),nbasis,.false.)
|
|
call mp2_grad(natoms,ncent,nbasis,dfnbasis,nbf(3),ncore,nocc,
|
|
& nvirt,zmat,zcv,dcore(iamat),dcore(imo),chfx,itol,cmp2,grads,
|
|
& efield,ctol,atsymbol,atchg,natrange)
|
|
|
|
call dbldealloc(imem_old)
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine fock_der(nbasis,dfnbasis,nocc,densa,densb,dens2,
|
|
& xveca,scftype,dero,ca,ldf,dom,ctol,chfx,clrhfx,csrhfx,omega,
|
|
& itol,natoms,ncent,efield,grads,sder)
|
|
************************************************************************
|
|
* Derivative of the Fock matrix wrt the atomic centers
|
|
* sum_{mu nu} D_{mu nu} (F^xi)_{mu nu}
|
|
************************************************************************
|
|
use domain, only: domain_type
|
|
use common_mod, only: oeintfile,scrfile3,scrfile4,maxcor,imem,
|
|
& dcore,icore,tedatfile,minpfile,irecln,iout,nbset,varsfile,
|
|
& ifltln
|
|
implicit none
|
|
integer nbasis,dfnbasis,nocc,dero,ncent,natoms,locfit
|
|
double precision densa(nbasis,nbasis),densb(nbasis,nbasis)
|
|
double precision dens2(nbasis,nbasis),xveca(dfnbasis,4)
|
|
double precision, target :: ca(nbasis,nocc)
|
|
double precision, target :: sder(nbasis,nbasis,3)
|
|
double precision efield(3,ncent),grads(3,natoms,8)
|
|
double precision ctol,chfx,csrhfx,clrhfx,itol,omega
|
|
character*5 scftype
|
|
logical ldf
|
|
type(domain_type) dom
|
|
|
|
integer hailen,oroute,i,nocc1,nocc2,iwork
|
|
integer nocc_p,nocc_m,igrad_tmp
|
|
integer dblalloc
|
|
double precision tegrad(3)
|
|
double precision, pointer, contiguous :: mo1(:,:),mo2(:,:)
|
|
logical l3der
|
|
|
|
l3der=.true.
|
|
oroute=2
|
|
locfit=0
|
|
if(chfx.eq.0.0d0) then
|
|
call dfillzero(xveca,4*dfnbasis)
|
|
call direct_fock_build(densa,densb,dcore,dcore,dens2,100,
|
|
$ scftype,2,dero,1,sder,dcore,ca,ldf,dcore,dcore,dcore,
|
|
$ tegrad,hailen,dom%nmoat,dom%moat,dom%moadd,
|
|
$ dom%dfnmobasis,ctol,.false.,xveca,0,chfx,iout,varsfile,
|
|
$ icore,dcore,nbset,oeintfile,nocc,scrfile3,scrfile4,maxcor,
|
|
$ imem,tedatfile,dfnbasis,nbasis,oroute,efield,minpfile,
|
|
$ .false.,1,dcore,irecln,1,.false.,0,0,0,1.d0,dens2,1,dcore,
|
|
$ 0,locfit,dom%nmobasis,dom%natdom,dom%atdom,dom%naoat,
|
|
$ dom%aoat,dom%atind,i,i,clrhfx,csrhfx,omega,l3der,grads,
|
|
$ dcore,dcore,i,.false.,.false.,dcore,.false.,.false.,0,i,
|
|
$ .true.,dcore,dcore,.false.,.false.,nocc)
|
|
else
|
|
iwork=dblalloc(3*nbasis*nbasis)
|
|
call dscal(nbasis*nbasis,0.5d0,dens2,1)
|
|
call factor_dens(nbasis,nocc_p,nocc_m,dens2,sder,itol)
|
|
|
|
if(nocc_p.gt.0) then
|
|
call dsyrk('u','n',nbasis,nocc_p,2.0d0,sder,nbasis,0.0d0,
|
|
& dens2,nbasis)
|
|
call filllo(dens2,nbasis)
|
|
|
|
if(nocc.le.nocc_p) then
|
|
nocc1=nocc
|
|
nocc2=nocc_p
|
|
mo1=>ca
|
|
mo2=>sder(:,:,1)
|
|
else
|
|
nocc1=nocc_p
|
|
nocc2=nocc
|
|
mo1=>sder(:,:,1)
|
|
mo2=>ca
|
|
endif
|
|
|
|
call dfillzero(xveca,4*dfnbasis)
|
|
call direct_fock_build(densa,densb,dcore,dcore,dens2,100,
|
|
$ scftype,2,dero,1,dcore(iwork),dcore,mo1,ldf,dcore,dcore,
|
|
$ dcore,tegrad,hailen,dom%nmoat,dom%moat,dom%moadd,
|
|
$ dom%dfnmobasis,ctol,.false.,xveca,0,chfx,iout,varsfile,
|
|
$ icore,dcore,nbset,oeintfile,nocc1,scrfile3,scrfile4,
|
|
$ maxcor,imem,tedatfile,dfnbasis,nbasis,oroute,efield,
|
|
$ minpfile,.false.,1,dcore,irecln,1,.false.,0,0,0,1.d0,
|
|
$ dens2,1,mo2,0,locfit,dom%nmobasis,dom%natdom,dom%atdom,
|
|
$ dom%naoat,dom%aoat,dom%atind,i,i,clrhfx,csrhfx,omega,
|
|
$ l3der,grads,dcore,dcore,i,.false.,.false.,dcore,.false.,
|
|
$ .false.,0,i,.true.,dcore,dcore,.false.,.false.,nocc2)
|
|
endif
|
|
|
|
if(nocc_m.gt.0) then
|
|
call dsyrk('u','n',nbasis,nocc_m,2.0d0,sder(1,1,2),nbasis,
|
|
& 0.0d0,dens2,nbasis)
|
|
call filllo(dens2,nbasis)
|
|
|
|
if(nocc.le.nocc_m) then
|
|
nocc1=nocc
|
|
nocc2=nocc_m
|
|
mo1=>ca
|
|
mo2=>sder(:,:,2)
|
|
else
|
|
nocc1=nocc_m
|
|
nocc2=nocc
|
|
mo1=>sder(:,:,2)
|
|
mo2=>ca
|
|
endif
|
|
|
|
igrad_tmp=dblalloc(3*8*natoms)
|
|
call dfillzero(dcore(igrad_tmp),3*8*natoms)
|
|
|
|
call dfillzero(xveca,4*dfnbasis)
|
|
call direct_fock_build(densa,densb,dcore,dcore,dens2,100,
|
|
$ scftype,2,dero,1,dcore(iwork),dcore,mo1,ldf,dcore,dcore,
|
|
$ dcore,tegrad,hailen,dom%nmoat,dom%moat,dom%moadd,
|
|
$ dom%dfnmobasis,ctol,.false.,xveca,0,chfx,iout,varsfile,
|
|
$ icore,dcore,nbset,oeintfile,nocc1,scrfile3,scrfile4,
|
|
$ maxcor,imem,tedatfile,dfnbasis,nbasis,oroute,efield,
|
|
$ minpfile,.false.,1,dcore,irecln,1,.false.,0,0,0,1.d0,
|
|
$ dens2,1,mo2,0,locfit,dom%nmobasis,dom%natdom,dom%atdom,
|
|
$ dom%naoat,dom%aoat,dom%atind,i,i,clrhfx,csrhfx,omega,
|
|
$ l3der,dcore(igrad_tmp),dcore,dcore,i,.false.,.false.,
|
|
$ dcore,.false.,.false.,0,i,.true.,dcore,dcore,.false.,
|
|
$ .false.,nocc2)
|
|
|
|
call daxpy(3*8*natoms,-1.0d0,dcore(igrad_tmp),1,grads,1)
|
|
endif
|
|
call dbldealloc(iwork)
|
|
endif
|
|
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine props(nbasis,r8heap,i4heap,sder,hder,denst,rf,scftype,
|
|
& densa,densb,ca,cb,ciscont,dft,embed,dfbasis_scf,nal,nbe,moa,
|
|
& mob,focka,fockb,ea,eb,s,popul,mnbasis,nocc,natoms,atsymbol,
|
|
& atchg,ncent,natrange,mnatrange,distc,verbosity,coord,nfroz,xdip,
|
|
& dipx,dipy,dipz,qmreg,calctype,lgradd,grdens,ihmat2,ppqa)
|
|
************************************************************************
|
|
* Calculating properties
|
|
************************************************************************
|
|
use common_mod, only: scrfile1,scrfile2,iout,mocoeffile,oeintfile,
|
|
& ifcfile,angtobohr,echesu,eref,ecc
|
|
implicit none
|
|
integer nbasis,ciscont,nal,nbe,mnbasis,nocc,natoms,ncent,nfroz
|
|
integer natrange(2,natoms),mnatrange(2,natoms),verbosity
|
|
integer*4 i4heap(*)
|
|
double precision r8heap(*),sder(nbasis,nbasis,3)
|
|
double precision hder(nbasis,nbasis,3),denst(nbasis,nbasis)
|
|
double precision rf(nbasis,nbasis),ea(nal),eb(nbe)
|
|
double precision densa(nbasis,nbasis,ciscont),densb(nbasis,nbasis)
|
|
double precision ca(nbasis,nbasis,ciscont),cb(nbasis,nbasis)
|
|
double precision moa(nal,nbasis),mob(nbe,nbasis)
|
|
double precision focka(nbasis,nbasis),fockb(nbasis,nbasis)
|
|
double precision s(nbasis,nbasis),atchg(ncent),ppqa(nbasis,nbasis)
|
|
double precision distc(natoms,natoms),coord(3,natoms)
|
|
double precision xdip(nbasis,nbasis),ihmat2(nbasis,nbasis)
|
|
double precision dipx,dipy,dipz
|
|
character*2 atsymbol(natoms)
|
|
character*5 scftype
|
|
character*8 embed,popul,qmreg,grdens
|
|
character*16 calctype
|
|
character*20 dfbasis_scf
|
|
character*32 dft
|
|
logical lgradd
|
|
|
|
c running population ananlysis
|
|
call pop_anal(nbasis,scrfile1,scrfile2,iout,r8heap,i4heap,sder,
|
|
& hder,denst,rf,scftype,densa,densb,mocoeffile,ca,cb,ciscont,
|
|
& dft,embed,dfbasis_scf,nal,nbe,moa,mob,focka,fockb,ea,eb,
|
|
& oeintfile,s,popul,mnbasis,nocc,natoms,atsymbol,atchg,
|
|
& natrange,mnatrange)
|
|
C Calculate Mayer bond orders
|
|
call mayer_bond_orders(nbasis,denst,s,distc,rf,natoms,atsymbol,
|
|
$ natrange,iout)
|
|
C Atomic decomposition of HF energy
|
|
call ener_deco(nbasis,dft,verbosity,popul,natoms,natrange,
|
|
$ oeintfile,r8heap,i4heap,rf,focka,fockb,denst,densa,densb,
|
|
$ scftype,iout,coord,atchg,atsymbol)
|
|
call scf_props(nbasis,iout,rf,nfroz,r8heap,i4heap,scrfile1,
|
|
& focka,fockb,denst,xdip,dipx,dipy,dipz,oeintfile,angtobohr,
|
|
& echesu,qmreg,scftype,eref)
|
|
C Calculate dipole and quadrupole-moments
|
|
if(calctype.ne.'scf '.and..not.lgradd) then
|
|
call mp2_props(nbasis,oeintfile,angtobohr,echesu,iout,
|
|
& r8heap,i4heap,ppqa,xdip,dipx,dipy,dipz,
|
|
& scftype,dft,ecc,grdens)
|
|
endif
|
|
C rism and ESPcharge inserted here for now !GA
|
|
C rism correction energy: !GA
|
|
call rism_esp(nbasis,iout,r8heap,i4heap,ihmat2,ppqa,denst,
|
|
& scrfile1,natoms,ncent,atchg,atsymbol,coord,calctype,
|
|
& ifcfile)
|
|
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine scf_props(nbasis,iout,rf,nfroz,r8heap,i4heap,scrfile1,
|
|
& focka,fockb,denst,xdip,dipx,dipy,dipz,oeintfile,angtobohr,
|
|
& echesu,qmreg,scftype,eref)
|
|
************************************************************************
|
|
* Calculate SCF properties
|
|
************************************************************************
|
|
implicit none
|
|
integer nbasis,iout,nfroz,scrfile1,oeintfile
|
|
double precision rf(nbasis,nbasis),r8heap(*),i4heap(*)
|
|
double precision focka(nbasis,nbasis),fockb(nbasis,nbasis)
|
|
double precision denst(nbasis,nbasis),xdip(nbasis,nbasis)
|
|
double precision dipx,dipy,dipz,angtobohr,echesu,eref
|
|
character*5 scftype
|
|
character*8 qmreg
|
|
C ReadHuzinaga projector
|
|
write(iout,*)
|
|
write(iout,*)
|
|
write(iout,*) 'Calculation of SCF first-order properties...'
|
|
nfroz=0
|
|
call dfillzero(rf,nbasis**2)
|
|
if(qmreg.eq.'0 ') then
|
|
open(scrfile1,file='HUZPROJ',form='unformatted')
|
|
read(scrfile1) nfroz
|
|
call roeint(r8heap,i4heap,rf,scrfile1,nbasis)
|
|
call roeint(r8heap,i4heap,focka,scrfile1,nbasis)
|
|
if(scftype.eq.'uhf ') then
|
|
call roeint(r8heap,i4heap,fockb,scrfile1,nbasis)
|
|
call daxpy(nbasis**2,1.d0,fockb,1,focka,1)
|
|
call dscal(nbasis**2,0.5d0,focka,1)
|
|
endif
|
|
close(scrfile1)
|
|
call dsymm('l','u',nbasis,nbasis,1.d0,rf,nbasis,focka,nbasis,
|
|
$ 0.d0,r8heap,nbasis)
|
|
call dcopy(nbasis**2,denst,1,r8heap(nbasis**2+1),1)
|
|
call daxpy(nbasis**2,-1.d0,rf,1,r8heap(nbasis**2+1),1)
|
|
call dsymm('r','u',nbasis,nbasis,1.d0,r8heap(nbasis**2+1),
|
|
$ nbasis,r8heap,nbasis,0.d0,rf,nbasis)
|
|
endif
|
|
call calcmom(r8heap,i4heap,denst,xdip,nbasis,oeintfile,angtobohr,
|
|
$ iout,1.d0,echesu*angtobohr,eref,dipx,dipy,dipz)
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine mp2_props(nbasis,oeintfile,angtobohr,echesu,iout,
|
|
& r8heap,i4heap,ppqa,xdip,dipx,dipy,dipz,scftype,
|
|
& dft,ecc,grdens)
|
|
************************************************************************
|
|
************************************************************************
|
|
implicit none
|
|
integer nbasis,oeintfile,iout
|
|
integer*4 i4heap(*)
|
|
double precision angtobohr,echesu,r8heap(*)
|
|
double precision ppqa(nbasis,nbasis)
|
|
double precision xdip(nbasis,nbasis),dipx,dipy,dipz,ecc
|
|
character*5 scftype
|
|
character*8 grdens
|
|
character*32 dft
|
|
|
|
write(iout,*)
|
|
write(iout,*)
|
|
write(iout,*) 'Calculation of MP2 first-order properties...'
|
|
call calcmom(r8heap,i4heap,ppqa,xdip,nbasis,oeintfile,angtobohr,
|
|
$ iout,1.d0,echesu*angtobohr,ecc,dipx,dipy,dipz)
|
|
if(trim(grdens).ne.'off') then
|
|
write(iout,*)
|
|
call griddens(nbasis,ppqa,ppqa,scftype,dft)
|
|
endif
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine rism_esp(nbasis,iout,r8heap,i4heap,ihmat2,ppqa,denst,
|
|
& scrfile1,natoms,ncent,atchg,atsymbol,coord,calctype,ifcfile)
|
|
************************************************************************
|
|
************************************************************************
|
|
implicit none
|
|
integer nbasis,ncent,natoms,scrfile1,iout,ifcfile
|
|
integer*4 i4heap(*)
|
|
double precision r8heap(*),ppqa(nbasis,nbasis)
|
|
double precision denst(nbasis,nbasis),ihmat2(nbasis,nbasis)
|
|
double precision atchg(natoms),coord(3,natoms)
|
|
character*2 atsymbol(natoms)
|
|
character*16 calctype
|
|
|
|
character*8 rism,espcharge
|
|
double precision elexenfull,elexenatom,elexen2
|
|
double precision expval
|
|
|
|
call getkey('rism',4,rism,8)
|
|
if(rism.ne.'off ') then
|
|
call getvar('coord ',coord)
|
|
open(scrfile1,file='NUCATTFULL',form='UNFORMATTED')
|
|
rewind(scrfile1)
|
|
call roeint(r8heap,i4heap,ihmat2,scrfile1,nbasis)
|
|
if(calctype.ne.'scf ') then
|
|
elexenfull=expval(ppqa,ihmat2,nbasis)
|
|
else
|
|
elexenfull=expval(denst,ihmat2,nbasis)
|
|
endif
|
|
close(scrfile1)
|
|
open(scrfile1,file='NUCATTATOM',form='UNFORMATTED')
|
|
rewind(scrfile1)
|
|
call roeint(r8heap,i4heap,ihmat2,scrfile1,nbasis)
|
|
if(calctype.ne.'scf ') then
|
|
elexenatom=expval(ppqa,ihmat2,nbasis)
|
|
else
|
|
elexenatom=expval(denst,ihmat2,nbasis)
|
|
endif
|
|
close(scrfile1)
|
|
elexen2=elexenfull-elexenatom
|
|
write(iout,*)
|
|
write(iout,'(a,ES15.6E2)')
|
|
$' Pointcharge-solute interaction energy [au]: ',elexen2
|
|
c write(iout,"('(Should be substracted from the final '
|
|
c $'electronic energy for meaningful values!)')")
|
|
open(unit=ifcfile,file='iface',access='append')
|
|
write(ifcfile,7596) 'ENERGY ','PC-DENS CORR ',1,1,1,
|
|
$elexen2, 0d0,0d0
|
|
close(ifcfile)
|
|
7596 format(a8,1x,a15,1x,3(i2,1x),1pe23.15,2(1pe15.8))
|
|
endif
|
|
C end of rism correction energy !GA
|
|
C espcharge calculation
|
|
call getkey('espcharge',9,espcharge,8)
|
|
if(espcharge.eq.'chelpg '.or.espcharge.eq.'mk ') then
|
|
if(calctype.ne.'scf ') then
|
|
call espchargecalc(espcharge,natoms,ncent,coord,ppqa,
|
|
$atsymbol,atchg)
|
|
else
|
|
call espchargecalc(espcharge,natoms,ncent,coord,denst,
|
|
$atsymbol,atchg)
|
|
endif
|
|
endif
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine ener_deco(nbasis,dft,verbosity,popul,natoms,natrange,
|
|
$ oeintfile,r8heap,i4heap,rf,focka,fockb,denst,densa,densb,
|
|
$ scftype,iout,coord,atchg,atsymbol)
|
|
************************************************************************
|
|
* HF energy decomposition
|
|
************************************************************************
|
|
implicit none
|
|
integer natoms,natrange(2,natoms),verbosity,oeintfile,iout
|
|
integer nbasis,iatoms
|
|
double precision r8heap(*),i4heap(*),rf(nbasis,nbasis)
|
|
double precision focka(nbasis,nbasis),fockb(nbasis,nbasis)
|
|
double precision denst(nbasis,nbasis),densa(nbasis,nbasis,*)
|
|
double precision densb(nbasis,nbasis),coord(3,natoms)
|
|
double precision atchg(*)
|
|
double precision sum,sum2,sum3,sum4,ddot,nucrepat
|
|
character*2 atsymbol(natoms)
|
|
character*4 popul
|
|
character*5 scftype
|
|
character*32 dft
|
|
|
|
if(trim(dft).eq.'off'.and.
|
|
$ (verbosity.ge.3.or.popul.eq.'deco ')) then
|
|
open(oeintfile,file='OEINT',form='UNFORMATTED')
|
|
read(oeintfile)
|
|
call roeint(r8heap,i4heap,rf,oeintfile,nbasis)
|
|
close(oeintfile)
|
|
if(scftype.eq.'rhf ') call daxpy(nbasis**2,1.d0,focka,1,rf,1)
|
|
write(iout,*)
|
|
write(iout,*)'Atomic decomposition of Hartree-Fock energy [au]:'
|
|
write(iout,*)' Electronic Nuclear Total'
|
|
sum3=0.d0
|
|
sum4=0.d0
|
|
do iatoms=1,natoms
|
|
sum2=0.5d0*
|
|
$ddot(nbasis*(natrange(2,iatoms)-natrange(1,iatoms)),
|
|
$denst(1,natrange(1,iatoms)+1),1,rf(1,natrange(1,iatoms)+1),1)
|
|
if(scftype.eq.'uhf ') then
|
|
sum2=sum2+0.5d0*(
|
|
$ddot(nbasis*(natrange(2,iatoms)-natrange(1,iatoms)),
|
|
$densa(1,natrange(1,iatoms)+1,1),1,focka(1,natrange(1,iatoms)+1),1)
|
|
$+ddot(nbasis*(natrange(2,iatoms)-natrange(1,iatoms)),
|
|
$densb(1,natrange(1,iatoms)+1),1,fockb(1,natrange(1,iatoms)+1),1))
|
|
endif
|
|
sum=nucrepat(iatoms,natoms,coord,atchg)
|
|
write(iout,'(i4,1x,a3,3f15.8)') iatoms,atsymbol(iatoms),
|
|
$sum2,sum,sum2+sum
|
|
sum3=sum3+sum2
|
|
sum4=sum4+sum
|
|
enddo
|
|
write(iout,"(2x,51('-'))")
|
|
write(iout,"(' Total ',3f15.8)") sum3,sum4,sum3+sum4
|
|
endif
|
|
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine mayer_bond_orders(nbasis,denst,s,distc,rf,natoms,
|
|
& atsymbol,natrange,iout)
|
|
************************************************************************
|
|
************************************************************************
|
|
implicit none
|
|
integer nbasis,iatoms,jatoms,mu,nu,j,iout,natoms
|
|
integer natrange(2,natoms)
|
|
double precision denst(nbasis,nbasis),s(nbasis,nbasis)
|
|
double precision distc(natoms,natoms),rf(nbasis,nbasis)
|
|
double precision sum
|
|
character*2 atsymbol(natoms)
|
|
character*8 c8
|
|
character*16 bond
|
|
|
|
write(iout,*)
|
|
write(iout,*) 'Mayer bond orders:'
|
|
call getvar('distc ',distc)
|
|
call dsymm('l','u',nbasis,nbasis,1.d0,denst,nbasis,s,nbasis,0.d0,
|
|
$ rf,nbasis)
|
|
j=0
|
|
do iatoms=1,natoms
|
|
do jatoms=1,iatoms-1
|
|
if(distc(iatoms,jatoms).lt.10.d0) then
|
|
sum=0.d0
|
|
do mu=natrange(1,iatoms)+1,natrange(2,iatoms)
|
|
do nu=natrange(1,jatoms)+1,natrange(2,jatoms)
|
|
sum=sum+rf(mu,nu)*rf(nu,mu)
|
|
enddo
|
|
enddo
|
|
if(sum.gt.0.1d0) then
|
|
write(c8,'(i8)') jatoms
|
|
bond=trim(adjustl(c8)) // trim(atsymbol(jatoms)) // '-'
|
|
write(c8,'(i8)') iatoms
|
|
bond=trim(bond)//trim(adjustl(c8))//trim(atsymbol(iatoms))
|
|
j=j+1
|
|
write(iout,"(i5,2x,a14,f8.4)") j,bond,sum
|
|
endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine pop_anal(nbasis,scrfile1,scrfile2,iout,r8heap,i4heap,
|
|
$ sder,hder,denst,rf,scftype,densa,densb,mocoeffile,ca,cb,ciscont,
|
|
$ dft,embed,dfbasis_scf,nal,nbe,moa,mob,focka,fockb,ea,eb,
|
|
$ oeintfile,s,popul,mnbasis,nocc,natoms,atsymbol,atchg,natrange,
|
|
$ mnatrange)
|
|
************************************************************************
|
|
************************************************************************
|
|
implicit none
|
|
integer nbasis,scrfile1,scrfile2,iout,mocoeffile,ciscont,nal,nbe
|
|
integer oeintfile,mnbasis,nocc,natoms,natrange(2,natoms)
|
|
integer mnatrange(2,natoms),isp
|
|
integer*4 i4heap(*)
|
|
double precision r8heap(*)
|
|
double precision sder(nbasis,nbasis,3),hder(nbasis,nbasis,3)
|
|
double precision denst(nbasis,nbasis),rf(nbasis,nbasis)
|
|
double precision densa(nbasis,nbasis,ciscont),densb(nbasis,nbasis)
|
|
double precision ca(nbasis,nbasis,ciscont),cb(nbasis,nbasis)
|
|
double precision moa(nal,nbasis),mob(nbe,nbasis),ea(nal),eb(nbe)
|
|
double precision focka(nbasis,nbasis),fockb(nbasis,nbasis)
|
|
double precision s(nbasis,nbasis),atchg(*)
|
|
character*2 atsymbol(natoms)
|
|
character*4 oniomtype
|
|
character*5 scftype
|
|
character*8 embed,popul
|
|
character*20 dfbasis_scf
|
|
character*32 dft
|
|
logical ldf
|
|
|
|
write(iout,*)
|
|
write(iout,*)
|
|
write(iout,*) 'Performing population analysis...'
|
|
call read_data
|
|
call iao_charge
|
|
C Calculate Mulliken and Lowdin atomic charges
|
|
open(scrfile1,file='SROOT',form='unformatted')
|
|
call roeint(r8heap,i4heap,sder,scrfile1,nbasis)
|
|
close(scrfile1)
|
|
call dsymm('l','u',nbasis,nbasis,1.d0,denst,nbasis,sder,nbasis,
|
|
$0.d0,rf,nbasis)
|
|
write(iout,*)
|
|
call print_charge
|
|
contains
|
|
|
|
subroutine read_data
|
|
implicit none
|
|
integer i,j
|
|
double precision sum
|
|
|
|
ldf=dfbasis_scf.ne.'none '
|
|
isp=0
|
|
oniomtype=' '
|
|
inquire(file='ONIOMROUTE',exist=ldf)
|
|
if(ldf) then
|
|
open(scrfile2,file='ONIOMROUTE',form='UNFORMATTED')
|
|
read(scrfile2) isp,oniomtype
|
|
close(scrfile2)
|
|
endif !HB
|
|
C Read SCF densities
|
|
open(scrfile2,file='SCFDENSITIES',form='UNFORMATTED')
|
|
rewind(scrfile2)
|
|
call roeint(r8heap,i4heap,densa,scrfile2,nbasis)
|
|
if(scftype.ne.'rhf ')
|
|
$ call roeint(r8heap,i4heap,densb,scrfile2,nbasis)
|
|
close(scrfile2)
|
|
C Read MO coefficients from mocoeffile
|
|
open(mocoeffile,file='MOCOEF',form='UNFORMATTED')
|
|
rewind(mocoeffile)
|
|
call roequa(r8heap,i4heap,ca,mocoeffile,nbasis,nbasis)
|
|
if(scftype.eq.'uhf ')
|
|
$ call roequa(r8heap,i4heap,cb,mocoeffile,nbasis,nbasis)
|
|
close(mocoeffile)
|
|
if(trim(dft).ne.'off'.or.
|
|
$ trim(embed).ne.'off'.or.
|
|
$ trim(dfbasis_scf).ne.'none') then
|
|
if(scftype.eq.'uhf ') then
|
|
call motransp(nal,nbasis,moa,ca,.false.)
|
|
call motransp(nbe,nbasis,mob,cb,.false.)
|
|
else
|
|
call motransp(nal,nbasis,moa,ca,.false.)
|
|
call dscal(nbasis*nal,dsqrt(2.d0),moa,1)
|
|
endif
|
|
endif
|
|
C Read AO Fock-matrix and orbital energies
|
|
open(scrfile1,file='FOCK',form='UNFORMATTED')
|
|
rewind(scrfile1)
|
|
call roeint(r8heap,i4heap,focka,scrfile1,nbasis)
|
|
if(scftype.eq.'uhf ')
|
|
$ call roeint(r8heap,i4heap,fockb,scrfile1,nbasis)
|
|
read(scrfile1) (ea(i),i=1,nal)
|
|
if(scftype.eq.'uhf ') read(scrfile1) (eb(i),i=1,nbe)
|
|
close(scrfile1)
|
|
c Create total density in the case of UHF
|
|
if(scftype.eq.'uhf ') then
|
|
do i=1,nbasis
|
|
do j=1,i
|
|
sum=densa(i,j,1)+densb(i,j)
|
|
denst(i,j)=sum
|
|
denst(j,i)=sum
|
|
enddo
|
|
enddo
|
|
endif
|
|
C Read overlap integrals
|
|
open(oeintfile,file='OEINT',form='UNFORMATTED')
|
|
call roeint(r8heap,i4heap,s,oeintfile,nbasis)
|
|
close(oeintfile)
|
|
end subroutine
|
|
|
|
subroutine iao_charge
|
|
implicit none
|
|
C Calculate IAO charges
|
|
if(popul.ne.'iao ') return
|
|
open(scrfile1,file='SROOT',form='unformatted')
|
|
read(scrfile1)
|
|
call roeint(r8heap,i4heap,sder(1,1,1),scrfile1,nbasis)
|
|
close(scrfile1)
|
|
open(scrfile1,file='S12MAT',form='UNFORMATTED')
|
|
call roeint(r8heap,i4heap,sder(1,1,2),scrfile1,mnbasis)
|
|
call rtdmx (r8heap,i4heap,sder(1,1,3),scrfile1,nbasis,mnbasis)
|
|
close(scrfile1)
|
|
call iao(nbasis,mnbasis,nocc,s,sder,sder(1,1,2),sder(1,1,3),ca,
|
|
$ rf,r8heap,hder,hder(1,1,2),hder(1,1,3),denst)
|
|
end subroutine
|
|
|
|
subroutine print_charge
|
|
implicit none
|
|
integer iatoms
|
|
double precision ddot
|
|
|
|
if(popul.eq.'iao ') then
|
|
write(iout,*) ' Atomic charges'
|
|
write(iout,*) ' Mulliken Lowdin IAO '
|
|
do iatoms=1,natoms
|
|
write(iout,'(i4,1x,a3,3f12.6)') iatoms,atsymbol(iatoms),
|
|
$atchg(iatoms)-ddot(nbasis*(natrange(2,iatoms)-natrange(1,iatoms)),
|
|
$denst(1,natrange(1,iatoms)+1) ,1, s(1,natrange(1,iatoms)+1),1),
|
|
$atchg(iatoms)-ddot(nbasis*(natrange(2,iatoms)-natrange(1,iatoms)),
|
|
$sder (1,natrange(1,iatoms)+1,1),1,rf(1,natrange(1,iatoms)+1),1),
|
|
$atchg(iatoms)-ddot(nbasis*(mnatrange(2,iatoms)-
|
|
$mnatrange(1,iatoms)),sder(1,mnatrange(1,iatoms)+1,2),1,
|
|
$sder(1,mnatrange(1,iatoms)+1,3),1)
|
|
enddo
|
|
if(isp.eq.1.and.oniomtype.eq.'ee') then
|
|
open(scrfile1,file='ATCHARGE',form='FORMATTED')
|
|
do iatoms=1,natoms
|
|
write(scrfile1,'(i4,1x,a3,3f12.6)') iatoms,atsymbol(iatoms),
|
|
$atchg(iatoms)-ddot(nbasis*(natrange(2,iatoms)-natrange(1,iatoms)),
|
|
$denst(1,natrange(1,iatoms)+1) ,1, s(1,natrange(1,iatoms)+1),1),
|
|
$atchg(iatoms)-ddot(nbasis*(natrange(2,iatoms)-natrange(1,iatoms)),
|
|
$sder (1,natrange(1,iatoms)+1,1),1,rf(1,natrange(1,iatoms)+1),1),
|
|
$atchg(iatoms)-ddot(nbasis*(mnatrange(2,iatoms)-
|
|
$mnatrange(1,iatoms)),sder(1,mnatrange(1,iatoms)+1,2),1,
|
|
$sder(1,mnatrange(1,iatoms)+1,3),1)
|
|
enddo
|
|
close(scrfile1)
|
|
endif
|
|
else
|
|
write(iout,*) ' Atomic charges'
|
|
write(iout,*) ' Mulliken Lowdin'
|
|
do iatoms=1,natoms
|
|
write(iout,'(i4,1x,a3,3f12.6)') iatoms,atsymbol(iatoms),
|
|
$atchg(iatoms)-ddot(nbasis*(natrange(2,iatoms)-natrange(1,iatoms)),
|
|
$denst(1,natrange(1,iatoms)+1) ,1, s(1,natrange(1,iatoms)+1),1),
|
|
$atchg(iatoms)-ddot(nbasis*(natrange(2,iatoms)-natrange(1,iatoms)),
|
|
$sder (1,natrange(1,iatoms)+1,1),1,rf(1,natrange(1,iatoms)+1),1)
|
|
enddo
|
|
if(isp.eq.1.and.oniomtype.eq.'ee') then
|
|
open(scrfile1,file='ATCHARGE',form='FORMATTED')
|
|
do iatoms=1,natoms
|
|
write(scrfile1,'(i4,1x,a3,3f12.6)') iatoms,atsymbol(iatoms),
|
|
$atchg(iatoms)-ddot(nbasis*(natrange(2,iatoms)-natrange(1,iatoms)),
|
|
$denst(1,natrange(1,iatoms)+1) ,1, s(1,natrange(1,iatoms)+1),1),
|
|
$atchg(iatoms)-ddot(nbasis*(natrange(2,iatoms)-natrange(1,iatoms)),
|
|
$sder (1,natrange(1,iatoms)+1,1),1,rf(1,natrange(1,iatoms)+1),1)
|
|
enddo
|
|
close(scrfile1)
|
|
endif
|
|
endif
|
|
end subroutine
|
|
|
|
end subroutine
|