c
c  bcspeval -- eval bicubic spline function and/or derivatives
c
      subroutine bcspeval(xget, yget, iselect, fval, x, nx, y, ny, ilinx
     1   , iliny, f, inf3, ier)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:50:51  10/ 1/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nx, ny, ilinx, iliny, inf3, ier
      real xget, yget
      integer, dimension(6) :: iselect
      real, dimension(6) :: fval
      real, dimension(nx) :: x
      real, dimension(ny) :: y
      real, dimension(4,4,inf3,ny) :: f
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, j
      real :: dx, dy
C-----------------------------------------------
c
c
c
c  modification -- dmc 11 Jan 1999 -- remove SAVE stmts; break routine
C    into these parts:
C
C    bcspevxy -- find grid cell of target pt.
C    bcspevfn -- evaluate function using output of bcpsevxy
C
C    in cases where multiple functions are defined on the same grid,
C    time can be saved by using bcspevxy once and then bcspevfn
C    multiple times.
c
c  input:
c     (xget,yget)   location where interpolated value is desired
c                   x(1).le.xget.le.x(nx) expected
c                   y(1).le.yget.le.y(ny) expected
c
c     iselect       select desired output
c
c                     iselect(1)=1 -- want function value (f) itself
c                     iselect(2)=1 -- want  df/dx
c                     iselect(3)=1 -- want  df/dy
c                     iselect(4)=1 -- want  d2f/dx2
c                     iselect(5)=1 -- want  d2f/dy2
c                     iselect(6)=1 -- want  d2f/dxdy
c
c              example:  iselect(1)=iselect(2)=iselect(3)=1
c                            f, df/dx, and df/dy all evaluated
c                        iselect(4)=iselect(5)=iselect(6)=0
c                            2nd derivatives not evaluated.
c
c                   see fval (output) description.
c
c     x(1...nx)     independent coordinate x, strict ascending
c     y(1...ny)     independent coordinate y, strict ascending
c
c     ilinx  --  =1: flag that x is linearly spaced (avoid search for speed)
c     iliny  --  =1: flag that y is linearly spaced (avoid search for speed)
c
c  **CAUTION** actual even spacing of x, y is NOT CHECKED HERE!
c
c
c     f             the function values (at grid points) and spline coefs
c
c  evaluation formula:  for point x btw x(i) and x(i+1), dx=x-x(i)
c                             and y btw y(j) and y(j+1), dy=y-y(j),
c
c      spline value =
c        f(1,1,i,j) + dx*f(2,1,i,j) + dx**2*f(3,1,i,j) + dx**3*f(4,1,i,j)
c   +dy*(f(1,2,i,j) + dx*f(2,2,i,j) + dx**2*f(3,2,i,j) + dx**3*f(4,2,i,j))
c   +d2*(f(1,3,i,j) + dx*f(2,3,i,j) + dx**2*f(3,3,i,j) + dx**3*f(4,3,i,j))
c   +d3*(f(1,4,i,j) + dx*f(2,4,i,j) + dx**2*f(3,4,i,j) + dx**3*f(4,4,i,j))
c
c      where d2=dy**2 and d3=dy**3.
c
c  output:
c      up to 6 elements of fval, ordered as follows:
c        fval(1)=function value or lowest order derivative requested
c        fval(2)=next order derivative
c             etc
c        the ordering is a subset of the sequence given under the "iselect"
c        description.
c
c      ier = 0 -- successful completion; = 1 -- an error occurred.
c
c-------------------------------------------------------------------
c  local
c
c
c
c--------------------------
c
      call bcspevxy(xget,yget,x,nx,y,ny,ilinx,iliny,i,j,dx,dy,ier)
      if (ier /= 0) return 
c
      call bcspevfn (iselect, 1, 1, fval, i, j, dx, dy, f, inf3, ny)
c
      return 
      end subroutine bcspeval
c
c-------------------------------------------------------------------------
c  bcspevxy -- look up x-y zone
c
c  this is the "first part" of bcspeval, see comments, above.
c
      subroutine bcspevxy(xget, yget, x, nx, y, ny, ilinx, iliny, i, j, 
     1   dx, dy, ier)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:50:51  10/ 1/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nx, ny, ilinx, iliny, i, j, ier
      real xget, yget, dx, dy
      real, dimension(nx) :: x
      real, dimension(ny) :: y
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: nxm, nym, ii, jj
      real :: zxget, zyget, zxtol, zytol
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real , EXTERNAL :: write
C-----------------------------------------------
c
c
c
c
c  output of bcspevxy
c
                                        ! dx=x-x(i)  dy=y-y(j)
C
c
c------------------------------------
c
      ier = 0
c
c  range check
c
      zxget = xget
      zyget = yget
 
      if (xget<x(1) .or. xget>x(nx)) then
         zxtol = 4.0E-7*max(abs(x(1)),abs(x(nx)))
         if (xget<x(1) - zxtol .or. xget>x(nx)+zxtol) then
            ier = 1
            write (6, 1001) xget, x(1), x(nx)
 1001       format(' ?bcspeval:  xget=',1pe11.4,' out of range ',1pe11.4
     1         ,' to ',1pe11.4)
         else
            if (xget<x(1) - 0.5*zxtol .or. xget>x(nx)+0.5*zxtol) write (
     1         6, 1011) xget, x(1), x(nx)
 1011       format(' %bcspeval:  xget=',1pe15.8,' beyond range ',1pe15.8
     1         ,' to ',1pe15.8,' (fixup applied)')
            if (xget < x(1)) then
               zxget = x(1)
            else
               zxget = x(nx)
            endif
         endif
      endif
      if (yget<y(1) .or. yget>y(ny)) then
         zytol = 4.0E-7*max(abs(y(1)),abs(y(ny)))
         if (yget<y(1) - zytol .or. yget>y(ny)+zytol) then
            ier = 1
            write (6, 1002) yget, y(1), y(ny)
 1002       format(' ?bcspeval:  yget=',1pe11.4,' out of range ',1pe11.4
     1         ,' to ',1pe11.4)
         else
            if (yget<y(1) - 0.5*zytol .or. yget>y(ny)+0.5*zytol) write (
     1         6, 1012) yget, y(1), y(ny)
 1012       format(' %bcspeval:  yget=',1pe15.8,' beyond range ',1pe15.8
     1         ,' to ',1pe15.8,' (fixup applied)')
            if (yget < y(1)) then
               zyget = y(1)
            else
               zyget = y(ny)
            endif
         endif
      endif
      if (ier /= 0) return 
c
c  now find interval in which target point lies..
c
      nxm = nx - 1
      nym = ny - 1
c
      if (ilinx == 1) then
         ii = 1 + nxm*(zxget - x(1))/(x(nx)-x(1))
         i = min(nxm,ii)
      else
         if (1<=i .and. i<nxm) then
            if (x(i)<=zxget .and. zxget<=x(i+1)) then
            else
               call bcspefnd (x, nx, zxget, i)
            endif
         else
            call bcspefnd (x, nx, zxget, i)
         endif
      endif
c
      if (iliny == 1) then
         jj = 1 + nym*(zyget - y(1))/(y(ny)-y(1))
         j = min(nym,jj)
      else
         if (1<=j .and. j<nym) then
            if (y(j)<=zyget .and. zyget<=y(j+1)) then
            else
               call bcspefnd (y, ny, zyget, j)
            endif
         else
            call bcspefnd (y, ny, zyget, j)
         endif
      endif
c
      dx = zxget - x(i)
      dy = zyget - y(j)
c
      return 
      end subroutine bcspevxy
c------------------------------------------------------------------------
c  bcspevfn -- OK now evaluate the bicubic spline
c
      subroutine bcspevfn(ict,ivec,ivd,fval,iv,jv,dxv,dyv,f,inf3,ny)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:50:51  10/ 1/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer ivec, ivd, inf3, ny
      integer, dimension(6) :: ict
      integer, dimension(ivec) :: iv, jv
      real, dimension(ivd,6) :: fval
      real, dimension(ivec) :: dxv, dyv
      real, dimension(4,4,inf3,ny) :: f
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: v, iaval, i, j
      real :: dx, dy
C-----------------------------------------------
c
c  input:
c        ict(1)=1 for f      (don't evaluate f if ict(1)=0)
c        ict(2)=1 for df/dx   ""
c        ict(3)=1 for df/dy   ""
c        ict(4)=1 for d2f/dx2
c        ict(5)=1 for d2f/dy2
c        ict(6)=1 for d2f/dxdy
c
c    note:  if ict(1)=-1, evaluate f,d2f/dx2,d2f/dy2,d4f/dx2dy2
c
c
c    ivec-- number of vector pts (spline values to look up)
c    ivd -- 1st dimension of fval, .ge.ivec
c
c output:
c
c    v = index to element in vector;
c  fval(v,1) = first item requested by ict(...),
c  fval(v,2) = 2nd item requested,  ...etc...
c
c  input:
c
c
c  usage example:
c
c  1.  for each element (xx(v),yy(v)) in a vector of (x,y) pairs,
c    find the x and y zone indices and displacements with respect
c    to the "lower left corner" of the zone; store these in vectors
c    iv,jv and dxv,dyv.
c
c  2.  set ict(1)=0, ict(2)=1, ict(3)=1, the rest zero -- get only
c      the 1st derivatives.
c
c  3.  ivec is the length of the vector; ivd is the 1st dimension
c      of the array fval to receive the output
c
c      real fval(ivd,6)
c      real xv(ivd),yv(ivd)
c      integer iv(ivd),jv(ivd)
c      real dxv(ivd),dyv(ivd)
c      integer ict(6)
c
c      real fspline(4,4,nx,ny)  ! spline coeffs
c      data ict/0,1,1,0,0,0/    ! this call:  want 1st derivatives
c                               ! only ... these will be output to
c                               ! fval(*,1) fval(*,2)
c      ...
c      do iv=1,ivec
c        ...                    ! find indices and displacements
c      enddo
c      call bcspevfn(ict,ivec,ivd,fval,iv,jv,dxv,dyv,fspline,nx,ny)
c
c-------------------------------------------------------------------
c  local:
c
c
c  OK can now do evaluations
c
      iaval = 0                                  ! fval addressing
c
      if (ict(1)>0 .or. ict(1)==(-1)) then
c  evaluate f
         iaval = iaval + 1
         do v = 1, ivec
            i = iv(v)
            j = jv(v)
            dx = dxv(v)
            dy = dyv(v)
            fval(v,iaval) = f(1,1,i,j) + dy*(f(1,2,i,j)+dy*(f(1,3,i,j)+
     1         dy*f(1,4,i,j))) + dx*(f(2,1,i,j)+dy*(f(2,2,i,j)+dy*(f(2,3
     2         ,i,j)+dy*f(2,4,i,j)))+dx*(f(3,1,i,j)+dy*(f(3,2,i,j)+dy*(f
     3         (3,3,i,j)+dy*f(3,4,i,j)))+dx*(f(4,1,i,j)+dy*(f(4,2,i,j)+
     4         dy*(f(4,3,i,j)+dy*f(4,4,i,j))))))
         end do
      endif
c
      if (ict(2)>0 .and. ict(1)/=(-1)) then
c  evaluate df/dx
         iaval = iaval + 1
         do v = 1, ivec
            i = iv(v)
            j = jv(v)
            dx = dxv(v)
            dy = dyv(v)
            fval(v,iaval) = f(2,1,i,j) + dy*(f(2,2,i,j)+dy*(f(2,3,i,j)+
     1         dy*f(2,4,i,j))) + 2.0*dx*(f(3,1,i,j)+dy*(f(3,2,i,j)+dy*(f
     2         (3,3,i,j)+dy*f(3,4,i,j)))+1.5*dx*(f(4,1,i,j)+dy*(f(4,2,i,
     3         j)+dy*(f(4,3,i,j)+dy*f(4,4,i,j)))))
         end do
      endif
c
      if (ict(3)>0 .and. ict(1)/=(-1)) then
c  evaluate df/dy
         iaval = iaval + 1
         do v = 1, ivec
            i = iv(v)
            j = jv(v)
            dx = dxv(v)
            dy = dyv(v)
            fval(v,iaval) = f(1,2,i,j) + dy*(2.0*f(1,3,i,j)+dy*3.0*f(1,4
     1         ,i,j)) + dx*(f(2,2,i,j)+dy*(2.0*f(2,3,i,j)+dy*3.0*f(2,4,i
     2         ,j))+dx*(f(3,2,i,j)+dy*(2.0*f(3,3,i,j)+dy*3.0*f(3,4,i,j))
     3         +dx*(f(4,2,i,j)+dy*(2.0*f(4,3,i,j)+dy*3.0*f(4,4,i,j)))))
         end do
      endif
c
      if (ict(4)>0 .or. ict(1)==(-1)) then
c  evaluate d2f/dx2
         iaval = iaval + 1
         do v = 1, ivec
            i = iv(v)
            j = jv(v)
            dx = dxv(v)
            dy = dyv(v)
            fval(v,iaval) = 2.0*(f(3,1,i,j)+dy*(f(3,2,i,j)+dy*(f(3,3,i,j
     1         )+dy*f(3,4,i,j)))) + 6.0*dx*(f(4,1,i,j)+dy*(f(4,2,i,j)+dy
     2         *(f(4,3,i,j)+dy*f(4,4,i,j))))
         end do
      endif
c
      if (ict(5)>0 .or. ict(1)==(-1)) then
c  evaluate d2f/dy2
         iaval = iaval + 1
         do v = 1, ivec
            i = iv(v)
            j = jv(v)
            dx = dxv(v)
            dy = dyv(v)
            fval(v,iaval) = 2.0*f(1,3,i,j) + 6.0*dy*f(1,4,i,j) + dx*(2.0
     1         *f(2,3,i,j)+6.0*dy*f(2,4,i,j)+dx*(2.0*f(3,3,i,j)+6.0*dy*f
     2         (3,4,i,j)+dx*(2.0*f(4,3,i,j)+6.0*dy*f(4,4,i,j))))
         end do
      endif
c
      if (ict(6)>0 .and. ict(1)/=(-1)) then
c  evaluate d2f/dxdy
         iaval = iaval + 1
         do v = 1, ivec
            i = iv(v)
            j = jv(v)
            dx = dxv(v)
            dy = dyv(v)
            fval(v,iaval) = f(2,2,i,j) + dy*(2.0*f(2,3,i,j)+dy*3.0*f(2,4
     1         ,i,j)) + 2.*dx*(f(3,2,i,j)+dy*(2.0*f(3,3,i,j)+dy*3.0*f(3,
     2         4,i,j))+1.5*dx*(f(4,2,i,j)+dy*(2.0*f(4,3,i,j)+dy*3.0*f(4,
     3         4,i,j))))
         end do
      endif
c
      if (ict(1) == (-1)) then
         iaval = iaval + 1
         do v = 1, ivec
            i = iv(v)
            j = jv(v)
            dx = dxv(v)
            dy = dyv(v)
            fval(v,iaval) = 4.0*f(3,3,i,j) + 12.0*dy*f(3,4,i,j) + dx*(
     1         12.0*f(4,3,i,j)+36.0*dy*f(4,4,i,j))
         end do
      endif
c
      return 
      end subroutine bcspevfn
