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

7608 lines
284 KiB
Fortran
Raw Blame History

************************************************************************
module common_mod
************************************************************************
* Module containing variables in MRCC/SCFCOMMON files
************************************************************************
#include "MRCCCOMMON"
#include "SCFCOMMON"
end module
************************************************************************
module mcscf
************************************************************************
* THIS MODULE CONTAINS THE VARIABLES AND SUBROUTINES FOR THE MCSCF
* CALCULATION
************************************************************************
use common_mod, only: nirmax, nir, nfunc, dcore, c_ptr, p_ptr,
& orbperir, nbasis, imem, nal, nbe, sqrsize, lsa,
& symtra_ptr, iintpos, icore, nelec, scftype,
& scfmaxit
implicit none
integer nactperir(nirmax)
integer actoffset(nirmax)
integer vecoffset(2*nirmax)
integer sqrasize
integer nact
integer nactel
integer multiplicity
integer rmax, rmaxp1
integer igrad, ikappa, ioldkappa, iproj_kappa
integer ikappa_tr
integer iq, ip2, ip4 ! Q matrix, 1- and 2 electron density
integer ib, ibtr ! basis vectors and their transformed
integer iproj_hess, iproj_hess2 ! Projected Hessian
integer ifock_ptr, afock_ptr ! inactive and active Fock
integer igenfock, idiag
integer ntmaxit ! maximal number of microiterations
integer qscfsizea, qscfsizeb, qscfsize
integer qscfsizevec(3)
integer irefdet ! reference determinant for the CI program
integer iocc_num ! occupation number
integer ieigval2 ! calues for MO sorting
logical posdef
logical ldf ! density fitting
double precision grad_scale
c Variables for BFGS method
integer isvec ! s_k vectors
integer iyvec ! y_k vectors
integer irho ! rho=1/(y_k's_k) values
integer bfgs_max_pairs ! maximum number of (s_k, y_k) pairs
integer bfgs_pairs ! number of available (s_k, y_k) pairs
integer ibfgs_h0 ! initiial approximation for H (inverse Hessian)
integer ibfgs_vector_map
integer ioldgrad ! old gradient vector
integer ibfgs_oldkappa ! Solution in the previous interation
integer bfgs_step
double precision grad_max_norm ! Maximum norm of the gradient
character*8 modf_integs, modf_act_integs, rohf_fock_file
character*32 dft
parameter(modf_integs = 'modfints', modf_act_integs = 'act_ints')
parameter(rohf_fock_file = 'rohffock')
equivalence(qscfsizevec(1), qscfsizea)
equivalence(qscfsizevec(2), qscfsizeb)
equivalence(qscfsizevec(3), qscfsize)
************************************************************************
contains !FUNCTION AND SUBROUTINE DEFINITIONS
************************************************************************
subroutine mcscf_calc(sqroffset, offset, ener, oldener,
& posdef, h, npos, chfx, hnuc, qscf, gn, lfin, nfr, nc, ncorenew,
& exc, devparr, dft, embed, scfdamp, route, lwdfn, peps, reject,
& itol, step, clrhfx, csrhfx, omega,pcm)
************************************************************************
* Main routine for MCSCF calculation
************************************************************************
use common_mod, only: sqrsize2, verblevel, qmat_ptr, rmat_ptr,
& c_ptr, sdfile, enerepsilon, iout, verblevel
implicit none
integer offset(nir), sqroffset(nir), npos, ir, lwork, step
double precision chfx,itol,clrhfx,csrhfx,omega
double precision hnuc, gn, oldgn
double precision ener, oldener, h
double precision peps, delta, eps, delta_conjgrad
parameter(eps = 1.0d-3)
character*8 qscf
integer lfin, nfr, nc, ncorenew
double precision exc, devparr(2)
character*32 dft,pcm
character*8 embed
character*16 scfdamp,tprint
character*4 route
logical lwdfn, posdef, reject
integer itmp
integer i, subspace_dim
integer dblalloc, idamax
double precision dnrm2
oldgn = gn
lwork = 1000*ntmaxit
subspace_dim = 0
delta=enerepsilon
if(qscf .ne. 'newton ')
& call save_data(dcore(c_ptr), dcore(ifock_ptr), dcore(afock_ptr),
& dcore(igenfock), dcore(rmat_ptr), dcore(p_ptr), dcore(ip2),
& dcore(ip4), dcore(iq))
if(scftype .ne. 0) then
rewind(sdfile)
write(sdfile) dcore(p_ptr:p_ptr+sqrsize2-1)
else
rewind(sdfile)
write(sdfile) dcore(p_ptr:p_ptr+sqrsize-1)
write(sdfile) dcore(ip2:ip2+nact**2-1)
endif
call dfillzero(dcore(igrad), qscfsize)
call mk_grad(dcore(igenfock), dcore(igrad), sqroffset, qscfsize,
& grad_scale)
i = idamax(qscfsize, dcore(igrad), 1)
grad_max_norm = dabs(dcore(igrad+i-1))
c if(verblevel .ge. 3) then
write(iout,"(1X,'Gradient norm: ',ES15.4E2)")
& grad_max_norm
c endif
if(grad_max_norm .gt. delta) then
delta_conjgrad = delta
else
delta_conjgrad = enerepsilon*0.1d0
endif
gn = dnrm2(qscfsize, dcore(igrad), 1)
if(scftype .ge. 3) then
call mk_hessdiag(dcore(rmat_ptr), dcore(ifock_ptr),
& dcore(afock_ptr), dcore(iq), dcore(qmat_ptr), dcore(ip2),
& dcore(idiag), sqroffset, offset)
else
call mk_hessdiag(dcore(igenfock), dcore(ifock_ptr),
& dcore(afock_ptr), dcore(iq), dcore(qmat_ptr), dcore(ip2),
& dcore(idiag), sqroffset, offset)
endif
select case(qscf)
case('newton ', 'newtonl ')
call conjgrad(dcore(igrad), dcore(c_ptr),
& dcore(ikappa), dcore(ib), dcore(ib+qscfsize),
& dcore(ib+2*qscfsize), dcore(ib+3*qscfsize),
& dcore(ib+4*qscfsize), dcore(ib+5*qscfsize),
& dcore(idiag), dcore(ip2), npos, icore(iintpos),
& sqroffset, offset, nfr, qscfsize, lsa, delta_conjgrad,
& chfx, exc, step, lfin, embed, lwdfn, scfdamp, route, nc,
& ncorenew, devparr, ntmaxit, clrhfx, csrhfx, omega, pcm)
call trcoef(dcore(ikappa), dcore(c_ptr), sqroffset)
call build_dens(dcore(c_ptr), dcore(p_ptr), sqrsize, sqroffset)
if(qscf .eq. 'newtonl ') then
call line_search(offset, sqroffset, hnuc, step, ener, oldener,
& gn, oldgn, dcore(ikappa), dcore(ioldkappa),
& dcore(ikappa_tr), dcore(c_ptr), dcore(igenfock),
& dcore(igrad), dcore(ip2), dcore(ip4), dcore(iq), chfx,
& qscf, h, reject, npos, lfin, nfr, nc, ncorenew, exc,
& devparr, dft, embed, scfdamp, route, lwdfn, .false.,
& dcore(ib), clrhfx, csrhfx, omega, pcm)
else
ener = mcscf_energy(chfx, hnuc, npos, offset, sqroffset,
& lfin, nfr, nc, ncorenew, exc, devparr, dft, embed,
& scfdamp, route, lwdfn,clrhfx,csrhfx,omega,pcm)
endif
case('aughessg', 'aughessl', 'aughessm', 'aughess ')
do
if(grad_max_norm .lt. eps .and. posdef) then
reject=.false.
call conjgrad(dcore(igrad), dcore(c_ptr), dcore(ikappa),
& dcore(ib), dcore(ib+qscfsize), dcore(ib+2*qscfsize),
& dcore(ib+3*qscfsize), dcore(ib+4*qscfsize),
& dcore(ib+5*qscfsize), dcore(idiag), dcore(ip2), npos,
& icore(iintpos), sqroffset, offset, nfr, qscfsize, lsa,
& delta_conjgrad, chfx, exc, step, lfin, embed, lwdfn,
& scfdamp, route, nc, ncorenew, devparr, ntmaxit, clrhfx,
& csrhfx, omega, pcm)
call trcoef(dcore(ikappa), dcore(c_ptr), sqroffset)
call build_dens(dcore(c_ptr), dcore(p_ptr), sqrsize,
& sqroffset)
ener = mcscf_energy(chfx, hnuc, npos, offset, sqroffset,
& lfin, nfr, nc, ncorenew, exc, devparr, dft, embed,
& scfdamp, route, lwdfn,clrhfx,csrhfx,omega,pcm)
else
reject = .true.
call mk_stepvector(dcore(ib), dcore(ibtr), dcore(igrad),
& dcore(idiag), dcore(iproj_hess), dcore(iproj_hess2),
& dcore(ikappa), dcore(iproj_kappa), ntmaxit, h, gn,
& dcore(ikappa_tr), lwork, peps, npos, sqroffset, offset,
& nfr, qscfsize, posdef, chfx, subspace_dim, delta, exc,
& itol, step, lfin, embed, lwdfn, scfdamp, route,
& nc, ncorenew, devparr, clrhfx, csrhfx, omega, pcm)
call trcoef(dcore(ikappa), dcore(c_ptr), sqroffset)
call build_dens(dcore(c_ptr), dcore(p_ptr), sqrsize,
& sqroffset)
call line_search(offset, sqroffset, hnuc, step, ener,
& oldener, gn, oldgn, dcore(ikappa), dcore(ioldkappa),
& dcore(ikappa_tr), dcore(c_ptr), dcore(igenfock),
& dcore(igrad), dcore(ip2), dcore(ip4), dcore(iq), chfx,
& qscf, h, reject, npos, lfin, nfr, nc, ncorenew, exc,
& devparr, dft, embed, scfdamp, route, lwdfn, .true.,
& dcore(ib), clrhfx, csrhfx, omega, pcm)
endif
if((reject .and. grad_max_norm .lt. delta) .or.
& .not. reject) exit
enddo
case('bfgs ')
call bfgs_h0(dcore(isvec), dcore(iyvec), dcore(ibfgs_h0),
& icore(ibfgs_vector_map), gn, h, dcore(idiag))
call lbfgs(dcore(igrad), dcore(ibfgs_h0), dcore(irho),
& dcore(isvec), dcore(iyvec), icore(ibfgs_vector_map),
& dcore(ikappa), dcore(imem))
call trcoef(dcore(ikappa), dcore(c_ptr), sqroffset)
call build_dens(dcore(c_ptr), dcore(p_ptr), sqrsize,
& sqroffset)
call line_search(offset, sqroffset, hnuc, step, ener,
& oldener, gn, oldgn, dcore(ikappa), dcore(ioldkappa),
& dcore(ikappa_tr), dcore(c_ptr), dcore(igenfock),
& dcore(igrad), dcore(ip2), dcore(ip4), dcore(iq), chfx,
& qscf, h, reject, npos, lfin, nfr, nc, ncorenew, exc,
& devparr, dft, embed, scfdamp, route, lwdfn, .false.,
& dcore(ib), clrhfx, csrhfx, omega, pcm)
call add_sy_pair(dcore(isvec), dcore(iyvec), dcore(irho),
& dcore(ikappa), dcore(ibfgs_oldkappa), dcore(igrad),
& dcore(ioldgrad), icore(ibfgs_vector_map))
end select
end subroutine
************************************************************************
subroutine mk_hessdiag(mofock, ifock, afock, qmat, qmat_rohf, p2,
& diag, sqroffset, offset)
************************************************************************
* Diagonal part of the Hessian matrix for preconditioning
************************************************************************
use common_mod, only: orbperir, nir, nfunc, sqrsize, sqrsize2,
& scftype
implicit none
integer sqroffset(nir), offset(nir)
integer k, ir, p, q, kos, n, i, a
integer dimir, noccir, nvirtir, nactir
integer oeintfile
double precision mofock(sqrsize2), diag(qscfsize), p2(nact, nact)
double precision ifock(sqrsize), afock(sqrsize)
double precision qmat(nbasis, nact)
double precision qmat_rohf(sqrsize)
parameter(oeintfile = 71)
double precision ddot
if(scftype .eq. 1 .or. scftype .eq. 2) then
k = 1
do n = 0, rmax
do ir = 1, nir
do i = 1, orbperir(ir+n*nir)
do a = orbperir(ir+n*nir)+1, nfunc(ir)
if(orbperir(ir+n*nir) .eq. nfunc(ir) .or.
& orbperir(ir+n*nir) .eq. 0) cycle
diag(k) = mofock(n*sqrsize+sqroffset(ir)+(nfunc(ir)+1)*
& (a-1)) - mofock(n*sqrsize+sqroffset(ir)+
& (nfunc(ir)+1)*(i-1))
k = k + 1
enddo
enddo
enddo
enddo
call dscal(qscfsize, 4.0d0, diag, 1)
elseif(scftype .ge. 3) then
k = 1
do ir = 1, nir
noccir = orbperir(ir)
nactir = nactperir(ir)
dimir = nfunc(ir)
nvirtir = dimir - noccir - nactir
c active - occupied part
do q = 1, noccir
do p = 1, nactir
diag(k) =
& 2.0d0*mofock(sqroffset(ir)+(noccir+p-1)*(dimir+1))-
& 2.0d0*mofock(sqroffset(ir)+(q-1)*(nfunc(ir)+1))+
& qmat_rohf(sqroffset(ir)+(noccir+p-1)*(dimir+1))
c & qmat_rohf(sqroffset(ir)+(p-1)*(nactir+1))
k = k + 1
enddo
enddo
c virtual - occupied part
do q = 1, noccir
do p = 1, nvirtir
diag(k) = 4.0d0*(
& mofock(sqroffset(ir)+(noccir+nactir+p-1)*(dimir+1))-
& mofock(sqroffset(ir)+(q-1)*(dimir+1)))
k = k + 1
enddo
enddo
c virtual - active part
do q = 1, nactir
do p = 1, nvirtir
diag(k) = 2.0d0*(mofock(sqroffset(ir)+
& (noccir+nactir+p-1)*(dimir+1))-
& mofock(sqroffset(ir)+(noccir+q-1)*(dimir+1)))+
& qmat_rohf(sqroffset(ir)+(noccir+q-1)*(dimir+1))
c & qmat_rohf(sqroffset(ir)+(q-1)*(nactir+1))
k = k + 1
enddo
enddo
enddo
else
kos = 1
do ir = 1, nir
noccir = orbperir(ir)
nactir = nactperir(ir)
dimir = nfunc(ir)
nvirtir = dimir - noccir - nactir
c active - occupied part
do q = 1, noccir
do p = 1, nactir
diag(kos+p-1+(q-1)*nactir) =
& 4.0d0*(ifock(sqroffset(ir)+(noccir+p-1)*(1+dimir))+
& afock(sqroffset(ir)+(noccir+p-1)*(1+dimir))-
& ifock(sqroffset(ir)+(q-1)*(dimir+1))-
& afock(sqroffset(ir)+(q-1)*(dimir+1)))+
& 2.0d0*p2(actoffset(ir)+p-1, actoffset(ir)+p-1)*
& (ifock(sqroffset(ir)+(q-1)*(dimir+1))+
& afock(sqroffset(ir)+(q-1)*(1+dimir)))-
& 2.0d0*(qmat(offset(ir)+noccir+p-1, p)+
& ddot(nactir, p2(actoffset(ir), actoffset(ir)+p-1), 1,
& ifock(sqroffset(ir)+noccir+(noccir+p-1)*dimir), 1))
enddo
enddo
c virtual - occupied
do q = 1, noccir
do p = 1, nvirtir
diag(kos+nactir*noccir+p-1+(q-1)*nvirtir) =
& -2.0d0*mofock(sqroffset(ir)+(q-1)*(1+dimir))+
& 4.0d0*(ifock(sqroffset(ir)+
& (noccir+nactir+p-1)*(dimir+1))+
& afock(sqroffset(ir)+(noccir+nactir+p-1)*(dimir+1)))
enddo
enddo
c virtual - active
do q = 1, nactir
do p = 1, nvirtir
diag(kos+(nactir+nvirtir)*noccir+p-1+(q-1)*nvirtir) =
& 2.0d0*p2(actoffset(ir)+q-1, actoffset(ir)+q-1)*(
& ifock(sqroffset(ir)+(nactir+noccir+p-1)*(dimir+1))+
& afock(sqroffset(ir)+(nactir+noccir+p-1)*(dimir+1)))-
& 2.0d0*(ddot(nactir, p2(actoffset(ir),actoffset(ir)+q-1),
& 1, ifock(sqroffset(ir)+noccir+(noccir+q-1)*dimir), 1)+
& qmat(offset(ir)+noccir+q-1, q))
enddo
enddo
kos = kos + (nactir+nvirtir)*noccir + nvirtir*nactir
enddo
endif
end subroutine
************************************************************************
subroutine mk_stepvector(b, btr, grad, diag, a, aa, x, xx, maxit,
& h, gn, res, lwork, peps, npos, sqroffset, offset, nfr,
& n, posdef, chfx, m, delta, exc, itol, step, lfin,
& embed, lwdfn, scfdamp, route, nc, ncorenew,
& devparr, clrhfx, csrhfx, omega, pcm)
************************************************************************
* Subroutine to calculate trust region step vector
************************************************************************
use common_mod, only: iout
implicit none
integer maxit, m, n, i, j, iw, ir
integer lwork, npos, sqrsize, info
integer sqroffset(nir), offset(nir), restart_vec
double precision clrhfx,csrhfx,omega
double precision b(n, maxit), grad(n), diag(n)
double precision a(maxit, maxit), aa(maxit+1, maxit+1), x(n)
double precision alpha, mu, h, peps, btr(n, maxit), xx(maxit)
double precision res(n), res_norm, gn, chfx, exc, itol
double precision k, delta, errbd
logical cond, posdef, lsa, restart
parameter (k = 5.0d-3, restart_vec = 2)
integer lfin,nfr,nc,ncorenew,step
double precision devparr(2)
character*4 route
character*16 scfdamp
character*32 pcm
logical lwdfn
character*8 embed
integer dblalloc, idamax
double precision dnrm2
write(iout,"(1x,70('*'))")
write(iout,"(1X,'Calculating trust region step...')")
iw = dblalloc(maxit+1)
if(m .eq. 0) then
write(iout,"(1X,'Calculating initial trial vectors...')")
b(1:n, 1:maxit) = 0.0d0
btr(1:n, 1:maxit) = 0.0d0
call init_trial_vector(b, btr, n, grad, diag, b(1, 4), nbasis,
& npos, sqroffset, offset, nfr, n, chfx, exc, step, lfin,
& embed, lwdfn, scfdamp, route, nc, ncorenew,
& devparr, clrhfx, csrhfx, omega, pcm)
m = 2
restart = .false.
else
write(iout, "(1X,A)")
& 'Restarting trust region method from previous subspace'
m = min(restart_vec, m-1)
restart = .true.
endif
c write(*,"(1X,'Trust radius: ', F12.9)") h
cond = .true.
call dcopy(n, b(1, 2), 1, b(1, 3), 1)
do while(m .lt. maxit .and. cond)
if(restart) then
restart = .false.
else
call build_red_hessian(b, btr, a, maxit, m, n)
endif
call aug_hess_method(a, maxit, grad, h, m, xx, alpha, mu, aa,
& maxit+1, gn, dcore(imem), lwork, dcore(iw))
c calculating the approximate solution x and H*x
call dgemv('n', n, m, 1.0d0, b, n, xx, 1, 0.0d0, x, 1)
call dgemv('n', n, m, 1.0d0, btr, n, xx, 1, 0.0d0, res, 1)
call new_trial_vector(b, btr, n, grad, x, diag, res,dcore(imem),
& mu, alpha, m, npos, sqroffset, offset, nfr, n, chfx, exc,
& step, lfin, embed, lwdfn, scfdamp, route, nc,
& ncorenew, devparr, clrhfx, csrhfx, omega, pcm)
c check for convergence
i = idamax(n, res, 1)
res_norm = dabs(res(i))
if(res_norm .lt. delta) cond = .false.
write(iout,"(1X,'Microiteration',I5,9X,
& 'Norm of the residual vector: ',ES12.5E2)") m-1, res_norm
m = m + 1
enddo
if(m .eq. maxit .and. cond) then
write(iout,"('ERROR: Trust region method failed to converge!')")
write(iout,"('Norm of final residual vector: ',ES15.8E2)")
& res_norm
call mrccend(1)
else
write(iout,"(' Trust region step has converged!')")
endif
write(iout,"(1x,70('*'))")
c Check the definiteness of the Hessian
aa = 0.0d0
do i = 1, m-1
do j = 1, m-1
aa(i, j) = a(i, j)
enddo
enddo
call dsyev('n', 'u', m-1, aa, maxit+1, res, dcore(imem), lwork,
& info)
c Bauer-Fike
errbd=mat_one_norm(aa,maxit+1,m-1,m-1)*
& mat_inf_norm(aa,maxit+1,m-1,m-1)*itol*dble(m-1)*1.0d-2
if(res(1) .lt. -errbd) then
posdef = .false.
else
posdef = .true.
endif
c The res vector stores the H*x product (needed for line search)
call dgemv('n', n, m-1, 1.0d0, btr, n, xx, 1, 0.0d0, res, 1)
call dbldealloc(iw)
end subroutine
************************************************************************
double precision function mat_one_norm(mat,lda,n,m) result(norm)
************************************************************************
* Calculates the 1-norm of the matrix mat
************************************************************************
implicit none
integer n,m,lda,i,j
double precision mat(lda,m),x
if(n.eq.0 .or. m.eq.0) then
norm=0.0d0
return
endif
x=0.0d0
norm=0.0d0
do i=1,m
norm=norm+dabs(mat(1,i))
enddo
do j=2,n
x=0.0d0
do i=1,m
x=x+dabs(mat(j,i))
enddo
if(x.gt.norm) norm=x
enddo
return
end function
************************************************************************
double precision function mat_inf_norm(mat,lda,n,m) result(norm)
************************************************************************
* Calculates the infinity norm of the matrix mat
************************************************************************
implicit none
integer n,m,lda,i,j
double precision mat(lda,m),x
if(n.eq.0 .or. m.eq.0) then
norm=0.0d0
return
endif
x=0.0d0
norm=0.0d0
do i=1,n
norm=norm+dabs(mat(i,1))
enddo
do j=2,m
x=0.0d0
do i=1,n
x=x+dabs(mat(i,j))
enddo
if(x.gt.norm) norm=x
enddo
return
end function
************************************************************************
subroutine new_trial_vector(b, btr, ldb, grad, x, diag, res, tmp,
& mu, alpha, m, npos, sqroffset, offset, nfr, n, chfx,
& exc, step, lfin, embed, lwdfn, scfdamp, route, nc,
& ncorenew, devparr, clrhfx, csrhfx, omega, pcm)
************************************************************************
* Subroutine to calculate new trial vector for augemented Hessian method
************************************************************************
implicit none
integer ldb, m, n, i, sqroffset(nir), offset(nir),npos,step
double precision b(ldb, *), grad(n), diag(n)
double precision tmp(*), x(n), btr(ldb, *)
double precision res(n), mu, alpha, chfx, exc
double precision clrhfx,csrhfx,omega
integer lfin,nfr,nc,ncorenew
double precision devparr(2)
character*4 route
character*16 scfdamp
character*32 pcm
logical lwdfn
character*8 embed
call daxpy(n, -mu, x, 1, res, 1)
call daxpy(n, 1.0d0, grad, 1, res, 1)
call dcopy(n, res, 1, b(1, m+1), 1)
do i = 1, n
b(i, m+1) = b(i, m+1)/(diag(i) - mu)
enddo
call gsch(b(1, 1), b(1, m+1), tmp, ldb, n, m)
call lintr(b(1, m+1), btr(1, m+1), grad, offset, sqroffset, n,
& npos, chfx, exc, step, .false., lfin, embed, lwdfn,
& scfdamp, route, nfr, nc, ncorenew, devparr, clrhfx, csrhfx,
& omega, pcm)
end subroutine
************************************************************************
subroutine aug_hess_method(a, lda, grad, h, n, x, alpha, mu,
& aa, ldaa, gn, work, lwork, w)
************************************************************************
* Augemented Hessian method
************************************************************************
use common_mod, only: iout
implicit none
integer lda, n, ldaa, lwork, idx, phase, i, ord(n+1), ipiv(n+1)
integer info
double precision a(lda, *), x(*), grad(*), h, deth, deth2
double precision aa(ldaa, *), w(*), x_norm2, lvlshift
double precision mu, alpha, gn, oldalpha, mu1, lvlshift2
double precision delta, tol_low, tol_up, dtol, eps, work(*)
double precision alpha1, alpha2, x_norm, oldx_norm, hc
logical cond
parameter (delta = 1.0d-16, eps = 1.0d-5)
double precision dnrm2
integer*4 isyev
equivalence(isyev,info)
tol_low = h*0.9d0
tol_up = h
dtol = tol_up - tol_low
cond = .true.
phase = 1
idx = 1
alpha1 = 0.0d0
alpha2 = 1.0d1
alpha = alpha2
oldx_norm = -1.0d0
oldalpha = -1.0d0
aa(1:n, 1:n) = a(1:n, 1:n)
call dsyev('v', 'u', n, aa, ldaa, w, work, lwork, info)
hc = gn*aa(1, idx)
if(w(idx) .gt. 0.0d0) then
lvlshift = w(idx)
do i = 1, n
a(i, i) = a(i, i) - lvlshift
enddo
else
lvlshift = 0.0d0
endif
if(w(idx+1) .gt. 0.0d0) then
lvlshift2 = w(idx+1)
else
lvlshift2 = 0.0d0
endif
if(hc .lt. 1.0d-14) then
alpha = 1.0d-20
call mk_ah(a, lda, aa, ldaa, n, gn, alpha)
call dsyev('v', 'u', n+1, aa, ldaa, w, work, lwork, info)
if(isyev .ne. 0) then
write(iout,*) 'error hard case diagonaliztation', isyev
call mrccend(1)
endif
call dscal(n, 1.0d0/(aa(1, idx)*alpha), aa(2, idx), 1)
x_norm = dnrm2(n, aa(2, idx), 1)
if(x_norm .lt. tol_low) then
do i = 1, n
a(i, i) = a(i, i) + lvlshift - lvlshift2
enddo
lvlshift = lvlshift2
idx = idx + 1
endif
endif
alpha = alpha2
do while(cond)
call mk_ah(a, lda, aa, ldaa, n, gn, alpha)
call dsyev('v', 'u', n+1, aa, ldaa, w, work, lwork, info)
if(isyev .ne. 0) then
write(iout,*) 'error diagonalization', isyev
write(iout,*) 'alpha', alpha, 'idx', idx, 'n', n
call mrccend(1)
endif
c bisection search
call dscal(n, 1.0d0/(aa(1, idx)*alpha), aa(2, idx), 1)
x_norm = dnrm2(n, aa(2, idx), 1)
select case(phase)
case(1)
if(x_norm .gt. tol_low .and. x_norm .lt. tol_up) then
call dcopy(n, aa(2, idx), 1, x, 1)
cond = .false.
elseif(x_norm .lt. h) then
oldalpha = alpha
alpha = alpha1 - 0.5d0*(alpha1 - alpha2)
phase = 2
else
oldalpha = alpha
alpha1 = alpha2
alpha2 = 1.5d0*alpha2
alpha = alpha2
endif
case(2)
if(x_norm .lt. tol_up .and. x_norm .gt. tol_low) then
call dcopy(n, aa(2, idx), 1, x, 1)
cond = .false.
elseif(x_norm .gt. h) then
oldalpha = alpha
alpha1 = alpha
alpha = alpha1 - 0.5d0*(alpha1 - alpha2)
else
oldalpha = alpha
alpha2 = alpha
alpha = alpha1 - 0.5d0*(alpha1 - alpha2)
endif
end select
if(cond) then
if(alpha .gt. 1.0d40 .or. alpha .lt. 1.0d-40 .or.
& dabs(alpha-oldalpha) .le. 1.0d-40)then
if(idx .le. n) then
idx = idx + 1
else
write(iout,*) 'cannot find solution'
call mrccend(1)
endif
alpha1 = 0.0d0
alpha2 = 1.0d-2
alpha = alpha2
phase = 1
x_norm = -1.0d0
oldalpha = -1.0d0
endif
oldx_norm = x_norm
endif
enddo
mu = w(idx) + lvlshift
if(lvlshift .ne. 0.0d0) then
do i = 1, n
a(i, i) = a(i, i) + lvlshift
enddo
endif
end subroutine
************************************************************************
subroutine mk_ah(h, ldh, ah, ldah, n, gn, alpha)
************************************************************************
* Subroutine to build the augmented Hessian matrix
************************************************************************
implicit none
integer ldh, ldah, n, i
double precision h(ldh, *), ah(ldah, *), gn, alpha
ah(1:n+1, 1:n+1) = 0.0d0
do i = 1, n
call dcopy(i, h(1, i), 1, ah(2, i+1), 1)
enddo
ah(1, 2) = alpha*gn
end subroutine
************************************************************************
subroutine build_red_hessian(b, btr, a, lda, m, n)
************************************************************************
* Building reduced Hessian matrix
************************************************************************
implicit none
integer lda, n, m, i, j
double precision b(n, *), a(lda, *), btr(n,*)
double precision ddot
if(m .eq. 2) then
do i = 1, 2
do j = i, 2
a(i, j) = ddot(n, btr(1, i), 1, b(1, j), 1)
a(j, i) = a(i, j)
enddo
enddo
else
do i = 1, m
a(i, m) = ddot(n, btr(1, m), 1, b(1, i), 1)
a(m, i) = a(i, m)
enddo
endif
end subroutine
************************************************************************
subroutine init_trial_vector(b, btr, ldb, grad, diag, tmp, nbasis,
& npos, sqroffset, offset, nfr, n, chfx, exc, step, lfin,
& embed, lwdfn, scfdamp, route, nc, ncorenew,
& devparr, clrhfx, csrhfx, omega, pcm)
************************************************************************
* Initial trial vectors for trust region calculation
************************************************************************
implicit none
integer ldb, m, n, nbasis, i, j, npos
integer sqroffset(nir), offset(nir)
integer imem, step
double precision clrhfx,csrhfx,omega
double precision b(ldb, *), grad(n), diag(n), tmp(*), btr(ldb, *)
double precision dnrm2, chfx, exc
integer lfin,nfr,nc,ncorenew
double precision devparr(2)
character*4 route
character*16 scfdamp
character*32 pcm
logical lwdfn
character*8 embed
c first trial vector
call daxpy(n, 1.0d0/dnrm2(n, grad, 1), grad, 1, b(1, 1), 1)
c second trial vector
call lintr(b(1, 1), b(1, 2), grad, offset, sqroffset, n, npos,
& chfx, exc, step, .false., lfin, embed, lwdfn,
& scfdamp, route, nfr, nc, ncorenew, devparr, clrhfx, csrhfx,
& omega, pcm)
call dcopy(n, b(1, 2), 1, btr(1, 1), 1)
call daxpy(n, 1.0d0, grad, 1, b(1, 2), 1)
call dscal(n, -1.0d0, b(1, 2), 1)
call gsch(b, b(1, 2), tmp, ldb, n, 1)
call lintr(b(1, 2), btr(1, 2), grad, offset, sqroffset, n, npos,
& chfx, exc, step, .false., lfin, embed, lwdfn,
& scfdamp, route, nfr, nc, ncorenew, devparr, clrhfx, csrhfx,
& omega, pcm)
c third trial vector
c j = 1
c mv = diag(j)
c do i = 2, n
c if(diag(i) .lt. mv) then
c j = i
c mv = diag(j)
c endif
c enddo
c b(1:n, 3) = 0.0d0
c b(j, 3) = 1.0d0
c call gsch(b, b(1, 3), tmp, ldb, n, 2)
end subroutine
************************************************************************
subroutine minres(b, btr, grad, diag, a, aa, x, xx, maxit,
& h, gn, res, lwork, peps, npos, sqroffset, offset, nfr,
& n, posdef, chfx, m, delta, exc, step, lfin, embed,
& lwdfn, scfdamp, route, nc, ncorenew, devparr, clrhfx,
& csrhfx, omega, pcm)
************************************************************************
use common_mod, only: iout
implicit none
integer maxit, m, n, i, j, iw, ir, k
integer lwork, npos, sqrsize, info, step
integer sqroffset(nir), offset(nir), restart_vec
double precision clrhfx,csrhfx,omega
double precision b(n, maxit), grad(n), diag(n)
double precision a(maxit, maxit), aa(maxit+1, maxit+1), x(n)
double precision mu, h, peps, btr(n, maxit), xx(maxit)
double precision res(n), res_norm, gn, chfx, exc
double precision delta
double precision beta(maxit+1), alpha(maxit+1)
double precision tmat(maxit+1, maxit+1), norm_mat(maxit+1)
logical cond, posdef, lsa, restart
parameter (restart_vec = 2)
integer lfin,nfr,nc,ncorenew
double precision devparr(2)
character*4 route
character*16 scfdamp
character*32 pcm
logical lwdfn
character*8 embed
integer idamax
double precision dnrm2
write(iout,"(1X,'Calculating Newton-step with minres...')")
m = 0
btr = 0.0d0
tmat = 0.0d0
norm_mat = 0.0d0
call dcopy(qscfsize, grad, 1, btr, 1)
call new_lanczos_vec(b, grad, btr(1, 1), btr(1, 2), btr(1, 3),
& beta, alpha, diag, m, maxit, offset, sqroffset, chfx, npos,
& exc, step, lfin, embed, lwdfn, scfdamp, route, nfr, nc,
& ncorenew, devparr, clrhfx, csrhfx, omega, pcm)
norm_mat(m+1) = dnrm2(qscfsize, b(1, m+1), 1)
m = m + 1
call new_lanczos_vec(b, grad, btr(1, 1), btr(1, 2), btr(1, 3),
& beta, alpha, diag, m, maxit, offset, sqroffset, chfx, npos,
& exc, step, lfin, embed, lwdfn, scfdamp, route, nfr, nc,
& ncorenew, devparr, clrhfx, csrhfx, omega, pcm)
norm_mat(m+1) = dnrm2(qscfsize, b(1, m+1), 1)
k = 1
do
write(iout,'(1X,"Iteration", I4)') k
c Building scaled T matrix
tmat = 0.0d0
tmat(1, 1) = alpha(1) / norm_mat(1)
tmat(2, 1) = beta(1) / norm_mat(2)
do i = 2, m
tmat(i, i-1) = beta(i-1) / norm_mat(i-1)
tmat(i, i) = alpha(i) / norm_mat(i)
tmat(i, i+1) = beta(i+1) / norm_mat(i+1)
enddo
write(iout,*) 'tmat'
call prmx(tmat, m+1, m, m)
c Forming right hand side
xx = 0.0d0
xx(1) = norm_mat(1)
c Solving least square problem
call dgels('n', m+1, m, 1, tmat, maxit+1, xx, m+1, dcore(imem),
& lwork, info)
c Calculate residual vector
c Building original T matrix
tmat(1, 1) = alpha(1)
tmat(2, 1) = beta(1)
do j = 2, m
tmat(i, i-1) = beta(i-1)
tmat(i, i) = alpha(i)
tmat(i, i+1) = beta(i+1)
enddo
call dgemv('n', m+1, m, 1.0d0, tmat, maxit+1, xx, 1, 0.0d0,
& dcore(imem), 1)
call dgemv('n', qscfsize, m+1, 1.0d0, b, qscfsize,
& dcore(imem), 1, 0.0d0, res, 1)
c Check norm of the residual
i = idamax(qscfsize, res, 1)
write(iout,"(1X,'Norm of the residual:',ES15.8E2)") dabs(res(i))
write(iout,"(1X,70('*'))")
if(dabs(res(i)) .lt. 1.0d-7) then
c Calculate approximate solution in the original space
call dgemv('n', qscfsize, m, 1.0d0, b, qscfsize, xx, 1, 0.0d0,
& x, 1)
exit
endif
m = m + 1
call new_lanczos_vec(b, grad, btr(1, 1), btr(1, 2), btr(1, 3),
& beta, alpha, diag, m, maxit, offset, sqroffset, chfx, npos,
& exc, step, lfin, embed, lwdfn, scfdamp, route, nfr, nc,
& ncorenew, devparr, clrhfx, csrhfx, omega, pcm)
k = k + 1
enddo
end subroutine
************************************************************************
subroutine new_lanczos_vec(q, grad, t, w, w2, beta, alpha, diag,
& m, maxit, offset, sqroffset, chfx, npos, exc, step, lfin,
& embed, lwdfn, scfdamp, route, nfr, nc, ncorenew, devparr,
& clrhfx, csrhfx, omega, pcm)
************************************************************************
implicit none
integer m, offset(nir), sqroffset(nir), i, npos, maxit, step
double precision clrhfx,csrhfx,omega
double precision t(qscfsize), w(qscfsize), w2(qscfsize)
double precision diag(qscfsize), exc
double precision q(qscfsize, maxit), grad(qscfsize)
double precision beta(maxit-1), alpha(maxit), chfx
integer lfin,nfr,nc,ncorenew
double precision devparr(2)
character*4 route
character*16 scfdamp
character*32 pcm
logical lwdfn
character*8 embed
double precision ddot
c Preconditioning
do i = 1, qscfsize
q(i, m+1) = t(i) / diag(i)
enddo
c New basis vector: q = D^{-1}*t / beta
beta(m+1) = dsqrt(ddot(qscfsize, t, 1, q(1, m+1), 1))
call dscal(qscfsize, 1/beta(m+1), q(1, m+1), 1)
c New w vector: w = t / beta
w2 = t
call dscal(qscfsize, 1/beta(m+1), w2, 1)
c Calculating H*q
call lintr(q(1, m+1), t, grad, offset, sqroffset, qscfsize,
& npos, chfx, exc, step, .false., lfin, embed, lwdfn,
& scfdamp, route, nfr, nc, ncorenew, devparr, clrhfx, csrhfx,
& omega, pcm)
c alpha = q*H*q
alpha(m+1) = ddot(qscfsize, q(1, m+1), 1, t, 1)
c New t: t = H*q - alpha*w2 - beta*w
call daxpy(qscfsize, -alpha(m+1), w2, 1, t, 1)
call daxpy(qscfsize, -beta(m+1), w, 1, t, 1)
w = w2
return
c call lintr(q(1, m), q(1, m+1), grad, offset, sqroffset, qscfsize,
c & npos, chfx, vint)
c call daxpy(qscfsize, -beta(m-1), q(1, m-1), 1, q(1, m+1), 1)
c alpha(m) = ddot(qscfsize, q(1, m), 1, q(1, m+1))
c call daxpy(qscfsize, -alpha(m), q(1, m), 1, q(1, m+1), 1)
c beta(m) = dnrm2(qscfsize, q(1, m+1), 1)
c call daxpy(qscfsize, 1/beta(m), q(1, m+1), 1)
end subroutine
************************************************************************
double precision function mcscf_energy(chfx, hnuc, npos, offset,
& sqroffset, lfin, nfr, nc, ncorenew, exc, devparr, dft, embed,
& scfdamp, route, lwdfn,clrhfx,csrhfx,omega,pcm) result(ener)
************************************************************************
* MCSCF energy and generalized Fock matrix caclulation
************************************************************************
use common_mod, only: sqrsize, sqrsize2, scftype, qmat_ptr
implicit none
integer sqroffset(nir), offset(nir), npos
integer ir, p, q, ihcore, r, itmp, i, j
double precision hnuc, chfx, ener2,clrhfx,csrhfx,omega
integer lfin, nfr, nc, ncorenew
double precision exc, devparr(2)
character*32 dft,pcm
character*8 embed
character*16 scfdamp
character*4 route
logical lwdfn
integer dblalloc
ihcore = dblalloc(sqrsize2)
c Building generalized Fock matrix
call mk_genfock(sqroffset, offset, dcore(ip2), dcore(ip4),
& dcore(igenfock), dcore(iq), dcore(ihcore), scftype, npos,
& chfx, lfin, nfr, nc, ncorenew, exc, devparr, dft, embed,
& scfdamp, route, lwdfn, hnuc,clrhfx,csrhfx,omega,pcm)
ener = 0.0d0
select case(scftype)
case(0) ! MCSCF
do ir = 1, nir
do p = 1, nfunc(ir)
ener = ener + dcore(igenfock+sqroffset(ir)-1+
& (p-1)*(nfunc(ir)+1))
enddo
do p = 1, orbperir(ir)
ener = ener + 2.0d0*dcore(ihcore+sqroffset(ir)-1+
& (p-1)*(nfunc(ir)+1))
enddo
do p = 1, nactperir(ir)
do q = 1, nactperir(ir)
ener = ener + dcore(ip2+actoffset(ir)-1+p-1 +
& (actoffset(ir)+q-2)*nact)*
& dcore(ihcore+sqroffset(ir)-1+orbperir(ir)+p-1+
& (orbperir(ir)+q-1)*nfunc(ir))
enddo
enddo
enddo
ener = 0.5d0*ener + hnuc
case(3,4,5) ! ROHF
if(trim(dft).eq.'off'.and.trim(pcm).eq.'off') then
do ir = 1, nir
do p = 1, nfunc(ir)
ener = ener + dcore(igenfock+sqroffset(ir)-1+
& (p-1)*(nfunc(ir)+1))
enddo
do p = 1, orbperir(ir)
ener = ener + 2.0d0*dcore(ihcore+sqroffset(ir)-1+
& (p-1)*(nfunc(ir)+1))
enddo
do p = 1, nactperir(ir)
ener = ener +
& dcore(ihcore+sqroffset(ir)-1+orbperir(ir)+p-1+
& (orbperir(ir)+p-1)*nfunc(ir))
enddo
enddo
ener = 0.5d0*ener + hnuc
else
do ir = 1, nir
do p = 1, nactperir(ir)
ener = ener - 0.25d0*
& dcore(qmat_ptr+sqroffset(ir)-1+orbperir(ir)+p-1+
& (orbperir(ir)+p-1)*nfunc(ir))
enddo
do p = 1, orbperir(ir)
ener = ener + 2.0d0*dcore(ihcore+sqroffset(ir)-1+
& (p-1)*(nfunc(ir)+1))
enddo
do p = 1, nactperir(ir)
ener = ener +
& dcore(ihcore+sqroffset(ir)-1+orbperir(ir)+p-1+
& (orbperir(ir)+p-1)*nfunc(ir))
enddo
enddo
ener = ener + exc + hnuc
endif
case(1, 2) ! RHF/UHF
if(trim(dft).eq.'off'.and.trim(pcm).eq.'off') then
do r = 0, rmax
do ir = 1, nir
do p = 1, orbperir(ir+r*nir)
ener = ener +
& dcore(igenfock+r*sqrsize+
& sqroffset(ir)-1+(p-1)*(nfunc(ir)+1))+
& dcore(ihcore+r*sqrsize+
& sqroffset(ir)-1+(p-1)*(nfunc(ir)+1))
enddo
enddo
enddo
if(scftype .eq. 1) then
ener = ener + hnuc
else
ener = 0.5*ener + hnuc
endif
else
do r = 0, rmax
do ir = 1, nir
do p = 1, orbperir(ir+r*nir)
ener = ener +
& dcore(ihcore+r*sqrsize+sqroffset(ir)-1+
& (p-1)*(nfunc(ir)+1))
enddo
enddo
enddo
if(scftype .eq. 1) then
ener = 2.0d0*ener + exc + hnuc
else
ener = ener + exc + hnuc
endif
endif
end select
call dbldealloc(ihcore)
return
end function
************************************************************************
subroutine qscf_alloc(qscf,ndocc,nsocc,nvirt,nooccfl,nal,nbe)
************************************************************************
* Allocate memory for QSCF and MCSCF calculations
************************************************************************
use common_mod, only : fock_ptr, scfmaxit, sqrsize2, dfbasis_scf,
& qmat_ptr, iout
implicit none
character*8 qscf,cbfgsmem
integer nvirtir, ir, r, isym, imult, i, memsize, nal, nbe, nelec
integer nvirt
integer nsocc, ndocc
integer dblalloc
character*(4) mult, sym, maxmicroit
logical nooccfl
integer multpg(8,8)
data multpg /1,2,3,4,5,6,7,8,
$ 2,1,4,3,6,5,8,7,
$ 3,4,1,2,7,8,5,6,
$ 4,3,2,1,8,7,6,5,
$ 5,6,7,8,1,2,3,4,
$ 6,5,8,7,2,1,4,3,
$ 7,8,5,6,3,4,1,2,
$ 8,7,6,5,4,3,2,1/
integer intalloc
iocc_num = dblalloc(0)
ieigval2 = dblalloc(0)
if(nooccfl) then
if(scftype .eq. 2) then
memsize=nal*(nbasis-nal)+nbe*(nbasis-nbe)
else
memsize=nsocc*ndocc+nsocc*nvirt+nvirt*ndocc
endif
else
memsize = qscfsize
endif
call getkey('maxmicroit',10,maxmicroit,4)
read(maxmicroit,*) ntmaxit
ntmaxit = ntmaxit + 2
ifock_ptr = fock_ptr ! Inactive Fock matrix
afock_ptr = fock_ptr + sqrsize ! Active Fock matrix
igrad = dblalloc(memsize)
ikappa = dblalloc(memsize)
ikappa_tr = dblalloc(memsize)
idiag = dblalloc(memsize)
ip4 = dblalloc(nact**4) ! 2-electron (4 index) density
ip2 = dblalloc(nact**2) ! 1-electron (2 index) density
if(scftype .eq. 0) then
iq = dblalloc(nbasis*nact) ! Q matrix
endif
if(qscf .ne. 'bfgs ') then
iproj_kappa = dblalloc(ntmaxit)
iproj_hess = dblalloc(ntmaxit*ntmaxit) ! projected Hessian
iproj_hess2 = dblalloc((ntmaxit+1)*(ntmaxit+1)) ! projected augemented Hessian
endif
if(qscf .ne. 'newton ' .and. qscf .ne. 'bfgs ') then
ioldkappa = dblalloc(memsize)
ib = dblalloc(memsize*(ntmaxit))
ibtr = dblalloc(memsize*(ntmaxit))
elseif(qscf .eq. 'bfgs ') then
ioldkappa = dblalloc(memsize)
ib = dblalloc(memsize)
ibtr = dblalloc(0)
else
ioldkappa = dblalloc(0)
ib = dblalloc(6*memsize)
ibtr = dblalloc(0)
endif
if(scftype .eq. 0) igenfock = dblalloc(sqrsize)
c BFGS
if(qscf .eq. 'bfgs ') then
call getkey('bfgsmem',7,cbfgsmem,8)
read(cbfgsmem,*) bfgs_max_pairs
bfgs_step = 0
isvec = dblalloc(memsize*bfgs_max_pairs)
iyvec = dblalloc(memsize*bfgs_max_pairs)
irho = dblalloc(bfgs_max_pairs)
ibfgs_h0 = dblalloc(memsize)
bfgs_pairs = 0
ibfgs_vector_map = intalloc(bfgs_max_pairs)
ioldgrad = dblalloc(memsize)
ibfgs_oldkappa = dblalloc(memsize)
call dfillzero(dcore(ioldgrad),memsize)
call dfillzero(dcore(ibfgs_oldkappa),memsize)
endif
c Calculate reference determinant for the CI program
if(scftype .eq. 0) then
iocc_num = dblalloc(nbasis)
ieigval2 = dblalloc(nbasis)
irefdet = intalloc(nact)
call getkey('symm', 4, sym, 4)
call getkey('mult', 4, mult, 4)
isym = 1
if(sym .eq. 'off ') then
continue
elseif(sym .ne. ' ') then
read(sym,*) isym
if(isym .eq. 0) isym = 1
else
write(iout,'(A)')
& " WARNING: THE SYMM KEYWORD IS NOT SET BY THE USER"
write(iout,'(" ASSUMING SYMM=1")')
endif
read(mult,*) imult
call refdet(imult, isym, multpg, icore(irefdet))
endif
end subroutine
************************************************************************
subroutine qscf_init(qscf)
************************************************************************
* initialize module variables
************************************************************************
use common_mod, only : fock_ptr, scfmaxit, sqrsize2, dfbasis_scf,
& rmat_ptr, qmat_ptr
implicit none
character*8 qscf,cbfgsmem
integer nvirtir, ir, r, isym, imult, i
integer nvirt, nal, nbe, nelec, memsize
integer dblalloc
character*(4) mult, sym
integer multpg(8,8)
data multpg /1,2,3,4,5,6,7,8,
$ 2,1,4,3,6,5,8,7,
$ 3,4,1,2,7,8,5,6,
$ 4,3,2,1,8,7,6,5,
$ 5,6,7,8,1,2,3,4,
$ 6,5,8,7,2,1,4,3,
$ 7,8,5,6,3,4,1,2,
$ 8,7,6,5,4,3,2,1/
integer intalloc
c Density fitting?
call getkey('dfbasis_scf',11,dfbasis_scf,20)
ldf = dfbasis_scf .ne. 'none '
call getkey('mult', 4, mult, 4)
read(mult,*) multiplicity
call getkey('dft',3,dft,32)
if(scftype .eq. 0 .or. scftype .eq. 1 .or. scftype .ge. 3) then
rmax = 0
elseif(scftype .eq. 2) then
rmax = 1
endif
rmaxp1 = rmax + 1
if(scftype .ge. 3) then
nact = 0
do ir = 1, nir
if(nfunc(ir).eq.0) then
nactperir(ir) = 0
else
nactperir(ir) = orbperir(ir+nir)
nact = nact + orbperir(ir+nir)
endif
enddo
actoffset(1) = 1
do ir = 2, nir
actoffset(ir) = actoffset(ir-1) + nactperir(ir-1)
enddo
elseif(scftype .ne. 0) then
nactperir = 0
endif
qscfsizevec = 0
do r = 0, rmax
do ir = 1, nir
nvirtir = nfunc(ir) - orbperir(ir+r*nir) - nactperir(ir)
qscfsizevec(r+1) = qscfsizevec(r+1) +
& (nactperir(ir) + nvirtir)*orbperir(ir+r*nir) +
& nvirtir*nactperir(ir)
enddo
enddo
qscfsize = qscfsizea + qscfsizeb
do r = 0, rmax
vecoffset(r*nir+1) = 1
do ir = 2, nir
nvirtir = nfunc(ir-1) - orbperir(ir-1+r*nir) - nactperir(ir-1)
vecoffset(ir+r*nir) = vecoffset(ir-1+r*nir) +
& (nactperir(ir-1) + nvirtir)*orbperir(ir-1+r*nir) +
& nactperir(ir-1)*nvirtir
enddo
enddo
if(scftype .ne. 0) then
if(scftype .ge. 3) then
grad_scale = -2.0d0
else
grad_scale = -4.0d0
endif
else
grad_scale = -2.0d0
endif
ifock_ptr = fock_ptr ! Inactive Fock matrix
afock_ptr = fock_ptr + sqrsize ! Active Fock matrix
if(scftype .ge. 3) iq = qmat_ptr
if(scftype .ne. 0) igenfock = ifock_ptr
end subroutine
************************************************************************
subroutine mk_genfock(sqroffset, offset, p2, p4, genfock, q,
& hcore, scftype, npos, chfx, lfin, nfr, nc, ncorenew,
& exc, devparr, dft, embed, scfdamp, route, lwdfn, hnuc,
& clrhfx,csrhfx,omega,pcm)
************************************************************************
* building generalized Fock matrix
************************************************************************
use common_mod, only: indexirrep_ptr, symdens_ptr, symdens2_ptr,
& symfock_ptr, symfock2_ptr, verblevel, sqrsize, sqrsize2,
& symqmat_ptr, qmat_ptr, sorig_ptr, rmat_ptr, rs_ptr
implicit none
integer offset(nir), sqroffset(nir), npos, scftype, idx
double precision chfx,clrhfx,csrhfx,omega
double precision p2(nact, nact), p4(nact, nact, nact, nact)
double precision genfock(nbasis*nbasis), q(nbasis*nact), hnuc
double precision hcore(sqrsize), ener
integer isymfock_ptr, asymfock_ptr ! (in)active Fock without symmtery (nbasis**2)
integer iap, imoint, iip, oeintfile
integer extr_c ! Full C extracted from symmetry basis
integer i, j, k, l, teintf(10), ir, r, ihcore, ic_act
integer fort55, nvirtir
parameter(fort55 = 55)
integer dblalloc
parameter(oeintfile = 71)
c things for the fock_build
integer lfin, nfr, nc, ncorenew
double precision exc, devparr(2)
character*32 dft,pcm
character*8 embed
character*16 scfdamp
character*4 route
logical lwdfn
integer idamax
isymfock_ptr = symfock_ptr
if(lsa) then
asymfock_ptr = symfock2_ptr
else
asymfock_ptr = afock_ptr
endif
iip = symdens_ptr ! density matrix
iap = symdens2_ptr
C HARTREE-FOCK CALCULATION
if(scftype .eq. 1 .or. scftype .eq. 2) then
C WARNING: THIS LOOP ASSUMES THAT SYMDENS2_PTR FOLLOWS
C SYMDENS_PTR, THAT IS, SYMDENS2_PTR - SYMDENS_PTR = NBASIS**2
do r = 0, rmax
call mxto(dcore(iip+r*nbasis**2), dcore(symtra_ptr),
& dcore(isymfock_ptr), nbasis, dcore(p_ptr+r*sqrsize),
& offset, lsa)
enddo
call dfillzero(dcore(isymfock_ptr), nbasis**2)
if(scftype .eq. 2) call dfillzero(dcore(asymfock_ptr),nbasis**2)
call fock_build(dcore(iip), dcore(iap), dcore(isymfock_ptr),
& dcore(asymfock_ptr), dcore(imem), dcore(indexirrep_ptr),
& offset, sqroffset, npos, icore(iintpos), 2, dcore(c_ptr),
& lfin, exc, dft, chfx, lwdfn, embed, scfdamp, route, nfr,nc,
& ncorenew, devparr, dcore(symtra_ptr), 0,clrhfx,csrhfx,
& omega, dcore(rs_ptr), .false., 1, 1, pcm, dcore, dcore,
& .false.)
C SAME WARNING AS ABOVE BUT FOR SYMFOCK_PTR AND SYMFOCK2_PTR
do r = 0, rmax
call mxts(dcore(isymfock_ptr+r*nbasis**2), dcore(symtra_ptr),
& dcore(iip), nbasis,dcore(ifock_ptr+r*sqrsize),offset,lsa)
enddo
call dfillzero(dcore(imem), 2*nbasis**2)
call readh(dcore(imem),oeintfile,dcore(symtra_ptr),nbasis,
& offset,lsa)
do r = 0, rmax
call daxpy(sqrsize, 1.0d0, dcore(imem), 1,
&dcore(ifock_ptr+r*sqrsize), 1)
do ir = 1, nir
c Transform one electron integrals to MO basis
if(nfunc(ir) .eq. 0) cycle
call dsymm('l', 'u', nfunc(ir), nfunc(ir), 1.0d0,
& dcore(imem+sqroffset(ir)-1), nfunc(ir),
& dcore(c_ptr+sqroffset(ir)-1+r*sqrsize), nfunc(ir),
& 0.0d0, dcore(imem+nbasis**2), nfunc(ir))
call dgemm('t', 'n', nfunc(ir), nfunc(ir), nfunc(ir), 1.0d0,
& dcore(c_ptr+sqroffset(ir)-1+r*sqrsize), nfunc(ir),
& dcore(imem+nbasis**2), nfunc(ir), 0.0d0,
& hcore(sqroffset(ir)+r*sqrsize), nfunc(ir))
enddo
enddo
open(unit=562, file=rohf_fock_file, form='unformatted')
do r = 0, rmax
write(562)dcore(ifock_ptr+r*sqrsize:ifock_ptr+(r+1)*sqrsize-1)
call tomo(dcore(ifock_ptr+r*sqrsize),
& dcore(ifock_ptr+r*sqrsize), dcore(c_ptr+r*sqrsize),
& dcore(imem), sqroffset, .true.)
enddo
close(562)
return
elseif(scftype .ge. 3) then
call mxto(dcore(symdens_ptr),dcore(symtra_ptr),dcore(imem),
& nbasis,dcore(p_ptr),offset,lsa)
call mxto(dcore(symdens2_ptr),dcore(symtra_ptr),dcore(imem),
& nbasis,dcore(p_ptr+sqrsize),offset,lsa)
call dfillzero(dcore(symfock_ptr), nbasis**2)
call dfillzero(dcore(symqmat_ptr), nbasis**2)
call fock_build(dcore(symdens_ptr),dcore(symdens2_ptr),
& dcore(symfock_ptr),dcore(symfock_ptr),dcore(symqmat_ptr),
& icore(indexirrep_ptr),offset,sqroffset,npos,
& icore(iintpos),2,dcore(c_ptr),lfin,exc,dft,chfx,lwdfn,
& embed,scfdamp,route,nfr,nc,ncorenew,devparr,
& dcore(symtra_ptr),0,clrhfx,csrhfx,omega,dcore(rs_ptr),
& .false.,1,1,pcm,dcore,dcore,.false.)
call mxts(dcore(symfock_ptr),dcore(symtra_ptr),dcore(imem),
& nbasis,dcore(ifock_ptr),offset,lsa)
call mxts(dcore(symqmat_ptr),dcore(symtra_ptr),dcore(imem),
& nbasis,dcore(qmat_ptr),offset,lsa)
call r_build(dcore(rmat_ptr),dcore(sorig_ptr),dcore(p_ptr),
& dcore(qmat_ptr),sqroffset,dcore(imem),dcore(rs_ptr),dft)
call readh(dcore(imem),oeintfile,dcore(symtra_ptr),nbasis,
& offset,lsa)
call dcopy(sqrsize, dcore(imem), 1, hcore, 1)
call daxpy(sqrsize, 1.0d0, dcore(ifock_ptr), 1, dcore(imem), 1)
call daxpy(sqrsize, -1.d0, dcore(qmat_ptr), 1, dcore(imem), 1)
call daxpy(sqrsize, 0.5d0, dcore(rmat_ptr), 1, dcore(imem), 1)
open(unit=562, file=rohf_fock_file, form='unformatted')
write(562) dcore(imem:imem+nbasis**2-1)
close(562)
call dcopy(sqrsize, hcore, 1, dcore(imem), 1)
c call daxpy(nbasis**2,1.0d0,dcore(imem),1,dcore(ifock_ptr),1)
do ir = 1, nir
c Transform one electron integrals to MO basis
if(nfunc(ir) .eq. 0) cycle
call dsymm('l', 'u', nfunc(ir), nfunc(ir), 1.0d0,
& dcore(imem+sqroffset(ir)-1), nfunc(ir),
& dcore(c_ptr+sqroffset(ir)-1), nfunc(ir), 0.0d0,
& hcore, nfunc(ir))
call dgemm('t', 'n', nfunc(ir), nfunc(ir), nfunc(ir),
& 1.0d0, dcore(c_ptr+sqroffset(ir)-1), nfunc(ir),
& hcore, nfunc(ir), 0.0d0, dcore(imem+sqroffset(ir)-1),
& nfunc(ir))
enddo
call dcopy(sqrsize, dcore(imem), 1, hcore, 1)
do ir = 1, nir
if(nfunc(ir) .eq. 0) cycle
! transforming the Fock matrix
call dsymm('l', 'u', nfunc(ir), nfunc(ir),
& 1.0d0, dcore(ifock_ptr+sqroffset(ir)-1), nfunc(ir),
& dcore(c_ptr+sqroffset(ir)-1), nfunc(ir), 0.0d0,
& dcore(imem), nfunc(ir))
call dgemm('t', 'n', nfunc(ir), nfunc(ir),
& nfunc(ir), 1.0d0, dcore(c_ptr+sqroffset(ir)-1),
& nfunc(ir), dcore(imem), nfunc(ir), 0.0d0,
& dcore(ifock_ptr+sqroffset(ir)-1), nfunc(ir))
! Saving the ROHF MO Fock for the Hessian
call dcopy(nfunc(ir)**2, dcore(ifock_ptr+sqroffset(ir)-1), 1,
& dcore(rmat_ptr+sqroffset(ir)-1), 1)
! Transforming the ROHF Q matrix (!= QSCF Q matrix!!!!)
call dsymm('l', 'u', nfunc(ir), nfunc(ir),
& 1.0d0, dcore(qmat_ptr+sqroffset(ir)-1), nfunc(ir),
& dcore(c_ptr+sqroffset(ir)-1), nfunc(ir), 0.0d0,
& dcore(imem), nfunc(ir))
! Saving MO ROHF Q matrix for the Hessian
call dgemm('t', 'n', nfunc(ir), nfunc(ir), nfunc(ir),
& 1.0d0, dcore(c_ptr+sqroffset(ir)-1), nfunc(ir),
& dcore(imem), nfunc(ir), 0.0d0,
& dcore(qmat_ptr+sqroffset(ir)-1), nfunc(ir))
! Adding Q matrix to the generalized Fock matrix
idx = sqroffset(ir)-1+orbperir(ir)*nfunc(ir)
call daxpy(nfunc(ir)*nactperir(ir), -0.5d0,
& dcore(qmat_ptr+idx), 1, dcore(ifock_ptr+idx), 1)
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
if(nvirtir .ne. 0)
& call dfillzero(dcore(ifock_ptr+sqroffset(ir)+(orbperir(ir)+
& nactperir(ir))*nfunc(ir)-1), nfunc(ir)*nvirtir)
call daxpy(nfunc(ir)*(nactperir(ir)+orbperir(ir)), 1.0d0,
& hcore(sqroffset(ir)), 1,
& dcore(ifock_ptr+sqroffset(ir)-1), 1)
if(orbperir(ir) .ne. 0) call dscal(nfunc(ir)*orbperir(ir),
& 2.0d0, dcore(ifock_ptr+sqroffset(ir)-1), 1)
enddo
call daxpy(sqrsize, 1.0d0, hcore, 1, dcore(rmat_ptr), 1)
return
endif
C MCSCF CALCULATION
call get_moint(imoint, imoint, offset, npos, icore(iintpos), 0,
& dcore, .false.)
call mxto(dcore(iip), dcore(symtra_ptr), dcore(isymfock_ptr),
& nbasis, dcore(p_ptr), offset, lsa)
call dfillzero(dcore(isymfock_ptr), nbasis**2)
call fock_build(dcore(iip), dcore(iip), dcore(isymfock_ptr),
& dcore(isymfock_ptr), dcore(imem), dcore(indexirrep_ptr),
& offset, sqroffset, npos, icore(iintpos), 2, dcore(c_ptr),
& lfin, exc, dft, chfx, lwdfn, embed, scfdamp, route, nfr, nc,
& ncorenew, devparr, dcore(symtra_ptr), 0,clrhfx,csrhfx,omega,
& dcore(rs_ptr), .false., 1, 1, pcm, dcore, dcore, .false.)
call mxts(dcore(isymfock_ptr), dcore(symtra_ptr), dcore(iip),
& nbasis, dcore(ifock_ptr), offset, lsa)
call build_mofock(dcore(c_ptr), dcore(ifock_ptr),
& dcore(ifock_ptr), sqrsize, nfr, sqroffset, dcore(imem))
call readh(dcore(imem),oeintfile,dcore(symtra_ptr),nbasis,offset,
& lsa)
do ir = 1, nir
c Transform one electron integrals to MO basis
if(nfunc(ir) .eq. 0) cycle
call dsymm('l', 'u', nfunc(ir), nfunc(ir), 1.0d0,
& dcore(imem+sqroffset(ir)-1), nfunc(ir),
& dcore(c_ptr+sqroffset(ir)-1), nfunc(ir), 0.0d0,
& hcore, nfunc(ir))
call dgemm('t', 'n', nfunc(ir), nfunc(ir), nfunc(ir),
& 1.0d0, dcore(c_ptr+sqroffset(ir)-1), nfunc(ir),
& hcore, nfunc(ir), 0.0d0, dcore(imem+sqroffset(ir)-1),
& nfunc(ir))
enddo
c Write one electron MO integrals to file
c (only active-active part is needed)
call dcopy(sqrsize, dcore(imem), 1, hcore, 1)
call daxpy(sqrsize, 1.0d0, hcore, 1, dcore(ifock_ptr), 1)
call ci_solver(imoint, hcore, offset, sqroffset, p2, p4,
& verblevel, dcore(ifock_ptr), hnuc)
if(nact .ne. 0) call mk_ap(p2, dcore(iap), dcore(c_ptr),
& sqroffset, offset, dcore(asymfock_ptr))
c build active and inactive Fock matrix
if(lsa) then
call mx_basis_tr(dcore(iap), dcore(symtra_ptr),
& dcore(asymfock_ptr), 'to', nbasis)
endif
call dfillzero(dcore(asymfock_ptr), nbasis**2)
call fock_build(dcore(iap), dcore(iap), dcore(asymfock_ptr),
& dcore(asymfock_ptr), dcore(imem), dcore(indexirrep_ptr),
& offset, sqroffset, npos, icore(iintpos), 2, dcore(c_ptr),
& lfin, exc, dft, chfx, lwdfn, embed, scfdamp, route, nfr, nc,
& ncorenew, devparr,dcore(symtra_ptr),nact,clrhfx,csrhfx,omega,
& dcore(rs_ptr), .false., 1, 1, pcm, dcore, dcore, .false.)
call mxts(dcore(asymfock_ptr), dcore(symtra_ptr), dcore(iip),
& nbasis, dcore(afock_ptr), offset, lsa)
call build_mofock(dcore(c_ptr), dcore(afock_ptr),
& dcore(afock_ptr), sqrsize, nfr, sqroffset, dcore(imem))
c building generalized MO Fock matrix
c WARNING: The transpose of the MO Fock matrix will be built!!
call assemble_fock(nbasis, nir, sqrsize, offset, sqroffset,
& orbperir, dcore(ifock_ptr), dcore(afock_ptr), q,
& hcore, p2, p4, dcore(imoint), genfock, dcore(c_ptr))
call dbldealloc(imoint)
end subroutine
************************************************************************
subroutine ci_solver(imoint, hcore, offset, sqroffset, p2, p4,
& verblevel, ifock, hnuc)
************************************************************************
* Subroutine to solve the CI problem in the active space
************************************************************************
implicit none
integer imoint, offset(nir), sqroffset(nir), verblevel
integer tmp1, tmp2
double precision hcore(sqrsize), p2(nact, nact), hnuc
double precision p4(nact, nact, nact, nact), ifock(sqrsize)
double precision ener
integer dblalloc
call write55(dcore(imoint), ifock, hcore, dcore(c_ptr), offset,
& sqroffset, dcore(imem), hnuc)
call write56
c CI calculation
if(nact .ne. 0) then
c write(*,"(1X,70('='))")
c write(*,'(20X,"MCSCF: EXECUTING GOLDSTONE....")')
c write(*,"(1X,70('='))")
call ishell("goldstone > /dev/null")
c write(*,"(1X,70('='))")
c write(*,'(20X,"MCSCF: EXECUTING XMRCC....")')
c write(*,"(1X,70('='))")
call ishell("rm -f fort.24")
call ishell("xmrcc > /dev/null")
c write(*,"(1X,70('='))")
c write(*,'(20X,"MCSCF: EXECUTING MRCC....")')
c write(*,"(1X,70('='))")
c call ishell("mrcc > /dev/null")
open(unit=50,file='ROUTE',form='formatted')
write(50,'(A)') 'mcscf'
close(50)
call ishell("mrcc > ci_output")
call read_dens(p4, p2)
endif
end subroutine
************************************************************************
subroutine build_mofock(c, fock, mofock, sqrsize, nfr,
& sqroffset, tmp)
************************************************************************
* Build MO Fock matrix for QSCF calculations
************************************************************************
use common_mod, only : nfunc, nir, nbasis
implicit none
integer ir, nfr, sqroffset(*), sqrsize, k
double precision fock(sqrsize)
double precision mofock(sqrsize)
double precision c(sqrsize), tmp(*)
do k = 0, rmax
do ir = 1, nir
if(nfunc(ir) .eq. 0) cycle
call dsymm('l', 'u', nfunc(ir), nfunc(ir), 1.0d0,
& fock(k*sqrsize+sqroffset(ir)), nfunc(ir),
& c(k*sqrsize+nbasis*nfr+sqroffset(ir)), nfunc(ir),
& 0.0d0, tmp, nfunc(ir))
call dgemm('t', 'n', nfunc(ir), nfunc(ir), nfunc(ir), 1.0d0,
& c(k*sqrsize+nbasis*nfr+sqroffset(ir)), nfunc(ir), tmp,
& nfunc(ir), 0.0d0, mofock(k*sqrsize+sqroffset(ir)),
& nfunc(ir))
enddo
enddo
end subroutine
************************************************************************
subroutine write55(moint, ifock, hcore, c, offset, sqroffset, tmp,
& hnuc)
************************************************************************
* Write MO integrals to fort.55
************************************************************************
implicit none
integer offset(nir), sqroffset(nir)
integer i, j, k, l, ii, ir, fort55, oeintfile, idx
double precision c(sqrsize), hcore(sqrsize), tmp(sqrsize)
double precision moint(nbasis, nact, nact, nact), hnuc, x
double precision ifock(sqrsize), delta
parameter(fort55 = 55, delta = 1.0d-11)
parameter(oeintfile = 71)
open(unit=fort55, file="fort.55")
write(fort55, *) nact, nactel
do i = 1, nir
do j = 1, nactperir(i)
write(unit=fort55,fmt='(i2)',advance='no') i
enddo
enddo
write(fort55,*)
write(fort55,*) 150000
do ir = 1, nir
do i = 1, nactperir(ir)
ii = i+actoffset(ir)-1
do j = ii, nact
do k = 1, nact
do l = k, nact
if(dabs(moint(offset(ir)+orbperir(ir)+i-1,j,k,l))
& .gt. delta) then
write(fort55,'(e28.20,4i4)')
& moint(offset(ir)+orbperir(ir)+i-1, j, k, l),
& ii, j, k, l
endif
enddo
enddo
enddo
enddo
enddo
do ir = 1, nir
if(nactperir(ir) .ne. 0) then
do i = 1, nactperir(ir)
do j = i, nactperir(ir)
idx = sqroffset(ir)+orbperir(ir)+j-1+
& (orbperir(ir)+i-1)*nfunc(ir)
if(dabs(ifock(idx)) .gt. delta) then
write(fort55, '(e28.20,4i4)') ifock(idx),
& actoffset(ir)-1+j, actoffset(ir)+i-1, 0, 0
endif
enddo
enddo
endif
enddo
x = hnuc
do ir = 1, nir
do i = 1, orbperir(ir)
x = x + hcore(sqroffset(ir)-1+i+(i-1)*nfunc(ir)) +
& ifock(sqroffset(ir)-1+i+(i-1)*nfunc(ir))
enddo
enddo
write(fort55, '(e28.20,4i4)') x, 0, 0, 0, 0
close(fort55)
end subroutine
************************************************************************
subroutine write56()
************************************************************************
* Write fort.56 file
************************************************************************
use common_mod, only : iclsh
implicit none
integer un, memory, clsh, opsh, isym, i, imult
parameter(un = 56)
character*(4) cctol, mult, sym
character*(*) cl
parameter(cl='ex.lev,nsing,ntrip, rest,CC/CI,dens,conver,symm,
& diag, CS ,spatial, HF ,ndoub,nacto,nactv, tol ,maxex, sacc,
& freq, dboc, mem, locno, eps')
integer intalloc
open(unit=un, file='fort.56')
call getkey('symm', 4, sym, 4)
call getkey('mult', 4, mult, 4)
call getkey('cctol', 5, cctol, 4)
if(mult .eq. '1 ') then
clsh = 1
opsh = 0
else
clsh = 0
opsh = 1
endif
isym = 1
if(sym .ne. ' ') then
read(sym,*) isym
endif
read(mult,*) imult
write(un,'(7I4,I4,7I4,1X,A,I4,I4,A,I4,I4,I4,1pe10.3)')
& nactel, clsh, 0, 0, 0, -2, 0, isym, 0, iclsh, 1, 0,
& opsh, 0, 0, cctol, 0, 0, ' 0.00', 0, 500, 0, 0.0d0
write(un,'(A)') cl
do i = 0, nact-1
write(un,'(I4)', advance='no') icore(irefdet+i)
enddo
close(un)
end subroutine
*************************************************************************
subroutine mk_ap(p2, ap, c, sqroffset, offset, tmp)
*************************************************************************
* Transform the active-active part of the 2-index MCSCF density matrix
* to AO basis
*************************************************************************
implicit none
integer dimir, nactir, ir, sqroffset(nir), offset(nir)
double precision p2(nact, nact), ap(nbasis, nbasis), tmp(*)
double precision c(sqrsize)
ap = 0.0d0
do ir = 1, nir
if(nactperir(ir) .eq. 0) cycle
dimir = nfunc(ir)
nactir = nactperir(ir)
call dgemm('n', 'n', dimir, nactir, nactir, 1.0d0,
& c(sqroffset(ir)+dimir*orbperir(ir)), dimir,
& p2(actoffset(ir), actoffset(ir)), nact, 0.0d0, tmp, dimir)
call dgemm('n', 't', dimir, dimir, nactir, 1.0d0, tmp, dimir,
& c(sqroffset(ir)+dimir*orbperir(ir)), dimir, 0.0d0,
& ap(offset(ir), offset(ir)), nbasis)
enddo
end subroutine
************************************************************************
subroutine read_dens(p4, p2)
************************************************************************
* Read CI density matrices from file
************************************************************************
implicit none
integer un
integer i, j, k, l
double precision tmp, ener
double precision p2(nact,nact), p4(nact,nact,nact,nact)
parameter(un = 13)
p2 = 0.0d0
open(unit=un, file="CCDENSITIES")
do
read(unit = un, fmt = *, end=888) tmp, i, j, k, l
if(k .eq. 0 .and. l .eq. 0) then
p2(i, j) = tmp
p2(j, i) = tmp
endif
enddo
888 close(un)
p4 = 0.0d0
open(78,status='unknown',form='unformatted')
read(78, end=999) tmp, i, k, j, l
do while(l.ne.0)
p4(i,j,k,l) = p4(i,j,k,l) + tmp
p4(k,l,i,j) = p4(k,l,i,j) + tmp
p4(j,i,l,k) = p4(j,i,l,k) + tmp
p4(l,k,j,i) = p4(l,k,j,i) + tmp
read(78, end=999) tmp, i, k, j, l
enddo
999 close(78)
call dscal(nact**4, 0.5d0, p4, 1)
end subroutine
************************************************************************
subroutine assemble_fock(nbasis, nir, sqrsize, offset, sqroffset,
& orbperir, ifock, afock, q, hcore, p2, p4, moint,
& genfock, c)
************************************************************************
* Assemble generalized Fock matrix from the inactive and active Fock
* matrices. On input, ifock and afock contain the inactive and active AO
* Fock matrices. On output, the genfock matrix contains the genaralized
* Fock matrix, ifock, and afock contain the MO inactive and active Fock
* matrices respectively.
************************************************************************
implicit none
integer nbasis, sqrsize, nir, orbperir(nir), offset(nir)
integer sqroffset(nir), nvirtir
double precision ifock(sqrsize), afock(sqrsize)
double precision genfock(sqrsize), hcore(sqrsize)
double precision c(sqrsize), q(nbasis, nact)
double precision moint(nbasis, nact, nact, nact)
double precision p2(nact, nact), p4(nact, nact, nact, nact)
integer ir, i
do ir = 1, nir
c sum up the active and inactive part
c 2*(ifock_ni + afock_ni) for gradient
if(orbperir(ir) .ne. 0) then
call dcopy(nfunc(ir)*orbperir(ir), ifock(sqroffset(ir)), 1,
& genfock(sqroffset(ir)), 1)
call daxpy(nfunc(ir)*orbperir(ir), 1.0d0,afock(sqroffset(ir)),
& 1, genfock(sqroffset(ir)), 1)
call dscal(nfunc(ir)*orbperir(ir), 2.0d0,
& genfock(sqroffset(ir)), 1)
endif
if(nactperir(ir) .ne. 0) then
c general-active part of the inactive MO Fock
call dgemm('n', 't', nfunc(ir), nactperir(ir), nactperir(ir),
& 1.0d0, ifock(sqroffset(ir)+orbperir(ir)*nfunc(ir)),
& nfunc(ir), p2(actoffset(ir), actoffset(ir)), nact, 0.0d0,
& genfock(sqroffset(ir)+orbperir(ir)*nfunc(ir)), nfunc(ir))
endif
c general-virtual part
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
call dfillzero(genfock(sqroffset(ir)+
& (orbperir(ir)+nactperir(ir))*nfunc(ir)), nfunc(ir)*nvirtir)
enddo
c Add Q matrix to the generalized Fock matrix
call fockq(genfock, moint, p4, q, sqroffset, offset, actoffset)
end subroutine
************************************************************************
subroutine gfock_act(offset, sqroffset, ifock, genfock, c, p2)
************************************************************************
* Build the second part of the generalized MO Fock matrix, The first
* index is active, the second is general.
************************************************************************
implicit none
integer offset(nir), sqroffset(nir), ir, nvirtir
double precision ifock(sqrsize), c(sqrsize)
double precision genfock(sqrsize), p2(nact, nact)
do ir = 1, nir
c general virtual part (==0)
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
call dfillzero(genfock(sqroffset(ir)+
& (orbperir(ir)+nactperir(ir))*nfunc(ir)), nfunc(ir)*nvirtir)
if(nactperir(ir) .eq. 0) cycle
c general-active part of the inactive MO Fock
call dgemm('n', 't', nfunc(ir), nactperir(ir), nactperir(ir),
& 1.0d0, ifock(sqroffset(ir)+orbperir(ir)*nfunc(ir)),
& nfunc(ir), p2(actoffset(ir), actoffset(ir)), nact, 0.0d0,
& genfock(sqroffset(ir)+orbperir(ir)*nfunc(ir)), nfunc(ir))
enddo
end subroutine
************************************************************************
subroutine fockq(genfock, moint, p4, q, sqroffset, offset,
& actoffset)
************************************************************************
* Q matrix for generalized Fock matrix construction
************************************************************************
implicit none
integer sqroffset(nir), offset(nir), actoffset(nir), ir, m, v
integer i, x, y, w
double precision genfock(sqrsize)
double precision moint(nbasis, nact, nact, nact)
double precision p4(nact, nact, nact, nact)
double precision q(nbasis,nact)
call dgemm('n', 't', nbasis, nact, nact**3, 1.0d0, moint, nbasis,
& p4, nact, 0.0d0, q, nbasis)
c adding Q matrix to the Fock matrix
do ir = 1, nir
if(nactperir(ir) .eq. 0) cycle
do v = 1, nactperir(ir)
do m = 1, nfunc(ir)
genfock(sqroffset(ir)+m-1+(orbperir(ir)+v-1)*nfunc(ir)) =
& genfock(sqroffset(ir)+m-1+(orbperir(ir)+v-1)*nfunc(ir)) +
& q(offset(ir)+m-1, actoffset(ir)+v-1)
enddo
enddo
enddo
end subroutine
************************************************************************
subroutine hessq_rohf(kappa, genfock, q, dens, idens, work, iwork,
& sqroffset, offset, npos, cmat, lfin, exc, lwdfn, embed, scfdamp,
& route, nfr, nc, ncorenew, devparr, chfx, clrhfx, csrhfx, omega,
& pcm)
************************************************************************
* One-index transformed Q matrix for ROHF Hessian
* iwork is the memory address of work
* idens is the memory address of dens
************************************************************************
use common_mod, only: nbasis, sqrsize, orbperir, nfunc, nir,
& indexirrep_ptr, iintpos, icore, lsa, nbasis, scfalg,
& dcore, rs_ptr, dfnbasis, nal, nbe
implicit none
integer sqroffset(nir), offset(nir), iwork, idens
integer ir, dimir, nactir, noccir, nvirtir, kos
integer idens_ptr(2), im(2), i, j
double precision clrhfx,csrhfx,omega
double precision kappa(qscfsize), dens(nbasis**2), cmat(sqrsize)
double precision genfock(sqrsize), q(sqrsize), work(nbasis**2)
integer lfin,nfr,nc,ncorenew,npos
double precision exc,devparr(2), chfx
character*4 route
character*16 scfdamp
logical lwdfn
character*32 dft,pcm
character*8 embed
call getkey('dft',3,dft,32)
kos = 1
do ir = 1, nir
dimir = nfunc(ir)
nactir = nactperir(ir)
noccir = orbperir(ir)
nvirtir = dimir - noccir - nactir
c occupied part
if(noccir.ne.0 .and. nactir.ne.0) then
call dgemm('t', 'n', noccir, nactir, nactir, 0.5d0,
& kappa(kos), nactir, q(sqroffset(ir)+noccir*(1+dimir)),
& dimir, 1.0d0, genfock(sqroffset(ir)+noccir*dimir),
& dimir)
call dgemm('n', 't', noccir, nactir, noccir, -0.5d0,
& q(sqroffset(ir)), dimir, kappa(kos), nactir, 1.0d0,
& genfock(sqroffset(ir)+noccir*dimir), dimir)
endif
if(noccir.ne.0 .and. nactir.ne.0 .and. nvirtir.ne.0) then
call dgemm('t', 'n', noccir, nactir, nvirtir, 0.5d0,
& kappa(kos+noccir*nactir), nvirtir,
& q(sqroffset(ir)+noccir+nactir+noccir*dimir), dimir,
& 1.0d0, genfock(sqroffset(ir)+noccir*dimir), dimir)
call dgemm('n', 'n', noccir, nactir, nvirtir, 0.5d0,
& q(sqroffset(ir)+(noccir+nactir)*dimir), dimir,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir, 1.0d0,
& genfock(sqroffset(ir)+noccir*dimir), dimir)
endif
c active part
if(noccir.ne.0 .and. nactir.ne.0) then
call dgemm('n', 'n', nactir, nactir, noccir, -0.5d0,
& kappa(kos), nactir, q(sqroffset(ir)+noccir*dimir),
& dimir, 1.0d0,
& genfock(sqroffset(ir)+(1+noccir)*dimir), dimir)
call dgemm('n', 't', nactir, nactir, noccir, -0.5d0,
& q(sqroffset(ir)+noccir), dimir, kappa(kos), nactir,
& 1.0d0, genfock(sqroffset(ir)+noccir*(dimir+1)), dimir)
endif
if(nvirtir.ne.0 .and. nactir.ne.0) then
call dgemm('t', 'n', nactir, nactir, nvirtir,
& 0.5d0, kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
& q(sqroffset(ir)+noccir*(1+dimir)+nactir), dimir, 1.0d0,
& genfock(sqroffset(ir)+(1+noccir)*dimir), dimir)
call dgemm('n', 'n', nactir, nactir, nvirtir, 0.5d0,
& q(sqroffset(ir)+noccir+(noccir+nactir)*dimir), dimir,
& kappa(kos+(nactir*nvirtir)*noccir), nvirtir,
& 1.0d0, genfock(sqroffset(ir)+noccir*(dimir+1)), dimir)
endif
c virtual part
if(nvirtir.ne.0 .and. noccir.ne.0 .and. nactir.ne.0) then
call dgemm('n', 'n', nvirtir, nactir, noccir,
& -0.5d0, kappa(kos+nactir*noccir), nvirtir,
& q(sqroffset(ir)+noccir*dimir), dimir, 1.0d0,
& genfock(sqroffset(ir)+nactir+noccir*(dimir+1)), dimir)
call dgemm('n', 't', nvirtir, nactir, noccir, -0.5d0,
& q(sqroffset(ir)+noccir+nactir), dimir, kappa(kos),
& nactir, 1.0d0,
& genfock(sqroffset(ir)+nactir+noccir*(dimir+1)), dimir)
endif
if(nactir.ne.0 .and. nvirtir.ne.0) then
call dgemm('n', 'n', nvirtir, nactir, nactir, -0.5d0,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
& q(sqroffset(ir)+noccir*(dimir+1)), dimir, 1.0d0,
& genfock(sqroffset(ir)+nactir+noccir*(dimir+1)), dimir)
call dgemm('n', 'n', nvirtir, nactir, nvirtir, 0.5d0,
& q(sqroffset(ir)+(noccir+nactir)*(dimir+1)), dimir,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir, 1.0d0,
& genfock(sqroffset(ir)+nactir+noccir*(dimir+1)), dimir)
endif
kos = kos + (nactir + nvirtir)*noccir + nactir*nvirtir
enddo
if(ldf) then
idens_ptr(1) = idens
idens_ptr(2) = imem
im(1) = iwork
im(2) = iwork
call build_mmat(offset, sqroffset, idens_ptr, im, npos, kappa,
& cmat, chfx, 2, dfnbasis, nal, nbe, lfin, exc, embed,
& lwdfn, scfdamp, route, nfr, nc, ncorenew, devparr, clrhfx,
& csrhfx, omega, .true., pcm)
IF(trim(scfalg).ne.'disk') then
do i = 1, nbasis
do j = i+1, nbasis
work(i+(j-1)*nbasis) = 0.5d0*work(i+(j-1)*nbasis)
work(j+(i-1)*nbasis) = work(i+(j-1)*nbasis)
enddo
enddo
endif
else
call dfillzero(work,nbasis**2)
call fock_build(dens, dens, work, work, work,
& icore(indexirrep_ptr), offset, sqroffset, npos,
& icore(iintpos), 2, cmat, lfin, exc, dft, -1.0d0, lwdfn,
& embed, scfdamp, route, nfr, nc, ncorenew, devparr,
& dcore(symtra_ptr),0,clrhfx,csrhfx,omega,dcore(rs_ptr),
& .true.,1,1,pcm,dcore,dcore,.false.)
endif
if(lsa) then
call mxts(work,dcore(symtra_ptr),dens,nbasis,dens,offset,lsa)
call dcopy(sqrsize,dens,1,work,1)
endif
do ir = 1, nir
if(nactperir(ir) .eq. 0) cycle
call dsymm('l', 'u', nfunc(ir), nactperir(ir), 1.0d0,
& work(sqroffset(ir)), nfunc(ir),
& cmat(sqroffset(ir)+orbperir(ir)*nfunc(ir)), nfunc(ir),
& 0.0d0, dens, nfunc(ir))
call dgemm('t', 'n', nfunc(ir), nactperir(ir), nfunc(ir),
& -0.5d0, cmat(sqroffset(ir)), nfunc(ir), dens, nfunc(ir),
& 1.0d0, genfock(sqroffset(ir)+orbperir(ir)*nfunc(ir)),
& nfunc(ir))
enddo
end subroutine
************************************************************************
subroutine hessq_mcscf(kappa, genfock, p4, p4_sym, q, c, csym,
& work, offset, sqroffset, npos)
************************************************************************
* Q matrix for one-index transformed Fock matrix construction
************************************************************************
implicit none
integer offset(nir), sqroffset(nir), npos
integer intpos(3,(nbasis+1)*nbasis/2)
integer kos, ir, dimir, noccir, nactir, nvirtir
integer i, j, k, l, m, v, w, x, y
integer imoint1, imoint2, ic_act
double precision genfock(sqrsize), p4(nact, nact, nact, nact)
double precision p4_sym(nact, nact, nact, nact)
double precision q(nbasis,nact), c(nbasis, nbasis)
double precision kappa(qscfsize), kappa_ao(nbasis*nact)
double precision work(nbasis*nact), csym(sqrsize)
double precision c2(nbasis, nact)
double precision, allocatable :: int1(:,:,:,:)
double precision, allocatable :: int2(:,:,:,:)
double precision, allocatable :: kappa_mx(:,:)
double precision, allocatable :: genfock2(:)
integer dblalloc, idamax
c First part of the one-index transformed Q matrix is just the matrix
c product of the original Q matrix and the kappa matrix
kos = 1
do ir = 1, nir
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
dimir = nfunc(ir)
noccir = orbperir(ir)
nactir = nactperir(ir)
c occupied part
if(noccir.ne.0 .and. nactir.ne.0) then
call dgemm('t', 'n', noccir, nactir, nactir, -1.0d0,
& kappa(kos), nactir, q(offset(ir)+noccir, actoffset(ir)),
& nbasis, 1.0d0, genfock(sqroffset(ir)+noccir*dimir),
& dimir)
endif
if(noccir.ne.0 .and. nactir.ne.0 .and. nvirtir.ne.0) then
call dgemm('t', 'n', noccir, nactir, nvirtir, -1.0d0,
& kappa(kos+noccir*nactir), nvirtir,
& q(offset(ir)+noccir+nactir, actoffset(ir)), nbasis,
& 1.0d0, genfock(sqroffset(ir)+noccir*dimir), dimir)
endif
c active part
if(noccir.ne.0 .and. nactir.ne.0) then
call dgemm('n', 'n', nactir, nactir, noccir,
& 1.0d0, kappa(kos), nactir, q(offset(ir), actoffset(ir)),
& nbasis, 1.0d0,
& genfock(sqroffset(ir)+noccir+noccir*dimir), dimir)
endif
if(nvirtir.ne.0 .and. nactir.ne.0) then
call dgemm('t', 'n', nactir, nactir, nvirtir,
& -1.0d0, kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
& q(offset(ir)+noccir+nactir, actoffset(ir)), nbasis,1.0d0,
& genfock(sqroffset(ir)+noccir+noccir*dimir), dimir)
endif
c virtual part
if(nvirtir.ne.0 .and. noccir.ne.0 .and. nactir.ne.0) then
call dgemm('n', 'n', nvirtir, nactir, noccir,
& 1.0d0, kappa(kos+nactir*noccir), nvirtir,
& q(offset(ir), actoffset(ir)), nbasis, 1.0d0,
& genfock(sqroffset(ir)+noccir+nactir+noccir*dimir),dimir)
endif
if(nactir.ne.0 .and. nvirtir.ne.0) then
call dgemm('n', 'n', nvirtir, nactir, nactir, 1.0d0,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
& q(offset(ir)+noccir, actoffset(ir)), nbasis, 1.0d0,
& genfock(sqroffset(ir)+noccir+nactir+noccir*dimir),dimir)
endif
kos = kos + (nactir + nvirtir)*noccir + nactir*nvirtir
enddo
call dcopy(nact**4, p4, 1, p4_sym, 1)
do v = 1, nact
do w = 1, nact
do x = 1, nact
do y = 1, nact
p4_sym(v,w,x,y) = p4_sym(v,w,x,y) + p4(v,w,y,x)
enddo
enddo
enddo
enddo
if(ldf) then
work = 0.0d0
call df_hessq(npos, icore(iintpos), offset, sqroffset, work,
& kappa, p4_sym)
do ir = 1, nir
if(nactperir(ir) .eq. 0) cycle
do i = 1, nactperir(ir)
do j = 1, nfunc(ir)
genfock(sqroffset(ir)+j-1+(orbperir(ir)+i-1)*nfunc(ir)) =
& genfock(sqroffset(ir)+j-1+(orbperir(ir)+i-1)*nfunc(ir))+
& work(offset(ir)+j-1+(actoffset(ir)+i-2)*nbasis)
enddo
enddo
enddo
else
call get_moint(imoint1, imoint2, offset, npos, icore(iintpos),
& 1, kappa, .false.)
call dgemm('t', 't', nbasis, nact, nact**3, 1.0d0,
& dcore(imoint1), nact**3, p4, nact, 0.0d0, work, nbasis)
call dgemm('t', 't', nbasis, nact, nact**3, 1.0d0,
& dcore(imoint2), nact**3, p4_sym, nact, 1.0d0, work,
& nbasis)
do ir = 1, nir
if(nactperir(ir) .eq. 0) cycle
call dgemm('t', 'n', nfunc(ir), nactperir(ir), nbasis, 1.0d0,
& c(1, offset(ir)), nbasis,
& work(1+(actoffset(ir)-1)*nbasis), nbasis, 1.0d0,
& genfock(sqroffset(ir)+orbperir(ir)*nfunc(ir)),
& nfunc(ir))
call dgemm('t', 'n', nfunc(ir), nactperir(ir), nbasis, 1.0d0,
& c(1, offset(ir)), nbasis,
& work(1+(actoffset(ir)-1)*nbasis), nbasis, 1.0d0,
& dcore(imem), nfunc(ir))
enddo
c call dgemm('t', 'n', nbasis, nact, nbasis, 1.0d0, c, nbasis,
c & work, nbasis, 0.0d0, dcore(imem), nbasis)
call dbldealloc(imoint2)
endif
end subroutine
************************************************************************
subroutine get_moint(imoint1, imoint2, offset, npos, intpos, job,
& kappa, recalc)
************************************************************************
************************************************************************
use common_mod, only: nbasis, nir
implicit none
integer imoint1, imoint2, offset(nir), npos
integer intpos(3,(nbasis+1)*nbasis/2)
integer job
double precision kappa(qscfsize)
logical recalc
integer dblalloc
if(ldf) then
call df_get_moint(imoint1, offset, npos, intpos, job, kappa,
& recalc)
else
if(.not. recalc) then
call ao2moint(imoint1, imoint2, offset, npos, intpos, job,
& kappa)
endif
endif
end subroutine
************************************************************************
subroutine ao2moint(imoint, imoint2, offset, npos, intpos, job,
& kappa)
************************************************************************
* Calculates MO integrals for gradient and 1-index transformed gradient
* calculations.
* Gradient: job == 0; 1-index transf. gradient: job == 1
* moint2 and c2 are not referenced in case of job == 0
* If job == 1 then the 2nd index of moint and the 3rd index of moint2 are
* transformed with c2, the other indexes are transformed with c. The 1st
* index is left in AO basis.
************************************************************************
use common_mod, only: ifltln, maxcor, orbperir
implicit none
integer offset(nir), npos, job
integer intpos(3,(nbasis+1)*nbasis/2), i, k, iwork, j, l, ir
integer ipos, ninteg, nninteg, maxm, ip, iposlo, teintf(10)
integer ig3 ! 1 index in MO basis, 3 index in AO basis
integer itmp, ic_act, extr_c, ictr
integer imoint, imoint2 ! MO integrals
double precision kappa(qscfsize)
integer job_grad, job_hess
parameter(job_grad = 0, job_hess = 1)
integer imem1
common/memcom/ imem1
integer dblalloc
CALL INTOPENRSQ(TEINTF)
if(job .eq. job_grad) then
imoint = dblalloc(nbasis*nact**3)
itmp = dblalloc(nbasis**2*nact**2-nbasis*nact**3)
ig3 = dblalloc(nbasis**3*nact)
elseif(job .eq. job_hess) then
ig3 = dblalloc(nbasis**3*nact)
imoint = dblalloc(nbasis*nact**3)
iwork = dblalloc(nbasis**2*nact**2)
imoint2 = ig3
endif
if(lsa) then
extr_c = dblalloc(nbasis**2)
call extract_mo(offset, dcore(ig3), extr_c)
else
extr_c = c_ptr
endif
ic_act = dblalloc(nbasis*nact)
call active_mo(offset, extr_c, ic_act)
if(job .eq. job_hess) then
ictr = dblalloc(nbasis*nact)
call transf_coef(dcore(extr_c), kappa, dcore(ictr), offset)
endif
call dfillzero(dcore(ig3), nbasis**3*nact)
IPOS=0
MAXM=IFLTLN*MIN(MAXCOR-(IMEM-IMEM1),20*nbasis*(nbasis+1)/2)
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
I =INTPOS(1,IP)
K =INTPOS(2,IP)
NINTEG=INTPOS(3,IP)
call tr_index2(dcore(ig3), dcore(ic_act), i, k, dcore(imem),
& ninteg, nninteg, nbasis, nact)
NNINTEG=NNINTEG+6*NINTEG
ENDDO
IF(IPOS.EQ.NPOS) EXIT
ENDDO
CALL INTCLOSE(TEINTF)
c iwork = dblalloc(nbasis**2*nact**2)
if(job .eq. job_grad) then ! MO integrals for gradient calculation
call tr_index_grad(dcore(ig3), dcore(imoint), dcore(ig3),
& dcore(imoint), dcore(extr_c), dcore(ic_act))
call dbldealloc(itmp)
elseif(job .eq. job_hess) then ! MO integrals for 1-index transformed gradient calculation
call tr_index_hess(dcore(ig3), dcore(ic_act), dcore(ictr),
& dcore(imoint), dcore(imoint2), dcore(iwork))
call dbldealloc(iwork)
endif
end subroutine
************************************************************************
subroutine df_get_moint(imoint, offset, npos, intpos, job, kappa,
& recalc)
************************************************************************
* Calculates MO integrals for gradient and 1-index transformed gradient
* calculations.
* Gradient: job == 0; 1-index transf. gradient: job == 1
* moint2 and c2 are not referenced in case of job == 0
* If job == 1 then the 2nd index of moint and the 3rd index of moint2 are
* transformed with c2, the other indexes are transformed with c. The 1st
* index is left in AO basis.
************************************************************************
use common_mod, only: maxcor, orbperir, pepsilon, dfnbasis, iout
implicit none
integer offset(nir), npos, job
integer intpos(3,(nbasis+1)*nbasis/2)
integer i, ii, k, j, l, ir
integer ipos, ninteg, nninteg, maxm, teintf(10)
integer itmp, ic_act, extr_c, ictr, ic_act2, icpr
integer imoint! MO integrals
integer ii4core, iact_int, itr_int
integer nbl, nbll, nblock
double precision kappa(qscfsize)
double precision dtol, ss
integer job_grad, job_hess, integ_file, integ_file2
parameter(job_grad = 0, job_hess = 1, integ_file = 666)
parameter(integ_file2 = 667)
integer imem1
common/memcom/ imem1
logical recalc
integer dblalloc, mod
double precision dabs
ic_act = dblalloc(nbasis*nact)
icpr = dblalloc(nbasis)
if(lsa) then
extr_c = dblalloc(nbasis**2)
call extract_mo(offset, dcore(imem), extr_c)
else
extr_c = c_ptr
endif
ic_act2 = dblalloc(nbasis*nact)
call active_mo(offset, extr_c, ic_act2)
do i = 1, nact
do j = 1, nbasis
dcore(ic_act+(i-1)+(j-1)*nact) =
& dcore(ic_act2+(j-1)+(i-1)*nbasis)
enddo
enddo
call dbldealloc(ic_act2)
c Prescreening
do i=1,nbasis
ss=0.d0
do ii=1,nact
ss=max(ss,dabs(dcore(ic_act+ii-1+(i-1)*nact)))
enddo
dcore(icpr+i-1)=ss
enddo
ii=3*dfnbasis
ii=(ii+mod(ii,2))/2
ii4core=dblalloc(ii)
c dtol=pepsilon/dfloat(nbasis*nact)
dtol=min(pepsilon, 1.0d-8)/dfloat(nbasis*nact)
maxm=maxcor-(imem-imem1)
nbl = min(nact, maxm/(2*dfnbasis*nbasis))
if(nbl .lt. 1) then
write(iout,*) 'Insufficient memory for integral transformation!'
call mrccend(1)
endif
nblock = nact / nbl
nbll = mod(nact, nbl)
if(nbll .gt. 0) then
nblock = nblock + 1
else
nbll = nbl
endif
iact_int = dblalloc(nbl*nbasis*dfnbasis) ! (act,gen|fitting) integs
c write(*,"(' Number of integral batches:',i5)") nblock
c write(*,"(' Active indices per batch:',i5)") nbl
c Transform 2 index to MO basis: (fitting|act,gen)
c We store the (fitting|act,gen) integrals in the 'integ' file
c We store the (fitting|act,act) integrals in the 'integ_act' file
CALL INTOPENRSQ(TEINTF)
open(unit=integ_file, file=modf_integs, form='unformatted')
open(unit=integ_file2, file=modf_act_integs, form='unformatted')
do i = 1, nblock-1
call df_index1_tr(npos, intpos, teintf, nbl, dcore(imem),
& dcore(ii4core), dcore(ic_act+(i-1)*nbl), dcore(icpr),
& dtol)
call dgemm('n', 'n', dfnbasis*nbl, nbasis, nbasis, 1.0d0,
& dcore(imem), dfnbasis*nbl, dcore(extr_c), nbasis, 0.0d0,
& dcore(iact_int), dfnbasis*nbl)
call df_save_integ(dcore(iact_int), nbl*(i-1)+1, nbl, 1, nbasis,
& integ_file)
call df_save_act_integ(dcore(iact_int), nbl*(i-1)+1, nbl,
& offset, integ_file2)
enddo
call df_index1_tr(npos, intpos, teintf, nbll, dcore(imem),
& dcore(ii4core), dcore(ic_act+(nblock-1)*nbl), dcore(icpr),
& dtol)
call dgemm('n', 'n', dfnbasis*nbll, nbasis, nbasis, 1.0d0,
& dcore(imem), dfnbasis*nbll, dcore(extr_c), nbasis, 0.0d0,
& dcore(iact_int), dfnbasis*nbll)
call df_save_integ(dcore(iact_int), nbl*(nblock-1)+1, nbll, 1,
& nbasis, integ_file)
call df_save_act_integ(dcore(iact_int), nbl*(nblock-1)+1, nbll,
& offset, integ_file2)
close(integ_file)
close(integ_file2)
CALL INTCLOSE(TEINTF)
call dbldealloc(ic_act)
if(recalc) return
c Allocate memory for MO integrals
imoint = dblalloc(nact**3*nbasis) ! (mw|xy)
iact_int = dblalloc(dfnbasis*nact**2) ! (P|xy)
maxm=maxcor-(imem-imem1)
if(dfnbasis*nbasis.gt.maxm) then
write(iout,*)' Insufficient memory for integral transformation!'
write(iout,*)' No space for MO integrals!'
call mrccend(1)
endif
i=mod(maxm,dfnbasis*nbasis)
nbl=min(nact,(maxm-i)/(dfnbasis*nbasis))
nbll=mod(nact,nbl)
nblock=(nact-nbll)/nbl
if(nbll.ne.0) then
nblock=nblock+1
else
nbll=nbl
endif
call dfillzero(dcore(imoint), nact**3*nbasis)
open(unit=integ_file2, file=modf_act_integs, form='unformatted')
call df_read_integ(dcore(iact_int), nact, nact, .false.,
& integ_file2)
close(integ_file2)
open(unit=integ_file, file=modf_integs, form='unformatted')
c Calculating MO integrals
do i = 1, nblock-1
call df_read_integ(dcore(imem), nbasis, nbl, .true., integ_file)
call dgemm('t', 'n', nact**2, nbl*nbasis, dfnbasis, 1.0d0,
& dcore(iact_int), dfnbasis, dcore(imem), dfnbasis, 1.0d0,
& dcore(imoint+nact**2*nbasis*(i-1)*nbl), nact**2)
enddo
call df_read_integ(dcore(imem), nbasis, nbll, .true., integ_file)
call dgemm('t', 'n', nact**2, nbll*nbasis, dfnbasis, 1.0d0,
& dcore(iact_int), dfnbasis, dcore(imem), dfnbasis, 1.0d0,
& dcore(imoint+nact**2*nbasis*(nblock-1)*nbl), nact**2)
close(integ_file)
call dbldealloc(iact_int)
c Transpose the integrals
itmp = dblalloc(nbasis*nact**3)
call transp_moint(dcore(imoint), dcore(itmp), nact**2,
& nbasis*nact)
call dcopy(nbasis*nact**3, dcore(itmp), 1, dcore(imoint), 1)
call dbldealloc(itmp)
end subroutine
************************************************************************
subroutine df_hessq(npos, intpos, offset, sqroffset, qmat, kappa,
& p4_symm)
************************************************************************
************************************************************************
use common_mod, only: maxcor, orbperir, pepsilon, dfnbasis,
& nbasis, iout
implicit none
integer npos, intpos(3,(nbasis+1)*nbasis/2), offset(nir)
integer sqroffset(nir)
integer j,l
integer ictr, extr_c, itmp, ic_act, iact_int, i, ii, maxm, icpr
integer nbl, nbll, nblock, teintf(10), ii4core, ikappa_act, k, ir
double precision qmat(nbasis, nact), kappa(qscfsize)
double precision p4_symm(nact, nact, nact, nact)
double precision ss, dtol
integer integ_file
parameter(integ_file = 666)
integer dblalloc, mod
integer imem1, imem_old
common/memcom/ imem1
imem_old = imem
c Calculating transformed MO coefficients
ictr = dblalloc(nbasis*nact)
if(lsa) then
extr_c = dblalloc(nbasis**2)
call extract_mo(offset, dcore(imem), extr_c)
else
extr_c = c_ptr
endif
call transf_coef(dcore(extr_c), kappa, dcore(ictr), offset)
if(lsa) call dbldealloc(extr_c)
c Prescreening
icpr = dblalloc(nbasis)
do i=1,nbasis
ss=0.d0
do ii=1, nact
ss=max(ss,dabs(dcore(ictr+ii-1+(i-1)*nact)))
enddo
dcore(icpr+i-1)=ss
enddo
c First part: the 2nd index is transformed with kappa
iact_int = dblalloc(dfnbasis*nact**2)
open(unit=integ_file, file=modf_act_integs, form='unformatted')
call df_read_integ(dcore(imem), nact, nact, .false., integ_file)
close(integ_file)
call dgemm('n', 'n', dfnbasis, nact**2, nact**2, 1.0d0,
& dcore(imem), dfnbasis, dcore(ip4), nact**2, 0.0d0,
& dcore(iact_int), dfnbasis)
itmp = dblalloc(nbasis*nact)
call dfillzero(dcore(itmp), nbasis*nact)
ii=3*dfnbasis
ii=(ii+mod(ii,2))/2
ii4core=dblalloc(ii)
c dtol=pepsilon/dfloat(nbasis*nact)
dtol=min(pepsilon, 1.0d-8)/dfloat(nbasis*nact)
maxm=maxcor-(imem-imem1)
if(dfnbasis*nbasis.gt.maxm) then
write(iout,*)' Insufficient memory for integral transformation!'
write(iout,*)' No space for MO integrals!'
call mrccend(1)
endif
i=mod(maxm,dfnbasis*nbasis)
nbl=min(nact,(maxm-i)/(dfnbasis*nbasis))
nbll=mod(nact,nbl)
nblock=(nact-nbll)/nbl
if(nbll.ne.0) then
nblock=nblock+1
else
nbll=nbl
endif
CALL INTOPENRSQ(TEINTF)
do i = 1, nblock-1
call df_index1_tr(npos, intpos, teintf, nbl, dcore(imem),
& dcore(ii4core), dcore(ictr+(i-1)*nbl), dcore(icpr), dtol)
call dgemm('t', 'n', nbasis, nact, dfnbasis*nbl, 1.0d0,
& dcore(imem), dfnbasis*nbl,
& dcore(iact_int+(i-1)*dfnbasis*nbl), dfnbasis*nact, 1.0d0,
& dcore(itmp), nbasis)
enddo
call df_index1_tr(npos, intpos, teintf, nbl, dcore(imem),
& dcore(ii4core), dcore(ictr+(nblock-1)*nbl), dcore(icpr),
& dtol)
call dgemm('t', 'n', nbasis, nact, dfnbasis*nbll, 1.0d0,
& dcore(imem), dfnbasis*nbl,
& dcore(iact_int+(nblock-1)*dfnbasis*nbl), dfnbasis*nact,
& 1.0d0, dcore(itmp), nbasis)
CALL INTCLOSE(TEINTF)
if(lsa) then
extr_c = dblalloc(nbasis**2)
call extract_mo(offset, dcore(imem), extr_c)
else
extr_c = c_ptr
endif
call dgemm('t', 'n', nbasis, nact, nbasis, 1.0d0, dcore(extr_c),
& nbasis, dcore(itmp), nbasis, 1.0d0, qmat, nbasis)
call dbldealloc(ictr)
c Second part: The 3rd index is transformed with kappa
iact_int = dblalloc(dfnbasis*nact**2)
ikappa_act = dblalloc(nact*nbasis)
call dfillzero(dcore(ikappa_act), nbasis*nact)
call mxvec_conv(dcore(imem), kappa, orbperir, qscfsize,
& sqroffset, .false., .true.)
k = 0
do ir = 1, nir
do i = 1, nactperir(ir)
call dcopy(nfunc(ir),
& dcore(imem+sqroffset(ir)-1+orbperir(ir)+i-1), nfunc(ir),
& dcore(ikappa_act+k+(offset(ir)-1)*nact), nact)
k = k + 1
enddo
enddo
maxm=maxcor-(imem-imem1)
if(dfnbasis*nbasis.gt.maxm) then
write(iout,*)' Insufficient memory for integral transformation!'
write(iout,*)' No space for MO integrals!'
call mrccend(1)
endif
i=mod(maxm,dfnbasis*nbasis)
nbl=min(nact,(maxm-i)/(dfnbasis*nbasis))
nbll=mod(nact,nbl)
nblock=(nact-nbll)/nbl
if(nbll.ne.0) then
nblock=nblock+1
else
nbll=nbl
endif
open(unit=integ_file, file=modf_integs, form='unformatted')
do i = 1, nblock-1
call df_read_integ(dcore(imem), nbl, nbasis, .false.,integ_file)
call dgemm('n', 't', nact, dfnbasis*nbl, nbasis, 1.0d0,
& dcore(ikappa_act), nact, dcore(imem), dfnbasis*nbl, 0.0d0,
& dcore(iact_int+(i-1)*dfnbasis*nbl*nact), nact)
enddo
call df_read_integ(dcore(imem), nbll, nbasis, .false., integ_file)
call dgemm('n', 't', nact, dfnbasis*nbll, nbasis, 1.0d0,
& dcore(ikappa_act), nact, dcore(imem), dfnbasis*nbll, 0.0d0,
& dcore(iact_int+(nblock-1)*dfnbasis*nbl*nact), nact)
call transp_moint(dcore(iact_int), dcore(imem), nact,
& dfnbasis*nact)
call dgemm('n', 'n', dfnbasis, nact**2, nact**2, 1.0d0,
& dcore(imem), dfnbasis, p4_symm, nact**2, 0.0d0,
& dcore(iact_int), dfnbasis)
close(integ_file)
open(unit=integ_file, file=modf_integs, form='unformatted')
do i = 1, nblock-1
call df_read_integ(dcore(imem), nbl, nbasis, .false.,integ_file)
call dgemm('t', 'n', nbasis, nact, dfnbasis*nbl, 1.0d0,
& dcore(imem), dfnbasis*nbl,
& dcore(iact_int+(i-1)*dfnbasis*nbl), dfnbasis*nact,
& 1.0d0, qmat, nbasis)
enddo
call df_read_integ(dcore(imem), nbll, nbasis, .false., integ_file)
call dgemm('t', 'n', nbasis, nact, dfnbasis*nbll, 1.0d0,
& dcore(imem), dfnbasis*nbll,
& dcore(iact_int+(nblock-1)*dfnbasis*nbl), dfnbasis*nact,
& 1.0d0, qmat, nbasis)
close(integ_file)
call dbldealloc(imem_old)
end subroutine
************************************************************************
subroutine df_save_integ(hai, start_n, n, start_m, m, output_file)
************************************************************************
************************************************************************
use common_mod, only: dfnbasis
implicit none
integer start_n, n, start_m, m, output_file
integer i, j, k
double precision hai(dfnbasis, n, m)
do j = 1, dfnbasis
do i = 1, n
do k = 1, m
write(output_file) hai(j, i, k), j, start_n+i-1, start_m+k-1
enddo
enddo
enddo
end subroutine
************************************************************************
subroutine df_save_act_integ(hai, start_n, n, offset, output_file)
************************************************************************
************************************************************************
use common_mod, only: dfnbasis, nbasis, nir, orbperir
implicit none
integer start_n, n, output_file, offset(nir)
integer i, j, k, m, ir
double precision hai(dfnbasis, n, nbasis)
m = 0
do ir = 1, nir
do j = 1, nactperir(ir)
do k = 1, n
do i = 1, dfnbasis
write(output_file)hai(i, k, offset(ir)+orbperir(ir)+j-1),
& i, start_n+k-1, j+m
enddo
enddo
enddo
m = m + nactperir(ir)
enddo
end subroutine
************************************************************************
subroutine df_read_integ(hai, n, m, transp, input_file)
************************************************************************
************************************************************************
use common_mod, only: dfnbasis
implicit none
integer n, m, input_file
integer j, x, y, z, y_start, z_start
double precision hai(dfnbasis, n, m), tmp
logical transp
read(input_file) tmp, x, y, z
y_start = y - 1
z_start = z - 1
if(transp) then
hai(x, z - z_start, y - y_start) = tmp
do j = 1, dfnbasis*n*m-1
read(input_file) tmp, x, y, z
hai(x, z - z_start, y - y_start) = tmp
enddo
else
hai(x, z - z_start, y - y_start) = tmp
do j = 1, dfnbasis*n*m-1
read(input_file) tmp, x, y, z
hai(x, y - y_start, z - z_start) = tmp
enddo
endif
end subroutine
************************************************************************
subroutine transp_moint(a, at, n, m)
************************************************************************
************************************************************************
implicit none
integer n, m
integer i, j, k
double precision a(n, m)
double precision at(m, n)
at = transpose(a)
end subroutine
************************************************************************
subroutine transf_coef(c, kappa, ctr, offset)
************************************************************************
************************************************************************
use common_mod, only: nfunc, orbperir, nir, nirmax
implicit none
integer offset(2*nirmax)
integer kos, dimir, noccir, nactir, nvirtir, ir
double precision c(nbasis, nbasis), ctr(nbasis*nact)
double precision kappa(qscfsize)
kos = 1
ctr = 0.0d0
do ir = 1, nir
dimir = nfunc(ir)
noccir = orbperir(ir)
nactir = nactperir(ir)
if(nactperir(ir) .ne. 0 .and. orbperir(ir) .ne. 0) then
call dgemm('n', 't', nactperir(ir), nbasis, orbperir(ir),
& 1.0d0, kappa(kos), nactperir(ir), c(1,offset(ir)),
& nbasis, 1.0d0, ctr(actoffset(ir)), nact)
endif
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
if(nactperir(ir).ne.0 .and. nvirtir.ne.0) then
call dgemm('t', 't', nactperir(ir), nbasis, nvirtir,
& -1.0d0, kappa(kos+(nactperir(ir)+nvirtir)*orbperir(ir)),
& nvirtir, c(1, offset(ir)+orbperir(ir)+nactperir(ir)),
& nbasis, 1.0d0, ctr(actoffset(ir)), nact)
endif
kos = kos + (nactir + nvirtir)*noccir + nactir*nvirtir
enddo
end subroutine
************************************************************************
subroutine extract_mo(offset, tmp, extr_c)
************************************************************************
************************************************************************
use common_mod, only: dcore, c_ptr, symtra_ptr, nbasis,
& nirmax, lsa
implicit none
integer extr_c, offset(nir)
double precision tmp(nbasis, nbasis)
if(lsa) then
call mx_symm_extr(tmp, dcore(c_ptr), offset)
call dgemm('n', 'n', nbasis, nbasis, nbasis, 1.0d0,
& dcore(symtra_ptr), nbasis, tmp, nbasis,
& 0.0d0, dcore(extr_c), nbasis)
else
extr_c = c_ptr
endif
end subroutine
************************************************************************
subroutine active_mo(offset, extr_c, ic_act)
************************************************************************
* This subroutine copies the MO coefficients of the active orbitals into
* the array pointed by ic_act
************************************************************************
use common_mod, only: nirmax, nbasis, orbperir
implicit none
integer extr_c, ic_act, offset(nirmax)
integer k, ir, i
k = 1
do ir = 1, nir
do i = 1, nactperir(ir)
call dcopy(nbasis,
& dcore(extr_c+(offset(ir)+orbperir(ir)+i-2)*nbasis), 1,
& dcore(ic_act+(k-1)*nbasis), 1)
k = k + 1
enddo
enddo
end subroutine
************************************************************************
subroutine tr_index_hess(g3, c_act, ctr, moint1, moint2, g2)
************************************************************************
* Transforms the 2nd, 3rd and 4th indeces of the AO integrals to MO
* basis. The 2nd index of the moint1 array and the 3rd index of the
* moint2 array are transformed with c2 (the transformed MO cefficients),
* the other indeces are transformed with c (the original MO coef matrix)
* The 1st index is left in AO basis for both moint1/2.
* g2 is a working array
************************************************************************
implicit none
integer i,j,k,l
double precision g3(nbasis, nact, nbasis, nbasis)
double precision moint1(nact, nact, nact, nbasis)
double precision moint2(nact, nact, nact, nbasis)
double precision g2(nact, nact, nbasis, nbasis)
double precision c_act(nbasis, nact)
double precision ctr(nact, nbasis)
c Calculating moint1
call dgemm('t', 'n', nact, nbasis**2*nact, nbasis, 1.0d0, c_act,
& nbasis, g3, nbasis, 0.0d0, g2, nact)
call dgemm('n', 't', nact, nbasis*nact**2, nbasis, 1.0d0, ctr,
& nact, g2, nbasis*nact**2, 0.0d0, moint1, nact)
c Calculating moint2
call dgemm('n', 'n', nact, nbasis**2*nact, nbasis, 1.0d0, ctr,
& nact, g3, nbasis, 0.0d0, g2, nact)
call dgemm('t', 't', nact, nbasis*nact**2, nbasis, 1.0d0, c_act,
& nbasis, g2, nbasis*nact**2, 0.0d0, moint2, nact)
end subroutine
************************************************************************
subroutine tr_index_grad(g3, g2, g1, moint, c, c_act)
************************************************************************
* Transforms the 2nd, 3rd and 4th indeces of the AO integrals to MO
* basis. The moint array stores the MO integrals in (11|22) format.
************************************************************************
use common_mod, only: nbasis
implicit none
integer i,j,k,l
double precision c(nbasis, nbasis), c_act(nbasis, nact)
double precision g3(nbasis, nact, nbasis, nbasis)
double precision g2(nact, nact, nbasis, nbasis)
double precision g1(nact, nact, nact, nbasis)
double precision moint(nbasis, nact, nact, nact)
call dgemm('t', 'n', nact, nbasis**2*nact, nbasis, 1.0d0, c_act,
& nbasis, g3, nbasis, 0.0d0, g2, nact)
call dgemm('t', 't', nact, nbasis*nact**2, nbasis, 1.0d0, c_act,
& nbasis, g2, nbasis*nact**2, 0.0d0, g1, nact)
call dgemm('t', 't', nbasis, nact**3, nbasis, 1.0d0, c, nbasis,
& g1, nact**3, 0.0d0, moint, nbasis)
end subroutine
************************************************************************
subroutine refdet(mult, sym, multpg, det)
************************************************************************
* Create reference determinant for CI calculation (written to fort.56)
************************************************************************
use common_mod, only: iout
implicit none
integer sym, mult, multpg(8, 8), det(nact)
integer nalpha, nbeta, npair, nel, i, k, l
integer combin(100), asym(100), tosym(100);
logical cond
det = 0
! storing the symmetry of the active orbitals
k = 1
do i = 1, nirmax
if(nactperir(i) .ne. 0) then
do l = k, k+nactperir(i)-1
tosym(l) = i
enddo
k = k + nactperir(i)
endif
enddo
nalpha = mult - 1
nbeta = 0
npair = (nactel - nalpha)/2
nel = nalpha
cond = .false.
do
if(nel.eq.0) then ! closed shell (?)
if(sym .eq. 1) then
k = 1
do while(npair .ne. 0)
if(det(k) .eq. 0) then
det(k) = 2
npair = npair - 1
endif
k = k + 1
enddo
return
else
if(npair.eq.0) then
write(iout,'(A)')
& ' ERROR: CANNOT GENERATE REFERENCE DETERMINANT!'
call mrccend(1)
endif
npair = npair - 1
nalpha = nalpha + 1
nbeta = nbeta + 1
nel = nel + 2
endif
endif
! calculating all posible combinations
do i = 1, nel
combin(i) = i
enddo
i = nel
do while(combin(1) .le. nact-nel+1)
do while(i > 1 .and. combin(i) .eq. nact-nel+i)
i = i - 1
enddo
do k = 1, nel
asym(k) = tosym(combin(k))
enddo
if(sym .eq. symm_mult(nel, asym, multpg)) then
cond = .true.
exit
endif
combin(i) = combin(i) + 1
do while(i .lt. nel)
combin(i+1) = combin(i) + 1
i = i + 1
enddo
enddo
if(cond) then
do k = 1, nbeta
det(combin(k)) = -1
enddo
do k = nbeta+1, nel
det(combin(k)) = 1
enddo
k = 1
do while(npair .ne. 0)
if(det(k) .eq. 0) then
det(k) = 2
npair = npair - 1
endif
k = k + 1
enddo
return
else
if(npair.eq.0) then
write(iout,'(A)')
& ' ERROR: CANNOT GENERATE REFERENCE DETERMINANT!'
call mrccend(1)
endif
npair = npair - 1
nalpha = nalpha + 1
nbeta = nbeta + 1
nel = nel + 2
endif
enddo
end subroutine
************************************************************************
integer function symm_mult(n, sym, multpg) result(ss)
************************************************************************
************************************************************************
implicit none
integer n, sym(n), multpg(8, 8)
integer k
ss = sym(1)
do k = 2, n
ss = multpg(ss, sym(k))
enddo
return
end function
************************************************************************
subroutine mk_grad(fock, grad, sqroffset, qscfsize, alpha)
************************************************************************
* MCSCF gradient
************************************************************************
implicit none
integer qscfsize, sqroffset(nir), m, n, ir, l, r, i, a, k, nvirtir
double precision fock(sqrsize), grad(qscfsize), alpha
grad = 0.0d0
if(scftype .eq. 1 .or. scftype .eq. 2) then
n = 1
do k = 0, rmax
do ir = 1, nir
if(nfunc(ir) .eq. orbperir(ir+k*nir)) cycle
do i = 1, orbperir(ir+k*nir)
do a = orbperir(ir+k*nir)+1, nfunc(ir)
grad(n)=fock(sqrsize*k+sqroffset(ir)+(i-1)*nfunc(ir)+a-1)
n = n + 1
enddo
enddo
enddo
enddo
elseif(scftype .ge. 3) then
n = 1
do ir = 1, nir
if(nfunc(ir) .eq. 0) cycle
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
c active-occupied part
if(orbperir(ir) .ne. 0 .and. nactperir(ir) .ne. 0) then
do i = 1, orbperir(ir)
do m = orbperir(ir)+1, orbperir(ir)+nactperir(ir)
grad(n) = fock(sqroffset(ir)+m-1+(i-1)*nfunc(ir)) -
& fock(sqroffset(ir)+i-1+(m-1)*nfunc(ir))
n = n + 1
enddo
enddo
endif
c virtual - occupied part
if(orbperir(ir) .ne. 0 .and. nvirtir .ne. 0) then
do i = 1, orbperir(ir)
do m = orbperir(ir)+nactperir(ir)+1, nfunc(ir)
grad(n) = fock(sqroffset(ir)+m-1+(i-1)*nfunc(ir))
n = n + 1
enddo
enddo
endif
c virtual - active part
if(nvirtir .ne. 0 .and. nactperir(ir) .ne. 0) then
do m = orbperir(ir)+1, orbperir(ir)+nactperir(ir)
do i = orbperir(ir)+nactperir(ir)+1, nfunc(ir)
grad(n) = fock(sqroffset(ir)+i-1+(m-1)*nfunc(ir))
n = n + 1
enddo
enddo
endif
enddo
else
l = 1
do r = 0, rmax
do ir = 1, nir
nvirtir = nfunc(ir) - orbperir(ir+r*nir) - nactperir(ir)
c active-occupied part
if(orbperir(ir+r*nir) .ne. 0 .and. nactperir(ir) .ne. 0)then
do n = 1, orbperir(r*nir+ir)
do m = orbperir(r*nir+ir)+1,
& orbperir(ir+r*nir)+nactperir(ir)
grad(l) =
& fock(sqroffset(ir)+r*sqrsize+m-1+(n-1)*nfunc(ir)) -
& fock(sqroffset(ir)+r*sqrsize+n-1+(m-1)*nfunc(ir))
l = l + 1
enddo
enddo
endif
c virtual-occupied part
if(orbperir(ir+r*nir) .ne. 0 .and. nvirtir .ne. 0) then
do n = 1, orbperir(r*nir+ir)
do m = 1+orbperir(r*nir+ir)+nactperir(ir), nfunc(ir)
grad(l) =
& fock(sqroffset(ir)+r*sqrsize+m-1+(n-1)*nfunc(ir))
l = l + 1
enddo
enddo
endif
c virtual-active part
if(nactperir(r*nir+ir) .ne. 0 .and. nvirtir .ne. 0) then
do n = 1+orbperir(r*nir+ir),
& orbperir(r*nir+ir)+nactperir(ir)
do m = 1+orbperir(ir+r*nir)+nactperir(ir), nfunc(ir)
grad(l) =
& fock(sqroffset(ir)+r*sqrsize+m-1+(n-1)*nfunc(ir))
l = l + 1
enddo
enddo
endif
enddo
enddo
endif
call dscal(qscfsize, alpha, grad, 1)
end subroutine
************************************************************************
subroutine mxvec_conv(mat, vec, orbperir, qscfsize, sqroffset,
& ldir, ljob)
************************************************************************
* Transform matrix representation to vector representation and back.
* Used for kappa matrix <-> kappa vector conversion
* ldir = .TRUE. : matrix to vector
* ldir = .FALSE. : vector to matrix
* ljob = .TRUE. : destructive mode, the vec or mat array is overwritten
* ljob = .FALSE. : additive mode
************************************************************************
use common_mod, only: sqrsize, nir, nfunc
implicit none
integer qscfsize, sqroffset(nir), orbperir(nir)
integer n, l, m, j, i, ir
double precision mat(sqrsize), vec(qscfsize)
logical ldir, ljob
if(ljob) then
if(ldir) then
call dfillzero(vec, qscfsize)
l = 1
do ir = 1, nir
c active-occupied part
do n = 1, orbperir(ir)
do m = orbperir(ir)+1, orbperir(ir)+nactperir(ir)
vec(l) = mat(sqroffset(ir)+m-1+(n-1)*nfunc(ir))
l = l + 1
enddo
enddo
c virtual-occupied part
do n = 1, orbperir(ir)
do m = 1+orbperir(ir)+nactperir(ir), nfunc(ir)
vec(l) = mat(sqroffset(ir)+m-1+(n-1)*nfunc(ir))
l = l + 1
enddo
enddo
c virtual-active part
do n = 1+orbperir(ir), orbperir(ir)+nactperir(ir)
do m = 1+orbperir(ir)+nactperir(ir), nfunc(ir)
vec(l) = mat(sqroffset(ir)+m-1+(n-1)*nfunc(ir))
l = l + 1
enddo
enddo
enddo
else
call dfillzero(mat, sqrsize)
n = 1
do ir = 1, nir
c active-occupied part
do j = 1, orbperir(ir)
do i = orbperir(ir)+1, orbperir(ir)+nactperir(ir)
mat(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) = vec(n)
mat(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) = -vec(n)
n = n + 1
enddo
enddo
c virtual-occupied part
do j = 1, orbperir(ir)
do i = orbperir(ir)+nactperir(ir)+1, nfunc(ir)
mat(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) = vec(n)
mat(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) = -vec(n)
n = n + 1
enddo
enddo
c virtual-active part
do j = 1+orbperir(ir), orbperir(ir)+nactperir(ir)
do i = orbperir(ir)+nactperir(ir)+1, nfunc(ir)
mat(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) = vec(n)
mat(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) = -vec(n)
n = n + 1
enddo
enddo
enddo
endif
else
if(ldir) then
l = 1
do ir = 1, nir
c active-occupied part
do n = 1, orbperir(ir)
do m = orbperir(ir)+1, orbperir(ir)+nactperir(ir)
vec(l) = vec(l) + mat(sqroffset(ir)+m-1+(n-1)*nfunc(ir))
l = l + 1
enddo
enddo
c virtual-occupied part
do n = 1, orbperir(ir)
do m = 1+orbperir(ir)+nactperir(ir), nfunc(ir)
vec(l) = vec(l) + mat(sqroffset(ir)+m-1+(n-1)*nfunc(ir))
l = l + 1
enddo
enddo
c virtual-active part
do n = 1+orbperir(ir), orbperir(ir)+nactperir(ir)
do m = 1+orbperir(ir)+nactperir(ir), nfunc(ir)
vec(l) = vec(l) + mat(sqroffset(ir)+m-1+(n-1)*nfunc(ir))
l = l + 1
enddo
enddo
enddo
else
n = 1
do ir = 1, nir
c active-occupied part
do j = 1, orbperir(ir)
do i = orbperir(ir)+1, orbperir(ir)+nactperir(ir)
mat(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) =
& mat(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) + vec(n)
mat(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) =
& mat(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) - vec(n)
n = n + 1
enddo
enddo
c virtual-occupied part
do j = 1, orbperir(ir)
do i = orbperir(ir)+nactperir(ir)+1, nfunc(ir)
mat(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) =
& mat(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) + vec(n)
mat(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) =
& mat(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) - vec(n)
n = n + 1
enddo
enddo
c virtual-active part
do j = 1+orbperir(ir), orbperir(ir)+nactperir(ir)
do i = orbperir(ir)+nactperir(ir)+1, nfunc(ir)
mat(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) =
& mat(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) + vec(n)
mat(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) =
& mat(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) - vec(n)
n = n + 1
enddo
enddo
enddo
endif
endif
end subroutine
************************************************************************
subroutine lintr(kappa, sigma, grad, offset, sqroffset, qscfsize,
& npos, chfx, exc, step, precond, lfin, embed, lwdfn,
& scfdamp, route, nfr, nc, ncorenew, devparr, clrhfx, csrhfx,
& omega, pcm)
************************************************************************
* Linear transformation with the MCSCF (QSCF) Hessian (sigma = H*kappa)
************************************************************************
use common_mod, only: nbasis, nir, sqrsize, dcore, imem
implicit none
integer offset(nir), sqroffset(nir), npos, qscfsize, ir, i, j
integer ihcore, oeintfile, step
double precision kappa(qscfsize), sigma(qscfsize), grad(qscfsize)
double precision clrhfx,csrhfx,omega
double precision chfx, exc
integer icc, itmp, ihess
double precision, allocatable :: kappa_mx(:,:)
logical precond
parameter(oeintfile = 71)
integer lfin,nfr,nc,ncorenew
double precision devparr(2)
character*4 route
character*16 scfdamp
character*32 pcm
logical lwdfn
character*8 embed
sigma = 0.0d0
if(precond) then
call lintr_approx(kappa, sigma, dcore(ip2), dcore(ifock_ptr),
& dcore(afock_ptr), dcore(iq), dcore(imem), offset,sqroffset)
return
endif
call lintr_com(kappa, sigma, dcore(c_ptr), dcore(ifock_ptr),
& dcore(afock_ptr), dcore(iq), dcore(ip2), dcore(ip4),
& qscfsize, npos, offset, sqroffset, chfx, step, precond,
& lfin, exc, embed, lwdfn, scfdamp, route, nfr, nc,
& ncorenew, devparr, clrhfx, csrhfx, omega,pcm)
if(scftype .eq. 0 .or. scftype .ge. 3) then
call lintr_mcscf(kappa, grad, sigma, qscfsize, sqroffset,
& offset)
endif
if(dft .ne. 'off ') then
call lintr_dft(kappa, sigma, dcore(c_ptr), offset, sqroffset,
& exc)
endif
end subroutine
************************************************************************
subroutine lintr_dft(x, sigma, c, offset, sqroffset, exc)
************************************************************************
c Add DFT part for sigma vector
************************************************************************
use common_mod, only: nfunc, orbperir, nir, sqrsize, lsa,
& symfock_ptr, symfock2_ptr, symdens_ptr, symdens2_ptr,
& symtra_ptr, nbasis, nal, nbe, dcore, imem, scftype, verblevel,
& maxcor, iout, ifltln, minpfile
implicit none
integer offset(nir), sqroffset(nir), itmp(2)
integer imo(2), iy(2), id(2), icsymm(2), imem_old
integer xos, r, ir, dimir, noccir, nvirtir, i, a
double precision x(qscfsize), sigma(qscfsize)
double precision c(sqrsize), exc
integer grfile
parameter(grfile = 15)
integer dblalloc
imem_old = imem
itmp(1) = dblalloc(nbasis**2)
itmp(2) = dblalloc(nbasis**2)
if(lsa) then
id(1) = symfock_ptr
id(2) = symfock2_ptr
icsymm(1) = symdens_ptr
icsymm(2) = symdens2_ptr
xos = 1
call dfillzero(dcore(id(1)), nbasis**2)
if(scftype .eq. 2) call dfillzero(dcore(id(2)), nbasis**2)
do r = 0, rmax
do ir = 1, nir
if(nfunc(ir).eq.0.or.nfunc(ir).eq.orbperir(ir+r*nir)) cycle
noccir = orbperir(ir+r*nir)
nvirtir = nfunc(ir) - orbperir(ir+r*nir)
dimir = nfunc(ir)
call dfillzero(dcore(itmp(1)), dimir**2)
do i = 1, noccir
do a = 1, nvirtir
dcore(itmp(1)+noccir+a-1+(i-1)*dimir) =
& x(xos+a-1+(i-1)*nvirtir)
enddo
enddo
call symmat(dcore(itmp(1)), dimir)
call dgemm('n', 'n', dimir, dimir, dimir, 1.0d0,
& c(r*sqrsize+sqroffset(ir)), dimir, dcore(itmp(1)),
& dimir, 0.0d0, dcore(itmp(2)), dimir)
call dgemm('n', 't', dimir, dimir, dimir, 1.0d0,
& dcore(itmp(2)), dimir, c(r*sqrsize+sqroffset(ir)),
& dimir, 0.0d0, dcore(id(r+1)+(offset(ir)-1)*(nbasis+1)),
& nbasis)
xos = xos + noccir*nvirtir
enddo
call mx_basis_tr(dcore(id(r+1)), dcore(symtra_ptr),
& dcore(icsymm(r+1)), 'TO', nbasis)
call mx_symm_extr(dcore(itmp(1)), c(r*sqrsize+1), offset)
call dgemm('n', 'n', nbasis, nbasis, nbasis, 1.0d0,
& dcore(symtra_ptr), nbasis, dcore(itmp(1)), nbasis,
& 0.0d0, dcore(icsymm(r+1)), nbasis)
enddo
imo(1) = dblalloc(nal*nbasis)
if(scftype .eq. 2) then
imo(2) = dblalloc(nbe*nbasis)
else
imo(2) = imo(1)
endif
call dvxc(nbasis, nal, nbe, dcore(itmp(1)), dcore(itmp(2)),
& dcore(imo(1)), dcore(imo(2)), grfile, dcore,iout, exc, dft,
& minpfile, scftype, ifltln, maxcor, imem, dcore, verblevel,
& 2, dcore(itmp(1)), 'vxcd', dcore(id(1)), dcore(id(2)),
& dcore(icsymm(1)), dcore(icsymm(2)), dcore(itmp(1)),
& dcore(itmp(1)), dcore(itmp(1)), dcore(itmp(1)), 200, 0, 1,
& 1, multiplicity)
call dbldealloc(imo(1))
do r = 0, rmax
call mx_basis_tr(dcore(itmp(r+1)), dcore(symtra_ptr),
& dcore(id(1)), 'TS', nbasis)
xos = 0
do ir = 1, nir
if(nfunc(ir).eq.0.or.nfunc(ir).eq.orbperir(ir+r*nir)) cycle
noccir = orbperir(ir+r*nir)
nvirtir = nfunc(ir) - orbperir(ir+r*nir)
dimir = nfunc(ir)
call dgemm('t', 'n', nvirtir, dimir, dimir, 1.0d0,
& c(r*sqrsize+sqroffset(ir)+noccir*dimir), dimir,
& dcore(itmp(r+1)+(offset(ir)-1)*(nbasis+1)),
& nbasis, 0.0d0, dcore(id(r+1)), nvirtir)
call dgemm('n', 'n', nvirtir, noccir, dimir, 1.0d0,
& dcore(id(r+1)), nvirtir, c(r*sqrsize+sqroffset(ir)),
& dimir, 1.0d0, sigma(r*qscfsizea+xos+1), nvirtir)
xos = xos + nvirtir*noccir
enddo
enddo
else
imo(1) = dblalloc(nal*nbasis)
id(1) = dblalloc(nbasis**2)
iy(1) = dblalloc(qscfsizea)
call dfillzero(dcore(iy(1)),qscfsizea)
if(scftype .eq. 2) then
imo(2) = dblalloc(nbe*nbasis)
iy(2) = dblalloc(qscfsizeb)
id(2) = dblalloc(nbasis**2)
call dfillzero(dcore(iy(2)),qscfsizeb)
else
imo(2) = imo(1)
iy(2) = iy(1)
id(2) = id(1)
endif
call dvxc(nbasis, nal, nbe, dcore(itmp(1)), dcore(itmp(2)),
& dcore(imo(1)), dcore(imo(2)), grfile, dcore, iout, exc,
& dft, minpfile, scftype,ifltln, maxcor, imem, dcore,
& verblevel, 2, dcore(itmp(1)), 'vxcd', dcore(id(1)),
& dcore(id(2)), c, c(rmax*sqrsize+1), x, x(rmax*qscfsizea+1),
& dcore(iy(1)), dcore(iy(2)), 2, 0, 1, 1, multiplicity)
call daxpy(qscfsizea, 1.0d0, dcore(iy(1)), 1, sigma, 1)
if(scftype .eq. 2) call daxpy(qscfsizeb, 1.0d0, dcore(iy(2)), 1,
& sigma(1+qscfsizea), 1)
endif
call dbldealloc(imem_old)
end subroutine
************************************************************************
subroutine lintr_mcscf(kappa, grad, sigma, qscfsize, sqroffset,
& offset)
************************************************************************
* [kappa, grad] part of the Hessian (only for MCSCF)
************************************************************************
implicit none
integer p, q, ir, nvirtir, qscfsize, sqroffset(nir), kos
integer offset(nir)
double precision kappa(qscfsize), grad(qscfsize), sigma(qscfsize)
kos = 1
do ir = 1, nir
nvirtir = nfunc(ir)-orbperir(ir)-nactperir(ir)
if(nactperir(ir).ne.0 .and. orbperir(ir).ne.0 .and.
& nvirtir.ne.0) then
c p = active, q = occ, r = virt
call dgemm('t', 'n', nactperir(ir), orbperir(ir), nvirtir,
& 0.5d0, kappa(kos+(nvirtir+nactperir(ir))*orbperir(ir)),
& nvirtir, grad(kos+nactperir(ir)*orbperir(ir)), nvirtir,
& 1.0d0, sigma(kos), nactperir(ir))
call dgemm('t', 'n', nactperir(ir), orbperir(ir), nvirtir,
& -0.5d0, grad(kos+(nvirtir+nactperir(ir))*orbperir(ir)),
& nvirtir, kappa(kos+nactperir(ir)*orbperir(ir)),
& nvirtir, 1.0d0, sigma(kos), nactperir(ir))
c p = virt, q = occ, r = act
call dgemm('n', 'n', nvirtir, orbperir(ir), nactperir(ir),
& -0.5d0, kappa(kos+(nvirtir+nactperir(ir))*orbperir(ir)),
& nvirtir, grad(kos), nactperir(ir), 1.0d0,
& sigma(kos+nactperir(ir)*orbperir(ir)), nvirtir)
call dgemm('n', 'n', nvirtir, orbperir(ir), nactperir(ir),
& 0.5d0, grad(kos+(nvirtir+nactperir(ir))*orbperir(ir)),
& nvirtir, kappa(kos), nactperir(ir), 1.0d0,
& sigma(kos+nactperir(ir)*orbperir(ir)), nvirtir)
c p = virt, q = act, r = occ
call dgemm('n', 't', nvirtir, nactperir(ir), orbperir(ir),
& 0.5d0, kappa(kos+nactperir(ir)*orbperir(ir)), nvirtir,
& grad(kos), nactperir(ir), 1.0d0,
& sigma(kos+(nactperir(ir)+nvirtir)*orbperir(ir)), nvirtir)
call dgemm('n', 't', nvirtir, nactperir(ir), orbperir(ir),
& -0.5d0, grad(kos+nactperir(ir)*orbperir(ir)), nvirtir,
& kappa(kos), nactperir(ir), 1.0d0,
& sigma(kos+(nactperir(ir)+nvirtir)*orbperir(ir)), nvirtir)
endif
kos = kos + (nvirtir+nactperir(ir))*orbperir(ir) +
& nactperir(ir)*nvirtir
enddo
c
end subroutine
************************************************************************
subroutine lintr_fock(ifock, kappa, focktr, sigma, sqroffset,
& orbperir, qscfsize, linact_build)
************************************************************************
* The first part of the Hessian calculated from the Fock matrix
* sigma(m,n) = sum_p [ ifock(m,p)*kappa(n,p) + ifock(p,n)*kappa(m,p) ]
************************************************************************
implicit none
integer qscfsize, sqroffset(nir), orbperir(nir)
double precision ifock(sqrsize), kappa(qscfsize), focktr(sqrsize)
double precision sigma(qscfsize)
logical linact_build
integer ir, m, n, p, kos, dimir, nactir, noccir, nvirtir, i, j
sigma = 0.0d0
kos = 1
do ir = 1, nir
dimir = nfunc(ir)
nactir = nactperir(ir)
noccir = orbperir(ir)
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
if(nactperir(ir) .ne. 0 .and. orbperir(ir) .ne. 0) then
c m = act, n = occ, p = act
call dgemm('n', 'n', nactir, noccir, nactir, -1.0d0,
& ifock(sqroffset(ir)+noccir*(dimir+1)), dimir,
& kappa(kos), nactir, 1.0d0, sigma(kos), nactir)
c m = act, n = occ, p = occ
call dgemm('n', 'n', nactir, noccir, noccir, 1.0d0,
& kappa(kos), nactir, ifock(sqroffset(ir)), dimir,
& 1.0d0, sigma(kos), nactir)
c m = act, n = occ, p = virt
if(nvirtir .ne. 0) then
call dgemm('n', 'n', nactir, noccir, nvirtir, -1.0d0,
& ifock(sqroffset(ir)+noccir+(noccir+nactir)*dimir),
& dimir, kappa(kos+nactir*noccir), nvirtir, 1.0d0,
& sigma(kos), nactir)
call dgemm('t','n', nactir, noccir, nvirtir, -1.0d0,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
& ifock(sqroffset(ir)+noccir+nactir), dimir, 1.0d0,
& sigma(kos), nactir)
endif
endif
if(noccir .ne. 0 .and. nvirtir .ne. 0) then
c m = virt, n = occ, p = act
if(nactir .ne. 0) then
call dgemm('n', 'n', nvirtir, noccir, nactir, -1.0d0,
& ifock(sqroffset(ir)+noccir+nactir+noccir*dimir),
& dimir, kappa(kos), nactir, 1.0d0,
& sigma(kos+nactir*noccir), nvirtir)
call dgemm('n', 'n', nvirtir, noccir, nactir, 1.0d0,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
& ifock(sqroffset(ir)+orbperir(ir)), dimir, 1.0d0,
& sigma(kos+nactir*noccir), nvirtir)
endif
c m = virt, n = occ, p = occ
call dgemm('n', 'n', nvirtir, noccir, noccir, 1.0d0,
& kappa(kos+nactir*noccir), nvirtir, ifock(sqroffset(ir)),
& dimir, 1.0d0, sigma(kos+nactir*noccir), nvirtir)
c m = virt, n = occ, p = virt
call dgemm('n', 'n', nvirtir, noccir, nvirtir, -1.0d0,
& ifock(sqroffset(ir)+(noccir+nactir)*(dimir+1)), dimir,
& kappa(kos+noccir*nactir), nvirtir, 1.0d0,
& sigma(kos+nactir*noccir), nvirtir)
endif
if(nvirtir .ne. 0 .and. nactir .ne. 0) then
c m = virt, n = act, p = act
call dgemm('n', 'n', nvirtir, nactir, nactir, 1.0d0,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
& ifock(sqroffset(ir)+noccir*(dimir+1)), dimir,
& 1.0d0, sigma(kos+(nactir+nvirtir)*noccir), nvirtir)
c m = virt, n = act, p = occ
if(noccir .ne. 0) then
call dgemm('n','t', nvirtir, nactir, noccir, 1.0d0,
& ifock(sqroffset(ir)+noccir+nactir), dimir,
& kappa(kos), nactir, 1.0d0,
& sigma(kos+(nactir+nvirtir)*noccir), nvirtir)
call dgemm('n', 'n', nvirtir, nactir, noccir, 1.0d0,
& kappa(kos+nactir*noccir), nvirtir,
& ifock(sqroffset(ir)+noccir*dimir), dimir, 1.0d0,
& sigma(kos+(nactir+nvirtir)*noccir), nvirtir)
endif
c m = virt, n = act, p = virt
call dgemm('n','n', nvirtir, nactir, nvirtir, -1.0d0,
& ifock(sqroffset(ir)+(noccir+nactir)*(dimir+1)), dimir,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir, 1.0d0,
& sigma(kos+(nactir+nvirtir)*noccir), nvirtir)
endif
kos = kos + (nvirtir + nactir)*noccir + nactir*nvirtir
enddo
c add to the one-index transformed fock matrix
n = 1
do ir = 1, nir
c active-occupied part
do j = 1, orbperir(ir)
do i = orbperir(ir)+1, orbperir(ir)+nactperir(ir)
focktr(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) =
& focktr(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) + sigma(n)
focktr(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) =
& focktr(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) + sigma(n)
n = n + 1
enddo
enddo
c virtual-occupied part
do j = 1, orbperir(ir)
do i = orbperir(ir)+nactperir(ir)+1, nfunc(ir)
focktr(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) =
& focktr(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) + sigma(n)
focktr(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) =
& focktr(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) + sigma(n)
n = n + 1
enddo
enddo
c virtual-active part
do j = 1+orbperir(ir), orbperir(ir)+nactperir(ir)
do i = orbperir(ir)+nactperir(ir)+1, nfunc(ir)
focktr(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) =
& focktr(sqroffset(ir)+i-1+(j-1)*nfunc(ir)) + sigma(n)
focktr(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) =
& focktr(sqroffset(ir)+j-1+(i-1)*nfunc(ir)) + sigma(n)
n = n + 1
enddo
enddo
enddo
c diagonal blocks are not built (redundant rotations),
c but the active-active block of the one index transformed inactive
c Fock matrix is needed
if(.not. linact_build) return
kos = 1
do ir = 1, nir
c m = act, n = act, p = occ
if(nactperir(ir) .ne. 0 .and. orbperir(ir) .ne. 0) then
call dgemm('n', 't', nactperir(ir), nactperir(ir),
& orbperir(ir), 1.0d0, ifock(sqroffset(ir)+orbperir(ir)),
& nfunc(ir), kappa(kos), nactperir(ir), 1.0d0,
& focktr(sqroffset(ir)+orbperir(ir)*(nfunc(ir)+1)),
& nfunc(ir))
call dgemm('n', 'n', nactperir(ir), nactperir(ir),
& orbperir(ir), 1.0d0, kappa(kos), nactperir(ir),
& ifock(sqroffset(ir)+orbperir(ir)*nfunc(ir)), nfunc(ir),
& 1.0d0, focktr(sqroffset(ir)+orbperir(ir)*(nfunc(ir)+1)),
& nfunc(ir))
endif
c m = act, n = act, p = virt
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
if(nactperir(ir) .ne. 0 .and. nvirtir .ne. 0) then
nactir = nactperir(ir)
noccir = orbperir(ir)
dimir = nfunc(ir)
call dgemm('n', 'n', nactir, nactir, nvirtir, -1.0d0,
& ifock(sqroffset(ir)+noccir+(noccir+nactir)*dimir), dimir,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir, 1.0d0,
& focktr(sqroffset(ir)+orbperir(ir)*(1+nfunc(ir))), dimir)
call dgemm('t', 'n', nactir, nactir, nvirtir, -1.0d0,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
& ifock(sqroffset(ir)+(noccir+nactir)+noccir*dimir), dimir,
& 1.0d0, focktr(sqroffset(ir)+orbperir(ir)*(1+nfunc(ir))),
& dimir)
endif
kos = kos + (nvirtir + nactperir(ir))*orbperir(ir) +
& nactperir(ir)*nvirtir
enddo
end subroutine
************************************************************************
subroutine lintr_com(kappa, sigma, c, ifock, afock, q, p2, p4,
& qscfsize, npos, offset, sqroffset, chfx, step, precond,
& lfin, exc, embed, lwdfn, scfdamp, route, nfr, nc,
& ncorenew, devparr, clrhfx, csrhfx, omega,pcm)
************************************************************************
* Common part of the Hessian, it is almost the same for HF and MCSCF
************************************************************************
use common_mod, only: symdens_ptr, symdens2_ptr, symfock_ptr,
& symfock2_ptr, scftype, rmat_ptr, dfnbasis, nal, nbe
implicit none
integer qscfsize, npos, sqroffset(nir), offset(nir), alpha
integer iim, iam, iidens, iadens, im(2), idens(2)
integer iifocktr, iafocktr, ir, iaokappa, iwork, itmp, inosym_c
integer ic2, ikappa_ao, ip4_symm, nvirtir, imem_old
integer scratch1, scratch2, step, iqmat_dens
double precision clrhfx,csrhfx,omega
double precision c(sqrsize), p2(nact, nact), kappa(qscfsize), chfx
double precision sigma(qscfsize), p4(nact, nact, nact, nact)
double precision ifock(sqrsize), afock(sqrsize), q(nbasis*nact)
c M matrices for the one index transformed inactive and
c active Fock matrices
equivalence (iim, im(1)), (iam, im(2))
c Modified densities for the construction of the one index
c transformed Fock matrices
equivalence (iidens, idens(1)), (iadens, idens(2))
integer dblalloc
logical precond
c Other parameters
integer lfin,nfr,nc,ncorenew
double precision exc,devparr(2)
character*4 route
character*16 scfdamp
logical lwdfn
character*8 embed
character*32 pcm
c select case(scftype)
c case(1)
c idens(1) = symdens_ptr
c im(1) = symfock_ptr
c idens(2) = idens(1)
c im(2) = im(1)
c case(0, 2)
c idens(1) = symdens_ptr
c idens(2) = symdens2_ptr
c im(1) = symfock_ptr
c im(2) = symfock2_ptr
c end select
imem_old = imem
if(scftype .eq. 1) then
if(lsa) then
idens(1) = symdens_ptr
im(1) = symfock_ptr
idens(2) = dblalloc(nbasis**2)
im(2) = im(1)
iifocktr = idens(1)
iafocktr = iifocktr
scratch1 = im(1)
scratch2 = im(2)
else
idens(1) = dblalloc(nbasis**2)
idens(2) = dblalloc(nbasis**2)
im(1) = dblalloc(nbasis**2)
im(2) = im(1)
iifocktr = im(1)
iafocktr = im(2)
scratch1 = idens(1)
scratch2 = idens(2)
endif
elseif(scftype.eq.0 .or. scftype .eq.2 .or. scftype .ge. 3) then
if(lsa) then
idens(1) = symdens_ptr
idens(2) = symdens2_ptr
im(1) = symfock_ptr
im(2) = symfock2_ptr
iifocktr = idens(1)
iafocktr = iifocktr + sqrsize
scratch1 = im(1)
scratch2 = im(2)
else
idens(1) = dblalloc(nbasis**2)
idens(2) = dblalloc(nbasis**2)
im(1) = dblalloc(nbasis**2)
im(2) = dblalloc(nbasis**2)
iifocktr = im(1)
iafocktr = im(2)
scratch1 = idens(1)
scratch2 = idens(2)
endif
endif
c One index transformed Fock matrices (reuse memory of the density
c matrices)
call dfillzero(dcore(im(1)), nbasis**2)
if(scftype .ne. 1) call dfillzero(dcore(im(2)), nbasis**2)
call dfillzero(dcore(idens(1)), nbasis**2)
call dfillzero(dcore(idens(2)), nbasis**2)
c building one-index transformed Fock matrices
c first, we build the terms from the 2-electron integrals
call build_mmat(offset, sqroffset, idens, im, npos, kappa, c,
& chfx, step, dfnbasis, nal, nbe, lfin, exc, embed, lwdfn,
& scfdamp, route, nfr, nc, ncorenew, devparr, clrhfx, csrhfx,
& omega, .false., pcm)
call mxts(dcore(im(1)), dcore(symtra_ptr), dcore(iafocktr),
& nbasis, dcore(iifocktr), offset, lsa)
call tomo(dcore(iifocktr), dcore(iifocktr), c, dcore(scratch1),
& sqroffset, .true.)
if(scftype .ne. 1) then
call mxts(dcore(im(2)), dcore(symtra_ptr), dcore(scratch1),
& nbasis, dcore(iafocktr), offset, lsa)
if(scftype .eq. 2) then
alpha = 1 + sqrsize
else
alpha = 1
endif
call tomo(dcore(iafocktr), dcore(iafocktr), c(alpha),
& dcore(scratch1), sqroffset, .true.)
endif
c second, we build the terms from the inactive and active Fock matrices
c or alpha and beta Fock matrices in case of UHF (RHF)
if(scftype .ge. 3) then
call lintr_fock(dcore(rmat_ptr), kappa, dcore(iafocktr), sigma,
& sqroffset, orbperir, qscfsizea, .false.)
else
call lintr_fock(ifock, kappa, dcore(iifocktr), sigma, sqroffset,
& orbperir, qscfsizea, scftype.eq.0)
endif
if(scftype .eq. 0) then
call lintr_fock(afock, kappa, dcore(iafocktr), sigma, sqroffset,
& orbperir, qscfsizea, .false.)
elseif(scftype .eq. 2) then
call lintr_fock(afock, kappa(1+qscfsizea), dcore(iafocktr),
& sigma, sqroffset, orbperir(1+nir), qscfsizeb, .false.)
endif
if(scftype .ne. 0 .and. scftype .lt. 3) then
call mk_grad(dcore(iifocktr), sigma, sqroffset, qscfsize,
& grad_scale)
call dbldealloc(imem_old)
return
endif
c build one-index transformed generealized Fock matrix
if(scftype .eq. 0) then
do ir = 1, nir
if(orbperir(ir) .ne. 0) then
call daxpy(nfunc(ir)*orbperir(ir), 1.0d0,
& dcore(iifocktr+sqroffset(ir)-1), 1,
& dcore(iafocktr+sqroffset(ir)-1), 1)
call dscal(nfunc(ir)*orbperir(ir), 2.0d0,
& dcore(iafocktr+sqroffset(ir)-1), 1)
endif
enddo
call gfock_act(offset, sqroffset, dcore(iifocktr),
& dcore(iafocktr), c, p2)
elseif(scftype .ge. 3) then
do ir = 1, nir
if(orbperir(ir)+nactperir(ir) .ne. 0) then
call daxpy(nfunc(ir)*(orbperir(ir)+nactperir(ir)), 1.0d0,
& dcore(iifocktr+sqroffset(ir)-1), 1,
& dcore(iafocktr+sqroffset(ir)-1), 1)
endif
if(orbperir(ir) .ne. 0) then
call dscal(nfunc(ir)*orbperir(ir), 2.0d0,
& dcore(iafocktr+sqroffset(ir)-1), 1)
endif
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
if(nvirtir .ne. 0) then
call dfillzero(dcore(iafocktr+sqroffset(ir)-1+
& nfunc(ir)*(orbperir(ir)+nactperir(ir))),
& nvirtir*nfunc(ir))
endif
enddo
endif
c write(*,*) 'afocktr'
c call prmx(dcore(iafocktr), nbasis, nbasis, nbasis)
c stop
c Building one-index transformed Q matrix
if(scftype .lt. 3) then
iwork = scratch1 !dblalloc(nbasis*nact)
if(lsa .and. .not. ldf) then
call mx_symm_extr(dcore(scratch1), dcore(c_ptr), offset)
call dgemm('n', 'n', nbasis, nbasis, nbasis, 1.0d0,
& dcore(symtra_ptr), nbasis, dcore(scratch1), nbasis,
& 0.0d0, dcore(scratch2), nbasis)
inosym_c = scratch2
else
inosym_c = c_ptr
endif
ip4_symm = dblalloc(nact**4)
call hessq_mcscf(kappa, dcore(iafocktr), p4, dcore(ip4_symm),
& dcore(iq), dcore(inosym_c), dcore(c_ptr), dcore(iwork),
& offset, sqroffset, npos)
elseif(scftype .ge. 3) then
if(ldf) then
iwork = scratch1
iqmat_dens = scratch2
else
if(lsa) then
iqmat_dens = scratch2
iwork = scratch1
itmp = imem
call qmat_dens_rohf(dcore(c_ptr), kappa, dcore(iqmat_dens),
& dcore(iwork), dcore(itmp), sqroffset, offset)
else
iqmat_dens = scratch2
iwork = scratch1
itmp = scratch1
call qmat_dens_rohf(dcore(c_ptr), kappa, dcore(iqmat_dens),
& dcore(iqmat_dens), dcore(itmp), sqroffset, offset)
endif
endif
call hessq_rohf(kappa, dcore(iafocktr), dcore(iq),
& dcore(iqmat_dens), iqmat_dens, dcore(iwork), iwork,
& sqroffset, offset, npos, dcore(c_ptr), lfin, exc, lwdfn,
& embed, scfdamp, route, nfr, nc, ncorenew, devparr, chfx,
& clrhfx,csrhfx,omega,pcm)
endif
call mk_grad(dcore(iafocktr), sigma, sqroffset, qscfsize,
& grad_scale)
call dbldealloc(imem_old)
end subroutine
************************************************************************
subroutine qmat_dens_rohf(cmat, kappa, dens, work, tmp, sqroffset,
& offset)
************************************************************************
* Density-like matrix for ROHF one-index transformed ROHF Q matrix
************************************************************************
use common_mod, only: sqrsize, nbasis, nir, nfunc, orbperir, lsa,
& dcore, symtra_ptr
implicit none
integer sqroffset(nir), offset(nir), kos
integer ir, dimir, noccir, nactir, nvirtir, i, j
double precision cmat(sqrsize), kappa(qscfsize), dens(nbasis**2)
double precision work(nbasis**2), tmp(*), x
kos = 1
do ir = 1, nir
dimir = nfunc(ir)
noccir = orbperir(ir)
nactir = nactperir(ir)
nvirtir = dimir - noccir - nactir
if(dimir .eq. 0) cycle
if(nactir .eq. 0) then
call dfillzero(work(sqroffset(ir)), dimir**2)
kos = kos + noccir*nvirtir
cycle
endif
if(noccir .ne. 0) then
call dgemm('n', 't', nactir, dimir, noccir, 1.0d0, kappa(kos),
& nactir, cmat(sqroffset(ir)), dimir, 0.0d0, tmp, nactir)
else
call dfillzero(tmp, nactir*dimir)
endif
if(nvirtir .ne. 0) then
call dgemm('t', 't', nactir, dimir, nvirtir, -1.0d0,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
& cmat(sqroffset(ir)+(noccir+nactir)*dimir), dimir, 1.0d0,
& tmp, nactir)
endif
if(nvirtir .ne. 0 .or. noccir .ne. 0) then
call dgemm('n', 'n', dimir, dimir, nactir, 1.0d0,
& cmat(sqroffset(ir)+noccir*dimir), dimir, tmp, nactir,
& 0.0d0, work(sqroffset(ir)), dimir)
do i = 1, dimir
do j = i, dimir
x = work(sqroffset(ir)+i-1+(j-1)*dimir) +
& work(sqroffset(ir)+j-1+(i-1)*dimir)
work(sqroffset(ir)+i-1+(j-1)*dimir) = x
work(sqroffset(ir)+j-1+(i-1)*dimir) = x
enddo
enddo
else
call dfillzero(work(sqroffset(ir)), dimir**2)
endif
kos = kos + noccir*(nactir + nvirtir) + nactir*nvirtir
enddo
if(lsa) then
call mxto(dens,dcore(symtra_ptr),work,nbasis,work,offset,lsa)
endif
end subroutine
************************************************************************
subroutine build_mmat(offset, sqroffset, idens, im, npos, kappa,
& c, chfx, step, dfnbasis, nal, nbe, lfin, exc, embed, lwdfn,
& scfdamp, route, nfr, nc, ncorenew, devparr, clrhfx, csrhfx,
& omega, lqmat, pcm)
************************************************************************
* Subroutine to build M matrix for SCF Hessian
************************************************************************
use common_mod, only: iintpos, dcore, icore, nbasis, scftype,
& imem, maxcor, pepsilon, iout, oeintfile, natoms, nir, sqrsize,
& inatrange, indexirrep_ptr, scfalg, rs_ptr
implicit none
integer offset(nir), sqroffset(nir), i, j, k, l, imem_old
integer idens(2), im(2), npos, step, old_scftype
integer ic(2), icoul, icoul2, icpr, ii, maxm, teintf(10), ipos
integer ii4core, r, nocc, nal, nbe, dfnbasis, nocca, noccb, ir
double precision clrhfx,csrhfx,omega
double precision chfx, kappa(qscfsize), c(sqrsize)
double precision dtol
character*32 dft,pcm
logical lbeta, lqmat
integer imem1
common/memcom/ imem1
c Other parameters
integer lfin,nfr,nc,ncorenew
double precision exc,devparr(2)
character*4 route
character*16 scfdamp
logical lwdfn
character*8 embed
integer dblalloc
imem_old=imem
nocc=max(nal,nbe)
if(ldf) then
c building M matrix with density fitting
if(scftype .eq. 2) then
nocca = nal
noccb = nbe
ic(1) = dblalloc(2*nal*nbasis)
ic(2) = dblalloc(2*nbe*nbasis)
elseif(scftype .eq. 0) then
nocca = 0
do ir = 1, nir
nocca = nocca + orbperir(ir)
enddo
noccb = nact
ic(1) = dblalloc(2*nocca*nbasis)
ic(2) = dblalloc(2*noccb*nbasis)
elseif(scftype .ge. 3) then
if(lqmat) then
nocca = nact
noccb = nact
ic(1) = dblalloc(2*nocca*nbasis)
ic(2) = ic(1)
else
nocca = 0
do ir = 1, nir
nocca = nocca + orbperir(ir)
enddo
noccb = nact
ic(1) = dblalloc(2*nocca*nbasis)
ic(2) = dblalloc(2*noccb*nbasis)
endif
else
nocca = nal
noccb = nocca
ic(1) = dblalloc(2*nal*nbasis)
ic(2) = ic(1)
endif
call mo4df(offset, sqroffset, ic, kappa, c, dcore(ip2),
& dcore(idens(1)), dcore(im(1)), dcore(imem), lqmat)
c building the modified density matrix
if(lqmat) then
call dfillzero(dcore(im(1)), nbasis**2)
else
call lintr_dens(kappa, c, dcore(idens(1)), dcore(idens(2)),
& dcore(im(1)), qscfsize, offset, sqroffset, dcore(ip2))
endif
if(scftype .eq. 2 .and. trim(scfalg).eq.'disk') then
call daxpy(nbasis**2, 1.0d0, dcore(idens(2)), 1,
& dcore(idens(1)), 1)
endif
else
call lintr_dens(kappa, c, dcore(idens(1)), dcore(idens(2)),
& dcore(im(1)), qscfsize, offset, sqroffset, dcore(ip2))
endif
call build_mmat_(offset, sqroffset, idens, im, npos, kappa,
& c, chfx, step, dfnbasis, nal, nbe, lfin, exc, embed, lwdfn,
& scfdamp, route, nfr, nc, ncorenew, devparr, clrhfx, csrhfx,
& omega, lqmat, pcm, nocca, noccb, ic)
call dbldealloc(imem_old)
end subroutine
************************************************************************
subroutine build_mmat_(offset, sqroffset, idens, im, npos, kappa,
& c, chfx, step, dfnbasis, nal, nbe, lfin, exc, embed, lwdfn,
& scfdamp, route, nfr, nc, ncorenew, devparr, clrhfx, csrhfx,
& omega, lqmat, pcm, nocca, noccb, ic)
************************************************************************
* Subroutine to build M matrix for SCF Hessian
************************************************************************
use common_mod, only: iintpos, dcore, icore, nbasis, scftype,
& imem, maxcor, pepsilon, iout, oeintfile, natoms, nir, sqrsize,
& inatrange, indexirrep_ptr, scfalg, rs_ptr
implicit none
integer offset(nir), sqroffset(nir), i, j, k, l, imem_old
integer idens(2), im(2), npos, step, old_scftype
integer ic(2), icoul, icoul2, icpr, ii, maxm, teintf(10), ipos
integer ii4core, r, nocc, nal, nbe, dfnbasis, nocca, noccb, ir
double precision clrhfx,csrhfx,omega
double precision chfx, kappa(qscfsize), c(sqrsize)
double precision dtol
character*32 dft,pcm
logical lbeta, lqmat
integer imem1
common/memcom/ imem1
c Other parameters
integer lfin,nfr,nc,ncorenew
double precision exc,devparr(2)
character*4 route
character*16 scfdamp
logical lwdfn
character*8 embed
integer dblalloc
imem_old=imem
nocc=max(nal,nbe)
if(ldf) then
c building M matrix with density fitting
call getkey('dft',3,dft,32)
call dfillzero(dcore(im(1)), nbasis**2)
if(scftype .eq. 0 .or. scftype .ge. 2) then
call dfillzero(dcore(im(2)), nbasis**2)
endif
c Integral direct calculation
IF(trim(scfalg).ne.'disk') then
if(scftype .eq. 1) then
call fock_build(dcore(idens(1)),dcore(idens(1)),
$ dcore(im(1)),dcore(im(1)),dcore,icore(indexirrep_ptr),
$ offset,sqroffset,npos,icore(iintpos),step,dcore(ic(1)),
$ lfin,exc,dft,chfx,lwdfn,embed,scfdamp,route,nfr,nc,
$ ncorenew,devparr,dcore(symtra_ptr),0,clrhfx,csrhfx,omega,
$ dcore(rs_ptr),.true.,ic(1),ic(2),pcm,dcore,dcore,.false.)
elseif(scftype .eq. 2) then
call fock_build(dcore(idens(1)),dcore(idens(2)),
$ dcore(im(1)),dcore(im(2)),dcore,icore(indexirrep_ptr),
$ offset,sqroffset,npos,icore(iintpos),step,dcore(ic(1)),
$ lfin,exc,dft,chfx,lwdfn,embed,scfdamp,route,nfr,nc,
$ ncorenew,devparr,dcore(symtra_ptr),0,clrhfx,csrhfx,omega,
$ dcore(rs_ptr),.true.,ic(1),ic(2),pcm,dcore,dcore,.false.)
elseif(scftype .ge. 3) then
if(lqmat) then
call fock_build(dcore(idens(2)),dcore(idens(2)),
$ dcore(im(2)),dcore(im(2)),dcore(im(2)),
$ icore(indexirrep_ptr),offset,sqroffset,npos,
$ icore(iintpos),step,dcore(ic(2)),lfin,exc,dft,
$ 2.0d0*chfx,lwdfn,embed,scfdamp,route,nfr,nc,ncorenew,
$ devparr,dcore(symtra_ptr),nact,clrhfx,csrhfx,omega,
$ dcore(rs_ptr),.true.,ic(2),ic(2),pcm,dcore,dcore,
$ .false.)
else
old_scftype = scftype
scftype = 1
call fock_build(dcore(idens(1)),dcore(idens(1)),
$ dcore(im(1)),dcore(im(1)),dcore,icore(indexirrep_ptr),
$ offset,sqroffset,npos,icore(iintpos),step,dcore(ic(1)),
$ lfin,exc,dft,chfx,lwdfn,embed,scfdamp,route,nfr,nc,
$ ncorenew,devparr,dcore(symtra_ptr),0,clrhfx,csrhfx,
$ omega,dcore(rs_ptr),.true.,ic(1),ic(2),pcm,dcore,dcore,
$ .false.)
call dscal(nbasis**2, 1.0d0/8.0d0, dcore(idens(2)), 1) !???
call fock_build(dcore(idens(2)),dcore(idens(2)),
$ dcore(im(2)),dcore(im(2)),dcore(im(2)),
$ icore(indexirrep_ptr),
$ offset,sqroffset,npos,icore(iintpos),step,dcore(ic(2)),
$ lfin,exc,dft,chfx,lwdfn,embed,scfdamp,route,nfr,nc,
$ ncorenew,devparr,dcore(symtra_ptr),nact,clrhfx,csrhfx,
$ omega,dcore(rs_ptr),.true.,ic(2),ic(2),pcm,dcore,dcore,
$ .false.)
scftype = old_scftype
endif
endif
call extract_m(dcore(im(1)), nbasis)
if(scftype .ge. 2) then
call extract_m(dcore(im(2)), nbasis)
endif
c disk
else
icoul = dblalloc(dfnbasis)
if(scftype .eq. 0 .or. scftype .ge. 3) then
icoul2 = dblalloc(dfnbasis)
else
icoul2 = icoul
endif
icpr = dblalloc(2*nbasis)
ii=3*dfnbasis
ii=(ii+mod(ii,2))/2
ii4core=dblalloc(ii)
maxm=maxcor-(imem-imem1)
c dtol=pepsilon/dfloat(nbasis*nocc)
dtol=min(pepsilon, 1.0d-8)/dfloat(nbasis*nocc)
CALL INTOPENRSQ(TEINTF)
if(lqmat) then
call df_disk_fock(dcore(im(1)),dcore(im(1)),dcore(idens(1)),
& dcore(idens(1)),nbasis,dfnbasis,npos,ipos,
& dcore(imem),dcore(icoul2),dcore(icoul),dcore(icpr),
& dcore(ii4core),icore(iintpos),teintf,2*noccb,2*nocca,
& dcore(ic(1)),dcore(ic(1)),1,maxm,iout,
& dcore(inatrange),dcore(imem),oeintfile,natoms,dft,
& chfx,scftype,dtol,.true.,lbeta,'m')
else
call dfillzero(dcore(icoul), dfnbasis)
if(scftype .eq. 0 .or. scftype .ge. 3)
& call dfillzero(dcore(icoul2), dfnbasis)
call df_disk_fock(dcore(im(1)),dcore(im(2)),dcore(idens(1)),
& dcore(idens(2)),nbasis,dfnbasis,npos,ipos,dcore(imem),
& dcore(icoul),dcore(icoul2),dcore(icpr),dcore(ii4core),
& icore(iintpos),teintf,2*nocca,2*noccb,dcore(ic(1)),
& dcore(ic(2)),1,maxm,iout,dcore(inatrange),dcore(imem),
& oeintfile,natoms,dft,-chfx,scftype,dtol,.false.,
& lbeta, 'm')
if((scftype .ge. 2 .or. scftype .eq. 0) .and. lbeta) then
call df_disk_fock(dcore(im(2)),dcore(im(1)),
& dcore(idens(2)),dcore(idens(1)),nbasis,dfnbasis,npos,
& ipos,dcore(imem),dcore(icoul2),dcore(icoul),
& dcore(icpr),dcore(ii4core),icore(iintpos),teintf,
& 2*noccb,2*nocca,dcore(ic(2)),dcore(ic(1)),1,maxm,
& iout,dcore(inatrange),dcore(imem),oeintfile,natoms,
& dft,-chfx,scftype,dtol,.true.,lbeta,'m')
endif
endif
CALL INTCLOSE(TEINTF)
call extract_m(dcore(im(1)), nbasis)
if(scftype .ge. 2 .or. scftype .eq. 0 .and. .not. lqmat) then
call extract_m(dcore(im(2)), nbasis)
endif
if(scftype .ge. 3 .and. lqmat) then
call dscal(nbasis, 2.0d0, dcore(im(1)), nbasis+1)
endif
endif
else
c Conventional 4-center
call dfillzero(dcore(im(1)), nbasis**2)
if(scftype .eq. 0) call dfillzero(dcore(im(2)), nbasis**2)
call buildm2(npos, icore(iintpos), dcore(im(1)),
& dcore(idens(1)), dabs(chfx))
endif
call dbldealloc(imem_old)
end subroutine
************************************************************************
subroutine mo4df(offset, sqroffset, ic, x, c, p2, tmp1, tmp2,
& tmp3, lqmat)
************************************************************************
* Subroutine to calculate transformed MO coefficients for M matrix
* construction with density fitting
************************************************************************
use common_mod, only: scftype, orbperir, nfunc, symtra_ptr, nir,
& sqrsize, nbasis, lsa, nal, nbe, nirmax, scfalg
implicit none
integer offset(nir), sqroffset(nir)
integer rmax, ic(2), r
integer nocc(2), xos, ir, j, i
integer nvirtir, dimir, noccir, nactir, coff
double precision x(qscfsize), c(sqrsize), p2(nact, nact)
double precision tmp1(nbasis**2), tmp2(nbasis**2)
double precision tmp3(nbasis, nbasis)
logical lqmat
if(scftype .eq. 1) then
rmax = 0
nocc(1) = nal
elseif(scftype .eq. 0) then
rmax = 0
nocc(1) = 0
do ir = 1, nir
nocc(1) = nocc(1) + orbperir(ir)
enddo
nocc(2) = nact
elseif(scftype .ge. 3) then
if(lqmat) then
rmax = 0
nocc(1) = nact
nocc(2) = nact
else
rmax = 0
nocc(1) = 0
do ir = 1, nir
nocc(1) = nocc(1) + orbperir(ir)
enddo
nocc(2) = nact
endif
elseif(scftype .eq. 2) then
rmax = 1
nocc(1) = nal
nocc(2) = nbe
endif
if(.not. lqmat) then
xos = 1
do r = 0, rmax
call dfillzero(dcore(ic(r+1)), 2*nocc(r+1)*nbasis)
call dfillzero(tmp1, sqrsize)
call dfillzero(tmp2, sqrsize)
c Calculate C*kappa
do ir = 1, nir
dimir = nfunc(ir)
noccir = orbperir(ir+r*nir)
nactir = nactperir(ir)
nvirtir = nfunc(ir) - orbperir(ir+r*nir) - nactir
if(nactir .ne. 0 .and. noccir .ne. 0) then
call dgemm('n', 'n', dimir, noccir, nactir, 1.0d0,
& c(sqroffset(ir)+noccir*dimir+r*sqrsize), dimir,
& x(xos), nactir, 0.0d0, tmp1(sqroffset(ir)), dimir)
endif
if(noccir .ne. 0 .and. nvirtir .ne. 0) then
call dgemm('n', 'n', dimir, noccir, nvirtir, 1.0d0,
& c(sqroffset(ir)+(noccir+nactir)*dimir+r*sqrsize),
& dimir, x(xos+noccir*nactir), nvirtir, 1.0d0,
& tmp1(sqroffset(ir)), dimir)
endif
if(noccir .ne. 0) then
call daxpy(noccir*dimir, -1.0d0, tmp1(sqroffset(ir)), 1,
& tmp2(sqroffset(ir)), 1)
call daxpy(noccir*dimir, 1.0d0,c(sqroffset(ir)+r*sqrsize),
& 1, tmp1(sqroffset(ir)), 1)
call daxpy(noccir*dimir, 1.0d0,c(sqroffset(ir)+r*sqrsize),
& 1, tmp2(sqroffset(ir)), 1)
endif
xos = xos + (nvirtir + nactir)*noccir + nactir*nvirtir
enddo
if(lsa) then
call mx_symm_extr(tmp3, tmp1, offset)
call dgemm('n', 'n', nbasis, nbasis, nbasis, 1.0d0,
& dcore(symtra_ptr), nbasis, tmp3, nbasis, 0.0d0,
& tmp1, nbasis)
call mx_symm_extr(tmp3, tmp2, offset)
call dgemm('n', 'n', nbasis, nbasis, nbasis, 1.0d0,
& dcore(symtra_ptr), nbasis, tmp3, nbasis, 0.0d0,
& tmp2, nbasis)
endif
IF(trim(scfalg).ne.'disk') then
coff = 0
do ir=1,nir
if(orbperir(ir+r*nir).eq.0) cycle
call dcopy(nbasis*orbperir(ir+r*nir),
& tmp1(1+(offset(ir)-1)*nbasis),1,
& dcore(ic(r+1)+coff*nbasis),1)
call dcopy(nbasis*orbperir(ir+r*nir),
& tmp2(1+(offset(ir)-1)*nbasis),1,
& dcore(ic(r+1)+(nocc(r+1)+coff)*nbasis),1)
coff = coff + orbperir(ir+r*nir)
enddo
call dscal(2*nocc(r+1)*nbasis, 1.0d0/dsqrt(2.0d0),
& dcore(ic(r+1)), 1)
else
c Transpose MO coefficients for df_disk_fock
coff = 0
do ir = 1, nir
if(orbperir(ir+r*nir).eq.0) cycle
do i = 1, orbperir(ir+r*nir)
coff = coff + 1
do j = 1, nbasis
dcore(ic(r+1)+coff-1+(j-1)*2*nocc(r+1)) =
& tmp1(j+(offset(ir)+i-2)*nbasis)
dcore(ic(r+1)+nocc(r+1)+coff-1+(j-1)*2*nocc(r+1)) =
& tmp2(j+(offset(ir)+i-2)*nbasis)
enddo
enddo
enddo
call dscal(2*nocc(r+1)*nbasis, 1.0d0/dsqrt(2.0d0),
& dcore(ic(r+1)), 1)
endif
enddo
endif
if(scftype .eq. 0 .or. scftype .ge. 3) then
call dfillzero(dcore(ic(2)), 2*nocc(2)*nbasis)
call dfillzero(tmp1, nbasis**2)
xos = 1
do ir = 1, nir
nactir = nactperir(ir)
noccir = orbperir(ir)
dimir = nfunc(ir)
nvirtir = dimir - noccir - nactir
c active - occupied part
if(nactir .ne. 0 .and. noccir .ne. 0) then
c p2 is a unit matrix in case of ROHF
if(scftype .ge. 3) then
do i = 1, noccir
do j = 1, nactir
tmp2(j+(i-1)*nactir) = -0.5d0*x(xos+j-1+(i-1)*nactir)
enddo
enddo
else
call dgemm('n', 'n', nactir, noccir, nactir, -0.5d0,
& p2(actoffset(ir), actoffset(ir)), nact, x(xos),
& nactir, 0.0d0, tmp2, nactir)
endif
call dgemm('n', 't', dimir, nactir, noccir, 1.0d0,
& c(sqroffset(ir)), dimir, tmp2, nactir, 0.0d0,
& tmp1(sqroffset(ir)), dimir)
endif
c virtual - active
if(nvirtir .ne. 0 .and. nactir .ne. 0) then
c p2 is a unit matrix in case of ROHF
if(scftype .ge. 3) then
do i = 1, nactir
do j = 1, nvirtir
tmp2(i+(j-1)*nactir) =
& 0.5d0*x(xos+(nactir+nvirtir)*noccir+j-1+(i-1)*nvirtir)
enddo
enddo
else
call dgemm('n', 't', nactir, nvirtir, nactir, 0.5d0,
& p2(actoffset(ir), actoffset(ir)), nact,
& x(xos+(nvirtir+nactir)*noccir), nvirtir, 0.0d0, tmp2,
& nactir)
endif
call dgemm('n', 't', dimir, nactir, nvirtir, 1.0d0,
& c(sqroffset(ir)+(noccir+nactir)*dimir), dimir, tmp2,
& nactir, 1.0d0, tmp1(sqroffset(ir)), dimir)
endif
xos = xos + (nvirtir + nactir)*noccir + nactir*nvirtir
enddo
call dfillzero(tmp2, nbasis**2)
do ir = 1, nir
nactir = nactperir(ir)
noccir = orbperir(ir)
dimir = nfunc(ir)
nvirtir = dimir - noccir - nactir
if(nactir .ne. 0) then
call daxpy(nactir*dimir, -1.0d0, tmp1(sqroffset(ir)), 1,
& tmp2(sqroffset(ir)), 1)
call daxpy(nactir*dimir, 1.0d0,
& c(sqroffset(ir)+noccir*dimir), 1, tmp1(sqroffset(ir)),
& 1)
call daxpy(nactir*dimir, 1.0d0,
& c(sqroffset(ir)+noccir*dimir), 1, tmp2(sqroffset(ir)),
& 1)
endif
enddo
if(lsa) then
call mx_symm_extr(tmp3, tmp1, offset)
call dgemm('n', 'n', nbasis, nbasis, nbasis, 1.0d0,
& dcore(symtra_ptr), nbasis, tmp3, nbasis, 0.0d0,
& tmp1, nbasis)
call mx_symm_extr(tmp3, tmp2, offset)
call dgemm('n', 'n', nbasis, nbasis, nbasis, 1.0d0,
& dcore(symtra_ptr), nbasis, tmp3, nbasis, 0.0d0,
& tmp2, nbasis)
endif
coff = 0
if(lqmat) then
r = 0
else
r = 1
endif
call dfillzero(dcore(ic(r+1)), 2*nocc(r+1)*nbasis)
IF(trim(scfalg).ne.'disk') then
do ir = 1, nir
nactir = nactperir(ir)
if(nfunc(ir) .eq. nactir .or. nactir .eq. 0) cycle
call dcopy(nbasis*nactir, tmp1(1+(offset(ir)-1)*nbasis),
& 1, dcore(ic(r+1)+coff*nbasis), 1)
call dcopy(nbasis*nactir, tmp2(1+(offset(ir)-1)*nbasis),
& 1, dcore(ic(r+1)+(nocc(r+1)+coff)*nbasis), 1)
coff = coff + nactir
enddo
c Transpose MO coefficients for df_disk_fock
else
do ir = 1, nir
nactir = nactperir(ir)
if(nfunc(ir).eq.nactir .or. nactir.eq.0) cycle
dimir = nfunc(ir)
noccir = orbperir(ir)
nvirtir = dimir - noccir
do i = 1, nactir
coff = coff + 1
do j = 1, nbasis
dcore(ic(r+1)+coff-1+(j-1)*2*nocc(r+1)) =
& tmp1(j+(offset(ir)+i-2)*nbasis)
dcore(ic(r+1)+nocc(r+1)+coff-1+(j-1)*2*nocc(r+1)) =
& tmp2(j+(offset(ir)+i-2)*nbasis)
enddo
enddo
enddo
endif
call dscal(2*nocc(r+1)*nbasis, 1/dsqrt(2.0d0), dcore(ic(r+1)),1)
endif
end subroutine
************************************************************************
subroutine extract_m(m, n)
************************************************************************
* Building symmetric M matrix in case of density fitting
************************************************************************
use common_mod, only: dcore, imem
implicit none
integer n, i, j
double precision m(n, n), tmp
do i = 1, n
do j = i+1, n
tmp = m(i, j) + m(j, i)
m(i, j) = tmp
m(j, i) = tmp
enddo
enddo
#if defined (MPI)
call symreduce(m,dcore(imem),n)
#endif
end subroutine
************************************************************************
subroutine tomo(aomat, momat, c, tmp, sqroffset, lsym)
************************************************************************
* Transform matrix to MO basis
************************************************************************
implicit none
integer sqroffset(nir), ir
double precision aomat(sqrsize), momat(sqrsize)
double precision c(sqrsize), tmp(sqrsize)
logical lsym
do ir = 1, nir
if(nfunc(ir) .eq. 0) cycle
if(lsym) then
call dsymm('l', 'u', nfunc(ir), nfunc(ir), 1.0d0,
& aomat(sqroffset(ir)), nfunc(ir), c(sqroffset(ir)),
& nfunc(ir), 0.0d0, tmp, nfunc(ir))
else
call dgemm('n', 'n', nfunc(ir), nfunc(ir), nfunc(ir), 1.0d0,
& aomat(sqroffset(ir)), nfunc(ir), c(sqroffset(ir)),
& nfunc(ir), 0.0d0, tmp, nfunc(ir))
endif
call dgemm('t', 'n', nfunc(ir), nfunc(ir), nfunc(ir), 1.0d0,
& c(sqroffset(ir)), nfunc(ir), tmp, nfunc(ir), 0.0d0,
& momat(sqroffset(ir)), nfunc(ir))
enddo
end subroutine
************************************************************************
subroutine lintr_dens(kappa, c, idens, adens, tmp, qscfsize,
& offset, sqroffset, p2)
************************************************************************
* Modified densities for the construction of the M matrix
* MCSCF : idens and adens are the densities for the one index
* transformed inactive and active Fock matrices, respectively
* UHF : idens is the alpha, adens is the beta density
* RHF : idens is the modified density, adens is not referenced
************************************************************************
implicit none
integer qscfsize, sqroffset(nir), offset(nir), ir, kos, nvirtir
integer i, j, dimir
double precision kappa(qscfsize), c(sqrsize), idens(nbasis,nbasis)
double precision adens(nbasis, nbasis)
double precision p2(nact, nact)
double precision tmp(nbasis**2)
double precision val, alpha, beta, delta
! RHF, ROHF and MCSCF
if(scftype .eq. 0 .or. scftype .eq. 1 .or. scftype .ge. 3) then
if(ldf) then
alpha = 1.0d0
beta = -1.0d0
delta = -0.5d0
else
alpha = -4.0d0 ! multiplies the whole modified density
beta = 1.0d0 ! multiplies only the diagonal part
delta = 1.0d0 ! multiplies only the offdiagonal part
endif
elseif(scftype .eq. 2) then ! UHF
if(ldf) then
alpha = 1.0d0
beta = -0.5d0
delta = -0.25d0
else
alpha = -2.0d0
beta = 1.0d0
delta = 1.0d0
endif
endif
c building modified density for the construction of the active Fock
if(scftype .eq. 0 .or. scftype .ge. 3) then
if(lsa) then
call mod_act_dens(offset, sqroffset, kappa, p2, c, adens, tmp,
& idens)
else
call mod_act_dens(offset, sqroffset, kappa, p2, c, tmp, adens,
& idens)
endif
c symmetrize the modified density matrix
if(ldf) then
call symm_dens(adens, nbasis, 2.0d0, 1.0d0)
else
call symm_dens(adens, nbasis, 1.0d0, 1.0d0)
endif
endif
c MCSCF / ROHF inactive / RHF / UHF alpha modified density
if(lsa) then
call mod_dens(kappa, qscfsizea, idens, nbasis, c, tmp, orbperir,
& nactperir, sqroffset, offset, alpha, beta, delta)
else
call mod_dens(kappa, qscfsizea, tmp, nbasis, c, idens, orbperir,
& nactperir, sqroffset, offset, alpha, beta, delta)
endif
c symmetrize the modified density matrix
call symm_dens(idens, nbasis, beta, delta)
c UHF beta modified density
if(scftype .eq. 2) then
if(lsa) then
call mod_dens(kappa(qscfsizea+1), qscfsizeb, adens, nbasis,
& c(1+sqrsize), tmp, orbperir(nir+1), nactperir, sqroffset,
& offset, alpha, beta, delta)
else
call mod_dens(kappa(qscfsizea+1), qscfsizeb, tmp, nbasis,
& c(1+sqrsize), adens, orbperir(nir+1), nactperir,
& sqroffset, offset, alpha, beta, delta)
endif
c symmetrize the modified density matrix
call symm_dens(adens, nbasis, beta, delta)
endif
end subroutine
************************************************************************
subroutine mod_act_dens(offset, sqroffset, kappa, p2, c, adens,
& tmp, work)
************************************************************************
* Modified active density for MCSCF M matrix construction
************************************************************************
use common_mod, only: nir, orbperir, nfunc, sqrsize, sqrsize2,
& nbasis, scftype
implicit none
integer kos, ir, nvirtir, dimir, i, j
integer offset(*), sqroffset(*)
double precision p2(nact, nact), tmp(sqrsize), c(sqrsize2)
double precision adens(sqrsize), work(sqrsize)
double precision kappa(qscfsize)
tmp = 0.0d0
adens = 0.0d0
kos = 1
do ir = 1, nir
c contribution from the active-occupied part of the kappa vector
if(orbperir(ir) .ne. 0 .and. nactperir(ir) .ne. 0) then
if(scftype .lt. 3) then ! MCSCF
call dgemm('n', 'n', nactperir(ir), orbperir(ir),
& nactperir(ir), 2.0d0,p2(actoffset(ir),actoffset(ir)),
& nact, kappa(kos), nactperir(ir), 0.0d0, work,
& nactperir(ir))
else ! ROHF: 1-el. dens. is a unit matrix
call dcopy(nactperir(ir)*orbperir(ir),kappa(kos),1,work,1)
call dscal(nactperir(ir)*orbperir(ir),2.0d0,work,1)
endif
call dgemm('n', 't', nactperir(ir), nfunc(ir),
& orbperir(ir), 1.0d0, work, nactperir(ir),
& c(sqroffset(ir)), nfunc(ir), 0.0d0, adens,
& nactperir(ir))
call dgemm('n', 'n', nfunc(ir), nfunc(ir), nactperir(ir),
& 1.0d0, c(sqroffset(ir)+orbperir(ir)*nfunc(ir)),
& nfunc(ir), adens, nactperir(ir), 0.0d0,
& tmp(sqroffset(ir)), nfunc(ir))
endif
c contribution from the virtual-active part of the kappa vector
dimir = nfunc(ir)
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
if(nvirtir .ne. 0 .and. nactperir(ir) .ne. 0) then
if(scftype .lt. 3) then ! MCSCF
call dgemm('n' ,'t', nactperir(ir), nvirtir,nactperir(ir),
& -2.0d0, p2(actoffset(ir), actoffset(ir)), nact,
& kappa(kos+(nactperir(ir)+nvirtir)*orbperir(ir)),
& nvirtir, 0.0d0, work, nactperir(ir))
else ! ROHF (we have to transpose kappa)
do i = 1, nactperir(ir)
do j = 1, nvirtir
work(i+(j-1)*nactperir(ir)) =
& -2.0d0*kappa(kos+(nactperir(ir)+nvirtir)*orbperir(ir)+
& j-1+(i-1)*nvirtir)
enddo
enddo
endif
call dgemm('n', 't', nactperir(ir), nfunc(ir), nvirtir,
& 1.0d0, work, nactperir(ir),
& c(sqroffset(ir)+(orbperir(ir)+nactperir(ir))*dimir),
& dimir, 0.0d0, adens, nactperir(ir))
call dgemm('n', 'n', nfunc(ir), nfunc(ir), nactperir(ir),
& 1.0d0, c(sqroffset(ir)+orbperir(ir)*dimir), dimir,
& adens, nactperir(ir), 1.0d0, tmp(sqroffset(ir)),
& nfunc(ir))
endif
kos = kos + (nactperir(ir) + nvirtir)*orbperir(ir) +
& nvirtir*nactperir(ir)
enddo
call mxto(adens, dcore(symtra_ptr), tmp, nbasis, tmp, offset,
& lsa)
end subroutine
************************************************************************
subroutine mod_dens(kappa, qscfsize, idens, nbasis, c, tmp,
& orbperir, nactperir, sqroffset, offset, alpha, beta,
& delta)
************************************************************************
* Modified density for MCSCF and HF calculations
************************************************************************
implicit none
integer qscfsize, nbasis, offset(nir)
integer sqroffset(nir), orbperir(nir), nactperir(nir)
integer ir, nvirtir, kos, dimir
double precision kappa(qscfsize), c(sqrsize)
double precision idens(nbasis**2), tmp(nbasis**2)
double precision alpha, beta, delta
c building modified dnesity for inactive Fock matrix construction
tmp = 0.0d0
kos = 1
do ir = 1, nir
c active - occupied part
if(nactperir(ir) .ne. 0 .and. orbperir(ir) .ne. 0) then
call dgemm('n', 'n', nfunc(ir), orbperir(ir), nactperir(ir),
& alpha, c(sqroffset(ir)+orbperir(ir)*nfunc(ir)),
& nfunc(ir), kappa(kos), nactperir(ir), 0.0d0, idens,
& nfunc(ir))
call dgemm('n', 't', nfunc(ir),nfunc(ir),orbperir(ir),1.0d0,
& c(sqroffset(ir)), nfunc(ir), idens, nfunc(ir), 0.0d0,
& tmp(sqroffset(ir)), nfunc(ir))
endif
c virtual - occupied part
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
if(orbperir(ir) .ne. 0 .and. nvirtir .ne. 0) then
dimir = nfunc(ir)
call dgemm('n', 'n', nfunc(ir), orbperir(ir), nvirtir,alpha,
& c(sqroffset(ir)+(orbperir(ir)+nactperir(ir))*dimir),
& nfunc(ir),kappa(kos+nactperir(ir)*orbperir(ir)),
& nvirtir, 0.0d0, idens, nfunc(ir))
call dgemm('n', 't', nfunc(ir),nfunc(ir),orbperir(ir),1.0d0,
& c(sqroffset(ir)), nfunc(ir), idens, nfunc(ir), 1.0d0,
& tmp(sqroffset(ir)), nfunc(ir))
endif
kos = kos + (nactperir(ir) + nvirtir)*orbperir(ir) +
& nvirtir*nactperir(ir)
enddo
call mxto(idens, dcore(symtra_ptr), tmp, nbasis, tmp, offset, lsa)
end subroutine
************************************************************************
subroutine symm_dens(dens, nbasis, beta, delta)
************************************************************************
* Subroutine to symmterize modified density
************************************************************************
implicit none
integer nbasis, i, j
double precision dens(nbasis, nbasis), beta, delta, val
if(beta .eq. 1.0d0 .and. delta .eq. 1.0d0) then
do i = 1, nbasis
do j = i+1, nbasis
val = dens(i, j) + dens(j, i)
dens(i, j) = val
dens(j, i) = val
enddo
enddo
elseif(beta .eq. 1.0d0 .and. delta .ne. 1.0d0) then
do i = 1, nbasis
do j = i+1, nbasis
val = delta*(dens(i, j) + dens(j, i))
dens(i, j) = val
dens(j, i) = val
enddo
enddo
elseif(beta .ne. 1.0d0 .and. delta .eq. 1.0d0) then
do i = 1, nbasis
dens(i, i) = beta*dens(i, i)
do j = i+1, nbasis
val = dens(i, j) + dens(j, i)
dens(i, j) = val
dens(j, i) = val
enddo
enddo
else
do i = 1, nbasis
dens(i, i) = beta*dens(i, i)
do j = i+1, nbasis
val = delta*(dens(i, j) + dens(j, i))
dens(i, j) = val
dens(j, i) = val
enddo
enddo
endif
end subroutine
************************************************************************
subroutine lintr_approx(kappa, sigma, p2, ifock, afock, qmat, tmp,
& offset, sqroffset)
************************************************************************
* Linear transformation with the one-electron approximation of the
* Hessian matrix
************************************************************************
use common_mod, only: orbperir, nfunc, nir, sqrsize, nbasis
implicit none
integer offset(nir), sqroffset(nir)
integer ir, dimir, nactir, nvirtir, noccir, kos
double precision kappa(qscfsize), sigma(qscfsize)
double precision p2(nact, nact), hcore(qscfsize)
double precision ifock(sqrsize), afock(sqrsize)
double precision tmp(sqrsize), qmat(nbasis, nact)
sigma = 0.0d0
kos = 1
do ir = 1, nir
dimir = nfunc(ir)
noccir = orbperir(ir)
nactir = nactperir(ir)
nvirtir = dimir - noccir - nactir
c*** active - occupied part
c H_tiuj*kappa_uj
if(nactir .ne. 0 .and. noccir .ne. 0) then
call dsymm('l', 'U', nactir, noccir, 2.0d0,
& p2(actoffset(ir), actoffset(ir)), nact, kappa(kos),
& nactir, 0.0d0, tmp, nactir)
call dsymm('r', 'u', nactir, noccir, 1.0d0,
& ifock(sqroffset(ir)), dimir, tmp, nactir, 1.0d0,
& sigma(kos), nactir)
call dgemm('t', 'n', nactir, noccir, nactir, -4.0d0,
& qmat(offset(ir)+noccir, 1), nbasis, kappa(kos), nactir,
& 1.0d0, sigma(kos), nactir)
call dsymm('l', 'u', nactir, noccir, 4.0d0,
& ifock(sqroffset(ir)+noccir*(dimir+1)), dimir, kappa(kos),
& nactir, 1.0d0, sigma(kos), nactir)
call dsymm('l', 'u', nactir, noccir, 4.0d0,
& afock(sqroffset(ir)+noccir*(dimir+1)), dimir, kappa(kos),
& nactir, 1.0d0, sigma(kos), nactir)
call dsymm('l', 'u', nactir, noccir, -2.0d0,
& p2(actoffset(ir), actoffset(ir)), nact, kappa(kos),
& nactir, 0.0d0, tmp, nactir)
call dsymm('l', 'u', nactir, noccir, 1.0d0,
& ifock(sqroffset(ir)+noccir*(dimir+1)), dimir, tmp,
& nactir, 1.0d0, sigma(kos), nactir)
call dsymm('r', 'u', nactir, noccir, -4.0d0,
& ifock(sqroffset(ir)), dimir, kappa(kos), nactir, 1.0d0,
& sigma(kos), nactir)
call dsymm('r', 'u', nactir, noccir, -4.0d0,
& afock(sqroffset(ir)), dimir, kappa(kos), nactir, 1.0d0,
& sigma(kos), nactir)
endif
c H_tiaj*akppa_aj
if(nactir .ne. 0 .and. nvirtir .ne. 0 .and. noccir .ne. 0) then
call dgemm('t', 'n', nactir, noccir, nvirtir, -2.0d0,
& qmat(offset(ir)+noccir+nactir, 1), nbasis,
& kappa(kos+noccir*nactir), nvirtir, 1.0d0, sigma(kos),
& nactir)
call dgemm('t', 'n', nactir, noccir, nvirtir, 4.0d0,
& ifock(sqroffset(ir)+noccir*(dimir+1)+nactir), dimir,
& kappa(kos+noccir*nactir), nvirtir, 1.0d0, sigma(kos),
& nactir)
call dgemm('t', 'n', nactir, noccir, nvirtir, 4.0d0,
& afock(sqroffset(ir)+noccir*(dimir+1)+nactir), dimir,
& kappa(kos+noccir*nactir), nvirtir, 1.0d0, sigma(kos),
& nactir)
call dgemm('t', 'n', nactir, noccir, nvirtir, 1.0d0,
& ifock(sqroffset(ir)+noccir*(dimir+1)+nactir), dimir,
& kappa(kos+noccir*nactir), nvirtir, 0.0d0, tmp,
& nactir)
call dsymm('l', 'u', nactir, noccir, -1.0d0,
& p2(actoffset(ir), actoffset(ir)), nact, tmp, nactir,
& 1.0d0, sigma(kos), nactir)
endif
c H_tiau*kappa_au
if(nactir .ne. 0 .and. nvirtir .ne. 0 .and. noccir .ne. 0) then
call dsymm('r', 'U', nvirtir, nactir, -2.0d0,
& p2(actoffset(ir), actoffset(ir)), nact,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir, 0.0d0, tmp,
& nvirtir)
call dgemm('t', 'n', nactir, noccir, nvirtir, 1.0d0, tmp,
& nvirtir, ifock(sqroffset(ir)+nactir+noccir), dimir,
& 1.0d0, sigma(kos), nactir)
call dgemm('t', 'n', nactir, noccir, nvirtir, 2.0d0,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
& ifock(sqroffset(ir)+noccir+nactir), dimir, 1.0d0,
& sigma(kos), nactir)
call dgemm('t', 'n', nactir, noccir, nvirtir, 2.0d0,
& kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
& afock(sqroffset(ir)+noccir+nactir), dimir, 1.0d0,
& sigma(kos), nactir)
endif
cc*** virtual - occupied part
cc H_ajti*kappa_ti
c if(nactir .ne. 0 .and. nvirtir .ne. 0 .and. noccir .ne. 0) then
c call dgemm('n', 'n', nvirtir, noccir, nactir, -2.0d0,
c & qmat(offset(ir)+noccir+nactir, 1), nbasis, kappa(kos),
c & nactir, 1.0d0, sigma(kos+noccir*nactir), nvirtir)
c call dgemm('n', 'n', nvirtir, noccir, nactir, 4.0d0,
c & ifock(sqroffset(ir)+noccir*(dimir+1)+nactir), dimir,
c & kappa(kos), nactir, 1.0d0, sigma(kos+noccir*nactir),
c & nvirtir)
c call dgemm('n', 'n', nvirtir, noccir, nactir, 4.0d0,
c & afock(sqroffset(ir)+noccir*(dimir+1)+nactir), dimir,
c & kappa(kos), nactir, 1.0d0, sigma(kos+noccir*nactir),
c & nvirtir)
c call dsymm('l', 'u', nactir, noccir, -1.0d0,
c & p2(actoffset(ir), actoffset(ir)), nact, kappa(kos),
c & nactir, 0.0d0, tmp, nactir)
c call dgemm('N', 'n', nvirtir, noccir, nactir, 1.0d0,
c & ifock(sqroffset(ir)+noccir*(dimir+1)+nactir), dimir,
c & tmp, nactir, 1.0d0, sigma(kos+noccir*nactir), nvirtir)
c endif
cc H_aibj*kappa_bj
c if(nvirtir .ne. 0 .and. noccir .ne. 0) then
c call dsymm('l', 'u', nvirtir, noccir, 4.0d0,
c & ifock(sqroffset(ir)+(noccir+nactir)*(dimir+1)), dimir,
c & kappa(kos+noccir*nactir), nvirtir, 1.0d0,
c & sigma(kos+noccir*nactir), nvirtir)
c call dsymm('l', 'u', nvirtir, noccir, 4.0d0,
c & afock(sqroffset(ir)+(noccir+nactir)*(dimir+1)), dimir,
c & kappa(kos+noccir*nactir), nvirtir, 1.0d0,
c & sigma(kos+noccir*nactir), nvirtir)
c call dsymm('r', 'u', nvirtir, noccir, -4.0d0,
c & ifock(sqroffset(ir)), dimir, kappa(kos+noccir*nactir),
c & nvirtir, 1.0d0, sigma(kos+noccir*nactir), nvirtir)
c call dsymm('r', 'u', nvirtir, noccir, -4.0d0,
c & afock(sqroffset(ir)), dimir, kappa(kos+noccir*nactir),
c & nvirtir, 1.0d0, sigma(kos+noccir*nactir), nvirtir)
c endif
cc H_aibt*kappa_bt
c if(nactir .ne. 0 .and. nvirtir .ne. 0 .and. noccir .ne. 0) then
c call dgemm('n', 't', nvirtir, noccir, nactir, -2.0d0,
c & kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
c & qmat(offset(ir)+nactir, 1), nbasis, 1.0d0,
c & sigma(kos+noccir*nactir), nvirtir)
c call dgemm('n', 'n', nvirtir, noccir, nactir, -2.0d0,
c & kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
c & ifock(sqroffset(ir)+noccir), dimir, 1.0d0,
c & sigma(kos+noccir*nactir), nvirtir)
c call dgemm('n', 'n', nvirtir, noccir, nactir, -2.0d0,
c & kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
c & afock(sqroffset(ir)+noccir), dimir, 1.0d0,
c & sigma(kos+noccir*nactir), nvirtir)
c call dsymm('r' ,'u', nvirtir, nactir, -1.0d0,
c & p2(actoffset(ir), actoffset(ir)), nact,
c & kappa(kos+nactir*noccir), nvirtir, 0.0d0, tmp, nvirtir)
c call dgemm('n', 'n', nvirtir, noccir, nactir, 1.0d0, tmp,
c & nvirtir, ifock(sqroffset(ir)+noccir), dimir, 1.0d0,
c & sigma(kos+noccir*nactir), nvirtir)
c endif
cc*** virtual - active part
cc H_auti*kappa_ti
c if(nactir .ne. 0 .and. nvirtir .ne. 0 .and. noccir .ne. 0) then
c call dsymm('l', 'u', nactir, noccir, -2.0d0,
c & p2(actoffset(ir), actoffset(ir)), nact, kappa(kos),
c & nactir, 0.0d0, tmp, nactir)
c call dgemm('n', 't', nvirtir, nactir, noccir, 1.0d0,
c & ifock(sqroffset(ir)+nactir+noccir), dimir, tmp, nactir,
c & 1.0d0, sigma(kos+(nactir+nvirtir)*noccir), nvirtir)
c call dgemm('N', 't', nvirtir, nactir, noccir, 2.0d0,
c & ifock(sqroffset(ir)+noccir+nactir), dimir, kappa(kos),
c & nactir, 1.0d0, sigma(kos+(nactir+nvirtir)*noccir),
c & nvirtir)
c call dgemm('N', 't', nvirtir, nactir, noccir, 2.0d0,
c & afock(sqroffset(ir)+noccir+nactir), dimir, kappa(kos),
c & nactir, 1.0d0, sigma(kos+(nactir+nvirtir)*noccir),
c & nvirtir)
c endif
cc H_btai*kappa_ai
c if(nactir .ne. 0 .and. nvirtir .ne. 0 .and. noccir .ne. 0) then
c call dgemm('n', 'N', nvirtir, nactir, noccir, -2.0d0,
c & qmat(sqroffset(ir), 1), nbasis,kappa(kos+nactir*noccir),
c & nvirtir, 1.0d0, sigma(kos+(nactir+nvirtir)*noccir),
c & nvirtir)
c call dgemm('n', 'n', nvirtir, nactir, noccir, -2.0d0,
c & kappa(kos+nactir*noccir), nvirtir,
c & ifock(sqroffset(ir)+noccir*dimir), dimir, 1.0d0,
c & sigma(kos+noccir*(nactir+nvirtir)), nvirtir)
c call dgemm('n', 'n', nvirtir, nactir, noccir, -2.0d0,
c & kappa(kos+nactir*noccir), nvirtir,
c & afock(sqroffset(ir)+noccir*dimir), dimir, 1.0d0,
c & sigma(kos+noccir*(nactir+nvirtir)), nvirtir)
c call dgemm('n', 'n', nvirtir, nactir, noccir, -1.0d0,
c & kappa(kos+noccir*nactir), nvirtir,
c & ifock(sqroffset(ir)+nactir*dimir), dimir, 0.0d0, tmp,
c & nvirtir)
c call dsymm('r', 'u', nvirtir, nactir, 1.0d0,
c & p2(actoffset(ir), actoffset(ir)), nact, tmp, nvirtir,
c & 1.0d0, sigma(kos+noccir*(nvirtir+nactir)), nvirtir)
c endif
cc H_atbu*kappa_bu
c if(nvirtir .ne. 0 .and. nactir .ne. 0) then
c call dsymm('l', 'u', nvirtir, nactir, 2.0d0,
c & ifock(sqroffset(ir)+(noccir+nactir)*(dimir+1)), dimir,
c & kappa(kos+(nactir+nvirtir)*noccir), nvirtir, 0.0d0, tmp,
c & nvirtir)
c call dsymm('r', 'u', nvirtir, nactir, 1.0d0,
c & p2(actoffset(ir), actoffset(ir)), nact, tmp, nvirtir,
c & 1.0d0, sigma(kos+(nactir+nvirtir)*noccir), nvirtir)
c call dgemm('n', 'n', nvirtir, nactir, nactir, -2.0d0,
c & kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
c & qmat(offset(ir)+noccir, 1), nbasis, 1.0d0,
c & sigma(kos+(nactir+nvirtir)*noccir), nvirtir)
c call dgemm('n', 't', nvirtir, nactir, nactir, -2.0d0,
c & kappa(kos+(nactir+nvirtir)*noccir), nvirtir,
c & qmat(offset(ir)+noccir, 1), nbasis, 1.0d0,
c & sigma(kos+(nactir+nvirtir)*noccir), nvirtir)
c call dsymm('r', 'u', nactir, nactir, -1.0d0,
c & p2(actoffset(ir), actoffset(ir)), nact,
c & ifock(sqroffset(ir)+noccir*(dimir+1)), dimir, 0.0d0, tmp,
c & nactir)
c call dgemm('N', 'N', nvirtir, nactir, nactir, 1.0d0,
c & kappa(kos+(nactir+nvirtir)*noccir), nvirtir, tmp, nactir,
c & 1.0d0, sigma(kos+(nactir+nvirtir)*noccir), nvirtir)
c call dsymm('l', 'u', nactir, nactir, -1.0d0,
c & p2(actoffset(ir), actoffset(ir)), nact,
c & ifock(sqroffset(ir)+noccir*(dimir+1)), dimir, 0.0d0, tmp,
c & nactir)
c call dgemm('N', 'N', nvirtir, nactir, nactir, 1.0d0,
c & kappa(kos+(nactir+nvirtir)*noccir), nvirtir, tmp, nactir,
c & 1.0d0, sigma(kos+(nactir+nvirtir)*noccir), nvirtir)
c endif
kos = kos + noccir*(nactir+nvirtir) + nvirtir*nactir
enddo
end subroutine
************************************************************************
SUBROUTINE buildm2(npos, intpos, m, p, chfx)
************************************************************************
* Building M matrix from 2-electron integrals
************************************************************************
#include "MRCCCOMMON"
#include "SCFCOMMON"
C ARRAYS
INTEGER INTPOS(3,(nbasis+1)*nbasis/2)
INTEGER TEINTF(10)
INTEGER*2 SSI(4)
C SCALARS
INTEGER T,Q
INTEGER I,J,K,L
INTEGER IFEOF
INTEGER NPOS
INTEGER IPOS
INTEGER IMEM1
INTEGER NINTEG
INTEGER NNINTEG
INTEGER IPOSLO
INTEGER IP
INTEGER MAXM
integer nb2
REAL*8 TEMP, m(*), p(*), chfx
EQUIVALENCE(TEMP,SSI)
COMMON/MEMCOM/ IMEM1
integer idamax
C
CALL INTOPENRSQ(TEINTF)
C
nb2 = nbasis**2
IPOS=0
MAXM=IFLTLN*MIN(MAXCOR-(IMEM-IMEM1),20*nbasis*(nbasis+1)/2)
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
I =INTPOS(1,IP)
K =INTPOS(2,IP)
NINTEG=INTPOS(3,IP)
C BUILDING FOCK PART FROM READ BATCH
SELECT CASE (scftype)
CASE (1) !RHF
CALL getm2elems_rhf(NBASIS,dcore(imem),I,K,NINTEG,
& NNINTEG,m,p,chfx)
CASE (2) !UHF
CALL getm2elems_uhf(NBASIS,dcore(imem),I,K,NINTEG,
& NNINTEG,m(1), m(1+nb2), p, p(nb2+1), chfx)
case (0) !MCSCF
CALL getm2elems_mcscf(NBASIS,dcore(imem),I,K,NINTEG,
& NNINTEG,m,p,chfx)
case default !ROHF
CALL getm2elems_mcscf(NBASIS,dcore(imem),I,K,NINTEG,
& NNINTEG,m,p,chfx)
END SELECT
NNINTEG=NNINTEG+6*NINTEG
ENDDO
IF(IPOS.EQ.NPOS) EXIT
ENDDO
CALL INTCLOSE(TEINTF)
RETURN
END subroutine
************************************************************************
subroutine conjgrad(grad, c, x, newr, oldr, p, ptr, z,
& oldz, diag, p2, npos, intpos, sqroffset, offset, nfr,
& n, lsa, peps, chfx, exc, step, lfin, embed, lwdfn,
& scfdamp, route, nc, ncorenew, devparr, kmax, clrhfx,
& csrhfx, omega, pcm)
************************************************************************
* A preconditioned conjugate gradient method to solve the Newton-equation
************************************************************************
use common_mod, only: verblevel, iout
implicit none
integer n, k, npos, intpos(*), i, kmax, ir
integer sqroffset(nir), offset(nir)
integer step
double precision clrhfx,csrhfx,omega
double precision grad(n), c(sqrsize), x(n), z(n)
double precision diag(n), p2(nact, nact)
double precision oldr(n), newr(n), p(n), ptr(n)
double precision newr_norm, oldr_norm, oldz(n)
double precision alpha, beta, peps, chfx, exc
logical lsa
integer lfin,nfr,nc,ncorenew
double precision devparr(2)
character*4 route
character*16 scfdamp
character*32 pcm
logical lwdfn
character*8 embed
integer idamax, dblalloc
double precision ddot, dnrm2
k = 1
write(iout,"(1X,70('*'))")
write(iout,"(1X,'Calculating Newton-step...')")
call dlaset('f', n, 1, 0.0d0, 0.0d0, x, n)
call dcopy(n, grad, 1, newr, 1)
call dscal(n, -1.0d0, newr, 1)
i = idamax(n, newr, 1)
newr_norm = dabs(newr(i))
call dcopy(n, newr, 1, p, 1)
do i = 1, n
p(i) = p(i)/diag(i)
enddo
call dcopy(n, p, 1, z, 1)
write(iout,"(1X,'Microiteration',I5,9X,
& 'Norm of the residual vector: ',ES12.5E2)") k, newr_norm
do while(newr_norm .gt. peps)
if(k .gt. kmax) then
write(iout,*) " ERROR: NEWTON-METHOD HAS NOT CONVERGED!"
call mrccend(1)
endif
call dcopy(n, newr, 1, oldr, 1)
call dcopy(n, z, 1, oldz, 1)
oldr_norm = newr_norm
call lintr(p, ptr, grad, offset, sqroffset, n, npos, chfx, exc,
& step, .false., lfin, embed, lwdfn, scfdamp, route,
& nfr, nc, ncorenew, devparr, clrhfx, csrhfx, omega, pcm)
alpha = ddot(n, oldr, 1, oldz, 1)/ddot(n, p, 1, ptr, 1)
call daxpy(n, alpha, p, 1, x, 1)
call daxpy(n, -alpha, ptr, 1, newr, 1)
i = idamax(n, newr, 1)
newr_norm = dabs(newr(i))
do i = 1, n
z(i) = newr(i)/diag(i)
enddo
beta = ddot(n, newr, 1, z, 1)/ddot(n, oldr, 1, oldz, 1)
call dscal(n, beta, p, 1)
call daxpy(n, 1.0d0, z, 1, p, 1)
k = k + 1
write(iout,"(1X,'Microiteration',I5,9X,
& 'Norm of the residual vector: ',ES12.5E2)") k, newr_norm
enddo
write(iout,"(' Newton-step has converged!')")
write(iout,"(1X,70('*'))")
write(iout,*)
end subroutine
************************************************************************
subroutine lbfgs(grad, h0, rho, svec, yvec, bfgs_vector_map, qvec,
& alpha)
************************************************************************
* Limited memory BFGS: calculating -H_k * grad
************************************************************************
implicit none
integer i, ii
integer bfgs_vector_map(bfgs_max_pairs)
double precision alpha(bfgs_max_pairs), beta
double precision rho(bfgs_max_pairs)
double precision svec(qscfsize, bfgs_max_pairs)
double precision yvec(qscfsize, bfgs_max_pairs)
double precision grad(qscfsize), qvec(qscfsize), h0(qscfsize)
double precision ddot
call dcopy(qscfsize, grad, 1, qvec, 1)
do ii = bfgs_pairs, 1, -1
i = bfgs_vector_map(ii)
alpha(i) = rho(i)*ddot(qscfsize, svec(1, i), 1, qvec, 1)
qvec = qvec - alpha(i)*yvec(1:qscfsize, i)
enddo
do i = 1, qscfsize
qvec(i) = qvec(i) * h0(i)
enddo
do ii = 1, bfgs_pairs
i = bfgs_vector_map(ii)
beta = rho(i)*ddot(qscfsize, yvec(1, i), 1, qvec, 1)
qvec = qvec + svec(1:qscfsize, i)*(alpha(i)-beta)
enddo
call dscal(qscfsize, -1.d0, qvec, 1)
c write(*,'(A)') 'qvec'
c call prmx(qvec,1,1,qscfsize)
return
end subroutine
************************************************************************
subroutine add_sy_pair(svec, yvec, rho, xvec, oldxvec, grad,
& oldgrad, bfgs_vector_map)
************************************************************************
* Updating (s_k, y_k) pairs for BFGS calculation
************************************************************************
implicit none
integer n, i
integer bfgs_vector_map(bfgs_max_pairs)
double precision rho(bfgs_max_pairs), x
double precision svec(qscfsize, bfgs_max_pairs)
double precision yvec(qscfsize, bfgs_max_pairs)
double precision xvec(qscfsize), oldxvec(qscfsize)
double precision grad(qscfsize), oldgrad(qscfsize)
double precision ddot
x = ddot(qscfsize, oldxvec, 1, grad, 1) -
& ddot(qscfsize, oldxvec, 1, oldgrad, 1)
if(x .gt. 0.0d0) then
if(bfgs_step .ne. 0) then
if(bfgs_pairs .lt. bfgs_max_pairs) then
bfgs_pairs = bfgs_pairs + 1
n = bfgs_pairs
bfgs_vector_map(n) = n
else
n = mod(bfgs_step, bfgs_max_pairs)
do i = 2, bfgs_max_pairs
bfgs_vector_map(i-1) = bfgs_vector_map(i)
enddo
bfgs_vector_map(bfgs_max_pairs) = n
endif
call dcopy(qscfsize, oldxvec, 1, svec(1, n), 1)
call dcopy(qscfsize, grad, 1, yvec(1, n), 1)
call daxpy(qscfsize, -1.0d0, oldgrad, 1, yvec(1, n), 1)
c rho(n) = 1.0d0/ddot(qscfsize, svec(1, n), 1, yvec(1, n), 1)
rho(n) = 1.0d0/x
endif
endif
bfgs_step = bfgs_step + 1
call dcopy(qscfsize, xvec, 1, oldxvec, 1)
call dcopy(qscfsize, grad, 1, oldgrad, 1)
end subroutine
************************************************************************
subroutine bfgs_h0(svec, yvec, h0, bfgs_vector_map, grad_norm, h,
& diag)
************************************************************************
* Caclulating the BFGS approximate inverse Hessian (H_0)
************************************************************************
implicit none
integer n
integer bfgs_vector_map(bfgs_max_pairs)
double precision svec(qscfsize, bfgs_max_pairs)
double precision yvec(qscfsize, bfgs_max_pairs)
double precision h0(qscfsize), diag(qscfsize)
double precision grad_norm ! 2-norm of gradient
double precision h ! trust radius
double precision g
double precision dnrm2
do n = 1, qscfsize
h0(n) = 1.0d0/diag(n)
enddo
return
end subroutine
************************************************************************
double precision function check_grad(fock, c, qmat,
& sqroffset, work, work2, scftype) result(grad_norm)
************************************************************************
* Check gradient norm for BFGS calculation
************************************************************************
use common_mod, only: sqrsize, sqrsize2, nfunc
implicit none
integer r, ir
integer sqroffset(nir), scftype, nvirtir
double precision fock(sqrsize2), c(sqrsize2), qmat(sqrsize)
double precision work(sqrsize), work2(sqrsize2)
integer idamax
if(scftype .lt. 3) then
do r = 0, rmax
do ir = 1, nir
if(nfunc(ir) .eq. 0) cycle
call dsymm('l', 'u', nfunc(ir), nfunc(ir), 1.0d0,
& fock(sqroffset(ir)+r*sqrsize), nfunc(ir),
& c(sqroffset(ir)+r*sqrsize), nfunc(ir), 0.0d0,
& work(sqroffset(ir)), nfunc(ir))
call dgemm('t', 'n', nfunc(ir), nfunc(ir), nfunc(ir),
& 1.0d0, c(sqroffset(ir)+r*sqrsize), nfunc(ir),
& work(sqroffset(ir)), nfunc(ir), 0.0d0,
& work2(sqroffset(ir)+r*sqrsize), nfunc(ir))
enddo
enddo
elseif(scftype .ge. 3) then
do ir = 1, nir
if(nfunc(ir) .eq. 0) cycle
! transforming the Fock matrix
call dsymm('l', 'u', nfunc(ir), orbperir(ir)+nactperir(ir),
& 1.0d0, fock(sqroffset(ir)), nfunc(ir),
& c(sqroffset(ir)), nfunc(ir), 0.0d0,
& work(sqroffset(ir)), nfunc(ir))
call dgemm('t', 'n', nfunc(ir), orbperir(ir)+nactperir(ir),
& nfunc(ir), 1.0d0, c(sqroffset(ir)), nfunc(ir),
& work(sqroffset(ir)), nfunc(ir), 0.0d0,
& work2(sqroffset(ir)), nfunc(ir))
! Transforming the ROHF Q matrix (!= QSCF Q matrix!!!!)
call dsymm('l', 'u', nfunc(ir), nactperir(ir),
& 1.0d0, qmat(sqroffset(ir)), nfunc(ir),
& c(sqroffset(ir)+orbperir(ir)*nfunc(ir)), nfunc(ir),
& 0.0d0, work(sqroffset(ir)), nfunc(ir))
call dgemm('t', 'n', nfunc(ir), nactperir(ir), nfunc(ir),
& -0.5d0, c(sqroffset(ir)), nfunc(ir), work(sqroffset(ir)),
& nfunc(ir), 1.0d0,
& work2(sqroffset(ir)+orbperir(ir)*nfunc(ir)), nfunc(ir))
if(orbperir(ir) .ne. 0) call dscal(nfunc(ir)*orbperir(ir),
& 2.0d0, work2(sqroffset(ir)), 1)
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
if(nvirtir .ne. 0)
& call dfillzero(work2(sqroffset(ir)+(orbperir(ir)+
& nactperir(ir))*nfunc(ir)), nfunc(ir)*nvirtir)
enddo
endif
call mk_grad(work2, work, sqroffset, qscfsize, grad_scale)
grad_norm = dabs(work(idamax(qscfsize, work, 1)))
return
end function
************************************************************************
subroutine solve_precond(x, chfx, offset, sqroffset, npos, exc,
& clrhfx, csrhfx, omega, pcm)
************************************************************************
* Solving a linear equation with the preconditioner
************************************************************************
use common_mod, only: symtra_ptr,dcore,imem,nbasis,sqrsize,iout,
& c_ptr
implicit none
integer i, ir, j, info, offset(*), sqroffset(*), npos, step
integer isymm_gf, ihcore
double precision clrhfx,csrhfx,omega
double precision x(qscfsize)
double precision chfx, exc
integer oeintfile
parameter(oeintfile = 71)
double precision, allocatable :: hessian(:,:), tmp(:)
integer lfin,nfr,nc,ncorenew
double precision devparr(2)
character*4 route
character*16 scfdamp
character*32 pcm
logical lwdfn
character*8 embed
integer dblalloc
allocate(hessian(qscfsize, qscfsize))
allocate(tmp(qscfsize))
c Solving the linear eqaution
do i = 1, qscfsize
tmp = 0.0d0
tmp(i) = 1.0d0
call lintr(tmp, hessian(1, i), dcore(igrad), offset,
& sqroffset, qscfsize, npos, chfx, exc, step, .true.,
& lfin, embed, lwdfn, scfdamp, route, nfr, nc,
& ncorenew, devparr, clrhfx, csrhfx, omega, pcm)
enddo
write(iout,*) 'hess approx'
call prmx(hessian, qscfsize, qscfsize, qscfsize)
call dgesv(qscfsize, 1, hessian, qscfsize, dcore(imem), x,
& qscfsize, info)
deallocate(hessian)
deallocate(tmp)
c call dbldealloc(ihcore)
end subroutine
************************************************************************
subroutine trcoef(kappa, c, sqroffset)
************************************************************************
* Transform MO coef with exp(-kappa)
************************************************************************
implicit none
integer sqroffset(nir)
integer i, ir, s, info, dimir, r
integer ifullkappa, it, iu, ieig, ia
double precision kappa(qscfsize), c(sqrsize)
integer idamax, dblalloc
double precision dabs, dsqrt
c i = idamax(qscfsize, kappa, 1)
c if(dabs(kappa(i)) .lt. 1.0d-8) return
s = maxval(nfunc, nir)
it = dblalloc(s*s) ! T = kappa**2
ifullkappa = dblalloc(sqrsize) ! Matrix form of the kappa vector
ieig = dblalloc(s) ! Eigenvalues of T
ia = dblalloc(s)
iu = dblalloc(s*s) ! Temporary array
call dfillzero(dcore(ifullkappa), sqrsize)
do r = 0, rmax
call mxvec_conv(dcore(ifullkappa), kappa(1+r*qscfsizea),
& orbperir(1+r*nir), qscfsize, sqroffset, .false., .true.)
call dscal(sqrsize, -1.0d0, dcore(ifullkappa), 1)
do ir = 1, nir
if(nfunc(ir) .eq. 0) cycle
dimir = nfunc(ir)
call dgemm('n', 'n', dimir, dimir, dimir, 1.0d0,
& dcore(ifullkappa+sqroffset(ir)-1), dimir,
& dcore(ifullkappa+sqroffset(ir)-1), dimir, 0.0d0,
& dcore(it), nfunc(ir))
call dsyev('v', 'u', nfunc(ir), dcore(it), nfunc(ir),
& dcore(ieig), dcore(imem), max(nbasis**2, 3*nfunc(ir)-1),
& info)
do i = 1, dimir
dcore(ieig+i-1) = dsqrt(dabs(dcore(ieig+i-1)))
if(dcore(ieig+i-1) .lt. 1.0d-10) then
dcore(ia+i-1) = 1.0d0
dcore(ieig+i-1) = 1.0d0
else
dcore(ia+i-1) = dcos(dcore(ieig+i-1))
dcore(ieig+i-1) = dsin(dcore(ieig+i-1))/dcore(ieig+i-1)
endif
enddo
call dgemm('t', 'n', dimir, dimir, dimir, 1.0d0, dcore(it),
& dimir, dcore(ifullkappa+sqroffset(ir)-1), dimir, 0.0d0,
& dcore(iu), dimir)
do i = 1, dimir
call dscal(dimir, dcore(ieig+i-1), dcore(iu+i-1), dimir)
enddo
call dgemm('n', 'n', dimir, dimir, dimir, 1.0d0, dcore(it),
& dimir, dcore(iu), dimir, 0.0d0,
& dcore(ifullkappa+sqroffset(ir)-1), dimir)
call dcopy(dimir**2, dcore(it), 1, dcore(iu), 1)
do i = 1, dimir
call dscal(dimir, dcore(ia+i-1), dcore(it+dimir*(i-1)), 1)
enddo
call dgemm('n', 't', dimir, dimir, dimir, 1.0d0, dcore(iu),
& dimir, dcore(it), dimir, 1.0d0,
& dcore(ifullkappa+sqroffset(ir)-1), dimir)
call dgemm('n', 'n', dimir, dimir, dimir, 1.0d0,
& c(r*sqrsize+sqroffset(ir)), dimir,
& dcore(ifullkappa+sqroffset(ir)-1), dimir, 0.0d0,
& dcore(iu), dimir)
call dcopy(dimir**2,dcore(iu),1,c(r*sqrsize+sqroffset(ir)),1)
enddo
enddo
call dbldealloc(it)
end subroutine
************************************************************************
subroutine build_dens(c, p, sqrsize, sqroffset)
************************************************************************
* Build density matrix
************************************************************************
implicit none
integer sqrsize, sqroffset(nir)
integer ir, q
double precision c(sqrsize), p(sqrsize)
p = 0.0d0
if(scftype .eq. 0 .or. scftype .eq. 1) then
do ir = 1, nir
if(orbperir(ir) .ne. 0) then
call dsyrk('u', 'n', nfunc(ir), orbperir(ir), 2.0d0,
& c(sqroffset(ir)), nfunc(ir), 0.0d0, p(sqroffset(ir)),
& nfunc(ir))
call filllo(p(sqroffset(ir)), nfunc(ir))
endif
enddo
elseif(scftype .eq. 2) then
do q = 0, 1
do ir = 1, nir
if(orbperir(ir+q*nir) .eq. 0) cycle
call dsyrk('u', 'n', nfunc(ir), orbperir(ir+q*nir), 1.d0,
& c(sqroffset(ir)+q*sqrsize), nfunc(ir), 0.d0,
& p(sqroffset(ir)+q*sqrsize), nfunc(ir))
call filllo(p(sqroffset(ir)+q*sqrsize),nfunc(ir))
enddo
enddo
elseif(scftype .ge. 3) then
do ir = 1, nir
if(nfunc(ir) .eq. 0) cycle
call dsyrk('u', 'n', nfunc(ir), orbperir(ir), 2.0d0,
& c(sqroffset(ir)), nfunc(ir), 0.0d0, p(sqroffset(ir)),
& nfunc(ir))
call filllo(p(sqroffset(ir)), nfunc(ir))
enddo
do ir = 1, nir
if(nfunc(ir) .eq. 0) cycle
call dsyrk('u', 'n', nfunc(ir), orbperir(ir+nir), 1.0d0,
& c(sqroffset(ir)+orbperir(ir)*nfunc(ir)), nfunc(ir),
& 0.0d0, p(sqroffset(ir)+sqrsize), nfunc(ir))
call filllo(p(sqroffset(ir)+sqrsize), nfunc(ir))
enddo
call daxpy(sqrsize, 1.0d0, p(sqrsize+1), 1, p, 1)
endif
end subroutine
************************************************************************
logical function check_goldstein(diff, alpha, ener, oldener, eps)
************************************************************************
* Check whether the Goldstein condition is satesfied for the step in
* line search algorithm
************************************************************************
implicit none
double precision alpha, ener, oldener, a, c, diff, eps
parameter(c = 1.0d-4)
a = oldener + c*alpha*diff
if(a - ener .gt. -eps) then
check_goldstein = .true.
else
check_goldstein = .false.
endif
return
end function
************************************************************************
double precision function nsteplen_q(ener0, enera,alpha, diff)
************************************************************************
* New steplength from quadratic interpolation
************************************************************************
implicit none
double precision alpha, ener0, enera, diff
nsteplen_q=-0.5d0*diff*alpha*alpha/(enera - ener0 - diff*alpha)
return
end function
************************************************************************
double precision function nsteplen_c(ener0, enera0, alpha0,
& enera1, alpha1, diff)
************************************************************************
* New steplength from cubic interpolation
************************************************************************
implicit none
double precision ener0, enera1, alpha1, enera0, alpha0
double precision a, b, div, diff, delta, eps
parameter(delta = 1.0d-3, eps = 1.0d-1)
div = 1.0d0/(alpha0*alpha0*alpha1*alpha1*(alpha1-alpha0))
a = (alpha0*alpha0*(enera1 - ener0 - diff*alpha1) -
& alpha1*alpha1*(enera0 - ener0 - diff*alpha0))*div
b = (-alpha0*alpha0*alpha0*(enera1 - ener0 - diff*alpha1) +
& alpha1*alpha1*alpha1*(enera0 - ener0 - diff*alpha0))*div
nsteplen_c = (-b + dsqrt(b*b - 3.0d0*a*diff))/(3.0d0*a)
if(nsteplen_c .gt. 0.0d0 .and.
& (dabs(nsteplen_c - alpha1) .lt. delta .or.
& dabs(nsteplen_c - eps*alpha1) .lt. delta)) then
nsteplen_c = 5.0d-1*alpha1
endif
return
end function
************************************************************************
double precision function zoom(alpha_lo, alpha_hi, oldener,
& ener_lo, ener_hi, diff, mo, c1, c2, kappa, oldkappa, chfx, hnuc,
& npos, offset, sqroffset, lfin, nfr, nc, ncorenew, exc, devparr,
& dft, embed, scfdamp, route, lwdfn, work, microit_step, maxit,
& clrhfx, csrhfx, omega, pcm) result(ener)
************************************************************************
* Calculating steplength for line search (Wolfe condition)
* See chapter 3 of Nocedal and Wright
************************************************************************
use common_mod, only: iout
implicit none
integer lfin, nfr, nc, ncorenew, sqroffset(nir), offset(2*nir)
integer microit_step, npos, maxit
double precision alpha_hi, alpha_lo, ener_lo, ener_hi, diff_alpha
double precision oldener, diff, c1, c2, alpha, mo(*)
double precision kappa(qscfsize), oldkappa(qscfsize)
double precision chfx, hnuc, exc, devparr(2), work(qscfsize)
double precision clrhfx,csrhfx,omega
character*32 dft,pcm
character*8 embed
character*16 scfdamp
character*4 route
logical lwdfn
double precision ddot
do
microit_step = microit_step + 1
if(microit_step .gt. maxit+1 .or.
& dabs(alpha_lo - alpha_hi) .lt. 1.0d-7) return
alpha = (alpha_lo + alpha_hi) / 2.0d0
call dcopy(qscfsize, oldkappa, 1, kappa, 1)
call dscal(qscfsize, alpha, kappa, 1)
call read_data(mo, mo, mo, mo, mo, mo, mo, mo, mo, .true.)
call trcoef(kappa, mo, sqroffset)
call build_dens(mo, dcore(p_ptr), sqrsize, sqroffset)
ener = mcscf_energy(chfx, hnuc, npos, offset, sqroffset,
& lfin, nfr, nc, ncorenew, exc, devparr, dft, embed,
& scfdamp, route, lwdfn,clrhfx,csrhfx,omega,pcm)
write(iout,"(1X,'SCF energy in microiteration ', I2, ' is ',
& F24.16,' [AU]')") microit_step, ener
if(ener .gt. oldener+c1*alpha*diff .or. ener .ge. ener_lo) then
alpha_hi = alpha
ener_hi = ener
else
call mk_grad(dcore(igenfock), work, sqroffset, qscfsize,
& grad_scale)
diff_alpha = ddot(qscfsize, work, 1, kappa, 1)
if(dabs(diff_alpha).le.-c2*diff) exit
if(diff_alpha*(alpha_hi-alpha_lo) .ge. 0.0d0) then
alpha_hi = alpha_lo
ener_hi = ener
endif
alpha_lo = alpha
ener_lo = ener
endif
enddo
write(iout,"(1X,A)") 'Quasi-Newton step has been accepted!'
return
end function
************************************************************************
subroutine line_search(offset, sqroffset, hnuc, step, ener,
& oldener, gn, oldgn, kappa, oldkappa, kappa_tr, c,
& genfock, grad, p2, p4, qmat, chfx, qscf, trust_rad, rej, npos,
& lfin, nfr, nc, ncorenew, exc, devparr, dft, embed, scfdamp,
& route, lwdfn, update, work, clrhfx, csrhfx, omega, pcm)
************************************************************************
* Subroutine for line search optimization algorithm
************************************************************************
use common_mod, only: scftype, sqrsize, nir, sqrsize2, nbasis,
& enerepsilon, iintpos, rmat_ptr, iout
implicit none
integer offset(nir), sqroffset(nir), npos, step
integer microit_step, i, ir, maxit
double precision kappa(qscfsize), oldkappa(qscfsize), c(sqrsize2)
double precision genfock(sqrsize2), p2(nact, nact)
double precision kappa_tr(qscfsize), p4(nact, nact, nact, nact)
double precision qmat(nbasis, nact), grad(qscfsize)
double precision work(qscfsize)
double precision hnuc, ener, diff, chfx, gn, oldgn
double precision oldener, enera0, enera1, trust_rad
double precision alpha, alpha0, alpha1, alpha2,clrhfx,csrhfx,omega
double precision alpha_max, diff_alpha
double precision c1, c2
parameter (c1 = 1.0d-4, c2 = 0.9d0)
character*8 qscf
logical rej, update
integer lfin, nfr, nc, ncorenew
double precision exc, devparr(2)
character*32 dft,pcm
character*8 embed
character*16 scfdamp
character*4 route
logical lwdfn
double precision ddot, dnrm2
if(qscf .eq. 'aughess ') then ! There is no line search
ener = mcscf_energy(chfx, hnuc, npos, offset, sqroffset, lfin,
& nfr, nc, ncorenew, exc, devparr, dft, embed, scfdamp,
& route, lwdfn,clrhfx,csrhfx,omega,pcm)
call update_trust_radius(trust_rad, grad, ener, oldener, rej,
& kappa, kappa_tr, qscf, alpha, diff, gn, oldgn, qscfsize,
& microit_step)
if(rej) then
call read_data(c, dcore(ifock_ptr), dcore(afock_ptr),
& dcore(igenfock), dcore(rmat_ptr), dcore(p_ptr),
& dcore(ip2), dcore(ip4), dcore(iq), .false.)
ener = oldener
if(scftype .eq. 0) then
call get_moint(i, i, offset, npos, icore(iintpos), 1,
& kappa, .true.)
endif
write(iout,"(1X,A)")
& 'Augemented Hessian step has been rejected!'
endif
return
endif
write(iout,"(1X,'Starting line search...')")
! Line search for Wolfe condition (Nocedal, Wright: chap. 3)
if(qscf.eq.'bfgs ') then
alpha_max = 10.0d0
alpha = 1.0d0 ! Steplength in this microiteration
alpha0 = 0.0d0 ! Steplength in the previous iteration
maxit = 50
call dcopy(qscfsize, kappa, 1, oldkappa, 1)
diff = ddot(qscfsize, kappa, 1, grad, 1)
enera1 = oldener ! Energy in the previous microiteration
microit_step = 1
do
ener = mcscf_energy(chfx, hnuc, npos, offset, sqroffset, lfin,
& nfr, nc, ncorenew, exc, devparr, dft, embed, scfdamp,
& route, lwdfn, clrhfx, csrhfx, omega, pcm)
write(iout,"(1X,'SCF energy in microiteration ', I2, ' is ',
& F24.16,' [AU]')") microit_step, ener
if(dabs(ener - enera1) .lt. enerepsilon) return
if(ener .gt. oldener+c1*alpha*diff .or.
& (ener .ge. enera1 .and. microit_step .gt. 1)) then
ener = zoom(alpha0, alpha, oldener, enera1, ener, diff, c,
& c1, c2, kappa, oldkappa, chfx, hnuc, npos, offset,
& sqroffset, lfin, nfr, nc, ncorenew, exc, devparr,
& dft, embed, scfdamp, route, lwdfn, work,
& microit_step, maxit, clrhfx, csrhfx, omega, pcm)
return
endif
call mk_grad(dcore(igenfock), work, sqroffset, qscfsize,
& grad_scale)
diff_alpha = ddot(qscfsize, work, 1, kappa, 1)
if(dabs(diff_alpha) .le. -c2*diff) then
write(iout,"(1X,A)") 'Quasi-Newton step has been accepted!'
return
endif
if(diff_alpha .ge. 0.0d0) then
ener = zoom(alpha, alpha0, oldener, ener, enera1, diff,
& c, c1, c2, kappa, oldkappa, chfx, hnuc, npos, offset,
& sqroffset, lfin, nfr, nc, ncorenew, exc, devparr,
& dft, embed, scfdamp, route, lwdfn, work,
& microit_step, maxit, clrhfx, csrhfx, omega, pcm)
return
endif
alpha0 = alpha
alpha = 0.5d0*(alpha + alpha_max)
enera1 = ener
call dcopy(qscfsize, oldkappa, 1, kappa, 1)
call read_data(c, c, c, c, c, c, c, c, c, .true.)
call dscal(qscfsize, alpha, kappa, 1)
call trcoef(kappa, c, sqroffset)
call build_dens(c, dcore(p_ptr), sqrsize, sqroffset)
microit_step = microit_step + 1
enddo
return
endif
! Backtracking line search (Nocedal, Wright: chap 3)
microit_step = 1
alpha = 1.0d0
alpha0 = 1.0d0
call dcopy(qscfsize, kappa, 1, oldkappa, 1)
diff = ddot(qscfsize, kappa, 1, grad, 1)
do
ener = mcscf_energy(chfx, hnuc, npos, offset, sqroffset, lfin,
& nfr, nc, ncorenew, exc, devparr, dft, embed, scfdamp,
& route, lwdfn,clrhfx,csrhfx,omega,pcm)
write(iout,"(1X,'SCF energy in microiteration ', I2, ' is ',
& F24.16,' [AU]')") microit_step, ener
if(check_goldstein(diff, alpha, ener, oldener, enerepsilon))then
if(dabs(ener - oldener) .lt. enerepsilon .and.
& alpha .lt. 1.0d0.and.qscf.ne.'bfgs ') then
write(iout,"(1X, 'Steplength is too small!')")
write(iout,"(1X,A)")
& 'Augemented Hessian step has been rejected!'
write(iout,"(1X,70('*'))")
rej = .true.
trust_rad = 0.5d0*trust_rad
call read_data(c, dcore(ifock_ptr), dcore(afock_ptr),
& dcore(igenfock), dcore(rmat_ptr), dcore(p_ptr),
& dcore(ip2), dcore(ip4), dcore(iq), .false.)
ener = oldener
if(scftype .eq. 0) then
call get_moint(i, i, offset, npos, icore(iintpos), 1,
& kappa, .true.)
endif
return
else
call update_trust_radius(trust_rad, grad, ener, oldener,
& rej, kappa, kappa_tr, qscf, alpha, diff, gn, oldgn,
& qscfsize, microit_step)
if(rej) then
call read_data(c, dcore(ifock_ptr), dcore(afock_ptr),
& dcore(igenfock), dcore(rmat_ptr), dcore(p_ptr),
& dcore(ip2), dcore(iq), dcore(ip4), .false.)
ener = oldener
if(scftype .eq. 0) then
call get_moint(i, i, offset, npos, icore(iintpos), 1,
& kappa, .true.)
endif
if(qscf .eq. 'bfgs ') then
write(iout,"(1X,A)")
& 'Quasi-Newton step has been rejected!'
else
write(iout,"(1X,A)")
& 'Augemented Hessian step has been rejected!'
endif
write(iout,"(1x,70('*'))")
else
if(qscf .eq. 'bfgs ') then
write(iout,"(1X,A)")
& 'Quasi-Newton step has been accepted!'
else
write(iout,"(1X,A)")
& 'Augemented Hessian step has been accepted!'
endif
write(iout,"(1X,70('*'))")
endif
endif
return
else
call get_steplen(ener, oldener, enera0, enera1, alpha, alpha0,
& alpha1, alpha2, diff, qscf, microit_step)
call dcopy(qscfsize, oldkappa, 1, kappa, 1)
call read_data(c, c, c, c, c, c, c, c, c, .true.)
call dscal(qscfsize, alpha, kappa, 1)
c call dcopy(sqrsize2, oldc, 1, c, 1)
call trcoef(kappa, c, sqroffset)
call build_dens(c, dcore(p_ptr), sqrsize, sqroffset)
microit_step = microit_step + 1
endif
enddo
end subroutine
************************************************************************
subroutine get_steplen(ener, oldener, enera0, enera1, alpha,
& alpha0, alpha1, alpha2, diff, qscf, microit_step)
************************************************************************
* Calculate new steplength for line search
************************************************************************
implicit none
integer microit_step
double precision ener, oldener, enera0, enera1
double precision alpha, alpha0, alpha1, alpha2, diff
double precision h ! trust radius
character*8 qscf
if(microit_step .eq. 1) then
alpha1 = nsteplen_q(oldener, ener, alpha, diff)
alpha = alpha1
enera0 = ener
elseif(microit_step .eq. 2) then
enera1 = ener
alpha2 = nsteplen_c(oldener, enera0, alpha0, enera1,
& alpha1, diff)
alpha = alpha2
else
enera0 = enera1
enera1 = ener
alpha0 = alpha1
alpha1 = alpha2
alpha2 = nsteplen_c(oldener, enera0, alpha0, enera1,
& alpha1, diff)
alpha = alpha2
endif
end subroutine
************************************************************************
subroutine update_trust_radius(h, grad, ener, oldener, rej, x,
& xtr, qscf, alpha, diff, gn, oldgn, n, microit_step)
************************************************************************
* Trust region update scheme
************************************************************************
implicit none
integer n, microit_step
double precision h, ener, oldener, x(n), xtr(n), grad(n), q, r
double precision gn, oldgn, alpha, diff, relg, rho
character*8 qscf
double precision ddot
logical rej
rej = .false.
select case(qscf)
case('aughess ')
if(ener-oldener .gt. 0.0d0) then
h = 0.7d0*h
rej = .true.
return
endif
q = ddot(n, grad, 1, x, 1 ) + 0.5d0*ddot(n, xtr, 1, x, 1)
r = (ener - oldener)/q
if(r .gt. 0.75d0) then
rej = .false.
h = 1.2d0*h
elseif(r .ge. 0.25d0 .and. r .lt. 0.75d0) then
rej = .false.
elseif(r .lt. 0.25d0 .and. r .ge. 0.0d0) then
rej = .false.
h = 0.7d0*h
elseif(r .lt. 0.0d0) then
h = 0.7d0*h
rej = .true.
endif
case('aughessg')
if(alpha .lt. 1.0d0) then
h = h*alpha
else
rho = calc_ratio(n, diff, x, xtr, ener, oldener)
relg = dabs(gn - oldgn)/oldgn
if(rho .gt. 0.70d0) then
if(relg .lt. 0.10d0) then
h = 2.0d0*h
elseif(relg .lt. 0.20d0) then
h = 1.5d0*h
else
h = 1.2d0*h
endif
elseif(rho .gt. 0.5d0 .and. rho .lt. 0.70d0) then
if(relg .lt. 0.1d0) then
h = 1.7d0*h
elseif(relg .lt. 0.2d0) then
h = 1.2d0*h
endif
elseif(rho .lt. 0.25d0) then
h = 0.7d0*h
endif
endif
case('aughessl')
if(alpha .ne. 1.0d0) call dscal(n, alpha, xtr, 1)
rho = calc_ratio(n, diff, x, xtr, ener, oldener)
if(rho .gt. 0.75d0) then
h = 1.2d0*alpha*h
elseif(rho .lt. 0.25d0) then
h = 0.7d0*alpha*h
endif
case('aughessm')
if(microit_step .ne. 1) then
h = 0.5d0*h
else
if(alpha .ne. 1.0d0) call dscal(n, alpha, xtr, 1)
rho = calc_ratio(n, diff, x, xtr, ener, oldener)
if(rho .gt. 0.75d0) then
h = 2.0d0*h
elseif(rho .lt. 0.75d0 .and. rho .gt. 0.5d0) then
h = 1.2d0*h
elseif(rho .lt. 0.25d0) then
h = 0.7d0*h
endif
endif
end select
end subroutine
************************************************************************
double precision function calc_ratio(n,diff,d,dt,ener,oldener)
************************************************************************
implicit none
integer n
double precision ener, oldener, diff, d(*), dt(*), rho
double precision ddot
if(ener .gt. oldener) then
calc_ratio = -1.0d0
return
endif
calc_ratio = (ener - oldener)/diff + 0.5d0*ddot(n, dt, 1, d, 1)
return
end function
************************************************************************
integer function maxval(a, n)
************************************************************************
* Returns the maximal value in the array A (integer array)
************************************************************************
implicit none
integer n, a(n), i
maxval = a(1)
do i = 2, n
if(a(i) .gt. maxval) maxval = a(i)
enddo
return
end function
************************************************************************
subroutine orbitener(c, eigenvalue, occ_num, eigval2,
& sqroffset, offset, work, lfin, exc, dft, chfx, lwdfn, embed,
& scfdamp, route, nfr, nc, ncorenew, devparr, npos, r8heapsize,
& mapping, nooccfl, clrhfx, csrhfx, omega, pcm, molden)
************************************************************************
* Subroutine to calculate orbital energies and canonial MO coefficients
************************************************************************
use common_mod, only: nir, nfunc, sqrsize, nbasis, scftype, dcore,
& imem, c_ptr, icore, maxcor, p_ptr, symdens_ptr, iintpos,
& symdens2_ptr, symqmat_ptr, symfock_ptr, indexirrep_ptr,
& qmat_ptr, fock_ptr, sorig_ptr, rmat_ptr, orbperir, ndocc,
& nsocc, rs_ptr
implicit none
integer offset(*), sqroffset(*), info, offs
integer extr_c, occ_orb, act_orb, nvirtir, extr_fock
integer r8heapsize, npos, mapping(*)
integer r, ir, i, uhfoffset, k, maxm, j, i1, i2
integer scrfile1, oeintfile
parameter(scrfile1=11, oeintfile=71)
double precision eigenvalue(*), c(*), maxener
double precision occ_num(nbasis), eigval2(nbasis)
double precision work(*), chfx, exc
double precision clrhfx,csrhfx,omega
integer lfin,nfr,nc,ncorenew
double precision devparr(2)
character*4 route,molden
character*16 scfdamp
logical lwdfn, nooccfl
character*32 dft, pcm
character*8 embed
integer imem1
common/memcom/ imem1
integer dblalloc, intalloc
if(scftype .ne. 0 .and. scftype .lt. 3) then
uhfoffset = offset(nir) + nfunc(nir) - 1
c Orbital energies
do r = 0, rmax
do ir = 1, nir
if(nfunc(ir) .eq. 0) cycle
call dsyev('v', 'u', nfunc(ir),
& dcore(igenfock+r*sqrsize+sqroffset(ir)-1),
& nfunc(ir), eigenvalue(r*uhfoffset+offset(ir)),
& dcore(imem), 2*nbasis**2, info)
enddo
enddo
c Canonical MO coefficients
do r = 0, rmax
do ir = 1, nir
if(nfunc(ir) .eq. 0) cycle
call dgemm('n', 'n', nfunc(ir), nfunc(ir), nfunc(ir), 1.0d0,
& c(r*sqrsize+sqroffset(ir)), nfunc(ir),
& dcore(igenfock+r*sqrsize+sqroffset(ir)-1), nfunc(ir),
& 0.0d0, dcore(imem+r*sqrsize+sqroffset(ir)-1),nfunc(ir))
enddo
enddo
call dcopy((rmax+1)*sqrsize, dcore(imem), 1, c, 1)
elseif(scftype .ge. 3) then
maxm=maxcor-(imem-imem1)-nbasis**2
open(unit=562, file=rohf_fock_file, form='unformatted')
read(562) work(1:nbasis**2)
close(562)
C Solve pseudo-eigenvalue equation
call pseig(work(1+nbasis**2),work(1+2*nbasis**2),0.1d0,5,c,
$ work,eigenvalue,r8heapsize,offset,sqroffset,
$ dcore(sorig_ptr),dcore(p_ptr),scrfile1,route)
CALL QSORTD(MAPPING,NBASIS,EIGENVALUE) !SORTING THE EIGENVALUES
if(nooccfl) then
call ifillzero(orbperir,2*nir)
do i=1,ndocc !eigenvalues for the doubly occupied part
orbperir(icore(indexirrep_ptr+mapping(i)-1))=
& orbperir(icore(indexirrep_ptr+mapping(i)-1))+1
enddo
do i=1,nsocc !eigenvalues for the single occupied part
orbperir(icore(indexirrep_ptr+mapping(i+ndocc)-1)+nir)=
& orbperir(icore(indexirrep_ptr+mapping(i+ndocc)-1)+nir)+1
enddo
endif
else
call dfillzero(eigenvalue, nbasis)
call dfillzero(occ_num, nbasis)
maxm=maxcor-(imem-imem1)
do ir = 1, nir
if(orbperir(ir) .ne. 0) then
call dsyev('v', 'u', orbperir(ir),
& dcore(igenfock+sqroffset(ir)-1), nfunc(ir),
& eigenvalue(offset(ir)), dcore(imem), maxm,
& info)
call dgemm('n', 'n', nfunc(ir), orbperir(ir), orbperir(ir),
& 1.0d0, c(sqroffset(ir)), nfunc(ir),
& dcore(igenfock+sqroffset(ir)-1), nfunc(ir), 0.0d0,
& dcore(imem), nfunc(ir))
call dcopy(nfunc(ir)*orbperir(ir), dcore(imem), 1,
& c(sqroffset(ir)), 1)
do k = 1, orbperir(ir)
occ_num(offset(ir)+k-1) = 2.0d0
eigval2(offset(ir)+k-1) = eigenvalue(offset(ir)+k-1)
enddo
endif
if(nactperir(ir) .ne. 0) then
! call dsyev('v', 'u', nactperir(ir),
! & dcore(ip2+(actoffset(ir)-1)*(nact+1)),
! & nact, occ_num(offset(ir)+orbperir(ir)),
! & dcore(imem), maxm, info)
! call dgemm('n', 'n', nfunc(ir), nactperir(ir),nactperir(ir),
! & 1.0d0, c(sqroffset(ir)+orbperir(ir)*nfunc(ir)),
! & nfunc(ir), dcore(ip2+(actoffset(ir)-1)*(nact+1)),
! & nact, 0.0d0, dcore(imem), nfunc(ir))
! call dcopy(nactperir(ir)*nfunc(ir), dcore(imem), 1,
! & c(sqroffset(ir)+orbperir(ir)*nfunc(ir)), 1)
call dsyev('n', 'u', nactperir(ir),
& dcore(igenfock+sqroffset(ir)-1+
& orbperir(ir)*(nfunc(ir)+1)),
& nfunc(ir), eigenvalue(offset(ir)+orbperir(ir)),
& dcore(imem), maxm, info)
do k = 1, nactperir(ir)
eigval2(offset(ir)+orbperir(ir)+k-1) =
& eigenvalue(offset(ir)+orbperir(ir)+k-1)
enddo
endif
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
if(nvirtir .ne. 0) then
!sum up active and inactive fock matrices
offs=sqroffset(ir)-1+
& (orbperir(ir)+nactperir(ir))*(1+nfunc(ir))
do i=1,nvirtir
do j=1,nvirtir
dcore(imem+j-1+(i-1)*nvirtir)=
& 2.0d0*(dcore(ifock_ptr+offs+(j-1)+(i-1)*nfunc(ir))+
& dcore(afock_ptr+offs+(j-1)+(i-1)*nfunc(ir)))
enddo
enddo
call dsyev('v', 'u', nvirtir,
& dcore(imem),nvirtir,
& eigenvalue(offset(ir)+orbperir(ir)+nactperir(ir)),
& dcore(imem+nvirtir**2), maxm-nvirtir**2, info)
call dgemm('n', 'n', nfunc(ir), nvirtir, nvirtir, 1.0d0,
& c(sqroffset(ir)+(orbperir(ir)+nactperir(ir))*nfunc(ir)),
& nfunc(ir), dcore(imem), nvirtir, 0.0d0,
& dcore(imem+nvirtir**2), nfunc(ir))
call dcopy(nfunc(ir)*nvirtir, dcore(imem+nvirtir**2), 1,
& c(sqroffset(ir)+
& (orbperir(ir)+nactperir(ir))*nfunc(ir)), 1)
do k = 1, nvirtir
eigval2(offset(ir)+orbperir(ir)+nactperir(ir)+k-1) =
& eigenvalue(offset(ir)+orbperir(ir)+nactperir(ir)+k-1)
enddo
endif
enddo
call dscal(nbasis, 0.5d0, eigenvalue, 1)
maxener = 0.0d0 ! maximum of occupied orbital energies
do ir = 1, nir
if(orbperir(ir) .ne. 0) then
maxener = eigenvalue(offset(ir))
exit
endif
enddo
do ir = 1, nir
do i = 1, orbperir(ir)
if(maxener .le. eigenvalue(offset(ir)+i-1)) then
maxener = eigenvalue(offset(ir)+i-1)
endif
enddo
enddo
do ir = 1, nir
do i = 1, nactperir(ir)
eigval2(offset(ir)+orbperir(ir)+i-1) =
& maxener + 500.0d0 + eigenvalue(offset(ir)+orbperir(ir)+i-1)
enddo
nvirtir = nfunc(ir) - orbperir(ir) - nactperir(ir)
do i = 1, nvirtir
eigval2(offset(ir)+orbperir(ir)+nactperir(ir)+i-1) =
& maxener + 5000.0d0 +
& eigenvalue(offset(ir)+orbperir(ir)+nactperir(ir)+i-1)
enddo
enddo
endif
end subroutine
************************************************************************
subroutine print_molden_can(temp,c,cpr,symtra,offset,ener,mapping,
& moldenfile,lsa)
************************************************************************
************************************************************************
implicit none
integer ir,i,j,moldenfile
integer mapping(nbasis)
integer offset(nir)
double precision temp(*),symtra(nbasis,nbasis)
double precision ener(nbasis),c(*),cpr(nbasis,nbasis)
logical lsa
open(unit=moldenfile,file='MOLDEN.perm')
read(moldenfile,*) (mapping(i),i=1,nbasis)
close(moldenfile)
call ishell('cp MOLDEN MOLDEN.CAN')
open(moldenfile,file='MOLDEN.CAN',form='formatted',
& position='append')
call moto(cpr,symtra,temp,nbasis,c,offset,lsa)
do ir=1,nir
do i=1,nactperir(ir)
write(moldenfile,"(' Ene=',f14.4)")
$ min(ener(offset(ir)+orbperir(ir)+i-1),1.d7) ! NP
write(moldenfile,"(' Spin= Alpha')")
write(moldenfile,"(' Occup=',f14.4)") 0.0
do j=1,nbasis
write(moldenfile,"(I4,f18.10)")
& j,cpr(mapping(j),offset(ir)+orbperir(ir)+i-1)
enddo
enddo
enddo
close(moldenfile)
end subroutine
************************************************************************
subroutine orbital_energies(eigenvalue, offset, sqroffset, work,
$ r8heapsize, route)
************************************************************************
* Calculates orbital energies for QSCF calculations
************************************************************************
use common_mod, only: scftype, nfunc, sqrsize, dcore,
& imem, nir, nirmax, nbasis, maxcor, rmat_ptr, qmat_ptr,
& sorig_ptr, p_ptr, c_ptr
implicit none
integer offset(nirmax), sqroffset(nirmax), r8heapsize
integer uhfoffset, r, ir, info, offs, maxm, nvirtir, i, j
integer scrfile1
parameter(scrfile1=11)
character*4 route
double precision eigenvalue(nbasis), work(*)
integer imem1
common/memcom/ imem1
if(scftype .ne. 0 .and. scftype .lt. 3) then
maxm=maxcor-(imem-imem1)-nbasis
uhfoffset = offset(nir) + nfunc(nir) - 1
do r = 0, rmax
call dcopy(sqrsize, dcore(igenfock+r*sqrsize), 1, work, 1)
do ir = 1, nir
if(nfunc(ir) .eq. 0) cycle
call dsyev('n', 'u', nfunc(ir), work(sqroffset(ir)),
& nfunc(ir), eigenvalue(r*uhfoffset+offset(ir)),
& dcore(imem+nbasis**2), maxm, info)
enddo
enddo
elseif(scftype .ge. 3) then
maxm=maxcor-(imem-imem1)-nbasis**2
open(unit=562, file=rohf_fock_file, form='unformatted')
read(562) work(1:nbasis**2)
close(562)
C Solve pseudo-eigenvalue equation
call pseig(work(1+2*nbasis**2),work(1+3*nbasis**2),0.1d0,5,
& work(nbasis**2),work,eigenvalue,r8heapsize,offset,
& sqroffset,dcore(sorig_ptr),dcore(p_ptr),scrfile1,route)
endif
end subroutine
************************************************************************
subroutine print_ci_info(occ_num, ndocc, mapping, irlab, mosym,
& offset, sqroffset, c)
************************************************************************
* prints active space occupation and CI coefficients to the screen
************************************************************************
use common_mod, only: iout,maxcor
implicit none
integer mosym(nbasis), offset(*), info, sqroffset(nir)
integer irreps(nact),mo_index(nact),occupation(nact),ord(nact)
integer mapping(nbasis), ndocc, i, ii, ir, k, kk, maxm, j
double precision occ_num(nbasis), c(*)
character*4 irlab(nir)
character*16 tprint
integer imem1
common/memcom/ imem1
maxm=maxcor-(imem-imem1)-nbasis**2
write(iout,*)
call getkey('tprint',6,tprint,16)
if(trim(tprint).ne.'off') then
write(iout,'(A)') ' Reference determinant occupation'
write(iout,'(A)') ' MO Index Irrep Occupation'
kk=0
do ir=1,nirmax
if(nactperir(ir).ne.0) then
do k=1,nactperir(ir)
ii=offset(ir)+orbperir(ir)+k-1
i=1
do while(mapping(i).ne.ii)
i=i+1
enddo
kk=kk+1
irreps(kk)=ir
mo_index(kk)=i
occupation(kk)=icore(irefdet+kk-1)
enddo
endif
enddo
call qsortint(ord,nact,mo_index)
do kk=1,nact
write(iout,'(i5,1x,i5,4xa4,6x,I2)') mo_index(ord(kk)),
& ord(kk),
& irlab(irreps(ord(kk))),occupation(ord(kk))
enddo
write(iout,*)
call getkey('tprint',6,tprint,16)
call ishell(
& "tac ci_output | sed -e '/Dominant/q' | tac | head -n-3")
endif
dcore(ip2:ip2+nact*nact-1)=-dcore(ip2:ip2+nact*nact-1)
do ir=1,nir
if(nactperir(ir).ne.0) then
call dsyev('v', 'u', nactperir(ir),
& dcore(ip2+(actoffset(ir)-1)*(nact+1)),
& nact, occ_num(offset(ir)+orbperir(ir)),
& dcore(imem), maxm, info)
call dgemm('n', 'n', nfunc(ir), nactperir(ir),nactperir(ir),
& 1.0d0, c(sqroffset(ir)+orbperir(ir)*nfunc(ir)),
& nfunc(ir), dcore(ip2+(actoffset(ir)-1)*(nact+1)),
& nact, 0.0d0, dcore(imem), nfunc(ir))
call dcopy(nactperir(ir)*nfunc(ir), dcore(imem), 1,
& c(sqroffset(ir)+orbperir(ir)*nfunc(ir)), 1)
endif
enddo
occ_num=-occ_num
write(iout,*)
write(iout,'(A)') ' Final occupation in active space'
i=0
do ir=1,nir
do k=1,nactperir(ir)
i=i+1
write(iout,'(A,I4)') ' Natural orbital ',i
write(iout,'(A,f8.5)') ' Occupation number: ',
& occ_num(offset(ir)+orbperir(ir)+k-1)
write(iout,'(A)') ' Mixing coefficients: '
write(iout,'(A)') ' MO coefficient '
do j=1,nactperir(ir)
ii=1
do while(mapping(ii).ne.offset(ir)+orbperir(ir)+j-1)
ii=ii+1
enddo
write(iout,'(I4,4x,f12.8)') ii,
& dcore(ip2+(actoffset(ir)-1)*(nact+1)+(k-1)*nact+j-1)
enddo
write(iout,*)
enddo
enddo
end subroutine
************************************************************************
subroutine save_data(c, ifock, afock, genfock, mofock, p, p1,p2,q)
************************************************************************
* Save Fock matrices and MO coefficients to file
************************************************************************
use common_mod, only: sqrsize, sqrsize2, scftype
implicit none
integer i, u
double precision c(sqrsize2)
double precision ifock(sqrsize2), afock(sqrsize2), mofock(sqrsize)
double precision genfock(sqrsize2)
double precision p(sqrsize2), q(*)
double precision p1(nact*nact)
double precision p2(nact**4)
parameter(u = 999)
open(unit=u, file='trust_region_data', form="unformatted")
if(scftype .eq. 0) then
write(u) c(1:sqrsize)
write(u) ifock(1:sqrsize)
write(u) afock(1:sqrsize)
write(u) genfock(1:sqrsize)
write(u) p(1:sqrsize)
write(u) p1(1:nact**2)
write(u) p2(1:nact**4)
write(u) q(1:nbasis*nact)
elseif(scftype .eq. 1 .or. scftype .eq. 2) then
write(u) c(1:sqrsize2)
write(u) ifock(1:sqrsize2)
write(u) p(1:sqrsize2)
elseif(scftype .ge. 3) then
write(u) c(1:sqrsize)
write(u) ifock(1:sqrsize)
write(u) mofock(1:sqrsize)
write(u) p(1:sqrsize2)
write(u) q(1:sqrsize)
endif
close(u)
end subroutine
************************************************************************
subroutine read_data(c, ifock, afock, genfock, mofock, p, p1, p2,
& q, mo_only)
************************************************************************
* Read Fock matrices and MO coefficients from file
************************************************************************
use common_mod, only: sqrsize, sqrsize2, scftype
implicit none
integer u
double precision c(sqrsize2)
double precision ifock(sqrsize2), afock(sqrsize2), mofock(sqrsize)
double precision genfock(sqrsize2)
double precision p(sqrsize2), q(nbasis*nact)
double precision p1(nact*nact)
double precision p2(nact**4)
logical mo_only
parameter(u = 999)
open(unit=u, file='trust_region_data', form="unformatted")
if(scftype .eq. 0) then
read(u) c(1:sqrsize)
if(mo_only) then
close(u)
return
endif
read(u) ifock(1:sqrsize)
read(u) afock(1:sqrsize)
read(u) genfock(1:sqrsize)
read(u) p(1:sqrsize)
read(u) p1(1:nact**2)
read(u) p2(1:nact**4)
read(u) q(1:nbasis*nact)
elseif(scftype .eq. 1 .or. scftype .eq. 2) then
read(u) c(1:sqrsize2)
if(mo_only) then
close(u)
return
endif
read(u) ifock(1:sqrsize2)
read(u) p(1:sqrsize2)
elseif(scftype .ge. 3) then
read(u) c(1:sqrsize)
if(mo_only) then
close(u)
return
endif
read(u) ifock(1:sqrsize)
read(u) mofock(1:sqrsize)
read(u) p(1:sqrsize2)
read(u) q(1:sqrsize)
endif
close(u)
end subroutine
end module
************************************************************************
subroutine tr_index2(g3, c, i, k, i2heap, ninteg, nninteg, nbasis,
& nact)
************************************************************************
* Reads AO integrals and transforms the second index to MO basis (active
* only). The g3 array stores the output in (12|12) format.
************************************************************************
implicit none
integer*2 j, l, ssi(4), i2heap(*)
integer nninteg, ninteg, ir, q, i, k, w
integer nbasis, nact
c double precision g3(nbasis, nbasis, nbasis, nact)
double precision g3(nbasis, nact, nbasis, nbasis)
double precision c(nbasis, nact)
double precision temp
equivalence(temp, ssi)
DO Q=nninteg+1,nninteg+6*NINTEG,6
C GETTING ACTUAL INTEGRALS AND INDICES
ssi(1)=i2heap(q )
ssi(2)=i2heap(q+1)
ssi(3)=i2heap(q+2)
ssi(4)=i2heap(q+3)
j =i2heap(q+4)
l =i2heap(q+5)
if(i.eq.j) temp=0.5d0*temp
if(k.eq.l) temp=0.5d0*temp
if(i.eq.k.and.j.eq.l) temp=0.5d0*temp
do w = 1, nact
c temp = (ij|kl)
g3(i, w, k, l) = g3(i, w, k, l) + temp * c(j, w)
c temp = (ij|lk)
g3(i, w, l, k) = g3(i, w, l, k) + temp * c(j, w)
c temp = (ji|kl)
g3(j, w, k, l) = g3(j, w, k, l) + temp * c(i, w)
c temp = (ji|lk)
g3(j, w, l, k) = g3(j, w, l, k) + temp * c(i, w)
c temp = (kl|ij)
g3(k, w, i, j) = g3(k, w, i, j) + temp * c(l, w)
c temp = (kl|ji)
g3(k, w, j, i) = g3(k, w, j, i) + temp * c(l, w)
c temp = (lk|ij)
g3(l, w, i, j) = g3(l, w, i, j) + temp * c(k, w)
c temp = (lk|ji)
g3(l, w, j, i) = g3(l, w, j, i) + temp * c(k, w)
enddo
enddo
end subroutine
************************************************************************
subroutine tr_index4(g3, c, i, k, i2heap, ninteg, nninteg, nbasis,
& nact)
************************************************************************
* Reads AO integrals and transforms the last index to MO basis (active
* only). The g3 array stores the output in (12|12) format.
************************************************************************
implicit none
integer*2 j, l, ssi(4), i2heap(*)
integer nninteg, ninteg, ir, q, i, k, w
integer nbasis, nact
c double precision g3(nbasis, nbasis, nbasis, nact)
double precision g3(nbasis,nbasis, nbasis, nact)
double precision c(nbasis, nact)
double precision temp
equivalence(temp, ssi)
DO Q=nninteg+1,nninteg+6*NINTEG,6
C GETTING ACTUAL INTEGRALS AND INDICES
ssi(1)=i2heap(q )
ssi(2)=i2heap(q+1)
ssi(3)=i2heap(q+2)
ssi(4)=i2heap(q+3)
j =i2heap(q+4)
l =i2heap(q+5)
if(i.eq.j) temp=0.5d0*temp
if(k.eq.l) temp=0.5d0*temp
if(i.eq.k.and.j.eq.l) temp=0.5d0*temp
do w = 1, nact
c temp = (ij|kl)
g3(i, j, k, w) = g3(i, j, k, w) + temp * c(l, w)
c temp = (ij|lk)
g3(i, j, l, w) = g3(i, j, l, w) + temp * c(k, w)
c temp = (ji|kl)
g3(j, i, k, w) = g3(j, i, k, w) + temp * c(l, w)
c temp = (ji|lk)
g3(j, i, l, w) = g3(j, i, l, w) + temp * c(k, w)
c temp = (kl|ij)
g3(k, l, i, w) = g3(k, l, i, w) + temp * c(j, w)
c temp = (kl|ji)
g3(k, l, j, w) = g3(k, l, j, w) + temp * c(i, w)
c temp = (lk|ij)
g3(l, k, i, w) = g3(l, k, i, w) + temp * c(j, w)
c temp = (lk|ji)
g3(l, k, j, w) = g3(l, k, j, w) + temp * c(i, w)
enddo
enddo
end subroutine
************************************************************************
subroutine df_index1_tr(npos, intpos, teintf, nbl, hai, i4core,
& mo, cpr, dtol)
************************************************************************
************************************************************************
use common_mod, only: nbasis, dfnbasis
use mcscf, only: nact
implicit none
integer nbl, intpos(3, *), teintf(10), npos
integer i, j, k, l, n, kk, ii, ipos
integer*4 i4core(*), ssi(2)
double precision hai(dfnbasis, nbl, nbasis), cpr(nbasis)
double precision mo(nact, nbasis), dtol, pr, ss
equivalence(ss,ssi)
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(k,ii,j)=hai(k,ii,j)+ss*mo(ii,i)
enddo
endif
if(pr*cpr(j).gt.dtol) then
do ii=1,nbl
hai(k,ii,i)=hai(k,ii,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(k,ii,i)=hai(k,ii,i)+ss*mo(ii,i)
enddo
endif
enddo
endif
endif
enddo
end subroutine
************************************************************************
subroutine getm2elems_mcscf(nbasis,i2heap,i,k,ninteg,nninteg,m,
$ p,chfx)
************************************************************************
* Assembling M mtrix from 2-electron integrals for MCSCF calculation
************************************************************************
implicit none
integer*2 i2heap(*),i,j,k,l,ssi(4), ii, kk
integer nbasis,q,ninteg,nninteg, eset, which_case, r
real*8 tmp,chfx,g,x
real*8 m(nbasis,nbasis,2), p(nbasis,nbasis,2)
equivalence(g,ssi)
C
ii = i
kk = k
if(chfx .eq. 1.0d0) then
DO Q=nninteg+1,nninteg+6*NINTEG,6
C GETTING ACTUAL INTEGRALS AND INDICES
i = ii
k = kk
eset = 0
ssi(1)=i2heap(q )
ssi(2)=i2heap(q+1)
ssi(3)=i2heap(q+2)
ssi(4)=i2heap(q+3)
j =i2heap(q+4)
l =i2heap(q+5)
eset = which_case(i, j, k, l)
select case(eset)
case(1) !g=(ij|kl)
do r = 1, 2
tmp = g*p(k, l, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
tmp = -0.25d0*g*p(l, j, r)
m(i, k, r) = m(i, k, r) + tmp
m(k, i, r) = m(k, i, r) + tmp
tmp = -0.25d0*g*p(k, j, r)
m(i, l, r) = m(i, l, r) + tmp
m(l, i, r) = m(l, i, r) + tmp
tmp = -0.25d0*g*p(i, l, r)
m(k, j, r) = m(k, j, r) + tmp
m(j, k, r) = m(j, k, r) + tmp
tmp = -0.25d0*g*p(k, i, r)
m(j, l, r) = m(j, l, r) + tmp
m(l, j, r) = m(l, j, r) + tmp
tmp = g*p(i, j, r)
m(k, l, r) = m(k, l, r) + tmp
m(l, k, r) = m(l, k, r) + tmp
enddo
case(2) !g=(ii|kl)
tmp = -0.25d0*g
do r = 1, 2
m(i, k, r) = m(i, k, r) + tmp*p(i, l, r)
m(k, i, r) = m(k, i, r) + tmp*p(i, l, r)
m(i, l, r) = m(i, l, r) + tmp*p(i, k, r)
m(l, i, r) = m(l, i, r) + tmp*p(i, k, r)
m(k, l, r) = m(k, l, r) + g*p(i, i, r)
m(l, k, r) = m(l, k, r) + g*p(i, i, r)
m(i, i, r) = m(i, i, r) + g*p(l, k, r)
enddo
case(3) !g=(ij|jl)
do r = 1, 2
tmp = 0.75*g*p(l, j, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
tmp = 0.75*g*p(i, j, r)
m(j, l, r) = m(j, l, r) + tmp
m(l, j, r) = m(l, j, r) + tmp
tmp = -0.5d0*g*p(j, j, r)
m(i, l, r) = m(i, l, r) + tmp
m(l, i, r) = m(l, i, r) + tmp
m(j, j, r) = m(j, j, r) - 0.5d0*g*p(i, l, r)
enddo
case(4) !g=(ii|ij)
do r = 1, 2
m(i, i, r) = m(i, i, r) + 0.5d0*g*p(i, j, r)
tmp = 0.5d0*g*p(i, i, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
enddo
case(5) !g=(ii|ii)
do r = 1, 2
m(i, i, r) = m(i, i, r) + 0.5d0*g*p(i, i, r)
enddo
case(6) !g=(ii|jj)
do r = 1, 2
m(i, i, r) = m(i, i, r) + g*p(j, j, r)
m(j, j, r) = m(j, j, r) + g*p(i, i, r)
tmp = -0.25d0*g*p(i, j, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
enddo
case(7) !g=(ij|ij)
do r = 1, 2
tmp = 0.75d0*g*p(i, j, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
tmp = -0.5d0*g
m(i, i, r) = m(i, i, r) + tmp*p(j, j, r)
m(j, j, r) = m(j, j, r) + tmp*p(i, i, r)
enddo
end select
ENDDO
elseif(chfx .ne. 0.0d0) then
DO Q=nninteg+1,nninteg+6*NINTEG,6
C GETTING ACTUAL INTEGRALS AND INDICES
i = ii
k = kk
eset = 0
ssi(1)=i2heap(q )
ssi(2)=i2heap(q+1)
ssi(3)=i2heap(q+2)
ssi(4)=i2heap(q+3)
j =i2heap(q+4)
l =i2heap(q+5)
eset = which_case(i, j, k, l)
select case(eset)
case(1) !g=(ij|kl)
do r = 1, 2
tmp = g*p(k, l, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
tmp = g*p(i, j, r)
m(k, l, r) = m(k, l, r) + tmp
m(l, k, r) = m(l, k, r) + tmp
x = -0.25d0*g*chfx
tmp = x*p(l, j, r)
m(i, k, r) = m(i, k, r) + tmp
m(k, i, r) = m(k, i, r) + tmp
tmp = x*p(k, j, r)
m(i, l, r) = m(i, l, r) + tmp
m(l, i, r) = m(l, i, r) + tmp
tmp = x*p(i, l, r)
m(k, j, r) = m(k, j, r) + tmp
m(j, k, r) = m(j, k, r) + tmp
tmp = x*p(k, i, r)
m(j, l, r) = m(j, l, r) + tmp
m(l, j, r) = m(l, j, r) + tmp
enddo
case(2) !g=(ii|kl)
tmp = -0.25d0*g*chfx
do r = 1, 2
m(i, k, r) = m(i, k, r) + tmp*p(i, l, r)
m(k, i, r) = m(k, i, r) + tmp*p(i, l, r)
m(i, l, r) = m(i, l, r) + tmp*p(i, k, r)
m(l, i, r) = m(l, i, r) + tmp*p(i, k, r)
m(k, l, r) = m(k, l, r) + g*p(i, i, r)
m(l, k, r) = m(l, k, r) + g*p(i, i, r)
m(i, i, r) = m(i, i, r) + g*p(l, k, r)
enddo
case(3) !g=(ij|jl)
do r = 1, 2
tmp = (1.0d0 - 0.25d0*chfx)*g*p(l, j, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
tmp = (1.0d0 - 0.25d0*chfx)*g*p(i, j, r)
m(j, l, r) = m(j, l, r) + tmp
m(l, j, r) = m(l, j, r) + tmp
tmp = -0.5d0*g*chfx*p(j, j, r)
m(i, l, r) = m(i, l, r) + tmp
m(l, i, r) = m(l, i, r) + tmp
m(j, j, r) = m(j, j, r) - 0.5d0*g*chfx*p(i, l, r)
enddo
case(4) !g=(ii|ij)
do r = 1, 2
x = (1.0d0 - 0.5d0*chfx)*g
m(i, i, r) = m(i, i, r) + x*p(i, j, r)
tmp = x*p(i, i, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
enddo
case(5) !g=(ii|ii)
do r = 1, 2
m(i, i, r) = m(i, i, r) +
& (1.0d0 - 0.5d0*chfx)*g*p(i, i, r)
enddo
case(6) !g=(ii|jj)
do r = 1, 2
m(i, i, r) = m(i, i, r) + g*p(j, j, r)
m(j, j, r) = m(j, j, r) + g*p(i, i, r)
tmp = -0.25d0*chfx*g*p(i, j, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
enddo
case(7) !g=(ij|ij)
do r = 1, 2
tmp = (1.0d0 - 0.25d0*chfx)*g*p(i, j, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
tmp = -0.5d0*chfx*g
m(i, i, r) = m(i, i, r) + tmp*p(j, j, r)
m(j, j, r) = m(j, j, r) + tmp*p(i, i, r)
enddo
end select
ENDDO
elseif(chfx .eq. 0.0d0) then
DO Q=nninteg+1,nninteg+6*NINTEG,6
C GETTING ACTUAL INTEGRALS AND INDICES
i = ii
k = kk
eset = 0
ssi(1)=i2heap(q )
ssi(2)=i2heap(q+1)
ssi(3)=i2heap(q+2)
ssi(4)=i2heap(q+3)
j =i2heap(q+4)
l =i2heap(q+5)
eset = which_case(i, j, k, l)
select case(eset)
case(1) !g=(ij|kl)
do r = 1, 2
tmp = g*p(k, l, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
tmp = g*p(i, j, r)
m(k, l, r) = m(k, l, r) + tmp
m(l, k, r) = m(l, k, r) + tmp
enddo
case(2) !g=(ii|kl)
do r = 1, 2
m(k, l, r) = m(k, l, r) + g*p(i, i, r)
m(l, k, r) = m(l, k, r) + g*p(i, i, r)
m(i, i, r) = m(i, i, r) + g*p(l, k, r)
enddo
case(3) !g=(ij|jl)
do r = 1, 2
tmp = g*p(l, j, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
tmp = g*p(i, j, r)
m(j, l, r) = m(j, l, r) + tmp
m(l, j, r) = m(l, j, r) + tmp
enddo
case(4) !g=(ii|ij)
do r = 1, 2
m(i, i, r) = m(i, i, r) + g*p(i, j, r)
tmp = g*p(i, i, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
enddo
case(5) !g=(ii|ii)
do r = 1, 2
m(i, i, r) = m(i, i, r) + 1.0d0*g*p(i, i, r)
enddo
case(6) !g=(ii|jj)
do r = 1, 2
m(i, i, r) = m(i, i, r) + g*p(j, j, r)
m(j, j, r) = m(j, j, r) + g*p(i, i, r)
enddo
case(7) !g=(ij|ij)
do r = 1, 2
tmp = g*p(i, j, r)
m(i, j, r) = m(i, j, r) + tmp
m(j, i, r) = m(j, i, r) + tmp
enddo
end select
ENDDO
endif
C
return
end
************************************************************************
subroutine getm2elems_rhf(nbasis,i2heap,i,k,ninteg,nninteg,m,p,
$ chfx)
************************************************************************
* Assembling M mtrix from 2-electron integrals for RHF calculation
************************************************************************
implicit none
integer*2 i2heap(*),i,j,k,l,ssi(4), ii, kk
integer nbasis,q,ninteg,nninteg, eset, which_case
real*8 tmp,chfx, m(nbasis, *), g, p(nbasis, *), x
equivalence(g,ssi)
C
ii = i
kk = k
if(chfx .eq. 1.0d0) then
DO Q=nninteg+1,nninteg+6*NINTEG,6
c write(*,*) 'q', q
C GETTING ACTUAL INTEGRALS AND INDICES
i = ii
k = kk
eset = 0
ssi(1)=i2heap(q )
ssi(2)=i2heap(q+1)
ssi(3)=i2heap(q+2)
ssi(4)=i2heap(q+3)
j =i2heap(q+4)
l =i2heap(q+5)
eset = which_case(i, j, k, l)
select case(eset)
case(1) !g=(ij|kl)
tmp = g*p(k, l)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
tmp = -0.25d0*g*p(l, j)
m(i, k) = m(i, k) + tmp
m(k, i) = m(k, i) + tmp
tmp = -0.25d0*g*p(k, j)
m(i, l) = m(i, l) + tmp
m(l, i) = m(l, i) + tmp
tmp = -0.25d0*g*p(i, l)
m(k, j) = m(k, j) + tmp
m(j, k) = m(j, k) + tmp
tmp = -0.25d0*g*p(k, i)
m(j, l) = m(j, l) + tmp
m(l, j) = m(l, j) + tmp
tmp = g*p(i, j)
m(k, l) = m(k, l) + tmp
m(l, k) = m(l, k) + tmp
case(2) !g=(ii|kl)
tmp = -0.25d0*g
m(i, k) = m(i, k) + tmp*p(i, l)
m(k, i) = m(k, i) + tmp*p(i, l)
m(i, l) = m(i, l) + tmp*p(i, k)
m(l, i) = m(l, i) + tmp*p(i, k)
m(k, l) = m(k, l) + g*p(i, i)
m(l, k) = m(l, k) + g*p(i, i)
m(i, i) = m(i, i) + g*p(l, k)
case(3) !g=(ij|jl)
tmp = 0.75*g*p(l, j)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
tmp = 0.75*g*p(i, j)
m(j, l) = m(j, l) + tmp
m(l, j) = m(l, j) + tmp
tmp = -0.5d0*g*p(j, j)
m(i, l) = m(i, l) + tmp
m(l, i) = m(l, i) + tmp
m(j, j) = m(j, j) - 0.5d0*g*p(i, l)
case(4) !g=(ii|ij)
m(i, i) = m(i, i) + 0.5d0*g*p(i, j)
tmp = 0.5d0*g*p(i, i)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
case(5) !g=(ii|ii)
m(i, i) = m(i, i) + 0.5d0*g*p(i, i)
case(6) !g=(ii|jj)
m(i, i) = m(i, i) + g*p(j, j)
m(j, j) = m(j, j) + g*p(i, i)
tmp = -0.25d0*g*p(i, j)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
case(7) !g=(ij|ij)
tmp = 0.75d0*g*p(i, j)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
tmp = -0.5d0*g
m(i, i) = m(i, i) + tmp*p(j, j)
m(j, j) = m(j, j) + tmp*p(i, i)
end select
ENDDO
elseif(chfx .ne. 0.0d0) then
DO Q=nninteg+1,nninteg+6*NINTEG,6
C GETTING ACTUAL INTEGRALS AND INDICES
i = ii
k = kk
eset = 0
ssi(1)=i2heap(q )
ssi(2)=i2heap(q+1)
ssi(3)=i2heap(q+2)
ssi(4)=i2heap(q+3)
j =i2heap(q+4)
l =i2heap(q+5)
eset = which_case(i, j, k, l)
select case(eset)
case(1) !g=(ij|kl)
tmp = g*p(k, l)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
tmp = g*p(i, j)
m(k, l) = m(k, l) + tmp
m(l, k) = m(l, k) + tmp
x = -0.25d0*g*chfx
tmp = x*p(l, j)
m(i, k) = m(i, k) + tmp
m(k, i) = m(k, i) + tmp
tmp = x*p(k, j)
m(i, l) = m(i, l) + tmp
m(l, i) = m(l, i) + tmp
tmp = x*p(i, l)
m(k, j) = m(k, j) + tmp
m(j, k) = m(j, k) + tmp
tmp = x*p(k, i)
m(j, l) = m(j, l) + tmp
m(l, j) = m(l, j) + tmp
case(2) !g=(ii|kl)
tmp = -0.25d0*g*chfx
m(i, k) = m(i, k) + tmp*p(i, l)
m(k, i) = m(k, i) + tmp*p(i, l)
m(i, l) = m(i, l) + tmp*p(i, k)
m(l, i) = m(l, i) + tmp*p(i, k)
m(k, l) = m(k, l) + g*p(i, i)
m(l, k) = m(l, k) + g*p(i, i)
m(i, i) = m(i, i) + g*p(l, k)
case(3) !g=(ij|jl)
tmp = (1.0d0 - 0.25d0*chfx)*g*p(l, j)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
tmp = (1.0d0 - 0.25d0*chfx)*g*p(i, j)
m(j, l) = m(j, l) + tmp
m(l, j) = m(l, j) + tmp
tmp = -0.5d0*g*chfx*p(j, j)
m(i, l) = m(i, l) + tmp
m(l, i) = m(l, i) + tmp
m(j, j) = m(j, j) - 0.5d0*g*chfx*p(i, l)
case(4) !g=(ii|ij)
x = (1.0d0 - 0.5d0*chfx)*g
m(i, i) = m(i, i) + x*p(i, j)
tmp = x*p(i, i)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
case(5) !g=(ii|ii)
m(i, i) = m(i, i) + (1.0d0 - 0.5d0*chfx)*g*p(i, i)
case(6) !g=(ii|jj)
m(i, i) = m(i, i) + g*p(j, j)
m(j, j) = m(j, j) + g*p(i, i)
tmp = -0.25d0*chfx*g*p(i, j)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
case(7) !g=(ij|ij)
tmp = (1.0d0 - 0.25d0*chfx)*g*p(i, j)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
tmp = -0.5d0*chfx*g
m(i, i) = m(i, i) + tmp*p(j, j)
m(j, j) = m(j, j) + tmp*p(i, i)
end select
ENDDO
elseif(chfx .eq. 0.0d0) then
DO Q=nninteg+1,nninteg+6*NINTEG,6
C GETTING ACTUAL INTEGRALS AND INDICES
i = ii
k = kk
eset = 0
ssi(1)=i2heap(q )
ssi(2)=i2heap(q+1)
ssi(3)=i2heap(q+2)
ssi(4)=i2heap(q+3)
j =i2heap(q+4)
l =i2heap(q+5)
eset = which_case(i, j, k, l)
select case(eset)
case(1) !g=(ij|kl)
tmp = g*p(k, l)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
tmp = g*p(i, j)
m(k, l) = m(k, l) + tmp
m(l, k) = m(l, k) + tmp
case(2) !g=(ii|kl)
m(k, l) = m(k, l) + g*p(i, i)
m(l, k) = m(l, k) + g*p(i, i)
m(i, i) = m(i, i) + g*p(l, k)
case(3) !g=(ij|jl)
tmp = g*p(l, j)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
tmp = g*p(i, j)
m(j, l) = m(j, l) + tmp
m(l, j) = m(l, j) + tmp
case(4) !g=(ii|ij)
m(i, i) = m(i, i) + g*p(i, j)
tmp = g*p(i, i)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
case(5) !g=(ii|ii)
m(i, i) = m(i, i) + 1.0d0*g*p(i, i)
case(6) !g=(ii|jj)
m(i, i) = m(i, i) + g*p(j, j)
m(j, j) = m(j, j) + g*p(i, i)
case(7) !g=(ij|ij)
tmp = g*p(i, j)
m(i, j) = m(i, j) + tmp
m(j, i) = m(j, i) + tmp
end select
ENDDO
endif
C
return
end
************************************************************************
subroutine getm2elems_uhf(nbasis,i2heap,i,k,ninteg,nninteg,
& ma, mb, pa, pb, chfx)
************************************************************************
* Assembling M mtrix from 2-electron integrals for UHF calculation
************************************************************************
implicit none
integer*2 i2heap(*),i,j,k,l,ssi(4), ii, kk
integer nbasis,q,ninteg,nninteg, eset, which_case
real*8 tmp,chfx, ma(nbasis, *),mb(nbasis, *), g, pa(nbasis, *)
double precision pb(nbasis, *)
equivalence(g,ssi)
C
ii = i
kk = k
if(chfx .eq. 1.0d0) then
DO Q=nninteg+1,nninteg+6*NINTEG,6
C GETTING ACTUAL INTEGRALS AND INDICES
i = ii
k = kk
eset = 0
ssi(1)=i2heap(q )
ssi(2)=i2heap(q+1)
ssi(3)=i2heap(q+2)
ssi(4)=i2heap(q+3)
j =i2heap(q+4)
l =i2heap(q+5)
eset = which_case(i, j, k, l)
select case(eset)
case(1)
tmp = g*(pa(k, l) + pb(k, l))
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
tmp = g*(pa(i, j) + pb(i, j))
ma(k, l) = ma(k, l) + tmp
ma(l, k) = ma(l, k) + tmp
mb(k, l) = mb(k, l) + tmp
mb(l, k) = mb(l, k) + tmp
tmp = -0.5d0*g*pa(l, j)
ma(i, k) = ma(i, k) + tmp
ma(k, i) = ma(k, i) + tmp
tmp = -0.5d0*g*pb(l, j)
mb(i, k) = mb(i, k) + tmp
mb(k, i) = mb(k, i) + tmp
tmp = -0.5d0*g*pa(k, j)
ma(i, l) = ma(i, l) + tmp
ma(l, i) = ma(l, i) + tmp
tmp = -0.5d0*g*pb(k, j)
mb(i, l) = mb(i, l) + tmp
mb(l, i) = mb(l, i) + tmp
tmp = -0.5d0*g*pa(i, l)
ma(k, j) = ma(k, j) + tmp
ma(j, k) = ma(j, k) + tmp
tmp = -0.5d0*g*pb(i, l)
mb(k, j) = mb(k, j) + tmp
mb(j, k) = mb(j, k) + tmp
tmp = -0.5d0*g*pa(k, i)
ma(j, l) = ma(j, l) + tmp
ma(l, j) = ma(l, j) + tmp
tmp = -0.5d0*g*pb(k, i)
mb(j, l) = mb(j, l) + tmp
mb(l, j) = mb(l, j) + tmp
case(2)
tmp = g*(pa(i, i) + pb(i, i))
ma(k, l) = ma(k, l) + tmp
ma(l, k) = ma(l, k) + tmp
mb(k, l) = mb(k, l) + tmp
mb(l, k) = mb(l, k) + tmp
tmp = g*(pa(l, k) + pb(l, k))
ma(i, i) = ma(i, i) + tmp
mb(i, i) = mb(i, i) + tmp
tmp = -0.5d0*g
ma(i, k) = ma(i, k) + tmp*pa(i, l)
ma(k, i) = ma(k, i) + tmp*pa(i, l)
ma(i, l) = ma(i, l) + tmp*pa(i, k)
ma(l, i) = ma(l, i) + tmp*pa(i, k)
mb(i, k) = mb(i, k) + tmp*pb(i, l)
mb(k, i) = mb(k, i) + tmp*pb(i, l)
mb(i, l) = mb(i, l) + tmp*pb(i, k)
mb(l, i) = mb(l, i) + tmp*pb(i, k)
case(3)
tmp = g*(pa(l, j) + 0.5d0*pb(l, j))
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
tmp = g*(0.5d0*pa(l, j) + pb(l, j))
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
tmp = g*(pa(i, j) + 0.5d0*pb(i, j))
mb(j, l) = mb(j, l) + tmp
mb(l, j) = mb(l, j) + tmp
tmp = g*(0.5d0*pa(i, j) + pb(i, j))
ma(j, l) = ma(j, l) + tmp
ma(l, j) = ma(l, j) + tmp
tmp = -g*pa(j, j)
ma(i, l) = ma(i, l) + tmp
ma(l, i) = ma(l, i) + tmp
tmp = -g*pb(j, j)
mb(i, l) = mb(i, l) + tmp
mb(l, i) = mb(l, i) + tmp
ma(j, j) = ma(j, j) - g*pa(i, l)
mb(j, j) = mb(j, j) - g*pb(i, l)
case(4)
mb(i, i) = mb(i, i) + g*pa(i, j)
ma(i, i) = ma(i, i) + g*pb(i, j)
tmp = g*pa(i, i)
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
tmp = g*pb(i, i)
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
case(5)
mb(i, i) = mb(i, i) + g*pa(i, i)
ma(i, i) = ma(i, i) + g*pb(i, i)
case(6)
tmp = g*(pa(j, j) + pb(j, j))
ma(i, i) = ma(i, i) + tmp
mb(i, i) = mb(i, i) + tmp
tmp = g*(pa(i, i) + pb(i, i))
ma(j, j) = ma(j, j) + tmp
mb(j, j) = mb(j, j) + tmp
tmp = -0.5d0*g*pb(i, j)
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
tmp = -0.5d0*g*pa(i, j)
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
case(7)
tmp = g*(0.5d0*pa(i, j) + pb(i, j))
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
tmp = g*(0.5d0*pb(i, j) + pa(i, j))
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
mb(i, i) = mb(i, i) - g*pb(j, j)
mb(j, j) = mb(j, j) - g*pb(i, i)
ma(i, i) = ma(i, i) - g*pa(j, j)
ma(j, j) = ma(j, j) - g*pa(i, i)
case default
continue
end select
ENDDO
elseif(chfx .eq. 0.0d0) then
DO Q=nninteg+1,nninteg+6*NINTEG,6
C GETTING ACTUAL INTEGRALS AND INDICES
i = ii
k = kk
eset = 0
ssi(1)=i2heap(q )
ssi(2)=i2heap(q+1)
ssi(3)=i2heap(q+2)
ssi(4)=i2heap(q+3)
j =i2heap(q+4)
l =i2heap(q+5)
eset = which_case(i, j, k, l)
select case(eset)
case(1)
tmp = g*(pa(k, l) + pb(k, l))
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
tmp = g*(pa(i, j) + pb(i, j))
ma(k, l) = ma(k, l) + tmp
ma(l, k) = ma(l, k) + tmp
mb(k, l) = mb(k, l) + tmp
mb(l, k) = mb(l, k) + tmp
case(2)
tmp = g*(pa(i, i) + pb(i, i))
ma(k, l) = ma(k, l) + tmp
ma(l, k) = ma(l, k) + tmp
mb(k, l) = mb(k, l) + tmp
mb(l, k) = mb(l, k) + tmp
tmp = g*(pa(l, k) + pb(l, k))
ma(i, i) = ma(i, i) + tmp
mb(i, i) = mb(i, i) + tmp
case(3)
tmp = g*(pa(l, j) + pb(l, j))
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
tmp = g*(pa(l, j) + pb(l, j))
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
tmp = g*(pa(i, j) + pb(i, j))
mb(j, l) = mb(j, l) + tmp
mb(l, j) = mb(l, j) + tmp
tmp = g*(pa(i, j) + pb(i, j))
ma(j, l) = ma(j, l) + tmp
ma(l, j) = ma(l, j) + tmp
case(4)
tmp = g*(pa(i, j) + pb(i, j))
mb(i, i) = mb(i, i) + tmp
ma(i, i) = ma(i, i) + tmp
tmp = g*(pb(i, i) + pa(i, i))
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
case(5)
tmp = g*(pa(i, i) + pb(i, i))
mb(i, i) = mb(i, i) + tmp
ma(i, i) = ma(i, i) + tmp
case(6)
tmp = g*(pa(j, j) + pb(j, j))
ma(i, i) = ma(i, i) + tmp
mb(i, i) = mb(i, i) + tmp
tmp = g*(pa(i, i) + pb(i, i))
ma(j, j) = ma(j, j) + tmp
mb(j, j) = mb(j, j) + tmp
case(7)
tmp = g*(pa(i, j) + pb(i, j))
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
tmp = g*(pb(i, j) + pa(i, j))
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
case default
continue
end select
ENDDO
elseif(chfx .ne. 0.0d0 .and. chfx .ne. 1.0d0) then
DO Q=nninteg+1,nninteg+6*NINTEG,6
C GETTING ACTUAL INTEGRALS AND INDICES
i = ii
k = kk
eset = 0
ssi(1)=i2heap(q )
ssi(2)=i2heap(q+1)
ssi(3)=i2heap(q+2)
ssi(4)=i2heap(q+3)
j =i2heap(q+4)
l =i2heap(q+5)
eset = which_case(i, j, k, l)
select case(eset)
case(1)
tmp = g*(pa(k, l) + pb(k, l))
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
tmp = g*(pa(i, j) + pb(i, j))
ma(k, l) = ma(k, l) + tmp
ma(l, k) = ma(l, k) + tmp
mb(k, l) = mb(k, l) + tmp
mb(l, k) = mb(l, k) + tmp
tmp = -0.5d0*chfx*g*pa(l, j)
ma(i, k) = ma(i, k) + tmp
ma(k, i) = ma(k, i) + tmp
tmp = -0.5d0*chfx*g*pb(l, j)
mb(i, k) = mb(i, k) + tmp
mb(k, i) = mb(k, i) + tmp
tmp = -0.5d0*chfx*g*pa(k, j)
ma(i, l) = ma(i, l) + tmp
ma(l, i) = ma(l, i) + tmp
tmp = -0.5d0*chfx*g*pb(k, j)
mb(i, l) = mb(i, l) + tmp
mb(l, i) = mb(l, i) + tmp
tmp = -0.5d0*chfx*g*pa(i, l)
ma(k, j) = ma(k, j) + tmp
ma(j, k) = ma(j, k) + tmp
tmp = -0.5d0*chfx*g*pb(i, l)
mb(k, j) = mb(k, j) + tmp
mb(j, k) = mb(j, k) + tmp
tmp = -0.5d0*chfx*g*pa(k, i)
ma(j, l) = ma(j, l) + tmp
ma(l, j) = ma(l, j) + tmp
tmp = -0.5d0*chfx*g*pb(k, i)
mb(j, l) = mb(j, l) + tmp
mb(l, j) = mb(l, j) + tmp
case(2)
tmp = g*(pa(i, i) + pb(i, i))
ma(k, l) = ma(k, l) + tmp
ma(l, k) = ma(l, k) + tmp
mb(k, l) = mb(k, l) + tmp
mb(l, k) = mb(l, k) + tmp
tmp = g*(pa(l, k) + pb(l, k))
ma(i, i) = ma(i, i) + tmp
mb(i, i) = mb(i, i) + tmp
tmp = -0.5d0*chfx*g
ma(i, k) = ma(i, k) + tmp*pa(i, l)
ma(k, i) = ma(k, i) + tmp*pa(i, l)
ma(i, l) = ma(i, l) + tmp*pa(i, k)
ma(l, i) = ma(l, i) + tmp*pa(i, k)
mb(i, k) = mb(i, k) + tmp*pb(i, l)
mb(k, i) = mb(k, i) + tmp*pb(i, l)
mb(i, l) = mb(i, l) + tmp*pb(i, k)
mb(l, i) = mb(l, i) + tmp*pb(i, k)
case(3)
tmp = g*(pa(l, j) + (1.0d0 - 0.5d0*chfx)*pb(l, j))
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
tmp = g*((1.0d0 - 0.5d0*chfx)*pa(l, j) + pb(l, j))
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
tmp = g*(pa(i, j) + (1.0d0 - 0.5d0*chfx)*pb(i, j))
mb(j, l) = mb(j, l) + tmp
mb(l, j) = mb(l, j) + tmp
tmp = g*((1.0d0 - 0.5d0*chfx)*pa(i, j) + pb(i, j))
ma(j, l) = ma(j, l) + tmp
ma(l, j) = ma(l, j) + tmp
tmp = -chfx*g*pa(j, j)
ma(i, l) = ma(i, l) + tmp
ma(l, i) = ma(l, i) + tmp
tmp = -chfx*g*pb(j, j)
mb(i, l) = mb(i, l) + tmp
mb(l, i) = mb(l, i) + tmp
ma(j, j) = ma(j, j) - chfx*g*pa(i, l)
mb(j, j) = mb(j, j) - chfx*g*pb(i, l)
case(4)
tmp = g*(pa(i, j) + pb(i, j))
mb(i, i) = mb(i, i) + tmp - chfx*g*pb(i, j)
ma(i, i) = ma(i, i) + tmp - chfx*g*pa(i, j)
tmp = g*(pa(i, i) + pb(i, i)) - chfx*g*pb(i, i)
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
tmp = g*(pb(i, i) + pa(i, i)) - chfx*g*pa(i, i)
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
case(5)
tmp = g*(pa(i, i) + pb(i, i))
mb(i, i) = mb(i, i) + tmp - chfx*g*pb(i, i)
ma(i, i) = ma(i, i) + tmp - chfx*g*pa(i, i)
case(6)
tmp = g*(pa(j, j) + pb(j, j))
ma(i, i) = ma(i, i) + tmp
mb(i, i) = mb(i, i) + tmp
tmp = g*(pa(i, i) + pb(i, i))
ma(j, j) = ma(j, j) + tmp
mb(j, j) = mb(j, j) + tmp
tmp = -0.5d0*chfx*g*pb(i, j)
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
tmp = -0.5d0*chfx*g*pa(i, j)
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
case(7)
tmp = g*((1.0d0 - 0.5d0*chfx)*pa(i, j) + pb(i, j))
ma(i, j) = ma(i, j) + tmp
ma(j, i) = ma(j, i) + tmp
tmp = g*((1.0d0 - 0.5d0*chfx)*pb(i, j) + pa(i, j))
mb(i, j) = mb(i, j) + tmp
mb(j, i) = mb(j, i) + tmp
tmp = -chfx*g
mb(i, i) = mb(i, i) + tmp*pb(j, j)
mb(j, j) = mb(j, j) + tmp*pb(i, i)
ma(i, i) = ma(i, i) + tmp*pa(j, j)
ma(j, j) = ma(j, j) + tmp*pa(i, i)
case default
continue
end select
ENDDO
endif
C
return
end
************************************************************************
integer function which_case(i, j, k, l) result(eset)
************************************************************************
* Selecting case form M matrix construction (see above)
************************************************************************
implicit none
integer*2 i, j, k, l
if(i .eq. j) then
if(k .eq. l) then
if(i .eq. k) then
eset = 5
else
j = k
eset = 6
endif
else
if(i .eq. k) then
j = l
eset = 4
else
if(i .eq. l) then
j = k
eset = 4
else
eset = 2
endif
endif
endif
else
if(k .eq. l) then
if(i .eq. k) then
eset = 4
else
if(j .eq. k) then
j = i
i = k
eset = 4
else
eset = 2
k = i
i = l
l = j
endif
endif
else
if(i .eq. k) then
if(j .eq. l) then
eset = 7
else
i = j
j = k
eset = 3
endif
else
if(i .eq. l) then
if(j .eq. k) then
eset = 7
else
i = j
j = l
l = k
eset = 3
endif
else
if(j .eq. k) then
eset = 3
else
if(j .eq. l) then
l = k
eset = 3
else
eset = 1
endif
endif
endif
endif
endif
endif
return
end
************************************************************************
subroutine prmx(a, lda, n, m)
************************************************************************
************************************************************************
use common_mod, only: iout
implicit none
integer n, m, lda, i, j
double precision a(lda,*)
do i = 1, n
do j = 1, m
write(iout,'(ES12.5E2 A)', advance='no') a(i, j), ' '
enddo
write(iout,*)
c write(*,*) ';'
enddo
end
Reference in New Issue View Git Blame Copy Permalink