mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-18 12:40:58 +01:00
647 lines
22 KiB
Fortran
647 lines
22 KiB
Fortran
!********************************************************************************
|
|
!********************************************************************************
|
|
! ldfgrad.f90
|
|
! This file contains the routines required to calculate integrals and
|
|
! derivatives for local fitting SCF gradients
|
|
!********************************************************************************
|
|
!********************************************************************************
|
|
|
|
!********************************************************************************
|
|
subroutine ldfgrad_exc(nbasis,nocc,dfn,hai,tcd,chfx,mo1,mo2,hai1,hai2,iiroute, &
|
|
iout)
|
|
!********************************************************************************
|
|
! Exchange fitting for local DF gradient calculation (locfit1)
|
|
!********************************************************************************
|
|
implicit none
|
|
integer nbasis,nocc,dfn,iiroute,iout
|
|
integer i,iroute
|
|
double precision hai(dfn,nbasis),tcd(*),chfx,mo1(nbasis,nocc)
|
|
double precision mo2(nbasis,nocc)
|
|
double precision hai1(dfn,nocc),hai2(dfn,nocc),x
|
|
|
|
i=0
|
|
iroute=iiroute
|
|
if(iroute.eq.26) iroute=6
|
|
call dpptrf('L',dfn,tcd,i)
|
|
if(i/=0) then
|
|
write(iout,*) 'Fatal error at Cholesky decomposition!'
|
|
call mrccend(1)
|
|
endif
|
|
call dgemm('n','n',dfn,nocc,nbasis,1.0d0,hai,dfn,mo1,nbasis,0.0d0,hai1,dfn)
|
|
if(iroute==6) call dgemm('n','n',dfn,nocc,nbasis,1.0d0,hai,dfn,mo2,nbasis, &
|
|
0.0d0,hai2,dfn)
|
|
call dpptrs('l',dfn,nocc,tcd,hai1,dfn,i)
|
|
if(i.ne.0) then
|
|
write(iout,*) 'Fatal error at fitting!'
|
|
call mrccend(1)
|
|
endif
|
|
x=1.0d0
|
|
!if(iroute==8) x=2.0d0
|
|
call dgemm('n','t',dfn,nbasis,nocc,x,hai1,dfn,mo2,nbasis,0.0d0,hai,dfn)
|
|
|
|
if(iroute==6) then
|
|
call dpptrs('l',dfn,nocc,tcd,hai2,dfn,i)
|
|
if(i.ne.0) then
|
|
write(iout,*) 'Fatal error at fitting!'
|
|
call mrccend(1)
|
|
endif
|
|
call dgemm('n','t',dfn,nbasis,nocc,1.0d0,hai2,dfn,mo1,nbasis,1.0d0,hai,dfn)
|
|
endif
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine ldf_bij(dfn,nbasis,nocc,mo,mo2,hai,bij,df2int,lbij,ldfock,iout)
|
|
!********************************************************************************
|
|
! Calculating the Bij matrix for the LDF derivative
|
|
!********************************************************************************
|
|
implicit none
|
|
integer dfn,nocc,nbasis,lbij,iout
|
|
double precision mo(nbasis,nbasis),mo2(nbasis,nbasis)
|
|
double precision bij(*),hai(dfn,nbasis)
|
|
double precision df2int(dfn*(dfn+1)/2)
|
|
logical ldfock
|
|
|
|
if(ldfock) then
|
|
call ldfgrad_exc(nbasis,nocc,dfn,hai,df2int,1.0d0,mo,mo2,bij,bij(1+lbij),6, &
|
|
iout)
|
|
call dscal(dfn*nbasis,0.5d0,hai,1)
|
|
else
|
|
call ldfgrad_exc(nbasis,nocc,dfn,hai,df2int,1.0d0,mo,mo,bij,bij,8,iout)
|
|
endif
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
integer function ldf_bij_mem(dfnmobasis,nocc,imo1,imo2,ibij,ldfock) result(mem)
|
|
!********************************************************************************
|
|
! Calculate memory requirements for the Bij matrix
|
|
!********************************************************************************
|
|
implicit none
|
|
integer dfnmobasis(nocc),nocc,i,imo1,imo2,ibij
|
|
logical ldfock
|
|
|
|
integer dblalloc
|
|
|
|
mem=0
|
|
do i=imo1,imo2
|
|
mem=mem+dfnmobasis(i)
|
|
enddo
|
|
mem=mem*nocc
|
|
if(ldfock) mem=2*mem
|
|
ibij=dblalloc(mem)
|
|
return
|
|
end function
|
|
|
|
!********************************************************************************
|
|
subroutine ldf2grad(natoms,nocc,dfnmobasis,dfatdom,dfnatdom,imo1,imo2,dcore,bij,&
|
|
lbij,gam,dfnatrange,chfx,ldfock,dfnbasis)
|
|
!********************************************************************************
|
|
! Calculates Gamma_{PQ} to contract with the (P|Q) derivative
|
|
!********************************************************************************
|
|
implicit none
|
|
integer imo1,imo2,nocc,natoms
|
|
integer dfnmobasis(nocc),dfatdom(natoms,nocc),dfnatdom(nocc)
|
|
integer lbij,dfnatrange(2,natoms),dfnbasis
|
|
double precision dcore(*),bij(*),gam(dfnbasis*dfnbasis),chfx
|
|
logical ldfock
|
|
|
|
integer i,dfn,ibij1,ibij2,i1,i2,j
|
|
integer ki,kj,nki,nkj,ki1,ki2,kj2,kj1
|
|
integer iiatoms,iatoms,jjatoms,jatoms
|
|
integer igam_mo
|
|
|
|
integer dblalloc
|
|
|
|
dfn=0
|
|
do j=imo1,imo2
|
|
dfn=max(dfn,dfnmobasis(j))
|
|
enddo
|
|
igam_mo=dblalloc(dfn*dfn)
|
|
gam=0.0d0
|
|
|
|
do i=imo1,imo2
|
|
dfn=0
|
|
do j=imo1,i-1
|
|
dfn=dfn+dfnmobasis(j)
|
|
enddo
|
|
ibij1=1+dfn*nocc
|
|
ibij2=ibij1
|
|
if(ldfock) then
|
|
ibij2=ibij1+lbij
|
|
endif
|
|
dfn=dfnmobasis(i)
|
|
|
|
call dgemm('n','t',dfn,dfn,nocc,1.0d0,bij(ibij1),dfn,bij(ibij2),dfn,0.0d0, &
|
|
dcore(igam_mo),dfn)
|
|
if(ldfock) then
|
|
call symmat(dcore(igam_mo),dfn)
|
|
endif
|
|
|
|
ki=1
|
|
do iiatoms=1,dfnatdom(i)
|
|
iatoms=dfatdom(iiatoms,i)
|
|
ki1=dfnatrange(1,iatoms)
|
|
ki2=dfnatrange(2,iatoms)
|
|
nki=ki2-ki1
|
|
ki1=ki1+1
|
|
kj=1
|
|
do jjatoms=1,dfnatdom(i)
|
|
jatoms=dfatdom(jjatoms,i)
|
|
kj1=dfnatrange(1,jatoms)
|
|
kj2=dfnatrange(2,jatoms)
|
|
nkj=kj2-kj1
|
|
kj1=kj1+1
|
|
do i1=1,nki
|
|
do i2=1,nkj
|
|
gam(ki1+i1-1+(kj1+i2-2)*dfnbasis)=gam(ki1+i1-1+(kj1+i2-2)*dfnbasis)+&
|
|
dcore(igam_mo+ki+i1-2+(kj+i2-2)*dfn)
|
|
enddo
|
|
enddo
|
|
kj=kj+nkj
|
|
enddo
|
|
ki=ki+nki
|
|
enddo
|
|
enddo
|
|
call dscal(dfnbasis*dfnbasis,2.0d0*chfx,gam,1)
|
|
call dbldealloc(igam_mo)
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine ldf_shgamma(nilen,njlen,nocc,chfx,ieqj,hai,nbasis,dfnbasis,ifrst, &
|
|
jfrst,dx,mo,imo1,imo2,moadd,scrfile4,dfnatrange,dfnmobasis,ialpha,natoms, &
|
|
dfatind,dfatdom,dfnatdom)
|
|
!********************************************************************************
|
|
! Calculates the 3-center gamma matrix for a shell pair
|
|
!********************************************************************************
|
|
implicit none
|
|
integer nilen,njlen,nbasis,dfnbasis,jfrst,ifrst,imo1,imo2,ialpha
|
|
integer natoms,nocc
|
|
integer moadd(nocc),ndf,dfnb,scrfile4,dfnatrange(2,natoms)
|
|
integer dfnmobasis(nocc),dfatind(nocc,natoms),dfnatdom(nocc)
|
|
integer dfatdom(natoms,nocc)
|
|
integer i,imo,ihai,katoms,kkatoms,df1,df2,j,k
|
|
double precision chfx,hai(*),dx(nilen,njlen,dfnbasis),mo(nbasis,*)
|
|
logical ieqj
|
|
logical ll
|
|
|
|
integer intalloc
|
|
|
|
dx=0.0d0
|
|
!$OMP PARALLEL DO &
|
|
!$OMP PRIVATE(katoms,df1,df2,ndf,imo,ll,k,ihai,dfnb,i,j) &
|
|
!$OMP SHARED(dfnatrange,imo1,imo2,dfnatdom,dfatdom,moadd,dfatind) &
|
|
!$OMP SHARED(mo,dx,hai,nilen,njlen,ifrst,jfrst,dfnmobasis)
|
|
do katoms=1,natoms
|
|
df1=dfnatrange(1,katoms)
|
|
df2=dfnatrange(2,katoms)
|
|
ndf=df2-df1
|
|
do imo=imo1,imo2
|
|
ll=.false.
|
|
do k=1,dfnatdom(imo)
|
|
if(dfatdom(k,imo)==katoms) then
|
|
ll=.true.
|
|
exit
|
|
endif
|
|
enddo
|
|
if(.not.ll) cycle
|
|
ihai=moadd(imo)+dfatind(imo,katoms)-1
|
|
dfnb=dfnmobasis(imo)
|
|
do i=1,nilen
|
|
do j=1,njlen
|
|
do k=1,ndf
|
|
dx(i,j,k+df1)=dx(i,j,k+df1)+ &
|
|
mo(ifrst+i,imo)*hai(ihai+k+(jfrst+j-1)*dfnb)+ &
|
|
mo(jfrst+j,imo)*hai(ihai+k+(ifrst+i-1)*dfnb)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
if(ieqj) then
|
|
do i=1,nilen
|
|
dx(i,i,:)=0.5d0*dx(i,i,:)
|
|
do j=1,i-1
|
|
dx(i,j,:)=0.d0
|
|
enddo
|
|
enddo
|
|
endif
|
|
|
|
call dscal(nilen*njlen*dfnbasis,2.0d0*chfx,dx,1)
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine ldf_shdens(ddens,mo,mo2,nilen,njlen,ifrst,jfrst,nbasis,nocc)
|
|
!********************************************************************************
|
|
! calculates transformed density for local gradient calculations (Coulomb)
|
|
!********************************************************************************
|
|
implicit none
|
|
integer nilen,njlen,ifrst,jfrst,nbasis,nocc
|
|
integer i,j,ii,jj
|
|
double precision ddens(nilen,njlen),mo(nbasis,nocc)
|
|
double precision mo2(nbasis,nocc)
|
|
|
|
call dgemm('n','t',nilen,njlen,nocc,1.0d0,mo(ifrst+1,1),nbasis,mo2(jfrst+1,1),&
|
|
nbasis,0.0d0,ddens,nilen)
|
|
call dgemm('n','t',nilen,njlen,nocc,1.0d0,mo2(ifrst+1,1),nbasis,mo(jfrst+1,1),&
|
|
nbasis,1.0d0,ddens,nilen)
|
|
|
|
!ddens=0.5d0*ddens
|
|
do j=1,njlen
|
|
jj=jfrst+j
|
|
do i=1,nilen
|
|
ii=ifrst+i
|
|
if(ii.lt.jj) then
|
|
ddens(i,j)=0.d0
|
|
else if(ii.eq.jj) then
|
|
ddens(i,j)=0.5d0*ddens(i,j)
|
|
endif
|
|
enddo
|
|
enddo
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine ew_dens(nal,nbe,nbasis,dens2,ca,cb,ca2,cb2,rf,dcore,scrfile,scftype)
|
|
!********************************************************************************
|
|
! Calculates energy weighted density and CzC density
|
|
!********************************************************************************
|
|
implicit none
|
|
integer nal,nbe,nbasis,scrfile
|
|
double precision dens2(nbasis,nbasis),ca2(nbasis,nal),cb2(nbasis,nbe)
|
|
double precision ca(nbasis,nbasis),cb(nbasis,nbasis)
|
|
double precision rf(nbasis,nbasis),dcore(*)
|
|
character*5 scftype
|
|
|
|
integer iwork,iwork2,dblalloc
|
|
|
|
call dfillzero(rf,nbasis**2)
|
|
call dfillzero(dens2,nbasis**2)
|
|
iwork=dblalloc(nbasis**2)
|
|
iwork2=dblalloc(nbasis**2)
|
|
open(scrfile,file='LAGRANGE',form='unformatted')
|
|
call ew_dens_spin(nbasis,nal,nbasis-nal,ca,ca2,dens2,rf,dcore(iwork), &
|
|
dcore(iwork2))
|
|
if(scftype=='uhf ') then
|
|
call ew_dens_spin(nbasis,nbe,nbasis-nbe,cb,cb2,dens2,rf,dcore(iwork),&
|
|
dcore(iwork2))
|
|
endif
|
|
close(scrfile)
|
|
call filllo(dens2,nbasis)
|
|
call dbldealloc(iwork)
|
|
|
|
contains
|
|
|
|
subroutine ew_dens_spin(nbasis,nocc,nvirt,ca,ca2,dens2,rf,work,work2)
|
|
implicit none
|
|
integer nocc,nbasis,nvirt
|
|
double precision ca(nbasis,nbasis),ca2(nbasis,nocc),dens2(nbasis,nbasis)
|
|
double precision rf(nbasis,nbasis),work(nbasis*nbasis),work2(nbasis*nbasis)
|
|
|
|
read(scrfile)
|
|
read(scrfile) work(1:nvirt*nocc)
|
|
call dgemm('n','n',nbasis,nocc,nvirt,1.0d0,ca(1,1+nocc),nbasis,work,nvirt, &
|
|
0.0d0,ca2,nbasis)
|
|
call dsyr2k('u','n',nbasis,nocc,1.0d0,ca,nbasis,ca2,nbasis,1.0d0,dens2,nbasis)
|
|
read(scrfile) work
|
|
call dsymm('r','l',nbasis,nbasis,-0.5d0,work,nbasis,ca,nbasis,0.0d0,work2, &
|
|
nbasis)
|
|
call dgemm('n','t',nbasis,nbasis,nbasis,1.0d0,work2,nbasis,ca,nbasis,1.0d0,rf,&
|
|
nbasis)
|
|
|
|
read(scrfile)
|
|
end subroutine
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine dft_dens(nal,nbe,nbasis,densa,densb,scftype,scrfile)
|
|
!********************************************************************************
|
|
! Calculates densities for DFT gradient calculations
|
|
!********************************************************************************
|
|
use common_mod, only: dcore
|
|
implicit none
|
|
integer nal,nbe,nbasis,itemp,nocc,nvirt,scrfile
|
|
double precision densa(nbasis,nbasis),densb(nbasis,nbasis)
|
|
character*5 scftype
|
|
|
|
integer dblalloc
|
|
|
|
nocc=max(nal,nbe)
|
|
nvirt=max(nbasis-nal,nbasis-nbe)
|
|
itemp=dblalloc(nocc*nvirt)
|
|
|
|
open(unit=scrfile,file='LAGRANGE',form='unformatted')
|
|
call dft_dens_spin(nal,nbasis-nal,nbasis,densa,dcore(itemp))
|
|
if(scftype=='uhf ') then
|
|
read(scrfile) !xmat alpha
|
|
read(scrfile) !mo alpha
|
|
call dft_dens_spin(nbe,nbasis-nbe,nbasis,densb,dcore(itemp))
|
|
endif
|
|
close(scrfile)
|
|
|
|
call dbldealloc(itemp)
|
|
|
|
contains
|
|
|
|
subroutine dft_dens_spin(nocc,nvirt,nbasis,dens,z)
|
|
implicit none
|
|
integer nocc,nvirt,nbasis,i,a
|
|
double precision dens(nbasis,nbasis),z(nvirt,nocc)
|
|
|
|
read(scrfile) !zloc
|
|
read(scrfile) z(1:nvirt,1:nocc)
|
|
call dfillzero(dens,nbasis**2)
|
|
do i=1,nocc
|
|
do a=1,nvirt
|
|
dens(nocc+a,i)=z(a,i)
|
|
enddo
|
|
enddo
|
|
|
|
end subroutine
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine get_dipole(nbasis,nal,nbe,dip,modip,mo,scftype,dcore,imem)
|
|
!********************************************************************************
|
|
! Read dipole moment integrals and transform them into MO basis
|
|
!********************************************************************************
|
|
implicit none
|
|
integer nbasis,nal,nbe,imem,printfile,xyz,nal2,nbe2
|
|
double precision dip(nbasis,nbasis,3),modip(*)
|
|
double precision mo(nbasis,nbasis,*),dcore(*)
|
|
character*5 scftype
|
|
|
|
printfile=24
|
|
nal2=nal*nal
|
|
nbe2=nbe*nbe
|
|
! reading dipole moment integrals
|
|
open(printfile,file='PRINT',form='UNFORMATTED')
|
|
read(printfile) !kinetic energy integrals
|
|
do xyz=1,3
|
|
call read_aoints(nbasis,printfile,dip(1,1,xyz),dcore(imem),dcore(imem))
|
|
call dsymm('l','u',nbasis,nal,1.0d0,dip(1,1,xyz),nbasis,mo,nbasis,0.0d0, &
|
|
dcore(imem),nbasis)
|
|
call dgemm('t','n',nal,nal,nbasis,1.0d0,mo,nbasis,dcore(imem),nbasis,0.0d0, &
|
|
modip(1+(xyz-1)*nal2),nal)
|
|
if(scftype=='uhf ') then
|
|
call dsymm('l','u',nbasis,nbe,1.0d0,dip(1,1,xyz),nbasis,mo(1,1,2),nbasis, &
|
|
0.0d0,dcore(imem),nbasis)
|
|
call dgemm('t','n',nbe,nbe,nbasis,1.0d0,mo(1,1,2),nbasis,dcore(imem), &
|
|
nbasis,0.0d0,modip(1+3*nal2+(xyz-1)*nbe2),nbe)
|
|
endif
|
|
enddo
|
|
close(printfile)
|
|
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine get_modip(nbasis,nocc,mo,aodip,xdip_mo,ydip_mo,zdip_mo,work,&
|
|
printfile)
|
|
!********************************************************************************
|
|
!********************************************************************************
|
|
implicit none
|
|
integer nbasis,nocc,printfile
|
|
double precision mo(nbasis,nocc)
|
|
double precision aodip(nbasis**2),xdip_mo(nocc**2)
|
|
double precision ydip_mo(nocc**2)
|
|
double precision zdip_mo(nocc**2)
|
|
double precision work(*)
|
|
|
|
rewind(printfile)
|
|
read(printfile)
|
|
|
|
call read_aoints(nbasis,printfile,aodip,work,work)
|
|
call dsymm('l','u',nbasis,nocc,1.0d0,aodip,nbasis,mo,nbasis,0.0d0,work,nbasis)
|
|
call dgemm('t','n',nocc,nocc,nbasis,1.0d0,mo,nbasis,work,nbasis,0.0d0,xdip_mo,&
|
|
nocc)
|
|
call read_aoints(nbasis,printfile,aodip,work,work)
|
|
call dsymm('l','u',nbasis,nocc,1.0d0,aodip,nbasis,mo,nbasis,0.0d0,work,nbasis)
|
|
call dgemm('t','n',nocc,nocc,nbasis,1.0d0,mo,nbasis,work,nbasis,0.0d0,ydip_mo,&
|
|
nocc)
|
|
call read_aoints(nbasis,printfile,aodip,work,work)
|
|
call dsymm('l','u',nbasis,nocc,1.0d0,aodip,nbasis,mo,nbasis,0.0d0,work,nbasis)
|
|
call dgemm('t','n',nocc,nocc,nbasis,1.0d0,mo,nbasis,work,nbasis,0.0d0,zdip_mo,&
|
|
nocc)
|
|
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine dloc(nbasis,nocc,mo,zloc,der,natoms,nangmax,ncontrmax,nprimmax, &
|
|
ncartmax,nsphermax,nang,nangmin,ncontr,nprim,gexp,gcoef,coord,ctostr,gcn, &
|
|
nshrange,natrange,cartg,ialpha,dcore,imem,scrfile4)
|
|
!********************************************************************************
|
|
!********************************************************************************
|
|
implicit none
|
|
integer nbasis,nocc
|
|
integer natoms,nangmax,ncontrmax,nprimmax,ncartmax,nsphermax
|
|
integer nang(natoms),nangmin(natoms),ncontr(0:nangmax,natoms)
|
|
integer nprim(0:nangmax,natoms),gcn(2,ncontrmax,0:nangmax,natoms)
|
|
integer nshrange(2,0:nangmax,natoms),natrange(2,natoms)
|
|
integer imem,ialpha,scrfile4
|
|
double precision mo(nbasis,nocc),zloc(nocc*(nocc-1)/2),zloc_full(nocc,nocc)
|
|
double precision gexp(nprimmax,0:nangmax,natoms)
|
|
double precision gcoef(nprimmax,ncontrmax,0:nangmax,natoms),coord(3,natoms)
|
|
double precision ctostr(ncartmax**2,0:nangmax)
|
|
double precision der(3,natoms)
|
|
double precision dcore(*)
|
|
logical cartg
|
|
|
|
integer izfull,ncore,nval,imo
|
|
integer dblalloc
|
|
character*8 mode,c8
|
|
|
|
call getkey('embed',5,c8,8)
|
|
if(c8 /= 'off ') then
|
|
mode='embed '
|
|
else
|
|
call getkey('scfalg',6,c8,8)
|
|
if(c8 == 'locfit1 ') mode='locfit '
|
|
endif
|
|
|
|
izfull=dblalloc(nocc*nocc)
|
|
|
|
if(mode=='locfit ') then
|
|
open(scrfile4,file='LAGRANGE',form='unformatted')
|
|
if(ialpha==0) then
|
|
! alpha zloc
|
|
read(scrfile4) zloc(1:nocc*(nocc-1)/2)
|
|
else
|
|
! alpha multiplicators
|
|
read(scrfile4)
|
|
read(scrfile4)
|
|
read(scrfile4)
|
|
read(scrfile4)
|
|
! beta zloc
|
|
read(scrfile4) zloc(1:nocc*(nocc-1)/2)
|
|
endif
|
|
call dloc_(nbasis,nocc,mo,zloc,der,natoms,nangmax,ncontrmax,nprimmax, &
|
|
ncartmax,nsphermax,nang,nangmin,ncontr,nprim,gexp,gcoef,coord,ctostr,&
|
|
gcn,nshrange,natrange,cartg,ialpha,dcore,imem,dcore(izfull))
|
|
close(scrfile4)
|
|
elseif(mode=='embed ') then
|
|
open(scrfile4,file='NCORE')
|
|
read(scrfile4,*) ncore
|
|
close(scrfile4)
|
|
nval=nocc-ncore
|
|
|
|
imo=dblalloc(nbasis*nbasis)
|
|
call read_from_disk('MOCOEF.LOC ',dcore(imo),nbasis,.false.)
|
|
|
|
open(scrfile4,file='LAGRANGE',form='unformatted')
|
|
|
|
if(ncore*(ncore-1)/2 /= 0) then
|
|
read(scrfile4) zloc(1:ncore*(ncore-1)/2)
|
|
call dloc_(nbasis,ncore,dcore(imo),zloc,der,natoms,nangmax,ncontrmax, &
|
|
nprimmax,ncartmax,nsphermax,nang,nangmin,ncontr,nprim,gexp,gcoef, &
|
|
coord,ctostr,gcn,nshrange,natrange,cartg,ialpha,dcore,imem, &
|
|
dcore(izfull))
|
|
endif
|
|
|
|
if(nval*(nval-1)/2 /= 0) then
|
|
read(scrfile4) zloc(1:nval*(nval-1)/2)
|
|
call dloc_(nbasis,nval,dcore(imo+nbasis*ncore),zloc,der,natoms,nangmax,&
|
|
ncontrmax,nprimmax,ncartmax,nsphermax,nang,nangmin,ncontr,nprim,gexp,&
|
|
gcoef,coord,ctostr,gcn,nshrange,natrange,cartg,ialpha,dcore,imem, &
|
|
dcore(izfull))
|
|
endif
|
|
close(scrfile4)
|
|
endif
|
|
call dbldealloc(izfull)
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine dloc_(nbasis,nocc,mo,zloc,der,natoms,nangmax,ncontrmax,nprimmax, &
|
|
ncartmax,nsphermax,nang,nangmin,ncontr,nprim,gexp,gcoef,coord,ctostr,gcn, &
|
|
nshrange,natrange,cartg,ialpha,dcore,imem,zloc_full)
|
|
!********************************************************************************
|
|
! Derivative of the Boys localization condition
|
|
!********************************************************************************
|
|
implicit none
|
|
integer nbasis,nocc
|
|
integer natoms,nangmax,ncontrmax,nprimmax,ncartmax,nsphermax
|
|
integer nang(natoms),nangmin(natoms),ncontr(0:nangmax,natoms)
|
|
integer nprim(0:nangmax,natoms),gcn(2,ncontrmax,0:nangmax,natoms)
|
|
integer nshrange(2,0:nangmax,natoms),natrange(2,natoms)
|
|
integer ixdip,iydip,izdip,i,j,xyz,imem,ialpha
|
|
integer printfile,idens1,imodip,itemp,itemp2,imem_old,dxyz,iddip,iatoms,i1,i2
|
|
double precision mo(nbasis,nocc),zloc(nocc*(nocc-1)/2),zloc_full(nocc,nocc)
|
|
double precision gexp(nprimmax,0:nangmax,natoms)
|
|
double precision gcoef(nprimmax,ncontrmax,0:nangmax,natoms),coord(3,natoms)
|
|
double precision ctostr(ncartmax**2,0:nangmax)
|
|
double precision der(3,natoms)
|
|
double precision dcore(*),x,factor
|
|
logical cartg
|
|
parameter(printfile=24)
|
|
logical ll
|
|
|
|
integer dblalloc
|
|
|
|
imem_old=imem
|
|
|
|
call create_full(nocc,zloc,zloc_full)
|
|
! Reading dipole integrals
|
|
idens1=dblalloc(3*nbasis*nbasis)
|
|
imodip=dblalloc(3*nocc*nocc)
|
|
ixdip=imodip
|
|
iydip=ixdip+nocc*nocc
|
|
izdip=iydip+nocc*nocc
|
|
open(printfile,file='PRINT',form='UNFORMATTED')
|
|
call get_modip(nbasis,nocc,mo,dcore(idens1),dcore(ixdip),dcore(iydip),&
|
|
dcore(izdip),dcore(imem),printfile)
|
|
close(printfile)
|
|
|
|
! dens1=sum_{ij}z_ij*r_ij*L_{mu i}*L_{nu i}
|
|
call dfillzero(dcore(idens1),3*nbasis*nbasis)
|
|
do xyz=1,3
|
|
do i=1,nocc
|
|
x=0.0d0
|
|
do j=1,nocc
|
|
x=x-dcore(imodip+(xyz-1)*nocc*nocc+j-1+(i-1)*nocc)*zloc_full(j,i)
|
|
enddo
|
|
call dsyrk('u','n',nbasis,1,x,mo(1,i),nbasis,1.0d0,&
|
|
dcore(idens1+(xyz-1)*nbasis*nbasis),nbasis)
|
|
enddo
|
|
call filllo(dcore(idens1+(xyz-1)*nbasis**2),nbasis)
|
|
enddo
|
|
|
|
! dens2=sum_{ij} z_ij*r_ii*(L_{rho j}*L_{sigma i}+L_{sigma j}*L_{rho i})
|
|
itemp=dblalloc(nocc*nocc)
|
|
itemp2=dblalloc(nbasis*nocc)
|
|
do xyz=1,3
|
|
do j=1,nocc
|
|
do i=1,nocc
|
|
dcore(itemp+i-1+(j-1)*nocc)=dcore(imodip+(xyz-1)*nocc*nocc+i-1+(i-1)*nocc)*&
|
|
zloc_full(i,j)
|
|
enddo
|
|
enddo
|
|
call dgemm('n','t',nocc,nbasis,nocc,1.0d0,dcore(itemp),nocc,mo,nbasis, &
|
|
0.0d0,dcore(itemp2),nocc)
|
|
call dgemm('n','n',nbasis,nbasis,nocc,1.0d0,mo,nbasis,dcore(itemp2),nocc,&
|
|
1.0d0,dcore(idens1+(xyz-1)*nbasis*nbasis),nbasis)
|
|
call symmat(dcore(idens1+(xyz-1)*nbasis*nbasis),nbasis)
|
|
|
|
enddo
|
|
call dbldealloc(imodip)
|
|
|
|
call dscal(nbasis**2*3,2.0d0,dcore(idens1),1)
|
|
|
|
! contracting density with the derivative integrals
|
|
iddip=dblalloc(3*nbasis*nbasis)
|
|
do dxyz=1,3
|
|
select case(dxyz)
|
|
case(1)
|
|
call ddipx(natoms,nangmax,ncontrmax,nprimmax,ncartmax,nsphermax, &
|
|
nang,nangmin,ncontr,nprim,gexp,gcoef,coord,ctostr,nbasis,dcore(iddip), &
|
|
dcore(iddip+nbasis**2),dcore(iddip+2*nbasis**2),dcore(imem),gcn,nshrange,&
|
|
cartg,0,.false.)
|
|
case(2)
|
|
call ddipy(natoms,nangmax,ncontrmax,nprimmax,ncartmax,nsphermax, &
|
|
nang,nangmin,ncontr,nprim,gexp,gcoef,coord,ctostr,nbasis,dcore(iddip), &
|
|
dcore(iddip+nbasis**2),dcore(iddip+2*nbasis**2),dcore(imem),gcn,nshrange,&
|
|
cartg,0,.false.)
|
|
case(3)
|
|
call ddipz(natoms,nangmax,ncontrmax,nprimmax,ncartmax,nsphermax, &
|
|
nang,nangmin,ncontr,nprim,gexp,gcoef,coord,ctostr,nbasis,dcore(iddip), &
|
|
dcore(iddip+nbasis**2),dcore(iddip+2*nbasis**2),dcore(imem),gcn,nshrange,&
|
|
cartg,0,.false.)
|
|
end select
|
|
do xyz=1,3
|
|
ll=(xyz==dxyz)
|
|
do iatoms=1,natoms
|
|
i1=natrange(1,iatoms)+1
|
|
i2=natrange(2,iatoms)
|
|
do j=1,nbasis
|
|
factor=1.0d0
|
|
! if(ll.and.j<=i2.and.j>=i1) factor=2.0d0
|
|
do i=i1,i2
|
|
der(xyz,iatoms)=der(xyz,iatoms)+&
|
|
factor*dcore(iddip+(xyz-1)*nbasis**2+i-1+(j-1)*nbasis)*&
|
|
dcore(idens1+(dxyz-1)*nbasis**2+i-1+(j-1)*nbasis)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
call dbldealloc(imem_old)
|
|
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine read_from_disk(file_name,matrix,nbasis,lsym)
|
|
!********************************************************************************
|
|
! Reads Fock matrix from disk
|
|
!********************************************************************************
|
|
use common_mod, only: dcore,imem,scrfile1
|
|
implicit none
|
|
integer nbasis
|
|
double precision matrix(nbasis,nbasis)
|
|
character*16 file_name
|
|
logical lsym
|
|
|
|
call dfillzero(matrix,nbasis**2)
|
|
open(scrfile1,file=trim(file_name),form='unformatted')
|
|
if(lsym) then
|
|
call roeint(dcore(imem),dcore(imem),matrix,scrfile1,nbasis)
|
|
else
|
|
call readmo(dcore(imem),dcore(imem),matrix,scrfile1,nbasis,nbasis)
|
|
endif
|
|
close(scrfile1)
|
|
end subroutine
|