c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine surface  --  accessible surface area & derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "surface" performs an analytical computation of the weighted
c     solvent accessible surface area of each atom and the first
c     derivatives of the area with respect to Cartesian coordinates
c
c     literature references :
c
c     T. J. Richmond, "Solvent Accessible Surface Area and
c     Excluded Volume in Proteins", Journal of Molecular Biology,
c     178, 63-89 (1984)
c
c     L. Wesson and D. Eisenberg, "Atomic Solvation Parameters
c     Applied to Molecular Dynamics of Proteins in Solution",
c     Protein Science, 1, 227-235 (1992)
c
c     variables and parameters :
c
c     total    total surface area of the whole structure
c     area     accessible surface area of each atom
c     darea    x,y,z components of the gradient of the area of
c                the molecule with respect to atomic coordinates
c     radius   radii of the individual atoms
c     weight   weight assigned to each atom's area; if set to
c                1.0, return is actual area in square Angstroms
c     probe    radius of the probe sphere
c     sig      tolerance used in the tests for sphere overlaps
c                and for colinearity; if a connectivity error
c                occurs for an atom, change the coordinates of
c                the offending atom slightly
c
c
      subroutine surface (total,area,darea,radius,weight,probe)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'usage.i'
      integer maxarc
      parameter (maxarc=300)
      integer i,j,k,l,m,ii,ib,jb,in,io,ir
      integer mi,ni,narc,ider(maxarc),sign_yder(maxarc)
      integer key(maxarc),intag(maxarc),intag1(maxarc)
      real*8 total,area(maxatm),darea(3,maxatm)
      real*8 probe,radius(maxatm),r(maxatm)
      real*8 wght,weight(maxatm)
      real*8 sig,sigsq,arcsum,dsql,wxl,wxlsq,p,s,v,rcn,cosine
      real*8 axx,axy,axz,ayx,ayy,azx,azy,azz,uxl,uyl,uzl
      real*8 tx,ty,tz,txb,tyb,t2,td,tr2,tr,txr,tyr,tk1,tk2
      real*8 thec,the,t,tb,txk,tyk,tzk,t1,ti,tf,tt,txl,tyl,tzl
      real*8 arclen,exang,xr,yr,zr,rr,rrx2,rrsq,rplus,rminus
      real*8 ccsq,cc,xysq,bgl,bsqk,bsql,bk,gi,gl,pix2,pix4,pid2
      real*8 dax,day,daz,deal,decl,dtkal,dtkcl,dtlal,dtlcl
      real*8 therk,dk,gk,risqk,rik,risql,faca,facb,facc,gaca,gacb
      real*8 ux(maxarc),uy(maxarc),uz(maxarc)
      real*8 xc(maxarc),yc(maxarc),zc(maxarc)
      real*8 xc1(maxarc),yc1(maxarc),zc1(maxarc)
      real*8 dsq(maxarc),bsq(maxarc),b(maxarc)
      real*8 arci(maxarc),arcf(maxarc),ex(maxarc)
      real*8 kent(maxarc),kout(maxarc),lt(maxarc)
      real*8 bg(maxarc),ther(maxarc),ri(maxarc),risq(maxarc)
      real*8 b1(maxarc),dsq1(maxarc),bsq1(maxarc),gr(maxarc)
      logical ltop,skip(maxatm),omit(maxarc),komit
c
c
c     set multiples of pi and the overlap significance value
c
      pix2 = 2.0d0 * pi
      pix4 = 4.0d0 * pi
      pid2 = pi / 2.0d0
      sig = 0.01d0
      sigsq = sig**2
      total = 0.0d0
      do i = 1, maxarc
         ider(i) = 0
         sign_yder(i) = 0
      end do
c
c     zero the area and derivatives, and set the sphere radii
c
      do i = 1, n
         area(i) = 0.0d0
         darea(1,i) = 0.0d0
         darea(2,i) = 0.0d0
         darea(3,i) = 0.0d0
         r(i) = radius(i)
         if (r(i) .ne. 0.0d0)  r(i) = r(i) + probe
      end do
c
c     set the "skip" array to exclude all inactive atoms
c     that do not overlap any of the current active atoms
c
      do i = 1, n
         skip(i) = .true.
      end do
      do i = 1, n
         if (use(i)) then
            xr = x(i)
            yr = y(i)
            zr = z(i)
            rr = r(i)
            do k = 1, n
               rplus = (rr + r(k))**2
               ccsq = (x(k)-xr)**2 + (y(k)-yr)**2 + (z(k)-zr)**2
               if (ccsq .le. rplus)  skip(k) = .false.
            end do
         end if
      end do
c
c     compute the area and derivatives of current "ir" sphere
c
      do ir = 1, n
         if (skip(ir))  goto 160
         io = 0
         jb = 0
         ib = 0
         arclen = 0.0d0
         exang = 0.0d0
         xr = x(ir)
         yr = y(ir)
         zr = z(ir)
         rr = r(ir)
         rrx2 = 2.0d0 * rr
         rrsq = rr**2
         wght = weight(ir)
c
c     test each sphere to see if it overlaps the "ir" sphere
c
         do i = 1, n
            if (i .eq. ir)  goto 20
            rplus = rr + r(i)
            tx = x(i) - xr
            if (abs(tx) .ge. rplus)  goto 20
            ty = y(i) - yr
            if (abs(ty) .ge. rplus)  goto 20
            tz = z(i) - zr
            if (abs(tz) .ge. rplus)  goto 20
c
c     check for overlap of spheres by testing center to
c     center distance against sum and difference of radii
c
            xysq = tx**2 + ty**2
            if (xysq .lt. sigsq) then
               tx = sig
               ty = 0.0d0
               xysq = sigsq
            end if
            ccsq = xysq + tz**2
            cc = sqrt(ccsq)
            if (rplus-cc .le. sig)  goto 20
            rminus = rr - r(i)
c
c     check for a completely buried "ir" sphere
c
            if (cc-abs(rminus) .le. sig) then
               if (rminus .le. 0.0d0)  goto 160
               goto 20
            end if
c
c     calculate overlap parameters between "i" and "ir" sphere
c
            io = io + 1
            xc1(io) = tx
            yc1(io) = ty
            zc1(io) = tz
            dsq1(io) = xysq
            bsq1(io) = ccsq
            b1(io) = cc
            gr(io) = (ccsq+rplus*rminus) / (rrx2*b1(io))
            intag1(io) = i
            if (io .gt. maxarc) then
               write (iout,10)
   10          format (/,' SURFACE  --  Increase the Value of MAXARC')
               call fatal
            end if
   20       continue
         end do
c
c     case where no other spheres overlap the current sphere
c
         if (io .eq. 0) then
            area(ir) = pix4
            goto 150
         end if
c
c     case where only one sphere overlaps the current sphere
c
         if (io .eq. 1) then
            k = 1
            txk = xc1(1)
            tyk = yc1(1)
            tzk = zc1(1)
            bsqk = bsq1(1)
            bk = b1(1)
            intag(1) = intag1(1)
            arcsum = pix2
            ib = ib + 1
            arclen = arclen + gr(k)*arcsum
            in = intag(k)
            t1 = arcsum*rrsq*(bsqk-rrsq+r(in)**2) / (rrx2*bsqk*bk)
            darea(1,ir) = darea(1,ir) - txk*t1*wght
            darea(2,ir) = darea(2,ir) - tyk*t1*wght
            darea(3,ir) = darea(3,ir) - tzk*t1*wght
            darea(1,in) = darea(1,in) + txk*t1*wght
            darea(2,in) = darea(2,in) + tyk*t1*wght
            darea(3,in) = darea(3,in) + tzk*t1*wght
            goto 140
         end if
c
c     general case where more than one sphere intersects the
c     current sphere; sort intersecting spheres by their degree
c     of overlap with the current main sphere
c
         call sort2 (io,gr,key)
         do i = 1, io
            k = key(i)
            intag(i) = intag1(k)
            xc(i) = xc1(k)
            yc(i) = yc1(k)
            zc(i) = zc1(k)
            dsq(i) = dsq1(k)
            b(i) = b1(k)
            bsq(i) = bsq1(k)
            omit(i) = .false.
         end do
c
c     radius of the each circle on the surface of the "ir" sphere
c
         do i = 1, io
            gi = gr(i) * rr
            bg(i) = b(i) * gi
            risq(i) = rrsq - gi**2
            ri(i) = sqrt(risq(i))
            ther(i) = pid2 - asin(min(1.0d0,max(-1.0d0,gr(i))))
         end do
c
c     find boundary of inaccessible area on "ir" sphere
c
         do k = 1, io-1
            if (.not. omit(k)) then
               txk = xc(k)
               tyk = yc(k)
               tzk = zc(k)
               bk = b(k)
               therk = ther(k)
               do j = k+1, io
                  if (omit(j))  goto 50
c
c     check to see if J circle is intersecting K circle;
c     get distance between circle centers and sum of radii
c
                  cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j))
                  cc = acos(min(1.0d0,max(-1.0d0,cc)))
                  td = therk + ther(j)
c
c     check to see if circles enclose separate regions
c
                  if (cc .ge. td)  goto 50
c
c     check for circle J completely inside circle K
c
                  if (cc+ther(j) .lt. therk)  goto 30
c
c     check for circles essentially parallel
c
                  if (cc .gt. sig)  goto 40
   30             continue
                  omit(j) = .true.
                  goto 50
c
c     check for "ir" sphere completely buried
c
   40             continue
                  if (pix2-cc .le. td)  goto 160
   50             continue
               end do
            end if
         end do
c
c     find T value of circle intersections
c
         do k = 1, io
            if (omit(k))  goto 100
            komit = omit(k)
            omit(k) = .true.
            narc = 0
            ltop = .false.
            txk = xc(k)
            tyk = yc(k)
            tzk = zc(k)
            dk = sqrt(dsq(k))
            bsqk = bsq(k)
            bk = b(k)
            gk = gr(k) * rr
            risqk = risq(k)
            rik = ri(k)
            therk = ther(k)
c
c     rotation matrix elements
c
            t1 = tzk / (bk*dk)
            axx = txk * t1
            axy = tyk * t1
            axz = dk / bk
            ayx = tyk / dk
            ayy = txk / dk
            azx = txk / bk
            azy = tyk / bk
            azz = tzk / bk
            do l = 1, io
               if (.not. omit(l)) then
                  txl = xc(l)
                  tyl = yc(l)
                  tzl = zc(l)
c
c     rotate spheres so K vector colinear with z-axis
c
                  uxl = txl*axx + tyl*axy - tzl*axz
                  uyl = tyl*ayy - txl*ayx
                  uzl = txl*azx + tyl*azy + tzl*azz
                  cosine = min(1.0d0,max(-1.0d0,uzl/b(l)))
                  if (acos(cosine) .lt. therk+ther(l)) then
                     dsql = uxl**2 + uyl**2
                     tb = uzl*gk - bg(l)
                     txb = uxl * tb
                     tyb = uyl * tb
                     td = rik * dsql
                     tr2 = risqk*dsql - tb**2
                     if (tr2 .le. 0.000001d0)  tr2 = 0.000001d0
                     tr = sqrt(tr2)
                     txr = uxl * tr
                     tyr = uyl * tr
c
c     get T values of intersection for K circle
c
                     tb = (txb+tyr) / td
                     tb = min(1.0d0,max(-1.0d0,tb))
                     tk1 = acos(tb)
                     if (tyb-txr .lt. 0.0d0)  tk1 = pix2 - tk1
                     tb = (txb-tyr) / td
                     tb = min(1.0d0,max(-1.0d0,tb))
                     tk2 = acos(tb)
                     if (tyb+txr .lt. 0.0d0)  tk2 = pix2 - tk2
                     thec = (rrsq*uzl-gk*bg(l)) / (rik*ri(l)*b(l))
                     if (abs(thec) .lt. 1.0d0) then
                        the = -acos(thec)
                     else if (thec .ge. 1.0d0) then
                        the = 0.0d0
                     else if (thec .le. -1.0d0) then
                        the = -pi
                     end if
c
c     see if "tk1" is entry or exit point; check t=0 point;
c     "ti" is exit point, "tf" is entry point
c
                     cosine = min(1.0d0,max(-1.0d0,
     &                               (uzl*gk-uxl*rik)/(b(l)*rr)))
                     if ((acos(cosine)-ther(l))*(tk2-tk1)
     &                          .le. 0.0d0) then
                        ti = tk2
                        tf = tk1
                     else
                        ti = tk2
                        tf = tk1
                     end if
                     narc = narc + 1
                     if (narc .ge. maxarc) then
                        write (iout,60)
   60                   format (/,' SURFACE  --  Increase the Value',
     &                             ' of MAXARC')
                        call fatal
                     end if
                     if (tf .le. ti) then
                        arcf(narc) = tf
                        arci(narc) = 0.0d0
                        tf = pix2
                        lt(narc) = l
                        ex(narc) = the
                        ltop = .true.
                        narc = narc + 1
                     end if
                     arcf(narc) = tf
                     arci(narc) = ti
                     lt(narc) = l
                     ex(narc) = the
                     ux(l) = uxl
                     uy(l) = uyl
                     uz(l) = uzl
                  end if
               end if
            end do
            omit(k) = komit
c
c     special case; K circle without intersections
c
            if (narc .le. 0)  goto 80
c
c     general case; sum up arclength and set connectivity code
c
            call sort2 (narc,arci,key)
            arcsum = arci(1)
            mi = key(1)
            t = arcf(mi)
            ni = mi
            if (narc .gt. 1) then
               do j = 2, narc
                  m = key(j)
                  if (t .lt. arci(j)) then
                     arcsum = arcsum + arci(j) - t
                     exang = exang + ex(ni)
                     jb = jb + 1
                     if (jb .ge. maxarc) then
                        write (iout,70)
   70                   format (/,' SURFACE  --  Increase the Value',
     &                             ' of MAXARC')
                        call fatal
                     end if
                     l = lt(ni)
                     ider(l) = ider(l) + 1
                     sign_yder(l) = sign_yder(l) + 1
                     kent(jb) = maxarc*l + k
                     l = lt(m)
                     ider(l) = ider(l) + 1
                     sign_yder(l) = sign_yder(l) - 1
                     kout(jb) = maxarc*k + l
                  end if
                  tt = arcf(m)
                  if (tt .ge. t) then
                     t = tt
                     ni = m
                  end if
               end do
            end if
            arcsum = arcsum + pix2 - t
            if (.not. ltop) then
               exang = exang + ex(ni)
               jb = jb + 1
               l = lt(ni)
               ider(l) = ider(l) + 1
               sign_yder(l) = sign_yder(l) + 1
               kent(jb) = maxarc*l + k
               l = lt(mi)
               ider(l) = ider(l) + 1
               sign_yder(l) = sign_yder(l) - 1
               kout(jb) = maxarc*k + l
            end if
c
c     calculate the surface area derivatives
c
            do l = 1, io
               if (ider(l) .ne. 0) then
                  rcn = ider(l) * rrsq
                  ider(l) = 0
                  uzl = uz(l)
                  gl = gr(l) * rr
                  bgl = bg(l)
                  bsql = bsq(l)
                  risql = risq(l)
                  wxlsq = bsql - uzl**2
                  wxl = sqrt(wxlsq)
                  p = bgl - gk*uzl
                  v = risqk*wxlsq - p**2
                  if (v .le. 0.000001d0)  v = 0.000001d0
                  v = sqrt(v)
                  t1 = rr * (gk*(bgl-bsql)+uzl*(bgl-rrsq))
     &                             / (v*risql*bsql)
                  deal = -wxl*t1
                  decl = -uzl*t1 - rr/v
                  dtkal = (wxlsq-p) / (wxl*v)
                  dtkcl = (uzl-gk) / v
                  s = gk*b(l) - gl*uzl
                  t1 = 2.0d0*gk - uzl
                  t2 = rrsq - bgl
                  dtlal = -(risql*wxlsq*b(l)*t1-s*(wxlsq*t2+risql*bsql))
     &                              / (risql*wxl*bsql*v)
                  dtlcl = -(risql*b(l)*(uzl*t1-bgl)-uzl*t2*s)
     &                              / (risql*bsql*v)
                  gaca = rcn * (deal-(gk*dtkal-gl*dtlal)/rr) / wxl
                  gacb = (gk - uzl*gl/b(l)) * sign_yder(l) * rr / wxlsq
                  sign_yder(l) = 0
                  faca = ux(l)*gaca - uy(l)*gacb
                  facb = uy(l)*gaca + ux(l)*gacb
                  facc = rcn * (decl-(gk*dtkcl-gl*dtlcl)/rr)
                  dax = axx*faca - ayx*facb + azx*facc
                  day = axy*faca + ayy*facb + azy*facc
                  daz = azz*facc - axz*faca
                  in = intag(l)
                  darea(1,ir) = darea(1,ir) + dax*wght
                  darea(2,ir) = darea(2,ir) + day*wght
                  darea(3,ir) = darea(3,ir) + daz*wght
                  darea(1,in) = darea(1,in) - dax*wght
                  darea(2,in) = darea(2,in) - day*wght
                  darea(3,in) = darea(3,in) - daz*wght
               end if
            end do
            goto 90
   80       continue
            arcsum = pix2
            ib = ib + 1
   90       continue
            arclen = arclen + gr(k)*arcsum
            in = intag(k)
            t1 = arcsum*rrsq*(bsqk-rrsq+r(in)**2) / (rrx2*bsqk*bk)
            darea(1,ir) = darea(1,ir) - txk*t1*wght
            darea(2,ir) = darea(2,ir) - tyk*t1*wght
            darea(3,ir) = darea(3,ir) - tzk*t1*wght
            darea(1,in) = darea(1,in) + txk*t1*wght
            darea(2,in) = darea(2,in) + tyk*t1*wght
            darea(3,in) = darea(3,in) + tzk*t1*wght
  100       continue
         end do
         if (arclen .eq. 0.0d0)  goto 160
         if (jb .eq. 0)  goto 140
c
c     find number of independent boundaries; check
c     for connectivity error for the current atom
c
         j = 0
         do k = 1, jb
            if (kout(k) .ne. 0) then
               i = k
  110          continue
               m = kout(i)
               kout(i) = 0
               j = j + 1
               do ii = 1, jb
                  if (m .eq. kent(ii)) then
                     if (ii .eq. k) then
                        ib = ib + 1
                        if (j .eq. jb)  goto 140
                        goto 120
                     end if
                     i = ii
                     goto 110
                  end if
               end do
  120          continue
            end if
         end do
         ib = ib + 1
         write (iout,130)  ir
  130    format (/,' SURFACE  --  Connectivity Error at Atom',i6)
c
c     form the accessible area for the current atom
c
  140    continue
         area(ir) = ib*pix2 + exang + arclen
         area(ir) = mod(area(ir),pix4)
  150    continue
         area(ir) = area(ir) * rrsq * wght
         total = total + area(ir)
  160    continue
      end do
c
c     zero out the area derivatives for the inactive atoms
c
      do i = 1, n
         if (.not. use(i)) then
            darea(1,i) = 0.0d0
            darea(2,i) = 0.0d0
            darea(3,i) = 0.0d0
         end if
      end do
c
c     print out the surface area and derivatives for each atom
c
      if (debug) then
         write (iout,170)
  170    format (/,' Weighted Atomic Surface Areas and Derivatives :',
     &           //,4x,'Atom',7x,'Area Term',10x,'dA/dx',
     &              7x,'dA/dy',7x,'dA/dz',/)
         do i = 1, n
            if (.not. skip(i)) then
               write (iout,180)  i,area(i),(darea(j,i),j=1,3)
  180          format (i8,4x,f12.4,3x,3f12.4)
            end if
         end do
         write (iout,190)  total
  190    format (/,' Total Weighted Surface Area :',5x,f16.4)
      end if
      return
      end
