c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine piscf  --  scf molecular orbital calculation  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "piscf" performs an scf molecular orbital calculation for
c     the pisystem using a modified Pariser-Parr-Pople method
c
c
      subroutine piscf
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'pibond.i'
      include 'picalc.i'
      include 'pistuf.i'
      include 'units.i'
      integer i,j,k,m,iter,maxiter
      integer iatn,jatn,iorb,jorb
      real*8 f(maxpi,maxpi),hc(maxpi,maxpi)
      real*8 v(maxpi,maxpi),en(maxpi),ip(maxpi)
      real*8 gamma(maxpi,maxpi),ed(maxpi,maxpi)
      real*8 work1(maxpi),work2(maxpi)
      real*8 delta,converge,p,xij,yij,zij
      real*8 hcii,gii,gij,g11,g11sq,g12,g14
      real*8 povlap(maxpib),rij,erij,brij
      real*8 ovlap,covlap,ioniz_i,ioniz_j,cionize
      real*8 rijsq,hcij,qi,total,totold,ebeta
      real*8 aeth,abnz,ebe,ebb,ble,blb,eebond,bebond
      real*8 s1,s2,gjk,vij,vik,vmj,vmk,xi,xj,xk,xg
      character*6 mode
      logical initial
      save f,initial
      data initial  / .true. /
c
c
c     only needs to be done if pisystem is present
c
      if (norbit .eq. 0)  return
c
c     initialize some constants and parameters:
c
c     mode      planar or nonplanar pi-calculation
c     maxiter   maximum number of scf iterations
c     converge  criterion for scf convergence
c     ebeta     value of resonance integral for ethylene
c     cionize   ionizaton potential of carbon (hartree)
c
      mode = 'Planar'
      maxiter = 50
      converge = 0.00000001d0
      ebeta = -0.0757d0
      cionize = -11.16d0 / evolt
c
c     set the bond energies, alpha values and ideal bond length
c     parameter for carbon-carbon pibond type parameters:
c
c     ebe = equilibrium bond energy in ethylene
c     ebb = equilibrium bond energy in benzene
c     aeth = the P-P-P constant "a" in ethylene
c     abnz = the P-P-P constant "a" in benzene
c     ble = equilibrium bond length in ethylene
c     blb = equilibrium bond length in benzene
c
      ebe = 129.37d0
      ebb = 117.58d0
      aeth = 2.309d0
      abnz = 2.142d0
      ble = 1.338d0
      blb = 1.397d0
c
c     assign empirical one-center Coulomb integrals, and
c     first or second ionization potential depending on
c     whether the orbital contributes one or two electrons
c
      do i = 1, norbit
         gamma(i,i) = em(i)
         ip(i) = w(i) + (1.0d0-q(i))*em(i)
      end do
c
c     calculate two-center repulsion integrals
c     according to Ohno's semi-empirical formula
c
      do i = 1, norbit-1
         iorb = iorbit(i)
         gii = gamma(i,i)
         do j = i+1, norbit
            jorb = iorbit(j)
            g11 = 0.5d0 * (gii+gamma(j,j))
            g11sq = 1.0d0 / g11**2
            xij = x(iorb) - x(jorb)
            yij = y(iorb) - y(jorb)
            zij = z(iorb) - z(jorb)
            rijsq = (xij**2 + yij**2 + zij**2) / bohr**2
            g12 = 1.0d0 / sqrt(rijsq+g11sq)
            gamma(i,j) = g12
            gamma(j,i) = g12
         end do
      end do
c
c     zero out the resonance integral values
c
      do i = 1, norbit
         do j = 1, norbit
            hc(j,i) = 0.0d0
         end do
      end do
c
c     the first term in the sum to find alpha is the first
c     or second ionization potential, then the two-center
c     repulsion integrals are added
c
      do i = 1, norbit
         hcii = ip(i)
         do j = 1, norbit
            if (i .ne. j) then
               hcii = hcii - q(j)*gamma(i,j)
            end if
         end do
         hc(i,i) = hcii
      end do
c
c     get two-center repulsion integrals via Ohno's formula
c
      do k = 1, npibond
         i = pibond(2,k)
         j = pibond(3,k)
         iorb = iorbit(i)
         jorb = iorbit(j)
         iatn = atomic(iorb)
         jatn = atomic(jorb)
         xij = x(iorb) - x(jorb)
         yij = y(iorb) - y(jorb)
         zij = z(iorb) - z(jorb)
         rij = sqrt(xij**2 + yij**2 + zij**2)
         rijsq = rij**2 / bohr**2
         g11 = 0.5d0 * (gamma(i,i)+gamma(j,j))
         g11sq = 1.0d0 / g11**2
         g12 = gamma(i,j)
c
c     compute the bond energy using a Morse potential
c
         erij = aeth * (ble-rij)
         brij = abnz * (blb-rij)
         eebond = (2.0d0*exp(erij)-exp(2.0d0*erij)) * ebe / hartree
         bebond = (2.0d0*exp(brij)-exp(2.0d0*brij)) * ebb / hartree
c
c     compute the carbon-carbon resonance integral using
c     the Whitehead and Lo formula
c
         g14 = 1.0d0 / sqrt(4.0d0*rijsq+g11sq)
         hcij = 1.5d0*(bebond-eebond) - 0.375d0*g11
     &             + (5.0d0/12.0d0)*g12 - g14/24.0d0
c
c     if either atom is non-carbon, then factor the resonance
c     integral by overlap ratio and ionization potential ratio
c
         if (iatn.ne.6 .or. jatn.ne.6) then
            call overlap (iatn,jatn,rij,ovlap)
            call overlap (6,6,rij,covlap)
            hcij = hcij * (ovlap/covlap)
            ioniz_i = ip(i)
            if (q(i) .ne. 1.0d0) then
               if (iatn .eq. 7)  ioniz_i = 0.595d0 * ioniz_i
               if (iatn .eq. 8)  ioniz_i = 0.525d0 * ioniz_i
               if (iatn .eq. 16)  ioniz_i = 0.89d0 * ioniz_i
            end if
            ioniz_j = ip(j)
            if (q(j) .ne. 1.0d0) then
               if (jatn .eq. 7)  ioniz_j = 0.595d0 * ioniz_j
               if (jatn .eq. 8)  ioniz_j = 0.525d0 * ioniz_j
               if (jatn .eq. 16)  ioniz_j = 0.89d0 * ioniz_j
            end if
            hcij = hcij * (ioniz_i+ioniz_j)/(2.0d0*cionize)
         end if
c
c     set symmetric elements to the same value
c
         hc(i,j) = hcij
         hc(j,i) = hcij
      end do
c
c     make an initial guess at the Fock matrix if needed
c
      if (initial) then
c
c     we comment this line for MC-TINKER so that for each system
c     the initial guess is not the converged matrix of the previous
c     systems. That selection of initial Fock matrix caused problems
c
c        initial = .false.
c
         do i = 1, norbit
            do j = 1, norbit
               f(j,i) = hc(j,i)
            end do
         end do
         do i = 1, norbit
            f(i,i) = 0.5d0 * ip(i)
         end do
      end if
c
c     now, do the scf-mo computation; note that it needs to
c     be done twice, initially for the planar analog of the
c     actual system; then for the nonplanar (actual) system
c
      dowhile (mode.eq.'Planar' .or. mode.eq.'Nonpln')
         if (mode .eq. 'Nonpln') then
            call pitilt (povlap)
            do k = 1, npibond
               i = pibond(2,k)
               j = pibond(3,k)
               hc(i,j) = hc(i,j) * povlap(k)
               hc(j,i) = hc(i,j)
            end do
         end if
c
c     perform scf iterations until convergence is reached;
c     diagonalize the Fock matrix "f" to get the mo's,
c     then use mo's to form the next "f" matrix assuming
c     zero differential overlap except for one-center
c     exchange repulsions
c
         iter = 0
         delta = 2.0d0 * converge
         dowhile (delta.gt.converge .and. iter.lt.maxiter)
            iter = iter + 1
            call jacobi (norbit,maxpi,f,en,v,work1,work2)
            do i = 1, norbit
               do j = i, norbit
                  s1 = 0.0d0
                  s2 = 0.0d0
                  gij = gamma(i,j)
                  do k = 1, nfill
                     s2 = s2 - v(i,k)*v(j,k)*gij
                     if (i .eq. j) then
                        do m = 1, norbit
                           s1 = s1 + 2.0d0*gamma(i,m)*v(m,k)**2
                        end do
                     end if
                  end do
                  f(i,j) =  s1 + s2 + hc(i,j)
                  f(j,i) = f(i,j)
               end do
            end do
c
c     calculate the ground state energy, where "xi" sums the
c     molecular core integrals, "xj" sums the molecular coulomb
c     repulsion integrals, "xk" sums the molecular exchange
c     repulsion integrals, and "xg" is sums the nuclear repulsion
c
            xi = 0.0d0
            xj = 0.0d0
            xk = 0.0d0
            xg = 0.0d0
            do i = 1, nfill
               do j = 1, norbit
                  vij = v(j,i)
                  do k = 1, norbit
                     vik = v(k,i)
                     gjk = gamma(j,k)
                     xi = xi + 2.0d0*vij*vik*hc(j,k)
                     do m = 1, nfill
                        vmj = v(j,m)
                        vmk = v(k,m)
                        xj = xj + 2.0d0*vij*vij*vmk*vmk*gjk
                        xk = xk - vij*vmj*vik*vmk*gjk
                     end do
                  end do
               end do
            end do
            do i = 1, norbit-1
               qi = q(i)
               do j = i+1, norbit
                  xg = xg + qi*q(j)*gamma(i,j)
               end do
            end do
            total = xi + xj + xk + xg
            if (iter .ne. 1)  delta = abs(total-totold)
            totold = total
         end do
c
c     print warning if scf-mo iteration did not converge
c
         if (delta .gt. converge) then
            write (iout,10)
   10       format (' PISCF  --  The SCF-MO Iteration',
     &              ' has not reached Self-Consistency')
         end if
c
c     calculate electron densities from filled mo's
c
         do i = 1, norbit
            do j = 1, norbit
               ed(i,j) = 0.0d0
               do k = 1, nfill
                  ed(i,j) = ed(i,j) + 2.0d0*v(i,k)*v(j,k)
               end do
            end do
         end do
c
c     print out results for the scf computation
c
         if (debug) then
            write (iout,20)  mode,iter,total,delta
   20       format (/,1x,a6,' SCF-MO Iteration',i3,
     &              //,' Energy =',f10.4,3x,'Delta =',d12.4)
            write (iout,30)  xi,xj,xk,xg
   30       format (/,' Core Integrals      =',f11.4,
     &              /,' Coulomb Repulsion   =',f11.4,
     &              /,' Exchange Repulsion  =',f11.4,
     &              /,' Nuclear Repulsion   =',f11.4)
            write (iout,40)  (en(i),i=1,norbit)
   40       format (/,' Orbital Energies',/,(8f9.4))
            write (iout,50)
   50       format (/,' Molecular Orbitals')
            do i = 1, norbit
               write (iout,60)  (v(i,j),j=1,norbit)
   60          format (8f9.4)
            end do
            write (iout,70)
   70       format (/,' Fock Matrix')
            do i = 1, norbit
               write (iout,60)  (f(i,j),j=1,norbit)
            end do
            write (iout,80)  (ed(i,i),i=1,norbit)
   80       format (/,' Electron Densities',/,(8f9.4))
            write (iout,90)
   90       format (/,' Density Matrix')
            do i = 1, norbit
               write (iout,60)  (ed(i,j),j=1,norbit)
            end do
            write (iout,100)
  100       format (/,' H-core Matrix')
            do i = 1, norbit
               write (iout,60)  (hc(i,j),j=1,norbit)
            end do
            write (iout,110)
  110       format (/,' Gamma Matrix')
            do i = 1, norbit
               write (iout,60)  (gamma(i,j),j=1,norbit)
            end do
         end if
c
c     now, get the bond orders (compute p and p*b)
c
         if (debug) then
            write (iout,120)
  120       format (/,' PI Bond Orders')
         end if
         do k = 1, npibond
            i = pibond(2,k)
            j = pibond(3,k)
            p = 0.0d0
            do m = 1, nfill
               p = p + 2.0d0*v(i,m)*v(j,m)
            end do
            if (mode .eq. 'Planar') then
               pbpl(k) = p * hc(i,j)/ebeta
            else if (mode .eq. 'Nonpln') then
               pnpl(k) = p
            end if
            if (debug) then
               i = ibnd(1,pibond(1,k))
               j = ibnd(2,pibond(1,k))
               write (iout,130)  i,j,p
  130          format (4x,2i5,3x,f10.4)
            end if
         end do
c
c     if we have done planar calculation, do the nonplanar;
c     when both are complete, alter the pisystem constants
c
         if (mode .eq. 'Planar') then
            mode = 'Nonpln'
         else if (mode .eq. 'Nonpln') then
            mode = '      '
         end if
      end do
c
c     alter torsional and bond constants for pisystem
c
      call pialter
      return
      end
