c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine korbit  --  pisystem parameter assignment  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "korbit" assigns pi-orbital parameters to conjugated
c     systems and processes any new or changed parameters
c
c
      subroutine korbit
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'korbs.i'
      include 'picalc.i'
      include 'pistuf.i'
      include 'piterm.i'
      include 'tors.i'
      include 'units.i'
      integer i,j,k,size,next
      integer ia,ib,it,ita,itb
      real*8 elect,ioniz,repuls
      real*8 sslop,tslop
      character*3 pa,pb
      character*6 pt
      character*20 keyword
      character*80 record,string
      logical header,done
c
c
c     process keywords containing pisystem atom parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'PIATOM ') then
            if (header) then
               header = .false.
               write (iout,10)
   10          format (/,' Additional Pisystem Atom Parameters :',
     &                 //,6x,'Atom Type',3x,'Electron',3x,'Ionization',
     &                    3x,'Repulsion',/)
            end if
            ia = 0
            elect = 0.0d0
            ioniz = 0.0d0
            repuls = 0.0d0
            string = record(next:80)
            read (string,*,err=20)  ia,elect,ioniz,repuls
   20       continue
            write (iout,30)  ia,elect,ioniz,repuls
   30       format (8x,i4,3x,f10.3,3x,f10.3,2x,f10.3)
            if (ia.gt.0 .and. ia.le.maxclass) then
               electron(ia) = elect
               ionize(ia) = ioniz
               repulse(ia) = repuls
            else
   40          format (/,' KORBIT  --  Too many Atom Classes;',
     &                    ' Increase MAXCLASS')
               abort = .true.
            end if
         end if
      end do
c
c     process keywords containing pisystem bond parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'PIBOND ') then
            if (header) then
               header = .false.
               write (iout,50)
   50          format (/,' Additional Pisystem Bond Parameters :',
     &                 //,6x,'Atom Types',7x,'d Force',4x,'d Length',/)
            end if
            ia = 0
            ib = 0
            sslop = 0.0d0
            tslop = 0.0d0
            string = record(next:80)
            read (string,*,err=60)  ia,ib,sslop,tslop
   60       continue
            write (iout,70)  ia,ib,sslop,tslop
   70       format (6x,2i4,5x,2f11.3)
            size = 3
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            if (ia .le. ib) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            do j = 1, maxnpi
               if (kpi(j).eq.'      ' .or. kpi(j).eq.pt) then
                  kpi(j) = pt
                  sslope(j) = sslop
                  tslope(j) = tslop
                  goto 90
               end if
            end do
            write (iout,80)
   80       format (/,' KORBIT  --  Too many Pi-System Bond',
     &                 ' Type Parameters')
            abort = .true.
   90       continue
         end if
      end do
c
c     assign the values characteristic of the piatom types;
c     count the number of filled pi molecular orbitals
c
      nfill = 0
      do i = 1, norbit
         it = type(iorbit(i))
         q(i) = electron(it)
         w(i) = ionize(it) / evolt
         em(i) = repulse(it) / evolt
         nfill = nfill + nint(q(i))
      end do
      nfill = nfill / 2
c
c     assign parameters for all bonds between piatoms;
c     store the original bond lengths and force constants
c
      do i = 1, npibond
         j = pibond(1,i)
         ia = pibond(2,i)
         ib = pibond(3,i)
         ita = class(iorbit(ia))
         itb = class(iorbit(ib))
         size = 3
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            pt = pa//pb
         else
            pt = pb//pa
         end if
         done = .false.
         k = 0
         dowhile (.not.done .and. k.lt.maxnpi)
            k = k + 1
            if (kpi(k) .eq. pt) then
               done = .true.
               bkpi(i) = bk(j)
               blpi(i) = bl(j)
               kslope(i) = sslope(k)
               lslope(i) = tslope(k)
            end if
         end do
         if (.not.done) then
            write (iout,100)  ita,itb
  100       format (/,' KORBIT  --  No Parameters for Pi-Bond',
     &                 ' between Atom Types',2i4)
         end if
      end do
c
c     store the original torsional constants across pibonds
c
      do i = 1, npitors
         j = pitors(1,i)
         torspi(i) = tors2(1,j)
      end do
      return
      end
