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

4032 lines
166 KiB
Fortran
Raw Blame History

************************************************************************
subroutine df3intn(
$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,
$focka,dpre,imem1,maxcor,thad,thcf2,
$scoord,rqqij,dfrqq,hrec,dero,datoms,dfnang,
$dfncontr,dfnprim,dfgexp,dfgcn,dfnbasis,
$dfgcoef,dfindarr,dfscr,tcdfinv,dfipre,x,
$hai,mo,nbl,xpre,hailen,nmoat,moat,moadd,dfnmobasis,ctol,
$invfile,spctostr,imo1,imo2,cpre,lnolocx,lexc,scrfile4,chfx,
$dens,intpostc,lnaf,naftol,wnaf,lintra,nocc,emapi,
$enb,edfnb,jabbl,intadd,atpair,oroute,tegrad,
$frsted,edinbl,dfadd,alladd,edfnboldi,vlni,afdom,edfmapi, !NP additional vars of Jab trf from here
$enatdom,eatdom,
$npai,pabi,tr2naf,allint,edint,
$wmat,jpq,dfnbmax,olni,dfnshrange,acteds,
$ldfpair,times,enbi,eno,mapi,at2lmo,emodom,omo,mippsh,
$edfnbi,aip,cpao,nvirt,csmax,jipsh,jpi,aotocmo,
$dfnb_old,mallpa,jpab,jqab,vlno,inaf,edi,ccprog,
$comax,cmax,pmax,cni,cmi,mipsd,ijp,gcij,dfcoralg,
$atominpcd,mukp,npaop,smukp,lmo2vlnop,nlmo,ijpcp,mooc,kpa,jabqterm! abtyp.eq.5
$,nbset,bbset,smallmem,apofci,aqofci,aipinmem,nch,chol,mooci,
$jijp,jiap,cpaob,nvb,aotocmob,enob,oslcc,iaips,docc,nva,
$og2canpao,boys,omega,rlnv,rlnvb,inbcast_group)
************************************************************************
* Three-center Coulomb integrals for DF
c if lintra=
c 2: transform AO integrals to get Jab in naftyp=jpi NAF basis (local & no screening)
c 3: transform AO integrals to get Jab, fitting in original aux basis (local & no screening)
c 4: transform AO integrals to get Jab in naftyp=jpq NAF basis
c read and transform Jai and Jij to the jpq NAF basis (local & no screening)
c 9: transform AO integrals to get Jai (local & screening)
c 10: 9 and compute Jij as well
c 11: transform AO integrals to get Jab (local & screening)
c 12: transform AO integrals to get Jab (canonical & screening, Jab is not fitted)
c 13: transform AO integrals to get Jab (local & screening & ED PAO intermediate basis)
************************************************************************
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,imo1,imo2
integer nicontr,niprim,nicart,njcontr,njprim,njcart,nispher,nmboys
integer scrfile4,dens,it7,icd,kfrst,klast,nklen
integer tedatfile,nbasis,iout,ipold,ncdbra,jprim,oroute
integer njspher,katoms,imem,dblalloc,teintfile(10)
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,nkspher,nkcontr
integer ifrst,ilast,jfrst,jlast,nbl,kspher,kcontr,scrmem
integer hailen,nmoat(natoms),moat(natoms,nbl),dfnbasis
integer nkmos,invfile,nmcrt,iacrt,ifltln
integer moadd(*),dfnmobasis(nbl)
integer intpostc(3,(nbasis+1)*nbasis/2)
integer intpos(3,(nbasis+1)*nbasis/2),i2,iii,jjj
integer dfnang(natoms),dfncontr(0:nangmax,natoms)
integer dfnprim(0:nangmax,natoms),nilen,njlen
integer dfgcn(2,ncontrmax,0:nangmax,natoms)
integer dfindarr(natoms,0:nangmax,ncontrmax,nsphermax),nafroute
real*8 dfgexp(nprimmax,0:nangmax,natoms),dfscr(*) !dfscr(nbfshmax**3*xyzomp)
real*8 x(dfnbasis),cf
real*8 dfgcoef(nprimmax,ncontrmax,0:nangmax,natoms),ijpre,ctol
real*8 tcdfinv(dfnbasis,dfnbasis),dfipre(natoms,0:nangmax)
real*8 cpre(natoms,0:nangmax),chfx,omega
c real*8 dtol,icpre
real*8 hrec(4*nangmax,nprimmax,0:nangmax,natoms),ddot,ijcpre
real*8 focka(nbasis,nbasis),tegrad(3),etol
real*8 xpre(natoms,0:nangmax)
real*8 gexp(nprimmax,0:nangmax,natoms),coord(3,natoms)
real*8 gcoef(nprimmax,ncontrmax,0:nangmax,natoms)
real*8 ax,bx,ay,by,az,bz,cx,cy,cz,itol
real*8 ctostr(ncartmax**2,0:nangmax),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 dpre(natoms,0:nangmax,natoms,0:nangmax)
real*8 scoord(3,natoms,natoms,0:nangmax+1)
real*8 rqqij(4*nangmax+1+dero,nprimmax,nprimmax)
real*8 dfrqq(4*nangmax+1+dero,nprimmax,0:nangmax,natoms)
real*8 mo(nbasis,*),spctostr(3*ncartmax**2+1,0:nangmax)
real*8 hai(*)!,hai(dfnbasis,nbasis,nbl)
real*8 naftol,wnaf(dfnbasis,dfnbasis)
logical cartg,logjc,lhrr,lsave,llexc,lnaf
logical abcdl,jgi,lexc,lnolocx,lsep,diskints4cc
c parameter(pi=3.14159265358979323846264338327950288419716939938d0)
integer nmax1
integer iangmax,jangmax,kangmax
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*4 i4core(*),isyev
integer nkcart,nkprim !NP
equivalence(isyev,iisyev) !For Intel
equivalence(ss,ssi)
character*4 intalg,ccprog
character*8 dfalg,dfcoralg,lccoporder,ccsdalg
character*16 cscr16
c for aIP (and jIP) transformation in one ED
integer ldfpair(natoms,natoms)
real*8 times(6,0:100)
logical ltrfs,ltrfns,pscr,ltrfsai,ltrfsab,smallmem,aipinmem
c for lintra 9/10: aIP (and jIP) transformation in one ED
real*8 omo(*),mippsh(*),aip(*),cpao(*),jipsh,jpi(*),aotocmo
integer p2,emodom(nocc),mapi(nbasis,nocc),nvirt
integer at2lmo(natoms,0:nocc),edfnbi
integer mno,nno,enbi,eno,pp,pm,pn,jj,jo,p1
integer tn,tm,nch
real*8 cimax,cjmax,pimax,pjmax,aipest,pshmax,chol(*),mooci(*)
real*8 csmax(eno,0:nangmax,natoms),esti,estj,apofci(*),aqofci(*)
real*8 comax(0:nangmax,natoms),cmax(0:nangmax,natoms)
real*8 pmax(0:nangmax,natoms),cmi(nbfshmax*eno,*)
real*8 mipsd(nbfshmax**2*eno,*),cni(nbfshmax*eno,*)
c in stack
integer mlist(eno),nlist(eno)
c for lintra 11, screened Jab trf in one ED
integer dfnb_old,inaf,edi
c integer fact,ints(10)
real*8 mallpa(*),jpab(*),jqab(*),vlno(*),jijp,jiap
c for lintra 13 screened Jab trf in one ED through EDPAOs
integer nlmo,atominpcd(2,natoms),npaop,smukp
real*8 ijpcp,lmo2vlnop,mooc(*),kpa,mukp,jabqterm
C For local integral transformation of Jab in blocks of EDs
integer lintra,nocc,emapi(nbasis),enb(nocc)
integer atpair(natoms,natoms),edfmapi(dfnbasis)
integer dfnshrange(2,0:nangmax,natoms)
integer frsted,edinbl,dfadd(nocc),edfnboldi(nocc),vlni(nocc)
integer alladd,iocc,edfnb(nocc),intadd(nocc),allintp
integer eatdom,enatdom,dfnbmax,olni(nocc),afdom,acteds(nocc)
real*8 npai,pabi,jabbl(*),allint(*),edint,jpq
real*8 wmat(max(2*dfnbmax**2,32)),tr2naf(dfnb_old,*)
character*16 ilmoname,jname,filename
integer xyzomp,idfscr,n1crtm,ijsm
c db
real*8 twftrf,tcftrf,twdg,tcdg,twdax,tcdax
real*8 tcjpq0,tcjpq,twjpq0,twjpq
c db
c logkc
logical logkc
integer ia
c uncontracted
integer kp(nprimmax),gc1,ijang,ijatoms,var_c
integer ijp(nprimmax,0:nangmax,natoms)
real*8 gck(nprimmax,ncontrmax)
real*8 gcij(nprimmax,ncontrmax,0:nangmax,natoms)
c Gyula
integer bbset ! bbset'th basis set for the bra side
integer nbset,nangmaxv(nbset),ijangmax,bsm,d
logical lbragen,lketgen,ldprim,lsep2,l1der,lrange
real*8 dpremat(nprimmax**2),rdummy
c
real*8 c,cc
c SB oslcc
integer nvb,enob,iaips,osxmem,nva,ijaba,ijabbuff1,ijabbuff2
integer nvmax,rlnv,rlnvb
real*8 cpaob(*),aotocmob,og2canpao(*)
logical oslcc,docc,inbcast_group
C For OpenMP
integer iimem,iit7
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
#if defined (OMP)
integer OMP_GET_THREAD_NUM,omplen,OMP_GET_NUM_THREADS
logical omp_get_nested
!$OMP PARALLEL
C$OMP& DEFAULT(SHARED)
xyzomp=OMP_GET_NUM_THREADS()
!$OMP END PARALLEL
#ifdef Intel
# if __INTEL_COMPILER >= 1910
call omp_set_max_active_levels(1)
# else
call omp_set_nested(.false.)
# endif
#else
call omp_set_nested(.false.)
#endif
#else
xyzomp=1
tn=1
tm=0
#endif
c Gyula
call getvar('nangmaxv ',nangmaxv)
c
!NP
c db
twftrf=0.d0
tcftrf=0.d0
twdg=0.d0
tcdg=0.d0
twdax=0.d0
tcdax=0.d0
c db
nvmax=nvirt
if (oslcc) nvmax=max(nva,nvb)
dfnbasis_new=dfnbasis
ltrfsai=lintra.eq.9.or.lintra.eq.10 ! screening for Jai (and Jij)
ltrfsab=lintra.eq.11.or.lintra.eq.12.or.lintra.eq.13 ! screening for Jab
ltrfs=ltrfsai.or.ltrfsab
ltrfns=lintra.eq.2.or.lintra.eq.3.or.lintra.eq.4 ! do not screen integrals
pscr=ltrfns.and..not.ltrfs
c write(*,*) 'lintra,ltrfs,pscr',lintra,ltrfs,pscr
c write(*,*) 'ltrfsab,ctol',ltrfsab,ctol
if(ltrfs)
$call prescrmo(cmax,pmax,natoms,nangmax,nang,atpair,enbi,
$eno,nvirt,csmax,omo,cpao,at2lmo,nocc,emodom,moadd,mapi,
$nbasis,nshrange,emapi,aotocmo,comax,ltrfsai,vlno,ltrfsab,lintra,
$cpaob,nvb,aotocmob,enob,oslcc)
c keepit ints=0
c db
llexc=lexc.and.(iroute.eq.2.or.iroute.eq.4.or.iroute.eq.5)
lsave=iroute.eq.1.or.lnolocx
call getifltln(ifltln)
if (lintra.eq.12) then
if(omega.eq.0.d0) then
open(111,file='DFINT_AB',access="direct",
$recl=(nvirt+1)*nvirt/2*ifltln)
else
open(111,file='DFINT_AB_RS',access="direct",
$recl=(nvirt+1)*nvirt/2*ifltln)
endif
endif
c lsave=.true.
c write(6,*) 'szemet',lsave
if(llexc) then
call dfillzero(hai,hailen)
c call dfillzero(cpk,nbasis)
endif
call getkey('lccoporder',10,lccoporder,8)
call getkey('ccsdalg',7,ccsdalg,8)
diskints4cc=lccoporder.eq.'trffirst'.or.ccsdalg.eq.'disk '
$ .or.oslcc
call getkey('intalg',6,intalg,4)
call getkey('dfalg',5,dfalg,8)
if(intalg.eq.'auto') intalg='os '
ncd=1
if(dero.gt.0)then
intalg='herm'
ncd=3 !szemet
c write(6,*) 'szemet!!!szemet!!!szemet!!!szemet!!!szemet!!!'
c rewind(99)
c
c ndatoms=natoms
c ldatoms=2
c dero=1
c else
c dero=0
c ndatoms=1
c ldatoms=1
endif
c write(6,*) 'szemet!!!szemet!!!szemet!!!szemet!!!szemet!!!'
c lsep=.false.
lsep=lsave.and.intalg.ne.'rys '.and..not.cartg.and.dero.eq.0
C Gyula
lsep2=dero.eq.0.and.(intalg.eq.'rys '.or.cartg) ! df_primcalc will be called for ERIs in df3int_st
ldprim=.not.lsep2.and.dero.eq.0.and.intalg.eq."herm"
lrange=.false. ! no range separated ERIs here
if(dero.eq.1) then
l1der=.true.
dpremat=1.d0 ! ERI derivative Cauchy-Schwarz prescreening is not implemented here: need to call herm_prescr_driver for prescreenig integral-derivatives
endif
C
C Allocate memory for integrals (Do not allocate memory before!)
c write(6,*)dero
c ndim1=nbfshmax**2
c if(iroute.eq.1) ndim1=(nbasis-1)*nbasis+1
ndim1=nbfshmax
ndim2=ndim1*nbfshmax
ndim3=ndim2*nbfshmax
c i=3*ncd*ndim3
c if(mod(i,2).eq.1) i=i+1
c intmem=dblalloc(i/2)
if(lsave) intmem=dblalloc(ncd*ndim3*xyzomp)
C Open files: TEINT, MUIP, AIPED
if(iroute.eq.1) then
call intopenw(teintfile)
if(dens.gt.0) call intopenwtc(tcintfile)
endif
write(ilmoname,'(i6)') edi
ilmoname=adjustl(ilmoname)
if ((lintra.eq.9.or.lintra.eq.10).and.smukp.eq.2) then
filename="MUIP" // '.' // trim(ilmoname)
open(103,file=trim(filename),form='UNFORMATTED') ! MUIP file for half transformed (mu_AO^PCD, I_LMO | P_aux^LDF) integrals
endif
if ((lintra.eq.9.or.lintra.eq.10).and..not.aipinmem) then
filename="AIPED" // '.' // trim(ilmoname)
open(104,file=trim(filename),ACCESS='DIRECT',RECL=nvirt*ifltln)! AIPED file to save (a^PAO I_LMO | P_aux^LDF) integrals of an ED
if (oslcc) then
filename="AIPEDb" // '.' // trim(ilmoname)
open(105,file=trim(filename),ACCESS='DIRECT',RECL=nvb*ifltln)
endif
endif !aipinmem
C
nafroute=0
if(lnaf) nafroute=1
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) call dfcaaux(natoms,dfnang,dfnprim,nangmax,dfgexp,
$nprimmax,dero,dfrqq)
nbd=dfnbasis*(nbasis+1)*nbasis/2
ipold=0
ipos=0
ipostc=0
C Marking primitives for uncontracted AOs in the ordinary basis and rescaling elements of the prim -> AO transformation matrix
do ijatoms=1,natoms
do ijang=0,nang(ijatoms)
call kpgck(gcij(1,1,ijang,ijatoms),ijp(1,ijang,ijatoms),
$gcoef(1,1,ijang,ijatoms),gcn(1,1,ijang,ijatoms),nprimmax,
$ncontrmax,ncontr(ijang,ijatoms))
enddo
enddo
c Loop over atoms
do katoms=1,natoms
cx=coord(1,katoms)
cy=coord(2,katoms)
cz=coord(3,katoms)
kangmax=dfnang(katoms)
if(lintra.gt.0) then
if(ldfpair(katoms,katoms).eq.0) kangmax=-1
endif
do kang=0,kangmax
nkspher=2*kang+1
nkcontr=dfncontr(kang,katoms)
nkcart=(kang+1)*(kang+2)/2 !NP
nkprim=dfnprim(kang,katoms) !NP
if(cartg) nkspher=(kang+1)*(kang+2)/2
nklen=nkspher*nkcontr
kfrst=dfnshrange(1,kang,katoms)
klast=dfnshrange(2,kang,katoms)
C Determining if the DF auxiliary basis is uncontracted
call df_logkc(logkc,nkprim,nkcontr,dfgcn(1,1,kang,katoms))
C Marking primitives for uncontracted AOs in the DF basis and rescaling elements of the prim -> AO transformation matrix
if(.not.logkc) call kpgck(gck,kp,dfgcoef(1,1,kang,katoms),
$dfgcn(1,1,kang,katoms),nprimmax,ncontrmax,nkcontr)
C
if (ltrfs) then
pp=edfmapi(kfrst+1)
pshmax=dfipre(katoms,kang)
endif
do kspher=1,nkspher
do kcontr=1,nkcontr
dfindarr(katoms,kang,kcontr,kspher)=
$ dfindarr(katoms,kang,kcontr,kspher)-kfrst
enddo
enddo
c if (ltrfns) then !NP
allintp=1
c db call ifillzero(alladd,nbasis*(nbasis+1)/2)
c endif
do iiatoms=1,natoms
iangmax=nang(iiatoms)
if(lintra.gt.0) then
if(ldfpair(katoms,iiatoms).eq.0) iangmax=-1
endif
do iiang=0,iangmax
ifrst=nshrange(1,iiang,iiatoms)
ilast=nshrange(2,iiang,iiatoms)
nilen=ilast-ifrst
pm=emapi(ifrst+1) ! irrelevant if ltrfns and emapi(nbasis,nocc)
if(ltrfsai) then
cimax=cmax(iiang,iiatoms)
pimax=pmax(iiang,iiatoms)
c if lintra.eq.10 both AO index is transformed to both the PAO and canonical occ MO basis -> both Jai and Jij types are screened
if (lintra.eq.10) pimax=max(pimax,comax(iiang,iiatoms))
elseif(ltrfsab) then
pimax=pmax(iiang,iiatoms)
endif
c if(llexc) icpre=cpre(iiatoms,iiang)
it7=imem
#if defined (OMP)
if (dero.gt.0) stop 'OMP is not implemented for gradients'!NP
ijangmax=nangmaxv(bbset)
nmax1=2*ijangmax
nmcrt=(nmax1+1)*(nmax1+2)*(nmax1+3)/6
n1crtm=nmcrt-ijangmax*(ijangmax+1)*(ijangmax+2)/6
ijsm=(2*ijangmax+1)**2
bsm=2*ijangmax+1
call lcodegen(ijangmax,lbragen,kang,lketgen)
if(.not.(lsep2.or.ldprim).and..not.lrange) then
if(.not.lbragen.or..not.lketgen)
$ then ! general dfint routine
call intmem_dfint(nmcrt,bsm,bsm,nkspher,nmcrt*nkcart,
$ncontrmax,ncontrmax,nkcontr,kang,ijangmax,ijangmax,nprimmax,
$nprimmax,nkprim,nkcart,omplen)
else ! generated integral codes
call intmem_gen(bsm,bsm,nkspher,nkcart,n1crtm,ncontrmax,
$nkcontr,nprimmax,nprimmax,nkprim,omplen)
endif
elseif(lrange.and.lbragen.and.lketgen) then ! generated codes for range separated ERIs
call intmem_gen(bsm,bsm,nkspher,nkcart,n1crtm,ncontrmax,
$nkcontr,nprimmax,nprimmax,nkprim,omplen)
elseif(lsep2.or.(lrange.and..not.(lbragen.and.lketgen)))
$ then
omplen=0
call df_primcalc_mem(d,d,d,d,d,d,d,omplen,ijangmax.gt.0,
$intalg.eq.'rys '.and.nmax1+kang.le.40,ijangmax,ijangmax,kang,
$ncontrmax,ncontrmax,nkcontr,nprimmax,nprimmax,nkprim,cartg)
elseif(ldprim) then
omplen=0
call dprim_mem(
$d,d,d,d,d,d,d,d,d,d,d,d,d,dero,omplen,ijangmax,ijangmax,kang,0,
$1,1,nkprim,nkcontr,nprimmax,ncontrmax,nprimmax,ncontrmax,.false.)
endif
#endif
C$OMP PARALLEL DO if(lsep) Schedule(Dynamic) Default(Shared)
C$OMP& PRIVATE(jangmax,jjang,jfrst,jlast,njlen,ijcpre,ndim2,ndim3)
C$OMP& PRIVATE(jgi,iatoms,jatoms,iang,jang,i1,i2,logjc,bx,by,bz,sb2)
C$OMP& PRIVATE(nicart,nispher,njcart,njspher,ijs,nmax1,nmcrt,iacrt)
C$OMP& PRIVATE(n1crt,nicontr,niprim,njcontr,njprim,iian,jjan,ijpre)
C$OMP& PRIVATE(lhrr,iimem,nkmos,abcdl,etol,tn,tm)
C$OMP& PRIVATE(jjatoms,ax,ay,az,iit7,idfscr,scrmem)
C$OMP& PRIVATE(nno,nlist,mno,mlist,jj,jjj,jo,p1,p2,pn) ! variables for ltrfs=.true.
C$OMP& PRIVATE(aipest,cjmax,pjmax,esti,estj) ! variables for ltrfs=.true.
c C$OMP& PRIVATE(dfscr,omplen)
c if (dero.gt.0) C$OMP& PRIVATE(iprim,jprim,rqqij,i)
do jjatoms=1,iiatoms
jangmax=nang(jjatoms)
if(iiatoms.eq.jjatoms) jangmax=iiang
if(lintra.gt.0) then
if(atpair(iiatoms,jjatoms).eq.0.and.
$ atpair(jjatoms,iiatoms).eq.0) jangmax=-1 ! atpair can be asymmetric (e.g. inttyp=30)
endif
c if(dero.gt.0.and.iiatoms.ne.datoms.and.
c $jjatoms.ne.datoms.and.katoms.ne.datoms) jangmax=-1
scrmem=1
do jjang=0,jangmax
c keepit if(ltrfs) call time0(times)
jfrst=nshrange(1,jjang,jjatoms)
jlast=nshrange(2,jjang,jjatoms)
njlen=jlast-jfrst
c if(llexc) ijcpre=max(icpre,cpre(jjatoms,jjang))
c keepit !$OMP CRITICAL (int)
c keepit if (iiatoms.eq.jjatoms.and.iiang.eq.jjang) then
c keepit ints(1)=ints(1)+nilen*(nilen+1)/2*nklen
c keepit fact=1
c keepit else
c keepit ints(1)=ints(1)+nilen*njlen*nklen
c keepit fact=2
c keepit endif
c keepit if (ltrfsai) then
c keepit ints(3)=ints(3)+
c keepit $ nklen*nilen*njlen*(at2lmo(jjatoms,0)+at2lmo(iiatoms,0))
c keepit endif
c keepit if (ltrfsab) then
c keepit ints(3)=ints(3)+nklen*nilen*njlen*nvirt*fact ! total number of (P|mu,a) integrals
c keepit endif
c keepit !$OMP END CRITICAL (int)
if (ltrfs) then
ijpre=ipre(jjatoms,jjang,iiatoms,iiang)
pjmax=pmax(jjang,jjatoms)
endif
if(ltrfsai) then
cjmax=cmax(jjang,jjatoms)
if(lintra.eq.10)pjmax=max(pjmax,comax(jjang,jjatoms))
aipest=ijpre*pshmax*max(cimax*pjmax,cjmax*pimax) ! estimate for (P|ai) [and (P|ij)]
elseif(ltrfsab) then
aipest=ijpre*pshmax*pimax*pjmax ! estimate for (P|ab)
elseif(.not.ltrfs) then
aipest=1000000.d0*ctol
endif
c write(*,"('aipest',3i4,5f12.6)") ifrst,jfrst,kfrst,
c $ aipest,ijpre,pshmax,pimax,pjmax
if (pscr.or.((aipest.ge.ctol).and.ltrfs)) then ! prescreening
C Swap integral order
jgi=jjang.gt.iiang
if(jgi) then
iatoms=jjatoms
jatoms=iiatoms
iang=jjang
jang=iiang
i1=2
i2=1
else
iatoms=iiatoms
jatoms=jjatoms
iang=iiang
jang=jjang
i1=1
i2=2
endif
ndim2=nilen*njlen
ndim3=ndim2*nklen
c keepit !$OMP CRITICAL (int2)
c keepit if (iiatoms.eq.jjatoms.and.iiang.eq.jjang) then
c keepit ints(2)=ints(2)+nilen*(nilen+1)/2*nklen
c keepit fact=1
c keepit else
c keepit ints(2)=ints(2)+ndim3
c keepit fact=2
c keepit endif
c keepit if (ltrfsai) then
c keepit ints(4)=ints(4)+
c keepit $ nklen*nilen*njlen*(at2lmo(jjatoms,0)+at2lmo(iiatoms,0))
c keepit endif
c keepit if (ltrfsab) then
c keepit ints(4)=ints(4)+nklen*nilen*njlen*nvirt*fact ! number of evaluated (P|mu,a) integrals
c keepit endif
c keepit !$OMP END CRITICAL (int2)
#if defined (OMP)
c if(lsave) call dfillzero(
c $ dfscr(OMP_GET_THREAD_NUM()*nbfshmax**3+1),ncd*ndim3)
tn=OMP_GET_THREAD_NUM()
tm=tn
call dfillzero(
$ dfscr(tn*nbfshmax**3+1),ncd*ndim3)
#else
call dfillzero(dfscr,ncd*ndim3)
c if(lsave) call dfillzero(dfscr,ncd*ndim3)
#endif
logjc=iatoms.eq.jatoms.and.iang.eq.jang
abcdl=iatoms.eq.jatoms.and.iatoms.eq.katoms
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
nicontr=ncontr(iang,iatoms)
niprim=nprim(iang,iatoms)
njcontr=ncontr(jang,jatoms)
njprim=nprim(jang,jatoms)
iian=iatoms+iang*natoms
jjan=jatoms+jang*natoms
! lhrr=iang.gt.5.or.kang.gt.5.or..not.lsep
call lcodegen(iang,lbragen,kang,lketgen)
lhrr=.not.ldprim.and.
$(.not.lbragen.or..not.lketgen.or.lsep2)
pn=emapi(jfrst+1) ! irrelevant if ltrfns and emapi(nbasis,nocc)
if (ltrfsai) then
estj=ijpre*pshmax*pimax
nno=0
do jo=1,at2lmo(jjatoms,0)
jj=at2lmo(jjatoms,jo) ! which lmo has contribution from bf's on atom iatoms (index in ED_i)
if (estj*csmax(jj,jjang,jjatoms).ge.ctol) then ! screening (muIP) trf
nno=nno+1
nlist(nno)=jj
p2=(nno-1)*njlen
jjj=emodom(jj) ! absolute index of jj
p1=moadd(jj)+mapi(jfrst+1,jjj)
cni(p2+1:p2+njlen,tm+1)=omo(p1:p1+njlen-1)
endif
enddo
esti=ijpre*pshmax*pjmax
mno=0
do jo=1,at2lmo(iiatoms,0)
jj=at2lmo(iiatoms,jo) ! which lmo has contribution from bf's on atom iatoms (index in ED_i)
if (esti*csmax(jj,iiang,iiatoms).ge.ctol) then ! screening (muIP) trf
mno=mno+1
mlist(mno)=jj
p2=(mno-1)*nilen
jjj=emodom(jj) ! absolute index of jj
p1=moadd(jj)+mapi(ifrst+1,jjj)
cmi(p2+1:p2+nilen,tm+1)=omo(p1:p1+nilen-1)
endif
enddo
c keepit !$OMP CRITICAL (int3)
c keepit ints(5)=ints(5)+nklen*nilen*njlen*(mno+nno)
c keepit !$OMP END CRITICAL (int3)
endif ! if ltrfsai
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
c it7=imem
c if(dero.gt.0) then
c do iprim=1,niprim
c do jprim=1,njprim
c do i=1,4*nangmax+1+dero
c rqqij(i,iprim,jprim)=
c $i*1.d0/(2.d0*(gexp(iprim,iang,iatoms)+gexp(jprim,jang,jatoms)))
c enddo
c enddo
c enddo
c endif
C Construct the horizontal transformation matrix for the bra side
if(lhrr) then
#if defined (OMP)
iit7=imem+(3*n1crtm*ijsm+1)*tn
iimem=imem+(3*n1crtm*ijsm+1)*xyzomp+! memory for it7 of all threads
$ n1crtm*ijsm*tn
#else
iit7=it7
iimem=imem+3*n1crt*ijs+1
#endif
if(jang.gt.0) then
call genhrr(iang,jang,dcore(iimem),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(iimem),dcore(iit7),dcore(iit7),itol)
else
call dcopy(3*n1crt*ijs+1,spctostr(1,iang),1,dcore(iit7),1)
endif
c db
cc#if defined (OMP)
cc omplen=n1crt*ncartmax*(nicontr*njcontr*ncontrmax+1+
cc $nprimmax+ncontrmax*njprim+ncontrmax*njcontr*niprim)+
cc $max(nsphermax*ijs,nmcrt*max(ncartmax*(nangmax+3)/3,nmax1+nangmax))
cc $+ijs*ncartmax*nicontr*njcontr*ncontrmax
cc else
ccc if(dero.gt.0) then ...
ccc else
cc omplen=n1crt*ncartmax*(nicontr*njcontr*ncontrmax+1+
cc $nprimmax+ncontrmax*njprim+ncontrmax*njcontr*niprim)+
cc $max(nsphermax*ijs,nmcrt*max(ncartmax*(nangmax+3)/3,nmax1+nangmax))
cc#endif
c db
endif ! if(lhrr)
#if defined (OMP)
c note: can not overwrite the matrix resulting from genhrr either --> factor of 4 instead of 3
iimem=imem+(4*n1crtm*ijsm+1)*xyzomp+ ! memory for it7 of all threads
$ tn*omplen
idfscr=tn*nbfshmax**3+1 ! position to write in dfscr
#else
iimem=imem+3*n1crt*ijs+1 ! n1crt*ijs of dcore(iimem) can be overwritten
idfscr=1
#endif
c etol=1.d0
c nkmos=0
c if(llexc) then
c etol=ijcpre
c if(.not.lnolocx) then
c do l=1,nmoat(katoms)
c i=moat(katoms,l)
c if(i.ge.imo1.and.i.le.imo2) then
c nkmos=nkmos+1
c kmos(nkmos)=i
c endif
c enddo
c endif
c endif
c dtol=1.d0
c if(iroute.eq.2.and.lintra.eq.0)
c $dtol=dpre(iatoms,iang,jatoms,jang)
c if(iroute.eq.3.or.iroute.eq.4) dtol=xpre(katoms,kang)
c ss=ijpre*dfipre(katoms,kang)
c prescreen if((ss*dtol.gt.itol.and.iroute.ne.5).or.
c prescreen $ (ss*etol.gt.ctol.and.llexc).or.dero.gt.0) then
call df3int_st(iimem,iatoms,iang,jatoms,jang,katoms,kang,
$natoms,nangmax,itol,dero,
$lsep2,nicontr,njcontr,niprim,njprim,
$imem1,maxcor,dcore,iit7,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(idfscr),
$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,datoms,ncartmax,hrec,rqqij,dfrqq,ctostr,
$ncd,abcdl,scrmem,jgi,nkcart,nkspher,nkcontr,
$nkprim,logkc,
$c,cc,ijp(1,iang,iatoms),ijp(1,jang,jatoms),kp,
$gcij(1,1,iang,iatoms),gcij(1,1,jang,jatoms),gck,omega,boys,cartg,
$dpremat,l1der,.false.,ldprim,.false.,.false.,.false.,.false.,
$rdummy,rdummy,rdummy,rdummy,.false.,.false.,scrmem,0,lrange)
c imem=it7
if(lintra.eq.9.or.lintra.eq.10) then ! first AO->MO trf to the LMO basis
c call timeadd(times(1,25),times)
c call time0(times)
p1=enbi*eno*nklen*tm+1
call lmipined(nilen,njlen,nklen,mno,nno,dfscr(idfscr)
$,enbi,eno,mippsh(p1),pm,pn,cmi(1,tm+1),cni(1,tm+1),mlist,nlist,
$mipsd(1,tm+1),mipsd(1,tm+1))
c call timeadd(times(1,26),times)
elseif(ltrfsab) then ! first AO->MO trf to the virtual LNO basis
c call timeadd(times(1,32),times)
c call time0(times)
p1=enbi*nvirt*nklen*tm+1
p2=nbfshmax*nklen*nvirt*tm+1
call lmpained(nilen,njlen,nklen,nvirt,dfscr(idfscr),
$enbi,mippsh(p2),mippsh(p2),vlno,mallpa(p1),pm,pn,xyzomp)
c call timeadd(times(1,33),times)
c mippsh=mshpa
endif
if(ltrfns) then ! prescreen
!$OMP CRITICAL (stint)
c only one thread can write the shared allint, allintp and alladd variables at the same time
call storeaoint(dfscr(idfscr),allint,nklen,
$njlen,nilen,ifrst,jfrst,nbasis,alladd,allintp)
!$OMP END CRITICAL (stint)
endif !ltrfns
endif ! prescreening
enddo !jjang
enddo !jjatoms
C$OMP END PARALLEL DO
enddo !iiang
enddo !iiatoms
if(ltrfns) then
call l2monaftrf(nocc,edfnb,edfnboldi,edfmapi,lintra,
$alladd,nklen,kfrst,frsted,edinbl,acteds,npai,tr2naf,dfadd,jabbl,
$intadd,afdom,dfnbasis,mo,moadd,vlni,nbasis,emapi,enb,pabi,
$allint,edint,enatdom,eatdom,natoms,nang,nshrange,nangmax,
$tcftrf,twftrf,tcdg,twdg,tcdax,twdax)
endif !ltrfns
do kspher=1,nkspher
do kcontr=1,nkcontr
dfindarr(katoms,kang,kcontr,kspher)=
$ dfindarr(katoms,kang,kcontr,kspher)+kfrst
enddo
enddo
if (lintra.eq.9.or.lintra.eq.10) then
#if defined (OMP)
do p2=1,xyzomp-1
p1=enbi*eno*nklen*p2+1
call daxpy(enbi*eno*nklen,1.d0,mippsh(p1),1,mippsh,1)
enddo
#endif
if(smukp.ne.0) call savemukp(mippsh,enbi,eno,nklen,smukp,
$mukp,npaop,edfnbi,atominpcd,natoms,emapi,pp,103,
$mippsh(enbi*eno*nbfshmax+1)) ! save (mu k|P) for mu in PCD
call time0(times)
if (nvirt.gt.0) then
call led2ndtrf(lintra,mippsh,aip,cpao,nvirt,enbi,eno,nklen,
$edfnbi,pp,xyzomp,jipsh,jpi,aotocmo,smallmem,mooc,apofci,
$mippsh(enbi*eno*nbfshmax+1),aqofci,aipinmem,nch,chol,mooci,
$mippsh(osxmem(oslcc,enbi*eno*nbfshmax*2,0)+1),104,eno,oslcc,
$.true.,docc,eno*nvirt+osxmem(oslcc,enob*nvb,0))
endif
if (oslcc.and.enob.gt.0.and.nvb.gt.0) then
call led2ndtrf(lintra,mippsh,aip(iaips+1),cpaob,nvb,
$enbi,enob,nklen,edfnbi,pp,xyzomp,jipsh,jpi(edfnbi*eno**2+1),
$aotocmob,smallmem,mooc(eno**2+1),apofci(nvirt*edfnbi+1),
$mippsh(enbi*eno*nbfshmax+1),aqofci(edfnbi*nch*nvirt+1),aipinmem,
$nch,chol(eno*nvirt+1),mooci(eno**2+1),mippsh,105,eno,oslcc,
$.false.,docc,eno*nvirt+osxmem(oslcc,enob*nvb,0))
else
if (oslcc) call dfillzero(mippsh,nklen*eno*enbi*xyzomp)
endif !enob.gt.0.and.nvb.gt.0
c call timeadd(times(1,27),times)
elseif(ltrfsab) then
#if defined (OMP)
do p2=1,xyzomp-1
p1=enbi*nvirt*nklen*p2+1
call daxpy(enbi*nvirt*nklen,1.d0,mallpa(p1),1,mallpa,1)
enddo
#endif
c call time0(times)
call ljabtrf(enbi,nvirt,nklen,edfnbi,dfnb_old,mallpa,jpab,
$jqab,vlno,pp,xyzomp,inaf,tr2naf,lintra,dfcoralg)
c zero (mu,P^shell,a^all)
call dfillzero(mallpa,nklen*nvirt*enbi*xyzomp)
c call timeadd(times(1,34),times)
if (lintra.eq.12) then
c write the block of (P^sh,[ab]) to DFINT_AB in a transposed order: ([ab],P^sh)
call print_jab2(jpab,nvirt,nklen,111,pp)
endif
endif
C Progress monitor
if (.not.ltrfs) then
jjj=dfnbasis*(klast+1)*klast/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.ipold.ne.100) then
write(iout,"(i4,'% done.')") iii
call flush(iout)
ipold=iii
endif
endif
enddo !kang
enddo !katoms
!NP
if(lintra.eq.4) then
c compute NAFs using Jai, Jij and Jab integrals, perform AF -> NAF trf
c on Jai, Jij and Jab integral types and print them for ccsd.f
call ido(tcjpq0,twjpq0)
call jpqnaf(nocc,edfnboldi,frsted,edinbl,tr2naf,dfadd,jabbl,
$intadd,vlni,olni,wmat,wmat(dfnbmax**2+1),jpq,naftol,ccprog,edi,
$lintra,dfcoralg,diskints4cc,dcore,dcore,edfnbi,oslcc,nvb,
$.true.,nva,og2canpao,iout,rlnv,rlnvb,inbcast_group)
call idoadd(tcjpq,twjpq,tcjpq0,twjpq0)
endif !lintra.eq.4
jname='DFINT_AB'
if(lintra.eq.2.or.lintra.eq.3) then
c write jab's of the block
do iocc=frsted,frsted+edinbl-1
write(ilmoname,'(i6)') iocc
ilmoname=adjustl(ilmoname)
filename=trim(jname) // '.' // trim(ilmoname)
open(111,file=filename,form='unformatted')
call print_jab(jabbl(intadd(iocc)+1),vlni(iocc),
$ edfnb(iocc),111)
close(111)
enddo
elseif (lintra.eq.11.or.lintra.eq.13) then
if (lintra.eq.13) then ! add the mukP and klP dependent (2)-(4) terms to term (1) at jqab
call edpao2vlnoterms(jqab,nvirt,dfnb_old,lmo2vlnop,nlmo,ijpcp,
$kpa,mooc,vlno,vlno,kpa,jabqterm,inaf,tr2naf,dfcoralg,oslcc,docc,
$nvb)
elseif(lintra.eq.11.and.dfcoralg.eq."lineq ".and.inaf.eq.0)
$then
c fitting of Jab only here, since the complete list is needed for lineq fitting
call dtrsm('l','l','n','n',dfnb_old,nvirt*(nvirt+1)/2,1.d0,
$tr2naf,dfnb_old,jqab,dfnb_old)
endif
if (inaf.eq.0.or.inaf.eq.1) then
if (oslcc) then
c {{{ Transform Jab to canonical basis
! Transform J_ab to alpha canonical basis
ijaba=1+rlnvb*(rlnvb+1)*edfnbi/2
ijabbuff1=ijaba+nva*(nva+1)*edfnbi/2
ijabbuff2=ijabbuff1+rlnvb**2
call restricted2can_jab(edfnbi,rlnv,rlnvb,nva,jqab,
& jqab(ijaba),og2canpao,edi,jqab(ijabbuff1),jqab(ijabbuff2),
& 'DFINT_AB. ')
call restricted2can_jab(edfnbi,rlnvb,rlnvb,nvb,jqab,
& jqab,og2canpao(rlnv*nva+1),edi,jqab(ijabbuff1),
& jqab(ijabbuff2),'DFINT_ABb.')
c }}}
endif !oslcc
if (diskints4cc) then
c write Jab to disk
c if (.not.oslcc) then !if oslcc: write is done in ldrpa.f
write(ilmoname,'(i6)') edi
ilmoname=adjustl(ilmoname)
filename=trim(jname) // '.' // trim(ilmoname)
open(111,file=filename,form='unformatted')
call print_jab(jqab(osxmem(oslcc,ijaba,1)),
& osxmem(oslcc,nva,nvirt),edfnbi,111)
close(111)
if (oslcc) then
filename='DFINT_ABb.' // trim(ilmoname)
open(111,file=filename,form='unformatted')
call print_jab(jqab,osxmem(oslcc,nvb,nvirt),edfnbi,111)
close(111)
endif !oslcc
endif
elseif(inaf.eq.2) then
c construct Jpq NAFs and trf (pq,P) integrals to the NAF basis
call jpqnaf(nocc,dfnb_old,1,1,tr2naf,0,jqab,0,nvirt,eno,
$wmat,wmat(dfnb_old**2+1),
$jqab(dfnb_old*(rlnvb*(rlnvb+1)/2+osxmem(oslcc,nva*(nva+1)/2,0))
$+1),naftol,ccprog,edi,lintra,dfcoralg,diskints4cc,jijp,jiap,
$edfnbi,oslcc,nvb,docc,nva,og2canpao,iout,rlnv,rlnvb,inbcast_group)
endif
elseif (lintra.eq.12) then
close(111)
endif
if ((lintra.eq.9.or.lintra.eq.10).and.smukp.eq.2) close(103) ! close MUIP file
if ((lintra.eq.9.or.lintra.eq.10).and..not.aipinmem) then
close(104) ! close AIPED file
if (oslcc) close(105)
endif
c db
c keepit write(*,*) '(mu,nu,P): total, noscr , eval , %'
c keepit write(*,'(3i18,f8.2)') enbi*(enbi+1)/2*dfnb_old,ints(1),ints(2),
c keepit $ dble(ints(2))/ints(1)*100.d0
c keepit if(ltrfsai) then
c keepit write(*,*) '(mu,I,P) comp N: naive, total, intscr , trfscr, %, %'
c keepit write(*,'(4i18,2f8.2)') enbi**2*edfnbi*eno,ints(3:5),
c keepit $ dble(ints(4))/ints(3)*100.d0,dble(ints(5))/ints(3)*100.d0
c keepit endif
c keepit if (ltrfsab) then
c keepit write(*,*) '(P|mu,a) N of operations: theor, total, intscr %, %'
c keepit write(*,'(3i18,2f8.2)') enbi**2*dfnb_old*nvirt,ints(3:4),
c keepit $ dble(ints(4))/ints(3)*100.d0
c keepit endif
if(ltrfns) then
write(iout,*) 'time for the first MO trf'
write(iout,"(' CPU time [min]: ',f9.3,
$' Wall time [min]: ',f9.3)") tcftrf/60.d0,twftrf/60.d0
write(iout,*) 'time for second MO trf'
write(iout,"(' CPU time [min]: ',f9.3,
$' Wall time [min]: ',f9.3)") tcdg/60.d0,twdg/60.d0
write(iout,*) 'time for sorting integrals of the ED'
write(iout,"(' CPU time [min]: ',f9.3,
$' Wall time [min]: ',f9.3)") tcdax/60.d0,twdax/60.d0
if(lintra.eq.4) then
write(iout,*) 'time for the NAF construction and trf'
write(iout,"(' CPU time [min]: ',f9.3,
$' Wall time [min]: ',f9.3)") tcjpq/60.d0,twjpq/60.d0
endif
endif !lintra.eq.2.or.lintra.eq.3.or.lintra.eq.4
c db
!NP
c {{{ rest of df3intn
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)
c write(6,"(10000f12.6)") (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.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
if(lsave.or.oroute.ge.2) call dbldealloc(intmem)
C Calculate exchange
c write(6,*) 'focka1'
c write(6,"(4f15.10)") focka
if(llexc) then
c write(6,*) 'hai'
c if(oroute.eq.2) then
c write(6,"(10000f16.10)")
c $(dsqrt(2.d0)*hai(i),i=1,ncd*dfnbasis*nbl*nbasis)
c else
c write(6,"(10000f16.10)") (hai(i),i=1,ncd*dfnbasis*nbl*nbasis)
c endif
call timer
write(iout,*)
if(oroute.eq.2) then
C Intermediate for gradient
write(iout,*) 'Fitting step of exchange...'
c hai(dfnbasis,nbl,nbasis)
ifrst=imo1-1
ndim3=(2*ifrst+nbl+1)*nbl/2
intmem=dblalloc(dfnbasis*ndim3)
call sechalf(ifrst,dfnbasis,dfnbasis,nbl,nbasis,hai,
$dcore(intmem),mo,.false.,0.d0,1,1)
C
open(scrfile4,file='DFINV',form='UNFORMATTED')
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)
close(scrfile4)
call dsymm('l','l',dfnbasis,ndim3,1.d0,dcore(imem),dfnbasis,
$dcore(intmem),dfnbasis,0.d0,hai,dfnbasis)
write(invfile) imo1,imo2,nbl
write(invfile) (hai(i),i=1,dfnbasis*ndim3)
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
write(iout,*) 'Fitting and assembly step of exchange...'
ifrst=imo1-1
ndim3=(2*ifrst+nbl+1)*nbl/2
intmem=dblalloc(dfnbasis*ndim3)
do icd=0,ncd-1
call sechalf(ifrst,dfnbasis,dfnbasis,nbl,nbasis,
$hai(icd*dfnbasis*nbl*nbasis+1),dcore(intmem),mo,.false.,0.d0,1,1)
call dcopy(dfnbasis*ndim3,dcore(intmem),1,
$hai(icd*dfnbasis*ndim3+1),1)
enddo
read(invfile) i,j,k
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
call dbldealloc(intmem)
else
C HF exchange
write(iout,*) 'Fitting and assembly step of exchange...'
if(lnolocx) then
open(scrfile4,file='DFINV',form='UNFORMATTED')
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)
close(scrfile4)
c write(6,"(7f10.5)") (hai(i),i=1,hailen)
if(dfalg.eq.'cholesky') then
call dtrmm('l','l','t','n',dfnbasis,nbasis*nbl,1.d0,
$dcore(imem),dfnbasis,hai,dfnbasis)
c call dsyrk('l','t',nbasis,dfnbasis*nbl,chfx,hai,
call dsyrk('u','t',nbasis,dfnbasis*nbl,chfx,hai,
$dfnbasis*nbl,1.d0,focka,nbasis)
else
call dsymm('l','l',dfnbasis,nbasis*nbl,1.d0,dcore(imem),
$dfnbasis,hai,dfnbasis,0.d0,dcore(imem+dfnbasis**2),dfnbasis)
call dsyrk('u','t',nbasis,dfnbasis*nbl,chfx,
$dcore(imem+dfnbasis**2),dfnbasis*nbl,1.d0,focka,nbasis)
endif
else
do i=imo1,imo2
call dfexc(nbasis,dfnmobasis(i),hai(moadd(i)+1),focka,
$dcore(imem),invfile,chfx)
enddo
endif
endif
endif
C
c write(6,*) 'focka2'
c write(6,"(1000000f10.5)") focka
C
return
end subroutine df3intn
c }}}
c }}}
!NP
c{{{ subroutine storeaoint
************************************************************************
subroutine storeaoint(dfscr,allint,nklen,njlen,nilen,
$ifrst,jfrst,nbf,alladd,allintp)
************************************************************************
* Store (mu^shell,nu^shell,P^shell) to (nu^allinblock,mu^allinblock,P^shell)
* expand symmetry in case of mu=nu before storage
************************************************************************
implicit none
integer nbf,i,j,alladd(nbf*(nbf+1)/2)
integer nklen,njlen,nilen,ifrst,jfrst,ij,allintp
real*8 dfscr(nilen,njlen,nklen),allint(*)
ij=jfrst*(nbf-1)-jfrst*(jfrst-1)/2+ifrst+1 ! position in alladd, lower triang struct
if (1+ifrst.eq.1+jfrst) then
c fill in the upper triangle of dfscr
do i=1,nilen
do j=i+1,njlen
call dcopy(nklen,dfscr(j,i,1),nilen*njlen,
$ dfscr(i,j,1),nilen*njlen)
enddo
enddo
endif
call dcopy(nilen*njlen*nklen,dfscr,1,allint(allintp),1)
alladd(ij)=allintp ! starting position of the actual shell triplet in allint
allintp=allintp+nilen*njlen*nklen
return
end
c }}}
c
c{{{ subroutine l2monaftrf
************************************************************************
subroutine l2monaftrf(nocc,edfnbi,edfnboldi,edfmapi,lintra,
$alladd,nklen,kfrst,frsted,edinbl,acteds,npai,tr2naf,dfadd,jabbl,
$intadd,afdom,dfnbasis,mo,moadd,vlni,nbf,emapi,enbi,pabi,
$allint,edint,enatdom,eatdom,natoms,nang,nshrange,nangmax,
$tcftrf,twftrf,tcdg,twdg,tcdax,twdax)
************************************************************************
* 1) sort (mu,nu,P) of ED'i from all (mu,nu,P) integrals of the block,
* 2) transform (mu,nu,P) to (nu,P,a) and (P^shell,ab^i)
* 3) transform (P^shell,ab^i) for all ED_i in block to the NAF basis and
* add the contributions into (Q^i,a^i,b^i) for all ED_i in block
************************************************************************
implicit none
integer nocc,intadd(nocc),dfadd(nocc),moadd(nocc)
integer kfrst,p,d,kocc,pp,p2,nklen,lintra,ab,dfnbasis
integer frsted,edinbl,acteds(nocc),nacted,afdom(0:nocc,dfnbasis)
integer edfnbi(nocc),edfnboldi(nocc),edfmapi(dfnbasis,nocc),nbf
integer vlni(nocc),emapi(nbf,nocc),enbi(nocc),b,iocc,natoms
integer enatdom(nocc),eatdom(natoms,nocc),nang,nshrange,nangmax
integer alladd(nbf*(nbf+1)/2)
real*8 npai(*),tr2naf(*),jabbl(*),mo(*),pabi(*),edint(*),allint(*)
c db
real*8 twdg,tcdg,twdax,tcdax,tcftrf,twftrf
real*8 twdg0,tcdg0,twdax0,tcdax0,tcftrf0,twftrf0
c aux functions of the actual P^shell contributue to these ED's in the block
nacted=0
call ifillzero(acteds,nocc)
do d=1,afdom(0,kfrst+1)
kocc=afdom(d,kfrst+1)
if (kocc.ge.frsted.and.kocc.lt.frsted+edinbl) then
acteds(d)=kocc
nacted=nacted+1
endif
enddo !d
do d=1,nacted
iocc=acteds(d)
c sort (nu^alli mu^alli,P)^i for ED d from (nu^allinblock,mu^allinblock,P^shell)
call ido(tcdax0,twdax0)
call sortint(nbf,enbi(iocc),nklen,allint,edint,emapi(1,iocc),
$alladd,enatdom(iocc),eatdom(1,iocc),natoms,nang,nshrange,nangmax)
call idoadd(tcdax,twdax,tcdax0,twdax0)
c first AO->MO trf: (mu,nu,P) -> (nu,P,a)
call ido(tcftrf0,twftrf0)
call dgemm('t','n',enbi(iocc)*nklen,vlni(iocc),enbi(iocc),1.d0,
$edint,enbi(iocc),mo(moadd(iocc)+1),enbi(iocc),0.d0,
$npai,enbi(iocc)*nklen)
call idoadd(tcftrf,twftrf,tcftrf0,twftrf0)
c db
c write(*,*) 'mo', iocc, moadd(iocc)
c write(*,'(1000f16.10)')
c $ mo(moadd(iocc)+1:moadd(iocc)+enbi(iocc)*vlni(iocc))
c write(*,*) 'npai', iocc,enbi(iocc),nklen,vlni(iocc)
c write(*,'(1000f16.10)') npai(1:enbi(iocc)*nklen*vlni(iocc))
c db
c second AO->MO trf: (nu,P,a) -> (P,[ab]), ab is in upper triangle form
call ido(tcdg0,twdg0)
do b=1,vlni(iocc)
p2=moadd(iocc)+(b-1)*enbi(iocc)+1
pp=nklen*(b-1)*b/2+1
call dgemv('t',enbi(iocc),nklen*b,1.d0,npai,enbi(iocc),
$ mo(p2),1,0.d0,pabi(pp),1)
enddo !b
call idoadd(tcdg,twdg,tcdg0,twdg0)
c
ab=vlni(iocc)*(vlni(iocc)+1)/2
c if (lintra.eq.2.or.lintra.eq.3) then
C fitting and transform to the NAF basis OR only fitting, no NAFs
pp=intadd(iocc)+1
if (lintra.eq.2) then
p2=dfadd(iocc)+edfmapi(kfrst+1,iocc)
call dgemm('t','n',edfnbi(iocc),ab,nklen,1.d0,tr2naf(p2),
$edfnboldi(iocc),pabi,nklen,1.d0,jabbl(pp),edfnbi(iocc))
elseif (lintra.eq.3) then
p2=dfadd(iocc)+(edfmapi(kfrst+1,iocc)-1)*edfnboldi(iocc)+1
call dgemm('n','n',edfnbi(iocc),ab,nklen,1.d0,tr2naf(p2),
$edfnboldi(iocc),pabi,nklen,1.d0,jabbl(pp),edfnbi(iocc))
elseif (lintra.eq.4) then
C collect and store ([ab],P) integrals of the block for Jpq type NAF construction
do p=1,nklen
pp=intadd(iocc)+edfmapi(kfrst+p,iocc)
call dcopy(ab,pabi(p),nklen,jabbl(pp),edfnbi(iocc))
enddo
endif
enddo !d
return
end
c }}}
c
c{{{ subroutine sortint
************************************************************************
subroutine sortint(nbf,nb,nklen,allint,edint,emapi,
$alladd,enatdom,eatdom,natoms,nang,nshrange,nangmax)
************************************************************************
* 1) Sort (nu^alli mu^alli,P)^i of ED'i from (nu^allinblock,mu^allinblock,P^shell)
* 2) expand the symmetry of the AO indices
************************************************************************
implicit none
integer nbf,nb,ij,n,m,alladd(nbf*(nbf+1)/2),nklen,natoms
integer nilen,njlen,pp,enatdom,eatdom(natoms),nangmax,i,j,k
integer iedat,iat,iedang,jedat,jat,jedang,nang(natoms),mi,nj
integer nshrange(2,0:nangmax,natoms),nu,mu,emapi(nbf),nijlen
real*8 allint(*),edint(nb,nb,nklen)
c db
c write(*,*) 'full allint, 1:24'
c write(*,'(1000f10.4)') allint(1:24)
c db
c loops for atoms and shells of mu and nu, mu>=nu
do iedat=1,enatdom
iat=eatdom(iedat)
do iedang=0,nang(iat)
nilen=nshrange(2,iedang,iat)-nshrange(1,iedang,iat)
mu=nshrange(1,iedang,iat)+1 ! ifrst+1
m=emapi(mu)
do jedat=1,iedat
jat=eatdom(jedat)
do jedang=0,nang(jat)
njlen=nshrange(2,jedang,jat)-nshrange(1,jedang,jat)
nu=nshrange(1,jedang,jat)+1 ! jfrst+1
n=emapi(nu)
nijlen=nilen*njlen
if (mu.ge.nu) then
ij=(nu-1)*(nbf-1)-(nu-1)*(nu-2)/2+mu
do i=0,nilen-1
do j=0,njlen-1
pp=alladd(ij)+j*nilen+i
mi=m+i
nj=n+j
do k=0,nklen-1
edint(mi,nj,k+1)=allint(pp+k*nijlen)
enddo
c call dcopy(nklen,allint(pp),nilen*njlen,
c $ edint(m+i,n+j,1),nb**2)
enddo
enddo
if (mu.ne.nu) then
do i=0,nilen-1
do j=0,njlen-1
pp=alladd(ij)+j*nilen+i
mi=m+i
nj=n+j
do k=0,nklen-1
edint(nj,mi,k+1)=allint(pp+k*nijlen)
enddo
c call dcopy(nklen,allint(pp),nilen*njlen,
c $ edint(n+j,m+i,1),nb**2)
enddo
enddo
endif
else
ij=(mu-1)*(nbf-1)-(mu-1)*(mu-2)/2+nu
do i=0,nilen-1
do j=0,njlen-1
pp=alladd(ij)+i*njlen+j
mi=m+i
nj=n+j
do k=0,nklen-1
edint(mi,nj,k+1)=allint(pp+k*nijlen)
enddo
c call dcopy(nklen,allint(pp),nilen*njlen,
c $ edint(m+i,n+j,1),nb**2)
enddo
enddo
if (mu.ne.nu) then
do i=0,nilen-1
do j=0,njlen-1
pp=alladd(ij)+i*njlen+j
mi=m+i
nj=n+j
do k=0,nklen-1
edint(nj,mi,k+1)=allint(pp+k*nijlen)
enddo
c call dcopy(nklen,allint(pp),nilen*njlen,
c $ edint(n+j,m+i,1),nb**2)
enddo
enddo
endif
endif
c write(*,'(a30,9i4)') 'mu,nu,m,n,nbf,ij,alladd(ij)'
c $ ,mu,nu,m,n,nbf,ij,alladd(ij) ; flush(6)
c db
c write(*,*) 'full allint, 1:288'
c write(*,'(1000f10.4)') allint(1:288)
c db
c if (mu.ne.nu) then
c do i=0,nilen-1
c do j=0,njlen-1
c pp=alladd(ij)+j*nilen+i
c call dcopy(nklen,allint(pp),nilen*njlen,
c $ edint(n+j,m+i,1),nb**2)
c enddo
c enddo
c endif
enddo
enddo
enddo
enddo
c write(*,*) 'full edint', nb,nklen
c write(*,'(1000f16.10)') edint(1:nb,1:nb,1:nklen)
return
end
c }}}
c
c{{{ subroutine jpqnaf
************************************************************************
subroutine jpqnaf(nocc,edfnboldi,frsted,edinbl,
$tr2naf,dfadd,jabbl,intadd,vlni,olni,w1,w2,jpq,naftol,ccprog,edi,
$lintra,dfcoralg,diskints4cc,jijp,jiap,edfnbireturn,oslcc,nvb,
$docc,nva,og2canpao,iout,rlnv,rlnvb,inbcast_group)
************************************************************************
* contruct NAFs from Jai, Jij and Jab integrals, trf to NAF basis and prt Jpq for ccsd.f
************************************************************************
implicit none
integer nocc,intadd(nocc),nocci,nvirt,iout
integer i,j,dfnbasis,frsted,edinbl,dfnbasis_old
integer edfnboldi(nocc),dfadd(nocc)
integer vlni(nocc),olni(nocc),iocc,idegen
integer pp,p,q,iisyev,ij,a,pos,ncoi,idumy
real*8 tr2naf(*),jabbl(*),w1(*),w2(*),jpq(*),naftol
character*16 ilmoname,jname,filename,cscr16,naf
integer*4 isyev
equivalence(isyev,iisyev) !For Intel
character*4 ccprog
character*8 dfcoralg
c for lintra 11
integer edi,lintra
c for lccoporder
integer edfnbireturn
real*8 jijp(*),jiap(*)
logical diskints4cc
c oslcc, p in e.g. nvpa,nvpb means that it is used as a pointer (to reuse closed-shell code)
real*8 jabnaffact,og2canpao(*)
integer nvb,nob,betaoccnum,nva,nvpa,nvpb,nso,abdim,absdim
integer ijaba,ijabbuff1,ijabbuff2,ibeta,osxmem,rlnv,rlnvb
logical oslcc,docc,inbcast_group
integer rlnvbp
c debug
character*5 jabextract
c
do iocc=frsted,frsted+edinbl-1 ! loop for all ED's of the block
if (edinbl.gt.1) then
write(6,*)
write(6,"(' NAF construction in ext. dom:',i4,1x,a9)") iocc
endif
if (lintra.eq.11.or.lintra.eq.13) then
write(ilmoname,'(i6)') edi
else
write(ilmoname,'(i6)') iocc
edi=iocc
endif
ilmoname=adjustl(ilmoname)
c compute W'_ab from ([ab],P)
dfnbasis=edfnboldi(iocc) ! dfnbasis is a local variable here, not the global dfnbasis
nvirt=vlni(iocc)
nocci=olni(iocc)
p=dfadd(iocc)+1
pp=intadd(iocc)+1
betaoccnum=1
if (oslcc.and..not.docc) betaoccnum=0
nvpa=nvirt; nvpb=nvirt; rlnvbp=nvirt
if (oslcc) nvpa=nva !nv in closed-shell, alpha virt in open-shell case
if (oslcc) nvpb=nvb !nv in closed-shell, beta virt in open-shell case
if (oslcc) rlnvbp=rlnvb !nv in closed-shell, beta restricted virtuals in open-shell case
c db
c write(*,*) 'nocc,dfnbasis,nvirt,nocci,p,pp',
c $ nocc,dfnbasis,nvirt,nocci,p,pp
c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
c fitting Jab and obtain contribution of W_pq
c tr2naf contains the fitting coefficients here, without the NAF trf factor
if (dfcoralg.eq."cholinv ") then
call dtrmm('l','l','n','n',dfnbasis,rlnvbp*(rlnvbp+1)/2,
$1.d0,tr2naf(p),dfnbasis,jabbl(pp),dfnbasis)
elseif (dfcoralg.eq."lineq ") then
call dtrsm('l','l','n','n',dfnbasis,rlnvbp*(rlnvbp+1)/2,
$1.d0,tr2naf(p),dfnbasis,jabbl(pp),dfnbasis)
endif
ijaba=pp
if (oslcc) then
! Transform J_ab to alpha canonical basis
ijaba=pp+rlnvbp*(rlnvbp+1)*dfnbasis/2
ijabbuff1=ijaba+nva*(nva+1)*dfnbasis/2
ijabbuff2=ijabbuff1+rlnvbp**2
call restricted2can_jab(dfnbasis,rlnv,rlnvbp,nva,jabbl(pp),
& jabbl(ijaba),og2canpao,edi,jabbl(ijabbuff1),jabbl(ijabbuff2),
& '.false. ')
call restricted2can_jab(dfnbasis,rlnvbp,rlnvbp,nvb,jabbl(pp),
& jabbl(pp),og2canpao(rlnv*nva+1),edi,jabbl(ijabbuff1),
& jabbl(ijabbuff2),'.false. ')
endif
call dsyrk('u','n',dfnbasis,nvpa*(nvpa+1)/2,1.d0,
$ jabbl(ijaba),dfnbasis,0.d0,w1,dfnbasis)
if (oslcc) call dsyrk('u','n',dfnbasis,nvb*(nvb+1)/2,1.d0,
$ jabbl(pp),dfnbasis,1.d0,w1,dfnbasis)
call filllo(w1,dfnbasis)
c db
c write(*,*) 'Jab contribution to W before fitting'
c write(*,'(4es14.6)') w1(1:dfnbasis**2)
c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
c startegy1
c fitting W'_ab -> W_ab in two steps: 1) tr2naf^T W1 -> W1 ; 2) W1 tr2naf -> W1
c call dsyrk('u','n',dfnbasis,nvirt*(nvirt+1)/2,1.d0,jabbl(pp),
c $ dfnbasis,0.d0,w1,dfnbasis)
c call filllo(w1,dfnbasis)
c if (dfcoralg.eq."cholinv ") then
c call dtrmm('l','l','n','n',dfnbasis,dfnbasis,1.d0,
c $ tr2naf(p),dfnbasis,w1,dfnbasis)
c call dtrmm('r','l','t','n',dfnbasis,dfnbasis,1.d0,
c $ tr2naf(p),dfnbasis,w1,dfnbasis)
c elseif(dfcoralg.eq."lineq ") then
c call dtrsm('l','l','n','n',dfnbasis,dfnbasis,1.d0,
c $ tr2naf(p),dfnbasis,w1,dfnbasis)
c call dtrsm('r','l','t','n',dfnbasis,dfnbasis,1.d0,
c $ tr2naf(p),dfnbasis,w1,dfnbasis)
c endif
c call dsyev('V','U',dfnbasis,w1,dfnbasis,w2,
c $w2(1+dfnbasis),max(dfnbasis*(dfnbasis-1),12),isyev) ! 12=max of dfnb4*(dfnb4-1) if dfnbasis is small
c startegy1end
c db
c read W_pi, W_pi is already fitted
jname='nafWpi'
filename=trim(jname) // '.' // trim(ilmoname)
open(111,file=filename,form='unformatted')
read(111) ((w2((j-1)*dfnbasis+i),i=1,dfnbasis),j=1,dfnbasis)
if (lintra.eq.4) then
close(111,status='delete')
else
close(111)
endif
c db
c write(*,*) 'Jpi contribution to W'
c write(*,'(4es14.6)') w2(1:dfnbasis**2)
c db
c W_pq=W_pi+W_ab
call daxpy(dfnbasis**2,1.d0,w2,1,w1,1)
c db
c write(*,*) 'W before diag'
c write(*,'(4es14.6)') w1(1:dfnbasis**2)
c db
c construct NAFs from W_pq
call dsyev('V','U',dfnbasis,w1,dfnbasis,w2,
$w2(1+dfnbasis),max(dfnbasis*(dfnbasis-1),12),isyev) ! 12=max of dfnb4*(dfnb4-1) if dfnbasis is small
if(isyev.ne.0) then
write(6,*) 'Fatal error at the construction of NAFs jpq!'
call mrccend(1)
endif
c db
cdbprt write(*,*) 'NAF sing val',dfnbasis
cdbprt write(*,'(100000es18.8)') w2(1:min(dfnbasis,5))
c write(*,*) 'NAF coeff matrix'
c write(*,'(4es14.6)') w2(1:dfnbasis**2)
c db
c Scale open-shell NAF eigenvalues to match closed-shell case
if (oslcc) then
c scalenaf=(nocci*(nocci+1)/2+nob*(nob+1)/2+nva*nocci+nvb*nob+ !Jij,JIJ,Jai,JAI
c & nva*(nva+1)/2+nvb*(nvb+1)/2)/ !Jab,Jab
c &((nocci+nva)*(nocci+nva+1)/2) !Jpq
c n3centint=(nocci+nva)*(nocci+nva+1)/2
c ndocc3centint=nob*(nob+1)/2+nva*nob+nva*(nva+1)/2
c nsocc3centint=n3centint-ndocc3centint
c scalenaf=(2.d0*ndocc3centint+nsocc3centint)/n3centint
call dscal(dfnbasis,0.5d0,w2,1)
endif
c select retained NAFs
if (w2(1).lt.-max(1.d-5,naftol)) then
write(*,*) 'Warning: auxiliary basis might be linearly dependent'
write(*,*) 'All NAFs with imaginary singular values are dropped'
endif
i=0
do while((dabs(w2(i+1)).lt.naftol.or.
$ w2(i+1) .lt.-1.d-10).and.i.lt.dfnbasis) ! to exclude imag singular values
i=i+1
enddo
dfnbasis_old=dfnbasis
dfnbasis=dfnbasis-i
edfnbireturn=dfnbasis
pos=i*dfnbasis_old+1 ! kept NAF coeffs start here
c {{{ rewrite 55 with the new NAF dimension
jname='55'
filename=trim(jname) // '.' // trim(ilmoname)
c for MPI if (.not.diskints4cc) filename=trim(jname) ! == lccoporder.eq.'lccfirst'.and.ccsdalg.eq.'dfdirect'
open(555,file=trim(filename))
if (ccprog.eq.'ccsd') then
read(555,*) (idumy, i=1,3),idegen,idumy,ncoi, idumy
read(555,*)
read(555,*)
read(555,*)
read(555,*)
read(555,*) (w2(i),i=1,nocci) ! ui(1:nocc): expansion of LMO i on the canonical LNO's
read(555,"(e28.20)") w2(nocci+1:nocci+(nvpa+nocci)**2)
c read beta quantities
if (oslcc) then
read(555,*) !nuclear repulsion (0.d0 for local CC)
read(555,*) nob , nvb !beta occupied and virtual orbitals
if (nob.gt.0) then
read(555,*) w2(nocci+(nvpa+nocci)**2+1:
& nocci+(nvpa+nocci)**2+nob)
read(555,*) w2(nocci+(nvpa+nocci)**2+nob+1:
& nocci+(nvpa+nocci)**2+nob+(nob+nvb)**2)
endif !nob.gt.0
else !.not.oslcc
nob=nocci
endif !oslcc
rewind(555)
c corr bas, corr el , actocc?, deglev(actocc)
c write(555,'(7I6)')nocci+nvpa,2*nocci,nocci,idegen,dfnbasis,
write(555,'(7I6)')nocci+nvpa,osxmem(oslcc,nocci+nob,2*nocci),
$ nocci,idegen,dfnbasis,ncoi,nob
c dymension of the point group
write(555,'(1I6)') 1
c borders of a symmetry block
write(555,'(2I6)') 1, nocci+nvpa+1
c occupied orbitals of a given irrep
write(555,'(1I6)') nocci
c actocc?, deglev(actocc)
write(555,'(4I6)') nocci,1
c ui(1:nocc): expansion of LMO i on the canonical LNO's
write(555,'(100000e28.20)') (w2(i),i=1,nocci)
c Fockian in the canonical LNO basis is diagonal in the oo & vv blocks, could be full in the ov block
write(555,"(e28.20)") w2(nocci+1:nocci+(nvpa+nocci)**2)
c nuc repulsion is not needed in localc CC calc
write(555,"(e28.20,2i6)") 0.d0,0,0
if (oslcc) then
c number of beta occupied and virtual orbitals, occupation number of beta cLMO
write(555,'(3I6)') nob , nvb , betaoccnum
c ui(1:nocc): expansion of LMO I on the canonical LNO's
if (nob.gt.0) then
write(555,'(100000e28.20)')(w2(nocci+(nvpa+nocci)**2+i),i=1,
& nob)
c beta Fockian in the canonical LNO basis
write(555,"(e28.20)") w2(nocci+(nvpa+nocci)**2+nob+1:
& nocci+(nvpa+nocci)**2+nob+(nob+nvb)**2)
endif !nob.gt.0
endif !oslcc
elseif(ccprog.eq.'mrcc') then
read(555,*) (idumy, i=1,3),idegen,idumy, ncoi,idumy
read(555,*) (w2(i),i=1,nocci) ! ui(1:nocc): expansion of LMO i on the canonical LNO's
read(555,"(e28.20)") w2(nocci+1:2*nocci+nvirt+nvirt*nocci)
if (oslcc) then
ibeta=2*nocci+nvirt+nvirt*nocci
read(555,*) nob , nvb , betaoccnum !beta occupied and virtual orbitals
if (nob.gt.0) then
read(555,*) (w2(ibeta+i),i=1,nob) ! ui(1:nocc): expansion of LMO i on the canonical LNO's
read(555,*) w2(ibeta+nob+1:ibeta+2*nob+nvb+nob*nvb)
endif !nob.gt.0
else !.not.oslcc
nob=nocci
endif !oslcc
rewind(555)
write(555,'(7I6)') nocci, nvirt,dfnbasis, idegen,1,ncoi,nob
write(555,'(100000e28.20)') (w2(i),i=1,nocci)
write(555,"(e28.20)") w2(nocci+1:2*nocci+nvirt+nvirt*nocci)
if (oslcc) then
c number of beta occupied and virtual orbitals, occupation number of beta cLMO
write(555,'(3I6)') nob , nvb , betaoccnum
if (nob.gt.0) then
write(555,"(100000e28.20)") (w2(ibeta+i),i=1,nob) ! ui(1:nocc): expansion of LMO i on the canonical LNO's
write(555,"(e28.20)") w2(ibeta+nob+1:ibeta+2*nob+nvb+nob*nvb)
c write(555,"(e28.20)") (w2(nocci+i),i=1,nob)
c write(555,"(e28.20)") w2(3*nocci+nvirt+nvirt*nocci+1:
c $ 3*nocci+nvirt+nvirt*nocci+nob+nvb+nob*nvb)
endif !nob.gt.0
endif !oslcc
endif !ccprog
close(555)
c }}}
write(cscr16,'(f16.2)') 100.d0*dfnbasis/dfnbasis_old
write(iout,"(' Number of NAFs: ',i5,1x,a9)")
$ dfnbasis,trim('(' // adjustl(cscr16)) // '%)'
c startegy1
c call dcopy(dfnbasis_old*dfnbasis,w1(pos),1,w2,1)
c if (dfcoralg.eq."cholinv ") then
c call dtrmm('l','l','t','n',dfnbasis_old,dfnbasis,1.d0,
c $tr2naf(p),dfnbasis_old,w2,dfnbasis_old)
c elseif(dfcoralg.eq."lineq ") then
c call dtrsm('l','l','t','n',dfnbasis_old,dfnbasis,1.d0,
c $tr2naf(p),dfnbasis_old,w2,dfnbasis_old)
c endif
c call dgemm('t','n',dfnbasis,nvirt*(nvirt+1)/2,dfnbasis_old,1.d0,
c $ w2,dfnbasis_old,jabbl(pp),dfnbasis_old,0.d0,jpq,dfnbasis)
c startegy1end
c
c transform to NAF and write jab for ccsd.f
if (diskints4cc.or.lintra.eq.4) then
! Alpha Jab
filename='DFINT_AB' // '.' // trim(ilmoname)
call Jpq2NAF_write(dfnbasis,nvpa*(nvpa+1)/2,dfnbasis_old,
$ w1(pos),jabbl(ijaba),jpq,filename,.false.,.true.)
! Beta Jab
filename='DFINT_ABb' // '.' // trim(ilmoname)
if (oslcc.and.nob.gt.0) call Jpq2NAF_write(dfnbasis,
$ nvb*(nvb+1)/2,dfnbasis_old,w1(pos),jabbl(pp),jpq,filename,
$ .false.,.true.)
else
c transform Jab to NAF basis: (P,[ab])*fitting*NAF
call dgemm('t','n',dfnbasis,nvirt*(nvirt+1)/2,dfnbasis_old,1.d0,
$ w1(pos),dfnbasis_old,jabbl(pp),dfnbasis_old,0.d0,jpq,dfnbasis)
call dcopy(nvirt*(nvirt+1)/2*dfnbasis,jpq,1,jabbl,1) ! save J(P,AB) for ijab4c
endif
c
c transform Jai and Jij to the NAF basis
if (diskints4cc.or.lintra.eq.4) then
! Alpha Jai
filename='DFINT_AI' // '.' // trim(ilmoname)
q=dfnbasis_old*nvpa*nocci+1
call Jpq2NAF_write(dfnbasis,nvpa*nocci,dfnbasis_old,
$ w1(pos),jpq,jpq(q),filename,.true.,.false.)
! Beta Jai
if (oslcc) then
if(nob.gt.0) then
filename='DFINT_AIb' // '.' // trim(ilmoname)
q=dfnbasis_old*nvb*nob+1
call Jpq2NAF_write(dfnbasis,nvb*nob,
$ dfnbasis_old,w1(pos),jpq,jpq(q),filename,.true.,.false.)
endif
endif
else
c (a,i,P) is in memory, trf to J(a,i,Q)
call dcopy(nvpa*nocci*dfnbasis_old,jiap,1,jpq,1)
call dgemm('n','n',nvpa*nocci,dfnbasis,dfnbasis_old,1.d0,
$ jpq,nocci*nvpa,w1(pos),dfnbasis_old,0.d0,jiap,nvpa*nocci)
endif
c db
c write(*,*) 'jai in NAF basis written in dfint'
c write(*,'(4es14.6)') (((jpq(q-1+(p-1)*nvirt*nocci+(a-1)*nocci+i),
c $ i=1,nocci),a=1,nvirt),p=1,dfnbasis)
c db
if (diskints4cc.or.lintra.eq.4) then
c read and transform Jij as (P,[ij])
! Alpha Jij
filename='DFINT_IJ' // '.' // trim(ilmoname)
q=dfnbasis_old*nocci*(nocci+1)/2+1
call Jpq2NAF_write(dfnbasis,nocci*(nocci+1)/2,dfnbasis_old,
$ w1(pos),jpq,jpq(q),filename,.true.,.true.)
! Beta Jij
if (oslcc) then
if(nob.gt.0) then
filename='DFINT_IJb' // '.' // trim(ilmoname)
q=dfnbasis_old*nob*(nob+1)/2+1
call Jpq2NAF_write(dfnbasis,nob*(nob+1)/2,dfnbasis_old,
$ w1(pos),jpq,jpq(q),filename,.true.,.true.)
endif
endif
else
c (i,j,P) is in memory, trf to J(i,j,Q)
call dcopy(nocci**2*dfnbasis_old,jijp,1,jpq,1)
call dgemm('n','n',nocci**2,dfnbasis,dfnbasis_old,1.d0,
$ jpq,nocci**2,w1(pos),dfnbasis_old,0.d0,jijp,nocci**2)
endif
c db
c write(*,*) 'jij in NAF basis written in dfint'
c write(*,'(4es14.6)') ((jpq(q-1+(ij-1)*dfnbasis+p),
c $ p=1,dfnbasis),ij=1,nocci*(nocci+1)/2)
c db
enddo ! iocc
return
end
c }}}
c
c {{{ subroutine print_jab
subroutine print_jab(jab,nv,dfnb,scrfile1)
************************************************************************
* print Jab integrals for a block
************************************************************************
implicit none
integer nv,dfnb,scrfile1
c integer pp,a,b,ab,l
real*8 jab(dfnb,nv*(nv+1)/2)
c db
c write(*,*) 'jab in NAF basis for naf=1 and dfnb',nv,dfnb ;flush(6)
c do pp=1,dfnb
c write(*,'(i4,4es14.6)') pp, jab(pp,1:nv*(nv+1)/2)
c enddo
c write(*,*) 'Jab'
c write(*,'(100000es18.8)') jab(1:dfnb,1:nv*(nv+1)/2)
c do pp=1,dfnb
c a=1
c l=0
c do ab=1,nv*(nv+1)/2
c if (a*(a+1)/2+1.eq.ab) a=a+1
c b=ab-a*(a-1)/2
c if (dabs(jab(pp,ab)).gt.0.1) then
c write(100,'(4i6,es18.8)') pp,a,b,ab,jab(pp,ab)
c l=1
c endif
c enddo
c if (l.eq.1) write(100,*)
c enddo
c db
c
write(scrfile1) jab
c
return
end
c }}}
c
c {{{ subroutine print_jab2
subroutine print_jab2(jab,nv,dfnb,scrfile1,pp)
************************************************************************
* transpose and print Jab integrals for a block
************************************************************************
implicit none
integer nv,dfnb,scrfile1,ii,pp
real*8 jab(dfnb,nv*(nv+1)/2)
c
do ii=1,dfnb
write(scrfile1,rec=ii+pp-1) jab(ii,1:nv*(nv+1)/2)
enddo
c
c db
c do pp=1,dfnb
c write(*,'(i4,1000f12.6)') pp, jab(pp,1:nv*(nv+1)/2)
c enddo
c flush(6)
c db
return
end
c }}}
c
c{{{ subroutine storemnp
************************************************************************
subroutine storemnp(dfscr,mpn,nilen,njlen,ifrst,jfrst,enbi,
$dfnbasis,nbasis,emapi,edfmapinv,edfnbi,scred)
************************************************************************
* store (mu^shell,nu^shell,P^all in mol) to (nu^shell,P^all in ED,mu^all in ED)
* rearrange and expand symmetry before storage
************************************************************************
implicit none
integer enbi,i,j,edfnbi,edfmapinv(edfnbi),p,n,nbasis
integer njlen,nilen,ifrst,jfrst,dfnbasis,pos,emapi(nbasis)
real*8 dfscr(nilen,njlen,dfnbasis),mpn(nilen,edfnbi,enbi)
real*8 scred(nilen,njlen,edfnbi)
c sort the aux basis indices of the ED
do p=1,edfnbi
n=edfmapinv(p)
call dcopy(nilen*njlen,dfscr(1,1,n),1,scred(1,1,p),1)
enddo !p
cxx write(*,*) 'scred1',scred(1:nilen,1:njlen,1:dfnbasis)
c expand symmetry if nu and mu belong to the same shell
if (1+ifrst.eq.1+jfrst) then
do i=1,nilen
do j=i+1,njlen
call dcopy(edfnbi,scred(j,i,1),nilen*njlen,
$ scred(i,j,1),nilen*njlen)
enddo
enddo
endif
cxx write(*,*) 'scred2',scred(1:nilen,1:njlen,1:dfnbasis)
c rearrrange and store integrals
do i=1,nilen
do j=1,njlen
pos=emapi(jfrst+j)
call dcopy(edfnbi,scred(i,j,1),nilen*njlen,mpn(i,1,pos),nilen)
enddo
enddo
cxx write(*,*) 'nilen,njlen,dfnbasis,ifrst,jfrst',
cxx $ nilen,njlen,dfnbasis,ifrst,jfrst
cxx write(*,*) 'dfscr',dfscr(1:nilen,1:njlen,1:dfnbasis)
cxx write(*,*) 'mpn',mpn(1:nilen,1:edfnbi,1:enbi)
end
c }}}
c
c {{{ subroutine ledinttrf
subroutine ledinttrf(lintra,natrange,natoms,nocc,edfnbi,nbasis,
$at2lmo,emodom,moadd,mapi,emapi,no,npao,enbi,nilen,ifrst,
$mo,mpn,mpi,cpao,aotocmo,aip,pij,eatdom,enatdom)
************************************************************************
* perform
* if lintra.eq.5
* (mu^shell,P^all,nu^all) -> (muPI) -> (aPI), I: orignal LMO at PD_i, a: PAO
* if lintra.eq.6
* (muPI) -> (j,P,I) j: canonical occ MO in ED
* transformations for a single extended domain
************************************************************************
implicit none
c arguments
integer lintra,natoms,natrange(2,natoms),nocc,edfnbi,nbasis
integer at2lmo(natoms,0:nocc),emodom(nocc),moadd(nocc)
integer mapi(nbasis,nocc),emapi(nbasis),no,npao,enbi,nilen,ifrst
integer enatdom,eatdom(natoms)
real*8 mo(*),mpn(nilen,edfnbi,enbi),mpi(nilen,edfnbi,no)
real*8 cpao(enbi,npao),aotocmo(enbi,no)
real*8 aip(npao,edfnbi,no),pij(*)
c local
integer jatoms,nbfonj,jj,jjj,j,frstao,p,p1,jjatoms
c integer a,i,mu,nu,pp
c
cxx write(*,*) no,'mo(1:enbi*no)',mo(1:enbi*no)
c (mu^shell,P^all,nu^all) -> (mu^shell,P^all,I^all) trf
call dfillzero(mpi,nilen*edfnbi*no)
do jjatoms=1,enatdom
jatoms=eatdom(jjatoms)
c perform AO -> occ LMO only for those LMO's, that are expanded on the bf's of atom jatoms (orig LMO are expanded in the PD's)
c the list of these LMOs is stored in at2lmo
nbfonj=natrange(2,jatoms)-natrange(1,jatoms) ! number of bf's on atom jatoms
frstao=natrange(1,jatoms)+1 ! global index of first AO on atom jatoms
p=emapi(frstao) ! ED index of the first AO on atom jatoms
cxx write(*,*) 'jjatoms,jatoms,enatdom,frstao,p,nbfonj',
cxx $ jjatoms,jatoms,enatdom,frstao,p,nbfonj
cxx write(*,*) 'natr2,natr1', natrange(2,jatoms),natrange(1,jatoms)
do j=1,at2lmo(jatoms,0)
jj=at2lmo(jatoms,j) ! which lmo has contribution from bf's on atom jatoms (relative MO index in ED_i)
jjj=emodom(jj) ! absolute index of jj
p1=moadd(jj)+mapi(frstao,jjj)
cxx write(*,*) 'j,jj,jjj,nbfonj,nilen,edfnbi,p,p1',
cxx $ j,jj,jjj,nbfonj,nilen,edfnbi,p,p1
cxx write(*,*) 'mpn(1:nilen,1:edfnbi,1:enbi)',
cxx $ mpn(1:nilen,1:edfnbi,1:enbi)
cxx write(*,*) 'mpn(1,1,p:p+nbfonj-1)',mpn(1,1,p:p+nbfonj-1)
cxx write(*,*) 'mo(p1:p1+nbfonj-1)',mo(p1:p1+nbfonj-1)
cxx write(*,*) 'mpi in ledinttrf before', mpi(1:nilen,1:edfnbi,1:no)
call dgemv('n',nilen*edfnbi,nbfonj,1.d0,mpn(1,1,p),nilen*edfnbi
$,mo(p1),1,1.d0,mpi(1,1,jj),1)
cc do mu=1,nilen
cc do pp=1,edfnbi
cc do nu=0,nbfonj-1
cc if (ifrst+mu.eq.2.and.pp.eq.1.and.jj.eq.1) then
cc write(*,*) 'mpi(2,1,1) terms,nu',nu+1
cccxx write(*,*) mpi(mu,pp,jj),mpn(mu,pp,p+nu),
cccxx $ mo(p1+nu), mpn(mu,pp,p+nu)*mo(p1+nu)
ccc write(*,*) 'nu,p,jj', nu,p,jj
ccc write(*,*) 'mpi(1,1,jj)',mpi(mu,pp,jj),mpn(mu,pp,p+nu),
ccc $ mo(p1+nu), mpn(mu,pp,p+nu)*mo(p1+nu)
cc endif
cc mpi(mu,pp,jj)=mpi(mu,pp,jj)+mpn(mu,pp,p+nu)*mo(p1+nu)
cc enddo
cc if (ifrst+mu.eq.2.and.pp.eq.1.and.jj.eq.1)
cc $ write(*,*) 'mpi(2,1,1) after',mpi(mu,pp,jj)
cc enddo
cc enddo
cxx write(*,*) 'mpi(1:nilen,1:edfnbi,jj)',mpi(1:nilen,1:edfnbi,jj)
cxx write(*,*) '******* ********* *********'
cxx write(*,*)
enddo !j
enddo !jatoms
c (mu^shell,P,I) -> (a_PAO,P,I) contribution
p=emapi(ifrst+1)
call dgemm('t','n',npao,edfnbi*no,nilen,1.d0,cpao(p,1),enbi,
$mpi,nilen,1.d0,aip,npao)
C do a=1,npao
c do i=1,no
c do p=1,edfnbi
c do mu=1,nilen
c aip(a,p,i)= aip(a,p,i)+mpi(mu,p,i)*cpao(ifrst+mu,a)
c enddo
c enddo
c enddo
c enddo
c db
cxx write(*,*) '# # # # # # # # # # # # # # # # # # # # # # # # '
cxx write(*,*) 'ifrst,nilen of mu',ifrst,nilen
cxx write(*,*) '# # # # # # # # # # # # # # # # # # # # # # # # '
cxx write(*,*) 'mpn in ledinttrf', mpn(1:nilen,1:edfnbi,1:enbi)
cxx write(*,*) 'mo in ledinttrf', mo(1:enbi*no)
cxx write(*,*) 'mpi in ledinttrf', mpi(1:nilen,1:edfnbi,1:no)
cxx write(*,*) 'cpao in ledinttrf', cpao(p:p+nilen-1,1:npao)
c write(*,*) 'aip in ledinttrf', aip(1:npao*edfnbi*no)
cxx write(*,*) 'aip in ledinttrf a=1', aip(1,1:edfnbi,1:no)
cxx write(*,*) 'aip in ledinttrf a=2', aip(2,1:edfnbi,1:no)
cxx write(*,*) 'aip in ledinttrf a=3', aip(3,1:edfnbi,1:no)
c db
if (lintra.eq.6) then
c (nu^shell,P,I) -> (j,P,I) contribution
call dgemm('t','n',no,edfnbi*no,nilen,1.d0,aotocmo(p,1),enbi,
$mpi,nilen,1.d0,pij,no)
endif
c drop (mu^shell,P^all,nu^all)
call dfillzero(mpn,nilen*edfnbi*enbi)
return
end
c }}}
c
c {{{ subroutine ledintjab
subroutine ledintjab(edfnbi,dfnb_old,enbi,nilen,ifrst,emapi,
$ao2lno,mpn,qam,amp,jab,nv,nbasis,tr2naf,lnaf)
************************************************************************
* perform (mu^shell,P^all,nu^all) -> J_(Q,[ab]) (a,b=can virt LNO, Q=NAF/AF)
* transformations for a single extended domain
************************************************************************
implicit none
c arguments
integer edfnbi,dfnb_old,enbi,nilen,ifrst,nbasis,nv
integer emapi(nbasis),lnaf
real*8 mpn(nilen,dfnb_old,enbi),amp(nv,nilen,dfnb_old)
real*8 ao2lno(enbi,nv),tr2naf(dfnb_old,edfnbi)
real*8 qam(edfnbi,nv,nilen)
real*8 jab(edfnbi,nv*(nv+1)/2)
c local
integer a,p1,ab
c
c first AO->MO trf: (mu^shell,P^all,nu^all) -> (a^all,mu^shell,P^all)
call dgemm('t','t',nv,nilen*dfnb_old,enbi,1.d0,ao2lno,enbi,
$mpn,nilen*dfnb_old,0.d0,amp,nv)
cx write(*,*) 'mpn(1:nilen,1:edfnbi,1:enbi)',
cx $ mpn(1:nilen,1:dfnb_old,1:enbi)
cx write(*,*) 'amp(1:nv,1:nilen,1:dfnb_old)',
cx $ amp(1:nv,1:nilen,1:dfnb_old)
cx write(*,*) 'ao2lno(1:enbi,1:nv)',
cx $ ao2lno(1:enbi,1:nv)
c second trf of the aux function index
if (lnaf.eq.1) then
c AF -> NAF trf (a^all,mu^shell,P^all) -> J_(Q^all,a^all,mu^shell)
call dgemm('t','t',edfnbi,nilen*nv,dfnb_old,1.d0,tr2naf,dfnb_old,
$amp,nilen*nv,0.d0,qam,edfnbi)
cx write(*,*) 'qam(1:edfnbi,1:nv,1:nilen)',
cx $ qam(1:edfnbi,1:nv,1:nilen)
cx write(*,*) 'tr2naf(1:dfnb_old,1:edfnbi)',
cx $ tr2naf(1:dfnb_old,1:edfnbi)
elseif (lnaf.eq.0) then
c fitting (a^all,mu^shell,P^all) and transpose to J_(P^all,a^all,mu^shell)
c call dgemm('t','t',edfnbi,nilen*nv,dfnb_old,1.d0,tr2naf,dfnb_old,
c $amp,nilen*nv,0.d0,qam,edfnbi)
cx write(*,*) 'qam(1:edfnbi,1:nv,1:nilen)',
cx $ qam(1:edfnbi,1:nv,1:nilen)
cx write(*,*) 'tr2naf(1:dfnb_old,1:edfnbi)',
cx $ tr2naf(1:dfnb_old,1:edfnbi)
call dtrmm('r','l','t','n',nilen*nv,dfnb_old,1.d0,tr2naf,dfnb_old
$ ,amp,nilen*nv)
call gtrans(amp,qam,nilen*nv,dfnb_old)
endif
c second AO->MO trf: J_(Q^all,a^all,mu^shell) -> J_(Q,[ab]) for each mu shell
do a=1,nv
p1=emapi(ifrst+1)
ab=a*(a-1)/2+1
call dgemm('n','n',edfnbi,a,nilen,1.d0,qam(1,a,1),edfnbi*nv,
$ao2lno(p1,1),enbi,1.d0,jab(1,ab),edfnbi)
enddo
cx write(*,*) 'jab(1:edfnbi,1:nv*(nv+1)/2)',
cx $ jab(1:edfnbi,1:nv*(nv+1)/2)
c drop (mu^shell,P^all,nu^all)
call dfillzero(mpn,nilen*edfnbi*enbi)
return
end subroutine ledintjab
c }}}
c
c {{{ subroutine lmuiptrfv0
subroutine lmuiptrfv0(nbasis,natoms,nocc,dfnbasis,no,mo,moadd,
$mupi,nilen,njlen,ifrst,jfrst,dfscr,at2lmo,iatoms,jatoms,edfmapinv,
$mapi,emodom,enbi,edfnbi,mupiscr,nupiscr,mnp,nmp,emapi)
************************************************************************
* Transform one index of three-index integrals to occupied LMO basis
* for only one extended domain
************************************************************************
implicit none
integer nbasis,nocc,dfnbasis,no,moadd(nocc),natoms,n,p,edfnbi
integer jj,at2lmo(natoms,0:nocc),nilen,njlen,ifrst,jfrst,i,j
integer edfmapinv(edfnbi),p1,emodom(nocc),jjj
integer mapi(nbasis,nocc),enbi,nu,mu,iatoms,jatoms,eao
integer emapi(nbasis)
real*8 mo(*),mupi(enbi,edfnbi,no),dfscr(nilen,njlen,dfnbasis)
real*8 mnp(nilen,njlen,edfnbi),mupiscr(nilen,edfnbi)
real*8 nmp(njlen,nilen,edfnbi),nupiscr(njlen,edfnbi)
c write(*,*) 'no,nocc,enbi,edfnbi',no,nocc,enbi,edfnbi
c write(*,*) 'moadd', moadd(1:nocc)
c write(*,*) 'at2lmo', at2lmo(1:natoms,0:nocc)
c write(*,*) 'emodom', emodom(1:natoms)
c write(*,*) 'edfmapinv', edfmapinv(1:edfnbi)
c write(*,*) 'emapi', emapi(1:nbasis)
c write(*,*) 'mo', mo(1:enbi*no)
c cp dfscr to mnp with condensed aux indexing and
c fill in the full (nilen,njlen) block of mnp if ifrst.eq.jfrst
if (1+ifrst.ne.1+jfrst) then
do p=1,edfnbi
n=edfmapinv(p)
call dcopy(nilen*njlen,dfscr(1,1,n),1,mnp(1,1,p),1)
enddo !p
elseif (1+ifrst.eq.1+jfrst) then
do p=1,edfnbi
n=edfmapinv(p)
do i=1,nilen
do j=1,njlen
if (i.ge.j) then
mnp(i,j,p)=dfscr(i,j,n)
else
mnp(i,j,p)=dfscr(j,i,n)
endif
enddo
enddo
enddo !p
endif
c (mu^shell,nu^shell,P^EDi) --> (nu^shell,P^EDi,i_LMO) trf
do j=1,at2lmo(iatoms,0)
jj=at2lmo(iatoms,j) ! which lmo has contribution from bf's on atom iatoms (index in ED_i)
jjj=emodom(jj) ! absolute index of jj
p1=moadd(jj)+mapi(ifrst+1,jjj)
c write(*,*) '1,j,ifrst,jfrst,nilen,njlen',j,ifrst,jfrst,nilen,njlen
c write(*,*) 'dfnbi', edfnbi ; flush(6)
call dgemv('t',nilen,njlen*edfnbi,1.d0,mnp,nilen,mo(p1),1,
$0.d0,nupiscr,1)
do nu=1,njlen
eao=emapi(jfrst+nu)
call daxpy(edfnbi,1.d0,nupiscr(nu,1),njlen,mupi(eao,1,jj),enbi)
cx if (eao.eq.3.and.jj.eq.1) then
cx write(*,*) '*******************************'
cx write(*,*) 'j,jj,iatom,at2lmo(iat,0),at2lmo(iat,at2lmo(iat,0))',
cx $j,jj,iatoms,at2lmo(iatoms,0),'-',at2lmo(iatoms,1:at2lmo(iatoms,0))
cx write(*,'(a44,3x,5i4,10f8.4)')
cx % 'ifrst,jfrst,nilen,njlen,nu,mnp(1:nilen,nu,1)',
cx $ ifrst,jfrst,nilen,njlen,nu,mnp(1:nilen,nu,1)
cx write(*,*) 'mo', mo(p1:p1+nilen-1)
cx write(*,*) 'nupiscr(',nupiscr(nu,1),'mupi(',mupi(eao,1,jj)
cx write(*,*) '*******************************'
cx endif
enddo
c write(*,*) 'j LMO, jj,jjj,p1',j,jj,jjj,p1,nilen,njlen,enbi,edfnbi
c write(*,'(a5,10000f8.4)') 'mnp',mnp
c write(*,'(a5,10000f8.4)') 'mo',mo(p1:p1+nilen-1)
c write(*,'(a5,10000f8.4)') 'nupis',nupiscr
c write(*,'(a5,10000f8.4)') 'mupit',mupi
enddo
c mu <--> nu contribution to (nu^shell,P^EDi,i_LMO)
if (1+ifrst.ne.1+jfrst) then
do i=1,nilen
do j=1,njlen
call dcopy(edfnbi,mnp(i,j,1),nilen*njlen,nmp(j,i,1),nilen*njlen)
enddo
enddo
do j=1,at2lmo(jatoms,0)
jj=at2lmo(jatoms,j) ! which lmo has contribution from bf's on atom jatoms
jjj=emodom(jj) ! absolute index of jj
p1=moadd(jj)+mapi(jfrst+1,jjj)
c write(*,*) '2,j,ifrst,jfrst,nilen,njlen',j,ifrst,jfrst,nilen,njlen
c write(*,*) 'dfnbi', edfnbi ; flush(6)
call dgemv('t',njlen,edfnbi*nilen,1.d0,nmp,njlen,mo(p1),1,
$0.d0,mupiscr,1)
do mu=1,nilen
eao=emapi(ifrst+mu)
call daxpy(edfnbi,1.d0,mupiscr(mu,1),nilen,mupi(eao,1,jj),enbi)
cx if (eao.eq.3.and.jj.eq.1) then
cx write(*,*) '******** reverse term **********************'
cx write(*,'(a44,3x,5i4,10f8.4)')
cx $ 'ifrst,jfrst,nilen,njlen,mu,mnp(1:njlen,mu,1)',
cx $ ifrst,jfrst,nilen,njlen,mu,mnp(1:njlen,mu,1)
cx write(*,*) 'mo', mo(p1:p1+njlen-1)
cx write(*,*) 'mupiscr(',nupiscr(mu,1),'mupi(',mupi(eao,1,jj)
cx write(*,*) '*********end of resverse term ****************'
cx endif
enddo
c write(*,*) 'reverse part'
c write(*,*) 'j LMO, jj,jjj,p1',j,jj,jjj,p1,nilen,njlen,enbi,edfnbi
c write(*,'(a5,10000f8.4)') 'nmp',nmp
c write(*,'(a5,10000f8.4)') 'mo',mo(p1:p1+njlen-1)
c write(*,'(a5,10000f8.4)') 'nupis',nupiscr
c write(*,'(a5,10000f8.4)') 'mupit',mupi
enddo
endif
end
c }}}
c
c {{{ subroutine lmipined
subroutine lmipined(nilen,njlen,nklen,mno,nno,dfscr,nb,no,
$mippsh,pm,pn,cmi,cni,mlist,nlist,mipsd,nipsd)
************************************************************************
* Transform one index of three-index AO integral shell triplet to the occupied LMO basis
* of only one extended domain
************************************************************************
implicit none
integer nilen,njlen,nklen,mno,nno,nb,no
integer pm,pn,mlist(mno),nlist(nno)
real*8 cmi(nilen,mno),cni(njlen,nno)
real*8 dfscr(nilen,njlen,nklen),mippsh(nb,no,nklen)
real*8 mipsd(nilen,nno,nklen),nipsd(njlen,mno,nklen)
c internal variables
integer p,i,pm2,pn2,ii,j
c
c expand symmetry if nu and mu belong to the same shell
if (pn.eq.pm) then
do i=1,nilen
do j=i+1,njlen
dfscr(i,j,1:nklen)=dfscr(j,i,1:nklen)
enddo
enddo
endif
if (pm.gt.0) then ! mu is on an atom of the ED/PCD
c (mu^shell,nu^shell,P^shell) --> (mu^shell,I_LMO,P^shell) trf, version B
do p=1,nklen
c transform for a (mu^shell,nu^shell) doublet at a time
mipsd(1:nilen,1:nno,p)=matmul(dfscr(1:nilen,1:njlen,p),cni)
enddo
c cumulate (mu^shell,I_LMO,P^shell) contribution to (mu^all,I_LMO,P^shell)
pm2=pm+nilen-1
do p=1,nklen
do i=1,nno
ii=nlist(i)
mippsh(pm:pm2,ii,p)=mippsh(pm:pm2,ii,p)+mipsd(1:nilen,i,p)
enddo
enddo
endif
c mu <--> nu contribution to (mu^all,I_LMO,P^shell)
if (pn.ne.pm.and.pn.gt.0) then ! nu is on an atom of the ED/PCD, pn has to be .gt.0 here due to atpair selection
do p=1,nklen
c transform for a (mu^shell,nu^shell) doublet at a time
nipsd(1:njlen,1:mno,p)=
$ matmul(transpose(dfscr(1:nilen,1:njlen,p)),cmi)
enddo
c cumulate (nu^shell,I_LMO,P^shell) contribution to (mu^all,I_LMO,P^shell)
pn2=pn+njlen-1
do p=1,nklen
do i=1,mno
ii=mlist(i)
mippsh(pn:pn2,ii,p)=mippsh(pn:pn2,ii,p)+nipsd(1:njlen,i,p)
enddo
enddo
endif
return
end subroutine lmipined
c }}}
c
c {{{ subroutine lmpained
subroutine lmpained(nilen,njlen,nklen,nvirt,dfscr,nb,
$mshpa,nshpa,vlno,mallpa,pm,pn,nthread)
************************************************************************
* Transform one index of three-index AO integral shell triplet to the virtual LNO basis
* of only one extended domain
************************************************************************
implicit none
integer nilen,njlen,nklen,nb,nvirt
integer pm,pn,nthread
real*8 dfscr(nilen,njlen,nklen),mallpa(nb,nklen,nvirt)
real*8 mshpa(nilen,nvirt,nklen),nshpa(njlen,nklen,nvirt)
real*8 vlno(nb,*)
c internal variables
integer i,j,p,a,pm2,pn2
c
c expand symmetry if nu and mu belong to the same shell
if (pn.eq.pm) then
do i=1,nilen
do j=i+1,njlen
dfscr(i,j,1:nklen)=dfscr(j,i,1:nklen)
enddo
enddo
endif
pm2=pm+nilen-1
pn2=pn+njlen-1
c write(*,*) 'pm,pn,pm2,pn2,nvirt,nilen,njlen,nklen'
c write(*,*) pm,pn,pm2,pn2,nvirt,nilen,njlen,nklen
c write(*,'("dfscr",3i4,1000es14.6)') nilen,njlen,nklen,
c $dfscr(1:nilen,1:njlen,1:nklen)
c write(*,'("vlno1",2i4,1000es14.6)') njlen,nvirt,
c $vlno(pn:pn2,1:nvirt)
c write(*,'("vlno2",2i4,1000es14.6)') nilen,nvirt,
c $vlno(pm:pm2,1:nvirt)
c (mu^shell,nu^shell,P^shell) --> (mu^shell,a_LNO,P^shell) trf
do p=1,nklen
c transform for a (mu^shell,nu^shell) doublet at a time
mshpa(1:nilen,1:nvirt,p)=
$ matmul(dfscr(1:nilen,1:njlen,p),vlno(pn:pn2,1:nvirt))
c write(*,*) 'mshpa for p',p
c write(*,'(1000f12.6)') mshpa(1:nilen,1:nvirt,p)
enddo
c cumulate (mu^shell,a_LNO,P^shell) contribution to (mu^all,P^shell,a_LNO)
c write(*,*) 'mallpa 1 before adding mshpa', pm,'-',pm2
c write(*,'(1000f12.6)') mallpa(pm:pm2,1:nklen,1:nvirt)
do a=1,nvirt
do p=1,nklen
mallpa(pm:pm2,p,a)=mallpa(pm:pm2,p,a)+mshpa(1:nilen,a,p)
enddo
enddo
c mu <--> nu contribution to (nu^all,P^shell,a_LNO)
if (pn.ne.pm) then
c transform the shell triplet in one step
call dmatmul('t','n',njlen*nklen,nvirt,nilen,1.d0,dfscr,
$nilen,vlno(pm:pm2,1:nvirt),nilen,0.d0,nshpa,njlen*nklen,'auto ',
$nthread)
c cumulate (nu^shell,P^shell,a_LNO) contribution to (nu^all,P^shell,a_LNO)
mallpa(pn:pn2,1:nklen,1:nvirt)=mallpa(pn:pn2,1:nklen,1:nvirt)+
$ nshpa(1:njlen,1:nklen,1:nvirt)
endif
c write(*,*) 'full mallpa 2',nb,nvirt
c write(*,'(1000es14.6)') mallpa(1:nb,1:nklen,1:nvirt)
return
end subroutine lmpained
c }}}
c
c {{{ subroutine led2ndtrf
subroutine led2ndtrf(lintra,mippsh,aip,cpao,npao,enbi,no,nklen,
$edfnbi,pp,nproc,jipsh,jpi,aotocmo,smallmem,mooc,apofci,aipsh,
$aqofci,aipinmem,nch,chol,mooci,acipsh,aipfile,noa,oslcc,alpha,
$docc,ldofchol)
************************************************************************
* perform
* if lintra.eq.9:
* (muI,P^shell) -> (aIP), I: orignal LMO at PD_i, a: PAO
* if lintra.eq.10: do (aIP) of lintra.eq.9 and
* (muI,P^shell) -> (jIP) j: canonical occ MO in ED
* transformations for a single extended domain
************************************************************************
implicit none
integer lintra,npao,enbi,no,nklen,edfnbi,pp,nproc,i,p,ppp,q
real*8 mippsh(enbi,noa,nklen),aip(npao,no,*),jpi(no,edfnbi,noa)
real*8 cpao(enbi,npao),jipsh(no,noa,nklen),aotocmo(enbi,no)
c for smallmem
integer nch,aipfile,recn,firstmo,ldofchol,noa !noa is the occupied dimension of mippsh
real*8 apofci(npao,edfnbi),mooc(no,no),aipsh(npao,noa,nklen)
real*8 aqofci(npao,edfnbi,nch),chol,mooci,acipsh(npao,no,nklen)
logical smallmem,aipinmem,alpha,oslcc,docc
c
c If the central LMO is singly occupied we don't need it's
c contribution to the beta canonical occupied orbitals
c therefore we need to start the trf of I from the 2nd LMO
firstmo=1
if (oslcc.and..not.alpha.and..not.docc) firstmo=2
c (muI,P^shell) -> (j,I,P) contribution
if (lintra.eq.10) then
call dgemm('t','n',no,nklen*noa,enbi,1.d0,aotocmo,enbi,
$mippsh,enbi,0.d0,jipsh,no)
c tranpose (jIP) into (jPI) form
ppp=pp-1
firstmo=firstmo-1
do p=1,nklen
do i=1,no
call dcopy(no,jipsh(1,firstmo+i,p),1,jpi(1,ppp+p,i),1)
enddo
enddo
firstmo=firstmo+1
endif
c
c (muI,P^shell) -> (a_PAO,I,P) contribution
if (.not.smallmem) then
call dgemm('t','n',npao,nklen*noa,enbi,1.d0,cpao,enbi,
$mippsh,enbi,0.d0,aip(1,1,pp),npao)
elseif (smallmem) then
call dgemm('t','n',npao,nklen*noa,enbi,1.d0,cpao,enbi,
$mippsh,enbi,0.d0,aipsh,npao)
if(aipinmem) then
do q=1,nklen
if (alpha.or.docc) apofci(1:npao,pp+q-1)=aipsh(1:npao,1,q) ! save (aIP) for the central MO: (aP)_I
c transform (aIP) to the new pscan occ basis of the ED: (aiP)
call dgemm('n','n',npao,no,no,1.d0,aipsh(1,firstmo,q),npao,
$mooc,no,0.d0,aip(1,1,pp+q-1),npao)
enddo
elseif(.not.aipinmem) then
do q=1,nklen
if (alpha.or.docc) apofci(1:npao,pp+q-1)=aipsh(1:npao,1,q) ! save (aIP) for the central MO: (aP)_I
c transform (aIP) to the new pscan occ basis of the ED: (aiP)
call dgemm('n','n',npao,no,no,1.d0,aipsh(1,firstmo,q),npao,
$mooc,no,0.d0,acipsh(1,1,q),npao)
enddo
call make_aqwofci(aqofci,npao,nklen,nch,no,
$aipsh,chol,mooci,acipsh,pp-1,edfnbi,ldofchol,.false.)
c transpose (aiP) to (aPi) and write to AIPED file
do i=1,no
do q=1,nklen
recn=(i-1)*edfnbi+pp+q-1
write(aipfile,rec=recn) acipsh(1:npao,i,q)
enddo
enddo
call dfillzero(acipsh,npao*no*nklen)
endif ! aipinmem
call dfillzero(aipsh,nklen*noa*npao)
endif ! smallmem
c
c drop (muI,P^shell)
if (.not.(oslcc.and.alpha))
& call dfillzero(mippsh,nklen*noa*enbi*nproc)
return
end
c }}}
c
c {{{ subroutine ljabtrf
subroutine ljabtrf(nb,nvirt,nklen,edfnbi,dfnb_old,mallpa,jpab,
$jqab,vlno,pp,xyzomp,lnaf,tr2naf,lintra,dfcoralg)
************************************************************************
* perform (mu,P^shell,a^all) -> (P^shell,[ab]) transformations for a single extended domain
* if lnaf.eq.0 -> fitting of (P^shell,[ab]) and add contribution to the final J(Q,[ab]) list
* if lnaf.eq.1 -> trf (P^shell,[ab]) to Jpi NAF basis and add contribution to the final J(Q,[ab]) list
* if lnaf.eq.2 -> fitting and storage of (P^shell,[ab]), compute Jpq NAFs later
* if lnaf.eq.3 -> do not fit (P^shell,[ab]), transpose it to ([ab],P^shell) when written to disk later
* if lintra.eq.13 -> do not fit (P^shell,[ab])
************************************************************************
implicit none
integer nb,nvirt,nklen,edfnbi,dfnb_old,lnaf,xyzomp,pp,lintra
real*8 mallpa(nb,nklen,*),jqab(edfnbi,*)
real*8 vlno(nb,*),jpab(nklen,*)
real*8 tr2naf(dfnb_old,edfnbi)
character*8 dfcoralg
c internal varibles
integer b,p,pp2
c (mu,P^shell,a^all) -> (P^shell,[ab]) trf ([ab] upper triangle) for a single b at a time
do b=1,nvirt
p=b*(b-1)/2+1
call dgemv('t',nb,nklen*b,1.d0,mallpa,nb,vlno(1,b),1,0.d0,
$ jpab(1,p),1)
enddo
c write(*,*)
c write(*,*) '* # * # * # * # * # * # * # * # * # * # * # * # * # *'
c write(*,*) 'jpab',nklen,nvirt*(nvirt+1)/2
c write(*,'(1000f12.6)') jpab
c write(*,*) 'tr2naf',dfnb_old,edfnbi
c write(*,'(1000f12.6)') tr2naf
c write(*,*) 'jqab dgemm elott',edfnbi,nvirt*(nvirt+1)/2
c write(*,'(1000f12.6)') jqab
c fitting/NAF trf
pp2=edfnbi
if (lnaf.eq.0.and.lintra.ne.13.and.dfcoralg.eq."cholinv ") then
c fitting, use only the nonzero elements of tr2naf
c write(*,*) 'lnaf,pp2,nvirt,nklen,pp,dfnb_old,edfnbi'
c write(*,'(10i4)') lnaf,pp2,nvirt,nklen,pp,dfnb_old,edfnbi
call dgemm('n','n',pp2,nvirt*(nvirt+1)/2,nklen,1.d0,
$tr2naf(1,pp),dfnb_old,jpab,nklen,1.d0,jqab,edfnbi)
elseif (lnaf.eq.1) then
call dgemm('t','n',pp2,nvirt*(nvirt+1)/2,nklen,1.d0,tr2naf(pp,1),
$dfnb_old,jpab,nklen,1.d0,jqab,edfnbi)
elseif (lnaf.eq.2.or.lintra.eq.13.or.dfcoralg.eq."lineq ") then
c fitting or NAF trf later in subroutine edpao2vlnoterms or jpqnaf, respectively, just copy jpab to its place in jqab
do p=1,nklen
pp2=pp+p-1
call dcopy(nvirt*(nvirt+1)/2,jpab(p,1),nklen,
$ jqab(pp2,1),dfnb_old)
enddo
elseif (lnaf.eq.3) then
c do not fit (P^shell,[ab]), transpose it to ([ab],P^shell) when written to disk later
continue
endif
return
end
c }}}
c
c {{{ subroutine prescrmo
subroutine prescrmo(cmax,pmax,natoms,nangmax,nang,atpair,enbi,
$eno,npao,csmax,omo,cpao,at2lmo,nocc,emodom,moadd,mapi,
$nbasis,nshrange,emapi,aotocmo,comax,ltrfsai,vlno,ltrfsab,lintra,
$cpaob,npaob,aotocmob,enob,oslcc) !oslcc)
************************************************************************
* precompute various LMO and PAO coefficient maximas for prescreening
************************************************************************
implicit none
integer natoms,nangmax,enbi,eno,npao,nocc,nbasis
integer nang(natoms),atpair(natoms,natoms),at2lmo(natoms,0:nocc)
integer emodom(nocc),moadd(*),mapi(nbasis,nocc),anywhere
integer nshrange(2,0:nangmax,natoms),emapi(nbasis),lintra
real*8 csmax(eno,0:nangmax,natoms),comax(0:nangmax,natoms)
real*8 cmax(0:nangmax,natoms),pmax(0:nangmax,natoms)
real*8 omo(*),cpao(enbi,npao),aotocmo(enbi,eno),vlno(enbi,*)
c SB oslcc
integer npaob,enob
real*8 cpaob(enbi,npaob),aotocmob(enbi,enob)
logical oslcc
c internal variables
integer nilen,ifrst,pm,pm2,jj,jo,jjj,p1,p2
integer iiatoms,iangmax,iiang,jjatoms
logical ltrfsai,ltrfsab
call dfillzero(pmax,natoms*(nangmax+1))
if (ltrfsai) then
call dfillzero(csmax,natoms*(nangmax+1)*eno)
call dfillzero(comax,natoms*(nangmax+1))
call dfillzero(cmax,natoms*(nangmax+1))
do iiatoms=1,natoms
iangmax=nang(iiatoms)
anywhere=atpair(iiatoms,iiatoms)
do jjatoms=1,natoms ! find if atom iiatoms appear paired with any other atoms
if (anywhere.eq.1) exit
anywhere=
$ max(anywhere,atpair(iiatoms,jjatoms),atpair(jjatoms,iiatoms))
enddo
if(anywhere.eq.0) iangmax=-1 ! integrals with AOs on iiatoms are not computed
do iiang=0,iangmax
ifrst=nshrange(1,iiang,iiatoms)
nilen=nshrange(2,iiang,iiatoms)-ifrst
pm=emapi(ifrst+1)
pm2=pm+nilen-1
c max PAO/LNO coefficient values
if (pm.ne.0) then ! needed of asymmetric atpair, e.g., in the case of inttyp=30
pmax(iiang,iiatoms)=maxval(dabs(cpao(pm:pm2,1:npao)))
if (oslcc.and.npaob.gt.0.and.enob.gt.0)pmax(iiang,iiatoms)=
$ max(maxval(dabs(cpaob(pm:pm2,1:npaob))),pmax(iiang,iiatoms))
c max AO to canonical occupied MO coefficient values
if (lintra.eq.10) then
comax(iiang,iiatoms)=maxval(dabs(aotocmo(pm:pm2,1:eno)))
if (oslcc.and.npaob.gt.0.and.enob.gt.0)comax(iiang,iiatoms)=
$ max(maxval(dabs(aotocmob(pm:pm2,1:enob))),comax(iiang,iiatoms))
endif !lintra.eq.10
endif ! pm.ne.0
c max occ LMO coefficient values
do jo=1,at2lmo(iiatoms,0)
jj=at2lmo(iiatoms,jo) ! which lmo has contribution from bf's on atom iatoms (index in ED_i)
jjj=emodom(jj) ! absolute index of jj
p1=moadd(jj)+mapi(ifrst+1,jjj)
p2=p1+nilen-1
csmax(jj,iiang,iiatoms)=maxval(dabs(omo(p1:p2)))
enddo
cmax(iiang,iiatoms)=maxval(csmax(1:eno,iiang,iiatoms))
enddo ! iiang
enddo ! iiatoms
elseif(ltrfsab) then
do iiatoms=1,natoms
iangmax=nang(iiatoms)
anywhere=atpair(iiatoms,iiatoms)
do jjatoms=1,natoms ! find if atom iiatoms appear paired with any other atoms
if (anywhere.eq.1) exit
anywhere=
$ max(anywhere,atpair(iiatoms,jjatoms),atpair(jjatoms,iiatoms))
enddo
if(anywhere.eq.0) iangmax=-1 ! integrals with AOs on iiatoms are not computed
do iiang=0,iangmax
ifrst=nshrange(1,iiang,iiatoms)
nilen=nshrange(2,iiang,iiatoms)-ifrst
pm=emapi(ifrst+1)
pm2=pm+nilen-1
c max virt LNO coefficient values
pmax(iiang,iiatoms)=maxval(dabs(vlno(pm:pm2,1:npao))) ! npao=nvirt
enddo ! iiang
enddo ! iiatoms
c write(*,*) 'vlno',enbi,npao
c write(*,'(1000f12.6)') vlno(1:enbi,1:npao)
c write(*,*) 'pmax,natoms,nangmax',natoms,nangmax
c write(*,'(1000f12.6)') pmax(0:nangmax,1:natoms)
endif
return
end
c }}}
c
c {{{ idoadd ido
subroutine idoadd(tc,tw,tc0,tw0)
implicit none
real*8 tc,tw,tmp,tc0,tw0
integer w,ps
call CPU_TIME(tmp)
tc=tc+tmp-tc0
call SYSTEM_CLOCK(w,ps)
tw=tw+dble(w)/dble(ps)-tw0
return
end
subroutine ido(tc,tw)
implicit none
real*8 tc,tw
integer w,ps
call CPU_TIME(tc)
call SYSTEM_CLOCK(w,ps)
tw=dble(w)/dble(ps)
return
end
c }}}
c
c{{{ subroutine lfirsthalf_ab
************************************************************************
subroutine lfirsthalf_ab(nbf,nocc,dfnbasis,bfdom,acteds,dfadd,
$emapi,enbi,edfnbi,mo,moadd,jbqm,intadd,nilen,njlen,ifrst,
$jfrst,dfint,edfmapinv,
$edinbl,frsted,edfnboldi,tr2naf,mnp,jmnq,cmb,cmb2,vlni,jnqm,jmqn, !NP
$jnqm2,jmqn2,lintra)!NP
************************************************************************
* Integral direct fitting (and aux to NAF trf) + first half AO->vLNO trf in ED's
************************************************************************
implicit none
integer nbf,nocc,dfnbasis,i,j,q
integer bfdom(0:nocc,nbf),n,iii,nbfdi,nbfdj,jjj
integer emapi(nbf,nocc),iocc,jfrst,jocc
integer enbi(nocc),edfnbi(nocc),moadd(nocc)
integer intadd(nocc),nilen,njlen,ifrst
integer edfmapinv(dfnbasis,nocc)
real*8 mo(*),dfint(nilen,njlen,dfnbasis)
c variables for Jab construction
integer edinbl,p,edfnboldi(nocc),frsted,nacted,d,vlni(nocc),lintra
integer acteds(nocc),dfadd(nocc),pp
real*8 mnp(nilen,njlen,*),jmnq(nilen,njlen,*),jnqm(*),jnqm2(*)
real*8 jbqm(*),cmb(njlen,*),cmb2(nilen,*),tr2naf(*)
real*8 jmqn(nilen,*),jmqn2(nilen,*)
c
c (munu,P)_{all} contributes to these act ED's in the current block of ED's
nacted=0
call ifillzero(acteds,nocc)
nbfdi=bfdom(0,ifrst+1)
nbfdj=bfdom(0,jfrst+1)
if(nbfdi+nbfdj.gt.0) then
do iii=1,nbfdi
do jjj=1,nbfdj
iocc=bfdom(iii,ifrst+1)
jocc=bfdom(jjj,jfrst+1)
if (iocc.eq.jocc.and. ! both ifrst+1 and jfrst+1 are in the same ED
$ (iocc.ge.frsted.and.iocc.lt.frsted+edinbl)) then ! and this ED is in the block
nacted=nacted+1
acteds(nacted)=iocc
endif ! i and j are in the same ED
enddo
enddo
endif !nbfdi+nbfdj.gt.0
c
if(1+ifrst.ge.1+jfrst) then
do d=1,nacted
iocc=acteds(d)
c sort (munu,P)^i for ED d from (munu,P_{all in the block})
if (1+ifrst.gt.1+jfrst) then
do p=1,edfnboldi(iocc)
n=edfmapinv(p,iocc)
call dcopy(nilen*njlen,dfint(1,1,n),1,mnp(1,1,p),1)
enddo !p
elseif (1+ifrst.eq.1+jfrst) then
do p=1,edfnboldi(iocc)
n=edfmapinv(p,iocc)
do i=1,nilen
do j=1,njlen
if (i.ge.j) then
mnp(i,j,p)=dfint(i,j,n)
else
mnp(i,j,p)=dfint(j,i,n)
endif
enddo
enddo
enddo !p
endif
c db
c write(*,*) 'dimensions', iocc
c write(*,*) 'nilen,njlen,edfnboldi(iocc),dfadd(iocc)',
c $ nilen,njlen,edfnboldi(iocc),edfnbi(iocc),dfadd(iocc)
cc write(*,*) '(munuP)' ,iocc, ifrst+1,jfrst+1
cc write(*,*) mnp(1:nilen,1:njlen,1:edfnboldi(iocc))
c write(*,*) 'tr2naf' ,iocc
c write(*,*)
c $tr2naf(dfadd(iocc)+1:dfadd(iocc)+edfnboldi(iocc)*edfnbi(iocc))
c db
C fitting and transform to the NAF basis: (munu,P)^i -> (J_mn^Q)^i=(munuQ)^i
if (lintra.eq.2) then
call dgemm('n','n',nilen*njlen,edfnbi(iocc),edfnboldi(iocc),
$1.d0,mnp,nilen*njlen,tr2naf(dfadd(iocc)+1),edfnboldi(iocc),0.d0,
$jmnq,nilen*njlen)
c db
c write(*,*) 'jmnq',iocc , edfnbi(iocc) , edfnboldi(iocc)
c write(*,*) -1.d0*jmnq(1:nilen,1:njlen,1:edfnbi(iocc))
c db
elseif (lintra.eq.3) then
c only fitting, no NAF's
call dtrmm('r','l','t','n',nilen*njlen,edfnboldi(iocc),1.d0,
$ tr2naf(dfadd(iocc)+1),edfnboldi(iocc),mnp,nilen*njlen)
c db
c write(*,*) 'jmnq',iocc, edfnbi(iocc) , edfnboldi(iocc)
c write(*,*) mnp(1:nilen,1:njlen,1:edfnbi(iocc))
c db
endif ! lintra
c Integral direct trf of one AO index to vLNO: (J_munu,Q)^i -> (J_bQmu)^i
c select the necessary MO coefficients
do j=1,njlen
pp=emapi(jfrst+j,iocc)
call dcopy(vlni(iocc),mo(moadd(iocc)+pp),enbi(iocc),
$ cmb(j,1),njlen)
c db
c if (iocc.eq.3) then
c write(*,*) 'iocc,j,p,enbi(i),emapi(j,i),cmb(j,i),moadd(iocc)'
c write(*,*) iocc,j,pp,enbi(iocc),emapi(jfrst+j,iocc),
c $cmb(j,1:vlni(iocc)), moadd(iocc) ; flush(6)
c endif
c db
enddo
c transpose and transform: (munu|Q)^i -> (nuQmu)^i -> (bQmu)^i
c and cumulate contributions (bQmu)^i into (bQmu)^{all i in block}
c (munu|Q)^i -> (nuQmu)^i
p=intadd(iocc)+vlni(iocc)*edfnbi(iocc)*(emapi((ifrst+1),iocc)-1)
c db
c if (iocc.eq.3) then
c write(*,*) 'p,intadd(iocc),vlni(iocc),edfnbi(iocc),
c $ emapi((ifrst+1),iocc)-1'
c write(*,*) p,intadd(iocc),vlni(iocc),edfnbi(iocc),
c $ emapi((ifrst+1),iocc)-1
c endif
c db
if (lintra.eq.2) then
c db write(*,*) 'SZEMET, only contrib'
call gtrans(jmnq,jnqm,nilen,njlen*edfnbi(iocc))
call dgemm('t','n',vlni(iocc),edfnbi(iocc)*nilen,njlen,1.d0,
$cmb,njlen,jnqm,njlen,1.d0,jbqm(p+1),vlni(iocc))
c db
c if (iocc.eq.3) then
c write(*,*) 'jbqm, ifrst,jfrst, p', ifrst,jfrst, p
c write(*,*)-1.d0*jbqm(p+1:p+edfnbi(iocc)*nilen*vlni(iocc))
c endif
c db
elseif (lintra.eq.3) then
c db write(*,*) 'SZEMET, only contrib'
call gtrans(mnp,jnqm2,nilen,njlen*edfnbi(iocc))
call dgemm('t','n',vlni(iocc),edfnbi(iocc)*nilen,njlen,1.d0,
$cmb,njlen,jnqm2,njlen,1.d0,jbqm(p+1),vlni(iocc))
c db
c if (iocc.eq.3) then
c write(*,*) 'jbqm, ifrst,jfrst, p', ifrst,jfrst, p
c write(*,*) jbqm(p+1:p+edfnbi(iocc)*nilen*vlni(iocc)) ;flush(6)
c endif
c db
endif
c second contribution of (bQmu)^i to (bQnu)^{all i in block} (mu <--> nu)
if (1+ifrst.ne.1+jfrst) then
do j=1,nilen
pp=emapi(ifrst+j,iocc)
call dcopy(vlni(iocc),mo(moadd(iocc)+pp),enbi(iocc),
$ cmb2(j,1),nilen)
c db
c if (iocc.eq.3.and.ifrst.ge.8) then
c write(*,*) 'iocc,j,p,enbi(i),emapi(j,i),cmb(j,i),moadd(iocc)'
c write(*,*) iocc,j,pp,enbi(iocc),emapi(jfrst+j,iocc),
c $cmb2(j,1:vlni(iocc)), moadd(iocc) ; flush(6)
c endif
c db
enddo
p=intadd(iocc)+vlni(iocc)*edfnbi(iocc)*(emapi((jfrst+1),iocc)-1)
c db
c if (iocc.eq.3) then
c write(*,*) 'p,intadd(iocc),vlni(iocc),edfnbi(iocc),
c $ emapi((ifrst+1),iocc)-1,edfnboldi(iocc)'
c write(*,*) p,intadd(iocc),vlni(iocc),edfnbi(iocc),
c $ emapi((ifrst+1),iocc)-1,edfnboldi(iocc)
c endif
c db
if (lintra.eq.2) then
c rearrangement (munu|Q)^i -> (muQnu)^i
do i=1,nilen
do j=1,njlen
do q=1,edfnbi(iocc)
pp=(j-1)*edfnbi(iocc)+q
jmqn(i,pp)=jmnq(i,j,q)
enddo
enddo
enddo
c db
c if (iocc.eq.3.and.ifrst.ge.8) then
c write(*,*) 'jmqn', ifrst,jfrst, nilen , njlen, edfnbi(iocc)
c write(*,*) -1.d0*jmqn(1:nilen,1:edfnbi(iocc)*njlen)
c endif
c db
c contribution of (numu|Q) to (bQnu)^i
call dgemm('t','n',vlni(iocc),edfnbi(iocc)*njlen,nilen,1.d0,
$cmb2,nilen,jmqn,nilen,1.d0,jbqm(p+1),vlni(iocc))
c db
c write(*,*) 'SZEMET, only contrib'
c write(*,*) 'p,vlni(iocc),edfnbi(iocc)*njlen,nilen,p+il'
c write(*,*) p,vlni(iocc),edfnbi(iocc)*njlen,nilen
c $ ,p+edfnbi(iocc)*njlen*vlni(iocc)
c if (iocc.eq.3) then
c if (iocc.eq.3.and.ifrst.ge.8) then
c write(*,*) 'jbqm, ifrst,jfrst, p', ifrst,jfrst, p
c write(*,*) -1.d0*jbqm(p+1:p+edfnbi(iocc)*njlen*vlni(iocc))
c endif
c db
elseif (lintra.eq.3) then
do i=1,nilen
do j=1,njlen
do q=1,edfnbi(iocc)
pp=(j-1)*edfnbi(iocc)+q
jmqn2(i,pp)=mnp(i,j,q)
enddo
enddo
enddo
c db
c if (iocc.eq.3.and.ifrst.ge.8) then
c write(*,*)'jmqn',ifrst,jfrst, nilen , njlen,edfnbi(iocc),
c $ edfnboldi(iocc)
c write(*,*) jmqn2(1:nilen,1:edfnbi(iocc)*njlen)
c endif
c db
c contribution of (numu|Q) to (bQnu)^i
call dgemm('t','n',vlni(iocc),edfnbi(iocc)*njlen,nilen,1.d0,
$cmb2,nilen,jmqn2,nilen,1.d0,jbqm(p+1),vlni(iocc))
c db
c write(*,*) 'SZEMET, only contrib'
c write(*,*) 'p,vlni(iocc),edfnbi(iocc)*njlen,nilen'
c write(*,*) p,vlni(iocc),edfnbi(iocc)*njlen,nilen
c $ ,p+edfnbi(iocc)*njlen*vlni(iocc)
c if (iocc.eq.3.and.ifrst.ge.8) then
c write(*,*) 'jbqm, ifrst,jfrst, p', ifrst,jfrst, p
c write(*,*) jbqm(p+1:p+edfnbi(iocc)*njlen*vlni(iocc)) ;flush(6)
c endif
c db
endif ! lintra
endif ! mu .ne. nu
enddo !d
endif ! ii+ifrst.ge.jj+jfrst
return
end
c }}}
c
C {{{ lfirsthalf
************************************************************************
subroutine lfirsthalf(nbf,nocc,dfnbasis,bfdom,ibfdom,jbfdom,umapi,
$udfnbi,mo,moadd,jmi,intadd,mapi,nilen,njlen,ifrst,jfrst,
$dfint,udfmapinv)
************************************************************************
* Integral direct local first half-transformation
************************************************************************
implicit none
integer nbf,nocc,dfnbasis,i,j,k,nn,ii,jj
integer bfdom(0:nocc,nbf),iii,nbfdi,nbfdj,ndi,ndj
integer ibfdom(nocc),jbfdom(nocc),umapi(nbf,nocc),iocc,jfrst
integer udfnbi(nocc),moadd(nocc)
integer intadd(nocc),mapi(nbf,nocc),iadd,nilen,njlen,ifrst
integer udfmapinv(dfnbasis,nocc)
real*8 mo(*),jmi(*),coef,dfint(nilen,njlen,dfnbasis)
C
do ii=1,nilen
i=ii+ifrst
nbfdi=bfdom(0,i)
do jj=1,njlen
j=jj+jfrst
if(i.ge.j) then
nbfdj=bfdom(0,j)
if(nbfdi+nbfdj.gt.0) then
ndi=0
do iii=1,nbfdi
if(umapi(j,bfdom(iii,i)).ne.0) then
ndi=ndi+1
ibfdom(ndi)=bfdom(iii,i)
endif
enddo
ndj=0
do iii=1,nbfdj
if(umapi(i,bfdom(iii,j)).ne.0) then
ndj=ndj+1
jbfdom(ndj)=bfdom(iii,j)
endif
enddo
if(ndi+ndj.gt.0) then
do iii=1,ndi
iocc=ibfdom(iii)
coef=mo(moadd(iocc)+mapi(i,iocc))
nn=udfnbi(iocc)
iadd=intadd(iocc)+(umapi(j,iocc)-1)*nn
do k=1,nn
jmi(iadd+k)=jmi(iadd+k)+dfint(ii,jj,udfmapinv(k,iocc))*coef
enddo
enddo
if(i.ne.j) then
do iii=1,ndj
iocc=jbfdom(iii)
coef=mo(moadd(iocc)+mapi(j,iocc))
nn=udfnbi(iocc)
iadd=intadd(iocc)+(umapi(i,iocc)-1)*nn
do k=1,nn
jmi(iadd+k)=jmi(iadd+k)+dfint(ii,jj,udfmapinv(k,iocc))*coef
enddo
enddo
endif
endif
endif
endif
enddo
enddo
C
return
end
C }}}
c
C {{{ edpao2vlnoterms
************************************************************************
subroutine edpao2vlnoterms(jpab,nv,dfnb,lmo2vlnop,nlmo,jpi,jpa,
$mooc,canlmo2vlno,edpao2vlno,kpa,jabqterm,lnaf,fc,
$dfcoralg,oslcc,docc,nvb)
************************************************************************
* add the mukP and klP dependent (2)-(4) tems to term (1) at jpab
* a,b: canonical vLNO index
* see Eq. 21 of JCTC 14, 4193-4215 (2018)
************************************************************************
implicit none
integer nv,dfnb,nlmo,b,p,ab,a,lnaf,nvb,I,ncso,ifrst,nvp
real*8 jpab(dfnb,*),lmo2vlnop(nlmo,nv),edpao2vlno(*)
real*8 jpi(nlmo,dfnb,nlmo),jpa(nlmo,dfnb,nv),kpa(nlmo,dfnb,nv)
real*8 canlmo2vlno(nlmo,nv),mooc(nlmo,nlmo)
real*8 jabqterm(dfnb,nv,nv),fc(dfnb,dfnb)
character*8 dfcoralg
logical oslcc,docc
nvp=nv
if (oslcc) nvp=nvb
c CjI*VIb: CIj: inverse of ED LMO to canonical ED LMO ! warning: overwrite edpao2vlno, mooc stores mooci of ldrpa.f
call dgemm('n','n',nlmo,nv,nlmo,1.d0,mooc,nlmo,lmo2vlnop,nlmo,
$0.d0,canlmo2vlno,nlmo)
if (oslcc.and.nvb.gt.nv) then
ifrst=0
ncso=nvb-nv
if (.not.docc) then
ncso=ncso-1
ifrst=1
endif
! Add integrals where a or b is singly occupied
! (P|[ab']) a: vLNOp, b': singly occupied
! First term: (aI|P)
if (.not.docc)
& call dcopy(dfnb*nv,kpa,nlmo,jpab(1,nv*(nv+1)/2+1),1)
do I=1,ncso
call dcopy(dfnb*nv,kpa(nlmo-ncso+I,1,1),nlmo,
& jpab(1,(nv+ifrst+I-1)*(nv+ifrst+I)/2+1),1)
enddo
! Second term: -A_ja*(jI|P)
if (.not.docc) call dgemm('t','n',dfnb,nv,nlmo,-1.d0,jpi,nlmo,
& canlmo2vlno,nlmo,1.d0,jpab(1,nv*(nv+1)/2+1),dfnb)
do I=1,ncso
call dgemm('t','n',dfnb,nv,nlmo,-1.d0,jpi(1,1,nlmo-ncso+I),nlmo,
& canlmo2vlno,nlmo,1.d0,jpab(1,(nv+ifrst+I-1)*(nv+ifrst+I)/2+1),
& dfnb)
enddo
! (P|[a'b']) a',b': singly occupied
! a': central socc, b': central socc
if (.not.docc) then
call dgemv('t',nlmo,dfnb,1.d0,jpi,nlmo,mooc,1,
& 0.d0,jpab(1,nv*(nv+1)/2+nv+1),1)
! a': central socc, b': non central socc
do I=1,ncso
call dgemv('t',nlmo,dfnb,1.d0,jpi(1,1,nlmo-ncso+I),nlmo,mooc,1,
& 0.d0,jpab(1,(nv+ifrst+I-1)*(nv+ifrst+I)/2+nv+1),1)
enddo
endif !.not.docc
! a' non central socc, b': non central socc
do I=1,ncso
call dgemm('t','n',dfnb,I,nlmo,1.d0,jpi(1,1,nlmo-ncso+I),
& nlmo,mooc(1,nlmo-ncso+1),nlmo,0.d0,
& jpab(1,(nv+ifrst+I-1)*(nv+ifrst+I)/2+nv+ifrst+1),dfnb)
enddo
endif
c term (2): muKP: mu: AOs in the PCD, K: ED LMO -> KPa is already completed
c KPa-> (P|ab)_term23
call dgemm('t','n',dfnb*nv,nv,nlmo,1.d0,kpa,nlmo,lmo2vlnop,nlmo,
$0.d0,jabqterm,dfnb*nv)
c (P|[ab])=(P|[ab])-(P|ab)_term23-(P|ba)_term23
do b=1,nv
do a=1,b
ab=(b-1)*b/2+a
call daxpy(dfnb,-1.d0,jabqterm(1,a,b),1,jpab(1,ab),1)
call daxpy(dfnb,-1.d0,jabqterm(1,b,a),1,jpab(1,ab),1)
enddo
enddo
c
c term 4: jPI: j=canonical ED LMO, I: ED LMO -> jPa
call dgemm('n','n',nlmo*dfnb,nv,nlmo,1.d0,jpi,nlmo*dfnb,
$lmo2vlnop,nlmo,0.d0,jpa,nlmo*dfnb)
c term 4: jPa ->+P[ab]_term4
do b=1,nv
p=b*(b-1)/2+1
call dgemv('t',nlmo,dfnb*b,1.d0,jpa,nlmo,canlmo2vlno(1,b),1,1.d0,
$jpab(1,p),1)
enddo
c
if (lnaf.eq.0) then
C if naf_cor=off then just fitting of (P|[ab]) -> J_P[ab]
if (dfcoralg.eq."cholinv ") then
call dtrmm('l','l','n','n',dfnb,nvp*(nvp+1)/2,1.d0,fc,dfnb,
$jpab,dfnb)
elseif(dfcoralg.eq."lineq ") then
call dtrsm('l','l','n','n',dfnb,nvp*(nvp+1)/2,1.d0,fc,dfnb,
$jpab,dfnb)
endif
endif
c
return
end
C }}}
c
C {{{ savemukp
************************************************************************
subroutine savemukp(mippsh,enbi,no,nklen,smukp,mukp,npaop,dfnb,
$atominpcd,natoms,emapi,pp,muipfile,mupcdiof1p)
************************************************************************
* save (mu k|P) (AO in PAO center domain (PCD), ED LMO, aux in LDF) integrals
* for ED PAO intermediate Jab trf
* if smkup=1 -> save mukp in memory
* if smkup=2 -> save mukp on disk
************************************************************************
implicit none
integer enbi,no,nklen,npaop,dfnb,natoms,atominpcd(2,natoms),pp
integer emapi(*),iatoms,smukp,pm,pm2,nbatr,muipfile,p
real*8 mippsh(enbi,no,nklen),mukp(npaop,no,dfnb)
real*8 mupcdiof1p(npaop,no)
C
if (smukp.eq.1) then
pm2=1 ! AO index in PCD
do iatoms=1,natoms
nbatr=atominpcd(1,iatoms)-1
if (atominpcd(1,iatoms).ne.0) then ! iatoms is in PCD
pm=emapi(atominpcd(2,iatoms))
mukp(pm2:pm2+nbatr,1:no,pp:pp+nklen-1)=
$ mippsh(pm:pm+nbatr,1:no,1:nklen)
pm2=pm2+nbatr+1
endif
enddo
elseif (smukp.eq.2) then
do p=1,nklen
pm2=1 ! AO index in PCD
do iatoms=1,natoms
nbatr=atominpcd(1,iatoms)-1
if (atominpcd(1,iatoms).ne.0) then ! iatoms is in PCD
pm=emapi(atominpcd(2,iatoms))
mupcdiof1p(pm2:pm2+nbatr,1:no)=mippsh(pm:pm+nbatr,1:no,p)
pm2=pm2+nbatr+1
endif
enddo ! iatoms
write(muipfile) pp+p-1 ! this would be the aux index if mukp were allocated
write(muipfile) mupcdiof1p ! write to MUIP file all (mu_AO^PCD,I_LMO | P) for a single P per line
enddo ! p
call dfillzero(mupcdiof1p,npaop*no) ! zero the parf of mippsh that has been overwritten by mupcdiof1p
else
write(*,*) 'unsupported smukp value in savemukp'
call mrccend(1)
endif
C
return
end
C }}}
c
c {{{ subroutine make_aqwofci
subroutine make_aqwofci(aqwofci,nv,dfnb,nch,no,cholI,
$cholp,mooci,aip,pp,dfnbdim,ldofchol,transposed)
************************************************************************
c multiply J(aIP) with the Choleksy/Laplace factorized denoninator contributions and
c transform the occupied basis to the central LMO
************************************************************************
implicit none
integer nv,dfnb,nch,no,ichol,a,p,j,pp,dfnbdim,ldofchol
real*8 aqwofci(nv,dfnbdim,nch),cholp(ldofchol,nch),aip(nv,*)
real*8 cholI(nv,no),mooci(no,no)
logical transposed !T: aip(a,P,i); F: aip(a,i,P)
c
aqwofci(1:nv,pp+1:pp+dfnb,1:nch)=0.d0
do ichol=1,nch
c multiply the Cholesky-vectors with inverse LMO coefficients
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(a)
do a=1,nv
cholI(a,1:no)=mooci(1:no,1)*cholp((a-1)*no+1:a*no,ichol)
enddo
C$OMP END PARALLEL DO
c
c multiply J(aQ)_I with the correpoding Cholesky-vector elements -> J(aQ)_Iw
if (transposed) then !only used for oslcc, beta
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(p)
do p=1,dfnb
do j=1,no
aqwofci(1:nv,pp+p,ichol)=aqwofci(1:nv,pp+p,ichol)+
$ cholI(1:nv,j)*aip(1:nv,(j-1)*dfnb+p)
enddo
enddo
C$OMP END PARALLEL DO
else !.not.transposed
C$OMP PARALLEL DO
C$OMP& DEFAULT(SHARED)
C$OMP& PRIVATE(p)
do p=1,dfnb
do j=1,no
aqwofci(1:nv,pp+p,ichol)=aqwofci(1:nv,pp+p,ichol)+
$ cholI(1:nv,j)*aip(1:nv,(p-1)*no+j)
enddo
enddo
C$OMP END PARALLEL DO
endif !transposed
enddo !ichol
c
return
end
c }}}
c
c {{{ subroutine getifltln
subroutine getifltln(ifltlnval)
************************************************************************
* get the value of ifltln from MRCCCOMMON
************************************************************************
#include "MRCCCOMMON"
integer ifltlnval
c
ifltlnval=ifltln
return
end
c }}}
C
C {{{ subroutine lintra_ed
************************************************************************
subroutine lintra_ed(nbf,nocc,maxmem,iout,enbi,edfnbi,
$tedatfile,dfnbasis,nbi,moadd,natoms,!ints from here
$nangmax,ncontrmax,nprimmax,ncartmax,cartg,nsphermax,nmboys,itol,
$nbfshmax,nang,ncontr,nprim,gexp,gcoef,coord,ctostr,cf,boysval,
$indarr,gcn,pre,nshrange,thad,thcf2,scoord,
$rqqij,rqqkl,hrec,spctostr,nbset,maxcor,dfipre,scrfile3,scrfile4,
$dcore,imem,imem1,atpair,eatdom,enatdom,edi,no,nv,
$emodom,atocc,natocc,at2lmo,pij,aip,mapi,natrange,dfnatrange,cpao,
$aotocmo,dolcc,inttyp,dfnb_old,ao2vlno,tr2naf,ldfined,ldfpair,
$neldfat,eldfat,times,spre,dfipra,tcmax,logkc,
$oeatdom,oenatdom,edfmapi,edfmapinv,naftol,naf,naftyp,ccprog,icore,
$npaop,edpao2vlno,lmo2vlnop,paocdom,nlmo,ijpcp,mooc,imukp,cpabtyp,
$dfcoralg,ndao,ovltol,mukpinmem,usedisk,ikpa,iapofci,smallmem,
$iaqofci,aipinmem,nch,chol,mooci,ijij4c,ijia4c,ijab4c,
$cpaob,nvb,aotocmob,nob,oslcc,iaips,docc,nva,og2canpao,nangmin,
$rlnv,rlnvb,inbcast_group) !oslcc
************************************************************************
* Local integral transformation in an extended domain yielding
* inttyp (1 and) 3 (aPI) and (jPI) (without and) with screening
* inttyp (2 and) 4 J_(Q,[AB]) (without and) with screening
* inttyp 5 J_(Q,[AB]) trf with EDPAO intermedate basis
* (aPI) if lintra.eq.5 OR lintra.eq.8 OR lintra.eq.9
* (aPI) and (jPI) if lintra.eq.6 OR lintra.eq.10
* J_(Q,[AB]) if lintra.eq.7
* I: orignal LMO at PD_i, a: PAO, A,B: canonical LNO, j: canonical occ MO in ED
**********************************************************************
implicit none
integer nbf,nocc,maxmem,iout,memreq,tedatfile,j,nangmin
integer dfnbasis,moadd(nocc),k!scrfile1
integer enbi,edfnbi,mu,i,md,nbi(nocc),jj,natoms,impi
integer imo,dblalloc,atpair(natoms,natoms),ldfpair(natoms,natoms)
integer neldfat,eldfat(natoms),intalloc,ndao
C Variables for integral calculation
integer nangmax,ncontrmax,nprimmax,ncartmax,nsphermax,nmboys,nbset
integer nbfshmax,nang(natoms,nbset),ncontr(0:nangmax,natoms,nbset)
integer nprim(0:nangmax,natoms,nbset)
integer nshrange(2,0:nangmax,natoms,nbset)
integer indarr(natoms,0:nangmax,ncontrmax,nsphermax,nbset)
integer gcn(2,ncontrmax,0:nangmax,natoms,nbset),thad,maxcor
integer scrfile3,scrfile4,imem,imem1!,oeintfile
integer iatoms,jatoms,iiatoms,jjatoms,enatdom,n1crt,nc12
integer eatdom(natoms),xyzomp,idumy,oenatdom,oeatdom(natoms)
integer icore(*),iuncp,igcp
real*8 itol,gexp(nprimmax,0:nangmax,natoms,nbset),coord,ctostr,cf
real*8 gcoef(nprimmax,ncontrmax,0:nangmax,natoms,nbset),dfipre,r
real*8 rqqij,rqqkl,hrec,spctostr,boysval,pre,thcf2,scoord,dcore(*)
real*8 ovltol
logical cartg,lll,smallmem,inbcast_group
c additional variables of muip transformation
integer edi,no,nv,emodom(nocc),lintra,kk,mapi(nbf,nocc)
integer at2lmo(natoms,0:nocc),atocc(natoms,nocc),natocc(nocc)
integer dfnatrange(2,natoms),natrange(2,natoms)
integer emapi(nbf),emodominv(nocc),extramem,mpnc
integer inttyp,memreq2,memreq1,ver,edfmapi(dfnbasis),cpinttyp
integer imupiscr,imnp,inmp,impn,dfnb_old,edfmapinv(dfnb_old)
real*8 pij(no,edfnbi,no),aip(nv,edfnbi,no),cpao(enbi,nv),ctol
real*8 aotocmo(enbi,no),rdumy,times(6,0:100),spre,dfipra,tcmax
logical dolcc,ldfined,logkc,mukpinmem,aipinmem
c additional variables of jIP construction
integer ijip
c additional variables for Jab trf
integer lnaf,iamp,ijab,mx,iforw,dfnb4,mx2,mx3,usedisk
character*4 cscr4,ccprog
character*8 naftyp,dfcoralg
character*16 naf
real*8 naftol,ao2vlno(enbi,nv),tr2naf(dfnb_old,edfnbi)
c additional variables for jai/jij with df3intn
integer dfscrsz,fact,icsm,intmem,icmax,icomax,ipmax,icmi,icni
integer imipsd,iapofci,iaqofci,nch
real*8 chol,mooci
c additional variables for jab with df3intn
integer imshpa,impa,ijabp,ijabq
c additional variables for jab via ED PAOs
integer npaop,paocdom(0:natoms),nlmo,cpenbi,ikpa,cpabtyp,smukp
integer ijabqterm,imukp
real*8 edpao2vlno(npaop,nv),lmo2vlnop(nlmo,nv),ijpcp,mooc(*)
c additional variables for lccoporder=lccfirst
integer ijij4c,ijia4c,ijab4c
c internal variabes in stack
real*8 ttmp(2),cctol
integer atominpcd(2,natoms)
c SB oslcc
integer nvb,nob,osxmem,iaips,nvm,nom,nva,rlnv,rlnvb
real*8 cpaob(enbi,nvb),aotocmob(enbi,nob),og2canpao
logical oslcc,docc
c for debugging
c real*8 api(nv,no,edfnbi)
interface
subroutine boys
end
end interface
#if defined (OMP)
integer OMP_GET_NUM_THREADS
!$OMP PARALLEL
xyzomp=OMP_GET_NUM_THREADS()
!$OMP END PARALLEL
#else
xyzomp=1
#endif
C
call time0(ttmp)
idumy=1
rdumy=0.d0
mx=0
mx2=0
nom=no
nvm=nv
if (oslcc) then
nvm=max(nva,nvb,rlnv,rlnvb) !makes memory allocs simpler
nom=max(no,nob) !makes memory allocs simpler
endif
if (inttyp.eq.1.and.dolcc) then
lintra=6 ! Jai and Jij
elseif(inttyp.eq.1.and..not.dolcc) then
lintra=5 ! Jai
elseif((inttyp.eq.3.and..not.dolcc).or.inttyp.eq.30) then
lintra=9 ! Jai, 30= (a' I|P) vLNO'-LMO integrals in iapip
elseif(inttyp.eq.3.and.dolcc) then
lintra=10 ! Jai and Jij
elseif(inttyp.eq.2) then
lintra=7 ! Jab
elseif(inttyp.eq.4) then
lintra=11 ! Jab with screening
if (ccprog.eq.'cis ') lintra=12 ! for dolccx MD
elseif(inttyp.eq.5) then
lintra=13 ! Jab with screening through EDPAO intermediate step
else
write(*,*) 'unknown inttyp in lintra_ed'
call mrccend(1)
endif !inttyp
cpenbi=enbi
if (inttyp.eq.5.or.inttyp.eq.30) enbi=npaop
cpinttyp=inttyp
if (inttyp.eq.30) inttyp=3
if (inttyp.eq.3.or.inttyp.eq.4.or.inttyp.eq.5) then
call getkey('cctol',5,cscr4,4)
read(cscr4,*) j
cctol=10.d0**(-j)
ctol=min(100.d0*itol,10.d0**14*itol*cctol/dfloat(cpenbi**2)) ! max error in a single Jai,P/Jab,P integral -> the total error is below ctol (works well assuming the default itol=1d-10 & cctol=1d-5), cpednbi also for inttyp.eq.5 to make more consistent with the apip and ijp terms
else
ctol=itol
endif
if (ndao.gt.0) ctol=ctol/10.d0 ! need more accurate integrals with large, quasi-redundant AO basis
if (ovltol.ge.1.d-6.or.dble(ndao)/dble(nbf).gt.0.02d0)
$ ctol=ctol/10.d0 ! need even more accurate integrals with large ovltol or highly overlapping AO basis
cdbprt write(*,"('ctol',4es14.5)") ctol,itol,10.d0**14*itol*cctol/
cdbprt $ dfloat(cpenbi**2),10000.d0*cctol/dfloat(cpenbi**2)
smukp=0
if (inttyp.eq.3.and.cpabtyp.eq.5) then
if (mukpinmem) smukp=1 ! save (mu,k|P) integrals for the AOs of the PCD in memory
if (.not.mukpinmem.and.(usedisk.eq.1.or.usedisk.eq.2)) smukp=2! save (mu,k|P) integrals for the AOs of the PCD to disk
endif
extramem=0
if (smukp.eq.2.and.xyzomp.eq.1) extramem=npaop*no ! for mupcdiof1p in savemukp
if (inttyp.eq.2) then
lnaf=0
if (naf.ne.'off ') then
if (naftyp.eq.'jpi ') lnaf=1
if (naftyp.ne.'jpi ') then
write(iout,*) 'naftyp.ne.jpi is not implemented for',
$ ' locintrf=direct or directab, choose naftyp=jpi instead'
call mrccend(1)
c implement naftyp=jpq for lintra.eq.7 ???
endif
endif
elseif (inttyp.eq.4.or.inttyp.eq.5) then
lnaf=0
if (naf.ne.'off ') then
if (naftyp.eq.'jpi ') lnaf=1
if (naftyp.eq.'jpq ') then
lnaf=2
dfnb4=max(dfnb_old,4) ! for minimum work space of dsyev in jpqnaf
endif
if (naftyp.ne.'jpi '.and.naftyp.ne.'jpq ') then
write(iout,*)'naftyp.ne.(jpq or jpi) is not implemented for',
$ ' locintrf=direct or directab, choose naftyp=jpq (jpi) instead'
call mrccend(1)
endif
if (lnaf.eq.1.and.inttyp.eq.5) then
write(iout,*)'naftyp=jpi is not implemented in this route'
$ ,', please, choose naftyp=jpq instead'
call mrccend(1)
endif
endif
if (ccprog.eq.'cis ') lnaf=3 ! for dolccx MD
endif
if (inttyp.eq.5.and.(lintra.eq.12.or.lnaf.eq.3)) stop
$ 'Jab trf. with EDPAOs is not implemented for ccprog=cis'
c
if (lintra.ge.9.and.lintra.le.13) then
dfscrsz=nbfshmax**3*xyzomp
fact=4 ! can not overwrite the matrix computed by genhrr either
else
dfscrsz=dfnbasis*nbfshmax**2
fact=3
endif
C Gyula
igcp=dblalloc(nprimmax*(nangmax+1)*natoms*ncontrmax) ! rescaled normalization coefficients in df3int (gcij for df3intn, gck for df3int)
iuncp=intalloc(nprimmax*(nangmax+1)*natoms) ! labeling of uncontracted AOs in df3int (ijp for df3intn, kp for df3int)
C Calculate memory requirement for integral calculation
call intmemcalc(intmem,nbset,ncontrmax,nprimmax,
$1,1,3,xyzomp,dfscrsz,cartg,0.d0)
C
c write(*,*) 'inttyp,lintra,dolcc,ldfined',
c % inttyp,lintra,dolcc,ldfined
cdbprt write(*,*) 'md,nbfshmax,edfnbi,no,enbi,memreq,intmem'
cdbprt write(*,'(8i20)') md,nbfshmax,edfnbi,no,enbi,memreq,intmem
C Calculate memory requirement for integral calculation
maxmem=maxcor-(imem-imem1)-intmem
C Calculate memory requirement
if (inttyp.eq.1.or.inttyp.eq.3) then
mpnc=1
if (smallmem) mpnc=2
if (oslcc.and..not.aipinmem) mpnc=3
call inttyp1or3mem(inttyp,memreq,md,no,emodom,moadd,nbi,
$nbfshmax,edfnbi,enbi,natoms,nangmax,xyzomp,smallmem,extramem,
$memreq1,memreq2)
elseif (inttyp.eq.2) then
c mem requirement for Jab trf
memreq=nbfshmax*max(dfnb_old*enbi,edfnbi*nv) ! for mpn, pam and qam intermedtiates
$ +nbfshmax*dfnb_old*max(nv,nbfshmax) ! for amp and scred intermedtiate
$ +nv*(nv+1)/2*edfnbi ! for J(Q,[ab]) integral
elseif (inttyp.eq.4.or.inttyp.eq.5) then
memreq=nbfshmax*nv*xyzomp*nbfshmax+ ! for mshpa intermediate
$ nbfshmax*nv*xyzomp*enbi+ ! for mallpa intermediate
$ nv*(nv+1)/2*nbfshmax ! (P,[ab]) intermediate for a P shell
memreq=memreq+natoms*(nangmax+1) ! for pmax in df3intn
if (lnaf.eq.1) memreq=memreq+nv*(nv+1)/2*edfnbi ! for J(Q,[ab]) integral if naf.ne.off
if (lnaf.eq.0) memreq=memreq+
& (nvm*(nvm+1)/2+osxmem(oslcc,nva*(nva+1)/2,0))*dfnb_old+
& osxmem(oslcc,2*nvm**2,0) ! for J(P,[ab]) integral if naf.eq.off
if (lnaf.eq.2) then
mx=max(0,dfnb4**2+ !for W1
$ max(dfnb4**2,(no+nva)**2+no+osxmem(oslcc,(nob+nvb)**2+nob,0))! for W2 of jpqnaf, if needed, W2 also holds the full mo Fockian
$ -nbfshmax*(nv*(nv+1)/2+ !ijabp
$ enbi*nv*xyzomp)) ! ijabp and mallpa can be used (partially) to store W1 and W2
mx3=(nvm*(nvm+1)/2+osxmem(oslcc,nva*(nva+1)/2,0))*dfnb_old+! for J(P,[ab]) & J(Q,[ab]) if naftyp=jpq
$ max(max(nvm*(nvm+1)/2,nom*(nom+1),nvm*nom*2)*dfnb_old, ! for jpq array in jpqnaf
$ osxmem(oslcc,2*nvm**2,0)) !temp for J_ab to canonical
memreq=memreq+mx+mx3
endif
! no extra memory needed for lnaf.eq.3 ! for dolccx MD
if (inttyp.eq.5) then
if (lnaf.ne.2) memreq=memreq+nv**2*dfnb_old ! for jabqterm in edpao2vlnoterms
if (lnaf.eq.2) memreq=memreq+(nv**2-nv*(nv+1)/2)*dfnb_old ! for jabqterm in edpao2vlnoterms
endif
endif
cdbprt write(*,*) 'memreq,maxmem,mx,mx2,mx3'
cdbprt write(*,'(8i20)') memreq,maxmem,mx,mx2,mx3
if(memreq.gt.maxmem) then
write(iout,*)
write(iout,*)'Available memory for integral transformation
$in lintra_ed might be insufficient'
write(iout,'(f8.2,a53)') dble(memreq-maxmem)*8.d0/1024**2,
$ ' MB more memory is suggested to be allocated'
flush(iout)
c call mrccend(0)
endif
c memory allocation and initializations
if (inttyp.eq.1.or.inttyp.eq.3) then
C Read occ MO coefficients
imo=dblalloc(md)
call readlmoed(emodominv,nocc,no,emodom,moadd,nbi,101,dcore(imo))
call ifillzero(at2lmo,natoms*(nocc+1))
endif
if (inttyp.eq.1) then
c {{{ inttyp.eq.1 specific part
ver=0
c choose intergral trf algorithm if lintra=5 or 6
if (memreq2.le.maxmem) then
ver=2
lintra=8
write(iout,*) 'Running operation count efficient integral trf'
elseif (memreq2.gt.maxmem.and.memreq1.le.maxmem) then
ver=1
if (.not.ldfined) then
write(iout,*) 'Running memory economical intergral trf'
elseif (ldfined) then
write(iout,*)'Local DF is not implemented, switch algorithm:'
endif
write(iout,*) ' Increase memory with',
$ (memreq-maxmem)*8.d0/1024**2,
$'MB in order to switch to the operation count efficient algorithm'
if (ldfined) call mrccend(1)
endif
c allocate memory
if (ver.eq.1) then
impn=dblalloc(nbfshmax*edfnbi*enbi)
impi=dblalloc(nbfshmax*edfnbi*max(no,nbfshmax)) ! for scred and mpi
if (lintra.eq.6) then
call dfillzero(pij,edfnbi*no**2)
call dfillzero(aip,nv*edfnbi*no
& +osxmem(oslcc,nvb*edfnbi*nob,0))
elseif(lintra.eq.5) then
call dfillzero(aip,nv*edfnbi*no
& +osxmem(oslcc,nvb*edfnbi*nob,0))
endif
elseif (ver.eq.2) then
imnp=dblalloc(nbfshmax**2*edfnbi)
inmp=dblalloc(nbfshmax**2*edfnbi)
imupiscr=dblalloc(nbfshmax*edfnbi)
impi=dblalloc(enbi*edfnbi*no)
call dfillzero(dcore(impi),enbi*edfnbi*no)
endif
c }}}
elseif (inttyp.eq.3) then
icmax=dblalloc(natoms*(nangmax+1))
icomax=dblalloc(natoms*(nangmax+1))
ipmax=dblalloc(natoms*(nangmax+1))
icmi=dblalloc(nbfshmax*no*xyzomp)
icni=dblalloc(nbfshmax*no*xyzomp)
imipsd=dblalloc(nbfshmax**2*no*xyzomp)
impn=dblalloc(nbfshmax*enbi*no*max(mpnc,xyzomp)+extramem) ! mippsh intermedtiate in lmipined, mpnc for aipsh of led2ndtrf
call dfillzero(dcore(impn),nbfshmax*enbi*no*xyzomp)
icsm=dblalloc(natoms*(nangmax+1)*no)
call dfillzero(dcore(icsm),natoms*(nangmax+1)*no)
ijip=imem
if (lintra.eq.10) ijip=dblalloc(nom*no*nbfshmax) ! for (jIP)
elseif (inttyp.eq.2) then
impn=dblalloc(nbfshmax*max(dfnb_old*enbi,edfnbi*nv)) ! for mpn, pam and qam intermedtiates
iamp=dblalloc(nbfshmax*dfnb_old*max(nv,nbfshmax)) ! for amp and scred intermedtiate
ijab=dblalloc(nv*(nv+1)/2*edfnbi) ! for J(Q,[ab]) integral
call dfillzero(dcore(ijab),nv*(nv+1)/2*edfnbi)
elseif (inttyp.eq.4.or.inttyp.eq.5) then
ipmax=dblalloc(natoms*(nangmax+1)) ! for pmax in df3intn
imshpa=dblalloc(nbfshmax**2*nv*xyzomp) ! for mshpa intermediate in lmpained
impa=dblalloc(enbi*nbfshmax*nv*xyzomp) ! for mallpa in lmpained and ljabnaf
call dfillzero(dcore(impa),
& enbi*nbfshmax*nv*xyzomp)
ijabp=dblalloc(nv*(nv+1)/2*nbfshmax) ! (P,[ab]) intermediate for a P shell
if (lnaf.eq.2) iforw=dblalloc(mx) ! extra memory (if needed) for W1 and W2
if (lnaf.eq.1) then
ijabq=dblalloc(nv*(nv+1)/2*edfnbi) ! for J(Q,[ab]) integral, Q in NAF basis
elseif (lnaf.eq.0) then
ijabq=dblalloc((osxmem(oslcc,nva*(nva+1)/2,0)+nvm*(nvm+1)/2)
& *dfnb_old) ! for J(P,[ab]) integral, P in original aux basis,nva is virt beta dimension if abtyp.eq.5
elseif (lnaf.eq.2) then
ijabq=dblalloc(mx3)! for J(P,[ab]) integral and J(Q,[ab]) NAF trf-d int in jpqnaf
else ! if (lnaf.eq.3) then ! for dolccx MD
ijabq=imem
endif
ijab4c=ijabq
if(lnaf.ne.3) call dfillzero(dcore(ijabq),nv*(nv+1)/2*dfnb_old)
if (inttyp.eq.5) then ! ijabqterm position
if (lnaf.eq.2) then
ijabqterm=dblalloc((nv**2-nvm*(nvm+1)/2)*dfnb_old) ! second half of ijabq is usable, just extend it
ijabqterm=ijabq+nvm*(nvm+1)/2*dfnb_old ! do not owerwrite ijabq
else
ijabqterm=dblalloc(nv**2*dfnb_old)
endif
endif
c write(*,*) 'ijabq,ijabqterm,impa,mx,mx2,xyzomp'
c write(*,'(9i18)')ijabq-cpimem,ijabqterm-cpimem,impa-cpimem,mx,mx2
c $,xyzomp
endif ! if (inttyp.eq.1...
c
C Is a pair of atoms included in the extended domain?
if (inttyp.ne.5.and.cpinttyp.ne.30) then
call fillmap2l(natoms,enatdom,oenatdom,eatdom,oeatdom,atpair)
elseif (inttyp.ne.5.and.cpinttyp.eq.30) then ! for (a'I|P) vLNO'-LMO ints mu in PCD, nu in union of occupoied atom lists
call fillmap2l(natoms,paocdom(0),oenatdom,paocdom(1),oeatdom,
$ atpair)
elseif (inttyp.eq.5) then
call fillmap2l(natoms,paocdom(0),paocdom(0),paocdom(1),
$ paocdom(1),atpair)
endif
c
if (ldfined) then
C Is a pair of atoms included in both the extended domain and the local fitting domain?
if (inttyp.ne.5) then
call fillmap2l(natoms,neldfat,enatdom,eldfat,eatdom,ldfpair)
else
call fillmap2l(natoms,neldfat,paocdom(0),eldfat,paocdom(1),
$ ldfpair)
endif
else
do j=1,natoms
ldfpair(1:natoms,j)=atpair(1:natoms,j)
enddo
endif ! ldfined
c determine ED dependent maps
kk=0
if (inttyp.ne.5) then
do iiatoms=1,enatdom
iatoms=eatdom(iiatoms)
if (inttyp.eq.1.or.inttyp.eq.3) then
c list of LMO's in the ED to which bf's of a given atom contribute
do jj=1,no
j=emodom(jj)
do k=1,natocc(j)
if (atocc(k,j).eq.iatoms) then
at2lmo(iatoms,0)=at2lmo(iatoms,0)+1
at2lmo(iatoms,at2lmo(iatoms,0))=jj ! bf's on atom iatoms contribute to LMO jj
exit
endif
enddo
enddo
endif ! (inttyp.eq.1.or.inttyp.eq.3
enddo ! iiatoms
endif
c
call ifillzero(emapi,nbf)
if (inttyp.ne.5.and.cpinttyp.ne.30) then
c fill in emapi for the actual ED only
do iiatoms=1,enatdom
iatoms=eatdom(iiatoms)
do mu=natrange(1,iatoms)+1,natrange(2,iatoms)
kk=kk+1
emapi(mu)=kk ! position of absolute AO index in the ED AO basis
enddo
enddo ! iiatoms
else !if (inttyp.eq.5.or.cpinttyp.eq.30) then
do iiatoms=1,paocdom(0)
iatoms=paocdom(iiatoms)
do mu=natrange(1,iatoms)+1,natrange(2,iatoms)
kk=kk+1
emapi(mu)=kk ! position of absolute AO index in the PCD AO basis (only used for mu index if cpinttyp.eq.30 !!!)
enddo
enddo ! iiatoms
endif ! if (inttyp.ne.5...
call ifillzero(atominpcd,2*natoms)
if (smukp.gt.0) then
do iatoms=1,natoms
lll=.false.
do jjatoms=1,paocdom(0)
jatoms=paocdom(jjatoms)
if (iatoms.eq.jatoms) then
lll=.true.
exit
endif
enddo
if (lll) atominpcd(1,iatoms)=
$natrange(2,iatoms)-natrange(1,iatoms) ! number of AOs on iatoms if atom iatoms is in the PAO center domain
if (lll) atominpcd(2,iatoms)=natrange(1,iatoms)+1 ! index of the first AO on iatoms
enddo
endif !if (smukp.gt.0) then
C Compute (munu|P) integrals and perform the transformation
c write(*,*) 'no,lintra,nocc,enbi,edfnbi',no,lintra,nocc,enbi,edfnbi
c write(*,*) 'enatdom,eatdom', enatdom,eatdom(1:enatdom)
c write(*,*) 'paocdom(0),paocdom',paocdom(0),paocdom(1:paocdom(0))
c write(*,*) 'cpao',cpao(1:enbi,1:nv)
cx write(*,*) 'moadd', moadd(1:nocc)
cx do kk=1,natoms
cx write(*,*) 'atom' ,kk, 'pieces of mos',at2lmo(kk,0),
cx $ 'at2lmo', at2lmo(kk,1:at2lmo(kk,0))
cx enddo
cx write(*,*) 'emodom', emodom(1:nocc)
cx write(*,*) nbf,'emapi', emapi(1:nbf)
cx do l=1,nocc
cx write(*,*) 'mapi',l, 'th mo:', 'nbi',nbi(l), '--', mapi(1:nbf,l)
cx enddo
cx write(*,*) 'edfmapinv', edfmapinv(1:edfnbi)
cx write(*,*) 'atpair', atpair(1:natoms,1:natoms)
c {{{ if (inttyp.eq.1 -> lintra 5/6
if (inttyp.eq.1.and.ver.eq.1) then ! lintra.eq.5.or.lintra.eq.6
call df3int(natoms,nangmax,ncontrmax,nprimmax,nang,ncontr,nprim,
$gexp,gcoef,coord,ncartmax,ctostr,cartg,nsphermax,cf,boysval,
$nmboys,dcore,imem,indarr,tedatfile,nbf,gcn,dcore(imem),pre,2,itol,
$nbfshmax,nshrange,i,iout,dcore,
$dcore,dcore,dcore,' ',imem1,maxcor,thad,thcf2,
$scoord,rqqij,rqqkl,hrec,0,1,nang(1,3),
$ncontr(0,1,3),nprim(0,1,3),gexp(1,0,1,3),gcn(1,1,0,1,3),dfnbasis,
$gcoef(1,1,0,1,3),indarr(1,0,1,1,3),dcore(imem),dcore,dfipre,dcore,
$dcore,dcore(imo),1,dcore,idumy,idumy,idumy,idumy,idumy,
$moadd,idumy,idumy,itol, ! ??? ctol=?
$scrfile3,spctostr,1,1,dcore,.true.,.false.,scrfile4,-1.d0,.false.,
$0,0,idumy,.false.,0.d0,dcore,lintra,nocc,idumy,
$idumy,idumy,idumy,rdumy,rdumy,
$dcore(impi),idumy,mapi,edfmapinv,atpair,0,dcore,
$1,.false.,dcore,.false.,i,dfnatrange,
$enbi,emapi,edfnbi,natrange,emodom,no,nv,eatdom,enatdom,
$dcore(impn),at2lmo,cpao,aotocmo,aip,pij,times,spre,dfipra,tcmax,
$logkc,icore(iuncp),dcore(igcp),dcore,icore,0,i,i,i,i,i,i,natrange,
$i,i,i,0,icore,0.d0,boys,1,dcore,idumy,idumy,idumy,.false.,
$dcore,nshrange(1,0,1,3),dcore,i,dcore,dcore,i,nangmin,.false.,i,i,
$r,r,r,r,r,r,r,r,r,r,r,'off ',i,.false.,dcore,.false.,.false.,
$r,r,.false.,0,.false.,dcore(imem),i,i)
elseif (inttyp.eq.1.and.ver.eq.2) then ! lintra.eq.8
call df3int(natoms,nangmax,ncontrmax,nprimmax,nang,ncontr,nprim,
$gexp,gcoef,coord,ncartmax,ctostr,cartg,nsphermax,cf,boysval,
$nmboys,dcore,imem,indarr,tedatfile,nbf,gcn,dcore(imem),pre,2,itol,
$nbfshmax,nshrange,i,iout,dcore,
$dcore,dcore,dcore,' ',imem1,maxcor,thad,thcf2,
$scoord,rqqij,rqqkl,hrec,0,1,nang(1,3),
$ncontr(0,1,3),nprim(0,1,3),gexp(1,0,1,3),gcn(1,1,0,1,3),dfnbasis,
$gcoef(1,1,0,1,3),indarr(1,0,1,1,3),dcore(imem),dcore,dfipre,dcore,
$dcore,dcore(imo),1,dcore,idumy,i,i,i,i,moadd,i,i,itol, ! ??? ctol=?
$scrfile3,spctostr,1,1,dcore,.true.,.false.,scrfile4,-1.d0,.false.,
$0,0,idumy,.false.,0.d0,dcore,lintra,nocc,idumy,
$idumy,idumy,idumy,idumy,rdumy,
$dcore(impi),idumy,mapi,edfmapinv,atpair,0,dcore,
$1,.false.,dcore,.false.,i,dfnatrange,
$enbi,emapi,edfnbi,idumy,emodom,no,idumy,idumy,ldfpair,
$dcore(imnp),at2lmo,dcore(inmp),rdumy,dcore(imupiscr),rdumy,times,
$spre,dfipra,tcmax,logkc,icore(iuncp),dcore(igcp),dcore,icore,0,i,
$i,i,i,i,i,natrange,i,i,i,0,icore,0.d0,boys,1,dcore,idumy,
$idumy,idumy,.false.,dcore,nshrange(1,0,1,3),dcore,i,dcore,dcore,i,
$nangmin,.false.,i,i,r,r,r,r,r,r,r,r,r,r,r,'off ',i,.false.,
$dcore,.false.,.false.,r,r,.false.,0,.false.,dcore(imem),i,i)
call timeadd(times(1,1),ttmp)
C (muPi) -> (aPi), i: orignal LMO at PD_i, a: PAO
call time0(times)
call dgemm('t','n',nv,edfnbi*no,enbi,1.d0,cpao,enbi,
$dcore(impi),enbi,0.d0,aip,nv)
call timeadd(times(1,2),times)
C (muPI) -> (j,P,I)
if (dolcc) then
call dgemm('t','n',no,edfnbi*no,enbi,1.d0,aotocmo,enbi,
$dcore(impi),enbi,0.d0,pij,no)
endif
call dbldealloc(imo)
times(1:2,19:20)=times(3:4,17:18)-times(3:4,19:20) ! time for this ED
times(3:4,19:20)=times(3:4,17:18) ! sum up to this ED
times(5:6,19:20)=max(times(1:2,19:20),times(5:6,19:20)) ! max up to this ED
endif ! if (inttyp.eq.1.and.ver.eq.
c }}}
if (inttyp.eq.3) then ! lintra=9/10
c write(*,*) 'omo in lintra_ed',md
c write(*,*) dcore(imo:imo+md-1)
c write(*,*) 'cpao in lintra_ed',enbi*nv
c write(*,'(1000f8.4)') cpao
times(1,52)=imem-imem1+intmem
times(2,52)=3*nbf**2+no*nv*edfnbi!+no*nv**2
times(3,52)=max(times(1,52),times(3,52))
times(4,52)=max(times(2,52),times(4,52))
times(3,55)=max(times(3,55),dble(intmem))
call df3intn(natoms,nangmax,ncontrmax,nprimmax,nang,ncontr,nprim,
$gexp,gcoef,coord,ncartmax,ctostr,cartg,nsphermax,cf,boysval,
$nmboys,dcore,imem,indarr,tedatfile,nbf,gcn,dcore(imem),pre,2,itol,
$nbfshmax,nshrange,i,iout,
$dcore,dcore,imem1,maxcor,thad,thcf2,
$scoord,rqqij,rqqkl,hrec,0,1,nang(1,3),
$ncontr(0,1,3),nprim(0,1,3),gexp(1,0,1,3),gcn(1,1,0,1,3),dfnbasis,
$gcoef(1,1,0,1,3),indarr(1,0,1,1,3),dcore(imem),dcore,dfipre,dcore,
$dcore,dcore,1,dcore,i,i,i,moadd,i,ctol, ! ??? ctol=?
$scrfile3,spctostr,1,1,dcore,.true.,.false.,scrfile4,-1.d0,
$0,i,.false.,naftol,dcore,lintra,nocc,emapi,
$idumy,idumy,dcore,idumy,atpair,0,dcore,
$idumy,idumy,idumy,idumy,idumy,idumy,idumy,edfmapi,enatdom,eatdom,
$rdumy,rdumy,rdumy,rdumy,rdumy,
$rdumy,rdumy,edfnbi,idumy,nshrange(1,0,1,3),idumy,
$ldfpair,times,enbi,no,mapi,at2lmo,emodom,dcore(imo),dcore(impn),
$edfnbi,aip,cpao,nv,dcore(icsm),dcore(ijip),pij,aotocmo,
$edfnbi,rdumy,rdumy,rdumy,rdumy,idumy,edi,ccprog, ! screened Jab trf, lintra 11
$dcore(icmax),dcore(icomax),dcore(ipmax),dcore(icmi),dcore(icni), ! this line for screening
$dcore(imipsd),icore(iuncp),dcore(igcp),dfcoralg,
$atominpcd,dcore(imukp),npaop,smukp,rdumy,idumy,rdumy,mooc,rdumy, ! for abtyp.eq.5
$rdumy,nbset,1,smallmem,dcore(iapofci),dcore(iaqofci),aipinmem, ! for abtyp.eq.5
$nch,chol,mooci,rdumy,rdumy,cpaob,nvb,aotocmob,nob,oslcc,iaips, !oslcc
$docc,idumy,rdumy,rdumy,0.d0,idumy,idumy,inbcast_group) !oslcc
c for debugging
c if (dolcc) then
c write(*,*) 'rearrang aip 2 api for debugging only'
c call rearrange_api(aip,aip,no,nv,edfnbi,dcore(imem))
c endif
c do i=1,no
c do p=1,edfnbi
c aip(1:nv,p,i)=api(1:nv,i,p)
c enddo
c enddo
c write(*,'(1000es10.3)') aip
call dbldealloc(imo)
call timeadd(times(1,24),ttmp)
times(1:2,28:30)=times(3:4,25:27)-times(3:4,28:30) ! time for this ED
times(3:4,28:30)=times(3:4,25:27) ! sum up to this ED
times(5:6,28:30)=max(times(1:2,28:30),times(5:6,28:30)) ! max up to this ED
endif ! inttyp.eq.3
c db
c write(*,*) 'mupi in lintra_ed, i=1',dcore(impi:impi+enbi*edfnbi-1)
c write(*,*) 'no,nv,edfnbi', no,nv,edfnbi
c write(*,*) 'aotocmo', aotocmo(1:enbi,1:no)
c write(*,*) 'api in lintra_ed (aIP) order I=1',api(1:nv,1,1:edfnbi)
c write(*,*) 'aip in lintra_ed (aPI) order I=1',aip(1:nv,1:edfnbi,1)
c write(*,*) 'aip in lintra_ed (aPI) order I=2',aip(1:nv,1:edfnbi,2)
c if (inttyp.eq.1)
c $ write(*,*) 't1 in lintra_ed (aPI) full',aip
c if (inttyp.eq.3)
c $ write(*,*) 't3 in lintra_ed (aPI) full',aip !(1:nv,1:no,1:edfnbi)
c write(*,*) 'pij in lintra_ed (Pij)order i=1', pij(1:no,1:edfnbi,1)
cxx write(*,*) 'pij in lintra_ed (Pij)order ', pij
c db
if (inttyp.eq.2) then ! lintra.eq.7
call df3int(natoms,nangmax,ncontrmax,nprimmax,nang,ncontr,nprim,
$gexp,gcoef,coord,ncartmax,ctostr,cartg,nsphermax,cf,boysval,
$nmboys,dcore,imem,indarr,tedatfile,nbf,gcn,dcore(imem),pre,2,itol,
$nbfshmax,nshrange,i,iout,dcore,
$dcore,dcore,dcore,' ',imem1,maxcor,thad,thcf2,
$scoord,rqqij,rqqkl,hrec,0,1,nang(1,3),
$ncontr(0,1,3),nprim(0,1,3),gexp(1,0,1,3),gcn(1,1,0,1,3),dfnbasis,
$gcoef(1,1,0,1,3),indarr(1,0,1,1,3),dcore(imem),dcore,dfipre,dcore,
$dcore,ao2vlno,1,dcore,idumy,idumy,idumy,i,i,i,i,idumy,
$itol, ! ??? ctol=?
$scrfile3,spctostr,1,1,dcore,.true.,.false.,scrfile4,-1.d0,.false.,
$0,0,idumy,.false.,0.d0,dcore,lintra,nocc,i,idumy,idumy,idumy,
$rdumy,i,dcore(iamp),rdumy,idumy,edfmapinv,atpair,0,dcore,
$1,.false.,dcore,.false.,i,dfnatrange,
$enbi,emapi,dfnb_old,edfnbi,idumy,edi,nv,lnaf,ldfpair,
$dcore(impn),idumy,tr2naf,rdumy,dcore(ijab),rdumy,times,spre,
$dfipra,tcmax,logkc,icore(iuncp),dcore(igcp),dcore,icore,0,i,i,i,i,
$i,i,natrange,i,i,i,0,icore,0.d0,boys,1,dcore,idumy,idumy,
$idumy,.false.,dcore,nshrange(1,0,1,3),dcore,i,dcore,dcore,i,
$nangmin,.false.,i,i,r,r,r,r,r,r,r,r,r,r,r,'off ',i,.false.,
$dcore,.false.,.false.,r,r,.false.,0,.false.,dcore(imem),i,i)
call dbldealloc(impn)
endif
if (inttyp.eq.4) then ! lintra.eq.11 .or. lintra.eq.12
call df3intn(natoms,nangmax,ncontrmax,nprimmax,nang,ncontr,nprim,
$gexp,gcoef,coord,ncartmax,ctostr,cartg,nsphermax,cf,boysval,
$nmboys,dcore,imem,indarr,tedatfile,nbf,gcn,dcore(imem),pre,2,itol,
$nbfshmax,nshrange,i,iout,
$dcore,dcore,imem1,maxcor,thad,thcf2,
$scoord,rqqij,rqqkl,hrec,0,1,nang(1,3),
$ncontr(0,1,3),nprim(0,1,3),gexp(1,0,1,3),gcn(1,1,0,1,3),dfnbasis,
$gcoef(1,1,0,1,3),indarr(1,0,1,1,3),dcore(imem),dcore,dfipre,dcore,
$dcore,dcore,1,dcore,i,i,i,moadd,i,ctol, ! ??? ctol=?
$scrfile3,spctostr,1,1,dcore,.true.,.false.,scrfile4,-1.d0,
$0,i,.false.,naftol,dcore,lintra,nocc,emapi,
$idumy,idumy,dcore,idumy,atpair,0,dcore,
$idumy,idumy,idumy,idumy,idumy,idumy,idumy,edfmapi,enatdom,eatdom,
$rdumy,rdumy,tr2naf,rdumy,rdumy,
$dcore(impa),rdumy,dfnb_old,idumy,nshrange(1,0,1,3),idumy,
$ldfpair,times,enbi,no,mapi,idumy,idumy,rdumy,dcore(imshpa),
$edfnbi,rdumy,rdumy,nv,rdumy,rdumy,rdumy,idumy, ! screened Jab trf specific from here
$dfnb_old,dcore(impa),dcore(ijabp),dcore(ijabq),ao2vlno,lnaf,edi,
$ccprog,
$rdumy,rdumy,dcore(ipmax),rdumy,rdumy, ! this line for screening
$rdumy,icore(iuncp),dcore(igcp),dfcoralg,
$idumy,rdumy,idumy,idumy,rdumy,idumy,rdumy,rdumy,rdumy,rdumy,
$nbset,1,.false.,rdumy,rdumy,.true.,idumy,rdumy,rdumy,! for abtyp.eq.5
$dcore(ijij4c),dcore(ijia4c),rdumy,nvb,rdumy,idumy,oslcc,idumy,!oslcc
$docc,nva,og2canpao,rdumy,0.d0,rlnv,rlnvb,inbcast_group)!oslcc
endif
if (inttyp.eq.5) then ! lintra.eq.13
call df3intn(natoms,nangmax,ncontrmax,nprimmax,nang,ncontr,nprim,
$gexp,gcoef,coord,ncartmax,ctostr,cartg,nsphermax,cf,boysval,
$nmboys,dcore,imem,indarr,tedatfile,nbf,gcn,dcore(imem),pre,2,itol,
$nbfshmax,nshrange,i,iout,
$dcore,dcore,imem1,maxcor,thad,thcf2,
$scoord,rqqij,rqqkl,hrec,0,1,nang(1,3),
$ncontr(0,1,3),nprim(0,1,3),gexp(1,0,1,3),gcn(1,1,0,1,3),dfnbasis,
$gcoef(1,1,0,1,3),indarr(1,0,1,1,3),dcore(imem),dcore,dfipre,dcore,
$dcore,dcore,1,dcore,i,i,i,moadd,i,ctol, ! ??? ctol=?
$scrfile3,spctostr,1,1,dcore,.true.,.false.,scrfile4,-1.d0,
$0,i,.false.,naftol,dcore,lintra,nocc,emapi,
$idumy,idumy,dcore,idumy,atpair,0,dcore,
$idumy,idumy,idumy,idumy,idumy,idumy,idumy,edfmapi,enatdom,eatdom,
$rdumy,rdumy,tr2naf,rdumy,rdumy,
$dcore(impa),rdumy,dfnb_old,idumy,nshrange(1,0,1,3),idumy,
$ldfpair,times,enbi,no,mapi,idumy,idumy,rdumy,dcore(imshpa),
$edfnbi,rdumy,rdumy,nv,rdumy,rdumy,rdumy,idumy, ! screened Jab trf specific from here
$dfnb_old,dcore(impa),dcore(ijabp),dcore(ijabq),edpao2vlno,lnaf,edi
$,ccprog,
$rdumy,rdumy,dcore(ipmax),rdumy,rdumy, ! this line for screening
$rdumy,icore(iuncp),dcore(igcp),dfcoralg,
$idumy,dcore(imukp),npaop,0,lmo2vlnop,nlmo,ijpcp,mooc, ! for abtyp.eq.5
$dcore(ikpa),dcore(ijabqterm),nbset,1,.false.,rdumy,rdumy,.true., ! for abtyp.eq.5
$idumy,rdumy,rdumy, ! for abtyp.eq.5
$dcore(ijij4c),dcore(ijia4c),rdumy,nvb,rdumy,idumy,oslcc,idumy,!oslcc
$docc,nva,og2canpao,rdumy,0.d0,rlnv,rlnvb,inbcast_group)!oslcc
endif
if (inttyp.eq.5.or.cpinttyp.eq.30) enbi=cpenbi
if (inttyp.eq.4.or.inttyp.eq.5) then ! lintra.eq.11/13
call dbldealloc(ipmax)
call timeadd(times(1,31),ttmp)
times(1:2,36:38)=times(3:4,32:34)-times(3:4,36:38) ! time for this ED
times(3:4,36:38)=times(3:4,32:34)
times(5:6,36:38)=max(times(1:2,36:38),times(5:6,36:38)) ! max up to this ED
c memory requeirement
times(1,57)=imem-imem1+intmem
times(2,57)=memreq
times(3,57)=max(times(1,57),times(3,57))
times(4,57)=max(times(2,57),times(4,57))
endif
call dbldealloc(igcp)
return
end subroutine lintra_ed
C }}}
c
c {{{ subroutine readlmoed
subroutine readlmoed(emodominv,nocc,no,emodom,moadd,nbi,fn,mo)
************************************************************************
* read local occ MOs for a single ED
************************************************************************
implicit none
integer no,nocc,fn,jj,j,k,nbi(nocc),moadd(nocc)
integer emodom(nocc),emodominv(nocc)
real*8 mo(*)
emodominv(1:nocc)=0
do jj=1,no
emodominv(emodom(jj))=jj
enddo
c write(*,*) 'imo read in lintra_ed',no
rewind(fn)
do j=1,nocc
if (emodominv(j).eq.0) then
read(fn)
else
jj=emodominv(j)
read(fn) (mo(moadd(jj)+k),k=1,nbi(j))
c write(*,'(1000f8.5)') (mo(moadd(jj)+k),k=1,nbi(j))
endif
enddo
return
end
c }}}
c
c {{{ subroutine fillmap2l
subroutine fillmap2l(d,nl1,nl2,list1,list2,map)
************************************************************************
c fill in map of two lists
************************************************************************
implicit none
integer d,nl1,nl2
integer iiatoms,iatoms,jjatoms,jatoms,list1(*),list2(*),map(d,*)
c
call ifillzero(map,d**2)
do iiatoms=1,nl1
iatoms=list1(iiatoms)
do jjatoms=1,nl2
jatoms=list2(jjatoms)
map(iatoms,jatoms)=1
enddo
enddo
c
return
end
c }}}
c
c {{{ subroutine inttyp1or3mem
subroutine inttyp1or3mem(inttyp,memreq,md,no,emodom,moadd,nbi,
$nbfshmax,edfnbi,enbi,natoms,nangmax,xyzomp,smallmem,extramem,
$memreq1,memreq2)
************************************************************************
c calculate memory reqiurement for local AO to MO trf: (mu,nu,P) -> (a_PAO,I_LMO,P) in lintra_ed
************************************************************************
implicit none
integer inttyp,memreq,md,no,emodom(*),moadd(*),nbi(*)
integer nbfshmax,edfnbi,enbi,natoms,nangmax,xyzomp
integer jj,j,memreq1,memreq2,mpnc,extramem
logical smallmem
c
memreq=0
do jj=1,no
j=emodom(jj)
moadd(jj)=memreq
memreq=memreq+nbi(j)
enddo
md=memreq ! all memory for LMO coeffs
if (inttyp.eq.1) then
c version 1 (ver=1): mem requirement if full (muI|P) is not stored in memory
memreq1=md+nbfshmax*edfnbi*max(no,nbfshmax) ! for half-transf. ints (muPI) for a mu shell (mpi and scred intermediates)
$ +nbfshmax*edfnbi*enbi ! for mpn intermedtiate in lmuiptrfv2
c version 2 (ver=2): mem requirement if full (muI|P) can be stored in memory
memreq2=md+enbi*edfnbi*no ! for half-transf. ints (muiP)
$ +2*nbfshmax**2*edfnbi ! for mnp and nmp intermedtiates in lmuiptrf
$ +nbfshmax*edfnbi ! for mupiscr intermedtiate in lmuiptrf
memreq=min(memreq1,memreq2)
elseif (inttyp.eq.3) then
mpnc=1
if (smallmem) mpnc=2
memreq1=natoms*(nangmax+1)*(3+no) ! for cmax, pmax, comax, csmax in df3intn
memreq1=memreq1+(nbfshmax**2+2*nbfshmax)*no*xyzomp ! for cmi,cni,mipsd,nipsh in lmipined
memreq=md+memreq1+enbi*no*nbfshmax*max(mpnc,xyzomp)+extramem ! for mippsh intermedtiate in lmipined, mpnc for aipsh of led2ndtrf
endif
c
return
end
c }}}
c
C {{{ subroutine subsysdf2
************************************************************************
subroutine subsysdf2(df2mat,dfnb,natoms,natdomi,
$dcore,icore,imem,iimem,imapi,nbas,nnb,! 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,rqqkl,spctostr,nbset,dero,omega,boys,fulltc)
************************************************************************
* compute 2 center integrals of the correlation DF basis functions (-> df2mat)
* for a given subsystem of the molecule defined by its list of atoms in the inverse map of imapi
************************************************************************
implicit none
integer dfnb,natoms,natdomi,dero,imem,iimem,nbas,nnb
integer idummy,imapi(natdomi),dblalloc,intalloc,icore(*)
real*8 df2mat(dfnb,dfnb),dcore(*),r8dummy,itol,omega
C Variables for integral calculation
integer nbset
integer nangmax,ncontrmax,nprimmax,nang(natoms,nbset)
integer ncontr(0:nangmax,natoms,nbset)
integer nprim(0:nangmax,natoms,nbset),ncartmax,nsphermax,nmboys
integer iroute,iout,datoms,idfipre
integer imem1,maxcor,thad,gcn(2,ncontrmax,0:nangmax,natoms,nbset)
real*8 gexp(nprimmax,0:nangmax,natoms,nbset)
real*8 gcoef(nprimmax,ncontrmax,0:nangmax,natoms,nbset)
real*8 coord(3,natoms),ctostr,cf,boysval,thcf2
real*8 scoord,rqqij,rqqkl,spctostr
logical cartg,fulltc
c memory addresses
integer inang,incontr,inprim,igcoef,icoord,inshrange
integer igexp,igcn,idfindarr,idfrqq
interface
subroutine boys
end
end interface
c
idummy=0
r8dummy=0.d0
iroute=0 ! turn off progress monitor
if(dero.gt.0) then
datoms=-1
else
datoms=1
endif
c memory addresses
idfrqq=dblalloc((4*nangmax+1+dero)*nprimmax*(nangmax+1)*natdomi)
inang=intalloc(2*natdomi)
incontr=intalloc(2*natdomi*(nangmax+1))
inprim=intalloc(2*natdomi*(nangmax+1))
igcoef=dblalloc(nprimmax*ncontrmax*(nangmax+1)*natdomi)
icoord=dblalloc(3*natdomi)
inshrange=intalloc(2*(nangmax+1)*natdomi)
igexp=dblalloc(2*nprimmax*natdomi*(nangmax+1))
igcn=intalloc(2*ncontrmax*(nangmax+1)*natdomi)
idfindarr=intalloc((1+nangmax)*ncontrmax*nsphermax*natdomi)
idfipre=dblalloc(natdomi*(1+nangmax))
c rearrange data defining the full molecule for the subsystem
call rearr_basdat(icore(inang),icore(incontr),icore(inprim),
$dcore(igcoef),dcore(icoord),icore(inshrange),dcore(igexp),
$icore(igcn),imapi,natdomi,nang,ncontr,nprim,gcoef,coord,
$gexp,gcn,natoms,nangmax,ncontrmax,nprimmax,nbset,
$nbas,nnb,icore(iimem),icore(iimem),cartg)
c fill dfindarr
call fill_indarr(icore(idfindarr),natdomi,icore(inang+natdomi),
$icore(incontr+natdomi*(nangmax+1)),cartg,nangmax,ncontrmax,
$nsphermax)
c rearrange: nang,ncontr,nprim,gcoef,coord,nshrange,gexp,gcn
c recompute: dfindarr
c nem kell pre,dfipre , hely kell thcf2,scoord
call df2int(natdomi,nangmax,ncontrmax,nprimmax,icore(inang),
$icore(incontr),icore(inprim),dcore(igexp),
$dcore(icoord),ncartmax,ctostr,cartg,nsphermax,
$cf,boysval,nmboys,dcore,imem,
$iroute,0.00001d0*itol,
$icore(inshrange),iout,imem1,maxcor,thad,thcf2,
$scoord,rqqij,rqqkl,
$dero,datoms,icore(inang+natdomi),
$icore(incontr+natdomi*(nangmax+1)),
$icore(inprim+natdomi*(nangmax+1)),
$dcore(igexp+nprimmax*natdomi*(nangmax+1)),
c $icore(igcn+ncontrmax*(nangmax+1)*natdomi*2),dcore(idfrqq),dfnb,
c $dcore(igcoef+nprimmax*ncontrmax*(nangmax+1)*natdomi),
$icore(igcn),dcore(idfrqq),dfnb,dcore(igcoef),icore(idfindarr),
$df2mat,dcore(idfipre),idummy,idummy,.false.,idummy,
$df2mat,spctostr,0,r8dummy,idummy,fulltc,df2mat,omega,boys)
call dbldealloc(idfrqq)
return
end
c }}}
c
c {{{ subroutine fill_indarr
************************************************************************
subroutine fill_indarr(indarr,natoms,nang,ncontr,cartg,nangmax,
$ncontrmax,nsphermax)
************************************************************************
* fill indarr for an input basis set
************************************************************************
implicit none
integer natoms,nangmax,ncontrmax,nsphermax
integer nang(natoms),ncontr(0:nangmax,natoms)
integer indarr(natoms,0:nangmax,ncontrmax,nsphermax)
integer iatoms,iang,icontr,i,nbasis,l,icart
logical cartg
nbasis=0
do iatoms=1,natoms
do iang=0,nang(iatoms)
do icontr=1,ncontr(iang,iatoms)
icart=0
if(cartg) then
do i=0,iang
icart=icart+1
nbasis=nbasis+1
indarr(iatoms,iang,icontr,icart)=nbasis
enddo ! i
else
do l=-iang,iang
nbasis=nbasis+1
indarr(iatoms,iang,icontr,l+iang+1)=nbasis
enddo
endif
enddo ! icontr
enddo ! iang
enddo ! iatoms
c write(*,*) 'nbasis in fill_indarr',nbasis
return
end
c }}}
c
c {{{ subroutine rearr_basdat
************************************************************************
subroutine rearr_basdat(snang,sncontr,snprim,sgcoef,subcoord,
$sdfnshrange,sgexp,sgcn,imapi,natdomi,nang,ncontr,nprim,gcoef,
$coord,gexp,gcn,natoms,nangmax,ncontrmax,nprimmax,
$nbset,nbas,nnb,snangmin,nangmin,cartg)
************************************************************************
* rearrange data defining the basis set of the complete molecule for a subset of atoms
************************************************************************
implicit none
integer natdomi,imapi(natdomi),i,ii,j,jj,natoms
integer nangmax,ncontrmax,nprimmax,nbset,nnb,nbas
C array containing the basis set data of the complete system
integer nang(natoms,nbset),ncontr(0:nangmax,natoms,nbset)
integer nangmin(natoms,nbset)
integer nprim(0:nangmax,natoms,nbset)
integer gcn(2,ncontrmax,0:nangmax,natoms,nbset)
real*8 gexp(nprimmax,0:nangmax,natoms,nbset)
real*8 gcoef(nprimmax,ncontrmax,0:nangmax,natoms,*)
real*8 coord(3,natoms)
logical cartg
C for modified dimensional arrays of the subsystem
integer snang(natdomi,nnb),sncontr(0:nangmax,natdomi,nnb)
integer snangmin(natdomi,nnb)
integer snprim(0:nangmax,natdomi,nnb)
integer sdfnshrange(2,0:nangmax,natdomi)
integer sgcn(2,ncontrmax,0:nangmax,natdomi)
real*8 sgcoef(nprimmax,ncontrmax,0:nangmax,natdomi)
real*8 subcoord(3,natdomi),sgexp(nprimmax,0:nangmax,natdomi,nnb)
c internal variables
integer nbasis,iatoms,iang,iiatoms
do i=1,natdomi
ii=imapi(i) ! absolute atom index of i
do j=1,nnb ! for AO and corr DF basis sets
if (j.eq.1) then
jj=1
elseif (j.eq.2) then
jj=nbas ! sequential number of the density fitting basis for correlation
endif
snang(i,j)=nang(ii,jj)
sncontr(0:nangmax,i,j)=ncontr(0:nangmax,ii,jj)
snprim(0:nangmax,i,j)=nprim(0:nangmax,ii,jj)
sgexp(1:nprimmax,0:nangmax,i,j)=gexp(1:nprimmax,0:nangmax,ii,jj)
enddo
sgcoef(1:nprimmax,1:ncontrmax,0:nangmax,i)=
$ gcoef(1:nprimmax,1:ncontrmax,0:nangmax,ii,nbas)
sgcn(1:2,1:ncontrmax,0:nangmax,i)=
$ gcn(1:2,1:ncontrmax,0:nangmax,ii,nbas)
subcoord(1:3,i)=coord(1:3,ii)
if (nbas.eq.1) snangmin(i,nbas)=nangmin(ii,nbas)
enddo
c recompute (df)nshrange for the subsystem
nbasis=0
sdfnshrange(1:2,0:nangmax,1:natdomi)=0
do iiatoms=1,natdomi
iatoms=imapi(iiatoms) ! absolute atom index of iiatoms
do iang=0,nang(iatoms,nbas)
sdfnshrange(1,iang,iiatoms)=nbasis
if(cartg) then
nbasis=nbasis+ncontr(iang,iatoms,nbas)*(iang+1)*(iang+2)/2
else
nbasis=nbasis+ncontr(iang,iatoms,nbas)*(2*iang+1)
endif
sdfnshrange(2,iang,iiatoms)=nbasis
enddo ! iang
enddo ! iatoms
c
return
end
c }}}
c
c {{{ function osxmem
************************************************************************
integer function osxmem(oslcc,memiftrue,memiffalse)
************************************************************************
implicit none
integer memiftrue,memiffalse
logical oslcc
if (oslcc) then
osxmem=memiftrue
else
osxmem=memiffalse
endif
return
end function ! }}}
c
c {{{ subroutine restricted2can_jab
subroutine restricted2can_jab(dfnb,nvra,nvrb,nval,jabr,jabcan,
&og2cana,ilmo,jabbuff1,jabbuff2,filebase)
implicit none
integer dfnb,nval,nvra,a,b,nvrb,ilmo,p
real*8 jabr(dfnb,nvrb*(nvrb+1)/2),jabcan(dfnb,*)
real*8 og2cana(nvra,nval)
real*8 jabbuff1(nvrb,nvrb),jabbuff2(nvrb,*)
character*10 filebase
character*16 filename,ilmoname
write(ilmoname,'(i6)') ilmo
do p=1,dfnb
! Extract J_ab
do b=1,nvrb
do a=1,b
jabbuff1(a,b)=jabr(p,b*(b-1)/2+a)
if (a.ne.b) jabbuff1(b,a)=jabr(p,b*(b-1)/2+a)
enddo
enddo
! Transfrom J_ab -> J_ab'
call dgemm('n','n',nvrb,nval,nvra,1.d0,jabbuff1,nvrb,og2cana,
& nvra,0.d0,jabbuff2,nvrb)
! Transform and pack J_ab' -> J_a'<b'
do b=1,nval
call dgemv('t',nvra,b,1.d0,og2cana,nvra,jabbuff2(1,b),1,0.d0,
& jabcan(p,b*(b-1)/2+1),dfnb)
enddo
enddo !p
if (trim(filebase).ne.'.false.') then
filename=adjustl(trim(filebase)) // adjustl(trim(ilmoname))
open(111,file=trim(filename),form='unformatted')
write(111) jabcan(1:dfnb,1:nval*(nval+1)/2)
close(111)
endif
return
end subroutine restricted2can_jab !}}}
c
subroutine Jpq2NAF_write(dfnb,pqdim,dfnb_old,W,Jpq_old,Jpq,
$ filename,readold,Ppq)
implicit none
integer dfnb,pqdim,dfnb_old
real*8 W(dfnb_old,dfnb),Jpq_old(*),Jpq(*)
character*16 filename
logical readold,Ppq !Ppq: true if the index order of Jpq_old is (P|pq)
if (readold) then
open(111,file=trim(filename),form='unformatted')
read(111) Jpq_old(1:dfnb_old*pqdim)
close(111,status='delete')
endif !readold
if (Ppq) then
call dgemm('t','n',dfnb,pqdim,dfnb_old,1.d0,W,dfnb_old,Jpq_old,
$ dfnb_old,0.d0,Jpq,dfnb)
else
call dgemm('n','n',pqdim,dfnb,dfnb_old,1.d0,Jpq_old,pqdim,W,
$ dfnb_old,0.d0,Jpq,pqdim)
endif !Ppq
open(111,file=trim(filename),form='unformatted')
write(111) Jpq(1:dfnb*pqdim)
close(111)
return
end subroutine Jpq2NAF_write
Reference in New Issue View Git Blame Copy Permalink