lukasplevac/easyconfigs-it4i
1
0
Fork 0
mirror of https://code.it4i.cz/sccs/easyconfigs-it4i.git synced 2025-04-17 04:00:49 +01:00
Code Issues Packages Projects Releases Wiki Activity
easyconfigs-it4i/m/MRCC/mrcc_files/dft.f
Lukas Krupcik eb1ea94130 merge master
2024-07-25 10:27:17 +02:00

4685 lines
187 KiB
Fortran
Raw Blame History

************************************************************************
subroutine dft_core(nbasis,nal,nbe,focka,fockb,moa,mob,grfile,
$dcore,iout,exc,dft,minpfile,scftype,ifltln,maxcor,imem,imem1,
$icore,verbosity,dero,grad,route,densa,densb,nstate,mult,chfx,
$istore)
************************************************************************
* Driver for DFT calculations
************************************************************************
implicit none
integer nbasis,ngrid,natoms,nangmax,ncontrmax,nprimmax,ncartmax,i
integer nsphermax,igrid,inang,incontr,inprim,igexp,igcoef,icoord,n
integer ictostr,idvec,ivxca,igexp2,grfile,iweight,nal,nbe,j,mgga
integer dblalloc,intalloc,nbset,iout,igpgra,igpgrb,nd,izk,minpfile
integer itrmat,ilmata,irhoa,irhob,ifuna,isgvaa,ivrhoa,ivrhob,nb
integer isigmaaa,isigmabb,isigmaab,ivsigmabb,ivsigmaab,ivsigmaaa
integer ivxcb,ifunb,scftype,ilmatb,isgvbb,isgvab,ifltln,maxcor
integer imem,imem1,nbl,nbll,nblock,iblock,icore(*),nstate,mult
integer ncent,inangmin,verbosity,dero,idvec0,ibfmap,itaua,itaub
integer igrhoa,igrhob,igcn,imma,immb,iiatrange,ivtaua,ivtaub
integer ivvtaua,ivvtaub,irho,ivrho,isigma,ivsigma,itau,ivtau
integer ilapl_rhoa,ilapl_rhob,ivlapl_rhoa,ivlapl_rhob,ilapl_rho
integer ivlapl_rho,idensity,igradient,ikappa,ivvlapl_rhoa,igraa
integer ivvlapl_rhob,iv2rhoa2,iv2rhob2,iv2rhoab,iv2rhoasigmaaa
integer iv2rhoasigmaab,iv2rhoasigmabb,iv2rhobsigmabb,igdrhoa,igrbb
integer iv2rhobsigmaab,iv2rhobsigmaaa,iv2sigmaaa2,iv2sigmaaaab
integer iv2sigmaaabb,iv2sigmaab2,iv2sigmaabbb,iv2sigmabb2,igdrhob
integer ivv2rhoa2,ivv2rhob2,ivv2rhoab,ivv2rhoasigmaaa,idgpgra
integer ivv2rhoasigmaab,ivv2rhoasigmabb,ivv2rhobsigmabb,idgpgrb
integer ivv2rhobsigmaab,ivv2rhobsigmaaa,ivv2sigmaaa2,ivv2sigmaaaab
integer ivv2sigmaaabb,ivv2sigmaab2,ivv2sigmaabbb,ivv2sigmabb2
integer igpgra2,igpgrb2,shltype,istore,denscorr,ii
integer ionull,ionull_dn,ionull_dg,ikappa_dn,imind2,imaxd14,dhyb
integer dfnbasis,iisyev,irsw,ncore,nocca,noccb,ijpi_b,nbf(3),inb
integer ibatchsize,iscr,ifunc,imem_old,ifb,ijpi_a,ibij,ijij
real*8 focka(nbasis,nbasis),fockb(nbasis,nbasis),itol,dnrm2,chfx
real*8 densa(nbasis,nbasis),densb(nbasis,nbasis),cfnorm
real*8 moa(nal,nbasis),mob(nbe,nbasis),sum,grad,dcore(*),ddot,exc
real*8 vv10nl,bparam,cparam,beta,mu
character*4 citol,route,ccprog,cscr4
character*6 core
character*32 dft,cdft
logical cartg,lll,lnl,lscvv10,lcf,lrs
integer*4 isyev
equivalence(isyev,iisyev)
#if defined (MPI)
include 'mpif.h'
integer*4 mpierr
integer thrd,xyzcount,xyzsize,xyzsiz1
integer rank,mpicount,mpisize,mpisiz1
common/para/ thrd,xyzcount,xyzsize,xyzsiz1,
$ rank,mpicount,mpisize,mpisiz1
#endif
C Implemented "simple" functionals (add new functionals here)
C (Problematic functionals: P86, PBEc/UKS, PW91c/UKS)
integer nfunc,nfuncmax,nlfunc
parameter(nfunc=30,nfuncmax=256)
real*8 cf(nfuncmax),cfe(nfuncmax),exf(nfuncmax)
character*8 c8
character*32 cfunc(nfuncmax),c32
imem_old=imem
cfunc( 1)='lda '
cfunc( 2)='b88 '
cfunc( 3)='pbex '
cfunc( 4)='pw91x '
cfunc( 5)='lyp '
cfunc( 6)='vwn5 '
cfunc( 7)='pw '
cfunc( 8)='p86 '
cfunc( 9)='pbec '
cfunc(10)='pw91c '
cfunc(11)='b3lyp3 '
cfunc(12)='b97 '
cfunc(13)='hcth120 '
cfunc(14)='hcth147 '
cfunc(15)='hcth407 '
cfunc(16)='vv10 '
cfunc(17)='ncap '
cfunc(18)='srpbec '
cfunc(19)='srlda '
cfunc(20)='srpw '
cfunc(21)='ssrpbec '
cfunc(22)='ssrpbex '
cfunc(23)='ssrp86 '
cfunc(24)='ssrlyp '
cfunc(25)='ssrb88 '
cfunc(26)='ssrpw91c '
cfunc(27)='ssrpw91x '
cfunc(28)='winfhpc '
cfunc(29)='winfphpc '
cfunc(30)='ecmd_pbec '
cfunc(nfunc+1:nfuncmax)=' '
nlfunc=0
ifunc=intalloc(nfuncmax)
icore(ifunc:ifunc+nfuncmax-1)=0
call getkey('denscorr',8,cscr4,4)
read(cscr4,*) denscorr
call getvar('ncore ',ncore)
call getkey('core',4,core,6)
if(core.eq.'corr '.or.denscorr.eq.0) ncore=0
nocca=nal-ncore
noccb=max(0,nbe-ncore)
C Initialize coefficients
shltype=min(2,scftype)
if(mult.ne.1) shltype=2
lscvv10=.false.
beta=0.d0
cf=0.d0
cfe=0.d0
exf=0.d0
call getvar('mgga ',mgga)
c write(6,*) 'szemet!!!'
c mgga=2
nd=0
if(mgga.gt.0) nd=4
if(mgga.gt.1) nd=10
if(route.eq.'den1'.or.route.eq.'den2') then
open(99,file='DENSITY',form='unformatted')
nd=10
endif
if(route.ne.'scl1'.and.route.ne.'coul') exc=0.d0
call cfini(dft,minpfile,cfunc,nfunc,nlfunc,cf,cfe,iout,route,nd,
$dero,bparam,cparam,beta,lscvv10,icore(ifunc),nfuncmax)
if(route.eq.'scl1') then
cf=-cf
call getkey('dft',3,cdft,32)
if(trim(cdft).ne.'off') then
call cfini(cdft,minpfile,cfunc,nfunc,nlfunc,cf,cfe,iout,' ',
$nd,dero,bparam,cparam,beta,lscvv10,icore(ifunc),nfuncmax)
else
cfe=cf
endif
endif
c call getkey('embed',5,embed,8)
c if(trim(embed).eq.'rs') then
c lrs=.true.
c cfb=0.d0
c cfeb=0.d0
c exfb=0.d0
c open(minpfile,file='MINP')
c call getkeym('embed',5,embed,8)
c read(minpfile,*)
c read(minpfile,*) cdft
c close(minpfile)
c cdft=adjustl(cdft)
c call lowercase(cdft,cdft,32)
c call cfini(cdft,minpfile,cfunc,nfunc,nlfunc,cfb,cfeb,iout,
c $' ',nd,dero,bparam,cparam,beta,lscvv10)
c else
lrs=.false.
c endif
call getkey('itol',4,citol,4)
read(citol,*) i
itol=10.d0**(-i)
lcf=dnrm2(nfunc+nlfunc,cf,1)+dnrm2(nfunc+nlfunc,cfe,1).lt.itol
if(lcf.and.route.ne.'den1'.and.route.ne.'den2')return
lnl=dabs(cfe(16))+dabs(cf(16)).gt.itol
C Read variables and allocate memory for grid-independent arrays
call getvar('nbset ',nbset)
call getvar('ngrid ',ngrid)
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)
inang=intalloc(natoms*nbset) ! Do not allocate memory before!
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)
icoord=dblalloc(3*ncent)
ictostr=dblalloc((nangmax+1)*ncartmax**2)
inangmin=intalloc(natoms*nbset)
iiatrange=intalloc(2*natoms)
igcn=intalloc(2*ncontrmax*(nangmax+1)*natoms*nbset)
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('coord ',dcore(icoord))
call getvar('ctostr ',dcore(ictostr))
call getvar('cartg ',cartg)
call getvar('nangmin ',icore(inangmin))
call getvar('gcn ',icore(igcn))
igrid=dblalloc(3*ngrid)
iweight=dblalloc(ngrid)
irsw=iweight
c if(lrs) irsw=dblalloc(ngrid)
idensity=igrid
igradient=igrid
ikappa=igrid
ionull=igrid
ionull_dn=igrid
ionull_dg=igrid
ikappa_dn=igrid
if(lnl) then
idensity=dblalloc(ngrid)
igradient=dblalloc(ngrid)
ikappa=dblalloc(ngrid)
#if defined (MPI)
dcore(idensity :idensity +ngrid-1)=0.d0
dcore(igradient:igradient+ngrid-1)=0.d0
#endif
if(lscvv10) then
ionull=dblalloc(ngrid)
ionull_dn=dblalloc(ngrid)
ionull_dg=dblalloc(ngrid)
ikappa_dn=dblalloc(ngrid)
endif
endif
itrmat=dblalloc(nsphermax*ncontrmax*ncartmax*nprimmax)
ivxca=dblalloc(nbasis**2)
if(denscorr.eq.0) then
imma=dblalloc(nbasis*nal)
else
imma=dblalloc(nbasis**2)
endif
if(shltype.eq.2) then
ivxcb=dblalloc(nbasis**2)
if(denscorr.eq.0) then
immb=dblalloc(nbasis*nbe)
else
immb=dblalloc(nbasis**2)
endif
else
ivxcb=ivxca
immb=imma
endif
igexp2=dblalloc(nprimmax)
ibfmap=intalloc(nbasis)
C Read the grid
open(grfile,file='DFTGRID',form='unformatted')
rewind(grfile)
read(grfile) (dcore(igrid+i),i=0,3*ngrid-1)
read(grfile) (dcore(iweight+i),i=0,ngrid-1)
read(grfile) nblock,nbl,nbll
c ibatchsize=intalloc(nblock)
c icore(ibatchsize:ibatchsize+nblock-2)=nbl
c icore(ibatchsize+nblock-1)=nbll
c maxmem=maxcor-(imem-imem1)
C Minimal square distance of blocks for vdW functionals
if(lnl) then
imind2=dblalloc(nblock*(nblock-1)/2)
read(grfile) dcore(imind2:imind2-1+nblock*(nblock-1)/2)
imaxd14=dblalloc(nblock)
else
imind2=igrid
imaxd14=igrid
endif
close(grfile)
if(route.eq.'den1'.or.route.eq.'den2') write(99) ngrid
C Allocate memory for grid-dependent arrays
idvec=dblalloc(nd*nbasis*nbl)
idvec0=dblalloc(nbasis*nbl)
ilmata=dblalloc(max(nbasis,nd*nal*nbl,3*nbl))
igpgra=dblalloc(nbasis*nbl*max(1,nd-6))
call getvar('omega ',mu)
iscr=imem
if(mu.gt.0.d0.and.sum(icore(ifunc:ifunc+nfuncmax-1)).ge.1) then ! ssr
if(shltype.eq.2) then
iscr=dblalloc(nbl*6*2)
else
iscr=dblalloc(nbl*3*2)
endif
endif
call getkey('ccprog',6,ccprog,4)
call getvar('dhyb ',dhyb)
c if(trim(ccprog).ne.'cis'.and.
c $sum(icore(ifunc:ifunc+nfuncmax-1)).gt.1.and.dhyb.eq.1) then
c write(6,*) 'RS-DH ansatz of Toulouse is available
c $only for excited-state calculations!'
c call mrccend(1)
c endif
C
if(denscorr.eq.0) then
inb=imem
ifb=imem
ijpi_a=imem
ijpi_b=imem
ibij=imem
ijij=imem
elseif(denscorr.gt.0) then
call getvar('nbf ',nbf)
dfnbasis=nbf(3)
C
inb=dblalloc(ngrid)
ifb=dblalloc(ngrid)
C
ii=max(nal,nbe)
ijpi_a=dblalloc(dfnbasis*nocca*nbasis)
if(scftype.eq.2) then
ijpi_b=dblalloc(dfnbasis*noccb*nbasis)
else
ijpi_b=ijpi_a
endif
ibij=dblalloc(dfnbasis*ii**2)
ijij=dblalloc(dfnbasis*(ii+1)*ii/2)
C
call readint(dcore(ijpi_a),dcore(ijpi_b),dfnbasis,nbasis,ncore,
$nocca,nal,noccb,nbe,grfile,scftype,dcore(ibij),dcore(ijij),
$dcore(ibij),dcore(ijij))
call dbldealloc(ibij)
C
iscr=dblalloc(shltype*(nbasis+dfnbasis)
$ +max(nocca,noccb)*dfnbasis)
C
endif
C
izk=dblalloc(nbl)
ivrhoa=dblalloc(nbl)
ifuna=dblalloc(nbl)
irhoa=dblalloc(nbl)
if(nd.eq.1) then
isigmaaa=ifuna
ivsigmaaa=ifuna
isgvaa=ifuna
igrhoa=ifuna
else
isigmaaa=dblalloc(nbl)
ivsigmaaa=dblalloc(nbl)
isgvaa=dblalloc(nbl)
igrhoa=dblalloc(3*nbl)
endif
if(shltype.eq.2) then
ifunb=dblalloc(nbl)
igpgrb=dblalloc(nbasis*nbl*max(1,nd-6))
ilmatb=dblalloc(max(nbasis,nd*nbe*nbl,3*nbl))
irhob=dblalloc(nbl)
ivrhob=dblalloc(nbl)
irho=dblalloc(2*nbl)
ivrho=dblalloc(2*nbl)
isigma=dblalloc(3*nbl)
ivsigma=dblalloc(3*nbl)
if(nd.eq.1) then
isigmabb =ifuna
isigmaab =ifuna
ivsigmabb=ifuna
ivsigmaab=ifuna
isgvbb=ifuna
isgvab=ifuna
igrhob=ifuna
else
isigmabb =dblalloc(nbl)
isigmaab =dblalloc(nbl)
ivsigmabb=dblalloc(nbl)
ivsigmaab=dblalloc(nbl)
isgvbb=dblalloc(nbl)
isgvab=dblalloc(nbl)
igrhob=dblalloc(3*nbl)
endif
else
ifunb=ifuna
igpgrb=ifuna
ilmatb=ifuna
irhob=ifuna
ivrhob=ifuna
isigmabb =ifuna
isigmaab =ifuna
ivsigmabb=ifuna
ivsigmaab=ifuna
isgvbb=ifuna
isgvab=ifuna
igrhob=ifuna
irho=irhoa
ivrho=ivrhoa
isigma=ifuna
ivsigma=ifuna
endif
iv2rhoa2=ifuna
iv2rhob2=ifuna
iv2rhoab=ifuna
iv2rhoasigmaaa=ifuna
iv2rhoasigmaab=ifuna
iv2rhoasigmabb=ifuna
iv2rhobsigmabb=ifuna
iv2rhobsigmaab=ifuna
iv2rhobsigmaaa=ifuna
iv2sigmaaa2=ifuna
iv2sigmaaaab=ifuna
iv2sigmaaabb=ifuna
iv2sigmaab2=ifuna
iv2sigmaabbb=ifuna
iv2sigmabb2=ifuna
ivv2rhoa2=ifuna
ivv2rhob2=ifuna
ivv2rhoab=ifuna
ivv2rhoasigmaaa=ifuna
ivv2rhoasigmaab=ifuna
ivv2rhoasigmabb=ifuna
ivv2rhobsigmabb=ifuna
ivv2rhobsigmaab=ifuna
ivv2rhobsigmaaa=ifuna
ivv2sigmaaa2=ifuna
ivv2sigmaaaab=ifuna
ivv2sigmaaabb=ifuna
ivv2sigmaab2=ifuna
ivv2sigmaabbb=ifuna
ivv2sigmabb2=ifuna
igdrhoa=ifuna
igdrhob=ifuna
idgpgra=ifuna
idgpgrb=ifuna
igraa=ifuna
igrbb=ifuna
igpgra2=ifuna
igpgrb2=ifuna
if(dero.eq.2.or.route.eq.'den2') then
iv2rhoa2=dblalloc(nbl)
ivv2rhoa2=dblalloc(nbl)
idgpgra=dblalloc(nbasis*nbl)
if(nd.gt.4) then
iv2rhoasigmaaa=dblalloc(nbl)
iv2sigmaaa2=dblalloc(nbl)
ivv2rhoasigmaaa=dblalloc(nbl)
ivv2sigmaaa2=dblalloc(nbl)
igdrhoa=dblalloc(3*nbl)
igraa=dblalloc(3*nbl)
igpgra2=dblalloc(nbasis*nbl*max(1,nd-6))
endif
if(shltype.eq.2) then
iv2rhob2=dblalloc(nbl)
iv2rhoab=dblalloc(nbl)
ivv2rhob2=dblalloc(nbl)
ivv2rhoab=dblalloc(nbl)
idgpgrb=dblalloc(nbasis*nbl)
if(nd.gt.4) then
iv2rhoasigmaab=dblalloc(nbl)
iv2rhoasigmabb=dblalloc(nbl)
iv2rhobsigmabb=dblalloc(nbl)
iv2rhobsigmaab=dblalloc(nbl)
iv2rhobsigmaaa=dblalloc(nbl)
iv2sigmaaaab=dblalloc(nbl)
iv2sigmaaabb=dblalloc(nbl)
iv2sigmaab2=dblalloc(nbl)
iv2sigmaabbb=dblalloc(nbl)
iv2sigmabb2=dblalloc(nbl)
ivv2rhoasigmaab=dblalloc(nbl)
ivv2rhoasigmabb=dblalloc(nbl)
ivv2rhobsigmabb=dblalloc(nbl)
ivv2rhobsigmaab=dblalloc(nbl)
ivv2rhobsigmaaa=dblalloc(nbl)
ivv2sigmaaaab=dblalloc(nbl)
ivv2sigmaaabb=dblalloc(nbl)
ivv2sigmaab2=dblalloc(nbl)
ivv2sigmaabbb=dblalloc(nbl)
ivv2sigmabb2=dblalloc(nbl)
igdrhob=dblalloc(3*nbl)
igrbb=dblalloc(3*nbl)
igpgrb2=dblalloc(nbasis*nbl*max(1,nd-6))
endif
endif
endif
itaua=ifuna
ivtaua=ifuna
ivvtaua=ifuna
ilapl_rhoa=ifuna
ivlapl_rhoa=ifuna
ivvlapl_rhoa=ifuna
itaub=ifuna
ivtaub=ifuna
ivvtaub=ifuna
ilapl_rhob=ifuna
ivlapl_rhob=ifuna
ivvlapl_rhob=ifuna
itau=ifuna
ivtau=ifuna
ilapl_rho=ifuna
ivlapl_rho=ifuna
if(mgga.gt.0.or.route.eq.'den1'.or.route.eq.'den2') then
if(dero.gt.1) then
write(iout,*) 'Not implemented for meta-GGA functionals!'
call mrccend(1)
endif
itaua=dblalloc(nbl)
ivtaua=dblalloc(nbl)
ivvtaua=dblalloc(nbl)
ilapl_rhoa=dblalloc(nbl)
ivlapl_rhoa=dblalloc(nbl)
ivvlapl_rhoa=dblalloc(nbl)
if(shltype.eq.2) then
itaub=dblalloc(nbl)
ivtaub=dblalloc(nbl)
ivvtaub=dblalloc(nbl)
ilapl_rhob=dblalloc(nbl)
ivlapl_rhob=dblalloc(nbl)
ivvlapl_rhob=dblalloc(nbl)
itau=dblalloc(2*nbl)
ivtau=dblalloc(2*nbl)
ilapl_rho=dblalloc(2*nbl)
ivlapl_rho=dblalloc(2*nbl)
else
itaub=itaua
ivtaub=ivtaua
ivvtaub=ivvtaua
ilapl_rhob=ilapl_rhoa
ivlapl_rhob=ivlapl_rhoa
ivvlapl_rhob=ivvlapl_rhoa
itau=itaua
ivtau=ivtaua
ilapl_rho=ilapl_rhoa
ivlapl_rho=ivlapl_rhoa
endif
endif
C Calculate exchange-correlation matrix
if(dero.eq.0) then
write(iout,*) 'Calculating the exchange-correlation matrix...'
else if(dero.eq.1.or.verbosity.ge.3) then
write(iout,*) 'Calculation of the gradient of the XC energy... '
endif
#if defined (MPI)
xyzcount=0
#endif
do iblock=1,nblock
#if defined (MPI)
if(xyzcount.eq.rank) then
#endif
nb=nbl
if(iblock.eq.nblock) nb=nbll
call dft_func(nb,dcore(igrid+3*(iblock-1)*nbl),
$dcore(iweight+(iblock-1)*nbl),natoms,nangmax,ncontrmax,nprimmax,
$ncartmax,nsphermax,icore(inang),icore(incontr),icore(inprim),
$dcore(igexp),dcore(igcoef),dcore(icoord),dcore(ictostr),cartg,
$dcore(idvec),nbasis,dcore(ivxca),dcore(igexp2),exf,itol,
$dcore(igpgra),dcore(itrmat),moa,nal,dcore(ilmata),dcore(irhoa),
$dcore(isigmaaa),dcore(ifuna),dcore(isgvaa),nd,dcore(izk),
$dcore(ivrhoa),dcore(ivsigmaaa),minpfile,iout,dcore(irhob),
$dcore(ivrhob),dcore(isigmabb),dcore(isigmaab),dcore(ivsigmabb),
$dcore(ivsigmaab),scftype,mob,nbe,dcore(ilmatb),dcore(ivxcb),
$dcore(ifunb),dcore(igpgrb),dcore(isgvbb),dcore(isgvab),cf,cfe,
$icore(inangmin),grad,dero,dcore(igrhoa),dcore(igrhob),icore(igcn),
$icore(idvec0),icore(ibfmap),focka,fockb,dcore(imma),dcore(immb),
$icore(iiatrange),nfunc,nlfunc,cfunc,dcore(itaua),dcore(itaub),
$dcore(ivtaua),dcore(ivtaub),dcore(ivvtaua),dcore(ivvtaub),mgga,
$dcore(irho),dcore(ivrho),dcore(isigma),dcore(ivsigma),dcore(itau),
$dcore(ivtau),dcore(ilapl_rhoa),dcore(ilapl_rhob),
$dcore(ivlapl_rhoa),dcore(ivlapl_rhob),dcore(ivvlapl_rhoa),
$dcore(ivvlapl_rhob),dcore(ilapl_rho),dcore(ivlapl_rho),
$dcore(idensity+(iblock-1)*nbl),dcore(igradient+(iblock-1)*nbl),
$lnl,dcore(iv2rhoa2),dcore(iv2rhob2),dcore(iv2rhoab),
$dcore(iv2rhoasigmaaa),dcore(iv2rhoasigmaab),dcore(iv2rhoasigmabb),
$dcore(iv2rhobsigmabb),dcore(iv2rhobsigmaab),dcore(iv2rhobsigmaaa),
$dcore(iv2sigmaaa2),dcore(iv2sigmaaaab),dcore(iv2sigmaaabb),
$dcore(iv2sigmaab2),dcore(iv2sigmaabbb),dcore(iv2sigmabb2),
$dcore(ivv2rhoa2),dcore(ivv2rhob2),dcore(ivv2rhoab),
$dcore(ivv2rhoasigmaaa),dcore(ivv2rhoasigmaab),
$dcore(ivv2rhoasigmabb),dcore(ivv2rhobsigmabb),
$dcore(ivv2rhobsigmaab),dcore(ivv2rhobsigmaaa),dcore(ivv2sigmaaa2),
$dcore(ivv2sigmaaaab),dcore(ivv2sigmaaabb),dcore(ivv2sigmaab2),
$dcore(ivv2sigmaabbb),dcore(ivv2sigmabb2),densa,densb,route,
$dcore(igdrhoa),dcore(igdrhob),dcore(idgpgra),dcore(idgpgrb),
$dcore(igraa),dcore(igrbb),dcore(igpgra2),dcore(igpgrb2),ngrid,
$dcore(igrid),dcore(iweight),dcore(idensity),dcore(ionull),
$dcore(ikappa),dcore(ionull_dn),dcore(ionull_dg),dcore(ikappa_dn),
$iblock,nbl,nblock,dcore(imind2),dcore(imaxd14),nstate,mult,
$shltype,lrs,dcore(irsw+(iblock-1)*nbl),beta,dcore(iscr),mu,
$icore(ifunc),nfuncmax,dcore(inb),dcore(ifb),dcore(iscr),ncore,
$nocca,noccb,denscorr,dcore(ijpi_a),dfnbasis,dcore(ijpi_b))
#if defined (MPI)
endif
if(xyzcount.eq.mpisize) then
xyzcount=0
else
xyzcount=xyzcount+1
endif
#endif
enddo
C Nonlocal vdW DF
if(lnl) then
#if defined (MPI)
call mpi_allreduce(dcore(idensity),dcore(ikappa),ngrid,
$MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,MPIERR)
dcore(idensity:idensity+ngrid-1)=dcore(ikappa:ikappa+ngrid-1)
call mpi_allreduce(dcore(igradient),dcore(ikappa),ngrid,
$MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,MPIERR)
dcore(igradient:igradient+ngrid-1)=dcore(ikappa:ikappa+ngrid-1)
#endif
if(lscvv10) then
call vv10nl_scf1(ngrid,dcore(iweight),
$dcore(idensity),dcore(igradient),itol,bparam,cparam,dcore(ionull),
&dcore(ikappa),dcore(ionull_dn),dcore(ionull_dg),dcore(ikappa_dn))
call maxdens14(dcore(igrid),ngrid,nblock,nbl,dcore(idensity),
&dcore(iweight),dcore(imaxd14))
#if defined (MPI)
xyzcount=0
#endif
do iblock=1,nblock
#if defined (MPI)
if(xyzcount.eq.rank) then
#endif
nb=nbl
if(iblock.eq.nblock) nb=nbll
call dft_func(nb,dcore(igrid+3*(iblock-1)*nbl),
$dcore(iweight+(iblock-1)*nbl),natoms,nangmax,ncontrmax,nprimmax,
$ncartmax,nsphermax,icore(inang),icore(incontr),icore(inprim),
$dcore(igexp),dcore(igcoef),dcore(icoord),dcore(ictostr),cartg,
$dcore(idvec),nbasis,dcore(ivxca),dcore(igexp2),exf,itol,
$dcore(igpgra),dcore(itrmat),moa,nal,dcore(ilmata),dcore(irhoa),
$dcore(isigmaaa),dcore(ifuna),dcore(isgvaa),nd,dcore(izk),
$dcore(ivrhoa),dcore(ivsigmaaa),minpfile,iout,dcore(irhob),
$dcore(ivrhob),dcore(isigmabb),dcore(isigmaab),dcore(ivsigmabb),
$dcore(ivsigmaab),scftype,mob,nbe,dcore(ilmatb),dcore(ivxcb),
$dcore(ifunb),dcore(igpgrb),dcore(isgvbb),dcore(isgvab),cf,cfe,
$icore(inangmin),grad,dero,dcore(igrhoa),dcore(igrhob),icore(igcn),
$icore(idvec0),icore(ibfmap),focka,fockb,dcore(imma),dcore(immb),
$icore(iiatrange),nfunc,nlfunc,cfunc,dcore(itaua),dcore(itaub),
$dcore(ivtaua),dcore(ivtaub),dcore(ivvtaua),dcore(ivvtaub),mgga,
$dcore(irho),dcore(ivrho),dcore(isigma),dcore(ivsigma),dcore(itau),
$dcore(ivtau),dcore(ilapl_rhoa),dcore(ilapl_rhob),
$dcore(ivlapl_rhoa),dcore(ivlapl_rhob),dcore(ivvlapl_rhoa),
$dcore(ivvlapl_rhob),dcore(ilapl_rho),dcore(ivlapl_rho),
$dcore(idensity+(iblock-1)*nbl),dcore(igradient+(iblock-1)*nbl),
$.false.,dcore(iv2rhoa2),dcore(iv2rhob2),dcore(iv2rhoab),
$dcore(iv2rhoasigmaaa),dcore(iv2rhoasigmaab),dcore(iv2rhoasigmabb),
$dcore(iv2rhobsigmabb),dcore(iv2rhobsigmaab),dcore(iv2rhobsigmaaa),
$dcore(iv2sigmaaa2),dcore(iv2sigmaaaab),dcore(iv2sigmaaabb),
$dcore(iv2sigmaab2),dcore(iv2sigmaabbb),dcore(iv2sigmabb2),
$dcore(ivv2rhoa2),dcore(ivv2rhob2),dcore(ivv2rhoab),
$dcore(ivv2rhoasigmaaa),dcore(ivv2rhoasigmaab),
$dcore(ivv2rhoasigmabb),dcore(ivv2rhobsigmabb),
$dcore(ivv2rhobsigmaab),dcore(ivv2rhobsigmaaa),dcore(ivv2sigmaaa2),
$dcore(ivv2sigmaaaab),dcore(ivv2sigmaaabb),dcore(ivv2sigmaab2),
$dcore(ivv2sigmaabbb),dcore(ivv2sigmabb2),densa,densb,'vv10',
$dcore(igdrhoa),dcore(igdrhob),dcore(idgpgra),dcore(idgpgrb),
$dcore(igraa),dcore(igrbb),dcore(igpgra2),dcore(igpgrb2),ngrid,
$dcore(igrid),dcore(iweight),dcore(idensity),dcore(ionull),
$dcore(ikappa),dcore(ionull_dn),dcore(ionull_dg),dcore(ikappa_dn),
$iblock,nbl,nblock,dcore(imind2),dcore(imaxd14),nstate,mult,
$shltype,lrs,dcore(irsw+(iblock-1)*nbl),beta,dcore(iscr),mu,
$icore(ifunc),nfuncmax,dcore(inb),dcore(ifb),dcore(iscr),ncore,
$nocca,noccb,denscorr,dcore(ijpi_a),dfnbasis,dcore(ijpi_b))
#if defined (MPI)
endif
if(xyzcount.eq.mpisize) then
xyzcount=0
else
xyzcount=xyzcount+1
endif
#endif
enddo
else
exf(16)=vv10nl(dcore(igrid),ngrid,dcore(iweight),
$dcore(idensity),dcore(igradient),dcore(ikappa),itol,bparam,cparam,
$beta)
endif
endif
C Calculate PS exchange-correlation matrix
c call dsyrk('u','t',nbasis,dfnbasis*nal,0.5d0*chfx,dcore(ifit),
c $dfnbasis*nal,1.d0,focka,nbasis)
c call filllo(focka,nbasis)
c endif
C Calculate exchange-correlation energy
call dftene(nfunc,nlfunc,cf ,cfe ,exf ,exc,verbosity,cfunc,iout)
c if(lrs)
c $call dftene(nfunc,nlfunc,cfb,cfeb,exfb,exc,verbosity,cfunc,iout)
C
if(dero.lt.2.or.verbosity.ge.3) then
if(trim(dft).ne.'off') then
if(verbosity.ge.3) then
write(iout,"(' Exchange-correlation energy [au]:',f20.12)")exc
else
write(iout,"(' Exchange-correlation energy [au]:',f20.12)")exc
endif
endif
call timer
write(iout,*)
endif
C Deallocate memory, close files
if(istore.ge.2) istore=imem+2
call dbldealloc(imem_old)
if(route.eq.'den1'.or.route.eq.'den2') close(99)
C
return
end
C
************************************************************************
subroutine dftene(nfunc,nlfunc,cf,cfe,exf,exc,verbosity,cfunc,
$iout)
************************************************************************
* Calculate and print DFT energy contribution
************************************************************************
implicit none
integer i,nfunc,nlfunc,verbosity,iout
real*8 cf(*),cfe(*),exf(nfunc+nlfunc),exc
character(len=8) c8
character(len=32) c32,cfunc(*)
#if defined (MPI)
include 'mpif.h'
real*8 scr(nfunc+nlfunc)
integer*4 mpierr
call mpi_allreduce(exf,scr,nfunc+nlfunc,
$MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,MPIERR)
exf=scr
#endif
C
do i=1,nfunc+nlfunc
if(cfe(i).ne.0.d0) then
exc=exc+cfe(i)*exf(i)
if(verbosity.ge.3) then
c32=cfunc(i)
call uppercase(c32,c32,32)
write(c8,'(f7.4)') cfe(i)
write(iout,"(1x,a34,f20.12)")
$trim(c8) // '*' // trim(c32) // ' [au]:',cfe(i)*exf(i)
endif
else if(cf(i).ne.0.d0.and.verbosity.ge.3) then
c32=cfunc(i)
call uppercase(c32,c32,32)
write(c8,'(f7.4)') cf(i)
write(iout,"(1x,a34,f20.12)")
$trim(c8) // '*' // trim(c32) // ' [au]:',cf(i)*exf(i)
endif
enddo
C
return
end
C
************************************************************************
subroutine dft_func(ngrid,grid,weight,natoms,nangmax,ncontrmax,
$nprimmax,ncartmax,nsphermax,nang,ncontr,nprim,gexp,gcoef,coord,
$ctostr,cartg,dvec,nbasis,vxca,gexp2,exf,itol,gpgra,trmat,moa,nal,
$lmata,rhoa,sigmaaa,funa,sgvaa,nd,zk,vrhoa,vsigmaaa,minpfile,iout,
$rhob,vrhob,sigmabb,sigmaab,vsigmabb,vsigmaab,scftype,mob,nbe,
$lmatb,vxcb,funb,gpgrb,sgvbb,sgvab,cf,cfe,nangmin,grad,dero,grhoa,
$grhob,gcn,dvec0,bfmap,focka,fockb,mma,mmb,iatrange,nfunc,nlfunc,
$cfunc,taua,taub,vtaua,vtaub,vvtaua,vvtaub,mgga,rho,vrho,sigma,
$vsigma,tau,vtau,lapl_rhoa,lapl_rhob,vlapl_rhoa,vlapl_rhob,
$vvlapl_rhoa,vvlapl_rhob,lapl_rho,vlapl_rho,density,gradient,lnl,
$v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,
$v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,
$v2sigmaaabb,v2sigmaab2,v2sigmaabbb,v2sigmabb2,vv2rhoa2,vv2rhob2,
$vv2rhoab,vv2rhoasigmaaa,vv2rhoasigmaab,vv2rhoasigmabb,
$vv2rhobsigmabb,vv2rhobsigmaab,vv2rhobsigmaaa,vv2sigmaaa2,
$vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,vv2sigmaabbb,vv2sigmabb2,
$densa,densb,route,gdrhoa,gdrhob,dgpgra,dgpgrb,graa,grbb,gpgra2,
$gpgrb2,nngrid,ggrid,wweight,ddensity,omeganull,kappa,omeganull_dn,
$omeganull_dg,kappa_dn,iblock,nbl,nblock,mind2,maxd14,nstate,mult,
$shltype,lrs,rsw,beta,scr,mu,func,nfuncmax,nb,fb,
$work,ncore,nocca,noccb,denscorr,jpi_a,dfnbasis,jpi_b)
************************************************************************
* Calculate exchange-correlation matrix
************************************************************************
implicit none
integer ngrid,natoms,nangmax,ncontrmax,nprimmax,ncartmax,nsphermax
integer nang(natoms),ncontr(0:nangmax,natoms),nbasis,nd,iout,i,j,n
integer nal,minpfile,nprim(0:nangmax,natoms),ibasis,scftype,nbe
integer nangmin(natoms),iatrange(2,natoms),dero,gcn,bfmap(nbasis)
integer nfunc,nlfunc,mgga,dr,nngrid,iblock,nbl,nblock,nstate,mult
integer shltype,denscorr
integer func(nfuncmax),nfuncmax,ncore,nocca,noccb,dfnbasis
real*8 mind2(nblock*(nblock-1)/2),maxd14(nblock),beta
real*8 grid(3,ngrid),gexp(nprimmax,0:nangmax,natoms),grho,sum,dtol
real*8 gcoef(nprimmax,ncontrmax,0:nangmax,natoms),funa(ngrid),a
real*8 coord(3,natoms),ctostr(ncartmax**2,0:nangmax),exf(*)
real*8 vxca(nbasis,nbasis),sgvaa(ngrid),dvec(ngrid,0:nd-1,nbasis)
real*8 gexp2(nprimmax),itol,weight(ngrid),moa(*)
real*8 dvec0(nbasis,*),scr(ngrid*3*2),mu
real*8 taua(ngrid),taub(ngrid),vtaua(ngrid),vtaub(ngrid)
real*8 vvtaua(ngrid),vvtaub(ngrid),density(ngrid),gradient(ngrid)
real*8 lmata(nal,ngrid,0:nd-1),gpgra(nbasis,ngrid),gr(3),cf(*)
real*8 lmatb(nbe,ngrid,0:nd-1),gpgrb(nbasis,ngrid),vsigmaaa(ngrid)
real*8 trmat(nsphermax*ncontrmax,ncartmax*nprimmax),funb(ngrid)
real*8 rhoa(ngrid),sigmaaa(ngrid),zk(ngrid),vrhoa(ngrid),cfe(*)
real*8 rhob(ngrid),vrhob(ngrid),sigmabb(ngrid),sigmaab(ngrid)
real*8 vsigmabb(ngrid),vsigmaab(ngrid),mob(*),mma,mmb
real*8 vxcb(nbasis,nbasis),sgvbb(ngrid),sgvab(ngrid)
real*8 focka(nbasis,nbasis),fockb(nbasis,nbasis),rsw(ngrid)
real*8 grad(3,natoms),grhoa(3,ngrid),grhob(3,ngrid)
real*8 lapl_rhoa(ngrid),vlapl_rhoa(ngrid),vvlapl_rhoa(ngrid)
real*8 lapl_rhob(ngrid),vlapl_rhob(ngrid),vvlapl_rhob(ngrid)
real*8 lapl_rho(2,ngrid),vlapl_rho(2,ngrid),graa(3,ngrid)
real*8 rho(2,ngrid),vrho(2,ngrid),sigma(3,ngrid),vsigma(3,ngrid)
real*8 tau(2,ngrid),vtau(2,ngrid),gdrhoa(3,ngrid),gdrhob(3,ngrid)
real*8 densa(nbasis,nbasis,*),densb(nbasis,nbasis,*),grbb(3,ngrid)
real*8 v2rhoa2(ngrid),v2rhob2(ngrid),v2rhoab(ngrid)
real*8 v2rhoasigmaaa(ngrid),v2rhoasigmaab(ngrid)
real*8 v2rhoasigmabb(ngrid),v2rhobsigmabb(ngrid)
real*8 v2rhobsigmaab(ngrid),v2rhobsigmaaa(ngrid)
real*8 v2sigmaaa2(ngrid),v2sigmaaaab(ngrid),v2sigmaaabb(ngrid)
real*8 v2sigmaab2(ngrid),v2sigmaabbb(ngrid),v2sigmabb2(ngrid)
real*8 vv2rhoa2(ngrid),vv2rhob2(ngrid),vv2rhoab(ngrid)
real*8 vv2rhoasigmaaa(ngrid),vv2rhoasigmaab(ngrid)
real*8 vv2rhoasigmabb(ngrid),vv2rhobsigmabb(ngrid)
real*8 vv2rhobsigmaab(ngrid),vv2rhobsigmaaa(ngrid)
real*8 vv2sigmaaa2(ngrid),vv2sigmaaaab(ngrid),vv2sigmaaabb(ngrid)
real*8 vv2sigmaab2(ngrid),vv2sigmaabbb(ngrid),vv2sigmabb2(ngrid)
real*8 dgpgra(nbasis,ngrid),dgpgrb(nbasis,ngrid),gpgra2,gpgrb2
real*8 ggrid(3,nngrid),wweight(nngrid),ddensity(nngrid)
real*8 omeganull(nngrid),kappa(nngrid),omeganull_dn(nngrid)
real*8 omeganull_dg(nngrid),kappa_dn(nngrid)
real*8 nb(ngrid),fb(ngrid),work(*),jpi_a(*),jpi_b(*)
C
character(len=4) route
character(len=32) cfunc(*)
logical cartg,lnl,lrs
#if defined (OMP)
integer omp_get_max_threads
#endif
C Calculate orbital values on grid
dtol=10.d0**(-dero-1)*dsqrt(itol)
if(nd.eq.1) then
call calcorb(ngrid,grid,natoms,nangmax,ncontrmax,nprimmax,
$ncartmax,nsphermax,nang,ncontr,nprim,gexp,gcoef,coord,ctostr,
$cartg,dvec,nbasis,gexp2,ibasis,nangmin,gcn,dtol,.true.,bfmap,
$iatrange)
else if(nd.eq.4) then
call calcorbd(ngrid,grid,natoms,nangmax,ncontrmax,nprimmax,
$ncartmax,nsphermax,nang,ncontr,nprim,gexp,gcoef,coord,ctostr,
$cartg,dvec,nbasis,gexp2,ibasis,nangmin,gcn,dtol,.true.,bfmap,
$iatrange) !30-40%
else if(nd.eq.10) then
call calcorbh(ngrid,grid,natoms,nangmax,ncontrmax,nprimmax,
$ncartmax,nsphermax,nang,ncontr,nprim,gexp,gcoef,coord,ctostr,
$cartg,dvec,nbasis,gexp2,ibasis,nangmin,gcn,dtol,.true.,bfmap,
$iatrange)
endif
if(ibasis.eq.0.and.route.ne.'den1'.and.route.ne.'den2') return
C Calculate density, density gradient, and grad(phi_i) \cdot grad(rho)
call calcdens(ngrid,nbasis,nocca,noccb,gpgra,gpgrb,dvec,moa,mob,
$lmata,lmatb,rhoa,rhob,sigmaaa,sigmabb,sigmaab,itol,nd,shltype,
$grhoa,grhob,ibasis,mma,mmb,bfmap,taua,taub,mgga,density,gradient,
$lnl,lapl_rhoa,lapl_rhob,dvec0,route,grid,weight,densa,densb,vxca,
$vxcb,gdrhoa,gdrhob,dgpgra,dgpgrb,gpgra2,moa(ncore*nbasis+1),
$mob(ncore*nbasis+1),denscorr)
C
if(denscorr.gt.0)
$call m_r(moa,mma,mob,mmb,bfmap,dvec0,ngrid,nbasis,ibasis,
$ncore,nocca,noccb,dfnbasis,nb,fb,jpi_a,jpi_b,scftype,work,
$work(shltype*nbasis+1),work(shltype*nbasis+
$dfnbasis*max(nocca,noccb)+1))
C
if(route.eq.'den2'.or.ibasis.eq.0) return
C Initialize arrays
funa=0.d0
if(nd.gt.1) then
sgvaa=0.d0
if(mgga.gt.0) then
vvtaua=0.d0
if(mgga.gt.1) vvlapl_rhoa=0.d0
endif
endif
if(shltype.eq.2) then
funb=0.d0
if(nd.gt.1) then
sgvbb=0.d0
sgvab=0.d0
if(mgga.gt.0) then
vvtaub=0.d0
if(mgga.gt.1) vvlapl_rhob=0.d0
endif
endif
endif
if(dero.eq.2) then
vv2rhoa2=0.d0
if(nd.gt.4) then
vv2rhoasigmaaa=0.d0
vv2sigmaaa2=0.d0
endif
if(shltype.eq.2) then
vv2rhob2=0.d0
vv2rhoab=0.d0
if(nd.gt.4) then
vv2rhoasigmaab=0.d0
vv2rhoasigmabb=0.d0
vv2rhobsigmabb=0.d0
vv2rhobsigmaab=0.d0
vv2rhobsigmaaa=0.d0
vv2sigmaaaab=0.d0
vv2sigmaaabb=0.d0
vv2sigmaab2=0.d0
vv2sigmaabbb=0.d0
vv2sigmabb2=0.d0
endif
endif
endif
dr=max(1,dero)
if(denscorr.gt.0) dr=dero
C Calculate functionals and functional derivatives
call calcfun(ngrid,shltype,nfunc,nlfunc,route,dr,nngrid,nblock,
$iblock,nbl,mind2,maxd14,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,
$vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,cfunc,weight,funa,funb,
$sgvaa,sgvbb,sgvab,taua,taub,vtaua,vtaub,vvtaua,vvtaub,cf,cfe,
$exf,nd,rho,vrho,sigma,vsigma,tau,vtau,lapl_rhoa,lapl_rhob,
$vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,vvlapl_rhob,lapl_rho,vlapl_rho,
$mgga,dero,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,ggrid,wweight,ddensity,dtol,omeganull,
$kappa,omeganull_dn,omeganull_dg,kappa_dn,lrs,rsw,beta,scr,mu,iout,
$func,nfuncmax,fb)
C Absorb weigths into grid-dependent quantities
call absweight(nd,ngrid,shltype,mgga,dero,weight,funa,funb,
$sgvaa,sgvbb,sgvab,vvtaua,vvtaub,vvlapl_rhoa,vvlapl_rhob,vv2rhoa2,
$vv2rhob2,vv2rhoab,vv2rhoasigmaaa,vv2sigmaaa2,vv2rhoasigmaab,
$vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,vv2rhobsigmaaa,
$vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,vv2sigmaabbb,vv2sigmabb2,fb)
if(dero.lt.2) then
C Calculate exchange-correlation matrix or the gradient of the XC energy
call calcvxc(ngrid,nbasis,sgvaa,sgvbb,sgvab,gpgra,gpgrb,
$funa,funb,dvec,vxca,vxcb,nd,shltype,lmata,lmatb,rhoa,rhob,
$iatrange,natoms,dero,grad,grhoa,grhob,lmata,lmatb,itol,gpgra,
$gpgrb,dvec0,ibasis,focka,fockb,bfmap,vxca,nal,nbe,mma,mmb,gpgra,
$gpgrb,vxca,vxcb,vvtaua,vvtaub,vvlapl_rhoa,vvlapl_rhob,mgga)!40-50%
else
C Calculate derivatives of the exchange-correlation matrix
call vxcder(ngrid,nbasis,nd,ibasis,weight,dvec,vxca,vxcb,
$focka,fockb,dvec0,bfmap,densa,densb,scftype,v2rhoa2,v2rhob2,gpgra,
$gpgrb,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,vv2rhoasigmaab,
$vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,vv2rhobsigmaaa,
$vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,vv2sigmaabbb,
$vv2sigmabb2,route,grad,natoms,lmata,lmatb,gpgra,gpgrb,vxca,vxcb,
$nal,nbe,mma,mmb,iatrange,funa,funb,graa,grbb,grhoa,grhob,gdrhoa,
$gdrhob,vxca,sigmaaa,sigmaab,sigmabb,dgpgra,dgpgrb,rhoa,rhob,sgvaa,
$sgvbb,sgvab,gpgra2,gpgrb2,nstate,mult,shltype)
endif
C
return
end
C
************************************************************************
subroutine vxcder(ngrid,nbasis,nd,ibasis,weight,dvec,vxca,vxcb,
$focka,fockb,dvec0,bfmap,densa,densb,scftype,drhoa,drhob,gpgra,
$gpgrb,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,route,grad,natoms,lmata,lmatb,gpgra3,gpgrb3,vxca3,
$vxcb3,nal,nbe,mma,mmb,iatrange,funa,funb,graa,grbb,grhoa,
$grhob,gdrhoa,gdrhob,vxca2,sigmaaa,sigmaab,sigmabb,dgpgra,dgpgrb,
$rhoa,rhob,sgvaa,sgvbb,sgvab,gpgra2,gpgrb2,nstate,mult,shltype)
************************************************************************
* Calculate derivatives of the exchange-correlation matrix
************************************************************************
implicit none
integer ngrid,nbasis,nd,ibasis,bfmap(nbasis),i,j,ii,jj,scftype,xyz
integer igrid,natoms,nal,nbe,ni,iatrange(2,natoms),iatoms,mu,mult
integer nstate,istate,shltype
real*8 weight(ngrid),dvec(ngrid,0:nd-1,ibasis),dvec0(ibasis,ngrid)
real*8 vxca(ibasis,ibasis),vxcb(ibasis,ibasis),drhoa(ngrid),tmpbi
real*8 focka(nbasis,nbasis,nstate),fockb(nbasis,nbasis,nstate)
real*8 densa(nbasis,nbasis,nstate),densb(nbasis,nbasis,nstate)
real*8 gpgra(ibasis,ngrid),gpgrb(ibasis,ngrid),tmp,funa(ngrid)
real*8 v2rhoa2(ngrid),v2rhob2(ngrid),v2rhoab(ngrid),funb(ngrid)
real*8 v2rhoasigmaaa(ngrid),v2rhoasigmaab(ngrid),grad(3,natoms)
real*8 v2rhoasigmabb(ngrid),v2rhobsigmabb(ngrid),gpgra3(nal,ngrid)
real*8 v2rhobsigmaab(ngrid),v2rhobsigmaaa(ngrid),gpgrb3(nbe,ngrid)
real*8 v2sigmaaa2(ngrid),v2sigmaaaab(ngrid),v2sigmaaabb(ngrid)
real*8 v2sigmaab2(ngrid),v2sigmaabbb(ngrid),v2sigmabb2(ngrid),ddot
real*8 lmata(nal,ngrid,0:nd-1),lmatb(nbe,ngrid,0:nd-1),rhoa(ngrid)
real*8 vxca3(nal,ibasis),vxcb3(nbe,ibasis),vxca2(nbasis)
real*8 mma(nal,ibasis),mmb(nbe,ibasis),ga1,ga2,ga3,rhob(ngrid)
real*8 sigmaaa(ngrid),sigmaab(ngrid),sigmabb(ngrid),gb1,gb2,gb3
real*8 gdrhob(3,ngrid),graa(3,ngrid),grbb(3,ngrid),saa,sbb,sab
real*8 grhoa(3,ngrid),grhob(3,ngrid),gdrhoa(3,ngrid)
real*8 dgpgra(ibasis,ngrid),dgpgrb(ibasis,ngrid),drhob(ngrid),dve
real*8 sgvaa(ngrid),sgvbb(ngrid),sgvab(ngrid),tmpa,tmpb,tmpai
real*8 gpgra2(ngrid,0:3,ibasis),gpgrb2(ngrid,0:3,ibasis),s
character(len=4) route
c Scaling of explicit gradient contribution
s=1.0d0
if(scftype.ge.2) s=2.0d0
C Loop over states
do istate=1,nstate
C Calculate density, density gradient, and sigma on grid
call dgrid(ngrid,nbasis,nd,ibasis,dvec,vxca,vxcb,dvec0,bfmap,
$densa(1,1,istate),densb(1,1,istate),scftype,drhoa,drhob,route,
$grhoa,grhob,gdrhoa,gdrhob,sigmaaa,sigmaab,sigmabb,dgpgra,dgpgrb,
$tmp,tmp,tmp,tmp,tmp)
C Calculate contribution to explicit gradient
if(route.ne.'vxcd') then
C LDA: d f/d rho * rho'_munu * (phi_mu phi_nu)'
if(scftype.ge.2) then
do iatoms=1,natoms
do xyz=1,3
tmp=0.d0
do i=iatrange(1,iatoms)+1,iatrange(2,iatoms)
tmpa=0.d0
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
C$OMP& REDUCTION(+:tmpa)
do igrid=1,ngrid
tmpa=tmpa+dvec(igrid,xyz,i)*(
$funa(igrid)*dgpgra(i,igrid)+funb(igrid)*dgpgrb(i,igrid))
enddo
C$OMP END PARALLEL DO
tmp=tmp+tmpa
enddo
grad(xyz,iatoms)=grad(xyz,iatoms)-2.d0*tmp
enddo
enddo
else
do iatoms=1,natoms
do xyz=1,3
tmp=0.d0
do i=iatrange(1,iatoms)+1,iatrange(2,iatoms)
tmpa=0.d0
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
C$OMP& REDUCTION(+:tmpa)
do igrid=1,ngrid
tmpa=tmpa+funa(igrid)*dvec(igrid,xyz,i)*dgpgra(i,igrid)
enddo
C$OMP END PARALLEL DO
tmp=tmp+tmpa
enddo
grad(xyz,iatoms)=grad(xyz,iatoms)-2.d0*tmp
enddo
enddo
endif
if(nd.gt.4) then
call dsymm('r','l',4*ngrid,ibasis,1.d0,vxca,ibasis,dvec,
$nd*ngrid,0.d0,gpgra2,4*ngrid)
if(scftype.ge.2) then
call dsymm('r','l',4*ngrid,ibasis,1.d0,vxcb,ibasis,dvec,
$nd*ngrid,0.d0,gpgrb2,4*ngrid)
C Not tested!
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid,saa,sbb,sab,ga1,gb1,ga2,gb2,ga3,gb3)
do igrid=1,ngrid
saa=2.d0*sgvaa(igrid)
sbb=2.d0*sgvbb(igrid)
sab=2.d0*sgvab(igrid)
ga1=grhoa(1,igrid)
gb1=grhob(1,igrid)
ga2=grhoa(2,igrid)
gb2=grhob(2,igrid)
ga3=grhoa(3,igrid)
gb3=grhob(3,igrid)
graa(1,igrid)=2.d0*saa*ga1+sab*gb1
graa(2,igrid)=2.d0*saa*ga2+sab*gb2
graa(3,igrid)=2.d0*saa*ga3+sab*gb3
grbb(1,igrid)=2.d0*sbb*gb1+sab*ga1
grbb(2,igrid)=2.d0*sbb*gb2+sab*ga2
grbb(3,igrid)=2.d0*sbb*gb3+sab*ga3
enddo
C$OMP END PARALLEL DO
else
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
graa(1:3,igrid)=sgvaa(igrid)*grhoa(1:3,igrid)
enddo
C$OMP END PARALLEL DO
endif
do iatoms=1,natoms
do mu=iatrange(1,iatoms)+1,iatrange(2,iatoms)
call grdens(ngrid,dvec(1,0,mu),gpgra2(1,0,mu),graa,
$grad(1,iatoms),grad(2,iatoms),grad(3,iatoms))
if(scftype.ge.2)
$ call grdens(ngrid,dvec(1,0,mu),gpgrb2(1,0,mu),grbb,
$grad(1,iatoms),grad(2,iatoms),grad(3,iatoms))
enddo
enddo
endif
endif
C Calculate the implicit gradient of XC matrix
if(nd.eq.4) then
C LDA: d^2 f/d rho^2 * rho' * phi_mu
if(scftype.ge.2) then
if(mult.eq.1) then
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
dgpgra(1:ibasis,igrid)=dvec0(1:ibasis,igrid)*
$(v2rhoa2(igrid)*drhoa(igrid)+v2rhoab(igrid)*drhob(igrid))
dgpgrb(1:ibasis,igrid)=dvec0(1:ibasis,igrid)*
$(v2rhob2(igrid)*drhob(igrid)+v2rhoab(igrid)*drhoa(igrid))
enddo
C$OMP END PARALLEL DO
else
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
dgpgra(1:ibasis,igrid)=dvec0(1:ibasis,igrid)*
$(v2rhoa2(igrid)*drhoa(igrid)-v2rhoab(igrid)*drhob(igrid))
dgpgrb(1:ibasis,igrid)=dvec0(1:ibasis,igrid)*
$(v2rhob2(igrid)*drhob(igrid)-v2rhoab(igrid)*drhoa(igrid))
enddo
C$OMP END PARALLEL DO
endif
else
if(mult.eq.1) then ! singlet
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
dgpgra(1:ibasis,igrid)=0.5d0*
$v2rhoa2(igrid)*drhoa(igrid)*dvec0(1:ibasis,igrid)
enddo
C$OMP END PARALLEL DO
else ! triplet
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
dgpgra(1:ibasis,igrid)=dvec0(1:ibasis,igrid)*
$(v2rhoa2(igrid)-v2rhoab(igrid))*drhoa(igrid)
enddo
C$OMP END PARALLEL DO
endif
endif
else
C GGA: sum_zeta d^2 f/d rho d zeta * rho' * phi_mu +
C d^2 f/d gamma_aa d zeta * rho' * grad(phi_mu) \cdot grad(rho_a)
if(scftype.ge.2) then
if(mult.eq.1) then ! singlet
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
if(rhoa(igrid).gt.0.d0) then
dgpgra(1:ibasis,igrid)=
$(v2rhoa2(igrid)*drhoa(igrid)+v2rhoab(igrid)*drhob(igrid)+
$ v2rhoasigmaaa(igrid)*sigmaaa(igrid)+
$ v2rhoasigmabb(igrid)*sigmabb(igrid)+
$ v2rhoasigmaab(igrid)*sigmaab(igrid))*dvec0(1:ibasis,igrid)+
$2d0*((2d0*v2rhoasigmaaa(igrid)+v2rhoasigmaab(igrid))*drhoa(igrid)+
$ (2d0*v2rhobsigmaaa(igrid)+v2rhobsigmaab(igrid))*drhob(igrid)+
$(2.d0*v2sigmaaa2 (igrid)+v2sigmaaaab(igrid))*sigmaaa(igrid)+
$(2.d0*v2sigmaaabb(igrid)+v2sigmaabbb(igrid))*sigmabb(igrid)+
$(2.d0*v2sigmaaaab(igrid)+v2sigmaab2 (igrid))*sigmaab(igrid)
$)*gpgra(1:ibasis,igrid)+
$4.d0*sgvaa(igrid)*(dvec(igrid,1,1:ibasis)*gdrhoa(1,igrid)+
$ dvec(igrid,2,1:ibasis)*gdrhoa(2,igrid)+
$ dvec(igrid,3,1:ibasis)*gdrhoa(3,igrid))+
$2.d0*sgvab(igrid)*(dvec(igrid,1,1:ibasis)*gdrhob(1,igrid)+
$ dvec(igrid,2,1:ibasis)*gdrhob(2,igrid)+
$ dvec(igrid,3,1:ibasis)*gdrhob(3,igrid))
else
dgpgra(1:ibasis,igrid)=0.d0
endif
if(rhob(igrid).gt.0.d0) then
dgpgrb(1:ibasis,igrid)=
$(v2rhob2(igrid)*drhob(igrid)+v2rhoab(igrid)*drhoa(igrid)+
$ v2rhobsigmabb(igrid)*sigmabb(igrid)+
$ v2rhobsigmaaa(igrid)*sigmaaa(igrid)+
$ v2rhobsigmaab(igrid)*sigmaab(igrid))*dvec0(1:ibasis,igrid)+
$2d0*((2d0*v2rhobsigmabb(igrid)+v2rhobsigmaab(igrid))*drhob(igrid)+
$ (2d0*v2rhoasigmabb(igrid)+v2rhoasigmaab(igrid))*drhoa(igrid)+
$(2.d0*v2sigmabb2 (igrid)+v2sigmaabbb(igrid))*sigmabb(igrid)+
$(2.d0*v2sigmaaabb(igrid)+v2sigmaaaab(igrid))*sigmaaa(igrid)+
$(2.d0*v2sigmaabbb(igrid)+v2sigmaab2 (igrid))*sigmaab(igrid)
$)*gpgrb(1:ibasis,igrid)+
$4.d0*sgvbb(igrid)*(dvec(igrid,1,1:ibasis)*gdrhob(1,igrid)+
$ dvec(igrid,2,1:ibasis)*gdrhob(2,igrid)+
$ dvec(igrid,3,1:ibasis)*gdrhob(3,igrid))+
$2.d0*sgvab(igrid)*(dvec(igrid,1,1:ibasis)*gdrhoa(1,igrid)+
$ dvec(igrid,2,1:ibasis)*gdrhoa(2,igrid)+
$ dvec(igrid,3,1:ibasis)*gdrhoa(3,igrid))
else
dgpgrb(1:ibasis,igrid)=0.d0
endif
enddo
C$OMP END PARALLEL DO
else ! triplet
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
if(rhoa(igrid).gt.0.d0) then
dgpgra(1:ibasis,igrid)=
$(v2rhoa2(igrid)*drhoa(igrid)-v2rhoab(igrid)*drhob(igrid)+
$ v2rhoasigmaaa(igrid)*sigmaaa(igrid)-
$ v2rhoasigmabb(igrid)*sigmabb(igrid))*dvec0(1:ibasis,igrid)+
$2d0*((2d0*v2rhoasigmaaa(igrid))*drhoa(igrid)-
$ (2d0*v2rhobsigmaaa(igrid))*drhob(igrid)+
$(2.d0*v2sigmaaa2 (igrid))*sigmaaa(igrid)-
$(2.d0*v2sigmaaabb(igrid))*sigmabb(igrid))*gpgra(1:ibasis,igrid)+
$4.d0*sgvaa(igrid)*(dvec(igrid,1,1:ibasis)*gdrhoa(1,igrid)+
$ dvec(igrid,2,1:ibasis)*gdrhoa(2,igrid)+
$ dvec(igrid,3,1:ibasis)*gdrhoa(3,igrid))-
$2.d0*sgvab(igrid)*(dvec(igrid,1,1:ibasis)*gdrhob(1,igrid)+
$ dvec(igrid,2,1:ibasis)*gdrhob(2,igrid)+
$ dvec(igrid,3,1:ibasis)*gdrhob(3,igrid))
else
dgpgra(1:ibasis,igrid)=0.d0
endif
if(rhob(igrid).gt.0.d0) then
dgpgrb(1:ibasis,igrid)=
$(v2rhob2(igrid)*drhob(igrid)-v2rhoab(igrid)*drhoa(igrid)+
$ v2rhobsigmabb(igrid)*sigmabb(igrid)-
$ v2rhobsigmaaa(igrid)*sigmaaa(igrid))*dvec0(1:ibasis,igrid)+
$2d0*((2d0*v2rhobsigmabb(igrid))*drhob(igrid)-
$ (2d0*v2rhoasigmabb(igrid))*drhoa(igrid)+
$(2.d0*v2sigmabb2 (igrid))*sigmabb(igrid)-
$(2.d0*v2sigmaaabb(igrid))*sigmaaa(igrid))*gpgrb(1:ibasis,igrid)+
$4.d0*sgvbb(igrid)*(dvec(igrid,1,1:ibasis)*gdrhob(1,igrid)+
$ dvec(igrid,2,1:ibasis)*gdrhob(2,igrid)+
$ dvec(igrid,3,1:ibasis)*gdrhob(3,igrid))-
$2.d0*sgvab(igrid)*(dvec(igrid,1,1:ibasis)*gdrhoa(1,igrid)+
$ dvec(igrid,2,1:ibasis)*gdrhoa(2,igrid)+
$ dvec(igrid,3,1:ibasis)*gdrhoa(3,igrid))
else
dgpgrb(1:ibasis,igrid)=0.d0
endif
enddo
C$OMP END PARALLEL DO
endif
else
if(mult.eq.1) then !singlet
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
if(rhoa(igrid).gt.0.d0) then
dgpgra(1:ibasis,igrid)=0.5d0*(
C zeta = rhoa
$(v2rhoa2(igrid) * drhoa(igrid)+
$ 0.5d0*v2rhoasigmaaa(igrid)*sigmaaa(igrid))*dvec0(1:ibasis,igrid)+
C zeta = sigmaaa
$(2.0d0*v2rhoasigmaaa(igrid)*drhoa(igrid)+
$ 0.5d0*v2sigmaaa2(igrid)*sigmaaa(igrid))*gpgra(1:ibasis,igrid)+
C Del rhoa derivatives
$ 2.0d0*sgvaa(igrid)*(dvec(igrid,1,1:ibasis)*gdrhoa(1,igrid)+
$ dvec(igrid,2,1:ibasis)*gdrhoa(2,igrid)+
$ dvec(igrid,3,1:ibasis)*gdrhoa(3,igrid)))
else
dgpgra(1:ibasis,igrid)=0.d0
endif
enddo
C$OMP END PARALLEL DO
else !triplet
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
if(rhoa(igrid).gt.0.d0) then
dgpgra(1:ibasis,igrid)=
$((v2rhoa2(igrid)-v2rhoab(igrid))*drhoa(igrid)+
$ (v2rhoasigmaaa(igrid)-v2rhoasigmabb(igrid))*sigmaaa(igrid)
$)*dvec0(1:ibasis,igrid)+
$4d0*((v2rhoasigmaaa(igrid)-v2rhobsigmaaa(igrid))*drhoa(igrid)+
$ (v2sigmaaa2(igrid)-v2sigmaaabb(igrid))*sigmaaa(igrid)
$ )*gpgra(1:ibasis,igrid)+2.d0*(2.d0*sgvaa(igrid)-sgvab(igrid))*
$ (dvec(igrid,1,1:ibasis)*gdrhoa(1,igrid)+
$ dvec(igrid,2,1:ibasis)*gdrhoa(2,igrid)+
$ dvec(igrid,3,1:ibasis)*gdrhoa(3,igrid))
else
dgpgra(1:ibasis,igrid)=0.d0
endif
enddo
C$OMP END PARALLEL DO
endif
endif
endif
C LDA: int d^2 f/d rho^2 * rho' * phi_mu * phi_nu dr
call dsyr2k('l','n',ibasis,ngrid,1.d0,dvec0,ibasis,
$dgpgra,ibasis,0.d0,vxca,ibasis)
if(scftype.ge.2)
$call dsyr2k('l','n',ibasis,ngrid,1.d0,dvec0,ibasis,
$dgpgrb,ibasis,0.d0,vxcb,ibasis)
C Add contribution to derivative Vxc
call addvxc(nbasis,ibasis,bfmap,focka(1,1,istate),
$fockb(1,1,istate),vxca,vxcb,scftype)
enddo !istate
C Calculate contribution to explicit gradient
if(route.ne.'vxcd') then
if(nd.eq.4) then
if(scftype.ge.2) then
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
gpgra3(1:nal,igrid)=lmata(1:nal,igrid,0)*
$(v2rhoa2(igrid)*drhoa(igrid)+v2rhoab(igrid)*drhob(igrid))
gpgrb3(1:nbe,igrid)=lmatb(1:nbe,igrid,0)*
$(v2rhob2(igrid)*drhob(igrid)+v2rhoab(igrid)*drhoa(igrid))
enddo
C$OMP END PARALLEL DO
else
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
gpgra3(1:nal,igrid)=
$v2rhoa2(igrid)*drhoa(igrid)*lmata(1:nal,igrid,0)
enddo
C$OMP END PARALLEL DO
endif
else
if(scftype.ge.2) then
C Not tested!
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
gpgra3(1:nal,igrid)=lmata(1:nal,igrid,0)*
$(v2rhoa2(igrid)*drhoa(igrid)+v2rhoab(igrid)*drhob(igrid)+
$ (v2rhoasigmaaa(igrid)*sigmaaa(igrid)+
$ v2rhoasigmabb(igrid)*sigmabb(igrid)+
$ v2rhoasigmaab(igrid)*sigmaab(igrid)))
gpgrb3(1:nbe,igrid)=lmatb(1:nbe,igrid,0)*
$(v2rhob2(igrid)*drhob(igrid)+v2rhoab(igrid)*drhoa(igrid)+
$ (v2rhobsigmaaa(igrid)*sigmaaa(igrid)+
$ v2rhobsigmabb(igrid)*sigmabb(igrid)+
$ v2rhobsigmaab(igrid)*sigmaab(igrid)))
enddo
C$OMP END PARALLEL DO
else
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
gpgra3(1:nal,igrid)=lmata(1:nal,igrid,0)*
$(v2rhoa2(igrid)*drhoa(igrid)+
$0.5d0*v2rhoasigmaaa(igrid)*sigmaaa(igrid))
enddo
C$OMP END PARALLEL DO
endif
endif
do xyz=1,3
call dgemm('n','n',nal,ibasis,ngrid,s,gpgra3,nal,
$dvec(1,xyz,1),nd*ngrid,0.d0,vxca3,nal)
if(scftype.ge.2)
$ call dgemm('n','n',nbe,ibasis,ngrid,s,gpgrb3,nbe,
$dvec(1,xyz,1),nd*ngrid,0.d0,vxcb3,nbe)
do iatoms=1,natoms
ni=iatrange(2,iatoms)-iatrange(1,iatoms)
if(ni.gt.0) then
i=iatrange(1,iatoms)+1
grad(xyz,iatoms)=grad(xyz,iatoms)-!2.d0*
$ddot(ni*nal,mma(1,i),1,vxca3(1,i),1)
if(scftype.ge.2)
$ grad(xyz,iatoms)=grad(xyz,iatoms)-!2.d0*
$ddot(ni*nbe,mmb(1,i),1,vxcb3(1,i),1)
endif
enddo
enddo
if(nd.gt.4) then
call dgemm('t','n',4*ngrid,ibasis,nal,1.d0,lmata,nal,mma,nal,
$0.d0,gpgra2(1,0,1),4*ngrid)
if(scftype.ge.2) then
call dgemm('t','n',4*ngrid,ibasis,nbe,1.d0,lmatb,nbe,mmb,nbe,
$0.d0,gpgrb2(1,0,1),4*ngrid)
C Not tested!
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid,saa,sbb,sab,ga1,gb1,ga2,gb2,ga3,gb3)
do igrid=1,ngrid
saa=2.d0*sgvaa(igrid)
sbb=2.d0*sgvbb(igrid)
sab=2.d0*sgvab(igrid)
ga1=gdrhoa(1,igrid)
gb1=gdrhob(1,igrid)
ga2=gdrhoa(2,igrid)
gb2=gdrhob(2,igrid)
ga3=gdrhoa(3,igrid)
gb3=gdrhob(3,igrid)
graa(1,igrid)=2.d0*saa*ga1+sab*gb1
graa(2,igrid)=2.d0*saa*ga2+sab*gb2
graa(3,igrid)=2.d0*saa*ga3+sab*gb3
grbb(1,igrid)=2.d0*sbb*gb1+sab*ga1
grbb(2,igrid)=2.d0*sbb*gb2+sab*ga2
grbb(3,igrid)=2.d0*sbb*gb3+sab*ga3
saa=2.0d0*(v2rhoasigmaaa(igrid)*drhoa(igrid)+
$ v2rhobsigmaaa(igrid)*drhob(igrid)+
$ v2sigmaaa2(igrid) *sigmaaa(igrid)+
$ v2sigmaaabb(igrid)*sigmabb(igrid)+
$ v2sigmaaaab(igrid)*sigmaab(igrid))
sbb=2.0d0*(v2rhoasigmabb(igrid)*drhoa(igrid)+
$ v2rhobsigmabb(igrid)*drhob(igrid)+
$ v2sigmaaabb(igrid)*sigmaaa(igrid)+
$ v2sigmabb2(igrid) *sigmabb(igrid)+
$ v2sigmaabbb(igrid)*sigmaab(igrid))
sab=2.0d0*(v2rhoasigmaab(igrid)*drhoa(igrid)+
$ v2rhobsigmaab(igrid)*drhob(igrid)+
$ v2sigmaaaab(igrid)*sigmaaa(igrid)+
$ v2sigmaabbb(igrid)*sigmabb(igrid)+
$ v2sigmaab2(igrid) *sigmaab(igrid))
ga1=grhoa(1,igrid)
gb1=grhob(1,igrid)
ga2=grhoa(2,igrid)
gb2=grhob(2,igrid)
ga3=grhoa(3,igrid)
gb3=grhob(3,igrid)
graa(1,igrid)=graa(1,igrid)+2.d0*saa*ga1+sab*gb1
graa(2,igrid)=graa(2,igrid)+2.d0*saa*ga2+sab*gb2
graa(3,igrid)=graa(3,igrid)+2.d0*saa*ga3+sab*gb3
grbb(1,igrid)=grbb(1,igrid)+2.d0*sbb*gb1+sab*ga1
grbb(2,igrid)=grbb(2,igrid)+2.d0*sbb*gb2+sab*ga2
grbb(3,igrid)=grbb(3,igrid)+2.d0*sbb*gb3+sab*ga3
enddo
C$OMP END PARALLEL DO
else
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
graa(1:3,igrid)=sgvaa(igrid)*gdrhoa(1:3,igrid)+
$(v2rhoasigmaaa(igrid)*drhoa(igrid)+
$ 0.25d0*v2sigmaaa2(igrid)*sigmaaa(igrid))*grhoa(1:3,igrid)
enddo
C$OMP END PARALLEL DO
endif
do iatoms=1,natoms
do mu=iatrange(1,iatoms)+1,iatrange(2,iatoms)
call grdens(ngrid,dvec(1,0,mu),gpgra2(1,0,mu),graa,
$grad(1,iatoms),grad(2,iatoms),grad(3,iatoms))
if(scftype.ge.2)
$ call grdens(ngrid,dvec(1,0,mu),gpgrb2(1,0,mu),grbb,
$grad(1,iatoms),grad(2,iatoms),grad(3,iatoms))
enddo
enddo
endif
endif
C
return
end
C
#if defined (LIBXC)
************************************************************************
subroutine libxcifc(ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,
$vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,shltype,dft,weight,funa,
$funb,sgvaa,sgvbb,sgvab,taua,taub,vtaua,vtaub,vvtaua,vvtaub,cf,exf,
$nd,rho,vrho,sigma,vsigma,tau,vtau,lapl_rhoa,lapl_rhob,vlapl_rhoa,
$vlapl_rhob,vvlapl_rhoa,vvlapl_rhob,lapl_rho,vlapl_rho,mgga,dero,
$v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,
$v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,
$v2sigmaaabb,v2sigmaab2,v2sigmaabbb,v2sigmabb2,vv2rhoa2,vv2rhob2,
$vv2rhoab,vv2rhoasigmaaa,vv2rhoasigmaab,vv2rhoasigmabb,
$vv2rhobsigmabb,vv2rhobsigmaab,vv2rhobsigmaaa,vv2sigmaaa2,
$vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,vv2sigmaabbb,vv2sigmabb2,
$lrs,rsw,ideriv,mu,scr,iout,func,fb)
************************************************************************
* Interface to the Libxc library
************************************************************************
use xc_f03_lib_m
implicit none
type(xc_f03_func_t) :: xc_func
type(xc_f03_func_info_t) :: xc_info
integer ngrid,shltype,i,nd,nnd,mgga,mmgga,ngrid8,dero,ideriv,iout
integer func
real*8 rhoa(ngrid),rhob(ngrid),sigmaaa(ngrid),sigmabb(ngrid),rsw
real*8 sigmaab(ngrid),zk(ngrid),vrhoa(ngrid),vrhob(ngrid)
real*8 vsigmaaa(ngrid),vsigmabb(ngrid),vsigmaab(ngrid)
real*8 weight,funa,funb,sgvaa,sgvbb,sgvab,cf,exf,fb(ngrid)
real*8 taua(ngrid),taub(ngrid),vtaua(ngrid),vtaub(ngrid)
real*8 vvtaua(ngrid),vvtaub(ngrid),v2rhosigma(6,ngrid)
real*8 lapl_rhoa(ngrid),vlapl_rhoa(ngrid),vvlapl_rhoa(ngrid)
real*8 lapl_rhob(ngrid),vlapl_rhob(ngrid),vvlapl_rhob(ngrid)
real*8 lapl_rho(2,ngrid),vlapl_rho(2,ngrid),v2sigma2(6,ngrid)
real*8 rho(2,ngrid),vrho(2,ngrid),sigma(3,ngrid),vsigma(3,ngrid)
real*8 tau(2,ngrid),vtau(2,ngrid),v2rho2(3,ngrid)
real*8 v2rhoa2(ngrid),v2rhob2,v2rhoab,v2rhoasigmaaa(ngrid)
real*8 v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa
real*8 v2sigmaaa2(ngrid),v2sigmaaaab,v2sigmaaabb,v2sigmaab2
real*8 v2sigmabb2,v2rhoasigmaab,v2sigmaabbb
real*8 vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,vv2rhoasigmaab
real*8 vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,vv2rhobsigmaaa
real*8 vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2
real*8 vv2sigmaabbb,vv2sigmabb2,mu,scr(ngrid,3*2)
character(len=32) dft
logical lrs,lexc
C
nnd=nd
ngrid8=ngrid
mmgga=0
if(shltype.eq.1) then
call xc_f03_func_init(xc_func,
$xc_f03_functional_get_number(dft),XC_UNPOLARIZED)
xc_info=xc_f03_func_get_info(xc_func)
lexc=mod(xc_f03_func_info_get_flags(xc_info),2).eq.1
select case(xc_f03_func_info_get_family(xc_info))
case(XC_FAMILY_LDA)
nnd=1
if(lexc) then
call xc_f03_lda_exc_vxc(xc_func,ngrid8,rhoa(1),zk(1),vrhoa(1))
else
zk=0.d0
call xc_f03_lda_vxc(xc_func,ngrid8,rhoa(1),vrhoa(1))
endif
if(dero.eq.2) then
nnd=4
call xc_f03_lda_fxc(xc_func,ngrid8,rhoa(1),v2rhoa2(1))
v2rhoa2=2.d0*v2rhoa2
endif
case(XC_FAMILY_GGA,XC_FAMILY_HYB_GGA)
if(lexc) then
call xc_f03_gga_exc_vxc(xc_func,ngrid8,rhoa(1),sigmaaa(1),
$zk(1),vrhoa(1),vsigmaaa(1))
else
zk=0.d0
call xc_f03_gga_vxc(xc_func,ngrid8,rhoa(1),sigmaaa(1),
$vrhoa(1),vsigmaaa(1))
endif
vsigmaaa=4.d0*vsigmaaa
if(dero.eq.2) then
call xc_f03_gga_fxc(xc_func,ngrid8,rhoa(1),sigmaaa(1),
$v2rhoa2(1),v2rhoasigmaaa(1),v2sigmaaa2(1))
v2rhoa2=2.d0*v2rhoa2
v2rhoasigmaaa=4.d0*v2rhoasigmaaa
v2sigmaaa2=16.d0*v2sigmaaa2
endif
case(XC_FAMILY_MGGA,XC_FAMILY_HYB_MGGA)
mmgga=mgga
if(lexc) then
call xc_f03_mgga_exc_vxc(xc_func,ngrid8,rhoa(1),sigmaaa(1),
$lapl_rhoa(1),taua(1),zk(1),vrhoa(1),vsigmaaa(1),vlapl_rhoa(1),
$vtaua(1))
else
zk=0.d0
call xc_f03_mgga_vxc(xc_func,ngrid8,rhoa(1),sigmaaa(1),
$lapl_rhoa(1),taua(1),vrhoa(1),vsigmaaa(1),vlapl_rhoa(1),vtaua(1))
endif
vtaua=0.5d0*vtaua
vsigmaaa=4.d0*vsigmaaa
end select
zk=rhoa*zk
else
call xc_f03_func_init(xc_func,
$xc_f03_functional_get_number(dft),XC_POLARIZED)
xc_info=xc_f03_func_get_info(xc_func)
lexc=mod(xc_f03_func_info_get_flags(xc_info),2).eq.1
call libxcpack(ngrid,rho,rhoa,rhob)
select case(xc_f03_func_info_get_family(xc_info))
case(XC_FAMILY_LDA)
nnd=1
if(lexc) then
call xc_f03_lda_exc_vxc(xc_func,ngrid8,rho(1,1),zk(1),
$vrho(1,1))
else
zk=0.d0
call xc_f03_lda_vxc(xc_func,ngrid8,rho(1,1),vrho(1,1))
endif
if(dero.eq.2) then
nnd=4
call xc_f03_lda_fxc(xc_func,ngrid8,rho(1,1),v2rho2(1,1))
call libxcunpack3(ngrid,v2rho2,v2rhoa2,v2rhoab,v2rhob2)
endif
case(XC_FAMILY_GGA,XC_FAMILY_HYB_GGA)
call libxcpack3(ngrid,sigma,sigmaaa,sigmaab,sigmabb)
if(lexc) then
call xc_f03_gga_exc_vxc(xc_func,ngrid8,rho(1,1),sigma(1,1),
$zk(1),vrho(1,1),vsigma(1,1))
else
zk=0.d0
call xc_f03_gga_vxc(xc_func,ngrid8,rho(1,1),sigma(1,1),
$vrho(1,1),vsigma(1,1))
endif
call libxcunpack3(ngrid,vsigma,vsigmaaa,vsigmaab,vsigmabb)
if(dero.eq.2) then
call xc_f03_gga_fxc(xc_func,ngrid8,rho(1,1),sigma(1,1),
$v2rho2(1,1),v2rhosigma(1,1),v2sigma2(1,1))
call libxcunpack3(ngrid,v2rho2,v2rhoa2,v2rhoab,v2rhob2)
call libxcunpack6(ngrid,v2rhosigma,v2rhoasigmaaa,
$v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmaaa,v2rhobsigmaab,
$v2rhobsigmabb) !Not tested
call libxcunpack6(ngrid,v2sigma2,v2sigmaaa2,v2sigmaaaab,
$v2sigmaaabb,v2sigmaab2,v2sigmaabbb,v2sigmabb2) !Not tested
endif
case(XC_FAMILY_MGGA,XC_FAMILY_HYB_MGGA)
mmgga=mgga
call libxcpack3(ngrid,sigma,sigmaaa,sigmaab,sigmabb)
call libxcpack(ngrid,tau,taua,taub)
if(mmgga.gt.1)
$ call libxcpack(ngrid,lapl_rho,lapl_rhoa,lapl_rhob)
if(lexc) then
call xc_f03_mgga_exc_vxc(xc_func,ngrid8,rho(1,1),sigma(1,1),
$lapl_rho(1,1),tau(1,1),zk(1),vrho(1,1),vsigma(1,1),vlapl_rho(1,1),
$vtau(1,1))
else
zk=0.d0
call xc_f03_mgga_vxc(xc_func,ngrid8,rho(1,1),sigma(1,1),
$lapl_rho(1,1),tau(1,1),vrho(1,1),vsigma(1,1),vlapl_rho(1,1),
$vtau(1,1))
endif
call libxcunpack3(ngrid,vsigma,vsigmaaa,vsigmaab,vsigmabb)
call libxcunpack(ngrid,vtau,vtaua,vtaub)
if(mmgga.gt.1)
$ call libxcunpack(ngrid,vlapl_rho,vlapl_rhoa,vlapl_rhob)
vtaua=0.5d0*vtaua
vtaub=0.5d0*vtaub
end select
call libxcunpack(ngrid,vrho,vrhoa,vrhob)
zk=(rhoa+rhob)*zk
endif
call xc_f03_func_end(xc_func)
C
if(func.eq.1) then
if(dft(4:6).eq.'_x_'.or.dft(5:7).eq.'_x_') then ! gga/lda or mgga
if(shltype.eq.2) then
call uks_x_libxcs
& (ideriv,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
& zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,
& v2rhoa2,v2rhob2,v2rhoab,
& v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,
& v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
& v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
& v2sigmaab2,v2sigmaabbb,v2sigmabb2,mu,scr)
else
call rks_x_libxcs(ideriv,ngrid,rhoa,sigmaaa,
& zk,vrhoa,vsigmaaa,
& v2rhoa2,v2rhoasigmaaa,v2sigmaaa2,mu,scr)
endif
elseif(dft(4:6).eq.'_c_'.or.dft(5:7).eq.'_c_') then ! gga/lda or mgga
if(shltype.eq.2) then
call uks_c_libxcs
& (ideriv,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
& zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,
& v2rhoa2,v2rhob2,v2rhoab,
& v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,
& v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
& v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
& v2sigmaab2,v2sigmaabbb,v2sigmabb2,mu,scr)
else
call rks_c_libxcs(ideriv,ngrid,rhoa,sigmaaa,
& zk,vrhoa,vsigmaaa,
& v2rhoa2,v2rhoasigmaaa,v2sigmaaa2,mu,scr)
endif
else
write(iout,*) 'Local-scaling is not available for
$this functional!'
call mrccend(1)
endif
elseif(func.eq.2) then
if(dft(4:6).eq.'_c_'.or.dft(5:7).eq.'_c_') then
if(shltype.eq.2) then
call ecmd_uks(ngrid,rhoa,rhob,zk,fb)
else
call ecmd_rks(ngrid,rhoa,zk,fb)
endif
else
write(iout,*) 'Density-based correction is not available for
$this functional!'
call mrccend(1)
endif
endif
C
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf,exf,nnd,shltype,mmgga,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
C
return
end
C
************************************************************************
subroutine libxcpack(ngrid,rho,rhoa,rhob)
************************************************************************
* Reorder 2-index arrays for the Libxc library
************************************************************************
implicit none
integer ngrid,i
real*8 rho(2,ngrid),rhoa(ngrid),rhob(ngrid)
C
do i=1,ngrid
rho(1,i)=rhoa(i)
rho(2,i)=rhob(i)
enddo
C
return
end
C
************************************************************************
subroutine libxcunpack(ngrid,rho,rhoa,rhob)
************************************************************************
* Reorder 2-index arrays returned by the Libxc library
************************************************************************
implicit none
integer ngrid,i
real*8 rho(2,ngrid),rhoa(ngrid),rhob(ngrid)
C
do i=1,ngrid
rhoa(i)=rho(1,i)
rhob(i)=rho(2,i)
enddo
C
return
end
C
************************************************************************
subroutine libxcpack3(ngrid,sigma,sigmaaa,sigmaab,sigmabb)
************************************************************************
* Reorder 3-index arrays for the Libxc library
************************************************************************
implicit none
integer ngrid,i
real*8 sigma(3,ngrid),sigmaaa(ngrid),sigmaab(ngrid),sigmabb(ngrid)
C
do i=1,ngrid
sigma(1,i)=sigmaaa(i)
sigma(2,i)=sigmaab(i)
sigma(3,i)=sigmabb(i)
enddo
C
return
end
C
************************************************************************
subroutine libxcunpack6(ngrid,v,vaaa,vaab,vabb,vbaa,vbab,vbbb)
************************************************************************
* Reorder 6-index arrays for the Libxc library
************************************************************************
implicit none
integer ngrid,i
real*8 v(6,ngrid),vaaa(ngrid),vaab(ngrid),vabb(ngrid),vbaa(ngrid)
real*8 vbab(ngrid),vbbb(ngrid)
C
do i=1,ngrid
vaaa(i)=v(1,i)
vaab(i)=v(2,i)
vabb(i)=v(3,i)
vbaa(i)=v(4,i)
vbab(i)=v(5,i)
vbbb(i)=v(6,i)
enddo
C
return
end
C
************************************************************************
subroutine libxcunpack3(ngrid,sigma,sigmaaa,sigmaab,sigmabb)
************************************************************************
* Reorder 3-index arrays for the Libxc library
************************************************************************
implicit none
integer ngrid,i
real*8 sigma(3,ngrid),sigmaaa(ngrid),sigmaab(ngrid),sigmabb(ngrid)
C
do i=1,ngrid
sigmaaa(i)=sigma(1,i)
sigmaab(i)=sigma(2,i)
sigmabb(i)=sigma(3,i)
enddo
C
return
end
C
#endif
************************************************************************
subroutine funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cs,exc,nd,shltype,mgga,dero,
$vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
************************************************************************
* Processing functional and derivative values
************************************************************************
implicit none
integer ngrid,nd,igrid,shltype,mgga,dero
real*8 weight(ngrid),zk(ngrid),vrhoa(ngrid),vrhob(ngrid),cs,exc
real*8 funa(ngrid),funb(ngrid),vsigmabb(ngrid),vsigmaab(ngrid)
real*8 vsigmaaa(ngrid),sgvaa(ngrid),sgvbb(ngrid),sgvab(ngrid),ddot
real*8 vtaua(ngrid),vtaub(ngrid),vvtaua(ngrid),vvtaub(ngrid)
real*8 vlapl_rhoa(ngrid),vlapl_rhob(ngrid),vvlapl_rhoa(ngrid)
real*8 vvlapl_rhob(ngrid),rsw(ngrid)
real*8 v2rhoa2(ngrid),v2rhob2(ngrid),v2rhoab(ngrid)
real*8 v2rhoasigmaaa(ngrid),v2rhoasigmaab(ngrid)
real*8 v2rhoasigmabb(ngrid),v2rhobsigmabb(ngrid)
real*8 v2rhobsigmaab(ngrid),v2rhobsigmaaa(ngrid)
real*8 v2sigmaaa2(ngrid),v2sigmaaaab(ngrid),v2sigmaaabb(ngrid)
real*8 v2sigmaab2(ngrid),v2sigmaabbb(ngrid),v2sigmabb2(ngrid)
real*8 vv2rhoa2(ngrid),vv2rhob2(ngrid),vv2rhoab(ngrid)
real*8 vv2rhoasigmaaa(ngrid),vv2rhoasigmaab(ngrid)
real*8 vv2rhoasigmabb(ngrid),vv2rhobsigmabb(ngrid)
real*8 vv2rhobsigmaab(ngrid),vv2rhobsigmaaa(ngrid)
real*8 vv2sigmaaa2(ngrid),vv2sigmaaaab(ngrid),vv2sigmaaabb(ngrid)
real*8 vv2sigmaab2(ngrid),vv2sigmaabbb(ngrid),vv2sigmabb2(ngrid)
logical lrs
C
c if(lrs) then
c call aweight(rsw,zk,ngrid)
c call absweight(nd,ngrid,shltype,mgga,dero,rsw,vrhoa,vrhob,
c $vsigmaaa,vsigmabb,vsigmaab,vtaua,vtaub,vlapl_rhoa,vlapl_rhob,
c $v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2sigmaaa2,v2rhoasigmaab,
c $v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
c $v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,v2sigmabb2)
c endif
exc=exc+ddot(ngrid,weight,1,zk,1)
if(cs.eq.0.d0) return
call daxpy(ngrid,cs,vrhoa,1,funa,1)
if(nd.gt.1) then
call daxpy(ngrid,cs,vsigmaaa,1,sgvaa,1)
if(mgga.gt.0) then
call daxpy(ngrid,cs,vtaua,1,vvtaua,1)
if(mgga.gt.1) call daxpy(ngrid,cs,vlapl_rhoa,1,vvlapl_rhoa,1)
endif
endif
if(shltype.eq.2) then
call daxpy(ngrid,cs,vrhob,1,funb,1)
if(nd.gt.1) then
call daxpy(ngrid,cs,vsigmabb,1,sgvbb,1)
call daxpy(ngrid,cs,vsigmaab,1,sgvab,1)
if(mgga.gt.0) then
call daxpy(ngrid,cs,vtaub,1,vvtaub,1)
if(mgga.gt.1)call daxpy(ngrid,cs,vlapl_rhob,1,vvlapl_rhob,1)
endif
endif
endif
if(dero.eq.2) then
call daxpy(ngrid,cs,v2rhoa2,1,vv2rhoa2,1)
if(nd.gt.4) then
call daxpy(ngrid,cs,v2rhoasigmaaa,1,vv2rhoasigmaaa,1)
call daxpy(ngrid,cs,v2sigmaaa2, 1,vv2sigmaaa2 ,1)
endif
if(shltype.eq.2) then
call daxpy(ngrid,cs,v2rhob2,1,vv2rhob2,1)
call daxpy(ngrid,cs,v2rhoab,1,vv2rhoab,1)
if(nd.gt.4) then
call daxpy(ngrid,cs,v2rhoasigmaab,1,vv2rhoasigmaab,1)
call daxpy(ngrid,cs,v2rhoasigmabb,1,vv2rhoasigmabb,1)
call daxpy(ngrid,cs,v2rhobsigmabb,1,vv2rhobsigmabb,1)
call daxpy(ngrid,cs,v2rhobsigmaab,1,vv2rhobsigmaab,1)
call daxpy(ngrid,cs,v2rhobsigmaaa,1,vv2rhobsigmaaa,1)
call daxpy(ngrid,cs,v2sigmaaaab ,1,vv2sigmaaaab ,1)
call daxpy(ngrid,cs,v2sigmaaabb ,1,vv2sigmaaabb ,1)
call daxpy(ngrid,cs,v2sigmaab2 ,1,vv2sigmaab2 ,1)
call daxpy(ngrid,cs,v2sigmaabbb ,1,vv2sigmaabbb ,1)
call daxpy(ngrid,cs,v2sigmabb2 ,1,vv2sigmabb2 ,1)
endif
endif
endif
C
return
end
C
************************************************************************
subroutine calcdens(ngrid,nbasis,nal,nbe,gpgra,gpgrb,dvec,moa,mob,
$lmata,lmatb,rhoa,rhob,sigmaaa,sigmabb,sigmaab,itol,nd,scftype,
$grhoa,grhob,ibasis,mma,mmb,bfmap,taua,taub,mgga,density,gradient,
$lnl,lapl_rhoa,lapl_rhob,dvec0,route,grid,weight,densa,densb,vxca,
$vxcb,gdrhoa,gdrhob,dgpgra,dgpgrb,gpgra2,moa2,mob2,denscorr)
************************************************************************
* Calculate density, density gradient, and grad(phi_mu) \cdot grad(rho)
************************************************************************
implicit none
integer igrid,ngrid,nbasis,nal,nbe,i,j,nd,scftype,ibasis,mgga
integer bfmap(nbasis),denscorr
real*8 moa(nal,nbasis),lmata(nal,ngrid,0:nd-1),gpgra(ibasis,ngrid)
real*8 moa2(nbasis,nal),mob2(nbasis,nbe),factor
real*8 mob(nbe,nbasis),lmatb(nbe,ngrid,0:nd-1),gpgrb(ibasis,ngrid)
real*8 dvec(ngrid,0:nd-1,ibasis),rhoa(ngrid),ddot,itol,ga(3),w
real*8 sigmaaa(ngrid),sigmabb(ngrid),sigmaab(ngrid),rhob(ngrid)
real*8 gb(3),grhoa(3,ngrid),grhob(3,ngrid),gai,gbi,density(ngrid)
real*8 mma(nal,ibasis),mmb(nbe,ibasis),taua(ngrid),taub(ngrid)
real*8 gradient(ngrid),lapl_rhoa(ngrid),lapl_rhob(ngrid),gpgra2
real*8 dvec0(ibasis,ngrid),grid(3,ngrid),weight(ngrid)
real*8 densa,densb,vxca,vxcb,gdrhoa,gdrhob,dgpgra,dgpgrb
logical lnl
character(len=4) route
C Store orbital values in another form for convenience and efficiency
do i=1,ibasis
dvec0(i,1:ngrid)=dvec(1:ngrid,0,i)
enddo
C Calculate density, density gradient, and density Laplacian on grid
if(route.eq.'den2') then
if(ibasis.eq.0) then
rhoa=0.d0
grhoa=0.d0
lapl_rhoa=0.d0
if(scftype.ge.2) then
rhob=0.d0
grhob=0.d0
lapl_rhob=0.d0
endif
else
call dgrid(ngrid,nbasis,nd,ibasis,dvec,vxca,vxcb,dvec0,bfmap,
$densa,densb,scftype,rhoa,rhob,route,grhoa,grhob,grhoa,grhob,
$sigmaaa,sigmaab,sigmabb,dgpgra,dgpgrb,lapl_rhoa,lapl_rhob,gpgra,
$gpgrb,gpgra2)
endif
goto 7654
endif
C Compress MO coefficient matrix
if(denscorr.eq.0) then
do i=1,ibasis
mma(1:nal,i)=moa(1:nal,bfmap(i))
enddo
if(scftype.ge.2.and.nbe.gt.0) then
do i=1,ibasis
mmb(1:nbe,i)=mob(1:nbe,bfmap(i))
enddo
endif
else
factor=1.d0
if(scftype.eq.1) factor=dsqrt(2.d0)
do i=1,ibasis
mma(1:nal,i)=factor*moa2(bfmap(i),1:nal)
enddo
if(scftype.ge.2.and.nbe.gt.0) then
do i=1,ibasis
mmb(1:nbe,i)=mob2(bfmap(i),1:nbe)
enddo
endif
endif
C Transform orbital values to MO basis
call dgemm('n','t',nal,nd*ngrid,ibasis,1.d0,mma,nal,dvec,nd*ngrid,
$0.d0,lmata,nal)
if(scftype.ge.2.and.nbe.gt.0)
$call dgemm('n','t',nbe,nd*ngrid,ibasis,1.d0,mmb,nbe,dvec,nd*ngrid,
$0.d0,lmatb,nbe)
C Calculate kinetic-energy density (tau) for meta-GGA
if(mgga.gt.0.or.route.eq.'den1'.or.route.eq.'den2') then
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
do igrid=1,ngrid
taua(igrid)=0.5d0*(
$dot_product(lmata(1:nal,igrid,1),lmata(1:nal,igrid,1))+
$dot_product(lmata(1:nal,igrid,2),lmata(1:nal,igrid,2))+
$dot_product(lmata(1:nal,igrid,3),lmata(1:nal,igrid,3)))
enddo
C$OMP END PARALLEL DO
if(scftype.ge.2.and.nbe.gt.0) then
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
do igrid=1,ngrid
taub(igrid)=0.5d0*(
$dot_product(lmatb(1:nbe,igrid,1),lmatb(1:nbe,igrid,1))+
$dot_product(lmatb(1:nbe,igrid,2),lmatb(1:nbe,igrid,2))+
$dot_product(lmatb(1:nbe,igrid,3),lmatb(1:nbe,igrid,3)))
enddo
C$OMP END PARALLEL DO
endif
endif
C Calculate the Laplacian of the density for meta-GGA
if(mgga.gt.1.or.route.eq.'den1'.or.route.eq.'den2') then
C x y z xx yy zz xy xz yz
C 1 2 3 4 5 6 7 8 9
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
do igrid=1,ngrid
lapl_rhoa(igrid)=4.d0*taua(igrid)+2.d0*
$dot_product(lmata(1:nal,igrid,0),lmata(1:nal,igrid,4)+
$ lmata(1:nal,igrid,5)+
$ lmata(1:nal,igrid,6))
enddo
C$OMP END PARALLEL DO
if(scftype.ge.2.and.nbe.gt.0) then
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
do igrid=1,ngrid
lapl_rhob(igrid)=4.d0*taub(igrid)+2.d0*
$dot_product(lmatb(1:nbe,igrid,0),lmatb(1:nbe,igrid,4)+
$ lmatb(1:nbe,igrid,5)+
$ lmatb(1:nbe,igrid,6))
enddo
C$OMP END PARALLEL DO
endif
endif
C Calculate density if no density gradient
if(nd.eq.1) then
do igrid=1,ngrid
rhoa(igrid)=ddot(nal,lmata(1,igrid,0),1,lmata(1,igrid,0),1)
if(rhoa(igrid).lt.itol) rhoa(igrid)=0.d0
enddo
if(scftype.ge.2) then
do igrid=1,ngrid
rhob(igrid)=ddot(nbe,lmatb(1,igrid,0),1,lmatb(1,igrid,0),1)
if(rhob(igrid).lt.itol) rhob(igrid)=0.d0
enddo
endif
else
C Calculate density, density gradient
C rhoa: alpha density
C rhob: beta density
C sigmaaa: dot product of the alpha density gradient with itself
C sigmabb: dot product of the beta density gradient with itself
C sigmaab: dot product of the alpha and beta density gradient
C grhoa: alpha density gradient
C grhob: beta density gradient
C gpgra: grad(phi_mu) \cdot grad(rhoa)
C gpgrb: grad(phi_mu) \cdot grad(rhob)
if(scftype.ge.2) then
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(i,gai,gbi,ga,gb)
do igrid=1,ngrid
c rhoa(igrid)=ddot(nal,lmata(1,igrid,0),1,lmata(1,igrid,0),1)
c rhob(igrid)=ddot(nbe,lmatb(1,igrid,0),1,lmatb(1,igrid,0),1)
rhoa(igrid)=dot_product(lmata(1:nal,igrid,0),
$ lmata(1:nal,igrid,0))
rhob(igrid)=dot_product(lmatb(1:nbe,igrid,0),
$ lmatb(1:nbe,igrid,0))
if(rhoa(igrid).lt.itol) then
rhoa(igrid)=0.d0
sigmaaa(igrid)=0.d0
grhoa(1,igrid)=0.d0
grhoa(2,igrid)=0.d0
grhoa(3,igrid)=0.d0
endif
if(rhob(igrid).lt.itol) then
rhob(igrid)=0.d0
sigmabb(igrid)=0.d0
grhob(1,igrid)=0.d0
grhob(2,igrid)=0.d0
grhob(3,igrid)=0.d0
endif
if(rhoa(igrid)+rhob(igrid).lt.itol) then
sigmaab(igrid)=0.d0
cycle
endif
do i=1,3
c gai=2.d0*ddot(nal,lmata(1,igrid,i),1,lmata(1,igrid,0),1)
c gbi=2.d0*ddot(nbe,lmatb(1,igrid,i),1,lmatb(1,igrid,0),1)
gai=2.d0*dot_product(lmata(1:nal,igrid,i),
$ lmata(1:nal,igrid,0))
gbi=2.d0*dot_product(lmatb(1:nbe,igrid,i),
$ lmatb(1:nbe,igrid,0))
ga(i)=gai
gb(i)=gbi
grhoa(i,igrid)=gai
grhob(i,igrid)=gbi
enddo
sigmaaa(igrid)=ga(1)*ga(1)+ga(2)*ga(2)+ga(3)*ga(3)
sigmabb(igrid)=gb(1)*gb(1)+gb(2)*gb(2)+gb(3)*gb(3)
sigmaab(igrid)=ga(1)*gb(1)+ga(2)*gb(2)+ga(3)*gb(3)
c call dgemv('n',nbasis,3,1.d0,dvec(1,igrid,1),nbasis*ngrid,
c $ga,1,0.d0,gpgra(1,igrid),1)
c call dgemv('n',nbasis,3,1.d0,dvec(1,igrid,1),nbasis*ngrid,
c $gb,1,0.d0,gpgrb(1,igrid),1)
gpgra(1:ibasis,igrid)=dvec(igrid,1,1:ibasis)*ga(1)+
$ dvec(igrid,2,1:ibasis)*ga(2)+
$ dvec(igrid,3,1:ibasis)*ga(3)
gpgrb(1:ibasis,igrid)=dvec(igrid,1,1:ibasis)*gb(1)+
$ dvec(igrid,2,1:ibasis)*gb(2)+
$ dvec(igrid,3,1:ibasis)*gb(3)
enddo
C$OMP END PARALLEL DO
else
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(i,gai,ga)
do igrid=1,ngrid
c rhoa(igrid)=ddot(nal,lmata(1,igrid,0),1,lmata(1,igrid,0),1)
rhoa(igrid)=dot_product(lmata(1:nal,igrid,0),
$ lmata(1:nal,igrid,0))
c write(6,"(40f19.14)") rhoa(igrid),grid(1:3,igrid),weight(igrid)
c write(6,"(40f19.14)") lmata(1:nal,igrid,0)
if(rhoa(igrid).lt.itol) then
rhoa(igrid)=0.d0
sigmaaa(igrid)=0.d0
grhoa(1,igrid)=0.d0
grhoa(2,igrid)=0.d0
grhoa(3,igrid)=0.d0
cycle
endif
do i=1,3
c gai=2.d0*ddot(nal,lmata(1,igrid,i),1,lmata(1,igrid,0),1)
gai=2.d0*dot_product(lmata(1:nal,igrid,i),
$ lmata(1:nal,igrid,0))
ga(i)=gai
grhoa(i,igrid)=gai
enddo
sigmaaa(igrid)=ga(1)*ga(1)+ga(2)*ga(2)+ga(3)*ga(3)
c call dgemv('n',nbasis,3,1.d0,dvec(1,igrid,1),nbasis*ngrid,
c $ga,1,0.d0,gpgra(1,igrid),1)
gpgra(1:ibasis,igrid)=dvec(igrid,1,1:ibasis)*ga(1)+
$ dvec(igrid,2,1:ibasis)*ga(2)+
$ dvec(igrid,3,1:ibasis)*ga(3)
enddo
C$OMP END PARALLEL DO
endif
endif
C Collect density and density gradient for nonlocal vdW DFs
if(lnl) then
if(scftype.ge.2) then
density=rhoa+rhob
gradient=sigmaaa+sigmabb+2.d0*sigmaab
else
density=rhoa
gradient=sigmaaa
endif
endif
C Save density
7654 continue
if(route.eq.'den1'.or.route.eq.'den2') then
if(scftype.ge.2) then
do igrid=1,ngrid
write(99) grid(1:3,igrid),weight(igrid),rhoa(igrid),
$rhob(igrid),grhoa(1:3,igrid),grhob(1:3,igrid),lapl_rhoa(igrid),
$lapl_rhob(igrid)
enddo
else
do igrid=1,ngrid
write(99) grid(1:3,igrid),weight(igrid),rhoa(igrid),
$grhoa(1:3,igrid),lapl_rhoa(igrid)
enddo
endif
endif
C
return
end
C
************************************************************************
subroutine calcvxc(ngrid,nbasis,sgvaa,sgvbb,sgvab,gpgra,
$gpgrb,funa,funb,dvec,vxca,vxcb,nd,shltype,lmata,lmatb,rhoa,rhob,
$iatrange,natoms,dero,grad,grhoa,grhob,graa,grbb,itol,gpgra2,
$gpgrb2,dvec0,ibasis,focka,fockb,bfmap,vxca2,nal,nbe,mma,mmb,
$gpgra3,gpgrb3,vxca3,vxcb3,vtaua,vtaub,vlapl_rhoa,vlapl_rhob,mgga)
************************************************************************
* Calculate exchange-correlation matrix
************************************************************************
implicit none
integer igrid,ngrid,nbasis,i,j,shltype,natoms,iatoms,jatoms,ni,ii
integer iatrange(2,natoms),nd,dero,mu,xyz,basis,jj,bfmap(nbasis)
integer ibasis,nal,nbe,mgga
real*8 sgvaa(ngrid),sgvbb(ngrid),sgvab(ngrid),gr(3)
real*8 gpgra(ibasis,ngrid),funa(ngrid),lmatb(nbe,ngrid,0:nd-1)
real*8 dvec(ngrid,0:nd-1,ibasis),vxca(ibasis,ibasis),funb(ngrid)
real*8 vxcb(ibasis,ibasis),gpgrb(ibasis,ngrid),w,ddot,itol
real*8 rhoa(ngrid),rhob(ngrid),saa,sbb,sab,ga1,gb1,ga2,gb2,ga3,gb3
real*8 grad(3,natoms),vtaua(ngrid),vtaub(ngrid),tmpa,tmpb
real*8 vlapl_rhoa(ngrid),vlapl_rhob(ngrid)
real*8 grhoa(3,ngrid),grhob(3,ngrid),graa(3,ngrid),grbb(3,ngrid)
real*8 gpgra2(ngrid,0:3,ibasis),gpgrb2(ngrid,0:3,ibasis),tmp
real*8 dvec0(ibasis,ngrid),vxca2(nbasis),lmata(nal,ngrid,0:nd-1)
real*8 focka(nbasis,nbasis),fockb(nbasis,nbasis),gpgra3(nal,ngrid)
real*8 mma(nal,ibasis),mmb(nbe,ibasis),gpgrb3(nbe,ngrid)
real*8 vxca3(nal,ibasis),vxcb3(nbe,ibasis)
C funa: weight * derivative of the functional wrt rho_a
C funb: weight * derivative of the functional wrt rho_b
C sgvaa: weight * derivative of the functional wrt gamma_aa
C sgvbb: weight * derivative of the functional wrt gamma_bb
C sgvab: weight * derivative of the functional wrt gamma_ab
if(dero.eq.0) then
C LDA: df/drho_a * phi_mu
if(nd.eq.1) then
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
gpgra(1:ibasis,igrid)=
$0.5d0*funa(igrid)*dvec0(1:ibasis,igrid)
enddo
C$OMP END PARALLEL DO
if(shltype.eq.2) then
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
gpgrb(1:ibasis,igrid)=
$0.5d0*funb(igrid)*dvec0(1:ibasis,igrid)
enddo
C$OMP END PARALLEL DO
endif
else
CGGA: df/drho_a * phi_mu + df/dgamma_aa * grad(phi_mu) \cdot grad(rho_a)
if(shltype.eq.2) then
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid,vxca2)
do igrid=1,ngrid
if(rhoa(igrid)+rhob(igrid).gt.0.d0) then
vxca2=gpgra(1:ibasis,igrid)
gpgra(1:ibasis,igrid)=
$2.d0*sgvaa(igrid)*gpgra(1:ibasis,igrid)+
$0.5d0*funa(igrid)*dvec0(1:ibasis,igrid)+
$ sgvab(igrid)*gpgrb(1:ibasis,igrid)
gpgrb(1:ibasis,igrid)=
$2.d0*sgvbb(igrid)*gpgrb(1:ibasis,igrid)+
$0.5d0*funb(igrid)*dvec0(1:ibasis,igrid)+
$ sgvab(igrid)*vxca2(1:ibasis)
else
gpgra(1:ibasis,igrid)=0.d0
gpgrb(1:ibasis,igrid)=0.d0
endif
enddo
C$OMP END PARALLEL DO
else
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
if(rhoa(igrid).gt.0.d0) then
gpgra(1:ibasis,igrid)=
$0.5d0*(sgvaa(igrid)*gpgra(1:ibasis,igrid)+
$ funa(igrid) *dvec0(1:ibasis,igrid))
else
gpgra(1:ibasis,igrid)=0.d0
endif
enddo
C$OMP END PARALLEL DO
endif
endif
C F^xc_munu = int (df/drho_a * phi_mu +
C df/dgamma_aa * grad(phi_mu) \cdot grad(rho_a)) phi_nu dr
call dsyr2k('l','n',ibasis,ngrid,1.d0,dvec0,ibasis,
$gpgra,ibasis,0.d0,vxca,ibasis) !30-40%
if(shltype.eq.2)
$ call dsyr2k('l','n',ibasis,ngrid,1.d0,dvec0,ibasis,
$gpgrb,ibasis,0.d0,vxcb,ibasis)
C meta-GGA: int dE_xc/dtau grad(chi_i) \cdot grad(chi_j) dr
if(mgga.gt.0) then
if(shltype.eq.2) then
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(i,j,igrid,tmp,tmpa,tmpb)
do i=1,ibasis
do j=1,i
tmpa=0.d0
tmpb=0.d0
do igrid=1,ngrid
tmp=dvec(igrid,1,i)*dvec(igrid,1,j)+
$ dvec(igrid,2,i)*dvec(igrid,2,j)+
$ dvec(igrid,3,i)*dvec(igrid,3,j)
tmpa=tmpa+tmp*vtaua(igrid)
tmpb=tmpb+tmp*vtaub(igrid)
enddo
vxca(i,j)=vxca(i,j)+tmpa
vxcb(i,j)=vxcb(i,j)+tmpb
enddo
enddo
C$OMP END PARALLEL DO
else
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(i,j,igrid,tmp)
do i=1,ibasis
do j=1,i
tmp=0.d0
do igrid=1,ngrid
tmp=tmp+vtaua(igrid)*(
$dvec(igrid,1,i)*dvec(igrid,1,j)+
$dvec(igrid,2,i)*dvec(igrid,2,j)+
$dvec(igrid,3,i)*dvec(igrid,3,j))
enddo
vxca(i,j)=vxca(i,j)+tmp
enddo
enddo
C$OMP END PARALLEL DO
endif
endif
C meta-GGA: int dE_xc/dLaplace_rho (Laplace(chi_i) chi_j +
C 2 grad(chi_i) \cdot grad(chi_j) + chi_i Laplace(chi_j)) dr
if(mgga.gt.1) then
if(shltype.eq.2) then
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(i,j,igrid,tmp,tmpa,tmpb)
do i=1,ibasis
do j=1,i
tmpa=0.d0
tmpb=0.d0
do igrid=1,ngrid
tmp=dvec(igrid,0,j)*(dvec(igrid,4,i) +
$ dvec(igrid,5,i) +
$ dvec(igrid,6,i))+
$ 2.d0*(dvec(igrid,1,i)* dvec(igrid,1,j) +
$ dvec(igrid,2,i)* dvec(igrid,2,j) +
$ dvec(igrid,3,i)* dvec(igrid,3,j))+
$ dvec(igrid,0,i)*(dvec(igrid,4,j) +
$ dvec(igrid,5,j) +
$ dvec(igrid,6,j))
tmpa=tmpa+tmp*vlapl_rhoa(igrid)
tmpb=tmpb+tmp*vlapl_rhob(igrid)
enddo
vxca(i,j)=vxca(i,j)+tmpa
vxcb(i,j)=vxcb(i,j)+tmpb
enddo
enddo
C$OMP END PARALLEL DO
else
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(i,j,igrid,tmp)
do i=1,ibasis
do j=1,i
tmp=0.d0
do igrid=1,ngrid
tmp=tmp+vlapl_rhoa(igrid)*(
$ dvec(igrid,0,j)*(dvec(igrid,4,i) +
$ dvec(igrid,5,i) +
$ dvec(igrid,6,i))+
$2.d0*(dvec(igrid,1,i)* dvec(igrid,1,j) +
$ dvec(igrid,2,i)* dvec(igrid,2,j) +
$ dvec(igrid,3,i)* dvec(igrid,3,j))+
$ dvec(igrid,0,i)*(dvec(igrid,4,j) +
$ dvec(igrid,5,j) +
$ dvec(igrid,6,j)))
enddo
vxca(i,j)=vxca(i,j)+tmp
enddo
enddo
C$OMP END PARALLEL DO
endif
endif
C Add Vxc to the Fock-matrix
call addvxc(nbasis,ibasis,bfmap,focka,fockb,vxca,vxcb,shltype)
else
C Calculation of the gradient of the XC energy
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
gpgra3(1:nal,igrid)=funa(igrid)*lmata(1:nal,igrid,0)
enddo
C$OMP END PARALLEL DO
if(shltype.eq.2) then
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
gpgrb3(1:nbe,igrid)=funb(igrid)*lmatb(1:nbe,igrid,0)
enddo
C$OMP END PARALLEL DO
endif
do xyz=1,3
call dgemm('n','n',nal,ibasis,ngrid,1.d0,gpgra3,nal,
$dvec(1,xyz,1),nd*ngrid,0.d0,vxca3,nal)
if(shltype.eq.2)
$ call dgemm('n','n',nbe,ibasis,ngrid,1.d0,gpgrb3,nbe,
$dvec(1,xyz,1),nd*ngrid,0.d0,vxcb3,nbe)
do iatoms=1,natoms
ni=iatrange(2,iatoms)-iatrange(1,iatoms)
if(ni.gt.0) then
i=iatrange(1,iatoms)+1
grad(xyz,iatoms)=grad(xyz,iatoms)-2.d0*
$ddot(ni*nal,mma(1,i),1,vxca3(1,i),1)
if(shltype.eq.2)
$ grad(xyz,iatoms)=grad(xyz,iatoms)-2.d0*
$ddot(ni*nbe,mmb(1,i),1,vxcb3(1,i),1)
endif
enddo
enddo
C xx yy zz xy xz yz
C 4 5 6 7 8 9
if(nd.eq.10) then
call dgemm('t','n',4*ngrid,ibasis,nal,1.d0,lmata,nal,mma,nal,
$0.d0,gpgra2(1,0,1),4*ngrid)
if(shltype.eq.2) then
call dgemm('t','n',4*ngrid,ibasis,nbe,1.d0,lmatb,nbe,mmb,nbe,
$0.d0,gpgrb2(1,0,1),4*ngrid)
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid,saa,sbb,sab,ga1,gb1,ga2,gb2,ga3,gb3)
do igrid=1,ngrid
saa=2.d0*sgvaa(igrid)
sbb=2.d0*sgvbb(igrid)
sab=2.d0*sgvab(igrid)
ga1=grhoa(1,igrid)
gb1=grhob(1,igrid)
ga2=grhoa(2,igrid)
gb2=grhob(2,igrid)
ga3=grhoa(3,igrid)
gb3=grhob(3,igrid)
graa(1,igrid)=2.d0*saa*ga1+sab*gb1
graa(2,igrid)=2.d0*saa*ga2+sab*gb2
graa(3,igrid)=2.d0*saa*ga3+sab*gb3
grbb(1,igrid)=2.d0*sbb*gb1+sab*ga1
grbb(2,igrid)=2.d0*sbb*gb2+sab*ga2
grbb(3,igrid)=2.d0*sbb*gb3+sab*ga3
enddo
C$OMP END PARALLEL DO
else
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(igrid)
do igrid=1,ngrid
graa(1:3,igrid)=sgvaa(igrid)*grhoa(1:3,igrid)
enddo
C$OMP END PARALLEL DO
endif
do iatoms=1,natoms
do mu=iatrange(1,iatoms)+1,iatrange(2,iatoms)
call grdens(ngrid,dvec(1,0,mu),gpgra2(1,0,mu),graa,
$grad(1,iatoms),grad(2,iatoms),grad(3,iatoms))
if(shltype.eq.2)
$ call grdens(ngrid,dvec(1,0,mu),gpgrb2(1,0,mu),grbb,
$grad(1,iatoms),grad(2,iatoms),grad(3,iatoms))
enddo
enddo
C meta-GGA: contribution of gradient of tau to molecular gradient
if(mgga.gt.0) then
do iatoms=1,natoms
do mu=iatrange(1,iatoms)+1,iatrange(2,iatoms)
call grtau(ngrid,dvec(1,0,mu),gpgra2(1,0,mu),
$grad(1,iatoms),grad(2,iatoms),grad(3,iatoms),vtaua)
if(shltype.eq.2)
$ call grtau(ngrid,dvec(1,0,mu),gpgrb2(1,0,mu),
$grad(1,iatoms),grad(2,iatoms),grad(3,iatoms),vtaub)
enddo
enddo
endif
endif
C
endif
C
return
end
C
************************************************************************
subroutine grtau(ngrid,dvec,gpgra2,gr1,gr2,gr3,vtaua)
************************************************************************
* Calculate the contribution of gradient of tau to molecular gradient
************************************************************************
implicit none
integer ngrid,igrid
real*8 dvec(ngrid,0:9),gpgra2(ngrid,0:3),tmp,gx,gy,gz,g1a,g2a,g3a
real*8 gr1,gr2,gr3,x11,x12,x13,x22,x23,x33,vtaua(ngrid)
C
g1a=0.d0
g2a=0.d0
g3a=0.d0
C$OMP PARALLEL DO
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,dvec,gpgra2,vtaua)
C$OMP& REDUCTION(+:g1a,g2a,g3a)
do igrid=1,ngrid
gx=gpgra2(igrid,1)
gy=gpgra2(igrid,2)
gz=gpgra2(igrid,3)
x11=dvec(igrid,4)
x22=dvec(igrid,5)
x33=dvec(igrid,6)
x12=dvec(igrid,7)
x13=dvec(igrid,8)
x23=dvec(igrid,9)
tmp=vtaua(igrid)
g1a=g1a+tmp*(gx*x11+gy*x12+gz*x13)
g2a=g2a+tmp*(gx*x12+gy*x22+gz*x23)
g3a=g3a+tmp*(gx*x13+gy*x23+gz*x33)
enddo
C$OMP END PARALLEL DO
gr1=gr1-2.d0*g1a
gr2=gr2-2.d0*g2a
gr3=gr3-2.d0*g3a
C
return
end
C
************************************************************************
subroutine grdens(ngrid,dvec,gpgra2,graa,gr1,gr2,gr3)
************************************************************************
* Calculate the contribution of density gradient to molecular gradient
************************************************************************
implicit none
integer ngrid,igrid
real*8 dvec(ngrid,0:*),gpgra2(ngrid,0:3),graa(3,ngrid)
real*8 gr1,gr2,gr3,x11,x12,x13,x21,x22,x23,x31,x32,x33,g1a,g2a,g3a
C
g1a=0.d0
g2a=0.d0
g3a=0.d0
C$OMP PARALLEL DO
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,dvec,gpgra2,graa)
C$OMP& REDUCTION(+:g1a,g2a,g3a)
do igrid=1,ngrid
x11= dvec(igrid,4)*gpgra2(igrid,0)
x22= dvec(igrid,5)*gpgra2(igrid,0)
x33= dvec(igrid,6)*gpgra2(igrid,0)
x12= dvec(igrid,7)*gpgra2(igrid,0)
x13= dvec(igrid,8)*gpgra2(igrid,0)
x23= dvec(igrid,9)*gpgra2(igrid,0)
x21=x12+dvec(igrid,2)*gpgra2(igrid,1)
x31=x13+dvec(igrid,3)*gpgra2(igrid,1)
x32=x23+dvec(igrid,3)*gpgra2(igrid,2)
x11=x11+dvec(igrid,1)*gpgra2(igrid,1)
x22=x22+dvec(igrid,2)*gpgra2(igrid,2)
x33=x33+dvec(igrid,3)*gpgra2(igrid,3)
x12=x12+dvec(igrid,1)*gpgra2(igrid,2)
x13=x13+dvec(igrid,1)*gpgra2(igrid,3)
x23=x23+dvec(igrid,2)*gpgra2(igrid,3)
g1a=g1a+x11*graa(1,igrid)+x12*graa(2,igrid)+x13*graa(3,igrid)
g2a=g2a+x21*graa(1,igrid)+x22*graa(2,igrid)+x23*graa(3,igrid)
g3a=g3a+x31*graa(1,igrid)+x32*graa(2,igrid)+x33*graa(3,igrid)
enddo
C$OMP END PARALLEL DO
gr1=gr1-g1a
gr2=gr2-g2a
gr3=gr3-g3a
C
return
end
C
************************************************************************
subroutine cfini(dft,minpfile,cfunc,nfunc,nlfunc,cf,cfe,iout,
$route,nd,dero,bparam,cparam,beta,lscvv10,func,nfuncmax)
************************************************************************
* Initialize coefficients for functionals
************************************************************************
#if defined (LIBXC)
use xc_f03_lib_m
#endif
implicit none
integer minpfile,n,i,iout,nfunc,nlfunc,nd,dero,nfuncmax
integer func(nfuncmax),flag
real*8 cf(*),cfe(*),bparam,cparam,beta,lambda
logical lxclda,lscvv10,lll
character*1 tmp(32)
character*4 route
character*8 embed
character*32 dft,cfunc(*)
#if defined (LIBXC)
type(xc_f03_func_t) :: xc_func
type(xc_f03_func_info_t) :: xc_info
#endif
lxclda=.true.
C Initialize coefficients for "simple" functionals
do i=1,nfunc
if(dft.eq.cfunc(i)) then
cf(i)=cf(i)+1.d0
if(i.ge.21.and.i.le.27) func(i)=1 ! built-in ssr
endif
enddo
C Definition of "combination" functionals (define new functionals here)
if(trim(dft).eq.'blyp') then
cf(2)=cf(2)+1.d0
cf(5)=cf(5)+1.d0
else if(trim(dft).eq.'b3lyp') then
cf(1)=cf(1)+0.08d0
cf(2)=cf(2)+0.72d0
cf(5)=cf(5)+0.81d0
cf(6)=cf(6)+0.19d0
else if(trim(dft).eq.'b3pw91') then
cf(1) =cf(1) +0.08d0
cf(2) =cf(2) +0.72d0
cf(6) =cf(6) +0.19d0
cf(10)=cf(10)+0.81d0
else if(trim(dft).eq.'bhlyp') then
cf(2)=cf(2)+0.5d0
cf(5)=cf(5)+1.d0
else if(trim(dft).eq.'bp86') then
cf(2)=cf(2)+1.d0
cf(8)=cf(8)+1.d0
else if(trim(dft).eq.'pbe') then
cf(3)=cf(3)+1.d0
cf(9)=cf(9)+1.d0
else if(trim(dft).eq.'pbe0') then
cf(3)=cf(3)+0.75d0
cf(9)=cf(9)+1.d0
else if(trim(dft).eq.'pw91') then
cf(4) =cf(4) +1.d0
cf(10)=cf(10)+1.d0
else if(trim(dft).eq.'b2plyp') then
cf(2)=cf(2)+0.47d0
cf(5)=cf(5)+0.73d0
else if(trim(dft).eq.'b2gpplyp') then
cf(2)=cf(2)+0.35d0
cf(5)=cf(5)+0.64d0
else if(trim(dft).eq.'dsdpbep86') then
cf(3)=cf(3)+0.30d0
cf(8)=cf(8)+0.43d0
else if(trim(dft).eq.'xyg3') then
cf(1)=cf(1)+0.08d0
cf(2)=cf(2)+0.72d0
cf(5)=cf(5)+0.81d0
cf(6)=cf(6)+0.19d0
cfe(1)=cfe(1)-0.0140d0
cfe(2)=cfe(2)+0.2107d0
cfe(5)=cfe(5)+0.6789d0
else if(trim(dft).eq.'drpa75'.or.trim(dft).eq.'scs-drpa75') then
cf(3) =cf(3) +0.25d0
cf(9) =cf(9) +1.d0
cfe(3)=cfe(3)+0.25d0
else if(trim(dft(1:3)).eq.'rs-') then
if(trim(dft(4:6)).eq.'pbe') cf(22) =0.5d0
if(trim(dft(4:6)).eq.'pbe') func(22) =1
if(trim(dft(4:6)).eq.'b88') cf(25) =0.5d0
if(trim(dft(4:6)).eq.'b88') func(25) =1
if(trim(dft(4:7)).eq.'pw91') cf(27) =0.5d0
if(trim(dft(4:7)).eq.'pw91') func(27) =1
if(trim(dft(8:10)).eq.'pbe') cf(21) =0.75d0
if(trim(dft(8:10)).eq.'pbe') func(21) =1
if(trim(dft(8:10)).eq.'lyp') cf(24) =0.75d0
if(trim(dft(8:10)).eq.'lyp') func(24) =1
if(trim(dft(9:12)).eq.'pw91') cf(26) =0.75d0
if(trim(dft(9:12)).eq.'pw91') func(26) =1
if(trim(dft(8:10)).eq.'p86') cf(23) =0.75d0
if(trim(dft(8:10)).eq.'p86') func(23) =1
c ll_user: low level user defined dft in embedding calculation
c it is required for the second derivative of the XC energy
c route=vxcd in this case and cannot be set to em1
else if(trim(dft).eq.'user'.or.trim(dft).eq.'ll_user'.or.
$ trim(dft).eq.'userd'.or.trim(dft).eq.'rsdh') then
open(minpfile,file='MINP')
if(route.eq.'em1 '.or.route.eq.'scl1'.or.route.eq.'emft'.or.
& route.eq.'em2 '.or.route.eq.'sch'.or.
& trim(dft).eq.'ll_user') then
call getkeym('embed',5,embed,8)
read(minpfile,*)
read(minpfile,*)
else
call getkeym('dft',3,dft,32)
endif
flag=1
if(trim(dft).eq.'rsdh') then
read(minpfile,*)
read(minpfile,*)
read(minpfile,*) lambda
close(minpfile)
open(minpfile,file='MINP')
if(route.eq.'em1 '.or.route.eq.'scl1'.or.
$ route.eq.'emft'.or.route.eq.'em2 '.or.route.eq.'sch') then
call getkeym('embed',5,embed,8)
read(minpfile,*)
read(minpfile,*)
else
call getkeym('dft',3,dft,32)
endif
flag=2
endif
call readuser(minpfile,cfunc,nfunc,nlfunc,cf,iout,bparam,cparam,
$beta,lxclda,lscvv10,func,nfuncmax,flag,lambda)
if(trim(dft).eq.'userd') call readuser(minpfile,cfunc,nfunc,
$nlfunc,cfe,iout,bparam,cparam,beta,lxclda,lll,func,nfuncmax,flag,
$lambda)
close(minpfile)
#if defined (LIBXC)
else if(trim(dft).eq.'m06-2x') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_MGGA_X_M06_2X '
cf(nfunc+nlfunc)=1.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_M06_2X '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'m06-hf') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_MGGA_X_M06_HF '
cf(nfunc+nlfunc)=1.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_M06_HF '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'m08-hx') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_MGGA_X_M08_HX '
cf(nfunc+nlfunc)=1.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_M08_HX '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'m08-so') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_MGGA_X_M08_SO '
cf(nfunc+nlfunc)=1.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_M08_SO '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'m06-l') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_X_M06_L '
cf(nfunc+nlfunc)=1.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_M06_L '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'scan') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_X_SCAN '
cf(nfunc+nlfunc)=1.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_SCAN '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'revscan') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_X_SCAN '
cf(nfunc+nlfunc)=1.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_REVSCAN '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'scan0') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_X_SCAN '
cf(nfunc+nlfunc)=0.75d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_SCAN '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'revscan0') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_X_SCAN '
cf(nfunc+nlfunc)=0.75d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_REVSCAN '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'scan0-2') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_X_SCAN '
cf(nfunc+nlfunc) =0.206299d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_SCAN '
cf(nfunc+nlfunc) =0.5d0
else if(trim(dft).eq.'tpss') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_X_TPSS '
cf(nfunc+nlfunc)=1.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_TPSS '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'revtpss') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_X_REVTPSS '
cf(nfunc+nlfunc)=1.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_REVTPSS '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'dsdpbehb95') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='GGA_X_WPBEH '
cf(nfunc+nlfunc)=0.34d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_BC95 '
cf(nfunc+nlfunc)=0.55d0
else if(trim(dft).eq.'hse06') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_GGA_XC_HSE06 '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'lc-wpbe') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_GGA_XC_LC_WPBE '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'cam-b3lyp') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_GGA_XC_CAM_B3LYP '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'m11') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_MGGA_X_M11 '
cf(nfunc+nlfunc)=1.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_M11 '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'mn12-sx') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_MGGA_X_MN12_SX '
cf(nfunc+nlfunc)=1.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_MN12_SX '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'mn15') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_MGGA_X_MN15 '
cf(nfunc+nlfunc)=1.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_C_MN15 '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'wb97') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_GGA_XC_WB97 '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'wb97x') then
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_GGA_XC_WB97X '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'wb97x-v') then
cf(16)=cf(16)+1.d0
lscvv10=.true.
bparam=6.d0
cparam=0.01d0
beta=(1.d0/12.d0)**0.75d0/32.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_GGA_XC_WB97X_V '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'b97m-v') then
cf(16)=cf(16)+1.d0
lscvv10=.true.
bparam=6.d0
cparam=0.01d0
beta=(1.d0/12.d0)**0.75d0/32.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='MGGA_XC_B97M_V '
cf(nfunc+nlfunc)=1.d0
else if(trim(dft).eq.'wb97m-v') then
cf(16)=cf(16)+1.d0
lscvv10=.true.
bparam=6.d0
cparam=0.01d0
beta=(1.d0/12.d0)**0.75d0/32.d0
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)='HYB_MGGA_XC_WB97M_V '
cf(nfunc+nlfunc)=1.d0
else if(xc_f03_functional_get_number(dft).gt.0) then
call xc_f03_func_init(xc_func,
$xc_f03_functional_get_number(dft),XC_UNPOLARIZED)
xc_info=xc_f03_func_get_info(xc_func)
lxclda=xc_f03_func_info_get_family(xc_info).eq.XC_FAMILY_LDA
call xc_f03_func_end(xc_func)
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)=dft
cf(nfunc+nlfunc)=1.d0
#endif
endif
if(trim(dft).ne.'userd'.and.trim(dft).ne.'drpa75'.and.
$trim(dft).ne.'scs-drpa75'.and.trim(dft).ne.'xyg3') then
do i=1,nfunc+nlfunc
cfe(i)=cf(i)
enddo
endif
C Shall we do GGA or gradient?
do i=1,nfunc
lxclda=lxclda.and.((cf(i).eq.0.d0.and.cfe(i).eq.0.d0).or.
$trim(cfunc(i)).eq.'lda'.or.trim(cfunc(i)).eq.'vwn5'.or.
$trim(cfunc(i)).eq.'pw')
enddo
#if defined (LIBXC)
do i=nfunc+1,nfunc+nlfunc
call xc_f03_func_init(xc_func,
$xc_f03_functional_get_number(cfunc(i)),XC_UNPOLARIZED)
xc_info=xc_f03_func_get_info(xc_func)
lxclda=lxclda.and.xc_f03_func_info_get_family(xc_info).eq.
$XC_FAMILY_LDA
call xc_f03_func_end(xc_func)
enddo
#endif
if(lxclda) then
nd=max(nd,1)
if(dero.gt.0) nd=max(nd,4)
else
nd=max(nd,4)
if(dero.gt.0) nd=max(nd,10)
endif
C
return
end
C
************************************************************************
subroutine readuser(minpfile,cfunc,nfunc,nlfunc,cf,iout,bparam,
$cparam,beta,lxclda,lscvv10,func,nfuncmax,flag,lambda)
************************************************************************
* Read user defined functionals
************************************************************************
#if defined (LIBXC)
use xc_f03_lib_m
#endif
implicit none
#if defined (LIBXC)
type(xc_f03_func_t) :: xc_func
type(xc_f03_func_info_t) :: xc_info
#endif
integer minpfile,n,i,j,iout,nfunc,nlfunc,nfuncmax,func(nfuncmax)
integer flag
real*8 sum,cf(*),bparam,cparam,beta,lambda
character(len=1) line1(512)
character(len=2) c2
character(len=32) cdft,cfunc(*),tmp
character(len=512) line
logical lll,lxclda,lscvv10
equivalence(line,line1)
equivalence(c2,cdft)
C
if(flag.eq.1) read(minpfile,*) n
if(flag.eq.2) n=2
do i=1,n
if(flag.eq.1) read(minpfile,*) sum,cdft
if(flag.eq.2) read(minpfile,*) cdft
cdft=adjustl(cdft)
call lowercase(cdft,cdft,32)
if(trim(cdft).eq.'vv10'.or.trim(cdft).eq.'vv10nl') then
lscvv10=.true.
bparam=5.9d0
cparam=0.0093d0
line1=' '
backspace(minpfile)
read(minpfile,'(a512)') line
call lowercase(line,line,512)
j=1
do while(line1(j ).ne.'v'.or.
$ line1(j+1).ne.'v'.or.
$ line1(j+2).ne.'1'.or.
$ line1(j+3).ne.'0')
j=j+1
enddo
if(trim(cdft).eq.'vv10') then
if(line1(j+5).ne.' '.or.line1(j+6).ne.' ') then
backspace(minpfile)
read(minpfile,*) sum,line,bparam,cparam
endif
beta=(3.d0/(bparam*bparam))**0.75d0/32.d0
else
if(line1(j+7).ne.' '.or.line1(j+8).ne.' ') then
backspace(minpfile)
read(minpfile,*) sum,line,bparam,cparam
endif
beta=0.d0
cdft='vv10 '
endif
endif
lll=.true.
do j=1,nfunc
if(trim(cfunc(j)).eq.trim(cdft)) then
if(flag.eq.1) cf(j)=cf(j)+sum
if(flag.eq.2) then
if(j.eq.22.or.j.eq.25.or.j.eq.27) then !exchange
cf(j)=1.d0-lambda
else ! correlation
cf(j)=1.d0-lambda**2
endif
endif
if(j.ge.21.and.j.le.27) func(j)=1 ! built-in ssr
lll=.false.
exit
endif
enddo
#if defined (LIBXC)
if(lll) then
C
if(cdft(1:3).eq.'ssr') then
tmp(1:29)=cdft(4:32)
cdft(1:29)=tmp(1:29)
func(nfunc+nlfunc+1)=1
endif
if(cdft(1:5).eq.'ecmd_') then
tmp(1:27)=cdft(6:32)
cdft(1:27)=tmp(1:27)
func(nfunc+nlfunc+1)=2
endif
C
call libxcconv(cdft)
if(xc_f03_functional_get_number(cdft).gt.0) then
lll=.false.
call xc_f03_func_init(xc_func,
$xc_f03_functional_get_number(cdft),XC_UNPOLARIZED)
xc_info=xc_f03_func_get_info(xc_func)
lxclda=lxclda.and.
$xc_f03_func_info_get_family(xc_info).eq.XC_FAMILY_LDA
call xc_f03_func_end(xc_func)
nlfunc=nlfunc+1
cfunc(nfunc+nlfunc)=cdft
if(flag.eq.1) cf(nfunc+nlfunc)=sum
if(flag.eq.2) then
if(cdft(4:6).eq.'_x_'.or.cdft(5:7).eq.'_x_') then ! gga/lda or mgga
cf(nfunc+nlfunc)=1.d0-lambda
elseif(cdft(4:6).eq.'_c_'.or.cdft(5:7).eq.'_c_') then ! gga/lda or mgga
cf(nfunc+nlfunc)=1.d0-lambda**2
endif
endif
endif
endif
#endif
if(c2.eq.'lr'.or.c2.eq.'sr') then
if(trim(cdft).ne.'lrhfx'.and.trim(cdft).ne.'srhfx')then
c2=' '
cdft=adjustl(cdft)
endif
endif
if(lll.and.trim(cdft).ne.'hfx'.and.
$trim(cdft).ne.'mp3' .and.trim(cdft).ne.'mp2' .and.
$trim(cdft).ne.'mp2s' .and.trim(cdft).ne.'mp2t' .and.
$trim(cdft).ne.'mp3s' .and.trim(cdft).ne.'mp3t' .and.
$trim(cdft).ne.'drpa' .and.trim(cdft).ne.'drpae' .and.
$trim(cdft).ne.'drpas'.and.trim(cdft).ne.'drpat' .and.
$trim(cdft).ne.'sosex'.and.trim(cdft).ne.'sosexs'.and.
$trim(cdft).ne.'sosext'.and.trim(cdft).ne.'lrhfx'.and.
$trim(cdft).ne.'srhfx'.and.trim(cdft).ne.'vv10nl') then
write(iout,*) 'Invalid functional name!'
call mrccend(1)
endif
enddo
C
return
end
C
************************************************************************
real*8 function vv10nl(grid,ngrid,weight,density,gradient,kappa,
$dtol,bparam,cparam,beta)
************************************************************************
* 2010 vdW density functional of Vydrov and Van Voorhis (VV10)
************************************************************************
implicit none
integer::grid1,grid2,ngrid
real*8,dimension(3,ngrid)::grid
real*8,dimension(ngrid)::weight,density,gradient,kappa
real*8::dtol,gr1,gr2,gr3,ka1,ga1
real*8::bparam,cparam,beta,sqrcparam,edens1,distv1,distv2,distv3
real*8::omegap,omegag,vf,ecnl,dist2,g1,g2
C Parameters
real*8,parameter::pi=3.1415926535897932384626433832795028841971693
&9938d0
real*8,parameter::sqr4pi=dsqrt(4.d0*pi)
real*8,parameter::threepi2=3.d0*pi*pi
sqrcparam=dsqrt(cparam)
C Omeganull (stored in gradient) and kappa
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(sqrcparam,bparam,dtol,ngrid,weight,density,gradient,kappa)
do grid1=1,ngrid
edens1=density(grid1)
if(dabs(weight(grid1)*edens1).gt.dtol) then
density(grid1)=weight(grid1)*edens1
omegap=sqr4pi*dsqrt(edens1)
omegag=sqrcparam*gradient(grid1)/(edens1*edens1)
gradient(grid1)=dsqrt(omegag*omegag+omegap*omegap/3.d0)
vf=(threepi2*edens1)**(1.d0/3.d0)
kappa(grid1)=bparam*vf*vf/omegap
else
density(grid1)=0.d0
gradient(grid1)=0.d0
kappa(grid1)=0.d0
endif
enddo
C$OMP END PARALLEL DO
C Non-local part of the correction
ecnl=0.d0
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,dtol,density,grid,kappa,gradient,beta)
C$OMP& REDUCTION(+:ecnl)
do grid1=1,ngrid
if(dabs(density(grid1)).gt.dtol) then
edens1=1.5d0*density(grid1)
gr1=grid(1,grid1)
gr2=grid(2,grid1)
gr3=grid(3,grid1)
ka1=kappa(grid1)
ga1=gradient(grid1)
do grid2=1,grid1-1
if(dabs(density(grid2)).gt.dtol) then
distv1=grid(1,grid2)-gr1
distv2=grid(2,grid2)-gr2
distv3=grid(3,grid2)-gr3
dist2=distv1*distv1+distv2*distv2+distv3*distv3
if(dist2.lt.2.2319151949d3) then
g1=ga1 *dist2+ka1
g2=gradient(grid2)*dist2+kappa(grid2)
ecnl=ecnl-edens1*density(grid2)/(g1*g2*(g1+g2))
endif
endif
enddo
ecnl=ecnl+density(grid1)*
$(beta-0.5d0*edens1/(ka1*ka1*(ka1+ka1)))
endif
enddo
C$OMP END PARALLEL DO
vv10nl=ecnl
C
return
end
C
************************************************************************
subroutine vv10nl_scf1(ngrid,weight,density,gradient,
&dtol,bparam,cparam,omeganull,kappa,omeganull_dn,omeganull_dg,
&kappa_dn)
************************************************************************
* 2010 vdW density functional of Vydrov and Van Voorhis (VV10)
************************************************************************
implicit none
C Input variables
integer,intent(in)::ngrid
real*8,dimension(ngrid),intent(in)::weight,density
real*8,dimension(ngrid),intent(in)::gradient
real*8,intent(in)::dtol,bparam,cparam
C Output variables
real*8,dimension(ngrid),intent(out)::omeganull,kappa
real*8,dimension(ngrid),intent(out)::omeganull_dn,omeganull_dg
real*8,dimension(ngrid),intent(out)::kappa_dn
C Other internal variables
integer::grid1
real*8::weight1,edens1,edens2,edens4,ggamma
real*8::omegap,omegag,vf,cgnm4,cg2nm4
C Parameters
real*8,parameter::pi=3.1415926535897932384626433832795028841971693
&9938d0
real*8,parameter::sqr4pi=dsqrt(4.d0*pi)
real*8,parameter::threepi2=3.d0*pi*pi
real*8,parameter::pi56=pi**(5.d0/6.d0)
real*8,parameter::three23=3.d0**(2.d0/3.d0)
real*8,parameter::twothirdpi=2.d0/3.d0*pi
real*8,parameter::fourthirdpi=2.d0*twothirdpi
real*8::sqrcparam
sqrcparam=dsqrt(cparam)
C Local part of the correction
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(sqrcparam,ngrid,dtol,weight,density,gradient,omeganull)
C$OMP& SHARED(kappa,omeganull_dn,omeganull_dg,kappa_dn,cparam,bparam)
do grid1=1,ngrid
edens1=density(grid1)
weight1=weight(grid1)
if(dabs(weight1*edens1).gt.dtol) then
edens2=edens1*edens1
edens4=edens2*edens2
ggamma=gradient(grid1)
cgnm4=cparam*ggamma/edens4
cg2nm4=cgnm4*ggamma
omegap=sqr4pi*dsqrt(edens1)
omegag=sqrcparam*ggamma/edens2
!Local functions
omeganull(grid1)=dsqrt(omegag*omegag+omegap*omegap/3.d0)
vf=(threepi2*edens1)**(1.d0/3.d0)
kappa(grid1)=bparam*vf*vf/omegap
!Derivatives of local functions
omeganull_dn(grid1)=(-2.d0*cparam*ggamma*ggamma/(edens1*edens4)+
&twothirdpi)/dsqrt(cg2nm4+fourthirdpi*edens1)
omeganull_dg(grid1)=cgnm4/
&dsqrt(cg2nm4+fourthirdpi*edens1)
kappa_dn(grid1)=bparam*three23*pi56/12.d0*edens1**(-5.d0/6.d0)
else
omeganull(grid1)=0.d0
kappa(grid1)=0.d0
omeganull_dn(grid1)=0.d0
omeganull_dg(grid1)=0.d0
kappa_dn(grid1)=0.d0
endif
enddo
C$OMP END PARALLEL DO
end subroutine
************************************************************************
subroutine vv10nl_scf2(nb,ngrid,nblock,iblock,nbl,mind6,maxd14,
&grid,weight,density,dtol,omeganull,kappa,omeganull_dn,
&omeganull_dg,kappa_dn,ecnl,fnfunc,fgfunc,beta)
************************************************************************
* 2010 vdW density functional of Vydrov and Van Voorhis (VV10)
************************************************************************
implicit none
C Input variables
integer,intent(in)::nb,ngrid,nblock,iblock,nbl
real*8,intent(in)::dtol,beta
real*8,dimension(nblock*(nblock-1)/2),intent(in)::mind6 !R^6
real*8,dimension(nblock),intent(in)::maxd14
real*8,dimension(3,ngrid),intent(in)::grid
real*8,dimension(ngrid),intent(in)::weight,density
real*8,dimension(ngrid),intent(in)::kappa,omeganull
real*8,dimension(ngrid),intent(in)::omeganull_dn,omeganull_dg
real*8,dimension(ngrid),intent(in)::kappa_dn
C Output variables
real*8,dimension(nb),intent(out)::ecnl,fnfunc,fgfunc
C Other internal variables
integer::grid1,grid2,grid3,ngridl,ngridu
integer::block2,bll2,blu2,blp
real*8::gr1,gr2,gr3,ka1,on1,ew2,gg
real*8::distv1,distv2,distv3,dist2
real*8::edens1,g1,g2,kernel,weight1
real*8::ecval,fnint,uval,ufunc,wfunc
real*8::maxd1,mval,itol
C Parameters
c real*8,parameter::pi=3.14159265358979323846264338327950288419717d0
c real*8,parameter::mpar=1.5d0*(4.d0/3.d0*pi)**(-1.5d0)
C Non-local part of the correction
itol=1d3*dtol/ngrid/ngrid!/mpar
maxd1=maxd14(iblock)
ngridl=1+(iblock-1)*nbl
ngridu=ngridl-1+nb
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(iblock,nbl,nblock,mind6,dtol,maxd14,ngridl,ngridu,ngrid)
C$OMP& SHARED(maxd1,itol,grid,density,weight,omeganull,kappa,beta)
C$OMP& SHARED(omeganull_dn,omeganull_dg,kappa_dn,ecnl,fnfunc,fgfunc)
do grid1=ngridl,ngridu
grid3=grid1-ngridl+1
edens1=density(grid1)
weight1=weight(grid1)
if (dabs(edens1*weight1).lt.dtol) then
ecnl(grid3)=0.d0
fnfunc(grid3)=0.d0
fgfunc(grid3)=0.d0
else
gr1=grid(1,grid1)
gr2=grid(2,grid1)
gr3=grid(3,grid1)
on1=omeganull(grid1)
ka1=kappa(grid1)
ecval=0.d0
fnint=0.d0
ufunc=0.d0
wfunc=0.d0
do block2=1,nblock
bll2=(block2-1)*nbl+1
blu2=min(bll2-1+nbl,ngrid)
blp=(iblock-1)*(iblock-2)/2+block2
mval=maxd1*maxd14(block2)/mind6(blp)
if (mval.gt.itol) then
do grid2=bll2,blu2
ew2=density(grid2)*weight(grid2)
if (dabs(ew2).gt.dtol) then
distv1=grid(1,grid2)-gr1
distv2=grid(2,grid2)-gr2
distv3=grid(3,grid2)-gr3
dist2=distv1*distv1+distv2*distv2+distv3*distv3
g1=on1 *dist2+ka1
g2=omeganull(grid2)*dist2+kappa(grid2)
gg=1.d0/(g1+g2)
kernel=-1.5d0*ew2*gg/(g1*g2)
ecval=ecval+0.5d0*edens1*kernel
fnint=fnint+kernel
uval=-kernel*(1.d0/g1+gg)
ufunc=ufunc+uval
wfunc=wfunc+dist2*uval
endif
enddo
endif
enddo
!Energy
ecnl(grid3)=beta*edens1+ecval
!Derivatives of energy
fnfunc(grid3)=beta+fnint+
&edens1*(kappa_dn(grid1)*ufunc+omeganull_dn(grid1)*wfunc)
fgfunc(grid3)=edens1*omeganull_dg(grid1)*wfunc
endif
enddo
C$OMP END PARALLEL DO
end subroutine
C
************************************************************************
subroutine maxdens14(grid,ngrid,nblock,nbl,density,weight,maxd14)
************************************************************************
* Calculates 4th root of maximal density values for a block
************************************************************************
implicit none
integer,intent(in)::ngrid,nblock,nbl
real*8,dimension(3,ngrid),intent(in)::grid
real*8,dimension(ngrid),intent(in)::density,weight
real*8,dimension(nblock),intent(out)::maxd14
integer::iblock,grl,igrid
real*8::mval
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(nblock,nbl,ngrid,density,weight,maxd14)
do iblock=1,nblock
grl=(iblock-1)*nbl+1
mval=0.d0
do igrid=grl,min(grl-1+nbl,ngrid)
mval=max(mval,density(igrid)**(1.d0/4.d0)*weight(igrid))
enddo
maxd14(iblock)=mval
enddo
C$OMP END PARALLEL DO
end subroutine
************************************************************************
subroutine aweight(weight,fun,ngrid)
************************************************************************
* Absorb weigths into grid-dependent quantities
************************************************************************
implicit none
integer igrid,ngrid
real*8 weight(ngrid),fun(ngrid)
C
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
do igrid=1,ngrid
fun(igrid)=weight(igrid)*fun(igrid)
enddo
C$OMP END PARALLEL DO
C
return
end
C
************************************************************************
subroutine addvxc(nbasis,ibasis,bfmap,focka,fockb,vxca,vxcb,
$shltype)
************************************************************************
* Add Vxc to the Fock-matrix
************************************************************************
implicit none
integer nbasis,ibasis,bfmap(ibasis),i,j,ii,jj,shltype
real*8 vxca(ibasis,ibasis),vxcb(ibasis,ibasis),tmp
real*8 focka(nbasis,nbasis),fockb(nbasis,nbasis)
C
do i=1,ibasis
ii=bfmap(i)
focka(ii,ii)=focka(ii,ii)+vxca(i,i)
do j=1,i-1
jj=bfmap(j)
tmp=vxca(i,j)
focka(ii,jj)=focka(ii,jj)+tmp
focka(jj,ii)=focka(jj,ii)+tmp
enddo
enddo
if(shltype.eq.2) then
do i=1,ibasis
ii=bfmap(i)
fockb(ii,ii)=fockb(ii,ii)+vxcb(i,i)
do j=1,i-1
jj=bfmap(j)
tmp=vxcb(i,j)
fockb(ii,jj)=fockb(ii,jj)+tmp
fockb(jj,ii)=fockb(jj,ii)+tmp
enddo
enddo
endif
C
return
end
C
************************************************************************
subroutine dgrid(ngrid,nbasis,nd,ibasis,dvec,vxca,vxcb,dvec0,
$bfmap,densa,densb,scftype,drhoa,drhob,route,grhoa,grhob,gdrhoa,
$gdrhob,sigmaaa,sigmaab,sigmabb,dgpgra,dgpgrb,lapl_rhoa,lapl_rhob,
$gpgra,gpgrb,gpgra2)
************************************************************************
* Calculate density, density gradient, and density Laplacian on grid
************************************************************************
implicit none
integer ngrid,nbasis,nd,ibasis,bfmap(nbasis),i,j,ii,jj,scftype
integer igrid
real*8 dvec(ngrid,0:nd-1,ibasis),dvec0(ibasis,ngrid)
real*8 vxca(ibasis,ibasis),vxcb(ibasis,ibasis)
real*8 drhoa(ngrid),drhob(ngrid),grhoa(3,ngrid),grhob(3,ngrid)
real*8 densa(nbasis,nbasis),densb(nbasis,nbasis)
real*8 gdrhoa(3,ngrid),gdrhob(3,ngrid),ga1,ga2,ga3,gb1,gb2,gb3
real*8 sigmaaa(ngrid),sigmaab(ngrid),sigmabb(ngrid)
real*8 dgpgra(ibasis,ngrid),dgpgrb(ibasis,ngrid)
real*8 lapl_rhoa(ngrid),lapl_rhob(ngrid),gpgra2(ibasis,ngrid,3)
real*8 gpgra(ibasis,ngrid,3),gpgrb(ibasis,ngrid,3)
character(len=4) route
C Compress density matrices (density matrices must be symmetric!!!)
do i=1,ibasis
ii=bfmap(i)
vxca(i,i)=densa(ii,ii)
do j=1,i-1
jj=bfmap(j)
vxca(i,j)=densa(ii,jj)
enddo
enddo
if(scftype.ge.2) then
do i=1,ibasis
ii=bfmap(i)
vxcb(i,i)=densb(ii,ii)
do j=1,i-1
jj=bfmap(j)
vxcb(i,j)=densb(ii,jj)
enddo
enddo
endif
C Calculate density on grid
if(scftype.ge.2) then
call dsymm('l','l',ibasis,ngrid,1.d0,vxca,ibasis,dvec0,ibasis,
$0.d0,dgpgra,ibasis)
call dsymm('l','l',ibasis,ngrid,1.d0,vxcb,ibasis,dvec0,ibasis,
$0.d0,dgpgrb,ibasis)
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,ibasis,dvec0,dgpgra,dgpgrb,drhoa,drhob)
do igrid=1,ngrid
drhoa(igrid)=dot_product(dvec0(1:ibasis,igrid),
$ dgpgra(1:ibasis,igrid))
drhob(igrid)=dot_product(dvec0(1:ibasis,igrid),
$ dgpgrb(1:ibasis,igrid))
enddo
C$OMP END PARALLEL DO
else
call dsymm('l','l',ibasis,ngrid,1.d0,vxca,ibasis,dvec0,ibasis,
$0.d0,dgpgra,ibasis)
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,ibasis,dvec0,dgpgra,drhoa)
do igrid=1,ngrid
drhoa(igrid)=dot_product(dvec0(1:ibasis,igrid),
$ dgpgra(1:ibasis,igrid))
enddo
C$OMP END PARALLEL DO
endif
C Calculate density gradient and sigma on grid
if(nd.gt.4) then
if(scftype.ge.2) then
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,ibasis,dvec,dgpgra,gdrhoa,sigmaaa,grhoa)
C$OMP& SHARED(dgpgrb,gdrhob,sigmabb,sigmaab,grhob)
do igrid=1,ngrid
ga1=2.d0*dot_product(dvec(igrid,1,1:ibasis),
$ dgpgra(1:ibasis,igrid))
ga2=2.d0*dot_product(dvec(igrid,2,1:ibasis),
$ dgpgra(1:ibasis,igrid))
ga3=2.d0*dot_product(dvec(igrid,3,1:ibasis),
$ dgpgra(1:ibasis,igrid))
gb1=2.d0*dot_product(dvec(igrid,1,1:ibasis),
$ dgpgrb(1:ibasis,igrid))
gb2=2.d0*dot_product(dvec(igrid,2,1:ibasis),
$ dgpgrb(1:ibasis,igrid))
gb3=2.d0*dot_product(dvec(igrid,3,1:ibasis),
$ dgpgrb(1:ibasis,igrid))
gdrhoa(1,igrid)=ga1
gdrhoa(2,igrid)=ga2
gdrhoa(3,igrid)=ga3
sigmaaa(igrid)=2.d0*(ga1*grhoa(1,igrid)+
$ ga2*grhoa(2,igrid)+
$ ga3*grhoa(3,igrid))
gdrhob(1,igrid)=gb1
gdrhob(2,igrid)=gb2
gdrhob(3,igrid)=gb3
sigmabb(igrid)=2.d0*(gb1*grhob(1,igrid)+
$ gb2*grhob(2,igrid)+
$ gb3*grhob(3,igrid))
sigmaab(igrid)= ga1*grhob(1,igrid)+
$ ga2*grhob(2,igrid)+
$ ga3*grhob(3,igrid)+
$ gb1*grhoa(1,igrid)+
$ gb2*grhoa(2,igrid)+
$ gb3*grhoa(3,igrid)
enddo
C$OMP END PARALLEL DO
else
C$OMP PARALLEL DO Schedule(Dynamic)
C$OMP& DEFAULT(PRIVATE)
C$OMP& SHARED(ngrid,ibasis,dvec,dgpgra,gdrhoa,sigmaaa,grhoa)
do igrid=1,ngrid
ga1=2.d0*dot_product(dvec(igrid,1,1:ibasis),
$ dgpgra(1:ibasis,igrid))
ga2=2.d0*dot_product(dvec(igrid,2,1:ibasis),
$ dgpgra(1:ibasis,igrid))
ga3=2.d0*dot_product(dvec(igrid,3,1:ibasis),
$ dgpgra(1:ibasis,igrid))
gdrhoa(1,igrid)=ga1
gdrhoa(2,igrid)=ga2
gdrhoa(3,igrid)=ga3
sigmaaa(igrid)=2.d0*(ga1*grhoa(1,igrid)+
$ ga2*grhoa(2,igrid)+
$ ga3*grhoa(3,igrid))
enddo
C$OMP END PARALLEL DO
endif
endif
if(route.eq.'den2') then
C Calculate density Laplacian on grid
do i=1,ibasis
gpgra2(i,1:ngrid,1:3)=dvec(1:ngrid,1:3,i)
enddo
call dsymm('l','l',ibasis,ngrid*3,1.d0,vxca,ibasis,gpgra2,
$ibasis,0.d0,gpgra,ibasis)
if(scftype.ge.2) then
call dsymm('l','l',ibasis,ngrid*3,1.d0,vxcb,ibasis,gpgra2,
$ibasis,0.d0,gpgrb,ibasis)
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
do igrid=1,ngrid
lapl_rhoa(igrid)=2d0*(dot_product(dvec(igrid,4,1:ibasis)+
$ dvec(igrid,5,1:ibasis)+
$ dvec(igrid,6,1:ibasis),
$ dgpgra(1:ibasis,igrid))+
$ dot_product(gpgra2(1:ibasis,igrid,1),
$ gpgra (1:ibasis,igrid,1))+
$ dot_product(gpgra2(1:ibasis,igrid,2),
$ gpgra (1:ibasis,igrid,2))+
$ dot_product(gpgra2(1:ibasis,igrid,3),
$ gpgra (1:ibasis,igrid,3)))
lapl_rhob(igrid)=2d0*(dot_product(dvec(igrid,4,1:ibasis)+
$ dvec(igrid,5,1:ibasis)+
$ dvec(igrid,6,1:ibasis),
$ dgpgrb(1:ibasis,igrid))+
$ dot_product(gpgra2(1:ibasis,igrid,1),
$ gpgrb (1:ibasis,igrid,1))+
$ dot_product(gpgra2(1:ibasis,igrid,2),
$ gpgrb (1:ibasis,igrid,2))+
$ dot_product(gpgra2(1:ibasis,igrid,3),
$ gpgrb (1:ibasis,igrid,3)))
enddo
C$OMP END PARALLEL DO
else
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
do igrid=1,ngrid
lapl_rhoa(igrid)=2d0*(dot_product(dvec(igrid,4,1:ibasis)+
$ dvec(igrid,5,1:ibasis)+
$ dvec(igrid,6,1:ibasis),
$ dgpgra(1:ibasis,igrid))+
$ dot_product(gpgra2(1:ibasis,igrid,1),
$ gpgra (1:ibasis,igrid,1))+
$ dot_product(gpgra2(1:ibasis,igrid,2),
$ gpgra (1:ibasis,igrid,2))+
$ dot_product(gpgra2(1:ibasis,igrid,3),
$ gpgra (1:ibasis,igrid,3)))
enddo
C$OMP END PARALLEL DO
endif
endif
C
return
end
C
************************************************************************
subroutine dvxc(nbasis,nal,nbe,focka,fockb,moa,mob,grfile,dcore,
$iout,exc,dft,minpfile,scftype,ifltln,maxcor,imem,icore,verbosity,
$dero,grad,route,densa,densb,fmoa,fmob,ppqa,ppqb,yia,yib,irt,ncore,
$flag,nstate,mult)
************************************************************************
* Calculate derivatives of the exchange-correlation matrix
* flag=1 Hessian
* flag=2 TDA TD-DFT
* flag=3 full TD-DFT
************************************************************************
implicit none
integer nbasis,nal,nbe,grfile,iout,minpfile,scftype,ifltln,imem
integer imem1,icore(*),verbosity,dero,maxcor,irt,a,i,j,k,l,ncore
integer flag,nstate,istate,mult
real*8 focka(nbasis+ncore,nbasis+ncore,nstate),exc,grad,dcore(*)
real*8 fockb(nbasis+ncore,nbasis+ncore,nstate)
real*8 densa(nbasis+ncore,nbasis+ncore,nstate)
real*8 ppqa((nbasis-nal)*nal*nstate),ppqb((nbasis-nbe)*nbe*nstate)
real*8 densb(nbasis+ncore,nbasis+ncore,nstate)
real*8 fmoa(nbasis+ncore,nbasis+ncore),moa(nal+ncore,nbasis+ncore)
real*8 fmob(nbasis+ncore,nbasis+ncore),mob(nbe+ncore,nbasis+ncore)
real*8 yia(nal,nbasis-nal,nstate),yib(nbe,nbasis-nbe,nstate)
character(len=4) route
character(len=32) dft
common/memcom/ imem1
C
if(irt.eq.2) then
densa=0.d0
k=0
if(flag.eq.1) then
do i=1,nal
do a=1,nbasis-nal
k=k+1
densa(nal+a,i,1)=ppqa(k)
enddo
enddo
elseif(flag.eq.2.or.flag.eq.3) then
do istate=1,nstate
do a=1,nbasis-nal
do i=1,nal
k=k+1
densa(ncore+nal+a,ncore+i,istate)=ppqa(k)
enddo
enddo
enddo
endif
elseif(irt .eq. 200) then
continue
else
call dcopy(nbasis*nbasis,ppqa,1,densa,1)
endif
if(irt .ne. 200) then
do istate=1,nstate
call symmat(densa(1,1,istate),nbasis+ncore)
call dsymm('r','l',nbasis+ncore,nbasis+ncore,1.d0,
$densa(1,1,istate),nbasis+ncore,fmoa,nbasis+ncore,0.d0,
$focka,nbasis+ncore)
call dgemm('n','t',nbasis+ncore,nbasis+ncore,nbasis+ncore,
$1.d0,focka,nbasis+ncore,fmoa,nbasis+ncore,0.d0,densa(1,1,istate),
$nbasis+ncore)
enddo
endif
call dfillzero(focka,nstate*(nbasis+ncore)**2)
if(scftype.ge.2) then
if(irt.eq.2) then
densb=0.d0
k=0
if(flag.eq.1) then
do i=1,nbe
do a=1,nbasis-nbe
k=k+1
densb(nbe+a,i,1)=ppqb(k)
enddo
enddo
else if(flag.eq.2.or.flag.eq.3) then
do istate=1,nstate
do a=1,nbasis-nbe
do i=1,nbe
k=k+1
densb(ncore+nbe+a,ncore+i,istate)=ppqb(k)
enddo
enddo
enddo
endif
elseif(irt .eq. 200) then
continue
else
call dcopy(nbasis*nbasis,ppqb,1,densb,1)
endif
if(irt .ne. 200) then
do istate=1,nstate
call symmat(densb(1,1,istate),nbasis+ncore)
call dsymm('r','l',nbasis+ncore,nbasis+ncore,1.d0,
$densb(1,1,istate),nbasis+ncore,fmob,nbasis+ncore,0.d0,fockb,
$nbasis+ncore)
call dgemm('n','t',nbasis+ncore,nbasis+ncore,nbasis+ncore,
$1.d0,fockb,nbasis+ncore,fmob,nbasis+ncore,0.d0,densb(1,1,istate),
$nbasis+ncore)
enddo
endif
call dfillzero(fockb,nstate*(nbasis+ncore)**2)
call motransp(nal+ncore,nbasis+ncore,moa,fmoa,.false.)
call motransp(nbe+ncore,nbasis+ncore,mob,fmob,.false.)
else
call motransp(nal+ncore,nbasis+ncore,moa,fmoa,.false.)
if(mult.eq.1) then
call dscal((nbasis+ncore)*(nal+ncore),dsqrt(2.d0),moa,1)
call dscal(nstate*(nbasis+ncore)**2,2.d0,densa,1) !alpha+beta
endif
endif
call dft_core(nbasis+ncore,nal+ncore,nbe+ncore,focka,fockb,moa,
$mob,grfile,dcore,iout,exc,dft,minpfile,scftype,ifltln,maxcor,imem,
$imem1,icore,verbosity,dero,grad,route,densa,densb,nstate,mult,
$0.d0,0)
#if defined (MPI)
call symreduce(focka,dcore(imem),nbasis+ncore)
if(scftype.eq.2) call symreduce(fockb,dcore(imem),nbasis+ncore)
#endif
if(irt .eq. 200) return
if(irt.eq.1) then
call dsymm('l','l',nbasis,nbasis-nal,1.d0,focka,nbasis,
$fmoa(1,nal+1),nbasis,0.d0,densa,nbasis)
call dgemm('t','n',nal,nbasis-nal,nbasis,1.d0,fmoa,nbasis,densa,
$nbasis,1.d0,yia,nal)
if(scftype.ge.2) then
call dsymm('l','l',nbasis,nbasis-nbe,1.d0,fockb,nbasis,
$fmob(1,nbe+1),nbasis,0.d0,densb,nbasis)
call dgemm('t','n',nbe,nbasis-nbe,nbasis,1.d0,fmob,nbasis,
$densb,nbasis,1.d0,yib,nbe)
endif
else if(irt.eq.2) then
do istate=1,nstate
call dsymm('l','l',nbasis+ncore,nal,1.d0,focka(1,1,istate),
$nbasis+ncore,fmoa(1,ncore+1),nbasis+ncore,0.d0,densa,nbasis+ncore)
if(flag.eq.1) then
call dgemm('t','n',nbasis-nal,nal,nbasis+ncore,1.d0,
$fmoa(1,nal+1),nbasis,densa,nbasis,1.d0,yia,nbasis-nal)
else if(flag.eq.2) then
call dgemm('t','n',nal,nbasis-nal,nbasis+ncore,0.5d0,densa,
$nbasis+ncore,fmoa(1,ncore+nal+1),nbasis+ncore,1.d0,
$yia(1,1,istate),nal)
else if(flag.eq.3) then
call dgemm('t','n',nal,nbasis-nal,nbasis+ncore,1.0d0,densa,
$nbasis+ncore,fmoa(1,ncore+nal+1),nbasis+ncore,1.d0,
$yia(1,1,istate),nal)
endif
enddo
if(scftype.ge.2) then
call dsymm('l','l',nbasis+ncore,nbe,1.d0,fockb,nbasis+ncore,
$fmob(1,ncore+1),nbasis+ncore,0.d0,densb,nbasis+ncore)
if(flag.eq.1) then
call dgemm('t','n',nbasis-nbe,nbe,nbasis,1.d0,fmob(1,nbe+1),
$nbasis,densb,nbasis,1.d0,yib,nbasis-nbe)
elseif(flag.eq.2) then
call dgemm('t','n',nbe,nbasis-nbe,nbasis+ncore,0.5d0,densb,
$nbasis+ncore,fmob(1,ncore+nbe+1),nbasis+ncore,1.d0,yib,nbe)
elseif(flag.eq.3) then
call dgemm('t','n',nbe,nbasis-nbe,nbasis+ncore,1.0d0,densb,
$nbasis+ncore,fmob(1,ncore+nbe+1),nbasis+ncore,1.d0,yib,nbe)
endif
endif
else if(irt.eq.3) then
call dsymm('l','l',nbasis,nal,1.d0,focka,nbasis,fmoa,nbasis,
$0.d0,densa,nbasis)
call dgemm('t','n',nal,nal,nbasis,0.5d0,fmoa,nbasis,densa,
$nbasis,1.d0,yia,nbasis)
if(scftype.ge.2) then
call dsymm('l','l',nbasis,nbe,1.d0,fockb,nbasis,fmob,nbasis,
$0.d0,densb,nbasis)
call dgemm('t','n',nbe,nbe,nbasis,0.5d0,fmob,nbasis,densb,
$nbasis,1.d0,yib,nbasis)
endif
else if(irt.eq.0) then
call dsymm('l','l',nbasis,nbasis,1.d0,focka,nbasis,
$fmoa,nbasis,0.d0,densa,nbasis)
call dgemm('t','n',nbasis,nbasis,nbasis,1.d0,fmoa,nbasis,densa,
$nbasis,1.d0,yia,nbasis)
if(scftype.ge.2) then
call dsymm('l','l',nbasis,nbasis,1.d0,fockb,nbasis,
$fmob,nbasis,0.d0,densb,nbasis)
call dgemm('t','n',nbasis,nbasis,nbasis,1.d0,fmob,nbasis,
$densb,nbasis,1.d0,yib,nbasis)
endif
endif
C
return
end
C
************************************************************************
subroutine calca(amat,fit,nbasis,natoms,natrange,dfnatrange,work,
$qint)
************************************************************************
* Assembly of ESP integrals
************************************************************************
implicit none
integer nbasis,dfnbasis,natoms,iatoms,jatoms,ni,nj,nk,i1,i2,j1,j2
integer natrange(2,natoms),dfnatrange(2,natoms),ik1,ik2,jk1,jk2,ii
integer nik,njk,i,j,k,iii,jj
real*8 amat(nbasis,nbasis),fit(*),work(*),qint(*)
C
amat=0.d0
ii=1
do iatoms=1,natoms
i1=natrange(1,iatoms)
i2=natrange(2,iatoms)
ni=i2-i1
i1=i1+1
ik1=dfnatrange(1,iatoms)
ik2=dfnatrange(2,iatoms)
nik=ik2-ik1
ik1=ik1+1
work(1:nik)=qint(ik1:ik2)
do jatoms=1,iatoms-1
j1=natrange(1,jatoms)
j2=natrange(2,jatoms)
nj=j2-j1
j1=j1+1
jk1=dfnatrange(1,jatoms)
jk2=dfnatrange(2,jatoms)
njk=jk2-jk1
jk1=jk1+1
nk=nik+njk
work(nik+1:nk)=qint(jk1:jk2)
call dgemv('T',nk,ni*nj,1.d0,fit(ii),nk,work,1,0.d0,
$work(nk+1),1)
jj=nk+1
do j=j1,j2
do i=i1,i2
amat(i,j)=work(jj)
jj=jj+1
enddo
enddo
ii=ii+ni*nj*nk
enddo
call dgemv('T',nik,ni*ni,1.d0,fit(ii),nik,work,1,0.d0,
$work(nik+1),1)
jj=nik+1
do j=i1,i2
do i=i1,i2
amat(i,j)=work(jj)
jj=jj+1
enddo
enddo
ii=ii+ni*ni*nik
enddo
c call fillup(amat,nbasis)
C
return
end
C
************************************************************************
subroutine absweight(nd,ngrid,shltype,mgga,dero,weight,funa,funb,
$sgvaa,sgvbb,sgvab,vvtaua,vvtaub,vvlapl_rhoa,vvlapl_rhob,v2rhoa2,
$v2rhob2,v2rhoab,v2rhoasigmaaa,v2sigmaaa2,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,v2sigmabb2)
************************************************************************
* Absorb weigths into grid-dependent quantities
************************************************************************
implicit none
integer nd,ngrid,shltype,mgga,dero
real*8 weight,funa,funb,sgvaa,sgvbb,sgvab,vvtaua,vvtaub
real*8 vvlapl_rhoa,vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab
real*8 v2rhoasigmaaa,v2sigmaaa2,v2rhoasigmaab,v2rhoasigmabb
real*8 v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaaab
real*8 v2sigmaaabb,v2sigmaab2,v2sigmaabbb,v2sigmabb2
C
call aweight(weight,funa,ngrid)
if(nd.gt.1) then
call aweight(weight,sgvaa,ngrid)
if(mgga.gt.0) then
call aweight(weight,vvtaua,ngrid)
if(mgga.gt.1) call aweight(weight,vvlapl_rhoa,ngrid)
endif
endif
if(shltype.eq.2) then
call aweight(weight,funb,ngrid)
if(nd.gt.1) then
call aweight(weight,sgvbb,ngrid)
call aweight(weight,sgvab,ngrid)
if(mgga.gt.0) then
call aweight(weight,vvtaub,ngrid)
if(mgga.gt.1) call aweight(weight,vvlapl_rhob,ngrid)
endif
endif
endif
if(dero.lt.2) return
call aweight(weight,v2rhoa2,ngrid)
if(nd.gt.4) then
call aweight(weight,v2rhoasigmaaa,ngrid)
call aweight(weight,v2sigmaaa2,ngrid)
endif
if(shltype.eq.2) then
call aweight(weight,v2rhob2,ngrid)
call aweight(weight,v2rhoab,ngrid)
if(nd.gt.4) then
call aweight(weight,v2rhoasigmaab,ngrid)
call aweight(weight,v2rhoasigmabb,ngrid)
call aweight(weight,v2rhobsigmabb,ngrid)
call aweight(weight,v2rhobsigmaab,ngrid)
call aweight(weight,v2rhobsigmaaa,ngrid)
call aweight(weight,v2sigmaaaab,ngrid)
call aweight(weight,v2sigmaaabb,ngrid)
call aweight(weight,v2sigmaab2,ngrid)
call aweight(weight,v2sigmaabbb,ngrid)
call aweight(weight,v2sigmabb2,ngrid)
endif
endif
C
return
end
C
************************************************************************
subroutine calcfun(ngrid,shltype,nfunc,nlfunc,route,dr,nngrid,
$nblock,iblock,nbl,mind2,maxd14,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,cfunc,weight,funa,funb,
$sgvaa,sgvbb,sgvab,taua,taub,vtaua,vtaub,vvtaua,vvtaub,cf,cfe,exf,
$nd,rho,vrho,sigma,vsigma,tau,vtau,lapl_rhoa,lapl_rhob,vlapl_rhoa,
$vlapl_rhob,vvlapl_rhoa,vvlapl_rhob,lapl_rho,vlapl_rho,mgga,dero,
$v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,
$v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,
$v2sigmaaabb,v2sigmaab2,v2sigmaabbb,v2sigmabb2,vv2rhoa2,vv2rhob2,
$vv2rhoab,vv2rhoasigmaaa,vv2rhoasigmaab,vv2rhoasigmabb,
$vv2rhobsigmabb,vv2rhobsigmaab,vv2rhobsigmaaa,vv2sigmaaa2,
$vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,vv2sigmaabbb,vv2sigmabb2,
$ggrid,wweight,ddensity,dtol,omeganull,kappa,omeganull_dn,
$omeganull_dg,kappa_dn,lrs,rsw,beta,scr,mu,iout,func,nfuncmax,fb)
************************************************************************
* Calculate functionals and functional derivatives
************************************************************************
implicit none
integer ngrid,shltype,nfunc,nlfunc,dr,dero,nd,mgga,i,nngrid,ii
integer nblock,iblock,nbl,maxd14,iout,nfuncmax,func(nfuncmax)
real*8 rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,vrhoa,vrhob,vsigmaaa
real*8 vsigmabb,vsigmaab,weight,funa,funb,sgvaa,sgvbb,sgvab,beta
real*8 taua,taub,vtaua,vtaub,vvtaua,vvtaub,cf(*),cfe(*),exf(*)
real*8 rho,vrho,sigma,vsigma,tau,vtau,lapl_rhoa,lapl_rhob,rsw
real*8 vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,vvlapl_rhob,lapl_rho
real*8 vlapl_rho,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,mind2
real*8 v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab
real*8 v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb
real*8 v2sigmaab2,v2sigmaabbb,v2sigmabb2,vv2rhoa2,vv2rhob2
real*8 vv2rhoab,vv2rhoasigmaaa,vv2rhoasigmaab,vv2rhoasigmabb
real*8 vv2rhobsigmabb,vv2rhobsigmaab,vv2rhobsigmaaa,vv2sigmaaa2
real*8 vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,vv2sigmaabbb,kappa_dn
real*8 vv2sigmabb2,ggrid,wweight,ddensity,dtol,omeganull,kappa
real*8 omeganull_dn,omeganull_dg,scr,mu,fb(*)
character(len=4) route
character(len=32) cfunc(*)
logical lrs
C
if(route.eq.'vv10') goto 9999
C Exchange functionals
C Slater (LDA) exchange
if(cf(1).ne.0.d0.or.cfe(1).ne.0.d0) then
if(shltype.eq.2) then
call uks_x_lda(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,
$vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_x_lda(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(1),exf(1),1,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C B88
if(cf(2).ne.0.d0.or.cfe(2).ne.0.d0) then
if(shltype.eq.2) then
call uks_x_b88(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,
$vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_x_b88(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(2),exf(2),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C PBEx
if(cf(3).ne.0.d0.or.cfe(3).ne.0.d0) then
if(shltype.eq.2) then
call uks_x_pbe(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,
$vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_x_pbe(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(3),exf(3),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C PW91x
if(cf(4).ne.0.d0.or.cfe(4).ne.0.d0) then
if(shltype.eq.2) then
call uks_x_pw91(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,
$vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_x_pw91(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(4),exf(4),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C Correlation functionals
C LYP
if(cf(5).ne.0.d0.or.cfe(5).ne.0.d0) then
if(shltype.eq.2) then
call uks_c_lyp(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,
$vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_c_lyp(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(5),exf(5),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C VWN5
if(cf(6).ne.0.d0.or.cfe(6).ne.0.d0) then
if(shltype.eq.2) then
call uks_c_vwn5(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,
$vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_c_vwn5(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(6),exf(6),1,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C PW
if(cf(7).ne.0.d0.or.cfe(7).ne.0.d0) then
if(shltype.eq.2) then
call uks_c_pw92(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,
$vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_c_pw92(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(7),exf(7),1,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C P86
if(cf(8).ne.0.d0.or.cfe(8).ne.0.d0) then
if(shltype.eq.2) then
call uks_c_p86(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,
$vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_c_p86(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(8),exf(8),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C PBEc
if(cf(9).ne.0.d0.or.cfe(9).ne.0.d0
$.or.cf(30).ne.0.d0.or.cfe(30).ne.0.d0) then
if(shltype.eq.2) then
call uks_c_pbe(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,
$vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_c_pbe(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
C
if(cf(30).ne.0.d0.or.cfe(30).ne.0.d0) then
if(shltype.eq.2) then
call ecmd_uks(ngrid,rhoa,rhob,zk,fb)
else
call ecmd_rks(ngrid,rhoa,zk,fb)
endif
ii=30
else
ii=9
endif
C
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(ii),exf(ii),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C PW91c
if(cf(10).ne.0.d0.or.cfe(10).ne.0.d0) then
if(shltype.eq.2) then
call uks_c_pw91(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,
$vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_c_pw91(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(10),exf(10),nd,shltype,
$0,dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,
$vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C Exchange-correlation functionals
C B3LYP3 (B3LYP in Gaussian)
if(cf(11).ne.0.d0.or.cfe(11).ne.0.d0) then
if(shltype.eq.2) then
call uks_xc_b3lyp(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_xc_b3lyp(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(11),exf(11),nd,shltype,
$0,dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,
$vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C B97
if(cf(12).ne.0.d0.or.cfe(12).ne.0.d0) then
if(shltype.eq.2) then
call uks_xc_b97(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_xc_b97(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(12),exf(12),nd,shltype,
$0,dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,
$vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C HCTH120
if(cf(13).ne.0.d0.or.cfe(13).ne.0.d0) then
if(shltype.eq.2) then
call uks_xc_hcth120(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_xc_hcth120(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(13),exf(13),nd,shltype,
$0,dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,
$vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C HCTH147
if(cf(14).ne.0.d0.or.cfe(14).ne.0.d0) then
if(shltype.eq.2) then
call uks_xc_hcth147(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_xc_hcth147(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(14),exf(14),nd,shltype,
$0,dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,
$vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C HCTH407
if(cf(15).ne.0.d0.or.cfe(15).ne.0.d0) then
if(shltype.eq.2) then
call uks_xc_hcth407(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_xc_hcth407(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(15),exf(15),nd,shltype,
$0,dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,
$vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C NCAP
if(cf(17).ne.0.d0.or.cfe(17).ne.0.d0) then
if(shltype.eq.2) then
call uks_x_ncap(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_x_ncap(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(17),exf(17),nd,shltype,
$0,dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,
$vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C Short-range functionals
C srPBEc
if(cf(18).ne.0.d0.or.cfe(18).ne.0.d0) then
if(shltype.eq.2) then
call uks_c_srpbe(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2)
else
call rks_c_srpbe(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(18),exf(18),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C srLDA
if(cf(19).ne.0.d0.or.cfe(19).ne.0.d0) then
if(shltype.eq.2) then
call uks_x_srlda(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2,mu)
else
call rks_x_srlda(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2,mu)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(19),exf(19),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C srPW
if(cf(20).ne.0.d0.or.cfe(20).ne.0.d0) then
if(shltype.eq.2) then
call uks_c_srpw(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2,mu)
else
call rks_c_srpw(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2,mu)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(20),exf(20),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C ssrPBEc
if(cf(21).ne.0.d0.or.cfe(21).ne.0.d0) then
if(shltype.eq.2) then
call uks_c_pbes(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2,mu,scr)
else
call rks_c_pbes(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2,mu,scr)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(21),exf(21),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C ssrPBEx
if(cf(22).ne.0.d0.or.cfe(22).ne.0.d0) then
if(shltype.eq.2) then
call uks_x_pbes(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2,mu,scr)
else
call rks_x_pbes(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2,mu,scr)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(22),exf(22),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C ssrP86
if(cf(23).ne.0.d0.or.cfe(23).ne.0.d0) then
if(shltype.eq.2) then
call uks_c_p86s(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2,mu,scr)
else
call rks_c_p86s(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2,mu,scr)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(23),exf(23),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C ssrLYP
if(cf(24).ne.0.d0.or.cfe(24).ne.0.d0) then
if(shltype.eq.2) then
call uks_c_lyps(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2,mu,scr)
else
call rks_c_lyps(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2,mu,scr)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(24),exf(24),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C ssrB88
if(cf(25).ne.0.d0.or.cfe(25).ne.0.d0) then
if(shltype.eq.2) then
call uks_x_b88s(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2,mu,scr)
else
call rks_x_b88s(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2,mu,scr)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(25),exf(25),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C ssrP91c
if(cf(26).ne.0.d0.or.cfe(26).ne.0.d0) then
if(shltype.eq.2) then
call uks_c_pw91s(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2,mu,scr)
else
call rks_c_pw91s(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2,mu,scr)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(26),exf(26),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C ssrP91x
if(cf(27).ne.0.d0.or.cfe(27).ne.0.d0) then
if(shltype.eq.2) then
call uks_x_pw91s(dr,ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,
$zk,vrhoa,vrhob,vsigmaaa,vsigmabb,vsigmaab,v2rhoa2,v2rhob2,v2rhoab,
$v2rhoasigmaaa,v2rhoasigmaab,v2rhoasigmabb,v2rhobsigmabb,
$v2rhobsigmaab,v2rhobsigmaaa,v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,
$v2sigmaab2,v2sigmaabbb,v2sigmabb2,mu,scr)
else
call rks_x_pw91s(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2,mu,scr)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(27),exf(27),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C Adiabatic connection models
C W_inf^hPC
if(cf(28).ne.0.d0.or.cfe(28).ne.0.d0) then
if(shltype.eq.2) then
write(iout,*) 'W_inf^hPC is not implemented for open shells!'
call mrccend(1)
else
call rks_x_winfhpc(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(28),exf(28),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C W_inf^'hPC
if(cf(29).ne.0.d0.or.cfe(29).ne.0.d0) then
if(shltype.eq.2) then
write(iout,*) "W_inf^'hPC is not implemented for open shells!"
call mrccend(1)
else
call rks_x_winfphpc(dr,ngrid,rhoa,sigmaaa,zk,vrhoa,vsigmaaa,
$v2rhoa2,v2rhoasigmaaa,v2sigmaaa2)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(29),exf(29),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C Functionals implemented in the Libxc library
#if defined (LIBXC)
do i=nfunc+1,nfunc+nlfunc
call libxcifc(ngrid,rhoa,rhob,sigmaaa,sigmabb,sigmaab,zk,vrhoa,
$vrhob,vsigmaaa,vsigmabb,vsigmaab,shltype,cfunc(i),weight,funa,
$funb,sgvaa,sgvbb,sgvab,taua,taub,vtaua,vtaub,vvtaua,vvtaub,cf(i),
$exf(i),nd,rho,vrho,sigma,vsigma,tau,vtau,lapl_rhoa,lapl_rhob,
$vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,vvlapl_rhob,lapl_rho,vlapl_rho,
$mgga,dero,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw,dr,mu,scr,iout,func(i),fb)
enddo
c write(6,*) 'rhoa'
c write(6,"(1000f9.5)") rhoa
c write(6,*) 'zk'
c write(6,"(1000f9.5)") zk
c write(6,*) 'funa'
c write(6,"(1000f9.5)") funa
c write(6,*) 'sgvaa'
c write(6,"(1000f9.5)") sgvaa
#endif
9999 continue
C VV10NL
if(route.eq.'vv10') then
call vv10nl_scf2(ngrid,nngrid,nblock,iblock,nbl,mind2,maxd14,
&ggrid,wweight,ddensity,dtol,omeganull,kappa,omeganull_dn,
&omeganull_dg,kappa_dn,zk,vrhoa,vsigmaaa,beta)
if(shltype.eq.2) then
call dcopy(ngrid,vrhoa,1,vrhob,1)
call dcopy(ngrid,vsigmaaa,1,vsigmabb,1)
call dcopy(ngrid,vsigmaaa,1,vsigmaab,1)
call dscal(ngrid,2.d0,vsigmaab,1)
endif
call funcproc(ngrid,weight,zk,vrhoa,vrhob,vsigmaaa,vsigmabb,
$vsigmaab,funa,funb,sgvaa,sgvbb,sgvab,cf(16),exf(16),nd,shltype,0,
$dero,vtaua,vtaub,vvtaua,vvtaub,vlapl_rhoa,vlapl_rhob,vvlapl_rhoa,
$vvlapl_rhob,v2rhoa2,v2rhob2,v2rhoab,v2rhoasigmaaa,v2rhoasigmaab,
$v2rhoasigmabb,v2rhobsigmabb,v2rhobsigmaab,v2rhobsigmaaa,
$v2sigmaaa2,v2sigmaaaab,v2sigmaaabb,v2sigmaab2,v2sigmaabbb,
$v2sigmabb2,vv2rhoa2,vv2rhob2,vv2rhoab,vv2rhoasigmaaa,
$vv2rhoasigmaab,vv2rhoasigmabb,vv2rhobsigmabb,vv2rhobsigmaab,
$vv2rhobsigmaaa,vv2sigmaaa2,vv2sigmaaaab,vv2sigmaaabb,vv2sigmaab2,
$vv2sigmaabbb,vv2sigmabb2,lrs,rsw)
endif
C
return
end
C
************************************************************************
subroutine m_r(moa,mma,mob,mmb,bfmap,dvec0,ngrid,nbasis,ibasis,
$ncore,nocca,noccb,dfnb,nb,fb,jpi_a,jpi_b,scftype,work1,qi,q)
************************************************************************
implicit none
integer ngrid,nbasis,ibasis,i,ncore,nocca,noccb,dfnb,bfmap(nbasis)
integer scftype,shift
real*8 dvec0(ibasis,ngrid),moa(nbasis,*),mob(nbasis,*)
real*8 jpi_b(nbasis,dfnb,noccb),jpi_a(nbasis,dfnb,nocca)
real*8 qi(*),q(dfnb,*),mma(ibasis,*),mmb(ibasis,*)
real*8 nb(ngrid),fb(ngrid),work1(*),n
real*8,parameter::pi=3.1415926535897932384626433832795028841971d0
C
c write(6,"(f15.10)") moa
c write(6,"(f15.10)")
c write(6,"(f15.10)") dvec0
c write(6,"(f15.10)")
C
C Compress MO coefficient matrix
shift=0
if(scftype.eq.2) shift=nbasis
C
do i=1,ibasis
mma(i,1:nbasis)=moa(bfmap(i),1:nbasis)
enddo
if(scftype.eq.2) then
do i=1,ibasis
mmb(i,1:nbasis)=mob(bfmap(i),1:nbasis)
enddo
endif
C
do i=1,ngrid
call dgemv('t',ibasis,nbasis,1.d0,mma,ibasis,
$dvec0(1,i),1,0.d0,work1,1)
nb(i)=sum(work1(ncore+1:ncore+nocca)**2)
C
if(scftype.eq.1) then
n=nb(i)
elseif(scftype.eq.3) then
n=sum(work1(ncore+1:ncore+noccb)**2)
elseif(scftype.eq.2) then
call dgemv('t',ibasis,nbasis,1.d0,mmb,ibasis,
$dvec0(1,i),1,0.d0,work1(nbasis+1),1)
n=sum(work1(nbasis+ncore+1:nbasis+ncore+noccb)**2)
endif
nb(i)=2.0d0*nb(i)*n
C
call dgemv('t',nbasis,dfnb*nocca,1.d0,jpi_a,nbasis,
$work1,1,0.d0,qi,1)
call dgemv('n',dfnb,nocca,1.d0,qi,dfnb,
$work1(ncore+1),1,0.d0,q,1)
C
if(scftype.eq.1) then
fb(i)=2.0d0*sum(q(1:dfnb,1)**2)
elseif(scftype.ne.1) then
call dgemv('t',nbasis,dfnb*noccb,1.d0,jpi_b,nbasis,
$work1(shift+1),1,0.d0,qi,1)
call dgemv('n',dfnb,noccb,1.d0,qi,dfnb,
$work1(shift+ncore+1),1,0.d0,q(1,2),1)
fb(i)=2.0d0*dot_product(q(1:dfnb,1),q(1:dfnb,2))
endif
C
if(nb(i).le.1.d-12.or.fb(i).le.0.d0.or.fb(i)*nb(i).lt.0.d0) then
fb(i) = 1.d+10
else
c write(6,"(2f35.10)") fb(i),nb(i)
fb(i) = fb(i) / nb(i)
endif
fb(i)=dsqrt(pi)*0.5d0*fb(i)
c write(6,"(f35.10)") fb(i)
C
enddo
C
return
end
C
************************************************************************
subroutine readint(jpi,jpi_b,dfnb,nbasis,ncore,nocc,nal,
$nocc_b,nbe,grfile,scftype,bij,jij,bij_b,jij_b)
************************************************************************
implicit none
integer dfnb,nocc,nbasis,ncore,i,grfile,j,nal,ii,nocc_b,nbe
integer scftype
real*8 jpi(nbasis,dfnb,nocc),jpi_b(nbasis,dfnb,nocc_b)
real*8 bij(nal,nal,dfnb),jij(dfnb,(nal+1)*nal/2)
real*8 bij_b(nbe,nbe,dfnb),jij_b(dfnb,(nbe+1)*nbe/2)
C
open(grfile,file='DFINT_IJ',form='unformatted')
read(grfile) jij
close(grfile)
C
ii=0
do i=1,nal
do j=1,i-1
ii=ii+1
bij(i,j,1:dfnb)=jij(1:dfnb,ii)
bij(j,i,1:dfnb)=jij(1:dfnb,ii)
enddo
ii=ii+1
bij(i,i,1:dfnb)=jij(1:dfnb,ii)
enddo
C
do j=1,nal
do i=1,nocc
jpi(j,1:dfnb,i)=bij(j,ncore+i,1:dfnb)
enddo
enddo
C
open(grfile,file='DFINT_AI',form='unformatted')
do i=1,nocc
read(grfile) (jpi(nal+j,1:dfnb,i),
$j=1,nbasis-nal)
enddo
close(grfile)
C
if(scftype.eq.2.and.nbe.gt.0) then
open(grfile,file='DFINT_IJb',form='unformatted')
read(grfile) jij_b
close(grfile)
C
ii=0
do i=1,nbe
do j=1,i-1
ii=ii+1
bij_b(i,j,1:dfnb)=jij_b(1:dfnb,ii)
bij_b(j,i,1:dfnb)=jij_b(1:dfnb,ii)
enddo
ii=ii+1
bij_b(i,i,1:dfnb)=jij_b(1:dfnb,ii)
enddo
C
do j=1,nbe
do i=1,nocc_b
jpi_b(j,1:dfnb,i)=bij_b(j,ncore+i,1:dfnb)
enddo
enddo
C
open(grfile,file='DFINT_AIb',form='unformatted')
do i=1,nocc_b
read(grfile) (jpi_b(nbe+j,1:dfnb,i),
$j=1,nbasis-nbe)
enddo
close(grfile)
endif
C
return
end
C
************************************************************************
Reference in New Issue View Git Blame Copy Permalink