mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-17 20:20:49 +01:00
429 lines
15 KiB
Fortran
429 lines
15 KiB
Fortran
************************************************************************
|
|
subroutine grad_ai(nbasis,nvirt,nocc,dfnbasis,npos,bia,bim,cpr,
|
|
$i4core,intpos,mo,scrfile1,ifrst,dtol,nbll,nbl,eo,ev,iout,nbf,
|
|
$ccalc,bjb,iajb,iblock,scr,dofit,scrfile4,emp2c,emp2x,bjb_a,iajb_a,
|
|
$lbeta,nbla,nblla,iblocka,nvirtal,emp2ab,dfintaifile,eoa,eva,dens,
|
|
$fmo,iajbl,tiajb,pbc,pjk,scrfile7,nblock,last,iab,tab,yia,mpfile,
|
|
$nrec,tiajbl,scfile,densfile,itol,tedatfile,scrfile8,scspv)
|
|
************************************************************************
|
|
* Calculate DF-MP2 energy and density matrix
|
|
************************************************************************
|
|
implicit none
|
|
integer nbasis,dfnbasis,intpos(3,(nbf+1)*nbf/2),npos,ipos,scrfile8
|
|
integer nbl,ifrst,nbf,nrec
|
|
integer i,j,k,l,n,kk,ii,nocc,nvirt,a,b,c,iout,nbll,kldim,jj,jk,nb
|
|
integer scrfile1,jblock,iblock,jfrst,ia,ij,kl,ja,jb,ib,ijdim,dens
|
|
integer scrfile4,nbla,nblla,iblocka,nvirtal,dfintaifile,scrfile7
|
|
integer irec,nblock,iiblock,mpfile,scfile,densfile,tedatfile
|
|
real*8 dtol,pr,bia(dfnbasis,nbll,nvirt),eo(nocc),ev(nvirt),temp,eb
|
|
real*8 bim(dfnbasis*nbll*nbf),cpr(nbf),mo(nbf,nbasis),itmp,ddot
|
|
real*8 bjb(dfnbasis,nbl,nvirt),iajb(nbll,nvirt,nbl,nvirt),ei,ej,ea
|
|
real*8 iajbl(nbll,nvirt,nbll,nvirt),tiajb(nbll,nvirt,nbl),itol
|
|
real*8 tiajbl(nbl,nvirt,nbll),scspv
|
|
real*8 pbc(nvirt,nvirt),pjk(nocc,nocc),tab(nocc,nocc)
|
|
real*8 scr(*),emp2c,emp2x,emp2ab,iab(nocc,nocc)
|
|
real*8 bjb_a(*),eoa(*),eva(nvirtal),fmo(nbf,nbf)
|
|
real*8 iajb_a(nbll*nvirt*nbla*nvirtal),yia(dfnbasis,nbl,nvirt)
|
|
integer*4 i4core(*)
|
|
character*16 ccalc
|
|
logical dofit,lbeta,last
|
|
C First half transformation: (P,nu,mu) -> (P,i,mu)
|
|
call firsthalf(nbf,dfnbasis,nbll,intpos,npos,bim,cpr,
|
|
$mo(1,ifrst+1),i4core,dtol,.false.,scr,scr(dfnbasis+1),scspv)
|
|
C Fitting: (P,i,mu) -> B^P_imu
|
|
c if(.not.dofit) then
|
|
if(.true.) then
|
|
open(scrfile4,file='DFINV',form='UNFORMATTED')
|
|
call dfillzero(scr,dfnbasis**2)
|
|
call rspmx(scr,dfnbasis,scrfile4)
|
|
close(scrfile4)
|
|
call dtrsm('L','L','N','N',dfnbasis,nbll*nbf,1.d0,
|
|
$scr,dfnbasis,bim,dfnbasis)
|
|
endif
|
|
C Save B^P_imu
|
|
write(scfile) bim
|
|
C Second half transformation: B^P_imu -> B^P_ia
|
|
call dgemm('n','n',dfnbasis*nbll,nvirt,nbf,1.d0,bim,dfnbasis*nbll,
|
|
$mo(1,nocc+1),nbf,0.d0,bia,dfnbasis*nbll)
|
|
C Calculate DF-MP2 energy and assemble (ia|jb) list
|
|
rewind(scrfile1)
|
|
C Loop over blocks
|
|
do jblock=1,iblock-1 !J=1,I-1
|
|
read(scrfile1) bjb
|
|
C Assemble (ia|jb)
|
|
call dgemm('t','n',nvirt*nbll,nvirt*nbl,dfnbasis,1.d0,bia,
|
|
$dfnbasis,bjb,dfnbasis,0.d0,iajb,nvirt*nbll)
|
|
C Calculate MP2 energy
|
|
jfrst=(jblock-1)*nbl
|
|
do i=1,nbll
|
|
ei=eo(ifrst+i)
|
|
do j=1,nbl
|
|
ej=ei+eo(jfrst+j)
|
|
do a=1,nvirt
|
|
ea=ej-ev(a)
|
|
do b=1,nvirt
|
|
itmp=iajb(i,a,j,b)
|
|
temp=itmp/(ea-ev(b))
|
|
emp2c=emp2c+itmp*temp
|
|
emp2x=emp2x+iajb(i,b,j,a)*temp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C Devide integrals by denominator
|
|
do i=1,nbll
|
|
ei=eo(ifrst+i)
|
|
do j=1,nbl
|
|
ej=ei+eo(jfrst+j)
|
|
do a=1,nvirt
|
|
ea=ej-ev(a)
|
|
do b=1,nvirt
|
|
iajb(i,a,j,b)=iajb(i,a,j,b)/(ea-ev(b))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C Calculate P_bc
|
|
call dfillzero(yia,dfnbasis*nvirt*nbll)
|
|
do b=1,nvirt
|
|
do i=1,nbll
|
|
do j=1,nbl
|
|
do a=1,nvirt
|
|
tiajb(i,a,j)=2.d0*iajb(i,a,j,b)-iajb(i,b,j,a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
call dgemm('n','t',dfnbasis,nbll*nvirt,nbl,1.d0,bjb(1,1,b),
|
|
$dfnbasis,tiajb,nbll*nvirt,1.d0,yia,dfnbasis)
|
|
call dgemv('t',nvirt*nbll*nbl,b,1.d0,iajb,nvirt*nbll*nbl,
|
|
$tiajb,1,1.d0,pbc(1,b),1)
|
|
do j=1,nbl
|
|
do a=1,nvirt
|
|
call dgemm('n','n',1,nvirt-a+1,nbll,1.d0,iajb(1,a,j,b),
|
|
$1,tiajb(1,a,j),nbll,1.d0,pbc(a,a),nvirt)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
call getput(mpfile,(iblock-1)*nrec+1,yia,dfnbasis*nvirt*nbll)
|
|
call dfillzero(yia,dfnbasis*nvirt*nbl)
|
|
do a=1,nvirt
|
|
do i=1,nbll
|
|
do j=1,nbl
|
|
do b=1,nvirt
|
|
tiajbl(j,b,i)=2.d0*iajb(i,a,j,b)-iajb(i,b,j,a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
call dgemm('n','t',dfnbasis,nbl*nvirt,nbll,1.d0,bia(1,1,a),
|
|
$dfnbasis,tiajbl,nbl*nvirt,1.d0,yia,dfnbasis)
|
|
enddo
|
|
call getput(mpfile,(jblock-1)*nrec+1,yia,dfnbasis*nvirt*nbl)
|
|
C Save integrals for the calculation of P_jk
|
|
irec=(iblock-1)**2+(jblock-1)*2+1
|
|
do a=1,nvirt
|
|
do b=1,a
|
|
write(scrfile7,rec=irec ) ((iajb(i,a,j,b),i=1,nbll),j=1,nbl)
|
|
write(scrfile7,rec=irec+1) ((iajb(i,b,j,a),i=1,nbll),j=1,nbl)
|
|
irec=irec+nblock**2
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C Last block, J=I
|
|
C Assemble (ia|jb)
|
|
call dsyrk('l','t',nvirt*nbll,dfnbasis,1.d0,bia,dfnbasis,0.d0,
|
|
$iajbl,nvirt*nbll)
|
|
C Calculate MP2 energy
|
|
do i=1,nbll
|
|
ei=eo(ifrst+i)
|
|
do a=1,nvirt
|
|
ea=ei-ev(a)
|
|
temp=0.25d0*iajbl(i,a,i,a)**2/ea
|
|
emp2c=emp2c+temp
|
|
emp2x=emp2x+temp
|
|
do j=1,i-1 !a.eq.b
|
|
ej=ea+eo(ifrst+j)
|
|
temp=iajbl(i,a,j,a)**2/(ej-ev(a))
|
|
emp2c=emp2c+temp
|
|
emp2x=emp2x+temp
|
|
enddo
|
|
do j=1,nbll !a.gt.b
|
|
ej=ea+eo(ifrst+j)
|
|
do b=1,a-1
|
|
itmp=iajbl(i,a,j,b)
|
|
temp=itmp/(ej-ev(b))
|
|
emp2c=emp2c+itmp*temp
|
|
emp2x=emp2x+iajbl(j,a,i,b)*temp
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
C Devide integrals by denominator
|
|
do i=1,nbll
|
|
ei=eo(ifrst+i)
|
|
do a=1,nvirt
|
|
ea=ei-ev(a)
|
|
iajbl(i,a,i,a)=0.5d0*iajbl(i,a,i,a)/ea
|
|
do j=1,i-1 !a.eq.b
|
|
ej=ea+eo(ifrst+j)
|
|
iajbl(i,a,j,a)=iajbl(i,a,j,a)/(ej-ev(a))
|
|
enddo
|
|
do j=1,nbll !a.gt.b
|
|
ej=ea+eo(ifrst+j)
|
|
do b=1,a-1
|
|
iajbl(i,a,j,b)=iajbl(i,a,j,b)/(ej-ev(b))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
call fillup(iajbl,nbll*nvirt)
|
|
C Calculate P_bc and Y^P_ia
|
|
call dfillzero(yia,dfnbasis*nvirt*nbll)
|
|
do b=1,nvirt
|
|
do a=1,nvirt
|
|
do i=1,nbll
|
|
do j=1,nbll
|
|
tiajb(i,a,j)=2.d0*iajbl(i,a,j,b)-iajbl(i,b,j,a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
call dgemm('n','t',dfnbasis,nbll*nvirt,nbll,1.d0,bia(1,1,b),
|
|
$dfnbasis,tiajb,nbll*nvirt,1.d0,yia,dfnbasis)
|
|
call dgemv('t',nvirt*nbll*nbll,b,1.d0,iajbl,nvirt*nbll*nbll,
|
|
$tiajb,1,1.d0,pbc(1,b),1)
|
|
enddo
|
|
C Save Y^P_ia in the case of out-of-core algorithm
|
|
call getput(mpfile,(iblock-1)*nrec+1,yia,dfnbasis*nvirt*nbll)
|
|
C Calculate P_jk
|
|
if(nblock.eq.1) then
|
|
C In-core
|
|
do b=1,nvirt
|
|
do a=1,nvirt
|
|
do i=1,nbll
|
|
do j=1,nbll
|
|
tiajb(i,a,j)=2.d0*iajbl(i,a,j,b)-iajbl(i,b,j,a)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
do j=1,nbll
|
|
call dgemv('t',nvirt*nbll,j,-1.d0,iajbl(1,1,1,b),nvirt*nbll,
|
|
$tiajb(1,1,j),1,1.d0,pjk(j,1),nocc)
|
|
enddo
|
|
enddo
|
|
else
|
|
C Save integrals for the calculation of P_jk
|
|
irec=(iblock-1)*(iblock+1)+1
|
|
do a=1,nvirt
|
|
do b=1,a
|
|
write(scrfile7,rec=irec)((iajbl(i,a,j,b),i=1,nbll),j=1,nbll)
|
|
irec=irec+nblock**2
|
|
enddo
|
|
enddo
|
|
endif
|
|
C Out-of-core
|
|
if(last) then
|
|
irec=0
|
|
do a=1,nvirt
|
|
do b=1,a
|
|
do iiblock=1,nblock-1
|
|
do jblock=1,iiblock-1
|
|
irec=irec+1
|
|
read(scrfile7,rec=irec)
|
|
$ ((iab((iiblock-1)*nbl+i,(jblock-1)*nbl+j),i=1,nbl),j=1,nbl)
|
|
irec=irec+1
|
|
read(scrfile7,rec=irec)
|
|
$ ((iab((jblock-1)*nbl+j,(iiblock-1)*nbl+i),i=1,nbl),j=1,nbl)
|
|
enddo
|
|
irec=irec+1
|
|
read(scrfile7,rec=irec)
|
|
$ ((iab((iiblock-1)*nbl+i,(iiblock-1)*nbl+j),i=1,nbl),j=1,nbl)
|
|
enddo
|
|
do jblock=1,nblock-1
|
|
irec=irec+1
|
|
read(scrfile7,rec=irec)
|
|
$ ((iab((nblock-1)*nbl+i,(jblock-1)*nbl+j),i=1,nbll),j=1,nbl)
|
|
irec=irec+1
|
|
read(scrfile7,rec=irec)
|
|
$ ((iab((jblock-1)*nbl+j,(nblock-1)*nbl+i),i=1,nbll),j=1,nbl)
|
|
enddo
|
|
irec=irec+1
|
|
read(scrfile7,rec=irec)
|
|
$ ((iab((nblock-1)*nbl+i,(nblock-1)*nbl+j),i=1,nbll),j=1,nbll)
|
|
C
|
|
if(a.eq.b) then
|
|
call dsyrk('l','n',nocc,nocc,-1.d0,iab,nocc,1.d0,pjk,nocc)
|
|
else
|
|
do i=1,nocc
|
|
do j=1,nocc
|
|
tab(i,j)=iab(j,i)
|
|
enddo
|
|
enddo
|
|
call dsyrk('l','n',nocc,nocc,-2.d0,iab,nocc,1.d0,pjk,nocc)
|
|
call dsyrk('l','t',nocc,nocc,-2.d0,iab,nocc,1.d0,pjk,nocc)
|
|
call dsyr2k('l','n',nocc,nocc,1.d0,tab,nocc,iab,nocc,1.d0,
|
|
$pjk,nocc)
|
|
endif
|
|
enddo
|
|
enddo
|
|
endif
|
|
C Assemble alpha-beta (ai|bj) list and calculate its contribution to MP2
|
|
if(lbeta) then
|
|
rewind(dfintaifile)
|
|
do jblock=1,iblocka
|
|
nb=nbla
|
|
if(jblock.eq.iblocka) nb=nblla
|
|
read(dfintaifile) (bjb_a(i),i=1,nvirtal*nb*dfnbasis)
|
|
call dgemm('t','n',nvirt*nbll,nvirtal*nb,dfnbasis,1.d0,bia,
|
|
$dfnbasis,bjb_a,dfnbasis,0.d0,iajb_a,nvirt*nbll)
|
|
jfrst=(jblock-1)*nbla
|
|
ii=0
|
|
do b=1,nvirtal
|
|
eb=-eva(b)
|
|
do j=1,nb
|
|
ej=eb+eoa(jfrst+j)
|
|
do a=1,nvirt
|
|
ea=ej-ev(a)
|
|
do i=1,nbll
|
|
ii=ii+1
|
|
emp2ab=emp2ab+iajb_a(ii)**2/(ea+eo(ifrst+i))
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
endif
|
|
C Save integrals
|
|
write(scrfile1) bia
|
|
C Final operations
|
|
if(last.or.nblock.eq.1) then
|
|
C Save one-particle densities
|
|
call woeintu(scr,scr,pbc,densfile,itol,nvirt)
|
|
call woeint(scr,scr,pjk,densfile,itol,nocc)
|
|
C Read L_QP (Cholesky factor of V)
|
|
open(scrfile4,file='DFINV',form='UNFORMATTED')
|
|
call rspmx(scr,dfnbasis,scrfile4)
|
|
call fillup(scr,dfnbasis)
|
|
close(scrfile4)
|
|
C Loop over blocks
|
|
rewind(scfile)
|
|
rewind(scrfile1)
|
|
open(scrfile8,file='GAMMA',form='unformatted')
|
|
call dfillzero(pbc,nvirt*nbf)
|
|
call dfillzero(pjk,dfnbasis**2)
|
|
do iiblock=1,nblock-1
|
|
C Construct L"_amu
|
|
read(scfile) (bim(i),i=1,dfnbasis*nbl*nbf)
|
|
call getlst(mpfile,(iiblock-1)*nrec+1,bjb,dfnbasis*nvirt*nbl)
|
|
call dgemm('t','n',nvirt,nbf,dfnbasis*nbl,1.d0,bjb,
|
|
$dfnbasis*nbl,bim,dfnbasis*nbl,1.d0,pbc,nvirt)
|
|
C Multiply Y^P_ia with V^-1/2_QP -> Gamma^P_ia
|
|
call dtrsm('l','l','t','n',dfnbasis,nvirt*nbl,1.0d0,scr,
|
|
$dfnbasis,bjb,dfnbasis)
|
|
c call dcopy(dfnbasis*nvirt*nbl,bia,1,bjb,1)
|
|
read(scrfile1) (bim(i),i=1,dfnbasis*nbl*nvirt)
|
|
call dgemm('n','t',dfnbasis,dfnbasis,nbl*nvirt,1.d0,bjb,
|
|
$dfnbasis,bim,dfnbasis,1.d0,pjk,dfnbasis)
|
|
C Calculate Gamma^P_inu
|
|
call dgemm('n','t',dfnbasis*nbl,nbf,nvirt,1.d0,bjb,
|
|
$dfnbasis*nbl,mo(1,nocc+1),nbf,0.d0,bim,dfnbasis*nbl)
|
|
write(scrfile8) (iiblock-1)*nbl+1,iiblock*nbl
|
|
write(scrfile8) (bim(i),i=1,dfnbasis*nbl*nbf)
|
|
enddo
|
|
C Last block
|
|
C Construct L"_amu
|
|
read(scfile) bim
|
|
call getlst(mpfile,(nblock-1)*nrec+1,bjb,dfnbasis*nvirt*nbll)
|
|
call dgemm('t','n',nvirt,nbf,dfnbasis*nbll,1.d0,bjb,
|
|
$dfnbasis*nbll,bim,dfnbasis*nbll,1.d0,pbc,nvirt)
|
|
C Multiply Y^P_ia with V^-1/2_QP -> Gamma^P_ia
|
|
call dtrsm('l','l','t','n',dfnbasis,nvirt*nbll,1.0d0,scr,
|
|
$dfnbasis,bjb,dfnbasis)
|
|
c call dcopy(dfnbasis*nvirt*nbll,bia,1,bjb,1)
|
|
C Calculate gammatilde^PQ
|
|
read(scrfile1) (bim(i),i=1,dfnbasis*nbll*nvirt)
|
|
call dgemm('n','t',dfnbasis,dfnbasis,nbll*nvirt,1.d0,bjb,
|
|
$dfnbasis,bim,dfnbasis,1.d0,pjk,dfnbasis)
|
|
C Calculate Gamma^P_inu
|
|
call dgemm('n','t',dfnbasis*nbll,nbf,nvirt,1.d0,bjb,
|
|
$dfnbasis*nbll,mo(1,nocc+1),nbf,0.d0,bim,dfnbasis*nbll)
|
|
write(scrfile8) (nblock-1)*nbl+1,(nblock-1)*nbl+nbll
|
|
write(scrfile8) bim
|
|
C Fitting gammatilde^PQ with L_QP
|
|
call dtrsm('r','l','n','n',dfnbasis,dfnbasis,1.0d0,scr,
|
|
$dfnbasis,pjk,dfnbasis)
|
|
C Save gamma^PQ
|
|
c write(6,*) 'gamma^PQ'
|
|
call wtdmx(scr(dfnbasis*dfnbasis+1),scr(dfnbasis*dfnbasis+1),
|
|
$pjk,densfile,itol,dfnbasis,dfnbasis)
|
|
C Transform L"_amu to the MO basis and save result
|
|
call dgemm('n','n',nvirt,nbf,nbf,1.d0,pbc,nvirt,fmo,nbf,0.d0,
|
|
$pjk,nvirt)
|
|
call wtdmx(scr(dfnbasis*dfnbasis+1),scr(dfnbasis*dfnbasis+1),
|
|
$pjk,densfile,itol,nvirt,nbf)
|
|
C Calculate L_imu
|
|
rewind(scrfile8)
|
|
call dfillzero(pbc,nocc*nbf)
|
|
do iiblock=1,nblock-1
|
|
jfrst=(iiblock-1)*nbl+1
|
|
read(scrfile8)
|
|
read(scrfile8) (bim(i),i=1,dfnbasis*nbl*nbf)
|
|
call limuconst(nbf,dfnbasis,nbl,intpos,npos,bim,i4core,
|
|
$scr,pbc,nocc,jfrst,.false.)
|
|
enddo
|
|
jfrst=(nblock-1)*nbl+1
|
|
read(scrfile8)
|
|
read(scrfile8) bim
|
|
call limuconst(nbf,dfnbasis,nbll,intpos,npos,bim,i4core,
|
|
$scr,pbc,nocc,jfrst,.false.)
|
|
C Transform L_imu to the MO basis and save result
|
|
call dgemm('n','n',nocc,nbf,nbf,1.d0,pbc,nocc,fmo,nbf,0.d0,
|
|
$pjk,nocc)
|
|
call wtdmx(scr(dfnbasis*dfnbasis+1),scr(dfnbasis*dfnbasis+1),
|
|
$pjk,densfile,itol,nocc,nbf)
|
|
close(scrfile8)
|
|
endif
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine limuconst(nbf,dfnbasis,nbll,intpos,npos,jmi,i4core,
|
|
$kvec,limu,nocc,jfrst,dofit)
|
|
************************************************************************
|
|
* Calculate L_imu intermediate for DF-MP2 gradient
|
|
************************************************************************
|
|
implicit none
|
|
integer nbf,dfnbasis,nbll,intpos(3,*),npos,ipos,i,j,nocc,jfrst
|
|
integer n,ii,kk,teintf(10),mu,nu,p
|
|
real*8 ss,pr,limu(nocc,nbf)
|
|
real*8 jmi(dfnbasis,nbll,nbf),kvec(dfnbasis)
|
|
integer*4 i4core(*),ssi(2)
|
|
equivalence(ss,ssi)
|
|
logical dofit
|
|
C
|
|
if(dofit) then
|
|
call intopenrsqtc(teintf)
|
|
else
|
|
call intopenrsq(teintf)
|
|
endif
|
|
do ipos=1,npos
|
|
nu=intpos(1,ipos)
|
|
mu=intpos(2,ipos)
|
|
n=intpos(3,ipos)
|
|
call intreadsq(i4core,n,teintf)
|
|
call dfillzero(kvec,dfnbasis)
|
|
do kk=0,n-1
|
|
ssi(1)=i4core(3*kk+1)
|
|
ssi(2)=i4core(3*kk+2)
|
|
kvec( i4core(3*kk+3))=ss
|
|
enddo
|
|
call dgemv('t',dfnbasis,nbll,1.d0,jmi(1,1,nu),dfnbasis,kvec,1,
|
|
$1.d0,limu(jfrst,mu),1)
|
|
if(mu.ne.nu)
|
|
$ call dgemv('t',dfnbasis,nbll,1.d0,jmi(1,1,mu),dfnbasis,kvec,1,
|
|
$1.d0,limu(jfrst,nu),1)
|
|
enddo
|
|
call intclose(teintf)
|
|
return
|
|
end
|
|
C
|