mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-17 04:00:49 +01:00
3747 lines
152 KiB
Fortran
3747 lines
152 KiB
Fortran
************************************************************************
|
|
subroutine df3int(
|
|
$natoms,nangmax,ncontrmax,nprimmax,
|
|
$nang,ncontr,nprim,
|
|
$gexp,gcoef,coord,
|
|
$ncartmax,ctostr,cartg,
|
|
$nsphermax,cf,boysval,
|
|
$nmboys,
|
|
$dcore,imem,
|
|
$indarr,tedatfile,nbasis,gcn,
|
|
$i4core,ipre,iroute,
|
|
$itol,
|
|
$nbfshmax,nshrange,intpos,iout,
|
|
$densa,
|
|
$focka,fockb,
|
|
$dpre,scftype,
|
|
$imem1,maxcor,thad,thcf2,
|
|
$scoord,
|
|
$rqqij,dfrqq,hrec,
|
|
$deroo,datoms,
|
|
$dfnang,dfncontr,dfnprim,dfgexp,dfgcn,dfnbasis,dfgcoef,
|
|
$dfindarr,dfscr,tcdfinv,dfipre,x,hai,mo,nbll,xpre,hailen,nmoat,
|
|
$moat,
|
|
$imos,kmos,moadd,dfatind,dfnmobasis,ctol0,invfile,spctostr,
|
|
$imo1,imo2,cpre,lnolocx,lexc,scrfile4,chfx,dofit,isqrt,dens,
|
|
$intpostc,lnaf,naftol,wnaf,lintra,nocc,bfdom,ibfdom,jbfdom,
|
|
$umapi,unbi,udfnbi,jmi,intadd,mapi,udfmapinv,atpair,oroute,tegrad,
|
|
$nstate,lcis,rmi,lbij,nbl,dfnatrange,
|
|
$int1,int2,int3,int4,int5,int6,int7,int8,ldfpair,
|
|
$real1,int9,real3,real4,real5,real6,times,spre,dfipra,tcmax,logkc,
|
|
$kp,gck,mo2,cisflag,locfit,nmobasis,natdom,atdom,naoat,aoat,atind,
|
|
$natrange,iimos,jjmos,exclist,ialpha,icore,omega,boys,crsh,
|
|
$haiold,idprscr,itcint,ituv,ll3der,d3dfipre,dfnshrange,grads,ihai,
|
|
$mo3,scrd,nvirt,dfnangmin,lprog,shlmax_th,shnlm_max_th,irreg_re,
|
|
$xlm,tcc,tcs,smat,tsmat,tsmat_tr,smat_tr2,irreg_im,ocint2,ocint,
|
|
$fmm,lmint_max,lcisgrad,rma,lcisgrad2,loccri,kmat,hai_occri,
|
|
$loverlap,istore,ldfock,ldfdens,ishupto,nocc2)
|
|
************************************************************************
|
|
* Three-center Coulomb integrals for DF
|
|
************************************************************************
|
|
implicit none
|
|
integer natoms,nangmax,ncontrmax,nprimmax,ncartmax,iatoms,jatoms,i
|
|
integer nang(natoms),ncontr(0:nangmax,natoms),iang,jang,nsphermax
|
|
integer nprim(0:nangmax,natoms),kang,iprim,j,k,l,imo1,imo2,jj
|
|
integer nicontr,niprim,nicart,njcontr,njprim,njcart,nispher,nmboys
|
|
integer scrfile4,isqrt,dens,it7,icd,nstate,nbl,nob,nop,iscr
|
|
integer tedatfile,nbasis,iout,ipold,jprim,oroute,kfrst
|
|
integer njspher,katoms,imem,dblalloc,teintfile(10),nklen
|
|
integer indarr(natoms*(1+nangmax)*ncontrmax*nsphermax),iian,jjan
|
|
integer intmem,iroute,dero,tcintfile(10)
|
|
integer thad(0:nangmax,-1:2*nangmax,0:2*nangmax,0:2*nangmax),ipos
|
|
integer gcn(2,ncontrmax,0:nangmax,natoms),nbfshmax,ipostc
|
|
integer ijs,nshrange(2,0:nangmax,natoms),i1,dfnatrange(2,natoms)
|
|
integer dfnshrange(2,0:nangmax,natoms),ihai,deroo,ibij,idx,nvirt
|
|
integer ifrst,ilast,jfrst,jlast,nbll,ii,scrmem,xyzomp,nkl,istore
|
|
integer hailen,nmoat(natoms),moat(natoms,nbll),dfnbasis,locfit
|
|
integer kmos(nbll),nkmos,invfile,nmcrt,iacrt,tcis,cisflag,nimos
|
|
integer moadd(nocc),dfnmobasis(nocc),imos(nbll),exclist(natoms)
|
|
integer intpostc(3,(nbasis+1)*nbasis/2),dfatind(nocc,natoms),crsh
|
|
integer intpos(3,(nbasis+1)*nbasis/2),i2,iii,jjj,nmobasis(*)
|
|
integer naoat(natoms,2),aoat(natoms,nocc),natdom(nocc)
|
|
integer natrange(2,*)
|
|
integer dfnang(natoms),dfncontr(0:nangmax,natoms),nshi,nshj,njkmos
|
|
integer dfnprim(0:nangmax,natoms),nilen,njlen,atind(nocc,natoms)
|
|
integer dfgcn(2,ncontrmax,0:nangmax,natoms),nkprim,kprim,niiimos
|
|
integer nkcart,nkspher,nkcontr,atdom(natoms,nocc),niimos,njjmos
|
|
integer dfindarr(natoms*(1+nangmax)*ncontrmax*nsphermax),nafroute
|
|
integer iimos(nbll),jjmos(nbll),ikmos(nbll),nikmos,jkmos(nbll)
|
|
real*8 dfgexp(nprimmax,0:nangmax,natoms),dfscr(*),tcmax,omega
|
|
real*8 x(dfnbasis,0:3),cf,ddens(nbfshmax,nbfshmax,nstate),rbraket
|
|
real*8 dfgcoef(nprimmax,ncontrmax,0:nangmax,natoms),ijpre,ctol
|
|
real*8 tcdfinv(dfnbasis,dfnbasis),dfipre(natoms,0:nangmax),etol
|
|
real*8 cpre(natoms,0:nangmax),chfx,rpq(3,nprimmax,nprimmax)
|
|
real*8 densa(nbasis,nbasis,nstate)!,densb(nbasis,nbasis,nstate)
|
|
real*8 hrec(4*nangmax,nprimmax,0:nangmax,natoms),ddot,dtol!,dte(*)
|
|
real*8 focka(nbasis,nbasis,3),fockb(nbasis,nbasis,3),tegrad(3)
|
|
real*8 xpre(natoms,0:nangmax)!qmat(nbasis,nbasis,*)
|
|
real*8 gexp(nprimmax,0:nangmax,natoms),coord(3,natoms)
|
|
real*8 gcoef(nprimmax,ncontrmax,0:nangmax,natoms),dfipra(natoms)
|
|
real*8 ax,bx,ay,by,az,bz,cx,cy,cz,itol,icpre,ijcpre,cctol
|
|
real*8 ctostr(ncartmax**2,0:nangmax),zab,dcore(*)
|
|
real*8 thcf2(3,0:nangmax,0:nangmax,natoms,natoms),sb2
|
|
real*8 ipre(natoms,0:nangmax,natoms,0:nangmax),ss,boysval
|
|
real*8 spre(natoms,0:nangmax,natoms,0:nangmax),a,b,c,p,normg,mu
|
|
real*8 dpre(natoms,0:nangmax,natoms,0:nangmax),ab,cc
|
|
real*8 scoord(3,natoms,natoms,0:nangmax+1),ddfact,sab,qab,zc
|
|
real*8 rqqij(4*nangmax+1+deroo,nprimmax,nprimmax),grads(3,natoms)
|
|
real*8 dfrqq(4*nangmax+1+deroo,nprimmax,0:nangmax,natoms)
|
|
real*8 mo(nbasis,*),spctostr(3*ncartmax**2+1,0:nangmax)
|
|
real*8 mo2(nbasis,*),cisc
|
|
real*8 mo3(nocc,nocc),scrd(dfnbasis,nvirt,nocc)
|
|
logical lcisgrad,lldexc_old,lcisgrad2,llcis,ltdhf
|
|
integer ncont,inad
|
|
real*8 hai(hailen),haiold(hailen)!,hai(dfnbasis,nbasis,nbll)
|
|
real*8 naftol,wnaf(dfnbasis,dfnbasis),extab,extmunu,rext,extc,rbk
|
|
real*8 rmi(nbasis,nocc,nstate),blz(0:nangmax),cmax,extc_ahlrichs
|
|
real*8 extab_fmmi,extab_fmmj,extab_fmmii,extab_fmmjj
|
|
real*8 rma(nbasis,nvirt,2)
|
|
logical cartg,logjc,lhrr,dofit,llexc,lnaf,lcis,lbij,lldexc
|
|
logical abcdl,jgi,ieqj,lexc,lnolocx,lsep,llg,lsmall,l3route,lprog
|
|
c parameter(pi=3.14159265358979323846264338327950288419716939938d0)
|
|
integer nmax1,m,ilast2,ifrst2,ialpha,idfatdom,idfnatdom,intalloc
|
|
integer iangmax,jangmax,kangmax,icore(*),dfnangmin(natoms)
|
|
integer n1crt,iiatoms
|
|
integer iiang,jjatoms,nnaa
|
|
integer ndim1,ndim2,nbd,imem1,maxcor
|
|
integer jjang,nnaac
|
|
integer datoms,ncd
|
|
integer ndim3,iisyev,dfnbasis_new
|
|
integer ssi(4)
|
|
integer kfrst1,int_scr
|
|
integer*4 i4core(*),isyev
|
|
equivalence(isyev,iisyev) !For Intel
|
|
equivalence(ss,ssi)
|
|
character*4 intalg
|
|
character*5 scftype
|
|
character*8 dfalg,cialg,cscr8
|
|
character*16 cscr16,calc
|
|
c ldfgrad
|
|
integer ihai1,ihai2,libij,ifock_scr
|
|
integer ifock_scr_i,ifock_scr_j
|
|
integer ldf_bij_mem
|
|
double precision ddens2(nbfshmax,nbfshmax),ldfdens(*)
|
|
! double precision, allocatable :: fock_scr(:,:)
|
|
logical ldfock
|
|
c prim_uc
|
|
integer, pointer :: ip(:),jp(:)
|
|
integer, target :: iip(nprimmax),jjp(nprimmax)
|
|
real*8, pointer :: gci(:,:),gcj(:,:)
|
|
real*8, target :: gcii(nprimmax,ncontrmax)
|
|
real*8, target :: gcjj(nprimmax,ncontrmax)
|
|
integer kp(nprimmax,0:nangmax,natoms)
|
|
real*8 gck(nprimmax,ncontrmax,0:nangmax,natoms)
|
|
c logkc
|
|
logical logkc(0:nangmax,natoms)
|
|
integer nkc
|
|
c memory req
|
|
logical lrange,lbragen,lketgen ! generated codes or not
|
|
integer d,dfintder1cmem,dfint3dermem,dijklen
|
|
c dERI prescreening
|
|
integer ang,ncrt(-1:2*(nangmax+deroo)),idprscr,itcint,ituv
|
|
integer crt(-1:2*(nangmax+deroo)),idummy,nj
|
|
integer npk,ddatoms,dscrmem
|
|
real*8 dsptr(1+3*ncartmax**2,(deroo+1)*(deroo+2)/2,
|
|
$0:nangmax,0:deroo)
|
|
real*8 ddfipre(0:nangmax),rdummy,dtcm,tcm(0:deroo)
|
|
real*8 d3dfipre(0:nangmax,natoms)
|
|
real*8 dpremat(nprimmax**2),apr,bpr,cpr,prval
|
|
real*8 diprei,dipre2i(nprimmax**2)
|
|
real*8 diprej,dipre2j(nprimmax**2)
|
|
real*8 dipre2nd(nprimmax**2)
|
|
logical ldpre,labcpre,l1c,lsig,ldab,lda,ldb,ldc
|
|
logical lcsig,lbcsig,lacsig
|
|
real*8 ypre,ypre0,ctol0,sqvl
|
|
real*8 gpre,gpre0,dpre_states
|
|
real*8 qab_da,qab_db
|
|
integer k1,k2
|
|
real*8 qabcalc,getsdpre
|
|
integer ifn,jfn,ishupto,isdpre,nsh,shnum
|
|
integer alldERI,screendERI,dfbnum,ndERIsd
|
|
integer, allocatable :: countdERI(:,:)
|
|
|
|
c dERI
|
|
logical ll3der,l3der,l1der ! 1 center or 3 centers?
|
|
integer nd,ndd
|
|
logical labc,lab,lac,lbc,ldprim
|
|
c
|
|
C For local integral transformation
|
|
integer lintra,nocc,nocc2,bfdom,ibfdom,jbfdom,umapi,unbi
|
|
integer udfnbi,intadd(natoms,0:nangmax,natoms,0:nangmax),mapi
|
|
integer udfmapinv,atpair(natoms,natoms)
|
|
real*8 jmi
|
|
!NP
|
|
integer int1,int2,int3,int4,int5,int6,int7,int8,int9
|
|
integer ldfpair(natoms,natoms)
|
|
real*8 real1,real3,real4,real5,real6,times(6,0:100)
|
|
integer jjlim
|
|
logical lperm,loverlap,lscr,overla3_scr,ext_test
|
|
character*16 ilmoname,jname,filename
|
|
!NP
|
|
C For OpenMP
|
|
integer iimem
|
|
c occri
|
|
integer nthread
|
|
logical loccri
|
|
double precision kmat(nbasis*nocc),hai_occri(*)
|
|
integer omp_get_max_threads
|
|
c fmm
|
|
integer lmint, lmint_min, nlm, nn, iitn
|
|
integer lmint_max, nlm_max, shlmax, shnlm_max, fmmord
|
|
integer isx, isy, isz, ints, intc, intj, inti, step
|
|
character*8 fmm
|
|
real*8 mcxyz(3),extab_fmm,rextab_fmm,rextba_fmm,extc_fmm,rext_fmm
|
|
real*8 xab2, yab2, zab2, xac2, yac2, zac2, extent, get_maxval
|
|
logical lj2,lfmm,lc1,lc2,le1,le2
|
|
character*8 cpssp
|
|
integer shlmax_th(0:*),shnlm_max_th(0:*)
|
|
real*8 irreg_re(*),xlm(*),tcc(*),tcs(*),smat(*),tsmat(*)
|
|
real*8 smat_tr2(nbfshmax*nbll*2*(((lmint_max+1)*(lmint_max+2))/2))
|
|
real*8 tsmat_tr(*),irreg_im(*)
|
|
real*8 ocint2(dfnbasis,2*(nangmax+1)),ocint(dfnbasis)
|
|
interface
|
|
subroutine boys(x,nlo,nmax,boysval,coef,nm,t,norm,siz,omega,alpha)
|
|
implicit none
|
|
integer nlo,nmax,nm,siz
|
|
real*8 x,boysval(0:nm,0:1480),coef(0:nm),t(siz,0:nmax),norm,omega
|
|
real*8 alpha
|
|
end
|
|
end interface
|
|
interface
|
|
subroutine mulint_gn
|
|
end
|
|
end interface
|
|
#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
|
|
#else
|
|
integer thrd
|
|
#endif
|
|
#if defined (OMP)
|
|
integer OMP_GET_NUM_THREADS,OMP_GET_THREAD_NUM,omplen
|
|
C$OMP PARALLEL
|
|
C$OMP& DEFAULT(SHARED)
|
|
xyzomp=OMP_GET_NUM_THREADS()
|
|
C$OMP END PARALLEL
|
|
#else
|
|
xyzomp=1
|
|
#endif
|
|
C Set variables for multipole method
|
|
call getkey('pssp',4,cpssp,8)
|
|
if(trim(fmm).ne.'off') then
|
|
call getkey('fmmord',6,cscr8,8)
|
|
read(cscr8,*) fmmord
|
|
c call getkey('extent',6,cscr16,16)
|
|
c read(cscr16,*) extent
|
|
extent=0.d0
|
|
extent = -extent ! ez kell ha extent != 0
|
|
nlm = ((lmint_max+1)*(lmint_max+2))/2
|
|
nlm_max = nlm
|
|
lmint=nlm_max
|
|
smat_tr2 = 0.0d0
|
|
lmint = nangmax
|
|
nlm = ((lmint+1)*(lmint+2))/2
|
|
ocint = 0.0d0
|
|
ocint2 = 0.0d0
|
|
xlm(1:2*(((lmint_max+1)*(lmint_max+2))/2)*xyzomp) = 0.0d0
|
|
C One-center multipole integrals for the aux basis, real part
|
|
call mulinf(natoms,nangmax,ncontrmax,nprimmax,ncartmax,
|
|
$nsphermax,dfnang,dfnangmin,dfncontr,dfnprim,dfgexp,dfgcoef,
|
|
$coord,ctostr,dfnbasis,ocint2,dcore(imem),dfgcn,dfnshrange,cartg,
|
|
$coord(1,2),lmint,0,.true.)
|
|
do katoms = 1, natoms
|
|
kangmax=dfnang(katoms)
|
|
do kang=0,kangmax
|
|
nkspher=2*kang+1
|
|
nkcontr=dfncontr(kang,katoms)
|
|
nklen=nkcontr*nkspher
|
|
kfrst = dfnshrange(1,kang,katoms)
|
|
do i = kfrst+1, kfrst+nklen
|
|
ocint(i) = get_maxval(ocint2(i,1),dfnbasis,kang)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
C
|
|
scrmem=1
|
|
diprei=0.d0
|
|
diprej=0.d0
|
|
ifock_scr_i=1
|
|
ifock_scr_j=1
|
|
C
|
|
call getkey('calc',4,calc,16)
|
|
ltdhf=.false.
|
|
if(trim(calc).eq.'scf') ltdhf=.true.
|
|
ncont=1
|
|
if(lcisgrad2) ncont=3
|
|
cctol=1d2*itol
|
|
dfnbasis_new=dfnbasis
|
|
llexc=lexc.and.(iroute.eq.2.or.iroute.eq.4.or.iroute.eq.5.or.
|
|
& iroute.eq.6.or.iroute.eq.7.or.iroute.eq.8.or.
|
|
& iroute.eq.37.or.iroute.eq.28.or.iroute.eq.26)
|
|
if(llexc.and.cisflag.ne.4.and.iroute.ne.7.and.iroute.ne.37)
|
|
& call dfillzero(hai,hailen)
|
|
lperm=.true. !NP : if true: exploit permutational symm in the 3-center AO intergals
|
|
if (lintra.eq.5.or.lintra.eq.6.or.lintra.eq.7) lperm=.false. !NP
|
|
call getkey('intalg',6,intalg,4)
|
|
call getkey('dfalg',5,dfalg,8)
|
|
if(intalg.eq.'auto') intalg='os '
|
|
ncd=1
|
|
lsmall=iroute.ne.1.and.lintra.eq.0.and.istore.eq.0
|
|
l3route=ll3der.and.deroo.gt.0
|
|
if(istore.eq.1) then
|
|
dpre=1.d0
|
|
inad=hailen+1
|
|
endif
|
|
9753 continue
|
|
c allocate(fock_scr(nbfshmax*nocc*xyzomp,2))
|
|
ctol = ctol0
|
|
if(l3route.and.oroute.ne.4) then
|
|
l3der=.false.
|
|
dero=0
|
|
else
|
|
l3der=ll3der
|
|
dero=deroo
|
|
if(dero.eq.1.and.l3der) then
|
|
ctol = itol
|
|
C Variables for counting the number of all dERIs and not screened dERIs
|
|
alldERI=0
|
|
screendERI=0
|
|
allocate(countdERI(2,xyzomp))
|
|
countdERI = 0
|
|
C Number of shells
|
|
nsh=shnum(natoms,nang,icore(ishupto))
|
|
isdpre=ishupto+natoms
|
|
endif
|
|
endif
|
|
if(dero.gt.0)then
|
|
intalg='herm'
|
|
ncd=3 !szemet
|
|
endif
|
|
c Reading Gamma^P_imu for MP2 gradient
|
|
if(oroute.eq.4.and.ll3der)
|
|
& read(invfile) (hai(i),i=1,dfnbasis*nbll*nbasis)
|
|
|
|
lsep=(dero.eq.0.and.(omega.ne.0.d0.or.intalg.eq.'rys '.or.cartg))
|
|
& .or.loverlap ! df_primcalc will be called for ERIs
|
|
ldprim=.not.lsep.and.dero.eq.0.and.intalg.eq."herm" ! dprimcalc will be called for ERIs
|
|
l1der=dero.eq.1.and..not.l3der ! derivatives with respect to one center
|
|
lrange=(omega.ne.0.d0.and..not.cartg.and.intalg.eq.'os ').or.
|
|
& loverlap ! generated codes for range separated ERIs
|
|
if(l3der) then
|
|
nd=3
|
|
else
|
|
nd=1
|
|
endif
|
|
if(lsmall) then
|
|
ndim1=nbfshmax*xyzomp*nd
|
|
else
|
|
ndim1=dfnbasis*nd
|
|
endif
|
|
C Allocate memory for integrals(Do not allocate before dealloc(intmem)!)
|
|
ndim2=ndim1*nbfshmax
|
|
ndim3=ndim2*nbfshmax
|
|
intmem=dblalloc(ncd*ndim3) !dfscr
|
|
if(l3der.and.llexc) then
|
|
idx=dblalloc(nbfshmax*nbfshmax*dfnbasis)
|
|
if(.not.lnolocx) then
|
|
call read_dfatdom(natoms,nocc,idfatdom,idfnatdom,ialpha,
|
|
&scrfile4,icore)
|
|
endif
|
|
else
|
|
idx=imem
|
|
endif
|
|
C Open TEINT
|
|
if(iroute.eq.1) then
|
|
call intopenw(teintfile)
|
|
if(dens.gt.0) call intopenwtc(tcintfile)
|
|
endif
|
|
C
|
|
nafroute=0
|
|
if(lnaf) nafroute=1
|
|
C DAVID
|
|
c to check the type of direct cis algorithm
|
|
tcis=0
|
|
nob=0
|
|
if(llexc) then
|
|
if(lcis) then
|
|
call getkey('cialg',5,cialg,8)
|
|
if(cialg.eq.'direct '.or.(cisflag.eq.3.or.cisflag.eq.5))
|
|
$tcis=3
|
|
if(cialg.eq.'direct2 '.or.cisflag.eq.4) tcis=2
|
|
if(cialg.eq.'direct3 ') tcis=1
|
|
endif
|
|
if(tcis.eq.2.and.cisflag.ne.4) then
|
|
write(iout,*) 'Assembly step of exchange...'
|
|
ifrst=imo1-1
|
|
ndim3=(2*ifrst+nbll+1)*nbll/2
|
|
C nob=the number of blocks
|
|
nob=nocc/nbl
|
|
if(mod(nocc,nbl).ne.0) nob=nob+1
|
|
C nop=the number of tiles in all blocks
|
|
nop=nob*(nob+1)/2
|
|
call getdir(nbl,nbll,imo1,imo2,nop,nob,nstate,nbasis,hai,rmi,
|
|
$invfile,tcis,mo)
|
|
endif
|
|
endif
|
|
C
|
|
2345 continue
|
|
c Precalculate auxiliary variables
|
|
call caaux(coord,scoord,natoms,nangmax,thad,thcf2,nprimmax,gexp
|
|
$,nprim,nang,nnaa,nnaac,ncontrmax,hrec,intalg,dero)
|
|
if(dero.gt.0.or.ldprim)
|
|
$call dfcaaux(natoms,dfnang,dfnprim,nangmax,dfgexp,
|
|
$nprimmax,dero,dfrqq)
|
|
nbd=dfnbasis*(nbasis+1)*nbasis/2
|
|
ipold=0
|
|
ipos=0
|
|
ipostc=0
|
|
do iang=0,nangmax
|
|
blz(iang)=dsqrt(ddfact(2*iang-1))
|
|
enddo
|
|
|
|
c Determining if the DF auxiliary basis is uncontracted
|
|
do katoms=1,natoms
|
|
do kang=0,dfnang(katoms)
|
|
nkc=dfncontr(kang,katoms)
|
|
call df_logkc(logkc(kang,katoms),dfnprim(kang,katoms),nkc,
|
|
$dfgcn(1,1,kang,katoms))
|
|
if(.not.logkc(kang,katoms)) then
|
|
c kp,gck
|
|
call kpgck(gck(1,1,kang,katoms),kp(1,kang,katoms),
|
|
$dfgcoef(1,1,kang,katoms),dfgcn(1,1,kang,katoms),nprimmax,
|
|
$ncontrmax,nkc)
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
C Gyula
|
|
if(l1der) then
|
|
c Calculate two-center prescreening ERI derivatives for datoms: save to ddfipre
|
|
do ang=-1,2*(nangmax+dero)
|
|
ncrt(ang)=(ang+1)*(ang+2)/2
|
|
crt(ang)=ang*(ang+1)*(ang+2)/6 ! num. of components up to ang-1
|
|
enddo
|
|
C Compute solid harm. trf matrix for derivatives from Hermite Gaussians
|
|
call dsptr_fill(nangmax,ncrt,dero,dsptr,spctostr,ncartmax)
|
|
C (d[k]|d[k]) for datoms
|
|
ddfipre=0.d0 ! maximum (d[k]|d[k]) for each kang
|
|
dtcm=0.d0 ! [maximum (d[k]|d[k])]*nkprim for datoms
|
|
do kang=0,dfnang(datoms)
|
|
nkprim=dfnprim(kang,datoms)
|
|
call prim_md_kk(kang,nkprim,dfgexp(1,kang,datoms),
|
|
$(kang+dero+1)*(kang+dero+2)/2,2*(kang+1)+1,ncartmax,nprimmax,
|
|
$kang+dero,dsptr(1,1,kang,dero),dero,ddfipre(kang),ncd,ncrt,
|
|
$2*kang+1,dfgcoef(1,1,kang,datoms),ncontrmax)
|
|
ddfipre(kang)=dsqrt(ddfipre(kang))
|
|
if(logkc(kang,datoms)) then
|
|
npk=1
|
|
else
|
|
npk=nkprim
|
|
endif
|
|
dtcm=max(dtcm,npk*ddfipre(kang))
|
|
enddo
|
|
elseif(l3der) then
|
|
c Calculate two-center prescreening ERI derivatives: save to d3dfipre
|
|
call herm_prescr_driver(rdummy,nang,natoms,nangmax,gexp,dcore,
|
|
$coord,ncartmax,nprimmax,spctostr,dero,nprim,scoord,idprscr,
|
|
$itcint,ituv,ncd,ncontrmax,gcoef,dfgcoef,dfgexp,dfnprim,d3dfipre,
|
|
$rdummy,tcm,itol,idummy,idummy,logkc,.false.,dfnang,1,ncrt,crt,
|
|
$dsptr)
|
|
endif
|
|
llcis=lcis.or.((lcisgrad.or.lcisgrad2).and..not.l3der)
|
|
C
|
|
#if defined (MPI)
|
|
xyzcount=0
|
|
#endif
|
|
c Loop over atoms
|
|
ilast=0
|
|
do iiatoms=1,natoms
|
|
#if defined (MPI)
|
|
if((lexc.and.iroute.ne.3).or.xyzcount.eq.rank) then
|
|
#endif
|
|
if(cisflag.eq.5) then
|
|
if(locfit.eq.2.and.exclist(iiatoms).eq.0) cycle
|
|
endif
|
|
iangmax=nang(iiatoms)
|
|
if(lintra.gt.0) then
|
|
if(atpair(iiatoms,iiatoms).eq.0) iangmax=-1
|
|
endif
|
|
if(llexc.and.locfit.ge.2) then
|
|
nimos=0
|
|
do ii=1,naoat(iiatoms,2)
|
|
i=aoat(iiatoms,ii)
|
|
if(i.ge.imo1.and.i.le.imo2) then
|
|
nimos=nimos+1
|
|
imos(nimos)=i
|
|
endif
|
|
enddo
|
|
niiimos=nimos
|
|
do ii=naoat(iiatoms,2)+1,naoat(iiatoms,1)
|
|
i=aoat(iiatoms,ii)
|
|
if(i.ge.imo1.and.i.le.imo2) then
|
|
nimos=nimos+1
|
|
imos(nimos)=i
|
|
endif
|
|
enddo
|
|
endif
|
|
do iiang=0,iangmax
|
|
C
|
|
if(cisflag.eq.5.and.locfit.eq.2) then
|
|
ifrst2=nshrange(1,iiang,iiatoms)
|
|
ilast2=nshrange(2,iiang,iiatoms)
|
|
nilen=ilast2-ifrst2
|
|
ifrst=ilast
|
|
ilast=ifrst+nilen
|
|
nshi=ifrst2-nshrange(1,0,iiatoms)
|
|
else
|
|
ifrst=nshrange(1,iiang,iiatoms)
|
|
ilast=nshrange(2,iiang,iiatoms)
|
|
nilen=ilast-ifrst
|
|
nshi=ifrst-nshrange(1,0,iiatoms)
|
|
endif
|
|
C
|
|
if(llexc) icpre=cpre(iiatoms,iiang)
|
|
if (.not.lperm) then !NP
|
|
jjlim=natoms
|
|
elseif (lperm) then
|
|
jjlim=iiatoms
|
|
endif
|
|
c iip,gcii
|
|
call kpgck(gcii,iip,gcoef(1,1,iiang,iiatoms),
|
|
$gcn(1,1,iiang,iiatoms),nprimmax,ncontrmax,ncontr(iiang,iiatoms))
|
|
jlast=0
|
|
do jjatoms=1,jjlim !NP
|
|
if(cisflag.eq.5) then
|
|
if(locfit.eq.2.and.exclist(jjatoms).eq.0) cycle
|
|
endif
|
|
jangmax=nang(jjatoms)
|
|
if(iiatoms.eq.jjatoms.and.lperm) jangmax=iiang !NP
|
|
if(lintra.gt.0) then
|
|
if(atpair(iiatoms,jjatoms).eq.0) jangmax=-1
|
|
endif
|
|
do jjang=0,jangmax
|
|
if(fmm.ne.'off '.or.loverlap) then
|
|
extab_fmmi = extc_ahlrichs(gexp(1,iiang,iiatoms),
|
|
& nprim(iiang,iiatoms),1.0d-8)
|
|
extab_fmmj = extc_ahlrichs(gexp(1,jjang,jjatoms),
|
|
& nprim(jjang,jjatoms),1.0d-8)
|
|
if(.not.ext_test(extab_fmmi,extab_fmmj,
|
|
& coord(1,iiatoms),coord(1,jjatoms))) cycle
|
|
endif
|
|
c jjp,gcjj
|
|
if(jjang.ne.iiang.or.jjatoms.ne.iiatoms) then
|
|
call kpgck(gcjj,jjp,gcoef(1,1,jjang,jjatoms),
|
|
$gcn(1,1,jjang,jjatoms),nprimmax,ncontrmax,ncontr(jjang,jjatoms))
|
|
else
|
|
jjp=iip
|
|
gcjj=gcii
|
|
endif
|
|
if(lintra.eq.8) call time0(times)
|
|
ijpre=ipre(iiatoms,iiang,jjatoms,jjang)
|
|
C
|
|
if(cisflag.eq.5.and.locfit.eq.2) then
|
|
ifrst2=nshrange(1,jjang,jjatoms)
|
|
ilast2=nshrange(2,jjang,jjatoms)
|
|
njlen=ilast2-ifrst2
|
|
jfrst=jlast
|
|
jlast=jfrst+njlen
|
|
nshj=ifrst2-nshrange(1,0,jjatoms)
|
|
else
|
|
jfrst=nshrange(1,jjang,jjatoms)
|
|
jlast=nshrange(2,jjang,jjatoms)
|
|
nshj=jfrst-nshrange(1,0,jjatoms)
|
|
njlen=jlast-jfrst
|
|
endif
|
|
c write(6,*) 'intad',istore,intadd(iiatoms,iiang,jjatoms,jjang)
|
|
if(istore.ge.2) then
|
|
c write(6,*) 'hai',hai(1),loc(hai(1))
|
|
j=intadd(iiatoms,iiang,jjatoms,jjang)
|
|
if((j.gt.0.and.istore.eq.2).or.j.gt.istore) then
|
|
call dfinttran(
|
|
$hai(intadd(iiatoms,iiang,jjatoms,jjang)),
|
|
$dfscr(ncd*ndim3+1),dfnbasis,nilen,njlen,ifrst,jfrst,
|
|
$hai,mo(1,imo1),nbasis,nbll,
|
|
$densa(1,1,1),x(1,min(1,dero)),iroute,focka(1,1,1),
|
|
$fockb(1,1,1),ieqj,dfscr(ncd*ndim3+1),dfscr,
|
|
$dfscr(nilen*max(njlen,nbll)*dfnbasis+1),llexc,scftype,
|
|
$lcis)
|
|
cycle
|
|
else if(j.lt.0) then
|
|
cycle
|
|
endif
|
|
endif
|
|
jgi=jjang.gt.iiang
|
|
if(jgi) then
|
|
iatoms=jjatoms
|
|
jatoms=iiatoms
|
|
iang=jjang
|
|
jang=iiang
|
|
else
|
|
iatoms=iiatoms
|
|
jatoms=jjatoms
|
|
iang=iiang
|
|
jang=jjang
|
|
endif
|
|
ieqj=iiatoms.eq.jjatoms.and.iiang.eq.jjang
|
|
if(l3der.and.oroute.eq.4) then
|
|
call shgamma2(nilen,njlen,2.0d0*chfx,ieqj,hai,nbasis,
|
|
&dfnbasis,ifrst,jfrst,dcore(idx),nbll,mo(1,imo1))
|
|
elseif(l3der.and.llexc.and.lnolocx.and..not.ldfock) then
|
|
call shgamma(nilen,njlen,chfx,ieqj,
|
|
$hai,nbasis,dfnbasis,jfrst,dcore(idx),nbll,mo(ifrst+1,imo1),nstate,
|
|
$ltdhf)
|
|
elseif(l3der.and.llexc.and.lnolocx.and.ldfock) then
|
|
call shgamma2(nilen,njlen,chfx,ieqj,hai,nbasis,
|
|
&dfnbasis,ifrst,jfrst,dcore(idx),nbll,mo(1,imo1))
|
|
elseif(l3der.and.llexc.and..not.lnolocx) then
|
|
call ldf_shgamma(nilen,njlen,nocc,chfx,ieqj,hai,
|
|
&nbasis,dfnbasis,ifrst,jfrst,dcore(idx),mo,imo1,imo2,moadd,
|
|
&scrfile4,dfnatrange,dfnmobasis,ialpha,natoms,dfatind,
|
|
&icore(idfatdom),icore(idfnatdom))
|
|
endif
|
|
if(lsmall.and.cisflag.lt.3.and..not.lbij) then
|
|
dpre_states=0.d0
|
|
do icd=1,nstate
|
|
call shdens(ddens(1,1,icd),densa(1,1,icd),nilen,njlen,
|
|
$ifrst,jfrst,nbasis,lcis,dpre_states)
|
|
enddo
|
|
endif
|
|
C Gyula
|
|
C Four-center prescreening ERI derivatives
|
|
if(dero.eq.1) then
|
|
lda=datoms.eq.iatoms
|
|
ldb=datoms.eq.jatoms
|
|
ldab=lda.or.ldb
|
|
niprim=nprim(iang,iatoms)
|
|
njprim=nprim(jang,jatoms)
|
|
nicontr=ncontr(iang,iatoms)
|
|
njcontr=ncontr(jang,jatoms)
|
|
ax=coord(1,iatoms)
|
|
bx=coord(1,jatoms)
|
|
ay=coord(2,iatoms)
|
|
by=coord(2,jatoms)
|
|
az=coord(3,iatoms)
|
|
bz=coord(3,jatoms)
|
|
sb2=(ax-bx)**2+(ay-by)**2+(az-bz)**2
|
|
if(l1der) then
|
|
if(ldab) then ! (d[i]j|d[i]j) and/or (id[j]|id[j])
|
|
nmax1=iang+jang+1
|
|
if(lda) then ! (d[i]j|d[i]j)
|
|
call dipre_driv(niprim,njprim,nicontr,njcontr,sb2,
|
|
$nmax1,1,0,iang,jang,diprei,dipre2i,gcn(1,1,iang,iatoms),
|
|
$gcn(1,1,jang,jatoms),dsptr,dero,ncartmax,nangmax,nprimmax,
|
|
$idprscr,itcint,ituv,gexp(1,iang,iatoms),gexp(1,jang,jatoms),
|
|
$gcoef(1,1,iang,iatoms),gcoef(1,1,jang,jatoms),ncontrmax,ax,bx,ay,
|
|
$by,az,bz,dcore,ncrt,crt,.false.)
|
|
endif
|
|
if(ldb) then ! (id[j]|id[j])
|
|
if(iatoms.eq.jatoms.and.iang.eq.jang) then
|
|
diprej=diprei
|
|
dipre2j=dipre2i
|
|
else
|
|
call dipre_driv(niprim,njprim,nicontr,njcontr,sb2,
|
|
$nmax1,0,1,iang,jang,diprej,dipre2j,gcn(1,1,iang,iatoms),
|
|
$gcn(1,1,jang,jatoms),dsptr,dero,ncartmax,nangmax,nprimmax,
|
|
$idprscr,itcint,ituv,gexp(1,iang,iatoms),gexp(1,jang,jatoms),
|
|
$gcoef(1,1,iang,iatoms),gcoef(1,1,jang,jatoms),ncontrmax,ax,bx,ay,
|
|
$by,az,bz,dcore,ncrt,crt,.false.)
|
|
endif
|
|
endif
|
|
endif
|
|
if(.not.(lda.and.ldb)) then! (ij|ij) ERIs for primitives: will be required for the screening of C derivatives
|
|
nmax1=iang+jang
|
|
call dipre_driv(niprim,njprim,nicontr,njcontr,sb2,
|
|
$nmax1,0,0,iang,jang,rdummy,dipre2nd,gcn(1,1,iang,iatoms),
|
|
$gcn(1,1,jang,jatoms),dsptr,dero,ncartmax,nangmax,nprimmax,
|
|
$idprscr,itcint,ituv,gexp(1,iang,iatoms),gexp(1,jang,jatoms),
|
|
$gcoef(1,1,iang,iatoms),gcoef(1,1,jang,jatoms),ncontrmax,ax,bx,ay,
|
|
$by,az,bz,dcore,ncrt,crt,.false.)
|
|
endif
|
|
ldpre=(.not.ldab.and.ijpre*dtcm.gt.ctol) ! C derivative
|
|
$ .or.(lda.and..not.ldb
|
|
$ .and.diprei*tcmax+ijpre*dtcm.gt.ctol) ! A or AC derivative
|
|
$ .or.(ldb.and..not.lda
|
|
$ .and.diprej*tcmax+ijpre*dtcm.gt.ctol) ! B or BC derivative
|
|
$ .or.(lda.and.ldb
|
|
$ .and.(diprei+diprej)*tcmax.gt.ctol) ! AB derivative
|
|
else ! l3der
|
|
nmax1=iang+jang+1
|
|
call dipre_driv(niprim,njprim,nicontr,njcontr,sb2, ! (d[i]j|d[i]j)
|
|
$nmax1,1,0,iang,jang,diprei,dipre2i,gcn(1,1,iang,iatoms),
|
|
$gcn(1,1,jang,jatoms),dsptr,dero,ncartmax,nangmax,nprimmax,
|
|
$idprscr,itcint,ituv,gexp(1,iang,iatoms),gexp(1,jang,jatoms),
|
|
$gcoef(1,1,iang,iatoms),gcoef(1,1,jang,jatoms),ncontrmax,ax,bx,ay,
|
|
$by,az,bz,dcore,ncrt,crt,.false.)
|
|
call dipre_driv(niprim,njprim,nicontr,njcontr,sb2, ! (id[j]|id[j])
|
|
$nmax1,0,1,iang,jang,diprej,dipre2j,gcn(1,1,iang,iatoms),
|
|
$gcn(1,1,jang,jatoms),dsptr,dero,ncartmax,nangmax,nprimmax,
|
|
$idprscr,itcint,ituv,gexp(1,iang,iatoms),gexp(1,jang,jatoms),
|
|
$gcoef(1,1,iang,iatoms),gcoef(1,1,jang,jatoms),ncontrmax,ax,bx,ay,
|
|
$by,az,bz,dcore,ncrt,crt,.false.)
|
|
nmax1=iang+jang
|
|
call dipre_driv(niprim,njprim,nicontr,njcontr,sb2,! (ij|ij) ERIs for primitives
|
|
$nmax1,0,0,iang,jang,rdummy,dipre2nd,gcn(1,1,iang,iatoms),
|
|
$gcn(1,1,jang,jatoms),dsptr,dero,ncartmax,nangmax,nprimmax,
|
|
$idprscr,itcint,ituv,gexp(1,iang,iatoms),gexp(1,jang,jatoms),
|
|
$gcoef(1,1,iang,iatoms),gcoef(1,1,jang,jatoms),ncontrmax,ax,bx,ay,
|
|
$by,az,bz,dcore,ncrt,crt,.false.)
|
|
apr = diprei*tcmax
|
|
cpr = ijpre*tcm(1)
|
|
prval = (apr+cpr) + max(apr,cpr)
|
|
ypre0=0.d0
|
|
do icd=0,ncont-1
|
|
ypre0=max(ypre0,maxval(dabs(x(:,icd))))
|
|
enddo
|
|
gpre0=
|
|
$maxval(dabs(dcore(idx:idx+nilen*njlen*dfnbasis-1)))
|
|
if(llexc) then
|
|
if(iroute.eq.2) then
|
|
dtol=max(gpre0,dpre_states*ypre0)
|
|
else
|
|
dtol=gpre0
|
|
endif
|
|
else
|
|
dtol=dpre_states*ypre0
|
|
endif
|
|
prval = prval*dtol
|
|
ldpre=prval.gt.ctol
|
|
endif
|
|
else
|
|
ldpre=.false.
|
|
endif
|
|
C
|
|
if((dero.eq.0.and.ijpre*tcmax.gt.ctol) ! undifferentiated
|
|
$ .or.ldpre ! 1st der
|
|
$ .or.dero.gt.1) then ! higher der
|
|
c write(6,*) 'bent',istore.lt.2,intadd(iiatoms,iiang,jjatoms,jjang)
|
|
if(llexc) ijcpre=max(icpre,cpre(jjatoms,jjang))
|
|
if(llexc.and.locfit.ge.2) then
|
|
niimos=0
|
|
njjmos=0
|
|
do jj=1,naoat(jjatoms,2)
|
|
j=aoat(jjatoms,jj)
|
|
if(j.ge.imo1.and.j.le.imo2) then
|
|
do i=1,nimos
|
|
if(imos(i).eq.j) then
|
|
if(ijpre*tcmax*
|
|
$sum(dabs(mo(jfrst+1:jlast,j))).gt.cctol) then
|
|
njjmos=njjmos+1
|
|
jjmos(njjmos)=j
|
|
endif
|
|
if(i.le.niiimos) then
|
|
if(ijpre*tcmax*
|
|
$sum(dabs(mo(ifrst+1:ilast,j))).gt.cctol) then
|
|
niimos=niimos+1
|
|
iimos(niimos)=j
|
|
endif
|
|
endif
|
|
exit
|
|
endif
|
|
enddo
|
|
endif
|
|
enddo
|
|
do jj=naoat(jjatoms,2)+1,naoat(jjatoms,1)
|
|
j=aoat(jjatoms,jj)
|
|
if(j.ge.imo1.and.j.le.imo2) then
|
|
do i=1,niiimos
|
|
if(imos(i).eq.j) then
|
|
if(ijpre*tcmax*
|
|
$sum(dabs(mo(ifrst+1:ilast,j))).gt.cctol) then
|
|
niimos=niimos+1
|
|
iimos(niimos)=j
|
|
endif
|
|
exit
|
|
endif
|
|
enddo
|
|
endif
|
|
enddo
|
|
endif
|
|
ndim2=nilen*njlen
|
|
if(lsmall) then
|
|
ndim3=ndim2*nbfshmax*nd
|
|
else
|
|
ndim3=ndim2*dfnbasis*nd
|
|
endif
|
|
if(.not.lsmall) call dfillzero(dfscr,ncd*ndim3)
|
|
C Swap integral order
|
|
if(jgi) then
|
|
i1=2
|
|
i2=1
|
|
ip => jjp
|
|
jp => iip
|
|
gci => gcjj
|
|
gcj => gcii
|
|
else
|
|
i1=1
|
|
i2=2
|
|
ip => iip
|
|
jp => jjp
|
|
gci => gcii
|
|
gcj => gcjj
|
|
endif
|
|
logjc=iatoms.eq.jatoms.and.iang.eq.jang
|
|
if(dero.ne.1) then
|
|
ax=coord(1,iatoms)
|
|
ay=coord(2,iatoms)
|
|
az=coord(3,iatoms)
|
|
bx=coord(1,jatoms)
|
|
by=coord(2,jatoms)
|
|
bz=coord(3,jatoms)
|
|
sb2=scoord(1,iatoms,jatoms,1)**2+
|
|
$ scoord(2,iatoms,jatoms,1)**2+
|
|
$ scoord(3,iatoms,jatoms,1)**2
|
|
niprim=nprim(iang,iatoms)
|
|
njprim=nprim(jang,jatoms)
|
|
nicontr=ncontr(iang,iatoms)
|
|
njcontr=ncontr(jang,jatoms)
|
|
endif
|
|
nicart=(iang+1)*(iang+2)/2
|
|
nispher=2*iang+1
|
|
njcart=(jang+1)*(jang+2)/2
|
|
njspher=2*jang+1
|
|
if(cartg) nispher=nicart
|
|
if(cartg) njspher=njcart
|
|
ijs=nispher*njspher
|
|
nmax1=iang+jang
|
|
nmcrt=(nmax1+1)*(nmax1+2)*(nmax1+3)/6
|
|
iacrt=iang*nicart/3
|
|
n1crt=nmcrt-iacrt
|
|
iian=iatoms+iang*natoms
|
|
jjan=jatoms+jang*natoms
|
|
it7=imem
|
|
if(dero.eq.0) then
|
|
call lcodegen(iang,lbragen,nangmax,lketgen)
|
|
lhrr=.not.ldprim ! don't need Cartesian HRR matrix for intalg=herm
|
|
$.and.
|
|
$(.not.lbragen.or..not.lketgen ! don't need Cartesian HRR matrix for generated codes
|
|
$ .or.(lsep.and..not.(lrange.and.lbragen.and.lketgen))) ! don't need Cartesian HRR matrix for generated codes
|
|
elseif(dero.eq.1) then
|
|
call dlcodegen(iang,lbragen,nangmax,lketgen)
|
|
if(.not.(lbragen.and.lketgen)) then
|
|
do iprim=1,niprim
|
|
do jprim=1,njprim
|
|
do i=1,4*nangmax+1+dero
|
|
rqqij(i,iprim,jprim)=
|
|
$i*1.d0/(2.d0*(gexp(iprim,iang,iatoms)+gexp(jprim,jang,jatoms)))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
lhrr=.false.
|
|
else ! dero.gt.1
|
|
a=gexp(1,iang,iatoms)
|
|
ab=a
|
|
do iprim=2,niprim
|
|
a =min(a ,gexp(iprim,iang,iatoms))
|
|
ab=max(ab,gexp(iprim,iang,iatoms))
|
|
enddo
|
|
b=gexp(1,jang,jatoms)
|
|
ab=max(ab,b)
|
|
do jprim=2,njprim
|
|
b =min(b ,gexp(jprim,jang,jatoms))
|
|
ab=max(ab,gexp(jprim,jang,jatoms))
|
|
enddo
|
|
p=a+b
|
|
mu=a*b/p
|
|
normg=dble(niprim*njprim)*
|
|
$2.d0*34.9868366552497256925256433597430d0*dexp(-mu*sb2)/p
|
|
lhrr=.false.
|
|
endif
|
|
if(lsmall.and.cisflag.lt.3.and..not.lbij) then
|
|
if(ldfock) then
|
|
C call ldf_shdens(ddens2,mo,mo2,nilen,njlen,ifrst,
|
|
C &jfrst,nbasis,nocc)
|
|
call shdens(ddens2,ldfdens,nilen,njlen,
|
|
$ifrst,jfrst,nbasis,lcis,dpre_states)
|
|
endif
|
|
endif
|
|
extab=extmunu(ax,ay,az,bx,by,bz,gexp(1,iang,iatoms),
|
|
$gexp(1,jang,jatoms),gcoef(1,1,iang,iatoms),gcoef(1,1,jang,jatoms),
|
|
$nprimmax,nicontr,njcontr,niprim,njprim,itol,rpq,zab)
|
|
qab=0.d0
|
|
if(dero.eq.0) then
|
|
if(ijpre.gt.0.d0) then
|
|
sab=spre(iatoms,iang,jatoms,jang)
|
|
qab=qabcalc(sab,ijpre,zab,0.1d0)
|
|
endif
|
|
elseif(l3der) then
|
|
sab=0.d0
|
|
if(iatoms.ne.jatoms) then
|
|
sab=getsdpre(iatoms,iang,jatoms,jang,nsh,icore(ishupto),
|
|
$dcore(isdpre))
|
|
endif
|
|
qab_da=qabcalc(sab,diprei,zab,0.1d0)
|
|
qab_db=qabcalc(sab,diprej,zab,0.1d0)
|
|
endif
|
|
|
|
C Construct the horizontal transformation matrix for the bra side
|
|
if(lhrr) then
|
|
imem=imem+3*n1crt*ijs+1
|
|
if(jang.gt.0) then
|
|
call genhrr(iang,jang,dcore(imem),ctostr(1,iang),
|
|
$ctostr(1,jang),n1crt,nispher,njspher,nicart,njcart,nangmax,thad,
|
|
$thcf2(1,0,0,iatoms,jatoms),itol)
|
|
call sppack(ijs,n1crt,dcore(imem),dcore(it7),dcore(it7),itol)
|
|
else
|
|
call dcopy(3*n1crt*ijs+1,spctostr(1,iang),1,dcore(it7),1)
|
|
endif
|
|
#if defined (OMP)
|
|
C Calculate the memory requirement of a thread
|
|
if(lsep) then
|
|
if(lbragen.and.lketgen.and.lrange) then ! codegen for range seperated ERIs
|
|
call intmem_gen(nispher,njspher,nsphermax,ncartmax,
|
|
$n1crt,njcontr,ncontrmax,niprim,njprim,nprimmax,omplen)
|
|
else ! df_primcalc will be called for ERIs
|
|
omplen=0
|
|
call df_primcalc_mem(d,d,d,d,d,d,d,omplen,lhrr,
|
|
$intalg.eq.'rys '.and.nmax1+nangmax.le.40,iang,jang,nangmax,
|
|
$nicontr,njcontr,ncontrmax,niprim,njprim,nprimmax,cartg)
|
|
endif
|
|
else
|
|
call intmem_dfint(nmcrt,nispher,njspher,nsphermax,
|
|
$n1crt*ncartmax,nicontr,njcontr,ncontrmax,nangmax,iang,jang,
|
|
$niprim,njprim,nprimmax,ncartmax,omplen)
|
|
omplen=omplen-(4*nmcrt*nispher*njspher+1) ! genhrr not parallelized
|
|
endif
|
|
else
|
|
if(dero.eq.0) then
|
|
if(.not.(ldprim.or.lsep)) then
|
|
call lcodegen(iang,lbragen,nangmax,lketgen)
|
|
if(lbragen.and.lketgen) then ! generated integral codes
|
|
call intmem_gen(nispher,njspher,nsphermax,ncartmax,
|
|
$n1crt,njcontr,ncontrmax,niprim,njprim,nprimmax,omplen)
|
|
else ! dfint subroutine
|
|
call intmem_dfint(nmcrt,nispher,njspher,nsphermax,
|
|
$n1crt*ncartmax,nicontr,njcontr,ncontrmax,nangmax,iang,jang,
|
|
$niprim,njprim,nprimmax,ncartmax,omplen)
|
|
omplen=omplen-(4*nmcrt*nispher*njspher+1) ! genhrr not parallelized
|
|
endif
|
|
elseif(lsep) then
|
|
if(lbragen.and.lketgen.and.lrange) then ! codegen for range seperated ERIs
|
|
call intmem_gen(nispher,njspher,nsphermax,ncartmax,
|
|
$n1crt,njcontr,ncontrmax,niprim,njprim,nprimmax,omplen)
|
|
else ! df_primcalc will be called for ERIs
|
|
omplen=0
|
|
call df_primcalc_mem(d,d,d,d,d,d,d,omplen,lhrr,
|
|
$intalg.eq.'rys '.and.nmax1+nangmax.le.40,iang,jang,nangmax,
|
|
$nicontr,njcontr,ncontrmax,niprim,njprim,nprimmax,cartg)
|
|
endif
|
|
else
|
|
omplen=0
|
|
call dprim_mem(
|
|
$d,d,d,d,d,d,d,d,d,d,d,d,d,0,omplen,iang,jang,nangmax,0,1,1,
|
|
$nprimmax,ncontrmax,njprim,njcontr,niprim,nicontr,.false.)
|
|
endif
|
|
elseif(dero.gt.0) then
|
|
if(dero.eq.1.and.lbragen.and.lketgen) then
|
|
omplen=dfintder1cmem(iang,jang,nangmax,
|
|
$ niprim,njcontr,njprim,ncontrmax,nprimmax,d)
|
|
if(l3der) omplen=max(omplen,! l1der routines might be called
|
|
$ dfint3dermem(iang,jang,nangmax,
|
|
$ niprim,njcontr,njprim,ncontrmax,nprimmax,d))
|
|
else
|
|
omplen=0
|
|
call dprim_mem(
|
|
$d,d,d,d,d,d,d,d,d,d,d,d,d,dero,omplen,iang,jang,nangmax,0,1,1,
|
|
$nprimmax,ncontrmax,njprim,njcontr,niprim,nicontr,l3der)
|
|
endif
|
|
endif
|
|
#endif
|
|
endif
|
|
#if defined (OMP)
|
|
if(lsmall)omplen=max(omplen,nbfshmax**2*nbll+nbfshmax**3)
|
|
#endif
|
|
lab=iatoms.eq.jatoms
|
|
labcpre=nmax1.le.2 ! C derivative is cheaper than B derivative and B derivative is cheaper than A derivative
|
|
if(iroute.eq.7.or.iroute.eq.37) then
|
|
call dfillzero(ldfdens,nbfshmax*nocc*xyzomp*2)
|
|
endif
|
|
C$OMP PARALLEL DO Schedule(Dynamic)
|
|
C$OMP& DEFAULT(SHARED)
|
|
C$OMP& PRIVATE(kang,iimem,katoms,kangmax,nkmos,abcdl,cx,cy,cz,etol)
|
|
C$OMP& PRIVATE(scrmem,thrd,kfrst,nklen,icd,iscr,nkcart,nkspher,nkcontr)
|
|
C$OMP& PRIVATE(nkprim,dtol,ss,i,j,l,m,kmos,rext,rbk,zc,cmax,lldexc,nkl)
|
|
C$OMP& PRIVATE(c,cc,kprim,ikmos,nikmos,jkmos,njkmos,rext_fmm,lfmm)
|
|
C$OMP& PRIVATE(step,rextab_fmm,rextba_fmm,xac2,yac2,zac2,extc_fmm,lscr)
|
|
C$OMP& PRIVATE(ldc,dpremat,lac,lbc,labc,ddatoms,l1c,lsig,ndd,dijklen,nj)
|
|
C$OMP& PRIVATE(dscrmem,apr,bpr,extab_fmmii,extab_fmmjj,lc1,lc2,le1,le2)
|
|
C$OMP& PRIVATE(lldexc_old,kfrst1,ifock_scr_i,ifock_scr_j)
|
|
C$OMP& PRIVATE(lacsig,lcsig,lbcsig,k1,k2,ypre,gpre,sqvl)
|
|
do katoms=1,natoms
|
|
if(cisflag.eq.5) then
|
|
if(locfit.eq.2.and.exclist(katoms).eq.0) cycle
|
|
endif
|
|
c write(6,"('atoms ',3i3)") iatoms,jatoms,katoms
|
|
#if defined (OMP)
|
|
iimem=imem+OMP_GET_THREAD_NUM()*omplen
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
#else
|
|
iimem=imem
|
|
thrd=0
|
|
#endif
|
|
if(iroute.eq.7.or.iroute.eq.37) then
|
|
ifock_scr_i=1+nilen*nocc*thrd
|
|
ifock_scr_j=1+njlen*nocc*thrd+nbfshmax*nocc*xyzomp
|
|
else
|
|
ifock_scr_i=1
|
|
ifock_scr_j=1
|
|
endif
|
|
C Gyula
|
|
if(.not.l3der.and.dero.gt.0) then
|
|
if((iatoms.ne.datoms.and.
|
|
$ jatoms.ne.datoms.and.katoms.ne.datoms).or.
|
|
$ (iatoms.eq.jatoms.and.iatoms.eq.katoms)) cycle
|
|
ldc=katoms.eq.datoms
|
|
ndd=1
|
|
elseif(l3der) then
|
|
if(iatoms.eq.jatoms.and.jatoms.eq.katoms) cycle
|
|
labc=iatoms.ne.jatoms.and.jatoms.ne.katoms
|
|
$.and.iatoms.ne.katoms
|
|
lac=iatoms.eq.katoms
|
|
lbc=jatoms.eq.katoms
|
|
if(labc) then
|
|
ndd=3
|
|
else
|
|
ndd=2
|
|
endif
|
|
endif
|
|
C
|
|
if(.not.lsmall) then
|
|
if(dero.gt.0) then
|
|
scrmem=nilen*njlen*dfnatrange(1,katoms)*ncd*nd+1
|
|
else
|
|
scrmem=nilen*njlen*dfnatrange(1,katoms)+1
|
|
endif
|
|
iscr=1
|
|
endif
|
|
etol=1.d0
|
|
kangmax=dfnang(katoms)
|
|
if(lintra.gt.0) then
|
|
if(ldfpair(katoms,jatoms).eq.0) kangmax=-1
|
|
endif
|
|
nkmos=0
|
|
if(llexc) then
|
|
if(lnolocx.or.l3der) then
|
|
nkmos=1
|
|
etol=ijcpre
|
|
else
|
|
if(locfit.ge.2) then
|
|
etol=ijcpre
|
|
nikmos=0
|
|
njkmos=0
|
|
do l=1,nmoat(katoms)
|
|
i=moat(katoms,l)
|
|
if(i.ge.imo1.and.i.le.imo2) then
|
|
do j=1,niimos
|
|
if(iimos(j).eq.i) then
|
|
nikmos=nikmos+1
|
|
ikmos(nikmos)=i
|
|
exit
|
|
endif
|
|
enddo
|
|
do j=1,njjmos
|
|
if(jjmos(j).eq.i) then
|
|
njkmos=njkmos+1
|
|
jkmos(njkmos)=i
|
|
exit
|
|
endif
|
|
enddo
|
|
endif
|
|
enddo
|
|
nkmos=nikmos+njkmos
|
|
else
|
|
etol=0.d0
|
|
dtol=ijpre*dfipra(katoms)
|
|
do l=1,nmoat(katoms)
|
|
i=moat(katoms,l)
|
|
if(i.ge.imo1.and.i.le.imo2) then
|
|
cmax=0.d0
|
|
do m=ifrst+1,ifrst+nilen
|
|
cmax=max(cmax,dabs(mo(m,i)))
|
|
if(lcis) cmax=max(cmax,dabs(mo2(m,i)))
|
|
enddo
|
|
do m=jfrst+1,jfrst+njlen
|
|
cmax=max(cmax,dabs(mo(m,i)))
|
|
if(lcis) cmax=max(cmax,dabs(mo2(m,i)))
|
|
enddo
|
|
if(dtol*cmax.gt.ctol.or.iroute.eq.7.or.
|
|
& iroute.eq.37) then
|
|
etol=max(etol,cmax)
|
|
nkmos=nkmos+1
|
|
kmos(nkmos)=i
|
|
endif
|
|
endif
|
|
enddo
|
|
endif
|
|
endif
|
|
endif
|
|
abcdl=iatoms.eq.jatoms.and.iatoms.eq.katoms
|
|
cx=coord(1,katoms)
|
|
cy=coord(2,katoms)
|
|
cz=coord(3,katoms)
|
|
kfrst=dfnatrange(1,katoms)
|
|
nkl=0
|
|
rbk=rbraket(cx,cy,cz,niprim,njprim,rpq,nprimmax)
|
|
if(fmm.ne.'off ') then
|
|
xac2 = (cx - coord(1,iiatoms))**2
|
|
yac2 = (cy - coord(2,iiatoms))**2
|
|
zac2 = (cz - coord(3,iiatoms))**2
|
|
extab_fmmii = dsqrt(xac2+yac2+zac2)-extab_fmmi
|
|
xac2 = (cx - coord(1,jjatoms))**2
|
|
yac2 = (cy - coord(2,jjatoms))**2
|
|
zac2 = (cz - coord(3,jjatoms))**2
|
|
extab_fmmjj = dsqrt(xac2+yac2+zac2)-extab_fmmj
|
|
endif
|
|
do kang=0,kangmax
|
|
nkcart=(kang+1)*(kang+2)/2
|
|
nkspher=2*kang+1
|
|
nkcontr=dfncontr(kang,katoms)
|
|
nkprim=dfnprim(kang,katoms)
|
|
if(cartg) nkspher=nkcart
|
|
nklen=nkcontr*nkspher
|
|
dtol=1.d0
|
|
if((iroute.eq.2.or.iroute.eq.28.or.iroute.eq.26).and.
|
|
$lintra.eq.0) dtol=dpre(iatoms,iang,jatoms,jang)
|
|
if(iroute.eq.3.or.iroute.eq.37.or.iroute.eq.4)
|
|
$dtol=xpre(katoms,kang)
|
|
if(dero.gt.0) then
|
|
C Gyula
|
|
if(l1der) then
|
|
dtol=1.d0
|
|
ss=0.d0
|
|
if(lda) ss=ss+diprei*dfipre(katoms,kang)
|
|
if(ldb) ss=ss+diprej*dfipre(katoms,kang)
|
|
if(ldc) ss=ss+ijpre*ddfipre(kang)
|
|
elseif(l3der) then
|
|
k1=dfnshrange(1,kang,katoms)
|
|
k2=dfnshrange(2,kang,katoms)
|
|
ypre=0.d0
|
|
do icd=0,ncont-1
|
|
ypre=max(ypre,maxval(dabs(x(k1+1:k2,icd))))
|
|
enddo
|
|
if(llexc) then
|
|
gpre=maxval(dabs(
|
|
$dcore(idx+nilen*njlen*k1:idx+nilen*njlen*k2-1)))
|
|
if(iroute.eq.2) then
|
|
dtol = max(gpre,dtol*ypre)
|
|
else
|
|
dtol = gpre
|
|
endif
|
|
else
|
|
dtol = dtol * ypre
|
|
endif
|
|
apr=diprei*dfipre(katoms,kang)
|
|
bpr=diprej*dfipre(katoms,kang)
|
|
rext=
|
|
$rbk-extab-extc(dfgexp(1,kang,katoms),nkprim,zc)
|
|
if(rext.gt.0.d0) then !SQVl estimator
|
|
sqvl=
|
|
$zc**(dble(2*kang+3)/4.d0)*blz(kang)/rbk**(kang+1)
|
|
apr=min(apr,qab_da*sqvl)
|
|
bpr=min(bpr,qab_db*sqvl)
|
|
endif
|
|
if(labc.or.lab) then
|
|
ss=apr+bpr
|
|
elseif(lac) then
|
|
ss=2.d0*apr+bpr
|
|
elseif(lbc) then
|
|
ss=apr+2.d0*bpr
|
|
endif
|
|
apr=apr*dtol
|
|
bpr=bpr*dtol
|
|
C
|
|
else
|
|
c=dfgexp(1,kang,katoms)
|
|
cc=max(ab,c)
|
|
do kprim=2,nkprim
|
|
c =min(c ,dfgexp(kprim,kang,katoms))
|
|
cc=max(cc,dfgexp(kprim,kang,katoms))
|
|
enddo
|
|
ss=dble(nkprim)*(2.d0*cc+max(iang,kang))*normg/
|
|
$(p*c*dsqrt(p+c))
|
|
endif
|
|
else
|
|
ss=ijpre*dfipre(katoms,kang)
|
|
rext=rbk-extab-extc(dfgexp(1,kang,katoms),nkprim,zc)
|
|
c if(rext.gt.1.d0) ss=min(ss/rext) !QQR estimator
|
|
if(rext.gt.0.d0) ss=min(ss, !SQVl estimator
|
|
$qab*zc**(dble(2*kang+3)/4.d0)*blz(kang)/rbk**(kang+1))
|
|
endif
|
|
lldexc=ss*etol.gt.ctol.and.nkmos.gt.0
|
|
if(loverlap) then
|
|
lscr=overla3_scr(niprim,njprim,nkprim,
|
|
&gexp(1,iang,iatoms),gexp(1,jang,jatoms),dfgexp(1,kang,katoms),
|
|
&coord(1,iatoms),coord(1,jatoms),coord(1,katoms),1.0d-6)
|
|
else
|
|
lscr=.true.
|
|
endif
|
|
if(l3der) then
|
|
countdERI(1,thrd+1) = countdERI(1,thrd+1) +
|
|
$ncd*ndim2*nklen*ndd ! Count all dERIs
|
|
endif
|
|
c Prescreening
|
|
if((dero.eq.0.and.( ! undifferentiated
|
|
& (ss*dtol.gt.ctol.and.iroute.ne.5.and.lscr) ! Only Coulomb
|
|
& .or.lldexc ! Exchange (not local)
|
|
& .or.iroute.eq.7 ! local: Exchange + CPHF
|
|
& .or.iroute.eq.37) ! local: Exchange + Coulomb + CPHF
|
|
& ).or.(dero.eq.1.and.( ! 1st derivative
|
|
& ldfock ! Fock derivative
|
|
& .or.(ss*dtol.gt.ctol))
|
|
& ).or.dero.gt.1 ! higher derivatives
|
|
& ) then
|
|
if(l3der) then
|
|
countdERI(2,thrd+1) = countdERI(2,thrd+1) +
|
|
$ncd*ndim2*nklen*ndd ! Count not screened dERIs
|
|
endif
|
|
if(fmm.ne.'off ') then
|
|
extc_fmm = extc_ahlrichs(dfgexp(1,kang,katoms),
|
|
& nkprim,1.0d-8)
|
|
rextab_fmm = extab_fmmii-extc_fmm
|
|
rextba_fmm = extab_fmmjj-extc_fmm
|
|
lfmm=(rextab_fmm.lt.extent
|
|
& .or.rextba_fmm.lt.extent).or.fmm.eq.'on '
|
|
lldexc=lldexc.and.(rextab_fmm.lt.extent
|
|
& .or.rextba_fmm.lt.extent)
|
|
lc1=fmm.eq.'on '.or.rextab_fmm.lt.extent
|
|
lc2=lc1
|
|
le1=rextba_fmm.lt.extent
|
|
le2=rextab_fmm.lt.extent.and..not.ieqj
|
|
else
|
|
lfmm=.true.
|
|
lc1=.true.
|
|
lc2=.true.
|
|
le1=.true.
|
|
le2=.not.ieqj
|
|
endif
|
|
c lldexc=lldexc.or.(llexc.and.dero.gt.0)
|
|
C Gyula
|
|
if(lsmall) then
|
|
scrmem=1
|
|
if(l3der) then
|
|
dijklen=ncd*ndim2*nklen*ndd
|
|
else
|
|
dijklen=ncd*ndim3
|
|
endif
|
|
iscr=thrd*ncd*ndim3+1
|
|
dfscr(iscr:iscr+dijklen-1)=0.d0
|
|
endif
|
|
|
|
ddatoms=datoms
|
|
l1c=.false. ! l1c: l3der, but only explicitly calculate 1 center
|
|
lsig=.false. ! lsig: there will be a significant contribution from one of the centers
|
|
dscrmem=scrmem
|
|
nj=0 ! nj!=0 indicates that translational invariance will be necessary
|
|
if(dero.eq.1) then
|
|
if(l1der) then
|
|
c Calculate primitive prescreening values for first derivatives
|
|
dpremat=0.d0
|
|
if(lda)
|
|
$ dpremat=dpremat+dipre2i*dfipre(katoms,kang)
|
|
if(ldb)
|
|
$ dpremat=dpremat+dipre2j*dfipre(katoms,kang)
|
|
if(ldc)
|
|
$ dpremat=dpremat+dipre2nd*ddfipre(kang)
|
|
elseif(l3der) then
|
|
c Decide if all three centers are significant
|
|
c and set variables if only one center is computed explicitly (l1c,lsig,ddatoms,dscrmem,dpremat)
|
|
call l3dercenters(labc,lab,lac,lbc,lcsig,lacsig,
|
|
$lbcsig,l1c,lsig,nj,dscrmem,scrmem,ncd,ndim2,nklen,dipre2i,
|
|
$dipre2j,dfipre(katoms,kang),natoms,nangmax,dpremat,nprimmax,
|
|
$ddatoms,apr,bpr,ctol,dtol,iatoms,jatoms,katoms)
|
|
endif ! l1der,l3der
|
|
endif ! dero.eq.1
|
|
if(lfmm) then
|
|
call df3int_st(iimem,iatoms,iang,jatoms,jang,katoms,kang,
|
|
$natoms,nangmax,itol,dero,
|
|
$lsep,nicontr,njcontr,niprim,njprim,
|
|
$imem1,maxcor,dcore,it7,iout,nprimmax,ncontrmax,
|
|
$dfgexp(1,kang,katoms),boysval,ax,
|
|
$ay,az,bx,by,bz,cx,cy,cz,sb2,cf,nmboys,nnaa,iian,jjan,logjc,indarr,
|
|
$ifrst,jfrst,dfscr(iscr),ndim2,ndim3,nilen,nsphermax,
|
|
$gexp(1,iang,iatoms),gexp(1,jang,jatoms),gcn(1,1,iang,iatoms),
|
|
$gcn(1,1,jang,jatoms),dfgcn(1,1,kang,katoms),
|
|
$gcoef(1,1,iang,iatoms),gcoef(1,1,jang,jatoms),
|
|
$dfgcoef(1,1,kang,katoms),nispher,njspher,ijs,n1crt,nmax1,intalg,
|
|
$spctostr,i1,i2,nnaac,lhrr,nicart,njcart,nmcrt,iacrt,scoord,
|
|
$ddatoms,ncartmax,hrec,rqqij,dfrqq,ctostr,ncd,abcdl,scrmem,
|
|
$jgi,nkcart,nkspher,nkcontr,nkprim,logkc(kang,katoms),c,cc,
|
|
$ip,jp,kp(1,kang,katoms),
|
|
$gci,gcj,gck(1,1,kang,katoms),omega,boys,cartg,dpremat,
|
|
$l1der,l3der,ldprim,labc,lab,lac,lbc,dipre2i,
|
|
$dipre2nd,dfipre(katoms,kang),d3dfipre(kang,katoms),l1c,lsig,
|
|
$dscrmem,nj,lrange)
|
|
kfrst1=0
|
|
if(loverlap) then
|
|
kfrst1=int_scr(dfscr(iscr),nilen,njlen,nklen,itol)
|
|
endif
|
|
if(lsmall.and.kfrst1.ne.nklen) then
|
|
if(oroute.eq.5.and.dero.eq.0) then
|
|
do icd=1,3
|
|
call dfinttrand(
|
|
$dfscr(iscr+nilen*njlen*kfrst1),dfscr(iscr+nilen*njlen*kfrst1),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),ddens,dfnbasis,nilen,njlen,
|
|
$nklen-kfrst1,ifrst,jfrst,kfrst+kfrst1,
|
|
$hai(icd*dfnbasis*nbll*nbasis+kfrst+kfrst1+1),
|
|
$mo(1,imo1),nbasis,nbll,x(kfrst+kfrst1+1,icd),iroute,ieqj,lldexc,
|
|
$dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),focka(1,1,icd),
|
|
$fockb(1,1,icd),scftype,ikmos,nikmos,jkmos,njkmos,
|
|
$lnolocx,hai,nkmos,kmos,moadd,dfnmobasis,nkl,mo,rmi(1,1,icd+1),
|
|
$tcis,nocc,hai(icd*dfnbasis*nbasis*nbll+1),imo1,dfatind(1,katoms),
|
|
$locfit,atind(1,iiatoms),atind(1,jjatoms),nshi,nshj,lc1,lc2,le1,
|
|
$le2,dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),
|
|
$ldfdens(ifock_scr_i),ldfdens(ifock_scr_j))
|
|
enddo
|
|
else
|
|
if(oroute.eq.5) then
|
|
do icd=0,ncd-1
|
|
call dfinttrand(
|
|
$dfscr(iscr+nilen*njlen*kfrst1+icd*ndim3),
|
|
$dfscr(iscr+nilen*njlen*kfrst1+icd*ndim3),
|
|
$dfscr(iscr+nilen*njlen*kfrst1+icd*ndim3),ddens,dfnbasis,nilen,
|
|
$njlen,nklen-kfrst1,ifrst,jfrst,kfrst+kfrst1,
|
|
$hai(icd*dfnbasis*nbll*nbasis+kfrst+kfrst1+1),
|
|
$mo(1,imo1),nbasis,nbll,x(kfrst+kfrst1+1,0),3,ieqj,lldexc,
|
|
$dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),focka(1,1,icd+1),
|
|
$fockb(1,1,icd+1),scftype,ikmos,nikmos,jkmos,njkmos,
|
|
$lnolocx,hai,nkmos,kmos,moadd,dfnmobasis,nkl,mo,rmi(1,1,icd+1),
|
|
$tcis,nocc,hai(icd*dfnbasis*nbasis*nbll+1),imo1,dfatind(1,katoms),
|
|
$locfit,atind(1,iiatoms),atind(1,jjatoms),nshi,nshj,lc1,lc2,le1,
|
|
$le2,dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),
|
|
$ldfdens(ifock_scr_i),ldfdens(ifock_scr_j))
|
|
enddo
|
|
endif
|
|
if(llcis) then
|
|
do icd=0,nstate-1
|
|
lldexc_old=lldexc
|
|
if(lcisgrad.and.icd.eq.1) lldexc=.false.
|
|
call dfinttrand(
|
|
$dfscr(iscr+nilen*njlen*kfrst1),dfscr(iscr+nilen*njlen*kfrst1),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),ddens(1,1,icd+1),dfnbasis,nilen,
|
|
$njlen,nklen-kfrst1,ifrst,
|
|
$jfrst,kfrst+kfrst1,hai(icd*dfnbasis*nbll*nbasis+kfrst+kfrst1+1),
|
|
$mo(1,icd*nbasis+imo1),nbasis,nbll,x(kfrst+kfrst1+1,icd),iroute,
|
|
$ieqj,lldexc,dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),focka(1,1,icd+1),
|
|
$fockb(1,1,icd+1),scftype,ikmos,nikmos,jkmos,njkmos,
|
|
$lnolocx,hai(icd*(moadd(imo2)+nbasis*dfnmobasis(imo2))+1),
|
|
$nkmos,kmos,moadd,dfnmobasis,nkl,mo(1,icd*nbasis+1),
|
|
$rmi(1,1,icd+1),tcis,nocc,hai(icd*dfnbasis*nbasis*nbll+1),imo1,
|
|
$dfatind(1,katoms),locfit,atind(1,iiatoms),atind(1,jjatoms),nshi,
|
|
$nshj,lc1,lc2,le1,le2,dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),
|
|
$ldfdens(ifock_scr_i),ldfdens(ifock_scr_j))
|
|
lldexc=lldexc_old
|
|
enddo
|
|
if(iroute.ne.3.and.tcis.eq.3.and.
|
|
$cisflag.lt.3) then
|
|
call dfinttrand(
|
|
$dfscr(iscr+nilen*njlen*kfrst1),dfscr(iscr+nilen*njlen*kfrst1),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),dcore(iimem),dfnbasis,nilen,njlen,
|
|
$nklen-kfrst1,ifrst,jfrst,kfrst+kfrst1,
|
|
$hai(nstate*dfnbasis*nbll*nbasis+kfrst+kfrst1+1),
|
|
$mo2(1,imo1),nbasis,nbll,dcore(iimem),5,ieqj,
|
|
$lldexc,dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),dcore(iimem),
|
|
$dcore(iimem),scftype,ikmos,nikmos,jkmos,njkmos,
|
|
$lnolocx,hai(nstate*(moadd(imo2)+nbasis*dfnmobasis(imo2))+1),
|
|
$nkmos,kmos,moadd,dfnmobasis,nkl,mo2,dcore(iimem),tcis,
|
|
$nocc,dcore(imem),imo1,dfatind(1,katoms),
|
|
$locfit,atind(1,iiatoms),atind(1,jjatoms),nshi,nshj,lc1,lc2,le1,
|
|
$le2,dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),
|
|
$ldfdens(ifock_scr_i),ldfdens(ifock_scr_j))
|
|
endif
|
|
else if(l3der) then
|
|
do icd=0,ncont-1
|
|
call df3grad(dfscr(iscr),iatoms,jatoms,
|
|
$katoms,grads,nilen,njlen,nklen,ddens(1,1,ncont-icd),ddens2,
|
|
$x(kfrst+1,icd),x(kfrst+1,1),llexc,iroute,
|
|
$dcore(idx+nilen*njlen*kfrst),icd,ncont-1,ldfock)
|
|
enddo
|
|
elseif(ldfock.and.iroute.lt.5) then
|
|
icd=0
|
|
call dfinttrand(
|
|
$dfscr(iscr+nilen*njlen*kfrst1),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),ddens,dfnbasis,nilen,
|
|
$njlen,nklen-kfrst1,ifrst,jfrst,kfrst+kfrst1,
|
|
$hai(kfrst+kfrst1+1),
|
|
$mo(1,imo1),nbasis,nbll,x(kfrst+kfrst1+1,0),
|
|
$iroute,ieqj,lldexc,dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),focka(1,1,1),
|
|
$fockb(1,1,1),scftype,ikmos,nikmos,jkmos,njkmos,
|
|
$lnolocx,hai,nkmos,kmos,moadd,dfnmobasis,nkl,mo,rmi(1,1,1),
|
|
$tcis,nocc,hai,imo1,dfatind(1,katoms),
|
|
$locfit,atind(1,iiatoms),atind(1,jjatoms),nshi,nshj,lc1,lc2,le1,
|
|
$le2,dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),
|
|
$ldfdens(ifock_scr_i),ldfdens(ifock_scr_j))
|
|
call dfinttrand(
|
|
$dfscr(iscr+nilen*njlen*kfrst1),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),ddens2,dfnbasis,nilen,
|
|
$njlen,nklen-kfrst1,ifrst,jfrst,kfrst+kfrst1,
|
|
$hai(kfrst+kfrst1+1),
|
|
$mo(1,imo1),nbasis,nbll,x(kfrst+kfrst1+1,1),
|
|
$iroute,ieqj,.false.,dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),focka(1,1,1),
|
|
$fockb(1,1,1),scftype,ikmos,nikmos,jkmos,njkmos,
|
|
$lnolocx,hai,nkmos,kmos,moadd,dfnmobasis,nkl,mo,rmi(1,1,1),
|
|
$tcis,nocc,hai,imo1,dfatind(1,katoms),
|
|
$locfit,atind(1,iiatoms),atind(1,jjatoms),nshi,nshj,lc1,lc2,le1,
|
|
$le2,dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),
|
|
$ldfdens(ifock_scr_i),ldfdens(ifock_scr_j))
|
|
else
|
|
do icd=0,ncd-1
|
|
call dfinttrand(
|
|
$dfscr(iscr+nilen*njlen*kfrst1+icd*ndim3),
|
|
$dfscr(iscr+nilen*njlen*kfrst1+icd*ndim3),
|
|
$dfscr(iscr+nilen*njlen*kfrst1+icd*ndim3),ddens,dfnbasis,nilen,
|
|
$njlen,nklen-kfrst1,ifrst,jfrst,kfrst+kfrst1,
|
|
$hai(icd*dfnbasis*nbll*nbasis+kfrst+kfrst1+1),
|
|
$mo(1,imo1),nbasis,nbll,x(kfrst+kfrst1+1,min(1,dero)*(icd+1)),
|
|
$iroute,ieqj,lldexc,dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),focka(1,1,icd+1),
|
|
$fockb(1,1,icd+1),scftype,ikmos,nikmos,jkmos,njkmos,
|
|
$lnolocx,hai,nkmos,kmos,moadd,dfnmobasis,nkl,mo,rmi(1,1,icd+1),
|
|
$tcis,nocc,hai(icd*dfnbasis*nbasis*nbll+1),imo1,dfatind(1,katoms),
|
|
$locfit,atind(1,iiatoms),atind(1,jjatoms),nshi,nshj,lc1,lc2,le1,
|
|
$le2,dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dfscr(iscr+nilen*njlen*kfrst1),
|
|
$ldfdens(ifock_scr_i),ldfdens(ifock_scr_j))
|
|
enddo
|
|
endif
|
|
endif
|
|
endif
|
|
endif
|
|
endif !Presreening
|
|
kfrst=kfrst+nklen
|
|
nkl=nkl+nklen
|
|
if(dero.gt.0) then
|
|
scrmem=scrmem+nilen*njlen*nklen*ncd*nd
|
|
else
|
|
scrmem=scrmem+nilen*njlen*nklen
|
|
endif
|
|
enddo !kang
|
|
enddo !katoms
|
|
C$OMP END PARALLEL DO
|
|
if(iroute.eq.7.or.iroute.eq.37) then
|
|
c write(*,*) 'fock_scr'
|
|
c write(*,'(10ES14.5)')
|
|
c &dcore(ifock_scr:ifock_scr+nbfshmax*nocc*xyzomp*2-1)
|
|
call update_fock(nbfshmax,nilen,njlen,nocc,
|
|
& ldfdens,fockb,ifrst,jfrst,xyzomp,
|
|
& nbasis,chfx)
|
|
endif
|
|
if(lintra.eq.8) call timeadd(times(1,17),times)
|
|
imem=it7
|
|
C Save three-center two-electron integrals
|
|
if(.not.lsmall) then
|
|
if(iroute.eq.1) then
|
|
call dfintsave(dfscr,
|
|
$dfscr(max(2*dfnbasis,ndim3)+1),tcdfinv,dfnbasis,
|
|
$nilen,njlen,ifrst,jfrst,ipos,intpos,i4core,itol,teintfile,dofit,
|
|
$isqrt,tcintfile,dens,ipostc,intpostc,nafroute,wnaf,dfnbasis_new)
|
|
else if(lintra.eq.1) then
|
|
call lfirsthalf(nbasis,nocc,dfnbasis,bfdom,
|
|
$ibfdom,jbfdom,umapi,udfnbi,mo,moadd,jmi,intadd,
|
|
$mapi,nilen,njlen,ifrst,jfrst,dfscr,udfmapinv)
|
|
!NP
|
|
else if(lintra.eq.2.or.lintra.eq.3) then
|
|
call lfirsthalf_ab(nbasis,nocc,dfnbasis,bfdom,
|
|
$ibfdom,int5,umapi,unbi,udfnbi,mo,moadd,jmi,intadd,
|
|
$nilen,njlen,ifrst,jfrst,dfscr,udfmapinv,int1,int3,
|
|
$int4,real1,real3,real4,real5,real5,int2,
|
|
$real3,real3,real4,real4,lintra)
|
|
! explanation of varaible names
|
|
! u...=e... , jmi=jmbq, int1=edinbl, int2=vlni, int5=dfadd
|
|
! int3=frsted, int4=edfnboldi, real1=tr2naf, real5=dcore(iscr3)=cmb
|
|
! real3=dcore(iscr1),jnqm,jmqn,mnp real4=dcore(iscr2),jnqm2,jmqn2,jmnq
|
|
else if(lintra.eq.5.or.lintra.eq.6.or.lintra.eq.7) then
|
|
c store (mu^shell,nu^shell,P^all in ED) to (nu^shell,P^all,mu^all)
|
|
call storemnp(dfscr,real1,nilen,njlen,ifrst,jfrst,int1,dfnbasis,
|
|
$nbasis,int2,udfmapinv,int3,jmi)
|
|
! explanation of varaible names : int1=enbi, real1=mpn, int2=emapi
|
|
! udfmapinv=edfmapinv, int3=edfnbi/(dfnb_old if lintra.eq.7) jmi=scred
|
|
else if(lintra.eq.8) then
|
|
c {{{ add (mu^shell,nu^shell,all aux) contribution to (muI|P) version
|
|
call time0(times)
|
|
call lmuiptrfv0(nbasis,natoms,nocc,dfnbasis,int6,mo,moadd,jmi,
|
|
$nilen,njlen,ifrst,jfrst,dfscr,int9,iiatoms,jjatoms,udfmapinv,
|
|
$mapi,int5,int1,int3,real5,real5,real1,real3,int2)
|
|
call timeadd(times(1,18),times)
|
|
! explanation of variable names
|
|
! int6=no, jmi=mupi, int5=emodom, int9=at2lmo, udfmapinv=edfmapinv
|
|
! int1=enbi, int3=edfnbi, real1=mnp, real3=nmp, real5=mupiscr , int2=emapi
|
|
c }}}
|
|
!NP
|
|
else
|
|
if(istore.eq.1) then
|
|
nn=nilen*njlen*dfnbasis
|
|
if(maxval(dabs(dfscr(1:nn))).gt.itol) then
|
|
c write(6,*) 'inad',inad-nn,hailen,maxval(dabs(dfscr(1:nn)))
|
|
c write(6,*) 'hai',hai(1),loc(hai(1))
|
|
if(inad-nn.ge.1) then
|
|
inad=inad-nn
|
|
intadd(iiatoms,iiang,jjatoms,jjang)=inad
|
|
call dcopy(nn,dfscr,1,hai(inad),1)
|
|
else
|
|
intadd(iiatoms,iiang,jjatoms,jjang)=0
|
|
endif
|
|
endif
|
|
endif
|
|
do icd=ncd-1,0,-1
|
|
call dfinttran(dfscr(icd*ndim3+1),
|
|
$dfscr(ncd*ndim3+1),dfnbasis,nilen,njlen,ifrst,jfrst,
|
|
$hai(icd*dfnbasis*nbll*nbasis+1),mo(1,imo1),nbasis,nbll,
|
|
$densa(1,1,1),x(1,min(1,dero)*(icd+1)),iroute,focka(1,1,icd+1),
|
|
$fockb(1,1,icd+1),ieqj,dfscr(ncd*ndim3+1),dfscr(icd*ndim3+1),
|
|
$dfscr(icd*ndim3+nilen*max(njlen,nbll)*dfnbasis+1),llexc,scftype,
|
|
$lcis)
|
|
enddo
|
|
endif
|
|
endif !.not.lsmall
|
|
else !Prescreening
|
|
if(lintra.eq.5.or.lintra.eq.6.or.lintra.eq.7) then
|
|
call dfillzero(dfscr,nilen*njlen*dfnbasis)
|
|
call storemnp(dfscr,real1,nilen,njlen,ifrst,jfrst,int1,dfnbasis,
|
|
$nbasis,int2,udfmapinv,int3,jmi)
|
|
endif
|
|
if(l3der) then
|
|
alldERI = alldERI +
|
|
$ ndERIsd(natoms,iatoms,jatoms,dfnatrange,ndim2,lab)
|
|
endif
|
|
endif !Prescreening
|
|
enddo !jjang
|
|
enddo !jjatoms
|
|
!NP
|
|
c multipole jjatoms
|
|
if(fmm.ne.'off ') then
|
|
tsmat_tr(1:nbfshmax*nbll*2*nlm_max*xyzomp) = 0.0d0
|
|
xlm(1:2*(((lmint_max+1)*(lmint_max+2))/2)*xyzomp) = 0.0d0
|
|
shlmax = 0
|
|
shnlm_max = 0
|
|
shlmax_th(0:xyzomp-1) = 0
|
|
shnlm_max_th(0:xyzomp-1) = 0
|
|
ax=coord(1,iiatoms)
|
|
ay=coord(2,iiatoms)
|
|
az=coord(3,iiatoms)
|
|
mcxyz(1) = coord(1,iiatoms)
|
|
mcxyz(2) = coord(2,iiatoms)
|
|
mcxyz(3) = coord(3,iiatoms)
|
|
extab_fmm = extc_ahlrichs(gexp(1,iiang,iiatoms),
|
|
& nprim(iiang,iiatoms),1.0d-8)
|
|
#if defined (OMP)
|
|
omplen = (iang+nangmax+1)**3+
|
|
& 2*(iang+nangmax+1)**4*(2*lmint_max+1)*2+
|
|
& 2*(lmint_max+1)**2+ncartmax**2*nlm_max*2+
|
|
& nsphermax*ncartmax*2*nlm_max+
|
|
& nsphermax**2*nprimmax*2*nlm_max+
|
|
& nsphermax**2*ncontrmax*nprimmax*2*nlm_max
|
|
#endif
|
|
C$OMP PARALLEL DO Schedule(Dynamic)
|
|
C$OMP& DEFAULT(SHARED)
|
|
C$OMP& PRIVATE(iimem,abcdl,cx,cy,cz,etol,jjatoms,jjang,ijpre,jfrst)
|
|
C$OMP& PRIVATE(jlast,nshj,njlen,jgi,iatoms,jatoms,iang,jang,ijcpre)
|
|
C$OMP& PRIVATE(niimos,njjmos,jj,jjmos,iimos,ndim2,ndim3,ieqj)
|
|
C$OMP& PRIVATE(bx,by,bz,njcart,njspher,njcontr)
|
|
C$OMP& PRIVATE(njprim,lmint_min,lmint,nlm)
|
|
C$OMP& PRIVATE(xab2,yab2,zab2,iitn,isx,isy,isz,ints,intc)
|
|
C$OMP& PRIVATE(intj,inti,nn,lj2,jangmax)
|
|
C$OMP& PRIVATE(scrmem,thrd,icd,iscr,ddens)
|
|
C$OMP& PRIVATE(dtol,ss,i,j,l,m,rext,rbk,zc,cmax,nkl)
|
|
C$OMP& PRIVATE(c,cc,ikmos,nikmos,jkmos,njkmos,rext_fmm)
|
|
C$OMP& PRIVATE(step,rextab_fmm,rextba_fmm,xac2,yac2,zac2,extc_fmm)
|
|
do jjatoms = 1, natoms
|
|
jangmax=nang(jjatoms)
|
|
#if defined (OMP)
|
|
iimem=imem+OMP_GET_THREAD_NUM()*omplen
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
#else
|
|
iimem=imem
|
|
thrd=0
|
|
#endif
|
|
do jjang=0,jangmax
|
|
ijpre=ipre(iiatoms,iiang,jjatoms,jjang)
|
|
jfrst=nshrange(1,jjang,jjatoms)
|
|
jlast=nshrange(2,jjang,jjatoms)
|
|
nshj=jfrst-nshrange(1,0,jjatoms)
|
|
njlen=jlast-jfrst
|
|
jgi=jjang.gt.iiang
|
|
iatoms=iiatoms
|
|
jatoms=jjatoms
|
|
iang=iiang
|
|
jang=jjang
|
|
if(llexc) ijcpre=max(icpre,cpre(jjatoms,jjang))
|
|
ss = ijpre*tcmax
|
|
if(ss.gt.ctol.and.
|
|
& (.not.llexc.or.ijpre*ijcpre*tcmax.gt.ctol)) then
|
|
if(llexc.and.locfit.ge.2) then
|
|
njjmos=0
|
|
do jj=1,naoat(jjatoms,2)
|
|
j=aoat(jjatoms,jj)
|
|
if(j.ge.imo1.and.j.le.imo2) then
|
|
do i=1,nimos
|
|
if(imos(i).eq.j) then
|
|
if(ijpre*tcmax*
|
|
$sum(dabs(mo(jfrst+1:jlast,j))).gt.cctol) then
|
|
njjmos=njjmos+1
|
|
jjmos(njjmos)=j
|
|
endif
|
|
exit
|
|
endif
|
|
enddo
|
|
endif
|
|
enddo
|
|
endif
|
|
ndim2=nilen*njlen
|
|
ndim3=ndim2*nbfshmax
|
|
ieqj=iiatoms.eq.jjatoms.and.iiang.eq.jjang
|
|
bx=coord(1,jatoms)
|
|
by=coord(2,jatoms)
|
|
bz=coord(3,jatoms)
|
|
njcart=(jang+1)*(jang+2)/2
|
|
njspher=2*jang+1
|
|
njcontr=ncontr(jang,jatoms)
|
|
njprim=nprim(jang,jatoms)
|
|
do icd=1,nstate
|
|
call shdens(ddens(1,1,icd),densa(1,1,icd),nilen,njlen,
|
|
$ ifrst,jfrst,nbasis,lcis,dpre_states)
|
|
enddo
|
|
! generate multipole moments
|
|
lmint_min = 0
|
|
lmint = iang+jang+fmmord
|
|
nlm = ((lmint+1)*(lmint+2))/2
|
|
if(lmint.gt.shlmax_th(thrd)) then
|
|
shlmax_th(thrd) = lmint
|
|
shnlm_max_th(thrd) = nlm
|
|
endif
|
|
xab2=(ax-bx)**2
|
|
yab2=(ay-by)**2
|
|
zab2=(az-bz)**2
|
|
iitn=nshrange(1,iang,iatoms)
|
|
if(jgi) then
|
|
! memory for t
|
|
isx =iimem
|
|
! memory for [n|R_lm|0] type integrals
|
|
isy =isx+(iang+jang+1)**3
|
|
! memory for R_lm values
|
|
isz =isy+2*(iang+jang+1)**4*(2*lmint+1)*2
|
|
ints=isz+2*(lmint+1)**2
|
|
intc=ints+nicart*njcart*2*nlm
|
|
intj=intc+njspher*nicart*2*nlm
|
|
inti=intj+nispher*njspher*njprim*2*nlm
|
|
dcore(isx:ints-1)=0.d0
|
|
nn=njspher*njcontr
|
|
call oneing_gn(2*nlm,ncontrmax,nprimmax,
|
|
$gexp(1,jang,jatoms),gexp(1,iang,iatoms),gcoef(1,1,jang,jatoms),
|
|
$gcoef(1,1,iang,iatoms),ctostr(1,jang),ctostr(1,iang),dcore(isx),
|
|
$dcore(isy),dcore(isz),dcore(ints),dcore(intc),dcore(intc),
|
|
$dcore(intj),dcore(inti),smat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
$nilen*njlen,nn,
|
|
$gcn(1,1,jang,jatoms),gcn(1,1,iang,iatoms),bx,by,bz,ax,ay,az,nn,
|
|
$0,njcontr,nicontr,njprim,niprim,njcart,nicart,njspher,nispher,
|
|
$xab2,yab2,zab2,jang,iang,cartg,mulint_gn,mcxyz,lmint,0,.false.)
|
|
else
|
|
! memory for t
|
|
isx =iimem
|
|
! memory for [n|R_lm|0] type integrals
|
|
isy =isx+(iang+jang+1)**3
|
|
! memory for R_lm values
|
|
isz =isy+2*(iang+jang+1)**4*(2*lmint+1)*2
|
|
ints=isz+2*(lmint+1)**2
|
|
intc=ints+nicart*njcart*2*nlm
|
|
intj=intc+nispher*njcart*2*nlm
|
|
inti=intj+nispher*njspher*niprim*2*nlm
|
|
dcore(isx:ints-1)=0.d0
|
|
nn=nispher*nicontr
|
|
call oneing_gn(2*nlm,ncontrmax,nprimmax,
|
|
$gexp(1,iang,iatoms),gexp(1,jang,jatoms),gcoef(1,1,iang,iatoms),
|
|
$gcoef(1,1,jang,jatoms),ctostr(1,iang),ctostr(1,jang),dcore(isx),
|
|
$dcore(isy),dcore(isz),dcore(ints),dcore(intc),dcore(intc),
|
|
$dcore(intj),dcore(inti),smat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
$nilen*njlen,nn,
|
|
$gcn(1,1,iang,iatoms),gcn(1,1,jang,jatoms),ax,ay,az,bx,by,bz,nn,
|
|
$0,nicontr,njcontr,niprim,njprim,nicart,njcart,nispher,njspher,
|
|
$xab2,yab2,zab2,iang,jang,cartg,mulint_gn,mcxyz,lmint,0,.false.)
|
|
endif
|
|
if(iroute.eq.2 .and. fmm.ne.'on ') then
|
|
if(iiatoms.eq.jjatoms) then
|
|
lj2 = jjang.le.iiang
|
|
else
|
|
lj2 = jjatoms.le.iiatoms
|
|
endif
|
|
if(lj2 .and. ss*dpre(iatoms,iang,jatoms,jang).gt.ctol)
|
|
& then
|
|
call mk_xlm(smat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
& smat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
& tsmat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
& tsmat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
& xlm(1+thrd*2*nlm_max),ddens,nilen,njlen,nlm,
|
|
& nlm_max,jgi)
|
|
endif
|
|
endif
|
|
if((iroute.eq.3.or.iroute.eq.4).and.fmm.ne.'on ')then
|
|
if(iiatoms.eq.jjatoms) then
|
|
lj2 = jjang.le.iiang
|
|
else
|
|
lj2 = jjatoms.le.iiatoms
|
|
endif
|
|
if(lj2) then
|
|
if(jgi) then
|
|
call transp_smat2(
|
|
& smat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
& tsmat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
& nilen,njlen,2*nlm)
|
|
call dfinttrand_J2(mcxyz,nilen,njlen,ifrst,jfrst,
|
|
& tsmat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
& tsmat(1+thrd*nbfshmax**2*2*nlm_max+
|
|
& nilen*njlen*nlm),ocint,x,dcore(iimem),
|
|
& irreg_re(1+thrd*(lmint_max+nangmax+1)**2),
|
|
$ irreg_im(1+thrd*(lmint_max+nangmax+1)**2),
|
|
& tcc(1+thrd*(nlm_max*(2*nangmax+1))),
|
|
& tcs(1+thrd*(nlm_max*(2*nangmax+1))),lmint_min,
|
|
& lmint,nlm,.false.,nilen*njlen,nprimmax,nangmax,
|
|
& natoms,cartg,ncd,ndim3,extab_fmm,scftype,dfnang,
|
|
& dfnprim,dfncontr,dfgexp,focka,fockb,nbasis,
|
|
& dfnbasis,dfnshrange,dfnatrange,coord,ax,ay,az,
|
|
& ss,ctol,xpre,extent,iiatoms,iiang,jjatoms,jjang)
|
|
else
|
|
call dfinttrand_J2(mcxyz,nilen,njlen,ifrst,jfrst,
|
|
& smat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
& smat(1+thrd*nbfshmax**2*2*nlm_max+
|
|
& nilen*njlen*nlm),ocint,x,dcore(iimem),
|
|
& irreg_re(1+thrd*(lmint_max+nangmax+1)**2),
|
|
$ irreg_im(1+thrd*(lmint_max+nangmax+1)**2),
|
|
& tcc(1+thrd*(nlm_max*(2*nangmax+1))),
|
|
& tcs(1+thrd*(nlm_max*(2*nangmax+1))),lmint_min,
|
|
& lmint,nlm,.false.,nilen*njlen,nprimmax,nangmax,
|
|
& natoms,cartg,ncd,ndim3,extab_fmm,scftype,dfnang,
|
|
& dfnprim,dfncontr,dfgexp,focka,fockb,nbasis,
|
|
& dfnbasis,dfnshrange,dfnatrange,coord,ax,ay,az,
|
|
& ss,ctol,xpre,extent,iiatoms,iiang,jjatoms,jjang)
|
|
endif
|
|
endif
|
|
endif
|
|
if(lexc.and.(iroute.eq.2.or.iroute.eq.4.or.
|
|
& iroute.eq.5)) then
|
|
call exc_smat(smat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
& smat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
& tsmat(1+thrd*nbfshmax**2*2*nlm_max),
|
|
& tsmat_tr(1+thrd*nbfshmax*nbll*2*nlm_max),
|
|
& mo,ifrst,jfrst,nilen,njlen,nbll,nlm,nlm_max,nbasis,
|
|
& imo1,jgi,lnolocx,locfit,jjmos,njjmos)
|
|
endif
|
|
endif !Prescreening?
|
|
enddo !jjang
|
|
enddo !jjatoms
|
|
C$OMP END PARALLEL DO
|
|
shlmax = maxval(shlmax_th(0:xyzomp-1))
|
|
shnlm_max = maxval(shnlm_max_th(0:xyzomp-1))
|
|
if(iroute.eq.2.and.fmm.ne.'on ') then
|
|
call reduce(xlm,nlm_max,shnlm_max,1,1,xyzomp)
|
|
endif
|
|
if(lexc.and.(iroute.eq.2.or.iroute.eq.4.or.
|
|
& iroute.eq.5)) then
|
|
call reduce(tsmat_tr,nlm_max,nlm_max,nbfshmax*nbll,
|
|
& nbll*nilen,xyzomp)
|
|
if(lnolocx) then
|
|
call transp_smat(tsmat_tr,smat_tr2,nbll*nilen,shnlm_max)
|
|
call transp_smat(tsmat_tr(1+nbll*nilen*nlm_max),
|
|
& smat_tr2(1+nbll*nilen*shnlm_max),nbll*nilen,
|
|
& shnlm_max) ! smat_tr2(nlm,nbll,nilen)
|
|
else
|
|
call transp_smat2(tsmat_tr,dcore(imem),nilen,nbll,
|
|
& shnlm_max)
|
|
call transp_smat(dcore(imem),smat_tr2,nilen*nbll,
|
|
& shnlm_max) !smat_tr2(nlm,nilen,nbll)
|
|
call transp_smat2(tsmat_tr(1+nbll*nilen*nlm_max),
|
|
& dcore(imem),nilen,nbll,shnlm_max)
|
|
call transp_smat(dcore(imem),
|
|
& smat_tr2(1+nbll*nilen*shnlm_max),nilen*nbll,
|
|
& shnlm_max) !smat_tr2(nlm,nilen,nbll)
|
|
endif
|
|
endif
|
|
|
|
#if defined (OMP)
|
|
omplen=max(ncd*ndim3,nbfshmax**2*nbll+nbfshmax**3)
|
|
#endif
|
|
lmint_min = 0
|
|
if(iroute.ne.3) then !.and.
|
|
c & smat_tr2(idamax(nbll*nilen*2*shnlm_max,
|
|
c & smat_tr2,1)).gt.0.0d0) then
|
|
c multipole
|
|
C$OMP PARALLEL DO Schedule(Dynamic)
|
|
C$OMP& DEFAULT(SHARED)
|
|
C$OMP& PRIVATE(kang,iimem,katoms,kangmax,nkmos,abcdl,cx,cy,cz,etol)
|
|
C$OMP& PRIVATE(scrmem,thrd,kfrst,nklen,icd,iscr,nkcart,nkspher,nkcontr)
|
|
C$OMP& PRIVATE(nkprim,dtol,ss,i,j,l,m,kmos,rext,rbk,zc,cmax,lldexc,nkl)
|
|
C$OMP& PRIVATE(c,cc,kprim,ikmos,nikmos,jkmos,njkmos,rext_fmm,extab_fmmi)
|
|
C$OMP& PRIVATE(step,extc_fmm,xac2,yac2,zac2)
|
|
do katoms=1,natoms
|
|
#if defined (OMP)
|
|
iimem=imem+OMP_GET_THREAD_NUM()*omplen
|
|
thrd=OMP_GET_THREAD_NUM()
|
|
#else
|
|
iimem=imem
|
|
thrd=0
|
|
#endif
|
|
scrmem=1
|
|
iscr=thrd*ncd*ndim3+1
|
|
kangmax=dfnang(katoms)
|
|
nkmos=0
|
|
if(llexc) then
|
|
if(lnolocx) then
|
|
nkmos=1
|
|
etol=ijcpre
|
|
else
|
|
if(locfit.ge.2) then
|
|
etol=ijcpre
|
|
nikmos=0
|
|
njkmos=0
|
|
do l=1,nmoat(katoms)
|
|
i=moat(katoms,l)
|
|
if(i.ge.imo1.and.i.le.imo2) then
|
|
do j=1,nimos
|
|
if(imos(j).eq.i) then
|
|
njkmos=njkmos+1
|
|
jkmos(njkmos)=i
|
|
exit
|
|
endif
|
|
enddo
|
|
endif
|
|
enddo
|
|
nkmos=nikmos+njkmos
|
|
else
|
|
etol=0.d0
|
|
dtol=ijpre*dfipra(katoms)
|
|
do l=1,nmoat(katoms)
|
|
i=moat(katoms,l)
|
|
if(i.ge.imo1.and.i.le.imo2) then
|
|
nkmos=nkmos+1
|
|
kmos(nkmos)=i
|
|
endif
|
|
enddo
|
|
endif
|
|
endif
|
|
endif
|
|
cx=coord(1,katoms)
|
|
cy=coord(2,katoms)
|
|
cz=coord(3,katoms)
|
|
xac2 = (cx - mcxyz(1))**2
|
|
yac2 = (cy - mcxyz(2))**2
|
|
zac2 = (cz - mcxyz(3))**2
|
|
extab_fmmi=dsqrt(xac2+yac2+zac2)-extab_fmm
|
|
call irreg_sh(shlmax, kangmax,
|
|
&irreg_re(1+thrd*(lmint_max+nangmax+1)**2),
|
|
&irreg_im(1+thrd*(lmint_max+nangmax+1)**2), cx-mcxyz(1),
|
|
&cy-mcxyz(2), cz-mcxyz(3), .false.)
|
|
kfrst=dfnatrange(1,katoms)
|
|
nkl=0
|
|
do kang=0,kangmax
|
|
nkcart=(kang+1)*(kang+2)/2
|
|
nkspher=2*kang+1
|
|
nkcontr=dfncontr(kang,katoms)
|
|
nkprim=dfnprim(kang,katoms)
|
|
if(cartg) nkspher=nkcart
|
|
nklen=nkcontr*nkspher
|
|
lldexc=.true.
|
|
extc_fmm = extc_ahlrichs(dfgexp(1,kang,katoms),
|
|
& nkprim,1.0d-8)
|
|
rext_fmm = extab_fmmi-extc_fmm
|
|
if(rext_fmm.ge.extent) then
|
|
step = 1
|
|
call int_mat(tcc(1+thrd*(nlm_max*(2*nangmax+1))),
|
|
&tcs(1+thrd*(nlm_max*(2*nangmax+1))),0,shlmax,step,kang,
|
|
&kang,1,shnlm_max,2*kang+1,
|
|
&irreg_re(1+thrd*(lmint_max+nangmax+1)**2),
|
|
&irreg_im(1+thrd*(lmint_max+nangmax+1)**2))
|
|
c endif
|
|
scrmem=1
|
|
dfscr(iscr:(thrd+1)*ncd*ndim3)=0.d0
|
|
do icd=0,ncd-1
|
|
call dfinttrand_mult(dfscr(iscr+icd*ndim3),
|
|
$dfscr(iscr+icd*ndim3),dfscr(iscr+icd*ndim3),ddens,dfnbasis,nilen,
|
|
$njlen,nklen,ifrst,jfrst,kfrst,
|
|
$hai(icd*dfnbasis*nbll*nbasis+kfrst+1),
|
|
$mo(1,imo1),nbasis,nbll,x(kfrst+1,min(1,dero)*(icd+1)),iroute,ieqj,
|
|
$lldexc,dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem),dcore(iimem),dcore(iimem),dcore(iimem),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),
|
|
$dcore(iimem+max(nilen,njlen)*nbfshmax*nbll),focka(1,1,icd+1),
|
|
$fockb(1,1,icd+1),scftype,ikmos,nikmos,jkmos,njkmos,
|
|
$lnolocx,hai,nkmos,kmos,moadd,dfnmobasis,nkl,mo,rmi(1,1,icd+1),
|
|
$tcis,nocc,hai(icd*dfnbasis*nbasis*nbll+1),imo1,dfatind(1,katoms),
|
|
$locfit,atind(1,iiatoms),atind(1,jjatoms),nshi,nshj,
|
|
$coord(1,katoms),mcxyz,tcc(1+thrd*(nlm_max*(2*nangmax+1))),
|
|
$tcs(1+thrd*(nlm_max*(2*nangmax+1))),
|
|
$irreg_re(1+thrd*(lmint_max+nangmax+1)**2),
|
|
$irreg_im(1+thrd*(lmint_max+nangmax+1)**2),xlm,
|
|
$ocint(dfnshrange(1,kang,katoms)+1),kang,lmint_min,lmint,shlmax,
|
|
$nlm,nlm_max,shnlm_max,.false.,rext_fmm,smat,smat_tr2,fmm,
|
|
$iiatoms,iiang,katoms)
|
|
enddo
|
|
endif
|
|
c endif !Presreening
|
|
kfrst=kfrst+nklen
|
|
nkl=nkl+nklen
|
|
scrmem=scrmem+nilen*njlen*nklen
|
|
enddo !kang
|
|
enddo !katoms
|
|
C$OMP END PARALLEL DO
|
|
endif
|
|
endif
|
|
c multipole jjatoms vege
|
|
if(lintra.eq.5.or.lintra.eq.6) then
|
|
c integral direct construction of (munuP) -> (muPI) -> (aPI), I: orignal LMO at PD_i, a: PAO
|
|
c and (muPI) -> (P,I,j) j: canonical occ MO in ED
|
|
call ledinttrf(lintra,int4,natoms,nocc,int3,nbasis,
|
|
$int9,int5,moadd,mapi,int2,int6,int7,int1,nilen,ifrst,
|
|
$mo,real1,jmi,real3,real4,real5,real6,int8,ldfpair)
|
|
! explanation of varaible names
|
|
! int4=natrange , int3=edfnbi, int9=at2lmo, int5=emodom,
|
|
! int2=emapi, int6=no, int7=npao int1=enbi
|
|
! real1=mpn jmi=mpi real3=cpao real4=aotocmo real5=aip real6=pij
|
|
! int8=eatdom ldfpair=enatdom
|
|
elseif(lintra.eq.7) then
|
|
call ledintjab(int4,int3,int1,nilen,ifrst,int2,
|
|
$mo,real1,real1,jmi,real5,int7,nbasis,real3,int8)
|
|
! explanation of varaible names
|
|
! int4=edfnbi, int3=dfnb_old , int1=enbi ,int2=emapi, mo=ao2vlno
|
|
! real1=mpn=qam jmi=amp, real5=jab, int7=nv, real3=tr2naf, int8=lnaf
|
|
endif
|
|
!NP
|
|
C Progress monitor
|
|
jjj=dfnbasis*(ilast+1)*ilast/2
|
|
iii=idnint(100.d0*dble(jjj)/dble(nbd))
|
|
if(((jjj.eq.nbd.or.(ipold.eq.0.and.iii.gt.0).or.
|
|
$(iii-ipold.gt.10.and.iii.lt.100)).and.lintra.ne.5.and.
|
|
$lintra.ne.6.and.lintra.ne.7.and.lintra.ne.8.and.lprog)
|
|
$.and.ipold.ne.100) then !NP
|
|
write(iout,"(i4,'% done.')") iii
|
|
call flush(iout)
|
|
ipold=iii
|
|
endif
|
|
enddo !iiang
|
|
#if defined (MPI)
|
|
endif
|
|
if(xyzcount.eq.mpisize) then
|
|
xyzcount=0
|
|
else
|
|
xyzcount=xyzcount+1
|
|
endif
|
|
#endif
|
|
enddo !iiatoms
|
|
c deallocate(fock_scr)
|
|
if(iroute.eq.7.or.iroute.eq.37) return
|
|
#if defined (MPI)
|
|
if(iroute.eq.2.and..not.lexc) then
|
|
call mpi_allreduce(x,dcore(imem),dfnbasis,
|
|
$MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,MPIERR)
|
|
x(1:dfnbasis,0)=dcore(imem:imem+dfnbasis-1)
|
|
endif
|
|
#endif
|
|
!NP
|
|
if(lintra.eq.7) then
|
|
c write jab of ED edi
|
|
jname='DFINT_AB'
|
|
write(ilmoname,'(i5)') int6
|
|
ilmoname=adjustl(ilmoname)
|
|
filename=trim(jname) // '.' // trim(ilmoname)
|
|
open(111,file=filename,form='unformatted')
|
|
call print_jab(real5,int7,int4,111)
|
|
!explanation of varaible names
|
|
!int4=edfnbi, real5=jab, int7=nv, int6=edi
|
|
close(111)
|
|
endif
|
|
!NP
|
|
C Construction of natural auxiliary functions
|
|
if(nafroute.eq.1) then
|
|
call timer
|
|
write(iout,*)
|
|
write(iout,*) 'Construction of natural auxiliary functions...'
|
|
call filllo(wnaf,dfnbasis)
|
|
call dtrmm('r','l','n','n',dfnbasis,dfnbasis,1.d0,tcdfinv,
|
|
$dfnbasis,wnaf,dfnbasis)
|
|
call dtrmm('l','l','t','n',dfnbasis,dfnbasis,1.d0,tcdfinv,
|
|
$dfnbasis,wnaf,dfnbasis)
|
|
call dsyev('V','U',dfnbasis,wnaf,dfnbasis,dcore(imem),
|
|
$dcore(imem+dfnbasis),3*dfnbasis,isyev)
|
|
if (dcore(imem).lt.-max(0.0001d0,naftol)) then
|
|
write(*,*) 'Warning: auxiliary basis might be linearly dependent'
|
|
write(*,*) 'All NAFs with imaginary singular values are dropped'
|
|
endif
|
|
c write(6,*) 'scf naf sing val',dfnbasis
|
|
c write(6,"(10000es16.8)") (dcore(imem+i),i=0,dfnbasis-1)
|
|
if(isyev.ne.0) then
|
|
write(iout,*) 'Fatal error at the construction of NAFs!'
|
|
call mrccend(1)
|
|
endif
|
|
i=0
|
|
do while((dabs(dcore(imem+i)).lt.naftol.or.
|
|
$ dcore(imem+i) .lt.0.d0).and.i.lt.dfnbasis)
|
|
i=i+1
|
|
enddo
|
|
dfnbasis_new=dfnbasis-i
|
|
call dtrmm('l','l','n','n',dfnbasis,dfnbasis_new,1.d0,tcdfinv,
|
|
$dfnbasis,wnaf(1,i+1),dfnbasis)
|
|
c call dsymm ('l','l',dfnbasis,dfnbasis_new,1.d0,tcdfinv,dfnbasis,
|
|
c $wnaf(1,i+1),dfnbasis,0.d0,dcore(imem),dfnbasis)
|
|
c call dgemm('t','n',dfnbasis_new,dfnbasis_new,dfnbasis,1.d0,
|
|
c $wnaf(1,i+1),dfnbasis,dcore(imem),dfnbasis,0.d0,tcdfinv,
|
|
c $dfnbasis_new)
|
|
c call invsqrt(tcdfinv,dfnbasis_new,dcore(imem),iout,j,1d-12,3)
|
|
c call dtrmm('r','l','n','n',dfnbasis,dfnbasis_new,1.d0,tcdfinv,
|
|
c $dfnbasis_new,wnaf(1,i+1),dfnbasis)
|
|
c if(j.ne.0) call mrccend(1)
|
|
write(iout,"(' Total number of auxiliary functions: ',i6)")
|
|
$dfnbasis
|
|
write(cscr16,'(f16.2)') 100.d0*dfnbasis_new/dfnbasis
|
|
write(iout,"(' Number of natural auxiliary functions:',i6,1x,
|
|
$a9)") dfnbasis_new,trim('(' // adjustl(cscr16)) // '%)'
|
|
call timer
|
|
write(iout,*)
|
|
write(iout,*) 'Recalculating integrals...'
|
|
nafroute=2
|
|
goto 2345
|
|
else if(nafroute.eq.2) then
|
|
dfnbasis=dfnbasis_new
|
|
endif
|
|
C Close TEINT
|
|
if(iroute.eq.1) then
|
|
call intclose(teintfile)
|
|
rewind(tedatfile)
|
|
write(tedatfile) ipos,intpos
|
|
if(dens.gt.0) then
|
|
call intclose(tcintfile)
|
|
write(tedatfile) ipostc,intpostc
|
|
endif
|
|
endif
|
|
call dbldealloc(intmem)
|
|
if(oroute.eq.7.or.(llexc.and.lcis.and.cisflag.eq.3)) return
|
|
C Calculate HF exchange in the case of local fitting
|
|
if(llexc.and..not.lnolocx.and..not.lcis.and.
|
|
& (oroute.eq.2.and.l3route.or.oroute.ne.2)) then
|
|
if(crsh.ne.1) then
|
|
write(iout,*) 'Local fitting is not available with RSHs!'
|
|
call mrccend(1)
|
|
endif
|
|
if(lprog) write(iout,*)
|
|
&'Fitting and assembly step of exchange...'
|
|
c if(tcis.eq.3)
|
|
c $ intmem=dblalloc(maxval(dfnmobasis(imo1:imo2))*nocc)
|
|
if(l3route) then
|
|
libij=ldf_bij_mem(dfnmobasis,nocc,imo1,imo2,ibij,ldfock)
|
|
endif
|
|
idfatdom=intalloc(natoms*nocc)
|
|
idfnatdom=intalloc(nocc)
|
|
if(ialpha.le.1) then
|
|
open(scrfile4,file='DFLTOC',form='unformatted')
|
|
else
|
|
open(scrfile4,file='DFLTOCb',form='unformatted')
|
|
endif
|
|
read(scrfile4)
|
|
read(scrfile4) (icore(idfatdom+i),i=0,natoms*nocc-1),
|
|
$ (icore(idfnatdom+i),i=0,nocc-1)
|
|
close(scrfile4)
|
|
#if defined(OMP)
|
|
if(loccri) nthread=omp_get_max_threads()
|
|
#else
|
|
nthread=1
|
|
#endif
|
|
if(locfit.ge.2.and.loccri) then
|
|
l=dblalloc(2*natoms)
|
|
else
|
|
l=1
|
|
endif
|
|
if(iroute.eq.6.or.iroute.eq.26) then
|
|
ihai1=dblalloc(nocc*maxval(dfnmobasis))
|
|
ihai2=dblalloc(nocc*maxval(dfnmobasis))
|
|
elseif(iroute.eq.8.or.iroute.eq.28) then
|
|
ihai1=dblalloc(nocc*maxval(dfnmobasis))
|
|
ihai2=ihai1
|
|
endif
|
|
iatoms=0
|
|
do i=imo1,imo2
|
|
c if(tcis.eq.3)
|
|
c $ call sechalf(ifrst,dfnmobasis(i),dfnmobasis(i),1,
|
|
c $nbasis,hai(nstate*(moadd(imo2)+nbasis*dfnmobasis(imo2))+
|
|
c $moadd(i)+1),dcore(intmem),mo2,.true.,0.d0,tcis,nocc)
|
|
if(nbasis.ne.nmobasis(i).and.loccri) then
|
|
k=dblalloc(nocc*nmobasis(i))
|
|
else
|
|
k=imem
|
|
endif
|
|
j=dblalloc((dfnmobasis(i)+1)*dfnmobasis(i)/2)
|
|
call subsysdf2(dcore(j),dfnmobasis(i),natoms,
|
|
$icore(idfnatdom+i-1),dcore,icore,imem,iimem,
|
|
$icore(idfatdom+natoms*(i-1)),2,2,! data for df2int from here
|
|
$nangmax,ncontrmax,nprimmax,ncartmax,nang,ncontr,nprim,gexp,gcoef,
|
|
$coord,ctostr,cartg,nsphermax,cf,boysval,nmboys,
|
|
$gcn,itol,iout,imem1,maxcor,thad,thcf2,scoord,
|
|
$rqqij,rqqij,spctostr,1,dero,omega,boys,.false.)
|
|
call dbldealloc(j)
|
|
if(l3route) then
|
|
call ldf_bij(dfnmobasis(i),nbasis,nocc,mo,mo2,
|
|
&hai(moadd(i)+1),dcore(ibij+iatoms),dcore(imem),libij/2,ldfock,
|
|
&iout)
|
|
iatoms=iatoms+dfnmobasis(i)*nocc
|
|
else
|
|
if(iroute.eq.6.or.iroute.eq.26.or.iroute.eq.8.or.
|
|
& iroute.eq.28) then
|
|
call ldfgrad_exc(nbasis,nocc,dfnmobasis(i),
|
|
&hai(moadd(i)+1),dcore(imem),chfx,mo,mo2,dcore(ihai1),dcore(ihai2),
|
|
&iroute,iout)
|
|
elseif(loccri) then
|
|
call dfexc_occri(nbasis,nmobasis(i),dfnmobasis(i),
|
|
$hai(moadd(i)+1),kmat,dcore(imem),invfile,chfx,dcore(k),
|
|
$natdom(i),atdom(1,i),natrange,iout,hai_occri,nocc,
|
|
$mo,aoat,naoat,natoms,nmoat,moat,dcore(l),i,nthread)
|
|
else
|
|
call dfexc(nbasis,nmobasis(i),dfnmobasis(i),
|
|
$hai(moadd(i)+1),focka,dcore(imem),invfile,chfx,dcore(imem),
|
|
$natdom(i),atdom(1,i),natrange,iout)
|
|
endif
|
|
endif
|
|
if(nbasis.ne.nmobasis(i).and.loccri) call dbldealloc(k)
|
|
enddo
|
|
if(locfit.ge.2.and.loccri) call dbldealloc(l)
|
|
call dbldealloc(idfatdom)
|
|
if(iroute.eq.6.or.iroute.eq.8) return
|
|
c if(tcis.eq.3) call dbldealloc(intmem)
|
|
endif
|
|
C Second half-transformation to get (ij|P), no restriction on i and j
|
|
if(llexc.and.oroute.eq.2.and.l3route) then
|
|
if(lcisgrad2) then ! CIS gradient
|
|
if(.not.ltdhf) then
|
|
ibij=dblalloc(dfnbasis*nbll*nocc*6) ! DAVID
|
|
elseif(ltdhf) then
|
|
ibij=dblalloc(dfnbasis*nbll*nocc*9)
|
|
endif
|
|
C CC
|
|
call dgemm('n','n',dfnbasis*nbll,nocc,nbasis,1.d0,hai,
|
|
$dfnbasis*nbll,mo,nbasis,0.d0,dcore(ibij),dfnbasis*nbll)
|
|
C Cc
|
|
call dgemm('n','n',dfnbasis*nbll,nocc,nbasis,1.d0,hai,
|
|
$dfnbasis*nbll,mo(1,nbasis+1),nbasis,0.d0,
|
|
$dcore(ibij+dfnbasis*nbll*nocc),dfnbasis*nbll)
|
|
C CX
|
|
call dgemm('n','n',dfnbasis*nbll,nocc,nbasis,1.d0,hai,
|
|
$dfnbasis*nbll,mo(1,2*nbasis+1),nbasis,0.d0,
|
|
$dcore(ibij+2*dfnbasis*nbll*nocc),dfnbasis*nbll)
|
|
C cc
|
|
call dgemm('n','n',dfnbasis*nbll,nocc,nbasis,1.d0,
|
|
$hai(dfnbasis*nbasis*nbll+1),dfnbasis*nbll,mo(1,nbasis+1),nbasis,
|
|
$0.d0,dcore(ibij+3*dfnbasis*nbll*nocc),dfnbasis*nbll)
|
|
C cC
|
|
call dgemm('n','n',dfnbasis*nbll,nocc,nbasis,1.d0,
|
|
$hai(dfnbasis*nbasis*nbll+1),dfnbasis*nbll,mo,nbasis,
|
|
$0.d0,dcore(ibij+4*dfnbasis*nbll*nocc),dfnbasis*nbll)
|
|
C XC
|
|
call dgemm('n','n',dfnbasis*nbll,nocc,nbasis,1.d0,
|
|
$hai(2*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,mo,nbasis,
|
|
$0.d0,dcore(ibij+5*dfnbasis*nbll*nocc),dfnbasis*nbll)
|
|
if(ltdhf) then
|
|
C Cc
|
|
call dgemm('n','n',dfnbasis*nbll,nocc,nbasis,1.d0,hai,
|
|
$dfnbasis*nbll,mo(1,3*nbasis+1),nbasis,0.d0,
|
|
$dcore(ibij+6*dfnbasis*nbll*nocc),dfnbasis*nbll)
|
|
C cC
|
|
call dgemm('n','n',dfnbasis*nbll,nocc,nbasis,1.d0,
|
|
$hai(3*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,mo,nbasis,
|
|
$0.d0,dcore(ibij+7*dfnbasis*nbll*nocc),dfnbasis*nbll)
|
|
C cc
|
|
call dgemm('n','n',dfnbasis*nbll,nocc,nbasis,1.d0,
|
|
$hai(3*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,mo(1,3*nbasis+1),
|
|
$nbasis,0.d0,dcore(ibij+8*dfnbasis*nbll*nocc),dfnbasis*nbll)
|
|
endif
|
|
elseif(lnolocx) then ! SCF gradient
|
|
ibij=dblalloc(dfnbasis*nbll*nocc2)
|
|
if(ldfock) then
|
|
call dgemm('n','n',dfnbasis*nbll,nocc2,nbasis,1.d0,hai,
|
|
$dfnbasis*nbll,mo2,nbasis,0.d0,dcore(ibij),dfnbasis*nbll)
|
|
else
|
|
call dgemm('n','n',dfnbasis*nbll,nocc,nbasis,1.d0,hai,
|
|
$dfnbasis*nbll,mo,nbasis,0.d0,dcore(ibij),dfnbasis*nbll)
|
|
endif
|
|
endif
|
|
else if(l3der.and.oroute.ne.4) then
|
|
c print screening ration
|
|
alldERI = alldERI + sum(countdERI(1,:))
|
|
screendERI = screendERI + sum(countdERI(2,:))
|
|
call print_scrrat_deri(iout,alldERI,screendERI)
|
|
deallocate(countdERI)
|
|
return
|
|
else
|
|
ibij=imem
|
|
endif
|
|
C Calculate two-center integrals and fit vector x
|
|
if((omega.eq.0.d0.and.lintra.eq.0.and.
|
|
$(((iroute.eq.2.or.iroute.eq.28.or.iroute.eq.26).and.oroute.ne.3)
|
|
$.or.llexc)).and.cisflag.ne.5.and.oroute.ne.4) then
|
|
if(.not.lnolocx.and.tcis.ne.3.and..not.l3route.and.
|
|
$iroute.ne.28.and.iroute.ne.26) call dbldealloc(ihai) !l3szemet
|
|
if(loccri.and.llexc.and.lnolocx) then
|
|
call dgemm('n','n',dfnbasis*nbll,nocc,nbasis,
|
|
&dsqrt(0.5d0),hai,dfnbasis*nbll,mo,nbasis,0.0d0,hai_occri,
|
|
&dfnbasis*nbll)
|
|
endif
|
|
intmem=dblalloc((dfnbasis+1)*dfnbasis/2)
|
|
call df2int(natoms,nangmax,ncontrmax,nprimmax,nang,ncontr,nprim,
|
|
$gexp,coord,ncartmax,ctostr,cartg,nsphermax,cf,boysval,nmboys,
|
|
$dcore,imem,0,0.00001d0*itol,dfnshrange,iout,imem1,maxcor,
|
|
$thad,thcf2,scoord,rqqij,rqqij,0,1,dfnang,dfncontr,dfnprim,dfgexp,
|
|
$dfgcn,dfrqq,dfnbasis,dfgcoef,dfindarr,dcore(intmem),dfipre,i,i,
|
|
$.false.,i,dcore(intmem),spctostr,0,i,tcmax,.false.,
|
|
$dcore(intmem),omega,boys)
|
|
call dbldealloc(intmem) !Do not use dcore(imem) after this point
|
|
call dpptrf('L',dfnbasis,dcore(imem),isyev)
|
|
if(isyev.ne.0) then
|
|
write(iout,*) 'Fatal error at the Cholesky decomposition!'
|
|
call mrccend(1)
|
|
endif
|
|
if((iroute.eq.2.or.iroute.eq.28.or.iroute.eq.26).and.
|
|
& oroute.ne.3) then
|
|
j=0 !GNU compiler bug
|
|
if(oroute.eq.5) then
|
|
call dpptrs('L',dfnbasis,3,dcore(imem),x(1,1),dfnbasis,j)
|
|
call dscal(3*dfnbasis,4.d0,x(1,1),1)
|
|
else
|
|
call dpptrs('L',dfnbasis,nstate,dcore(imem),x,dfnbasis,j)
|
|
if(ldfock) then
|
|
call dpptrs('L',dfnbasis,nstate,dcore(imem),x(1,1),
|
|
& dfnbasis,j)
|
|
call dscal(dfnbasis,4.0d0,x(1,1),1)
|
|
endif
|
|
if(.not.lcis) call dscal(dfnbasis*nstate,4.d0,x,1)
|
|
endif
|
|
if(j.ne.0) then
|
|
write(iout,*)
|
|
$'Fatal error at the fitting of the Coulomb contribution!'
|
|
call mrccend(1)
|
|
endif
|
|
endif
|
|
endif
|
|
C Fitting (ij|P) to get B^P_ij, B^P_ij -> B^P_imu transformation
|
|
if(oroute.eq.4.and.l3der) then
|
|
continue
|
|
elseif(llexc.and.oroute.eq.2.and.l3route.and.lnolocx) then
|
|
call timer
|
|
write(iout,*)
|
|
write(iout,*) 'Fitting and transformation of exchange...'
|
|
if(lcisgrad2) then
|
|
if(.not.ltdhf) then
|
|
call dpptrs('L',dfnbasis,nbll*nocc*6,dcore(imem),dcore(ibij),
|
|
$dfnbasis,j)
|
|
else
|
|
call dpptrs('L',dfnbasis,nbll*nocc*9,dcore(imem),dcore(ibij),
|
|
$dfnbasis,j)
|
|
endif
|
|
C
|
|
call gammacont(dfnbasis,nbll,nbasis,nocc,dcore,ibij,
|
|
$mo,hai,ltdhf,hailen)
|
|
C
|
|
else
|
|
if(ldfock) then
|
|
call dpptrs('L',dfnbasis,nbll*nocc2,dcore(imem),dcore(ibij),
|
|
$dfnbasis,j)
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc2,1.d0,
|
|
$dcore(ibij),dfnbasis*nbll,mo2,nbasis,0.d0,hai,dfnbasis*nbll)
|
|
else
|
|
call dpptrs('L',dfnbasis,nbll*nocc,dcore(imem),dcore(ibij),
|
|
$dfnbasis,j)
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,1.d0,
|
|
$dcore(ibij),dfnbasis*nbll,mo,nbasis,0.d0,hai,dfnbasis*nbll)
|
|
endif
|
|
endif
|
|
c if(l3route) llexc=.false.
|
|
else if(llexc.and.(lnolocx.or.lcis)) then
|
|
C Calculate exchange
|
|
if(lprog) then
|
|
call timer
|
|
write(iout,*)
|
|
endif
|
|
if((lcis.and.omega.eq.0.d0).or.cisflag.eq.4) then
|
|
if(cisflag.eq.5) then
|
|
if(locfit.eq.2) then
|
|
do i=1,nbll
|
|
call dgemm('n','n',dfnbasis,nvirt,nbasis,1.d0,
|
|
$hai((i-1)*dfnbasis*nbasis+1),dfnbasis,mo2(1,nocc+1),nbasis,
|
|
$0.d0,dcore(imem+(i-1)*dfnbasis*nvirt),dfnbasis)
|
|
enddo
|
|
call dgemm('n','n',dfnbasis*nvirt,nocc,nbll,1.d0,
|
|
$dcore(imem),dfnbasis*nvirt,mo3(1,imo1),nocc,1.d0,scrd,
|
|
$dfnbasis*nvirt)
|
|
C
|
|
elseif(locfit.eq.0) then
|
|
C DAVID blokkosan nem mukodik!
|
|
call dgemm('n','n',dfnbasis*nocc,nvirt,nbasis,1.d0,hai,
|
|
$dfnbasis*nocc,mo2(1,nocc+1),nbasis,1.d0,scrd,dfnbasis*nocc)
|
|
endif
|
|
C
|
|
return
|
|
endif
|
|
if(tcis.eq.1) then
|
|
write(iout,*) 'Assembly step of exchange...'
|
|
C nob=the number of blocks
|
|
nob=nocc/nbl
|
|
if(mod(nocc,nbl).ne.0) nob=nob+1
|
|
C nop=the number of tiles in all blocks
|
|
nop=nob*(nob+1)/2
|
|
call getdir(nbl,nbll,imo1,imo2,nop,nob,nstate,nbasis,hai,rmi,
|
|
$invfile,tcis,mo)
|
|
elseif(tcis.eq.2) then
|
|
return
|
|
elseif(tcis.eq.3) then
|
|
write(iout,*) 'Assembly step of exchange...'
|
|
C
|
|
if(lnolocx) then
|
|
if(lcisgrad) then
|
|
call gradcont(ifrst,dfnbasis,nbll,nbasis,hai,dcore,mo,
|
|
$tcis,nocc,chfx,rmi,hailen,imem,mo2,nvirt,rma,ltdhf)
|
|
else
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(nstate*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo2,.true.,0.d0,tcis,nocc)
|
|
C
|
|
j=0
|
|
call dpptrs('L',dfnbasis,nocc*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
if(j.ne.0) then
|
|
write(iout,*)
|
|
$'Fatal error at the fitting of the Coulomb contribution!'
|
|
call mrccend(1)
|
|
endif
|
|
C
|
|
do i=1,nstate
|
|
C collect
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,-chfx,
|
|
$hai((i-1)*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rmi(1,1,i),nbasis)
|
|
enddo
|
|
endif
|
|
C
|
|
if(crsh.ne.1.and.omega.eq.0.d0) then
|
|
do i=1,nstate+1 ! nstate*CIS coeff + MO coeff
|
|
call dcopy(nbasis*dfnbasis*nbll,hai((i-1)*dfnbasis*
|
|
$nbasis*nbll+1),1,haiold((i-1)*dfnbasis*nbasis*nbll+1),1)
|
|
j=0
|
|
call dpptrs('L',dfnbasis,nbasis*nbll,dcore(imem),
|
|
$haiold((i-1)*dfnbasis*nbasis*nbll+1),dfnbasis,j)
|
|
if(j.ne.0) then
|
|
write(iout,*)
|
|
$'Fatal error at the fitting of the Coulomb contribution!'
|
|
call mrccend(1)
|
|
endif
|
|
enddo
|
|
endif
|
|
C
|
|
else ! local fitting
|
|
intmem=dblalloc(maxval(dfnmobasis(imo1:imo2))*nocc)
|
|
idfatdom=intalloc(natoms*nocc)
|
|
idfnatdom=intalloc(nocc)
|
|
open(scrfile4,file='DFLTOC',form='unformatted')
|
|
read(scrfile4)
|
|
read(scrfile4) (icore(idfatdom+i),i=0,natoms*nocc-1),
|
|
$ (icore(idfnatdom+i),i=0,nocc-1)
|
|
close(scrfile4)
|
|
C
|
|
do ii=imo1,imo2
|
|
call sechalf(ifrst,dfnmobasis(ii),dfnmobasis(ii),1,
|
|
$nbasis,hai(nstate*(moadd(imo2)+nbasis*dfnmobasis(imo2))+
|
|
$moadd(ii)+1),dcore(intmem),mo2,.true.,0.d0,tcis,nocc)
|
|
C
|
|
c read(invfile)
|
|
c $(dcore(imem+i-1),i=1,(dfnmobasis(ii)+1)*dfnmobasis(ii)/2)
|
|
j=dblalloc((dfnmobasis(ii)+1)*dfnmobasis(ii)/2)
|
|
call subsysdf2(dcore(j),dfnmobasis(ii),natoms,
|
|
$icore(idfnatdom+ii-1),dcore,icore,imem,iimem,
|
|
$icore(idfatdom+natoms*(ii-1)),3,2,! data for df2int from here
|
|
$nangmax,ncontrmax,nprimmax,ncartmax,nang,ncontr,nprim,gexp,gcoef,
|
|
$coord,ctostr,cartg,nsphermax,cf,boysval,nmboys,
|
|
$gcn,itol,iout,imem1,maxcor,thad,thcf2,scoord,
|
|
$rqqij,rqqij,spctostr,1,dero,omega,boys,.false.)
|
|
call dbldealloc(j)
|
|
i=0
|
|
call dpptrf('L',dfnmobasis(ii),dcore(imem),i)
|
|
c call rspmx2(dcore(imem),dfnmobasis(ii),invfile)
|
|
c write(6,"(f15.10)")
|
|
c $dcore(imem:imem+(dfnmobasis(ii)+1)*dfnmobasis(ii)/2-1)
|
|
c write(6,"(f15.10)")
|
|
C
|
|
call dpptrs('L',dfnmobasis(ii),nocc,dcore(imem),
|
|
$dcore(intmem),dfnmobasis(ii),i)
|
|
if(i.ne.0) then
|
|
write(iout,*)
|
|
$'Fatal error at the fitting of the Coulomb contribution!'
|
|
call mrccend(1)
|
|
endif
|
|
C
|
|
C collect
|
|
do i=1,nstate
|
|
call dgemm('t','n',nbasis,nocc,dfnmobasis(ii),-chfx,
|
|
$hai((i-1)*(moadd(imo2)+nbasis*dfnmobasis(imo2))+moadd(ii)+1),
|
|
$dfnmobasis(ii),dcore(intmem),dfnmobasis(ii),1.d0,rmi(1,1,i),
|
|
$nbasis)
|
|
enddo
|
|
enddo ! loop for occs
|
|
c write(6,"(f15.10)") rmi
|
|
C
|
|
endif ! local fitting
|
|
C
|
|
if(ltdhf.and..not.lcisgrad) then
|
|
C
|
|
cisc=1.d0
|
|
if(cisflag.eq.1) cisc=-1.d0
|
|
C
|
|
if(lnolocx) then
|
|
do i=1,nstate
|
|
C
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai((i-1)*dfnbasis*nbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo2,.true.,0.d0,tcis,nocc)
|
|
C
|
|
C
|
|
j=0
|
|
call dpptrs('L',dfnbasis,nocc*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
if(j.ne.0) then
|
|
write(iout,*)
|
|
$'Fatal error at the fitting of the Coulomb contribution!'
|
|
call mrccend(1)
|
|
endif
|
|
C
|
|
C collect
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,-chfx*cisc,
|
|
$hai(nstate*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,rmi(1,1,i),
|
|
$nbasis)
|
|
enddo
|
|
else
|
|
C
|
|
idfatdom=intalloc(natoms*nocc)
|
|
idfnatdom=intalloc(nocc)
|
|
open(scrfile4,file='DFLTOC',form='unformatted')
|
|
read(scrfile4)
|
|
read(scrfile4) (icore(idfatdom+i),i=0,natoms*nocc-1),
|
|
$ (icore(idfnatdom+i),i=0,nocc-1)
|
|
close(scrfile4)
|
|
C
|
|
do i=1,nstate
|
|
c rewind(invfile)
|
|
c do ii=1,imo1-1
|
|
c read(invfile)
|
|
c enddo
|
|
C
|
|
do ii=imo1,imo2
|
|
call sechalf(ifrst,dfnmobasis(ii),dfnmobasis(ii),1,nbasis,
|
|
$hai((i-1)*(moadd(imo2)+nbasis*dfnmobasis(imo2))+moadd(ii)+1),
|
|
$dcore(intmem),mo2,.true.,0.d0,tcis,nocc)
|
|
C
|
|
c call rspmx2(dcore(imem),dfnmobasis(ii),invfile)
|
|
c read(invfile)
|
|
c $(dcore(imem+i-1),i=1,(dfnmobasis(ii)+1)*dfnmobasis(ii)/2)
|
|
C
|
|
c j=0
|
|
c call dpptrs('L',dfnmobasis(ii),nocc,dcore(imem),
|
|
c $dcore(intmem),dfnmobasis(ii),j)
|
|
c if(j.ne.0) then
|
|
c write(iout,*)
|
|
c $'Fatal error at the fitting of the Coulomb contribution!'
|
|
c call mrccend(1)
|
|
c endif
|
|
j=dblalloc((dfnmobasis(ii)+1)*dfnmobasis(ii)/2)
|
|
call subsysdf2(dcore(j),dfnmobasis(ii),natoms,
|
|
$icore(idfnatdom+ii-1),dcore,icore,imem,iimem,
|
|
$icore(idfatdom+natoms*(ii-1)),3,2,! data for df2int from here
|
|
$nangmax,ncontrmax,nprimmax,ncartmax,nang,ncontr,nprim,gexp,gcoef,
|
|
$coord,ctostr,cartg,nsphermax,cf,boysval,nmboys,
|
|
$gcn,itol,iout,imem1,maxcor,thad,thcf2,scoord,
|
|
$rqqij,rqqij,spctostr,1,dero,omega,boys,.false.)
|
|
call dbldealloc(j)
|
|
k=0
|
|
call dpptrf('L',dfnmobasis(ii),dcore(imem),k)
|
|
c call rspmx2(dcore(imem),dfnmobasis(ii),invfile)
|
|
c write(6,"(f15.10)")
|
|
c $dcore(imem:imem+(dfnmobasis(ii)+1)*dfnmobasis(ii)/2-1)
|
|
c write(6,"(f15.10)")
|
|
C
|
|
call dpptrs('L',dfnmobasis(ii),nocc,dcore(imem),
|
|
$dcore(intmem),dfnmobasis(ii),k)
|
|
if(k.ne.0) then
|
|
write(iout,*)
|
|
$'Fatal error at the fitting of the Coulomb contribution!'
|
|
call mrccend(1)
|
|
endif
|
|
C
|
|
C collect
|
|
call dgemm('t','n',nbasis,nocc,dfnmobasis(ii),-chfx*cisc,
|
|
$hai(nstate*(moadd(imo2)+nbasis*dfnmobasis(imo2))+moadd(ii)+1),
|
|
$dfnmobasis(ii),dcore(intmem),dfnmobasis(ii),1.d0,rmi(1,1,i),
|
|
$nbasis)
|
|
enddo !loop for occs
|
|
enddo !loop for states
|
|
endif !local fitting
|
|
endif !scf or not
|
|
C
|
|
endif ! tcis
|
|
else if(oroute.eq.2) then
|
|
C Intermediates for gradient
|
|
write(iout,*) 'Fitting step of exchange...'
|
|
c hai(dfnbasis,nbll,nbasis)
|
|
ifrst=imo1-1
|
|
ndim3=(2*ifrst+nbll+1)*nbll/2
|
|
intmem=dblalloc(dfnbasis*ndim3)
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,hai,
|
|
$dcore(intmem),mo,lbij,0.d0,tcis,nocc)
|
|
C
|
|
open(scrfile4,file='DFINV',form='UNFORMATTED')
|
|
if(trim(dfalg).ne.'lineq') then
|
|
if(dfalg.eq.'cholesky') read(scrfile4)
|
|
call rspmx(dcore(imem),dfnbasis,scrfile4)
|
|
c call roeint(dcore(imem+dfnbasis**2),dcore(imem+dfnbasis**2),
|
|
c $dcore(imem),scrfile4,dfnbasis)
|
|
elseif(trim(dfalg).eq.'lineq') then
|
|
read(scrfile4)
|
|
$(dcore(imem+i-1),i=1,(dfnbasis+1)*dfnbasis/2)
|
|
endif
|
|
close(scrfile4)
|
|
if(trim(dfalg).ne.'lineq') then
|
|
call dsymm('l','l',dfnbasis,ndim3,1.d0,dcore(imem),dfnbasis,
|
|
$dcore(intmem),dfnbasis,0.d0,hai,dfnbasis)
|
|
elseif(trim(dfalg).eq.'lineq') then
|
|
j=0
|
|
call dpptrs('L',dfnbasis,ndim3,dcore(imem),
|
|
$dcore(intmem),dfnbasis,j)
|
|
call dcopy(dfnbasis*ndim3,dcore(intmem),1,hai,1)
|
|
if(j.ne.0) then
|
|
write(iout,*)
|
|
$'Fatal error at the fitting of the Coulomb contribution!'
|
|
call mrccend(1)
|
|
endif
|
|
endif
|
|
if(lbij) then
|
|
call putdir(ndim3,nbll,nbl,hai,imo1,invfile)
|
|
else
|
|
c write(6,*) imo1,imo2,nbll,dfnbasis,ndim3
|
|
write(invfile) imo1,imo2,nbll
|
|
write(invfile) (hai(i),i=1,dfnbasis*ndim3)
|
|
inquire(file='APQ',exist=llg)
|
|
open(scrfile4,file='APQ',form='UNFORMATTED')
|
|
if(llg) then
|
|
call roeint(dcore(imem+dfnbasis**2),
|
|
$dcore(imem+dfnbasis**2),dcore(imem),scrfile4,dfnbasis)
|
|
call dsyrk('u','n',dfnbasis,ndim3,1.d0,hai,dfnbasis,
|
|
$1.d0,dcore(imem),dfnbasis)
|
|
rewind(scrfile4)
|
|
else
|
|
call dsyrk('u','n',dfnbasis,ndim3,1.d0,hai,dfnbasis,
|
|
$0.d0,dcore(imem),dfnbasis)
|
|
endif
|
|
call woeintu(dcore(imem+dfnbasis**2),
|
|
$dcore(imem+dfnbasis**2),dcore(imem),scrfile4,0.d0,dfnbasis)
|
|
close(scrfile4)
|
|
endif
|
|
c write(6,*) 'Jij'
|
|
c write(6,"(10000f16.10)") (hai(i),i=1,dfnbasis*ndim3)
|
|
call dbldealloc(intmem)
|
|
else if(oroute.eq.3) then
|
|
C Exchange contribution to gradient
|
|
if(lprog) write(iout,*)
|
|
&'Fitting and assembly step of exchange...'
|
|
ifrst=imo1-1
|
|
ndim3=(2*ifrst+nbll+1)*nbll/2
|
|
intmem=dblalloc(dfnbasis*ndim3)
|
|
do icd=0,ncd-1
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(icd*dfnbasis*nbll*nbasis+1),dcore(intmem),mo,.false.,0.d0,1,
|
|
$nocc)
|
|
call dcopy(dfnbasis*ndim3,dcore(intmem),1,
|
|
$hai(icd*dfnbasis*ndim3+1),1)
|
|
enddo
|
|
read(invfile) i,j,k
|
|
c write(6,*) i,j,k,dfnbasis,ndim3
|
|
read(invfile) (hai(ncd*dfnbasis*ndim3+i),i=1,dfnbasis*ndim3)
|
|
c write(6,*) 'der'
|
|
c write(6,"(10000f16.10)") (hai(i),i=1,ncd*dfnbasis*ndim3)
|
|
c write(6,*) 'Jij'
|
|
c write(6,"(10000f16.10)")
|
|
c $(hai(ncd*dfnbasis*ndim3+i),i=1,dfnbasis*ndim3)
|
|
do icd=0,ncd-1
|
|
tegrad(icd+1)=tegrad(icd+1)+32.d0*chfx*
|
|
$ddot(dfnbasis*ndim3,hai(icd*dfnbasis*ndim3+1),1,
|
|
$ hai(ncd*dfnbasis*ndim3+1),1)
|
|
enddo
|
|
c write(6,"(10f16.10)") tegrad
|
|
c tegrad=0.d0
|
|
call dbldealloc(intmem)
|
|
else if(oroute.eq.4) then
|
|
write(iout,*) 'Contracting integrals with densities...'
|
|
read(invfile) (dcore(imem+i),i=0,dfnbasis*nbll*nbasis-1)
|
|
do icd=0,ncd-1
|
|
tegrad(icd+1)=tegrad(icd+1)+4.d0*ddot(dfnbasis*nbll*nbasis,
|
|
$hai(icd*dfnbasis*nbll*nbasis+1),1,dcore(imem),1)
|
|
c write(6,*) tegrad(icd+1)
|
|
enddo
|
|
else if(oroute.eq.5) then
|
|
if(lprog)
|
|
& write(iout,*) 'Fitting and assembly step of exchange...'
|
|
ndim3=dfnbasis*nbasis*nbll
|
|
read(invfile) i,j,k
|
|
read(invfile) (hai(ncd*ndim3+i),i=1,ndim3)
|
|
do icd=0,ncd-1
|
|
call dgemm('t','n',nbasis,nbasis,dfnbasis*nbll,2.d0*chfx,
|
|
$hai(icd*ndim3+1),dfnbasis*nbll,hai(ncd*ndim3+1),dfnbasis*nbll,
|
|
$0.d0,hai((ncd+1)*ndim3+1),nbasis)
|
|
c $focka(1,1,icd+1),nbasis)
|
|
do i=1,nbasis
|
|
hai((ncd+1)*ndim3+(i-1)*nbasis+i)=2.d0*
|
|
$ hai((ncd+1)*ndim3+(i-1)*nbasis+i)
|
|
enddo
|
|
call daxpy(nbasis**2,1.d0,hai((ncd+1)*ndim3+1),1,
|
|
$focka(1,1,icd+1),1)
|
|
enddo
|
|
else
|
|
C HF exchange
|
|
if(lprog)
|
|
$ write(iout,*) 'Fitting and assembly step of exchange...'
|
|
if(omega.ne.0.d0) then
|
|
intmem=dblalloc(dfnbasis**2)
|
|
call df2int(natoms,nangmax,ncontrmax,nprimmax,nang,
|
|
$ncontr,nprim,gexp,coord,ncartmax,ctostr,cartg,nsphermax,cf,
|
|
$boysval,nmboys,dcore,imem,0,0.00001d0*itol,dfnshrange,iout,imem1,
|
|
$maxcor,thad,thcf2,scoord,rqqij,rqqij,0,1,dfnang,dfncontr,dfnprim,
|
|
$dfgexp,dfgcn,dfrqq,dfnbasis,dfgcoef,dfindarr,dcore(intmem),dfipre,
|
|
$i,i,.false.,i,dcore(intmem),spctostr,0,i,tcmax,.true.,
|
|
$dcore(intmem),omega,boys)
|
|
if(lcis) then
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(nstate*nbasis*dfnbasis*nbll+1),dcore(imem),mo2,.true.,0.d0,
|
|
$tcis,nocc)
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$haiold(nstate*nbasis*dfnbasis*nbll+1),dcore(imem+nocc*nbll*
|
|
$dfnbasis),mo2,.true.,0.d0,tcis,nocc)
|
|
call dsymm('l','l',dfnbasis,nocc*nbll,-1.d0,
|
|
$dcore(intmem),dfnbasis,dcore(imem+nocc*nbll*dfnbasis),
|
|
$dfnbasis,1.d0,dcore(imem),dfnbasis)
|
|
C
|
|
else
|
|
call dsymm('l','l',dfnbasis,nbasis*nbll,-0.5d0,
|
|
$dcore(intmem),dfnbasis,haiold,dfnbasis,1.d0,hai,dfnbasis)
|
|
call dbldealloc(intmem)
|
|
endif
|
|
endif
|
|
if(crsh.ne.1.and.omega.eq.0.d0.and..not.lcis) then
|
|
call dcopy(hailen,hai,1,haiold,1)
|
|
call dpptrs('L',dfnbasis,nbasis*nbll,dcore(imem),haiold,
|
|
$dfnbasis,isyev) ! Fitting coefficient for RSH
|
|
if(chfx.ne.0.d0)
|
|
$ call dsyr2k('u','t',nbasis,dfnbasis*nbll,0.5d0*chfx,hai,
|
|
$dfnbasis*nbll,haiold,dfnbasis*nbll,1.d0,focka,nbasis)
|
|
else if(omega.ne.0.d0) then ! RSH assembly
|
|
if(lcis) then
|
|
do i=1,nstate
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,-chfx,
|
|
$haiold((i-1)*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem),dfnbasis*nbll,1.d0,rmi(1,1,i),nbasis)
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,-chfx,
|
|
$hai((i-1)*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+nocc*nbll*dfnbasis),dfnbasis*nbll,1.d0,
|
|
$rmi(1,1,i),nbasis)
|
|
enddo
|
|
C
|
|
if(ltdhf) then !TDHF
|
|
C
|
|
cisc=1.d0
|
|
if(cisflag.eq.1) cisc=-1.d0
|
|
C
|
|
do i=1,nstate
|
|
C
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai((i-1)*dfnbasis*nbasis*nbll+1),dcore(imem),mo2,.true.,0.d0,
|
|
$tcis,nocc)
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$haiold((i-1)*dfnbasis*nbasis*nbll+1),dcore(imem+nocc*nbll*
|
|
$dfnbasis),mo2,.true.,0.d0,tcis,nocc)
|
|
C
|
|
call dsymm('l','l',dfnbasis,nocc*nbll,-1.d0,
|
|
$dcore(intmem),dfnbasis,dcore(imem+nocc*nbll*dfnbasis),
|
|
$dfnbasis,1.d0,dcore(imem),dfnbasis)
|
|
C
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,-chfx*cisc,
|
|
$haiold(nstate*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem),dfnbasis*nbll,1.d0,rmi(1,1,i),
|
|
$nbasis)
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,-chfx*cisc,
|
|
$hai(nstate*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+nocc*nbll*dfnbasis),dfnbasis*nbll,1.d0,rmi(1,1,i),
|
|
$nbasis)
|
|
enddo
|
|
endif
|
|
C
|
|
call dbldealloc(intmem)
|
|
else
|
|
call dsyr2k('u','t',nbasis,dfnbasis*nbll,chfx,hai,
|
|
$dfnbasis*nbll,haiold,dfnbasis*nbll,1.d0,focka,nbasis)
|
|
endif
|
|
endif
|
|
if(chfx.ne.0.d0.and.crsh.eq.1) then
|
|
if(oroute.ne.6) then
|
|
if(loccri) then
|
|
if(loverlap) then
|
|
call overlap_fitting_occri(dcore(imem),hai,
|
|
$hai_occri,dfnbasis,nbasis,dcore(imem+dfnbasis**2),natoms,
|
|
$nangmax,ncontrmax,nprimmax,ncartmax,nsphermax,dfnang,dfnangmin,
|
|
$dfncontr,dfnprim,dfgexp,dfgcoef,coord,ctostr,dfgcn,cartg,
|
|
$dfnshrange,nbll,nocc,mo,kmat,chfx)
|
|
else
|
|
call dpptrs('L',dfnbasis,nocc*nbll,dcore(imem),
|
|
$hai_occri,dfnbasis,isyev)
|
|
if(isyev.ne.0) then
|
|
write(iout,*)
|
|
$'Fatal error at the fitting of the exchange contribution!'
|
|
call mrccend(1)
|
|
endif
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,chfx,
|
|
$hai,dfnbasis*nbll,hai_occri,dfnbasis*nbll,1.0d0,kmat,
|
|
$nbasis)
|
|
endif
|
|
else
|
|
if(loverlap) then
|
|
call overlap_fitting(dcore(imem),hai,dfnbasis,nbasis,
|
|
$dcore(imem+dfnbasis**2),natoms,nangmax,ncontrmax,nprimmax,
|
|
$ncartmax,nsphermax,dfnang,dfnangmin,dfncontr,dfnprim,dfgexp,
|
|
$dfgcoef,coord,ctostr,dfgcn,cartg,dfnshrange,nbll)
|
|
else
|
|
call dtptrs('L','N','N',dfnbasis,nbasis*nbll,
|
|
$dcore(imem),hai,dfnbasis,isyev)
|
|
if(isyev.ne.0) then
|
|
write(iout,*)
|
|
$'Fatal error at the fitting of the exchange contribution!'
|
|
call mrccend(1)
|
|
endif
|
|
endif
|
|
call dsyrk('u','t',nbasis,dfnbasis*nbll,chfx,hai,
|
|
$dfnbasis*nbll,1.d0,focka,nbasis)
|
|
endif
|
|
else ! perturbation independent interm. MP2 exc.
|
|
call dpptrs('L',dfnbasis,nbasis*nbll,dcore(imem),hai,
|
|
$dfnbasis,isyev)
|
|
write(invfile) imo1,imo2,nbll
|
|
write(invfile) (hai(i),i=1,dfnbasis*nbasis*nbll)
|
|
endif
|
|
endif
|
|
endif
|
|
endif
|
|
C Starting gradient calculation
|
|
c 2-center integral derivative contribution
|
|
c In MP2 derivative (oroute==4) we know the full gamma matrix => we have to
|
|
c calculate this term only once (imo1==1)
|
|
if(l3route.and.(oroute.ne.4.or.imo1.eq.1)) then
|
|
call timer
|
|
write(iout,*)
|
|
write(iout,*)
|
|
$'Calculation of two-electron integral derivatives...'
|
|
l3route=.false.
|
|
C Contribution of two-center integral derivatives to gradient
|
|
intmem=dblalloc(3*dfnbasis**2)
|
|
call df2int(natoms,nangmax,ncontrmax,nprimmax,nang,
|
|
$ncontr,nprim,gexp,coord,ncartmax,ctostr,cartg,nsphermax,cf,
|
|
$boysval,nmboys,dcore,imem,0,0.00001d0*itol,i,iout,imem1,maxcor,
|
|
$thad,thcf2,scoord,rqqij,rqqij,1,-1,dfnang,dfncontr,dfnprim,dfgexp,
|
|
$dfgcn,dfrqq,dfnbasis,dfgcoef,dfindarr,dcore,dfipre,i,i,.false.,i,
|
|
$dcore(intmem),spctostr,0,i,tcmax,.true.,dcore,omega,boys)
|
|
|
|
c Calculating Gamma_PQ for local SCF gradient
|
|
scrmem=dblalloc(3*dfnbasis)
|
|
dscrmem=imem
|
|
if(llexc) then
|
|
dscrmem=dblalloc(dfnbasis**2)
|
|
call dfillzero(dcore(dscrmem),dfnbasis**2)
|
|
endif
|
|
if(llexc.and..not.lnolocx) then
|
|
call read_dfatdom(natoms,nocc,idfatdom,idfnatdom,ialpha,
|
|
&scrfile4,icore)
|
|
call ldf2grad(natoms,nocc,dfnmobasis,icore(idfatdom),
|
|
&icore(idfnatdom),imo1,imo2,dcore,dcore(ibij),libij/2,
|
|
&dcore(dscrmem),dfnatrange,chfx,ldfock,dfnbasis)
|
|
endif
|
|
call df2grad(grads,dfnbasis,x,llexc,iroute,
|
|
$dcore(intmem),natoms,dfnatrange,dcore(scrmem),dcore(dscrmem),
|
|
$dcore(ibij),nocc,nocc2,nbll,chfx,nstate,ltdhf,lnolocx,ldfock,
|
|
$oroute,scrfile4,dcore(imem))
|
|
call dbldealloc(intmem)
|
|
if(oroute.eq.4.and.l3der) return
|
|
if(ldfock.and.iroute.eq.2) call dscal(2*dfnbasis,0.5d0,x,1)
|
|
if(llexc) call dbldealloc(ibij)
|
|
goto 9753
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine read_dfatdom(natoms,nocc,idfatdom,idfnatdom,ialpha,
|
|
&scrfile4,icore)
|
|
************************************************************************
|
|
************************************************************************
|
|
implicit none
|
|
integer natoms,nocc,idfatdom,idfnatdom,ialpha,scrfile4,icore(*),i
|
|
integer intalloc
|
|
|
|
idfatdom=intalloc(natoms*nocc)
|
|
idfnatdom=intalloc(nocc)
|
|
if(ialpha.le.1) then
|
|
open(scrfile4,file='DFLTOC',form='unformatted')
|
|
else
|
|
open(scrfile4,file='DFLTOCb',form='unformatted')
|
|
endif
|
|
read(scrfile4)
|
|
read(scrfile4) (icore(idfatdom+i),i=0,natoms*nocc-1),
|
|
$ (icore(idfnatdom+i),i=0,nocc-1)
|
|
close(scrfile4)
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine df2grad(grads,dfn,x,llexc,iroute,tcd,natoms,dfnatrange,
|
|
$y,gam,bij,nocc,nocc2,nbll,chfx,nstate,ltdhf,lnolocx,ldfock,oroute,
|
|
$scrfile4,work)
|
|
************************************************************************
|
|
* Calculate two-center derivative ERI contribution to gradient
|
|
************************************************************************
|
|
implicit none
|
|
integer iroute,dfn,iatoms,natoms,ifrst,ilast,xyz,nocc,nbll
|
|
integer dfnatrange(2,natoms),nstate,flag,nocc2,oroute,scrfile4
|
|
real*8 x(dfn,*),grads(3,natoms),g(3),tcd(dfn*dfn,3),y(dfn,3)
|
|
real*8 bij(dfn*nbll*nocc,*),chfx,gam(dfn*dfn),factor,work(*)
|
|
real*8 scaling
|
|
logical llexc,ltdhf,lnolocx,ldfock
|
|
C Coulomb + exchange
|
|
if(llexc.or.oroute.eq.4) then
|
|
C Exchange
|
|
if(oroute.eq.4) then
|
|
open(scrfile4,file='CCDENSITIES',form='unformatted')
|
|
read(scrfile4)
|
|
read(scrfile4)
|
|
call rtdmx(work,work,gam,scrfile4,dfn,dfn)
|
|
close(scrfile4)
|
|
elseif(nstate.eq.1.and.lnolocx.and..not.ldfock) then
|
|
call dsyrk('u','n',dfn,nbll*nocc,2d0*chfx,bij,dfn,0d0,gam,dfn)
|
|
call filllo(gam,dfn)
|
|
elseif(nstate.eq.1.and.lnolocx.and.ldfock) then
|
|
call dsyrk('u','n',dfn,nbll*nocc2,2d0*chfx,bij,dfn,0d0,gam,dfn)
|
|
call filllo(gam,dfn)
|
|
elseif(nstate.ne.1) then ! CIS contribution
|
|
factor=1.d0
|
|
if(ltdhf) factor=0.5d0
|
|
call dsyrk('u','n',dfn,nbll*nocc,2.0d0*chfx*factor,bij(1,2),
|
|
$dfn,0.d0,gam,dfn)
|
|
if(ltdhf) call dsyrk('u','n',dfn,nbll*nocc,2.0d0*chfx*factor,
|
|
$bij(1,7),dfn,1.d0,gam,dfn)
|
|
call filllo(gam,dfn)
|
|
call dgemm('n','t',dfn,dfn,nbll*nocc,0.5d0*chfx,bij,
|
|
$dfn,bij(1,3),dfn,1.d0,gam,dfn)
|
|
call dgemm('n','t',dfn,dfn,nbll*nocc,0.5d0*chfx,bij(1,3),
|
|
$dfn,bij,dfn,1.d0,gam,dfn)
|
|
call dgemm('n','t',dfn,dfn,nbll*nocc,factor*chfx,bij,dfn,
|
|
$bij(1,4),dfn,1.d0,gam,dfn)
|
|
call dgemm('n','t',dfn,dfn,nbll*nocc,factor*chfx,bij(1,4),dfn,
|
|
$bij,dfn,1.d0,gam,dfn)
|
|
if(ltdhf) then
|
|
call dgemm('n','t',dfn,dfn,nbll*nocc,factor*chfx,bij,dfn,
|
|
$bij(1,9),dfn,1.d0,gam,dfn)
|
|
call dgemm('n','t',dfn,dfn,nbll*nocc,factor*chfx,bij(1,9),dfn,
|
|
$bij,dfn,1.d0,gam,dfn)
|
|
call dgemm('n','t',dfn,dfn,nbll*nocc,factor*chfx,bij(1,2),dfn,
|
|
$bij(1,5),dfn,1.d0,gam,dfn)
|
|
call dgemm('n','t',dfn,dfn,nbll*nocc,factor*chfx,bij(1,5),dfn,
|
|
$bij(1,2),dfn,1.d0,gam,dfn)
|
|
call dgemm('n','t',dfn,dfn,nbll*nocc,-factor*chfx,bij(1,8),
|
|
$dfn,bij(1,7),dfn,1.d0,gam,dfn)
|
|
call dgemm('n','t',dfn,dfn,nbll*nocc,-factor*chfx,bij(1,7),
|
|
$dfn,bij(1,8),dfn,1.d0,gam,dfn)
|
|
endif
|
|
endif
|
|
C Coulomb
|
|
if(iroute.eq.2.and.nstate.eq.1.and..not.ldfock) then
|
|
call dger(dfn,dfn,0.25d0,x,1,x,1,gam,dfn)
|
|
elseif(iroute.eq.2.and.nstate.eq.1.and.ldfock) then
|
|
call dsyr2('u',dfn,0.5d0*0.25d0,x,1,x(1,2),1,gam,dfn)
|
|
call filllo(gam,dfn)
|
|
elseif(iroute.eq.2.and.nstate.ne.1) then ! CIS contribution
|
|
call dger(dfn,dfn,1.0d0,x(1,2),1,x(1,2),1,gam,dfn)
|
|
call dger(dfn,dfn,0.25d0,x(1,1),1,x(1,3),1,gam,dfn)
|
|
call dger(dfn,dfn,0.25d0,x(1,3),1,x(1,1),1,gam,dfn)
|
|
call dscal(dfn,4.0d0,x(1,2),1)
|
|
endif
|
|
scaling=1.0d0
|
|
if(oroute.eq.4) scaling=4.0d0
|
|
C$OMP PARALLEL DO Schedule(Dynamic)
|
|
C$OMP& DEFAULT(SHARED)
|
|
C$OMP& PRIVATE(iatoms,ifrst,ilast,xyz,g)
|
|
do iatoms=1,natoms
|
|
ifrst=dfnatrange(1,iatoms)
|
|
ilast=dfnatrange(2,iatoms)
|
|
do xyz=1,3
|
|
g(xyz)=scaling*dot_product(
|
|
$tcd(ifrst*dfn+1:ilast*dfn,xyz),gam(ifrst*dfn+1:ilast*dfn))
|
|
enddo
|
|
!$OMP CRITICAL (grad)
|
|
grads(:,iatoms)=grads(:,iatoms)+g(:)
|
|
!$OMP END CRITICAL (grad)
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
else if(iroute.eq.2) then
|
|
C Only Coulomb
|
|
if(ldfock) then
|
|
call df2grad_coulomb(natoms,dfn,tcd,x,x(1,2),y,grads,
|
|
& dfnatrange,0.25d0*0.5d0)
|
|
call df2grad_coulomb(natoms,dfn,tcd,x(1,2),x,y,grads,
|
|
& dfnatrange,0.25d0*0.5d0)
|
|
else
|
|
call df2grad_coulomb(natoms,dfn,tcd,x,x,y,grads,
|
|
& dfnatrange,0.25d0)
|
|
endif
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine df2grad_coulomb(natoms,dfn,tcd,x,x2,y,grads,dfnatrange,
|
|
& factor)
|
|
************************************************************************
|
|
* gradient contribution from the 2-center coulomb integrals (only for
|
|
* the Coulomb parts)
|
|
************************************************************************
|
|
implicit none
|
|
integer natoms,dfn,dfnatrange(2,natoms)
|
|
double precision tcd(dfn,dfn,3),x(dfn),x2(dfn,1),y(dfn,3)
|
|
double precision grads(3,natoms),factor
|
|
|
|
integer iatoms,ifrst,ilast,xyz
|
|
double precision g(3)
|
|
|
|
call dgemv('t',dfn,dfn*3,1.d0,tcd,dfn,x,1,0.d0,y,1)
|
|
C$OMP PARALLEL DO Schedule(Dynamic)
|
|
C$OMP& DEFAULT(SHARED)
|
|
C$OMP& PRIVATE(iatoms,ifrst,ilast,xyz,g)
|
|
do iatoms=1,natoms
|
|
ifrst=dfnatrange(1,iatoms)+1
|
|
ilast=dfnatrange(2,iatoms)
|
|
do xyz=1,3
|
|
g(xyz)=factor*
|
|
$dot_product(y(ifrst:ilast,xyz),x2(ifrst:ilast,1))
|
|
enddo
|
|
!$OMP CRITICAL (grad)
|
|
grads(:,iatoms)=grads(:,iatoms)+g(:)
|
|
!$OMP END CRITICAL (grad)
|
|
enddo
|
|
C$OMP END PARALLEL DO
|
|
end subroutine
|
|
|
|
************************************************************************
|
|
subroutine df3grad(dfint,iatoms,jatoms,katoms,grads,nilen,njlen,
|
|
$nklen,dens,dens2,x,x2,lexc,iroute,dx,icd,nstate,ldfock)
|
|
************************************************************************
|
|
* Calculate three-center derivative ERI contribution to gradient
|
|
************************************************************************
|
|
implicit none
|
|
integer nilen,njlen,nklen,iatoms,jatoms,katoms,ij,k,ijk,iroute
|
|
integer icd,nstate
|
|
real*8 dfint(nilen*njlen*nklen,3,3),x(nklen),grads(3,*)
|
|
real*8 dens(nilen*njlen),dy(nilen*njlen*nklen),g1(3),g2(3),g3(3)
|
|
real*8 dens2(nilen*njlen),x2(nklen)
|
|
real*8 dx(nilen*njlen*nklen)
|
|
logical lexc,ldfock
|
|
c write(6,*) 'x'
|
|
c write(6,"(7f9.5)") x
|
|
c write(6,*) 'dens'
|
|
c write(6,"(7f9.5)") dens
|
|
c write(6,*) 'dfint'
|
|
c write(6,"(7f9.5)") dfint
|
|
C Coulomb
|
|
if(iroute.eq.2) then
|
|
ijk=0
|
|
if(ldfock) then
|
|
do k=1,nklen
|
|
do ij=1,nilen*njlen
|
|
ijk=ijk+1
|
|
dy(ijk)=dens2(ij)*x(k)+dens(ij)*x2(k)
|
|
enddo
|
|
enddo
|
|
else
|
|
do k=1,nklen
|
|
do ij=1,nilen*njlen
|
|
ijk=ijk+1
|
|
dy(ijk)=dens(ij)*x(k)
|
|
enddo
|
|
enddo
|
|
endif
|
|
else
|
|
dy=0.d0
|
|
endif
|
|
C Exchange
|
|
if(lexc.and.nstate.eq.0) dy=dy+dx
|
|
if(lexc.and.nstate.ne.0.and.icd.eq.0) dy=dy+dx
|
|
C
|
|
g1(1)=dot_product(dfint(:,1,1),dy)
|
|
g1(2)=dot_product(dfint(:,2,1),dy)
|
|
g1(3)=dot_product(dfint(:,3,1),dy)
|
|
g2(1)=dot_product(dfint(:,1,2),dy)
|
|
g2(2)=dot_product(dfint(:,2,2),dy)
|
|
g2(3)=dot_product(dfint(:,3,2),dy)
|
|
if(iatoms.eq.jatoms) then
|
|
!$OMP CRITICAL (grad)
|
|
grads(:,iatoms)=grads(:,iatoms)+g1(:)
|
|
grads(:,katoms)=grads(:,katoms)+g2(:)
|
|
!$OMP END CRITICAL (grad)
|
|
else if(iatoms.eq.katoms.or.jatoms.eq.katoms) then
|
|
!$OMP CRITICAL (grad)
|
|
grads(:,iatoms)=grads(:,iatoms)+g1(:)
|
|
grads(:,jatoms)=grads(:,jatoms)+g2(:)
|
|
!$OMP END CRITICAL (grad)
|
|
else
|
|
g3(1)=dot_product(dfint(:,1,3),dy)
|
|
g3(2)=dot_product(dfint(:,2,3),dy)
|
|
g3(3)=dot_product(dfint(:,3,3),dy)
|
|
!$OMP CRITICAL (grad)
|
|
grads(:,iatoms)=grads(:,iatoms)+g1(:)
|
|
grads(:,jatoms)=grads(:,jatoms)+g2(:)
|
|
grads(:,katoms)=grads(:,katoms)+g3(:)
|
|
!$OMP END CRITICAL (grad)
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine shgamma(nilen,njlen,chfx,ieqj,hai,nbasis,dfnbasis,
|
|
$jfrst,dx,nbll,mo,nstate,ltdhf)
|
|
************************************************************************
|
|
* Calculate three-index density matrix
|
|
************************************************************************
|
|
implicit none
|
|
integer nilen,njlen,nbasis,dfnbasis,jfrst,i,j,nbll,nstate
|
|
real*8 dx(nilen,njlen,dfnbasis),hai(dfnbasis,nbll,nbasis,*),chfx
|
|
real*8 mo(nbasis,*)
|
|
logical ieqj,ltdhf
|
|
C
|
|
if(nstate.eq.1) then
|
|
do j=jfrst+1,jfrst+njlen
|
|
call dgemm('n','t',nilen,dfnbasis,nbll,4.d0*chfx,mo,nbasis,
|
|
$hai(1,1,j,1),dfnbasis,0.d0,dx(1,j-jfrst,1),nilen*njlen)
|
|
enddo
|
|
else
|
|
do j=jfrst+1,jfrst+njlen
|
|
call dgemm('n','t',nilen,dfnbasis,nbll,2.0d0*chfx,
|
|
$mo(1,nbasis+1),nbasis,hai(1,1,j,1),dfnbasis,0.d0,dx(1,j-jfrst,1),
|
|
$nilen*njlen)
|
|
call dgemm('n','t',nilen,dfnbasis,nbll,2.0d0*chfx,
|
|
$mo(1,2*nbasis+1),nbasis,hai(1,1,j,3),dfnbasis,1.d0,
|
|
$dx(1,j-jfrst,1),nilen*njlen)
|
|
call dgemm('n','t',nilen,dfnbasis,nbll,2.0d0*chfx,mo,nbasis,
|
|
$hai(1,1,j,2),dfnbasis,1.d0,dx(1,j-jfrst,1),nilen*njlen)
|
|
enddo
|
|
if(ltdhf) then
|
|
do j=jfrst+1,jfrst+njlen
|
|
call dgemm('n','t',nilen,dfnbasis,nbll,2.0d0*chfx,
|
|
$mo(1,3*nbasis+1),nbasis,hai(1,1,j,4),dfnbasis,1.d0,
|
|
$dx(1,j-jfrst,1),nilen*njlen)
|
|
enddo
|
|
endif
|
|
endif
|
|
if(ieqj) then
|
|
do i=1,nilen
|
|
dx(i,i,:)=0.5d0*dx(i,i,:)
|
|
do j=1,i-1
|
|
dx(i,j,:)=0.d0
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine shgamma2(nilen,njlen,chfx,ieqj,hai,nbasis,dfnbasis,
|
|
$ifrst,jfrst,dx,nbll,mo)
|
|
************************************************************************
|
|
* Calculates the 3-center gamma matrix for a shell pair
|
|
************************************************************************
|
|
implicit none
|
|
integer nilen,njlen,nbasis,dfnbasis,ifrst,jfrst,nbll
|
|
double precision chfx,hai(dfnbasis,nbll,nbasis)
|
|
double precision dx(nilen,njlen,dfnbasis),mo(nbasis,*)
|
|
logical ieqj
|
|
|
|
integer imo,i,j,k
|
|
|
|
dx=0.0d0
|
|
do imo=1,nbll
|
|
do k=1,dfnbasis
|
|
do j=1,njlen
|
|
do i=1,nilen
|
|
dx(i,j,k)=dx(i,j,k)+hai(k,imo,ifrst+i)*mo(jfrst+j,imo)+
|
|
& hai(k,imo,jfrst+j)*mo(ifrst+i,imo)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
if(ieqj) then
|
|
do i=1,nilen
|
|
dx(i,i,:)=0.5d0*dx(i,i,:)
|
|
do j=1,i-1
|
|
dx(i,j,:)=0.d0
|
|
enddo
|
|
enddo
|
|
endif
|
|
call dscal(nilen*njlen*dfnbasis,2.0d0*chfx,dx,1)
|
|
|
|
end subroutine
|
|
************************************************************************
|
|
subroutine overlap_fitting_occri(vints,dfints,dfints_occri,
|
|
&dfnbasis,nbasis,work,natoms,nangmax,ncontrmax,nprimmax,ncartmax,
|
|
&nsphermax,dfnang,dfnangmin,dfncontr,dfnprim,dfgexp,dfgcoef,coord,
|
|
&ctostr,dfgcn,cartg,nshrange,nbll,nocc,mo,kocc,chfx)
|
|
************************************************************************
|
|
* Overlap fitting of 3-center integrals with occ-ri
|
|
************************************************************************
|
|
implicit none
|
|
integer dfnbasis,nbasis,i,j,nbll,nocc
|
|
integer natoms,nangmax,ncontrmax,nprimmax,ncartmax
|
|
integer nsphermax,dfnang(*),dfnangmin(*),dfncontr(*),dfnprim(*)
|
|
integer nshrange(*)
|
|
double precision dfints(dfnbasis,nbll,nbasis)
|
|
double precision dfints_occri(dfnbasis,nbll,nocc),mo(nbasis,nocc)
|
|
double precision dfgexp(*),dfgcoef(*),coord(*),ctostr
|
|
double precision vints(dfnbasis,dfnbasis),work(*),dfgcn(*)
|
|
double precision kocc(nbasis,nocc),chfx
|
|
logical cartg
|
|
|
|
call dgemm('n','n',dfnbasis*nbll,nocc,nbasis,dsqrt(0.5d0),dfints,
|
|
&dfnbasis*nbll,mo,nbasis,0.0d0,dfints_occri,dfnbasis*nbll)
|
|
|
|
work(1:dfnbasis**2)=0.0d0
|
|
call overla(natoms,nangmax,ncontrmax,nprimmax,ncartmax,
|
|
$nsphermax,dfnang,dfnangmin,dfncontr,dfnprim,dfgexp,dfgcoef,coord,
|
|
$ctostr,dfnbasis,work,work(1+dfnbasis**2),dfgcn,nshrange,cartg)
|
|
call fillup(work,dfnbasis)
|
|
|
|
call dtptrs('l','n','n',dfnbasis,dfnbasis,vints,work,dfnbasis,i)
|
|
call dsyrk('u','t',dfnbasis,dfnbasis,1.0d0,work,dfnbasis,0.0d0,
|
|
$vints,dfnbasis)
|
|
call dsysv('u',dfnbasis,nbll*nocc,vints,dfnbasis,work,
|
|
$dfints_occri,dfnbasis,work(1+dfnbasis),-1,i)
|
|
j=int(work(1+dfnbasis))
|
|
call dsysv('u',dfnbasis,nbll*nocc,vints,dfnbasis,work,
|
|
$dfints_occri,dfnbasis,work(1+dfnbasis),j,i)
|
|
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,chfx,dfints,
|
|
$dfnbasis*nbll,dfints_occri,dfnbasis*nbll,1.0d0,kocc,nbasis)
|
|
|
|
end subroutine
|
|
************************************************************************
|
|
subroutine overlap_fitting(vints,dfints,dfnbasis,nbasis,work,
|
|
&natoms,nangmax,ncontrmax,nprimmax,ncartmax,nsphermax,dfnang,
|
|
&dfnangmin,dfncontr,dfnprim,dfgexp,dfgcoef,coord,ctostr,
|
|
&dfgcn,cartg,nshrange,nbll)
|
|
************************************************************************
|
|
* Overlap fitting of 3-center integrals
|
|
************************************************************************
|
|
implicit none
|
|
integer dfnbasis,nbasis,i,j,nbll
|
|
integer natoms,nangmax,ncontrmax,nprimmax,ncartmax
|
|
integer nsphermax,dfnang(*),dfnangmin(*),dfncontr(*),dfnprim(*)
|
|
integer nshrange(*)
|
|
double precision dfints(dfnbasis,nbll,nbasis)
|
|
double precision dfgexp(*),dfgcoef(*),coord(*),ctostr
|
|
double precision vints(dfnbasis,dfnbasis),work(*),dfgcn(*)
|
|
logical cartg
|
|
|
|
call dcopy(dfnbasis*(dfnbasis+1)/2,vints,1,work,1)
|
|
do i=1,dfnbasis
|
|
do j=1,i
|
|
vints(i,j)=work(i+(j-1)*(2*dfnbasis-j)/2)
|
|
enddo
|
|
enddo
|
|
|
|
work(1:dfnbasis**2)=0.0d0
|
|
call overla(natoms,nangmax,ncontrmax,nprimmax,ncartmax,
|
|
$nsphermax,dfnang,dfnangmin,dfncontr,dfnprim,dfgexp,dfgcoef,coord,
|
|
$ctostr,dfnbasis,work,work(1+dfnbasis**2),dfgcn,nshrange,cartg)
|
|
call fillup(work,dfnbasis)
|
|
|
|
call dtrsm('r','l','t','n',dfnbasis,dfnbasis,1.0d0,vints,
|
|
$dfnbasis,work,dfnbasis)
|
|
|
|
call dgesv(dfnbasis,nbasis*nbll,work,dfnbasis,
|
|
$work(1+dfnbasis**2),dfints,dfnbasis,i)
|
|
|
|
end subroutine
|
|
************************************************************************
|
|
logical function ext_test(e1,e2,c1,c2)
|
|
************************************************************************
|
|
* Returns true if the extents overlap and false otherwise
|
|
************************************************************************
|
|
implicit none
|
|
double precision e1,e2,c1(3),c2(3)
|
|
|
|
if(e1+e2.lt.
|
|
& sqrt((c1(1)-c2(1))**2+
|
|
& (c1(2)-c2(2))**2+
|
|
& (c1(3)-c2(3))**2)) then
|
|
ext_test=.false.
|
|
else
|
|
ext_test=.true.
|
|
endif
|
|
return
|
|
end function
|
|
************************************************************************
|
|
logical function overla3_scr(nprima,nprimb,nprimc,expa,
|
|
&expb,expc,coorda,coordb,coordc,tol)
|
|
************************************************************************
|
|
* Returns true if the 3-center overlap integral is not negligible
|
|
* and false otherwise
|
|
************************************************************************
|
|
implicit none
|
|
integer nprima,nprimb,nprimc
|
|
double precision expa(nprima),expb(nprimb),expc(nprimc)
|
|
double precision coorda(3),coordb(3),coordc(3),coordd(3),tol
|
|
double precision a,b,c,d,dab,ddc,pi,integral
|
|
parameter(pi=3.14159265358979323846)
|
|
|
|
a=minval(expa)
|
|
b=minval(expb)
|
|
c=minval(expc)
|
|
d=a+b
|
|
|
|
dab=(coorda(1)-coordb(1))**2+
|
|
& (coorda(2)-coordb(2))**2+
|
|
& (coorda(3)-coordb(3))**2
|
|
|
|
coordd=a/d*coorda+b/d*coordb
|
|
ddc=(coordd(1)-coordc(1))**2+
|
|
& (coordd(2)-coordc(2))**2+
|
|
& (coordd(3)-coordc(3))**2
|
|
|
|
integral=exp(-(a*b/d*dab+d*c*ddc/(d+c)))*(pi/(d+c))**(1.5d0)
|
|
if(integral.lt.tol) then
|
|
overla3_scr=.false.
|
|
else
|
|
overla3_scr=.true.
|
|
endif
|
|
|
|
return
|
|
end function
|
|
|
|
************************************************************************
|
|
subroutine gradcont(ifrst,dfnbasis,nbll,nbasis,hai,dcore,mo,
|
|
$tcis,nocc,chfx,rmi,hailen,imem,mo2,nvirt,rma,ltdhf)
|
|
************************************************************************
|
|
implicit none
|
|
integer ifrst,dfnbasis,nbll,nbasis,hailen,tcis,nocc,imem,j
|
|
integer nvirt,cmotrf
|
|
logical ltdhf
|
|
real*8 hai(hailen),dcore(*),mo(nbasis,nbasis,*),chfx,factor
|
|
real*8 rmi(nbasis*nocc,*),mo2(nbasis,*),rma(nbasis*nvirt,*)
|
|
C
|
|
factor=1.d0
|
|
cmotrf=3
|
|
if(ltdhf) factor=0.5d0
|
|
if(ltdhf) cmotrf=4
|
|
C 2:
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(cmotrf*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo2,.true.,0.d0,tcis,nocc)
|
|
C
|
|
call dpptrs('L',dfnbasis,nocc*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,-chfx,
|
|
$hai,dfnbasis*nbll,dcore(imem+(dfnbasis+1)*dfnbasis/2),
|
|
$dfnbasis*nbll,1.d0,rmi,nbasis)
|
|
if(ltdhf) then
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,-chfx*factor,
|
|
$hai(2*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rmi(1,2),nbasis)
|
|
C
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,chfx*factor,
|
|
$hai(3*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rmi(1,4),nbasis)
|
|
endif
|
|
C 11:
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,-1.0d0*chfx,
|
|
$hai(cmotrf*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rmi(1,3),nbasis)
|
|
C 4:
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(cmotrf*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo,.true.,0.d0,tcis,nocc)
|
|
call dpptrs('L',dfnbasis,nocc*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,-1.0d0*chfx,
|
|
$hai(cmotrf*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rmi,nbasis)
|
|
C 6:
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(2*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo(1,1,3),.true.,0.d0,tcis,
|
|
$nocc)
|
|
call dpptrs('L',dfnbasis,nocc*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,
|
|
$-2.d0*chfx*factor,hai(cmotrf*dfnbasis*nbasis*nbll+1),
|
|
$dfnbasis*nbll,dcore(imem+(dfnbasis+1)*dfnbasis/2),
|
|
$dfnbasis*nbll,1.d0,rmi,nbasis)
|
|
if(ltdhf) then
|
|
C TDHF:
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(3*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo(1,1,4),.true.,0.d0,tcis,
|
|
$nocc)
|
|
call dpptrs('L',dfnbasis,nocc*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,
|
|
$-2.d0*chfx*factor,hai(cmotrf*dfnbasis*nbasis*nbll+1),
|
|
$dfnbasis*nbll,dcore(imem+(dfnbasis+1)*dfnbasis/2),
|
|
$dfnbasis*nbll,1.d0,rmi,nbasis)
|
|
C
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(cmotrf*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo(1,1,3),.true.,0.d0,tcis,
|
|
$nocc)
|
|
call dpptrs('L',dfnbasis,nocc*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,
|
|
$-2.d0*chfx*factor,hai(2*dfnbasis*nbasis*nbll+1),
|
|
$dfnbasis*nbll,dcore(imem+(dfnbasis+1)*dfnbasis/2),
|
|
$dfnbasis*nbll,1.d0,rmi,nbasis)
|
|
C
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(cmotrf*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo(1,1,4),.true.,0.d0,tcis,
|
|
$nocc)
|
|
call dpptrs('L',dfnbasis,nocc*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,
|
|
$2.d0*chfx*factor,hai(3*dfnbasis*nbasis*nbll+1),
|
|
$dfnbasis*nbll,dcore(imem+(dfnbasis+1)*dfnbasis/2),
|
|
$dfnbasis*nbll,1.d0,rmi,nbasis)
|
|
endif
|
|
C 7:
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(2*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo2,.true.,0.d0,tcis,
|
|
$nocc)
|
|
call dpptrs('L',dfnbasis,nocc*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,
|
|
$-2.d0*chfx*factor,hai(2*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rmi,nbasis)
|
|
C 10:
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,-chfx*factor,
|
|
$hai(cmotrf*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rmi(1,2),nbasis)
|
|
if(ltdhf) then
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(3*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo2,.true.,0.d0,tcis,
|
|
$nocc)
|
|
call dpptrs('L',dfnbasis,nocc*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,
|
|
$-2.d0*chfx*factor,hai(3*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rmi,nbasis)
|
|
call dgemm('t','n',nbasis,nocc,dfnbasis*nbll,-chfx*factor,
|
|
$hai(cmotrf*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rmi(1,4),nbasis)
|
|
endif
|
|
C
|
|
C AB block of the energy-weighted density
|
|
C 10:
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(2*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo2(1,nocc+1),
|
|
$.true.,0.d0,tcis,nvirt)
|
|
call dpptrs('L',dfnbasis,nvirt*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nvirt,dfnbasis*nbll,-chfx*factor,
|
|
$hai(cmotrf*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rma,nbasis)
|
|
C
|
|
if(ltdhf) then
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(3*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo2(1,nocc+1),
|
|
$.true.,0.d0,tcis,nvirt)
|
|
call dpptrs('L',dfnbasis,nvirt*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nvirt,dfnbasis*nbll,
|
|
$-chfx*factor,hai(cmotrf*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rma(1,3),nbasis)
|
|
C
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(cmotrf*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo2(1,nocc+1),
|
|
$.true.,0.d0,tcis,nvirt)
|
|
call dpptrs('L',dfnbasis,nvirt*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nvirt,dfnbasis*nbll,-chfx*factor,
|
|
$hai(2*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rma,nbasis)
|
|
C
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(cmotrf*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo2(1,nocc+1),
|
|
$.true.,0.d0,tcis,nvirt)
|
|
call dpptrs('L',dfnbasis,nvirt*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nvirt,dfnbasis*nbll,chfx*factor,
|
|
$hai(3*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rma(1,3),nbasis)
|
|
endif
|
|
C 11:
|
|
call sechalf(ifrst,dfnbasis,dfnbasis,nbll,nbasis,
|
|
$hai(cmotrf*nbasis*dfnbasis*nbll+1),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),mo2(1,nocc+1),
|
|
$.true.,0.d0,tcis,nvirt)
|
|
C
|
|
call dpptrs('L',dfnbasis,nvirt*nbll,dcore(imem),
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis,j)
|
|
call dgemm('t','n',nbasis,nvirt,dfnbasis*nbll,-1.0d0*chfx,
|
|
$hai(cmotrf*dfnbasis*nbasis*nbll+1),dfnbasis*nbll,
|
|
$dcore(imem+(dfnbasis+1)*dfnbasis/2),dfnbasis*nbll,1.d0,
|
|
$rma(1,2),nbasis)
|
|
C
|
|
return
|
|
end
|
|
************************************************************************
|
|
subroutine gammacont(dfnbasis,nbll,nbasis,nocc,dcore,ibij,
|
|
$mo,hai,ltdhf,hailen)
|
|
************************************************************************
|
|
implicit none
|
|
integer ibij,dfnbasis,nbll,nocc,nbasis,hailen
|
|
logical ltdhf
|
|
real*8 dcore(*),mo(nbasis,*),hai(hailen),factor
|
|
C
|
|
factor=1.d0
|
|
if(ltdhf) factor=0.5d0
|
|
C
|
|
hai=0.d0
|
|
C CCcc
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,factor,
|
|
$dcore(ibij),dfnbasis*nbll,mo(1,nbasis+1),nbasis,1.d0,hai,
|
|
$dfnbasis*nbll)
|
|
C CccC
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,factor,
|
|
$dcore(ibij+dfnbasis*nbll*nocc),dfnbasis*nbll,mo(1,nbasis+1),
|
|
$nbasis,1.d0,hai(dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
C CCXC
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,0.25d0,
|
|
$dcore(ibij),dfnbasis*nbll,mo(1,2*nbasis+1),
|
|
$nbasis,1.d0,hai(dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
C cCCc
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,factor,
|
|
$dcore(ibij+4*dfnbasis*nbll*nocc),dfnbasis*nbll,mo,
|
|
$nbasis,1.d0,hai,dfnbasis*nbll)
|
|
C ccCC
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,factor,
|
|
$dcore(ibij+3*dfnbasis*nbll*nocc),dfnbasis*nbll,mo,
|
|
$nbasis,1.d0,hai(dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
C CCCX
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,0.25d0,
|
|
$dcore(ibij),dfnbasis*nbll,mo,
|
|
$nbasis,1.d0,hai(2*dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
C XCCC
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,0.25d0,
|
|
$dcore(ibij+5*dfnbasis*nbll*nocc),dfnbasis*nbll,mo,
|
|
$nbasis,1.d0,hai(dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
C CXCC
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,0.25d0,
|
|
$dcore(ibij+2*dfnbasis*nbll*nocc),dfnbasis*nbll,mo,
|
|
$nbasis,1.d0,hai(dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
if(ltdhf) then
|
|
C CccC
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,factor,
|
|
$dcore(ibij+6*dfnbasis*nbll*nocc),dfnbasis*nbll,mo(1,3*nbasis+1),
|
|
$nbasis,1.d0,hai(dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
C cCCc
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,factor,
|
|
$dcore(ibij+7*dfnbasis*nbll*nocc),dfnbasis*nbll,mo,
|
|
$nbasis,1.d0,hai(3*dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
C CCcc
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,factor,
|
|
$dcore(ibij),dfnbasis*nbll,mo(1,3*nbasis+1),nbasis,1.d0,
|
|
$hai(3*dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
C ccCC
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,factor,
|
|
$dcore(ibij+8*dfnbasis*nbll*nocc),dfnbasis*nbll,mo,
|
|
$nbasis,1.d0,hai(dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
C CcCc (tilde)
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,factor,
|
|
$dcore(ibij+dfnbasis*nbll*nocc),dfnbasis*nbll,mo,
|
|
$nbasis,1.d0,hai,dfnbasis*nbll)
|
|
C cCcC (tilde)
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,factor,
|
|
$dcore(ibij+4*dfnbasis*nbll*nocc),dfnbasis*nbll,mo(1,nbasis+1),
|
|
$nbasis,1.d0,hai(dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
C CcCc
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,-factor,
|
|
$dcore(ibij+6*dfnbasis*nbll*nocc),dfnbasis*nbll,mo,
|
|
$nbasis,1.d0,hai(3*dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
C cCcC
|
|
call dgemm('n','t',dfnbasis*nbll,nbasis,nocc,-factor,
|
|
$dcore(ibij+7*dfnbasis*nbll*nocc),dfnbasis*nbll,mo(1,3*nbasis+1),
|
|
$nbasis,1.d0,hai(dfnbasis*nbasis*nbll+1),dfnbasis*nbll)
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine update_fock(nbfshmax,nilen,njlen,nocc,fock_scr,focka,
|
|
& ifrst,jfrst,xyzomp,nbasis,chfx)
|
|
************************************************************************
|
|
* Collects fock matrix contributions from different threads
|
|
* (LDF-SCF gradient only)
|
|
************************************************************************
|
|
implicit none
|
|
integer nbfshmax,nilen,njlen,nocc,xyzomp,ifrst,jfrst,nbasis
|
|
double precision focka(nbasis,nbasis)
|
|
double precision fock_scr(nbfshmax*nocc*xyzomp,2),chfx
|
|
integer i,j
|
|
|
|
do i=2,xyzomp
|
|
call daxpy(nilen*nocc,1.0d0,fock_scr(1+nilen*nocc*(i-1),1),1,
|
|
& fock_scr(1,1),1)
|
|
call daxpy(njlen*nocc,1.0d0,fock_scr(1+njlen*nocc*(i-1),2),1,
|
|
& fock_scr(1,2),1)
|
|
enddo
|
|
C$OMP PARALLEL DO
|
|
C$OMP& PRIVATE(i,j)
|
|
C$OMP& SHARED(nocc,nilen,njlen,focka,chfx,fock_scr,ifrst,jfrst)
|
|
C$OMP& SHARED(nbfshmax,nbasis,xyzomp)
|
|
do i=1,nocc
|
|
do j=1,nilen
|
|
focka(ifrst+j,i)=focka(ifrst+j,i)+
|
|
& chfx*fock_scr(j+(i-1)*nilen,1)
|
|
enddo
|
|
do j=1,njlen
|
|
focka(jfrst+j,i)=focka(jfrst+j,i)+
|
|
& chfx*fock_scr(j+(i-1)*njlen,2)
|
|
enddo
|
|
enddo
|
|
|
|
end subroutine
|
|
C
|
|
*************************************************************************
|
|
real*8 function qabcalc(sab,ijpre,zab,usq)
|
|
*************************************************************************
|
|
C Calculate prefactor for SQVl estimator
|
|
*************************************************************************
|
|
implicit none
|
|
real*8 zab,usq,ijpre,sab
|
|
real*8 dpi34,pisqr2
|
|
parameter(dpi34=3.9685778240728024992720094621189610321284d0)
|
|
parameter(pisqr2=4.44288293815836624701588099d0)
|
|
|
|
if(sab/ijpre.gt.usq) then
|
|
qabcalc=sab*dpi34
|
|
else
|
|
qabcalc=ijpre*pisqr2/zab**0.25d0
|
|
endif
|
|
|
|
return
|
|
end function qabcalc
|
|
C
|
|
***********************************************************************
|
|
subroutine l3dercenters(labc,lab,lac,lbc,lcsig,lacsig,lbcsig,l1c,
|
|
$lsig,nj,dscrmem,scrmem,ncd,ndim2,nklen,dipre2i,dipre2j,dfipre,
|
|
$natoms,nangmax,dpremat,nprimmax,ddatoms,apr,bpr,ctol,dtol,
|
|
$iatoms,jatoms,katoms)
|
|
***********************************************************************
|
|
C l3der: decide which derivatives to calculate
|
|
C when not all are significant
|
|
***********************************************************************
|
|
implicit none
|
|
logical labc,lab,lac,lbc,lcsig,lacsig,lbcsig,l1c,lsig
|
|
integer nj,dscrmem,scrmem,ncd,ndim2,nklen
|
|
integer natoms,nangmax,nprimmax,ddatoms,iatoms,jatoms,katoms
|
|
real*8 dipre2i(nprimmax**2),dipre2j(nprimmax**2)
|
|
real*8 dpremat(nprimmax**2),apr,bpr,ctol,dtol
|
|
real*8 dfipre
|
|
integer ilen
|
|
|
|
ilen=ncd*ndim2*nklen
|
|
lcsig=.false.
|
|
lbcsig=.false.
|
|
lacsig=.false.
|
|
if(apr.le.ctol.and.bpr.le.ctol) then ! only (ij|d[k]) is significant
|
|
lcsig=.false.
|
|
l1c=.true.
|
|
elseif(apr.le.ctol) then ! (d[i]j|k) is not significant
|
|
lbcsig=.true.
|
|
l1c=.true.
|
|
elseif(bpr.le.ctol) then ! (id[j]|k) is not significant
|
|
lacsig=.true.
|
|
l1c=.true.
|
|
endif
|
|
dpremat=(dipre2i+dipre2j)*dfipre
|
|
if(labc) then
|
|
if(lcsig) then
|
|
lsig=.true.
|
|
ddatoms=katoms ! compute C der explicitly
|
|
dscrmem=scrmem+2*ilen ! put C der in 3rd slot
|
|
elseif(lbcsig) then
|
|
lsig=.true.
|
|
ddatoms=jatoms ! compute B der explicitly
|
|
dpremat=dipre2j*dfipre
|
|
dscrmem=scrmem+ilen ! put B der in 2nd slot
|
|
nj=3 ! put C der in 3rd slot
|
|
elseif(lacsig) then
|
|
lsig=.true.
|
|
ddatoms=iatoms ! compute A der explicitly
|
|
dpremat=dipre2i*dfipre
|
|
dscrmem=scrmem ! put A der in 1st slot
|
|
nj=3 ! put C der in 3rd slot
|
|
endif
|
|
elseif(lab) then
|
|
l1c=.true.
|
|
lsig=.true.
|
|
ddatoms=katoms ! compute C der explicitly
|
|
dscrmem=scrmem+ilen ! put C der in 2nd slot
|
|
nj=1 ! put A der in 1st slot
|
|
elseif(lac) then
|
|
l1c=.true.
|
|
lsig=.true.
|
|
ddatoms=jatoms ! compute B der explicitly
|
|
dpremat=dipre2j*dfipre
|
|
dscrmem=scrmem+ilen ! put B der in 2nd slot
|
|
nj=1 ! put A der in 1st slot
|
|
elseif(lbc) then
|
|
l1c=.true.
|
|
lsig=.true.
|
|
ddatoms=iatoms ! compute A der explicitly
|
|
dpremat=dipre2i*dfipre
|
|
dscrmem=scrmem ! put A der in 1st slot
|
|
nj=2 ! put B der in 2nd slot
|
|
endif
|
|
dpremat = dpremat*dtol
|
|
|
|
return
|
|
end
|
|
C
|
|
***********************************************************************
|
|
subroutine print_scrrat_deri(iout,alldERI,screendERI)
|
|
***********************************************************************
|
|
C Print screening ratio for two-electron integral derivatives
|
|
***********************************************************************
|
|
implicit none
|
|
character*30 callderi,cscrderi
|
|
character*10 cscrratio
|
|
integer iout,alldERI,screendERI
|
|
|
|
write(iout,*)
|
|
write(iout,*)
|
|
$"Screening ratio for two-electron integral derivatives:"
|
|
write(cscrderi,"(I30)") alldERI-screendERI
|
|
write(callderi,"(I30)") alldERI
|
|
write(cscrratio,"(f10.2)")
|
|
$100*dfloat(alldERI-screendERI)/dfloat(alldERI)
|
|
write(iout,*)
|
|
$trim(adjustl(cscrratio))//"% of dERIs screened out ("//
|
|
$trim(adjustl(cscrderi))//" / "//trim(adjustl(callderi))//")"
|
|
write(iout,*)
|
|
|
|
return
|
|
end
|
|
C
|
|
***********************************************************************
|
|
integer function ndERIsd(natoms,iatoms,jatoms,dfnatrange,ndim2,
|
|
$lab)
|
|
***********************************************************************
|
|
C Calculate number of nonzero three-center two-electron
|
|
C integral-derivatives for a shell doublet
|
|
***********************************************************************
|
|
implicit none
|
|
integer natoms,iatoms,jatoms,dfnatrange(2,natoms),ndim2
|
|
logical lab
|
|
integer dfbnum,ndd,katoms
|
|
|
|
ndERIsd=0
|
|
do katoms=1,natoms
|
|
dfbnum=dfnatrange(2,katoms)-dfnatrange(1,katoms)
|
|
if(lab) then ! iatoms.eq.jatoms
|
|
if(katoms.ne.iatoms) then
|
|
ndd=2 ! A and C derivatives
|
|
else
|
|
ndd=0 ! A=B=C: all derivatives zero
|
|
endif
|
|
else
|
|
if(katoms.eq.iatoms.or.katoms.eq.jatoms) then
|
|
ndd=2 ! B and C or A and C derivatives
|
|
else
|
|
ndd=3 ! A, B, and C derivatives
|
|
endif
|
|
endif
|
|
ndERIsd = ndERIsd + ndim2*dfbnum*3*ndd
|
|
enddo
|
|
|
|
return
|
|
end function ndERIsd
|
|
C
|
|
***********************************************************************
|
|
real*8 function getsdpre(ia,i,ja,j,nsh,shupto,sdpre)
|
|
***********************************************************************
|
|
C Return maximum overlap derivative for a shell doublet
|
|
***********************************************************************
|
|
implicit none
|
|
integer shupto(*),shid,nsh
|
|
real*8 sdpre(nsh,nsh)
|
|
integer ia,i,ja,j
|
|
|
|
getsdpre = sdpre(shid(ia,i,shupto),shid(ja,j,shupto))
|
|
|
|
return
|
|
end function getsdpre
|
|
***********************************************************************
|