 
      subroutine dbcevl1(x, nx, y, ny, c, ic, xl, yl, pds, ier, icalc)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:50:51  10/ 1/01  
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nx, ny, ic, ier, icalc
      real(kind=dp) xl, yl
      real(kind=dp), dimension(*) :: x, y
      real(kind=dp), dimension(2,ic,*) :: c
      real(kind=dp), dimension(6) :: pds
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, j, k, km1, kp1, kp2, lxpl, lx, ly, l, lxp1
      real(kind=dp) :: hx, hy
      real(kind=dp), dimension(2) :: sux, suy, su, svx, sv, sxy
      real(kind=dp) :: u, v, s0, sh, sp0, sph, h, d
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real(kind=dp) spln0, spln1, spln2
C-----------------------------------------------
c
c --- this is a special version of dbcevl, used by the ONETWO suite
c --- of subroutines. It differs from the IMSL version in the calling
c --- arguments and the calculations below are reordered for efficiency
c --- That is, many times we don't need all of the pds array. This
c --- version returns only those values of pds specifically requested
c --- using the argument icalc. This leads to about at 50% improvement
c --- in execution time. --- HSJ
c
c
      data lx, ly/0, 0/
c
      ier = 0
c
c --- correlated table search for xl
c
      call tableintrp (x, nx, xl, lx)
      if (lx == 0) ier = 33
      if (lx == nx) ier = 35
      if (ier == 0) then
c
c --- correlated table search for yl
c
         call tableintrp (y, ny, yl, ly)
         if (ly == 0) ier = 34
         if (ly == ny) ier = 36
         if (ier == 0) then
c
c --- replaces the following linear search
c
****  if (xl .lt. x(1))  ier = 33
****  do 5 i=2,nx
****     lx = i-1
****     if (xl .le. x(i))  go to 10
****5 continue
****  ier = 35
***10 if (yl .lt. y(1))  ier = 34
****  do 15 j=2,ny
****     ly = j-1
****     if (yl .le. y(j))  go to 20
***15 continue
****  ier = 36
***20 if (ier .ne. 0)  go to 100
c
            lxp1 = lx + 1
            hx = x(lxp1) - x(lx)
            hy = y(ly+1) - y(ly)
            u = (xl - x(lx))/hx
            v = (yl - 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(c(1,lxpl,km1),c(1,lxpl,kp1),c(1,lxpl,k),c(1
     1            ,lxpl,kp2),hy,v)
               svx(l) = spln0(c(2,lxpl,km1),c(2,lxpl,kp1),c(2,lxpl,k),c(
     1            2,lxpl,kp2),hy,v)
               if (icalc >= 3) then              ! rearranged by HSJ
                  su(l) = spln0(c(1,lx,j),c(1,lxp1,j),c(2,lx,j),c(2,lxp1
     1               ,j),hx,u)
                  suy(l) = spln0(c(1,lx,i),c(1,lxp1,i),c(2,lx,i),c(2,
     1               lxp1,i),hx,u)
                  if (icalc >= 4) then
                     sux(l) = spln1(c(1,lx,j),c(1,lxp1,j),c(2,lx,j),c(2,
     1                  lxp1,j),hx,u)
                     sxy(l) = spln1(c(1,lx,i),c(1,lxp1,i),c(2,lx,i),c(2,
     1                  lxp1,i),hx,u)
                  endif
               endif
            end do
c
            pds(1) = spln0(sv(1),sv(2),svx(1),svx(2),hx,u)
c                               ! special routine only calculates pds(1)
            if (icalc == 1) return 
            pds(2) = spln1(sv(1),sv(2),svx(1),svx(2),hx,u)
            if (icalc == 2) return 
            pds(3) = spln1(su(1),su(2),suy(1),suy(2),hy,v)
            if (icalc == 3) return 
            pds(4) = spln1(sux(1),sux(2),sxy(1),sxy(2),hy,v)
            if (icalc == 4) return 
            pds(5) = spln2(sv(1),sv(2),svx(1),svx(2),hx,u)
            if (icalc == 5) return 
            pds(6) = spln2(su(1),su(2),suy(1),suy(2),hy,v)
         endif
      endif
      return 
      contains
      real(kind=dp) function spln0 (s0, sh, sp0, sph, h, d)
      real(kind=dp) s0
      real(kind=dp) sh
      real(kind=dp) sp0
      real(kind=dp) sph
      real(kind=dp) h
      real(kind=dp) d
      spln0 = s0 + d*(h*sp0 + d*(3.0*(sh - s0) - (sph + 2.0*sp0)*h + d*(
     1   2.0*(s0 - sh) + (sph + sp0)*h)))
      return 
      end function spln0
      real(kind=dp) function spln1 (s0, sh, sp0, sph, h, d)
      real(kind=dp) s0
      real(kind=dp) sh
      real(kind=dp) sp0
      real(kind=dp) sph
      real(kind=dp) h
      real(kind=dp) d
      spln1 = sp0 + d*(6.0*(sh - s0)/h - 2.0*(sph + 2.0*sp0) + 3.0*d*(
     1   2.0*(s0 - sh)/h + (sph + sp0)))
      return 
      end function spln1
      real(kind=dp) function spln2 (s0, sh, sp0, sph, h, d)
      real(kind=dp) s0
      real(kind=dp) sh
      real(kind=dp) sp0
      real(kind=dp) sph
      real(kind=dp) h
      real(kind=dp) d
      spln2 = 6.0*(sh - s0)/h**2 - 2.0*(sph + 2.0*sp0)/h + d*(2.0*(s0 - 
     1   sh)/h**2 + (sph + sp0)/h)*6.
      return 
      end function spln2
c
      end subroutine dbcevl1
