      subroutine dbcevl (x, nx, y, ny, sc, ic, xp, yp, pds, ierr)
C*******************************************************************************
C*                                                                             *
C*    ROUTINE NAME:  DBCEVL                                                    *
C*                                                                             *
C*    PURPOSE:  computes partial derivitives for a bicubic spline              *
C*                                                                             *
C*    AUTHOR:   Steve Reid - 18 August 1999                                    *
C*              S & E Computing                                                *
C*                                                                             *
C*    INPUTS:   x   - vector of length nx                                      *
C*              nx  - number of elements in vector x                           *
C*              y   - vector of length ny                                      *
C*              ny  - number of elements in vector y                           *
C*              sc  - spline coefficient array dimensioned (2, ic, 2 * ny)     *
C*              ic  - second dimension of sc array                             *
C*              xp  - x-coordinate of point at which mixed partial derivitives *
C*                    are to be calculated                                     *
C*              yp  - y-coordinate of point at which mixed partial derivitives *
C*                    are to be calculated                                     *
C*                                                                             *
C*    OUTPUTS:  pds - vector containing spline value at the point in question  *
C*                    and five derivitives; i.e.                               *
C*                      pds(1) = s(xp, yp)                                     *
C*                      pds(2) = ds/dx                                         *
C*                      pds(3) = ds/dy                                         *
C*                      pds(4) = d(ds/dx)/dy                                   *
C*                      pds(5) = d(ds/dx)/dx                                   *
C*                      pds(6) = d(ds/dy)/dy                                   *
C*                                                                             *
C*              ierr - error code (point out of bounds warnings)               *
C*                      33 = xp < x(1)                                         *
C*                      34 = yp < y(1)                                         *
C*                      35 = xp > x(nx)                                        *
C*                      36 = yp > y(ny)                                        *
C*                                                                             *
C*    ROUTINES CALLED:  tableintrp, uertst                                     *
C*                                                                             *
C*    LIMITATIONS:  The elements of input vectors x and y are assumed to be    *
C*                  pre-sorted into ascending order.  The input ic must be     *
C*                  greater than or equal to nx.                               *
C*                                                                             *
C*******************************************************************************
      implicit none
      integer i, ic, ierr, j, k, km1, kp1, kp2, l, lxp1, lxpl, lx, ly,
     &        nx, ny
      real*8  d, h, hx, hy, pds(6), sc(2, ic, *), s0, sh, sp0, sph,
     &        spln0, spln1, spln2, su(2), sux(2), suy(2), sv(2), svx(2),
     &        sxy(2), u, v, x(*), xp, y(*), yp
      character*6 isub /'dbcevl'/
      data    lx, ly /2 * 0/
c
c--Statement functions
c
      spln0 (s0,sh,sp0,sph,h,d) = s0+d*(h*sp0+d*(3.0*(sh-s0)-
     & (sph+2.0*sp0)*h+d*(2.0*(s0-sh)+(sph+sp0)*h)))
c
      spln1 (s0,sh,sp0,sph,h,d) = sp0+d*(6.0 * (sh-s0)/h-2.0*
     & (sph+2.0*sp0)+3.0*d*(2.0*(s0-sh)/h+(sph+sp0)))
c
      spln2 (s0,sh,sp0,sph,h,d) = 6.0 * (sh-s0)/h**2-2.0*
     & (sph+2.0*sp0)/h+d*(2.0*(s0-sh)/h**2+(sph+sp0)/h)*6.
c
c--Correlated table search for xp
c
      ierr = 0
      call tableintrp (x, nx, xp, lx)
      if (lx .eq. 0) then
         ierr = 33
         go to 9000
      elseif (lx .eq. nx) then
         ierr = 35
         go to 9000
      endif
c
c--Correlated table search for yp
c
      call tableintrp (y, ny, yp, ly)
      if (ly .eq. 0) then
         ierr = 34
         go to 9000
      elseif (ly .eq. ny) then
         ierr = 36
         go to 9000
      endif
c
      lxp1 = lx + 1
      hx   = x(lxp1) - x(lx)
      hy   = y(ly + 1) - y(ly)
      u    = (xp - x(lx)) / hx
      v    = (yp - y(ly)) / hy
      k    = 2 * ly
      kp1  = k + 1
      kp2  = k + 2
      km1  = k - 1
c
      do l = 1, 2
         lxpl   = lx - 1 + l
         i      = 2 * (ly - 1 + l)
         j      = i - 1
         sv(l)  = spln0 (sc(1, lxpl, km1), sc(1, lxpl, kp1),
     &                   sc(1, lxpl, k), sc(1, lxpl, kp2), hy, v)
         svx(l) = spln0 (sc(2, lxpl, km1), sc(2, lxpl, kp1),
     &                   sc(2, lxpl, k), sc(2, lxpl, kp2), hy, v)
         su(l)  = spln0 (sc(1, lx, j), sc(1, lxp1, j), sc(2, lx, j),
     &                   sc(2, lxp1, j), hx, u)
         suy(l) = spln0 (sc(1, lx, i), sc(1, lxp1, i), sc(2, lx, i),
     &                   sc(2, lxp1, i), hx, u)
         sux(l) = spln1 (sc(1, lx, j), sc(1, lxp1, j), sc(2, lx, j),
     &                   sc(2, lxp1, j), hx, u)
         sxy(l) = spln1 (sc(1, lx, i), sc(1, lxp1, i), sc(2, lx, i),
     &                   sc(2, lxp1, i), hx, u)
      enddo
c
      pds(1) = spln0 (sv(1), sv(2), svx(1), svx(2), hx, u)
      pds(2) = spln1 (sv(1), sv(2), svx(1), svx(2), hx, u)
      pds(3) = spln1 (su(1), su(2), suy(1), suy(2), hy, v)
      pds(4) = spln1 (sux(1), sux(2), sxy(1), sxy(2), hy, v)
      pds(5) = spln2 (sv(1), sv(2), svx(1), svx(2), hx, u)
      pds(6) = spln2 (su(1), su(2), suy(1), suy(2), hy, v)
      go to 9990
c
c--Error exit.
c
 9000 continue
      call uertst (ierr, isub)
c
c--Normal exit.
c
 9990 continue
      return
      end
