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

2353 lines
88 KiB
Fortran
Raw Blame History

************************************************************************
SUBROUTINE FOCK_BUILD(PA,PB,FOCKA,FOCKB,QMAT,INDEXIRREP,OFFSET,
$SQROFFSET,npos,intpos,step,cmat,lfin,exc,dft,cchfx,lwdfn,embed,
$scfdamp,route,nfr,nc,ncorenew,devparr,symtra,nact,cclrhfx,ccsrhfx,
$omega,rs,qscf_hess,ica,icb,pcm,excha,exchb,lscrohfldf)
************************************************************************
* CONSTRUCTION OF THE FOCK-MATRIX
************************************************************************
#if defined (LIBXC)
use xc_f03_lib_m
#endif
#include "MRCCCOMMON"
#include "SCFCOMMON"
#if defined (LIBXC)
type(xc_f03_func_t) :: xc_func
type(xc_f03_func_info_t) :: xc_info
integer*4 func_id
#endif
C ARRAYS
REAL*8 PA(NBASIS,NBASIS),cmat(*),devparr(2),cchfx,rs(*)
REAL*8 PB(NBASIS,NBASIS),symtra(nbasis,nbasis)
REAL*8 QMAT(NBASIS,NBASIS)
REAL*8 FOCKA(NBASIS,NBASIS),excha(nbasis,nbasis)
REAL*8 FOCKB(NBASIS,NBASIS),exchb(nbasis,nbasis)
integer nact
INTEGER INDEXIRREP(*),nfr,nalf,nbef
INTEGER INTPOS(3,(nbasis+1)*nbasis/2)
INTEGER TEINTF(10)
INTEGER OFFSET(*)
INTEGER SQROFFSET(*)
C SCALARS
INTEGER T,Q
INTEGER I,J,K,L
integer*2 ii2,kk2
INTEGER NPOS
INTEGER IPOS
INTEGER IMEM1
INTEGER STEP
INTEGER NINTEG
INTEGER NNINTEG
INTEGER IPOSLO
INTEGER IP
INTEGER MAXM
integer ii,intalloc,dblalloc,imoa,imob,icmo,icpr,iroute,imemold,n
integer ii4core,ix,nos,id,iimoa,iimob,iss,isi,nmobasis_ptr,locfit
integer nmoat_ptr,moat_ptr,ijpvt,natdom_ptr,naoat_ptr,aoat_ptr
integer dfnmobasis_ptr,moadd_ptr,atmo_ptr,lfin,atind_ptr
integer natmo_ptr,hailen,nc,ncorenew,idaa,icaa,lsexc,atdom_ptr
integer ifocka_tmp
integer ica,icb !memory address of MO coefficients for QSCF Hessian construcion
integer incorb,iactive_atoms
character*4 route
character*5 cscftype
character*7 scfiguess
character*8 embed,cpssp
character*16 scfdamp,c16
character*32 dft,cdft,pcm
real*8 temp,exc,chfx,dtol,excl,trpfa,trpfb,ddot,excrad,excrad_fin
real*8 chfxold,clrhfx,csrhfx,omega,cclrhfx,ccsrhfx,chfxa,clrhfxa
real*8 csrhfxa,epol
logical lbeta,lscale,lwdfn,llc,sclroute,linv,lmcl,lfdm,lpssp,lexc
logical qscf_hess,lscrohfldf
COMMON/MEMCOM/ IMEM1
C
call getkey('pssp',4,cpssp,8)
if(cpssp.eq.'off ') then
lpssp = .false.
else
lpssp=.true. ! integ.f
endif
lscale=.false.
llc=.false.
lsexc=0
sclroute=.false.
iroute=2
lfdm=trim(embed).eq.'fdm'.and.(route.eq.'em2 '.or.route.eq.'em3 ')
call getkey('scfiguess',9,scfiguess,7)
chfx=cchfx
clrhfx=cclrhfx
csrhfx=ccsrhfx
chfxa=0.d0
clrhfxa=0.d0
csrhfxa=0.d0
if(route.eq.'em1 '.or.route.eq.'em2 '.or.route.eq.'emft'.or.
$(route.eq.'sml '.and.trim(embed).ne.'off').or.route.eq.'sch ')then
chfx=0.d0
clrhfx=0.d0
csrhfx=0.d0
if(trim(dft).eq.'bhlyp') then
chfx=-0.5d0
else if(trim(dft).eq.'b3lyp') then
chfx=-0.2d0
else if(trim(dft).eq.'b3pw91') then
chfx=-0.2d0
else if(trim(dft).eq.'b3lyp3') then
chfx=-0.2d0
else if(trim(dft).eq.'b97') then
chfx=-0.1943d0
else if(trim(dft).eq.'pbe0') then
chfx=-0.25d0
else if(trim(dft).eq.'b2plyp') then
chfx=-0.53d0
else if(trim(dft).eq.'b2gpplyp') then
chfx=-0.65d0
else if(trim(dft).eq.'dsdpbep86') then
chfx=-0.70d0
else if(trim(dft).eq.'xyg3') then
chfx=-0.20d0
else if(trim(dft).eq.'scan0-2') then
chfx=-0.793701d0
else if(trim(dft).eq.'drpa75') then
chfx=-0.75d0
else if(trim(dft).eq.'scs-drpa75') then
chfx=-0.75d0
else if(trim(dft).eq.'m06-2x') then
chfx=-0.54d0
else if(trim(dft).eq.'m06-hf') then
chfx=-1.d0
else if(trim(dft).eq.'m08-hx') then
chfx=-0.5223d0
else if(trim(dft).eq.'m08-so') then
chfx=-0.5679d0
else if(trim(dft).eq.'dsdpbehb95') then
chfx=-0.66d0
else if(trim(dft).eq.'scan0') then
chfx=-0.25d0
else if(trim(dft).eq.'off') then
chfx=-1.d0
else if(trim(dft).eq.'cam-b3lyp') then
chfx=-0.19d0
clrhfx=-0.46d0
else if(trim(dft).eq.'m11') then
chfx=-1.d0
csrhfx=0.572d0
else if(trim(dft).eq.'mn12-sx') then
csrhfx=-0.25d0
else if(trim(dft).eq.'mn15') then
chfx=-0.44d0
else if(trim(dft).eq.'wb97') then
clrhfx=-1.d0
else if(trim(dft).eq.'wb97x') then
chfx=-0.157706d0
clrhfx=-0.842294d0
else if(trim(dft).eq.'wb97x-v') then
chfx=-0.167d0
clrhfx=-0.833d0
else if(trim(dft).eq.'wb97m-v') then
chfx=-0.15d0
clrhfx=-0.85d0
else if(trim(dft).eq.'hse06') then
csrhfx=-0.25d0
else if(trim(dft).eq.'lc-wpbe') then
csrhfx=-1.d0
else if(trim(dft(1:2)).eq.'rs') then
c clrhfx=-1.d0
c csrhfx=-0.5d0
write(6,*) 'Not tested!'
call mrccend(1)
else if(trim(dft).eq.'user') then
open(minpfile,file='MINP')
call getkeym('embed',5,embed,8)
read(minpfile,*)
read(minpfile,*)
read(minpfile,*) n
do i=1,n
read(minpfile,*) temp,cdft
cdft=adjustl(cdft)
call lowercase(cdft,cdft,32)
if(trim(cdft).eq.'hfx') then
chfx=-temp
else if(trim(cdft).eq.'lrhfx') then
clrhfx=-temp
else if(trim(cdft).eq.'srhfx') then
csrhfx=-temp
endif
enddo
close(minpfile)
#if defined (LIBXC)
else if(xc_f03_functional_get_number(dft).gt.0) then
func_id=xc_f03_functional_get_number(dft)
call xc_f03_func_init(xc_func,func_id,XC_UNPOLARIZED)
xc_info=xc_f03_func_get_info(xc_func)
chfx=xc_f03_hyb_exx_coef(xc_func)
call xc_f03_func_end(xc_func)
chfx=-chfx
#endif
endif
if(route.eq.'emft') then
if(chfx.eq.0.d0) then
call getvar('chfx ',chfx) !No HFx in low-level method
else
call getvar('chfx ',temp) !HFx in low-level method
if(temp.ne.0.d0) then
lsexc=1 !HFx in both the high- and the low-level method
else
lsexc=2 !HFx only in the low-level method
c chfx=0.d0
endif
endif
endif
if(route.eq.'sch ') then
call getvar('chfx ',chfxa)
call getvar('clrhfx ',clrhfxa)
call getvar('csrhfx ',csrhfxa)
endif
if(route.eq.'em2 ') then
open(scrfile1,file='CHFX')
write(scrfile1,'(ES30.16)') chfx
write(scrfile1,'(2ES30.16)') clrhfx,csrhfx
write(scrfile1,'(3ES30.16)') chfxa,clrhfxa,csrhfxa
close(scrfile1)
endif
endif
chfxold=chfx
if(lpssp) chfx=0.d0
lexc=chfx.ne.0.d0.or.clrhfx.ne.0.d0.or.csrhfx.ne.0.d0.or.
$chfxa.ne.0.d0.or.clrhfxa.ne.0.d0.or.csrhfxa.ne.0.d0.or.lsexc.gt.0
if(lexc) istore=0
C Clean up memory for exchange, do not perform memory operation before
if(dfbasis_scf.ne.'none ') then
call getvar('nbf ',nbf)
dfnbasis=nbf(2)
endif
imemold=imem
lmcl=(lexc.or.lsexc.gt.0).and.
$dfbasis_scf.ne.'none '.and.
$nbasis*max(nal,nbe)*dfnbasis.gt.maxcor-(imem-imem1)
if(lmcl.and.qscf_hess) then
write(*,'(1X,A)') 'Not enough memory for the Hessian'
call mrccend(1)
elseif(lmcl) then
if(verblevel.ge.3) write(iout,*) 'Cleaning up memory...'
open(unit=scrfile6,file='SCFSCR',form='unformatted')
write(scrfile6) dcore(c_ptr:imem-1)
close(scrfile6)
call dbldealloc(c_ptr)
endif
C
if(route.eq.'emft'.or.route.eq.'sch '.or.lfdm) then
idaa=dblalloc(nbasis**2)
icaa=dblalloc(nbasis**2)
else
idaa=imem
icaa=imem
endif
if(scftype.eq.1) then
cscftype='rhf '
else if(scftype.eq.2) then
cscftype='uhf '
else
cscftype='rohf '
endif
C Cholesky-decompose density matrix
if(scftype .eq. _MCSCF_ .or.
& (scftype .eq. _RHF_ .and. qscf_hess)) then
if(nact .eq. 0) then
nalf = 0
do i = 1, nir
nalf = nalf + orbperir(i)
enddo
nalf = nalf - nfr
nbef = nalf
else
nalf = nact
nbef = nact
endif
elseif(scftype .ge. 3 .and. qscf_hess) then
nalf = nact
nbef = nact
else
nalf=nal-nfr
nbef=nbe-nfr
endif
if(qscf_hess) then
nalf=2*nalf
nbef=2*nbef
endif
nc=0
imoa=imem
imob=imem
ix=imem
if(dfbasis_scf.ne.'none '.or.trim(dft).ne.'off'
$.or.route.eq.'den1'.or.route.eq.'den2'.or.lpssp) then
llc=(nir.eq.1.and.(step.gt.1.or.scfiguess.eq.'sad '.or.
$scfiguess.eq.'mo '.or.scfiguess.eq.'restart').and.
$.not.ldens.and.scftype.le.2.and.scfdamp.eq.'off ').or.
$route.eq.'sch '
if(lmcl.and.llc) then
call dcopy(nbasis*nalf,cmat,1,focka,1)
if(scftype.ge.2)
$ call dcopy(nbasis*nbef,cmat(sqrsize+1),1,fockb,1)
endif
if(dfbasis_scf.ne.'none ') then
ix=dblalloc(dfnbasis)
call dfillzero(dcore(ix),dfnbasis)
endif
nos=max(nalf,nbef)-min(nalf,nbef)
nocc=max(nalf,nbef)
if(route.eq.'emft'.or.route.eq.'sch '.or.lfdm) nocc=nbasis!schszemet
dtol=pepsilon/dfloat(nbasis*nocc)
if(qscf.ne.'off ') dtol=min(dtol,1.0d-8/dfloat(nbasis*nocc))
if(scftype.ge.3 .and. .not. qscf_hess) nbef=nos
if(qscf_hess) then
imoa=ica
if(scftype.ge.2) then
imob=icb
else
imob=ica
endif
else
imoa=dblalloc(nocc*nbasis)
imob=imoa
if(scftype.ge.2) imob=dblalloc(nocc*nbasis)
endif
icmo=dblalloc(nbasis**2)
ijpvt=intalloc(nbasis)
if(scftype.ge.3 .and. .not. qscf_hess) then
nbef=nos
call daxpy(nbasis**2,-1.d0,pb,1,pa,1)
endif
if(.not.qscf_hess) then
if(lmcl.and.llc) then
call denschol(nbasis,nalf,pa,dcore(icmo),dcore(imoa),
$dcore(imem),icore(ijpvt),llc,focka,scftype,i,' ')
if(scftype.ge.2)
$ call denschol(nbasis,nbef,pb,dcore(icmo),dcore(imob),
$dcore(imem),icore(ijpvt),llc,fockb,scftype,i,' ')
else
call denschol(nbasis,nalf,pa,dcore(icmo),dcore(imoa),
$dcore(imem),icore(ijpvt),llc,cmat,scftype,i,' ')
if(scftype.ge.2)
$ call denschol(nbasis,nbef,pb,dcore(icmo),dcore(imob),
$dcore(imem),icore(ijpvt),llc,cmat(sqrsize+1),scftype,i,' ')
endif
endif
if(scftype.ge.3 .and. .not. qscf_hess) then
call daxpy(nbasis**2,1.d0,pb,1,pa,1)
ii=0
do j=1,nbasis
do i=1,nbef
dcore(imoa+(j-1)*nalf+nbe+i-1)=dcore(imob+ii)
ii=ii+1
enddo
enddo
endif
if(route.eq.'sch ') then
call moatransp(nalf,nbasis,dcore(imoa),dcore(icaa),nfroz)
call motransp(nalf,nbasis,dcore(imoa),dcore(icaa),.true.)
else if(route.eq.'emft'.or.lfdm) then
if(embed.eq.'scl ') then
open(scrfile1,file='SROOT',form='unformatted')
iss=dblalloc(nbasis**2)
call roeint(dcore(imem),dcore(imem),dcore(iss),scrfile1,
$nbasis)
if(.true.) then
call motransp(nalf,nbasis,dcore(imoa),dcore(icaa),.true.)
call dscal(nbasis*nalf,1.d0/dsqrt(2.d0),dcore(icaa),1)
call spade(nbasis,nalf,nc,dcore(icaa),dcore(idaa),
$dcore(imem+nalf+1),dcore(imem),dcore(iss),natoms,minpfile,
$icore(inatrange),verblevel,ncorenew,incorb,iactive_atoms,
$.true.,'o') !HB
else
isi=dblalloc(nbasis**2)
call roeint(dcore(imem),dcore(imem),dcore(isi),scrfile1,
$nbasis)
call fragloc(nbasis,pa,dcore(imem+nbasis+nbasis**2),
$dcore(imem),dcore(isi),dcore(iss),dcore(icaa),dcore(idaa),natoms,
$minpfile,icore(inatrange),nalf,nc,2.d0,i,verblevel,
$dcore(imem+nbasis),.true.,ncorenew,dcore(imem+nbasis+2*nbasis**2),
$nbf(4),dcore(imem+nbasis+3*nbasis**2),
$dcore(imem+nbasis+4*nbasis**2),scrfile2)
endif
close(scrfile1)
call dbldealloc(isi)
call dscal(nbasis*nalf,dsqrt(2.d0),dcore(icaa),1)
c write(6,*) 'cca'
c write(6,"(13f10.6)") (dcore(icaa+i),i=0,nbasis*nc-1)
else
call emftdens(nbasis,natoms,minpfile,icore(inatrange),
$icore(ijpvt),iout,pa,dcore(idaa),dcore(icaa),nalf,dcore(imoa),
$.true.,.false.)
call denschol(nbasis,nalf,dcore(idaa),dcore(icmo),
$dcore(icaa),dcore(imem),icore(ijpvt),.false.,dcore(icaa),scftype,
$nc,route)
endif
write(iout,
$"(' Number of orbitals in embedded subsystem:',i5)") nc
write(iout,*)
if(lfdm) then
call dcopy(nbasis**2,dcore(idaa),1,pa,1)
ii=0
do j=1,nbasis
do i=1,nc
dcore(imoa+ii)=dcore(icaa+(i-1)*nbasis+j-1)
ii=ii+1
enddo
enddo
nalf=nc
nc=0
else
nc=nalf-nc
endif
endif
call dbldealloc(icmo)
if(scftype.eq.2) then
id=dblalloc(nbasis**2)
call dcopy(nbasis**2,pa,1,dcore(id),1)
call daxpy(nbasis**2,1.d0,pb,1,dcore(id),1)
endif
endif
C Local exchange?
call getkey('excrad',6,c16,16)
read(c16,*) excrad
call getkey('excrad_fin',10,c16,16)
read(c16,*) excrad_fin
if(lfin.eq.2) then
excrad=excrad_fin
else
lfin=0
endif
locfit=0
if(excrad.gt.0.d0.and.lexc) then
locfit=1
if(trim(scfalg).eq.'locfit2') locfit=2
endif
C
iimoa=imoa
iimob=imob
if(route.eq.'emft'.or.route.eq.'sch ') then
iimoa=dblalloc(nbasis**2)
endif
nmoat_ptr=imem
moat_ptr=imem
dfnmobasis_ptr=imem
moadd_ptr=imem
atmo_ptr=imem
natmo_ptr=imem
nmobasis_ptr=imem
natdom_ptr=imem
atdom_ptr=imem
naoat_ptr=imem
aoat_ptr=imem
atind_ptr=imem
if(dfbasis_scf.ne.'none '.and.(step.gt.1.or.
$scfiguess.eq.'restart'.or.scfiguess.eq.'sad '.or.
$scfiguess.eq.'mo ')) then
moadd_ptr= intalloc(nocc)
nmobasis_ptr =intalloc(nocc)
dfnmobasis_ptr=intalloc(nocc)
if(excrad.gt.0.d0) then
nmoat_ptr= intalloc(natoms)
moat_ptr= intalloc(nocc*natoms)
atmo_ptr= intalloc(nocc*natoms)
natmo_ptr= intalloc(nocc)
if(locfit.ge.2) then
natdom_ptr= intalloc(nocc)
atdom_ptr= intalloc(nocc*natoms)
naoat_ptr= intalloc(2*natoms)
aoat_ptr= intalloc(nocc*natoms)
atind_ptr= intalloc(natoms*nocc)
endif
endif
endif
C Initialize Fock matrix
focka=0.d0
if(scftype.eq.2) then
fockb=0.d0
else if(scftype.ge.3) then
qmat=0.d0
endif
1235 continue
IF(trim(scfalg).ne.'disk'.or.(trim(dfbasis_scf).ne.'none'
$.and.step.eq.1.and.scfiguess.ne.'restart'
$.and.scfiguess.ne.'sad '.and.scfiguess.ne.'mo '
$)) THEN
C INTEGRAL-DIRECT FOCK-MATRIX CONSTRUCTION
C Density-fitting algorithm
if(dfbasis_scf.ne.'none '.and.(step.gt.1.or.
$scfiguess.eq.'restart'.or.scfiguess.eq.'sad '.or.
$scfiguess.eq.'mo ')) then
lscale=.true.
if(scftype.eq.2) then
if(.not. qscf_hess) then
chfx=2.d0*chfx
clrhfx=2.d0*clrhfx
csrhfx=2.d0*csrhfx
endif
if(.not. qscf_hess)
$ write(iout,*) 'Constructing alpha Fock-matrix...'
call df_direct_fock(focka,fockb,dcore(id),nbasis,dfnbasis,
$pepsilon,nalf,dcore(iimoa),step,iout,icore(inatrange),oeintfile,
$natoms,dcore,icore,imem,icore(nmoat_ptr),icore(moat_ptr),
$icore(dfnmobasis_ptr),icore(moadd_ptr),icore(atmo_ptr),
$icore(natmo_ptr),scrfile3,iimem,scrfile4,lfin,dcore(imoa),
$dcore(ix),1,chfx,varsfile,nbset,scrfile3,maxcor,tedatfile,lwdfn,
$minpfile,irecln,sclroute,route,hailen,linv,nc,lsexc,ncorenew,
$dcore(icaa),devparr,excrad,excrad_fin,llc,cscftype,scfiguess,
$locfit,icore(nmobasis_ptr),icore(natdom_ptr),icore(atdom_ptr),
$icore(naoat_ptr),icore(aoat_ptr),icore(atind_ptr),clrhfx,csrhfx,
$omega,qscf_hess,lf12,excha,exchb,lscrohfldf,istore,intpos,loccri)
if(lexc) then!.and.nbef.gt.0) then
if(.not. qscf_hess)
$ write(iout,*) 'Constructing beta Fock-matrix...'
call df_direct_fock(fockb,focka,dcore(id),nbasis,dfnbasis,
$pepsilon,nbef,dcore(iimob),step,iout,icore(inatrange),oeintfile,
$natoms,dcore,icore,imem,icore(nmoat_ptr),icore(moat_ptr),
$icore(dfnmobasis_ptr),icore(moadd_ptr),icore(atmo_ptr),
$icore(natmo_ptr),scrfile3,iimem,scrfile4,lfin,dcore(imob),
$dcore(ix),2,chfx,varsfile,nbset,scrfile3,maxcor,tedatfile,lwdfn,
$minpfile,irecln,sclroute,route,hailen,linv,nc,lsexc,ncorenew,
$dcore(icaa),devparr,excrad,excrad_fin,llc,cscftype,scfiguess,
$locfit,icore(nmobasis_ptr),icore(natdom_ptr),icore(atdom_ptr),
$icore(naoat_ptr),icore(aoat_ptr),icore(atind_ptr),clrhfx,csrhfx,
$omega,qscf_hess,lf12,exchb,excha,lscrohfldf,istore,intpos,loccri)
endif
else if(scftype.ge.3.and.nbef.gt.0) then
if(.not.qscf_hess) write(iout,*) 'Constructing Fock-matrix...'
if(.not.qscf_hess) call df_direct_fock(focka,qmat,pa,nbasis,
$dfnbasis,pepsilon,nalf,dcore(iimoa),step,iout,icore(inatrange),
$oeintfile,natoms,dcore,icore,imem,icore(nmoat_ptr),
$icore(moat_ptr),icore(dfnmobasis_ptr),icore(moadd_ptr),
$icore(atmo_ptr),icore(natmo_ptr),scrfile3,iimem,scrfile4,lfin,
$dcore(imoa),dcore(ix),1,chfx,varsfile,nbset,scrfile3,maxcor,
$tedatfile,lwdfn,minpfile,irecln,sclroute,route,hailen,linv,nc,
$lsexc,ncorenew,dcore(icaa),devparr,excrad,excrad_fin,llc,cscftype,
$scfiguess,locfit,icore(nmobasis_ptr),icore(natdom_ptr),
$icore(atdom_ptr),icore(naoat_ptr),icore(aoat_ptr),
$icore(atind_ptr),clrhfx,csrhfx,omega,qscf_hess,lf12,excha,exchb,
$lscrohfldf,istore,intpos,loccri)
if(lexc) then
if(.not.qscf_hess)write(iout,*) 'Constructing Q matrix...'
call df_direct_fock(qmat,focka,pb,nbasis,dfnbasis,
$pepsilon,nbef,dcore(iimob),step,iout,icore(inatrange),oeintfile,
$natoms,dcore,icore,imem,icore(nmoat_ptr),icore(moat_ptr),
$icore(dfnmobasis_ptr),icore(moadd_ptr),icore(atmo_ptr),
$icore(natmo_ptr),scrfile3,iimem,scrfile4,lfin,dcore(imob),
$dcore(ix),2,-chfx,varsfile,nbset,scrfile3,maxcor,tedatfile,lwdfn,
$minpfile,irecln,sclroute,route,hailen,linv,nc,lsexc,ncorenew,
$dcore(icaa),devparr,excrad,excrad_fin,llc,cscftype,scfiguess,
$locfit,icore(nmobasis_ptr),icore(natdom_ptr),icore(atdom_ptr),
$icore(naoat_ptr),icore(aoat_ptr),icore(atind_ptr),-clrhfx,-csrhfx,
$omega,qscf_hess,lf12,excha,exchb,lscrohfldf,istore,intpos,loccri)
else
call daxpy(nbasis**2,1.d0,qmat,1,focka,1)
qmat=0.d0
endif
else
if(.not.qscf_hess) write(iout,*) 'Constructing Fock-matrix...'
call df_direct_fock(focka,fockb,pa,nbasis,dfnbasis,
$pepsilon,nalf,dcore(iimoa),step,iout,icore(inatrange),oeintfile,
$natoms,dcore,icore,imem,icore(nmoat_ptr),icore(moat_ptr),
$icore(dfnmobasis_ptr),icore(moadd_ptr),icore(atmo_ptr),
$icore(natmo_ptr),scrfile3,iimem,scrfile4,lfin,dcore(imoa),
$dcore(ix),0,chfx,varsfile,nbset,scrfile3,maxcor,tedatfile,lwdfn,
$minpfile,irecln,sclroute,route,hailen,linv,nc,lsexc,ncorenew,
$dcore(icaa),devparr,excrad,excrad_fin,llc,cscftype,scfiguess,
$locfit,icore(nmobasis_ptr),icore(natdom_ptr),icore(atdom_ptr),
$icore(naoat_ptr),icore(aoat_ptr),icore(atind_ptr),clrhfx,csrhfx,
$omega,qscf_hess,lf12,excha,exchb,lscrohfldf,istore,intpos,loccri)
endif
if(qscf_hess) return
else
C Conventional direct SCF, no density-fitting
call direct_fock_build(pa,pb,focka,fockb,qmat,step,cscftype,
$iroute,0,1,dcore,dcore,dcore,.false.,dcore,dcore,dcore,dcore,ii,
$ii,ii,ii,ii,dcore,.false.,dcore,0,chfx,iout,varsfile,
$icore,dcore,nbset,oeintfile,nocc,scrfile3,scrfile4,maxcor,
$imem,tedatfile,dfnbasis,nbasis,0,dcore,minpfile,.false.,1,dcore,
$irecln,1,.false.,0,0,0,devparr(1)+devparr(2),pa,1,dcore,0,0,
$i,i,i,i,i,i,i,i,clrhfx,csrhfx,omega,.false.,dcore,dcore,dcore,i,
$qscf_hess,.false.,dcore,.false.,.false.,istore,intpos,.false.,
$excha,exchb,lf12,loccri,i)
endif
ELSE
C CONVENTIONAL FOCK-MATRIX CONSTRUCTION
call intopenrsq(teintf)
C
if(dfbasis_scf.ne.'none ') then
lscale=.true.
nocc=max(nalf,nbef)
icpr=dblalloc(nbasis)
ii=3*dfnbasis
ii=(ii+mod(ii,2))/2
ii4core=dblalloc(ii)
maxm=maxcor-(imem-imem1)
if(scftype.eq.2) then
write(iout,*) 'Constructing alpha Fock-matrix...'
chfx=2.d0*chfx
call df_disk_fock(focka,fockb,dcore(id),dcore(id),nbasis,
$dfnbasis,npos,ipos,dcore(imem),dcore(ix),dcore(ix),dcore(icpr),
$dcore(ii4core),intpos,teintf,nalf,nbef,dcore(imoa),dcore(imob),
$step,maxm,iout,icore(inatrange),dcore(imem),oeintfile,natoms,dft,
$chfx,scftype,dtol,.false.,lbeta,'f')
if(lbeta.and.dabs(chfx).gt.dtol.and.nbef.gt.0) then
call timer
write(iout,*) 'Constructing beta Fock-matrix...'
call df_disk_fock(fockb,focka,pb,pb,nbasis,dfnbasis,npos,
$ipos,dcore(imem),dcore(ix),dcore(ix),dcore(icpr),dcore(ii4core),
$intpos,teintf,nbef,nalf,dcore(imob),dcore(imoa),step,maxm,iout,
$icore(inatrange),dcore(imem),oeintfile,natoms,dft,chfx,scftype,
$dtol,.true.,lbeta,'f')
endif
else if(scftype.ge.3) then
write(iout,*) 'Constructing Fock-matrix...'
call df_disk_fock(focka,qmat,pa,pa,nbasis,dfnbasis,npos,ipos,
$dcore(imem),dcore(ix),dcore(ix),dcore(icpr),dcore(ii4core),intpos,
$teintf,nalf,nbef,dcore(imoa),dcore(imob),step,maxm,iout,
$icore(inatrange),dcore(imem),oeintfile,natoms,dft,chfx,scftype,
$dtol,.false.,lbeta,'f')
if(lbeta.and.dabs(chfx).gt.dtol.and.nos.gt.0) then
call timer
write(iout,*) 'Constructing Q matrix...'
call df_disk_fock(qmat,focka,pb,pb,nbasis,dfnbasis,npos,
$ipos,dcore(imem),dcore(ix),dcore(ix),dcore(icpr),dcore(ii4core),
$intpos,teintf,nbef,nalf,dcore(imob),dcore(imoa),step,maxm,iout,
$icore(inatrange),dcore(imem),oeintfile,natoms,dft,-chfx,scftype,
$dtol,.true.,lbeta,'f')
endif
else
write(iout,*) 'Constructing Fock-matrix...'
call df_disk_fock(focka,fockb,pa,pa,nbasis,dfnbasis,npos,ipos,
$dcore(imem),dcore(ix),dcore(ix),dcore(icpr),dcore(ii4core),intpos,
$teintf,nalf,nbef,dcore(imoa),dcore(imob),step,maxm,iout,
$icore(inatrange),dcore(imem),oeintfile,natoms,dft,chfx,scftype,
$dtol,.false.,lbeta,'f')
endif
call timer
write(iout,*)
call dbldealloc(icpr)
else
C
IPOS=0
MAXM=IFLTLN*MIN(MAXCOR-(IMEM-IMEM1),20*nbasis*(nbasis+1)/2)
c MAXM=IFLTLN*MIN(MAXCOR-(IMEM-IMEM1),20*INTPOS(3,NPOS))
DO
NNINTEG=0
IPOSLO=IPOS+1
DO WHILE(IPOS.LT.NPOS.AND.12*NNINTEG.LT.MAXM)
IPOS=IPOS+1
NNINTEG=NNINTEG+INTPOS(3,IPOS)
ENDDO
IF(12*NNINTEG.GT.MAXM) THEN
NNINTEG=NNINTEG-INTPOS(3,IPOS)
IPOS=IPOS-1
ENDIF
CALL INTREADSQ(dcore(imem),NNINTEG,TEINTF)
NNINTEG=0
DO IP=IPOSLO,IPOS
ii2 =INTPOS(1,IP)
kk2 =INTPOS(2,IP)
NINTEG=INTPOS(3,IP)
C BUILDING FOCK PART FROM READ BATCH
SELECT CASE (scftype)
CASE (_RHF_, _MCSCF_)
CALL RHFFOCK(
& FOCKA,
& PA,
& NBASIS,
& dcore(imem),
& ii2,
& kk2,
& NINTEG,
& NNINTEG,chfx)
if(lf12) CALL RHFEXCH(
& excha,
& PA,
& NBASIS,
& dcore(imem),
& ii2,
& kk2,
& NINTEG,
& NNINTEG,chfx)
CASE (_UHF_)
CALL UHFFOCK(
& FOCKA,
& FOCKB,
& PA,
& PB,
& NBASIS,
& dcore(imem),
& ii2,
& kk2,
& NINTEG,
& NNINTEG,chfx)
if(lf12) CALL UHFEXCH(
& excha,
& exchb,
& PA,
& PB,
& NBASIS,
& dcore(imem),
& ii2,
& kk2,
& NINTEG,
& NNINTEG,chfx)
CASE (_ROHFSTD_,_ROHFSCN_)
if(qscf_hess) then
CALL rohf_qmat_hessian(
& FOCKA,
& QMAT,
& PA,
& PB,
& NBASIS,
& dcore(imem),
& ii2,
& kk2,
& NINTEG,
& NNINTEG,chfx)
else
CALL ROHFFOCK(
& FOCKA,
& QMAT,
& PA,
& PB,
& NBASIS,
& dcore(imem),
& ii2,
& kk2,
& NINTEG,
& NNINTEG,chfx)
endif
END SELECT
NNINTEG=NNINTEG+6*NINTEG
ENDDO
IF(IPOS.EQ.NPOS) EXIT
ENDDO
C CLOSE(TEINTFILE)
endif
CALL INTCLOSE(TEINTF)
ENDIF
C Additional exchange in the case of embedding
if(lsexc.eq.1) then
lsexc=0
call getvar('chfx ',temp)
chfx=temp-chfx
sclroute=.true.
if(dabs(chfx).gt.1d-18) goto 1235
endif
if((route.ne.'emft'.and.route.ne.'sch ').or.lfdm)
$call dbldealloc(nmoat_ptr)
C Scale diagonal Fock matrix elements in the case of DF
if(lscale) then
do i=1,nbasis
focka(i,i)=0.5d0*focka(i,i)
enddo
if(lf12) then
do i=1,nbasis
excha(i,i)=0.5d0*excha(i,i)
enddo
endif
if(scftype.eq.2) then
do i=1,nbasis
fockb(i,i)=0.5d0*fockb(i,i)
enddo
if(lf12) then
do i=1,nbasis
exchb(i,i)=0.5d0*exchb(i,i)
enddo
endif
else if(scftype.ge.3) then
do i=1,nbasis
qmat(i,i)=0.5d0*qmat(i,i)
enddo
endif
endif
C SYMMETRISING FOCK AFTER BUILD
SELECT CASE (scftype)
CASE (_RHF_,_MCSCF_)
call mxsym(focka,nbasis)
if(lf12) call mxsym(excha,nbasis)
CASE (_UHF_)
call mxsym(focka,nbasis)
call mxsym(fockb,nbasis)
if(lf12) then
call mxsym(excha,nbasis)
call mxsym(exchb,nbasis)
endif
CASE (_ROHFSTD_,_ROHFSCN_)
call mxsym(focka,nbasis)
c%%% meg kell keresni a programban, hogy az a kettes hol i
c veszik el valami mas helyen......
call mxsym(qmat,nbasis)
call dscal(nbasis**2,2.d0,qmat,1)
END SELECT
if(lf12.and.trim(dfbasis_scf).ne.'none') then
call daxpy(nbasis**2,1.d0,excha,1,focka,1)
if(scftype.ne._RHF_) call daxpy(nbasis**2,1.d0,exchb,1,fockb,1)
endif
C SCH exchange for subsystem A
if(route.eq.'sch ') then
if(sclroute) then
call daxpy(sqrsize,1.d0,fockb,1,focka,1)
else
nc=nfroz
call dcopy(nbasis**2,focka,1,fockb,1)
call daxpy(sqrsize,-1.d0,pb,1,pa,1)
chfx=chfxa-chfx
clrhfx=clrhfxa-clrhfx
csrhfx=csrhfxa-csrhfx
if(dabs(chfx)+dabs(clrhfx)+dabs(csrhfx).gt.1d-14) then
focka=0.d0
sclroute=.true.
goto 1235
endif
endif
endif
C PS exchange
if(lpssp) then
chfx=chfxold
call cosx(nbasis,focka,fockb,scrfile5,dcore,iout,scftype,
$imem,icore,verblevel,dcore,pa,pb,1,1,chfx,.true.)
if(scftype.eq.2) then
call cosx(nbasis,fockb,focka,scrfile5,dcore,iout,scftype,
$imem,icore,verblevel,dcore,pb,pa,1,1,chfx,.true.)
endif
endif
C DFT contribution
exc=0.d0
if(trim(dft).ne.'off'.or.route.eq.'emft'.or.route.eq.'den2'.or.
$route.eq.'sch '.or.trim(pcm).ne.'off') then
trpfa=0.d0
trpfb=0.d0
if(trim(dft).ne.'off'.or.route.eq.'emft'.or.route.eq.'sch '.or.
$trim(pcm).ne.'off') then
C Calculate Tr(PF)
trpfa=0.5d0*ddot(nbasis**2,pa,1,focka,1)
if(scftype.eq.2.or.route.eq.'sch ') then
trpfb=0.5d0*ddot(nbasis**2,pb,1,fockb,1)
if(route.eq.'sch ') then
call dcopy(nbasis**2,focka,1,rs,1)
call dcopy(nbasis**2,fockb,1,rs(sqrsize+1),1)
focka=0.d0
fockb=0.d0
endif
else
trpfb=0.d0
endif
endif
if(trim(dft).ne.'off'.or.route.eq.'emft'.or.route.eq.'den2'.or.
$route.eq.'sch ') then
c write(6,"(24f6.3)") focka
c write(6,*)
c write(6,"(24f8.4)") pa
c write(6,*)
c write(6,"(9f8.4)") (dcore(imoa+i-1),i=1,nalf*nbasis)
if(embed.eq.'coulomb ') then
call mx_symm_extr(dcore(imem+nbasis**2),cmat,offset)
call dgemm('n','n',nbasis,nbasis,nbasis,1.d0,symtra,nbasis,
$dcore(imem+nbasis**2),nbasis,0.d0,dcore(imem),nbasis)
call denschol(nbasis,orbperir(1),dcore,dcore,dcore(imoa),
$dcore,icore,.true.,dcore(imem),scftype,i,' ')
call dft_core(nbasis,orbperir(1),nbef,focka,fockb,
$dcore(imoa),dcore(imob),scrfile5,dcore,iout,exc,dft,minpfile,
$scftype,ifltln,maxcor,imem,imem1,icore,verblevel,0,dcore,route,pa,
$pb,1,1,chfx,istore)
call mx_symm_extr(dcore(imem+nbasis**2),cmat,offset)
call dgemm('n','n',nbasis,nbasis,nbasis,1.d0,symtra,nbasis,
$dcore(imem+nbasis**2),nbasis,0.d0,dcore(imem),nbasis)
call denschol(nbasis,orbperir(2),dcore,dcore,dcore(imoa),
$dcore,icore,.true.,dcore(imem+nfunc(1)*nbasis),scftype,i,' ')
call dft_core(nbasis,orbperir(2),nbef,focka,fockb,
$dcore(imoa),dcore(imob),scrfile5,dcore,iout,exc,dft,minpfile,
$scftype,ifltln,maxcor,imem,imem1,icore,verblevel,0,dcore,'coul',
$pa,pb,1,1,chfx,istore)
c write(6,*)
c write(6,"(9f8.4)") (dcore(imoa+i-1),i=1,nalf*nbasis)
C Calculate exchange-correlation energy and matrix
c write(6,*) 'dft1',nalf,nbef
else
if(scftype.ge.3) then
ii=0
do j=1,nbasis
do i=1,nbe
dcore(imoa+(j-1)*nal+i-1)=
$ dcore(imoa+(j-1)*nal+i-1)/dsqrt(2.d0)
dcore(imob+ii)=dcore(imoa+(j-1)*nal+i-1)
ii=ii+1
enddo
enddo
rs(1:2*nbasis**2)=0.d0
call dft_core(nbasis,nal,nbe,rs,rs(nbasis**2+1),
$dcore(imoa),dcore(imob),scrfile5,dcore,iout,exc,dft,minpfile,
$scftype,ifltln,maxcor,imem,imem1,icore,verblevel,0,dcore,route,pa,
$pb,1,1,chfx,istore)
c write(6,*) 'focka'
c write(6,"(7f9.5)") focka
c write(6,*) 'rsa'
c write(6,"(7f9.5)") rs(1:nbasis**2)
c write(6,*) 'rsb'
c write(6,"(7f9.5)") rs(nbasis**2+1:2*nbasis**2)
call daxpy(nbasis**2,0.5d0,rs ,1,focka,1)
call daxpy(nbasis**2,0.5d0,rs(nbasis**2+1),1,focka,1)
else
if(route.eq.'em2 ') then
ifocka_tmp=dblalloc(nbasis**2)
call dcopy(nbasis**2,focka,1,dcore(ifocka_tmp),1)
call dfillzero(focka,nbasis**2)
endif
call dft_core(nbasis,nalf,nbef,focka,fockb,dcore(imoa),
$dcore(imob),scrfile5,dcore,iout,exc,dft,minpfile,scftype,ifltln,
$maxcor,imem,imem1,icore,verblevel,0,dcore,route,pa,pb,1,1,chfx,
$istore)
if(route.eq.'em2 ') then
open(scrfile1,file='F2_XC_A',form='unformatted')
call woeint(dcore(imem),dcore(imem),focka,scrfile1,
$ 1d-10,nbasis)
close(scrfile1)
call daxpy(nbasis**2,1.0d0,dcore(ifocka_tmp),1,focka,1)
call dbldealloc(ifocka_tmp)
endif
endif
endif
if((route.eq.'emft'.or.route.eq.'sch ').and.nc.lt.nalf) then
if(route.eq.'sch ') call dcopy(nbasis**2,focka,1,fockb,1)
ii=0
do j=1,nbasis
do i=1,nalf-nc
dcore(imoa+ii)=dcore(icaa+(i-1)*nbasis+j-1)
ii=ii+1
enddo
enddo
call dft_core(nbasis,nalf-nc,nbef-nc,focka,fockb,
$dcore(imoa),dcore(imob),scrfile5,dcore,iout,exc,dft,minpfile,
$scftype,ifltln,maxcor,imem,imem1,icore,verblevel,0,dcore,'scl1',
$pa,pb,1,1,chfx,istore)
endif
endif
C Add Tr(PF) to energy
#if defined (MPI)
dcore(imem )=trpfa
dcore(imem+1)=trpfb
call mpi_allreduce(dcore(imem),dcore(imem+2),2,
$MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,MPIERR)
trpfa=dcore(imem+2)
trpfb=dcore(imem+3)
#endif
if(verblevel.ge.3) write(iout,
$"(' Coulomb energy + HF exchange [au]:',f20.12)") trpfa+trpfb
exc=exc+trpfa+trpfb
endif
if(route.eq.'sch ') then
call daxpy(sqrsize,1.d0,pb,1,pa,1)
call daxpy(sqrsize,1.d0,rs,1,focka,1)
call daxpy(sqrsize,1.d0,rs(sqrsize+1),1,fockb,1)
endif
#if defined (MPI)
call symreduce(focka,dcore(imem),nbasis)
if(scftype.eq.2) call symreduce(fockb,dcore(imem),nbasis)
if(scftype.ge.3) then
call symreduce(qmat,dcore(imem),nbasis)
if(trim(dft).ne.'off') then
call symreduce(rs ,dcore(imem),nbasis)
call symreduce(rs(nbasis**2+1),dcore(imem),nbasis)
endif
endif
#endif
C Calculate solvent contribution
#if defined (PCM)
if(trim(pcm).ne.'off') then
call pcm_core(pcm,epol,verblevel,iout,dcore,icore,imem,nbasis,
$focka,fockb,pa,pb,scftype,0,dcore)
exc=exc+epol
endif
#endif
C Release memory
call dbldealloc(imemold)
if(lmcl) then
if(verblevel.ge.3) write(iout,*) 'Restoring memory...'
open(unit=scrfile6,file='SCFSCR',form='unformatted')
read(scrfile6) dcore(c_ptr:imem-1)
close(scrfile6,status='delete')
endif
c write(6,*) 'focka scf'
c write(6,"(850f12.8)") focka
C
RETURN
END
************************************************************************
subroutine df_disk_fock(focka,fockb,p,p2,nbasis,dfnbasis,npos,
$ipos,hai,x,x2,cpr,i4core,intpos,teintf,nal,nbe,moa,mob,step,
$maxmem,iout,natrange,work,oeintfile,natoms,dft,chfx,scftype,dtol,
$lqmat,lbeta,job)
************************************************************************
* DF-HF Fock-matrix construction, integrals on disk
************************************************************************
implicit none
integer nbasis,dfnbasis,intpos(3,*),npos,ipos,iout,natrange,ihai2
integer i,j,k,l,n,kk,teintf(10),nn,ii,jpvt(nbasis),nal,nbe,step
integer maxmem,nblock,iblock,nbl,nbll,oeintfile,natoms,scftype
real*8 focka(nbasis,nbasis),fockb(nbasis,nbasis),p(nbasis,nbasis)
real*8 hai(*),cpr(nbasis),moa(nal,nbasis)
real*8 ddot,pp,pr,work(*),chfx,temp,ss,dtol,x(dfnbasis)
real*8 mob(nbe,nbasis),p2(nbasis,nbasis),x2(dfnbasis),pp2
integer*4 i4core(*),ssi(2)
character*16 dft
character*1 job
logical lqmat,lbeta, lq
equivalence(ss,ssi)
lbeta=.true.
C Prescreening values
do i=1,nbasis
ss=0.d0
do ii=1,nal
ss=max(ss,dabs(moa(ii,i)))
enddo
cpr(i)=ss
enddo
C Memory
if(dabs(chfx).gt.dtol) then
if(dfnbasis*nbasis.gt.maxmem) then
write(iout,*)
$'Insufficient memory for Fock-matrix construction!'
call mrccend(1)
endif
i=mod(maxmem,dfnbasis*nbasis)
nbl=min(nal,(maxmem-i)/(dfnbasis*nbasis))
nbll=mod(nal,nbl)
nblock=(nal-nbll)/nbl
if(nbll.ne.0) then
nblock=nblock+1
else
nbll=nbl
endif
if(job .ne. 'm') then
write(iout,"(' Number of integral batches:',i5)") nblock
write(iout,"(' Occupied indices per batch:',i5)") nbl
endif
else
nblock=1
nbl=nal
nbll=nal
endif
C UHF beta Fock matrix or ROHF Q matrix
if(lqmat) then
if(job .eq. 'm') then
i=(nal/2)/nbl+1
do iblock=1,i-1
call dfmid(focka,nbasis,dfnbasis,npos,ipos,hai,hai,cpr,
$ i4core,intpos,teintf,nal,moa((iblock-1)*nbl+1,1),
$ dtol,nbl,chfx,job,nbl,1,0)
enddo
j = nal/2-(i-1)*nbl
if(j. ne. 0) then
ihai2 = dfnbasis*nbasis*j+1
call dfmid(focka,nbasis,dfnbasis,npos,ipos,hai,hai(ihai2),
$ cpr,i4core,intpos,teintf,nal,moa((i-1)*nbl+1,1),
$ dtol,nbl,chfx,job,j,nbl-j,nbl-j)
else
c we do not process the i-th batch in this step, therefore the next loop
c should start at i not i+1
i = i - 1
endif
do iblock=i+1,nblock-1
call dfmid(focka,nbasis,dfnbasis,npos,ipos,hai,hai,cpr,
$ i4core,intpos,teintf,nal,moa((iblock-1)*nbl+1,1),dtol,
$ nbl,-chfx,job,nbl,1,0)
enddo
if(nblock .ge. 2) then
call dfmid(focka,nbasis,dfnbasis,npos,ipos,hai,hai,cpr,
$ i4core,intpos,teintf,nal,moa((nblock-1)*nbl+1,1),dtol,
$ nbll,-chfx,job,nbll,1,0)
endif
elseif(job .eq. 'f') then
do iblock=1,nblock-1
call dfmid(focka,nbasis,dfnbasis,npos,ipos,hai,hai,cpr,
$ i4core,intpos,teintf,nal,moa((iblock-1)*nbl+1,1),dtol,
$ nbl,chfx,job,nbl,1,0)
enddo
call dfmid(focka,nbasis,dfnbasis,npos,ipos,hai,hai,cpr,i4core,
$ intpos,teintf,nal,moa((nblock-1)*nbl+1,1),dtol,nbll,chfx,
$ job,nbll,1,0)
endif
else
C Fock-matrices
C First step of the Coulomb + exchange part
if(job .eq. 'm' .and. nbl .gt. nal/2) then
ihai2 = dfnbasis*nbasis*nal/2+1
call dffirst(focka,p,p2,nbasis,dfnbasis,npos,ipos,hai,
$hai(ihai2),x,x2,cpr,i4core,intpos,teintf,nal,moa,dtol,nbl,chfx,
$scftype,job,nal/2,nbl-nal/2,nbl-nal/2)
else
call dffirst(focka,p,p2,nbasis,dfnbasis,npos,ipos,hai,hai,x,
$x2,cpr,i4core,intpos,teintf,nal,moa,dtol,nbl,chfx,scftype,job,
$nbl,1,0)
endif
C Further steps of the exchange part
if(job .eq. 'm') then
i=(nal/2)/nbl+1
do iblock=2,i-1
call dfmid(focka,nbasis,dfnbasis,npos,ipos,hai,hai,cpr,
$ i4core,intpos,teintf,nal,moa((iblock-1)*nbl+1,1),
$ dtol,nbl,chfx,job,nbl,1,0)
enddo
if(i .gt. 1) then
j = nal/2-(i-1)*nbl
if(j .ne. 0) then
ihai2 = dfnbasis*nbasis*j+1
call dfmid(focka,nbasis,dfnbasis,npos,ipos,hai,hai(ihai2),
$ cpr,i4core,intpos,teintf,nal,moa((i-1)*nbl+1,1),
$ dtol,nbl,chfx,job,j,nbl-j,nbl-j)
else
c we do not process the i-th batch in this step, therefore the next loop
c should start at i not i+1
i = i - 1
endif
endif
do iblock=i+1,nblock-1
call dfmid(focka,nbasis,dfnbasis,npos,ipos,hai,hai,cpr,
$ i4core,intpos,teintf,nal,moa((iblock-1)*nbl+1,1),dtol,
$ nbl,-chfx,job,nbl,1,0)
enddo
elseif(job .eq. 'f') then
do iblock=2,nblock-1
call dfmid(focka,nbasis,dfnbasis,npos,ipos,hai,hai,cpr,
$ i4core,intpos,teintf,nal,moa((iblock-1)*nbl+1,1),dtol,
$ nbl,chfx,job,nbl,1,0)
enddo
endif
call intclose(teintf)
call intopenrsq(teintf)
if(nblock.gt.1) then
C Second step of the Coulomb part and last step of the exchange part
if(job .eq. 'm') then
lq = scftype.eq.2 .or. scftype .eq. 0 .or. scftype .ge. 3
call dflast(focka,fockb,p,p2,nbasis,dfnbasis,npos,ipos,hai,
$ hai,x,x2,cpr,i4core,intpos,teintf,nal,
$ moa((nblock-1)*nbl+1,1),dtol,nbll,-chfx,scftype,
$ .true.,lq,job,nbll,1,0)
elseif(job .eq. 'f') then
call dflast(focka,fockb,p,p2,nbasis,dfnbasis,npos,ipos,hai,
$ hai,x,x2,cpr,i4core,intpos,teintf,nal,
$ moa((nblock-1)*nbl+1,1),dtol,nbll,chfx,scftype,
$ .true.,scftype.eq.2,job,nbll,1,0)
endif
else if(nblock.eq.1.and.
& (scftype.ge.2.or.(scftype.eq.0.and.job.eq.'m'))) then
C Second step of the Coulomb part and beta exchange part if nblock=1
do i=1,nbasis
ss=0.d0
do ii=1,nbe
ss=max(ss,dabs(mob(ii,i)))
enddo
cpr(i)=ss
enddo
if(job .eq. 'm') then
ihai2 = dfnbasis*nbasis*nbe/2+1
lq = scftype .eq. 2 .or. scftype .eq. 0 .or. scftype .ge. 3
call dflast(fockb,focka,p2,p,nbasis,dfnbasis,npos,ipos,hai,
$ hai(ihai2),x2,x,cpr,i4core,intpos,teintf,nbe,mob(1,1),
$ dtol,nbe,chfx,scftype,lq,.true.,job,nbe/2,nbe/2,nbe/2)
elseif(job.eq.'f') then
call dflast(fockb,focka,p2,p,nbasis,dfnbasis,npos,ipos,hai,
$ hai,x2,x,cpr,i4core,intpos,teintf,nbe,mob(1,1),dtol,
$ nbe,chfx,scftype,scftype.eq.2,.true.,job,nbe,1,0)
endif
lbeta=.false.
else
C Second step of the Coulomb part if entire hai is kept in memory
do ipos=1,npos
i=intpos(1,ipos)
j=intpos(2,ipos)
n=intpos(3,ipos)
call intreadsq(i4core,n,teintf)
pp=0.d0
pp2 = 0.0d0
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
pp=pp+ss*x(k)
if(job .eq. 'm' .and. (scftype.eq.0.or.scftype.ge.3)) then
pp2 = pp2 + ss * x2(k)
endif
enddo
focka(i,j)=focka(i,j)+pp
if(scftype.eq.2) fockb(i,j)=fockb(i,j)+pp
if((scftype.eq.0.or.scftype.ge.3).and.job.eq.'m')
& fockb(i,j)=fockb(i,j)+pp2
enddo
endif
endif
C
if(scftype.ge.2 .or. scftype.eq.0) then
call intclose(teintf)
call intopenrsq(teintf)
endif
C
return
end
C
************************************************************************
subroutine dffirst(fock,p,p2,nbasis,dfnbasis,npos,ipos,hai,hai2,x,
$x2,cpr,i4core,intpos,teintf,nocc,mo,dtol,nbl,chfx,scftype,job,
$ldhai,ldhai2,n_neg)
************************************************************************
* DF-HF Fock-matrix construction, step 1
************************************************************************
implicit none
integer nbasis,dfnbasis,intpos(3,*),npos,ipos,nbl,n_neg,ldhai
integer i,j,k,l,n,kk,teintf(10),nn,ii,nocc,scftype,ldhai2
real*8 fock(nbasis,nbasis),p(nbasis,nbasis),ss,dtol,chfx
real*8 hai(ldhai,dfnbasis,nbasis),cpr(nbasis),mo(nocc,nbasis)
real*8 pp,pr,x(dfnbasis), hai2(ldhai2,dfnbasis,nbasis)
real*8 p2(nbasis,nbasis), x2(dfnbasis), pp2
integer*4 i4core(*),ssi(2)
character*1 job
equivalence(ss,ssi)
C Coulomb + exchange part
pp2 = 0.0d0
call dfillzero(x,dfnbasis)
if(job .eq. 'm' .and. (scftype .eq. 0 .or. scftype .ge. 3))
& call dfillzero(x2,dfnbasis)
if(dabs(chfx).gt.dtol) then
C We have exchange
if(job.eq.'f' .or.
$ (job.eq.'m' .and. (n_neg.eq.0.or.n_neg.eq.nbl))) then
call dfillzero(hai,nbl*nbasis*dfnbasis)
do ipos=1,npos
i=intpos(1,ipos)
j=intpos(2,ipos)
n=intpos(3,ipos)
call intreadsq(i4core,n,teintf)
pp=p(i,j)
if(job .eq.'m'.and.(scftype.eq.0.or.scftype.ge.3))
& pp2 = p2(i, j)
if(max(dabs(pp),dabs(pp2),cpr(i),cpr(j)).gt.dtol) then
if(i.ne.j) then
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
x(k)=x(k)+ss*pp
if(job .eq.'m'.and.(scftype.eq.0.or.scftype.ge.3))then
x2(k) = x2(k) + ss*pp2
endif
pr=dabs(ss)
if(pr*cpr(i).gt.dtol) then
do ii=1,nbl
hai(ii,k,j)=hai(ii,k,j)+ss*mo(ii,i)
enddo
endif
if(pr*cpr(j).gt.dtol) then
do ii=1,nbl
hai(ii,k,i)=hai(ii,k,i)+ss*mo(ii,j)
enddo
endif
enddo
else
pp=0.5d0*pp
pp2 = 0.5d0*pp2
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
x(k)=x(k)+ss*pp
if(job .eq.'m'.and.(scftype.eq.0.or.scftype.ge.3))then
x2(k) = x2(k) + ss*pp2
endif
if(dabs(ss)*cpr(i).gt.dtol) then
do ii=1,nbl
hai(ii,k,i)=hai(ii,k,i)+ss*mo(ii,i)
enddo
endif
enddo
endif
endif
enddo
C Second step of the exchange part
if(n_neg .eq. nbl) then
call dsyrk('u','t',nbasis,nbl*dfnbasis,-chfx,hai,
$ nbl*dfnbasis,1.d0,fock,nbasis)
else
call dsyrk('u','t',nbasis,nbl*dfnbasis,chfx,hai,
$ nbl*dfnbasis,1.d0,fock,nbasis)
endif
elseif(job.eq.'m' .and. n_neg.ne.0 .and. n_neg.ne.nbl) then
call dfillzero(hai,ldhai*nbasis*dfnbasis)
call dfillzero(hai2,ldhai2*nbasis*dfnbasis)
do ipos=1,npos
i=intpos(1,ipos)
j=intpos(2,ipos)
n=intpos(3,ipos)
call intreadsq(i4core,n,teintf)
pp=p(i,j)
if(scftype .eq. 0 .or. scftype .ge. 3) pp2 = p2(i, j)
if(max(dabs(pp),dabs(pp2),cpr(i),cpr(j)).gt.dtol) then
if(i.ne.j) then
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
x(k)=x(k)+ss*pp
if(scftype .eq. 0 .or. scftype .ge. 3)
& x2(k) = x2(k) + ss*pp2
pr=dabs(ss)
if(pr*cpr(i).gt.dtol) then
do ii=1,ldhai
hai(ii,k,j)=hai(ii,k,j)+ss*mo(ii,i)
enddo
endif
if(pr*cpr(j).gt.dtol) then
do ii=1,ldhai
hai(ii,k,i)=hai(ii,k,i)+ss*mo(ii,j)
enddo
endif
if(pr*cpr(i).gt.dtol) then
do ii=ldhai+1, nbl
hai2(ii-ldhai,k,j)=hai2(ii-ldhai,k,j)+ss*mo(ii,i)
enddo
endif
if(pr*cpr(j).gt.dtol) then
do ii=ldhai+1,nbl
hai2(ii-ldhai,k,i)=hai2(ii-ldhai,k,i)+ss*mo(ii,j)
enddo
endif
enddo
else
pp=0.5d0*pp
pp2=0.5d0*pp2
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
x(k)=x(k)+ss*pp
if(scftype.eq.0.or.scftype.ge.3) x2(k)=x2(k)+ss*pp2
if(dabs(ss)*cpr(i).gt.dtol) then
do ii=1,ldhai
hai(ii,k,i)=hai(ii,k,i)+ss*mo(ii,i)
enddo
endif
if(dabs(ss)*cpr(i).gt.dtol) then
do ii=ldhai+1,nbl
hai2(ii-ldhai,k,i)=hai2(ii-ldhai,k,i)+ss*mo(ii,i)
enddo
endif
enddo
endif
endif
enddo
C Second step of the exchange part
call dsyrk('u','t',nbasis,ldhai*dfnbasis,chfx,hai,
$ldhai*dfnbasis,1.d0,fock,nbasis)
call dsyrk('u','t',nbasis,ldhai2*dfnbasis,-chfx,hai2,
$ldhai2*dfnbasis,1.d0,fock,nbasis)
endif
else
C No exchange
do ipos=1,npos
i=intpos(1,ipos)
j=intpos(2,ipos)
n=intpos(3,ipos)
call intreadsq(i4core,n,teintf)
pp=p(i,j)
if(job.eq.'m'.and.(scftype.eq.0.or.scftype.ge.3)) pp2=p2(i, j)
if(max(dabs(pp),dabs(pp2)).gt.dtol) then
if(i.eq.j) then
pp=0.5d0*pp
pp2=0.5d0*pp2
endif
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
x(k)=x(k)+ss*pp
if(job.eq.'m'.and.(scftype.eq.0.or.scftype.ge.3)) then
x2(k) = x2(k) + ss*pp2
endif
enddo
endif
enddo
endif
if(job .eq. 'f') then
call dscal(dfnbasis,4.d0,x,1)
elseif(job .eq. 'm') then
call dscal(dfnbasis,8.d0,x,1)
endif
C
return
end
C
************************************************************************
subroutine dfmid(fock,nbasis,dfnbasis,npos,ipos,hai,hai2,cpr,
$i4core,intpos,teintf,nocc,mo,dtol,nbl,chfx,job,ldhai,ldhai2,n_neg)
************************************************************************
* DF-HF Fock-matrix construction, middle steps
************************************************************************
implicit none
integer nbasis,dfnbasis,intpos(3,*),npos,ipos,nbl,ldhai,ldhai2
integer i,j,k,l,n,kk,teintf(10),nn,ii,nocc,n_neg
real*8 fock(nbasis,nbasis),ss,dtol,chfx
real*8 hai(ldhai,dfnbasis,nbasis),cpr(nbasis),mo(nocc,nbasis)
real*8 pp,pr,hai2(ldhai2,dfnbasis,nbasis)
character*1 job
integer*4 i4core(*),ssi(2)
equivalence(ss,ssi)
C Exchange part only
call intclose(teintf)
call intopenrsq(teintf)
if(job.eq.'f' .or.
$ (job.eq.'m' .and. (n_neg.eq.0.or.n_neg.eq.nbl))) then
call dfillzero(hai,nbl*nbasis*dfnbasis)
do ipos=1,npos
i=intpos(1,ipos)
j=intpos(2,ipos)
n=intpos(3,ipos)
call intreadsq(i4core,n,teintf)
if(max(cpr(i),cpr(j)).gt.dtol) then
if(i.ne.j) then
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
pr=dabs(ss)
if(pr*cpr(i).gt.dtol) then
do ii=1,nbl
hai(ii,k,j)=hai(ii,k,j)+ss*mo(ii,i)
enddo
endif
if(pr*cpr(j).gt.dtol) then
do ii=1,nbl
hai(ii,k,i)=hai(ii,k,i)+ss*mo(ii,j)
enddo
endif
enddo
else
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
if(dabs(ss)*cpr(i).gt.dtol) then
do ii=1,nbl
hai(ii,k,i)=hai(ii,k,i)+ss*mo(ii,i)
enddo
endif
enddo
endif
endif
enddo
C Second step of the exchange part
call dsyrk('u','t',nbasis,nbl*dfnbasis,chfx,hai,nbl*dfnbasis,
$1.d0,fock,nbasis)
elseif(job.eq.'m' .and. n_neg.ne.0 .and. n_neg.ne.nbl) then
call dfillzero(hai,ldhai*nbasis*dfnbasis)
call dfillzero(hai2,ldhai2*nbasis*dfnbasis)
do ipos=1,npos
i=intpos(1,ipos)
j=intpos(2,ipos)
n=intpos(3,ipos)
call intreadsq(i4core,n,teintf)
if(max(cpr(i),cpr(j)).gt.dtol) then
if(i.ne.j) then
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
pr=dabs(ss)
if(pr*cpr(i).gt.dtol) then
do ii=1,ldhai
hai(ii,k,j)=hai(ii,k,j)+ss*mo(ii,i)
enddo
endif
if(pr*cpr(j).gt.dtol) then
do ii=1,ldhai
hai(ii,k,i)=hai(ii,k,i)+ss*mo(ii,j)
enddo
endif
if(pr*cpr(i).gt.dtol) then
do ii=ldhai+1, nbl
hai2(ii-ldhai,k,j)=hai2(ii-ldhai,k,j)+ss*mo(ii,i)
enddo
endif
if(pr*cpr(j).gt.dtol) then
do ii=ldhai+1,nbl
hai2(ii-ldhai,k,i)=hai2(ii-ldhai,k,i)+ss*mo(ii,j)
enddo
endif
enddo
else
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
if(dabs(ss)*cpr(i).gt.dtol) then
do ii=1,ldhai
hai(ii,k,i)=hai(ii,k,i)+ss*mo(ii,i)
enddo
endif
if(dabs(ss)*cpr(i).gt.dtol) then
do ii=ldhai+1,nbl
hai2(ii-ldhai,k,i)=hai2(ii-ldhai,k,i)+ss*mo(ii,i)
enddo
endif
enddo
endif
endif
enddo
C Second step of the exchange part
call dsyrk('u','t',nbasis,ldhai*dfnbasis,chfx,hai,
$ ldhai*dfnbasis,1.d0,fock,nbasis)
call dsyrk('u','t',nbasis,ldhai2*dfnbasis,-chfx,hai2,
$ ldhai2*dfnbasis,1.d0,fock,nbasis)
endif
return
end
C
************************************************************************
subroutine dflast(focka,fockb,p,p2,nbasis,dfnbasis,npos,ipos,hai,
$hai2,x,x2,cpr,i4core,intpos,teintf,nocc,mo,dtol,nbl,chfx,scftype,
$lq,lb,job,ldhai,ldhai2,n_neg)
************************************************************************
* DF-HF Fock-matrix construction, last step
************************************************************************
implicit none
integer nbasis,dfnbasis,intpos(3,*),npos,ipos,nbl,scftype,ldhai
integer i,j,k,l,n,kk,teintf(10),nn,ii,nocc,ldhai2,n_neg
real*8 focka(nbasis,nbasis),fockb(nbasis,nbasis),p(nbasis,nbasis)
real*8 hai(ldhai,dfnbasis,nbasis),cpr(nbasis),mo(nocc,nbasis)
real*8 pp,pr,ss,x(*),dtol,chfx,hai2(ldhai2,dfnbasis,nbasis)
real*8 x2(dfnbasis), p2(nbasis,nbasis), pp2
logical lq,lb
character*1 job
integer*4 i4core(*),ssi(2)
equivalence(ss,ssi)
C Coulomb + exchange part
if(job.eq.'f' .or.
$ (job.eq.'m' .and. (n_neg.eq.0.or.n_neg.eq.nbl))) then
call dfillzero(hai,nbl*nbasis*dfnbasis)
do ipos=1,npos
i=intpos(1,ipos)
j=intpos(2,ipos)
n=intpos(3,ipos)
call intreadsq(i4core,n,teintf)
pp=0.d0
pp2 = 0.0d0
if(i.ne.j) then
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
pp=pp+ss*x(k)
if(job.eq.'m'.and.(scftype.eq.0.or.scftype.ge.3)) then
pp2 = pp2 + ss * x2(k)
endif
pr=dabs(ss)
if(pr*cpr(i).gt.dtol) then
do ii=1,nbl
hai(ii,k,j)=hai(ii,k,j)+ss*mo(ii,i)
enddo
endif
if(pr*cpr(j).gt.dtol) then
do ii=1,nbl
hai(ii,k,i)=hai(ii,k,i)+ss*mo(ii,j)
enddo
endif
enddo
else
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
pp=pp+ss*x(k)
if(job.eq.'m'.and.(scftype.eq.0.or.scftype.ge.3)) then
pp2 = pp2 + ss * x2(k)
endif
if(dabs(ss)*cpr(i).gt.dtol) then
do ii=1,nbl
hai(ii,k,i)=hai(ii,k,i)+ss*mo(ii,i)
enddo
endif
enddo
endif
if(job.eq.'m'.and.(scftype.eq.0.or.scftype.ge.3)) then
focka(i, j) = focka(i, j) + pp
fockb(i, j) = fockb(i, j) + pp2
else
if(lq) focka(i,j)=focka(i,j)+pp
if(lb) fockb(i,j)=fockb(i,j)+pp
endif
enddo
C Second step of the exchange part
if(lq) then
if(nbl.gt.0) call dsyrk('u','t',nbasis,nbl*dfnbasis,chfx,hai,
$nbl*dfnbasis,1.d0,focka,nbasis)
else
if(nbl.gt.0) call dsyrk('u','t',nbasis,nbl*dfnbasis,-chfx,hai,
$nbl*dfnbasis,1.d0,focka,nbasis)
endif
elseif(job.eq.'m' .and. n_neg.ne.0 .and. n_neg.ne.nbl) then
call dfillzero(hai,ldhai*nbasis*dfnbasis)
call dfillzero(hai2,ldhai2*nbasis*dfnbasis)
do ipos=1,npos
i=intpos(1,ipos)
j=intpos(2,ipos)
n=intpos(3,ipos)
call intreadsq(i4core,n,teintf)
pp=0.d0
pp2 = 0.0d0
if(i.ne.j) then
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
pp=pp+ss*x(k)
if(scftype .eq. 0 .or. scftype .ge. 3) then
pp2 = pp2 + ss * x2(k)
endif
pr=dabs(ss)
if(pr*cpr(i).gt.dtol) then
do ii=1,ldhai
hai(ii,k,j)=hai(ii,k,j)+ss*mo(ii,i)
enddo
endif
if(pr*cpr(j).gt.dtol) then
do ii=1,ldhai
hai(ii,k,i)=hai(ii,k,i)+ss*mo(ii,j)
enddo
endif
if(pr*cpr(i).gt.dtol) then
do ii=ldhai+1, nbl
hai2(ii-ldhai,k,j)=hai2(ii-ldhai,k,j)+ss*mo(ii,i)
enddo
endif
if(pr*cpr(j).gt.dtol) then
do ii=ldhai+1,nbl
hai2(ii-ldhai,k,i)=hai2(ii-ldhai,k,i)+ss*mo(ii,j)
enddo
endif
enddo
else
do kk=0,n-1
ssi(1)=i4core(3*kk+1)
ssi(2)=i4core(3*kk+2)
k =i4core(3*kk+3)
pp=pp+ss*x(k)
if(job.eq.'m'.and.(scftype.eq.0.or.scftype.ge.3)) then
pp2 = pp2 + ss * x2(k)
endif
if(dabs(ss)*cpr(i).gt.dtol) then
do ii=1,ldhai
hai(ii,k,i)=hai(ii,k,i)+ss*mo(ii,i)
enddo
endif
if(dabs(ss)*cpr(i).gt.dtol) then
do ii=ldhai+1,nbl
hai2(ii-ldhai,k,i)=hai2(ii-ldhai,k,i)+ss*mo(ii,i)
enddo
endif
enddo
endif
if(job.eq.'m'.and.(scftype.eq.0.or.scftype.ge.3)) then
focka(i, j) = focka(i, j) + pp
fockb(i, j) = fockb(i, j) + pp2
else
if(lq) focka(i,j)=focka(i,j)+pp
if(lb) fockb(i,j)=fockb(i,j)+pp
endif
enddo
C Second step of the exchange part
if(lq) then
if(nbl.gt.0) then
call dsyrk('u','t',nbasis,ldhai*dfnbasis,chfx,hai,
$ ldhai*dfnbasis,1.d0,focka,nbasis)
call dsyrk('u','t',nbasis,ldhai2*dfnbasis,-chfx,hai2,
$ ldhai2*dfnbasis,1.d0,focka,nbasis)
endif
else
if(nbl.gt.0) call dsyrk('u','t',nbasis,nbl*dfnbasis,-chfx,hai,
$nbl*dfnbasis,1.d0,focka,nbasis)
endif
endif
C
return
end
************************************************************************
subroutine df_direct_fock(focka,fockb,p,nbasis,dfnbasis,scftol,
$nocc,mo,step,iout,natrange,oeintfile,natoms,dcore,icore,imem,
$nmoat,moat,dfnmobasis,moadd,atmo,natmo,ifile,iimem,scrfile4,lfin,
$moa,x,ialpha,chfx,varsfile,nbset,scrfile3,maxcor,tedatfile,lwdfn,
$minpfile,irecln,sclroute,route,hailen,linv,nc,lsexc,ncorenew,caa,
$devparr,excrad,excrad_fin,llc,scftype,scfiguess,locfit,nmobasis,
$natdom,atdom,naoat,aoat,atind,clrhfx,csrhfx,omega,qscf_hess,lf12,
$excha,exchb,lscrohfldf,istore,intpos,loccri)
************************************************************************
* Integral-direct Fock-matrix construction for DF-HF
************************************************************************
implicit none
integer nbasis,dfnbasis,iout,imem,ifile,iimem,katoms,lfin
integer i,j,k,l,n,kk,nn,ii,nocc,step,ierr,scrfile4,ialpha,idfatdom
integer oeintfile,natoms,is,iv,dfnmobasis(nocc),moadd,hailen,ist
integer dblalloc,intalloc,icore(*),iipra,natmo(*),idfatind,locfit
integer isa,ivi,iai,iind,atmo,nmoat(natoms),moat(natoms,nocc)
integer iover,iiold,icmo,idfnmobasis_old,minpfile,nmobasis(nocc)
integer naoat(natoms,2),aoat(natoms,nocc),atind,llocfit
integer varsfile,nbset,scrfile3,maxcor,tedatfile,irecln,idfnatdom
integer nc,ncore,ncorenew,incorb,inco,ncc1,ncc2,iatdom,lsexc
integer natdom(nocc),atdom(natoms,nocc),idist,iatoms,istore,intpos
integer natrange(2,natoms,*),nbatdom,ialpha_ovlp,iuboys
real*8 focka(nbasis,nbasis),p(nbasis,nbasis),temp,ss,ctol,chfx
real*8 mo(nbasis,nocc),dcore(*),devparr(2),bpcompo,itol
real*8 scftol,excrad,ddot,pr,moa(nocc,nbasis),clrhfx,csrhfx,omega
real*8 fockb(nbasis,nbasis),x(dfnbasis),caa(nbasis,nocc-nc)
real*8 excrad_fin,bpc(5),chargetol
real*8 excha(nbasis,nbasis),exchb(nbasis,nbasis)
character*4 cscr4,route
character*5 scftype,scfloc5(2)
character*7 scfiguess,scfmodom
character*16 orbloco,scfloc,c16
character*8 c8
logical linv,lwdfn,sclroute,llc,qscf_hess,lf12,lscrohfldf,loccri
equivalence(scfloc5,scfloc)
#if defined (MPI)
include 'mpif.h'
#endif
C Read thresholds
c write(6,*) 'fock1',chfx
c write(6,"(13f10.6)") focka
llocfit=locfit
if(excrad.eq.0.0d0) llocfit=0
call getkey('itol',4,cscr4,4)
read(cscr4,*) i
itol=10.d0**(-i)
ctol=min(itol,scftol/dfloat(dfnbasis*nocc))
if(sclroute) then
ncc1=0
ncc2=nc
if(route.eq.'emft'.or.route.eq.'sch ')
$call dcopy(nbasis*(nocc-nc),caa,1,mo,1)
goto 1236
endif
ncc1=0
ncc2=0
C Initialize MO coefficient matrix
if(route.eq.'emft'.and.lsexc.eq.0) then
ncc1=0
ncc2=nc
if(route.eq.'emft') call dcopy(nbasis*(nocc-nc),caa,1,mo,1)
elseif(.not. qscf_hess) then
open(scrfile3,file='MOA',form='unformatted')
write(scrfile3) moa
close(scrfile3)
call dcopy(nbasis*nocc,moa,1,dcore(imem),1)
ii=imem
do j=1,nbasis
mo(j,1:nocc)=dcore(ii:ii+nocc-1)
ii=ii+nocc
enddo
endif
C No local fitting
linv=.false.
do i=1,max(nocc,nocc-nc)
nmobasis(i)=nbasis
dfnmobasis(i)=dfnbasis
enddo
C Local fitting domains
if(nocc.gt.0.and.excrad.gt.0.d0.and.(chfx.ne.0.d0.or.lfin.eq.2))
$then
call getvar('ncore ',ncore)
if(.not.llc) ncore=0
icmo=dblalloc(nbasis**2)
c Lowdin charge criterion for initial fitting domains
chargetol=0.1d0
if (scftype.ne.'rhf ') chargetol=chargetol/2.d0
C Read S matrix
is=dblalloc(nbasis**2)
open(unit=oeintfile,file='OEINT',status='old',
$form='unformatted')
call roeint(dcore(imem),dcore(imem),dcore(is),oeintfile,nbasis)
C Initial guess for localization
ierr=1
if((lwdfn.and.step.ge.2).or.
& scfiguess.eq.'mo '.or.scfiguess.eq.'restart') then
iover=dblalloc(nbasis*nocc)
iiold=intalloc(nocc)
call loc_guess(imem,dcore,icmo,is,iover,iiold,ialpha,
&nbasis,nocc,scrfile3,mo,iout,lscrohfldf)
endif
C Pipek-Mezey localization
iv=dblalloc(nbasis*nocc)
write(iout,*)
call getkey('scfloc',6,scfloc,16)
if(scfloc.eq.'pm ') then
write(iout,*) 'Pipek-Mezey localization...'
C For Boys localization, orbloco=boys molden=off
call pmll(nocc,nbasis,natoms,natrange,dcore(is),mo,dcore(iv),
$dcore(imem),ierr.ne.0,ifile,step,devparr(1)+devparr(2),iout)
else if(trim(scfloc).eq.'boys') then
C For Boys localization, orbloco=boys molden=off
write(iout,*) 'Boys localization...'
iuboys=dblalloc(nocc*nocc)
open(scrfile3,file='PRINT',form='UNFORMATTED')
call localize('x',nocc,'boys',
&1.0d0,itol,itol,itol,natoms,dcore(imem),nbasis,
&scrfile3,'restart ',0,mo,nocc,.false.,dcore(iuboys))
close(scrfile3)
call dbldealloc(iuboys)
else if(trim(scfloc).eq.'pmm') then
write(iout,*) 'PM localization with Mulliken charges...'
open(scrfile3,file='PRINT',form='UNFORMATTED')
call localize('x',nocc,'pm ',1.0d0,itol,itol,itol,natoms,
&dcore(imem),nbasis,scrfile3,'restart ',0,mo,nocc,.false.,dcore)
close(scrfile3)
elseif(scfloc5(1).eq.'gboys') then
read(scfloc5(2),*) ss
write(*,"(' Generalized Boys localization ',
& '(m = ',f5.1,')')") ss
open(scrfile3,file='PRINT',form='UNFORMATTED')
call localize('x',nocc,'boys',ss,itol,itol,itol,natoms,
&dcore(imem),nbasis,scrfile3,'restart ',0,mo,nocc,.false.,dcore)
close(scrfile3)
endif
#if defined (MPI)
call MPI_Bcast(mo,nocc*nbasis,MPI_DOUBLE_PRECISION,0,
$MPI_COMM_WORLD,i)
#endif
call timer
C Check overlap with old MOs
if(ierr.eq.0) then
call dgemm('t','n',nocc,nocc,nbasis,1.d0,mo,nbasis,
$dcore(iover),nbasis,0.d0,dcore(imem),nocc)
call chkover(dcore(imem),mo,dcore(icmo),nbasis,nocc,
$icore(iiold))
endif
close(oeintfile)
C Lowdin charges or Boughton-Pulay algorithm
isa=dblalloc(nbasis**2)
ivi=dblalloc(nbasis)
iai=dblalloc(nbasis)
iind=intalloc(natoms)
if(ialpha.le.1.or.(lscrohfldf.and.ialpha.gt.1)) then
open(scrfile3,file='OLDMO',form='unformatted')
else
open(scrfile3,file='OLDMOb',form='unformatted')
endif
call wrtmo(dcore(imem),dcore(imem),mo,scrfile3,ctol,nbasis,nocc)
close(scrfile3)
ist=6
if(scfiguess.eq.'mo '.or.scfiguess.eq.'restart')
$ ist=idnint(dble(natoms)/5.d0)
if(excrad.gt.0.d0.and.(chfx.ne.0.d0.or.lfin.eq.2)) then
if(locfit.ge.2) then
cnp open(minpfile,file='MINP')
cnp call getkeym('scfmodom',8,scfmodom,7)
cnp if (scfmodom.eq.' ') scfmodom='bpcompl'
cnp close(minpfile)
scfmodom='werner '
cnp open(unit=oeintfile,file='OEINT',status='old',
cnp $form='unformatted')
cnp call roeint(dcore(imem),dcore(imem),dcore(is),oeintfile,
cnp $nbasis)
cnp close(oeintfile)
cnp call dsymm('l','l',nbasis,nocc,1.d0,dcore(is),nbasis,mo,
cnp $nbasis,0.d0,dcore(iv),nbasis)
if(scfmodom.eq.'werner '.or.scfmodom.eq.'both ') then ! Werner-like MO domain construction
c write(iout,*)
c write(iout,*)'MO domain criterion: ',min(1.d-6,scftol)
c if(.false.) then
naoat=0
natdom=0
bpc(3)=2.d0
bpc(4)=0.d0
bpc(5)=0.d0
do i=1,nocc
do iatoms=1,natoms
if(0.5d0*sum(mo(natrange(1,iatoms,1)+1:
$natrange(2,iatoms,1),i)**2).gt.min(1d-7,0.1d0*scftol)) then! scftol=1.d-6 by default
naoat(iatoms,1)=naoat(iatoms,1)+1
aoat(iatoms,naoat(iatoms,1))=i
natdom(i)=natdom(i)+1
atdom(natdom(i),i)=iatoms
endif
enddo
cnp call bpcompleteness(natdom(i),atdom(1,i),dcore(is),
cnp $dcore(iv),natrange,dcore(isa),dcore(ivi),dcore(iai),bpc(1),
cnp $dcore(imem),0,0.d0,nbasis,i,.false.,mo,nbatdom)
cnp call bpcompleteness(natdom(i),atdom(1,i),dcore(is),
cnp $dcore(iv),natrange,dcore(isa),dcore(ivi),dcore(iai),bpc(2),
cnp $dcore(imem),0,0.d0,nbasis,i,.true.,mo,nbatdom)
cnp write(6,"(2i5,4x,2es16.7,4x,1000i5)")
cnp $i,natdom(i),bpc(1)/2.d0,bpc(2)/2.d0,atdom(1:natdom(i),i)
cnp bpc(3)=min(bpc(3),bpc(2))
cnp bpc(4)=max(bpc(4),bpc(2))
cnp bpc(5)=bpc(5)+bpc(2)
enddo
cnp write(6,*)
cnp write(6,"(a23,i6,f10.1,i6,3es16.7)")
cnp $'Werner min/avg/max atom',
cnp $minval(natdom(1:nocc)),dble(sum(natdom(1:nocc),nocc))/dble(nocc),
cnp $maxval(natdom(1:nocc))!,bpc(3)/2.d0,bpc(4)/2.d0,bpc(5)/dble(2*nocc)
endif
if(scfmodom.eq.'bpcompl'.or.scfmodom.eq.'both ') then ! BP MO domain construction
call timer
call getkey('bpcompo',7,c16,16)
read(c16,*) bpcompo
write(iout,*)
write(iout,*)'MO domain criterion ',scfmodom,bpcompo
bpcompo=2.d0*bpcompo
open(unit=oeintfile,file='OEINT',status='old',
$form='unformatted')
call roeint(dcore(imem),dcore(imem),dcore(is),oeintfile,
$nbasis)
close(oeintfile)
call dsymm('l','l',nbasis,nocc,1.d0,dcore(is),nbasis,mo,
$nbasis,0.d0,dcore(iv),nbasis)
idist=dblalloc(natoms**2)
call bopu(nbasis,nocc,natoms,natrange,mo,dcore(iv),
$icore(iind),dcore(imem),dcore(is),dcore(isa),dcore(ivi),
$dcore(iai),atdom,naoat,aoat,natdom,bpcompo,bpcompo,nocc,
$max(30*step,5*ist),'nbp ',icore(iimem),natrange,nbasis,mo,
$dcore(idist),0,0.d0,0.0d0,.false.,iout,0.05d0)
call timer
call dbldealloc(idist)
endif
c project MOs onto their AO domain
cnp if (scfmodom.eq.'bpcompl'.or.scfmodom.eq.'werner '.or.
cnp $ scfmodom.eq.'both ') then
cnp bpc(1)=2.d0
cnp bpc(2)=0.d0
cnp bpc(5)=0.d0
cnp call dfillzero(dcore(icmo),nbasis*nocc)
cnp do i=1,nocc
cnp c call bpcompleteness(natdom(i),atdom(1,i),dcore(is),
cnp c $dcore(iv),natrange,dcore(isa),dcore(ivi),dcore(iai),bpc(3),
cnp c $dcore(imem),0,0.d0,nbasis,i,.false.,mo,nbatdom)
cnp call bpcompleteness(natdom(i),atdom(1,i),dcore(is),
cnp $dcore(iv),natrange,dcore(isa),dcore(ivi),dcore(iai),bpc(4),
cnp $dcore(imem),0,0.d0,nbasis,i,.true.,mo,nbatdom)
cnp write(*,'("truncated/projected completeness",i7,2es16.7)'),
cnp $i,bpc(3)/2.d0,bpc(4)/2.d0
cnp bpc(1)=min(bpc(4),bpc(1))
cnp bpc(2)=max(bpc(4),bpc(2))
cnp bpc(5)=bpc(5)+bpc(4)
cnp call normalize(nbatdom,1,dcore(iai),dcore(ivi),dcore(is),
cnp $.true.,2.d0,.true.)
cnp c map back the projected, normalized MO coeffs to the full basis mo
cnp ii=0
cnp do katoms=1,natdom(i)
cnp iatoms=atdom(katoms,i)
cnp do nn=natrange(1,iatoms,1)+1,natrange(2,iatoms,1)
cnp ii=ii+1
cnp dcore(icmo+(i-1)*nbasis+nn-1)=dcore(iai+ii-1)
cnp enddo !nn
cnp enddo! iiatoms
cnp enddo
cnp write(6,*)
cnp write(6,"(a22,i6,f10.1,i6,3es16.7)")
cnp $'final min/avg/max atom',
cnp $minval(natdom(1:nocc)),dble(sum(natdom(1:nocc),nocc))/dble(nocc),
cnp $maxval(natdom(1:nocc)),bpc(1)/2.d0,bpc(2)/2.d0,bpc(5)/dble(2*nocc)
cnp endif
c
endif
open(ifile,file='SROOT',form='UNFORMATTED')
call roeint(dcore(imem),dcore(imem),dcore(isa),ifile,nbasis)
close(ifile)
call dsymm('l','l',nbasis,nocc,1.d0,dcore(isa),nbasis,mo,
$nbasis,0.d0,dcore(iv),nbasis)
c call bopu(nbasis,nocc,natoms,natrange,dcore(iv),dcore(iv),
c $icore(iind),dcore(imem),dcore(isa),dcore(isa),dcore(ivi),
c $dcore(iai),atdom,naoat,aoat,natdom,0.0000001d0,0.1d0,nocc,natoms,
c $'lowd',icore(iimem),natrange,nbasis,dcore(iv),dcore(imem),0,0.d0,
c $0.0d0,.false.,iout,0.05d0)
call bopu(nbasis,nocc,natoms,natrange,dcore(iv),dcore(iv),
$icore(iind),dcore(imem),dcore(isa),dcore(isa),dcore(ivi),
$dcore(iai),atmo,nmoat,moat,natmo,chargetol,chargetol,nocc,
$max(2*step,ist),'lowd',icore(iimem),natrange,nbasis,dcore(iv),
$dcore(imem),0,0.d0,0.0d0,.false.,iout,0.05d0)
C Construct domains
iipra=dblalloc(natoms**2)
idfnmobasis_old=intalloc(nocc)
iatdom=intalloc(natoms)
idfatdom=intalloc(natoms*nocc)
idfatind=intalloc(natoms*nocc)
idfnatdom=intalloc(nocc)
call locdom(nbasis,nocc,natoms,natrange,atmo,nmoat,moat,natmo,
$excrad,icore(iatdom),dcore(iipra),dfnmobasis,moadd,hailen,
$dfnbasis,icore(idfnmobasis_old),linv,scrfile4,step,
$icore(iimem+natoms),iout,scftype,lwdfn,mo,icore(idfatdom),
$icore(idfnatdom),icore(iimem),icore(idfatind),2,
$ialpha,llocfit,nmobasis,natdom,atdom,naoat,aoat,atind,scftol,
$lscrohfldf)
cnp if (scfmodom.eq.'bpcompl'.or.scfmodom.eq.'werner '.or.
cnp $ scfmodom.eq.'both ') then
cnp c write(*,*) 'project on MO domain + normalize'
cnp c call dcopy(nbasis*nocc,dcore(icmo),1,mo,1)
cnp endif
endif
call dbldealloc(icmo)
endif ! Local fitting domains
1236 continue
if(lfin.ne.2.and.dabs(excrad-excrad_fin).gt.1d-2*itol) then
do i=1,nocc
if(dfnmobasis(i).lt.dfnbasis) lfin=1
enddo
lfin=1
endif
C Fock-matrix construction
call getkey('fitting',7,c8,8)
if(c8.eq.'overlap ') then
call getvar('ncore ',ncore)
if(.not.llc) ncore=0
icmo=dblalloc(nbasis**2)
C Read S matrix
is=dblalloc(nbasis**2)
open(unit=oeintfile,file='OEINT',status='old',
$form='unformatted')
call roeint(dcore(imem),dcore(imem),dcore(is),oeintfile,nbasis)
C Initial guess for localization
ierr=1
if(lwdfn.and.step.ge.2) then
iover=dblalloc(nbasis*nocc)
iiold=intalloc(nocc)
call loc_guess(imem,dcore,icmo,is,iover,iiold,ialpha,
&nbasis,nocc,scrfile3,mo,iout)
endif
C Pipek-Mezey localization
iv=dblalloc(nbasis*nocc)
write(iout,*)
write(iout,*) 'Pipek-Mezey localization...'
call pmll(nocc,nbasis,natoms,natrange,dcore(is),mo,dcore(iv),
$dcore(imem),ierr.ne.0,ifile,step,devparr(1)+devparr(2),iout)
#if defined (MPI)
call MPI_Bcast(mo,nocc*nbasis,MPI_DOUBLE_PRECISION,0,
$MPI_COMM_WORLD,i)
#endif
call timer
C Check overlap with old MOs
if(ierr.eq.0) then
call dgemm('t','n',nocc,nocc,nbasis,1.d0,mo,nbasis,
$dcore(iover),nbasis,0.d0,dcore(imem),nocc)
call chkover(dcore(imem),mo,dcore(icmo),nbasis,nocc,
$icore(iiold))
endif
close(oeintfile)
call dbldealloc(icmo)
endif
if(c8.eq.'coulomb ') then
if(.not.lf12) then
call direct_fock_build(p,p,focka,fockb,fockb,step,scftype,2,0,
$1,dcore,dcore,mo(1,ncc1+1),.true.,dcore,dcore,dcore,dcore,hailen,
$nmoat,moat,moadd,dfnmobasis,ctol,linv,x,ialpha,chfx,
$iout,varsfile,icore,dcore,nbset,oeintfile,max(1,nocc-ncc2),
$scrfile3,scrfile4,maxcor,imem,tedatfile,dfnbasis,nbasis,0,
$dcore,minpfile,.false.,1,dcore,irecln,1,sclroute,0,0,0,
$devparr(1)+devparr(2),p,1,dcore,0,llocfit,nmobasis,natdom,
$atdom,naoat,aoat,atind,i,i,clrhfx,csrhfx,omega,.false.,dcore,
$dcore,dcore,i,qscf_hess,.false.,dcore,.false.,.false.,istore,
$intpos,.false.,excha,exchb,lf12,loccri,nocc)
else
if(ialpha.le.1)
$ call direct_fock_build(p,p,focka,fockb,fockb,step,scftype,2,0,1,
$dcore,dcore,mo(1,ncc1+1),.true.,dcore,dcore,dcore,dcore,hailen,
$nmoat,moat,moadd,dfnmobasis,ctol,linv,x,ialpha,0.d0,
$iout,varsfile,icore,dcore,nbset,oeintfile,max(1,nocc-ncc2),
$scrfile3,scrfile4,maxcor,imem,tedatfile,dfnbasis,nbasis,0,
$dcore,minpfile,.false.,1,dcore,irecln,1,sclroute,0,0,0,
$devparr(1)+devparr(2),p,1,dcore,0,llocfit,nmobasis,natdom,
$atdom,naoat,aoat,atind,i,i,clrhfx,csrhfx,omega,.false.,dcore,
$dcore,dcore,i,qscf_hess,.false.,dcore,.false.,.false.,istore,
$intpos,.false.,excha,exchb,lf12,loccri,nocc)
if(dabs(chfx).gt.0.d0)
$ call direct_fock_build(p,p,excha,exchb,exchb,step,scftype,2,0,1,
$dcore,dcore,mo(1,ncc1+1),.true.,dcore,dcore,dcore,dcore,hailen,
$nmoat,moat,moadd,dfnmobasis,ctol,linv,x,ialpha,chfx,
$iout,varsfile,icore,dcore,nbset,oeintfile,max(1,nocc-ncc2),
$scrfile3,scrfile4,maxcor,imem,tedatfile,dfnbasis,nbasis,-1,
$dcore,minpfile,.false.,1,dcore,irecln,1,sclroute,0,0,0,
$devparr(1)+devparr(2),p,1,dcore,0,llocfit,nmobasis,natdom,
$atdom,naoat,aoat,atind,i,i,clrhfx,csrhfx,omega,.false.,dcore,
$dcore,dcore,i,qscf_hess,.false.,dcore,.false.,.false.,istore,
$intpos,.false.,excha,exchb,lf12,loccri,nocc)
endif
elseif(c8.eq.'overlap ') then
! Exchange part
if(ialpha.eq.2) then
ialpha_ovlp=0
else
ialpha_ovlp=ialpha
endif
call direct_fock_build(p,p,focka,fockb,fockb,step,scftype,2,0,1,
$dcore,dcore,mo(1,ncc1+1),.true.,dcore,dcore,dcore,dcore,hailen,
$nmoat,moat,moadd,dfnmobasis,ctol,linv,x,ialpha_ovlp,chfx,
$iout,varsfile,icore,dcore,nbset,oeintfile,max(1,nocc-ncc2),
$scrfile3,scrfile4,maxcor,imem,tedatfile,dfnbasis,nbasis,0,
$dcore,minpfile,.false.,1,dcore,irecln,1,sclroute,0,0,0,
$devparr(1)+devparr(2),p,1,dcore,0,llocfit,nmobasis,natdom,
$atdom,naoat,aoat,atind,i,i,clrhfx,csrhfx,omega,.false.,dcore,
$dcore,dcore,i,qscf_hess,.false.,dcore,.false.,.true.,istore,
$intpos,.false.,excha,exchb,lf12,loccri,nocc)
! Coulomb part
if(ialpha.lt.2) then
call direct_fock_build(p,p,focka,fockb,fockb,step,scftype,2,0,
$1,dcore,dcore,mo(1,ncc1+1),.true.,dcore,dcore,dcore,dcore,hailen,
$nmoat,moat,moadd,dfnmobasis,ctol,linv,x,ialpha,0.0d0,
$iout,varsfile,icore,dcore,nbset,oeintfile,max(1,nocc-ncc2),
$scrfile3,scrfile4,maxcor,imem,tedatfile,dfnbasis,nbasis,0,
$dcore,minpfile,.false.,1,dcore,irecln,1,sclroute,0,0,0,
$devparr(1)+devparr(2),p,1,dcore,0,llocfit,nmobasis,natdom,
$atdom,naoat,aoat,atind,i,i,clrhfx,csrhfx,omega,.false.,dcore,
$dcore,dcore,i,qscf_hess,.false.,dcore,.false.,.false.,istore,
$intpos,.false.,excha,exchb,lf12,loccri,nocc)
endif
endif
C Restore moa
if(((route.ne.'emft'.and.route.ne.'sch ').or.lsexc.gt.0).and.
$ .not.qscf_hess) then
open(scrfile3,file='MOA',form='unformatted')
read(scrfile3) moa
close(scrfile3,status='delete')
endif
C
return
end
C
C***********************************************************************
subroutine chkover(over,mo,cmo,nbasis,nocc,iold)
C***********************************************************************
C Check the overlap with old MOs and reorder new MOs accordingly
C***********************************************************************
implicit none
integer nbasis,nocc,i,j,jj,iold(nocc)
real*8 over(nocc,nocc),cmo(nbasis,nocc),mo(nbasis,nocc),maxd
c write(6,"(23f7.3)") over
C
call ifillzero(iold,nocc)
call dcopy(nbasis*nocc,mo,1,cmo,1)
maxd=0.d0
do i=1,nocc
jj=1
do while(iold(jj).ne.0)
jj=jj+1
enddo
do j=jj+1,nocc
if(dabs(over(i,j)).gt.dabs(over(i,jj)).and.iold(j).eq.0)then
jj=j
endif
enddo
iold(jj)=i
if(i.ne.jj) call dcopy(nbasis,cmo(1,i),1,mo(1,jj),1)
maxd=max(maxd,2.d0-dabs(over(i,jj)))
enddo
C
return
end
C
************************************************************************
subroutine moatransp(nocc,nbasis,mo1,mo2,nc)
************************************************************************
* Transpose MO coefficient matrix
************************************************************************
implicit none
integer nocc,nbasis,nc,i
real*8 mo1(nocc,nbasis),mo2(nocc,nbasis)
C
call dcopy(nocc*nbasis,mo1,1,mo2,1)
do i=1,nocc-nc
mo1(i,1:nbasis)=mo2(nc+i,1:nbasis)
enddo
do i=1,nc
mo1(nocc-nc+i,1:nbasis)=mo2(i,1:nbasis)
enddo
C
return
end
C
************************************************************************
subroutine r_build(rmat,s,pt,qmat,sqroffset,scr,rs,dft)
************************************************************************
* Build R matrix for ROHF: S*D*Q + Q*D*S
************************************************************************
#include "MRCCCOMMON"
#include "SCFCOMMON"
integer sqroffset(*),i,j
real*8 rmat(*),s(*),pt(*),qmat(*),scr(*),rs(*)
character(len=32) dft
C
do i=1,nir
if(nfunc(i).gt.0) then
call dsymm('l','l',nfunc(i),nfunc(i),1.d0,s(sqroffset(i)),
$nfunc(i),pt(sqroffset(i)),nfunc(i),0.d0,scr,nfunc(i))
call dsyr2k('u','n',nfunc(i),nfunc(i),1.d0,scr,nfunc(i),
$qmat(sqroffset(i)),nfunc(i),0.d0,rmat(sqroffset(i)),nfunc(i))
if(trim(dft).ne.'off') then
call dsymm('l','l',nfunc(i),nfunc(i),1.d0,s(sqroffset(i)),
$nfunc(i),pt(sqrsize+sqroffset(i)),nfunc(i),0.d0,rs(sqrsize+1),
$nfunc(i))
call daxpy(nfunc(i)**2,-0.5d0,rs(sqrsize+1),1,scr,1)
do j=1,nfunc(i)
scr((j-1)*nfunc(i)+j)=scr((j-1)*nfunc(i)+j)-1.d0
enddo
call dsymm('r','l',nfunc(i),nfunc(i),1.d0,rs(sqroffset(i)),
$nfunc(i),rs(sqrsize+1),nfunc(i),0.d0,scr(nfunc(i)**2+1),nfunc(i))
call dsyr2k('u','n',nfunc(i),nfunc(i),1.d0,scr,nfunc(i),
$scr(nfunc(i)**2+1),nfunc(i),1.d0,rmat(sqroffset(i)),nfunc(i))
endif
call filllo(rmat(sqroffset(i)),nfunc(i))
endif
enddo
C
return
end
C
************************************************************************
subroutine pseig(r8heap,r8heap1n,lshift,step,c,fock,eigenvalue,
$r8heapsize,offset,sqroffset,s,p,ifile,route)
************************************************************************
* Solve pseudo-eigenvalue equation
************************************************************************
#include "MRCCCOMMON"
#include "SCFCOMMON"
integer i,j,step,q,error,r8heapsize,offset(nir),ifile
integer sqroffset(nir),nq
integer*4 error4
real*8 r8heap(*),r8heap1n(*),lshift,c(*),fock(*),eigenvalue(*)
real*8 s(*),p(*),fac
equivalence(error,error4)
character*4 route
C
nq=0
if(scftype.eq._UHF_.or.route.eq.'sch ') nq=1
call dcopy((nq+1)*sqrsize,fock,1,c,1)
fac=-0.5d0*dble(nq+1)
if(route.eq.'sch ') fac=-0.5d0
C Level-shifting
if(lshift.gt.0.d0.and.step.gt.1) then
if(lnos) then
open(oeintfile,file='OEINT',form='unformatted')
call roeint(r8heap,r8heap,s,oeintfile,nfunc(1)) ! r8heap2n is overwritten by S !!!
close(oeintfile)
endif
do q=0,nq
do i=1,nir
if(nfunc(i).gt.0) then
call dsymm('l','l',nfunc(i),nfunc(i),fac,
$p(q*sqrsize+sqroffset(i)),nfunc(i),s(sqroffset(i)),nfunc(i),0.d0,
$r8heap1n,nfunc(i))
do j=1,nfunc(i)
r8heap1n((j-1)*nfunc(i)+j)=1.d0+
$ r8heap1n((j-1)*nfunc(i)+j)
enddo
call dsymm('l','l',nfunc(i),nfunc(i),lshift,
$s(sqroffset(i)),nfunc(i),r8heap1n,nfunc(i),1.d0,
$c(q*sqrsize+sqroffset(i)),nfunc(i))
endif
enddo
enddo
endif
error=0
C Solve generalized eigenvalue problem
open(ifile,file='SCHOL',form='unformatted')
if(ndao.eq.0) then
do i=1,nir
if(nfunc(i).gt.0) then
call rspmx(r8heap,nfunc(i),ifile)
do q=0,nq
call dsygst(1,'L',nfunc(i),c(q*sqrsize+sqroffset(i)),
$nfunc(i),r8heap,nfunc(i),error)
call dsyev('V','L',nfunc(i),c(q*sqrsize+sqroffset(i)),
$nfunc(i),eigenvalue(q*nbasis+offset(i)),r8heap1n,r8heapsize,error)
call dtrsm('L','L','T','N',nfunc(i),nfunc(i),1.d0,
$r8heap,nfunc(i),c(q*sqrsize+sqroffset(i)),nfunc(i))
if(error4.ne.0) then
write(iout,*) 'Fatal error at diagonalization!'
call mrccend(1)
endif
enddo
endif
enddo
else
do i=1,nir
if(nfunc(i).gt.0) then
read(ifile) r8heap(1:nfunc(i)*nfuns(i))
do q=0,nq
if(nfuns(i).gt.0) then
call dsymm('l','l',nfunc(i),nfuns(i),1.d0,
$c(q*sqrsize+sqroffset(i)),nfunc(i),r8heap,nfunc(i),0.d0,
$r8heap1n,nfunc(i))
call dgemm('t','n',nfuns(i),nfuns(i),nfunc(i),1.d0,
$r8heap,nfunc(i),r8heap1n,nfunc(i),0.d0,
$c(q*sqrsize+sqroffset(i)),nfuns(i))
call dsyev('V','L',nfuns(i),c(q*sqrsize+sqroffset(i)),
$nfuns(i),eigenvalue(q*nbasis+offset(i)),r8heap1n,r8heapsize,error)
if(error4.ne.0) then
write(iout,*) 'Fatal error at diagonalization!'
call mrccend(1)
endif
call dgemm('n','n',nfunc(i),nfuns(i),nfuns(i),1.d0,
$r8heap,nfunc(i),c(q*sqrsize+sqroffset(i)),nfuns(i),0.d0,
$r8heap1n,nfunc(i))
call dcopy(nfunc(i)*nfuns(i),r8heap1n,1,
$c(q*sqrsize+sqroffset(i)),1)
endif
eigenvalue(q*nbasis+offset(i)+nfuns(i):
$ q*nbasis+offset(i)+nfunc(i)-1)=1d30
c(q*sqrsize+sqroffset(i)+nfunc(i)*nfuns(i):
$ q*sqrsize+sqroffset(i)+nfunc(i)*nfunc(i)-1)=0.d0
enddo
endif
enddo
endif
close(ifile)
C Restore orbital energies in the case of level-shifting
if(lshift.gt.0.d0.and.step.gt.1) then
do q=0,nq
do i=1,nir
do j=orbperir(i+q*nir),nfunc(i)-1
eigenvalue(offset(i)+q*nbasis+j)=
$ eigenvalue(offset(i)+q*nbasis+j)-lshift
enddo
enddo
enddo
if(scftype.eq._ROHFSTD_.or.scftype.eq._ROHFSCN_) then
do i=1,nir
do j=orbperir(i),orbperir(i)+orbperir(i+nir)-1
eigenvalue(offset(i)+j)=
$ eigenvalue(offset(i)+j)+0.5d0*lshift
enddo
enddo
endif
endif
#if defined (MPI)
call MPI_Bcast(c,(nq+1)*sqrsize,MPI_DOUBLE_PRECISION,0,
$MPI_COMM_WORLD,i)
#endif
C
return
end
C
************************************************************************
subroutine moto(mat1,symtra,r8heap,nbasis,mat2,offset,lsa)
************************************************************************
* Transform one-electron quantities to symmetry basis
************************************************************************
implicit none
integer nbasis,offset
real*8 mat1(nbasis,nbasis),mat2(nbasis,nbasis)
real*8 symtra(nbasis,nbasis),r8heap(*)
logical lsa
C
if(lsa) then
call mx_symm_extr(r8heap,mat2,offset)
call dgemm('n','n',nbasis,nbasis,nbasis,1.d0,symtra,nbasis,
$r8heap,nbasis,0.d0,mat1,nbasis)
else
call dcopy(nbasis*nbasis,mat2,1,mat1,1) !Do not touch
endif
C
return
end
C
Reference in New Issue View Git Blame Copy Permalink