c
c cubspl     from nssl                version   8          05/19/77
c
c package cubspl
c
c
c latest revision        september 1976
c
c purpose                to perform one and two-dimensional cubic spline
c                        interpolation with choice of boundary
c                        conditions.  the function and selected
c                        derivatives may be evaluated at any point where
c                        interpolation is required.  in the
c                        two-dimensional case, the given data points
c                        must be on a rectangular grid, which need not
c                        be equally spaced.  the package cubspl contains
c                        seven routines.
c
c                        subroutine coeff1
c                          computes the coefficients for one-dimensional
c                          cubic spline interpolation using one of two
c                          boundary conditions at each end of the range.
c                            . second derivative given at boundary.
c                            . first derivative given at boundary.
c                            . periodic boundary condition.
c                            . first derivative determined by fitting a
c                              cubic to the four points nearest to the
c                              boundary.
c
c                        subroutine terp1
c                          using the coefficients computed by coeff1,
c                          this routine evaluates the function and/or
c                          first and second derivatives at any point
c                          where interpolation is required.
c
c                        subroutine coeff2
c                          computes the coefficients for two-dimensional
c                          bicubic spline interpolation with the same
c                          choice of boundary conditions as for coeff1.
c
c                        function terp2
c                          using the coefficients produced by coeff2,
c                          this subroutine evaluates the function or a
c                          selected derivative at any point where
c                          two-dimensional interpolation is required.
c
c                        subroutine trip
c                          a simple periodic, tridiagonal linear
c                          equation solver used by coeff1.
c
c                        subroutine search
c                          performs a binary search in a one-dimensional
c                          floating point table arranged in ascending
c                          order.  this routine is called by terp1 and
c                          terp2.
c
c                        subroutine intrp
c                          given coefficients provided by coeff1 and the
c                          position of the interpolation point in the
c                          independent variable table, this routine
c                          performs one-dimensional interpolation for
c                          the function value, first and second
c                          derivative, as desired.  this routine is
c                          called by terp1 and terp2.
c
c access cards           *fortran,s=ulib,n=cubspl
c                        *cosy
c                          these cards access all seven routines of the
c                          package, cubspl.
c
c space required         total space for all seven routines is
c                        2243 (octal) = 1187 (decimal).
c
c entry points           coeff1, terp1, coeff2, terp2, trip, search,
c                        intrp
c
c special conditions     tables of independent variables must be
c                        arranged in ascending order.  for
c                        two-dimensional interpolation, the data points
c                        must lie on a rectangular mesh.
c
c common blocks          none
c
c i/o                    none
c
c precision              single
c
c required ulib          none
c routines
c
c specialist             cicely ridley, ncar, boulder, colorado  80303
c
c language               fortran
c
c history                this package is based on the routines
c                            la e 102a, spl1d1
c                            la e 103a, spl1d2
c                            la e 104a, spl2d1
c                            la e 105a, spl2d2
c                        of the los alamos cubic spline package written
c                        by thomas j. jordan and bertha fagan, 1968.
c                        the routines have been streamlined and
c                        standardized.  the algorithm for
c                        two-dimensional interpolation is considerably
c                        modified.
c
c
      subroutine coeff1(n, x, f, w, iop, int, wk)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56   6/14/01  
C...Switches: -p4 -yb
      use Vterppars
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer n, int
      integer, dimension(2) :: iop
      real, dimension(n) :: x
      real, dimension(int*(n-1) +1):: w, f
      real, dimension(n,*) :: wk
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer::index,j0,i,jm,nn,mk,ml,i1,j1,j2,j3,j4,i2,in
      real::xxx,y2,b2,xxy
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      integer ii
      real terp
C-----------------------------------------------
c
c
c dimension of           x(n),f(int*(n-1)+1),w(int*(n-1)+1),iop(2),
c arguments              wk(3*n+1)
c
c latest revision        february 1974
c
c usage                  call coeff1(n,x,f,w,iop,int,wk)
c
c arguments
c
c on input               n
c                          the number of data points.  n must be at
c                          least 4.
c
c                        x
c                          table of n independent variable values in
c                          ascending order.  dimension of x in calling
c                          program must be at least n.
c
c                        f
c                          table of n corresponding dependent variable
c                          values.  the values are separated by interval
c                          int.  this is usually unity for
c                          one-dimensional interpolation.  other values
c                          are useful when coeff1 is incorporated in a
c                          two-dimensional interpolation scheme (see
c                          coeff2).  dimension of f in the calling
c                          program must be at least (int*(n-1)+1).
c
c                        iop
c                          two element integer array defining boundary
c                          conditions at x(1) and x(n) according to the
c                          following code.
c
c                          for iop(1)
c                          = 1  second derivative given at x(1).  place
c                               value of second derivative in w(1)
c                               before call to coeff1.
c                          = 2  first derivative given at x(1).  place
c                               value of first derivative in w(1) before
c                               call.
c                          = 3  periodic boundary condition.  x(1) and
c                               x(n) are equivalent points.  f(1) and
c                               f(int*(n-1)+1) are equal.
c                          = 4  the first derivative at x(1) is
c                               calculated by fitting a cubic to points
c                               x(1) through x(4).
c                          similarly, iop(2) defines the boundary
c                          condition at x(n).  when iop(2) = 1 (or 2),
c                          the value of the second (or first) derivative
c                          must be placed in w(int*(n-1)+1).  note that
c                          if iop(1) = 3, consistency demands that
c                          iop(2) = 3 also.
c
c                        int
c                          spacing in f and w tables.  for
c                          one-dimensional interpolation this will
c                          usually be unity.
c
c                        wk
c                          work area of dimension at least (3*n+1).
c
c on output              w
c                          table of second derivatives corresponding to
c                          given x and f values.  the separation of
c                          tabular entries is int (see above).
c                          dimension of w in the calling program must be
c                          at least (int*(n-1)+1).
c
c                          the arrays x, f, w are used as input for the
c                          routine terp1, which performs interpolation
c                          at a given value of the independent variable.
c
c space required         654 (octal) = 428 (decimal)
c
c timing                 the timing is linearly proportional to n, the
c                        number of data points.  for 21 data points, the
c                        time on the ncar cdc 7600 was approximately
c                        .24 milliseconds.
c
c
c
c arithmetic statement function for interpolation
c
c the following call is for gathering statistics on library use at ncar
c
c start to set up tridiagonal system
c
      j0 = 1
      do i = 2, n
         jm = j0
         j0 = j0 + int
         wk(i,1) = x(i) - x(i-1)
         wk(i,2) = (f(j0)-f(jm))/wk(i,1)
         wk(i,3) = wk(i,1)/6.
         wk(i,1) = wk(i,1)/3.
      end do
      nn = n
      mk = iop(1)
      ml = iop(2)
c
c apply boundary conditions at boundary 1
c
      go to (102,103,104,105) mk
c
c second derivative given at boundary 1
c
  102 continue
      wk(2,2) = wk(3,2) - wk(2,2) - wk(2,3)*w(1)
      wk(2,3) = 0.
      wk(2,1) = wk(2,1) + wk(3,1)
      i1 = 2
      nn = nn - 1
      go to 106
c
c first derivative given at boundary 1
c
  103 continue
      xxx = w(1)
      wk(1,2) = wk(2,2) - w(1)
      wk(2,2) = wk(3,2) - wk(2,2)
      wk(1,3) = 0.
      wk(1,1) = wk(2,1)
      wk(2,1) = wk(2,1) + wk(3,1)
      i1 = 1
      go to 106
c
c periodic boundary condition
c
  104 continue
      y2 = wk(2,2)
      b2 = wk(2,1)
      wk(2,2) = wk(3,2) - wk(2,2)
      wk(2,1) = wk(3,1) + wk(2,1)
      i1 = 2
      nn = nn - 1
      go to 106
c
c first derivative at boundary 1 from 4 point interpolation.
c
  105 continue
      a12 = x(1) - x(2)
      a13 = x(1) - x(3)
      a14 = x(1) - x(4)
      a23 = x(2) - x(3)
      a24 = x(2) - x(4)
      a34 = x(3) - x(4)
      j1 = 1
      j2 = j1 + int
      j3 = j2 + int
      j4 = j3 + int
      w(1) = terp(f(j1),f(j2),f(j3),f(j4))
      go to 103
c
c compute tridiagonal arrays
c
  106 continue
      i2 = n - 2
      wk(3:i2,2) = wk(4:i2+1,2) - wk(3:i2,2)
      wk(3:i2,1) = wk(4:i2+1,1) + wk(3:i2,1)
c
c apply boundary conditions at boundary 2.
c
      in = ii(n,int)
      go to (108,109,110,111) ml
c
c second derivative given at boundary 2.
c
  108 continue
      wk(n-1,2) = wk(n,2) - wk(n-1,2) - wk(n,3)*w(in)
      wk(n,3) = 0.
      wk(n-1,1) = wk(n-1,1) + wk(n,1)
      nn = nn - 1
      go to 112
c
c first derivative given at boundary 2.
c
  109 continue
      xxy = w(in)
      wk(n-1,2) = wk(n,2) - wk(n-1,2)
      wk(n,2) = (-wk(n,2)) + w(in)
      wk(n-1,1) = wk(n-1,1) + wk(n,1)
      wk(1,4) = 0.
      go to 112
c
c periodic boundary condition
c
  110 continue
      wk(n-1,2) = wk(n,2) - wk(n-1,2)
      wk(n,2) = y2 - wk(n,2)
      wk(n-1,1) = wk(n-1,1) + wk(n,1)
      wk(n,1) = wk(n,1) + b2
      wk(1,4) = wk(2,3)
      go to 112
c
c first derivative at boundary 2 from 4 point interpolation.
c
  111 continue
      a12 = x(n) - x(n-1)
      a13 = x(n) - x(n-2)
      a14 = x(n) - x(n-3)
      a23 = x(n-1) - x(n-2)
      a24 = x(n-1) - x(n-3)
      a34 = x(n-2) - x(n-3)
      j1 = in
      j2 = j1 - int
      j3 = j2 - int
      j4 = j3 - int
      w(in) = terp(f(j1),f(j2),f(j3),f(j4))
      go to 109
  112 continue
c
c solve tridiagonal system
c
      call trip(nn,wk(i1,3),wk(i1,1),wk(i1+1,3),wk(i1,2),
     1          w(ii(i1,int)),int)
      go to (114,114,113,114) mk
  113 continue
      w(1) = w(in)
  114 continue
      return 
      end subroutine coeff1
c
c
      subroutine coeff2(nx, x, ny, y, f, fxx, fyy, fxxyy, idm, ibd,
     1                  wk)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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, idm
      integer, dimension(4) :: ibd
      real, dimension(nx) :: x
      real, dimension(ny) :: y
      real, dimension(idm,ny) :: f, fxx, fyy, fxxyy
      real, dimension(3*max(nx,ny)+1) :: wk
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer, dimension(2) :: iloc, jloc
      integer :: i,j
C-----------------------------------------------
      data iloc(1), iloc(2), jloc(1), jloc(2)/1, 1, 4, 4/
c
c
c dimension of           x(nx),y(ny),f(idm,ny),fxx(idm,ny),fyy(idm,ny),
c arguments              fxxyy(idm,ny),ibd(4),wk(3*max0(nx,ny)+1)
c                        (idm must be .ge. nx)
c
c latest revision        february 1974
c
c usage                  call coeff2 (nx,x,ny,y,f,fxx,fyy,fxxyy,idm,ibd,wk)
c
c arguments
c
c on input               nx
c                          number of grid points in the x-direction.  nx
c                          must be at least 4.
c
c                        x
c                          table of nx values of the first independent
c                          variable arranged in ascending order.
c                          dimension of x in the calling program must be
c                          at least nx.
c
c                        ny
c                          number of grid points in the y-direction. ny
c                          must be at least 4.
c
c                        y
c                          table of ny values of the second independent
c                          variable arranged in ascending order.
c                          dimension of y in the calling program must be
c                          at least ny.
c
c                        f
c                          two dimensional array of function values at
c                          the grid points defined by the arrays x and
c                          y.  dimension of f in the calling program is
c                          (idm, nyy) where
c                              idm .ge. nx
c                              nyy .ge. ny
c
c                        idm
c                          first dimension in the calling program of
c                          arrays f, fxx, fyy, fxxyy.  idm must be at
c                          least nx.
c
c                        ibd
c                          four element integer array defining boundary
c                          conditions according to the following code.
c                          for ibd(1)
c                          = 1  the second derivative of f with respect
c                               to x is given at (x(1),y(j)) for
c                               j = 1,ny,1.  values of this second
c                               derivative must be placed in fxx(1,j)
c                               for j = 1,ny,1, before calling coeff2.
c                          = 2  the first derivative of f with respect
c                               to x is given at (x(1),y(j)) for
c                               j = 1,ny,1.  values of the derivative
c                               must be placed in fxx(1,j) for
c                               j = 1,ny,1 before calling coeff2.
c                          = 3  periodic boundary condition in the
c                               x-direction.  (x(1),y(j)) and
c                               and (x(nx),y(j)) are equivalent points
c                               for j = 1,ny,1.  f(1,j) and f(nx,j) are
c                               equal.
c                          = 4  the first derivative of f with respect
c                               to x at (x(1),y(j)) is computed by
c                               fitting a cubic to f(1,j) through f(4,j)
c                               for j = 1,ny,1.
c
c                          similarly, ibd(2) defines the boundary
c                          condition at (x(nx),y(j)) for j = 1,ny,1.
c                          when ibd(2) = 1 (or 2) the values of the
c                          second (or first) derivative of f with
c                          respect to x are placed in fxx(nx,j) for
c                          j = 1,ny,1.
c                            note that if ibd(1) = 3, consistency
c                            requires that ibd(2) = 3 also.
c                          for ibd(3)
c                          = 1  the second derivative of f with respect
c                               to y is given at (x(i),y(1)).  place
c                               values of the derivative in fyy(i,1) for
c                               i = 1,nx,1 before calling coeff2.
c                          = 2  the first derivative of f with respect
c                               to y is given at (x(i),y(1)).  values of
c                               this derivative must be placed in
c                               fyy(i,1) for i = 1,nx,1 before calling
c                               coeff2.
c                          = 3  periodic boundary condition in the
c                               y-direction.  (x(i),y(1)) and
c                               (x(i),y(ny)) are equivalent points.
c                               f(i,1) and f(i,ny) are equal.
c                          = 4  the first derivative of f with respect
c                               to y at (x(i),y(1)) is computed by
c                               fitting a cubic to f(i,1) through f(i,4)
c                               for i = 1,nx,1.
c
c                          similary, ibd(4) defines the boundary
c                          condition at (x(i),y(ny)) for i = 1,nx,1 and
c                          given derivative values are placed in
c                          fyy(i,ny).
c                            note that consistency demands that if
c                            ibd(3) = 3, then ibd(4) = 3 also.
c
c                        wk
c                          work area of dimension at least
c                          (3*max0(nx,ny)+1)
c
c on output              fxx
c                          array of second derivatives of f with respect
c                          to x computed by coeff2.  fxx(i,j) is
c                          derivative at (x(i),y(j)).  as for f,
c                          dimension of fxx in the calling program is
c                          (idm,nyy).
c
c                        fyy
c                          array of second derivatives of f with respect
c                          to y computed by coeff2.  dimension of fyy in
c                          the calling program is (idm,nyy).
c
c                        fxxyy
c                          array of fourth derivatives
c                          (d/dx)**2*(d/dy)**2*f, computed by coeff2.
c                          dimension of fxxyy in the calling program is
c                          (idm,nyy).
c
c                        the arrays x, y, f, fxx, fyy, fxxyy are used as
c                        input for the routine terp2 which performs
c                        interpolation at required values of the two
c                        independent variables.
c
c space required         370 (octal) = 248 (decimal)
c
c timing                 the timing is proportional to nx*ny.  for a
c                        21 x 21 grid of data points, the time taken on
c                        the ncar 7600 was 19.5 milliseconds.
c
c
c the following call is for gathering statistics on library use at ncar
c
c compute fxx
c
      do j = 1, ny
         call coeff1(nx, x, f(1,j), fxx(1,j), ibd(1), 1, wk)
      end do
c
c compute fyy
c
      do i = 1, nx
         call coeff1(ny, y, f(i,1), fyy(i,1), ibd(3), idm, wk)
      end do
c
c check for periodic boundary condition in both directions
c
      if (ibd(1) /= 3) then
         if (ibd(3) == 3) go to 105
c
c calculate fxxyy along left and right boundaries
c
         call coeff1(ny, y, fxx(1,1), fxxyy(1,1), jloc, idm, wk)
         call coeff1(ny, y, fxx(nx,1), fxxyy(nx,1), jloc, idm, wk)
         go to 106
      endif
c
c periodic in x direction . calculate fxxyy along lower and upper
c boundaries.
c
      call coeff1(nx, x, fyy(1,1), fxxyy(1,1), ibd(1), 1, wk)
      call coeff1(nx, x, fyy(1,ny), fxxyy(1,ny), ibd(1), 1, wk)
c
c calculate remaining fxxyy
c
      do i = 1, nx
         call coeff1(ny, y, fxx(i,1), fxxyy(i,1), iloc, idm, wk)
      end do
      go to 108
  105 continue
c
c periodic in y direction. calculate fxxyy along left and right
c boundaries.
c
      call coeff1(ny, y, fxx(1,1), fxxyy(1,1), ibd(3), idm, wk)
      call coeff1(ny, y, fxx(nx,1), fxxyy(nx,1), ibd(3), idm, wk)
  106 continue
c
c calculate remaining fxxyy
c
      do j = 1, ny
         call coeff1(nx, x, fyy(1,j), fxxyy(1,j), iloc, 1, wk)
      end do
  108 continue
      return 
      end subroutine coeff2
      subroutine cubspl(h, c, nprofn, nprof)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 nprofn, nprof
      real h
      real, dimension(nprofn,4) :: c
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n1, n, k
      real :: d2, ch4
C-----------------------------------------------
c ********** ********** ********** ********** ********** **********
c                                                                 *
c  this subroutine evaluates the coefficients for                 *
c        the cubic spline interpolation of the profiles.          *
c        derivatives in r = 0 and r = rplasm                      *
c        evaluated from divided differences                       *
c                                                                 *
c ********** ********** ********** ********** ********** **********
c ---------- ---------- ---------- ---------- ---------- ----------
      n1 = nprof - 1
c ---------- ---------- ---------- ---------- ---------- ----------
c  evaluate finite differences and store in c(j,4)
      c(:n1,4) = (c(2:n1+1,1)-c(:n1,1))/h
c ---------- ---------- ---------- ---------- ---------- ----------
c  forward evaluation of e(j) (=c(j,2)) and f(j) (=c(j,3))
      c(1,2) = 0.
      d2 = c(2,4) - c(1,4)
      c(1,3) = c(1,4) - d2/2.E0
      do n = 2, n1
         c(n,2) = -1./(4. + c(n-1,2))
         c(n,3) = (c(n-1,3)-3.*(c(n-1,4)+c(n,4)))*c(n,2)
      end do
c ---------- ---------- ---------- ---------- ---------- ----------
c   backward evaluation of the derivatives s(j) (=c(2,j))
c      and of higher coefficients
      c(nprof,2) = c(n1,4)
      c(nprof,3) = 0.
      c(nprof,4) = 0.
      do k = 1, n1
         n = nprof - k
         c(n,2) = c(n,2)*c(n+1,2) + c(n,3)
         ch4 = (c(n,2)+c(n+1,2)-2.*c(n,4))/h
         c(n,3) = 2.*((c(n,4)-c(n,2))/h-ch4)
         c(n,4) = 6.*ch4/h
      end do
      return 
      end subroutine cubspl
      subroutine dbcevl1(x, nx, y, ny, c, ic, xl, yl, pds, ier, icalc)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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, ic, ier, icalc
      real xl, yl
      real, dimension(*) :: x, y
      real, dimension(2,ic,1) :: c
      real, 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 :: hx, hy
      real, dimension(2) :: sux, suy, su, svx, sv, sxy
      real :: 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 spln0, spln1, spln2
C-----------------------------------------------
c---this is a special version of dbcevl,used by the onetwo suite
c---of subroutines. It differs form the imsl version in the calling
c---arguments and the calculations below are reordered for efficiency
c---That  is,many times we dont 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% improvent
c---in execution time.    HSJ
c                                  specifications for local variables
c                                  first executable statement
      ier = 0
      hx = x(2) - x(1)
      hy = y(2) - y(1)
c     The following computation of lx,ly is a speed-up modification
c     for equispaced grids (Bob H. 10/22/90):
      lx = (xl - x(1))/hx + 1
      ly = (yl - y(1))/hy + 1
      if (lx < 1) then
         lx = 1
         ier = 33
      else if (lx > nx) then
         lx = nx
         ier = 35
      endif
      if (ly < 1) then
         ly = 1
         ier = 34
      else if (ly > ny) then
         ly = ny
         ier = 36
      endif
      lxp1 = lx + 1
      u = (xl - x(lx))/hx
      v = (yl - y(ly))/hy
      k = 2*ly
      kp1 = k + 1
      kp2 = k + 2
      km1 = k - 1
      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),
     1      c(1,lxpl,kp2),hy,v)
         svx(l) = spln0(c(2,lxpl,km1),c(2,lxpl,kp1),c(2,lxpl,k),
     1      c(2,lxpl,kp2),hy,v)
         if (icalc >= 3) then
            su(l) = spln0(c(1,lx,j),c(1,lxp1,j),c(2,lx,j),
     1         c(2,lxp1,j),hx,u)
            suy(l) = spln0(c(1,lx,i),c(1,lxp1,i),c(2,lx,i),
     1         c(2,lxp1,i),hx,u)
            if (icalc >= 4) then
               sux(l) = spln1(c(1,lx,j),c(1,lxp1,j),c(2,lx,j),
     1            c(2,lxp1,j),hx,u)
               sxy(l) = spln1(c(1,lx,i),c(1,lxp1,i),c(2,lx,i),
     1            c(2,lxp1,i),hx,u)
            endif
         endif
      end do
      pds(1) = spln0(sv(1),sv(2),svx(1),svx(2),hx,u)
      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)
      if (ier > 0) call uertst (ier, 6Hdbcevl)
      return 
      end subroutine dbcevl1
      subroutine der4v(n, h, y, z, nz, ndim)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 n, nz, ndim
      real h
      real, dimension(ndim,5) :: y
      real, dimension(ndim) :: z
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i
      real :: d
C-----------------------------------------------
c----------------
c  given y(1:nz,j) at x(j),j=1..5 eqdistant separated at h,
c   find derivative z(1:ndim) at x(n),n=1..5
c------------------------------
      d = 12.E0*h
      select case (n) 
      case default
         z(:nz) = ((-25.*y(:nz,1))+48.*y(:nz,2)-36.*y(:nz,3)
     1      +16.*y(:nz,4)-3.*y(:nz,5))/d
         return 
      case (2) 
         z(:nz) = ((-3.*y(:nz,1))-10.*y(:nz,2)+18.*y(:nz,3)
     1      -6.*y(:nz,4)+y(:nz,5))/d
         return 
      case (3) 
         z(:nz) = (y(:nz,1)-8.*y(:nz,2)+8.*y(:nz,4)-y(:nz,5))/d
         return 
      case (4) 
         z(:nz) = ((-y(:nz,1))+6.*y(:nz,2)-18.*y(:nz,3)
     1      +10.*y(:nz,4)+3.*y(:nz,5))/d
         return 
      case (5) 
         z(:nz) = (25.*y(:nz,5)-48.*y(:nz,4)+36.*y(:nz,3)
     1      -16.*y(:nz,2)+3.*y(:nz,1))/d
         return 
      end select
      end subroutine der4v
      subroutine deriv4(n, h, y, z)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 n
      real h, z
      real, dimension(5) :: y
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      real :: d
C-----------------------------------------------
      d = 12.*h
      select case (n) 
      case default
         z = ((-25.*y(1))+48.*y(2)-36.*y(3)+16.*y(4)-3.*y(5))/d
         return 
      case (2) 
         z = ((-3.*y(1))-10.*y(2)+18.*y(3)-6.*y(4)+y(5))/d
         return 
      case (3) 
         z = (y(1)-y(5)+8.*(y(4)-y(2)))/d
         return 
      case (4) 
         z = ((-y(1))+6.*y(2)-18.*y(3)+10.*y(4)+3.*y(5))/d
         return 
      case (5) 
         z = (3.*y(1)-16.*y(2)+36.*y(3)-48.*y(4)+25.*y(5))/d
         return 
      end select
      end subroutine deriv4
c
      subroutine fterp1(f, fxx, fyy, nua, nta, us, thets, tempx,
     1                  tempy)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 nua, nta
      real, dimension(nua,nta) :: f, fxx, fyy
      real, dimension(nua) :: us
      real, dimension(nta) :: thets
      real, dimension(nua,nta) :: tempx, tempy
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, nuam, j, ntam, ii, jj
      real :: qx, qy, dthets, dthetsp, thets12, thets12p, dusp, us12, 
     1   us12p, dus, fx12, fx12p, fy12, fy12p, us1, usnu, thets1, 
     2   thetsnt, dudthets, u, thet
C-----------------------------------------------
c
c  Set up for bilinear interpolation of derivatives of f off
c  a uniform mesh in u and theta:
c
 
c  Calculate derivatives at mesh pts (error of order delta-v**3
c  or delta-theta**3).
c
c  Interior mesh pts:
      do i = 2, nuam - 1
         do j = 2, ntam - 1
            qx = ((us(i-1)-us(i))/(us(i+1)-us(i)))**2
            fxx(i,j) = (qx*f(i+1,j)+(1.-qx)*f(i,j)-f(i-1,j))/(qx
     1         *(us(i+1)-us(i))-(us(i-1)-us(i)))
            qy = ((thets(j-1)-thets(j))/(thets(j+1)-thets(j)))**2
            fyy(i,j) = (qy*f(i,j+1)+(1.-qy)*f(i,j)-f(i,j-1))/(qy
     1         *(thets(j+1)-thets(j))-(thets(j-1)-thets(j)))
         end do
      end do
 
c  Now do the edges of the mesh:
      dthets = thets(2) - thets(1)
      dthetsp = thets(ntam) - thets(ntam-1)
      thets12 = 0.5*(thets(1)+thets(2))
      thets12p = 0.5*(thets(ntam-1)+thets(ntam))
      dusp = us(nuam) - us(nuam-1)
      us12 = 0.5*(us(1)+us(2))
      us12p = 0.5*(us(nuam-1)+us(nuam))
      dus = us(2) - us(1)
 
      do i = 2, nuam - 1
         qx = ((us(i-1)-us(i))/(us(i+1)-us(i)))**2
         fxx(i,1) = (qx*f(i+1,1)+(1.-qx)*f(i,1)-f(i-1,1))/
     1              (qx*(us(i+1)-us(i))-(us(i-1)-us(i)))
         fxx(i,ntam) = (qx*f(i+1,ntam)+(1.-qx)*f(i,ntam)-f(i-1,ntam))
     1      /(qx*(us(i+1)-us(i))-(us(i-1)-us(i)))
      end do
 
      do j = 1, ntam
         fx12 = (f(2,j)-f(1,j))/dus
         fxx(1,j) = fx12 + (fxx(2,j)-fx12)/(us(2)-us12)*(us(1)-us12)
         fx12p = (f(nuam,j)-f(nuam-1,j))/dusp
         fxx(nuam,j) = fx12p + (fx12p - fxx(nuam-1,j))/(us12p-
     1      us(nuam-1))*(us(nuam)-us12p)
      end do
 
      do j = 2, ntam - 1
         fyy(1,j) = 0.0
         qy = ((thets(j-1)-thets(j))/(thets(j+1)-thets(j)))**2
         fyy(nuam,j) = (qy*f(nuam,j+1)+(1.-qy)*f(nuam,j)-f(nuam,j-1))
     1      /(qy*(thets(j+1)-thets(j))-(thets(j-1)-thets(j)))
      end do
 
      do i = 1, nuam
         fy12 = (f(i,2)-f(i,1))/dthets
         fyy(i,1) = fy12 + (fyy(i,2)-fy12)/(thets(2)-thets12)
     1      *(thets(1)-thets12)
         fy12p = (f(i,ntam)-f(i,ntam-1))/dthetsp
         fyy(i,ntam) = fy12p + (fy12p - fyy(i,ntam-1))/(thets12p-
     1      thets(ntam-1))*(thets(ntam)-thets12p)
      end do
 
c  Now interpolate these derivatives onto a uniform mesh in
c  the u and theta directions:
 
      us1 = us(1)
      usnu = us(nuam)
      thets1 = thets(1)
      thetsnt = thets(ntam)
      dus = (usnu - us1)/(nuam - 1)
      dthets = (thetsnt - thets1)/(ntam - 1)
      dudthets = dus*dthets
 
      do i = 1, nuam
         u = us1 + (i - 1)*dus
         call search (u, us, nuam, ii)
         do j = 1, ntam
            thet = thets1 + (j - 1)*dthets
            call search (thet, thets, ntam, jj)
            tempx(i,j) = (fxx(ii,jj)*(u-us(ii+1))*(thet-thets(jj+1))
     1      -fxx(ii+1,jj)*(u-us(ii))*(thet-thets(jj+1))-fxx(ii,jj+1)
     2      *(u-us(ii+1))*(thet-thets(jj))+fxx(ii+1,jj+1)*(u-us(ii))
     3         *(thet-thets(jj)))/dudthets
            tempy(i,j) = (fyy(ii,jj)*(u-us(ii+1))*(thet-thets(jj+1))
     1      -fyy(ii+1,jj)*(u-us(ii))*(thet-thets(jj+1))-fyy(ii,jj+1)
     2      *(u-us(ii+1))*(thet-thets(jj))+fyy(ii+1,jj+1)*(u-us(ii))
     3         *(thet-thets(jj)))/dudthets
         end do
      end do
 
c
      fxx(:nuam,:ntam) = tempx(:nuam,:ntam)
      fyy(:nuam,:ntam) = tempy(:nuam,:ntam)
 
      return 
      end subroutine fterp1
c
      subroutine fterp2(u0, thet0, i, j, usp, thetsp, dudthets, fxx,
     1                  fyy, nua, nta, dfdx, dfdy)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 i, j, nua, nta
      real u0, thet0, dudthets, dfdx, dfdy
      real, dimension(nua) :: usp
      real, dimension(nta) :: thetsp
      real, dimension(nua,nta) :: fxx, fyy
C-----------------------------------------------
      dfdx = (fxx(i,j)*(u0-usp(i+1))*(thet0-thetsp(j+1))-fxx(i+1,j)
     1   *(u0-usp(i))*(thet0-thetsp(j+1))-fxx(i,j+1)*(u0-usp(i+1))
     2   *(thet0-thetsp(j))+fxx(i+1,j+1)*(u0-usp(i))
     3   *(thet0-thetsp(j)))/dudthets
      dfdy = (fyy(i,j)*(u0-usp(i+1))*(thet0-thetsp(j+1))-fyy(i+1,j)
     1   *(u0-usp(i))*(thet0-thetsp(j+1))-fyy(i,j+1)*(u0-usp(i+1))
     2   *(thet0-thetsp(j))+fyy(i+1,j+1)*(u0-usp(i))
     3   *(thet0-thetsp(j)))/dudthets
      return 
      end subroutine fterp2
      subroutine inter3(f, z, y, x1, h)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real f, z, x1, h
      real, dimension(3) :: y
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      real :: a1, a2, a3, h2
C-----------------------------------------------
c---inter interpolates between 3-pts. xi=x1+(i-1)*h and find f at z
c-------------------------
      a1 = z - x1
      a2 = a1 - h
      a3 = a2 - h
      h2 = h*h
      f = a1*a2*y(3)/2./h2
      f = f - a1*a3*y(2)/h2
      f = f + a2*a3*y(1)/2./h2
      return 
      end subroutine inter3
      subroutine intern(f, z, y1, y2, y3, x1, x2, x3, n)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 n
      real z, x1, x2, x3
      real, dimension(n) :: f, y1, y2, y3
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i
      real :: a1, a2, a3, b1, b2, b3
C-----------------------------------------------
c---inter interpolates between 3-pts. xi and find f at z
c   f is an array of dimension n
c-------------------------
      a1 = z - x1
      a2 = z - x2
      a3 = z - x3
      b1 = x1 - x2
      b2 = x1 - x3
      b3 = x2 - x3
      f = a1*a2*y3/(b2*b3)
      f = f - a1*a3*y2/(b1*b3)
      f = f + a2*a3*y1/(b1*b2)
      return 
      end subroutine intern
      subroutine intrp(n, x, f, w, y, i, int, tab, itab)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 n, i, int
      real y
      integer, dimension(3) :: itab
      real, dimension(1) :: x, f, w
      real, dimension(3) :: tab
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: index, i0, ip
      real :: flk, flp, fl0, a, b, c
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      integer ii
C-----------------------------------------------
c     logical         itab(3)
c
c arithmetic statement function used to locate entries in f and w arrays
c
c
c perform interpolation or extrapolation
c
      flk = x(i+1) - x(i)
      flp = x(i+1) - y
      fl0 = y - x(i)
      i0 = ii(i,int)
      ip = i0 + int
      if (itab(1) == 1) then
c
c calculate f(y)
c
         a = (w(i0)*flp**3+w(ip)*fl0**3)/(6.*flk)
         b = (f(ip)/flk-w(ip)*flk/6.)*fl0
         c = (f(i0)/flk-w(i0)*flk/6.)*flp
         tab(1) = a + b + c
      endif
      if (itab(2) == 1) then
c
c calculate first derivative at y
c
         a = (w(ip)*fl0**2-w(i0)*flp**2)/(2.*flk)
         b = (f(ip)-f(i0))/flk
         c = (w(i0)-w(ip))*flk/6.
         tab(2) = a + b + c
      endif
c
c calculate second derivative at y
c
      if (itab(3) == 1) tab(3) = (w(i0)*flp+w(ip)*fl0)/flk
      return 
      end subroutine intrp
 
 
c===================================================================
c===================================================================
 
 
c      The following subroutine intrpp,copya,icsicu,icsevu,uertst
c          are taken from onetwo, and are for purposes of creating
c          spline profiles of density, etc.
 
      subroutine intrpp(ilow, iup, x, y, nold, xnew, ynew, nnew)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 nold, nnew
      character ilow*4, iup*4
      real, dimension(nold) :: x, y
      real, dimension(nnew) :: xnew, ynew
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      integer, parameter :: kjx = 151
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: iord, i, ier
      real, dimension(4) :: bpar
      real, dimension(kjx,3) :: c
      real, dimension(kjx) :: xt, yt
C-----------------------------------------------
c     ynew as a function of xnew given y as a function of x.  The
c     boundary conditions are specified as follows:
c       ilow : 'zero', set derivative at lower x value to zero
c             #'free', let derivative at lower x value be free
c       iup  : 'zero', set derivative at upper x value to zero
c             #'free', let derivative at upper x value be free
c------------------------------------------------------------------
c
c       must assure that x(1).le.x(2)....
c
      if (x(2) <= x(1)) go to 10
      iord = 0
c
   60 continue
      bpar = 0.
      if (ilow == 'zero') then
         bpar(1) = 1.
         bpar(2) = 6.*(y(2)-y(1))/(x(2)-x(1))**2
      endif
      if (iup == 'zero') then
         bpar(3) = 1.
         bpar(4) = -6.*(y(nold)-y(nold-1))/(x(nold)-x(nold-1))**2
      endif
c
      call icsicu (x, y, nold, bpar, c, kjx, ier)
c
      if (ier /= 0) go to 20
c
      call icsevu (x, y, nold, c, kjx, xnew, ynew, nnew, ier)
c
      if (iord == 0) return 
c
      x(:nold) = xt(:nold)
      y(:nold) = yt(:nold)
c
      return 
c
   10 continue
      iord = 1
c
      xt(:nold) = x(:nold)
      yt(:nold) = y(:nold)
c
      x(:nold) = xt(nold:1:(-1))
      y(:nold) = yt(nold:1:(-1))
c
      go to 60
c
c
   20 continue
      write (6, 40) ier, iord, nold
   40 format('1intrp    ier=',i3,'   iord=',i1,'   nold=',i3,/,
     1    '  i','     x      ','     y      ')
      write (6, 80) (i,x(i),y(i),i=1,nold)
   80 format(i5,2e12.4)
c
      call exit (1)
c
      end subroutine intrpp
      subroutine intrv(y, x, ytab, h, x1, nn, ndim)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 nn, ndim
      real x, h, x1
      real, dimension(ndim) :: y
      real, dimension(ndim,4) :: ytab
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: j
      real :: a1, a2, a3, a4, h3
C-----------------------------------------------
c------------------------
c  given ytab(1:nn,xx(i)),i=1,..4, xx(i)=x1+(i-1)*h, find
c     y(1:nn) at x
c  ndim=dimension of y as in calling routine
c----------------------
      a1 = x - x1
      a2 = a1 - h
      a3 = a2 - h
      a4 = a3 - h
      h3 = h*h*h
      y(:nn) = -(a3*a4)*a2*ytab(:nn,1)/(6.*h3)
      y(:nn) = y(:nn) + (a3*a4)*a1*ytab(:nn,2)/2./h3
      y(:nn) = y(:nn) - (a1*a2)*a4*ytab(:nn,3)/2./h3
      y(:nn) = y(:nn) + (a1*a2)*a3*ytab(:nn,4)/6./h3
      return 
      end subroutine intrv
      subroutine intrv1(y, x, ytab, h, x1, nn, ndim, a1, a2, a3, a4)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 nn, ndim
      real h
      real, dimension(ndim) :: y, x
      real, dimension(ndim,4) :: ytab
      real, dimension(ndim) :: x1, a1, a2, a3, a4
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: j
      real :: h3
C-----------------------------------------------
c------------------------
c  given ytab(1:nn,4),i=1,..4, at xx(1:nn,i)=x1(1:nn)+(i-1)*h, find
c     y(1:nn) at x(1:nn)
c  ndim=dimension of y as in calling routine
c----------------------
      h3 = h*h*h
      a1(:nn) = x(:nn) - x1(:nn)
      a2(:nn) = a1(:nn) - h
      a3(:nn) = a2(:nn) - h
      a4(:nn) = a3(:nn) - h
      y(:nn) = -(a3(:nn)*a4(:nn))*a2(:nn)*ytab(:nn,1)/(6.*h3)
      y(:nn) = y(:nn) + (a3(:nn)*a4(:nn))*a1(:nn)*ytab(:nn,2)/2./h3
      y(:nn) = y(:nn) - (a1(:nn)*a2(:nn))*a4(:nn)*ytab(:nn,3)/2./h3
      y(:nn) = y(:nn) + (a1(:nn)*a2(:nn))*a3(:nn)*ytab(:nn,4)/6./h3
      return 
      end subroutine intrv1
      subroutine mcsevu(h, x1, y, ny, yc, ic, ns, s, xs, ier)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 ny, ic, ns, ier
      real h, x1
      real, dimension(ny) :: y
      real, dimension(ic,3) :: yc
      real, dimension(ns) :: s, xs
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer, dimension(1) :: is
      integer :: i
      real, dimension(ns) :: d
      real :: zero
C-----------------------------------------------
c--------------------
c  evaluation of cubic spline
c   given y(ny),yc(ny,3) at x(j)=x1+(j-1)*h   j=1...ny
c   evaluate s(1:ns) at xs(1:ns)
c    xs(1:ns) should be less than x(ny)
c----------------------------------
      data zero/0.0/
      is(:ns) = (xs - x1)/h
      is(:ns) = min0(ny - 2,is(:ns))
      d = xs - is(:ns)*h - x1
      is(:ns) = is(:ns) + 1
 
c     do i=1,ns
c       wk(i)=yc(is(i),3)
c     enddo
c     do i=1,ns
c       s(i)=wk(i)*d(i)
c     enddo
c     do i=1,ns
c       wk(i)=yc(is(i),2)
c     enddo
c     do i=1,ns
c       s(i)=(s(i)+wk(i))*d(i)
c     enddo
c     do i=1,ns
c       wk(i)=yc(is(i),1)
c     enddo
c     do i=1,ns
c       s(i)=(s(i)+wk(i))*d(i)
c     enddo
c     do i=1,ns
c       wk(i)=y(is(i))
c     enddo
c     do i=1,ns
c       s(i)=s(i)+wk(i)
c     enddo
      s = ((yc(is(:ns),3)*d+yc(is(:ns),2))*d+yc(is(:ns),1))*d+
     1   y(is(:ns))
      return 
      end subroutine mcsevu
      subroutine mcsevu1(h, x1, y, ny, yc, ic, ns, s, xs, ier)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 ny, ic, ns, ier
      real h, x1
      real, dimension(ny) :: y
      real, dimension(ic,3) :: yc
      real, dimension(ns) :: s, xs
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer, dimension(ns) :: is
      integer :: i
      real, dimension(ns) :: d, wk
C-----------------------------------------------
c---------------------------
c   given y(1:ny),yc(1:ny,1:3) at x(i)=x1+(i-1)*h
c   find s(1:ns)=first derivative of function at xs(1:ns)
c-----------------------------
      is = (xs - x1)/h
      is = min0(ny - 2,is)
      d = xs - (is*h + x1)
      is = is + 1
      wk = yc(is,3)
      s = 3.*wk*d
      wk = yc(is,2)
      s = (s + 2.*wk)*d
      wk = yc(is,1)
      s = s + wk
      return 
      end subroutine mcsevu1
c
      function simp (m, dx, fx)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/01  
C...Switches: -p4 -yb
      implicit none
      real simp
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer m
      real dx
      real, dimension(1) :: fx
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i
C-----------------------------------------------
c
c $$$ Function to integrate using Simpson's rule.
c     Arguments:
c       m  : number of points
c       dx : uniform increment of independent variable
c       fx : function to be integrated
c
      simp = fx(1) + fx(m)
      simp = simp + sum(2.*fx(2:m-1))
      simp = simp + sum(2.*fx(2:m-1:2))
      simp = dx/3.*simp
      return 
      end function simp

      subroutine terp1(n, x, f, w, y, int, tab, itab)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 n, int
      real y
      integer, dimension(3) :: itab
      real, dimension(1) :: x, f, w
      real, dimension(3) :: tab
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i
C-----------------------------------------------
c
c
c dimension of           x(n),f(int*(n-1)+1),w(int*(n-1)+1),tab(3),
c arguments              itab(3)
c
c latest revision        february 1974
c
c usage                  call terp1 (n,x,f,w,y,int,tab,itab)
c
c arguments
c
c on input               n
c                          the number of data points.  n must be at
c                          least 4.
c
c                        x
c                          table of n independent variable values in
c                          ascending order.  dimension of x in the
c                          calling program must be at least n.
c
c                        f
c                          table of n corresponding dependent variable
c                          values separated by interval int, usually
c                          unity for one-dimensional interpolation.
c                          dimension of f in the calling program must be
c                          at least (int*(n-1)+1).
c
c                        w
c                          table of second derivatives computed by
c                          coeff1.  the separation of tabular entries is
c                          int.  dimension of w in the calling program
c                          must be at least (int*(n-1)+1).
c
c                        y
c                          value of the independent variable at which
c                          interpolation is required.  if y lies outside
c                          the range of the table, extrapolation takes
c                          place.
c
c                        int
c                          spacing of tabular entries in f and w arrays.
c                          this is usually unity for one-dimensional
c                          interpolation.
c
c                        itab
c                          three element integer array defining
c                          interpolation to be performed at y.
c                            if itab(1) = 1, the function value is
c                                            returned in tab(1).
c                            if itab(2) = 1, the first derivative is
c                                            returned in tab(2).
c                            if itab(3) = 1, the second derivative is
c                                            returned in tab(3).
c                          if itab(i) = 0 for i = 1, 2 or 3, the
c                          corresponding function value or derivative is
c                          not computed and tab(i) is not referenced.
c
c on output              tab
c                          three element array in which interpolated
c                          function value, first and second derivatives
c                          are returned as dictated by itab (see above).
c
c space required         47 (octal) = 39 (decimal)
c
c timing                 this procedure is fast.  the maximum time for
c                        the binary search is proportional to alog(n).
c                        the time for function and derivative evaluation
c                        is independent of n.  for 21 data points the
c                        time taken on the ncar 7600 is about
c                        80 microseconds.
c
c
c the following call is for gathering statistics on library use at ncar
c
c perform search
c
      call search (y, x, n, i)
c
c carry out interpolation (or extrapolation)
c
      call intrp (n, x, f, w, y, i, int, tab, itab)
      return 
      end subroutine terp1
      function terp2 (xb, yb, nx, x, ny, y, f, fxx, fyy, fxxyy,
     1                     idm, ixd, iyd)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real terp2
      integer nx, ny, idm, ixd, iyd
      real xb, yb
      real, dimension(1) :: x, y
      real, dimension(idm,1) :: f, fxx, fyy, fxxyy
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer, dimension(3) :: itab
      integer :: i, j, i1, j1, jj, n
      real, dimension(2) :: ff, ww
      real, dimension(3) :: tab
C-----------------------------------------------
c
c
c dimension of           x(nx),y(ny),f(idm,ny),fxx(idm,ny),fyy(idm,ny),
c arguments              fxxyy(idm,ny))
c                        (idm must be .ge. nx)
c
c latest revision        february 1974
c
c usage                  r = terp2 (xb,yb,nx,x,ny,y,f,fxx,fyy,fxxyy,idm,
c                                   ixd,iyd)
c
c arguments
c
c on input               xb, yb
c                          values of the independent variables, x and y,
c                          at which interpolation is required.
c
c                        nx
c                          number of grid points in the x-direction. nx
c                          must be at least 4.
c
c                        x
c                          table of nx values of the independent
c                          variable, x, arranged in ascending order.
c                          dimension of x in the calling program must be
c                          at least nx.
c
c                        ny
c                          number of grid points in the y-direction. ny
c                          must be at least 4.
c
c                        y
c                          table of ny values of the independent
c                          variable, y, arranged in ascending order.
c                          dimension of y in the calling program must be
c                          at least ny.
c
c                        f
c                          two-dimensional array of function values at
c                          grid points defined by the arrays x and y.
c                          dimension of f in the calling program is
c                          (idm,nyy), where
c                              idm .ge. nx
c                              nyy .ge. ny
c
c                        fxx
c                          array of second derivatives of f with respect
c                          to x computed by coeff2.  dimension of fxx in
c                          the calling program is (idm,nyy).  see under
c                          f above.
c
c                        fyy
c                          array of second derivatives of f with respect
c                          to y computed by coeff2.  dimension of fyy in
c                          the calling program is (idm,nyy).
c
c                        fxxyy
c                          array of fourth derivatives,
c                          (d/dx)**2*(d/dy)**2*f, computed by coeff2.
c                          dimension of fxxyy in the calling program is
c                          (idm,nyy).
c
c                        idm
c                          first dimension in the calling program of
c                          arrays f, fxx, fyy and fxxyy,
c                              idm .ge. nx
c
c                        ixd, iyd
c                          define derivative to be returned by the
c                          function terp2.  ixd, iyd may each take the
c                          the values 0, 1, 2.  the derivative returned
c                          is (d/dx)**ixd*(d/dy)**iyd*f.
c                            note that if ixd = iyd = 0, the function
c                            value itself is returned.
c
c space required         220 (octal) = 144 (decimal)
c
c timing                 this procedure is fast.  the maximum time for
c                        the binary search is proportional to
c                        alog(nx*ny).  the time for function evaluation
c                        is independent of n.  for a 21 x 21 grid of
c                        data points, an average time for an
c                        interpolation on the ncar cdc 7600 is about
c                        .29 milliseconds.
c
c
c
c
c the following call is for gathering statistics on library use at ncar
c
c search in x and y arrays.
c
      call search (xb, x, nx, i)
      call search (yb, y, ny, j)
c
c interpolate in x direction
c
      itab = 0
      i1 = ixd + 1
      itab(i1) = 1
      do j1 = 1, 2
         jj = j + j1 - 1
         call intrp (n, x, f(1,jj), fxx(1,jj), xb, i, 1, tab, itab)
         ff(j1) = tab(i1)
         call intrp (n, x, fyy(1,jj), fxxyy(1,jj), xb, i, 1, tab,
     1               itab)
         ww(j1) = tab(i1)
      end do
c
c interpolate in y direction
c
      itab = 0
      j1 = iyd + 1
      itab(j1) = 1
      call intrp (2, y(j), ff, ww, yb, 1, 1, tab, itab)
      terp2 = tab(j1)
      return 
      end function terp2

      function terp2p (xb, yb, nx, x, ny, y, f, fxx, fyy, fxxyy, 
     1   idm, ixd, iyd, isrch)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real terp2p
      integer nx, ny, idm, ixd, iyd, isrch
      real xb, yb
      real, dimension(1) :: x, y
      real, dimension(idm,1) :: f, fxx, fyy, fxxyy
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer, dimension(3) :: itab
      integer :: i, j, isav, jsav, i1, j1, jj, n
      real, dimension(2) :: ff, ww
      real, dimension(3) :: tab

      save ff, ww, tab, itab, i, j, isav, jsav, i1, j1, jj, n
C-----------------------------------------------
c
c Modified terp2 by adding isrch:  Binary search of grid for
c                    interpolation point is carried out only if
c                    isrch=1.  Otherwise, it is assumed that values
c                    have been generated by a previous call.
c
c
c dimension of           x(nx),y(ny),f(idm,ny),fxx(idm,ny),fyy(idm,ny),
c arguments              fxxyy(idm,ny))
c                        (idm must be .ge. nx)
c
c latest revision        february 1974
c
c usage                  r = terp2 (xb,yb,nx,x,ny,y,f,fxx,fyy,fxxyy,idm,
c                                   ixd,iyd)
c
c arguments
c
c on input               xb, yb
c                          values of the independent variables, x and y,
c                          at which interpolation is required.
c
c                        nx
c                          number of grid points in the x-direction. nx
c                          must be at least 4.
c
c                        x
c                          table of nx values of the independent
c                          variable, x, arranged in ascending order.
c                          dimension of x in the calling program must be
c                          at least nx.
c
c                        ny
c                          number of grid points in the y-direction. ny
c                          must be at least 4.
c
c                        y
c                          table of ny values of the independent
c                          variable, y, arranged in ascending order.
c                          dimension of y in the calling program must be
c                          at least ny.
c
c                        f
c                          two-dimensional array of function values at
c                          grid points defined by the arrays x and y.
c                          dimension of f in the calling program is
c                          (idm,nyy), where
c                              idm .ge. nx
c                              nyy .ge. ny
c
c                        fxx
c                          array of second derivatives of f with respect
c                          to x computed by coeff2.  dimension of fxx in
c                          the calling program is (idm,nyy).  see under
c                          f above.
c
c                        fyy
c                          array of second derivatives of f with respect
c                          to y computed by coeff2.  dimension of fyy in
c                          the calling program is (idm,nyy).
c
c                        fxxyy
c                          array of fourth derivatives,
c                          (d/dx)**2*(d/dy)**2*f, computed by coeff2.
c                          dimension of fxxyy in the calling program is
c                          (idm,nyy).
c
c                        idm
c                          first dimension in the calling program of
c                          arrays f, fxx, fyy and fxxyy,
c                              idm .ge. nx
c
c                        ixd, iyd
c                          define derivative to be returned by the
c                          function terp2.  ixd, iyd may each take the
c                          the values 0, 1, 2.  the derivative returned
c                          is (d/dx)**ixd*(d/dy)**iyd*f.
c                            note that if ixd = iyd = 0, the function
c                            value itself is returned.
c
c space required         220 (octal) = 144 (decimal)
c
c timing                 this procedure is fast.  the maximum time for
c                        the binary search is proportional to
c                        alog(nx*ny).  the time for function evaluation
c                        is independent of n.  for a 21 x 21 grid of
c                        data points, an average time for an
c                        interpolation on the ncar cdc 7600 is about
c                        .29 milliseconds.
c
c
c
c
c the following call is for gathering statistics on library use at ncar
c
c search in x and y arrays.
c
      if (isrch == 1) then
         call search (xb, x, nx, i)
         call search (yb, y, ny, j)
         isav = i
         jsav = j
      endif
c
c interpolate in x direction
c
      itab = 0
      i1 = ixd + 1
      itab(i1) = 1
      do j1 = 1, 2
         jj = jsav + j1 - 1
         call intrp (n, x, f(1,jj), fxx(1,jj), xb, isav, 1, tab, itab)
         ff(j1) = tab(i1)
         call intrp (n, x, fyy(1,jj), fxxyy(1,jj), xb, isav, 1, tab, 
     1      itab)
         ww(j1) = tab(i1)
      end do
c
c interpolate in y direction
c
      itab = 0
      j1 = iyd + 1
      itab(j1) = 1
      call intrp (2, y(jsav), ff, ww, yb, 1, 1, tab, itab)
      terp2p = tab(j1)
      return 
      end function terp2p
 
      subroutine trap2(x, y, yint, npts)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 npts
      real, dimension(1) :: x, y, yint
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i
C-----------------------------------------------
c-------------------------------------------
c   calculates integral y*dx using trapezoidal
c       rule
c--------------------------------------------
      yint(1) = 0.
      do i = 2, npts
         yint(i) = (y(i)+y(i-1))*(x(i)-x(i-1))*0.5 + yint(i-1)
      end do
      return 
      end subroutine trap2
      subroutine trapl(r, y, nj, xint)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/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 nj
      real xint
      real, dimension(1) :: r, y
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: j
C-----------------------------------------------
c
c this subroutine integrates y(r) with respect to r from
c   zero to rminor.  the trapezoidal rule is used.
c
      xint = dot_product(.5*(y(2:nj)+y(:nj-1)),r(2:nj)-r(:nj-1))
      return 
      end subroutine trapl

      function valspl (h, c, nprofn, i, jderiv)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:56 6/14/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real valspl
      integer nprofn, i, jderiv
      real h
      real, dimension(nprofn,4) :: c
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------
c ********** ********** ********** ********** ********** **********
c                                                                 *
c  this subroutine evaluates the cubic spline value               *
c        the function stored in the table c(j,1)                  *
c                                                                 *
c ********** ********** ********** ********** ********** **********
c ---------- ---------- ---------- ---------- ---------- ----------
      select case (jderiv) 
      case (0) 
         valspl = c(i,1) + h*(c(i,2)+0.5*h*(c(i,3)+0.333333333333*h
     1      *c(i,4)))
      case (1) 
         valspl = c(i,2) + h*(c(i,3)+0.5*h*c(i,4))
      case (2) 
         valspl = c(i,3) + h*c(i,4)
      case (3) 
         valspl = c(i,4)
      end select
c ---------- ---------- ---------- ---------- ---------- ----------
      return 
      end function valspl
c
      function spln0 (s0, sh, sp0, sph, h, d)
      implicit none
      real spln0
      real s0
      real sh
      real sp0
      real sph
      real h
      real d
      spln0 = s0 + d*(h*sp0 + d*(3.*(sh - s0) - (sph + 2.*sp0)*h + d*(2.
     1   *(s0 - sh) + (sph + sp0)*h)))
      return 
      end function spln0

      function spln1 (s0, sh, sp0, sph, h, d)
      implicit none
      real spln1
      real s0
      real sh
      real sp0
      real sph
      real h
      real d
      spln1 = sp0 + d*(6.*(sh - s0)/h - 2.*(sph + 2.*sp0) + 3.*d*(2.*(s0
     1    - sh)/h + (sph + sp0)))
      return 
      end function spln1

      function spln2 (s0, sh, sp0, sph, h, d)
      implicit none
      real spln2
      real s0
      real sh
      real sp0
      real sph
      real h
      real d
      spln2 = 6.*(sh - s0)/h**2 - 2.*(sph + 2.*sp0)/h + d*(2.*(s0 - sh)/
     1   h**2 + (sph + sp0)/h)*6.
      return 
      end function spln2
c
      function terp (g1, g2, g3, g4)
      use Vterppars, only: a12, a13, a14, a23, a24, a34
      implicit none
      real terp
      real :: g1,g2,g3,g4
      terp = (1./a12 + 1./a13 + 1./a14)*g1 - a13*a14/(a12*a23*a24)*g2 + 
     1   a12*a14/(a13*a23*a34)*g3 - a12*a13/(a14*a24*a34)*g4
      return 
      end function terp
c
      integer function ii (index,int)
      integer index, int
      ii = (index - 1)*int + 1
      return 
      end function ii         

      subroutine trip(n, a, b, c, y, z, int)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:58:46   6/14/01
C...Switches: -p4 -yb
C
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer n, int
      real, dimension(n) :: a, b, c, y
      real, dimension(*) :: z
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: index, nm2, j, nm1, in, k, ik
      real :: bn, yn, v, den
C-----------------------------------------------
C   I n t e r n a l   F u n c t i o n s
C-----------------------------------------------
c      integer ii
C-----------------------------------------------
c                             
c arithmetic statement function used to locate entries in array z.
c
c
c gaussian elimination
c
      bn = b(n)
      yn = y(n)
      v = c(n)
      y(1) = y(1)/b(1)
      a(1) = a(1)/b(1)
      b(1) = c(1)/b(1)
      nm2 = n - 2
      do j = 2, nm2
         den = b(j) - a(j)*b(j-1)
         b(j) = c(j)/den
         y(j) = (y(j)-a(j)*y(j-1))/den
         a(j) = -a(j)*a(j-1)/den
         bn = bn - v*a(j-1)
         yn = yn - v*y(j-1)
         v = -v*b(j-1)
      end do
      den = b(n-1) - a(n-1)*b(n-2)
      b(n-1) = (c(n-1)-a(n-1)*a(n-2))/den
      y(n-1) = (y(n-1)-a(n-1)*y(n-2))/den
      bn = bn - v*a(n-2)
      yn = yn - v*y(n-2)
      v = a(n) - v*b(n-2)
c
c back substitution
c
      z(ii(n)) = (yn - v*y(n-1))/(bn - v*b(n-1))
      z(ii(n-1)) = y(n-1) - b(n-1)*z(ii(n))
      nm1 = n - 1
      in = ii(n)
      do j = 2, nm1
         k = n - j
         ik = ii(k)
         z(ik) = y(k) - b(k)*z(ik+int) - a(k)*z(in)
      end do
      return
      contains
         integer function ii(k)
         integer :: k
         ii = (k-1)*int+1
         return
         end function ii
      end subroutine trip


      subroutine search(xbar, x, n, i)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:58:46   6/14/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 n, i
      real xbar
      real, dimension(*) :: x
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: m, k, nm1
      real :: b
C-----------------------------------------------
      data b/.69314718/
c
c if xbar is outside range of x table extrapolate
c
      if (xbar <= x(2)) then
         i = 1
         return
      endif
      if (xbar >= x(n-1)) then
         i = n - 1
         return
      endif
c
c find maximum power of two less than n
c
      m = int(alog(real(n))/b)
      i = 2**m
      if (i >= n) i = i/2
      k = i
      nm1 = n - 1
c
c conduct binary search.       
c
  103 continue
      k = k/2
 1002 continue
      if (xbar >= x(i)) go to 104
      i = i - k
      k = k/2
      if (xbar >= x(i)) go to 104
      i = i - k
      k = k/2
      if (xbar >= x(i)) go to 104
      i = i - k
      k = k/2
      if (xbar >= x(i)) go to 104
      i = i - k
      k = k/2
      go to 1002
  104 continue
      if (xbar <= x(i+1)) return
      i = min0(i + k,nm1)
      go to 103
      end subroutine search             
