      subroutine curv1 (n,x,y,slp1,slpn,islpsw,yp,temp,
     *                  sigma,ierr)
c
      integer n,islpsw,ierr
      real x(n),y(n),slp1,slpn,yp(n),temp(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory spline under tension through
c a sequence of functional values. the slopes at the two
c ends of the curve may be specified or omitted.  for actual
c computation of points on the curve it is necessary to call
c the function curv2.
c
c on input--
c
c   n is the number of values to be interpolated (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   functional values.
c
c   y is an array of the n ordinates of the values, (i. e.
c   y(k) is the functional value corresponding to x(k) ).
c
c   slp1 and slpn contain the desired values for the first
c   derivative of the curve at x(1) and x(n), respectively.
c   the user may omit values for either or both of these
c   parameters and signal this with islpsw.
c
c   islpsw contains a switch indicating which slope data
c   should be used and which should be estimated by this
c   subroutine,
c          = 0 if slp1 and slpn are to be used,
c          = 1 if slp1 is to be used but not slpn,
c          = 2 if slpn is to be used but not slp1,
c          = 3 if both slp1 and slpn are to be estimated
c              internally.
c
c   yp is an array of length at least n.
c
c   temp is an array of length at least n which is used for
c   scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e.g. .001) the resulting curve is approximately a
c   cubic spline. if abs(sigma) is large (e.g. 50.) the
c   resulting curve is nearly a polygonal line. if sigma
c   equals zero a cubic spline results.  a standard value
c   for sigma is approximately 1. in absolute value.
c
c on output--
c
c   yp contains the values of the second derivative of the
c   curve at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if x-values are not strictly increasing.
c
c and
c
c   n, x, y, slp1, slpn, islpsw and sigma are unaltered.
c
c this subroutine references package modules ceez, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      np1 = n+1
      ierr = 0
      if (n .le. 1) go to 8
      if (x(n) .le. x(1)) go to 9
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c approximate end slopes
c
      if (islpsw .ge. 2) go to 1
      slpp1 = slp1
      go to 2
    1 delx1 = x(2)-x(1)
      delx2 = delx1+delx1
      if (n .gt. 2) delx2 = x(3)-x(1)
      if (delx1 .le. 0. .or. delx2 .le. delx1) go to 9
      call ceez (delx1,delx2,sigmap,c1,c2,c3,n)
      slpp1 = c1*y(1)+c2*y(2)
      if (n .gt. 2) slpp1 = slpp1+c3*y(3)
    2 if (islpsw .eq. 1 .or. islpsw .eq. 3) go to 3
      slppn = slpn
      go to 4
    3 delxn = x(n)-x(nm1)
      delxnm = delxn+delxn
      if (n .gt. 2) delxnm = x(n)-x(n-2)
      if (delxn .le. 0. .or. delxnm .le. delxn) go to 9
      call ceez (-delxn,-delxnm,sigmap,c1,c2,c3,n)
      slppn = c1*y(n)+c2*y(nm1)
      if (n .gt. 2) slppn = slppn+c3*y(n-2)
c
c set up right hand side and tridiagonal system for yp and
c perform forward elimination
c
    4 delx1 = x(2)-x(1)
      if (delx1 .le. 0.) go to 9
      dx1 = (y(2)-y(1))/delx1
      call terms (diag1,sdiag1,sigmap,delx1)
      yp(1) = (dx1-slpp1)/diag1
      temp(1) = sdiag1/diag1
      if (n .eq. 2) go to 6
      do 5 i = 2,nm1
        delx2 = x(i+1)-x(i)
        if (delx2 .le. 0.) go to 9
        dx2 = (y(i+1)-y(i))/delx2
        call terms (diag2,sdiag2,sigmap,delx2)
        diag = diag1+diag2-sdiag1*temp(i-1)
        yp(i) = (dx2-dx1-sdiag1*yp(i-1))/diag
        temp(i) = sdiag2/diag
        dx1 = dx2
        diag1 = diag2
    5   sdiag1 = sdiag2
    6 diag = diag1-sdiag1*temp(nm1)
      yp(n) = (slppn-dx1-sdiag1*yp(nm1))/diag
c
c perform back substitution
c
      do 7 i = 2,n
        ibak = np1-i
    7   yp(ibak) = yp(ibak)-temp(ibak)*yp(ibak+1)
      return
c
c too few points
c
    8 ierr = 1
      return
c
c x-values not strictly increasing
c
    9 ierr = 2
      return
      end
      subroutine curvn1 (n,x,y,yp,temp,sigma,ierr)
c
      integer n,ierr
      real x(n),y(n),yp(n),temp(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a natural interpolatory spline under tension
c through a sequence of functional values. for actual
c computation of points on the curve it is necessary to call
c the function curv2.
c
c on input--
c
c   n is the number of values to be interpolated (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   functional values.
c
c   y is an array of the n ordinates of the values, (i. e.
c   y(k) is the functional value corresponding to x(k) ).
c
c   yp is an array of length at least n.
c
c   temp is an array of length at least n which is used for
c   scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e.g. .001) the resulting curve is approximately a
c   cubic spline. if abs(sigma) is large (e.g. 50.) the
c   resulting curve is nearly a polygonal line. if sigma
c   equals zero a cubic spline results.  a standard value
c   for sigma is approximately 1. in absolute value.
c
c on output--
c
c   yp contains the values of the second derivative of the
c   curve at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if x-values are not strictly increasing.
c
c and
c
c   n, x, y, and sigma are unaltered.
c
c this subroutine references package modules snhcsh.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      np1 = n+1
      ierr = 0
      if (n .le. 1) go to 4
      if (x(n) .le. x(1)) go to 5
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c set up right hand side and tridiagonal system for yp and
c perform forward elimination
c
      delx1 = x(2)-x(1)
      if (delx1 .le. 0.) go to 5
      dx1 = (y(2)-y(1))/delx1
      call terms (diag1,sdiag1,sigmap,delx1)
      sdiag1 = 0.
      yp(1) = 0.
      temp(1) = 0.
      if (n .eq. 2) go to 2
      do 1 i = 2,nm1
        delx2 = x(i+1)-x(i)
        if (delx2 .le. 0.) go to 5
        dx2 = (y(i+1)-y(i))/delx2
        call terms (diag2,sdiag2,sigmap,delx2)
        diag = diag1+diag2-sdiag1*temp(i-1)
        yp(i) = (dx2-dx1-sdiag1*yp(i-1))/diag
        temp(i) = sdiag2/diag
        dx1 = dx2
        diag1 = diag2
    1   sdiag1 = sdiag2
   2  yp(n) = 0.
      temp(n-1) = 0.
c
c perform back substitution
c
      do 3 i = 2,n
        ibak = np1-i
    3   yp(ibak) = yp(ibak)-temp(ibak)*yp(ibak+1)
      return
c
c too few points
c
    4 ierr = 1
      return
c
c x-values not strictly increasing
c
    5 ierr = 2
      return
      end
      subroutine curvsc(n,x,y,slp1,slpn,islpsw,sigma,yp,temp
     *                  ,fllmt,fulmt,dfllmt,dfulmt,ifcon
     *                  ,idfcon,isdcon,ierr,iercon)
c
      integer n,islpsw,ifcon(n),idfcon(n),isdcon(n),ierr,
     *          iercon(n)
      real x(n),y(n),slp1,slpn,sigma,yp(n),temp(1),
     *     fllmt(n),fulmt(n),dfllmt(n),dfulmt(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolation spline under tension, that
c satisfies specified conditions, through a sequence of
c functional values.  the slopes at the two ends of the
c curve may be specified or omitted.  the user may also
c specify a lower and/or upper limit for the spline and its
c first derivative on each interval as well as specifing the
c convexity or concavity of the spline on each interval.
c for actual computation of points on the curve it is
c necessary to call the function curv2.
c
c on input--
c
c   n is the number of values to be interpolated.  (n.ge.2)
c
c   x is an array of the n increasing abscissae of the
c   functional values.
c
c   y is an array of the n ordinates of the values, (i.e.
c   y(k) are functional values corresponding to x(k).)
c
c   slp1 and slpn contain the desired values for the first
c   derivatives of the curve at x(1) and x(n), respectively.
c   the user may omit values for either or both of these
c   parameters and signal this with islpsw.
c
c   islpsw contains a switch indicating which slope data
c   should used and which should be estimated by this
c   subroutine
c      = 0   if slp1 and slpn are to be used,
c      = 1   if slp1 is to be used but not slpn,
c      = 2   if slpn is to be used but not slp1,
c      = 3   if both slp1 and slpn are to be estimated
c            internally.
c
c   yp is an array of length at least n.
c
c   temp is an array of length at least 4*n used for
c   scratch storage.
c
c   fllmt and fulmt are arrays of length n which contain the
c   lower limit and the upper limit, respectively, of the
c   desired spline.  fllmt(i) and fulmt(i) describe the
c   limits for the interval x(i) .le. x .le. x(i+1).  the
c   nth element is ignored. the user may omit either or both
c   of these parameters for any interval i and signal this
c   with ifcon(i).
c
c   dfllmt and dfulmt are arrays of length n which contain
c   the lower and upper limits, respectively, of the first
c   derivative of the desired spline.  dfllmt(i) and
c   dfulmt(i) describe the limits for the interval x(i) .le.
c   x .le. x(i+1).  the nth element is ignored.  the user
c   may omit either or both of parameters for any interval i
c   and signal this with idfcon(i).
c
c   ifcon is an array of length n containing information
c   about fllmt and fulmt.
c       ifcon(i) = -1   if fllmt(i) is to be used but not
c                       fulmt(i),
c                =  0   if both fllmt(i) and fulmt(i) are to
c                       be used,
c                =  1   if fulmt(i) is to be used but not
c                       fllmt(i),
c                =  2   if both fllmt(i) and fulmt(i) are
c                       not used.
c   ifcon(n) is ignored.
c
c   idfcon is an array of length n containing information
c   about dfllmt and dfulmt.
c      idfcon(i) = -1   if dfllmt(i) is to be used but not
c                       dfulmt(i),
c                =  0   if both dfllmt(i) and dfulmt(i) are
c                       to be used,
c                =  1   if dfulmt(i) is to be used but not
c                       dfllmt(i),
c                =  2   if both dfllmt(i) and dfulmt(i) are
c                       not used.
c   idfcon(n) is ignored.
c
c and
c
c   isdcon(i) is an array of length n containing information
c   about the second derivative on each interval.
c      isdcon(i) = -1   the spline should be concave on the
c                       ith interval,
c                =  0   no constraints are placed on the
c                       2nd derivative on the ith interval,
c                =  1   the spline should be convex on the
c                       ith interval.
c   isdcon(n) is ignored.
c
c and
c
c   iercon is an array of length at least n.
c
c on output--
c
c   if ierr = 0 sigma contains the tension factor of a
c   spline under tension that satisfies the user specified
c   conditions.  if ierr = 4 sigma contains a large tension
c   factor of a spline under tension that does not satisfy
c   the conditions but graphically appears as piecewise
c   linear interpolation.  otherwise sigma is unaltered.
c
c   if ierr = 0 or 4 yp contains of the second derivative
c   values of the curve at the given nodes.
c   otherwise yp is unaltered.
c
c   ierr contains an error flag.
c      = 0   for normal return
c      = 1   if n is less than 2
c      = 2   if x-values are not strictly increasing
c      = 3   conditions cannot be met
c      = 4   conditions can be met but graphically the curve
c             will not differ from piecewise linear
c             interpolation.
c
c   iercon(i) is unaltered if ierr = 1 or 2.  otherwise
c   iercon(i) contains the decimal equivalent of a five
c   digit binary number a1 a2 a3 a4 a5.
c          a1 = 0   condition fllmt(i) can be met
c          a1 = 1   condition fllmt(i) cannot be met
c          a2 = 0   condition fulmt(i) can be met
c          a2 = 1   condition fulmt(i) cannot be met
c          a3 = 0   condition dfllmt(i) can be met
c          a3 = 1   condition dfllmt(i) cannot be met
c          a4 = 0   condition dfulmt(i) can be met
c          a4 = 1   condition dfulmt(i) cannot be met
c          a5 = 0   condition isdcon(i) can be met
c          a5 = 1   condition isdcon(i) cannot be met
c   iercon(n) is unaltered.
c
c n,x,y,slp1,slpn,islpsw,fllmt,fulmt,dfllmt,dfulmt,ifcon,
c idfcon, and isdcon are unaltered.
c
c this subroutine references package modules bpredt,ckintv,
c condck,ddrys,dfmxmn,dyrs,fmxmn,ipredt,mkrhs,mkrhs2,kmrhs3,
c predt,rcrvsc,sddyrs,sdyrs,store,strhlp,solnck,snhcs2,
c terms2,trifac, and trisol and fitpack modules ceez,curv2,
c curvd,intrvl,snhcsh, and terms.
c
c-----------------------------------------------------------
c
c
c this subroutine decomposes workspace for rcrvsc
c
      np1 = n + 1
      nnp1 = n + np1
      nnnp1 = n + nnp1
      call rcrvsc(n,x,y,slp1,slpn,islpsw,sigma,yp,
     *            temp(1),temp(np1),temp(nnp1),temp(nnnp1),
     *             fllmt,fulmt,dfllmt,dfulmt,ifcon,idfcon,
     *             isdcon,ierr,iercon)
      return
      end
      subroutine curvs (n,x,y,d,isw,s,eps,ys,ysp,sigma,temp,
     *                  ierr)
c
      integer n,isw,ierr
      real x(n),y(n),d(n),s,eps,ys(n),ysp(n),sigma,temp(n,9)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a smoothing spline under tension. for a given
c increasing sequence of abscissae (x(i)), i = 1,..., n and
c associated ordinates (y(i)), i = 1,..., n, the function
c determined minimizes the summation from i = 1 to n-1 of
c the square of the second derivative of f plus sigma
c squared times the difference of the first derivative of f
c and (f(x(i+1))-f(x(i)))/(x(i+1)-x(i)) squared, over all
c functions f with two continuous derivatives such that the
c summation of the square of (f(x(i))-y(i))/d(i) is less
c than or equal to a given constant s, where (d(i)), i = 1,
c ..., n are a given set of observation weights. the
c function determined is a spline under tension with third
c derivative discontinuities at (x(i)), i = 2,..., n-1. for
c actual computation of points on the curve it is necessary
c to call the function curv2. the determination of the curve
c is performed by subroutine curvss, the subroutine curvs
c only decomposes the workspace for curvss.
c
c on input--
c
c   n is the number of values to be smoothed (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   values to be smoothed.
c
c   y is an array of the n ordinates of the values to be
c   smoothed, (i. e. y(k) is the functional value
c   corresponding to x(k) ).
c
c   d is a parameter containing the observation weights.
c   this may either be an array of length n or a scalar
c   (interpreted as a constant). the value of d
c   corresponding to the observation (x(k),y(k)) should
c   be an approximation to the standard deviation of error.
c
c   isw contains a switch indicating whether the parameter
c   d is to be considered a vector or a scalar,
c          = 0 if d is an array of length n,
c          = 1 if d is a scalar.
c
c   s contains the value controlling the smoothing. this
c   must be non-negative. for s equal to zero, the
c   subroutine does interpolation, larger values lead to
c   smoother funtions. if parameter d contains standard
c   deviation estimates, a reasonable value for s is
c   float(n).
c
c   eps contains a tolerance on the relative precision to
c   which s is to be interpreted. this must be greater than
c   or equal to zero and less than or equal to one. a
c   reasonable value for eps is sqrt(2./float(n)).
c
c   ys is an array of length at least n.
c
c   ysp is an array of length at least n.
c
c   sigma contains the tension factor. this value indicates
c   the degree to which the first derivative part of the
c   smoothing functional is emphasized. if sigma is nearly
c   zero (e. g. .001) the resulting curve is approximately a
c   cubic spline. if sigma is large (e. g. 50.) the
c   resulting curve is nearly a polygonal line. if sigma
c   equals zero a cubic spline results. a standard value for
c   sigma is approximately 1.
c
c and
c
c   temp is an array of length at least 9*n which is used
c   for scratch storage.
c
c on output--
c
c   ys contains the smoothed ordinate values.
c
c   ysp contains the values of the second derivative of the
c   smoothed curve at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if s is negative,
c        = 3 if eps is negative or greater than one,
c        = 4 if x-values are not strictly increasing,
c        = 5 if a d-value is non-positive.
c
c and
c
c   n, x, y, d, isw, s, eps, and sigma are unaltered.
c
c this subroutine references package modules curvss, store,
c terms, and snhcsh.
c
c-----------------------------------------------------------
c
c decompose temp into nine arrays and call curvss
c
      call curvss (n,x,y,d,isw,s,eps,ys,ysp,sigma,temp(1,1),
     *             temp(1,2),temp(1,3),temp(1,4),temp(1,5),
     *             temp(1,6),temp(1,7),temp(1,8),temp(1,9),
     *             ierr)
      return
      end
      function curv2 (t,n,x,y,yp,sigma)
c
      integer n
      real t,x(n),y(n),yp(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function interpolates a curve at a given point
c using a spline under tension. the subroutine curv1 should
c be called earlier to determine certain necessary
c parameters.
c
c on input--
c
c   t contains a real value to be mapped onto the interpo-
c   lating curve.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, yp, and sigma should be input
c unaltered from the output of curv1.
c
c on output--
c
c   curv2 contains the interpolated value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      im1 = intrvl(t,x,n)
      i = im1+1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c set up and perform interpolation
c
      del1 = t-x(im1)
      del2 = x(i)-t
      dels = x(i)-x(im1)
      sum = (y(i)*del1+y(im1)*del2)/dels
      if (sigmap .ne. 0.) go to 1
      curv2 = sum-del1*del2*(yp(i)*(del1+dels)+yp(im1)*
     *        (del2+dels))/(6.*dels)
      return
    1 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (s1,dummy,sigmap*del1,-1)
      call snhcsh (s2,dummy,sigmap*del2,-1)
      curv2 = sum+(yp(i)*del1*(s1-ss)+yp(im1)*del2*(s2-ss))/
     *            (sigdel*sigmap*(1.+ss))
      return
      end
      function curvd (t,n,x,y,yp,sigma)
c
      integer n
      real t,x(n),y(n),yp(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function differentiates a curve at a given point
c using a spline under tension. the subroutine curv1 should
c be called earlier to determine certain necessary
c parameters.
c
c on input--
c
c   t contains a real value at which the derivative is to be
c   determined.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, yp, and sigma should be input
c unaltered from the output of curv1.
c
c on output--
c
c   curvd contains the derivative value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      im1 = intrvl(t,x,n)
      i = im1+1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c set up and perform differentiation
c
      del1 = t-x(im1)
      del2 = x(i)-t
      dels = x(i)-x(im1)
      sum = (y(i)-y(im1))/dels
      if (sigmap .ne. 0.) go to 1
      curvd = sum+(yp(i)*(2.*del1*del1-del2*(del1+dels))-
     *             yp(im1)*(2.*del2*del2-del1*(del2+dels)))
     *             /(6.*dels)
      return
    1 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (dummy,c1,sigmap*del1,1)
      call snhcsh (dummy,c2,sigmap*del2,1)
      curvd = sum+(yp(i)*(c1-ss)-yp(im1)*(c2-ss))/
     *        (sigdel*sigmap*(1.+ss))
      return
      end
      subroutine curv2d (t,yy,yx,yxx,n,x,y,yp,sigma)
c
      integer n
      real t,yy,yx,yxx,x(n),y(n),yp(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines function value, first, and
c second derivatives of a curve at a given point using a
c spline under tension. the subroutine curv1 should be
c called earlier to determine certain necessary parameters.
c
c on input--
c
c   t contains a real value at which the function and
c   derivatives are to be evaluated.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, yp, and sigma should be input
c unaltered from the output of curv1.
c
c on output--
c
c   yy, yx, and yxx contain the function value, first and
c   second derivatives, respectively.
c
c none of the input parameters are altered.
c
c this subroutine references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      im1 = intrvl(t,x,n)
      i = im1+1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c set up and perform interpolation
c
      del1 = t-x(im1)
      del2 = x(i)-t
      dels = x(i)-x(im1)
      yy = (y(i)*del1+y(im1)*del2)/dels
      yx = (y(i)-y(im1))/dels
      if (sigmap .ne. 0.) go to 1
      yy = yy-del1*del2*(yp(i)*(del1+dels)+yp(im1)*
     *        (del2+dels))/(6.*dels)
      yx = yx+(yp(i)*(2.*del1*del1-del2*(del1+dels))-
     *         yp(im1)*(2.*del2*del2-del1*(del2+dels)))
     *         /(6.*dels)
      yxx = (yp(i)*del1+yp(im1)*del2)/dels
      return
    1 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (s1,c1,sigmap*del1,0)
      call snhcsh (s2,c2,sigmap*del2,0)
      d = sigdel*sigmap*(1.+ss)
      yy = yy+(yp(i)*del1*(s1-ss)+yp(im1)*del2*(s2-ss))/d
      yx = yx+(yp(i)*(c1-ss)-yp(im1)*(c2-ss))/d
      yxx = (yp(i)*(1.+s1)*del1+yp(im1)*(1.+s2)*del2)/
     *       (dels*(1.+ss))
      return
      end
      function curvi (xl,xu,n,x,y,yp,sigma)
c
      integer n
      real xl,xu,x(n),y(n),yp(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function integrates a curve specified by a spline
c under tension between two given limits. the subroutine
c curv1 should be called earlier to determine necessary
c parameters.
c
c on input--
c
c   xl and xu contain the upper and lower limits of inte-
c   gration, respectively. (sl need not be less than or
c   equal to xu, curvi (xl,xu,...) .eq. -curvi (xu,xl,...) ).
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   yp is an array from subroutine curv1 containing
c   the values of the second derivatives at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, yp, and sigma should be input
c unaltered from the output of curv1.
c
c on output--
c
c   curvi contains the integral value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c determine actual upper and lower bounds
c
      xxl = xl
      xxu = xu
      ssign = 1.
      if (xl .lt. xu) go to 1
      xxl = xu
      xxu = xl
      ssign = -1.
      if (xl .gt. xu) go to 1
c
c return zero if xl .eq. xu
c
      curvi = 0.
      return
c
c search for proper intervals
c
    1 ilm1 = intrvl (xxl,x,n)
      il = ilm1+1
      ium1 = intrvl (xxu,x,n)
      iu = ium1+1
      if (il .eq. iu) go to 8
c
c integrate from xxl to x(il)
c
      sum = 0.
      if (xxl .eq. x(il)) go to 3
      del1 = xxl-x(ilm1)
      del2 = x(il)-xxl
      dels = x(il)-x(ilm1)
      t1 = (del1+dels)*del2/(2.*dels)
      t2 = del2*del2/(2.*dels)
      sum = t1*y(il)+t2*y(ilm1)
      if (sigma .eq. 0.) go to 2
      call snhcsh (dummy,c1,sigmap*del1,2)
      call snhcsh (dummy,c2,sigmap*del2,2)
      call snhcsh (ss,cs,sigmap*dels,3)
      sum = sum+((dels*dels*(cs-ss/2.)-del1*del1*(c1-ss/2.))
     *           *yp(il)+del2*del2*(c2-ss/2.)*yp(ilm1))/
     *          (sigmap*sigmap*dels*(1.+ss))
      go to 3
    2 sum = sum-t1*t1*dels*yp(il)/6.
     *         -t2*(del1*(del2+dels)+dels*dels)*yp(ilm1)/12.
c
c integrate over interior intervals
c
    3 if (iu-il .eq. 1) go to 6
      ilp1 = il+1
      do 5 i = ilp1,ium1
        dels = x(i)-x(i-1)
        sum = sum+(y(i)+y(i-1))*dels/2.
        if (sigma .eq. 0.) go to 4
        call snhcsh (ss,cs,sigmap*dels,3)
        sum = sum+(yp(i)+yp(i-1))*dels*(cs-ss/2.)/
     *            (sigmap*sigmap*(1.+ss))
        go to 5
    4   sum = sum-(yp(i)+yp(i-1))*dels*dels*dels/24.
    5   continue
c
c integrate from x(iu-1) to xxu
c
    6 if (xxu .eq. x(ium1)) go to 10
      del1 = xxu-x(ium1)
      del2 = x(iu)-xxu
      dels = x(iu)-x(ium1)
      t1 = del1*del1/(2.*dels)
      t2 = (del2+dels)*del1/(2.*dels)
      sum = sum+t1*y(iu)+t2*y(ium1)
      if (sigma .eq. 0.) go to 7
      call snhcsh (dummy,c1,sigmap*del1,2)
      call snhcsh (dummy,c2,sigmap*del2,2)
      call snhcsh (ss,cs,sigmap*dels,3)
      sum = sum+(yp(iu)*del1*del1*(c1-ss/2.)+yp(ium1)*
     *          (dels*dels*(cs-ss/2.)-del2*del2*(c2-ss/2.)))
     *         /(sigmap*sigmap*dels*(1.+ss))
      go to 10
    7 sum = sum-t1*(del2*(del1+dels)+dels*dels)*yp(iu)/12.
     *         -t2*t2*dels*yp(ium1)/6.
      go to 10
c
c integrate from xxl to xxu
c
    8 delu1 = xxu-x(ium1)
      delu2 = x(iu)-xxu
      dell1 = xxl-x(ium1)
      dell2 = x(iu)-xxl
      dels = x(iu)-x(ium1)
      deli = xxu-xxl
      t1 = (delu1+dell1)*deli/(2.*dels)
      t2 = (delu2+dell2)*deli/(2.*dels)
      sum = t1*y(iu)+t2*y(ium1)
      if (sigma .eq. 0.) go to 9
      call snhcsh (dummy,cu1,sigmap*delu1,2)
      call snhcsh (dummy,cu2,sigmap*delu2,2)
      call snhcsh (dummy,cl1,sigmap*dell1,2)
      call snhcsh (dummy,cl2,sigmap*dell2,2)
      call snhcsh (ss,dummy,sigmap*dels,-1)
      sum = sum+(yp(iu)*(delu1*delu1*(cu1-ss/2.)
     *            -dell1*dell1*(cl1-ss/2.))
     *          +yp(ium1)*(dell2*dell2*(cl2-ss/2.)
     *            -delu2*delu2*(cu2-ss/2.)))/
     *          (sigmap*sigmap*dels*(1.+ss))
      go to 10
    9 sum = sum-t1*(delu2*(dels+delu1)+dell2*(dels+dell1))*
     *             yp(iu)/12.
     *         -t2*(dell1*(dels+dell2)+delu1*(dels+delu2))*
     *             yp(ium1)/12.
c
c correct sign and return
c
   10 curvi = ssign*sum
      return
      end
      subroutine curvp1 (n,x,y,p,yp,temp,sigma,ierr)
c
      integer n,ierr
      real x(n),y(n),p,yp(n),temp(1),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a periodic interpolatory spline under tension
c through a sequence of functional values. for actual ends
c of the curve may be specified or omitted.  for actual
c computation of points on the curve it is necessary to call
c the function curvp2.
c
c on input--
c
c   n is the number of values to be interpolated (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   functional values.
c
c   y is an array of the n ordinates of the values, (i. e.
c   y(k) is the functional value corresponding to x(k) ).
c
c   p is the period (p .gt. x(n)-x(1)).
c
c   yp is an array of length at least n.
c
c   temp is an array of length at least 2*n which is used
c   for scratch storage.
c
c and
c
c   sigma contains the tension factor.  this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e.g. .001) the resulting curve is approximately a
c   cubic spline. if abs(sigma) is large (e.g. 50.) the
c   resulting curve is nearly a polygonal line. if sigma
c   equals zero a cubic spline results.  a standard value
c   for sigma is approximately 1. in absolute value.
c
c on output--
c
c   yp contains the values of the second derivative of the
c   curve at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if p is less than or equal to x(n)-x(1),
c        = 3 if x-values are not strictly increasing.
c
c and
c
c  n, x, y, and sigma are unaltered.
c
c this subroutine references package modules terms and
c snhcsh.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      np1 = n+1
      ierr = 0
      if (n .le. 1) go to 6
      if (p .le. x(n)-x(1) .or. p .le. 0.) go to 7
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/p
c
c set up right hand side and tridiagonal system for yp and
c perform forward elimination
c
      delx1 = p-(x(n)-x(1))
      dx1 = (y(1)-y(n))/delx1
      call terms (diag1,sdiag1,sigmap,delx1)
      delx2 = x(2)-x(1)
      if (delx2 .le. 0.) go to 8
      dx2 = (y(2)-y(1))/delx2
      call terms (diag2,sdiag2,sigmap,delx2)
      diag = diag1+diag2
      yp(1) = (dx2-dx1)/diag
      temp(np1) = -sdiag1/diag
      temp(1) = sdiag2/diag
      dx1 = dx2
      diag1 = diag2
      sdiag1 = sdiag2
      if (n .eq. 2) go to 2
      do 1 i = 2,nm1
        npi = n+i
        delx2 = x(i+1)-x(i)
        if (delx2 .le. 0.) go to 8
        dx2 = (y(i+1)-y(i))/delx2
        call terms (diag2,sdiag2,sigmap,delx2)
        diag = diag1+diag2-sdiag1*temp(i-1)
        yp(i) = (dx2-dx1-sdiag1*yp(i-1))/diag
        temp(npi) = -temp(npi-1)*sdiag1/diag
        temp(i) = sdiag2/diag
        dx1 = dx2
        diag1 = diag2
    1   sdiag1 = sdiag2
    2 delx2 = p-(x(n)-x(1))
      dx2 = (y(1)-y(n))/delx2
      call terms (diag2,sdiag2,sigmap,delx2)
      yp(n) = dx2-dx1
      temp(nm1) = temp(2*n-1)-temp(nm1)
      if (n .eq. 2) go to 4
c
c perform first step of back substitution
c
      do 3 i = 3,n
        ibak = np1-i
        npibak =n+ibak
        yp(ibak) = yp(ibak)-temp(ibak)*yp(ibak+1)
    3   temp(ibak) =temp(npibak)-temp(ibak)*temp(ibak+1)
    4 yp(n) = (yp(n)-sdiag2*yp(1)-sdiag1*yp(nm1))/
     *        (diag1+diag2+sdiag2*temp(1)+sdiag1*temp(nm1))
c
c perform second step of back substitution
c
      ypn =   yp(n)
      do 5 i = 1,nm1
    5    yp(i) = yp(i)+temp(i)*ypn
      return
c
c too few points
c
    6 ierr = 1
      return
c
c period too small
c
    7 ierr = 2
      return
c
c x-values not strictly increasing
c
    8 ierr = 3
      return
      end
      subroutine curvps (n,x,y,p,d,isw,s,eps,ys,ysp,sigma,
     *                   temp,ierr)
c
      integer n,isw,ierr
      real x(n),y(n),p,d(n),s,eps,ys(n),ysp(n),sigma,
     *     temp(n,11)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a periodic smoothing spline under tension. for a
c given increasing sequence of abscissae (x(i)), i = 1,...,n
c and associated ordinates (y(i)), i = 1,...,n, letting p be
c the period, x(n+1) = x(1)+p, and y(n+1) = y(1), the
c function determined minimizes the summation from i = 1 to
c n of the square of the second derivative of f plus sigma
c squared times the difference of the first derivative of f
c and (f(x(i+1))-f(x(i)))/(x(i+1)-x(i)) squared, over all
c functions f with period p and two continuous derivatives
c such that the summation of the square of
c (f(x(i))-y(i))/d(i) is less than or equal to a given
c constant s, where (d(i)), i = 1,...,n are a given set of
c observation weights. the function determined is a periodic
c spline under tension with third derivative discontinuities
c at (x(i)) i = 1,...,n (and all periodic translations of
c these values). for actual computation of points on the
c curve it is necessary to call the function curvp2. the
c determination of the curve is performed by subroutine
c curvpp, the subroutin curvps only decomposes the workspace
c for curvpp.
c
c on input--
c
c   n is the number of values to be smoothed (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   values to be smoothed.
c
c   y is an array of the n ordinates of the values to be
c   smoothed, (i. e. y(k) is the functional value
c   corresponding to x(k) ).
c
c   p is the period (p .gt. x(n)-x(1)).
c
c   d is a parameter containing the observation weights.
c   this may either be an array of length n or a scalar
c   (interpreted as a constant). the value of d
c   corresponding to the observation (x(k),y(k)) should
c   be an approximation to the standard deviation of error.
c
c   isw contains a switch indicating whether the parameter
c   d is to be considered a vector or a scalar,
c          = 0 if d is an array of length n,
c          = 1 if d is a scalar.
c
c   s contains the value controlling the smoothing. this
c   must be non-negative. for s equal to zero, the
c   subroutine does interpolation, larger values lead to
c   smoother funtions. if parameter d contains standard
c   deviation estimates, a reasonable value for s is
c   float(n).
c
c   eps contains a tolerance on the relative precision to
c   which s is to be interpreted. this must be greater than
c   or equal to zero and less than or equal to one. a
c   reasonable value for eps is sqrt(2./float(n)).
c
c   ys is an array of length at least n.
c
c   ysp is an array of length at least n.
c
c   sigma contains the tension factor. this value indicates
c   the degree to which the first derivative part of the
c   smoothing functional is emphasized. if sigma is nearly
c   zero (e. g. .001) the resulting curve is approximately a
c   cubic spline. if sigma is large (e. g. 50.) the
c   resulting curve is nearly a polygonal line. if sigma
c   equals zero a cubic spline results. a standard value for
c   sigma is approximately 1.
c
c and
c
c   temp is an array of length at least 11*n which is used
c   for scratch storage.
c
c on output--
c
c   ys contains the smoothed ordinate values.
c
c   ysp contains the values of the second derivative of the
c   smoothed curve at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if s is negative,
c        = 3 if eps is negative or greater than one,
c        = 4 if x-values are not strictly increasing,
c        = 5 if a d-value is non-positive,
c        = 6 if p is less than or equal to x(n)-x(1).
c
c and
c
c   n, x, y, p, d, isw, s, eps, and sigma are unaltered.
c
c this subroutine references package modules curvpp, store,
c terms, and snhcsh.
c
c-----------------------------------------------------------
c
c decompose temp into eleven arrays and call curvpp
c
      call curvpp (n,x,y,p,d,isw,s,eps,ys,ysp,sigma,
     *             temp(1,1),temp(1,2),temp(1,3),temp(1,4),
     *             temp(1,5),temp(1,6),temp(1,7),temp(1,8),
     *             temp(1,9),temp(1,10),temp(1,11),ierr)
      return
      end
      function curvp2 (t,n,x,y,p,yp,sigma)
c
      integer n
      real t,x(n),y(n),p,yp(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function interpolates a curve at a given point using
c a periodic spline under tension. the subroutine curvp1
c should be called earlier to determine certain necessary
c parameters.
c
c on input--
c
c   t contains a real value to be mapped onto the interpo-
c   lating curve.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   p contains the period.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, p, yp, and sigma should be input
c unaltered from the output of curvp1.
c
c on output--
c
c   curvp2 contains the interpolated value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvp and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      im1 = intrvp (t,x,n,p,tp)
      i = im1+1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/p
c
c set up and perform interpolation
c
      del1 = tp-x(im1)
      if (im1 .eq. n) go to 1
      del2 = x(i)-tp
      dels = x(i)-x(im1)
      go to 2
    1 i = 1
      del2 = x(1)+p-tp
      dels = p-(x(n)-x(1))
    2 sum = (y(i)*del1+y(im1)*del2)/dels
      if (sigmap .ne. 0.) go to 3
      curvp2 = sum-del1*del2*(yp(i)*(del1+dels)+yp(im1)*
     *        (del2+dels))/(6.*dels)
      return
    3 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (s1,dummy,sigmap*del1,-1)
      call snhcsh (s2,dummy,sigmap*del2,-1)
      curvp2 = sum+(yp(i)*del1*(s1-ss)+yp(im1)*del2*(s2-ss))/
     *            (sigdel*sigmap*(1.+ss))
      return
      end
      function curvpd (t,n,x,y,p,yp,sigma)
c
      integer n
      real t,x(n),y(n),p,yp(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function differentiates a curve at a given point
c using a periodic spline under tension. the subroutine
c curvp1 should be called earlier to determine certain
c necessary parameters.
c
c on input--
c
c   t contains a real value at which the derivative is to be
c   determined.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   p contains the period.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, p, yp, and sigma should be input
c unaltered from the output of curvp1.
c
c on output--
c
c   curvpd contains the derivative value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvp and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      im1 = intrvp (t,x,n,p,tp)
      i = im1+1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/p
c
c set up and perform differentiation
c
      del1 = tp-x(im1)
      if (im1 .eq. n) go to 1
      del2 = x(i)-tp
      dels = x(i)-x(im1)
      go to 2
    1 i = 1
      del2 = x(1)+p-tp
      dels = p-(x(n)-x(1))
    2 sum = (y(i)-y(im1))/dels
      if (sigmap .ne. 0.) go to 3
      curvpd = sum+(yp(i)*(2.*del1*del1-del2*(del1+dels))-
     *             yp(im1)*(2.*del2*del2-del1*(del2+dels)))
     *             /(6.*dels)
      return
    3 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (dummy,c1,sigmap*del1,1)
      call snhcsh (dummy,c2,sigmap*del2,1)
      curvpd = sum+(yp(i)*(c1-ss)-yp(im1)*(c2-ss))/
     *        (sigdel*sigmap*(1.+ss))
      return
      end
      subroutine crvp2d (t,yy,yx,yxx,n,x,y,p,yp,sigma)
c
      integer n
      real t,yy,yx,yxx,x(n),y(n),p,yp(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines function value, first, and
c second derivatives of a curve at a given point using a
c periodic spline under tension. the subroutine curv1 should
c be called earlier to determine certain necessary
c parameters.
c
c on input--
c
c   t contains a real value at which the function and
c   derivatives are to be evaluated.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   p contains the period.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, p, yp, and sigma should be input
c unaltered from the output of curv1.
c
c on output--
c
c   yy, yx, and yxx contain the function value, first and
c   second derivatives, respectively.
c
c none of the input parameters are altered.
c
c this subroutine references package modules intrvp and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      im1 = intrvp (t,x,n,p,tp)
      i = im1+1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/p
c
c set up and perform interpolation
c
      del1 = tp-x(im1)
      if (im1 .eq. n) go to 1
      del2 = x(i)-tp
      dels = x(i)-x(im1)
      go to 2
    1 i = 1
      del2 = x(1)+p-tp
      dels = p-(x(n)-x(1))
    2 yy = (y(i)*del1+y(im1)*del2)/dels
      yx = (y(i)-y(im1))/dels
      if (sigmap .ne. 0.) go to 3
      yy = yy-del1*del2*(yp(i)*(del1+dels)+yp(im1)*
     *        (del2+dels))/(6.*dels)
      yx = yx+(yp(i)*(2.*del1*del1-del2*(del1+dels))-
     *         yp(im1)*(2.*del2*del2-del1*(del2+dels)))
     *         /(6.*dels)
      yxx = (yp(i)*del1+yp(im1)*del2)/dels
      return
    3 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (s1,c1,sigmap*del1,0)
      call snhcsh (s2,c2,sigmap*del2,0)
      d = sigdel*sigmap*(1.+ss)
      yy = yy+(yp(i)*del1*(s1-ss)+yp(im1)*del2*(s2-ss))/d
      yx = yx+(yp(i)*(c1-ss)-yp(im1)*(c2-ss))/d
      yxx = (yp(i)*(1.+s1)*del1+yp(im1)*(1.+s2)*del2)/
     *       (dels*(1.+ss))
      return
      end
      function curvpi (xl,xu,n,x,y,p,yp,sigma)
c
      integer n
      real xl,xu,x(n),y(n),p,yp(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function integrates a curve specified by a periodic
c spline under tension between two given limits. the
c subroutine curvp1 should be called earlier to determine
c necessary parameters.
c
c on input--
c
c   xl and xu contain the upper and lower limits of inte-
c   gration, respectively. (sl need not be less than or
c   equal to xu, curvpi (xl,xu,...) .eq. -curvpi (xu,xl,...) ).
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   p contains the period.
c
c   yp is an array from subroutine curvp1 containing
c   the values of the second derivatives at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, p, yp, and sigma should be input
c unaltered from the output of curvp1.
c
c on output--
c
c
c   curvpi contains the integral value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvp and
c snhcsh.
c
c--------------------------------------------------------------
c
      integer uper
      logical bdy
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/p
c
c determine actual upper and lower bounds
c
      x1pp = x(1)+p
      isign = 1
      ilm1 = intrvp (xl,x,n,p,xxl)
      lper = int((xl-x(1))/p)
      if (xl .lt. x(1)) lper = lper-1
      ium1 = intrvp (xu,x,n,p,xxu)
      uper = int((xu-x(1))/p)
      if (xu .lt. x(1)) uper = uper-1
      ideltp = uper-lper
      bdy = float(ideltp)*(xxu-xxl) .lt. 0.
      if ((ideltp .eq. 0 .and. xxu .lt. xxl) .or.
     *    ideltp .lt. 0) isign = -1
      if (bdy) ideltp = ideltp-isign
      if (xxu .ge. xxl) go to 1
      xsave = xxl
      xxl = xxu
      xxu = xsave
      isave = ilm1
      ilm1 = ium1
      ium1 = isave
    1 il = ilm1+1
      if (ilm1 .eq. n) il = 1
      xil = x(il)
      if (ilm1 .eq. n) xil = x1pp
      iu = ium1+1
      if (ium1 .eq. n) iu = 1
      xiu = x(iu)
      if (ium1 .eq. n) xiu = x1pp
      s1 = 0.
      if (ilm1 .eq. 1 .or. (ideltp .eq. 0 .and.
     *    .not. bdy)) go to 4
c
c integrate from x(1) to x(ilm1), store in s1
c
      do 3 i = 2,ilm1
        dels = x(i)-x(i-1)
        s1 = s1+(y(i)+y(i-1))*dels/2.
        if (sigma .eq. 0.) go to 2
        call snhcsh (ss,cs,sigmap*dels,3)
        s1 = s1+(yp(i)+yp(i-1))*dels*(cs-ss/2.)/
     *            (sigmap*sigmap*(1.+ss))
        go to 3
    2   s1 = s1-(yp(i)+yp(i-1))*dels*dels*dels/24.
    3   continue
    4 s2 = 0.
      if (x(ilm1) .ge. xxl .or. (ideltp .eq. 0
     *    .and. .not. bdy)) go to 6
c
c integrate from x(ilm1) to xxl, store in s2
c
      del1 = xxl-x(ilm1)
      del2 = xil-xxl
      dels = xil-x(ilm1)
      t1 = del1*del1/(2.*dels)
      t2 = (del2+dels)*del1/(2.*dels)
      s2 = t1*y(il)+t2*y(ilm1)
      if (sigma .eq. 0.) go to 5
      call snhcsh (dummy,c1,sigmap*del1,2)
      call snhcsh (dummy,c2,sigmap*del2,2)
      call snhcsh (ss,cs,sigmap*dels,3)
      s2 = s2+(yp(il)*del1*del1*(c1-ss/2.)+yp(ilm1)*
     *          (dels*dels*(cs-ss/2.)-del2*del2*(c2-ss/2.)))
     *         /(sigmap*sigmap*dels*(1.+ss))
      go to 6
    5 s2 = s2-t1*(del2*(del1+dels)
     *     +dels*dels)*yp(il)/12.
     *     -t2*t2*dels*yp(ilm1)/6.
    6 s3 = 0.
      if (xxl .ge. xil .or. (ideltp .eq. 0 .and. bdy)
     *    .or. ilm1 .eq. ium1) go to 8
c
c integrate from xxl to xil, store in s3
c
      del1 = xxl-x(ilm1)
      del2 = xil-xxl
      dels = xil-x(ilm1)
      t1 = (del1+dels)*del2/(2.*dels)
      t2 = del2*del2/(2.*dels)
      s3 = t1*y(il)+t2*y(ilm1)
      if (sigma .eq. 0.) go to 7
      call snhcsh (dummy,c1,sigmap*del1,2)
      call snhcsh (dummy,c2,sigmap*del2,2)
      call snhcsh (ss,cs,sigmap*dels,3)
      s3 = s3+((dels*dels*(cs-ss/2.)-del1*del1*(c1-ss/2.))
     *           *yp(il)+del2*del2*(c2-ss/2.)*yp(ilm1))/
     *          (sigmap*sigmap*dels*(1.+ss))
      go to 8
    7 s3 = s3-t1*t1*dels*yp(il)/6.
     *     -t2*(del1*(del2+dels)+dels*dels)*
     *     yp(ilm1)/12.
    8 s4 = 0.
      if (ilm1 .ge. ium1-1 .or. (ideltp .eq. 0 .and. bdy))
     *   go to 11
c
c integrate from xil to x(ium1), store in s4
c
      ilp1 = il+1
      do 10 i = ilp1,ium1
        dels = x(i)-x(i-1)
        s4 = s4+(y(i)+y(i-1))*dels/2.
        if (sigma .eq. 0.) go to 9
        call snhcsh (ss,cs,sigmap*dels,3)
        s4 = s4+(yp(i)+yp(i-1))*dels*(cs-ss/2.)/
     *            (sigmap*sigmap*(1.+ss))
        go to 10
    9   s4 = s4-(yp(i)+yp(i-1))*dels*dels*dels/24.
   10   continue
   11 s5 = 0.
      if (x(ium1) .ge. xxu .or. (ideltp .eq. 0 .and. bdy)
     *    .or. ilm1 .eq. ium1) go to 13
c
c integrate from x(ium1) to xxu, store in s5
c
      del1 = xxu-x(ium1)
      del2 = xiu-xxu
      dels = xiu-x(ium1)
      t1 = del1*del1/(2.*dels)
      t2 = (del2+dels)*del1/(2.*dels)
      s5 = t1*y(iu)+t2*y(ium1)
      if (sigma .eq. 0.) go to 12
      call snhcsh (dummy,c1,sigmap*del1,2)
      call snhcsh (dummy,c2,sigmap*del2,2)
      call snhcsh (ss,cs,sigmap*dels,3)
      s5 = s5+(yp(iu)*del1*del1*(c1-ss/2.)+yp(ium1)*
     *          (dels*dels*(cs-ss/2.)-del2*del2*(c2-ss/2.)))
     *         /(sigmap*sigmap*dels*(1.+ss))
      go to 13
   12 s5 = s5-t1*(del2*(del1+dels)
     *     +dels*dels)*yp(iu)/12.
     *     -t2*t2*dels*yp(ium1)/6.
   13 s6 = 0.
      if (xxu .ge. xiu .or. (ideltp .eq. 0 .and.
     *    .not. bdy)) go to 15
c
c integrate from xxu to xiu, store in s6
c
      del1 = xxu-x(ium1)
      del2 = xiu-xxu
      dels = xiu-x(ium1)
      t1 = (del1+dels)*del2/(2.*dels)
      t2 = del2*del2/(2.*dels)
      s6 = t1*y(iu)+t2*y(ium1)
      if (sigma .eq. 0.) go to 14
      call snhcsh (dummy,c1,sigmap*del1,2)
      call snhcsh (dummy,c2,sigmap*del2,2)
      call snhcsh (ss,cs,sigmap*dels,3)
      s6 = s6+((dels*dels*(cs-ss/2.)-del1*del1*(c1-ss/2.))
     *           *yp(iu)+del2*del2*(c2-ss/2.)*yp(ium1))/
     *          (sigmap*sigmap*dels*(1.+ss))
      go to 15
   14 s6 = s6-t1*t1*dels*yp(iu)/6.
     *     -t2*(del1*(del2+dels)+dels*dels)*
     *     yp(ium1)/12.
   15 s7 = 0.
      if (iu .eq. 1 .or. (ideltp .eq. 0 .and. .not. bdy))
     *    go to 18
c
c integrate from xiu to x1pp, store in s7
c
      np1 = n+1
      iup1 = iu+1
      do 17 ii = iup1,np1
        im1 = ii-1
        i = ii
        if (i .eq. np1) i=1
        dels = x(i)-x(im1)
        if (dels .le. 0.) dels=dels+p
        s7 = s7+(y(i)+y(im1))*dels/2.
        if (sigma .eq. 0.) go to 16
        call snhcsh (ss,cs,sigmap*dels,3)
        s7 = s7+(yp(i)+yp(im1))*dels*(cs-ss/2.)/
     *            (sigmap*sigmap*(1.+ss))
        go to 17
   16   s7 = s7-(yp(i)+yp(im1))*dels*dels*dels/24.
   17   continue
   18 s8 = 0.
      if (ilm1 .lt. ium1 .or. (ideltp .eq. 0 .and. bdy))
     *   go to 20
c
c integrate from xxl to xxu, store in s8
c
      delu1 = xxu-x(ium1)
      delu2 = xiu-xxu
      dell1 = xxl-x(ium1)
      dell2 = xiu-xxl
      dels = xiu-x(ium1)
      deli = xxu-xxl
      t1 = (delu1+dell1)*deli/(2.*dels)
      t2 = (delu2+dell2)*deli/(2.*dels)
      s8 = t1*y(iu)+t2*y(ium1)
      if (sigma .eq. 0.) go to 19
      call snhcsh (dummy,cu1,sigmap*delu1,2)
      call snhcsh (dummy,cu2,sigmap*delu2,2)
      call snhcsh (dummy,cl1,sigmap*dell1,2)
      call snhcsh (dummy,cl2,sigmap*dell2,2)
      call snhcsh (ss,dummy,sigmap*dels,-1)
      s8 = s8+(yp(iu)*(delu1*delu1*(cu1-ss/2.)
     *            -dell1*dell1*(cl1-ss/2.))
     *          +yp(ium1)*(dell2*dell2*(cl2-ss/2.)
     *            -delu2*delu2*(cu2-ss/2.)))/
     *          (sigmap*sigmap*dels*(1.+ss))
      go to 20
   19 s8 = s8-t1*(delu2*(dels+delu1)
     *     +dell2*(dels+dell1))*yp(iu)/12.
     *     -t2*(dell1*(dels+dell2)
     *     +delu1*(dels+delu2))*yp(ium1)/12.
   20 so = s1+s2+s6+s7
      si = s3+s4+s5+s8
      if (bdy) go to 21
      curvpi = float(ideltp)*(so+si)+float(isign)*si
      return
   21 curvpi = float(ideltp)*(so+si)+float(isign)*so
      return
      end
      subroutine kurv1 (n,x,y,slp1,slpn,islpsw,xp,yp,temp,s,
     *                  sigma,ierr)
c
      integer n,islpsw,ierr
      real x(n),y(n),slp1,slpn,xp(n),yp(n),temp(n),s(n),
     *     sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a spline under tension forming a curve in the
c plane and passing through a sequence of pairs (x(1),y(1)),
c ...,(x(n),y(n)). for actual computation of points on the
c curve it is necessary to call the subroutine kurv2.
c
c on input--
c
c   n is the number of points to be interpolated (n.ge.2).
c
c   x is an array containing the n x-coordinates of the
c   points.
c
c   y is an array containing the n y-coordinates of the
c   points. (adjacent x-y pairs must be distinct, i. e.
c   either x(i) .ne. x(i+1) or y(i) .ne. y(i+1), for
c   i = 1,...,n-1.)
c
c   slp1 and slpn contain the desired values for the angles
c   (in radians) of the slope at (x(1),y(1)) and (x(n),y(n))
c   respectively. the angles are measured counter-clock-
c   wise from the x-axis and the positive sense of the curve
c   is assumed to be that moving from point 1 to point n.
c   the user may omit values for either or both of these
c   parameters and signal this with islpsw.
c
c   islpsw contains a switch indicating which slope data
c   should be used and which should be estimated by this
c   subroutine,
c          = 0 if slp1 and slpn are to be used,
c          = 1 if slp1 is to be used but not slpn,
c          = 2 if slpn is to be used but not slp1,
c          = 3 if both slp1 and slpn are to be estimated
c              internally.
c
c   xp and yp are arrays of length at least n.
c
c   temp is an array of length at least n which is used
c   for scratch storage.
c
c   s is an array of length at least n.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e.g. .001) the resulting curve is approximately a cubic
c   spline. if abs(sigma) is large (e. g. 50.) the resulting
c   curve is nearly a polygonal line. if sigma equals zero a
c   cubic spline results. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   xp and yp contain information about the curvature of the
c   curve at the given nodes.
c
c   s contains the polygonal arclengths of the curve.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if adjacent coordinate pairs coincide.
c
c and
c
c   n, x, y, slp1, slpn, islpsw, and sigma are unaltered.
c
c this subroutine references package modules ceez, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      np1 = n+1
      ierr = 0
      if (n .le. 1) go to 11
c
c determine polygonal arclengths
c
      s(1) = 0.
      do 1 i = 2,n
        im1 = i-1
    1   s(i) = s(im1)+sqrt((x(i)-x(im1))**2+
     *         (y(i)-y(im1))**2)
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/s(n)
c
c approximate end slopes
c
      if (islpsw .ge. 2) go to 2
      slpp1x = cos(slp1)
      slpp1y = sin(slp1)
      go to 4
    2 dels1 = s(2)-s(1)
      dels2 = dels1+dels1
      if (n .gt. 2) dels2 = s(3)-s(1)
      if (dels1 .eq. 0. .or. dels2 .eq. 0.) go to 12
      call ceez (dels1,dels2,sigmap,c1,c2,c3,n)
      sx = c1*x(1)+c2*x(2)
      sy = c1*y(1)+c2*y(2)
      if (n .eq. 2) go to 3
      sx = sx+c3*x(3)
      sy = sy+c3*y(3)
    3 delt = sqrt(sx*sx+sy*sy)
      slpp1x = sx/delt
      slpp1y = sy/delt
    4 if (islpsw .eq. 1 .or. islpsw .eq. 3) go to 5
      slppnx = cos(slpn)
      slppny = sin(slpn)
      go to 7
    5 delsn = s(n)-s(nm1)
      delsnm = delsn+delsn
      if (n .gt. 2) delsnm = s(n)-s(n-2)
      if (delsn .eq. 0. .or. delsnm .eq. 0.) go to 12
      call ceez (-delsn,-delsnm,sigmap,c1,c2,c3,n)
      sx = c1*x(n)+c2*x(nm1)
      sy = c1*y(n)+c2*y(nm1)
      if (n .eq. 2) go to 6
      sx = sx+c3*x(n-2)
      sy = sy+c3*y(n-2)
    6 delt = sqrt(sx*sx+sy*sy)
      slppnx = sx/delt
      slppny = sy/delt
c
c set up right hand sides and tridiagonal system for xp and
c yp and perform forward elimination
c
    7 dx1 = (x(2)-x(1))/s(2)
      dy1 = (y(2)-y(1))/s(2)
      call terms (diag1,sdiag1,sigmap,s(2))
      xp(1) = (dx1-slpp1x)/diag1
      yp(1) = (dy1-slpp1y)/diag1
      temp(1) = sdiag1/diag1
      if (n .eq. 2) go to 9
      do 8 i = 2,nm1
        dels2 = s(i+1)-s(i)
        if (dels2 .eq. 0.) go to 12
        dx2 = (x(i+1)-x(i))/dels2
        dy2 = (y(i+1)-y(i))/dels2
        call terms (diag2,sdiag2,sigmap,dels2)
        diag = diag1+diag2-sdiag1*temp(i-1)
        diagin = 1./diag
        xp(i) = (dx2-dx1-sdiag1*xp(i-1))*diagin
        yp(i) = (dy2-dy1-sdiag1*yp(i-1))*diagin
        temp(i) = sdiag2*diagin
        dx1 = dx2
        dy1 = dy2
        diag1 = diag2
    8   sdiag1 = sdiag2
    9 diag = diag1-sdiag1*temp(nm1)
      xp(n) = (slppnx-dx1-sdiag1*xp(nm1))/diag
      yp(n) = (slppny-dy1-sdiag1*yp(nm1))/diag
c
c perform back substitution
c
      do 10 i = 2,n
        ibak = np1-i
        xp(ibak) = xp(ibak)-temp(ibak)*xp(ibak+1)
   10   yp(ibak) = yp(ibak)-temp(ibak)*yp(ibak+1)
      return
c
c too few points
c
   11 ierr = 1
      return
c
c coincident adjacent points
c
   12 ierr = 2
      return
      end
      subroutine kurvn1 (n,x,y,xp,yp,temp,s,sigma,ierr)
c
      integer n,ierr
      real x(n),y(n),xp(n),yp(n),temp(n),s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a natural spline under tension forming a curve in
c the plane and passing through a sequence of pairs
c (x(1),y(1)),...,(x(n),y(n)). for actual computation of
c points on the curve it is necessary to call the
c subroutine kurv2.
c
c on input--
c
c   n is the number of points to be interpolated (n.ge.2).
c
c   x is an array containing the n x-coordinates of the
c   points.
c
c   y is an array containing the n y-coordinates of the
c   points. (adjacent x-y pairs must be distinct, i. e.
c   either x(i) .ne. x(i+1) or y(i) .ne. y(i+1), for
c   i = 1,...,n-1.)
c
c   xp and yp are arrays of length at least n.
c
c   temp is an array of length at least n which is used
c   for scratch storage.
c
c   s is an array of length at least n.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e.g. .001) the resulting curve is approximately a cubic
c   spline. if abs(sigma) is large (e. g. 50.) the resulting
c   curve is nearly a polygonal line. if sigma equals zero a
c   cubic spline results. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   xp and yp contain information about the curvature of the
c   curve at the given nodes.
c
c   s contains the polygonal arclengths of the curve.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if adjacent coordinate pairs coincide.
c
c and
c
c   n, x, y, slp1, slpn, islpsw, and sigma are unaltered.
c
c this subroutine references package modules terms and
c  snhcsh.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      np1 = n+1
      ierr = 0
      if (n .le. 1) go to 5
c
c determine polygonal arclengths
c
      s(1) = 0.
      do 1 i = 2,n
        im1 = i-1
    1   s(i) = s(im1)+sqrt((x(i)-x(im1))**2+
     *         (y(i)-y(im1))**2)
c
c denormalize tension factor
c
      if (s(n) .eq. 0.) go to 6
      sigmap = abs(sigma)*float(n-1)/s(n)
c
c set up right hand sides and tridiagonal system for xp and
c yp and perform forward elimination
c
      if (s(2) .eq. 0.) go to 6
      dx1 = (x(2)-x(1))/s(2)
      dy1 = (y(2)-y(1))/s(2)
      call terms (diag1,sdiag1,sigmap,s(2))
      sdiag1 = 0.
      xp(1) = 0.
      yp(1) = 0.
      temp(1) = 0.
      if (n .eq. 2) go to 3
      do 2 i = 2,nm1
        dels2 = s(i+1)-s(i)
        if (dels2 .eq. 0.) go to 6
        dx2 = (x(i+1)-x(i))/dels2
        dy2 = (y(i+1)-y(i))/dels2
        call terms (diag2,sdiag2,sigmap,dels2)
        diag = diag1+diag2-sdiag1*temp(i-1)
        diagin = 1./diag
        xp(i) = (dx2-dx1-sdiag1*xp(i-1))*diagin
        yp(i) = (dy2-dy1-sdiag1*yp(i-1))*diagin
        temp(i) = sdiag2*diagin
        dx1 = dx2
        dy1 = dy2
        diag1 = diag2
    2   sdiag1 = sdiag2
    3 xp(n) = 0.
      yp(n) = 0.
      temp(n-1) = 0.
c
c perform back substitution
c
      do 4 i = 2,n
        ibak = np1-i
        xp(ibak) = xp(ibak)-temp(ibak)*xp(ibak+1)
    4  yp(ibak) = yp(ibak)-temp(ibak)*yp(ibak+1)
      return
c
c too few points
c
    5 ierr = 1
      return
c
c coincident adjacent points
c
    6 ierr = 2
      return
      end
      subroutine kurv2 (t,xs,ys,n,x,y,xp,yp,s,sigma)
c
      integer n
      real t,xs,ys,x(n),y(n),xp(n),yp(n),s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine performs the mapping of points in the
c interval (0.,1.) onto a curve in the plane. the subroutine
c kurv1 should be called earlier to determine certain
c necessary parameters. the resulting curve has a parametric
c representation both of whose components are splines under
c tension and functions of the polygonal arclength
c parameter.
c
c on input--
c
c   t contains a real value to be mapped to a point on the
c   curve. the interval (0.,1.) is mapped onto the entire
c   curve, with 0. mapping to (x(1),y(1)) and 1. mapping
c   to (x(n),y(n)). values outside this interval result in
c   extrapolation.
c
c   n contains the number of points which were specified
c   to determine the curve.
c
c   x and y are arrays containing the x- and y-coordinates
c   of the specified points.
c
c   xp and yp are the arrays output from kurv1 containing
c   curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, xp, yp, s, and sigma should be
c input unaltered from the output of kurv1.
c
c on output--
c
c   xs and ys contain the x- and y-coordinates of the image
c   point on the curve.
c
c none of the input parameters are altered.
c
c this subroutine references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      tn = s(n)*t
      im1 = intrvl(tn,s,n)
      i = im1+1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/s(n)
c
c set up and perform interpolation
c
      del1 = tn-s(im1)
      del2 = s(i)-tn
      dels = s(i)-s(im1)
      sumx = (x(i)*del1+x(im1)*del2)/dels
      sumy = (y(i)*del1+y(im1)*del2)/dels
      if (sigmap .ne. 0.) go to 1
      d = del1*del2/(6.*dels)
      c1 = (del1+dels)*d
      c2 = (del2+dels)*d
      xs = sumx-xp(i)*c1-xp(im1)*c2
      ys = sumy-yp(i)*c1-yp(im1)*c2
      return
    1 sigdel = sigmap*dels
      call snhcsh(ss,dummy,sigdel,-1)
      call snhcsh(s1,dummy,sigmap*del1,-1)
      call snhcsh(s2,dummy,sigmap*del2,-1)
      d = sigdel*sigmap*(1.+ss)
      c1 = del1*(s1-ss)/d
      c2 = del2*(s2-ss)/d
      xs = sumx+xp(i)*c1+xp(im1)*c2
      ys = sumy+yp(i)*c1+yp(im1)*c2
      return
      end
      subroutine kurvd (t,xs,ys,xst,yst,xstt,ystt,n,x,y,xp,
     *                  yp,s,sigma)
c
      integer n
      real t,xs,ys,xst,yst,xstt,ystt,x(n),y(n),xp(n),yp(n),
     *     s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine performs the mapping of points in the
c interval (0.,1.) onto a curve in the plane. it also
c returns the first and second derivatives of the component
c functions. the subroutine kurv1 should be called earlier
c to determine certain necessary parameters. the resulting
c curve has a parametric representation both of whose
c components are splines under tension and functions of the
c polygonal arclength parameter.
c
c on input--
c
c   t contains a real value to be mapped to a point on the
c   curve. the interval (0.,1.) is mapped onto the entire
c   curve, with 0. mapping to (x(1),y(1)) and 1. mapping
c   to (x(n),y(n)). values outside this interval result in
c   extrapolation.
c
c   n contains the number of points which were specified
c   to determine the curve.
c
c   x and y are arrays containing the x- and y-coordinates
c   of the specified points.
c
c   xp and yp are the arrays output from kurv1 containing
c   curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, xp, yp, s, and sigma should be
c input unaltered from the output of kurv1.
c
c on output--
c
c   xs and ys contain the x- and y-coordinates of the image
c   point on the curve. xst and yst contain the first
c   derivatives of the x- and y-components of the mapping
c   with respect to t. xstt and ystt contain the second
c   derivatives of the x- and y-components of the mapping
c   with respect to t.
c
c none of the input parameters are altered.
c
c this subroutine references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      tn = s(n)*t
      im1 = intrvl(tn,s,n)
      i = im1+1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/s(n)
c
c set up and perform interpolation
c
      del1 = tn-s(im1)
      del2 = s(i)-tn
      dels = s(i)-s(im1)
      sumx = (x(i)*del1+x(im1)*del2)/dels
      sumy = (y(i)*del1+y(im1)*del2)/dels
      sumxt = s(n)*(x(i)-x(im1))/dels
      sumyt = s(n)*(y(i)-y(im1))/dels
      if (sigmap .ne. 0.) go to 1
      dels6 = 6.*dels
      d = del1*del2/dels6
      c1 = -(del1+dels)*d
      c2 = -(del2+dels)*d
      dels6 = dels6/s(n)
      ct1 = (2.*del1*del1-del2*(del1+dels))/dels6
      ct2 = -(2.*del2*del2-del1*(del2+dels))/dels6
      dels = dels/(s(n)*s(n))
      ctt1 = del1/dels
      ctt2 = del2/dels
      go to 2
    1 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (s1,co1,sigmap*del1,0)
      call snhcsh (s2,co2,sigmap*del2,0)
      d = sigdel*sigmap*(1.+ss)
      c1 = del1*(s1-ss)/d
      c2 = del2*(s2-ss)/d
      ct1 = (co1-ss)*s(n)/d
      ct2 = -(co2-ss)*s(n)/d
      ctt1 = del1*(1.+s1)*s(n)*s(n)/(dels*(1.+ss))
      ctt2 = del2*(1.+s2)*s(n)*s(n)/(dels*(1.+ss))
    2 xs = sumx+c1*xp(i)+c2*xp(im1)
      ys = sumy+c1*yp(i)+c2*yp(im1)
      xst = sumxt+ct1*xp(i)+ct2*xp(im1)
      yst = sumyt+ct1*yp(i)+ct2*yp(im1)
      xstt = ctt1*xp(i)+ctt2*xp(im1)
      ystt = ctt1*yp(i)+ctt2*yp(im1)
      return
      end
      function arkur (tl,tu,n,x,y,xp,yp,s,sigma)
c
      integer n
      real tl,tu,x(n),y(n),xp(n),yp(n),s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function integrates a curve in the plane specified
c by a spline under tension between two given limits. the
c subroutine kurv1 should be called earlier to determine
c necessary parameters.
c
c on input--
c
c   tl and tu contain the upper and lower limits of inte-
c   gration, respectively. (tl need not be less than or
c   equal to tu, arkur (tl,tu,...) .eq. -arkur (tu,tl,...)).
c   the arclength is measured from the image (using kurv2)
c   of tl to the image of tu.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the x- and y-coordinates
c   of the specified points.
c
c   xp and yp are the arrays output from kurv1 containing
c   curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, xp, yp, s, and sigma should be
c input unaltered from the output of kurv1.
c
c on output--
c
c   arkur contains the arclength.
c
c none of the input parameters are altered.
c
c this function references package modules arcln2, intrvl,
c and snhcsh.
c
c a common block named ar2com is used.
c
c-----------------------------------------------------------
c
      common /ar2com/ sigmap,si,sim1,dels,sxim1,syim1,
     *                sinhms,con,xpi,xpim1,ypi,ypim1
c
      gauss5 (a,b,d) = d*(w1*(arcln2(a+f1*d)+arcln2(b-f1*d))
     *                   +w2*(arcln2(a+f2*d)+arcln2(b-f2*d))
     *                   +w3*arcln2(a+f3*d))
c
c compute constants for 5 point gaussian quadrature
c
      sqt280 = sqrt (280.)
      f1 = (1.-sqrt ((35.+sqt280)/63.))/2.
      f2 = (1.-sqrt (15./(35.+sqt280)))/2.
      f3 = .5
      w1 = 5103./(32200.+650.*sqt280)
      w2 = (644.+13.*sqt280)/3600.
      w3 = 64./225.
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/s(n)
c
c determine actual upper and lower bounds
c
      ttl = s(n)*tl
      ttu = s(n)*tu
      ssign = 1.
      if (tl .lt. tu) go to 1
      ttl = s(n)*tu
      ttu = s(n)*tl
      ssign = -1.
      if (tl .gt. tu) go to 1
c
c return zero if tl .eq. tu
c
      arkur = 0.
      return
c
c search for proper intervals
c
    1 ilm1 = intrvl (ttl,s,n)
      il = ilm1+1
      ium1 = intrvl (ttu,s,n)
      iu = ium1+1
      if (il .eq. iu) go to 8
c
c integrate from ttl to s(il)
c
      sum = 0.
      if (ttl .eq. s(il)) go to 3
      si = s(il)
      sim1 = s(ilm1)
      dels = si-sim1
      sxim1 = (x(il)-x(ilm1))/dels
      syim1 = (y(il)-y(ilm1))/dels
      xpi = xp(il)
      xpim1 = xp(ilm1)
      ypi = yp(il)
      ypim1 = yp(ilm1)
      if (sigma .eq. 0.) go to 2
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
    2 sum = gauss5 (ttl,si,si-ttl)
c
c integrate over interior intervals
c
    3 if (iu-il .eq. 1) go to 6
      ilp1 = il+1
      do 5 i = ilp1,ium1
        si = s(i)
        sim1 = s(i-1)
        dels = si-sim1
        sxim1 = (x(i)-x(i-1))/dels
        syim1 = (y(i)-y(i-1))/dels
        xpi = xp(i)
        xpim1 = xp(i-1)
        ypi = yp(i)
        ypim1 = yp(i-1)
        if (sigma .eq. 0.) go to 4
        call snhcsh (sinhms,dummy,sigmap*dels,-1)
        con = sigmap*sigmap*dels*(1.+sinhms)
    4   sum = sum+gauss5 (sim1,si,si-sim1)
    5   continue
c
c integrate from s(iu-1) to ttu
c
    6 if (ttu .eq. s(ium1)) go to 10
      si = s(iu)
      sim1 = s(ium1)
      dels = si-sim1
      sxim1 = (x(iu)-x(ium1))/dels
      syim1 = (y(iu)-y(ium1))/dels
      xpi = xp(iu)
      xpim1 = xp(ium1)
      ypi = yp(iu)
      ypim1 = yp(ium1)
      if (sigma .eq. 0.) go to 7
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
    7 sum = sum+gauss5 (sim1,ttu,ttu-sim1)
      go to 10
c
c integrate from ttl to ttu
c
    8 si = s(iu)
      sim1 = s(ium1)
      dels = si-sim1
      sxim1 = (x(iu)-x(ium1))/dels
      syim1 = (y(iu)-y(ium1))/dels
      xpi = xp(iu)
      xpim1 = xp(ium1)
      ypi = yp(iu)
      ypim1 = yp(ium1)
      if (sigma .eq. 0.) go to 9
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
    9 sum = gauss5 (ttl,ttu,ttu-ttl)
c
c correct sign and return
c
   10 arkur = ssign*sum
      return
      end
      subroutine kurvp1 (n,x,y,xp,yp,temp,s,sigma,ierr)
c
      integer n,ierr
      real x(n),y(n),xp(n),yp(n),temp(1),s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a spline under tension forming a closed curve in
c the plane and passing through a sequence of pairs
c (x(1),y(1)),...,(x(n),y(n)). for actual computation of
c points on the curve it is necessary to call the subroutine
c kurvp2.
c
c on input--
c
c   n is the number of points to be interpolated (n.ge.2).
c
c   x is an array containing the n x-coordinates of the
c   points.
c
c   y is an array containing the n y-coordinates of the
c   points. (adjacent x-y pairs must be distinct, i. e.
c   either x(i) .ne. x(i+1) or y(i) .ne. y(i+1), for
c   i = 1,...,n-1 and either x(1) .ne. x(n) or y(1) .ne. y(n).)
c
c   xp and yp are arrays of length at least n.
c
c   temp is an array of length at least 2*n which is used
c   for scratch storage.
c
c   s is an array of length at least n.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e.g. .001) the resulting curve is approximately a cubic
c   spline. if abs(sigma) is large (e. g. 50.) the resulting
c   curve is nearly a polygonal line. if sigma equals zero a
c   cubic spline results. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   xp and yp contain information about the curvature of the
c   curve at the given nodes.
c
c   s contains the polygonal arclengths of the curve.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if adjacent coordinate pairs coincide.
c
c and
c
c   n, x, y, and sigma are unaltered,
c
c this subroutine references package modules terms and
c snhcsh.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      np1 = n+1
      ierr = 0
      if (n .le. 1) go to 7
c
c determine polygonal arclengths
c
      s(1) = sqrt((x(n)-x(1))**2+(y(n)-y(1))**2)
      do 1 i = 2,n
        im1 = i-1
    1   s(i) = s(im1)+sqrt((x(i)-x(im1))**2+
     *         (y(i)-y(im1))**2)
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/s(n)
c
c set up right hand sides of tridiagonal (with corner
c elements) linear system for xp and yp
c
      dels1 = s(1)
      if (dels1 .eq. 0.) go to 8
      dx1 = (x(1)-x(n))/dels1
      dy1 = (y(1)-y(n))/dels1
      call terms(diag1,sdiag1,sigmap,dels1)
      dels2 = s(2)-s(1)
      if (dels2 .eq. 0.) go to 8
      dx2 = (x(2)-x(1))/dels2
      dy2 = (y(2)-y(1))/dels2
      call terms(diag2,sdiag2,sigmap,dels2)
      diag = diag1+diag2
      diagin = 1./diag
      xp(1) = (dx2-dx1)*diagin
      yp(1) = (dy2-dy1)*diagin
      temp(np1) = -sdiag1*diagin
      temp(1) = sdiag2*diagin
      dx1 = dx2
      dy1 = dy2
      diag1 = diag2
      sdiag1 = sdiag2
      if (n .eq. 2) go to 3
      do 2 i = 2,nm1
        npi = n+i
        dels2 = s(i+1)-s(i)
        if (dels2 .eq. 0.) go to 8
        dx2 = (x(i+1)-x(i))/dels2
        dy2 = (y(i+1)-y(i))/dels2
        call terms(diag2,sdiag2,sigmap,dels2)
        diag = diag1+diag2-sdiag1*temp(i-1)
        diagin = 1./diag
        xp(i) = (dx2-dx1-sdiag1*xp(i-1))*diagin
        yp(i) = (dy2-dy1-sdiag1*yp(i-1))*diagin
        temp(npi) = -temp(npi-1)*sdiag1*diagin
        temp(i) = sdiag2*diagin
        dx1 = dx2
        dy1 = dy2
        diag1 = diag2
    2   sdiag1 = sdiag2
    3 dels2 = s(1)
      dx2 = (x(1)-x(n))/dels2
      dy2 = (y(1)-y(n))/dels2
      call terms(diag2,sdiag2,sigmap,dels2)
      xp(n) = dx2-dx1
      yp(n) = dy2-dy1
      temp(nm1) = temp(2*n-1)-temp(nm1)
      if (n.eq.2) go to 5
c
c perform first step of back substitution
c
      do 4 i = 3,n
        ibak = np1-i
        npibak = n+ibak
        xp(ibak) = xp(ibak)-temp(ibak)*xp(ibak+1)
        yp(ibak) = yp(ibak)-temp(ibak)*yp(ibak+1)
    4   temp(ibak) = temp(npibak)-temp(ibak)*temp(ibak+1)
    5 xp(n) = (xp(n)-sdiag2*xp(1)-sdiag1*xp(nm1))/
     *        (diag1+diag2+sdiag2*temp(1)+sdiag1*temp(nm1))
      yp(n) = (yp(n)-sdiag2*yp(1)-sdiag1*yp(nm1))/
     *        (diag1+diag2+sdiag2*temp(1)+sdiag1*temp(nm1))
c
c perform second step of back substitution
c
      xpn = xp(n)
      ypn = yp(n)
      do 6 i = 1,nm1
        xp(i) = xp(i)+temp(i)*xpn
    6   yp(i) = yp(i)+temp(i)*ypn
      return
c
c too few points
c
    7 ierr = 1
      return
c
c coincident adjacent points
c
    8 ierr = 2
      return
      end
      subroutine kurvp2 (t,xs,ys,n,x,y,xp,yp,s,sigma)
c
      integer n
      real t,xs,ys,x(n),y(n),xp(n),yp(n),s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine performs the mapping of points in the
c interval (0.,1.) onto a closed curve in the plane. the
c subroutine kurvp1 should be called earlier to determine
c certain necessary parameters. the resulting curve has a
c parametric representation both of whose components are
c periodic splines under tension and functions of the poly-
c gonal arclength parameter.
c
c on input--
c
c   t contains a value to be mapped onto the curve. the
c   interval (0.,1.) is mapped onto the entire closed curve
c   with both 0. and 1. mapping to (x(1),y(1)). the mapping
c   is periodic with period one thus any interval of the
c   form (tt,tt+1.) maps onto the entire curve.
c
c   n contains the number of points which were specified
c   to determine the curve.
c
c   x and y are arrays containing the x- and y-coordinates
c   of the specified points.
c
c   xp and yp are the arrays output from kurvp1 containing
c   curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, xp, yp, s and sigma should
c be input unaltered from the output of kurvp1.
c
c on output--
c
c   xs and ys contain the x- and y-coordinates of the image
c   point on the curve.
c
c none of the input parameters are altered.
c
c this subroutine references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      tn = t-float(ifix(t))
      if (tn .lt. 0.) tn = tn+1.
      tn = s(n)*tn+s(1)
      im1 = n
      if (tn .lt. s(n)) im1 = intrvl(tn,s,n)
      i = im1+1
      if (i .gt. n) i = 1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/s(n)
c
c set up and perform interpolation
c
      si = s(i)
      if (im1 .eq. n) si = s(n)+s(1)
      del1 = tn-s(im1)
      del2 = si-tn
      dels = si-s(im1)
      sumx = (x(i)*del1+x(im1)*del2)/dels
      sumy = (y(i)*del1+y(im1)*del2)/dels
      if (sigmap .ne. 0.) go to 1
      d = del1*del2/(6.*dels)
      c1 = (del1+dels)*d
      c2 = (del2+dels)*d
      xs = sumx-xp(i)*c1-xp(im1)*c2
      ys = sumy-yp(i)*c1-yp(im1)*c2
      return
    1 sigdel = sigmap*dels
      call snhcsh(ss,dummy,sigdel,-1)
      call snhcsh(s1,dummy,sigmap*del1,-1)
      call snhcsh(s2,dummy,sigmap*del2,-1)
      d = sigdel*sigmap*(1.+ss)
      ci = del1*(s1-ss)/d
      cim1 = del2*(s2-ss)/d
      xs = sumx+xp(i)*ci+xp(im1)*cim1
      ys = sumy+yp(i)*ci+yp(im1)*cim1
      return
      end
      subroutine kurvpd (t,xs,ys,xst,yst,xstt,ystt,n,x,y,xp,
     *                  yp,s,sigma)
c
      integer n
      real t,xs,ys,xst,yst,xstt,ystt,x(n),y(n),xp(n),yp(n),
     *     s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine performs the mapping of points in the
c interval (0.,1.) onto a closed curve in the plane. it also
c returns the first and second derivatives of the component
c functions. the subroutine kurvp1 should be called earlier
c to determine certain necessary parameters. the resulting
c curve has a parametric representation both of whose
c components are periodic splines under tension and
c functions of the polygonal arclength parameter.
c
c on input--
c
c   t contains a value to be mapped onto the curve. the
c   interval (0.,1.) is mapped onto the entire closed curve
c   with both 0. and 1. mapping to (x(1),y(1)). the mapping
c   is periodic with period one thus any interval of the
c   form (tt,tt+1.) maps onto the entire curve.
c
c   n contains the number of points which were specified
c   to determine the curve.
c
c   x and y are arrays containing the x- and y-coordinates
c   of the specified points.
c
c   xp and yp are the arrays output from kurvp1 containing
c   curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, xp, yp, s and sigma should
c be input unaltered from the output of kurvp1.
c
c on output--
c
c   xs and ys contain the x- and y-coordinates of the image
c   point on the curve. xst and yst contain the first
c   derivatives of the x- and y-components of the mapping
c   with respect to t. xstt and ystt contain the second
c   derivatives of the x- and y-components of the mapping
c   with respect to t.
c
c none of the input parameters are altered.
c
c this subroutine references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      tn = t-float(ifix(t))
      if (tn .lt. 0.) tn = tn+1.
      tn = s(n)*tn+s(1)
      im1 = n
      if (tn .lt. s(n)) im1 = intrvl(tn,s,n)
      i = im1+1
      if (i .gt. n) i = 1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/s(n)
c
c set up and perform interpolation
c
      si = s(i)
      if (im1 .eq. n) si = s(n)+s(1)
      del1 = tn-s(im1)
      del2 = si-tn
      dels = si-s(im1)
      sumx = (x(i)*del1+x(im1)*del2)/dels
      sumy = (y(i)*del1+y(im1)*del2)/dels
      sumxt = s(n)*(x(i)-x(im1))/dels
      sumyt = s(n)*(y(i)-y(im1))/dels
      if (sigmap .ne. 0.) go to 1
      dels6 = 6.*dels
      d = del1*del2/dels6
      c1 = -(del1+dels)*d
      c2 = -(del2+dels)*d
      dels6 = dels6/s(n)
      ct1 = (2.*del1*del1-del2*(del1+dels))/dels6
      ct2 = -(2.*del2*del2-del1*(del2+dels))/dels6
      dels = dels/(s(n)*s(n))
      ctt1 = del1/dels
      ctt2 = del2/dels
      go to 2
    1 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (s1,co1,sigmap*del1,0)
      call snhcsh (s2,co2,sigmap*del2,0)
      d = sigdel*sigmap*(1.+ss)
      c1 = del1*(s1-ss)/d
      c2 = del2*(s2-ss)/d
      ct1 = (co1-ss)*s(n)/d
      ct2 = -(co2-ss)*s(n)/d
      ctt1 = del1*(1.+s1)*s(n)*s(n)/(dels*(1.+ss))
      ctt2 = del2*(1.+s2)*s(n)*s(n)/(dels*(1.+ss))
    2 xs = sumx+c1*xp(i)+c2*xp(im1)
      ys = sumy+c1*yp(i)+c2*yp(im1)
      xst = sumxt+ct1*xp(i)+ct2*xp(im1)
      yst = sumyt+ct1*yp(i)+ct2*yp(im1)
      xstt = ctt1*xp(i)+ctt2*xp(im1)
      ystt = ctt1*yp(i)+ctt2*yp(im1)
      return
      end
      function arkurp (tl,tu,n,x,y,xp,yp,s,sigma)
c
      integer n
      real tl,tu,x(n),y(n),xp(n),yp(n),s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function integrates a closed curve in the plane
c specified by a spline under tension between two given
c limits. the subroutine kurvp1 should be called earlier to
c determine necessary parameters.
c
c on input--
c
c   tl and tu contain the upper and lower limits of inte-
c   gration, respectively. (tl need not be less than or
c   equal to tu, arkurp(tl,tu,...) .eq. -arkurp(tu,tl,...)).
c   the arclength is measured from the image (using kurvp2)
c   of tl to the image of tu.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the x- and y-coordinates
c   of the specified points.
c
c   xp and yp are the arrays output from kurvp1 containing
c   curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, xp, yp, s, and sigma should be
c input unaltered from the output of kurvp1.
c
c on output--
c
c   arkurp contains the arclength.
c
c none of the input parameters are altered.
c
c this function references package modules arcln2, intrvl,
c and snhcsh.
c
c a common block named ar2com is used.
c
c-----------------------------------------------------------
c
      integer uper
      logical bdy
c
      common /ar2com/ sigmap,si,sim1,dels,sxim1,syim1,
     *                sinhms,con,xpi,xpim1,ypi,ypim1
c
      gauss5 (a,b,d) = d*(w1*(arcln2(a+f1*d)+arcln2(b-f1*d))
     *                   +w2*(arcln2(a+f2*d)+arcln2(b-f2*d))
     *                   +w3*arcln2(a+f3*d))
c
c compute constants for 5 point gaussian quadrature
c
      sqt280 = sqrt (280.)
      f1 = (1.-sqrt ((35.+sqt280)/63.))/2.
      f2 = (1.-sqrt (15./(35.+sqt280)))/2.
      f3 = .5
      w1 = 5103./(32200.+650.*sqt280)
      w2 = (644.+13.*sqt280)/3600.
      w3 = 64./225.
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/s(n)
c
c determine actual upper and lower bounds
c
      s1pp = s(1)+s(n)
      isign = 1
      lper = int(tl)
      if (tl .lt. 0.) lper = lper-1
      ssl = (tl-float(lper))*s(n)+s(1)
      ilm1 = n
      if (ssl .lt. s(n)) ilm1 = intrvl (ssl,s,n)
      uper = int(tu)
      if (tu .lt. 0.) uper = uper-1
      ssu = (tu-float(uper))*s(n)+s(1)
      ium1 = n
      if (ssu .lt. s(n)) ium1 = intrvl (ssu,s,n)
      ideltp = uper-lper
      bdy = float(ideltp)*(ssu-ssl) .lt. 0.
      if ((ideltp .eq. 0 .and. ssu .lt. ssl) .or.
     *    ideltp .lt. 0) isign = -1
      if (bdy) ideltp = ideltp-isign
      if (ssu .ge. ssl) go to 1
      xsave = ssl
      ssl = ssu
      ssu = xsave
      isave = ilm1
      ilm1 = ium1
      ium1 = isave
    1 il = ilm1+1
      if (ilm1 .eq. n) il = 1
      sil = s(il)
      if (ilm1 .eq. n) sil = s1pp
      iu = ium1+1
      if (ium1 .eq. n) iu = 1
      siu = s(iu)
      if (ium1 .eq. n) siu = s1pp
      s1 = 0.
      if (ilm1 .eq. 1 .or. (ideltp .eq. 0 .and.
     *    .not. bdy)) go to 3
c
c integrate from s(1) to s(ilm1), store in s1
c
      do 2 i = 2,ilm1
        si = s(i)
        sim1 = s(i-1)
        dels = si-sim1
        sxim1 = (x(i)-x(i-1))/dels
        syim1 = (y(i)-y(i-1))/dels
        xpi = xp(i)
        xpim1 = xp(i-1)
        ypi = yp(i)
        ypim1 = yp(i-1)
        if (sigma .eq. 0.) go to 2
        call snhcsh (sinhms,dummy,sigmap*dels,-1)
        con = sigmap*sigmap*dels*(1.+sinhms)
    2   s1 = s1+gauss5 (sim1,si,si-sim1)
    3 s2 = 0.
      if (s(ilm1) .ge. ssl .or. (ideltp .eq. 0
     *    .and. .not. bdy)) go to 5
c
c integrate from s(ilm1) to ssl, store in s2
c
      si = sil
      sim1 = s(ilm1)
      dels = si-sim1
      sxim1 = (x(il)-x(ilm1))/dels
      syim1 = (y(il)-y(ilm1))/dels
      xpi = xp(il)
      xpim1 = xp(ilm1)
      ypi = yp(il)
      ypim1 = yp(ilm1)
      if (sigma .eq. 0.) go to 4
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
    4 s2 = s2+gauss5 (sim1,ssl,ssl-sim1)
    5 s3 = 0.
      if (ssl .ge. sil .or. (ideltp .eq. 0 .and. bdy)
     *    .or. ilm1 .eq. ium1) go to 7
c
c integrate from ssl to sil, store in s3
c
      si = sil
      sim1 = s(ilm1)
      dels = si-sim1
      sxim1 = (x(il)-x(ilm1))/dels
      syim1 = (y(il)-y(ilm1))/dels
      xpi = xp(il)
      xpim1 = xp(ilm1)
      ypi = yp(il)
      ypim1 = yp(ilm1)
      if (sigma .eq. 0.) go to 6
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
    6 s3 = s3+gauss5 (ssl,si,si-ssl)
    7 s4 = 0.
      if (ilm1 .ge. ium1-1 .or. (ideltp .eq. 0 .and. bdy))
     *   go to 9
c
c integrate from sil to s(ium1), store in s4
c
      ilp1 = il+1
      do 8 i = ilp1,ium1
        si = s(i)
        sim1 = s(i-1)
        dels = si-sim1
        sxim1 = (x(i)-x(i-1))/dels
        syim1 = (y(i)-y(i-1))/dels
        xpi = xp(i)
        xpim1 = xp(i-1)
        ypi = yp(i)
        ypim1 = yp(i-1)
        if (sigma .eq. 0.) go to 8
        call snhcsh (sinhms,dummy,sigmap*dels,-1)
        con = sigmap*sigmap*dels*(1.+sinhms)
    8   s4 = s4+gauss5 (sim1,si,si-sim1)
    9 s5 = 0.
      if (s(ium1) .ge. ssu .or. (ideltp .eq. 0 .and. bdy)
     *    .or. ilm1 .eq. ium1) go to 11
c
c integrate from s(ium1) to ssu, store in s5
c
      si = siu
      sim1 = s(ium1)
      dels = si-sim1
      sxim1 = (x(iu)-x(ium1))/dels
      syim1 = (y(iu)-y(ium1))/dels
      xpi = xp(iu)
      xpim1 = xp(ium1)
      ypi = yp(iu)
      ypim1 = yp(ium1)
      if (sigma .eq. 0.) go to 10
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
   10 s5 = s5+gauss5 (sim1,ssu,ssu-sim1)
   11 s6 = 0.
      if (ssu .ge. siu .or. (ideltp .eq. 0 .and.
     *    .not. bdy)) go to 13
c
c integrate from ssu to siu, store in s6
c
      si = siu
      sim1 = s(ium1)
      dels = si-sim1
      sxim1 = (x(iu)-x(ium1))/dels
      syim1 = (y(iu)-y(ium1))/dels
      xpi = xp(iu)
      xpim1 = xp(ium1)
      ypi = yp(iu)
      ypim1 = yp(ium1)
      if (sigma .eq. 0.) go to 12
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
   12 s6 = s6+gauss5 (ssu,si,si-ssu)
   13 s7 = 0.
      if (iu .eq. 1 .or. (ideltp .eq. 0 .and. .not. bdy))
     *    go to 15
c
c integrate from siu to s1pp, store in s7
c
      np1 = n+1
      iup1 = iu+1
      do 14 ii = iup1,np1
        im1 = ii-1
        i = ii
        if (i .eq. np1) i=1
        si = s(i)
        if (i .eq. 1) si = s1pp
        sim1 = s(im1)
        dels = si-sim1
        sxim1 = (x(i)-x(im1))/dels
        syim1 = (y(i)-y(im1))/dels
        xpi = xp(i)
        xpim1 = xp(im1)
        ypi = yp(i)
        ypim1 = yp(im1)
        if (sigma .eq. 0.) go to 14
        call snhcsh (sinhms,dummy,sigmap*dels,-1)
        con = sigmap*sigmap*dels*(1.+sinhms)
   14   s7 = s7+gauss5 (sim1,si,si-sim1)
   15 s8 = 0.
      if (ilm1 .lt. ium1 .or. (ideltp .eq. 0 .and. bdy))
     *   go to 17
c
c integrate from ssl to ssu, store in s8
c
      si = siu
      sim1 = s(ium1)
      dels = si-sim1
      sxim1 = (x(iu)-x(ium1))/dels
      syim1 = (y(iu)-y(ium1))/dels
      xpi = xp(iu)
      xpim1 = xp(ium1)
      ypi = yp(iu)
      ypim1 = yp(ium1)
      if (sigma .eq. 0.) go to 16
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
   16 s8 = s8+gauss5 (ssl,ssu,ssu-ssl)
   17 so = s1+s2+s6+s7
      si = s3+s4+s5+s8
      if (bdy) go to 18
      arkurp = float(ideltp)*(so+si)+float(isign)*si
      return
   18 arkurp = float(ideltp)*(so+si)+float(isign)*so
      return
      end
      function areakp (n,x,y,xp,yp,s,sigma)
c
      integer n
      real x(n),y(n),xp(n),yp(n),s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function determines the area enclosed by a closed
c curve in the plane. the sign associated with the area is
c such that the area is positive if the curve passes around
c the interior in a counter-clockwise fashion (and negative
c if clockwise). the subroutine kurvp1 should be called
c earlier to determine certain necessary parameters.
c
c on input--
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the x- and y-coordinates
c   of the specified points.
c
c   xp and yp are the arrays output from kurvp1 containing
c   curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, xp, yp, s, and sigma should be
c input unaltered from the output of kurvp1.
c
c on output--
c
c   areakp contains the area.
c
c none of the input parameters are altered.
c
c this function references package modules area and snhcsh.
c
c a common block named arecom is used.
c
c-----------------------------------------------------------
c
      common /arecom/ sigmap,si,sim1,dels,xi,xim1,syim1,
     *                sinhms,con,xpi,xpim1,ypi,ypim1
c
      gauss5 (a,b,d) = d*(w1*(area(a+f1*d)+area(b-f1*d))
     *                   +w2*(area(a+f2*d)+area(b-f2*d))
     *                   +w3*area(a+f3*d))
c
c compute constants for 5 point gaussian quadrature
c
      sqt280 = sqrt (280.)
      f1 = (1.-sqrt ((35.+sqt280)/63.))/2.
      f2 = (1.-sqrt (15./(35.+sqt280)))/2.
      f3 = .5
      w1 = 5103./(32200.+650.*sqt280)
      w2 = (644.+13.*sqt280)/3600.
      w3 = 64./225.
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/s(n)
c
c integrate from zero to s(n)
c
      nd2 = n/2
      xav = (x(1)+x(nd2+1))/2.
      ar = 0.
      do 1 im1 = 1,n
        i = im1+1
        if (im1 .eq. n) i = 1
        si = s(i)
        if (i .eq. 1) si = s(1)+s(n)
        sim1 = s(im1)
        dels = si-sim1
        xi = x(i)-xav
        xim1 = x(im1)-xav
        syim1 = (y(i)-y(im1))/dels
        xpi = xp(i)
        xpim1 = xp(im1)
        ypi = yp(i)
        ypim1 = yp(im1)
        if (sigma .eq. 0.) go to 1
        call snhcsh (sinhms,dummy,sigmap*dels,-1)
        con = sigmap*sigmap*dels*(1.+sinhms)
    1   ar = ar+gauss5 (sim1,si,si-sim1)
      areakp = ar
      return
      end
      subroutine qurv1 (n,x,y,z,slp1x,slp1y,slp1z,slpnx,
     *                  slpny,slpnz,islpsw,xp,yp,zp,temp,
     *                  s,sigma,ierr)
c
      integer n,islpsw,ierr
      real x(n),y(n),z(n),slp1x,slp1y,slp1z,slpnx,slpny,
     *     slpnz,xp(n),yp(n),zp(n),temp(n),s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a spline under tension passing through a sequence
c of triples (x(1),y(1),z(1)),...,(x(n),y(n),z(n)). the
c slopes at the two ends of the curve may be specified or
c omitted. for actual computation of points on the curve
c it is necessary to call the subroutine qurv2.
c
c on input--
c
c   n is the number of points to be interpolated (n.ge.2).
c
c   x is an array containing the n x-coordinates of the
c   points.
c
c   y is an array containing the n y-coordinates of the
c   points.
c
c   z is an array containing the n z-coordinates of the
c   points. (adjacent x-y-z triples must be distinct, i. e.
c   either x(i) .ne. x(i+1) or y(i) .ne. y(i+1) or z(i) .ne.
c   z(i+1), for i = 1,...,n-1 ).
c
c   slp1x, slp1y, slp1z and slpnx, slpny, slpnz contain the
c   desired values of the components of tangent vectors to
c   the curve at (x(1),y(1),z(1)) and(x(n),y(n),z(n)),
c   respectively. the positive sense of the curve is assumed
c   to be that moving from point 1 to point n. the user may
c   omit values for either or both of these triples and
c   signal this with islpsw.
c
c   islpsw contains a switch indicating which slope data
c   should be used and which should be estimated by this
c   subroutine,
c          = 0 if slp1x, slp1y, slp1z and slpnx, slpny,
c              slpnz are to be used,
c          = 1 if slp1x, slp1y, slp1z are to be used but
c              not slpnx, slpny, slpnz,
c          = 2 if slpnx, slpny, slpnz are to be used but
c              not slp1x, slp1y, slp1z,
c          = 3 if both end-tangents are to be estimated
c              internally.
c
c   xp, yp, and zp are arrays of length at least n.
c
c   temp is an array of length at least n which is used
c   for scratch storage.
c
c   s is an array of length at least n.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e.g. .001) the resulting curve is approximately a cubic
c   spline. if abs(sigma) is large (e. g. 50.) the resulting
c   curve is nearly a polygonal line. if sigma equals zero a
c   cubic spline results. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   xp, yp, and zp contain information about the curvature
c   of the curve at the given nodes.
c
c   s contains the polygonal arclengths of the curve.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if adjacent triples coincide.
c
c and
c
c   n, x, y, z, slp1x, slp1y, slp1z, slpnx, slpny, slpnz,
c   islpsw, and sigma are unaltered,
c
c this subroutine references package modules ceez, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      np1 = n+1
      ierr = 0
      if (n .le. 1) go to 9
c
c determine polygonal arclengths
c
      s(1) = 0.
      do 1 i = 2,n
        im1 = i-1
    1   s(i) = s(im1)+sqrt((x(i)-x(im1))**2+(y(i)-y(im1))**2
     *       +(z(i)-z(im1))**2)
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/s(n)
c
c approximate end slopes
c
      if (islpsw .ge. 2) go to 2
      slpp1x = slp1x
      slpp1y = slp1y
      slpp1z = slp1z
      go to 3
    2 dels1 = s(2)-s(1)
      dels2 = dels1+dels1
      if (n .gt. 2) dels2 = s(3)-s(1)
      if (dels1 .eq. 0. .or. dels2 .eq. 0.) go to 10
      call ceez (dels1,dels2,sigmap,c1,c2,c3,n)
      slpp1x = c1*x(1)+c2*x(2)
      slpp1y = c1*y(1)+c2*y(2)
      slpp1z = c1*z(1)+c2*z(2)
      if (n .eq. 2) go to 3
      slpp1x = slpp1x+c3*x(3)
      slpp1y = slpp1y+c3*y(3)
      slpp1z = slpp1z+c3*z(3)
    3 delt = sqrt(slpp1x*slpp1x+slpp1y*slpp1y+slpp1z*slpp1z)
      slpp1x = slpp1x/delt
      slpp1y = slpp1y/delt
      slpp1z = slpp1z/delt
      if (islpsw .eq. 1 .or. islpsw .eq. 3) go to 4
      slppnx = slpnx
      slppny = slpny
      slppnz = slpnz
      go to 5
    4 delsn = s(n)-s(nm1)
      delsnm = delsn+delsn
      if (n .gt. 2) delsnm = s(n)-s(n-2)
      if (delsn .eq. 0. .or. delsnm .eq. 0.) go to 10
      call ceez (-delsn,-delsnm,sigmap,c1,c2,c3,n)
      slppnx = c1*x(n)+c2*x(nm1)
      slppny = c1*y(n)+c2*y(nm1)
      slppnz = c1*z(n)+c2*z(nm1)
      if (n .eq. 2) go to 5
      slppnx = slppnx+c3*x(n-2)
      slppny = slppny+c3*y(n-2)
      slppnz = slppnz+c3*z(n-2)
    5 delt = sqrt(slppnx*slppnx+slppny*slppny+slppnz*slppnz)
      slppnx = slppnx/delt
      slppny = slppny/delt
      slppnz = slppnz/delt
c
c set up right hand sides and tridiagonal system for xp, yp
c and zp and perform forward elimination
c
      dx1 = (x(2)-x(1))/s(2)
      dy1 = (y(2)-y(1))/s(2)
      dz1 = (z(2)-z(1))/s(2)
      call terms (diag1,sdiag1,sigmap,s(2))
      xp(1) = (dx1-slpp1x)/diag1
      yp(1) = (dy1-slpp1y)/diag1
      zp(1) = (dz1-slpp1z)/diag1
      temp(1) = sdiag1/diag1
      if (n .eq. 2) go to 7
      do 6 i = 2,nm1
        dels2 = s(i+1)-s(i)
        if (dels2 .eq. 0.) go to 10
        dx2 = (x(i+1)-x(i))/dels2
        dy2 = (y(i+1)-y(i))/dels2
        dz2 = (z(i+1)-z(i))/dels2
        call terms (diag2,sdiag2,sigmap,dels2)
        diag = diag1+diag2-sdiag1*temp(i-1)
        diagin = 1./diag
        xp(i) = (dx2-dx1-sdiag1*xp(i-1))*diagin
        yp(i) = (dy2-dy1-sdiag1*yp(i-1))*diagin
        zp(i) = (dz2-dz1-sdiag1*zp(i-1))*diagin
        temp(i) = sdiag2*diagin
        dx1 = dx2
        dy1 = dy2
        dz1 = dz2
        diag1 = diag2
    6   sdiag1 = sdiag2
    7 diag = diag1-sdiag1*temp(nm1)
      xp(n) = (slppnx-dx1-sdiag1*xp(nm1))/diag
      yp(n) = (slppny-dy1-sdiag1*yp(nm1))/diag
      zp(n) = (slppnz-dz1-sdiag1*zp(nm1))/diag
c
c perform back substitution
c
      do 8 i = 2,n
        ibak = np1-i
        t = temp(ibak)
        xp(ibak) = xp(ibak)-t*xp(ibak+1)
        yp(ibak) = yp(ibak)-t*yp(ibak+1)
    8   zp(ibak) = zp(ibak)-t*zp(ibak+1)
      return
c
c too few points
c
    9 ierr = 1
      return
c
c coincident adjacent points
c
   10 ierr = 2
      return
      end
      subroutine qurvn1 (n,x,y,z,xp,yp,zp,temp,s,sigma,ierr)
c
      integer n,ierr
      real x(n),y(n),z(n),xp(n),yp(n),zp(n),temp(n),s(n),
     *     sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a natural spline under tension passing through a
c sequence of triples (x(1),y(1),z(1)),...,(x(n),y(n),z(n)).
c for actual computation of points on the curve it is
c necessary to call the subroutine qurv2.
c
c on input--
c
c   n is the number of points to be interpolated (n.ge.2).
c
c   x is an array containing the n x-coordinates of the
c   points.
c
c   y is an array containing the n y-coordinates of the
c   points.
c
c   z is an array containing the n z-coordinates of the
c   points. (adjacent x-y-z triples must be distinct, i. e.
c   either x(i) .ne. x(i+1) or y(i) .ne. y(i+1) or z(i) .ne.
c   z(i+1), for i = 1,...,n-1 ).
c
c   xp, yp, and zp are arrays of length at least n.
c
c   temp is an array of length at least n which is used
c   for scratch storage.
c
c   s is an array of length at least n.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e.g. .001) the resulting curve is approximately a cubic
c   spline. if abs(sigma) is large (e. g. 50.) the resulting
c   curve is nearly a polygonal line. if sigma equals zero a
c   cubic spline results. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   xp, yp, and zp contain information about the curvature
c   of the curve at the given nodes.
c
c   s contains the polygonal arclengths of the curve.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if adjacent triples coincide.
c
c and
c
c   n, x, y, z, and sigma are unaltered.
c
c this subroutine references package modules terms and
c snhcsh.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      np1 = n+1
      ierr = 0
      if (n .le. 1) go to 5
c
c determine polygonal arclengths
c
      s(1) = 0.
      do 1 i = 2,n
        im1 = i-1
    1   s(i) = s(im1)+sqrt((x(i)-x(im1))**2+(y(i)-y(im1))**2
     *       +(z(i)-z(im1))**2)
c
c denormalize tension factor
c
      if (s(n) .eq. 0.) go to 6
      sigmap = abs(sigma)*float(n-1)/s(n)
c
c set up right hand sides and tridiagonal system for xp, yp
c and zp and perform forward elimination
c
      if (s(2) .eq. 0.) go to 6
      dx1 = (x(2)-x(1))/s(2)
      dy1 = (y(2)-y(1))/s(2)
      dz1 = (z(2)-z(1))/s(2)
      call terms (diag1,sdiag1,sigmap,s(2))
      sdiag1 = 0.
      xp(1) = 0.
      yp(1) = 0.
      zp(1) = 0.
      temp(1) = 0.
      if (n .eq. 2) go to 3
      do 2 i = 2,nm1
        dels2 = s(i+1)-s(i)
        if (dels2 .eq. 0.) go to 6
        dx2 = (x(i+1)-x(i))/dels2
        dy2 = (y(i+1)-y(i))/dels2
        dz2 = (z(i+1)-z(i))/dels2
        call terms (diag2,sdiag2,sigmap,dels2)
        diag = diag1+diag2-sdiag1*temp(i-1)
        diagin = 1./diag
        xp(i) = (dx2-dx1-sdiag1*xp(i-1))*diagin
        yp(i) = (dy2-dy1-sdiag1*yp(i-1))*diagin
        zp(i) = (dz2-dz1-sdiag1*zp(i-1))*diagin
        temp(i) = sdiag2*diagin
        dx1 = dx2
        dy1 = dy2
        dz1 = dz2
        diag1 = diag2
    2   sdiag1 = sdiag2
    3 diag = diag1-sdiag1*temp(nm1)
      xp(n) = 0.
      yp(n) = 0.
      zp(n) = 0.
      temp(n-1) = 0.
c
c perform back substitution
c
      do 4 i = 2,n
        ibak = np1-i
        t = temp(ibak)
        xp(ibak) = xp(ibak)-t*xp(ibak+1)
        yp(ibak) = yp(ibak)-t*yp(ibak+1)
    4   zp(ibak) = zp(ibak)-t*zp(ibak+1)
      return
c
c too few points
c
    5 ierr = 1
      return
c
c coincident adjacent points
c
    6 ierr = 2
      return
      end
      subroutine qurv2 (t,xs,ys,zs,n,x,y,z,xp,yp,zp,s,sigma)
c
      integer n
      real t,xs,ys,zs,x(n),y(n),z(n),xp(n),yp(n),zp(n),s(n)
      real sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine performs the mapping of points in the
c interval (0.,1.) onto a curve in space.  the subroutine
c qurv1 should be called earlier to determine certain
c necessary parameters. the resulting curve has a parametric
c representation all of whose components are splines under
c tension and functions of the polygonal arclength
c parameter.
c
c on input--
c
c   t contains a real value to be mapped to a point on the
c   curve. the interval (0.,1.) is mapped onto the entire
c   curve, with 0. mapping to (x(1),y(1,z(1)) and 1. mapping
c   to (x(n),y(n),z(n)). values outside this interval result
c   in extrapolation.
c
c   n contains the number of points which were specified
c   to determine the curve.
c
c   x, y, and z are arrays containing the x-, y- and z-
c   coordinates of the specified points.
c
c   xp, yp, and zp are the arrays output from qurv1
c   containing curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, z, xp, yp, zp, s, and sigma
c should be input unaltered from the output of qurv1.
c
c on output--
c
c   xs, ys and zs contain the x-, y- and z-coordinates of
c   the image point on the curve.
c
c none of the input parameters are altered.
c
c this subroutine references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      tn = s(n)*t
      im1 = intrvl(tn,s,n)
      i = im1+1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/s(n)
c
c set up and perform interpolation
c
      del1 = tn-s(im1)
      del2 = s(i)-tn
      dels = s(i)-s(im1)
      sumx = (x(i)*del1+x(im1)*del2)/dels
      sumy = (y(i)*del1+y(im1)*del2)/dels
      sumz = (z(i)*del1+z(im1)*del2)/dels
      if (sigmap .ne. 0.) go to 1
      d = del1*del2/(6.*dels)
      c1 = (del1+dels)*d
      c2 = (del2+dels)*d
      xs = sumx-xp(i)*c1-xp(im1)*c2
      ys = sumy-yp(i)*c1-yp(im1)*c2
      zs = sumz-zp(i)*c1-zp(im1)*c2
      return
    1 sigdel = sigmap*dels
      call snhcsh(ss,dummy,sigdel,-1)
      call snhcsh(s1,dummy,sigmap*del1,-1)
      call snhcsh(s2,dummy,sigmap*del2,-1)
      d = sigdel*sigmap*(1.+ss)
      c1 = del1*(s1-ss)/d
      c2 = del2*(s2-ss)/d
      xs = sumx+xp(i)*c1+xp(im1)*c2
      ys = sumy+yp(i)*c1+yp(im1)*c2
      zs = sumz+zp(i)*c1+zp(im1)*c2
      return
      end
      subroutine qurvd (t,xs,ys,zs,xst,yst,zst,xstt,ystt,
     *                  zstt,n,x,y,z,xp,yp,zp,s,sigma)
c
      integer n
      real t,xs,ys,zs,xst,yst,zst,xstt,ystt,zstt,x(n),y(n),
     *     z(n),xp(n),yp(n),zp(n),s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine performs the mapping of points in the
c interval (0.,1.) onto a curve in space. it also returns
c the first and second derivatives of the component
c functions. the subroutine qurv1 should be called earlier
c to determine certain necessary parameters. the resulting
c curve has a parametric representation all of whose
c components are splines under tension and functions of the
c polygonal arclength parameter.
c
c on input--
c
c   t contains a real value to be mapped to a point on the
c   curve. the interval (0.,1.) is mapped onto the entire
c   curve, with 0. mapping to (x(1),y(1,z(1)) and 1. mapping
c   to (x(n),y(n),z(n)). values outside this interval result
c   in extrapolation.
c
c   n contains the number of points which were specified
c   to determine the curve.
c
c   x, y, and z are arrays containing the x-, y- and z-
c   coordinates of the specified points.
c
c   xp, yp, and zp are the arrays output from qurv1
c   containing curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, z, xp, yp, zp, s, and sigma
c should be input unaltered from the output of qurv1.
c
c on output--
c
c   xs, ys, and zs contain the x-, y-, and z-coordinates of
c   the image point on the curve. xst, yst, and zst contain
c   the first derivatives of the x-, y-, and z-components of
c   the mapping with respect to t. xstt, ystt, and zstt
c   contain the second derivatives of the x-, y-, and z-
c   components of the mapping with respect to t.
c   with respect to t.
c
c none of the input parameters are altered.
c
c this subroutine references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      tn = s(n)*t
      im1 = intrvl(tn,s,n)
      i = im1+1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/s(n)
c
c set up and perform interpolation
c
      del1 = tn-s(im1)
      del2 = s(i)-tn
      dels = s(i)-s(im1)
      sumx = (x(i)*del1+x(im1)*del2)/dels
      sumy = (y(i)*del1+y(im1)*del2)/dels
      sumz = (z(i)*del1+z(im1)*del2)/dels
      sumxt = s(n)*(x(i)-x(im1))/dels
      sumyt = s(n)*(y(i)-y(im1))/dels
      sumzt = s(n)*(z(i)-z(im1))/dels
      if (sigmap .ne. 0.) go to 1
      dels6 = 6.*dels
      d = del1*del2/dels6
      c1 = -(del1+dels)*d
      c2 = -(del2+dels)*d
      dels6 = dels6/s(n)
      ct1 = (2.*del1*del1-del2*(del1+dels))/dels6
      ct2 = -(2.*del2*del2-del1*(del2+dels))/dels6
      dels = dels/(s(n)*s(n))
      ctt1 = del1/dels
      ctt2 = del2/dels
      go to 2
    1 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (s1,co1,sigmap*del1,0)
      call snhcsh (s2,co2,sigmap*del2,0)
      d = sigdel*sigmap*(1.+ss)
      c1 = del1*(s1-ss)/d
      c2 = del2*(s2-ss)/d
      ct1 = (co1-ss)*s(n)/d
      ct2 = -(co2-ss)*s(n)/d
      ctt1 = del1*(1.+s1)*s(n)*s(n)/(dels*(1.+ss))
      ctt2 = del2*(1.+s2)*s(n)*s(n)/(dels*(1.+ss))
    2 xs = sumx+c1*xp(i)+c2*xp(im1)
      ys = sumy+c1*yp(i)+c2*yp(im1)
      zs = sumz+c1*zp(i)+c2*zp(im1)
      xst = sumxt+ct1*xp(i)+ct2*xp(im1)
      yst = sumyt+ct1*yp(i)+ct2*yp(im1)
      zst = sumzt+ct1*zp(i)+ct2*zp(im1)
      xstt = ctt1*xp(i)+ctt2*xp(im1)
      ystt = ctt1*yp(i)+ctt2*yp(im1)
      zstt = ctt1*zp(i)+ctt2*zp(im1)
      return
      end
      function arqur (tl,tu,n,x,y,z,xp,yp,zp,s,sigma)
c
      integer n
      real tl,tu,x(n),y(n),z(n),xp(n),yp(n),zp(n),s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function integrates a curve in three dimensions
c specified by a spline under tension between two given
c limits. the subroutine qurv1 should be called earlier to
c determine necessary parameters.
c
c on input--
c
c   tl and tu contain the upper and lower limits of inte-
c   gration, respectively. (tl need not be less than or
c   equal to tu, arqur (tl,tu,...) .eq. -arqur (tu,tl,...)).
c   the arclength is measured from the image (using qurv2)
c   of tl to the image of tu.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x, y, and z are arrays containing the x-, y-, and z-
c   cordinates of the specified points.
c
c   xp, yp, and zp are the arrays output from qurv1
c   containing curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, z, xp, yp, zp, s, and sigma should
c be input unaltered from the output of qurv1.
c
c on output--
c
c   arqur contains the arclength.
c
c none of the input parameters are altered.
c
c this function references package modules arcln3, intrvl,
c and snhcsh.
c
c a common block named ar3com is used.
c
c-----------------------------------------------------------
c
      common /ar3com/ sigmap,si,sim1,dels,sxim1,syim1,
     *                szim1,sinhms,con,xpi,xpim1,ypi,ypim1,
     *                zpi,zpim1
c
      gauss5 (a,b,d) = d*(w1*(arcln3(a+f1*d)+arcln3(b-f1*d))
     *                   +w2*(arcln3(a+f2*d)+arcln3(b-f2*d))
     *                   +w3*arcln3(a+f3*d))
c
c compute constants for 5 point gaussian quadrature
c
      sqt280 = sqrt (280.)
      f1 = (1.-sqrt ((35.+sqt280)/63.))/2.
      f2 = (1.-sqrt (15./(35.+sqt280)))/2.
      f3 = .5
      w1 = 5103./(32200.+650.*sqt280)
      w2 = (644.+13.*sqt280)/3600.
      w3 = 64./225.
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/s(n)
c
c determine actual upper and lower bounds
c
      ttl = s(n)*tl
      ttu = s(n)*tu
      ssign = 1.
      if (tl .lt. tu) go to 1
      ttl = s(n)*tu
      ttu = s(n)*tl
      ssign = -1.
      if (tl .gt. tu) go to 1
c
c return zero if tl .eq. tu
c
      arqur = 0.
      return
c
c search for proper intervals
c
    1 ilm1 = intrvl (ttl,s,n)
      il = ilm1+1
      ium1 = intrvl (ttu,s,n)
      iu = ium1+1
      if (il .eq. iu) go to 8
c
c integrate from ttl to s(il)
c
      sum = 0.
      if (ttl .eq. s(il)) go to 3
      si = s(il)
      sim1 = s(ilm1)
      dels = si-sim1
      sxim1 = (x(il)-x(ilm1))/dels
      syim1 = (y(il)-y(ilm1))/dels
      szim1 = (z(il)-z(ilm1))/dels
      xpi = xp(il)
      xpim1 = xp(ilm1)
      ypi = yp(il)
      ypim1 = yp(ilm1)
      zpi = zp(il)
      zpim1 = zp(ilm1)
      if (sigma .eq. 0.) go to 2
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
    2 sum = gauss5 (ttl,si,si-ttl)
c
c integrate over interior intervals
c
    3 if (iu-il .eq. 1) go to 6
      ilp1 = il+1
      do 5 i = ilp1,ium1
        si = s(i)
        sim1 = s(i-1)
        dels = si-sim1
        sxim1 = (x(i)-x(i-1))/dels
        syim1 = (y(i)-y(i-1))/dels
        szim1 = (z(i)-z(i-1))/dels
        xpi = xp(i)
        xpim1 = xp(i-1)
        ypi = yp(i)
        ypim1 = yp(i-1)
        zpi = zp(i)
        zpim1 = zp(i-1)
        if (sigma .eq. 0.) go to 4
        call snhcsh (sinhms,dummy,sigmap*dels,-1)
        con = sigmap*sigmap*dels*(1.+sinhms)
    4   sum = sum+gauss5 (sim1,si,si-sim1)
    5   continue
c
c integrate from s(iu-1) to ttu
c
    6 if (ttu .eq. s(ium1)) go to 10
      si = s(iu)
      sim1 = s(ium1)
      dels = si-sim1
      sxim1 = (x(iu)-x(ium1))/dels
      syim1 = (y(iu)-y(ium1))/dels
      szim1 = (z(iu)-z(ium1))/dels
      xpi = xp(iu)
      xpim1 = xp(ium1)
      ypi = yp(iu)
      ypim1 = yp(ium1)
      zpi = zp(iu)
      zpim1 = zp(ium1)
      if (sigma .eq. 0.) go to 7
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
    7 sum = sum+gauss5 (sim1,ttu,ttu-sim1)
      go to 10
c
c integrate from ttl to ttu
c
    8 si = s(iu)
      sim1 = s(ium1)
      dels = si-sim1
      sxim1 = (x(iu)-x(ium1))/dels
      syim1 = (y(iu)-y(ium1))/dels
      szim1 = (z(iu)-z(ium1))/dels
      xpi = xp(iu)
      xpim1 = xp(ium1)
      ypi = yp(iu)
      ypim1 = yp(ium1)
      zpi = zp(iu)
      zpim1 = zp(ium1)
      if (sigma .eq. 0.) go to 9
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
    9 sum = gauss5 (ttl,ttu,ttu-ttl)
c
c correct sign and return
c
   10 arqur = ssign*sum
      return
      end
      subroutine qurvp1 (n,x,y,z,xp,yp,zp,temp,s,sigma,ierr)
c
      integer n,ierr
      real x(n),y(n),z(n),xp(n),yp(n),zp(n),temp(1),s(n),
     *     sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a spline under tension forming a closed curve in
c three dimensional space passing through a sequence of
c triples (x(1),y(1),z(1)),...,(x(n),y(n),z(n)). for actual
c computation of points on the curve it is necessary to call
c the subroutine qurvp2.
c
c on input--
c
c   n is the number of points to be interpolated (n.ge.2).
c
c   x is an array containing the n x-coordinates of the
c   points.
c
c   y is an array containing the n y-coordinates of the
c   points.
c
c   z is an array containing the n z-coordinates of the
c   points. (adjacent x-y-z triples must be distinct, i. e.
c   either x(i) .ne. x(i+1) or y(i) .ne. y(i+1) or z(i) .ne.
c   z(i+1), for i = 1,...,n-1 and either x(1) .ne. x(n) or
c   y(1) .ne. y(n) or z(1) .ne. z(n).)
c   xp, yp, and zp are arrays of length at least n.
c
c   temp is an array of length at least 2*n which is used
c   for scratch storage.
c
c   s is an array of length at least n.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e.g. .001) the resulting curve is approximately a cubic
c   spline. if abs(sigma) is large (e. g. 50.) the resulting
c   curve is nearly a polygonal line. if sigma equals zero a
c   cubic spline results. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   xp, yp, and zp contain information about the curvature
c   of the curve at the given nodes.
c
c   s contains the polygonal arclengths of the curve.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if adjacent coordinate pairs coincide.
c
c and
c
c   n, x, y, z, and sigma are unaltered,
c
c this subroutine references package modules terms and
c snhcsh.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      np1 = n+1
      ierr = 0
      if (n .le. 1) go to 7
c
c determine polygonal arclengths
c
      s(1) = sqrt((x(n)-x(1))**2+(y(n)-y(1))**2+
     *            (z(n)-z(1))**2)
      do 1 i = 2,n
        im1 = i-1
    1   s(i) = s(im1)+sqrt((x(i)-x(im1))**2+
     *         (y(i)-y(im1))**2+(z(i)-z(im1))**2)
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/s(n)
c
c set up right hand sides of tridiagonal (with corner
c elements) linear system for xp, yp, and zp
c
      dels1 = s(1)
      if (dels1 .eq. 0.) go to 8
      dx1 = (x(1)-x(n))/dels1
      dy1 = (y(1)-y(n))/dels1
      dz1 = (z(1)-z(n))/dels1
      call terms(diag1,sdiag1,sigmap,dels1)
      dels2 = s(2)-s(1)
      if (dels2 .eq. 0.) go to 8
      dx2 = (x(2)-x(1))/dels2
      dy2 = (y(2)-y(1))/dels2
      dz2 = (z(2)-z(1))/dels2
      call terms(diag2,sdiag2,sigmap,dels2)
      diag = diag1+diag2
      diagin = 1./diag
      xp(1) = (dx2-dx1)*diagin
      yp(1) = (dy2-dy1)*diagin
      zp(1) = (dz2-dz1)*diagin
      temp(np1) = -sdiag1*diagin
      temp(1) = sdiag2*diagin
      dx1 = dx2
      dy1 = dy2
      dz1 = dz2
      diag1 = diag2
      sdiag1 = sdiag2
      if (n .eq. 2) go to 3
      do 2 i = 2,nm1
        npi = n+i
        dels2 = s(i+1)-s(i)
        if (dels2 .eq. 0.) go to 8
        dx2 = (x(i+1)-x(i))/dels2
        dy2 = (y(i+1)-y(i))/dels2
        dz2 = (z(i+1)-z(i))/dels2
        call terms(diag2,sdiag2,sigmap,dels2)
        diag = diag1+diag2-sdiag1*temp(i-1)
        diagin = 1./diag
        xp(i) = (dx2-dx1-sdiag1*xp(i-1))*diagin
        yp(i) = (dy2-dy1-sdiag1*yp(i-1))*diagin
        zp(i) = (dz2-dz1-sdiag1*zp(i-1))*diagin
        temp(npi) = -temp(npi-1)*sdiag1*diagin
        temp(i) = sdiag2*diagin
        dx1 = dx2
        dy1 = dy2
        dz1 = dz2
        diag1 = diag2
    2   sdiag1 = sdiag2
    3 dels2 = s(1)
      dx2 = (x(1)-x(n))/dels2
      dy2 = (y(1)-y(n))/dels2
      dz2 = (z(1)-z(n))/dels2
      call terms(diag2,sdiag2,sigmap,dels2)
      xp(n) = dx2-dx1
      yp(n) = dy2-dy1
      zp(n) = dz2-dz1
      temp(nm1) = temp(2*n-1)-temp(nm1)
      if (n.eq.2) go to 5
c
c perform first step of back substitution
c
      do 4 i = 3,n
        ibak = np1-i
        npibak = n+ibak
        xp(ibak) = xp(ibak)-temp(ibak)*xp(ibak+1)
        yp(ibak) = yp(ibak)-temp(ibak)*yp(ibak+1)
        zp(ibak) = zp(ibak)-temp(ibak)*zp(ibak+1)
    4   temp(ibak) = temp(npibak)-temp(ibak)*temp(ibak+1)
    5 xp(n) = (xp(n)-sdiag2*xp(1)-sdiag1*xp(nm1))/
     *        (diag1+diag2+sdiag2*temp(1)+sdiag1*temp(nm1))
      yp(n) = (yp(n)-sdiag2*yp(1)-sdiag1*yp(nm1))/
     *        (diag1+diag2+sdiag2*temp(1)+sdiag1*temp(nm1))
      zp(n) = (zp(n)-sdiag2*zp(1)-sdiag1*zp(nm1))/
     *        (diag1+diag2+sdiag2*temp(1)+sdiag1*temp(nm1))
c
c perform second step of back substitution
c
      xpn = xp(n)
      ypn = yp(n)
      zpn = zp(n)
      do 6 i = 1,nm1
        xp(i) = xp(i)+temp(i)*xpn
        yp(i) = yp(i)+temp(i)*ypn
    6   zp(i) = zp(i)+temp(i)*zpn
      return
c
c too few points
c
    7 ierr = 1
      return
c
c coincident adjacent points
c
    8 ierr = 2
      return
      end
      subroutine qurvp2 (t,xs,ys,zs,n,x,y,z,xp,yp,zp,s,
     *                   sigma)
c
      integer n
      real t,xs,ys,zs,x(n),y(n),z(n),xp(n),yp(n),zp(n),s(n),
     *     sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine performs the mapping of points in the
c interval (0.,1.) onto a closed curve in three dimensional
c space. the subroutine qurvp1 should be called earlier to
c determine certain necessary parameters. the resulting
c curve has a parametric representation all three of whose
c components are periodic splines under tension and
c functions of the polygonal arclength parameter.
c
c on input--
c
c   t contains a value to be mapped onto the curve. the
c   interval (0.,1.) is mapped onto the entire closed curve
c   with both 0. and 1. mapping to (x(1),y(1),z(1)). the
c   mapping is periodic with period one thus any interval of
c   the form (tt,tt+1.) maps onto the entire curve.
c
c   n contains the number of points which were specified
c   to determine the curve.
c
c   x, y, and are arrays containing the x-, y-, and z-
c   coordinates of the specified points.
c
c   xp, yp, and zp are the arrays output from qurvp1
c   containing curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, z, xp, yp, zp, s and sigma should
c be input unaltered from the output of qurvp1.
c
c on output--
c
c   xs, ys, and zs contain the x-, y-, and z-coordinates of
c   the image point on the curve.
c
c none of the input parameters are altered.
c
c this subroutine references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      tn = t-float(ifix(t))
      if (tn .lt. 0.) tn = tn+1.
      tn = s(n)*tn+s(1)
      im1 = n
      if (tn .lt. s(n)) im1 = intrvl(tn,s,n)
      i = im1+1
      if (i .gt. n) i = 1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/s(n)
c
c set up and perform interpolation
c
      si = s(i)
      if (im1 .eq. n) si = s(n)+s(1)
      del1 = tn-s(im1)
      del2 = si-tn
      dels = si-s(im1)
      sumx = (x(i)*del1+x(im1)*del2)/dels
      sumy = (y(i)*del1+y(im1)*del2)/dels
      sumz = (z(i)*del1+z(im1)*del2)/dels
      if (sigmap .ne. 0.) go to 1
      d = del1*del2/(6.*dels)
      c1 = (del1+dels)*d
      c2 = (del2+dels)*d
      xs = sumx-xp(i)*c1-xp(im1)*c2
      ys = sumy-yp(i)*c1-yp(im1)*c2
      zs = sumz-zp(i)*c1-zp(im1)*c2
      return
    1 sigdel = sigmap*dels
      call snhcsh(ss,dummy,sigdel,-1)
      call snhcsh(s1,dummy,sigmap*del1,-1)
      call snhcsh(s2,dummy,sigmap*del2,-1)
      d = sigdel*sigmap*(1.+ss)
      ci = del1*(s1-ss)/d
      cim1 = del2*(s2-ss)/d
      xs = sumx+ci*xp(i)+cim1*xp(im1)
      ys = sumy+ci*yp(i)+cim1*yp(im1)
      zs = sumz+ci*zp(i)+cim1*zp(im1)
      return
      end
      subroutine qurvpd (t,xs,ys,zs,xst,yst,zst,xstt,ystt,
     *                  zstt,n,x,y,z,xp,yp,zp,s,sigma)
c
      integer n
      real t,xs,ys,zs,xst,yst,zst,xstt,ystt,zstt,x(n),y(n),
     *     z(n),xp(n),yp(n),zp(n),s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine performs the mapping of points in the
c interval (0.,1.) onto a closed curve in space. it also
c returns the first and second derivatives of the component
c functions. the subroutine qurvp1 should be called earlier
c to determine certain necessary parameters. the resulting
c curve has a parametric representation all of whose
c components are periodic splines under tension and
c functions of the polygonal arclength parameter.
c
c on input--
c
c   t contains a value to be mapped onto the curve. the
c   interval (0.,1.) is mapped onto the entire closed curve
c   with both 0. and 1. mapping to (x(1),y(1),z(1)). the
c   mapping is periodic with period one thus any interval of
c   the form (tt,tt+1.) maps onto the entire curve.
c
c   n contains the number of points which were specified
c   to determine the curve.
c
c   x, y, and are arrays containing the x-, y-, and z-
c   coordinates of the specified points.
c
c   xp, yp, and zp are the arrays output from qurvp1
c   containing curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, z, xp, yp, zp, s and sigma should
c be input unaltered from the output of qurvp1.
c
c on output--
c
c   xs, ys, and zs contain the x-, y-, and z-coordinates of
c   the image point on the curve. xst, yst, and zst contain
c   the first derivatives of the x-, y-, and z-components of
c   the mapping with respect to t. xstt, ystt, and zstt
c   contain the second derivatives of the x-, y-, and z-
c   components of the mapping with respect to t.
c
c none of the input parameters are altered.
c
c this subroutine references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      tn = t-float(ifix(t))
      if (tn .lt. 0.) tn = tn+1.
      tn = s(n)*tn+s(1)
      im1 = n
      if (tn .lt. s(n)) im1 = intrvl(tn,s,n)
      i = im1+1
      if (i .gt. n) i = 1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/s(n)
c
c set up and perform interpolation
c
      si = s(i)
      if (im1 .eq. n) si = s(n)+s(1)
      del1 = tn-s(im1)
      del2 = si-tn
      dels = si-s(im1)
      sumx = (x(i)*del1+x(im1)*del2)/dels
      sumy = (y(i)*del1+y(im1)*del2)/dels
      sumz = (z(i)*del1+z(im1)*del2)/dels
      sumxt = s(n)*(x(i)-x(im1))/dels
      sumyt = s(n)*(y(i)-y(im1))/dels
      sumzt = s(n)*(z(i)-z(im1))/dels
      if (sigmap .ne. 0.) go to 1
      dels6 = 6.*dels
      d = del1*del2/dels6
      c1 = -(del1+dels)*d
      c2 = -(del2+dels)*d
      dels6 = dels6/s(n)
      ct1 = (2.*del1*del1-del2*(del1+dels))/dels6
      ct2 = -(2.*del2*del2-del1*(del2+dels))/dels6
      dels = dels/(s(n)*s(n))
      ctt1 = del1/dels
      ctt2 = del2/dels
      go to 2
    1 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (s1,co1,sigmap*del1,0)
      call snhcsh (s2,co2,sigmap*del2,0)
      d = sigdel*sigmap*(1.+ss)
      c1 = del1*(s1-ss)/d
      c2 = del2*(s2-ss)/d
      ct1 = (co1-ss)*s(n)/d
      ct2 = -(co2-ss)*s(n)/d
      ctt1 = del1*(1.+s1)*s(n)*s(n)/(dels*(1.+ss))
      ctt2 = del2*(1.+s2)*s(n)*s(n)/(dels*(1.+ss))
    2 xs = sumx+c1*xp(i)+c2*xp(im1)
      ys = sumy+c1*yp(i)+c2*yp(im1)
      zs = sumz+c1*zp(i)+c2*zp(im1)
      xst = sumxt+ct1*xp(i)+ct2*xp(im1)
      yst = sumyt+ct1*yp(i)+ct2*yp(im1)
      zst = sumzt+ct1*zp(i)+ct2*zp(im1)
      xstt = ctt1*xp(i)+ctt2*xp(im1)
      ystt = ctt1*yp(i)+ctt2*yp(im1)
      zstt = ctt1*zp(i)+ctt2*zp(im1)
      return
      end
      function arqurp (tl,tu,n,x,y,z,xp,yp,zp,s,sigma)
c
      integer n
      real tl,tu,x(n),y(n),z(n),xp(n),yp(n),zp(n),s(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function integrates a closed curve in three
c dimensions specified by a spline under tension between two
c given limits. the subroutine qurvp1 should be called
c earlier to determine necessary parameters.
c
c on input--
c
c   tl and tu contain the upper and lower limits of inte-
c   gration, respectively. (tl need not be less than or
c   equal to tu, arqurp(tl,tu,...) .eq. -arqurp(tu,tl,...)).
c   the arclength is measured from the image (using qurvp2)
c   of tl to the image of tu.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x, y, and z are arrays containing the x-, y-, and z-
c   cordinates of the specified points.
c
c   xp, yp, and zp are the arrays output from qurvp1
c   containing curvature information.
c
c   s is an array containing the polygonal arclengths of
c   the curve.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, z, xp, yp, zp, s, and sigma should
c be input unaltered from the output of qurvp1.
c
c on output--
c
c   arqurp contains the arclength.
c
c none of the input parameters are altered.
c
c this function references package modules arcln3, intrvl,
c and snhcsh.
c
c a common block named ar3com is used.
c
c-----------------------------------------------------------
c
      integer uper
      logical bdy
c
      common /ar3com/ sigmap,si,sim1,dels,sxim1,syim1,
     *                szim1,sinhms,con,xpi,xpim1,ypi,ypim1,
     *                zpi,zpim1
c
      gauss5 (a,b,d) = d*(w1*(arcln3(a+f1*d)+arcln3(b-f1*d))
     *                   +w2*(arcln3(a+f2*d)+arcln3(b-f2*d))
     *                   +w3*arcln3(a+f3*d))
c
c compute constants for 5 point gaussian quadrature
c
      sqt280 = sqrt (280.)
      f1 = (1.-sqrt ((35.+sqt280)/63.))/2.
      f2 = (1.-sqrt (15./(35.+sqt280)))/2.
      f3 = .5
      w1 = 5103./(32200.+650.*sqt280)
      w2 = (644.+13.*sqt280)/3600.
      w3 = 64./225.
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/s(n)
c
c determine actual upper and lower bounds
c
      s1pp = s(1)+s(n)
      isign = 1
      lper = int(tl)
      if (tl .lt. 0.) lper = lper-1
      ssl = (tl-float(lper))*s(n)+s(1)
      ilm1 = n
      if (ssl .lt. s(n)) ilm1 = intrvl (ssl,s,n)
      uper = int(tu)
      if (tu .lt. 0.) uper = uper-1
      ssu = (tu-float(uper))*s(n)+s(1)
      ium1 = n
      if (ssu .lt. s(n)) ium1 = intrvl (ssu,s,n)
      ideltp = uper-lper
      bdy = float(ideltp)*(ssu-ssl) .lt. 0.
      if ((ideltp .eq. 0 .and. ssu .lt. ssl) .or.
     *    ideltp .lt. 0) isign = -1
      if (bdy) ideltp = ideltp-isign
      if (ssu .ge. ssl) go to 1
      xsave = ssl
      ssl = ssu
      ssu = xsave
      isave = ilm1
      ilm1 = ium1
      ium1 = isave
    1 il = ilm1+1
      if (ilm1 .eq. n) il = 1
      sil = s(il)
      if (ilm1 .eq. n) sil = s1pp
      iu = ium1+1
      if (ium1 .eq. n) iu = 1
      siu = s(iu)
      if (ium1 .eq. n) siu = s1pp
      s1 = 0.
      if (ilm1 .eq. 1 .or. (ideltp .eq. 0 .and.
     *    .not. bdy)) go to 3
c
c integrate from s(1) to s(ilm1), store in s1
c
      do 2 i = 2,ilm1
        si = s(i)
        sim1 = s(i-1)
        dels = si-sim1
        sxim1 = (x(i)-x(i-1))/dels
        syim1 = (y(i)-y(i-1))/dels
        szim1 = (z(i)-z(i-1))/dels
        xpi = xp(i)
        xpim1 = xp(i-1)
        ypi = yp(i)
        ypim1 = yp(i-1)
        zpi = zp(i)
        zpim1 = zp(i-1)
        if (sigma .eq. 0.) go to 2
        call snhcsh (sinhms,dummy,sigmap*dels,-1)
        con = sigmap*sigmap*dels*(1.+sinhms)
    2   s1 = s1+gauss5 (sim1,si,si-sim1)
    3 s2 = 0.
      if (s(ilm1) .ge. ssl .or. (ideltp .eq. 0
     *    .and. .not. bdy)) go to 5
c
c integrate from s(ilm1) to ssl, store in s2
c
      si = sil
      sim1 = s(ilm1)
      dels = si-sim1
      sxim1 = (x(il)-x(ilm1))/dels
      syim1 = (y(il)-y(ilm1))/dels
      szim1 = (z(il)-z(ilm1))/dels
      xpi = xp(il)
      xpim1 = xp(ilm1)
      ypi = yp(il)
      ypim1 = yp(ilm1)
      zpi = zp(il)
      zpim1 = zp(ilm1)
      if (sigma .eq. 0.) go to 4
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
    4 s2 = s2+gauss5 (sim1,ssl,ssl-sim1)
    5 s3 = 0.
      if (ssl .ge. sil .or. (ideltp .eq. 0 .and. bdy)
     *    .or. ilm1 .eq. ium1) go to 7
c
c integrate from ssl to sil, store in s3
c
      si = sil
      sim1 = s(ilm1)
      dels = si-sim1
      sxim1 = (x(il)-x(ilm1))/dels
      syim1 = (y(il)-y(ilm1))/dels
      szim1 = (z(il)-z(ilm1))/dels
      xpi = xp(il)
      xpim1 = xp(ilm1)
      ypi = yp(il)
      ypim1 = yp(ilm1)
      zpi = zp(il)
      zpim1 = zp(ilm1)
      if (sigma .eq. 0.) go to 6
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
    6 s3 = s3+gauss5 (ssl,si,si-ssl)
    7 s4 = 0.
      if (ilm1 .ge. ium1-1 .or. (ideltp .eq. 0 .and. bdy))
     *   go to 9
c
c integrate from sil to s(ium1), store in s4
c
      ilp1 = il+1
      do 8 i = ilp1,ium1
        si = s(i)
        sim1 = s(i-1)
        dels = si-sim1
        sxim1 = (x(i)-x(i-1))/dels
        syim1 = (y(i)-y(i-1))/dels
        szim1 = (z(i)-z(i-1))/dels
        xpi = xp(i)
        xpim1 = xp(i-1)
        ypi = yp(i)
        ypim1 = yp(i-1)
        zpi = zp(i)
        zpim1 = zp(i-1)
        if (sigma .eq. 0.) go to 8
        call snhcsh (sinhms,dummy,sigmap*dels,-1)
        con = sigmap*sigmap*dels*(1.+sinhms)
    8   s4 = s4+gauss5 (sim1,si,si-sim1)
    9 s5 = 0.
      if (s(ium1) .ge. ssu .or. (ideltp .eq. 0 .and. bdy)
     *    .or. ilm1 .eq. ium1) go to 11
c
c integrate from s(ium1) to ssu, store in s5
c
      si = siu
      sim1 = s(ium1)
      dels = si-sim1
      sxim1 = (x(iu)-x(ium1))/dels
      syim1 = (y(iu)-y(ium1))/dels
      szim1 = (z(iu)-z(ium1))/dels
      xpi = xp(iu)
      xpim1 = xp(ium1)
      ypi = yp(iu)
      ypim1 = yp(ium1)
      zpi = zp(iu)
      zpim1 = zp(ium1)
      if (sigma .eq. 0.) go to 10
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
   10 s5 = s5+gauss5 (sim1,ssu,ssu-sim1)
   11 s6 = 0.
      if (ssu .ge. siu .or. (ideltp .eq. 0 .and.
     *    .not. bdy)) go to 13
c
c integrate from ssu to siu, store in s6
c
      si = siu
      sim1 = s(ium1)
      dels = si-sim1
      sxim1 = (x(iu)-x(ium1))/dels
      syim1 = (y(iu)-y(ium1))/dels
      szim1 = (z(iu)-z(ium1))/dels
      xpi = xp(iu)
      xpim1 = xp(ium1)
      ypi = yp(iu)
      ypim1 = yp(ium1)
      zpi = zp(iu)
      zpim1 = zp(ium1)
      if (sigma .eq. 0.) go to 12
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
   12 s6 = s6+gauss5 (ssu,si,si-ssu)
   13 s7 = 0.
      if (iu .eq. 1 .or. (ideltp .eq. 0 .and. .not. bdy))
     *    go to 15
c
c integrate from siu to s1pp, store in s7
c
      np1 = n+1
      iup1 = iu+1
      do 14 ii = iup1,np1
        im1 = ii-1
        i = ii
        if (i .eq. np1) i=1
        si = s(i)
        if (i .eq. 1) si = s1pp
        sim1 = s(im1)
        dels = si-sim1
        sxim1 = (x(i)-x(im1))/dels
        syim1 = (y(i)-y(im1))/dels
        szim1 = (z(i)-z(im1))/dels
        xpi = xp(i)
        xpim1 = xp(im1)
        ypi = yp(i)
        ypim1 = yp(im1)
        zpi = zp(i)
        zpim1 = zp(im1)
        if (sigma .eq. 0.) go to 14
        call snhcsh (sinhms,dummy,sigmap*dels,-1)
        con = sigmap*sigmap*dels*(1.+sinhms)
   14   s7 = s7+gauss5 (sim1,si,si-sim1)
   15 s8 = 0.
      if (ilm1 .lt. ium1 .or. (ideltp .eq. 0 .and. bdy))
     *   go to 17
c
c integrate from ssl to ssu, store in s8
c
      si = siu
      sim1 = s(ium1)
      dels = si-sim1
      sxim1 = (x(iu)-x(ium1))/dels
      syim1 = (y(iu)-y(ium1))/dels
      szim1 = (z(iu)-z(ium1))/dels
      xpi = xp(iu)
      xpim1 = xp(ium1)
      ypi = yp(iu)
      ypim1 = yp(ium1)
      zpi = zp(iu)
      zpim1 = zp(ium1)
      if (sigma .eq. 0.) go to 16
      call snhcsh (sinhms,dummy,sigmap*dels,-1)
      con = sigmap*sigmap*dels*(1.+sinhms)
   16 s8 = s8+gauss5 (ssl,ssu,ssu-ssl)
   17 so = s1+s2+s6+s7
      si = s3+s4+s5+s8
      if (bdy) go to 18
      arqurp = float(ideltp)*(so+si)+float(isign)*si
      return
   18 arqurp = float(ideltp)*(so+si)+float(isign)*so
      return
      end
      subroutine surf1 (m,n,x,y,z,iz,zx1,zxm,zy1,zyn,zxy11,
     *                  zxym1,zxy1n,zxymn,islpsw,zp,temp,
     *                  sigma,ierr)
c
      integer m,n,iz,islpsw,ierr
      real x(m),y(n),z(iz,n),zx1(n),zxm(n),zy1(m),zyn(m),
     *     zxy11,zxym1,zxy1n,zxymn,zp(m,n,3),temp(1),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through a rect-
c angular grid of functional values. the surface determined
c can be represented as the tensor product of splines under
c tension. the x- and y-partial derivatives around the
c boundary and the x-y-partial derivatives at the four
c corners may be specified or omitted. for actual mapping
c of points onto the surface it is necessary to call the
c function surf2.
c
c on input--
c
c   m is the number of grid lines in the x-direction, i. e.
c   lines parallel to the y-axis (m .ge. 2).
c
c   n is the number of grid lines in the y-direction, i. e.
c   lines parallel to the x-axis (n .ge. 2).
c
c   x is an array of the m x-coordinates of the grid lines
c   in the x-direction. these should be strictly increasing.
c
c   y is an array of the n y-coordinates of the grid lines
c   in the y-direction. these should be strictly increasing.
c
c   z is an array of the m * n functional values at the grid
c   points, i. e. z(i,j) contains the functional value at
c   (x(i),y(j)) for i = 1,...,m and j = 1,...,n.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   zx1 and zxm are arrays of the m x-partial derivatives
c   of the function along the x(1) and x(m) grid lines,
c   respectively. thus zx1(j) and zxm(j) contain the x-part-
c   ial derivatives at the points (x(1),y(j)) and
c   (x(m),y(j)), respectively, for j = 1,...,n. either of
c   these parameters will be ignored (and approximations
c   supplied internally) if islpsw so indicates.
c
c   zy1 and zyn are arrays of the n y-partial derivatives
c   of the function along the y(1) and y(n) grid lines,
c   respectively. thus zy1(i) and zyn(i) contain the y-part-
c   ial derivatives at the points (x(i),y(1)) and
c   (x(i),y(n)), respectively, for i = 1,...,m. either of
c   these parameters will be ignored (and estimations
c   supplied internally) if islpsw so indicates.
c
c   zxy11, zxym1, zxy1n, and zxymn are the x-y-partial
c   derivatives of the function at the four corners,
c   (x(1),y(1)), (x(m),y(1)), (x(1),y(n)), and (x(m),y(n)),
c   respectively. any of the parameters will be ignored (and
c   estimations supplied internally) if islpsw so indicates.
c
c   islpsw contains a switch indicating which boundary
c   derivative information is user-supplied and which
c   should be estimated by this subroutine. to determine
c   islpsw, let
c        i1 = 0 if zx1 is user-supplied (and = 1 otherwise),
c        i2 = 0 if zxm is user-supplied (and = 1 otherwise),
c        i3 = 0 if zy1 is user-supplied (and = 1 otherwise),
c        i4 = 0 if zyn is user-supplied (and = 1 otherwise),
c        i5 = 0 if zxy11 is user-supplied
c                                       (and = 1 otherwise),
c        i6 = 0 if zxym1 is user-supplied
c                                       (and = 1 otherwise),
c        i7 = 0 if zxy1n is user-supplied
c                                       (and = 1 otherwise),
c        i8 = 0 if zxymn is user-supplied
c                                       (and = 1 otherwise),
c   then islpsw = i1 + 2*i2 + 4*i3 + 8*i4 + 16*i5 + 32*i6
c                   + 64*i7 + 128*i8
c   thus islpsw = 0 indicates all derivative information is
c   user-supplied and islpsw = 255 indicates no derivative
c   information is user-supplied. any value between these
c   limits is valid.
c
c   zp is an array of at least 3*m*n locations.
c
c   temp is an array of at least n+n+m locations which is
c   used for scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   bi-linear. if sigma equals zero tensor products of
c   cubic splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   zp contains the values of the xx-, yy-, and xxyy-partial
c   derivatives of the surface at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2 or m is less than 2,
c        = 2 if the x-values or y-values are not strictly
c            increasing.
c
c and
c
c   m, n, x, y, z, iz, zx1, zxm, zy1, zyn, zxy11, zxym1,
c   zxy1n, zxymn, islpsw, and sigma are unaltered.
c
c this subroutine references package modules ceez, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      mm1 = m-1
      mp1 = m+1
      nm1 = n-1
      np1 = n+1
      npm = n+m
      ierr = 0
      if (n .le. 1 .or. m .le. 1) go to 46
      if (y(n) .le. y(1)) go to 47
c
c denormalize tension factor in y-direction
c
      sigmay = abs(sigma)*float(n-1)/(y(n)-y(1))
c
c obtain y-partial derivatives along y = y(1)
c
      if ((islpsw/8)*2 .ne. (islpsw/4)) go to 2
      do 1 i = 1,m
    1   zp(i,1,1) = zy1(i)
      go to 5
    2 dely1 = y(2)-y(1)
      dely2 = dely1+dely1
      if (n .gt. 2) dely2 = y(3)-y(1)
      if (dely1 .le. 0. .or. dely2 .le. dely1) go to 47
      call ceez (dely1,dely2,sigmay,c1,c2,c3,n)
      do 3 i = 1,m
    3   zp(i,1,1) = c1*z(i,1)+c2*z(i,2)
      if (n .eq. 2) go to 5
      do 4 i = 1,m
    4   zp(i,1,1) = zp(i,1,1)+c3*z(i,3)
c
c obtain y-partial derivatives along y = y(n)
c
    5 if ((islpsw/16)*2 .ne. (islpsw/8)) go to 7
      do 6 i = 1,m
        npi = n+i
    6   temp(npi) = zyn(i)
      go to 10
    7 delyn = y(n)-y(nm1)
      delynm = delyn+delyn
      if (n .gt. 2) delynm = y(n)-y(n-2)
      if (delyn .le. 0. .or. delynm .le. delyn) go to 47
      call ceez (-delyn,-delynm,sigmay,c1,c2,c3,n)
      do 8 i = 1,m
        npi = n+i
    8   temp(npi) = c1*z(i,n)+c2*z(i,nm1)
      if (n .eq. 2) go to 10
      do 9 i = 1,m
        npi = n+i
    9   temp(npi) = temp(npi)+c3*z(i,n-2)
   10 if (x(m) .le. x(1)) go to 47
c
c denormalize tension factor in x-direction
c
      sigmax = abs(sigma)*float(m-1)/(x(m)-x(1))
c
c obtain x-partial derivatives along x = x(1)
c
      if ((islpsw/2)*2 .ne. islpsw) go to 12
      do 11 j = 1,n
   11   zp(1,j,2) = zx1(j)
      if ((islpsw/32)*2 .eq. (islpsw/16) .and.
     *    (islpsw/128)*2  .eq. (islpsw/64)) go to 15
   12 delx1 = x(2)-x(1)
      delx2 = delx1+delx1
      if (m .gt. 2) delx2 = x(3)-x(1)
      if (delx1 .le. 0. .or. delx2 .le. delx1) go to 47
      call ceez (delx1,delx2,sigmax,c1,c2,c3,m)
      if ((islpsw/2)*2 .eq. islpsw) go to 15
      do 13 j = 1,n
   13   zp(1,j,2) = c1*z(1,j)+c2*z(2,j)
      if (m .eq. 2) go to 15
      do 14 j = 1,n
   14   zp(1,j,2) = zp(1,j,2)+c3*z(3,j)
c
c obtain x-y-partial derivative at (x(1),y(1))
c
   15 if ((islpsw/32)*2 .ne. (islpsw/16)) go to 16
      zp(1,1,3) = zxy11
      go to 17
   16 zp(1,1,3) = c1*zp(1,1,1)+c2*zp(2,1,1)
      if (m .gt. 2) zp(1,1,3) = zp(1,1,3)+c3*zp(3,1,1)
c
c obtain x-y-partial derivative at (x(1),y(n))
c
   17 if ((islpsw/128)*2 .ne. (islpsw/64)) go to 18
      zxy1ns = zxy1n
      go to 19
   18 zxy1ns = c1*temp(n+1)+c2*temp(n+2)
      if (m .gt. 2) zxy1ns = zxy1ns+c3*temp(n+3)
c
c obtain x-partial derivative along x = x(m)
c
   19 if ((islpsw/4)*2 .ne. (islpsw/2)) go to 21
      do 20 j = 1,n
        npmpj = npm+j
   20   temp(npmpj) = zxm(j)
      if ((islpsw/64)*2 .eq. (islpsw/32) .and.
     *    (islpsw/256)*2 .eq. (islpsw/128)) go to 24
   21 delxm = x(m)-x(mm1)
      delxmm = delxm+delxm
      if (m .gt. 2) delxmm = x(m)-x(m-2)
      if (delxm .le. 0. .or. delxmm .le. delxm) go to 47
      call ceez (-delxm,-delxmm,sigmax,c1,c2,c3,m)
      if ((islpsw/4)*2 .eq. (islpsw/2)) go to 24
      do 22 j = 1,n
        npmpj = npm+j
   22   temp(npmpj) = c1*z(m,j)+c2*z(mm1,j)
      if (m .eq. 2) go to 24
      do 23 j = 1,n
        npmpj = npm+j
   23   temp(npmpj) = temp(npmpj)+c3*z(m-2,j)
c
c obtain x-y-partial derivative at (x(m),y(1))
c
   24 if ((islpsw/64)*2 .ne. (islpsw/32)) go to 25
      zp(m,1,3) = zxym1
      go to 26
   25 zp(m,1,3) = c1*zp(m,1,1)+c2*zp(mm1,1,1)
      if (m .gt. 2) zp(m,1,3) = zp(m,1,3)+c3*zp(m-2,1,1)
c
c obtain x-y-partial derivative at (x(m),y(n))
c
   26 if ((islpsw/256)*2 .ne. (islpsw/128)) go to 27
      zxymns = zxymn
      go to 28
   27 zxymns = c1*temp(npm)+c2*temp(npm-1)
      if (m .gt. 2) zxymns = zxymns+c3*temp(npm-2)
c
c set up right hand sides and tridiagonal system for y-grid
c perform forward elimination
c
   28 del1 = y(2)-y(1)
      if (del1 .le. 0.) go to 47
      deli = 1./del1
      do 29 i = 1,m
   29   zp(i,2,1) = deli*(z(i,2)-z(i,1))
      zp(1,2,3) = deli*(zp(1,2,2)-zp(1,1,2))
      zp(m,2,3) = deli*(temp(npm+2)-temp(npm+1))
      call terms (diag1,sdiag1,sigmay,del1)
      diagi = 1./diag1
      do 30 i = 1,m
   30   zp(i,1,1) = diagi*(zp(i,2,1)-zp(i,1,1))
      zp(1,1,3) = diagi*(zp(1,2,3)-zp(1,1,3))
      zp(m,1,3) = diagi*(zp(m,2,3)-zp(m,1,3))
      temp(1) = diagi*sdiag1
      if (n .eq. 2) go to 34
      do 33 j = 2,nm1
        jm1 = j-1
        jp1 = j+1
        npmpj = npm+j
        del2 = y(jp1)-y(j)
        if (del2 .le. 0.) go to 47
        deli = 1./del2
        do 31 i = 1,m
   31     zp(i,jp1,1) = deli*(z(i,jp1)-z(i,j))
        zp(1,jp1,3) = deli*(zp(1,jp1,2)-zp(1,j,2))
        zp(m,jp1,3) = deli*(temp(npmpj+1)-temp(npmpj))
        call terms (diag2,sdiag2,sigmay,del2)
        diagin = 1./(diag1+diag2-sdiag1*temp(jm1))
        do 32 i = 1,m
   32     zp(i,j,1) = diagin*(zp(i,jp1,1)-zp(i,j,1)-
     *                        sdiag1*zp(i,jm1,1))
        zp(1,j,3) = diagin*(zp(1,jp1,3)-zp(1,j,3)-
     *                      sdiag1*zp(1,jm1,3))
        zp(m,j,3) = diagin*(zp(m,jp1,3)-zp(m,j,3)-
     *                      sdiag1*zp(m,jm1,3))
        temp(j) = diagin*sdiag2
        diag1 = diag2
   33   sdiag1 = sdiag2
   34 diagin = 1./(diag1-sdiag1*temp(nm1))
      do 35 i = 1,m
        npi = n+i
   35   zp(i,n,1) = diagin*(temp(npi)-zp(i,n,1)-
     *                      sdiag1*zp(i,nm1,1))
      zp(1,n,3) = diagin*(zxy1ns-zp(1,n,3)-
     *                    sdiag1*zp(1,nm1,3))
      temp(n) = diagin*(zxymns-zp(m,n,3)-
     *                  sdiag1*zp(m,nm1,3))
c
c perform back substitution
c
      do 37 j = 2,n
        jbak = np1-j
        jbakp1 = jbak+1
        t = temp(jbak)
        do 36 i = 1,m
   36     zp(i,jbak,1) = zp(i,jbak,1)-t*zp(i,jbakp1,1)
        zp(1,jbak,3) = zp(1,jbak,3)-t*zp(1,jbakp1,3)
   37   temp(jbak) = zp(m,jbak,3)-t*temp(jbakp1)
c
c set up right hand sides and tridiagonal system for x-grid
c perform forward elimination
c
      del1 = x(2)-x(1)
      if (del1 .le. 0.) go to 47
      deli = 1./del1
      do 38 j = 1,n
        zp(2,j,2) = deli*(z(2,j)-z(1,j))
   38   zp(2,j,3) = deli*(zp(2,j,1)-zp(1,j,1))
      call terms (diag1,sdiag1,sigmax,del1)
      diagi = 1./diag1
      do 39 j = 1,n
        zp(1,j,2) = diagi*(zp(2,j,2)-zp(1,j,2))
   39   zp(1,j,3) = diagi*(zp(2,j,3)-zp(1,j,3))
      temp(n+1) = diagi*sdiag1
      if (m  .eq. 2) go to 43
      do 42 i = 2,mm1
        im1 = i-1
        ip1 = i+1
        npi = n+i
        del2 = x(ip1)-x(i)
        if (del2 .le. 0.) go to 47
        deli = 1./del2
        do 40 j = 1,n
          zp(ip1,j,2) = deli*(z(ip1,j)-z(i,j))
   40     zp(ip1,j,3) = deli*(zp(ip1,j,1)-zp(i,j,1))
        call terms (diag2,sdiag2,sigmax,del2)
        diagin = 1./(diag1+diag2-sdiag1*temp(npi-1))
        do 41 j = 1,n
          zp(i,j,2) = diagin*(zp(ip1,j,2)-zp(i,j,2)-
     *                        sdiag1*zp(im1,j,2))
   41     zp(i,j,3) = diagin*(zp(ip1,j,3)-zp(i,j,3)-
     *                        sdiag1*zp(im1,j,3))
        temp(npi) = diagin*sdiag2
        diag1 = diag2
   42   sdiag1 = sdiag2
   43 diagin = 1./(diag1-sdiag1*temp(npm-1))
      do 44 j = 1,n
        npmpj = npm+j
        zp(m,j,2) = diagin*(temp(npmpj)-zp(m,j,2)-
     *                      sdiag1*zp(mm1,j,2))
   44   zp(m,j,3) = diagin*(temp(j)-zp(m,j,3)-
     *                      sdiag1*zp(mm1,j,3))
c
c perform back substitution
c
      do 45 i = 2,m
        ibak = mp1-i
        ibakp1 = ibak+1
        npibak = n+ibak
        t = temp(npibak)
        do 45 j = 1,n
          zp(ibak,j,2) = zp(ibak,j,2)-t*zp(ibakp1,j,2)
   45     zp(ibak,j,3) = zp(ibak,j,3)-t*zp(ibakp1,j,3)
      return
c
c too few points
c
   46 ierr = 1
      return
c
c points not strictly increasing
c
   47 ierr = 2
      return
      end
      subroutine surfn1 (m,n,x,y,z,iz,zp,temp,sigma,ierr)
c
      integer m,n,iz,ierr
      real x(m),y(n),z(iz,n),zp(m,n,3),temp(1),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through a rect-
c angular grid of functional values. the surface determined
c can be represented as the tensor product of natural
c splines under tension. for actual mapping of points onto
c the surface it is necessary to call the function surf2.
c
c on input--
c
c   m is the number of grid lines in the x-direction, i. e.
c   lines parallel to the y-axis (m .ge. 2).
c
c   n is the number of grid lines in the y-direction, i. e.
c   lines parallel to the x-axis (n .ge. 2).
c
c   x is an array of the m x-coordinates of the grid lines
c   in the x-direction. these should be strictly increasing.
c
c   y is an array of the n y-coordinates of the grid lines
c   in the y-direction. these should be strictly increasing.
c
c   z is an array of the m * n functional values at the grid
c   points, i. e. z(i,j) contains the functional value at
c   (x(i),y(j)) for i = 1,...,m and j = 1,...,n.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c
c   zp is an array of at least 3*m*n locations.
c
c   temp is an array of at least max(n,m) locations which is
c   used for scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   bi-linear. if sigma equals zero tensor products of
c   cubic splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   zp contains the values of the xx-, yy-, and xxyy-partial
c   derivatives of the surface at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2 or m is less than 2,
c        = 2 if the x-values or y-values are not strictly
c            increasing.
c
c and
c
c   m, n, x, y, z, iz, and sigma are unaltered.
c
c this subroutine references package modules terms and
c snhcsh.
c
c-----------------------------------------------------------
c
      mm1 = m-1
      mp1 = m+1
      nm1 = n-1
      np1 = n+1
      ierr = 0
      if (n .le. 1 .or. m .le. 1) go to 17
      if (y(n) .le. y(1)) go to 18
c
c denormalize tension factor in y-direction
c
      sigmay = abs(sigma)*float(n-1)/(y(n)-y(1))
      if (x(m) .le. x(1)) go to 18
c
c denormalize tension factor in x-direction
c
      sigmax = abs(sigma)*float(m-1)/(x(m)-x(1))
c
c set up right hand sides and tridiagonal system for y-grid
c perform forward elimination
c
      del1 = y(2)-y(1)
      if (del1 .le. 0.) go to 18
      deli = 1./del1
      do 1 i = 1,m
    1   zp(i,2,1) = deli*(z(i,2)-z(i,1))
      call terms (diag1,sdiag1,sigmay,del1)
      sdiag1 = 0.
      do 2 i = 1,m
    2   zp(i,1,1) = 0.
      temp(1) = 0.
      if (n .eq. 2) go to 6
      do 5 j = 2,nm1
        jm1 = j-1
        jp1 = j+1
        del2 = y(jp1)-y(j)
        if (del2 .le. 0.) go to 18
        deli = 1./del2
        do 3 i = 1,m
    3     zp(i,jp1,1) = deli*(z(i,jp1)-z(i,j))
        call terms (diag2,sdiag2,sigmay,del2)
        diagin = 1./(diag1+diag2-sdiag1*temp(jm1))
        do 4 i = 1,m
    4     zp(i,j,1) = diagin*(zp(i,jp1,1)-zp(i,j,1)-
     *                        sdiag1*zp(i,jm1,1))
        temp(j) = diagin*sdiag2
        diag1 = diag2
    5   sdiag1 = sdiag2
    6 diagin = 1./(diag1-sdiag1*temp(nm1))
      do 7 i = 1,m
    7   zp(i,n,1) = 0.
      temp(nm1) = 0.
c
c perform back substitution
c
      do 8 j = 2,n
        jbak = np1-j
        jbakp1 = jbak+1
        t = temp(jbak)
        do 8 i = 1,m
    8     zp(i,jbak,1) = zp(i,jbak,1)-t*zp(i,jbakp1,1)
c
c set up right hand sides and tridiagonal system for x-grid
c perform forward elimination
c
      del1 = x(2)-x(1)
      if (del1 .le. 0.) go to 18
      deli = 1./del1
      do 9 j = 1,n
        zp(2,j,2) = deli*(z(2,j)-z(1,j))
    9   zp(2,j,3) = deli*(zp(2,j,1)-zp(1,j,1))
      call terms (diag1,sdiag1,sigmax,del1)
      sdiag1 = 0.
      do 10 j = 1,n
        zp(1,j,2) = 0.
   10   zp(1,j,3) = 0.
      temp(1) = 0.
      if (m  .eq. 2) go to 14
      do 13 i = 2,mm1
        im1 = i-1
        ip1 = i+1
        del2 = x(ip1)-x(i)
        if (del2 .le. 0.) go to 18
        deli = 1./del2
        do 11 j = 1,n
          zp(ip1,j,2) = deli*(z(ip1,j)-z(i,j))
   11     zp(ip1,j,3) = deli*(zp(ip1,j,1)-zp(i,j,1))
        call terms (diag2,sdiag2,sigmax,del2)
        diagin = 1./(diag1+diag2-sdiag1*temp(i-1))
        do 12 j = 1,n
          zp(i,j,2) = diagin*(zp(ip1,j,2)-zp(i,j,2)-
     *                        sdiag1*zp(im1,j,2))
   12     zp(i,j,3) = diagin*(zp(ip1,j,3)-zp(i,j,3)-
     *                        sdiag1*zp(im1,j,3))
        temp(i) = diagin*sdiag2
        diag1 = diag2
   13   sdiag1 = sdiag2
   14 do 15 j = 1,n
        zp(m,j,2) = 0.
   15   zp(m,j,3) = 0.
      temp(mm1) = 0.
c
c perform back substitution
c
      do 16 i = 2,m
        ibak = mp1-i
        ibakp1 = ibak+1
        t = temp(ibak)
        do 16 j = 1,n
          zp(ibak,j,2) = zp(ibak,j,2)-t*zp(ibakp1,j,2)
   16     zp(ibak,j,3) = zp(ibak,j,3)-t*zp(ibakp1,j,3)
      return
c
c too few points
c
   17 ierr = 1
      return
c
c points not strictly increasing
c
   18 ierr = 2
      return
      end
      subroutine bsurf1 (m,n,xmin,xmax,ymin,ymax,z,iz,zp,
     *                   temp,sigma,ierr)
c
      integer m,n,iz,ierr
      real xmin,xmax,ymin,ymax,z(iz,n),zp(m,n,3),temp(1),
     *     sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through a rect-
c angular grid of functional values. the x and y values are
c assumed equally spaced in the grid. the surface determined
c can be represented as the tensor product of splines under
c tension. for actual interpolation at a grid of points
c equally spaced in both x and y coordinates it is necessary
c to call subroutine bsurf2.
c
c on input--
c
c   m is the number of grid lines in the x-direction, i. e.
c   lines parallel to the y-axis (m .ge. 2).
c
c   n is the number of grid lines in the y-direction, i. e.
c   lines parallel to the x-axis (n .ge. 2).
c
c   xmin and xmax are the lower and upper limits,
c   respectively, of the grid in the x-direction. xmax
c   should be greater than xmin.
c
c   ymin and ymax are the lower and upper limits,
c   respectively, of the grid in the y-direction. ymax
c   should be greater than ymin.
c
c   z is an array of the m * n functional values at the grid
c   points, i. e. z(i,j) contains the functional value at
c   (x(i),y(j)) for i = 1,...,m and j = 1,...,n, where x(i)
c   represents the i-th equispaced x value, and y(j)
c   represents the j-th equispaced y value.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   zp is an array of at least 3*m*n locations.
c
c   temp is an array of at least n+n+m locations which is
c   used for scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   bi-linear. if sigma equals zero tensor products of
c   cubic splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   zp contains the values of the xx-, yy-, and xxyy-partial
c   derivatives of the surface at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2 or m is less than 2,
c        = 2 if xmax is not greater than xmin or ymax is not
c            greater than ymin.
c
c and
c
c   m, n, xmin, xmax, ymin, ymax, z, iz, and sigma are
c   unaltered.
c
c this subroutine references package modules ceez, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      mm1 = m-1
      mp1 = m+1
      nm1 = n-1
      np1 = n+1
      npm = n+m
      ierr = 0
      if (n .le. 1 .or. m .le. 1) go to 30
      if (ymax .le. ymin) go to 31
c
c denormalize tension factor in y-direction
c
      sigmay = abs(sigma)*float(n-1)/(ymax-ymin)
c
c obtain y-partial derivatives along y = ymin
c
      dely1 = (ymax-ymin)/float(n-1)
      dely2 = dely1+dely1
      call ceez (dely1,dely2,sigmay,c1,c2,c3,n)
      do 1 i = 1,m
    1   zp(i,1,1) = c1*z(i,1)+c2*z(i,2)
      if (n .eq. 2) go to 3
      do 2 i = 1,m
    2   zp(i,1,1) = zp(i,1,1)+c3*z(i,3)
c
c obtain y-partial derivatives along y = ymax
c
    3 c1 = -c1
      c2 = -c2
      if (n .gt. 2) c3 = -c3
      do 4 i = 1,m
        npi = n+i
    4   temp(npi) = c1*z(i,n)+c2*z(i,nm1)
      if (n .eq. 2) go to 6
      do 5 i = 1,m
        npi = n+i
    5   temp(npi) = temp(npi)+c3*z(i,n-2)
    6 if (xmax .le. xmin) go to 31
c
c denormalize tension factor in x-direction
c
      sigmax = abs(sigma)*float(m-1)/(xmax-xmin)
c
c obtain x-partial derivatives along x = xmin
c
      delx1 = (xmax-xmin)/float(m-1)
      delx2 = delx1+delx1
      call ceez (delx1,delx2,sigmax,c1,c2,c3,m)
      do 7 j = 1,n
    7   zp(1,j,2) = c1*z(1,j)+c2*z(2,j)
      if (m .eq. 2) go to 9
      do 8 j = 1,n
    8   zp(1,j,2) = zp(1,j,2)+c3*z(3,j)
c
c obtain x-y-partial derivative at (xmin,ymin)
c
    9 zp(1,1,3) = c1*zp(1,1,1)+c2*zp(2,1,1)
      if (m .gt. 2) zp(1,1,3) = zp(1,1,3)+c3*zp(3,1,1)
c
c obtain x-y-partial derivative at (xmin,ymax)
c
      zxy1ns = c1*temp(n+1)+c2*temp(n+2)
      if (m .gt. 2) zxy1ns = zxy1ns+c3*temp(n+3)
c
c obtain x-partial derivative along x = xmax
c
      c1 = -c1
      c2 = -c2
      if (m .gt. 2) c3 = -c3
      do 10 j = 1,n
        npmpj = npm+j
   10   temp(npmpj) = c1*z(m,j)+c2*z(mm1,j)
      if (m .eq. 2) go to 12
      do 11 j = 1,n
        npmpj = npm+j
   11   temp(npmpj) = temp(npmpj)+c3*z(m-2,j)
c
c obtain x-y-partial derivative at (xmax,ymin)
c
   12 zp(m,1,3) = c1*zp(m,1,1)+c2*zp(mm1,1,1)
      if (m .gt. 2) zp(m,1,3) = zp(m,1,3)+c3*zp(m-2,1,1)
c
c obtain x-y-partial derivative at (xmax,ymax)
c
      zxymns = c1*temp(npm)+c2*temp(npm-1)
      if (m .gt. 2) zxymns = zxymns+c3*temp(npm-2)
c
c set up right hand sides and tridiagonal system for y-grid
c perform forward elimination
c
      del1 = dely1
      deli = 1./del1
      do 13 i = 1,m
   13   zp(i,2,1) = deli*(z(i,2)-z(i,1))
      zp(1,2,3) = deli*(zp(1,2,2)-zp(1,1,2))
      zp(m,2,3) = deli*(temp(npm+2)-temp(npm+1))
      call terms (diag1,sdiag1,sigmay,del1)
      diagi = 1./diag1
      do 14 i = 1,m
   14   zp(i,1,1) = diagi*(zp(i,2,1)-zp(i,1,1))
      zp(1,1,3) = diagi*(zp(1,2,3)-zp(1,1,3))
      zp(m,1,3) = diagi*(zp(m,2,3)-zp(m,1,3))
      temp(1) = diagi*sdiag1
      if (n .eq. 2) go to 18
      do 17 j = 2,nm1
        jm1 = j-1
        jp1 = j+1
        npmpj = npm+j
        do 15 i = 1,m
   15     zp(i,jp1,1) = deli*(z(i,jp1)-z(i,j))
        zp(1,jp1,3) = deli*(zp(1,jp1,2)-zp(1,j,2))
        zp(m,jp1,3) = deli*(temp(npmpj+1)-temp(npmpj))
        diagin = 1./(diag1+diag1-sdiag1*temp(jm1))
        do 16 i = 1,m
   16     zp(i,j,1) = diagin*(zp(i,jp1,1)-zp(i,j,1)-
     *                        sdiag1*zp(i,jm1,1))
        zp(1,j,3) = diagin*(zp(1,jp1,3)-zp(1,j,3)-
     *                      sdiag1*zp(1,jm1,3))
        zp(m,j,3) = diagin*(zp(m,jp1,3)-zp(m,j,3)-
     *                      sdiag1*zp(m,jm1,3))
   17   temp(j) = diagin*sdiag1
   18 diagin = 1./(diag1-sdiag1*temp(nm1))
      do 19 i = 1,m
        npi = n+i
   19   zp(i,n,1) = diagin*(temp(npi)-zp(i,n,1)-
     *                      sdiag1*zp(i,nm1,1))
      zp(1,n,3) = diagin*(zxy1ns-zp(1,n,3)-
     *                    sdiag1*zp(1,nm1,3))
      temp(n) = diagin*(zxymns-zp(m,n,3)-
     *                  sdiag1*zp(m,nm1,3))
c
c perform back substitution
c
      do 21 j = 2,n
        jbak = np1-j
        jbakp1 = jbak+1
        t = temp(jbak)
        do 20 i = 1,m
   20     zp(i,jbak,1) = zp(i,jbak,1)-t*zp(i,jbakp1,1)
        zp(1,jbak,3) = zp(1,jbak,3)-t*zp(1,jbakp1,3)
   21   temp(jbak) = zp(m,jbak,3)-t*temp(jbakp1)
c
c set up right hand sides and tridiagonal system for x-grid
c perform forward elimination
c
      del1 = delx1
      deli = 1./del1
      do 22 j = 1,n
        zp(2,j,2) = deli*(z(2,j)-z(1,j))
   22   zp(2,j,3) = deli*(zp(2,j,1)-zp(1,j,1))
      call terms (diag1,sdiag1,sigmax,del1)
      diagi = 1./diag1
      do 23 j = 1,n
        zp(1,j,2) = diagi*(zp(2,j,2)-zp(1,j,2))
   23   zp(1,j,3) = diagi*(zp(2,j,3)-zp(1,j,3))
      temp(n+1) = diagi*sdiag1
      if (m  .eq. 2) go to 27
      do 26 i = 2,mm1
        im1 = i-1
        ip1 = i+1
        npi = n+i
        do 24 j = 1,n
          zp(ip1,j,2) = deli*(z(ip1,j)-z(i,j))
   24     zp(ip1,j,3) = deli*(zp(ip1,j,1)-zp(i,j,1))
        diagin = 1./(diag1+diag1-sdiag1*temp(npi-1))
        do 25 j = 1,n
          zp(i,j,2) = diagin*(zp(ip1,j,2)-zp(i,j,2)-
     *                        sdiag1*zp(im1,j,2))
   25     zp(i,j,3) = diagin*(zp(ip1,j,3)-zp(i,j,3)-
     *                        sdiag1*zp(im1,j,3))
   26   temp(npi) = diagin*sdiag1
   27 diagin = 1./(diag1-sdiag1*temp(npm-1))
      do 28 j = 1,n
        npmpj = npm+j
        zp(m,j,2) = diagin*(temp(npmpj)-zp(m,j,2)-
     *                      sdiag1*zp(mm1,j,2))
   28   zp(m,j,3) = diagin*(temp(j)-zp(m,j,3)-
     *                      sdiag1*zp(mm1,j,3))
c
c perform back substitution
c
      do 29 i = 2,m
        ibak = mp1-i
        ibakp1 = ibak+1
        npibak = n+ibak
        t = temp(npibak)
        do 29 j = 1,n
          zp(ibak,j,2) = zp(ibak,j,2)-t*zp(ibakp1,j,2)
   29     zp(ibak,j,3) = zp(ibak,j,3)-t*zp(ibakp1,j,3)
      return
c
c too few points
c
   30 ierr = 1
      return
c
c xmax not greater than xmin or ymax not greater than ymin
c
   31 ierr = 2
      return
      end
      subroutine xsurf1 (m,n,xmin,xmax,y,z,iz,zp,temp,sigma,
     *                   ierr)
c
      integer m,n,iz,ierr
      real xmin,xmax,y(n),z(iz,n),zp(m,n,3),temp(1),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through a rect-
c angular grid of functional values. the x values are
c assumed equally spaced in the grid. the surface determined
c can be represented as the tensor product of splines under
c tension. for actual interpolation at a grid of points
c equally spaced in both x and y coordinates it is necessary
c to call subroutine xsurf2.
c
c on input--
c
c   m is the number of grid lines in the x-direction, i. e.
c   lines parallel to the y-axis (m .ge. 2).
c
c   n is the number of grid lines in the y-direction, i. e.
c   lines parallel to the x-axis (n .ge. 2).
c
c   xmin and xmax are the lower and upper limits,
c   respectively, of the grid in the x-direction. xmax
c   should be greater than xmin.
c
c   y is an array of the n y-coordinates of the grid lines
c   in the y-direction. these should be strictly increasing.
c
c   z is an array of the m * n functional values at the grid
c   points, i. e. z(i,j) contains the functional value at
c   (x(i),y(j)) for i = 1,...,m and j = 1,...,n, where x(i)
c   represents the i-th equispaced x value.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   zp is an array of at least 3*m*n locations.
c
c   temp is an array of at least n+n+m locations which is
c   used for scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   bi-linear. if sigma equals zero tensor products of
c   cubic splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   zp contains the values of the xx-, yy-, and xxyy-partial
c   derivatives of the surface at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2 or m is less than 2,
c        = 2 if the y-values are not strictly increasing
c            or xmax is not greater than xmin.
c
c and
c
c   m, n, xmin, xmax, y, z, iz, and sigma are unaltered.
c
c this subroutine references package modules ceez, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      mm1 = m-1
      mp1 = m+1
      nm1 = n-1
      np1 = n+1
      npm = n+m
      ierr = 0
      if (n .le. 1 .or. m .le. 1) go to 30
      if (y(n) .le. y(1)) go to 31
c
c denormalize tension factor in y-direction
c
      sigmay = abs(sigma)*float(n-1)/(y(n)-y(1))
c
c obtain y-partial derivatives along y = y(1)
c
      dely1 = y(2)-y(1)
      dely2 = dely1+dely1
      if (n .gt. 2) dely2 = y(3)-y(1)
      if (dely1 .le. 0. .or. dely2 .le. dely1) go to 31
      call ceez (dely1,dely2,sigmay,c1,c2,c3,n)
      do 1 i = 1,m
    1   zp(i,1,1) = c1*z(i,1)+c2*z(i,2)
      if (n .eq. 2) go to 3
      do 2 i = 1,m
    2   zp(i,1,1) = zp(i,1,1)+c3*z(i,3)
c
c obtain y-partial derivatives along y = y(n)
c
    3 delyn = y(n)-y(nm1)
      delynm = delyn+delyn
      if (n .gt. 2) delynm = y(n)-y(n-2)
      if (delyn .le. 0. .or. delynm .le. delyn) go to 31
      call ceez (-delyn,-delynm,sigmay,c1,c2,c3,n)
      do 4 i = 1,m
        npi = n+i
    4   temp(npi) = c1*z(i,n)+c2*z(i,nm1)
      if (n .eq. 2) go to 6
      do 5 i = 1,m
        npi = n+i
    5   temp(npi) = temp(npi)+c3*z(i,n-2)
    6 if (xmax .le. xmin) go to 31
c
c denormalize tension factor in x-direction
c
      sigmax = abs(sigma)*float(m-1)/(xmax-xmin)
c
c obtain x-partial derivatives along x = xmin
c
      delx1 = (xmax-xmin)/float(m-1)
      delx2 = delx1+delx1
      call ceez (delx1,delx2,sigmax,c1,c2,c3,m)
      do 7 j = 1,n
    7   zp(1,j,2) = c1*z(1,j)+c2*z(2,j)
      if (m .eq. 2) go to 9
      do 8 j = 1,n
    8   zp(1,j,2) = zp(1,j,2)+c3*z(3,j)
c
c obtain x-y-partial derivative at (xmin,y(1))
c
    9 zp(1,1,3) = c1*zp(1,1,1)+c2*zp(2,1,1)
      if (m .gt. 2) zp(1,1,3) = zp(1,1,3)+c3*zp(3,1,1)
c
c obtain x-y-partial derivative at (xmin,y(n))
c
      zxy1ns = c1*temp(n+1)+c2*temp(n+2)
      if (m .gt. 2) zxy1ns = zxy1ns+c3*temp(n+3)
c
c obtain x-partial derivative along x = xmax
c
      c1 = -c1
      c2 = -c2
      if (m .gt. 2) c3 = -c3
      do 10 j = 1,n
        npmpj = npm+j
   10   temp(npmpj) = c1*z(m,j)+c2*z(mm1,j)
      if (m .eq. 2) go to 12
      do 11 j = 1,n
        npmpj = npm+j
   11   temp(npmpj) = temp(npmpj)+c3*z(m-2,j)
c
c obtain x-y-partial derivative at (xmax,y(1))
c
   12 zp(m,1,3) = c1*zp(m,1,1)+c2*zp(mm1,1,1)
      if (m .gt. 2) zp(m,1,3) = zp(m,1,3)+c3*zp(m-2,1,1)
c
c obtain x-y-partial derivative at (xmax,y(n))
c
      zxymns = c1*temp(npm)+c2*temp(npm-1)
      if (m .gt. 2) zxymns = zxymns+c3*temp(npm-2)
c
c set up right hand sides and tridiagonal system for y-grid
c perform forward elimination
c
      del1 = y(2)-y(1)
      if (del1 .le. 0.) go to 31
      deli = 1./del1
      do 13 i = 1,m
   13   zp(i,2,1) = deli*(z(i,2)-z(i,1))
      zp(1,2,3) = deli*(zp(1,2,2)-zp(1,1,2))
      zp(m,2,3) = deli*(temp(npm+2)-temp(npm+1))
      call terms (diag1,sdiag1,sigmay,del1)
      diagi = 1./diag1
      do 14 i = 1,m
   14   zp(i,1,1) = diagi*(zp(i,2,1)-zp(i,1,1))
      zp(1,1,3) = diagi*(zp(1,2,3)-zp(1,1,3))
      zp(m,1,3) = diagi*(zp(m,2,3)-zp(m,1,3))
      temp(1) = diagi*sdiag1
      if (n .eq. 2) go to 18
      do 17 j = 2,nm1
        jm1 = j-1
        jp1 = j+1
        npmpj = npm+j
        del2 = y(jp1)-y(j)
        if (del2 .le. 0.) go to 31
        deli = 1./del2
        do 15 i = 1,m
   15     zp(i,jp1,1) = deli*(z(i,jp1)-z(i,j))
        zp(1,jp1,3) = deli*(zp(1,jp1,2)-zp(1,j,2))
        zp(m,jp1,3) = deli*(temp(npmpj+1)-temp(npmpj))
        call terms (diag2,sdiag2,sigmay,del2)
        diagin = 1./(diag1+diag2-sdiag1*temp(jm1))
        do 16 i = 1,m
   16     zp(i,j,1) = diagin*(zp(i,jp1,1)-zp(i,j,1)-
     *                        sdiag1*zp(i,jm1,1))
        zp(1,j,3) = diagin*(zp(1,jp1,3)-zp(1,j,3)-
     *                      sdiag1*zp(1,jm1,3))
        zp(m,j,3) = diagin*(zp(m,jp1,3)-zp(m,j,3)-
     *                      sdiag1*zp(m,jm1,3))
        temp(j) = diagin*sdiag2
        diag1 = diag2
   17   sdiag1 = sdiag2
   18 diagin = 1./(diag1-sdiag1*temp(nm1))
      do 19 i = 1,m
        npi = n+i
   19   zp(i,n,1) = diagin*(temp(npi)-zp(i,n,1)-
     *                      sdiag1*zp(i,nm1,1))
      zp(1,n,3) = diagin*(zxy1ns-zp(1,n,3)-
     *                    sdiag1*zp(1,nm1,3))
      temp(n) = diagin*(zxymns-zp(m,n,3)-
     *                  sdiag1*zp(m,nm1,3))
c
c perform back substitution
c
      do 21 j = 2,n
        jbak = np1-j
        jbakp1 = jbak+1
        t = temp(jbak)
        do 20 i = 1,m
   20     zp(i,jbak,1) = zp(i,jbak,1)-t*zp(i,jbakp1,1)
        zp(1,jbak,3) = zp(1,jbak,3)-t*zp(1,jbakp1,3)
   21   temp(jbak) = zp(m,jbak,3)-t*temp(jbakp1)
c
c set up right hand sides and tridiagonal system for x-grid
c perform forward elimination
c
      del1 = delx1
      deli = 1./del1
      do 22 j = 1,n
        zp(2,j,2) = deli*(z(2,j)-z(1,j))
   22   zp(2,j,3) = deli*(zp(2,j,1)-zp(1,j,1))
      call terms (diag1,sdiag1,sigmax,del1)
      diagi = 1./diag1
      do 23 j = 1,n
        zp(1,j,2) = diagi*(zp(2,j,2)-zp(1,j,2))
   23   zp(1,j,3) = diagi*(zp(2,j,3)-zp(1,j,3))
      temp(n+1) = diagi*sdiag1
      if (m  .eq. 2) go to 27
      do 26 i = 2,mm1
        im1 = i-1
        ip1 = i+1
        npi = n+i
        do 24 j = 1,n
          zp(ip1,j,2) = deli*(z(ip1,j)-z(i,j))
   24     zp(ip1,j,3) = deli*(zp(ip1,j,1)-zp(i,j,1))
        diagin = 1./(diag1+diag1-sdiag1*temp(npi-1))
        do 25 j = 1,n
          zp(i,j,2) = diagin*(zp(ip1,j,2)-zp(i,j,2)-
     *                        sdiag1*zp(im1,j,2))
   25     zp(i,j,3) = diagin*(zp(ip1,j,3)-zp(i,j,3)-
     *                        sdiag1*zp(im1,j,3))
   26   temp(npi) = diagin*sdiag1
   27 diagin = 1./(diag1-sdiag1*temp(npm-1))
      do 28 j = 1,n
        npmpj = npm+j
        zp(m,j,2) = diagin*(temp(npmpj)-zp(m,j,2)-
     *                      sdiag1*zp(mm1,j,2))
   28   zp(m,j,3) = diagin*(temp(j)-zp(m,j,3)-
     *                      sdiag1*zp(mm1,j,3))
c
c perform back substitution
c
      do 29 i = 2,m
        ibak = mp1-i
        ibakp1 = ibak+1
        npibak = n+ibak
        t = temp(npibak)
        do 29 j = 1,n
          zp(ibak,j,2) = zp(ibak,j,2)-t*zp(ibakp1,j,2)
   29     zp(ibak,j,3) = zp(ibak,j,3)-t*zp(ibakp1,j,3)
      return
c
c too few points
c
   30 ierr = 1
      return
c
c points not strictly increasing
c
   31 ierr = 2
      return
      end
      subroutine ysurf1 (m,n,x,ymin,ymax,z,iz,zp,temp,sigma,
     *                   ierr)
c
      integer m,n,iz,ierr
      real x(m),ymin,ymax,z(iz,n),zp(m,n,3),temp(1),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through a rect-
c angular grid of functional values. the y values are
c assumed equally spaced in the grid. the surface determined
c can be represented as the tensor product of splines under
c tension. for actual interpolation at a grid of points
c equally spaced in both x and y coordinates it is necessary
c to call subroutine ysurf2.
c
c on input--
c
c   m is the number of grid lines in the x-direction, i. e.
c   lines parallel to the y-axis (m .ge. 2).
c
c   n is the number of grid lines in the y-direction, i. e.
c   lines parallel to the x-axis (n .ge. 2).
c
c   x is an array of the m x-coordinates of the grid lines
c   in the x-direction. these should be strictly increasing.
c
c   ymin and ymax are the lower and upper limits,
c   respectively, of the grid in the y direction. ymax
c   should be greater than ymin.
c
c   z is an array of the m * n functional values at the grid
c   points, i. e. z(i,j) contains the functional value at
c   (x(i),y(j)) for i = 1,...,m and j = 1,...,n, where y(j)
c   represents the j-th equispaced y value.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   zp is an array of at least 3*m*n locations.
c
c   temp is an array of at least n+n+m locations which is
c   used for scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   bi-linear. if sigma equals zero tensor products of
c   cubic splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   zp contains the values of the xx-, yy-, and xxyy-partial
c   derivatives of the surface at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2 or m is less than 2,
c        = 2 if the x-values are not strictly increasing
c            or ymax is not greater than ymin.
c
c and
c
c   m, n, x, ymin, ymax, z, iz, and sigma are unaltered.
c
c this subroutine references package modules ceez, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      mm1 = m-1
      mp1 = m+1
      nm1 = n-1
      np1 = n+1
      npm = n+m
      ierr = 0
      if (n .le. 1 .or. m .le. 1) go to 30
      if (ymax .le. ymin) go to 31
c
c denormalize tension factor in y-direction
c
      sigmay = abs(sigma)*float(n-1)/(ymax-ymin)
c
c obtain y-partial derivatives along y = ymin
c
      dely1 = (ymax-ymin)/float(n-1)
      dely2 = dely1+dely1
      call ceez (dely1,dely2,sigmay,c1,c2,c3,n)
      do 1 i = 1,m
    1   zp(i,1,1) = c1*z(i,1)+c2*z(i,2)
      if (n .eq. 2) go to 3
      do 2 i = 1,m
    2   zp(i,1,1) = zp(i,1,1)+c3*z(i,3)
c
c obtain y-partial derivatives along y = ymax
c
    3 c1 = -c1
      c2 = -c2
      if (n .gt. 2) c3 = -c3
      do 4 i = 1,m
        npi = n+i
    4   temp(npi) = c1*z(i,n)+c2*z(i,nm1)
      if (n .eq. 2) go to 6
      do 5 i = 1,m
        npi = n+i
    5   temp(npi) = temp(npi)+c3*z(i,n-2)
    6 if (x(m) .le. x(1)) go to 31
c
c denormalize tension factor in x-direction
c
      sigmax = abs(sigma)*float(m-1)/(x(m)-x(1))
c
c obtain x-partial derivatives along x = x(1)
c
      delx1 = x(2)-x(1)
      delx2 = delx1+delx1
      if (m .gt. 2) delx2 = x(3)-x(1)
      if (delx1 .le. 0. .or. delx2 .le. delx1) go to 31
      call ceez (delx1,delx2,sigmax,c1,c2,c3,m)
      do 7 j = 1,n
    7   zp(1,j,2) = c1*z(1,j)+c2*z(2,j)
      if (m .eq. 2) go to 9
      do 8 j = 1,n
    8   zp(1,j,2) = zp(1,j,2)+c3*z(3,j)
c
c obtain x-y-partial derivative at (x(1),ymin)
c
    9 zp(1,1,3) = c1*zp(1,1,1)+c2*zp(2,1,1)
      if (m .gt. 2) zp(1,1,3) = zp(1,1,3)+c3*zp(3,1,1)
c
c obtain x-y-partial derivative at (x(1),ymax)
c
      zxy1ns = c1*temp(n+1)+c2*temp(n+2)
      if (m .gt. 2) zxy1ns = zxy1ns+c3*temp(n+3)
c
c obtain x-partial derivative along x = x(m)
c
      delxm = x(m)-x(mm1)
      delxmm = delxm+delxm
      if (m .gt. 2) delxmm = x(m)-x(m-2)
      if (delxm .le. 0. .or. delxmm .le. delxm) go to 31
      call ceez (-delxm,-delxmm,sigmax,c1,c2,c3,m)
      do 10 j = 1,n
        npmpj = npm+j
   10   temp(npmpj) = c1*z(m,j)+c2*z(mm1,j)
      if (m .eq. 2) go to 12
      do 11 j = 1,n
        npmpj = npm+j
   11   temp(npmpj) = temp(npmpj)+c3*z(m-2,j)
c
c obtain x-y-partial derivative at (x(m),ymin)
c
   12 zp(m,1,3) = c1*zp(m,1,1)+c2*zp(mm1,1,1)
      if (m .gt. 2) zp(m,1,3) = zp(m,1,3)+c3*zp(m-2,1,1)
c
c obtain x-y-partial derivative at (x(m),ymax)
c
      zxymns = c1*temp(npm)+c2*temp(npm-1)
      if (m .gt. 2) zxymns = zxymns+c3*temp(npm-2)
c
c set up right hand sides and tridiagonal system for y-grid
c perform forward elimination
c
      del1 = dely1
      deli = 1./del1
      do 13 i = 1,m
   13   zp(i,2,1) = deli*(z(i,2)-z(i,1))
      zp(1,2,3) = deli*(zp(1,2,2)-zp(1,1,2))
      zp(m,2,3) = deli*(temp(npm+2)-temp(npm+1))
      call terms (diag1,sdiag1,sigmay,del1)
      diagi = 1./diag1
      do 14 i = 1,m
   14   zp(i,1,1) = diagi*(zp(i,2,1)-zp(i,1,1))
      zp(1,1,3) = diagi*(zp(1,2,3)-zp(1,1,3))
      zp(m,1,3) = diagi*(zp(m,2,3)-zp(m,1,3))
      temp(1) = diagi*sdiag1
      if (n .eq. 2) go to 18
      do 17 j = 2,nm1
        jm1 = j-1
        jp1 = j+1
        npmpj = npm+j
        do 15 i = 1,m
   15     zp(i,jp1,1) = deli*(z(i,jp1)-z(i,j))
        zp(1,jp1,3) = deli*(zp(1,jp1,2)-zp(1,j,2))
        zp(m,jp1,3) = deli*(temp(npmpj+1)-temp(npmpj))
        diagin = 1./(diag1+diag1-sdiag1*temp(jm1))
        do 16 i = 1,m
   16     zp(i,j,1) = diagin*(zp(i,jp1,1)-zp(i,j,1)-
     *                        sdiag1*zp(i,jm1,1))
        zp(1,j,3) = diagin*(zp(1,jp1,3)-zp(1,j,3)-
     *                      sdiag1*zp(1,jm1,3))
        zp(m,j,3) = diagin*(zp(m,jp1,3)-zp(m,j,3)-
     *                      sdiag1*zp(m,jm1,3))
   17   temp(j) = diagin*sdiag1
   18 diagin = 1./(diag1-sdiag1*temp(nm1))
      do 19 i = 1,m
        npi = n+i
   19   zp(i,n,1) = diagin*(temp(npi)-zp(i,n,1)-
     *                      sdiag1*zp(i,nm1,1))
      zp(1,n,3) = diagin*(zxy1ns-zp(1,n,3)-
     *                    sdiag1*zp(1,nm1,3))
      temp(n) = diagin*(zxymns-zp(m,n,3)-
     *                  sdiag1*zp(m,nm1,3))
c
c perform back substitution
c
      do 21 j = 2,n
        jbak = np1-j
        jbakp1 = jbak+1
        t = temp(jbak)
        do 20 i = 1,m
   20     zp(i,jbak,1) = zp(i,jbak,1)-t*zp(i,jbakp1,1)
        zp(1,jbak,3) = zp(1,jbak,3)-t*zp(1,jbakp1,3)
   21   temp(jbak) = zp(m,jbak,3)-t*temp(jbakp1)
c
c set up right hand sides and tridiagonal system for x-grid
c perform forward elimination
c
      del1 = x(2)-x(1)
      if (del1 .le. 0.) go to 31
      deli = 1./del1
      do 22 j = 1,n
        zp(2,j,2) = deli*(z(2,j)-z(1,j))
   22   zp(2,j,3) = deli*(zp(2,j,1)-zp(1,j,1))
      call terms (diag1,sdiag1,sigmax,del1)
      diagi = 1./diag1
      do 23 j = 1,n
        zp(1,j,2) = diagi*(zp(2,j,2)-zp(1,j,2))
   23   zp(1,j,3) = diagi*(zp(2,j,3)-zp(1,j,3))
      temp(n+1) = diagi*sdiag1
      if (m  .eq. 2) go to 27
      do 26 i = 2,mm1
        im1 = i-1
        ip1 = i+1
        npi = n+i
        del2 = x(ip1)-x(i)
        if (del2 .le. 0.) go to 31
        deli = 1./del2
        do 24 j = 1,n
          zp(ip1,j,2) = deli*(z(ip1,j)-z(i,j))
   24     zp(ip1,j,3) = deli*(zp(ip1,j,1)-zp(i,j,1))
        call terms (diag2,sdiag2,sigmax,del2)
        diagin = 1./(diag1+diag2-sdiag1*temp(npi-1))
        do 25 j = 1,n
          zp(i,j,2) = diagin*(zp(ip1,j,2)-zp(i,j,2)-
     *                        sdiag1*zp(im1,j,2))
   25     zp(i,j,3) = diagin*(zp(ip1,j,3)-zp(i,j,3)-
     *                        sdiag1*zp(im1,j,3))
        temp(npi) = diagin*sdiag2
        diag1 = diag2
   26   sdiag1 = sdiag2
   27 diagin = 1./(diag1-sdiag1*temp(npm-1))
      do 28 j = 1,n
        npmpj = npm+j
        zp(m,j,2) = diagin*(temp(npmpj)-zp(m,j,2)-
     *                      sdiag1*zp(mm1,j,2))
   28   zp(m,j,3) = diagin*(temp(j)-zp(m,j,3)-
     *                      sdiag1*zp(mm1,j,3))
c
c perform back substitution
c
      do 29 i = 2,m
        ibak = mp1-i
        ibakp1 = ibak+1
        npibak = n+ibak
        t = temp(npibak)
        do 29 j = 1,n
          zp(ibak,j,2) = zp(ibak,j,2)-t*zp(ibakp1,j,2)
   29     zp(ibak,j,3) = zp(ibak,j,3)-t*zp(ibakp1,j,3)
      return
c
c too few points
c
   30 ierr = 1
      return
c
c points not strictly increasing
c
   31 ierr = 2
      return
      end
      subroutine nsurf1 (m,n,x,y,z,iz,zp,temp,sigma,ierr)
c
      integer m,n,iz,ierr
      real x(m),y(n),z(iz,n),zp(m,n,3),temp(1),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through a rect-
c angular grid of functional values. the surface determined
c can be represented as the tensor product of splines under
c tension. for actual mapping of points onto the surface it
c necessary to call the function surf2. for actual
c interpolation at a grid of points equally spaced in both
c x and y coordinates it is necessary to call subroutine
c nsurf2.
c
c on input--
c
c   m is the number of grid lines in the x-direction, i. e.
c   lines parallel to the y-axis (m .ge. 2).
c
c   n is the number of grid lines in the y-direction, i. e.
c   lines parallel to the x-axis (n .ge. 2).
c
c   x is an array of the m x-coordinates of the grid lines
c   in the x-direction. these should be strictly increasing.
c
c   y is an array of the n y-coordinates of the grid lines
c   in the y-direction. these should be strictly increasing.
c
c   z is an array of the m * n functional values at the grid
c   points, i. e. z(i,j) contains the functional value at
c   (x(i),y(j)) for i = 1,...,m and j = 1,...,n.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   zp is an array of at least 3*m*n locations.
c
c   temp is an array of at least n+n+m locations which is
c   used for scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   bi-linear. if sigma equals zero tensor products of
c   cubic splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   zp contains the values of the xx-, yy-, and xxyy-partial
c   derivatives of the surface at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2 or m is less than 2,
c        = 2 if the x-values or y-values are not strictly
c            increasing.
c
c and
c
c   m, n, x, y, z, iz, and sigma are unaltered.
c
c this subroutine references package modules ceez, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      mm1 = m-1
      mp1 = m+1
      nm1 = n-1
      np1 = n+1
      npm = n+m
      ierr = 0
      if (n .le. 1 .or. m .le. 1) go to 30
      if (y(n) .le. y(1)) go to 31
c
c denormalize tension factor in y-direction
c
      sigmay = abs(sigma)*float(n-1)/(y(n)-y(1))
c
c obtain y-partial derivatives along y = y(1)
c
      dely1 = y(2)-y(1)
      dely2 = dely1+dely1
      if (n .gt. 2) dely2 = y(3)-y(1)
      if (dely1 .le. 0. .or. dely2 .le. dely1) go to 31
      call ceez (dely1,dely2,sigmay,c1,c2,c3,n)
      do 1 i = 1,m
    1   zp(i,1,1) = c1*z(i,1)+c2*z(i,2)
      if (n .eq. 2) go to 3
      do 2 i = 1,m
    2   zp(i,1,1) = zp(i,1,1)+c3*z(i,3)
c
c obtain y-partial derivatives along y = y(n)
c
    3 delyn = y(n)-y(nm1)
      delynm = delyn+delyn
      if (n .gt. 2) delynm = y(n)-y(n-2)
      if (delyn .le. 0. .or. delynm .le. delyn) go to 31
      call ceez (-delyn,-delynm,sigmay,c1,c2,c3,n)
      do 4 i = 1,m
        npi = n+i
    4   temp(npi) = c1*z(i,n)+c2*z(i,nm1)
      if (n .eq. 2) go to 6
      do 5 i = 1,m
        npi = n+i
    5   temp(npi) = temp(npi)+c3*z(i,n-2)
    6 if (x(m) .le. x(1)) go to 31
c
c denormalize tension factor in x-direction
c
      sigmax = abs(sigma)*float(m-1)/(x(m)-x(1))
c
c obtain x-partial derivatives along x = x(1)
c
      delx1 = x(2)-x(1)
      delx2 = delx1+delx1
      if (m .gt. 2) delx2 = x(3)-x(1)
      if (delx1 .le. 0. .or. delx2 .le. delx1) go to 31
      call ceez (delx1,delx2,sigmax,c1,c2,c3,m)
      do 7 j = 1,n
    7   zp(1,j,2) = c1*z(1,j)+c2*z(2,j)
      if (m .eq. 2) go to 9
      do 8 j = 1,n
    8   zp(1,j,2) = zp(1,j,2)+c3*z(3,j)
c
c obtain x-y-partial derivative at (x(1),y(1))
c
    9 zp(1,1,3) = c1*zp(1,1,1)+c2*zp(2,1,1)
      if (m .gt. 2) zp(1,1,3) = zp(1,1,3)+c3*zp(3,1,1)
c
c obtain x-y-partial derivative at (x(1),y(n))
c
      zxy1ns = c1*temp(n+1)+c2*temp(n+2)
      if (m .gt. 2) zxy1ns = zxy1ns+c3*temp(n+3)
c
c obtain x-partial derivative along x = x(m)
c
      delxm = x(m)-x(mm1)
      delxmm = delxm+delxm
      if (m .gt. 2) delxmm = x(m)-x(m-2)
      if (delxm .le. 0. .or. delxmm .le. delxm) go to 31
      call ceez (-delxm,-delxmm,sigmax,c1,c2,c3,m)
      do 10 j = 1,n
        npmpj = npm+j
   10   temp(npmpj) = c1*z(m,j)+c2*z(mm1,j)
      if (m .eq. 2) go to 12
      do 11 j = 1,n
        npmpj = npm+j
   11   temp(npmpj) = temp(npmpj)+c3*z(m-2,j)
c
c obtain x-y-partial derivative at (x(m),y(1))
c
   12 zp(m,1,3) = c1*zp(m,1,1)+c2*zp(mm1,1,1)
      if (m .gt. 2) zp(m,1,3) = zp(m,1,3)+c3*zp(m-2,1,1)
c
c obtain x-y-partial derivative at (x(m),y(n))
c
      zxymns = c1*temp(npm)+c2*temp(npm-1)
      if (m .gt. 2) zxymns = zxymns+c3*temp(npm-2)
c
c set up right hand sides and tridiagonal system for y-grid
c perform forward elimination
c
      del1 = y(2)-y(1)
      if (del1 .le. 0.) go to 31
      deli = 1./del1
      do 13 i = 1,m
   13   zp(i,2,1) = deli*(z(i,2)-z(i,1))
      zp(1,2,3) = deli*(zp(1,2,2)-zp(1,1,2))
      zp(m,2,3) = deli*(temp(npm+2)-temp(npm+1))
      call terms (diag1,sdiag1,sigmay,del1)
      diagi = 1./diag1
      do 14 i = 1,m
   14   zp(i,1,1) = diagi*(zp(i,2,1)-zp(i,1,1))
      zp(1,1,3) = diagi*(zp(1,2,3)-zp(1,1,3))
      zp(m,1,3) = diagi*(zp(m,2,3)-zp(m,1,3))
      temp(1) = diagi*sdiag1
      if (n .eq. 2) go to 18
      do 17 j = 2,nm1
        jm1 = j-1
        jp1 = j+1
        npmpj = npm+j
        del2 = y(jp1)-y(j)
        if (del2 .le. 0.) go to 31
        deli = 1./del2
        do 15 i = 1,m
   15     zp(i,jp1,1) = deli*(z(i,jp1)-z(i,j))
        zp(1,jp1,3) = deli*(zp(1,jp1,2)-zp(1,j,2))
        zp(m,jp1,3) = deli*(temp(npmpj+1)-temp(npmpj))
        call terms (diag2,sdiag2,sigmay,del2)
        diagin = 1./(diag1+diag2-sdiag1*temp(jm1))
        do 16 i = 1,m
   16     zp(i,j,1) = diagin*(zp(i,jp1,1)-zp(i,j,1)-
     *                        sdiag1*zp(i,jm1,1))
        zp(1,j,3) = diagin*(zp(1,jp1,3)-zp(1,j,3)-
     *                      sdiag1*zp(1,jm1,3))
        zp(m,j,3) = diagin*(zp(m,jp1,3)-zp(m,j,3)-
     *                      sdiag1*zp(m,jm1,3))
        temp(j) = diagin*sdiag2
        diag1 = diag2
   17   sdiag1 = sdiag2
   18 diagin = 1./(diag1-sdiag1*temp(nm1))
      do 19 i = 1,m
        npi = n+i
   19   zp(i,n,1) = diagin*(temp(npi)-zp(i,n,1)-
     *                      sdiag1*zp(i,nm1,1))
      zp(1,n,3) = diagin*(zxy1ns-zp(1,n,3)-
     *                    sdiag1*zp(1,nm1,3))
      temp(n) = diagin*(zxymns-zp(m,n,3)-
     *                  sdiag1*zp(m,nm1,3))
c
c perform back substitution
c
      do 21 j = 2,n
        jbak = np1-j
        jbakp1 = jbak+1
        t = temp(jbak)
        do 20 i = 1,m
   20     zp(i,jbak,1) = zp(i,jbak,1)-t*zp(i,jbakp1,1)
        zp(1,jbak,3) = zp(1,jbak,3)-t*zp(1,jbakp1,3)
   21   temp(jbak) = zp(m,jbak,3)-t*temp(jbakp1)
c
c set up right hand sides and tridiagonal system for x-grid
c perform forward elimination
c
      del1 = x(2)-x(1)
      if (del1 .le. 0.) go to 31
      deli = 1./del1
      do 22 j = 1,n
        zp(2,j,2) = deli*(z(2,j)-z(1,j))
   22   zp(2,j,3) = deli*(zp(2,j,1)-zp(1,j,1))
      call terms (diag1,sdiag1,sigmax,del1)
      diagi = 1./diag1
      do 23 j = 1,n
        zp(1,j,2) = diagi*(zp(2,j,2)-zp(1,j,2))
   23   zp(1,j,3) = diagi*(zp(2,j,3)-zp(1,j,3))
      temp(n+1) = diagi*sdiag1
      if (m  .eq. 2) go to 27
      do 26 i = 2,mm1
        im1 = i-1
        ip1 = i+1
        npi = n+i
        del2 = x(ip1)-x(i)
        if (del2 .le. 0.) go to 31
        deli = 1./del2
        do 24 j = 1,n
          zp(ip1,j,2) = deli*(z(ip1,j)-z(i,j))
   24     zp(ip1,j,3) = deli*(zp(ip1,j,1)-zp(i,j,1))
        call terms (diag2,sdiag2,sigmax,del2)
        diagin = 1./(diag1+diag2-sdiag1*temp(npi-1))
        do 25 j = 1,n
          zp(i,j,2) = diagin*(zp(ip1,j,2)-zp(i,j,2)-
     *                        sdiag1*zp(im1,j,2))
   25     zp(i,j,3) = diagin*(zp(ip1,j,3)-zp(i,j,3)-
     *                        sdiag1*zp(im1,j,3))
        temp(npi) = diagin*sdiag2
        diag1 = diag2
   26   sdiag1 = sdiag2
   27 diagin = 1./(diag1-sdiag1*temp(npm-1))
      do 28 j = 1,n
        npmpj = npm+j
        zp(m,j,2) = diagin*(temp(npmpj)-zp(m,j,2)-
     *                      sdiag1*zp(mm1,j,2))
   28   zp(m,j,3) = diagin*(temp(j)-zp(m,j,3)-
     *                      sdiag1*zp(mm1,j,3))
c
c perform back substitution
c
      do 29 i = 2,m
        ibak = mp1-i
        ibakp1 = ibak+1
        npibak = n+ibak
        t = temp(npibak)
        do 29 j = 1,n
          zp(ibak,j,2) = zp(ibak,j,2)-t*zp(ibakp1,j,2)
   29     zp(ibak,j,3) = zp(ibak,j,3)-t*zp(ibakp1,j,3)
      return
c
c too few points
c
   30 ierr = 1
      return
c
c points not strictly increasing
c
   31 ierr = 2
      return
      end
      subroutine surfs (m,n,x,y,dx,dy,isw,s,eps,z,iz,zs,zsp,
     *                  work,sigma,ierr)
c
      integer m,n,isw,iz,ierr
      real x(m),y(n),dx(m),dy(n),s,eps,z(iz,n),zs(m,n),
     *     zsp(1),work(1),sigma
c
c                       coded by a. k. cline and t. h. rowan
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a smoothing surface under tension approximating
c a rectangular grid of functional values. for given
c increasing sequences of abscissae (x(i)), i = 1,..., m,
c (y(j)), j = 1,..., n and associated ordinates (z(i,j)),
c i = 1,..., m, j = 1,...,n, the function is determined
c so that the double summation of the square of
c (f(x(i),y(j))-z(i,j))/(dx(i)*dy(j)) is less than or equal
c to a given constant s, where (dx(i)), i = 1,..., m and
c (dy(j)), j = 1,..., n are given sets of observation
c weights. the method used is to solve n one-dimensional
c smoothing problems along fixed y lines and to solve m
c one-dimensional smoothing problems along fixed x lines,
c independently from the fixed y solutions. the functional
c values of the smoothed surface are determined by averaging
c the x-direction smoothed values with the y-direction
c smoothed values. for actual mapping of points onto the
c smoothed surface it is necessary to call the function
c surf2 with the surface information returned by surfs in zs
c and zsp. the determination of the surface is performed by
c subroutine surfss. the subroutine surfs decomposes the
c workspace for surfss and determines surface derivative
c information needed by surf2.
c
c on input--
c
c   m is the number of grid lines in the x-direction, i. e.
c   lines parallel to the y-axis (m .ge. 2).
c
c   n is the number of grid lines in the y-direction, i. e.
c   lines parallel to the x-axis (n .ge. 2).
c
c   x is an array of the m x-coordinates of the grid lines
c   in the x-direction. these should be strictly increasing.
c
c   y is an array of the n y-coordinates of the grid lines
c   in the y-direction. these should be strictly increasing.
c
c   dx and dy are parameters containing the observation
c   weights. these may either be arrays of lengths m and n
c   respectively or scalars (interpreted as constants). the
c   product of the values of dx and dy corresponding to the
c   observation (x(i),y(j),z(i,j)) should be an
c   approximation to the standard deviation of error.
c
c   isw contains a switch indicating whether the parameters
c   dx and dy are to be considered vectors or scalars,
c          = 0 if dx and dy are arrays of lengths m and n
c              respectively,
c          = 1 if dx and dy are scalars.
c
c   s contains the value controlling the smoothing. this
c   must be non-negative. for s equal to zero, the
c   subroutine does interpolation, larger values lead to
c   smoother functions. if dx(i)*dy(j) is an approximation
c   to the standard deviation of error for observation
c   (x(i),y(j),z(i,j)), a reasonable value for s is
c   float(m*n).
c
c   eps contains a tolerance on the relative precision to
c   which s is to be interpreted. this must be greater than
c   or equal to zero and less than or equal to one. a
c   reasonable value for eps is sqrt(2./float(m*n)).
c
c   z is an array of the m * n functional values at the grid
c   points, i. e. z(i,j) contains the functional value at
c   (x(i),y(j)) for i = 1,...,m and j = 1,...,n.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   zs is an array of at least m*n locations.
c
c   zsp is an array of at least 3*m*n locations.
c
c   work is an array of at least 7 * max(m,n) locations to
c   be used internally for workspace.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   bi-linear. if sigma equals zero tensor products of
c   cubic splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   zs contains the smoothed ordinate values.
c
c   zsp contains the values of the xx-, yy-, and
c   xxyy-partial derivatives of the smoothed surface at the
c   given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2 or m is less than 2,
c        = 2 if s is negative,
c        = 3 if eps is negative or greater than one,
c        = 4 if the x-values or y-values are not strictly
c            increasing,
c        = 5 if a dx-value or dy-value is non-positive.
c
c and
c
c   m, n, x, y, dx, dy, isw, s, eps, z, iz, and sigma are
c   unaltered.
c
c this subroutine references package modules surfss, surfn1,
c crvssa, crvssb, terms, and snhcsh.
c
c this subroutine references blas module scopy.
c
c-----------------------------------------------------------
c
      mxmn = max0(m,n)
      i2 = mxmn+1
      i3 = i2+mxmn
      i4 = i3+mxmn
      i5 = i4+mxmn
      i6 = i5+mxmn
      i7 = i6+mxmn
      call surfss (m,n,x,y,dx,dy,isw,s,eps,z,iz,zs,zsp,
     *           zsp(i2),zsp(i3),zsp(i4),zsp(i5),zsp(i6),
     *           work,work(i2),work(i3),work(i4),work(i5),
     *           work(i6),work(i7),sigma,ierr)
      call surfn1 (m,n,x,y,zs,m,zsp,work,sigma,ierr)
      return
      end
      function surf2 (xx,yy,m,n,x,y,z,iz,zp,sigma)
c
      integer m,n,iz
      real xx,yy,x(m),y(n),z(iz,n),zp(m,n,3),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function interpolates a surface at a given coordinate
c pair using a bi-spline under tension. the subroutine surf1
c should be called earlier to determine certain necessary
c parameters.
c
c on input--
c
c   xx and yy contain the x- and y-coordinates of the point
c   to be mapped onto the interpolating surface.
c
c   m and n contain the number of grid lines in the x- and
c   y-directions, respectively, of the rectangular grid
c   which specified the surface.
c
c   x and y are arrays containing the x- and y-grid values,
c   respectively, each in increasing order.
c
c   z is a matrix containing the m * n functional values
c   corresponding to the grid values (i. e. z(i,j) is the
c   surface value at the point (x(i),y(j)) for i = 1,...,m
c   and j = 1,...,n).
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3*m*n locations stored with the
c   various surface derivative information determined by
c   surf1.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters m, n, x, y, z, iz, zp, and sigma should be
c input unaltered from the output of surf1.
c
c on output--
c
c   surf2 contains the interpolated surface value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c inline one dimensional cubic spline interpolation
c
      hermz (f1,f2,fp1,fp2) = (f2*del1+f1*del2)/dels-del1*
     *                        del2*(fp2*(del1+dels)+
     *                              fp1*(del2+dels))/
     *                        (6.*dels)
c
c inline one dimensional spline under tension interpolation
c
      hermnz (f1,f2,fp1,fp2,sigmap) = (f2*del1+f1*del2)/dels
     *          +(fp2*del1*(sinhm1-sinhms)
     *           +fp1*del2*(sinhm2-sinhms)
     *          )/(sigmap*sigmap*dels*(1.+sinhms))
c
c denormalize tension factor in x and y direction
c
      sigmax = abs(sigma)*float(m-1)/(x(m)-x(1))
      sigmay = abs(sigma)*float(n-1)/(y(n)-y(1))
c
c determine y interval
c
      jm1 = intrvl (yy,y,n)
      j = jm1+1
c
c determine x interval
c
      im1 = intrvl (xx,x,m)
      i = im1+1
      del1 = yy-y(jm1)
      del2 = y(j)-yy
      dels = y(j)-y(jm1)
      if (sigmay .ne. 0.) go to 1
c
c perform four interpolations in y-direction
c
      zim1 = hermz(z(i-1,j-1),z(i-1,j),zp(i-1,j-1,1),
     *                                  zp(i-1,j,1))
      zi = hermz(z(i,j-1),z(i,j),zp(i,j-1,1),zp(i,j,1))
      zxxim1 = hermz(zp(i-1,j-1,2),zp(i-1,j,2),
     *                zp(i-1,j-1,3),zp(i-1,j,3))
      zxxi = hermz(zp(i,j-1,2),zp(i,j,2),
     *              zp(i,j-1,3),zp(i,j,3))
      go to 2
    1 call snhcsh (sinhm1,dummy,sigmay*del1,-1)
      call snhcsh (sinhm2,dummy,sigmay*del2,-1)
      call snhcsh (sinhms,dummy,sigmay*dels,-1)
      zim1 = hermnz(z(i-1,j-1),z(i-1,j),zp(i-1,j-1,1),
     *               zp(i-1,j,1),sigmay)
      zi = hermnz(z(i,j-1),z(i,j),zp(i,j-1,1),zp(i,j,1),
     *             sigmay)
      zxxim1 = hermnz(zp(i-1,j-1,2),zp(i-1,j,2),
     *                 zp(i-1,j-1,3),zp(i-1,j,3),sigmay)
      zxxi = hermnz(zp(i,j-1,2),zp(i,j,2),
     *               zp(i,j-1,3),zp(i,j,3),sigmay)
c
c perform final interpolation in x-direction
c
    2 del1 = xx-x(im1)
      del2 = x(i)-xx
      dels = x(i)-x(im1)
      if (sigmax .ne. 0.) go to 3
      surf2 = hermz(zim1,zi,zxxim1,zxxi)
      return
    3 call snhcsh (sinhm1,dummy,sigmax*del1,-1)
      call snhcsh (sinhm2,dummy,sigmax*del2,-1)
      call snhcsh (sinhms,dummy,sigmax*dels,-1)
      surf2 = hermnz(zim1,zi,zxxim1,zxxi,sigmax)
      return
      end
      subroutine surfd (xx,yy,zz,zx,zy,zxx,zxy,zyy,m,n,x,y,
     *                  z,iz,zp,sigma)
c
      integer m,n,iz
      real xx,yy,zz,zx,zy,zxx,zxy,zyy,x(m),y(n),z(iz,n),
     *     zp(m,n,3),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine evaluates the function value, the two
c first partial derivatives, and the three second partial
c derivatives of a tensor product spline under tension in
c two variables. the subroutine surf1 should be called
c earlier to determine certain necessary parameters.
c
c on input--
c
c   xx and yy contain the x- and y-coordinates of the point
c   to be mapped onto the interpolating surface.
c
c   m and n contain the number of grid lines in the x- and
c   y-directions, respectively, of the rectangular grid
c   which specified the surface.
c
c   x and y are arrays containing the x- and y-grid values,
c   respectively, each in increasing order.
c
c   z is a matrix containing the m * n functional values
c   corresponding to the grid values (i. e. z(i,j) is the
c   surface value at the point (x(i),y(j)) for i = 1,...,m
c   and j = 1,...,n).
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3*m*n locations stored with the
c   various surface derivative information determined by
c   surf1.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters m, n, x, y, z, iz, zp, and sigma should be
c input unaltered from the output of surf1.
c
c on output--
c
c   zz contains the interpolated function value.
c
c   zx and zy contain the x- and y- partial derivatives,
c   respectively.
c
c   zxx, zxy, and zyy contain the xx-, xy-, and yy-partial
c   derivatives, respectively.
c
c and
c
c   none of the input parameters are altered.
c
c this subroutine references package modules intrvl
c and snhcsh.
c
c-----------------------------------------------------------
      real cc(10),zj(2),xj(2),xxj(2),yyj(2),xyyj(2),xxyyj(2)
c
c denormalize tension factor in x and y directions
c
      sigmax = abs(sigma)*float(m-1)/(x(m)-x(1))
      sigmay = abs(sigma)*float(n-1)/(y(n)-y(1))
c
c determine x interval
c
      im1 = intrvl (xx,x,m)
      i = im1+1
c
c determine y interval
c
      jm1 = intrvl (yy,y,n)
      j = jm1+1
c
c obtain x mesh distances
c
      del1 = xx-x(im1)
      del2 = x(i)-xx
      dels = x(i)-x(im1)
c
c obtain common coefficients
c
      cc(1) = del2/dels
      cc(2) = del1/dels
      d = -1./dels
      cc(5) = d
      cc(6) = -d
      if (sigmax .ne. 0.) go to 1
c
c obtain coefficients for cubic spline
c
      con = -del1*del2/(6.*dels)
      cc(3) = (del2+dels)*con
      cc(4) = (del1+dels)*con
      cc(7) = -(2.*del2*del2-del1*(del2+dels))/(6.*dels)
      cc(8) = (2.*del1*del1-del2*(del1+dels))/(6.*dels)
      cc(9) = cc(1)
      cc(10) = cc(2)
      go to 2
c
c obtain coefficients for spline under tension
c
    1 sigdel = sigmax*dels
      call snhcsh (sinhm1,coshm1,sigmax*del1,0)
      call snhcsh (sinhm2,coshm2,sigmax*del2,0)
      call snhcsh (sinhms,dummy,sigdel,-1)
      sinhs = 1.+sinhms
      con = 1./(sigmax*sigdel*sinhs)
      cc(3) = con*del2*(sinhm2-sinhms)
      cc(4) = con*del1*(sinhm1-sinhms)
      cc(7) = -con*(coshm2-sinhms)
      cc(8) = con*(coshm1-sinhms)
      cc(9) = (del2*(1.+sinhm2))/(dels*sinhs)
      cc(10) = (del1*(1.+sinhm1))/(dels*sinhs)
c
c interpolate in x direction
c
    2 call threet (cc,z(im1,jm1),zp(im1,jm1,2),zj(1),xj(1),
     *             xxj(1))
      call threet (cc,z(im1,j),zp(im1,j,2),zj(2),xj(2),
     *             xxj(2))
      call threet (cc,zp(im1,jm1,1),zp(im1,jm1,3),yyj(1),
     *             xyyj(1),xxyyj(1))
      call threet (cc,zp(im1,j,1),zp(im1,j,3),yyj(2),
     *             xyyj(2),xxyyj(2))
c
c obtain y mesh distances
c
      del1 = yy-y(jm1)
      del2 = y(j)-yy
      dels = y(j)-y(jm1)
c
c obtain common coefficients
c
      cc(1) = del2/dels
      cc(2) = del1/dels
      d = -1./dels
      cc(5) = d
      cc(6) = -d
      if (sigmay .ne. 0.) go to 3
c
c obtain coefficients for cubic spline
c
      con = -del1*del2/(6.*dels)
      cc(3) = (del2+dels)*con
      cc(4) = (del1+dels)*con
      cc(7) = -(2.*del2*del2-del1*(del2+dels))/(6.*dels)
      cc(8) = (2.*del1*del1-del2*(del1+dels))/(6.*dels)
      cc(9) = cc(1)
      cc(10) = cc(2)
      go to 4
c
c obtain coefficients for spline under tension
c
    3 sigdel = sigmay*dels
      call snhcsh (sinhm1,coshm1,sigmay*del1,0)
      call snhcsh (sinhm2,coshm2,sigmay*del2,0)
      call snhcsh (sinhms,dummy,sigdel,-1)
      sinhs = 1.+sinhms
      con = 1./(sigmay*sigdel*sinhs)
      cc(3) = con*del2*(sinhm2-sinhms)
      cc(4) = con*del1*(sinhm1-sinhms)
      cc(7) = -con*(coshm2-sinhms)
      cc(8) = con*(coshm1-sinhms)
      cc(9) = (del2*(1.+sinhm2))/(dels*sinhs)
      cc(10) = (del1*(1.+sinhm1))/(dels*sinhs)
c
c interpolate in y direction
c
    4 call threet (cc,zj,yyj,zz,zy,zyy)
      call threet (cc,xj,xyyj,zx,zxy,dummy)
      zxx = cc(1)*xxj(1)+cc(2)*xxj(2)+cc(3)*xxyyj(1)+
     *      cc(4)*xxyyj(2)
      return
      end
      function surfi (xl,xu,yl,yu,m,n,x,y,z,iz,zp,t,sigma)
c
      integer m,n,iz
      real xl,xu,yl,yu,x(m),y(n),z(iz,n),zp(m,n,3),t(m,2),
     *     sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function integrates a surface specified by a spline
c under tension within a rectangle. the subroutine surf1
c should be called earlier to determine necessary
c parameters.
c
c on input--
c
c   xl and xu contain the upper and lower limits of inte-
c   gration in the x-direction, respectively. (xl need not
c   be less than or equal to xu, surfi (xl,xu,...) .eq.
c   -surfi (xu,xl,...) ).
c
c   yl and yu contain the upper and lower limits of inte-
c   gration in the y-direction, respectively. (yl need not
c   be less than or equal to yu, surfi (...,yl,yu,...) .eq.
c   -surfi (...,yu,yl,...) ).
c
c   m and n contain the number of grid lines in the x- and
c   y-directions, respectively, of the rectangular grid
c   which specified the surface.
c
c   x and y are arrays containing the x- and y-grid values,
c   respectively, each in increasing order.
c
c   z is a matrix containing the m * n functional values
c   corresponding to the grid values (i. e. z(i,j) is the
c   surface value at the point (x(i),y(j)) for i = 1,...,m
c   and j = 1,...,n).
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3*m*n locations stored with the
c   various surface derivative information determined by
c   surf1.
c
c   t is an array of at least 2 * m locations which is used
c   for scratch storage.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters m, n, x, y, z, iz, zp, and sigma should be
c input unaltered from the output of surf1.
c
c on output--
c
c   surfi contains the integral value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c denormalize tension factor in x direction
c
      sigmap = abs(sigma)*float(m-1)/(x(m)-x(1))
c
c determine actual upper and lower bounds for x integration
c
      xxl = xl
      xxu = xu
      ssign = 1.
      if (xl .lt. xu) go to 1
      xxl = xu
      xxu = xl
      ssign = -1.
      if (xl .gt. xu) go to 1
c
c return zero if xl .eq. xu
c
      surfi = 0.
      return
c
c search for proper x intervals
c
    1 ilm1 = intrvl (xxl,x,m)
      il = ilm1+1
      ium1 = intrvl (xxu,x,m)
      iu = ium1+1
      if (il .eq. iu) go to 8
c
c obtain coefficients from xxl to x(il)
c
      t(il,1) = 0.
      t(ilm1,1) = 0.
      t(il,2) = 0.
      t(ilm1,2) = 0.
      t(iu,1) = 0.
      t(ium1,1) = 0.
      t(iu,2) = 0.
      t(ium1,2) = 0.
      if (xxl .eq. x(il)) go to 3
      del1 = xxl-x(ilm1)
      del2 = x(il)-xxl
      dels = x(il)-x(ilm1)
      t1 = (del1+dels)*del2/(2.*dels)
      t2 = del2*del2/(2.*dels)
      t(il,1) = t1
      t(ilm1,1) = t2
      if (sigma .eq. 0.) go to 2
      call snhcsh (dummy,c1,sigmap*del1,2)
      call snhcsh (dummy,c2,sigmap*del2,2)
      call snhcsh (ss,cs,sigmap*dels,3)
      d = sigmap*sigmap*dels*(1.+ss)
      t(il,2) = (dels*dels*(cs-ss/2.)-del1*del1*(c1-ss/2.))
     *          /d
      t(ilm1,2) = del2*del2*(c2-ss/2.)/d
      go to 3
    2 t(il,2) = -t1*t1*dels/6.
      t(ilm1,2) = -t2*(del1*(del2+dels)+dels*dels)/12.
c
c obtain coefficients over interior x intervals
c
    3 if (iu-il .eq. 1) go to 6
      ilp1 = il+1
      do 5 i = ilp1,ium1
        dels = x(i)-x(i-1)
        t(i,1) = dels/2.
        t(i-1,1) = t(i-1,1)+dels/2.
        if (sigma .eq. 0.) go to 4
        call snhcsh (ss,cs,sigmap*dels,3)
        t(i,2) = dels*(cs-ss/2.)/(sigmap*sigmap*(1.+ss))
        t(i-1,2) = t(i-1,2)+t(i,2)
        go to 5
    4   t(i,2) = -dels*dels*dels/24.
        t(i-1,2) = t(i-1,2)+t(i,2)
    5   continue
c
c obtain coefficients from x(iu-1) to xxu
c
    6 if (xxu .eq. x(ium1)) go to 10
      del1 = xxu-x(ium1)
      del2 = x(iu)-xxu
      dels = x(iu)-x(ium1)
      t1 = del1*del1/(2.*dels)
      t2 = (del2+dels)*del1/(2.*dels)
      t(iu,1) = t1
      t(ium1,1) = t(ium1,1)+t2
      if (sigma .eq. 0.) go to 7
      call snhcsh (dummy,c1,sigmap*del1,2)
      call snhcsh (dummy,c2,sigmap*del2,2)
      call snhcsh (ss,cs,sigmap*dels,3)
      d = sigmap*sigmap*dels*(1.+ss)
      t(iu,2) = del1*del1*(c1-ss/2.)/d
      t(ium1,2) = t(ium1,2)+(dels*dels*(cs-ss/2.)-
     .            del2*del2*(c2-ss/2.))/d
      go to 10
    7 t(iu,2) = -t1*(del2*(del1+dels)+dels*dels)/12.
      t(ium1,2) = t(ium1,2)-t2*t2*dels/6.
      go to 10
c
c obtain coefficients from xxl to xxu
c
    8 delu1 = xxu-x(ium1)
      delu2 = x(iu)-xxu
      dell1 = xxl-x(ium1)
      dell2 = x(iu)-xxl
      dels = x(iu)-x(ium1)
      deli = xxu-xxl
      t1 = (delu1+dell1)*deli/(2.*dels)
      t2 = (delu2+dell2)*deli/(2.*dels)
      t(iu,1) = t1
      t(ium1,1) = t2
      if (sigma .eq. 0.) go to 9
      call snhcsh (dummy,cu1,sigmap*delu1,2)
      call snhcsh (dummy,cu2,sigmap*delu2,2)
      call snhcsh (dummy,cl1,sigmap*dell1,2)
      call snhcsh (dummy,cl2,sigmap*dell2,2)
      call snhcsh (ss,dummy,sigmap*dels,-1)
      d = sigmap*sigmap*dels*(1.+ss)
      t(iu,2) = (delu1*delu1*(cu1-ss/2.)-
     *           dell1*dell1*(cl1-ss/2.))/d
      t(ium1,2) = (dell2*dell2*(cl2-ss/2.)-
     *           delu2*delu2*(cu2-ss/2.))/d
      go to 10
    9 t(iu,2) = -t1*(delu2*(dels+delu1)+dell2*
     *           (dels+dell1))/12.
      t(ium1,2) = -t2*(dell1*(dels+dell2)+delu1*
     *              (dels+delu2))/12.
c
c denormalize tension factor in y direction
c
   10 sigmap = abs(sigma)*float(n-1)/(y(n)-y(1))
c
c determine actual upper and lower bounds for y integration
c
      yyl = yl
      yyu = yu
      if (yl .lt. yu) go to 11
      yyl = yu
      yyu = yl
      ssign = -ssign
      if (yl .gt. yu) go to 11
c
c return zero if yl .eq. yu
c
      surfi = 0.
      return
c
c search for proper y intervals
c
   11 jlm1 = intrvl (yyl,y,n)
      jl = jlm1+1
      jum1 = intrvl (yyu,y,n)
      ju = jum1+1
      if (jl .eq. ju) go to 21
c
c integrate from yyl to y(jl)
c
      sum = 0.
      if (yyl .eq. y(jl)) go to 14
      del1 = yyl-y(jlm1)
      del2 = y(jl)-yyl
      dels = y(jl)-y(jlm1)
      t1 = (del1+dels)*del2/(2.*dels)
      t2 = del2*del2/(2.*dels)
      zjl = 0.
      zjlm1 = 0.
      zyyjl = 0.
      zyyjl1 = 0.
      do 12 i = ilm1,iu
        zjl = zjl+t(i,1)*z(i,jl)+t(i,2)*zp(i,jl,2)
        zjlm1 = zjlm1+t(i,1)*z(i,jlm1)+t(i,2)*zp(i,jlm1,2)
        zyyjl = zyyjl+t(i,1)*zp(i,jl,1)+t(i,2)*zp(i,jl,3)
   12   zyyjl1 = zyyjl1+t(i,1)*zp(i,jlm1,1)+t(i,2)*
     *           zp(i,jlm1,3)
      sum = t1*zjl+t2*zjlm1
      if (sigma .eq. 0.) go to 13
      call snhcsh (dummy,c1,sigmap*del1,2)
      call snhcsh (dummy,c2,sigmap*del2,2)
      call snhcsh (ss,cs,sigmap*dels,3)
      sum = sum+((dels*dels*(cs-ss/2.)-del1*del1*(c1-ss/2.))
     *           *zyyjl+del2*del2*(c2-ss/2.)*zyyjl1)/
     *          (sigmap*sigmap*dels*(1.+ss))
      go to 14
   13 sum = sum-t1*t1*dels*zyyjl/6.
     *         -t2*(del1*(del2+dels)+dels*dels)*zyyjl1/12.
c
c integrate over interior y intervals
c
   14 if (ju-jl .eq. 1) go to 18
      jlp1 = jl+1
      do 17 j = jlp1,jum1
        dels = y(j)-y(j-1)
        zj = 0.
        zyyj = 0.
        do 15 i = ilm1,iu
          zj = zj+t(i,1)*(z(i,j)+z(i,j-1))+t(i,2)*
     *         (zp(i,j,2)+zp(i,j-1,2))
   15      zyyj = zyyj+t(i,1)*(zp(i,j,1)+zp(i,j-1,1))
     *            +t(i,2)*(zp(i,j,3)+zp(i,j-1,3))
        sum = sum+zj*dels/2.
        if (sigma .eq. 0.) go to 16
        call snhcsh (ss,cs,sigmap*dels,3)
        sum = sum+zyyj*dels*(cs-ss/2.)/
     *            (sigmap*sigmap*(1.+ss))
        go to 17
   16   sum = sum-zyyj*dels*dels*dels/24.
   17   continue
c
c integrate from y(ju-1) to yyu
c
   18 if (yyu .eq. y(jum1)) go to 24
      del1 = yyu-y(jum1)
      del2 = y(ju)-yyu
      dels = y(ju)-y(jum1)
      t1 = del1*del1/(2.*dels)
      t2 = (del2+dels)*del1/(2.*dels)
      zju = 0.
      zjum1 = 0.
      zyyju = 0.
      zyyju1 = 0.
      do 19 i = ilm1,iu
        zju = zju+t(i,1)*z(i,ju)+t(i,2)*zp(i,ju,2)
        zjum1 = zjum1+t(i,1)*z(i,jum1)+t(i,2)*zp(i,jum1,2)
        zyyju = zyyju+t(i,1)*zp(i,ju,1)+t(i,2)*zp(i,ju,3)
   19   zyyju1 = zyyju1+t(i,1)*zp(i,jum1,1)+t(i,2)*
     *           zp(i,jum1,3)
      sum = sum+t1*zju+t2*zjum1
      if (sigma .eq. 0.) go to 20
      call snhcsh (dummy,c1,sigmap*del1,2)
      call snhcsh (dummy,c2,sigmap*del2,2)
      call snhcsh (ss,cs,sigmap*dels,3)
      sum = sum+(zyyju*del1*del1*(c1-ss/2.)+zyyju1*
     *          (dels*dels*(cs-ss/2.)-del2*del2*(c2-ss/2.)))
     *         /(sigmap*sigmap*dels*(1.+ss))
      go to 24
   20 sum = sum-t1*(del2*(del1+dels)+dels*dels)*zyyju/12.
     *         -t2*t2*dels*zyyju1/6.
      go to 24
c
c integrate from yyl to yyu
c
   21 delu1 = yyu-y(jum1)
      delu2 = y(ju)-yyu
      dell1 = yyl-y(jum1)
      dell2 = y(ju)-yyl
      dels = y(ju)-y(jum1)
      deli = yyu-yyl
      t1 = (delu1+dell1)*deli/(2.*dels)
      t2 = (delu2+dell2)*deli/(2.*dels)
      zju = 0.
      zjum1 = 0.
      zyyju = 0.
      zyyju1 = 0.
      do 22 i = ilm1,iu
        zju = zju+t(i,1)*z(i,ju)+t(i,2)*zp(i,ju,2)
        zjum1 = zjum1+t(i,1)*z(i,jum1)+t(i,2)*zp(i,jum1,2)
        zyyju = zyyju+t(i,1)*zp(i,ju,1)+t(i,2)*zp(i,ju,3)
   22   zyyju1 = zyyju1+t(i,1)*zp(i,jum1,1)+t(i,2)*
     *           zp(i,jum1,3)
      sum = t1*zju+t2*zjum1
      if (sigma .eq. 0.) go to 23
      call snhcsh (dummy,cu1,sigmap*delu1,2)
      call snhcsh (dummy,cu2,sigmap*delu2,2)
      call snhcsh (dummy,cl1,sigmap*dell1,2)
      call snhcsh (dummy,cl2,sigmap*dell2,2)
      call snhcsh (ss,dummy,sigmap*dels,-1)
      sum = sum+(zyyju*(delu1*delu1*(cu1-ss/2.)
     *            -dell1*dell1*(cl1-ss/2.))
     *          +zyyju1*(dell2*dell2*(cl2-ss/2.)
     *            -delu2*delu2*(cu2-ss/2.)))/
     *          (sigmap*sigmap*dels*(1.+ss))
      go to 24
   23 sum = sum-t1*(delu2*(dels+delu1)+dell2*(dels+dell1))*
     *             zyyju/12.
     *         -t2*(dell1*(dels+dell2)+delu1*(dels+delu2))*
     *             zyyju1/12.
c
c correct sign and return
c
   24 surfi = ssign*sum
      return
      end
      subroutine bsurf2 (dxmin,dxmax,md,dymin,dymax,nd,dz,
     *                   idz,m,n,xmin,xmax,ymin,ymax,z,iz,
     *                   zp,work,sigma)
c
      integer md,nd,idz,m,n,iz
      real dxmin,dxmax,dymin,dymax,dz(idz,nd),xmin,xmax,
     *     ymin,ymax,z(iz,n),zp(m,n,3),work(4,md),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine maps values onto a surface at every point
c of a grid equally spaced in both x and y coordinates. the
c surface interpolation is performed using a bi-spline under
c tension. the subroutine bsurf1 should be called earlier to
c determine certain necessary parameters. in both bsurf1 and
c bsurf2, the original grid is assumed to be equally spaced
c in the x and y coordinates.
c
c on input--
c
c   dxmin and dxmax contain the lower and upper limits,
c   respectively, of the x-coordinates of the second grid.
c
c   md contains the number of grid lines in the x direction
c   of the second grid (md .ge. 1).
c
c   dymin and dymax contain the lower and upper limits,
c   respectively, of the y-coordinates of the second grid.
c
c   nd contains the number of grid lines in the y direction
c   of the second grid (nd .ge. 1).
c
c   idz contains the row dimension of the array dz as
c   declared in the calling program.
c
c   m and n contain the number of grid lines in the x- and
c   y-directions, respectively, of the rectangular grid
c   which specified the surface.
c
c   xmin and xmax are the lower and upper limits,
c   respectively, of the grid in the x direction.
c
c   ymin and ymax are the lower and upper limits,
c   respectively, of the grid in the y direction.
c
c   z is a matrix containing the m * n functional values
c   corresponding to the grid values (i. e. z(i,j) is the
c   surface value at the point (x(i),y(j)) for i = 1,...,m
c   and j = 1,...,n, where x(i) represents the i-th
c   equispaced x value and y(j) represents the j-th
c   equispaced y value).
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3*m*n locations stored with the
c   various surface derivative information determined by
c   surf1.
c
c   work is an array of 4*md locations to be used internally
c   for workspace.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters m, n, xmin, xmax, ymin, ymax, z, iz, zp,
c and sigma should be input unaltered from the output of
c bsurf1.
c
c on output--
c
c   dz contains the md by nd array of surface values
c   interpolated at the points of the second grid.
c
c none of the input parameters are altered.
c
c this function references package module snhcsh.
c
c-----------------------------------------------------------
c
c denormalize tension factor in x and y direction
c
      sigmax = abs(sigma)*float(m-1)/(xmax-xmin)
      sigmay = abs(sigma)*float(n-1)/(ymax-ymin)
c
c find intervals of second x grid with respect to original x
c grid
c
      deltdx = 0.
      if (md .ge. 2) deltdx = (dxmax-dxmin)/float(md-1)
      delx = (xmax-xmin)/float(m-1)
      if (sigmax .ne. 0.) call snhcsh (sinhms,dummy,
     *                                 sigmax*delx,-1)
      do 2 ii = 1,md
        xii = dxmin+float(ii-1)*deltdx
        i = 2+ifix((xii-xmin)/delx)
        if (i .lt. 2) i = 2
        if (i .gt. m) i = m
        del1 = xii-xmin-float(i-2)*delx
        del2 = delx-del1
        work(1,ii) = del2/delx
        work(2,ii) = del1/delx
        if (sigmax .ne. 0.) go to 1
        temp = -del1*del2/(6.*delx)
        work(3,ii) = temp*(del2+delx)
        work(4,ii) = temp*(del1+delx)
        go to 2
    1   call snhcsh (sinhm1,dummy,sigmax*del1,-1)
        call snhcsh (sinhm2,dummy,sigmax*del2,-1)
        temp = sigmax*sigmax*delx*(1.+sinhms)
        work(3,ii) = del2*(sinhm2-sinhms)/temp
        work(4,ii) = del1*(sinhm1-sinhms)/temp
    2   continue
c
c find intervals of second y grid with respect to original y
c grid and perform intrpolation
c
      deltdy = 0.
      if (nd .ge. 2) deltdy = (dymax-dymin)/float(nd-1)
      dely = (ymax-ymin)/float(n-1)
      if (sigmay .ne. 0.) call snhcsh (sinhms,dummy,
     *                                 sigmay*dely,-1)
      do 5 jj=1,nd
        yjj = dymin+float(jj-1)*deltdy
        j = 2+ifix((yjj-ymin)/dely)
        if (j .lt. 2) j = 2
        if (j .gt. n) j = n
        jm1 = j-1
        del1 = yjj-ymin-float(j-2)*dely
        del2 = dely-del1
        c1 = del2/dely
        c2 = del1/dely
        if (sigmay .ne. 0.) go to 3
        temp = -del1*del2/(6.*dely)
        c3 = temp*(del2+dely)
        c4 = temp*(del1+dely)
        go to 4
    3   call snhcsh (sinhm1,dummy,sigmay*del1,-1)
        call snhcsh (sinhm2,dummy,sigmay*del2,-1)
        temp = sigmay*sigmay*dely*(1.+sinhms)
        c3 = del2*(sinhm2-sinhms)/temp
        c4 = del1*(sinhm1-sinhms)/temp
    4   lasti = 0
        do 5 ii=1,md
          xii = dxmin+float(ii-1)*deltdx
          i = 2+ifix((xii-xmin)/delx)
          if (i .lt. 2) i = 2
          if (i .gt. m) i = m
          im1 = i-1
          if (im1 .eq. lasti) go to 5
          lasti = im1
          zim1 = c1*z(im1,jm1)+c2*z(im1,j)
     *           +c3*zp(im1,jm1,1)+c4*zp(im1,j,1)
          zi = c1*z(i,jm1)+c2*z(i,j)
     *         +c3*zp(i,jm1,1)+c4*zp(i,j,1)
          zxxim1 = c1*zp(im1,jm1,2)+c2*zp(im1,j,2)
     *             +c3*zp(im1,jm1,3)+c4*zp(im1,j,3)
          zxxi = c1*zp(i,jm1,2)+c2*zp(i,j,2)
     *           +c3*zp(i,jm1,3)+c4*zp(i,j,3)
    5     dz(ii,jj) = work(1,ii)*zim1+work(2,ii)*zi
     *                +work(3,ii)*zxxim1+work(4,ii)*zxxi
      return
      end
      subroutine xsurf2 (dxmin,dxmax,md,dymin,dymax,nd,dz,
     *                   idz,m,n,xmin,xmax,y,z,iz,zp,work,
     *                   sigma)
c
      integer md,nd,idz,m,n,iz
      real dxmin,dxmax,dymin,dymax,dz(idz,nd),xmin,xmax,
     *     y(n),z(iz,n),zp(m,n,3),work(4,md),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine maps values onto a surface at every point
c of a grid equally spaced in both x and y coordinates. the
c surface interpolation is performed using a bi-spline under
c tension. the subroutine xsurf1 should be called earlier to
c determine certain necessary parameters. in both xsurf1 and
c xsurf2, the original grid is assumed to be equally spaced
c in the x coordinate.
c
c on input--
c
c   dxmin and dxmax contain the lower and upper limits,
c   respectively, of the x-coordinates of the second grid.
c
c   md contains the number of grid lines in the x direction
c   of the second grid (md .ge. 1).
c
c   dymin and dymax contain the lower and upper limits,
c   respectively, of the y-coordinates of the second grid.
c
c   nd contains the number of grid lines in the y direction
c   of the second grid (nd .ge. 1).
c
c   idz contains the row dimension of the array dz as
c   declared in the calling program.
c
c   m and n contain the number of grid lines in the x- and
c   y-directions, respectively, of the rectangular grid
c   which specified the surface.
c
c   xmin and xmax are the lower and upper limits,
c   respectively, of the grid in the x direction.
c
c   y is an array containing the y grid values in increasing
c   order.
c
c   z is a matrix containing the m * n functional values
c   corresponding to the grid values (i. e. z(i,j) is the
c   surface value at the point (x(i),y(j)) for i = 1,...,m
c   and j = 1,...,n, where x(i) represents the i-th
c   equispaced x value).
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3*m*n locations stored with the
c   various surface derivative information determined by
c   surf1.
c
c   work is an array of 4*md locations to be used internally
c   for workspace.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters m, n, xmin, xmax, y, z, iz, zp, and sigma
c should be input unaltered from the output of xsurf1.
c
c on output--
c
c   dz contains the md by nd array of surface values
c   interpolated at the points of the second grid.
c
c none of the input parameters are altered.
c
c this function references package module snhcsh.
c
c-----------------------------------------------------------
c
c denormalize tension factor in x and y direction
c
      sigmax = abs(sigma)*float(m-1)/(xmax-xmin)
      sigmay = abs(sigma)*float(n-1)/(y(n)-y(1))
c
c find intervals of second x grid with respect to original x
c grid
c
      deltdx = 0.
      if (md .ge. 2) deltdx = (dxmax-dxmin)/float(md-1)
      delx = (xmax-xmin)/float(m-1)
      if (sigmax .ne. 0.) call snhcsh (sinhms,dummy,
     *                                 sigmax*delx,-1)
      do 2 ii = 1,md
        xii = dxmin+float(ii-1)*deltdx
        i = 2+ifix((xii-xmin)/delx)
        if (i .lt. 2) i = 2
        if (i .gt. m) i = m
        del1 = xii-xmin-float(i-2)*delx
        del2 = delx-del1
        work(1,ii) = del2/delx
        work(2,ii) = del1/delx
        if (sigmax .ne. 0.) go to 1
        temp = -del1*del2/(6.*delx)
        work(3,ii) = temp*(del2+delx)
        work(4,ii) = temp*(del1+delx)
        go to 2
    1   call snhcsh (sinhm1,dummy,sigmax*del1,-1)
        call snhcsh (sinhm2,dummy,sigmax*del2,-1)
        temp = sigmax*sigmax*delx*(1.+sinhms)
        work(3,ii) = del2*(sinhm2-sinhms)/temp
        work(4,ii) = del1*(sinhm1-sinhms)/temp
    2   continue
c
c find intervals of second y grid with respect to original y
c grid and perform intrpolation
c
      deltdy = 0.
      if (nd .ge. 2) deltdy = (dymax-dymin)/float(nd-1)
      lastj = 1
      do 6 jj=1,nd
        yjj = dymin+float(jj-1)*deltdy
        j = lastj
    3   j = j+1
        if (yjj .gt. y(j) .and. j .lt. n) go to 3
        jm1 = j-1
        lastj = jm1
        del1 = yjj-y(jm1)
        del2 = y(j)-yjj
        dels = y(j)-y(jm1)
        c1 = del2/dels
        c2 = del1/dels
        if (sigmay .ne. 0.) go to 4
        temp = -del1*del2/(6.*dels)
        c3 = temp*(del2+dels)
        c4 = temp*(del1+dels)
        go to 5
    4   call snhcsh (sinhm1,dummy,sigmay*del1,-1)
        call snhcsh (sinhm2,dummy,sigmay*del2,-1)
        call snhcsh (sinhms,dummy,sigmay*dels,-1)
        temp = sigmay*sigmay*dels*(1.+sinhms)
        c3 = del2*(sinhm2-sinhms)/temp
        c4 = del1*(sinhm1-sinhms)/temp
    5   lasti = 0
        do 6 ii=1,md
          xii = dxmin+float(ii-1)*deltdx
          i = 2+ifix((xii-xmin)/delx)
          if (i .lt. 2) i = 2
          if (i .gt. m) i = m
          im1 = i-1
          if (im1 .eq. lasti) go to 6
          lasti = im1
          zim1 = c1*z(im1,jm1)+c2*z(im1,j)
     *           +c3*zp(im1,jm1,1)+c4*zp(im1,j,1)
          zi = c1*z(i,jm1)+c2*z(i,j)
     *         +c3*zp(i,jm1,1)+c4*zp(i,j,1)
          zxxim1 = c1*zp(im1,jm1,2)+c2*zp(im1,j,2)
     *             +c3*zp(im1,jm1,3)+c4*zp(im1,j,3)
          zxxi = c1*zp(i,jm1,2)+c2*zp(i,j,2)
     *           +c3*zp(i,jm1,3)+c4*zp(i,j,3)
    6     dz(ii,jj) = work(1,ii)*zim1+work(2,ii)*zi
     *                +work(3,ii)*zxxim1+work(4,ii)*zxxi
      return
      end
      subroutine ysurf2 (dxmin,dxmax,md,dymin,dymax,nd,dz,
     *                   idz,m,n,x,ymin,ymax,z,iz,zp,work,
     *                   sigma)
c
      integer md,nd,idz,m,n,iz
      real dxmin,dxmax,dymin,dymax,dz(idz,nd),x(m),ymin,
     *     ymax,z(iz,n),zp(m,n,3),work(4,md),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine maps values onto a surface at every point
c of a grid equally spaced in both x and y coordinates. the
c surface interpolation is performed using a bi-spline under
c tension. the subroutine ysurf1 should be called earlier to
c determine certain necessary parameters. in both ysurf1 and
c ysurf2, the original grid is assumed to be equally spaced
c in the y coordinate.
c
c on input--
c
c   dxmin and dxmax contain the lower and upper limits,
c   respectively, of the x-coordinates of the second grid.
c
c   md contains the number of grid lines in the x direction
c   of the second grid (md .ge. 2).
c
c   dymin and dymax contain the lower and upper limits,
c   respectively, of the y-coordinates of the second grid.
c
c   nd contains the number of grid lines in the y direction
c   of the second grid (nd .ge. 2).
c
c   idz contains the row dimension of the array dz as
c   declared in the calling program.
c
c   m and n contain the number of grid lines in the x- and
c   y-directions, respectively, of the rectangular grid
c   which specified the surface.
c
c   x is an array containing the x grid values in increasing
c   order.
c
c   ymin and ymax are the lower and upper limits,
c   respectively, of the grid in the y direction.
c
c   z is a matrix containing the m * n functional values
c   corresponding to the grid values (i. e. z(i,j) is the
c   surface value at the point (x(i),y(j)) for i = 1,...,m
c   and j = 1,...,n, where y(j) represents the j-th
c   equispaced y value).
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3*m*n locations stored with the
c   various surface derivative information determined by
c   ysurf1.
c
c   work is an array of 4*md locations to be used internally
c   for workspace.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters m, n, x, ymin, ymax, z, iz, zp, and sigma
c should be input unaltered from the output of ysurf1.
c
c on output--
c
c   dz contains the md by nd array of surface values
c   interpolated at the points of the second grid.
c
c none of the input parameters are altered.
c
c this function references package module snhcsh.
c
c-----------------------------------------------------------
c
c denormalize tension factor in x and y direction
c
      sigmax = abs(sigma)*float(m-1)/(x(m)-x(1))
      sigmay = abs(sigma)*float(n-1)/(ymax-ymin)
c
c find intervals of second x grid with respect to original x
c grid
c
      deltdx = 0.
      if (md .ge. 2) deltdx = (dxmax-dxmin)/float(md-1)
      lasti = 1
      do 3 ii = 1,md
        xii = dxmin+float(ii-1)*deltdx
        i = lasti
    1   i = i+1
        if (xii .gt. x(i) .and. i .lt. m) go to 1
        im1 = i-1
        lasti = im1
        del1 = xii-x(im1)
        del2 = x(i)-xii
        dels = x(i)-x(im1)
        work(1,ii) = del2/dels
        work(2,ii) = del1/dels
        if (sigmax .ne. 0.) go to 2
        temp = -del1*del2/(6.*dels)
        work(3,ii) = temp*(del2+dels)
        work(4,ii) = temp*(del1+dels)
        go to 3
    2   call snhcsh (sinhm1,dummy,sigmax*del1,-1)
        call snhcsh (sinhm2,dummy,sigmax*del2,-1)
        call snhcsh (sinhms,dummy,sigmax*dels,-1)
        temp = sigmax*sigmax*dels*(1.+sinhms)
        work(3,ii) = del2*(sinhm2-sinhms)/temp
        work(4,ii) = del1*(sinhm1-sinhms)/temp
    3   continue
c
c find intervals of second y grid with respect to original y
c grid and perform intrpolation
c
      deltdy = 0.
      if (nd .ge. 2) deltdy = (dymax-dymin)/float(nd-1)
      dely = (ymax-ymin)/float(n-1)
      if (sigmay .ne. 0.) call snhcsh (sinhms,dummy,
     *                                 sigmay*dely,-1)
      do 7 jj=1,nd
        yjj = dymin+float(jj-1)*deltdy
        j = 2+ifix((yjj-ymin)/dely)
        if (j .lt. 2) j = 2
        if (j .gt. n) j = n
        jm1 = j-1
        del1 = yjj-ymin-float(j-2)*dely
        del2 = dely-del1
        c1 = del2/dely
        c2 = del1/dely
        if (sigmay .ne. 0.) go to 4
        temp = -del1*del2/(6.*dely)
        c3 = temp*(del2+dely)
        c4 = temp*(del1+dely)
        go to 5
    4   call snhcsh (sinhm1,dummy,sigmay*del1,-1)
        call snhcsh (sinhm2,dummy,sigmay*del2,-1)
        temp = sigmay*sigmay*dely*(1.+sinhms)
        c3 = del2*(sinhm2-sinhms)/temp
        c4 = del1*(sinhm1-sinhms)/temp
    5   lasti = 0
        do 7 ii=1,md
          xii = dxmin+float(ii-1)*deltdx
          i = max0 (1, lasti)
    6     i = i+1
          if (xii .gt. x(i) .and. i .lt. m) go to 6
          im1 = i-1
          if (im1 .eq. lasti) go to 7
          lasti = im1
          zim1 = c1*z(im1,jm1)+c2*z(im1,j)
     *           +c3*zp(im1,jm1,1)+c4*zp(im1,j,1)
          zi = c1*z(i,jm1)+c2*z(i,j)
     *         +c3*zp(i,jm1,1)+c4*zp(i,j,1)
          zxxim1 = c1*zp(im1,jm1,2)+c2*zp(im1,j,2)
     *             +c3*zp(im1,jm1,3)+c4*zp(im1,j,3)
          zxxi = c1*zp(i,jm1,2)+c2*zp(i,j,2)
     *           +c3*zp(i,jm1,3)+c4*zp(i,j,3)
    7     dz(ii,jj) = work(1,ii)*zim1+work(2,ii)*zi
     *                +work(3,ii)*zxxim1+work(4,ii)*zxxi
      return
      end
      subroutine nsurf2 (dxmin,dxmax,md,dymin,dymax,nd,dz,
     *                   idz,m,n,x,y,z,iz,zp,work,sigma)
c
      integer md,nd,idz,m,n,iz
      real dxmin,dxmax,dymin,dymax,dz(idz,nd),x(m),y(n),
     *     z(iz,n),zp(m,n,3),work(4,md),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine maps values onto a surface at every point
c of a grid equally spaced in both x and y coordinates. the
c surface interpolation is performed using a bi-spline
c under tension. the subroutine surf1 or nsurf1 should be
c called earlier to determine certain necessary parameters.
c
c on input--
c
c   dxmin and dxmax contain the lower and upper limits,
c   respectively, of the x-coordinates of the second grid.
c
c   md contains the number of grid lines in the x direction
c   of the second grid (md .ge. 1).
c
c   dymin and dymax contain the lower and upper limits,
c   respectively, of the y-coordinates of the second grid.
c
c   nd contains the number of grid lines in the y direction
c   of the second grid (nd .ge. 1).
c
c   idz contains the row dimension of the array dz as
c   declared in the calling program.
c
c   m and n contain the number of grid lines in the x- and
c   y-directions, respectively, of the rectangular grid
c   which specified the surface.
c
c   x and y are arrays containing the x- and y-grid values,
c   respectively, each in increasing order.
c
c   z is a matrix containing the m * n functional values
c   corresponding to the grid values (i. e. z(i,j) is the
c   surface value at the point (x(i),y(j)) for i = 1,...,m
c   and j = 1,...,n).
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3*m*n locations stored with the
c   various surface derivative information determined by
c   surf1.
c
c   work is an array of 4*md locations to be used internally
c   for workspace.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters m, n, x, y, z, iz, zp, and sigma should be
c input unaltered from the output of surf1 or nsurf1.
c
c on output--
c
c   dz contains the md by nd array of surface values
c   interpolated at the points of the second grid.
c
c none of the input parameters are altered.
c
c this function references package module snhcsh.
c
c-----------------------------------------------------------
c
c denormalize tension factor in x and y direction
c
      sigmax = abs(sigma)*float(m-1)/(x(m)-x(1))
      sigmay = abs(sigma)*float(n-1)/(y(n)-y(1))
c
c find intervals of second x grid with respect to original x
c grid
c
      deltdx = 0.
      if (md .ge. 2) deltdx = (dxmax-dxmin)/float(md-1)
      lasti = 1
      do 3 ii = 1,md
        xii = dxmin+float(ii-1)*deltdx
        i = lasti
    1   i = i+1
        if (xii .gt. x(i) .and. i .lt. m) go to 1
        im1 = i-1
        lasti = im1
        del1 = xii-x(im1)
        del2 = x(i)-xii
        dels = x(i)-x(im1)
        work(1,ii) = del2/dels
        work(2,ii) = del1/dels
        if (sigmax .ne. 0.) go to 2
        temp = -del1*del2/(6.*dels)
        work(3,ii) = temp*(del2+dels)
        work(4,ii) = temp*(del1+dels)
        go to 3
    2   call snhcsh (sinhm1,dummy,sigmax*del1,-1)
        call snhcsh (sinhm2,dummy,sigmax*del2,-1)
        call snhcsh (sinhms,dummy,sigmax*dels,-1)
        temp = sigmax*sigmax*dels*(1.+sinhms)
        work(3,ii) = del2*(sinhm2-sinhms)/temp
        work(4,ii) = del1*(sinhm1-sinhms)/temp
    3   continue
c
c find intervals of second y grid with respect to original y
c grid and perform intrpolation
c
      deltdy = 0.
      if (nd .ge. 2) deltdy = (dymax-dymin)/float(nd-1)
      lastj = 1
      do 8 jj=1,nd
        yjj = dymin+float(jj-1)*deltdy
        j = lastj
    4   j = j+1
        if (yjj .gt. y(j) .and. j .lt. n) go to 4
        jm1 = j-1
        lastj = jm1
        del1 = yjj-y(jm1)
        del2 = y(j)-yjj
        dels = y(j)-y(jm1)
        c1 = del2/dels
        c2 = del1/dels
        if (sigmay .ne. 0.) go to 5
        temp = -del1*del2/(6.*dels)
        c3 = temp*(del2+dels)
        c4 = temp*(del1+dels)
        go to 6
    5   call snhcsh (sinhm1,dummy,sigmay*del1,-1)
        call snhcsh (sinhm2,dummy,sigmay*del2,-1)
        call snhcsh (sinhms,dummy,sigmay*dels,-1)
        temp = sigmay*sigmay*dels*(1.+sinhms)
        c3 = del2*(sinhm2-sinhms)/temp
        c4 = del1*(sinhm1-sinhms)/temp
    6   lasti = 0
        do 8 ii=1,md
          xii = dxmin+float(ii-1)*deltdx
          i = max0 (1, lasti)
    7     i = i+1
          if (xii .gt. x(i) .and. i .lt. m) go to 7
          im1 = i-1
          if (im1 .eq. lasti) go to 8
          lasti = im1
          zim1 = c1*z(im1,jm1)+c2*z(im1,j)
     *           +c3*zp(im1,jm1,1)+c4*zp(im1,j,1)
          zi = c1*z(i,jm1)+c2*z(i,j)
     *         +c3*zp(i,jm1,1)+c4*zp(i,j,1)
          zxxim1 = c1*zp(im1,jm1,2)+c2*zp(im1,j,2)
     *             +c3*zp(im1,jm1,3)+c4*zp(im1,j,3)
          zxxi = c1*zp(i,jm1,2)+c2*zp(i,j,2)
     *           +c3*zp(i,jm1,3)+c4*zp(i,j,3)
    8     dz(ii,jj) = work(1,ii)*zim1+work(2,ii)*zi
     *                +work(3,ii)*zxxim1+work(4,ii)*zxxi
      return
      end
      subroutine bsurf3 (dxmin,dxmax,md,dymin,dymax,nd,dzt,
     *                   m,n,xmin,xmax,ymin,ymax,z,iz,zp,
     *                   work,sigma,linout)
c
      integer md,nd,m,n,iz
      real dxmin,dxmax,dymin,dymax,dzt(md),xmin,xmax,ymin,
     *     ymax,z(iz,n),zp(m,n,3),work(4,md),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine maps values onto a surface at every point
c of a grid equally spaced in both x and y coordinates. the
c surface interpolation is performed using a bi-spline under
c tension. the subroutine bsurf1 should be called earlier to
c determine certain necessary parameters. in both bsurf1 and
c bsurf3, the original grid is assumed to be equally spaced
c in the x and y coordinates. the surface values along
c horizontal lines are output one by one (starting with the
c line with largest y-coordinate) by calling a user provided
c subroutine.
c
c on input--
c
c   dxmin and dxmax contain the lower and upper limits,
c   respectively, of the x-coordinates of the second grid.
c
c   md contains the number of grid lines in the x direction
c   of the second grid (md .ge. 1).
c
c   dymin and dymax contain the lower and upper limits,
c   respectively, of the y-coordinates of the second grid.
c
c   nd contains the number of grid lines in the y direction
c   of the second grid (nd .ge. 1).
c
c   dzt is an array of at least md locations.
c
c   m and n contain the number of grid lines in the x- and
c   y-directions, respectively, of the rectangular grid
c   which specified the surface.
c
c   xmin and xmax are the lower and upper limits,
c   respectively, of the grid in the x direction.
c
c   ymin and ymax are the lower and upper limits,
c   respectively, of the grid in the y direction.
c
c   z is a matrix containing the m * n functional values
c   corresponding to the grid values (i. e. z(i,j) is the
c   surface value at the point (x(i),y(j)) for i = 1,...,m
c   and j = 1,...,n, where x(i) represents the i-th
c   equispaced x value and y(j) represents the j-th
c   equispaced y value).
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3*m*n locations stored with the
c   various surface derivative information determined by
c   surf1.
c
c   work is an array of 4*md locations to be used internally
c   for workspace.
c
c   sigma contains the tension factor (its sign is ignored).
c
c and
c
c   linout is the name of a user provided subroutine with
c   parameters dzt and md which accepts a vector dzt of md
c   surface values along a horizontal line. the routine is
c   called nd times by nsurf3, once for each horizontal line
c   moving from dymax to dymin. the subroutine linout should
c   be declared external in the calling program.
c
c the parameters m, n, xmin, xmax, ymin, ymax, z, iz, zp,
c and sigma should be input unaltered from the output of
c bsurf1.
c
c none of the input parameters are altered.
c
c this function references package module snhcsh.
c
c-----------------------------------------------------------
c
c dnormalize tension factor in x and y direction
c
      sigmax = abs(sigma)*float(m-1)/(xmax-xmin)
      sigmay = abs(sigma)*float(n-1)/(ymax-ymin)
c
c find intervals of second x grid with respect to original x
c grid
c
      deltdx = 0.
      if (md .ge. 2) deltdx = (dxmax-dxmin)/float(md-1)
      delx = (xmax-xmin)/float(m-1)
      if (sigmax .ne. 0.) call snhcsh (sinhms,dummy,
     *                                 sigmax*delx,-1)
      do 2 ii = 1,md
        xii = dxmin+float(ii-1)*deltdx
        i = 2+ifix((xii-xmin)/delx)
        if (i .lt. 2) i = 2
        if (i .gt. m) i = m
        del1 = xii-xmin-float(i-2)*delx
        del2 = delx-del1
        work(1,ii) = del2/delx
        work(2,ii) = del1/delx
        if (sigmax .ne. 0.) go to 1
        temp = -del1*del2/(6.*delx)
        work(3,ii) = temp*(del2+delx)
        work(4,ii) = temp*(del1+delx)
        go to 2
    1   call snhcsh (sinhm1,dummy,sigmax*del1,-1)
        call snhcsh (sinhm2,dummy,sigmax*del2,-1)
        temp = sigmax*sigmax*delx*(1.+sinhms)
        work(3,ii) = del2*(sinhm2-sinhms)/temp
        work(4,ii) = del1*(sinhm1-sinhms)/temp
    2   continue
c
c find intervals of second y grid with respect to original y
c grid and perform intrpolation
c
      deltdy = 0.
      if (nd .ge. 2) deltdy = (dymax-dymin)/float(nd-1)
      dely = (ymax-ymin)/float(n-1)
      if (sigmay .ne. 0.) call snhcsh (sinhms,dummy,
     *                                 sigmay*dely,-1)
      do 6 jj=1,nd
        yjj = dymin+float(nd-jj)*deltdy
        j = 2+ifix((yjj-ymin)/dely)
        if (j .lt. 2) j = 2
        if (j .gt. n) j = n
        jm1 = j-1
        del1 = yjj-ymin-float(j-2)*dely
        del2 = dely-del1
        c1 = del2/dely
        c2 = del1/dely
        if (sigmay .ne. 0.) go to 3
        temp = -del1*del2/(6.*dely)
        c3 = temp*(del2+dely)
        c4 = temp*(del1+dely)
        go to 4
    3   call snhcsh (sinhm1,dummy,sigmay*del1,-1)
        call snhcsh (sinhm2,dummy,sigmay*del2,-1)
        temp = sigmay*sigmay*dely*(1.+sinhms)
        c3 = del2*(sinhm2-sinhms)/temp
        c4 = del1*(sinhm1-sinhms)/temp
    4   lasti = 0
        do 5 ii=1,md
          xii = dxmin+float(ii-1)*deltdx
          i = 2+ifix((xii-xmin)/delx)
          if (i .lt. 2) i = 2
          if (i .gt. m) i = m
          im1 = i-1
          if (im1 .eq. lasti) go to 5
          lasti = im1
          zim1 = c1*z(im1,jm1)+c2*z(im1,j)
     *           +c3*zp(im1,jm1,1)+c4*zp(im1,j,1)
          zi = c1*z(i,jm1)+c2*z(i,j)
     *         +c3*zp(i,jm1,1)+c4*zp(i,j,1)
          zxxim1 = c1*zp(im1,jm1,2)+c2*zp(im1,j,2)
     *             +c3*zp(im1,jm1,3)+c4*zp(im1,j,3)
          zxxi = c1*zp(i,jm1,2)+c2*zp(i,j,2)
     *           +c3*zp(i,jm1,3)+c4*zp(i,j,3)
    5     dzt(ii) = work(1,ii)*zim1+work(2,ii)*zi
     *                +work(3,ii)*zxxim1+work(4,ii)*zxxi
c
c output row jj
c
    6   call linout (dzt,md)
      return
      end
      subroutine xsurf3 (dxmin,dxmax,md,dymin,dymax,nd,dzt,
     *                   m,n,xmin,xmax,y,z,iz,zp,work,
     *                   sigma,linout)
c
      integer md,nd,m,n,iz
      real dxmin,dxmax,dymin,dymax,dzt(md),xmin,xmax,y(n),
     *     z(iz,n),zp(m,n,3),work(4,md),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine maps values onto a surface at every point
c of a grid equally spaced in both x and y coordinates. the
c surface interpolation is performed using a bi-spline under
c tension. the subroutine xsurf1 should be called earlier to
c determine certain necessary parameters. in both xsurf1 and
c xsurf3, the original grid is assumed to be equally spaced
c in the x coordinate. the surface values along horizontal
c lines are output one by one (starting with the line with
c the largest y-coordinate) by calling a user provided
c subroutine.
c
c on input--
c
c   dxmin and dxmax contain the lower and upper limits,
c   respectively, of the x-coordinates of the second grid.
c
c   md contains the number of grid lines in the x direction
c   of the second grid (md .ge. 1).
c
c   dymin and dymax contain the lower and upper limits,
c   respectively, of the y-coordinates of the second grid.
c
c   nd contains the number of grid lines in the y direction
c   of the second grid (nd .ge. 1).
c
c   dzt is an array of at least md locations.
c
c   m and n contain the number of grid lines in the x- and
c   y-directions, respectively, of the rectangular grid
c   which specified the surface.
c
c   xmin and xmax are the lower and upper limits,
c   respectively, of the grid in the x direction.
c
c   y is an array containing the y grid values in increasing
c   order.
c
c   z is a matrix containing the m * n functional values
c   corresponding to the grid values (i. e. z(i,j) is the
c   surface value at the point (x(i),y(j)) for i = 1,...,m
c   and j = 1,...,n, where x(i) represents the i-th
c   equispaced x value).
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3*m*n locations stored with the
c   various surface derivative information determined by
c   surf1.
c
c   work is an array of 4*md locations to be used internally
c   for workspace.
c
c   sigma contains the tension factor (its sign is ignored).
c
c and
c the surface values along horizontal lines are output one
c by one (starting with the line with largest y-coordinate)
c by calling a user provided subroutine.
c
c the parameters m, n, xmin, xmax, y, z, iz, zp, and sigma
c should be input unaltered from the output of xsurf1.
c
c on output--
c
c
c none of the input parameters are altered.
c this function references package module snhcsh.
c
c-----------------------------------------------------------
c
c dnormalize tension factor in x and y direction
c
      sigmax = abs(sigma)*float(m-1)/(xmax-xmin)
      sigmay = abs(sigma)*float(n-1)/(y(n)-y(1))
c
c find intervals of second x grid with respect to original x
c grid
c
      deltdx = 0.
      if (md .ge. 2) deltdx = (dxmax-dxmin)/float(md-1)
      delx = (xmax-xmin)/float(m-1)
      if (sigmax .ne. 0.) call snhcsh (sinhms,dummy,
     *                                 sigmax*delx,-1)
      do 2 ii = 1,md
        xii = dxmin+float(ii-1)*deltdx
        i = 2+ifix((xii-xmin)/delx)
        if (i .lt. 2) i = 2
        if (i .gt. m) i = m
        del1 = xii-xmin-float(i-2)*delx
        del2 = delx-del1
        work(1,ii) = del2/delx
        work(2,ii) = del1/delx
        if (sigmax .ne. 0.) go to 1
        temp = -del1*del2/(6.*delx)
        work(3,ii) = temp*(del2+delx)
        work(4,ii) = temp*(del1+delx)
        go to 2
    1   call snhcsh (sinhm1,dummy,sigmax*del1,-1)
        call snhcsh (sinhm2,dummy,sigmax*del2,-1)
        temp = sigmax*sigmax*delx*(1.+sinhms)
        work(3,ii) = del2*(sinhm2-sinhms)/temp
        work(4,ii) = del1*(sinhm1-sinhms)/temp
    2   continue
c
c find intervals of second y grid with respect to original y
c grid and perform intrpolation
c
      deltdy = 0.
      if (nd .ge. 2) deltdy = (dymax-dymin)/float(nd-1)
      lastj = n
      do 7 jj=1,nd
        yjj = dymin+float(nd-jj)*deltdy
        j = lastj+1
    3   j = j-1
        if (yjj .lt. y(j-1) .and. j .gt. 2) go to 3
        jm1 = j-1
        lastj = j
        del1 = yjj-y(jm1)
        del2 = y(j)-yjj
        dels = y(j)-y(jm1)
        c1 = del2/dels
        c2 = del1/dels
        if (sigmay .ne. 0.) go to 4
        temp = -del1*del2/(6.*dels)
        c3 = temp*(del2+dels)
        c4 = temp*(del1+dels)
        go to 5
    4   call snhcsh (sinhm1,dummy,sigmay*del1,-1)
        call snhcsh (sinhm2,dummy,sigmay*del2,-1)
        call snhcsh (sinhms,dummy,sigmay*dels,-1)
        temp = sigmay*sigmay*dels*(1.+sinhms)
        c3 = del2*(sinhm2-sinhms)/temp
        c4 = del1*(sinhm1-sinhms)/temp
    5   lasti = 0
        do 6 ii=1,md
          xii = dxmin+float(ii-1)*deltdx
          i = 2+ifix((xii-xmin)/delx)
          if (i .lt. 2) i = 2
          if (i .gt. m) i = m
          im1 = i-1
          if (im1 .eq. lasti) go to 6
          lasti = im1
          zim1 = c1*z(im1,jm1)+c2*z(im1,j)
     *           +c3*zp(im1,jm1,1)+c4*zp(im1,j,1)
          zi = c1*z(i,jm1)+c2*z(i,j)
     *         +c3*zp(i,jm1,1)+c4*zp(i,j,1)
          zxxim1 = c1*zp(im1,jm1,2)+c2*zp(im1,j,2)
     *             +c3*zp(im1,jm1,3)+c4*zp(im1,j,3)
          zxxi = c1*zp(i,jm1,2)+c2*zp(i,j,2)
     *           +c3*zp(i,jm1,3)+c4*zp(i,j,3)
    6     dzt(ii) = work(1,ii)*zim1+work(2,ii)*zi
     *                +work(3,ii)*zxxim1+work(4,ii)*zxxi
c
c output line jj
c
    7   call linout (dzt,md)
      return
      end
      subroutine ysurf3 (dxmin,dxmax,md,dymin,dymax,nd,dzt,
     *                   m,n,x,ymin,ymax,z,iz,zp,work,sigma,
     *                   linout)
c
      integer md,nd,m,n,iz
      real dxmin,dxmax,dymin,dymax,dzt(md),x(m),ymin,
     *     ymax,z(iz,n),zp(m,n,3),work(4,md),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine maps values onto a surface at every point
c of a grid equally spaced in both x and y coordinates. the
c surface interpolation is performed using a bi-spline under
c tension. the subroutine ysurf1 should be called earlier to
c determine certain necessary parameters. in both ysurf1 and
c ysurf3, the original grid is assumed to be equally spaced
c in the y coordinate. the surface values along horizontal
c lines are output one by one (starting with the line with
c the largest y-coordinate) by calling a user provided
c subroutine.
c
c on input--
c
c   dxmin and dxmax contain the lower and upper limits,
c   respectively, of the x-coordinates of the second grid.
c
c   md contains the number of grid lines in the x direction
c   of the second grid (md .ge. 2).
c
c   dymin and dymax contain the lower and upper limits,
c   respectively, of the y-coordinates of the second grid.
c
c   nd contains the number of grid lines in the y direction
c   of the second grid (nd .ge. 2).
c
c   dzt is an array of at least md locations.
c
c   m and n contain the number of grid lines in the x- and
c   y-directions, respectively, of the rectangular grid
c   which specified the surface.
c
c   x is an array containing the x grid values in increasing
c   order.
c
c   ymin and ymax are the lower and upper limits,
c   respectively, of the grid in the y direction.
c
c   z is a matrix containing the m * n functional values
c   corresponding to the grid values (i. e. z(i,j) is the
c   surface value at the point (x(i),y(j)) for i = 1,...,m
c   and j = 1,...,n, where y(j) represents the j-th
c   equispaced y value).
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3*m*n locations stored with the
c   various surface derivative information determined by
c   ysurf1.
c
c   work is an array of 4*md locations to be used internally
c   for workspace.
c
c   sigma contains the tension factor (its sign is ignored).
c
c and
c
c   linout is the name of a user provided subroutine with
c   parameters dzt and md which accepts a vector dzt of md
c   surface values along a horizontal line. the routine is
c   called nd times by nsurf3, once for each horizontal line
c   moving from dymax to dymin. the subroutine linout should
c   be declared external in the calling program.
c
c the parameters m, n, x, ymin, ymax, z, iz, zp, and sigma
c should be input unaltered from the output of ysurf1.
c
c none of the input parameters are altered.
c
c this function references package module snhcsh.
c
c-----------------------------------------------------------
c
c dnormalize tension factor in x and y direction
c
      sigmax = abs(sigma)*float(m-1)/(x(m)-x(1))
      sigmay = abs(sigma)*float(n-1)/(ymax-ymin)
c
c find intervals of second x grid with respect to original x
c grid
c
      deltdx = 0.
      if (md .ge. 2) deltdx = (dxmax-dxmin)/float(md-1)
      lasti = 1
      do 3 ii = 1,md
        xii = dxmin+float(ii-1)*deltdx
        i = lasti
    1   i = i+1
        if (xii .gt. x(i) .and. i .lt. m) go to 1
        im1 = i-1
        lasti = im1
        del1 = xii-x(im1)
        del2 = x(i)-xii
        dels = x(i)-x(im1)
        work(1,ii) = del2/dels
        work(2,ii) = del1/dels
        if (sigmax .ne. 0.) go to 2
        temp = -del1*del2/(6.*dels)
        work(3,ii) = temp*(del2+dels)
        work(4,ii) = temp*(del1+dels)
        go to 3
    2   call snhcsh (sinhm1,dummy,sigmax*del1,-1)
        call snhcsh (sinhm2,dummy,sigmax*del2,-1)
        call snhcsh (sinhms,dummy,sigmax*dels,-1)
        temp = sigmax*sigmax*dels*(1.+sinhms)
        work(3,ii) = del2*(sinhm2-sinhms)/temp
        work(4,ii) = del1*(sinhm1-sinhms)/temp
    3   continue
c
c find intervals of second y grid with respect to original y
c grid and perform intrpolation
c
      deltdy = 0.
      if (nd .ge. 2) deltdy = (dymax-dymin)/float(nd-1)
      dely = (ymax-ymin)/float(n-1)
      if (sigmay .ne. 0.) call snhcsh (sinhms,dummy,
     *                                 sigmay*dely,-1)
      do 8 jj=1,nd
        yjj = dymin+float(nd-jj)*deltdy
        j = 2+ifix((yjj-ymin)/dely)
        if (j .lt. 2) j = 2
        if (j .gt. n) j = n
        jm1 = j-1
        del1 = yjj-ymin-float(j-2)*dely
        del2 = dely-del1
        c1 = del2/dely
        c2 = del1/dely
        if (sigmay .ne. 0.) go to 4
        temp = -del1*del2/(6.*dely)
        c3 = temp*(del2+dely)
        c4 = temp*(del1+dely)
        go to 5
    4   call snhcsh (sinhm1,dummy,sigmay*del1,-1)
        call snhcsh (sinhm2,dummy,sigmay*del2,-1)
        temp = sigmay*sigmay*dely*(1.+sinhms)
        c3 = del2*(sinhm2-sinhms)/temp
        c4 = del1*(sinhm1-sinhms)/temp
    5   lasti = 0
        do 7 ii=1,md
          xii = dxmin+float(ii-1)*deltdx
          i = max0 (1, lasti)
    6     i = i+1
          if (xii .gt. x(i) .and. i .lt. m) go to 6
          im1 = i-1
          if (im1 .eq. lasti) go to 7
          lasti = im1
          zim1 = c1*z(im1,jm1)+c2*z(im1,j)
     *           +c3*zp(im1,jm1,1)+c4*zp(im1,j,1)
          zi = c1*z(i,jm1)+c2*z(i,j)
     *         +c3*zp(i,jm1,1)+c4*zp(i,j,1)
          zxxim1 = c1*zp(im1,jm1,2)+c2*zp(im1,j,2)
     *             +c3*zp(im1,jm1,3)+c4*zp(im1,j,3)
          zxxi = c1*zp(i,jm1,2)+c2*zp(i,j,2)
     *           +c3*zp(i,jm1,3)+c4*zp(i,j,3)
    7     dzt(ii) = work(1,ii)*zim1+work(2,ii)*zi
     *                +work(3,ii)*zxxim1+work(4,ii)*zxxi
c
c output line jj
c
    8   call linout (dzt,md)
      return
      end
      subroutine nsurf3 (dxmin,dxmax,md,dymin,dymax,nd,dzt,
     *                   m,n,x,y,z,iz,zp,work,sigma,linout)
c
      integer md,nd,m,n,iz
      real dxmin,dxmax,dymin,dymax,dzt(md),x(m),y(n),
     *     z(iz,n),zp(m,n,3),work(4,md),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine maps values onto a surface at every point
c of a grid equally spaced in both x and y coordinates. the
c surface interpolation is performed using a bi-spline
c under tension. the subroutine surf1 or nsurf1 should be
c called earlier to determine certain necessary parameters.
c the surface values along horizontal lines are output one
c by one (starting with the line with largest y-coordinate)
c by calling a user provided subroutine.
c
c on input--
c
c   dxmin and dxmax contain the lower and upper limits,
c   respectively, of the x-coordinates of the second grid.
c
c   md contains the number of grid lines in the x direction
c   of the second grid (md .ge. 1).
c
c   dymin and dymax contain the lower and upper limits,
c   respectively, of the y-coordinates of the second grid.
c
c   nd contains the number of grid lines in the y direction
c   of the second grid (nd .ge. 1).
c
c   dzt is an array of at least md locations.
c
c   m and n contain the number of grid lines in the x- and
c   y-directions, respectively, of the rectangular grid
c   which specified the surface.
c
c   x and y are arrays containing the x- and y-grid values,
c   respectively, each in increasing order.
c
c   z is a matrix containing the m * n functional values
c   corresponding to the grid values (i. e. z(i,j) is the
c   surface value at the point (x(i),y(j)) for i = 1,...,m
c   and j = 1,...,n).
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3*m*n locations stored with the
c   various surface derivative information determined by
c   surf1.
c
c   work is an array of 4*md locations to be used internally
c   for workspace.
c
c   sigma contains the tension factor (its sign is ignored).
c
c and
c
c   linout is the name of a user provided subroutine with
c   parameters dzt and md which accepts a vector dzt of md
c   surface values along a horizontal line. the routine is
c   called nd times by nsurf3, once for each horizontal line
c   moving from dymax to dymin. the subroutine linout should
c   be declared external in the calling program.
c
c the parameters m, n, x, y, z, iz, zp, and sigma should be
c input unaltered from the output of surf1 or nsurf1.
c
c none of the input parameters are altered.
c
c this function references package module snhcsh.
c
c-----------------------------------------------------------
c
c dnormalize tension factor in x and y direction
c
      sigmax = abs(sigma)*float(m-1)/(x(m)-x(1))
      sigmay = abs(sigma)*float(n-1)/(y(n)-y(1))
c
c find intervals of second x grid with respect to original x
c grid
c
      deltdx = 0.
      if (md .ge. 2) deltdx = (dxmax-dxmin)/float(md-1)
      lasti = 1
      do 3 ii = 1,md
        xii = dxmin+float(ii-1)*deltdx
        i = lasti
    1   i = i+1
        if (xii .gt. x(i) .and. i .lt. m) go to 1
        im1 = i-1
        lasti = im1
        del1 = xii-x(im1)
        del2 = x(i)-xii
        dels = x(i)-x(im1)
        work(1,ii) = del2/dels
        work(2,ii) = del1/dels
        if (sigmax .ne. 0.) go to 2
        temp = -del1*del2/(6.*dels)
        work(3,ii) = temp*(del2+dels)
        work(4,ii) = temp*(del1+dels)
        go to 3
    2   call snhcsh (sinhm1,dummy,sigmax*del1,-1)
        call snhcsh (sinhm2,dummy,sigmax*del2,-1)
        call snhcsh (sinhms,dummy,sigmax*dels,-1)
        temp = sigmax*sigmax*dels*(1.+sinhms)
        work(3,ii) = del2*(sinhm2-sinhms)/temp
        work(4,ii) = del1*(sinhm1-sinhms)/temp
    3   continue
c
c find intervals of second y grid with respect to original y
c grid and perform intrpolation
c
      deltdy = 0.
      if (nd .ge. 2) deltdy = (dymax-dymin)/float(nd-1)
      lastj = n
      do 9 jj=1,nd
        yjj = dymin+float(nd-jj)*deltdy
        j = lastj+1
    4   j = j-1
        if (yjj .lt. y(j-1) .and. j .gt. 2) go to 4
        jm1 = j-1
        lastj = j
        del1 = yjj-y(jm1)
        del2 = y(j)-yjj
        dels = y(j)-y(jm1)
        c1 = del2/dels
        c2 = del1/dels
        if (sigmay .ne. 0.) go to 5
        temp = -del1*del2/(6.*dels)
        c3 = temp*(del2+dels)
        c4 = temp*(del1+dels)
        go to 6
    5   call snhcsh (sinhm1,dummy,sigmay*del1,-1)
        call snhcsh (sinhm2,dummy,sigmay*del2,-1)
        call snhcsh (sinhms,dummy,sigmay*dels,-1)
        temp = sigmay*sigmay*dels*(1.+sinhms)
        c3 = del2*(sinhm2-sinhms)/temp
        c4 = del1*(sinhm1-sinhms)/temp
    6   lasti = 0
        do 8 ii=1,md
          xii = dxmin+float(ii-1)*deltdx
          i = max0 (1, lasti)
    7     i = i+1
          if (xii .gt. x(i) .and. i .lt. m) go to 7
          im1 = i-1
          if (im1 .eq. lasti) go to 8
          lasti = im1
          zim1 = c1*z(im1,jm1)+c2*z(im1,j)
     *           +c3*zp(im1,jm1,1)+c4*zp(im1,j,1)
          zi = c1*z(i,jm1)+c2*z(i,j)
     *         +c3*zp(i,jm1,1)+c4*zp(i,j,1)
          zxxim1 = c1*zp(im1,jm1,2)+c2*zp(im1,j,2)
     *             +c3*zp(im1,jm1,3)+c4*zp(im1,j,3)
          zxxi = c1*zp(i,jm1,2)+c2*zp(i,j,2)
     *           +c3*zp(i,jm1,3)+c4*zp(i,j,3)
    8     dzt(ii) = work(1,ii)*zim1+work(2,ii)*zi
     *                +work(3,ii)*zxxim1+work(4,ii)*zxxi
c
c output line jj
c
    9   call linout (dzt,md)
      return
      end
      subroutine surfb1 (nx,ny,x,y,w,nw1,c,vx,vy,temp,sigma,
     *                   ierr)
c
      integer nx,ny,nw1,ierr
      real x(nx),y(ny),w(nw1,ny),c(nx,ny),vx(5,nx),vy(5,ny),
     *     temp(1),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory function on a two dimensional
c rectangular grid. the function determined can be
c represented as a tensor product of splines under tension
c for actual mapping of points it is necessary to call the
c subroutine surfbd, which also returns first and second
c partial derivatives.
c
c on input--
c
c   nx and ny are the number of grid lines in the x- and y
c   directions, respectively, of the rectangular grid. (nx
c   and ny should be at least 2.)
c
c   x and y are arrays of the nx and ny coordinates of the
c   grid lines in x- and y-directions, respectively. these
c   should be strictly increasing.
c
c   w is an array of the nx * ny functional values at the
c   the grid points, i. e. w(i,j) contains the functional
c   value at (x(i),y(j)) for i = 1,...,nx, and j = 1,...,ny.
c
c   nw1 is the first dimension of the array w used in the
c   calling program (nw1 .ge. nx).
c
c   c is an array of at least nx * ny locations. this
c   parameter may coincide with w in which case w is
c   destroyed on output.
c
c   vx and vy are arrays of at least 5 * nx and 5 * ny
c   locations, respectively.
c
c   temp is an array of at least 3 * max(nx, ny) locations
c   which is used for scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicate
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   bi-linear. if sigma equals zero tensor products of cubic
c   splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   c contains the coefficients of a representation of the
c   interpolated function in a b-spline tensor production
c   form.
c
c   vx and vy contain b-spline under tension basis data.
c
c   ierr contains an error flag.
c        = 0 for normal return,
c        = 1 if nx or ny is less than 2,
c        = 2 if the x- or y-arrays are not strictly
c            increasing.
c
c and
c
c   none of the input parameters are altered (except w if
c   this parameter and c are identical in the calling
c   sequence).
c
c this subroutine references package modules vgen, terms,
c snhcsh, tridec, and trislm.
c
c--------------------------------------------------------- -
c
c copy w into c
c
      do 1 j = 1,ny
        do 1 i = 1,nx
    1     c(i,j) = w(i,j)
c
c generate basis functions along x-grid
c set up tridiagonal system and solve
c
      call vgen (nx,x,sigma,vx,ierr)
      if (ierr .ne. 0) return
      do 2 i = 2,nx
    2   temp(i) = vx(5,i-1)
      nxpi = nx
      do 3 i = 1,nx
        nxpi = nxpi+1
    3   temp(nxpi) = 1.
      do 4 i = 2,nx
        nxpi = nxpi+1
    4   temp(nxpi) = vx(4,i)
      call tridec (nx,temp(1),temp(nx+1),temp(2*nx+1),
     *             temp(1),temp(nx+1),ierr)
      call trislm (nx,temp(1),temp(nx+1),temp(2*nx+1),c,nx,
     *            ny,1)
c
c generate basis functions along y-grid
c set up tridiagonal system and solve
c
      call vgen (ny,y,sigma,vy,ierr)
      if (ierr .ne. 0) return
      do 5 j = 2,ny
    5   temp(j) = vy(5,j-1)
      nypj = ny
      do 6 j = 1,ny
        nypj = nypj+1
    6   temp(nypj) = 1.
      do 7 j = 2,ny
        nypj = nypj+1
    7   temp(nypj) = vy(4,j)
      call tridec (ny,temp(1),temp(ny+1),temp(2*ny+1),
     *             temp(1),temp(ny+1),ierr)
      call trislm (ny,temp(1),temp(ny+1),temp(2*ny+1),c,1,
     *            nx,nx)
      return
      end
      subroutine nbtoh2 (nx,ny,c,vx,vy,z,iz,zp)
c
      integer nx,ny,iz
      real c(nx,ny),vx(5,nx),vy(5,ny),z(iz,ny),zp(nx,ny,3)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine obtains a hermite interpolation
c representation (i. e. function values and second partial
c derivatives) for a two dimensional spline from a b-spline
c basis representation. the spline is assumed to have
c natural end conditions.
c
c on input--
c
c   nx and ny are the number of grid lines in the x- and y-
c   directions, respectively, of the rectangular grid which
c   specified the function.
c
c   c is an array of coefficients describing the function in
c   terms of a b-spline under tension basis. in the
c   expansion of the function, for i = 1,...,nx and j = 1,
c   ...,ny, the coefficient multiplying the product of basis
c   function i in x and basis function j in y is stored in
c   c(i,j).
c
c   vx and vy are arrays of length 5 * nx and 5 * ny,
c   respectively, containing the b-spline basis data for the
c   x- and y-grids.
c
c   z is an array of at least nx * ny locations.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. nx).
c
c and
c
c   zp is an array of at least 3 * nx * ny locations.
c
c the parameters nx, ny, c, vx, and vy should be input
c unaltered from the output of val2b1.
c
c on output--
c
c   z is an array of the nx * ny functional values at the
c   grid points, i. e. z(i,j) contains the functional value
c   at (x(i),y(j)) for i = 1,...,nx and j = 1,...,ny.
c
c   zp contains the values of the xx-, yy-, and xxyy-partial
c   derivatives of the surface at the given nodes.
c
c and
c
c   nx, ny, c, vx, vy, and iz are unaltered.
c
c this subroutine references package module sum.
c
c-----------------------------------------------------------
c
c combine data from v array to determine function and second
c derivative values
c
      real vxs(5),vys(5)
c
c loop on y grid
c
      do 5 j = 1,ny
        jsw = 2
        jm1 = j-1
        if (j .ne. 1) go to 1
        jsw = 1
        jm1 = ny
    1   jp1 = j+1
        if (j .ne. ny) go to 2
        jsw = 3
        jp1 = 1
c
c store values of b-splines in y
c
    2   vys(1) = vy(5,jm1)
        vys(2) = vy(4,jp1)
        vys(3) = vy(3,jm1)
        vys(4) = vy(2,j)
        vys(5) = vy(1,jp1)
c
c loop on x grid
c
        do 5 i = 1,nx
          isw = 2
          im1 = i-1
          if (i .ne. 1) go to 3
          isw = 1
          im1 = nx
    3     ip1 = i+1
          if (i .ne. nx) go to 4
          isw = 3
          ip1 = 1
c
c store values of b-splines in x
c
    4     vxs(1) = vx(5,im1)
          vxs(2) = vx(4,ip1)
          vxs(3) = vx(3,im1)
          vxs(4) = vx(2,i)
          vxs(5) = vx(1,ip1)
c
c accumulate in x direction
c
          call sum (c(im1,jm1),c(i,jm1),c(ip1,jm1),vxs,s1,
     *              sxx1,isw)
          call sum (c(im1,j),c(i,j),c(ip1,j),vxs,s2,sxx2,
     *              isw)
          call sum (c(im1,jp1),c(i,jp1),c(ip1,jp1),vxs,s3,
     *              sxx3,isw)
c
c accumulate in y direction
c
          call sum (s1,s2,s3,vys,z(i,j),zp(i,j,1),jsw)
    5     call sum (sxx1,sxx2,sxx3,vys,zp(i,j,2),zp(i,j,3),
     *              jsw)
      return
      end
      subroutine surfbd (xx,yy,w,wx,wy,wxx,wxy,wyy,nx,ny,x,
     *                   y,c,vx,vy,sigma)
c
      integer nx,ny
      real xx,yy,w,wx,wy,wxx,wxy,wyy,x(nx),y(ny),vx(5,nx),
     *     vy(5,ny),c(nx,ny),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine evaluates the function value, the two
c first partial derivatives, and the six second partial
c derivatives of a tensor product spline under tension in
c two variables.
c
c on input--
c
c   xx and yy contain the x- and y-coordines of the point
c   at which the interpolation is to be performe .d.
c
c   nx and ny are the number of grid lines in the x- and y-
c   directions, respectively, of the rectangular grid which
c   specified the function.
c
c   x and y are arrays containing the x- and y-grid values,
c   respectively.
c
c   c is an array of coefficients describing the function in
c   terms of a b-spline under tension basis. in the
c   expansion of the function, for i = 1,...,nx and j = 1,
c   ...,ny, the coefficient multiplying the product of basis
c   function i in x and basis function j in y is stored in
c   c(i,j).
c
c   vx and vy are arrays of length 5*nx and 5*ny,
c   respectively, containing the b-spline basis data for the
c   x- and y-grids.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters nx, ny, x, y, z, c, vx, vy, and sigma
c should be input unaltered from the output of surfb1.
c
c on output--
c
c   w contains the interpolated function value.
c
c   wx and wy contain the x- and y-partial derivatives,
c   respectively.
c
c   wxx, wxy, and wyy contain the xx-, xy-, and yy-partial
c   derivatives, respectively.
c
c and
c
c   none of the input parameters are altered.
c
c this subroutine references package modules dsplnz, intrvl,
c and snhcsh.
c
c--------------------------------------------------------- ----
c
      real bx(3,4),by(3,4)
c
c evaluate basis functions at xx and yy
c
      call dsplnz (xx,nx,x,vx,sigma,istart,bx)
      call dsplnz (yy,ny,y,vy,sigma,jstart,by)
c
c accumulate tensor products
c
      sum = 0.
      sumx = 0.
      sumy = 0.
      sumxx = 0.
      sumxy = 0.
      sumyy = 0.
      do 2 j = 1,4
        jj = jstart+j-1
        if (jj .eq. 0 .or. jj .gt. ny) go to 2
        by1j = by(1,j)
        by2j = by(2,j)
        by3j = by(3,j)
        do 1 i = 1,4
          ii = istart+i-1
          if (ii .eq. 0 .or. ii .gt. nx) go to 1
          bx1i = bx(1,i)
          bx2i =  bx(2,i)
          cij = c(ii,jj)
          sum = sum+cij*bx1i*by1j
          sumx = sumx+cij*bx2i*by1j
          sumy = sumy+cij*bx1i*by2j
          sumxx = sumxx+cij*bx(3,i)*by1j
          sumxy = sumxy+cij*bx2i*by2j
          sumyy = sumyy+cij*bx1i*by3j
    1     continue
    2   continue
      w = sum
      wx = sumx
      wy = sumy
      wxx = sumxx
      wxy = sumxy
      wyy = sumyy
      return
      end
      subroutine surfa1(m,n,r,theta,p,z,iz,zr1,zrm,islpsw,
     *                  zp,temp,sigma,istar,ierr)
c
      integer m,n,iz,islpsw,istar,ierr
      real    r(m),theta(n),p,z(iz,n),zr1(n),zrm(n),
     *        zp(m,n,3),temp(1),sigma
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through function
c values specified on a grid which is periodic in the second
c independent variable and non-polar in both variables.  the
c surface determined can be represented as the tensor pro-
c duct of splines under tension.  certain partial deriv-
c atives at the boundary are needed.  these may be specified
c or omitted.  for actual mapping of the points onto the
c surface it is necessary to call the function surfa2.
c
c on input--
c
c   m is the number of r-values in the grid (m .ge. 2).
c
c   n is the number of theta-values in the grid (n .ge. 2).
c
c   r is an array of the m r-coordinates in the grid.
c   the values should be positive and strictly increasing.
c
c   theta is an array of the n theta-coordinates in the
c   grid.  if a ray with its endpoint at the origin sweeps
c   the plane from theta(1) to theta(2) to ... to theta(n),
c   it must move continuously in a counterclockwise direc-
c   tion.  either the sequence is strictly increasing and
c   satisfies theta(n)-theta(1) .lt. p, or theta(n) .lt.
c   theta(1) and there is an index, istar, so that if the
c   elements of the sequence whose indices are greater than
c   or equal to istar are increased by p, then the sequence
c   is strictly increasing.
c
c   p is the period for theta.
c
c   z is an array of the m * n function values at the
c   grid points.  z(i,j) contains the function value at
c   (r(i),theta(j)) for i = 1,...,m and j = 1,...,n.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   zr1 is an array of n partial derivatives with
c   respect to r along the line r = r(1).  zr1(j) is the
c   partial derivative with respect to r at (r(1),theta(j))
c   for j = 1,...,n.
c
c   zrm is an array of n partial derivatives with
c   respect to r along the line r = r(m).  zrm(j) is the
c   partial derivative with respect to r at (r(m),theta(j))
c   for j = 1,...,n.
c
c   islpsw is a switch indicating which boundary derivative
c   information is user supplied and which is estimated.
c   islpsw = 0  if all the derivatives are supplied.
c          = 1  if zr1 is supplied and zrm is estimated.
c          = 10 if zr1 is estimated and zrm is supplied.
c          = 11 if all derivatives are to be estimated.
c
c   zp is an array of at least 3 * m * n locations.
c
c   temp is an array of at least 5 * max(m,n) locations
c   which is used for scratch storage.
c
c and
c
c   sigma contains the tension factor.  this value indicates
c   the curviness desired.  if abs(sigma) is nearly zero (e.
c   g. .001) the resulting surface is approximately the ten-
c   sor product of cubic splines.  if abs(sigma) is large
c   (e.g. 50.) the resulting surface is approximately bi-
c   linear.  if sigma equals zero, tensor products of cubic
c   splines result.  a standard value for sigma is approx-
c   imately 1. in absolute value.
c
c on output--
c
c   zp contains the partial derivative values necessary for
c   evaluation of the function.
c
c   istar is the index where
c        theta(istar-1) .gt. theta(istar).
c   istar is 0 if the theta-values are strictly increasing.
c
c   ierr contains an error flag,
c        = 0 if normal return,
c        = 1 if n .lt. 2 .or. m .lt. 2,
c        = 2 if r values are not strictly increasing or if theta
c            values are not specified correctly,
c        = 4 if period is too small for data.
c
c and
c
c   the input parameters are unaltered.
c
c this subroutine references package modules bdryn, ceez,
c chekin, delr, matnn, matnp, rhsnn, rhsnp, snhcsh, terms,
c trdec, tridep, trsol, and trisop and blas modules saxpy,
c scopy, and sscal.
c
c-----------------------------------------------------------
c
c check input
c
      if (n .lt. 2 .or. m .lt. 2) go to 1
      call chekin(n,theta,istar,ierr)
      if (ierr .ne. 0) return
      if (((istar .eq. 0) .and. (theta(n)-theta(1) .gt. p))
     *                    .or.
     *    ((istar .gt. 0) .and. ((theta(n) .gt. theta(1))
     *                                     .or.
     *       (theta(istar-1)-theta(istar) .gt. p)))) go to 3
      delrm1 = r(m)-r(1)
      if (delrm1 .le. 0) go to 2
      call chekin(m,r,idum,ierr)
      if (ierr .ne. 0) return
c
      np1 = n+1
      nt2p1 = np1+n
      nt3p1 = nt2p1+n
      nt4p1 = nt3p1+n
      mm1 = m-1
      mm2 = m-2
      mp1 = m+1
      mt2p1 = mp1+m
c
c denormalize tension factor
c
      sigmar = abs(sigma)*float(mm1)/delrm1
      sigmat = abs(sigma)*float(n)/p
c
c obtain boundary derivatives from input or approximations
c
c fr(r1,tj)
c
      call bdryn(m,n,(islpsw/10)*10-islpsw,istar,1,zr1,r(1),
     *           r(2),r(3),iz,z(1,1),z(2,1),z(3,1),sigmar,m,
     *           zp(1,1,1),ierr)
c
c fr(rm,tj)
c
      call bdryn(m,n,(islpsw/100)*10-islpsw/10,istar,1,zrm,
     *           r(m),r(mm1),r(mm2),iz,z(m,1),z(mm1,1),
     *           z(mm2,1),sigmar,m,zp(m,1,1),ierr)
c
c set up and solve systems in r-direction
c
      call rhsnn(n,m,1,iz,z,r,m,zp(1,1,1),zp(m,1,1),1,m,
     *           zp(1,1,1))
      call matnn(m,sigmar,r,temp(1),temp(mp1))
      call trdec(m,temp(1),temp(mp1),temp(mt2p1))
      call trsol(m,n,1,m,temp(mt2p1),temp(1),temp(mp1),
     *            zp(1,1,1))
c
c set up and solve systems in t-direction
c
      call rhsnp(m,n,p,iz,1,z,theta,m,1,zp(1,1,2))
      call rhsnp(m,n,p,m,1,zp(1,1,1),theta,m,1,zp(1,1,3))
      call matnp(n,p,sigmat,theta,temp(1),temp(np1),c)
      call tridep(n,c,temp(1),temp(np1),temp(nt2p1),
     *             temp(nt3p1),temp(nt4p1))
      call trisop(n,temp(1),temp(np1),temp(nt2p1),
     *             temp(nt3p1),temp(nt4p1),m,m,1,zp(1,1,2))
      call trisop(n,temp(1),temp(np1),temp(nt2p1),
     *            temp(nt3p1),temp(nt4p1),mm1,m,1,zp(1,1,3))
      return
c
c error conditions
c
c problem dimensions too small
c
    1 ierr = 1
      return
c
c grid values not strictly increasing
c
    2 ierr = 2
      return
c
c period too small
c
    3 ierr = 4
      return
      end
      function surfa2(rr,tt,m,n,r,theta,p,z,iz,zp,istar,
     *                sigma)
c
      integer m,n,iz
      real    rr,tt,p,r(m),theta(n),z(iz,n),zp(m,n,3),sigma
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function interpolates a surface at the point (rr,tt)
c using a bi-spline under tension when the surface is per-
c iodic in the second independent variable and non-polar in
c both variables.  subroutine surfa1 should have been called
c previously to determine certain necessary parameters.
c
c on input--
c
c   rr and tt contain the r- and theta-coordinates of the
c   point to be mapped onto the interpolating surface.
c
c   m and n contain the number of grid lines in the r- and
c   theta-directions, respectively, of the grid which spec-
c   ified the surface.
c
c   r and theta are arrays containing the r- and theta-
c   grid values, respectively.  the r-array must be strictly
c   increasing.  if p is added to all theta array elements
c   whose index is istar or greater, then the resulting
c   array is strictly increasing.
c
c   z is an array of m * n function values.  in cylindrical
c   coordinates, (r(i),theta(j),z(i,j)) is a point on the
c   surface being interpolated.
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3 * m * n locations containing the
c   surface derivative information determined by surfa1.
c
c   istar is the index where theta(istar-1) .gt.
c   theta(istar).  istar is zero if the theta values are
c   strictly increasing.
c
c and
c
c   sigma contains the tension factor.
c
c the parameters m, n, r, theta, p, z, iz, sigma, zp, and
c istar should be input unaltered from the output of surfa1.
c
c on output--
c
c   surfa2 is the interpolated surface value.
c
c and
c
c   the input parameters are unaltered.
c
c this module references package modules intrvl, intrvp, and
c snhcsh.
c
c-----------------------------------------------------------
c
c cubic spline - f1,fpp1,f2,fpp2 basis
c
      herz(f1,fpp1,f2,fpp2) = (f1*del2+f2*del1)/h
     *    -del1*del2*(fpp1*(del2+h)+fpp2*(del1+h))/(6.*h)
c
c tension spline
c
      hernz (f1,fpp1,f2,fpp2) = c1*f1+cpp1*fpp1+c2*f2+
     *                          cpp2*fpp2
c
c
c denormalize tension factor
c
      sigmar = abs(sigma)*float(m-1)/(r(m)-r(1))
      sigmat = abs(sigma)*float(n)/p
c
c locate (rr,tt) within r-grid , set up theta interpolation
c
      i = intrvl(rr,r,m)
      ip1 = i+1
      if (istar .ne. 0) go to 2
c
c monotonic theta-values
c
      j = intrvp(tt,theta,n,p,tp)
      if (j .eq. n) go to 1
      jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tp-theta(j)
      del2 = theta(jp1)-tp
      go to 6
    1 jp1 = 1
      h = p-(theta(n)-theta(1))
      del1 = tp-theta(j)
      del2 = theta(jp1)+p-tp
      go to 6
c
c non-monotonic theta-values
c
    2 j = intrvp(tt,theta,istar-1,p,tp)
      if (tp .gt. theta(istar-1)) go to 3
      jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tp-theta(j)
      del2 = theta(jp1)-tp
      go to 6
    3 if (tp .lt. theta(istar)+p .or. tp .gt. theta(n)+p)
     *   go to 4
      j = intrvl(tp,theta(istar),n-istar+1)+istar-1
      jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tp-theta(j)
      del2 = theta(jp1)-tp
      go to 6
    4 if (tp .le. theta(n)+p) go to 5
      j = n
      jp1 = 1
      h = theta(1)+p-(theta(n)+p)
      del1 = theta(1)+p-tp
      del2 = tp-theta(n)+p
      go to 6
    5 j = istar-1
      jp1 = istar
      h = theta(istar)+p-theta(istar-1)
      del1 = tp-theta(istar-1)
      del2 = theta(istar)+p-tp
    6 if (sigma .ne. 0.) go to 7
c
c
c cubic spline interpolation
c
c
c interpolate in theta direction
c
      fip1 = herz(z(ip1,j),zp(ip1,j,2),z(ip1,jp1),
     *       zp(ip1,jp1,2))
      frrip1 = herz(zp(ip1,j,1),zp(ip1,j,3),zp(ip1,jp1,1),
     *         zp(ip1,jp1,3))
      fi = herz(z(i,j),zp(i,j,2),z(i,jp1),zp(i,jp1,2))
      frri = herz(zp(i,j,1),zp(i,j,3),zp(i,jp1,1),
     *       zp(i,jp1,3))
c
c interpolate in r direction
c
      h = r(ip1)-r(i)
      del1 = rr-r(i)
      del2 = r(ip1)-rr
c
       surfa2 = herz(fi,frri,fip1,frrip1)
      return
c
c
c spline under tension interpolation
c
c
c theta direction
c
    7 call snhcsh(sinhm1,dummy,sigmat*del1,-1)
      call snhcsh(sinhm2,dummy,sigmat*del2,-1)
      call snhcsh(sinhmh,dummy,sigmat*h,-1)
      c1 = del2/h
      c2 = del1/h
      denom = sigmat*sigmat*h*(1.+sinhmh)
      cpp1 = del2*(sinhm2-sinhmh)/denom
      cpp2 = del1*(sinhm1-sinhmh)/denom
c
      fip1 = hernz(z(ip1,j),zp(ip1,j,2),z(ip1,jp1),
     *             zp(ip1,jp1,2))
      frrip1 = hernz(zp(ip1,j,1),zp(ip1,j,3),zp(ip1,jp1,1),
     *               zp(ip1,jp1,3))
c
      fi = hernz(z(i,j),zp(i,j,2),z(i,jp1),zp(i,jp1,2))
      frri = hernz(zp(i,j,1),zp(i,j,3),zp(i,jp1,1),
     *             zp(i,jp1,3))
c
c r direction
c
      h = r(ip1)-r(i)
      del1 = rr-r(i)
      del2 = r(ip1)-rr
      call snhcsh(sinhm1,dummy,sigmar*del1,-1)
      call snhcsh(sinhm2,dummy,sigmar*del2,-1)
      call snhcsh(sinhmh,dummy,sigmar*h,-1)
      c1 = del2/h
      c2 = del1/h
      denom = sigmar*sigmar*h*(1.+sinhmh)
      cpp1 = del2*(sinhm2-sinhmh)/denom
      cpp2 = del1*(sinhm1-sinhmh)/denom
c
      surfa2 = hernz(fi,frri,fip1,frrip1)
c
      return
      end
      subroutine surfw1(m,n,r,theta,z,iz,zr10,zr190,zrm,zt1,
     *                  ztn,zrtm1,zrtmn,islpsw,zp,temp,
     *                  sigma,istar,ierr)
c
      integer m,n,iz,islpsw,istar,ierr
      real    r(m),theta(n),z(iz,n),zr10,zr190,zrm(n),
     *        zt1(m),ztn(m),zrtm1,zrtmn,zp(m,n,3),temp(1),
     *        sigma
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through function
c values which are non-periodic in both variables and have
c one pole in the first independent variable.  the surface
c determined can be represented as the tensor product of
c splines under tension.  certain partial derivatives at the
c boundary are needed.  these may be specified or omitted.
c for actual mapping of the points onto the surface it is
c necessary to call the function surfw2.
c
c on input--
c
c   m is the number of r-values in the grid (m .ge. 2).
c
c   n is the number of theta-values in the grid (m .ge. 2).
c
c   r is an array of the m r-coordinates in the grid.
c   r(1) = 0. is the pole and the values should be strictly
c   increasing.
c
c   theta is an array of the n theta-coordinates in the
c   grid.  if a ray with its endpoint at the origin sweeps
c   the plane from theta(1) to theta(2) to ... to theta(n),
c   it must move continuously in a counterclockwise direc-
c   tion.  either the sequence is strictly increasing and
c   satisfies theta(n)-theta(1) .lt. 360., or theta(n) .lt.
c   theta(1) and there is an index, istar, so that if the
c   elements of the sequence whose indices are greater than
c   or equal to istar are increased by 360., then the
c   sequence is strictly increasing.
c
c   z is an array of the m * n function values at the
c   grid points.  z(i,j) contains the functional value at
c   (r(i),theta(j)) for i = 1,...,m and j = 1,...,n.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   zr10 is the value of the partial derivative with
c   respect to r at (0.,0.) = (r(1),0.).
c
c   zr190 is the value of the partial derivative with
c   respect to r at (0.,90.) = (r(1),90.)
c
c   zrm is an array of n partial derivatives with
c   respect to r along the line r = r(m).  zrm(j) is the
c   partial derivative with respect to r at (r(m),theta(j))
c   for j = 1,...,n.
c
c   zt1 is an array of m partial derivatives with
c   respect to theta along the line theta = theta(1).
c   zt1(i) is the partial derivative with respect to theta at
c   (r(i),theta(1)) for i = 1,...,m.
c
c   ztn is an array of m partial derivatives with
c   respect to theta along the line theta = theta(n).
c   ztn(i) is the partial derivative with respect to theta at
c   (r(i),theta(n)) for i = 1,...,m.
c
c   zrtm1 is the second mixed partial derivative at
c   (r(m),theta(1)).
c
c   zrtmn is the second mixed partial derivative at
c   (r(m),theta(n)).
c
c   islpsw is a switch indicating which boundary derivative
c   information is user supplied and which is estimated.
c   islpsw is an 6-digit decimal number.  a zero digit
c   signifies that the corresponding derivative is supp-
c   lied.  a non-zero digit instructs the module to approx-
c   imate the derivatives.  from left to right the deriv-
c   atives are
c           zrtmn zrtm1 ztn zt1 zrm (zr10 and zr190).
c   islpsw = 0 means all derivatives are supplied.
c   islpsw = 111111 means all derivatives will be approx-
c   imated.
c
c   zp is an array of at least 3 * m * n locations.
c
c   temp is an array of at least 3 * max(m,n) locations
c   which is used for scratch storage.
c
c and
c
c   sigma contains the tension factor.  this value indicates
c   the curviness desired.  if abs(sigma) is nearly zero (e.
c   g. .001) the resulting surface is approximately the ten-
c   sor product of cubic splines.  if abs(sigma) is large
c   (e.g. 50.) the resulting surface is approximately bi-
c   linear.  if sigma equals zero, tensor products of cubic
c   splines result.  a standard value for sigma is approx-
c   imately 1. in absolute value.
c
c on output--
c
c   zp contains the partial derivative values necessary for
c   evaluation of the function.
c
c   istar is the index where
c         theta(istar-1) .gt. theta(istar).
c   istar is 0 if the theta-values are strictly increasing.
c
c   ierr contains an error flag,
c        = 0 if normal return,
c        = 1 if n .lt. 2 .or. m .lt. 2,
c        = 2 if r values are not strictly increasing or
c            if theta values are not specified correctly,
c        = 3 if r(1) .ne. 0.,
c        = 4 if the range of theta-values is too large.
c
c and
c
c   m, n, r, z, iz, islpsw, zrm, ztn, zrtm1, zrtmn,  and
c   sigma are unaltered.
c
c this subroutine references package modules bdryn, bdryp,
c ceez, chekin, delr, lstsq, matnn, rhsnn, snhcsh, terms,
c trdec, and trsol and blas modules saxpy, scopy, sdot,
c snrm2, and sscal.
c
c-----------------------------------------------------------
c
c check input
c
      if (n .lt. 2 .or. m .lt. 2) go to 1
      if (r(1) .ne. 0.) go to 3
      call chekin(n,theta,istar,ierr)
      if (ierr .ne. 0) return
      if (((istar .eq. 0) .and. (theta(n)-theta(1) .gt. 360.))
     *                    .or.
     *    ((istar .gt. 0) .and. ((theta(n) .gt. theta(1))
     *   .or. (theta(istar-1)-theta(istar) .gt. 360.))))
     * go to 4
      delrm1 = r(m)-r(1)
      if (delrm1 .le. 0) go to 2
      call chekin(m,r,idum,ierr)
      if (ierr .ne. 0) return
      nm1 = n-1
      nm2 = n-2
      np1 = n+1
      nt2p1 = np1+n
      nm1tm = (n-1)*m
      mm1 = m-1
      mm2 = m-2
      mp1 = m+1
      mt2p1 = mp1+m
      fact = atan(1.)/45.
c
c denormalize tension factor
c
      sigmar = abs(sigma)*float(mm1)/delrm1
      sigmat = abs(sigma)*float(nm1)/
     *         (theta(n)-theta(1)
     *         +180.+sign(180.,theta(1)-theta(n)))
c
c obtain boundary derivatives from input or approximations
c
c fr(r1,tj)
c
      call bdryp(m,n,(islpsw/10)*10-islpsw,zr10,zr190,r(1),
     *           r(2),r(3),iz,z(1,1),z(2,1),z(3,1),sigmar,
     *           theta,m,zp(1,1,1),dd0,dd90,temp,ierr)
c
c fr(rm,tj)
c
      call bdryn(m,n,(islpsw/100)*10-islpsw/10,istar,1,zrm,
     *           r(m),r(mm1),r(mm2),iz,z(m,1),z(mm1,1),
     *           z(mm2,1),sigmar,m,zp(m,1,1),ierr)
c
c frt(r1,t1) and frt(r1,tn)
c
      zp(1,1,3) = fact*(dd90*cos(fact*theta(1))
     *                  -dd0*sin(fact*theta(1)))
      zp(1,n,3) = fact*(dd90*cos(fact*theta(n))
     *                  -dd0*sin(fact*theta(n)))
c
c ft(ri,t1)
c
      call bdryn(n,m,(islpsw/1000)*10-islpsw/100,istar,1,
     *           zt1,theta(1),theta(2),theta(3),1,z(1,1),
     *           z(1,2),z(1,3),sigmat,1,zp(1,1,2),ierr)
c
c ft(ri,tn)
c
      call bdryn(n,m,(islpsw/10000)*10-islpsw/1000,istar,1,
     *           ztn,theta(n),theta(nm1),theta(nm2),1,
     *           z(1,n),z(1,nm1),z(1,nm2),sigmat,1,
     *           zp(1,n,2),ierr)
c
c frt(rm,t1) and frt(rm,tn)
c
      call bdryn(n,1,(islpsw/100000)*10-islpsw/10000,istar,
     *           1,zrtm1,theta(1),theta(2),theta(3),1,
     *           zp(m,1,1),zp(m,2,1),zp(m,3,1),sigmat,1,
     *           zp(m,1,3),ierr)
      call bdryn(n,1,(islpsw/1000000)*10-islpsw/100000,
     *           istar,1,zrtmn,theta(n),theta(nm1),
     *           theta(nm2),1,zp(m,n,1),zp(m,nm1,1),
     *           zp(m,nm2,1),sigmat,1,zp(m,n,3),ierr)
c
c set up and solve systems in r-direction
c
      call rhsnn(n,m,1,iz,z,r,m,zp(1,1,1),zp(m,1,1),1,m,
     *           zp(1,1,1))
      call rhsnn(2,m,1,nm1tm,zp(1,1,2),r,nm1tm,zp(1,1,3),
     *           zp(m,1,3),1,nm1tm,zp(1,1,3))
      call matnn(m,sigmar,r,temp(1),temp(mp1))
      call trdec(m,temp(1),temp(mp1),temp(mt2p1))
      call trsol(m,n,1,m,temp(mt2p1),temp(1),temp(mp1),
     *            zp(1,1,1))
      call trsol(m,2,1,nm1tm,temp(mt2p1),temp(1),temp(mp1),
     *            zp(1,1,3))
c
c save fr(0,0) and fr(0,90) for later
c
      zp(1,1,3) = dd0
      zp(1,2,3) = dd90
c
c set up and solve systems in t-direction
c
      call rhsnn(m,n,iz,1,z,theta,1,zp(1,1,2),zp(1,n,2),m,1,
     *           zp(1,1,2))
      call rhsnn(mm1,n,m,1,zp(2,1,1),theta,1,zp(2,1,3),
     *           zp(2,n,3),m,1,zp(2,1,3))
      call matnn(n,sigmat,theta,temp(1),temp(np1))
      call trdec(n,temp(1),temp(np1),temp(nt2p1))
      call trsol(n,m,m,1,temp(nt2p1),temp(1),temp(np1),
     *            zp(1,1,2))
      call trsol(n,mm1,m,1,temp(nt2p1),temp(1),temp(np1),
     *            zp(2,1,3))
      return
c
c error conditions
c
c problem dimensions too small
c
    1 ierr = 1
      return
c
c grid values not strictly increasing
c
    2 ierr = 2
      return
c
c r(1) not a pole
c
    3 ierr = 3
      return
c
c range of theta-values too large
c
    4 ierr = 4
      return
c
      end
      function surfw2(rr,tt,m,n,r,theta,z,iz,zp,istar,sigma)
c
      integer m,n,iz
      real    rr,tt,r(m),theta(n),z(iz,n),zp(m,n,3),sigma
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function interpolates a surface at the point (rr,tt)
c using a bi-spline under tension when the surface is non-
c periodic in both variables and has one pole in the first
c independent variable.  subroutine surfw1 should have been
c called previously to determine certain necessary param-
c eters.
c
c on input--
c
c   rr and tt contain the r- and theta-coordinates of the
c   point to be mapped onto the interpolating surface.
c
c   m and n contain the number of grid lines in the r- and
c   theta-directions, respectively, of the grid which spec-
c   ified the surface.
c
c   r and theta are arrays containing the r- and theta-
c   grid values, respectively.  the r-array must be strictly
c   increasing.  if p is added to all theta array elements
c   whose index is istar or greater, then the resulting
c   array is strictly increasing.
c
c   z is an array of m * n function values.  in cylindrical
c   coordinates, (r(i),theta(j),z(i,j)) is a point on the
c   surface being interpolated.
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3 * m * n locations containing the
c   surface derivative information determined by surfw1.
c
c   istar is the index where
c         theta(istar-1) .gt. theta(istar).
c   istar is 0 if the theta values are strictly increasing.
c
c and
c
c   sigma contains the tension factor.
c
c the parameters m, n, r, t, z, iz, sigma, zp, and istar
c should be input unaltered from the output of surfw1.
c
c on output--
c
c   surfw2 is the interpolated surface value.
c
c and
c
c   the input parameters are unaltered.
c
c this module references package modules intrvl and snhcsh.
c
c-----------------------------------------------------------
c
c cubic spline - f1,fpp1,f2,fpp2 basis
c
      herz(f1,fpp1,f2,fpp2) = (f1*del2+f2*del1)/h
     *    -del1*del2*(fpp1*(del2+h)+fpp2*(del1+h))/(6.*h)
c
c cubic spline - f1,fp1,f2,fpp2 basis
c
      herzp(f1,fp1,f2,fpp2) = (-f1*del2*(del2*del2-3.*h*h)
     *     +f2*del1*del1*(del2+2.*h))/(2.*h*h*h)
     *     +(fp1*(2.*h-del1)/(2.*h)-fpp2*del1/4.)
     *     *del1*del2/h
c
c tension spline
c
      hernz (f1,fpp1,f2,fpp2) = c1*f1+cpp1*fpp1+c2*f2+
     *                          cpp2*fpp2
c
c denormalize tension factor
c
      sigmar = abs(sigma)*float(m-1)/(r(m)-r(1))
      sigmat = abs(sigma)*float(n-1)/
     *         (theta(n)-theta(1)
     *              +180.+sign(180.,theta(1)-theta(n)))
c
c locate (rr,tt) within r-grid , set up theta interpolation
c
      i = intrvl(rr,r,m)
      ip1 = i+1
      if (istar .ne. 0) go to 1
      j = intrvl(tt,theta,n)
      go to 5
    1 if (tt .lt. theta(istar) .or. tt .gt. theta(istar-1))
     *                       go to 2
      if (tt .eq. theta(istar)) go to 3
      if (tt .eq. theta(istar-1)) go to 4
      if (tt .le. theta(n)) j = intrvl(tt,theta(istar),
     *                      n-istar+1)+istar-1
      if (tt .gt. theta(n)) j = intrvl(tt,theta,istar-1)
      go to 5
    2 h = theta(istar)+360.-theta(istar-1)
      del1 = tt-theta(istar-1)+180.+sign(180.,theta(istar-1)
     *                                        -tt)
      del2 = theta(istar)-tt+180.+sign(180.,tt-theta(istar))
      j = istar-1
      jp1 = istar
      go to 6
    3 j = istar-1
      jp1 = istar
      h = theta(istar)+360.-theta(istar-1)
      del1 = h
      del2 = 0.
      go to 6
    4 j = istar-1
      jp1 = istar
      h = theta(istar)+360.-theta(istar-1)
      del1 = 0.
      del2 = h
      go to 6
    5 jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tt-theta(j)
      del2 = theta(jp1)-tt
c
    6 if (sigma .ne. 0.) go to 8
c
c
c cubic spline interpolation
c
c
c interpolate in theta direction
c
      fip1 = herz(z(ip1,j),zp(ip1,j,2),z(ip1,jp1),
     *       zp(ip1,jp1,2))
      frrip1 = herz(zp(ip1,j,1),zp(ip1,j,3),zp(ip1,jp1,1),
     *         zp(ip1,jp1,3))
      if (r(1) .eq. 0. .and. i .eq. 1) go to 7
c
c no pole
c
      fi = herz(z(i,j),zp(i,j,2),z(i,jp1),zp(i,jp1,2))
      frri = herz(zp(i,j,1),zp(i,j,3),zp(i,jp1,1),
     *       zp(i,jp1,3))
c
c interpolate in r direction
c
      h = r(ip1)-r(i)
      del1 = rr-r(i)
      del2 = r(ip1)-rr
c
       surfw2 = herz(fi,frri,fip1,frrip1)
      return
c
c pole
c
    7 fi = z(1,1)
      fact = atan(1.)/45.
      fri  = zp(1,1,3)*cos(tt*fact)+zp(1,2,3)*sin(tt*fact)
      h = r(ip1)-r(i)
      del1 = rr-r(i)
      del2 = r(ip1)-rr
c
      surfw2 = herzp(fi,fri,fip1,frrip1)
      return
c
c
c spline under tension interpolation
c
c
c theta direction
c
    8 call snhcsh(sinhm1,dummy,sigmat*del1,-1)
      call snhcsh(sinhm2,dummy,sigmat*del2,-1)
      call snhcsh(sinhmh,dummy,sigmat*h,-1)
      c1 = del2/h
      c2 = del1/h
      denom = sigmat*sigmat*h*(1.+sinhmh)
      cpp1 = del2*(sinhm2-sinhmh)/denom
      cpp2 = del1*(sinhm1-sinhmh)/denom
c
      fip1 = hernz(z(ip1,j),zp(ip1,j,2),z(ip1,jp1),
     *             zp(ip1,jp1,2))
      frrip1 = hernz(zp(ip1,j,1),zp(ip1,j,3),zp(ip1,jp1,1),
     *               zp(ip1,jp1,3))
c
      if (r(1) .eq. 0. .and. i .eq. 1) go to 9
c
c no pole
c
      fi = hernz(z(i,j),zp(i,j,2),z(i,jp1),zp(i,jp1,2))
      frri = hernz(zp(i,j,1),zp(i,j,3),zp(i,jp1,1),
     *             zp(i,jp1,3))
c
c r direction
c
      h = r(ip1)-r(i)
      del1 = rr-r(i)
      del2 = r(ip1)-rr
      call snhcsh(sinhm1,dummy,sigmar*del1,-1)
      call snhcsh(sinhm2,dummy,sigmar*del2,-1)
      call snhcsh(sinhmh,dummy,sigmar*h,-1)
      c1 = del2/h
      c2 = del1/h
      denom = sigmar*sigmar*h*(1.+sinhmh)
      cpp1 = del2*(sinhm2-sinhmh)/denom
      cpp2 = del1*(sinhm1-sinhmh)/denom
c
      surfw2 = hernz(fi,frri,fip1,frrip1)
c
      return
c
c pole
c
    9 fi = z(1,1)
      fact = atan(1.)/45.
      fri = (zp(1,1,3)*cos(tt*fact)+zp(1,2,3)*sin(tt*fact))
c
c r direction
c
      h = r(ip1)-r(i)
      del1 = rr-r(i)
      del2 = r(ip1)-rr
      call snhcsh(sinhm1,dummy,sigmar*del1,-1)
      call snhcsh(sinhm2,dummy,sigmar*del2,-1)
      call snhcsh(sinhmh,coshmh,sigmar*h,0)
      c1 = del2*(sinhm2-coshmh)/(h*(sinhmh-coshmh))
      cpp1 = del2*(sinhm2-sinhmh)/(sinhmh-coshmh)
      c2 = (del1-cpp1)/h
      cpp2 = (del1*(sinhm1-sinhmh)+cpp1*sinhmh)/
     *       (sigmar*sigmar*h*(1.+sinhmh))
c
      surfw2 = hernz(fi,fri,fip1,frrip1)
c
      return
      end
      subroutine surfd1(m,n,r,theta,z,iz,zr10,zr190,zrm,
     *                  islpsw,zp,temp,sigma,istar,ierr)
c
      integer m,n,iz,islpsw,istar,ierr
      real    r(m),theta(n),z(iz,n),zr10,zr190,zrm(n),
     *        zp(m,n,3),temp(1),sigma
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine returns parameters necessary to compute an
c interpolatory surface passing through function values
c specified on a grid which is periodic in the second
c independent variable and has one pole in the first inde-
c pendent variable.  the surface determined can be
c can be represented as the tensor product of splines under
c tension.  certain partial derivatives at the boundary are
c needed.  these may be specified or omitted.  for actual
c mapping of the points onto the surface it is necessary to
c call the function surfd2.
c
c on input--
c
c   m is the number of r-values in the grid (m .ge. 2).
c
c   n is the number of theta-values in the grid (n .ge. 2).
c
c   r is an array of the m r-coordinates in the grid.
c   the values should be non-negative and strictly increas-
c   ing, and r(1) must be zero.
c
c   theta is an array of the n theta-coordinates in the
c   grid.  if a ray with its endpoint at the origin sweeps
c   the plane from theta(1) to theta(2) to ... to theta(n),
c   it must move continuously in a counterclockwise direc-
c   tion.  either the sequence is strictly increasing and
c   satisfies theta(n)-theta(1) .lt. 360., or theta(n) .lt.
c   theta(1) and there is an index, istar, so that if the
c   elements of the sequence whose indices are greater than
c   or equal to istar are increased by 360., then the
c   sequence is strictly increasing.
c
c   z is an array of the m * n function values at the
c   grid points.  z(i,j) contains the function value at
c   (r(i),theta(j)) for i = 1,...,m and j = 1,...,n.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   zr10 is the partial derivative with respect to r at
c   (r(1),0).
c
c   zr190 is the partial derivative with respect to r at
c   (r(1),90).
c
c   zrm is an array of n partial derivatives with
c   respect to r along the line r = r(m).  zrm(j) is the
c   partial derivative with respect to r at (r(m),theta(j))
c   for j = 1,...,n.
c
c   islpsw is a switch indicating which boundary derivative
c   information is user supplied and which is estimated.
c   if islpsw = 0  all derivatives are supplied.
c             = 1  z10 and z190 are supplied and
c                  zrm is to be estimated.
c             = 10 z10 and z190 are to be estimated and
c                  zrm is supplied.
c             = 11 all derivatives are to be estimated.
c
c   zp is an array of dimension 3 * m * n or more.
c
c   temp is an array of at least 5 * max(m,n) locations
c   which is used for scratch storage.
c
c and
c
c   sigma contains the tension factor.  this value indicates
c   the curviness desired.  if abs(sigma) is nearly zero (e.
c   g. .001) the resulting surface is approximately the ten-
c   sor product of cubic splines.  if abs(sigma) is large
c   (e.g. 50.) the resulting surface is approximately bi-
c   linear.  if sigma equals zero, tensor products of cubic
c   splines result.  a standard value for sigma is approx-
c   imately 1. in absolute value.
c
c on output--
c
c   zp contains the partial derivative values necessary for
c   evaluation of the function.
c
c   istar is the index where
c        theta(istar-1) .gt. theta(istar).
c   istar is 0 if the theta-values are strictly increasing.
c
c   ierr contains an error flag,
c        = 0 if normal return,
c        = 1 if n .lt. 2 .or. m .lt. 2,
c        = 2 if r values are not strictly increasing
c            or if theta values are not specified correctly,
c        = 3 if r(1) .ne. 0.  (r(1) = 0 is a pole),
c        = 4 if the range of theta-values is too large,
c
c and
c
c   m, n, r, t, z, iz, islpsw, zr10, zr190, zrm,  and
c   sigma are unaltered.
c
c this subroutine references package modules bdryn, bdryp,
c ceez, chekin, delr, lstsq, matnn, matnp, rhsnn, rhsnp,
c snhcsh, terms, trdec, tridep, trsol, and trisop
c and blas modules saxpy, scopy, sdot, snrm2, and sscal.
c
c-----------------------------------------------------------
c
c check input
c
      if (n .lt. 2 .or. m .lt. 2) go to 1
      if (r(1) .ne. 0.) go to 5
      call chekin(n,theta,istar,ierr)
      if (ierr .ne. 0) return
      p = 360.
      if (((istar .eq. 0) .and. (theta(n)-theta(1) .gt. p))
     *                    .or.
     *    ((istar .gt. 0) .and. ((theta(n) .gt. theta(1))
     *    .or. (theta(istar-1)-theta(istar) .gt. p))))
     *     go to 3
      delrm1 = r(m)-r(1)
      if (delrm1 .le. 0) go to 2
      call chekin(m,r,idum,ierr)
      if (ierr .ne. 0) return
      np1 = n+1
      nt2p1 = np1+n
      nt3p1 = nt2p1+n
      nt4p1 = nt3p1+n
      mm1 = m-1
      mm2 = m-2
      mp1 = m+1
      mt2p1 = mp1+m
c
c denormalize tension factor
c
      sigmar = abs(sigma)*float(mm1)/delrm1
      sigmat = abs(sigma)*float(n)/p
c
c obtain boundary derivatives from input or approximations
c
c fr(r1,tj)
c
      call bdryp(m,n,(islpsw/10)*10-islpsw,zr10,zr190,
     *           r(1),r(2),r(3),iz,z(1,1),z(2,1),z(3,1),
     *           sigmar,theta,m,zp(1,1,1),dd0,dd90,temp,ierr)
c
c fr(rm,tj)
c
      call bdryn(m,n,(islpsw/100)*10-islpsw/10,istar,1,zrm,
     *           r(m),r(mm1),r(mm2),iz,z(m,1),z(mm1,1),
     *           z(mm2,1),sigmar,m,zp(m,1,1),ierr)
c
c set up and solve systems in r-direction
c
      call rhsnn(n,m,1,iz,z,r,m,zp(1,1,1),zp(m,1,1),1,m,
     *           zp(1,1,1))
      call matnn(m,sigmar,r,temp(1),temp(mp1))
      call trdec(m,temp(1),temp(mp1),temp(mt2p1))
      call trsol(m,n,1,m,temp(mt2p1),temp(1),temp(mp1),
     *            zp(1,1,1))
c
c save fr(0,0) and fr(0,90) for later
c
      zp(1,1,3) = dd0
      zp(1,2,3) = dd90
c
c set up and solve systems in t-direction
c
      call rhsnp(m,n,p,iz,1,z,theta,m,1,zp(1,1,2))
      call rhsnp(mm1,n,p,m,1,zp(2,1,1),theta,m,1,zp(2,1,3))
      call matnp(n,p,sigmat,theta,temp(1),temp(np1),c)
      call tridep(n,c,temp(1),temp(np1),temp(nt2p1),
     *             temp(nt3p1),temp(nt4p1))
      call trisop(n,temp(1),temp(np1),temp(nt2p1),
     *             temp(nt3p1),temp(nt4p1),m,m,1,zp(1,1,2))
      call trisop(n,temp(1),temp(np1),temp(nt2p1),
     *             temp(nt3p1),temp(nt4p1),mm1,m,1,zp(2,1,3))
      return
c
c error conditions
c
c problem dimensions too small
c
    1 ierr = 1
      return
c
c grid values not strictly increasing
c
    2 ierr = 2
      return
c
c range of theta-values too large
c
    3 ierr = 4
      return
c
c missing pole
c
    5 ierr = 3
      return
      end
      function surfd2(rr,tt,m,n,r,theta,z,iz,zp,istar,sigma)
c
      integer m,n,iz
      real    rr,tt,r(m),theta(n),z(iz,n),zp(m,n,3),sigma
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function interpolates a surface at the point (rr,tt)
c using a bi-spline under tension when the surface is per-
c iodic in the second independent variable and has one pole
c in the first independent variable.  subroutine surfd1
c should have been called previously to determine certain
c necessary parameters.
c
c on input--
c
c   rr and tt contain the r- and theta-coordinates of the
c   point to be mapped onto the interpolating surface.
c
c   m and n contain the number of grid lines in the r- and
c   theta-directions, respectively, of the grid which spec-
c   ified the surface.
c
c   r and theta are arrays containing the r- and theta-
c   grid values, respectively.  the r-array must be strictly
c   increasing.  if 360 is added to all theta array elements
c   whose index is istar or greater, then the resulting
c   array is strictly increasing.
c
c   z is an array of m * n function values.  in cylindrical
c   coordinates, (r(i),theta(j),z(i,j)) is a point on the
c   surface being interpolated.
c
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3 * m * n locations containing the
c   surface derivative information determined by surfd1.
c
c   istar is the index for theta(istar-1) .gt. theta(istar).
c   istar is zero if the theta values are strictly increasing.
c
c and
c
c   sigma contains the tension factor.
c
c the parameters m, n, r, t, z, iz, sigma, zp, and istar
c should be input unaltered from the output of surfd1.
c
c on output--
c
c   surfd2 is the interpolated surface value.
c
c and
c
c   the input parameters are unaltered.
c
c this module references package modules intrvl, intrvp, and
c snhcsh.
c
c-----------------------------------------------------------
c
c cubic spline - f1,fpp1,f2,fpp2 basis
c
      herz(f1,fpp1,f2,fpp2) = (f1*del2+f2*del1)/h
     *    -del1*del2*(fpp1*(del2+h)+fpp2*(del1+h))/(6.*h)
c
c cubic spline - f1,fp1,f2,fpp2 basis
c
      herzp(f1,fp1,f2,fpp2) = (-f1*del2*(del2*del2-3.*h*h)
     *     +f2*del1*del1*(del2+2.*h))/(2.*h*h*h)
     *     +(fp1*(2.*h-del1)/(2.*h)-fpp2*del1/4.)
     *     *del1*del2/h
c
c tension spline
c
      hernz (f1,fpp1,f2,fpp2) = c1*f1+cpp1*fpp1+c2*f2+
     *                          cpp2*fpp2
c
c denormalize tension factor
c
      pt = 360.
      sigmar = abs(sigma)*float(m-1)/(r(m)-r(1))
      sigmat = abs(sigma)*float(n)/pt
c
c locate (rr,tt) within r-grid , set up theta interpolation
c
      i = intrvl(rr,r,m)
      ip1 = i+1
      if (istar .ne. 0) go to 2
c
c monotonic theta-values
c
      j = intrvp(tt,theta,n,pt,tp)
      if (j .eq. n) go to 1
      jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tp-theta(j)
      del2 = theta(jp1)-tp
      go to 6
    1 jp1 = 1
      h = pt-(theta(n)-theta(1))
      del1 = tp-theta(j)
      del2 = theta(jp1)+pt-tp
      go to 6
c
c non-monotonic theta-values
c
    2 j = intrvp(tt,theta,istar-1,pt,tp)
      if (tp .gt. theta(istar-1)) go to 3
      jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tp-theta(j)
      del2 = theta(jp1)-tp
      go to 6
    3 if (tp .lt. theta(istar)+360. .or. tp .gt. theta(n)+360.)
     *   go to 4
      j = intrvl(tp,theta(istar),n-istar+1)+istar-1
      jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tp-theta(j)
      del2 = theta(jp1)-tp
      go to 6
    4 if (tp .le. theta(n)+360.) go to 5
      j = n
      jp1 = 1
      h = theta(1)+pt-(theta(n)+360.)
      del1 = theta(1)+pt-tp
      del2 = tp-theta(n)+360.
      go to 6
    5 j = istar-1
      jp1 = istar
      h = theta(istar)+360.-theta(istar-1)
      del1 = tp-theta(istar-1)
      del2 = theta(istar)+360.-tp
    6 if (sigma .ne. 0.) go to 8
c
c
c cubic spline interpolation
c
c
c interpolate in theta direction
c
      fip1 = herz(z(ip1,j),zp(ip1,j,2),z(ip1,jp1),
     *       zp(ip1,jp1,2))
      frrip1 = herz(zp(ip1,j,1),zp(ip1,j,3),zp(ip1,jp1,1),
     *         zp(ip1,jp1,3))
      if (r(1) .eq. 0. .and. i .eq. 1) go to 7
c
c no pole
c
      fi = herz(z(i,j),zp(i,j,2),z(i,jp1),zp(i,jp1,2))
      frri = herz(zp(i,j,1),zp(i,j,3),zp(i,jp1,1),
     *       zp(i,jp1,3))
c
c interpolate in r direction
c
      h = r(ip1)-r(i)
      del1 = rr-r(i)
      del2 = r(ip1)-rr
c
       surfd2 = herz(fi,frri,fip1,frrip1)
      return
c
c pole
c
    7 fi = z(1,1)
      fact = atan(1.)/45.
      fri  = zp(1,1,3)*cos(tt*fact)+zp(1,2,3)*sin(tt*fact)
      h = r(ip1)-r(i)
      del1 = rr-r(i)
      del2 = r(ip1)-rr
c
      surfd2 = herzp(fi,fri,fip1,frrip1)
      return
c
c
c spline under tension interpolation
c
c
c theta direction
c
    8 call snhcsh(sinhm1,dummy,sigmat*del1,-1)
      call snhcsh(sinhm2,dummy,sigmat*del2,-1)
      call snhcsh(sinhmh,dummy,sigmat*h,-1)
      c1 = del2/h
      c2 = del1/h
      denom = sigmat*sigmat*h*(1.+sinhmh)
      cpp1 = del2*(sinhm2-sinhmh)/denom
      cpp2 = del1*(sinhm1-sinhmh)/denom
c
      fip1 = hernz(z(ip1,j),zp(ip1,j,2),z(ip1,jp1),
     *             zp(ip1,jp1,2))
      frrip1 = hernz(zp(ip1,j,1),zp(ip1,j,3),zp(ip1,jp1,1),
     *               zp(ip1,jp1,3))
c
      if (r(1) .eq. 0. .and. i .eq. 1) go to 9
c
c no pole
c
      fi = hernz(z(i,j),zp(i,j,2),z(i,jp1),zp(i,jp1,2))
      frri = hernz(zp(i,j,1),zp(i,j,3),zp(i,jp1,1),
     *             zp(i,jp1,3))
c
c r direction
c
      h = r(ip1)-r(i)
      del1 = rr-r(i)
      del2 = r(ip1)-rr
      call snhcsh(sinhm1,dummy,sigmar*del1,-1)
      call snhcsh(sinhm2,dummy,sigmar*del2,-1)
      call snhcsh(sinhmh,dummy,sigmar*h,-1)
      c1 = del2/h
      c2 = del1/h
      denom = sigmar*sigmar*h*(1.+sinhmh)
      cpp1 = del2*(sinhm2-sinhmh)/denom
      cpp2 = del1*(sinhm1-sinhmh)/denom
c
      surfd2 = hernz(fi,frri,fip1,frrip1)
c
      return
c
c pole
c
    9 fi = z(1,1)
      fact = atan(1.)/45.
      fri = (zp(1,1,3)*cos(tt*fact)+zp(1,2,3)*sin(tt*fact))
c
c r direction
c
      h = r(ip1)-r(i)
      del1 = rr-r(i)
      del2 = r(ip1)-rr
      call snhcsh(sinhm1,dummy,sigmar*del1,-1)
      call snhcsh(sinhm2,dummy,sigmar*del2,-1)
      call snhcsh(sinhmh,coshmh,sigmar*h,0)
      c1 = del2*(sinhm2-coshmh)/(h*(sinhmh-coshmh))
      cpp1 = del2*(sinhm2-sinhmh)/(sinhmh-coshmh)
      c2 = (del1-cpp1)/h
      cpp2 = (del1*(sinhm1-sinhmh)+cpp1*sinhmh)/
     *       (sigmar*sigmar*h*(1.+sinhmh))
c
      surfd2 = hernz(fi,fri,fip1,frrip1)
c
      return
      end
      subroutine surft1(m,n,r,theta,pr,pt,z,iz,zp,temp,
     *                  sigma,istar,ierr)
c
      integer m,n,iz,istar,ierr
      real    r(m),theta(n),pr,pt,z(iz,n),zp(m,n,3),temp(1),
     *        sigma
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through function
c values specified on a grid which is periodic and non-polar
c in both variables.  the surface determined can be re-
c presented as the tensor product of splines under tension.
c for actual maping of the points onto the surface it is
c necessary to call the function surft2.
c
c on input--
c
c   m is the  number of r-values in the grid (m .ge. 2).
c
c   n is the number of theta-values in the grid (n .ge. 2).
c
c   r is an array of the m r-coordinates in the grid.
c   these should be strictly increasing.
c
c   theta is an array of the n theta-coordinates in the
c   grid.  if a ray with its endpoint at the origin sweeps
c   the plane from theta(1) to theta(2) to ... to theta(n),
c   it must move continuously in a counterclockwise direc-
c   tion.  either the sequence is strictly increasing and
c   satisfies theta(n)-theta(1) .lt. pt, or theta(n) .lt.
c   theta(1) and there is an index, istar, so that if the
c   elements of the sequence whose indices are greater than
c   or equal to istar are increased by pt, then the sequence
c   is strictly increasing.
c
c   pr is the period for r.  pr .gt. abs(r(m)-r(1)).
c
c   pt is the period for theta.
c
c   z is an array of the m * n functional values at the
c   grid points.  z(i,j) contains the functional value at
c   (r(i),theta(j)) for i = 1,...,m and j = 1,...,n.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   zp is an array of at least 3 * m * n locations.
c
c   temp is an array of at least 5 * max(m,n) locations
c   which is used for scratch storage.
c
c and
c
c   sigma contains the tension factor.  this value indicates
c   the curviness desired.  if abs(sigma) is nearly zero (e.
c   g. .001) the resulting surface is approximately the ten-
c   sor product of cubic splines.  if abs(sigma) is large
c   (e.g. 50.) the resulting surface is approximately bi-
c   linear.  if sigma equals zero, tensor products of cubic
c   splines result.  a standard value for sigma is approx-
c   imately 1. in absolute value.
c
c on output--
c
c   zp contains the partial derivative values necessary for
c   evaluation of the function.
c
c   istar is the index in the theta-domain where
c         theta(istar-1) .gt. theta(istar).
c   istar = 0 if the theta-values are strictly increasing.
c
c   ierr contains an error flag,
c        = 0 if normal return,
c        = 1 if n .lt. 2 .or. m .lt. 2,
c        = 2 if r values are not strictly increasing or if
c            theta values are not specified correctly,
c        = 4 if period is too small for data.
c
c and
c
c   the input parameters are unaltered.
c
c this subroutine references package modules ceez, chekin,
c delr, matnp, rhsnp, snhcsh, terms, tridep, and trisop
c and blas modules saxpy, scopy, and sscal.
c
c-----------------------------------------------------------
c
c check input
c
      if (n .lt. 2 .or. m .lt. 2) go to 1
      call chekin(n,theta,istar,ierr)
      if (ierr .ne. 0) return
      if (((istar .eq. 0) .and. (theta(n)-theta(1) .gt. pt))
     *                    .or.
     *    ((istar .gt. 0) .and. ((theta(n) .gt. theta(1))
     * .or. (theta(istar-1)-theta(istar) .gt. pt)))) go to 3
      delrm1 = r(m)-r(1)
      if (delrm1 .le. 0) go to 2
      if (pr .le. delrm1) go to 3
      call chekin(m,r,idum,ierr)
      if (ierr .ne. 0) return
      np1 = n+1
      nt2p1 = np1+n
      nt3p1 = nt2p1+n
      nt4p1 = nt3p1+n
      mp1 = m+1
      mt2p1 = mp1+m
      mt3p1 = mt2p1+m
      mt4p1 = mt3p1+m
c
c denormalize tension factor
c
      sigmar = abs(sigma)*float(m)/pr
      sigmat = abs(sigma)*float(n)/pt
c
c set up and solve systems in r-direction
c
      call rhsnp(n,m,pr,1,iz,z,r,1,m,zp)
      call matnp(m,pr,sigmar,r,temp(1),temp(mp1),c)
      call tridep(m,c,temp(1),temp(mp1),temp(mt2p1),
     *            temp(mt3p1),temp(mt4p1))
      call trisop(m,temp(1),temp(mp1),temp(mt2p1),
     *            temp(mt3p1),temp(mt4p1),n,1,m,zp)
c
c set up and solve systems in t-direction
c
      call rhsnp(m,n,pt,iz,1,z,theta,m,1,zp(1,1,2))
      call rhsnp(m,n,pt,m,1,zp(1,1,1),theta,m,1,zp(1,1,3))
      call matnp(n,pt,sigmat,theta,temp(1),temp(np1),c)
      call tridep(n,c,temp(1),temp(np1),temp(nt2p1),
     *            temp(nt3p1),temp(nt4p1))
      call trisop(n,temp(1),temp(np1),temp(nt2p1),
     *            temp(nt3p1),temp(nt4p1),m,m,1,zp(1,1,2))
      call trisop(n,temp(1),temp(np1),temp(nt2p1),
     *            temp(nt3p1),temp(nt4p1),m,m,1,zp(1,1,3))
c
      return
c
c error conditions
c
c
c problem dimensions too small
c
    1 ierr = 1
      return
c
c grid values not strictly increasing
c
    2 ierr = 2
      return
c
c period too small
c
    3 ierr = 4
      return
      end
      function surft2(rr,tt,m,n,r,theta,pr,pt,z,iz,zp,
     *                istar,sigma)
c
      integer m,n,iz,istar
      real    rr,tt,r(m),theta(n),pr,pt,z(iz,n),zp(m,n,3),
     *        sigma
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function interpolates a surface at the point (rr,tt)
c using a bi-spline under tension when the surface is per-
c iodic in both variables and non-polar in both variables.
c subroutine surft1 should have been called previously to
c determine certain necessary parameters .
c
c on input--
c
c   rr and tt contain the r- and theta-coordinates of the
c   point to be mapped onto the interpolating surface.
c
c   m and n contain the number of grid lines in the r- and
c   theta-directions, respectively, of the grid which spec-
c   ified the surface.
c
c   r and theta are arrays containing the r- and theta-
c   grid values, respectively.  the r-array must be strictly
c   increasing.  if p is added to all theta array elements
c   whose index is istar or greater, then the resulting
c   array is strictly increasing.
c
c   pr is the period for r.
c
c   pt is the period for theta.
c
c   z is an array of m * n function values.  in cylindrical
c   coordinates, (r(i),theta(j),z(i,j)) is a point on the
c   surface being interpolated.
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3 * m * n locations containing the
c   surface derivative information determined by surft1.
c
c   istar is the index where
c         theta(istar-1) .gt. theta(istar).
c   istar is zero if the theta values are strictly increas-
c   ing.
c
c and
c
c   sigma contains the tension factor.
c
c the parameters m, n, r, t, pr, pt, z, iz, sigma, zp, and
c istar should be input unaltered from the output of surft1.
c
c on output--
c
c   surft2 is the interpolated surface value.
c
c and
c
c   the input parameters are unaltered.
c
c this module references package modules intrvl, intrvp and
c snhcsh.
c
c-----------------------------------------------------------
c
c cubic spline - f1,fpp1,f2,fpp2 basis
c
      herz(f1,fpp1,f2,fpp2) = (f1*del2+f2*del1)/h
     *    -del1*del2*(fpp1*(del2+h)+fpp2*(del1+h))/(6.*h)
c
c tension spline
c
      hernz (f1,fpp1,f2,fpp2) = c1*f1+cpp1*fpp1+c2*f2+
     *                          cpp2*fpp2
c
c denormalize tension factor
c
      sigmar = abs(sigma)*float(m-1)/(r(m)-r(1))
      sigmat = abs(sigma)*float(n)/pt
c
c locate (rr,tt) within r-grid , set up theta interpolation
c
      i = intrvp(rr,r,m,pr,rp)
      ip1 = i+1
      if (i .eq. m) ip1 = 1
      if (istar .ne. 0) go to 2
c
c monotonic theta-values
c
      j = intrvp(tt,theta,n,pt,tp)
      if (j .eq. n) go to 1
      jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tp-theta(j)
      del2 = theta(jp1)-tp
      go to 6
    1 jp1 = 1
      h = pt-(theta(n)-theta(1))
      del1 = tp-theta(j)
      del2 = theta(jp1)+pt-tp
      go to 6
c
c non-monotonic theta-values
c
    2 j = intrvp(tt,theta,istar-1,pt,tp)
      if (tp .gt. theta(istar-1)) go to 3
      jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tp-theta(j)
      del2 = theta(jp1)-tp
      go to 6
    3 if (tp .lt. theta(istar)+360. .or.
     *    tp .gt. theta(n)+360.) go to 4
      j = intrvl(tp,theta(istar),n-istar+1)+istar-1
      jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tp-theta(j)
      del2 = theta(jp1)-tp
      go to 6
    4 if (tp .le. theta(n)+360.) go to 5
      j = n
      jp1 = 1
      h = theta(1)+pt-(theta(n)+360.)
      del1 = theta(1)+pt-tp
      del2 = tp-theta(n)+360.
      go to 6
    5 j = istar-1
      jp1 = istar
      h = theta(istar)+360.-theta(istar-1)
      del1 = tp-theta(istar-1)
      del2 = theta(istar)+360.-tp
    6 if (sigma .ne. 0.) go to 8
c
c
c cubic spline interpolation
c
c
c interpolate in theta direction
c
      fip1 = herz(z(ip1,j),zp(ip1,j,2),z(ip1,jp1),
     *       zp(ip1,jp1,2))
      frrip1 = herz(zp(ip1,j,1),zp(ip1,j,3),zp(ip1,jp1,1),
     *         zp(ip1,jp1,3))
      fi = herz(z(i,j),zp(i,j,2),z(i,jp1),zp(i,jp1,2))
      frri = herz(zp(i,j,1),zp(i,j,3),zp(i,jp1,1),
     *       zp(i,jp1,3))
c
c interpolate in r direction
c
      if (i .eq. m) go to 7
      h = r(ip1)-r(i)
      del1 = rp-r(i)
      del2 = r(ip1)-rp
c
       surft2 = herz(fi,frri,fip1,frrip1)
      return
    7 h = pr-(r(m)-r(1))
      del1 = rp-r(i)
      del2 = r(1)+pr-rp
      surft2 = herz(fi,frri,fip1,frrip1)
      return
c
c
c spline under tension interpolation
c
c
c theta direction
c
    8 call snhcsh(sinhm1,dummy,sigmat*del1,-1)
      call snhcsh(sinhm2,dummy,sigmat*del2,-1)
      call snhcsh(sinhmh,dummy,sigmat*h,-1)
      c1 = del2/h
      c2 = del1/h
      denom = sigmat*sigmat*h*(1.+sinhmh)
      cpp1 = del2*(sinhm2-sinhmh)/denom
      cpp2 = del1*(sinhm1-sinhmh)/denom
c
      fip1 = hernz(z(ip1,j),zp(ip1,j,2),z(ip1,jp1),
     *             zp(ip1,jp1,2))
      frrip1 = hernz(zp(ip1,j,1),zp(ip1,j,3),zp(ip1,jp1,1),
     *               zp(ip1,jp1,3))
      fi = hernz(z(i,j),zp(i,j,2),z(i,jp1),zp(i,jp1,2))
      frri = hernz(zp(i,j,1),zp(i,j,3),zp(i,jp1,1),
     *             zp(i,jp1,3))
c
c r direction
c
      if (i .eq. m) go to 9
      h = r(ip1)-r(i)
      del1 = rp-r(i)
      del2 = r(ip1)-rp
      go to 10
    9 h = pr-(r(m)-r(1))
      del1 = rp-r(i)
      del2 = r(1)+pr-rp
   10 call snhcsh(sinhm1,dummy,sigmar*del1,-1)
      call snhcsh(sinhm2,dummy,sigmar*del2,-1)
      call snhcsh(sinhmh,dummy,sigmar*h,-1)
      c1 = del2/h
      c2 = del1/h
      denom = sigmar*sigmar*h*(1.+sinhmh)
      cpp1 = del2*(sinhm2-sinhmh)/denom
      cpp2 = del1*(sinhm1-sinhmh)/denom
c
      surft2 = hernz(fi,frri,fip1,frrip1)
c
      return
      end
      subroutine surfl1(m,n,phi,theta,rho,ir,rp10,rp190,
     *                rpm0,rpm90,rt1,rtn,islpsw,rp,temp,
     *                sigma,istar,ierr)
c
      integer m,n,ir,islpsw,ierr,istar
      real    phi(m),theta(n),rho(ir,n),rp10,rp190,rpm0,
     *        rpm90,rt1(m),rtn(m),rp(m,n,3),temp(1),sigma
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through function
c values specified on a grid which is non-periodic in both
c variables and has two poles in the first independent var-
c iable.  the surface determined can be represented as the
c tensor product of splines under tension.  certain partial
c derivatives at the boundary are needed.  these may be
c specified or omitted.  for actual mapping of the points
c onto the surface it is necessary to call the function
c surfl2.
c
c on input--
c
c   m is the number of phi-values in the grid (m .ge. 3).
c
c   n is the number of theta values in the grid (n .ge. 2).
c
c   phi is an array of the m phi-coordinates in the grid.
c   phi(1) = -90, phi(m) = +90, and the values should be
c   strictly increasing.
c
c   theta is an array of the n theta-coordinates in the
c   grid.  if a ray with its endpoint at the origin sweeps
c   the plane from theta(1) to theta(2) to...to theta(n), it
c   must move continuously in a counterclockwise direction.
c   either the sequence is strictly increasing and satisfies
c   theta(n)-theta(1) .lt. 360., or theta(n) .lt. theta(1)
c   and there is an index, istar, so that if the elements of
c   the sequence whose indices are greater than or equal to
c   istar are increased by 360., then the sequence is str-
c   ictly increasing.
c
c   rho is an array of the m * n function values at the
c   grid points.  rho(i,j) contains the function value at
c   (phi(i),theta(j)) for i = 1,...,m and j = 1,...,n.
c
c   ir is the row dimension of the matrix rho used in the
c   calling program (iz .ge. m).
c
c   rp10 is the value of the partial derivative with respect
c   to phi at (-90,0).
c
c   rp190 is the value of the partial derivative with res-
c   pect to phi at (-90,90).
c
c   rpm0 is the value of the partial derivative with respect
c   to phi at (+90,0).
c
c   rpm90 is the value of the partial derivative with re-
c   spect to  phi at (+90.,90.).
c
c   rt1 is an array of m partial derivatives  with re-
c   spect to theta along the curve theta = theta(1).  rt1(i)
c   is the partial derivative with respect to theta at
c   (phi(i),theta(1)) for i = 1,...,m.
c
c   rtn is an array of m partial derivatives with re-
c   spect to theta along the curve theta = theta(n).  rtn(i)
c   is the partial derivative with respect to theta at
c   (phi(i),theta(n)) for i = 1,...,m.
c
c   islpsw is a switch indicating which boundary derivative
c   information is user supplied and which is to be estim-
c   ated. islpsw is an 4-digit decimal number.  a zero digit
c   signifies that the corresponding derivative(s) is
c   supplied.  a non-zero digit instructs the module to
c   approximate the derivatives.  from left to right the
c   derivatives are
c
c     rtn  rt1  rpm0   rp10
c               rpm90  rp190
c
c   islpsw = 0 means all derivatives are supplied.
c   islpsw = 1111 means all derivatives will be
c   approximated.
c
c   rp is an array of at least 3 * m * n locations.
c
c   temp is an array of at least 3 * max(m,n) locations
c   which is used for scratch storage.
c
c and
c
c   sigma contains the tension factor.  this value indicates
c   the curviness desired.  if abs(sigma) is nearly zero (e.
c   g. .001) the resulting surface is approximately the ten-
c   sor product of cubic splines.  if abs(sigma) is large
c   (e.g. 50.) the resulting surface is approximately bi-
c   linear.  if sigma equals zero, tensor products of cubic
c   splines result.  a standard value for sigma is approx-
c   imately 1. in absolute value.
c
c on output--
c
c   rp contains the partial derivative values necessary for
c   evaluation of the function.
c
c   istar is the index where
c        theta(istar-1) .gt. theta(istar).
c   istar = 0 if the theta-values are strictly increasing.
c
c   ierr contains an error flag,
c        = 0 if normal return,
c        = 1 if n .lt. 2 or m .lt. 3,
c        = 2 if phi values are not strictly increasing or
c            if theta values are not specified correctly,
c        = 3 if phi(1) and phi(m) are not poles,
c        = 4 if the range of theta-values is too large.
c
c and
c
c   m, n, phi, theta, rho, ir, islpsw, rp10, rp190, rpm0,
c   rpm90, rt1, rtn, and sigma are unaltered.
c
c this subroutine references package modules bdryn, bdryp,
c ceez, chekin, delr, lstsq, matnn, rhsnn, snhcsh, terms,
c trdec, and trsol and blas modules saxpy, scopy, sdot,
c snrm2, and sscal.
c
c-----------------------------------------------------------
c
c check input
c
      if (n .lt. 2 .or. m .lt. 3) go to 1
      if (phi(1) .ne. -90. .or. phi(m) .ne. 90.) go to 3
      call chekin(n,theta,istar,ierr)
      if (ierr .ne. 0) return
      if (((istar .eq. 0).and.(theta(n)-theta(1) .gt. 360.))
     *                    .or.
     *    ((istar .gt. 0) .and. ((theta(n) .gt. theta(1))
     *                                     .or.
     *   (theta(istar-1)-theta(istar) .gt. 360.)))) go to 4
      delpm1 = phi(m)-phi(1)
      deltn1 = theta(n)-theta(1)+180.+
     *         sign(180.,theta(1)-theta(n))
      if (delpm1 .le. 0. .or. deltn1 .eq. 0.) go to 2
      call chekin(m,phi,idum,ierr)
      if (ierr .ne. 0) return
      nm1 = n-1
      nm2 = n-2
      np1 = n+1
      nt2p1 = np1+n
      nm1tm = (n-1)*m
      mm1 = m-1
      mm2 = m-2
      mp1 = m+1
      mt2p1 = mp1+m
      fact = atan(1.)/45.
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(mm1)/delpm1
      sigmat = abs(sigma)*float(nm1)/deltn1
c
c obtain boundary derivatives
c
      call bdryp(m,n,(islpsw/10)*10-islpsw,rp10,rp190,
     *           phi(1),phi(2),phi(3),ir,rho(1,1),rho(2,1),
     *           rho(3,1),sigmap,theta,m,rp(1,1,1),dd10,
     *           dd190,temp,ierr)
c
      call bdryp(m,n,(islpsw/100)*10-islpsw/10,rpm0,
     *           rpm90,phi(m),phi(mm1),phi(mm2),ir,
     *           rho(m,1),rho(mm1,1),rho(mm2,1),
     *           sigmap,theta,m,rp(m,1,1),ddm0,ddm90,
     *           temp,ierr)
c
      fact1 = fact*theta(1)
      factn = fact*theta(n)
      rp(1,1,3) = fact*(dd190*cos(fact1)-dd10*sin(fact1))
      rp(1,n,3) = fact*(dd190*cos(factn)-dd10*sin(factn))
      rp(m,1,3) = fact*(ddm90*cos(fact1)-ddm0*sin(fact1))
      rp(m,n,3) = fact*(ddm90*cos(factn)-ddm0*sin(factn))
c
      call bdryn(n,m,(islpsw/1000)*100-islpsw/100,istar,
     *          1,rt1,theta(1),theta(2),theta(3),1,rho(1,1),
     *           rho(1,2),rho(1,3),sigmat,1,rp(1,1,2),ierr)
c
      call bdryn(n,m,(islpsw/10000)*1000-islpsw/1000,istar,
     *      1,rtn,theta(n),theta(nm1),theta(nm2),1,rho(1,n),
     *        rho(1,nm1),rho(1,nm2),sigmat,1,rp(1,n,2),ierr)
c
c set up and solve systems in phi-direction
c
      call rhsnn(n,m,1,ir,rho,phi,m,rp(1,1,1),rp(m,1,1),1,m,
     *           rp(1,1,1))
      call rhsnn(2,m,1,nm1tm,rp(1,1,2),phi,nm1tm,rp(1,1,3),
     *           rp(m,1,3),1,nm1tm,rp(1,1,3))
      call matnn(m,sigmap,phi,temp(1),temp(mp1))
      call trdec(m,temp(1),temp(mp1),temp(mt2p1))
      call trsol(m,n,1,m,temp(mt2p1),temp(1),temp(mp1),
     *            rp(1,1,1))
      call trsol(m,2,1,nm1tm,temp(mt2p1),temp(1),temp(mp1),
     *            rp(1,1,3))
c
c save dd*s for later
c
      rp(1,1,3) = dd10
      rp(1,2,3) = dd190
      rp(m,1,3) = ddm0
      rp(m,2,3) = ddm90
c
c set up and solve systems in theta-direction
c
      call rhsnn(m,n,ir,1,rho,theta,1,rp(1,1,2),rp(1,n,2),
     *           m,1,rp(1,1,2))
      call rhsnn(mm2,n,m,1,rp(2,1,1),theta,1,rp(2,1,3),
     *           rp(2,n,3),m,1,rp(2,1,3))
      call matnn(n,sigmat,theta,temp(1),temp(np1))
      call trdec(n,temp(1),temp(np1),temp(nt2p1))
      call trsol(n,m,m,1,temp(nt2p1),temp(1),temp(np1),
     *            rp(1,1,2))
      call trsol(n,mm2,m,1,temp(nt2p1),temp(1),temp(np1),
     *            rp(2,1,3))
      return
c
c error conditions
c
c problem dimensions too small
c
    1 ierr = 1
      return
c
c grid values not strictly increasing
c
    2 ierr = 2
      return
c
c missing pole(s)
c
    3 ierr = 3
      return
c range of theta-values too large
c
    4 ierr = 4
      return
c
      end
      function surfl2(pp,tt,m,n,phi,theta,r,ir,rp,istar,sigma)
c
      integer m,n,ir
      real    pp,tt,phi(m),theta(n),r(ir,n),rp(m,n,3),sigma
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function interpolates a surface at the point (pp,tt)
c using a bi-spline under tension when the surface is non-
c periodic in both variables and has two poles in the first
c independent variable.  surfl1 should have been called
c previously to determine certain necessary parameters.
c
c on input--
c
c   pp and tt contain the phi- and theta-coordinates of the
c   point to be mapped onto the interpolating surface.
c
c   m and n contain the number of grid lines in the phi- and
c   theta-directions, respectively, of the grid which spec-
c   ified the surface.
c
c   phi and theta are arrays containing the phi- and theta-
c   grid values, respectively.  the phi-array must be str-
c   ictly increasing.  if 360. is added to all theta-array
c   elements whose index is istar or greater, then the
c   resulting array is strictly increasing.
c
c   r is an array of m * n function values.  in spherical
c   coordinates, (phi(i),theta(j),r(i,j)) is a point on the
c   surface being interpolated.
c
c   ir contains the row dimension of the array r as declared
c   in the calling program.
c
c   rp is an array of 3 * m * n locations containing the
c   surface derivative information determined by surfl1.
c
c   istar is the index where
c        theta(istar-1) .gt. theta(istar)
c   istar is zero if the theta values are strictly increasing.
c
c and
c
c   sigma contains the tension factor.
c
c the parameters m, n, phi, theta, r, ir, sigma, rp, and
c istar should be input unaltered from the output of surfl1.
c
c
c on output--
c
c   surfl2 is the interpolated surface value.
c
c and
c
c   the input parameters are unaltered.
c
c this module references package modules intrvl and snhcsh.
c
c-----------------------------------------------------------
c
c cubic spline - f1,fpp1,f2,fpp2 basis
c
      herz(f1,fpp1,f2,fpp2) = (f1*del2+f2*del1)/h
     *    -del1*del2*(fpp1*(del2+h)+fpp2*(del1+h))/(6.*h)
c
c cubic spline - f1,fp1,f2,fpp2 basis
c
      herzp(f1,fp1,f2,fpp2) = (-f1*del2*(del2*del2-3.*h*h)
     *     +f2*del1*del1*(del2+2.*h))/(2.*h*h*h)
     *     +(fp1*(2.*h-del1)/(2.*h)-fpp2*del1/4.)
     *     *del1*del2/h
c
c tension spline
c
      hernz (f1,fpp1,f2,fpp2) = c1*f1+cpp1*fpp1+c2*f2+
     *                          cpp2*fpp2
c
c denormalize tension factor
c
      sigmar = abs(sigma)*float(m-1)/(phi(m)-phi(1))
      sigmat = abs(sigma)*float(n-1)/(theta(n)-theta(1)+180.
     *                                +sign(180.,theta(1)-theta(n)))
c
c locate (pp,tt) within r-grid , set up theta interpolation
c
      i = intrvl(pp,phi,m)
      ip1 = i+1
      if (istar .ne. 0) go to 1
      j = intrvl(tt,theta,n)
      go to 3
    1 if (tt .lt. theta(istar) .or. tt .gt. theta(istar-1)) go to 2
      if (tt .le. theta(n)) j = intrvl(tt,theta(istar),n-istar+1)+
     *                    istar-1
      if (tt .gt. theta(n)) j = intrvl(tt,theta,istar-1)
      go to 3
    2 h = theta(istar)+360.-theta(istar-1)
      del1 = tt-theta(istar-1)+180.+sign(180.,theta(istar-1)-tt)
      del2 = theta(istar)-tt+180.+sign(180.,tt-theta(istar))
      j = istar-1
      jp1 = istar
      go to 4
    3 jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tt-theta(j)
      del2 = theta(jp1)-tt
c
    4 if (sigma .ne. 0.) go to 7
c
c
c cubic spline interpolation
c
      if (phi(1) .eq. -90. .and. i .eq. 1) go to 5
      if (phi(m) .eq. +90. .and. ip1 .eq. m) go to 6
c
c no pole
c
      fip1 = herz(r(ip1,j),rp(ip1,j,2),r(ip1,jp1),
     *       rp(ip1,jp1,2))
      fppip1 = herz(rp(ip1,j,1),rp(ip1,j,3),rp(ip1,jp1,1),
     *         rp(ip1,jp1,3))
      fi = herz(r(i,j),rp(i,j,2),r(i,jp1),rp(i,jp1,2))
      fppi = herz(rp(i,j,1),rp(i,j,3),rp(i,jp1,1),
     *       rp(i,jp1,3))
      h = phi(ip1)-phi(i)
      del1 = pp-phi(i)
      del2 = phi(ip1)-pp
c
       surfl2 = herz(fi,fppi,fip1,fppip1)
      return
c
c south pole
c
    5 fip1 = herz(r(ip1,j),rp(ip1,j,2),r(ip1,jp1),
     *            rp(ip1,jp1,2))
      fppip1 = herz(rp(ip1,j,1),rp(ip1,j,3),rp(ip1,jp1,1),
     *              rp(ip1,jp1,3))
      fi = r(1,1)
      fact = atan(1.)/45.
      fpi  = rp(1,1,3)*cos(tt*fact)+rp(1,2,3)*sin(tt*fact)
      h = phi(ip1)-phi(i)
      del1 = pp-phi(i)
      del2 = phi(ip1)-pp
      surfl2 = herzp(fi,fpi,fip1,fppip1)
      return
c
c north pole
c
    6 fi = herz(r(i,j),rp(i,j,2),r(i,jp1),rp(i,jp1,2))
      fppi = herz(rp(i,j,1),rp(i,j,3),rp(i,jp1,1),
     *            rp(i,jp1,3))
      fip1 = r(m,1)
      fact = atan(1.)/45.
      fpip1 = rp(m,1,3)*cos(tt*fact)+rp(m,2,3)*sin(tt*fact)
      h = phi(ip1)-phi(i)
      del1 = phi(ip1)-pp
      del2 = pp-phi(i)
      surfl2 = herzp(fip1,fpip1,fi,fppi)
      return
c
c
c spline under tension interpolation
c
c
c theta direction
c
    7 call snhcsh(sinhm1,dummy,sigmat*del1,-1)
      call snhcsh(sinhm2,dummy,sigmat*del2,-1)
      call snhcsh(sinhmh,dummy,sigmat*h,-1)
      c1 = del2/h
      c2 = del1/h
      denom = sigmat*sigmat*h*(1.+sinhmh)
      cpp1 = del2*(sinhm2-sinhmh)/denom
      cpp2 = del1*(sinhm1-sinhmh)/denom
c
      if (phi(1) .eq. -90. .and. i .eq. 1) go to 8
      if (phi(m) .eq. +90. .and. ip1 .eq. m) go to 9
c
c no pole
c
      fip1 = hernz(r(ip1,j),rp(ip1,j,2),r(ip1,jp1),
     *             rp(ip1,jp1,2))
      fppip1 = hernz(rp(ip1,j,1),rp(ip1,j,3),rp(ip1,jp1,1),
     *               rp(ip1,jp1,3))
      fi = hernz(r(i,j),rp(i,j,2),r(i,jp1),rp(i,jp1,2))
      fppi = hernz(rp(i,j,1),rp(i,j,3),rp(i,jp1,1),
     *             rp(i,jp1,3))
c
c r direction
c
      h = phi(ip1)-phi(i)
      del1 = pp-phi(i)
      del2 = phi(ip1)-pp
      call snhcsh(sinhm1,dummy,sigmar*del1,-1)
      call snhcsh(sinhm2,dummy,sigmar*del2,-1)
      call snhcsh(sinhmh,dummy,sigmar*h,-1)
      c1 = del2/h
      c2 = del1/h
      denom = sigmar*sigmar*h*(1.+sinhmh)
      cpp1 = del2*(sinhm2-sinhmh)/denom
      cpp2 = del1*(sinhm1-sinhmh)/denom
      surfl2 = hernz(fi,fppi,fip1,fppip1)
      return
c
c south pole
c
   8  fip1 = hernz(r(ip1,j),rp(ip1,j,2),r(ip1,jp1),
     *             rp(ip1,jp1,2))
      fppip1 = hernz(rp(ip1,j,1),rp(ip1,j,3),
     *               rp(ip1,jp1,1),rp(ip1,jp1,3))
      fi = r(1,1)
      fact = atan(1.)/45.
      fpi = (rp(1,1,3)*cos(tt*fact)+rp(1,2,3)*sin(tt*fact))
c
      h = phi(ip1)-phi(i)
      del1 = pp-phi(i)
      del2 = phi(ip1)-pp
      call snhcsh(sinhm1,dummy,sigmar*del1,-1)
      call snhcsh(sinhm2,dummy,sigmar*del2,-1)
      call snhcsh(sinhmh,coshmh,sigmar*h,0)
      c1 = del2*(sinhm2-coshmh)/(h*(sinhmh-coshmh))
      cpp1 = del2*(sinhm2-sinhmh)/(sinhmh-coshmh)
      c2 = (del1-cpp1)/h
      cpp2 = (del1*(sinhm1-sinhmh)+cpp1*sinhmh)/
     *       (sigmar*sigmar*h*(1.+sinhmh))
      surfl2 = hernz(fi,fpi,fip1,fppip1)
      return
c
c north pole
c
   9  fi = hernz(r(i,j),rp(i,j,2),r(i,jp1),rp(i,jp1,2))
      fppi = hernz(rp(i,j,1),rp(i,j,3),rp(i,jp1,1),
     *             rp(i,jp1,3))
      fip1 = r(m,1)
      fact = atan(1.)/45.
      fpip1 = rp(m,1,3)*cos(tt*fact)+rp(m,2,3)*sin(tt*fact)
      h = phi(ip1)-phi(i)
      del1 = phi(ip1)-pp
      del2 = pp-phi(i)
      call snhcsh(sinhm1,dummy,sigmar*del1,-1)
      call snhcsh(sinhm2,dummy,sigmar*del2,-1)
      call snhcsh(sinhmh,coshmh,sigmar*h,0)
      c1 = del2*(sinhm2-coshmh)/(h*(sinhmh-coshmh))
      cpp1 = del2*(sinhm2-sinhmh)/(sinhmh-coshmh)
      c2 = (del1-cpp1)/h
      cpp2 = (del1*(sinhm1-sinhmh)+cpp1*sinhmh)/
     *       (sigmar*sigmar*h*(1.+sinhmh))
      surfl2 = hernz(fip1,fpip1,fi,fppi)
      return
      end
      subroutine surfs1(m,n,phi,theta,rho,ir,rp10,rp190,
     *                rpm0,rpm90,islpsw,rp,temp,sigma,istar,
     *                ierr)
c
      integer m,n,ir,islpsw,ierr
      real    phi(m),theta(n),rho(ir,n),rp10,rp190,rpm0,
     *        rpm90,rp(m,n,3),temp(1),sigma
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through
c function values specified on a grid which is periodic in
c the second independent variable and has two poles in the
c first independent variable.  the surface determined can
c be represented as the tensor product of splines under
c tension.  certain partial derivatives at the boundary
c are needed.  these may be specified or omitted.  for
c actual mapping of the points onto the surface it is
c necessary to call the function surfs2.
c
c on input--
c
c   m is the number of phi values in the grid (m .ge. 3).
c
c   n is the number of theta values in the grid (n .ge. 2).
c
c   phi is an array of the m phi-coordinates in the grid.
c   phi(1) = -90, phi(m) = +90, and the values should be
c   strictly increasing.
c
c   theta is an array of the n theta-coordinates in the
c   grid.  if a ray with its endpoint at the origin sweeps
c   the plane from theta(1) to theta(2) to...to theta(n), it
c   must move continuously in a counterclockwise direction.
c   either the sequence is strictly increasing and satisfies
c   theta(n)-theta(1) .lt. 360., or theta(n) .lt. theta(1)
c   and there is an index, istar, so that if the elements of
c   the sequence whose indices are greater than or equal to
c   istar are increased by 360., then the sequence is str-
c   ictly increasing.
c
c   rho is an array of the m * n function values at the grid
c   points.  rho(i,j) contains the function value at
c   (phi(i),theta(j)) for i = 1,...,m and j = 1,...,n.
c
c   ir is the row dimension of the matrix rho used in the
c   calling program (iz .ge. m).
c
c   rp10 is the value of the partial derivative with respect
c   to phi at (-90,0).
c
c   rp190 is the value of the partial deriv. with respect
c   to phi at (-90,90).
c
c   rpm0 is the value of the partial derivative with respect
c   to phi at (+90,0).
c
c   rpm90 is the value of the partial deriv. with respect
c   to phi at (+90,90).
c
c   islpsw is a switch indicating which boundary derivative
c   information is user supplied and which is to be
c   estimated.
c   islpsw = 0   if all derivatives are supplied.
c          = 1   if rp10 and rp190 are to be estimated and
c                rpm0 and rpm90 are supplied.
c          = 10  if rp10 and rp190 are supplied and
c                rpm0 and rpm90 are to be estimated.
c          = 11  if all derivatives are to be estimated.
c
c   rp is an array of at least 3 * m * n locations.
c
c   temp is an array of at least 5 * max(m,n) locations
c   which is used for scratch storage.
c
c and
c
c   sigma contains the tension factor.  this value indicates
c   the curviness desired.  if abs(sigma) is nearly zero (e.
c   g. .001) the resulting surface is approximately the ten-
c   sor product of cubic splines.  if abs(sigma) is large
c   (e.g. 50.) the resulting surface is approximately bi-
c   linear.  if sigma equals zero, tensor products of cubic
c   splines result.  a standard value for sigma is approx-
c   imately 1. in absolute value.
c
c on output--
c
c   rp contains the partial derivative values necessary for
c   evaluation of the function.
c
c   istar is the index where
c         theta(istar-1) .gt. theta(istar).
c   istar = 0 if the theta-values are strictly increasing.
c
c   ierr is an error flag,
c        = 0 if normal return,
c        = 1 if n .lt. 2 or m .lt. 3,
c        = 2 if phi values are not strictly increasing or
c            if theta values are not specified correctly,
c        = 3 if phi(1) and phi(m) are not poles,
c        = 4 if the range of theta-values is too large.
c
c and
c
c   m, n, phi, theta, rho, ir, islpsw, rp10, rp190, rpm0,
c   rpm90 and sigma are unaltered.
c
c this subroutine references package modules bdryp, ceez,
c chekin, delr, lstsq, matnn, matnp, rhsnn, rhsnp, snhcsh,
c terms, trdec, tridep, trsol, and trisop and blas modules
c saxpy, scopy, sdot, snrm2, and sscal.
c
c-----------------------------------------------------------
c
c check input
c
      if (n .lt. 2 .or. m .lt. 3) go to 1
      if (phi(1) .ne. -90. .or. phi(m) .ne. 90.) go to 3
      call chekin(n,theta,istar,ierr)
      if (ierr .ne. 0) return
      if (((istar .eq. 0) .and. (theta(n)-theta(1) .gt. 360.))
     *                    .or.
     *    ((istar .gt. 0) .and. (theta(n) .gt. theta(1))))
     *    go to 4
      if (ierr .ne. 0) return
      delpm1 = phi(m)-phi(1)
      deltn1 = theta(n)-theta(1)+180.+sign(180.,theta(1)-
     *                                          theta(n))
      if (delpm1 .le. 0. .or. deltn1 .eq. 0.) go to 2
      call chekin(m,phi,idum,ierr)
      if (ierr .ne. 0) return
      p = 360.
      np1 = n+1
      nt2p1 = np1+n
      nt3p1 = nt2p1+n
      nt4p1 = nt3p1+n
      mm1 = m-1
      mm2 = m-2
      mp1 = m+1
      mt2p1 = mp1+m
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(mm1)/delpm1
      sigmat = abs(sigma)*float(n)/p
c
c obtain boundary derivatives
c
      call bdryp(m,n,(islpsw/10)*10-islpsw,rp10,rp190,
     *           phi(1),phi(2),phi(3),ir,rho(1,1),rho(2,1),
     *           rho(3,1),sigmap,theta,m,rp(1,1,1),dd10,
     *           dd190,temp,ierr)
c
      call bdryp(m,n,(islpsw/100)*10-islpsw/10,rpm0,
     *           rpm90,phi(m),phi(mm1),phi(mm2),ir,
     *           rho(m,1),rho(mm1,1),rho(mm2,1),
     *           sigmap,theta,m,rp(m,1,1),ddm0,ddm90,
     *           temp,ierr)
c
c set up and solve systems in phi-direction
c
      call rhsnn(n,m,1,ir,rho,phi,m,rp(1,1,1),rp(m,1,1),1,m,
     *           rp(1,1,1))
      call matnn(m,sigmap,phi,temp(1),temp(mp1))
      call trdec(m,temp(1),temp(mp1),temp(mt2p1))
      call trsol(m,n,1,m,temp(mt2p1),temp(1),temp(mp1),
     *            rp(1,1,1))
c
c save dd*s for later
c
      rp(1,1,3) = dd10
      rp(1,2,3) = dd190
      rp(m,1,3) = ddm0
      rp(m,2,3) = ddm90
c
c set up and solve systems in theta-direction
c
      call rhsnp(m,n,p,ir,1,rho,theta,m,1,rp(1,1,2))
      call rhsnp(mm2,n,p,m,1,rp(2,1,1),theta,m,1,rp(2,1,3))
      call matnp(n,p,sigmat,theta,temp(1),temp(np1),c)
      call tridep(n,c,temp(1),temp(np1),temp(nt2p1),
     *            temp(nt3p1),temp(nt4p1))
      call trisop(n,temp(1),temp(np1),temp(nt2p1),
     *           temp(nt3p1),temp(nt4p1),m,m,1, rp(1,1,2))
      call trisop(n,temp(1),temp(np1),temp(nt2p1),
     *         temp(nt3p1),temp(nt4p1),mm2,m,1, rp(2,1,3))
      return
c
c error conditions
c
c problem dimensions too small
c
    1 ierr = 1
      return
c
c grid values not strictly increasing
c
    2 ierr = 2
      return
c
c missing pole(s)
c
    3 ierr = 3
      return
c
c range of theta-values too large
c
    4 ierr = 4
      return
c
      end
      function surfs2(pp,tt,m,n,phi,theta,r,ir,rp,istar,
     *                sigma)
c
      integer m,n,ir
      real    pp,tt,phi(m),theta(n),r(ir,n),rp(m,n,3),sigma
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function interpolates a surface at the point (pp,tt)
c using a bi-spline under tension when the surface is
c periodic in both variables and has two poles in the first
c independent variable.  surfl1 should have been called
c previously to determine certain necessary parameters.
c
c on input--
c
c   pp and tt contain the phi- and theta-coordinates of the
c   point to be mapped onto the interpolating surface.
c
c   m and n contain the number of grid lines in the phi- and
c   theta-directions, respectively, of the grid which spec-
c   ified the surface.
c
c   phi and theta are arrays containing the phi- and theta-
c   grid values, respectively.  the phi-array must be str-
c   ictly increasing.  if 360. is added to all theta-array
c   elements whose index is istar or greater, then the
c   resulting array is strictly increasing.
c
c   r is an array of m * n function values.  in spherical
c   coordinates, (phi(i),theta(j),r(i,j)) is a point on the
c   surface being interpolated.
c
c   ir contains the row dimension of the array r as declared
c   in the calling program.
c
c   rp is an array of 3 * m * n locations containing the
c   surface derivative information determined by surfs1.
c
c   istar is the index where
c        theta(istar-1) .gt. theta(istar).
c   istar is zero if the theta values are strictly increasing.
c
c and
c
c   sigma contains the tension factor.
c
c the parameters m, n, phi, t, r, ir, sigma, rp, and istar
c should be input unaltered from the output of surfs1.
c
c
c on output--
c
c   surfs2 is the interpolated surface value.
c
c and
c
c   the input parameters are unaltered.
c
c this module references package modules intrvl, intrvp,
c and snhcsh.
c
c-----------------------------------------------------------
c
c cubic spline - f1,fpp1,f2,fpp2 basis
c
      herz(f1,fpp1,f2,fpp2) = (f1*del2+f2*del1)/h
     *    -del1*del2*(fpp1*(del2+h)+fpp2*(del1+h))/(6.*h)
c
c cubic spline - f1,fp1,f2,fpp2 basis
c
      herzp(f1,fp1,f2,fpp2) = (-f1*del2*(del2*del2-3.*h*h)
     *     +f2*del1*del1*(del2+2.*h))/(2.*h*h*h)
     *     +(fp1*(2.*h-del1)/(2.*h)-fpp2*del1/4.)
     *     *del1*del2/h
c
c tension spline
c
      hernz (f1,fpp1,f2,fpp2) = c1*f1+cpp1*fpp1+c2*f2+
     *                          cpp2*fpp2
c
c denormalize tension factor
c
      sigmar = abs(sigma)*float(m-1)/(phi(m)-phi(1))
      pt = 360.
      sigmat = abs(sigma)*float(n)/pt
c
c locate (pp,tt) within r-grid , set up theta interpolation
c
      i = intrvl(pp,phi,m)
      ip1 = i+1
      if (istar .ne. 0) go to 2
      j = intrvp(tt,theta,n,pt,tp)
      if (j .eq. n) go to 1
      jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tp-theta(j)
      del2 = theta(jp1)-tp
      go to 6
    1 jp1 = 1
      h = pt-(theta(n)-theta(1))
      del1 = tp-theta(j)
      del2 = theta(jp1)+pt-tp
      go to 6
c
c non-monotonic theta-values
c
    2 j = intrvp(tt,theta,istar-1,pt,tp)
      if (tp .gt. theta(istar-1)) go to 3
      jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tp-theta(j)
      del2 = theta(jp1)-tp
      go to 6
    3 if (tp .lt. theta(istar)+360. .or. tp .gt. theta(n)+360.)
     *   go to 4
      j = intrvl(tp,theta(istar),n-istar+1)+istar-1
      jp1 = j+1
      h = theta(jp1)-theta(j)
      del1 = tp-theta(j)
      del2 = theta(jp1)-tp
      go to 6
    4 if (tp .le. theta(n)+360.) go to 5
      j = n
      jp1 = 1
      h = theta(1)+pt-(theta(n)+360.)
      del1 = theta(1)+pt-tp
      del2 = tp-theta(n)+360.
      go to 6
    5 j = istar-1
      jp1 = istar
      h = theta(istar)+360.-theta(istar-1)
      del1 = tp-theta(istar-1)
      del2 = theta(istar)+360.-tp
    6 if (sigma .ne. 0.) go to 9
c
c
c cubic spline interpolation
c
c
      if (phi(1) .eq. -90. .and. i .eq. 1) go to 7
      if (phi(m) .eq. +90. .and. ip1 .eq. m) go to 8
c
c no pole
c
      fip1 = herz(r(ip1,j),rp(ip1,j,2),r(ip1,jp1),
     *            rp(ip1,jp1,2))
      fppip1 = herz(rp(ip1,j,1),rp(ip1,j,3),rp(ip1,jp1,1),
     *              rp(ip1,jp1,3))
      fi = herz(r(i,j),rp(i,j,2),r(i,jp1),rp(i,jp1,2))
      fppi = herz(rp(i,j,1),rp(i,j,3),rp(i,jp1,1),
     *            rp(i,jp1,3))
      h = phi(ip1)-phi(i)
      del1 = pp-phi(i)
      del2 = phi(ip1)-pp
       surfs2 = herz(fi,fppi,fip1,fppip1)
      return
c
c south pole
c
    7 fip1 = herz(r(ip1,j),rp(ip1,j,2),r(ip1,jp1),
     *            rp(ip1,jp1,2))
      fppip1 = herz(rp(ip1,j,1),rp(ip1,j,3),rp(ip1,jp1,1),
     *              rp(ip1,jp1,3))
      fi = r(1,1)
      fact = atan(1.)/45.
      fpi  = rp(1,1,3)*cos(tt*fact)+rp(1,2,3)*sin(tt*fact)
      h = phi(ip1)-phi(i)
      del1 = pp-phi(i)
      del2 = phi(ip1)-pp
      surfs2 = herzp(fi,fpi,fip1,fppip1)
      return
c
c north pole
c
    8 fi = herz(r(i,j),rp(i,j,2),r(i,jp1),rp(i,jp1,2))
      fppi = herz(rp(i,j,1),rp(i,j,3),rp(i,jp1,1),
     *            rp(i,jp1,3))
      fip1 = r(m,1)
      fact = atan(1.)/45.
      fpip1 = rp(m,1,3)*cos(tt*fact)+rp(m,2,3)*sin(tt*fact)
      h = phi(ip1)-phi(i)
      del1 = phi(ip1)-pp
      del2 = pp-phi(i)
      surfs2 = herzp(fip1,fpip1,fi,fppi)
      return
c
c
c spline under tension interpolation
c
c
c theta direction
c
    9 call snhcsh(sinhm1,dummy,sigmat*del1,-1)
      call snhcsh(sinhm2,dummy,sigmat*del2,-1)
      call snhcsh(sinhmh,dummy,sigmat*h,-1)
      c1 = del2/h
      c2 = del1/h
      denom = sigmat*sigmat*h*(1.+sinhmh)
      cpp1 = del2*(sinhm2-sinhmh)/denom
      cpp2 = del1*(sinhm1-sinhmh)/denom
c
      if (phi(1) .eq. -90. .and. i .eq. 1) go to 10
      if (phi(m) .eq. +90. .and. ip1 .eq. m) go to 11
c
c no pole
c
      fip1 = hernz(r(ip1,j),rp(ip1,j,2),r(ip1,jp1),
     *             rp(ip1,jp1,2))
      fppip1 = hernz(rp(ip1,j,1),rp(ip1,j,3),rp(ip1,jp1,1),
     *               rp(ip1,jp1,3))
      fi = hernz(r(i,j),rp(i,j,2),r(i,jp1),rp(i,jp1,2))
      fppi = hernz(rp(i,j,1),rp(i,j,3),rp(i,jp1,1),
     *             rp(i,jp1,3))
c
c r direction
c
      h = phi(ip1)-phi(i)
      del1 = pp-phi(i)
      del2 = phi(ip1)-pp
      call snhcsh(sinhm1,dummy,sigmar*del1,-1)
      call snhcsh(sinhm2,dummy,sigmar*del2,-1)
      call snhcsh(sinhmh,dummy,sigmar*h,-1)
      c1 = del2/h
      c2 = del1/h
      denom = sigmar*sigmar*h*(1.+sinhmh)
      cpp1 = del2*(sinhm2-sinhmh)/denom
      cpp2 = del1*(sinhm1-sinhmh)/denom
      surfs2 = hernz(fi,fppi,fip1,fppip1)
      return
c
c south pole
c
   10 fip1 = hernz(r(ip1,j),rp(ip1,j,2),r(ip1,jp1),
     *             rp(ip1,jp1,2))
      fppip1 = hernz(rp(ip1,j,1),rp(ip1,j,3),
     *               rp(ip1,jp1,1),rp(ip1,jp1,3))
      fi = r(1,1)
      fact = atan(1.)/45.
      fpi = (rp(1,1,3)*cos(tt*fact)+rp(1,2,3)*sin(tt*fact))
c
      h = phi(ip1)-phi(i)
      del1 = pp-phi(i)
      del2 = phi(ip1)-pp
      call snhcsh(sinhm1,dummy,sigmar*del1,-1)
      call snhcsh(sinhm2,dummy,sigmar*del2,-1)
      call snhcsh(sinhmh,coshmh,sigmar*h,0)
      c1 = del2*(sinhm2-coshmh)/(h*(sinhmh-coshmh))
      cpp1 = del2*(sinhm2-sinhmh)/(sinhmh-coshmh)
      c2 = (del1-cpp1)/h
      cpp2 = (del1*(sinhm1-sinhmh)+cpp1*sinhmh)/
     *       (sigmar*sigmar*h*(1.+sinhmh))
      surfs2 = hernz(fi,fpi,fip1,fppip1)
      return
c
c north pole
c
   11 fi = hernz(r(i,j),rp(i,j,2),r(i,jp1),rp(i,jp1,2))
      fppi = hernz(rp(i,j,1),rp(i,j,3),rp(i,jp1,1),
     *             rp(i,jp1,3))
      fip1 = r(m,1)
      fact = atan(1.)/45.
      fpip1 = rp(m,1,3)*cos(tt*fact)+rp(m,2,3)*sin(tt*fact)
      h = phi(ip1)-phi(i)
      del1 = phi(ip1)-pp
      del2 = pp-phi(i)
      call snhcsh(sinhm1,dummy,sigmar*del1,-1)
      call snhcsh(sinhm2,dummy,sigmar*del2,-1)
      call snhcsh(sinhmh,coshmh,sigmar*h,0)
      c1 = del2*(sinhm2-coshmh)/(h*(sinhmh-coshmh))
      cpp1 = del2*(sinhm2-sinhmh)/(sinhmh-coshmh)
      c2 = (del1-cpp1)/h
      cpp2 = (del1*(sinhm1-sinhmh)+cpp1*sinhmh)/
     *       (sigmar*sigmar*h*(1.+sinhmh))
      surfs2 = hernz(fip1,fpip1,fi,fppi)
      return
      end
      subroutine val3b1 (nx,ny,nz,x,y,z,w,nw1,nw2,c,vx,vy,
     *                   vz,temp,sigma,ierr)
c
      integer nx,ny,nz,nw1,nw2,ierr
      real x(nx),y(ny),z(nz),w(nw1,nw2,nz),c(nx,ny,nz),
     *     vx(5,nx),vy(5,ny),vz(5,nz),temp(1),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory function on a three dimensional
c rectangular grid. the function determined can be
c represented as a tensor product of splines under tension.
c for actual mapping of points it is necessary to call the
c subroutine val3bd, which also returns first and second
c partial derivatives.
c
c on input--
c
c   nx, ny, and nz are the number of grid lines in the x-,
c   y-, and z-directions, respectively, of the rectangular
c   grid. (nx, ny, and nz should be at least 2.)
c
c   x, y, and z are arrays of the nx, ny, and nz coordinates
c   of the grid lines in the x-, y-, and z-directions,
c   respectively. these should be strictly increasing.
c
c   w is an array of the nx * ny * nz functional values at
c   the grid points, i. e. w(i,j,k) contains the functional
c   value at (x(i),y(j),z(k)) for i = 1,...,nx,
c   j = 1,...,ny, and k = 1,...,nz.
c
c   nw1 and nw2 are the first two dimensions of the array w
c   used in the calling program (nw1 .ge. nx and nw2 .ge.
c   ny).
c
c   c is an array of at least nx * ny * nz locations. this
c   parameter may coincide with w in which case w is
c   destroyed on output.
c
c   vx, vy, and vz are arrays of at least 5 * nx, 5 * ny,
c   and 5 * nz locations, respectively.
c
c   temp is an array of at least 3 * max(nx, ny, nz)
c   locations which is used for scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   tri-linear. if sigma equals zero tensor products of
c   cubic splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   c contains the coefficients of a representation of the
c   interpolated function in a b-spline tensor production
c   form.
c
c   vx, vy, and vz contain b-spline under tension basis
c   data.
c
c   ierr contains an error flag.
c        = 0 for normal return,
c        = 1 if nx, ny, or nz is less than 2,
c        = 2 if the x-, y-, or z-arrays are not strictly
c            increasing.
c
c and
c
c   none of the input parameters are altered (except w if
c   this parameter and c are identical in the calling
c   sequence).
c
c this subroutine references package modules vgen, terms,
c snhcsh, tridec, and trislm.
c
c-----------------------------------------------------------
c
c copy w into c
c
      do 1 k = 1,nz
        do 1 j = 1,ny
          do 1 i = 1,nx
    1       c(i,j,k) = w(i,j,k)
c
c generate basis functions along x-grid
c set up tridiagonal system and solve
c
      call vgen (nx,x,sigma,vx,ierr)
      if (ierr .ne. 0) return
      do 2 i = 2,nx
    2   temp(i) = vx(5,i-1)
      nxpi = nx
      do 3 i = 1,nx
        nxpi = nxpi+1
    3   temp(nxpi) = 1.
      do 4 i = 2,nx
        nxpi = nxpi+1
    4   temp(nxpi) = vx(4,i)
      call tridec (nx,temp(1),temp(nx+1),temp(2*nx+1),
     *             temp(1),temp(nx+1),ierr)
      call trislm (nx,temp(1),temp(nx+1),temp(2*nx+1),c,nx,
     *            ny*nz,1)
c
c generate basis functions along y-grid
c set up tridiagonal system and solve
c
      call vgen (ny,y,sigma,vy,ierr)
      if (ierr .ne. 0) return
      do 5 j = 2,ny
    5   temp(j) = vy(5,j-1)
      nypj = ny
      do 6 j = 1,ny
        nypj = nypj+1
    6   temp(nypj) = 1.
      do 7 j = 2,ny
        nypj = nypj+1
    7   temp(nypj) = vy(4,j)
      call tridec (ny,temp(1),temp(ny+1),temp(2*ny+1),
     *             temp(1),temp(ny+1),ierr)
      do 8 k = 1,nz
    8   call trislm (ny,temp(1),temp(ny+1),temp(2*ny+1),
     *               c(1,1,k),1,nx,nx)
c
c generate basis functions along z-grid
c set up tridiagonal system and solve
c
      call vgen (nz,z,sigma,vz,ierr)
      if (ierr .ne. 0) return
      do 9 k = 2,nz
    9   temp(k) = vz(5,k-1)
      nzpk = nz
      do 10 k = 1,nz
        nzpk = nzpk+1
   10   temp(nzpk) = 1.
      do 11 k = 2,nz
        nzpk = nzpk+1
   11   temp(nzpk) = vz(4,k)
      call tridec (nz,temp(1),temp(nz+1),temp(2*nz+1),
     *             temp(1),temp(nz+1),ierr)
      call trislm (nz,temp(1),temp(nz+1),temp(2*nz+1),c,1,
     *            nx*ny,nx*ny)
      return
      end
      subroutine val3bd (xx,yy,zz,w,wx,wy,wz,wxx,wxy,wyy,
     *                   wyz,wzz,wxz,nx,ny,nz,x,y,z,c,vx,vy,
     *                   vz,sigma)
c
      integer nx,ny,nz
      real xx,yy,zz,w,wx,wy,wz,wxx,wxy,wyy,wyz,wzz,wxz,
     *     x(nx),y(ny),z(nz),vx(5,nx),vy(5,ny),vz(5,nz),
     *     c(nx,ny,nz),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine evaluates the function value, the three
c first partial derivatives, and the six second partial
c derivatives of a tensor product spline under tension in
c three variables.
c
c on input--
c
c   xx, yy, and zz contain the x-, y-, and z-coordinates of
c   the point at which the interpolation is to be performed.
c
c   nx, ny, and nz are the number of grid lines in the x-,
c   y-, and z-directions, respectively, of the rectangular
c   grid which specified the function.
c
c   x, y, and z are arrays containing the x-, y-, and z-grid
c   values, respectively.
c
c   c is an array of coefficients describing the function in
c   terms of a b-spline under tension basis. in the
c   expansion of the function, for i = 1,...,nx, j = 1,...,
c   ny, and k = 1,...,nz, the coefficient multiplying the
c   product of basis function i in x, basis function j in y,
c   and basis function k in z is stored in c(i,j,k).
c
c   vx, vy, and vz are arrays of length 5*nx, 5*ny, and
c   5*nz, respectively, containing the b-spline basis data
c   for the x-, y-, and z-grids.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters nx, ny, nz, x, y, z, c, vx, vy, vz, and
c sigma should be input unaltered from the output of
c val3b1.
c
c on output--
c
c   w contains the interpolated function value.
c
c   wx, wy, and wz contain the x-, y-, and z-partial
c   derivatives, respectively.
c
c   wxx, wxy, wyy, wyz, wzz, and wxz contain the xx-, xy-
c   yy-, yz-, zz-, and xz-partial derivatives, respectively.
c
c and
c
c   none of the input parameters are altered.
c
c this subroutine references package modules dsplnz, intrvl,
c and snhcsh.
c
c--------------------------------------------------------------
c
      real bx(3,4),by(3,4),bz(3,4)
c
c evaluate basis functions at xx, yy, and zz
c
      call dsplnz (xx,nx,x,vx,sigma,istart,bx)
      call dsplnz (yy,ny,y,vy,sigma,jstart,by)
      call dsplnz (zz,nz,z,vz,sigma,kstart,bz)
c
c accumulate tensor products
c
      sum = 0.
      sumx = 0.
      sumy = 0.
      sumz = 0.
      sumxx = 0.
      sumxy = 0.
      sumyy = 0.
      sumyz = 0.
      sumzz = 0.
      sumxz = 0.
      do 3 k = 1,4
        kk = kstart+k-1
        if (kk .eq. 0 .or. kk .gt. nz) go to 3
        bz1k = bz(1,k)
        bz2k = bz(2,k)
        bz3k = bz(3,k)
        do 2 j = 1,4
          jj = jstart+j-1
          if (jj .eq. 0 .or. jj .gt. ny) go to 2
          by1j = by(1,j)
          by2j = by(2,j)
          by3j = by(3,j)
          do 1 i = 1,4
            ii = istart+i-1
            if (ii .eq. 0 .or. ii .gt. nx) go to 1
            bx1i = bx(1,i)
            bx2i =  bx(2,i)
            cijk = c(ii,jj,kk)
            sum = sum+cijk*bx1i*by1j*bz1k
            sumx = sumx+cijk*bx2i*by1j*bz1k
            sumy = sumy+cijk*bx1i*by2j*bz1k
            sumz = sumz+cijk*bx1i*by1j*bz2k
            sumxx = sumxx+cijk*bx(3,i)*by1j*bz1k
            sumxy = sumxy+cijk*bx2i*by2j*bz1k
            sumyy = sumyy+cijk*bx1i*by3j*bz1k
            sumyz = sumyz+cijk*bx1i*by2j*bz2k
            sumzz = sumzz+cijk*bx1i*by1j*bz3k
            sumxz = sumxz+cijk*bx2i*by1j*bz2k
    1       continue
    2     continue
    3   continue
      w = sum
      wx = sumx
      wy = sumy
      wz = sumz
      wxx = sumxx
      wxy = sumxy
      wyy = sumyy
      wyz = sumyz
      wzz = sumzz
      wxz = sumxz
      return
      end
      subroutine nbtoh3 (nx,ny,nz,c,vx,vy,vz,w,nw1,nw2,wxxp,
     *                 wyyp,wzzp,wxxyyp,wyyzzp,wxxzzp,wxyz2p)
c
      integer nx,ny,nz,nw1,nw2
      real c(nx,ny,nz),vx(5,nx),vy(5,ny),vz(5,nz),
     *     w(nw1,nw2,nz),wxxp(nx,ny,nz),wyyp(nx,ny,nz),
     *     wzzp(nx,ny,nz),wxxyyp(nx,ny,nz),wyyzzp(nx,ny,nz),
     *     wxxzzp(nx,ny,nz),wxyz2p(nx,ny,nz)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine obtains a hermite interpolation
c representation (i. e. function values and partial
c derivatives) for a three dimensional spline from a
c b-spline basis representation. the spline is assumed to
c have natural end conditions.
c
c on input--
c
c   nx, ny, and nz are the number of grid lines in the x-,
c   y-, and z-directions, respectively, of the rectangular
c   grid which specified the function.
c
c   c is an array of coefficients describing the function in
c   terms of a b-spline under tension basis. in the
c   expansion of the function, for i = 1,...,nx, j = 1,...,
c   ny, and k = 1,...,nz, the coefficient multiplying the
c   product of basis function i in x, basis function j in y,
c   and basis function k in z is stored in c(i,j,k).
c
c   vx, vy, and vz are arrays of length 5*nx, 5*ny, and
c   5*nz, respectively, containing the b-spline basis data
c   for the x-, y-, and z-grids.
c
c   w is an array of at least nx * ny * nz locations.
c
c   nw1 and nw2 are the first two dimensions of the array w
c   used in the calling program (nw1 .ge. nx and nw2 .ge.
c   ny).
c
c and
c
c   wxxp, wyyp, wzzp, wxxyyp, wyyzzp, wxxzzp, and wxyz2p are
c   arrays of at least nx * ny * nz locations each.
c
c the parameters nx, ny, nz, c, vx, vy, and vz should be
c input unaltered from the output of val3b1.
c
c on output--
c
c   w is an array of the nx * ny * nz functional values at
c   the grid points, i. e. w(i,j,k) contains the functional
c   value at (x(i),y(j),z(k)) for i = 1,...,nx,
c   j = 1,...,ny, and k = 1,...,nz.
c
c   wxxp, wyyp, wzzp, wxxyyp, wyyzzp, wxxzzp, and wxyz2p
c   contain the values of the xx-, yy-, zz-, xxyy-, yyzz-,
c   xxzz-, and xxyyzz-partial derivatives of the function at
c   the given nodes, respectively.
c
c and
c
c   nx, ny, nz, c, vx, vy, vz, nw1, and nw2 are unaltered.
c
c this subroutine references package module sum.
c
c-----------------------------------------------------------
c
c combine data from v array to determine function and second
c derivative values
c
      real vxs(5),vys(5),vzs(5)
c
c loop on z grid
c
      do 7 k = 1,nz
        ksw = 2
        km1 = k-1
        if (k .ne. 1) go to 1
        ksw = 1
        km1 = nz
    1   kp1 = k+1
        if ( k .ne. nz) go to 2
        ksw = 3
        kp1 = 1
c
c store values of b-splines in z
c
    2   vzs(1) = vz(5,km1)
        vzs(2) = vz(4,kp1)
        vzs(3) = vz(3,km1)
        vzs(4) = vz(2,k)
        vzs(5) = vz(1,kp1)
c
c loop on y grid
c
        do 7 j = 1,ny
          jsw = 2
          jm1 = j-1
          if (j .ne. 1) go to 3
          jsw = 1
          jm1 = ny
    3     jp1 = j+1
          if (j .ne. ny) go to 4
          jsw = 3
          jp1 = 1
c
c store values of b-splines in y
c
    4     vys(1) = vy(5,jm1)
          vys(2) = vy(4,jp1)
          vys(3) = vy(3,jm1)
          vys(4) = vy(2,j)
          vys(5) = vy(1,jp1)
          do 7 i = 1,nx
            isw = 2
            im1 = i-1
            if (i .ne. 1) go to 5
            isw = 1
            im1 = nx
    5       ip1 = i+1
            if (i .ne. nx) go to 6
            isw = 3
            ip1 = 1
c
c store values of b-splines in x
c
    6       vxs(1) = vx(5,im1)
            vxs(2) = vx(4,ip1)
            vxs(3) = vx(3,im1)
            vxs(4) = vx(2,i)
            vxs(5) = vx(1,ip1)
c
c accumulate in x direction
c
            call sum (c(im1,jm1,km1),c(i,jm1,km1),
     *                c(ip1,jm1,km1),vxs,skm1,sxkm1,isw)
            call sum (c(im1,j,km1),c(i,j,km1),
     *                c(ip1,j,km1),vxs,skm2,sxkm2,isw)
            call sum (c(im1,jp1,km1),c(i,jp1,km1),
     *                c(ip1,jp1,km1),vxs,skm3,sxkm3,isw)
            call sum (c(im1,jm1,k),c(i,jm1,k),
     *                c(ip1,jm1,k),vxs,sk1,sxk1,isw)
            call sum (c(im1,j,k),c(i,j,k),
     *                c(ip1,j,k),vxs,sk2,sxk2,isw)
            call sum (c(im1,jp1,k),c(i,jp1,k),
     *                c(ip1,jp1,k),vxs,sk3,sxk3,isw)
            call sum (c(im1,jm1,kp1),c(i,jm1,kp1),
     *                c(ip1,jm1,kp1),vxs,skp1,sxkp1,isw)
            call sum (c(im1,j,kp1),c(i,j,kp1),
     *                c(ip1,j,kp1),vxs,skp2,sxkp2,isw)
            call sum (c(im1,jp1,kp1),c(i,jp1,kp1),
     *                c(ip1,jp1,kp1),vxs,skp3,sxkp3,isw)
            call sum (skm1,skm2,skm3,vys,t1,ty1,jsw)
c
c accumulate in y direction
c
            call sum (sk1,sk2,sk3,vys,t2,ty2,jsw)
            call sum (skp1,skp2,skp3,vys,t3,ty3,jsw)
            call sum (sxkm1,sxkm2,sxkm3,vys,tx1,txy1,jsw)
            call sum (sxk1,sxk2,sxk3,vys,tx2,txy2,jsw)
            call sum (sxkp1,sxkp2,sxkp3,vys,tx3,txy3,jsw)
c
c accumulate in z direction
c
            call sum (t1,t2,t3,vzs,w(i,j,k),wzzp(i,j,k),ksw)
            call sum (tx1,tx2,tx3,vzs,wxxp(i,j,k),
     *                wxxzzp(i,j,k),ksw)
            call sum (ty1,ty2,ty3,vzs,wyyp(i,j,k),
     *                wyyzzp(i,j,k),ksw)
    7       call sum (txy1,txy2,txy3,vzs,wxxyyp(i,j,k),
     *                wxyz2p(i,j,k),ksw)
      return
      end
      subroutine val3hd (xx,yy,zz,ww,wx,wy,wz,wxx,wxy,wyy,
     *                   wyz,wzz,wxz,nx,ny,nz,x,y,z,w,nw1,
     *                   nw2,wxxp,wyyp,wzzp,wxxyyp,wyyzzp,
     *                   wxxzzp,wxyz2p,sigma)
c
      integer nx,ny,nz,nw1,nw2
      real xx,yy,zz,ww,wx,wy,wz,wxx,wxy,wyy,wyz,wzz,wxz,
     *     x(nx),y(ny),z(nz),w(nw1,nw2,nz),wxxp(nx,ny,nz),
     *     wyyp(nx,ny,nz),wzzp(nx,ny,nz),wxxyyp(nx,ny,nz),
     *     wyyzzp(nx,ny,nz),wxxzzp(nx,ny,nz),
     *     wxyz2p(nx,ny,nz),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine evaluates the function value, the three
c first partial derivatives, and the six second partial
c derivatives of a tensor product spline under tension in
c three variables.
c
c on input--
c
c   xx, yy, and zz contain the x-, y-, and z-coordinates of
c   the point at which the interpolation is to be performed.
c
c   nx, ny, and nz are the number of grid lines in the x-,
c   y-, and z-directions, respectively, of the rectangular
c   grid which specified the function.
c
c   x, y, and z are arrays containing the x-, y-, and z-grid
c   values, respectively.
c
c   w is an array of the nx * ny * nz functional values at
c   the grid points, i. e. w(i,j,k) contains the functional
c   value at (x(i),y(j),z(k)) for i = 1,...,nx,
c   j = 1,...,ny, and k = 1,...,nz.
c
c   nw1 and nw2 are the first two dimensions of the array w
c   used in the calling program (nw1 .ge. nx and nw2 .ge.
c   ny).
c
c   wxxp, wyyp, wzzp, wxxyyp, wyyzzp, wxxzzp, and wxyz2p
c   contain the values of the xx-, yy-, zz-, xxyy-, yyzz-,
c   xxzz-, and xxyyzz-partial derivatives of the function at
c   the given nodes, respectively.
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters nx, ny, nz, x, y, z, w, nw1, nw2, wxxp,
c wyyp, wzzp, wxxyyp, wyyzzp, wxxzzp and wxyz2p should be
c input unaltered from the output of nbtoh3.
c
c on output--
c
c   ww contains the interpolated function value.
c
c   wx, wy, and wz contain the x-, y-, and z-partial
c   derivatives, respectively.
c
c   wxx, wxy, wyy, wyz, wzz, and wxz contain the xx-, xy-
c   yy-, yz-, zz-, and xz-partial derivatives, respectively.
c
c and
c
c   none of the input parameters are altered.
c
c this subroutine references package modules threet, intrvl,
c and snhcsh.
c
c--------------------------------------------------------------
c
      real cc(10),wkm(2),wk(2),wyykm(2),wyyk(2),wxkm(2),
     *     wxk(2),wxyykm(2),wxyyk(2),wzzkm(2),wzzk(2),
     *     wzzyym(2),wzzyyk(2),wxzzkm(2),wxzzk(2),xyyzzm(2),
     *     xyyzzk(2),wxxkm(2),wxxk(2),wxxyym(2),wxxyyk(2),
     *     wxxzzm(2),wxxzzk(2),wxyz2m(2),wxyz2k(2),wwk(2),
     *     yk(2),yyk(2),xk(2),xyk(2),xzzk(2),xyzzk(2),
     *     zzk(2),yzzk(2),yyzzk(2),xxk(2),xxzzk(2)
c
c denormalize tension factor in x, y, and z directions
c
      sigmax = abs(sigma)*float(nx-1)/(x(nx)-x(1))
      sigmay = abs(sigma)*float(ny-1)/(y(ny)-y(1))
      sigmaz = abs(sigma)*float(nz-1)/(z(nz)-z(1))
c
c determine x interval
c
      im1 = intrvl (xx,x,nx)
      i = im1+1
c
c determine y interval
c
      jm1 = intrvl (yy,y,ny)
      j = jm1+1
c
c determine z interval
c
      km1 = intrvl (zz,z,nz)
      k = km1+1
c
c obtain x mesh distances
c
      del1 = xx-x(im1)
      del2 = x(i)-xx
      dels = x(i)-x(im1)
c
c obtain common coefficients
c
      cc(1) = del2/dels
      cc(2) = del1/dels
      d = -1./dels
      cc(5) = d
      cc(6) = -d
      if (sigmax .ne. 0.) go to 1
c
c obtain coefficients for cubic spline
c
      con = -del1*del2/(6.*dels)
      cc(3) = (del2+dels)*con
      cc(4) = (del1+dels)*con
      cc(7) = -(2.*del2*del2-del1*(del2+dels))/(6.*dels)
      cc(8) = (2.*del1*del1-del2*(del1+dels))/(6.*dels)
      cc(9) = cc(1)
      cc(10) = cc(2)
      go to 2
c
c obtain coefficients for spline under tension
c
    1 sigdel = sigmax*dels
      call snhcsh (sinhm1,coshm1,sigmax*del1,0)
      call snhcsh (sinhm2,coshm2,sigmax*del2,0)
      call snhcsh (sinhms,dummy,sigdel,-1)
      sinhs = 1.+sinhms
      con = 1./(sigmax*sigdel*sinhs)
      cc(3) = con*del2*(sinhm2-sinhms)
      cc(4) = con*del1*(sinhm1-sinhms)
      cc(7) = -con*(coshm2-sinhms)
      cc(8) = con*(coshm1-sinhms)
      cc(9) = (del2*(1.+sinhm2))/(dels*sinhs)
      cc(10) = (del1*(1.+sinhm1))/(dels*sinhs)
c
c interpolate in x direction
c
    2 call threet (cc,w(im1,jm1,km1),wxxp(im1,jm1,km1),
     *             wkm(1),wxkm(1),wxxkm(1))
      call threet (cc,w(im1,j,km1),wxxp(im1,j,km1),wkm(2),
     *             wxkm(2),wxxkm(2))
      call threet (cc,w(im1,jm1,k),wxxp(im1,jm1,k),wk(1),
     *             wxk(1),wxxk(1))
      call threet (cc,w(im1,j,k),wxxp(im1,j,k),wk(2),wxk(2),
     *             wxxk(2))
      call threet (cc,wyyp(im1,jm1,km1),wxxyyp(im1,jm1,km1),
     *             wyykm(1),wxyykm(1),wxxyym(1))
      call threet (cc,wyyp(im1,j,km1),wxxyyp(im1,j,km1),
     *             wyykm(2),wxyykm(2),wxxyym(2))
      call threet (cc,wyyp(im1,jm1,k),wxxyyp(im1,jm1,k),
     *             wyyk(1),wxyyk(1),wxxyyk(1))
      call threet (cc,wyyp(im1,j,k),wxxyyp(im1,j,k),wyyk(2),
     *             wxyyk(2),wxxyyk(2))
      call threet (cc,wzzp(im1,jm1,km1),wxxzzp(im1,jm1,km1),
     *             wzzkm(1),wxzzkm(1),wxxzzm(1))
      call threet (cc,wzzp(im1,j,km1),wxxzzp(im1,j,km1),
     *             wzzkm(2),wxzzkm(2),wxxzzm(2))
      call threet (cc,wzzp(im1,jm1,k),wxxzzp(im1,jm1,k),
     *             wzzk(1),wxzzk(1),wxxzzk(1))
      call threet (cc,wzzp(im1,j,k),wxxzzp(im1,j,k),wzzk(2),
     *             wxzzk(2),wxxzzk(2))
      call threet (cc,wyyzzp(im1,jm1,km1),
     *             wxyz2p(im1,jm1,km1),wzzyym(1),xyyzzm(1),
     *             wxyz2m(1))
      call threet (cc,wyyzzp(im1,j,km1),wxyz2p(im1,j,km1),
     *             wzzyym(2),xyyzzm(2),wxyz2m(2))
      call threet (cc,wyyzzp(im1,jm1,k),wxyz2p(im1,jm1,k),
     *             wzzyyk(1),xyyzzk(1),wxyz2k(1))
      call threet (cc,wyyzzp(im1,j,k),wxyz2p(im1,j,k),
     *             wzzyyk(2),xyyzzk(2),wxyz2k(2))
c
c obtain y mesh distances
c
      del1 = yy-y(jm1)
      del2 = y(j)-yy
      dels = y(j)-y(jm1)
c
c obtain common coefficients
c
      cc(1) = del2/dels
      cc(2) = del1/dels
      d = -1./dels
      cc(5) = d
      cc(6) = -d
      if (sigmay .ne. 0.) go to 3
c
c obtain coefficients for cubic spline
c
      con = -del1*del2/(6.*dels)
      cc(3) = (del2+dels)*con
      cc(4) = (del1+dels)*con
      cc(7) = -(2.*del2*del2-del1*(del2+dels))/(6.*dels)
      cc(8) = (2.*del1*del1-del2*(del1+dels))/(6.*dels)
      cc(9) = cc(1)
      cc(10) = cc(2)
      go to 4
c
c obtain coefficients for spline under tension
c
    3 sigdel = sigmay*dels
      call snhcsh (sinhm1,coshm1,sigmay*del1,0)
      call snhcsh (sinhm2,coshm2,sigmay*del2,0)
      call snhcsh (sinhms,dummy,sigdel,-1)
      sinhs = 1.+sinhms
      con = 1./(sigmay*sigdel*sinhs)
      cc(3) = con*del2*(sinhm2-sinhms)
      cc(4) = con*del1*(sinhm1-sinhms)
      cc(7) = -con*(coshm2-sinhms)
      cc(8) = con*(coshm1-sinhms)
      cc(9) = (del2*(1.+sinhm2))/(dels*sinhs)
      cc(10) = (del1*(1.+sinhm1))/(dels*sinhs)
c
c interpolate in y direction
c
    4 call threet (cc,wkm,wyykm,wwk(1),yk(1),yyk(1))
      call threet (cc,wk,wyyk,wwk(2),yk(2),yyk(2))
      call threet (cc,wxkm,wxyykm,xk(1),xyk(1),dummy)
      call threet (cc,wxk,wxyyk,xk(2),xyk(2),dummy)
      call threet (cc,wxzzkm,xyyzzm,xzzk(1),xyzzk(1),dummy)
      call threet (cc,wxzzk,xyyzzk,xzzk(2),xyzzk(2),dummy)
      call threet (cc,wzzkm,wzzyym,zzk(1),yzzk(1),yyzzk(1))
      call threet (cc,wzzk,wzzyyk,zzk(2),yzzk(2),yyzzk(2))
      xxk(1) = cc(1)*wxxkm(1)+cc(2)*wxxkm(2)+cc(3)*wxxyym(1)+
     *         cc(4)*wxxyyk(2)
      xxk(2) = cc(1)*wxxk(1)+cc(2)*wxxk(2)+cc(3)*wxxyyk(1)+
     *         cc(4)*wxxyyk(2)
      xxzzk(1) = cc(1)*wxxzzm(1)+cc(2)*wxxzzm(2)+cc(3)*
     *           wxyz2m(1)+cc(4)*wxyz2m(2)
      xxzzk(2) = cc(1)*wxxzzk(1)+cc(2)*wxxzzk(2)+cc(3)*
     *           wxyz2k(1)+cc(4)*wxyz2k(2)
c
c obtain z mesh distances
c
      del1 = zz-z(km1)
      del2 = z(k)-zz
      dels = z(k)-z(km1)
c
c obtain common coefficients
c
      cc(1) = del2/dels
      cc(2) = del1/dels
      d = -1./dels
      cc(5) = d
      cc(6) = -d
      if (sigmaz .ne. 0.) go to 5
c
c obtain coefficients for cubic spline
c
      con = -del1*del2/(6.*dels)
      cc(3) = (del2+dels)*con
      cc(4) = (del1+dels)*con
      cc(7) = -(2.*del2*del2-del1*(del2+dels))/(6.*dels)
      cc(8) = (2.*del1*del1-del2*(del1+dels))/(6.*dels)
      cc(9) = cc(1)
      cc(10) = cc(2)
      go to 6
c
c obtain coefficients for spline under tension
c
    5 sigdel = sigmaz*dels
      call snhcsh (sinhm1,coshm1,sigmaz*del1,0)
      call snhcsh (sinhm2,coshm2,sigmaz*del2,0)
      call snhcsh (sinhms,dummy,sigdel,-1)
      sinhs = 1.+sinhms
      con = 1./(sigmaz*sigdel*sinhs)
      cc(3) = con*del2*(sinhm2-sinhms)
      cc(4) = con*del1*(sinhm1-sinhms)
      cc(7) = -con*(coshm2-sinhms)
      cc(8) = con*(coshm1-sinhms)
      cc(9) = (del2*(1.+sinhm2))/(dels*sinhs)
      cc(10) = (del1*(1.+sinhm1))/(dels*sinhs)
c
c interpolate in z direction
c
    6 call threet (cc,wwk,zzk,ww,wz,wzz)
      call threet (cc,xk,xzzk,wx,wxz,dummy)
      call threet (cc,yk,yzzk,wy,wyz,dummy)
      wxx = cc(1)*xxk(1)+cc(2)*xxk(2)+cc(3)*xxzzk(1)+
     *      cc(4)*xxzzk(2)
      wyy = cc(1)*yyk(1)+cc(2)*yyk(2)+cc(3)*yyzzk(1)+
     *      cc(4)*yyzzk(2)
      wxy = cc(1)*xyk(1)+cc(2)*xyk(2)+cc(3)*xyzzk(1)+
     *      cc(4)*xyzzk(2)
      return
      end
      subroutine zurfn1 (m,n,x,y,z,ix,iy,iz,xp,yp,zp,s,t,
     *                   temp,sigma,ierr)
c
      integer m,n,ix,iy,iz,ierr
      real x(ix,n),y(iy,n),z(iz,n),xp(m,n,3),yp(m,n,3),
     *     zp(m,n,3),s(m),t(n),temp(1),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through a grid of
c points in three dimensional space--(x(i,j),y(i,j),z(i,j))
c for i=1,...,m and j=1,...,n. the surface determined can be
c represented as three tensor products of splines under
c tension. for actual mapping of points onto the surface it
c is necessary to call the subroutine zurf2d (which also
c returns derivatives with respect to two parameters for use
c in calculating normal vectors, tangent planes, curvatures,
c etc.). this subroutine decomposes the workspace then calls
c the subroutine zurfnc.
c
c on input--
c
c   m is the number of rows in the arrays x, y, and z
c   containing the surface values.
c
c   n is the number of columns in the arrays x, y, and z
c   containing the surface values.
c
c   x is an array of the m x n x-coordinates of the surface
c   points.
c
c   y is an array of the m x n y-coordinates of the surface
c   points.
c
c   z is an array of the m x n z-coordinates of the surface
c   points.
c
c   ix is the row dimension of the matrix x used in the
c   calling program (ix .ge. m).
c
c   iy is the row dimension of the matrix y used in the
c   calling program (iy .ge. m).
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   xp is an array of at least 3*m*n locations.
c
c   yp is an array of at least 3*m*n locations.
c
c   zp is an array of at least 3*m*n locations.
c
c   s is an array of length at least m.
c
c   t is an array of length at least n.
c
c   temp is an array of at least 4*max(m,n) + 3n locations
c   which is used for scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   bi-linear. if sigma equals zero tensor products of
c   cubic splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   xp, yp, and zp contain information about the curvature
c   of the surface at the given points.
c
c   s and t contain vectors of grids to be used in the
c   parameterized surface.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2 or m is less than 2,
c        = 2 if either x(i,j) = x(i+1,j), y(i,j) = y(i+1,j),
c            and z(i,j) = z(i+1,j) or x(i,j) = x(i,j+1),
c            y(i,j) = y(i,j+1), and z(i,j) = z(i,j+1).
c
c and
c
c   m, n, x, y, z, ix, iy, iz, and sigma are unaltered.
c
c this subroutine references package modules zurfnc, ceez,
c terms, and snhcsh.
c
c-----------------------------------------------------------
c
c decompose workspace and invoke zurfnc
c
      maxmn = max0(m,n)
      i1 = 4*maxmn+n+1
      i2 = i1+n
      call zurfnc (m,n,x,y,z,ix,iy,iz,xp,yp,zp,s,t,temp,
     *             temp(maxmn+1),temp(2*maxmn+1),
     *             temp(3*maxmn+1),temp(4*maxmn+1),temp(i1),
     *             temp(i2),sigma,ierr)
      return
      end
      subroutine zurf2d (ss,tt,xx,yy,zz,xs,ys,zs,xt,yt,zt,
     *                   xss,yss,zss,xst,yst,zst,xtt,ytt,
     *                   ztt,m,n,x,y,z,ix,iy,iz,xp,yp,zp,s,
     *                   t,sigma)
c
      integer m,n,ix,iy,iz
      real ss,tt,xx,yy,zz,xs,ys,zs,xt,yt,zt,xss,yss,zss,
     *     xst,yst,zst,xtt,ytt,ztt,x(ix,n),y(iy,n),z(iz,n),
     *     xp(m,n,3),yp(m,n,3),zp(m,n,3),s(m),t(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine performs the mapping of points in the
c square (0.,1.) x (0.,1.) onto a surface. the subroutine
c zurfn1 should be called earlier to determine certain
c necessary parameters. the resulting suface has a
c parametric representation all three of whose components
c are splines under tension and functions of the two grid
c parameters.
c
c on input--
c
c   ss and tt contain real values to be mapped to a point on
c   the surface. the square (0.,1.) x (0.,1.) is mapped onto
c   the entire surface with (0.,0.) mapping to
c   (x(1,1),y(1,1),z(1,1)), (0.,1.) mapping to
c   (x(1,n),y(1,n),z(1,n)), (1.,0.) mapping to
c   (x(m,1),y(m,1),z(m,1)), and (1.,1.) mapping to
c   (x(m,n),y(m,n),z(m,n)). values outside this square
c   result in extrapolation.
c
c   m and n contain the dimensions of the arrays of points
c   which were specified to determine the surface.
c
c   x, y, and z are arrays containing the x-, y-, and z-
c   coordinates of the specified points, respectively.
c
c   ix, iy, and iz contain the row dimensions of the arrays
c   x, y, and z, resptively, as declared in the calling
c   program.
c
c   xp, yp, and zp are the arrays output from zurfn1
c   containing curvature information.
c
c   s and t are arrays containing the parametric grids.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters m, n, x, y, z, xp, yp, zp, s, t, and sigma
c should be input unaltered from the output of zurfn1.
c
c on output--
c
c   xx, yy, and zz contain the x-, y-, and z-coordinates of
c   the image point on the surface.
c
c   xs, ys, and zs contain the first partial derivatives of
c   the x-, y-, and z- coordinates on the surface with
c   respect to the first parameter.
c
c   xt, yt, and zt contain the first partial derivatives of
c   the x-, y-, and z- coordinates on the surface with
c   the image point on the surface.
c
c   xss, yss, and zss contain the second partial derivatives
c   of the x-, y-, and z- coordinates on the surface with
c   respect to the first parameter.
c
c   xst, yst, and zst contain the second mixed partial
c   derivative of the x-, y-, and z- coordinates on the
c   surface with respect to the two parameters.
c
c   xtt, ytt, and ztt contain the second partial derivatives
c   of the x-, y-, and z- coordinates on the surface with
c   respect to the second parameter.
c
c and
c
c   none of the input parameters are altered.
c
c this subroutine references package modules intrvl, threet,
c and snhcsh.
c
c-----------------------------------------------------------
c
      real cc(10),xj(2),yj(2),zj(2),xsj(2),ysj(2),zsj(2),
     *     xssj(2),yssj(2),zssj(2),xttj(2),yttj(2),zttj(2),
     *     xsttj(2),ysttj(2),zsttj(2),xssttj(2),yssttj(2),
     *     zssttj(2)
c
c denormalize tension factor in s and t directions
c
      sigmas = abs(sigma)*float(m-1)/(s(m)-s(1))
      sigmat = abs(sigma)*float(n-1)/(t(n)-t(1))
c
c determine s interval
c
      im1 = intrvl (ss,s,m)
      i = im1+1
c
c determine t interval
c
      jm1 = intrvl (tt,t,n)
      j = jm1+1
c
c obtain s mesh distances
c
      del1 = ss-s(im1)
      del2 = s(i)-ss
      dels = s(i)-s(im1)
c
c obtain common coefficients
c
      cc(1) = del2/dels
      cc(2) = del1/dels
      d = -1./dels
      cc(5) = d
      cc(6) = -d
      if (sigmas .ne. 0.) go to 1
c
c obtain coefficients for cubic spline
c
      con = -del1*del2/(6.*dels)
      cc(3) = (del2+dels)*con
      cc(4) = (del1+dels)*con
      cc(7) = -(2.*del2*del2-del1*(del2+dels))/(6.*dels)
      cc(8) = (2.*del1*del1-del2*(del1+dels))/(6.*dels)
      cc(9) = cc(1)
      cc(10) = cc(2)
      go to 2
c
c obtain coefficients for spline under tension
c
    1 sigdel = sigmas*dels
      call snhcsh (sinhm1,coshm1,sigmas*del1,0)
      call snhcsh (sinhm2,coshm2,sigmas*del2,0)
      call snhcsh (sinhms,dummy,sigdel,-1)
      sinhs = 1.+sinhms
      con = 1./(sigmas*sigdel*sinhs)
      cc(3) = con*del2*(sinhm2-sinhms)
      cc(4) = con*del1*(sinhm1-sinhms)
      cc(7) = -con*(coshm2-sinhms)
      cc(8) = con*(coshm1-sinhms)
      cc(9) = (del2*(1.+sinhm2))/(dels*sinhs)
      cc(10) = (del1*(1.+sinhm1))/(dels*sinhs)
c
c interpolate in s direction
c
    2 call threet (cc,x(im1,jm1),xp(im1,jm1,2),xj(1),xsj(1),
     *             xssj(1))
      call threet (cc,x(im1,j),xp(im1,j,2),xj(2),xsj(2),
     *             xssj(2))
      call threet (cc,xp(im1,jm1,1),xp(im1,jm1,3),xttj(1),
     *             xsttj(1),xssttj(1))
      call threet (cc,xp(im1,j,1),xp(im1,j,3),xttj(2),
     *             xsttj(2),xssttj(2))
      call threet (cc,y(im1,jm1),yp(im1,jm1,2),yj(1),ysj(1),
     *             yssj(1))
      call threet (cc,y(im1,j),yp(im1,j,2),yj(2),ysj(2),
     *             yssj(2))
      call threet (cc,yp(im1,jm1,1),yp(im1,jm1,3),yttj(1),
     *             ysttj(1),yssttj(1))
      call threet (cc,yp(im1,j,1),yp(im1,j,3),yttj(2),
     *             ysttj(2),yssttj(2))
      call threet (cc,z(im1,jm1),zp(im1,jm1,2),zj(1),zsj(1),
     *             zssj(1))
      call threet (cc,z(im1,j),zp(im1,j,2),zj(2),zsj(2),
     *             zssj(2))
      call threet (cc,zp(im1,jm1,1),zp(im1,jm1,3),zttj(1),
     *             zsttj(1),zssttj(1))
      call threet (cc,zp(im1,j,1),zp(im1,j,3),zttj(2),
     *             zsttj(2),zssttj(2))
c
c obtain t mesh distances
c
      del1 = tt-t(jm1)
      del2 = t(j)-tt
      dels = t(j)-t(jm1)
c
c obtain common coefficients
c
      cc(1) = del2/dels
      cc(2) = del1/dels
      d = -1./dels
      cc(5) = d
      cc(6) = -d
      if (sigmat .ne. 0.) go to 3
c
c obtain coefficients for cubic spline
c
      con = -del1*del2/(6.*dels)
      cc(3) = (del2+dels)*con
      cc(4) = (del1+dels)*con
      cc(7) = -(2.*del2*del2-del1*(del2+dels))/(6.*dels)
      cc(8) = (2.*del1*del1-del2*(del1+dels))/(6.*dels)
      cc(9) = cc(1)
      cc(10) = cc(2)
      go to 4
c
c obtain coefficients for spline under tension
c
    3 sigdel = sigmat*dels
      call snhcsh (sinhm1,coshm1,sigmat*del1,0)
      call snhcsh (sinhm2,coshm2,sigmat*del2,0)
      call snhcsh (sinhms,dummy,sigdel,-1)
      sinhs = 1.+sinhms
      con = 1./(sigmat*sigdel*sinhs)
      cc(3) = con*del2*(sinhm2-sinhms)
      cc(4) = con*del1*(sinhm1-sinhms)
      cc(7) = -con*(coshm2-sinhms)
      cc(8) = con*(coshm1-sinhms)
      cc(9) = (del2*(1.+sinhm2))/(dels*sinhs)
      cc(10) = (del1*(1.+sinhm1))/(dels*sinhs)
c
c interpolate in t direction
c
    4 call threet (cc,xj,xttj,xx,xt,xtt)
      call threet (cc,xsj,xsttj,xs,xst,dummy)
      xss = cc(1)*xssj(1)+cc(2)*xssj(2)+cc(3)*xssttj(1)+
     *      cc(4)*xssttj(2)
      call threet (cc,yj,yttj,yy,yt,ytt)
      call threet (cc,ysj,ysttj,ys,yst,dummy)
      yss = cc(1)*yssj(1)+cc(2)*yssj(2)+cc(3)*yssttj(1)+
     *      cc(4)*yssttj(2)
      call threet (cc,zj,zttj,zz,zt,ztt)
      call threet (cc,zsj,zsttj,zs,zst,dummy)
      zss = cc(1)*zssj(1)+cc(2)*zssj(2)+cc(3)*zssttj(1)+
     *      cc(4)*zssttj(2)
      return
      end
      subroutine vgen (n,x,sigma,v,ierr)
c
      integer n,ierr
      real x(n),sigma,v(5,n)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine generates an array of coefficients used by
c other subroutines for the determination of a b-spline
c under tension basis.
c
c on input--
c
c   n is the number of knots defining the basis (n .ge. 2).
c
c   x is the array of the n increasing knots. any linear
c   combination of the resulting basis will have third
c   derivative discontinuities only at the interior knots,
c   (i. e. x(2),...,x(n-1) ).
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the basis functions are approximately cubic
c   splines. if abs(sigma) is large (e. g. 50.) the basis
c   functions are nearly piecewise linear. if sigma equals
c   zero a cubic spline basis results. a standard value for
c   sigma is approximately 1. in absolute value.
c
c and
c
c   v is an array of at least 5*n locations.
c
c on output--
c
c   v contains certain coefficients to be used by other
c   subprograms for the determination of the b-spline under
c   tension basis. considered as a 5 by n array, for i = 1,
c   ... , n, b-spline basis function i is specified by--
c     v(1,i) = second derivative at x(i-1), for i .ne. 1,
c     v(2,i) = second derivative at x(i),   for all i,
c     v(3,i) = second derivative at x(i+1), for i .ne. n,
c     v(4,i) = function value at x(i-1),    for i .ne. 1,
c     v(5,i) = function value at x(i+1),    for i .ne. n,
c   and the properties that it has--
c     1. function value 1 at x(i),
c     2. function value and second derivative = 0 at
c        x(1), ... , x(i-2), and x(i+2), ... , x(n).
c   in v(5,n) and v(3,n) are contained function value and
c   second derivative of basis function zero at x(1),
c   respectively. in v(4,1) and v(1,1) are contained
c   function value and second derivative of basis function
c   n+1 at x(n), respectively. fuction value and second
c   derivative of these two basis functions are zero at all
c   other knots. only basis function zero has non-zero
c   second derivative value at x(1) and only basis
c   function n+1 has non-zero second derivative at x(n).
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if x-values are not strictly increasing.
c
c and
c
c   n, x, and sigma are unaltered.
c
c this subroutine references package modules terms and
c snhcsh.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      ierr = 0
      if (n .le. 1) go to 3
      if (x(n) .le. x(1)) go to 4
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c generate coefficients for left end basis functions
c
      d3 = x(2)-x(1)
      if (d3 .le. 0.) go to 4
      call terms (diag3,sdiag3,sigmap,d3)
      d4 = d3
      if (n .ge. 3) d4 = x(3)-x(2)
      if (d4 .le. 0.) go to 4
      call terms (diag4,sdiag4,sigmap,d4)
      a22 = diag3+sdiag3
      a23 = diag3+diag4+sdiag3+sdiag4
      v(2,1) = 0.
      v(3,1) = 1./(d3*(diag3+diag4)+(d3+d4)*sdiag4)
      v(5,1) = sdiag4*d4*v(3,1)
      if (n .eq. 2) go to 2
      a22 = 2.*a22
      d1 = d3
      d2 = d3
      d3 = d4
      diag1 = diag3
      diag2 = diag3
      diag3 = diag4
      sdiag1 = sdiag3
      sdiag2 = sdiag3
      sdiag3 = sdiag4
c
c generate coefficients for interior basis functions
c
      do 1 i = 2,nm1
        if (i .ne. nm1) d4 = x(i+2)-x(i+1)
        if (d4 .le. 0.) go to 4
        if (d4 .ne. d3) call terms (diag4,sdiag4,sigmap,d4)
        a11 = diag1+diag2+sdiag1*(1.+d1/d2)
        a12 = sdiag2/a11
        b1 = 1./(d2*a11)
        a33 = diag3+diag4+sdiag4*(1.+d4/d3)
        a32 = sdiag3/a33
        b3 = 1./(d3*a33)
        a21 = a22
        a22 = a23
        a23 = diag3+diag4+sdiag3+sdiag4
        v(2,i) = -(a21*b1+a23*b3)/(a22-a21*a12-a23*a32)
        v(1,i) = b1-a12*v(2,i)
        v(3,i) = b3-a32*v(2,i)
        v(4,i) = sdiag1*d1*v(1,i)
        v(5,i) = sdiag4*d4*v(3,i)
c
c save constants for next iteration
c
        d1 = d2
        d2 = d3
        d3 = d4
        diag1 = diag2
        diag2 = diag3
        diag3 = diag4
        sdiag1 = sdiag2
        sdiag2 = sdiag3
    1   sdiag3 = sdiag4
c
c generate coefficients for right end basis functions
c
      v(2,n) = 0.
      v(1,n) = 1./(d2*(diag1+diag2)+(d2+d1)*sdiag1)
      v(4,n) = sdiag1*d1*v(1,n)
      v(3,n) = v(1,3)
      v(5,n) = v(4,3)
      v(1,1) = v(3,n-2)
      v(4,1) = v(5,n-2)
c
c adjust basis for natural end conditions
c
      v(4,2) = v(4,2)-v(1,2)*v(5,n)/v(3,n)
      v(1,2) = 0.
      v(5,nm1) = v(5,nm1)-v(3,nm1)*v(4,1)/v(1,1)
      v(3,nm1) = 0.
      return
c
c n equal to 2
c
    2 v(4,1) = v(5,1)
      v(1,1) = v(3,1)
      v(3,1) = 0.
      v(5,1) = 0.
      v(1,2) = 0.
      v(2,2) = 0.
      v(3,2) = v(1,1)
      v(4,2) = 0.
      v(5,2) = v(4,1)
      return
c
c too few knots
c
    3 ierr = 1
      return
c
c x-values not strictly increasing
c
    4 ierr = 2
      return
      end
      subroutine vgenp (n,x,p,sigma,v,ierr)
c
      integer n,ierr
      real x(n),p,sigma,v(5,n)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine generates an array of coefficients used by
c other subroutines for the determination of a periodic
c b-spline under tension basis.
c
c on input--
c
c   n is the number of knots defining the basis (n .ge. 2).
c
c   x is the array of the n increasing knots. any linear
c   combination of the resulting basis will have third
c   derivative discontinuities only at the knots and their
c   periodic translations (i. e. ...,x(1)-p,...,x(n)-p,x(1),
c   ...,x(n),x(1)+p,...,x(n)+p,... ).
c
c   p is the period (p .gt. x(n)-x(1)).
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the basis functions are approximately cubic
c   splines. if abs(sigma) is large (e. g. 50.) the basis
c   functions are nearly piecewise linear. if sigma equals
c   zero a cubic spline basis results. a standard value for
c   sigma is approximately 1. in absolute value.
c
c and
c
c   v is an array of at least 5*n locations.
c
c on output--
c
c   v contains certain coefficients to be used by other
c   subprograms for the determination of the periodic
c   b-spline under tension basis. considered as a 5 by n
c   array, for i = 1, ... , n, b-spline basis function i is
c   specified by--
c     v(1,i) = second derivative at x(i-1),
c     v(2,i) = second derivative at x(i),
c     v(3,i) = second derivative at x(i+1),
c     v(4,i) = function value at x(i-1),
c     v(5,i) = function value at x(i+1),
c   and the properties that it has--
c     1. function value 1 at x(i),
c     2. function value = 0 at x(1), ... , x(i-2) and
c        x(i+2), ... , x(n),
c     3. if n is greater than 3, second derivative = 0 at
c        x(1), ... , x(i-2) and x(i-2), ... , x(n).
c     the meaning of x(0) = x(n)-p, x(-1) = x(n-1)-p,
c     x(n+1) = x(1)+p, and x(n+2) = x(2)+p.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if p is less than or equal to x(n)-x(1),
c        = 3 if x-values are not strictly increasing.
c
c and
c
c   n, x, p, and sigma are unaltered.
c
c this subroutine references package modules terms and
c snhcsh.
c
c-----------------------------------------------------------
c
      real d(3),b(3)
c
      nm1 = n-1
      ierr = 0
      if (n .le. 1) go to 5
      if (p .le. 0. .or. p .le. x(n)-x(1)) go to 6
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/p
c
c set up constants for loop initiation
c
      if (n .eq. 2) go to 2
      if (n .eq. 3) go to 3
      d1 = x(n)-x(n-1)
      d2 = x(1)+p-x(n)
      d3 = x(2)-x(1)
      if (d1 .le. 0. .or. d2 .le. 0. .or. d3 .le. 0.)
     *   go to 7
      call terms (diag1,sdiag1,sigmap,d1)
      call terms (diag2,sdiag2,sigmap,d2)
      call terms (diag3,sdiag3,sigmap,d3)
      diag4 = diag3
      sdiag4 = sdiag3
      a22 = diag1+diag2+sdiag1+sdiag2
      a23 = diag2+diag3+sdiag2+sdiag3
c
c generate coefficients for basis functions
c
      do 1 i = 1,n
        d4 = x(2)-x(1)
        if (i .eq. nm1) d4 = x(1)+p-x(n)
        if (i .lt. nm1) d4 = x(i+2)-x(i+1)
        if (d4 .le. 0.) go to 7
        if (d4 .ne. d3) call terms (diag4,sdiag4,sigmap,d4)
        a11 = diag1+diag2+sdiag1*(1.+d1/d2)
        a12 = sdiag2/a11
        b1 = 1./(d2*a11)
        a33 = diag3+diag4+sdiag4*(1.+d4/d3)
        a32 = sdiag3/a33
        b3 = 1./(d3*a33)
        a21 = a22
        a22 = a23
        a23 = diag3+diag4+sdiag3+sdiag4
        v(2,i) = -(a21*b1+a23*b3)/(a22-a21*a12-a23*a32)
        v(1,i) = b1-a12*v(2,i)
        v(3,i) = b3-a32*v(2,i)
        v(4,i) = sdiag1*d1*v(1,i)
        v(5,i) = sdiag4*d4*v(3,i)
c
c save constants for next iteration
c
        d1 = d2
        d2 = d3
        d3 = d4
        diag1 = diag2
        diag2 = diag3
        diag3 = diag4
        sdiag1 = sdiag2
        sdiag2 = sdiag3
    1   sdiag3 = sdiag4
      return
c
c n equal to 2
c
    2 d1 = x(2)-x(1)
      d2 = x(1)+p-x(2)
      if (d1 .le. 0. .or. d2 .le. 0.) go to 7
      call terms (diag1,sdiag1,sigmap,d1)
      call terms (diag2,sdiag2,sigmap,d2)
      v(2,1) = -(1./d1+1./d2)/(diag1+diag2-sdiag1-sdiag2)
      v(1,1) = -v(2,1)
      v(3,1) = -v(2,1)
      v(4,1) = 0.
      v(5,1) = 0.
      v(2,2) = v(2,1)
      v(1,2) = -v(2,2)
      v(3,2) = -v(2,2)
      v(4,2) = 0.
      v(5,2) = 0.
      return
c
c n equal to 3
c
    3 d(1) = x(2)-x(1)
      d(2) = x(3)-x(2)
      d(3) = x(1)+p-x(3)
      if (d(1) .le. 0. .or. d(2) .le. 0. .or. d(3) .le. 0.)
     *   go to 7
      call terms (diag1,sdiag1,sigmap,d(1))
      call terms (diag2,sdiag2,sigmap,d(2))
      call terms (diag3,sdiag3,sigmap,d(3))
      t11 = 1./(diag3+diag1)
      t21 = sdiag1*t11
      t31 = sdiag3*t11
      t22 = 1./(diag1+diag2-t21*sdiag1)
      t = sdiag2-t21*sdiag3
      t32 = t22*t
      t33 = 1./(diag2+diag3-t31*sdiag3-t32*t)
      do 4 i = 1,3
        im1 = i-1
        if (i .eq. 1) im1 = 3
        ip1 = i+1
        if (i .eq. 3) ip1 = 1
        b(im1) = 1./d(im1)
        b(i) = -(1./d(im1)+1./d(i))
        b(ip1) = 1./d(i)
        b(2) = b(2)-t21*b(1)
        b(3) = t33*(b(3)-t31*b(1)-t32*b(2))
        b(2) = t22*b(2)-t32*b(3)
        b(1) = t11*b(1)-t21*b(2)-t31*b(3)
        v(1,i) = b(im1)
        v(2,i) = b(i)
        v(3,i) = b(ip1)
        v(4,i) = 0.
    4   v(5,i) = 0.
      return
c
c too few knots
c
    5 ierr = 1
      return
c
c invalid period
c
    6 ierr = 2
      return
c
c x-values not strictly increasing
c
    7 ierr = 3
      return
      end
      subroutine bsplnz (t,n,x,v,sigma,istart,b)
c
      integer n,istart
      real t,x(n),v(5,n),sigma,b(4)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine evaluates at a given point the four non-
c zero basis functions of a b-spline under tension basis.
c the index of the first non-zero basis function is also
c determined. (the sense of the word non-zero is extended to
c include the special cases where the given point coincides
c with a knot in which case one of the four returned
c function values may be zero.) the subroutine vgen should
c be called earlier to determine certain necessary
c coefficients.
c
c on input--
c
c   t contains a real value at which the basis functions are
c   to be evaluated.
c
c   n contains the number of knots defining the basis.
c
c   x contains the array of knots.
c
c   v contains the array of coefficients determined by vgen
c   for calculation of basis functions.
c
c   sigma contains the tension factor (its sign is ignored).
c
c   istart is an integer variable.
c
c and
c
c   b is a real array of length 4.
c
c the parameters n, x, v, and sigma should be input
c unaltered from the output of vgen.
c
c on output--
c
c   istart contains the index of the first non-zero basis
c   function. thus 0 .le. istart .le. n-2 and the non-zero
c   basis functions have indices istart, ... , istart+3.
c
c   b contains the values at t of basis functions istart,
c   ... , istart+3 in b(1), ... , b(4), respectively.
c   t, n, x, v, and sigma are unaltered.
c
c this subroutine references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c determine index of first non-zero basis function
c
      i = intrvl (t,x,n)-1
c
c compute distances to adjacent knots and lagrangian
c weights
c
      del1 = t-x(i+1)
      del2 = x(i+2)-t
      dels = x(i+2)-x(i+1)
      c1 = del2/dels
      c2 = del1/dels
      if (sigmap .ne. 0.) go to 1
      fac = -del1*del2/(6.*dels)
      cp1 = fac*(del2+dels)
      cp2 = fac*(del1+dels)
      go to 2
    1 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (s1,dummy,sigmap*del1,-1)
      call snhcsh (s2,dummy,sigmap*del2,-1)
      d = sigdel*sigmap*(1.+ss)
      cp1 = del1*(s1-ss)/d
      cp2 = del2*(s2-ss)/d
c
c compute basis function values
c
    2 ii = i
      if (ii .eq. 0) ii = n
      iip1 = i+1
      iip2 = i+2
      iip3 = i+3
      if (iip2 .eq. n) iip3 = 1
      b(1) = c1*v(5,ii)+cp1*v(3,ii)
      b(2) = c1+c2*v(5,iip1)+cp1*v(2,iip1)+cp2*v(3,iip1)
      b(3) = c1*v(4,iip2)+c2+cp1*v(1,iip2)+cp2*v(2,iip2)
      b(4) = c2*v(4,iip3)+cp2*v(1,iip3)
      istart = i
      return
      end
      subroutine bsppnz (t,n,x,p,v,sigma,istart,b)
c
      integer n,istart
      real t,x(n),p,v(5,n),sigma,b(4)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine evaluates at a given point the four non-
c zero basis functions of a periodic b-spline under tension
c basis. the index of the first non-zero basis function is
c also determined. (the sense of the word non-zero is
c extended to include the special cases where the given
c point coincides with a knot in which case the last of the
c four function values is zero.) the subroutine vgenp should
c be called earlier to determine certain necessary
c coefficients. for n equal to 2 and 3 only n basis
c functions exist. these are the only values returned.
c
c on input--
c
c   t contains a real value at which the basis functions are
c   to be evaluated.
c
c   n contains the number of knots defining the basis.
c
c   x contains the array of knots.
c
c   p is the period.
c
c   v contains the array of coefficients determined by vgenp
c   for calculation of basis functions.
c
c   sigma contains the tension factor (its sign is ignored).
c
c   istart is an integer variable.
c
c and
c
c   b is a real array of length 4.
c
c the parameters n, x, p, v, and sigma should be input
c unaltered from the output of vgenp.
c
c on output--
c
c   istart contains the index of the first non-zero basis
c   function. thus 1 .le. istart .le. n and the non-zero
c   basis functions have indices istart, ... , istart+3
c   interpreted in a cyclical fashion (e. g. if istart = n-1
c   then the active indices are n-1, n, 1, and 2).
c   furthermore, for n = 2 and n = 3, istart = 1 and only
c   1, ... , n are the indices of the basis functions.
c
c   b contains the values at t of basis functions istart,
c   ... , istart+3 in b(1), ... , b(4), respectively (except
c   for n = 2 and n = 3 for which only b(1), ... , b(n)
c   contain values).
c
c and
c
c   t, n, x, p, v, and sigma are unaltered.
c
c this subroutine references package modules intrvp and
c snhcsh.
c
c-----------------------------------------------------------
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/p
c
c determine index of first non-zero basis function
c
      i = intrvp (t,x,n,p,tp)-1
c
c compute distances to adjacent knots and lagrangian
c weights
c
      del1 = tp-x(i+1)
      xip2 = x(1)+p
      if (i .ne. n-1) xip2 = x(i+2)
      del2 = xip2-tp
      dels = xip2-x(i+1)
      c1 = del2/dels
      c2 = del1/dels
      if (sigmap .ne. 0.) go to 1
      fac = -del1*del2/(6.*dels)
      cp1 = fac*(del2+dels)
      cp2 = fac*(del1+dels)
      go to 2
    1 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (s1,dummy,sigmap*del1,-1)
      call snhcsh (s2,dummy,sigmap*del2,-1)
      d = sigdel*sigmap*(1.+ss)
      cp1 = del1*(s1-ss)/d
      cp2 = del2*(s2-ss)/d
c
c compute basis function values
c
    2 ii = mod(i+n-1,n)+1
      iip1 = mod(i,n)+1
      if (n .eq. 2) go to 3
      iip2 = mod(i+1,n)+1
      if (n .eq. 3) go to 4
      iip3 = mod(i+2,n)+1
      b(1) = c1*v(5,ii)+cp1*v(3,ii)
      b(2) = c1+c2*v(5,iip1)+cp1*v(2,iip1)+cp2*v(3,iip1)
      b(3) = c1*v(4,iip2)+c2+cp1*v(1,iip2)+cp2*v(2,iip2)
      b(4) = c2*v(4,iip3)+cp2*v(1,iip3)
      istart = ii
      return
c
c n equal to 2
c
    3 b(ii) = c2+(cp2-cp1)*v(2,ii)
      b(iip1) = 1.-b(ii)
      istart = 1
      return
c
c n equal to 3
c
    4 b(ii) = cp1*v(3,ii)+cp2*v(1,ii)
      b(iip1) = c1+cp1*v(2,iip1)+cp2*v(3,iip1)
      b(iip2) = c2+cp1*v(1,iip2)+cp2*v(2,iip2)
      istart = 1
      return
      end
      subroutine dsplnz (t,n,x,v,sigma,istart,b)
c
      integer n,istart
      real t,x(n),v(5,n),sigma,b(3,4)
c
c                       coded by a. k. cline and r. j. renka
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine evaluates at a given point the four non-
c zero basis functions of a b-spline under tension basis and
c their first and second derivatives. the index of the first
c non-zero basis function is also determined. (the sense of
c the word non-zero is extended to include the special case
c where the given point coincides with a knot in which case
c the last of the four returned function values may be zero.
c ) the subroutine vgen should be called earlier to
c determine certain necessary coefficients.
c
c on input--
c
c   t contains a real value at which the basis functions are
c   to be evaluated.
c
c   n contains the number of knots defining the basis.
c
c   x contains the array of knots.
c
c   v contains the array of coefficients determined by vgen
c   for calculation of basis functions.
c
c   sigma contains the tension factor (its sign is ignored).
c
c   istart is an integer variable.
c
c and
c
c   b is a real array with 3 rows and 4 columns.
c
c the parameters n, x, v, and sigma should be input
c unaltered from the output of vgen.
c
c on output--
c
c   istart contains the index of the first non-zero basis
c   function. thus 0 .le. istart .le. n-2 and the non-zero
c   basis functions have indices istart, ... , istart+3.
c
c   b contains the values at t of basis functions istart,
c   ... , istart+3 in b(1,1), ... , b(1,4), respectively.
c   first and second derivatives of the corresponding
c   functions are contained in b(2,1), ... , b(2,4), and
c   b(3,1), ... , b(3,4), respectively.
c
c   t, n, x, v, and sigma are unaltered.
c
c this subroutine references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c determine index of first non-zero basis function
c
      i = intrvl (t,x,n)-1
c
c compute distances to adjacent knots and lagrangian
c weights
c
      del1 = t-x(i+1)
      del2 = x(i+2)-t
      dels = x(i+2)-x(i+1)
      c10 = del2/dels
      c20 = del1/dels
      c11 = -1./dels
      c21 = 1./dels
      if (sigmap .ne. 0.) go to 1
      fac = -del1*del2/(6.*dels)
      cp10 = fac*(del2+dels)
      cp20 = fac*(del1+dels)
      cp11 = -(2.*del2*del2-del1*(del2+dels))/(6.*dels)
      cp21 = (2.*del1*del1-del2*(del1+dels))/(6.*dels)
      cp12 = c10
      cp22 = c20
      go to 2
    1 sigdel = sigmap*dels
      call snhcsh (sinhm1,coshm1,sigmap*del1,0)
      call snhcsh (sinhm2,coshm2,sigmap*del2,0)
      call snhcsh (sinhms,dummy,sigdel,-1)
      denom = sigmap*sigdel*(1.+sinhms)
      cp10 = del2*(sinhm2-sinhms)/denom
      cp20 = del1*(sinhm1-sinhms)/denom
      cp11 = -(coshm2-sinhms)/denom
      cp21 = (coshm1-sinhms)/denom
      cp12 = del2*(1.+sinhm2)/(dels*(1.+sinhms))
      cp22 = del1*(1.+sinhm1)/(dels*(1.+sinhms))
c
c compute basis function values
c
    2 ii = i
      if (ii .eq. 0) ii = n
      iip1 = i+1
      iip2 = i+2
      iip3 = i+3
      if (iip2 .eq. n) iip3 = 1
      b(1,1) = c10*v(5,ii)+cp10*v(3,ii)
      b(1,2) = c10+c20*v(5,iip1)+cp10*v(2,iip1)+
     *         cp20*v(3,iip1)
      b(1,3) = c10*v(4,iip2)+c20+cp10*v(1,iip2)+
     *         cp20*v(2,iip2)
      b(1,4) = c20*v(4,iip3)+cp20*v(1,iip3)
      b(2,1) = c11*v(5,ii)+cp11*v(3,ii)
      b(2,2) = c11+c21*v(5,iip1)+cp11*v(2,iip1)+
     *         cp21*v(3,iip1)
      b(2,3) = c11*v(4,iip2)+c21+cp11*v(1,iip2)+
     *         cp21*v(2,iip2)
      b(2,4) = c21*v(4,iip3)+cp21*v(1,iip3)
      b(3,1) = cp12*v(3,ii)
      b(3,2) = cp12*v(2,iip1)+cp22*v(3,iip1)
      b(3,3) = cp12*v(1,iip2)+cp22*v(2,iip2)
      b(3,4) = cp22*v(1,iip3)
      istart = i
      return
      end
      subroutine dsppnz (t,n,x,p,v,sigma,istart,b)
c
      integer n,istart
      real t,x(n),p,v(5,n),sigma,b(3,4)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine evaluates at a given point the four non-
c zero basis functions of a periodic b-spline under tension
c basis and their first and second derivatives. the index of
c the first non-zero basis function is also determined. (the
c sense of the word non-zero is extended to include the
c special cases where the given point coincides with knot
c in which case the last of the four function values and
c derivatives are zero.) the subroutine vgenp should be
c called earlier to determine certain necessary coefficients
c . for n equal to two and n equal to three only n basis
c functions exist. these are the only values returned.
c
c on input--
c
c   t contains a real value at which the basis functions are
c   to be evaluated.
c
c   n contains the number of knots defining the basis.
c
c   x contains the array of knots.
c
c   p is the period.
c
c   v contains the array of coefficients determined by vgenp
c   for calculation of basis functions.
c
c   sigma contains the tension factor (its sign is ignored).
c
c   istart is an integer variable.
c
c and
c
c   b is a real array with 3 rows and 4 columns.
c
c the parameters n, x, p, v, and sigma should be input
c unaltered from the output of vgenp.
c
c on output--
c
c   istart contains the index of the first non-zero basis
c   function. thus 1 .le. istart .le. n and the non-zero
c   basis functions have indices istart, ... , istart+3
c   interpreted in a cyclical fashion (e. g. if istart = n-1
c   then the active indices are n-1, n, 1, and 2).
c   furthermore, for n = 2 and n = 3, istart = 1 and only
c   1, ... , n are the indices of the basis functions.
c
c   b contains the values at t of basis functions istart,
c   ... , istart+3 in b(1,1), ... , b(1,4), respectively,
c   corresponding first derivatives in b(2,1), ... , b(2,4),
c   and corresponding second derivatives in b(3,1), ... ,
c   b(3,4) (except for n = 2 and n = 3 for which only b(.,1)
c   , ... , b(.,n) contain values).
c
c and
c
c   t, n, x, p, v, and sigma are unaltered.
c
c this subroutine references package modules intrvp and
c snhcsh.
c
c-----------------------------------------------------------
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/p
c
c determine index of first non-zero basis function
c
      i = intrvp (t,x,n,p,tp)-1
c
c compute distances to adjacent knots and lagrangian
c weights
c
      del1 = tp-x(i+1)
      xip2 = x(1)+p
      if (i .ne. n-1) xip2 = x(i+2)
      del2 = xip2-tp
      dels = xip2-x(i+1)
      c10 = del2/dels
      c20 = del1/dels
      c11 = -1./dels
      c21 = 1./dels
      if (sigmap .ne. 0.) go to 1
      fac = -del1*del2/(6.*dels)
      cp10 = fac*(del2+dels)
      cp20 = fac*(del1+dels)
      cp11 = -(2.*del2*del2-del1*(del2+dels))/(6.*dels)
      cp21 = (2.*del1*del1-del2*(del1+dels))/(6.*dels)
      cp12 = c10
      cp22 = c20
      go to 2
    1 sigdel = sigmap*dels
      call snhcsh (sinhm1,coshm1,sigmap*del1,0)
      call snhcsh (sinhm2,coshm2,sigmap*del2,0)
      call snhcsh (sinhms,dummy,sigdel,-1)
      denom = sigmap*sigdel*(1.+sinhms)
      cp10 = del2*(sinhm2-sinhms)/denom
      cp20 = del1*(sinhm1-sinhms)/denom
      cp11 = -(coshm2-sinhms)/denom
      cp21 = (coshm1-sinhms)/denom
      cp12 = del2*(1.+sinhm2)/(dels*(1.+sinhms))
      cp22 = del1*(1.+sinhm1)/(dels*(1.+sinhms))
c
c compute basis function values
c
    2 ii = mod(i+n-1,n)+1
      iip1 = mod(i,n)+1
      if (n .eq. 2) go to 3
      iip2 = mod(i+1,n)+1
      if (n .eq. 3) go to 4
      iip3 = mod(i+2,n)+1
      b(1,1) = c10*v(5,ii)+cp10*v(3,ii)
      b(1,2) = c10+c20*v(5,iip1)+cp10*v(2,iip1)+
     *         cp20*v(3,iip1)
      b(1,3) = c10*v(4,iip2)+c20+cp10*v(1,iip2)+
     *         cp20*v(2,iip2)
      b(1,4) = c20*v(4,iip3)+cp20*v(1,iip3)
      b(2,1) = c11*v(5,ii)+cp11*v(3,ii)
      b(2,2) = c11+c21*v(5,iip1)+cp11*v(2,iip1)+
     *         cp21*v(3,iip1)
      b(2,3) = c11*v(4,iip2)+c21+cp11*v(1,iip2)+
     *         cp21*v(2,iip2)
      b(2,4) = c21*v(4,iip3)+cp21*v(1,iip3)
      b(3,1) = cp12*v(3,ii)
      b(3,2) = cp12*v(2,iip1)+cp22*v(3,iip1)
      b(3,3) = cp12*v(1,iip2)+cp22*v(2,iip2)
      b(3,4) = cp22*v(1,iip3)
      istart = ii
      return
c
c n equal to 2
c
    3 b(1,ii) = c20+(cp20-cp10)*v(2,ii)
      b(1,iip1) = 1.-b(1,ii)
      b(2,ii) = c21+(cp21-cp11)*v(2,ii)
      b(2,iip1) = -b(2,ii)
      b(3,ii) = (cp22-cp12)*v(2,ii)
      b(3,iip1) = -b(3,ii)
      istart = 1
      return
c
c n equal to 3
c
    4 b(1,ii) = cp10*v(3,ii)+cp20*v(1,ii)
      b(1,iip1) = c10+cp10*v(2,iip1)+cp20*v(3,iip1)
      b(1,iip2) = c20+cp10*v(1,iip2)+cp20*v(2,iip2)
      b(2,ii) = cp11*v(3,ii)+cp21*v(1,ii)
      b(2,iip1) = c11+cp11*v(2,iip1)+cp21*v(3,iip1)
      b(2,iip2) = c21+cp11*v(1,iip2)+cp21*v(2,iip2)
      b(3,ii) = cp12*v(3,ii)+cp22*v(1,ii)
      b(3,iip1) = cp12*v(2,iip1)+cp22*v(3,iip1)
      b(3,iip2) = cp12*v(1,iip2)+cp22*v(2,iip2)
      istart = 1
      return
      end
      subroutine btoh1 (n,c,v,y,yp)
c
      integer n
      real c(1),v(5,n),y(n),yp(n)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine obtains a hermite interpolation
c representation (i.e. function values and second
c derivatives) for a one dimensional spline from a b-spline
c basis representation.
c
c on input--
c
c   n is the number of knots defining the b-spline basis
c   (n .ge. 2).
c
c   c contains the array of n+2 coefficients of the b-spline
c   representation. for i = 1, ... , n+2, c(i) is the
c   coefficient for basis function i-1.
c
c   v is an array containing the b-spline under tension
c   basis data as determined by vgen.
c
c and
c
c   y and yp are arrays of at least n locations.
c
c on output--
c
c   y contains the function values at the knots (i.e. y(i)
c   contains the function value at x(i), for i=1,...,n).
c
c   yp contains the second derivative of the spline at the
c   knots (i.e. yp(i) contains the second derivative at
c   x(i), for i=1,...,n).
c
c and
c
c   none of the input parameters are altered.
c
c-----------------------------------------------------------
c
c combine data from v array to determine function and second
c derivative values
c
      do 1 i = 1,n
        im1 = i-1
        if (i .eq. 1) im1 = n
        ip1 = i+1
        if (i .eq. n) ip1 = 1
        y(i) = c(i)*v(5,im1)+c(i+1)+c(i+2)*v(4,ip1)
    1   yp(i) = c(i)*v(3,im1)+c(i+1)*v(2,i)
     *          +c(i+2)*v(1,ip1)
      return
      end
      subroutine nbtoh1 (n,c,v,y,yp)
c
      integer n
      real c(n),v(5,n),y(n),yp(n)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine obtains a hermite interpolation
c representation (i.e. function values and second
c derivatives) for a one dimensional spline from a b-spline
c basis representation. the spline is assumed to have
c natural end conditions.
c
c on input--
c
c   n is the number of knots defining the b-spline basis
c   (n .ge. 2).
c
c   c is an array containing the coefficients of the spline
c   with respect to the b-spline basis.
c
c   v is an array containing the b-spline under tension
c   basis data as determined by vgen.
c
c and
c
c   y and yp are arrays of at least n locations.
c
c on output--
c
c   y contains the function values at the knots (i.e. y(i)
c   contains the function value at x(i), for i=1,...,n).
c
c   yp contains the second derivative of the spline at the
c   knots (i.e. yp(i) contains the second derivative at
c   x(i), for i=1,...,n).
c
c and
c
c   none of the input parameters are altered.
c
c-----------------------------------------------------------
c
c combine data from v array to determine function and second
c derivative values
c
      y(1) = c(1)+c(2)*v(4,2)
      yp(1) = c(1)*v(2,1)+c(2)*v(1,2)
      if (n .eq. 2) go to 2
      nm1 = n-1
      do 1 i = 2,nm1
        y(i) = c(i-1)*v(5,i-1)+c(i)+c(i+1)*v(4,i+1)
    1   yp(i) = c(i-1)*v(3,i-1)+c(i)*v(2,i)+c(i+1)*v(1,i+1)
    2 y(n) = c(nm1)*v(5,nm1)+c(n)
      yp(n) = c(nm1)*v(3,nm1)+c(n)*v(2,n)
      return
      end
      function arcln2 (t)
c
      real t
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function determines the arclength integrand
c
c          sqrt ( xprime (t) **2 + yprime (t) **2 )
c
c of a curve (x(t),y(t)) each of whose components is a
c spline under tension (and where xprime and yprime indicate
c the derivatives of x and y, respectively).
c
c on input--
c
c   t is a value of the independent variable.
c
c on output--
c
c   arcln2 contains the arclength integrand quantity
c   evaluated at t.
c
c and
c
c   t is unaltered.
c
c this function references package module snhcsh.
c
c a common block named ar2com is used.
c
c-----------------------------------------------------------
c
c the elements of ar2com are as follows--
c   (let im1 = intrvl (t,s,n) and i = im1+1)
c   sim1   contains s(im1)
c   si     contains s(i)
c   dels   contains s(i)-s(im1)
c   sxim1  contains (x(i)-x(im1))/dels
c   syim1  contains (y(i)-y(im1))/dels
c   sinhms contains sinhm (sigmap*dels)
c   con    contains sigmap**2*dels*(1.+sinhms)
c   xpi    contains xp(i)
c   xpim1  contains xp(im1)
c   yp     contains yp(i)
c   ypim1  contains yp(im1)
c
      common /ar2com/ sigmap,si,sim1,dels,sxim1,syim1,
     *                sinhms,con,xpi,xpim1,ypi,ypim1
c
      del1 = t-sim1
      del2 = si-t
      if (sigmap .ne. 0.) go to 1
      ci = (2.*del1*del1-del2*(del1+dels))/(6.*dels)
      cim1 = -(2.*del2*del2-del1*(del2+dels))/(6.*dels)
      go to 2
    1 call snhcsh (dummy,coshm1,sigmap*del1,1)
      call snhcsh (dummy,coshm2,sigmap*del2,1)
      ci = (coshm1-sinhms)/con
      cim1 = -(coshm2-sinhms)/con
    2 sumx = sxim1+ci*xpi+cim1*xpim1
      sumy = syim1+ci*ypi+cim1*ypim1
      arcln2 = sqrt(sumx*sumx+sumy*sumy)
      return
      end
      function arcln3 (t)
c
      real t
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function determines the arclength integrand
c
c  sqrt ( xprime (t) **2 + yprime (t) **2 + zprime (t) **2 )
c
c of a curve (x(t),y(t),z(t)) each of whose components is a
c spline under tension (and where xprime, yprime, and zprime
c indicate the derivatives of x, y, and z, respectively).
c
c on input--
c
c   t is a value of the independent variable.
c
c on output--
c
c   arcln3 contains the arclength integrand quantity
c   evaluated at t.
c
c and
c
c   t is unaltered.
c
c this function references package module snhcsh.
c
c a common block named ar3com is used.
c
c-----------------------------------------------------------
c
c the elements of ar3com are as follows--
c   (let im1 = intrvl (t,s,n) and i = im1+1)
c   sim1   contains s(im1)
c   si     contains s(i)
c   dels   contains s(i)-s(im1)
c   sxim1  contains (x(i)-x(im1))/dels
c   syim1  contains (y(i)-y(im1))/dels
c   szim1  contains (z(i)-z(im1))/dels
c   sinhms contains sinhm (sigmap*dels)
c   con    contains sigmap**2*dels*(1.+sinhms)
c   xpi    contains xp(i)
c   xpim1  contains xp(im1)
c   yp     contains yp(i)
c   ypim1  contains yp(im1)
c   zp     contains zp(i)
c   zpim1  contains zp(im1)
c
      common /ar3com/ sigmap,si,sim1,dels,sxim1,syim1,
     *                szim1,sinhms,con,xpi,xpim1,ypi,ypim1,
     *                zpi,zpim1
c
      del1 = t-sim1
      del2 = si-t
      if (sigmap .ne. 0.) go to 1
      ci = (2.*del1*del1-del2*(del1+dels))/(6.*dels)
      cim1 = -(2.*del2*del2-del1*(del2+dels))/(6.*dels)
      go to 2
    1 call snhcsh (dummy,coshm1,sigmap*del1,1)
      call snhcsh (dummy,coshm2,sigmap*del2,1)
      ci = (coshm1-sinhms)/con
      cim1 = -(coshm2-sinhms)/con
    2 sumx = sxim1+ci*xpi+cim1*xpim1
      sumy = syim1+ci*ypi+cim1*ypim1
      sumz = szim1+ci*zpi+cim1*zpim1
      arcln3 = sqrt(sumx*sumx+sumy*sumy+sumz*sumz)
      return
      end
      function area (t)
c
      real t
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function determines the area integrand
c
c          x (t) * yprime (t)
c
c of a curve (x(t),y(t)) each of whose components is a
c spline under tension (and where yprime indicates the
c derivative of y).
c
c on input--
c
c   t is a value of the independent variable.
c
c on output--
c
c   area contains the area integrand quantity evaluated at
c   t.
c
c and
c
c   t is unaltered.
c
c this function references package module snhcsh.
c
c a common block named arecom is used.
c
c-----------------------------------------------------------
c
c the elements of arecom are as follows--
c   (let im1 = intrvl (t,s,n) and i = im1+1 (= 1 if im1 = n)
c   sim1   contains s(im1)
c   si     contains s(i) (s(1) + s(n) if i = 1)
c   dels   contains s(i)-s(im1)
c   xi     contains x(i)
c   xim1   contains x(im1)
c   syim1  contains (y(i)-y(im1))/dels
c   sinhms contains sinhm (sigmap*dels)
c   con    contains sigmap**2*dels*(1.+sinhms)
c   xpi    contains xp(i)
c   xpim1  contains xp(im1)
c   yp     contains yp(i)
c   ypim1  contains yp(im1)
c
      common /arecom/ sigmap,si,sim1,dels,xi,xim1,syim1,
     *                sinhms,con,xpi,xpim1,ypi,ypim1
c
c
c determine x(t) and yprime(t)
c
      del1 = t-sim1
      del2 = si-t
      sumx = (xi*del1+xim1*del2)/dels
      if (sigmap .ne. 0.) go to 1
      dels6 = 6.*dels
      d = del1*del2/dels6
      c1 = -(del1+dels)*d
      c2 = -(del2+dels)*d
      ct1 = (2.*del1*del1-del2*(del1+dels))/dels6
      ct2 = -(2.*del2*del2-del1*(del2+dels))/dels6
      go to 2
    1 call snhcsh (s1,co1,sigmap*del1,0)
      call snhcsh (s2,co2,sigmap*del2,0)
      c1 = del1*(s1-sinhms)/con
      c2 = del2*(s2-sinhms)/con
      ct1 = (co1-sinhms)/con
      ct2 = -(co2-sinhms)/con
    2 xs = sumx+c1*xpi+c2*xpim1
      yst = syim1+ct1*ypi+ct2*ypim1
      area = xs*yst
      return
      end
      subroutine bdryn(m,n,isw,istar,id,d,r1,r2,r3,
     *                iz,z1,z2,z3,sigma,ifp,fp,ierr)
c
      integer m,n,isw,istar,id,iz,ifp,ierr
      real    d(1),z1(1),z2(1),z3(1),
     *        sigma,fp(1),r1,r2,r3
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine constructs non-polar boundary derivatives.
c if f is a function of r and theta defined over a grid with m
c m r-values and n theta-values, the values of fr(r(1),theta(j)),
c j = 1,...,n are placed in array fp, where fr denotes the
c partial derivative of f with respect to r.
c
c on input--
c
c   m is the number of r-values in the grid (m .ge. 2).
c
c   n is the number of derivatives to be placed in fp
c   (n .ge. 1).
c
c   isw specifies whether or not derivatives are user-
c   supplied.
c       = 0 if derivatives are in d.
c         .ne. 0 if derivatives are to be approximated.
c
c   istar describes monotonicity of the grid.
c         = 0 if data is strictly monotone
c         .ne. 0 otherwise
c
c   id is the distance between derivatives in d.
c
c   d is an array of n derivatives.  its contents are
c   ignored if isw .ne. 0.
c
c   r1,r2,r3 are the grid values r(1), r(2), r(3).
c
c   iz is the distance between function values in arrays
c   z1, z2, z3.
c
c   z1 is an array containing the n function values at
c   (r(1),theta(j)),j = 1,...,n.
c
c   z2 is an array containing the n function values at
c   (r(2),theta(j)),j = 1,...,n.
c
c   z3 is an array containing the n function values at
c   (r(3),theta(j),j = 1,...,n.  z3 is ignored if m = 2.
c
c   sigma is the denormalized tension factor.
c
c and
c
c   ifp is the distance between derivatives in fp.
c
c on output--
c
c   fp is the array which contains the n derivatives.
c
c   ierr is an error flag,
c        = 0  if normal return,
c        = 1  if input dimensions are too small.
c
c and
c
c   the input parameters are unaltered.
c
c this module references package module ceez.
c
c-----------------------------------------------------------
c
      integer i,idi,ifi,izi
c
      ierr = 0
      if (n .lt. 1 .or. m .lt. 2) go to 7
      if (isw .ne. 0) go to 2
c
c derivatives supplied
c
      idi = 1
      ifi = 1
      do 1 i = 1,n
         fp(ifi) = d(idi)
         ifi = ifi+ifp
    1    idi = idi+id
      return
c
c estimate derivatives
c
    2 delr1 = r2-r1
      if (m .eq. 2) go to 3
      delr2 = r3-r1
      if (delr1 .eq. sign(delr1,r3-r2)) go to 4
c
c adjust for non-monotonic data
c
      delr2 = delr2-sign(360.,delr2)
      if (r3-r1 .ne. sign(r3-r1,r3-r2))
     *    delr1 = delr1-sign(360.,delr1)
      go to 4
c
c
c m = 2
c
    3 if (istar .gt. 0) delr1 = delr1+360.
      delr2 = delr1+delr1
c
    4 call ceez(delr1,delr2,sigma,c1,c2,c3,m)
      izi = 1
      ifi = 1
      do 5 i = 1,n
         fp(ifi) = z1(izi)*c1+z2(izi)*c2
         ifi = ifi+ifp
    5    izi = izi+iz
      if (m .eq. 2) return
      izi = 1
      ifi = 1
      do 6 i = 1,n
         fp(ifi) = fp(ifi)+z3(izi)*c3
         izi = izi+iz
    6    ifi = ifi+ifp
      return
c
c error - input dimensions too small
c
    7 ierr = 1
      return
      end
      subroutine bdryp(m,n,isw,d0,d90,r1,r2,r3,iz,z1,z2,z3,
     *                 sigma,theta,ifp,fp,dd0,dd90,temp,ierr)
c
      integer m,n,isw,iz,ifp,ierr
      real    z1(1),z2(1),z3(1),sigma,theta(n),fp(1),temp(1),
     *        d0,d90,r1,r2,r3,dd0,dd90
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine constructs boundary derivatives at a pole.
c if f is a function of r and theta defined over a grid with m
c r-values and n theta-values, if r(1) is a pole, and if fr
c denotes the partial derivative of f with respect to r,
c then the values of fr(r(1),theta(j)), j = 1,...,n are calc-
c ulated from fr(r(1),0) and fr(r(1),90.) in such a way that
c fr is continuous and placed in array fp.  the values
c f(r(1),0) and f(r(1),pi/2.) are either supplied by the
c user or approximated by the routine.
c
c on input--
c
c   m is the number of r-values in the grid (m .ge. 2).
c
c   n is the number of derivatives to be placed in fp
c   (n .ge. 2).
c
c   isw is a switch which tells where to get the derivatives
c        = 0    if derivatives are in d0,d90.
c        .ne. 0 if derivatives are to be approximated.
c
c   d0 is the derivative of f with respect to r at (r(1),0).
c   this value is ignored if isw is not zero.
c
c   d90 is the deriv. of f with respect to r at (r(1),90).
c   this value is ignored if isw is not zero.
c
c   r1,r2,r3 are grid values r(1), r(2), r(3), respectively.
c   r3 is ignored if m = 2.
c
c   iz is the distance between function values in arrays z1,
c   z2, and z3.
c
c   z1 is an array of n function values at (r(1),theta(j)),
c   j = 1,...,n.
c
c   z2 is an array of n function values at (r(2),theta(j)),
c   j = 1,...,n.
c
c   z3 is an array of n function values at (r(3),theta(j)),
c   j = 1,...,n.  z3 is ignored if m = 2.
c
c   sigma is the denormalized tension factor.
c
c   theta is the array of n values of theta in degrees at which
c   fr is to be evaluated.
c
c   ifp is the distance between derivatives in fp.
c
c and
c
c   temp is workspace of dimension at least 3 * n.
c
c on output--
c
c   fp is the array which contains the n derivatives in
c   locations fp(1),fp(ifp+1),...,fp((n-1)*ifp+1).
c
c   dd0 = fr(0,0)
c   dd90 = fr(0,90)
c
c   ierr is an error flag,
c        = 0  if normal return,
c        = 1  if input dimensions are too small,
c        = 4  if derivatives could not be estimated.
c
c and
c
c   the input parameters are unaltered.
c
c note that r and theta are not interchangable in this module.
c
c this module references package modules ceez and lstsq,
c and blas modules saxpy, scopy, sdot, snrm2, and sscal.
c
c-----------------------------------------------------------
c
      ierr = 0
      if(n .lt. 1 .or. m .lt. 2) go to 6
c
      dd0 = d0
      dd90 = d90
c
c go directly to calculation if d0,d90 are supplied.
c
      if (isw .eq. 0) go to 4
c
c estimate boundary derivatives d0 and d90
c
      delr1 = r2-r1
      delr2 = delr1+delr1
      if (m .gt. 2) delr2 = r3-r1
      call ceez(delr1,delr2,sigma,c1,c2,c3,m)
      izi = 1
      ifi = 1
      do 1 i = 1,n
         fp(ifi) = z1(izi)*c1+z2(izi)*c2
         ifi = ifi+ifp
    1    izi = izi+iz
      if (m .eq. 2) go to 3
      izi = 1
      ifi = 1
      do 2 i = 1,n
         fp(ifi) = fp(ifi)+z3(izi)*c3
         izi = izi+iz
    2    ifi = ifi+ifp
    3 call lstsq(n,theta,ifp,fp,dd0,dd90,temp(1),temp(n+1),
     *            temp(2*n+1),ierr)
c
c return if error flag set for singular system
c
      if (ierr .ne. 0) go to 7
c
c calculate derivatives at pole
c
    4 ifi = 1
      fact = atan(1.)/45.
      do 5 i = 1,n
        fp(ifi) = dd0*cos(fact*theta(i))+dd90*sin(fact*theta(i))
    5    ifi = ifi+ifp
c
      return
c
c error - input dimensions too small
c
    6 ierr = 1
      return
c
c error - singular least squares system
c
    7 ierr = 4
      return
c
      end
      subroutine bpredt(n,x,y,sigma,dyp,
     *                  yp,fllmt,fulmt,dfllmt,dfulmt,ifcon,
     *                  idfcon,isdcon,psigma,delta,sigmal)
c
      integer n,ifcon(n),idfcon(n),isdcon(n)
      real x(n),y(n),sigma,
     *     dyp(n),yp(n),fllmt(n),fulmt(n),dfllmt(n),
     *     dfulmt(n),psigma,delta,sigmal
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine predicts a new sigma that is less than the
c present sigma.  this routine assumes the present sigma
c satisfies the conditions and looks for the a smaller sigma
c that does also.
c
c on input--
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   x and y are arrays containing the abscissae and
c   ordinates respectively, of the specified points.
c
c   sigma is the tension factor.
c
c   dyp is an array containing the partials of yp with
c   respect to the tension factor.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c   fllmt and fulmt are arrays of length n which contain the
c   lower limit and the upper limit, respectively, of the
c   desired spline.  fllmt(i) and fulmt(i) describe the
c   limits for the interval x(i) .le. x .le. x(i+1).  the
c   nth element is ignored. the user may omit either or both
c   of these parameters for any interval i and signal this
c   with ifcon(i).
c
c   dfllmt and dfulmt are arrays of length n which contain
c   the lower and upper limits, respectively, of the first
c   derivative of the desired spline.  dfllmt(i) and
c   dfulmt(i) describe the limits for the interval x(i) .le.
c   x .le. x(i+1).  the nth element is ignored.  the user
c   may omit either or both of parameters for any interval i
c   and signal this with idfcon(i).
c
c
c   ifcon is an array of length n containing information
c   about fllmt and fulmt.
c       ifcon(i) = -1   if fllmt(i) is to be used but not
c                       fulmt(i),
c                =  0   if both fllmt(i) and fulmt(i) are to
c                       be used,
c                =  1   if fulmt(i) is to be used but not
c                       fllmt(i),
c                =  2   if both fllmt(i) and fulmt(i) are
c                       not used.
c   ifcon(n) is ignored.
c
c   idfcon is an array of length n containing information
c   about dfllmt and dfulmt.
c      idfcon(i) = -1   if dfllmt(i) is to be used but not
c                       dfulmt(i),
c                =  0   if both dfllmt(i) and dfulmt(i) are
c                       to be used,
c                =  1   if dfulmt(i) is to be used but not
c                       dfllmt(i),
c                =  2   if both dfllmt(i) and dfulmt(i) are
c                       not used.
c   idfcon(n) is ignored.
c
c and
c
c   isdcon(i) is an array of length n containing information
c   about the second derivative on each interval.
c      isdcon(i) = -1   the spline should be concave on the
c                       ith interval,
c                =  0   no constraints are placed on the
c                       2nd derivative on the ith interval,
c                =  1   the spline should be convex on the
c                       ith interval.
c   isdcon(n) is ignored.
c
c on output--
c
c   psigma contains a predicted value of sigma.
c
c   delta contains the difference between the actual maximum
c   /minimum value and the desired maximum/minimum value of
c   the condition used to choose psigma.  if no psigma can
c   be chosen psigma and delta are returned as zero.
c
c
c none of the input parameters are changed.
c
c this subroutine references package modules ddyrs,dfmxmn,
c dyrs,fmxmn,mkrhs2,predt,snhcs2,terms2, and trisol
c and fitpack modules curv2,curvd,intrvl, and snhcsh.
c
c-----------------------------------------------------------
c
      psigma = 0.0
      delta = 0.0
      nm1 = n - 1
      do 10 i = 1,nm1
c
c check fllmt and fulmt
c
        if (ifcon(i).eq.2) go to 4
        call fmxmn(n,i,x,y,yp,sigma,ifcon(i),fmax,fmin,xmax
     *             ,xmin)
        if (ifcon(i).eq.1) go to 3
        delta0 = fllmt(i) - fmin
        call predt(xmin,n,x,yp,dyp,sigma,delta0,
     *                              pnsig,0)
        if (pnsig.gt.sigma) go to 2
        psigma = amax1(psigma,pnsig)
        if (psigma.eq.pnsig) delta = -delta0
    2   if (ifcon(i).eq.-1) go to 4
    3   delta0 = fulmt(i) - fmax
        call predt(xmax,n,x,yp,dyp,sigma,delta0,
     *                              pnsig,0)
        if (pnsig.gt.sigma) go to 4
        psigma = amax1(psigma,pnsig)
        if (psigma.eq.pnsig) delta = -delta0
c
c check dfllmt and dfulmt
c
    4   if (idfcon(i).eq.2) go to 7
        call dfmxmn(n,i,x,y,yp,sigma,idfcon(i),dfmax,dfmin,
     *              xmax,xmin)
        if (idfcon(i).eq.1) go to 6
        delta0 = dfllmt(i) - dfmin
        call predt(xmin,n,x,yp,dyp,sigma,delta0,
     *                            pnsig,-1)
        if (pnsig.gt.sigma) go to 5
        psigma = amax1(psigma,pnsig)
        if (psigma.eq.pnsig) delta =-delta0
    5   if (idfcon(i).eq.-1) go to 7
    6   delta0 = dfulmt(i) - dfmax
        call predt(xmax,n,x,yp,dyp,sigma,delta0,
     *                             pnsig,-1)
        if (pnsig.gt.sigma) go to 7
        psigma = amax1(psigma,pnsig)
        if (psigma.eq.pnsig) delta =-delta0
c
c check isdcon
c
    7   if (isdcon(i).eq.0) go to 10
        if (isdcon(i).eq.1) go to 8
        imax = i
        sdmax = amax1(yp(i),yp(i+1))
        if (sdmax.ne.yp(i)) imax = i+1
        delta0 = -sdmax
        call predt(dummy,n,x,yp,dyp,sigma,delta0,
     *                               pnsig,imax)
        if (pnsig.gt.sigma) go to 10
        psigma = amax1(psigma,pnsig)
        if (psigma.eq.pnsig) delta = -delta0
        go to 10
    8   imin = i
        sdmin = amin1(yp(i),yp(i+1))
        if (sdmin.ne.yp(i)) imin = i+1
        delta0 = -sdmin
        call predt(dummy,n,x,yp,dyp,sigma,delta0,
     *                               pnsig,imin)
        if (pnsig.gt.sigma) go to 10
        psigma = amax1(psigma,pnsig)
        if (psigma.eq.pnsig) delta = -delta0
   10 continue
      return
      end
      subroutine ceez (del1,del2,sigma,c1,c2,c3,n)
c
      real del1,del2,sigma,c1,c2,c3
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the coefficients c1, c2, and c3
c used to determine endpoint slopes. specifically, if
c function values y1, y2, and y3 are given at points x1, x2,
c and x3, respectively, the quantity c1*y1 + c2*y2 + c3*y3
c is the value of the derivative at x1 of a spline under
c tension (with tension factor sigma) passing through the
c three points and having third derivative equal to zero at
c x1. optionally, only two values, c1 and c2 are determined.
c
c on input--
c
c   del1 is x2-x1 (.gt. 0.).
c
c   del2 is x3-x1 (.gt. 0.). if n .eq. 2, this parameter is
c   ignored.
c
c   sigma is the tension factor.
c
c and
c
c   n is a switch indicating the number of coefficients to
c   be returned. if n .eq. 2 only two coefficients are
c   returned. otherwise all three are returned.
c
c on output--
c
c   c1, c2, and c3 contain the coefficients.
c
c none of the input parameters are altered.
c
c this subroutine references package module snhcsh.
c
c-----------------------------------------------------------
c
      if (n .eq. 2) go to 2
      if (sigma .ne. 0.) go to 1
      del = del2-del1
c
c tension .eq. 0.
c
      c1 = -(del1+del2)/(del1*del2)
      c2 = del2/(del1*del)
      c3 = -del1/(del2*del)
      return
c
c tension .ne. 0.
c
    1 call snhcsh (dummy,coshm1,sigma*del1,1)
      call snhcsh (dummy,coshm2,sigma*del2,1)
      delp = sigma*(del2+del1)/2.
      delm = sigma*(del2-del1)/2.
      call snhcsh (sinhmp,dummy,delp,-1)
      call snhcsh (sinhmm,dummy,delm,-1)
      denom = coshm1*(del2-del1)-2.*del1*delp*delm*
     *        (1.+sinhmp)*(1.+sinhmm)
      c1 = 2.*delp*delm*(1.+sinhmp)*(1.+sinhmm)/denom
      c2 = -coshm2/denom
      c3 = coshm1/denom
      return
c
c two coefficients
c
    2 c1 = -1./del1
      c2 = -c1
      return
      end
      subroutine chekin(n,x,istar,ierr)
c
      integer n,istar,ierr
      real x(n)
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c   this subroutine checks the monotonicity of input grid
c   values.
c
c on input--
c
c   n is the number of grid values.
c
c and
c
c   x is an array of the n grid values.
c
c on output--
c
c   istar is the index where x(istar-1) .gt. x(istar).
c   istar is zero if the grid values are strictly increasing.
c
c   ierr is an error flag,
c        = 0 if the grid values are specified correctly,
c        = 2 if the grid values are not specified as 1 or 2
c            sequences of strictly increasing values.
c
c and
c
c   the input parameters are unaltered.
c
c-----------------------------------------------------------
c
c
      istar = 0
      ierr = 0
      if (x(n) .lt. x(1)) go to 2
      do 1 i = 2,n
         if (x(i) .le. x(i-1)) go to 7
    1    continue
      return
c
    2 do 3 i = 2,n
         if (x(i) .le. x(i-1)) go to 4
    3    continue
c
    4 if (x(i) .eq. x(i-1)) go to 7
      if (i .eq. n) go to 6
      ip1 = i+1
      do 5 in = ip1,n
         if (x(in) .le. x(in-1)) go to 7
    5    continue
c
    6 istar = i
      return
c
c error
c
    7 ierr = 2
      return
      end
      subroutine ckintv(n,i,x,y,sp1,sp2,sp3,fllmt,fulmt,
     *           dfllmt,dfulmt,ifcon,idfcon,isdcon,ierr,
     *           iercon)
c
      integer n,i,ifcon(n),idfcon(n),isdcon(n),ierr,
     *        iercon(n)
      real x(n),y(n),sp1,sp2,sp3,fllmt(n),fulmt(n),dfllmt(n)
     *     ,dfulmt(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine checks a certain interval to see if user
c specified conditions can be achieved by an interpolation
c spline under tension for every tension factor greater than
c some unknown real number.
c
c on input--
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   i contains the index of the interval to be checked.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   sp1, sp2, and sp3 are the limits of the slopes in the
c   i-1,i,i+1 intervals respectively.  if i = 1, sp1 should
c   contain the value of the first derivative of the curve
c   at x(1).  if i = n, sp3 should contain the value of the
c   first derivative of the curve at x(n).
c
c   fllmt and fulmt are arrays of length n which contain the
c   lower limit and the upper limit, respectively, of the
c   desired slpine.  fllmt(j) and fulmt(j) describe the
c   limits for the interval x(j) .le. x .le. x(j+1).  the
c   nth element is ignored.  the user may omit either or
c   both of these parameters for any interval j and signal
c   this with ifcon(j).
c
c   dfllmt and dfulmt are arrays of length n which contain
c   the lower and the upper limits, respectively, of the
c   first derivative of the desired spline.  dfllmt(j) and
c   dfulmt(j) describe the limits for the interval x(j) .le.
c    x .le. x(j+1).  the nth element is ignored.  the user
c   may omit either or both of these parameters for any
c   interval j and signal this with idfcon(j).
c
c   ifcon is an array of length n indicating information
c   about fllmt and fulmt.
c         ifcon(j) = -1   if fllmt(j) is to be used but not
c                         fulmt(j).
c                  =  0   if both fllmt(j) and fulmt(j) are
c                         to be used.
c                  =  1   if fulmt(j) is to be used but not
c                         fllmt(j).
c                  =  2   if both fllmt(j) and fulmt(j) are
c                         not used.
c   ifcon(n) is ignored.
c
c   idfcon is an array of length n indicating information
c   about dfllmt and dfulmt.
c         idfcon(j) = -1   if dfllmt(j) is to be used but
c                          dfullmt(j).
c                   =  0   if both dfllmt(j) and dfulmt(j)
c                          are to be used.
c                   =  1   if dfulmt(j) is to be used but
c                          not dfllmt(j).
c                   =  2   if both dfllmt(j) and dfulmt(j)
c                          are not used.
c
c   isdcon is an array of length n indicating information
c   about second derivative on each interval.
c         isdcon(j) = -1   the spline should be concave on
c                          the jth interval.
c                   =  0   no constraints are placed on the
c                          2nd derivative on the jth
c                          interval.
c                   =  1   the spline should be convex on
c                          the jth interval.
c   isdcon(n) is ignored.
c
c and
c
c   iercon is an array of length at least n.
c
c on output--
c
c   ierr contains an error flag.
c                    = 0   for normal return.
c                    = 3   conditions cannot be met.
c
c   iercon(i) contains the decimmal equivalent of a five
c   digit number a1 a2 a3 a4 a5.
c                 a1 = 0   condition fllmt(i) can be met
c                 a1 = 1   condition fllmt(i) cannot be met
c                 a2 = 0   condition fulmt(i) can be met
c                 a2 = 1   condition fulmt(i) cannot be met
c                 a3 = 0   condition dfllmt(i) can be met
c                 a3 = 1   condition dfllmt(i) cannot be met
c                 a4 = 0   condition dfulmt(i) can be met
c                 a4 = 1   condition dfulmt(i) cannot be met
c                 a5 = 0   condition isdcon(i) can be met
c                 a5 = 1   condition isdcon(i) cannot be met
c    iercon(j), where j not equal to i , is unaltered.
c
c none of the input parameters are altered.
c
c-----------------------------------------------------------
c
c initialize iercon
c
      ierr = 0
      iercon(i) = 0
c
c find limit of endpoint slopes
c
      epslp1 = (sp1+sp2)/2
      epslp2 = (sp2+sp3)/2
      if (i.eq.1) epslp1 = sp1
      if (i.eq.n-1) epslp2 = sp3
c
c check fllmt
c
      if (ifcon(i).ge.1) go to 3
      gllmt = amin1(y(i+1),y(i))
      if (fllmt(i).lt.gllmt) go to 3
      ierr = 3
      iercon(i) = 16
c
c check fulmt
c
    3 if (ifcon(i).eq.-1.or.ifcon(i).eq.2) go to 4
      gulmt = amax1(y(i+1),y(i))
      if (fulmt(i).gt.gulmt) go to 4
      ierr = 3
      iercon(i) = iercon(i) + 8
c
c check dfllmt
c
    4 if (idfcon(i).ge.1) go to 5
      gllmt = amin1(epslp1,sp2,epslp2)
      if (dfllmt(i) .lt.gllmt) go to 5
      ierr = 3
      iercon(i) = iercon(i) + 4
c
c check dfulmt
c
    5 if (idfcon(i).eq.-1.or.idfcon(i).eq.2) go to 6
      gulmt = amax1(epslp1,sp2,epslp2)
      if (dfulmt(i).gt.gulmt) go to 6
      ierr = 3
      iercon(i) = iercon(i) + 2
c
c check isdcon
c
    6 if(isdcon(i).eq.0) return
      if(isdcon(i).eq.1) go to 7
      if(sp1.gt.sp2.and.sp2.gt.sp3) return
      ierr = 3
      iercon(i) = iercon(i) + 1
      return
    7 if(sp1.lt.sp2.and.sp2.lt.sp3) return
      ierr = 3
      iercon(i) = iercon(i) + 1
      return
      end
      subroutine condck(n,x,y,slpp1,slppn,fllmt,fulmt,dfllmt
     *         ,dfulmt,ifcon,idfcon,isdcon,ierr,iercon)
c
      integer n,ifcon(n),idfcon(n),isdcon(n),ierr,iercon(n)
      real x(n),y(n),slpp1,slppn,fllmt(n),fulmt(n),dfllmt(n)
     *     ,dfulmt(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine checks to see if user specified conditions
c can be achieved by an interpolation spline under tension
c for every tension factor greater than some unknown real
c number.
c
c on input--
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   slpp1 and slppn contain the desired values for the first
c   derivatives of the curve at x(1) and x(n), respectively.
c
c   fllmt and fulmt are arrays of length n which contain the
c   lower limit and the upper limit, respectively, of the
c   desired slpine.  fllmt(j) and fulmt(j) describe the
c   limits for the interval x(j) .le. x .le. x(j+1).  the
c   nth element is ignored.  the user may omit either or
c   both of these parameters for any interval j and signal
c   this with ifcon(j).
c
c   dfllmt and dfulmt are arrays of length n which contain
c   the lower and the upper limits, respectively, of the
c   first derivative of the desired spline.  dfllmt(j) and
c   dfulmt(j) describe the limits for the interval x(j) .le.
c    x .le. x(j+1).  the nth element is ignored.  the user
c   may omit either or both of these parameters for any
c   interval j and signal this with idfcon(j).
c
c   ifcon is an array of length n indicating information
c   about fllmt and fulmt.
c         ifcon(j) = -1   if fllmt(j) is to be used but not
c                         fulmt(j).
c                  =  0   if both fllmt(j) and fulmt(j) are
c                         to be used.
c                  =  1   if fulmt(j) is to be used but not
c                         fllmt(j).
c                  =  2   if both fllmt(j) and fulmt(j) are
c                         not used.
c   ifcon(n) is ignored.
c
c   idfcon is an array of length n indicating information
c   about dfllmt and dfulmt.
c         idfcon(j) = -1   if dfllmt(j) is to be used but
c                          dfullmt(j).
c                   =  0   if both dfllmt(j) and dfulmt(j)
c                          are to be used.
c                   =  1   if dfulmt(j) is to be used but
c                          not dfllmt(j).
c                   =  2   if both dfllmt(j) and dfulmt(j)
c                          are not used.
c
c   isdcon is an array of length n indicating information
c   about second derivative on each interval.
c         isdcon(j) = -1   the spline should be concave on
c                          the jth interval.
c                   =  0   no constraints are placed on the
c                          2nd derivative on the jth
c                          interval.
c                   =  1   the spline should be convex on
c                          the jth interval.
c   isdcon(n) is ignored.
c
c and
c
c   iercon is an array of length at least n.
c
c on output--
c
c   ierr contains an error flag.
c                    = 0   for normal return.
c                    = 3   conditions cannot be met.
c
c   iercon(i) contains the decimmal equivalent of a five
c   digit number a1 a2 a3 a4 a5.
c                 a1 = 0   condition fllmt(i) can be met
c                 a1 = 1   condition fllmt(i) cannot be met
c                 a2 = 0   condition fulmt(i) can be met
c                 a2 = 1   condition fulmt(i) cannot be met
c                 a3 = 0   condition dfllmt(i) can be met
c                 a3 = 1   condition dfllmt(i) cannot be met
c                 a4 = 0   condition dfulmt(i) can be met
c                 a4 = 1   condition dfulmt(i) cannot be met
c                 a5 = 0   condition isdcon(i) can be met
c                 a5 = 1   condition isdcon(i) cannot be met
c    iercon(j), where j not equal to i , is unaltered.
c
c none of the input parameters are altered.
c
c this subroutine references package module ckintv.
c
c-----------------------------------------------------------
c
      ierr = 0
      dvdif1 = (y(2)-y(1))/(x(2)-x(1))
      if(n.eq.2) go to 30
      dvdif2 = (y(3)-y(2))/(x(3)-x(2))
c
c check first interval
c
      call ckintv(n,1,x,y,slpp1,dvdif1,dvdif2,fllmt,fulmt,
     *            dfllmt,dfulmt,ifcon,idfcon,isdcon,iierr,
     *            iercon)
      if (iierr.eq.3) ierr = 3
      nm2 = n - 2
      if (nm2.eq.1) go to 20
c
c check middle intervals
c
      do 19 i = 2,nm2
        dvdif3 = (y(i+2)-y(i+1))/(x(i+2)-x(i+1))
        call ckintv(n,i,x,y,dvdif1,dvdif2,dvdif3,fllmt,fulmt
     *      ,dfllmt,dfulmt,ifcon,idfcon,isdcon,iierr,iercon)
        if (iierr.eq.3) ierr = 3
        dvdif1 = dvdif2
        dvdif2 = dvdif3
   19 continue
c
c check last interval
c
   20 call ckintv(n,n-1,x,y,dvdif1,dvdif2,slppn,fllmt,fulmt,
     *     dfllmt,dfulmt,ifcon,idfcon,isdcon,iierr,iercon)
      if (iierr.eq.3) ierr = 3
      return
c
c case where n = 2
c
   30 call ckintv(2,1,x,y,slpp1,dvdif1,slppn,fllmt,fulmt,
     *     dfllmt,dfulmt,ifcon,idfcon,isdcon,ierr,iercon)
      return
      end
      subroutine crvssa (n,x,d,isw,td,tsd1,hd,hsd1,hsd2,
     *                   sigma,ierr)
c
      integer n,isw,ierr
      real x(n),d(n),td(n),tsd1(n),hd(n),hsd1(n),hsd2(n)
c
c                       coded by a. k. cline and t. h. rowan
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to set
c up the computation of smoothing splines under tension for
c a given increasing sequence of abscissae. for actual
c determination of the parameters necessary to compute a
c smoothing spline under tension it is necessary to call the
c subroutine crvssb.
c
c on input--
c
c   n is the number of values to be smoothed (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   values to be smoothed.
c
c
c   d is a parameter containing the observation weights.
c   this may either be an array of length n or a scalar
c   (interpreted as a constant). the value of d
c   corresponding to the observation (x(k),y(k)) should
c   be an approximation to the standard deviation of error.
c
c   isw contains a switch indicating whether the parameter
c   d is to be considered a vector or a scalar,
c          = 0 if d is an array of length n,
c          = 1 if d is a scalar.
c
c   td, tsd1, hd, hsd1, and hsd2 are arrays of at least n
c   locations.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the degree to which the first derivative part of the
c   smoothing functional is emphasized. if sigma is nearly
c   zero (e. g. .001) the resulting curve is approximately a
c   cubic spline. if sigma is large (e. g. 50.) the
c   resulting curve is nearly a polygonal line. if sigma
c   equals zero a cubic spline results. a standard value for
c   sigma is approximately 1.
c
c on output--
c
c   td, tsd1, hd, hsd1, and hsd2 contain information needed
c   by crvssb to determine parameters of a smoothing spline
c   under tension.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 4 if x-values are not strictly increasing,
c        = 5 if a d-value is non-positive.
c
c and
c
c   n, x, y, d, isw, and sigma are unaltered.
c
c this subroutine references package modules terms and
c snhcsh.
c
c-----------------------------------------------------------
c
      if (n .lt. 2) go to 5
      ierr = 0
      if (n .eq. 2) return
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c form t matrix
c
      nm1 = n-1
      delxi1 = 1.
      dim1 = 0.
      do 1 i = 1,nm1
        delxi = x(i+1)-x(i)
        if (delxi .le. 0.) go to 6
        call terms (di,tsd1(i+1),sigmap,delxi)
        td(i) = di+dim1
        hd(i) = -(1./delxi+1./delxi1)
        hsd1(i+1) = 1./delxi
        delxi1 = delxi
    1   dim1 = di
      if (isw .eq. 1) go to 3
c
c form h matrix - d array
c
      if (d(1) .le. 0. .or. d(2) .le. 0.) go to 7
      betapp = 0.
      betap = 0.
      alphap = 0.
      do 2 i = 2,nm1
        alpha = hd(i)*d(i)*d(i)
        if (d(i+1) .le. 0.) go to 7
        beta = hsd1(i+1)*d(i+1)*d(i+1)
        hd(i) = (hsd1(i)*d(i-1))**2+alpha*hd(i)
     *                             +beta*hsd1(i+1)
        hsd2(i) = hsd1(i)*betapp
        hsd1(i) = hsd1(i)*(alpha+alphap)
        alphap = alpha
        betapp = betap
    2   betap = beta
      return
c
c form h matrix - d constant
c
    3 if (d(1) .le. 0.) go to 7
      hsd1p = 0.
      hdim1 = 0.
      do 4 i = 2,nm1
        hdi = hd(i)
        hd(i) = hsd1(i)*hsd1(i)+hdi*hdi+hsd1(i+1)*hsd1(i+1)
        hsd2(i) = hsd1(i)*hsd1p
        hsd1p = hsd1(i)
        hsd1(i) = hsd1p*(hdi+hdim1)
    4   hdim1 = hdi
      return
c
c n less than 2
c
    5 ierr = 1
      return
c
c x-values not strictly increasing
c
    6 ierr = 4
      return
c
c weight non-positive
c
    7 ierr = 5
      return
      end
      subroutine crvssb (n,x,y,d,isw,s,eps,ys,ysp,p,td,tsd1,
     *                   hd,hsd1,hsd2,rd,rsd1,rsd2,v,iflag)
c
      integer n,isw,iflag
      real x(n),y(n),d(n),s,eps,ys(n),ysp(n),p,td(n),
     *     tsd1(n),hd(n),hsd1(n),hsd2(n),rd(n),rsd1(n),
     *     rsd2(n),v(n)
c
c                       coded by a. k. cline and t. h. rowan
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a smoothing spline under tension. for a given
c increasing sequence of abscissae (x(i)), i = 1,..., n and
c associated ordinates (y(i)), i = 1,..., n, the function
c determined minimizes the summation from i = 1 to n-1 of
c the square of the second derivative of f plus sigma
c squared times the difference of the first derivative of f
c and (f(x(i+1))-f(x(i)))/(x(i+1)-x(i)) squared, over all
c functions f with two continuous derivatives such that the
c summation of the square of (f(x(i))-y(i))/d(i) is less
c than or equal to a given constant s, where (d(i)), i = 1,
c ..., n are a given set of observation weights. the
c function determined is a spline under tension with third
c derivative discontinuities at (x(i)), i = 2,..., n-1. the
c subroutine crvssa should be called earlier to determine
c certain necessary parameters.
c
c on input--
c
c   n is the number of values to be smoothed (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   values to be smoothed.
c
c   y is an array of the n ordinates of the values to be
c   smoothed, (i. e. y(k) is the functional value
c   corresponding to x(k) ).
c
c   d is a parameter containing the observation weights.
c   this may either be an array of length n or a scalar
c   (interpreted as a constant). the value of d
c   corresponding to the observation (x(k),y(k)) should
c   be an approximation to the standard deviation of error.
c
c   isw contains a switch indicating whether the parameter
c   d is to be considered a vector or a scalar,
c          = 0 if d is an array of length n,
c          = 1 if d is a scalar.
c
c   s contains the value controlling the smoothing. this
c   must be non-negative. for s equal to zero, the
c   subroutine does interpolation, larger values lead to
c   smoother funtions. if parameter d contains standard
c   deviation estimates, a reasonable value for s is
c   float(n).
c
c   eps contains a tolerance on the relative precision to
c   which s is to be interpreted. this must be greater than
c   or equal to zero and less than or equal to one. a
c   reasonable value for eps is sqrt(2./float(n)).
c
c   ys is an array of length at least n.
c
c   ysp is an array of length at least n.
c
c   p contains the initial approximation to the lagrangian
c   parameter to be determined by the newton iteration.
c   this must be non-negative. if an initial approximation
c   is not known, zero should be used.
c
c and
c
c   td, tsd1, hd, hsd1, and hsd2 are the arrays output from
c   crvssa containing information needed to determine
c   parameters of a smoothing spline under tension.
c
c the parameters n, x, d, isw, td, tsd1, hd, hsd1, and hsd2
c should be input unaltered from the output of crvssa.
c
c on output--
c
c   ys contains the smoothed ordinate values.
c
c   ysp contains the values of the second derivative of the
c   smoothed curve at the given nodes.
c
c   p contains the value of the lagrangian parameter
c   determined by the newton iteration.
c
c   iflag contains a flag indicating how the newton
c   iteration terminated,
c         = 0 for convergence to finite p,
c         = 1 if converging to infinite p. this value of p
c             should not be used as an initial approximation
c             to the lagrangian parameter in future calls to
c             crvssb.
c
c and
c
c   n, x, y, d, isw, s, and eps are unaltered.
c
c this subroutine references package modules terms and
c snhcsh.
c
c-----------------------------------------------------------
c
      iflag = 0
      ysp(1) = 0.
      ysp(n) = 0.
      if (n .eq. 2) go to 15
      v(1) = 0.
      v(n) = 0.
      rsd1(1) = 0.
      rd(1) = 0.
      rsd2(n) = 0.
      rdim1 = 0.
      yspim2 = 0.
c
c form second differences of y into ys
c
      nm1 = n-1
      nm3 = n-3
      delyi1 = 0.
      do 1 i = 1,nm1
        delxi = x(i+1)-x(i)
        delyi = (y(i+1)-y(i))/delxi
        ys(i) = delyi-delyi1
    1   delyi1 = delyi
c
c calculate lower and upper tolerances
c
      sl = s*(1.-eps)
      su = s*(1.+eps)
      if (isw .eq. 0) go to 5
      sl = d(1)*d(1)*sl
      su = d(1)*d(1)*su
c
c top of iteration
c cholesky factorization of p*t+h into r
c
    5 do 6 i = 2,nm1
        rsd2i = hsd2(i)
        rsd1i = p*tsd1(i)+hsd1(i)-rsd2i*rsd1(i-1)
        rsd2(i) = rsd2i*rdim1
        rdim1 = rd(i-1)
        rsd1(i) = rsd1i*rdim1
        rd(i) = 1./(p*td(i)+hd(i)-rsd1i*rsd1(i)
     *                           -rsd2i*rsd2(i))
        ysp(i) = ys(i)-rsd1(i)*ysp(i-1)-rsd2(i)*yspim2
    6   yspim2 = ysp(i-1)
c
c back solve of r(transpose)* r * ysp = ys
c
      ysp(nm1) = rd(nm1)*ysp(nm1)
      if (n .eq. 3) go to 8
      do 7 ibak = 1,nm3
        i = nm1-ibak
    7   ysp(i) = rd(i)*ysp(i)-rsd1(i+1)*ysp(i+1)
     *                       -rsd2(i+2)*ysp(i+2)
    8 sum = 0.
      delyi1 = 0.
      if (isw .eq. 1) go to 10
c
c calculation of residual norm
c  - d array
c
      do 9 i = 1,nm1
        delyi = (ysp(i+1)-ysp(i))/(x(i+1)-x(i))
        v(i) = (delyi-delyi1)*d(i)*d(i)
        sum = sum+v(i)*(delyi-delyi1)
    9   delyi1 = delyi
      v(n) = -delyi1*d(n)*d(n)
      go to 12
c
c calculation of residual norm
c  - d constant
c
   10 do 11 i = 1,nm1
        delyi = (ysp(i+1)-ysp(i))/(x(i+1)-x(i))
        v(i) = delyi-delyi1
        sum = sum+v(i)*(delyi-delyi1)
   11   delyi1 = delyi
      v(n) = -delyi1
   12 sum = sum-v(n)*delyi1
c
c test for convergence
c
      if (sum .le. su .and. sum .ge. sl) go to 15
c
c calculation of newton correction
c
      f = 0.
      g = 0.
      wim2 = 0.
      wim1 = 0.
      do 13 i = 2,nm1
        tui = tsd1(i)*ysp(i-1)+td(i)*ysp(i)
     *                        +tsd1(i+1)*ysp(i+1)
        wi = tui-rsd1(i)*wim1-rsd2(i)*wim2
        f = f+tui*ysp(i)
        g = g+wi*wi*rd(i)
        wim2 = wim1
   13   wim1 = wi
      h = f-p*g
      if (h .le. 0.) go to 14
c
c update p - newton step
c
      step = (sum-sqrt(sum*sl))/h
      if (step .le. 0. .and. p .eq. 0.) go to 15
      if (sl .ne. 0.) step = step*sqrt(sum/sl)
      pnew = amax1(p+step,0.)
      if (pnew .eq. p) go to 15
      p = pnew
      go to 5
c
c store smoothed y-values and second derivatives
c
   14 iflag = 1
   15 do 16 i = 1,n
        ys(i) = y(i)-v(i)
   16   ysp(i) = p*ysp(i)
      return
      end
      subroutine curvpp (n,x,y,p,d,isw,s,eps,ys,ysp,sigma,
     *                   td,tsd1,hd,hsd1,hsd2,rd,rsd1,rsd2,
     *                   rnm1,rn,v,ierr)
c
      integer n,isw,ierr
      real x(n),y(n),p,d(n),s,eps,ys(n),ysp(n),sigma,td(n),
     *     tsd1(n),hd(n),hsd1(n),hsd2(n),rd(n),rsd1(n),
     *     rsd2(n),rnm1(n),rn(n),v(n)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a periodic smoothing spline under tension. for a
c given increasing sequence of abscissae (x(i)), i = 1,...,n
c and associated ordinates (y(i)), i = 1,...,n, letting p be
c the period, x(n+1) = x(1)+p, and y(n+1) = y(1), the
c function determined minimizes the summation from i = 1 to
c n of the square of the second derivative of f plus sigma
c squared times the difference of the first derivative of f
c and (f(x(i+1))-f(x(i)))/(x(i+1)-x(i)) squared, over all
c functions f with period p and two continuous derivatives
c such that the summation of the square of
c (f(x(i))-y(i))/d(i) is less than or equal to a given
c constant s, where (d(i)), i = 1,...,n are a given set of
c observation weights. the function determined is a periodic
c spline under tension with third derivative discontinuities
c at (x(i)) i = 1,...,n (and all periodic translations of
c these values). for actual computation of points on the
c curve it is necessary to call the function curvp2.
c
c on input--
c
c   n is the number of values to be smoothed (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   values to be smoothed.
c
c   y is an array of the n ordinates of the values to be
c   smoothed, (i. e. y(k) is the functional value
c   corresponding to x(k) ).
c
c   p is the period (p .gt. x(n)-x(1)).
c
c   d is a parameter containing the observation weights.
c   this may either be an array of length n or a scalar
c   (interpreted as a constant). the value of d
c   corresponding to the observation (x(k),y(k)) should
c   be an approximation to the standard deviation of error.
c
c   isw contains a switch indicating whether the parameter
c   d is to be considered a vector or a scalar,
c          = 0 if d is an array of length n,
c          = 1 if d is a scalar.
c
c   s contains the value controlling the smoothing. this
c   must be non-negative. for s equal to zero, the
c   subroutine does interpolation, larger values lead to
c   smoother funtions. if parameter d contains standard
c   deviation estimates, a reasonable value for s is
c   float(n).
c
c   eps contains a tolerance on the relative precision to
c   which s is to be interpreted. this must be greater than
c   or equal to zero and less than equal or equal to one. a
c   reasonable value for eps is sqrt(2./float(n)).
c
c   ys is an array of length at least n.
c
c   ysp is an array of length at least n.
c
c   sigma contains the tension factor. this value indicates
c   the degree to which the first derivative part of the
c   smoothing functional is emphasized. if sigma is nearly
c   zero (e. g. .001) the resulting curve is approximately a
c   cubic spline. if sigma is large (e. g. 50.) the
c   resulting curve is nearly a polygonal line. if sigma
c   equals zero a cubic spline results. a standard value for
c   sigma is approximately 1.
c
c and
c
c   td, tsd1, hd, hsd1, hsd2, rd, rsd1, rsd2, rnm1, rn, and
c   v are arrays of length at least n which are used for
c   scratch storage.
c
c on output--
c
c   ys contains the smoothed ordinate values.
c
c   ysp contains the values of the second derivative of the
c   smoothed curve at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if s is negative,
c        = 3 if eps is negative or greater than one,
c        = 4 if x-values are not strictly increasing,
c        = 5 if a d-value is non-positive,
c        = 6 if p is less than or equal to x(n)-x(1).
c
c and
c
c   n, x, y, d, isw, s, eps, and sigma are unaltered.
c
c this subroutine references package modules store, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      if (n .lt. 2) go to 25
      if (s .lt. 0.) go to 26
      if (eps .lt. 0. .or. eps .gt. 1.) go to 27
      if (p .le. x(n)-x(1)) go to 30
      ierr = 0
      q = 0.
      rsd1(1) = 0.
      rsd2(1) = 0.
      rsd2(2) = 0.
      rsd1(n-1) = 0.
      rsd2(n-1) = 0.
      rsd2(n) = 0.
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/p
c
c form t matrix and second differences of y into ys
c
      nm1 = n-1
      nm2 = n-2
      nm3 = n-3
      delxi1 = x(1)+p-x(n)
      delyi1 = (y(1)-y(n))/delxi1
      call terms (dim1,tsd1(1),sigmap,delxi1)
      hsd1(1) = 1./delxi1
      do 1 i = 1,n
        ip1 = i+1
        if (i .eq. n) ip1 = 1
        delxi = x(ip1)-x(i)
        if (i .eq. n) delxi = x(1)+p-x(n)
        if (delxi .le. 0.) go to 28
        delyi = (y(ip1)-y(i))/delxi
        ys(i) = delyi-delyi1
        call terms (di,tsd1(ip1),sigmap,delxi)
        td(i) = di+dim1
        hd(i) = -(1./delxi+1./delxi1)
        hsd1(ip1) = 1./delxi
        delxi1 = delxi
        delyi1 = delyi
    1   dim1 = di
      hsd11 = hsd1(1)
      if (n .ge. 3) go to 2
      tsd1(2) = tsd1(1)+tsd1(2)
      tsd1(1) = 0.
      hsd1(2) = hsd1(1)+hsd1(2)
      hsd1(1) = 0.
c
c calculate lower and upper tolerances
c
    2 sl = s*(1.-eps)
      su = s*(1.+eps)
      if (d(1) .le. 0.) go to 29
      if (isw .eq. 1) go to 5
c
c form h matrix - d array
c
      betapp = hsd1(n)*d(n)*d(n)
      betap = hsd1(1)*d(1)*d(1)
      alphap = hd(n)*d(n)*d(n)
      im1 = n
      sumd = 0.
      sumy = 0.
      do 3 i = 1,n
        disq = d(i)*d(i)
        sumd = sumd+1./disq
        sumy = sumy+y(i)/disq
        ip1 = i+1
        if (i .eq. n) ip1 = 1
        alpha = hd(i)*disq
        if (d(ip1) .le. 0.) go to 29
        hsd1ip = hsd1(ip1)
        if (i .eq. n) hsd1ip = hsd11
        beta = hsd1ip*d(ip1)*d(ip1)
        hd(i) = (hsd1(i)*d(im1))**2+alpha*hd(i)
     *                             +beta*hsd1ip
        hsd2(i) = hsd1(i)*betapp
        hsd1(i) = hsd1(i)*(alpha+alphap)
        im1 = i
        alphap = alpha
        betapp = betap
    3   betap = beta
      if (n .eq. 3) hsd1(3) = hsd1(3)+hsd2(2)
c
c test for straight line fit
c
      con = sumy/sumd
      sum = 0.
      do 4 i = 1,n
    4   sum = sum+((y(i)-con)/d(i))**2
      if (sum .le. su) go to 23
      go to 8
c
c form h matrix - d constant
c
    5 sl = d(1)*d(1)*sl
      su = d(1)*d(1)*su
      hsd1p = hsd1(n)
      hdim1 = hd(n)
      sumy = 0.
      do 6 i = 1,n
        sumy = sumy+y(i)
        hsd1ip = hsd11
        if (i .lt. n) hsd1ip = hsd1(i+1)
        hdi = hd(i)
        hd(i) = hsd1(i)*hsd1(i)+hdi*hdi+hsd1ip*hsd1ip
        hsd2(i) = hsd1(i)*hsd1p
        hsd1p = hsd1(i)
        hsd1(i) = hsd1p*(hdi+hdim1)
    6   hdim1 = hdi
      if (n .eq. 3) hsd1(3) = hsd1(3)+hsd2(2)
c
c test for straight line fit
c
      con = sumy/float(n)
      sum = 0.
      do 7 i = 1,n
    7   sum = sum+(y(i)-con)**2
      if (sum .le. su) go to 23
c
c top of iteration
c cholesky factorization of q*t+h into r
c
c
c i = 1
c
    8 rd(1) = 1./(q*td(1)+hd(1))
      rnm1(1) = hsd2(1)
      yspnm1 = ys(nm1)
      rn(1) = q*tsd1(1)+hsd1(1)
      yspn = ys(n)
      ysp(1) = ys(1)
      rsd1i = q*tsd1(2)+hsd1(2)
      rsd1(2) = rsd1i*rd(1)
      sumnm1 = 0.
      sum2 = 0.
      sumn = 0.
      if (n .eq. 3) go to 11
      if (n .eq. 2) go to 12
c
c i = 2
c
      rd(2) = 1./(q*td(2)+hd(2)-rsd1i*rsd1(2))
      rnm1(2) = -rnm1(1)*rsd1(2)
      rn(2) = hsd2(2)-rn(1)*rsd1(2)
      ysp(2) = ys(2)-rsd1(2)*ysp(1)
      if (n .eq. 4) go to 10
      do 9 i = 3,nm2
        rsd2i = hsd2(i)
        rsd1i = q*tsd1(i)+hsd1(i)-rsd2i*rsd1(i-1)
        rsd2(i) = rsd2i*rd(i-2)
        rsd1(i) = rsd1i*rd(i-1)
        rd(i) = 1./(q*td(i)+hd(i)-rsd1i*rsd1(i)
     *                           -rsd2i*rsd2(i))
        rnm1(i) = -rnm1(i-2)*rsd2(i)-rnm1(i-1)*rsd1(i)
        rnm1t = rnm1(i-2)*rd(i-2)
        sumnm1 = sumnm1+rnm1t*rnm1(i-2)
        rnm1(i-2) = rnm1t
        sum2 = sum2+rnm1t*rn(i-2)
        yspnm1 = yspnm1-rnm1t*ysp(i-2)
        rn(i) = -rn(i-2)*rsd2(i)-rn(i-1)*rsd1(i)
        rnt = rn(i-2)*rd(i-2)
        sumn = sumn+rnt*rn(i-2)
        rn(i-2) = rnt
        yspn = yspn-rnt*ysp(i-2)
    9   ysp(i) = ys(i)-rsd1(i)*ysp(i-1)-rsd2(i)*ysp(i-2)
c
c i = n-3
c
   10 rnm1(nm3) = hsd2(nm1)+rnm1(nm3)
      rnm1(nm2) = rnm1(nm2)-hsd2(nm1)*rsd1(nm2)
      rnm1t = rnm1(nm3)*rd(nm3)
      sumnm1 = sumnm1+rnm1t*rnm1(nm3)
      rnm1(nm3) = rnm1t
      sum2 = sum2+rnm1t*rn(nm3)
      yspnm1 = yspnm1-rnm1t*ysp(nm3)
      rnt = rn(nm3)*rd(nm3)
      sumn = sumn+rnt*rn(nm3)
      rn(nm3) = rnt
      yspn = yspn-rnt*ysp(nm3)
c
c i = n-2
c
   11 rnm1(nm2) = q*tsd1(nm1)+hsd1(nm1)+rnm1(nm2)
      rnm1t = rnm1(nm2)*rd(nm2)
      sumnm1 = sumnm1+rnm1t*rnm1(nm2)
      rnm1(nm2) = rnm1t
      rn(nm2) = hsd2(n)+rn(nm2)
      sum2 = sum2+rnm1t*rn(nm2)
      yspnm1 = yspnm1-rnm1t*ysp(nm2)
      rnt = rn(nm2)*rd(nm2)
      sumn = sumn+rnt*rn(nm2)
      rn(nm2) = rnt
      yspn = yspn-rnt*ysp(nm2)
c
c i = n-1
c
   12 rd(nm1) = 1./(q*td(nm1)+hd(nm1)-sumnm1)
      ysp(nm1) = yspnm1
      rn(nm1) = q*tsd1(n)+hsd1(n)-sum2
      rnt = rn(nm1)*rd(nm1)
      sumn = sumn+rnt*rn(nm1)
      rn(nm1) = rnt
      yspn = yspn-rnt*ysp(nm1)
c
c i = n
c
      rdn = q*td(n)+hd(n)-sumn
      print *, rdn, q
      rd(n) = 0.
      if (rdn .gt. 0. .and. q .ne. 0.) rd(n) = 1/rdn
      ysp(n) = yspn
c
c back solve of r(transpose)* r * ysp = ys
c
      ysp(n) = rd(n)*ysp(n)
      ysp(nm1) = rd(nm1)*ysp(nm1)-rn(nm1)*ysp(n)
      if (n .eq. 2) go to 14
      yspn = ysp(n)
      yspnm1 = ysp(nm1)
      do 13 ibak = 1,nm2
        i = nm1-ibak
   13   ysp(i) = rd(i)*ysp(i)-rsd1(i+1)*ysp(i+1)
     *                  -rsd2(i+2)*ysp(i+2)-rnm1(i)*yspnm1
     *                  -rn(i)*yspn
   14 sum = 0.
      delyi1 = (ysp(1)-ysp(n))/(x(1)+p-x(n))
      if (isw .eq. 1) go to 16
c
c calculation of residual norm
c  - d array
c
      do 15 i = 1,nm1
        delyi = (ysp(i+1)-ysp(i))/(x(i+1)-x(i))
        v(i) = (delyi-delyi1)*d(i)*d(i)
        sum = sum+v(i)*(delyi-delyi1)
   15   delyi1 = delyi
      delyi = (ysp(1)-ysp(n))/(x(1)+p-x(n))
      v(n) = (delyi-delyi1)*d(n)*d(n)
      go to 18
c
c calculation of residual norm
c  - d constant
c
   16 do 17 i = 1,nm1
        delyi = (ysp(i+1)-ysp(i))/(x(i+1)-x(i))
        v(i) = delyi-delyi1
        sum = sum+v(i)*(delyi-delyi1)
   17   delyi1 = delyi
      delyi = (ysp(1)-ysp(n))/(x(1)+p-x(n))
      v(n) = delyi-delyi1
   18   sum = sum+v(n)*(delyi-delyi1)
c
c test for convergence
c
      if (sum .le. su) go to 21
c
c calculation of newton correction
c
      f = 0.
      g = 0.
      rnm1sm = 0.
      rnsm = 0.
      im1 = n
      if (n .eq. 2) go to 20
      wim2 = 0.
      wim1 = 0.
      do 19 i = 1,nm2
        tui = tsd1(i)*ysp(im1)+td(i)*ysp(i)
     *                        +tsd1(i+1)*ysp(i+1)
        wi = tui-rsd1(i)*wim1-rsd2(i)*wim2
        rnm1sm = rnm1sm-rnm1(i)*wi
        rnsm = rnsm-rn(i)*wi
        f = f+tui*ysp(i)
        g = g+wi*wi*rd(i)
        im1 = i
        wim2 = wim1
   19   wim1 = wi
   20 tui = tsd1(nm1)*ysp(im1)+td(nm1)*ysp(nm1)
     *      +tsd1(n)*ysp(n)
      wi = tui+rnm1sm
      f = f+tui*ysp(nm1)
      g = g+wi*wi*rd(nm1)
      tui = tsd1(n)*ysp(nm1)+td(n)*ysp(n)
     *      +tsd1(1)*ysp(1)
      wi = tui+rnsm-rn(nm1)*wi
      f = f+tui*ysp(n)
      g = g+wi*wi*rd(n)
      h = f-q*g
      if (h .le. 0.) go to 21
c
c update q - newton step
c
      step = (sum-sqrt(sum*sl))/h
      if (sl .ne. 0.) step = step*sqrt(sum/sl)
      if (store(q+step) .eq. q) go to 21
      q = q+step
      go to 8
c
c store smoothed y-values and second derivatives
c
   21 do 22 i = 1,n
        ys(i) = y(i)-v(i)
   22   ysp(i) = q*ysp(i)
      return
c
c store constant ys and zero ysp
c
   23 do 24 i = 1,n
        ys(i) = con
   24   ysp(i) = 0.
      return
c
c n less than 2
c
   25 ierr = 1
      return
c
c s negative
c
   26 ierr = 2
      return
c
c eps negative or greater than 1
c
   27 ierr = 3
      return
c
c x-values not strictly increasing
c
   28 ierr = 4
      return
c
c weight non-positive
c
   29 ierr = 5
      return
c
c incorrect period
c
   30 ierr = 6
      return
      end
      subroutine curvss (n,x,y,d,isw,s,eps,ys,ysp,sigma,td,
     *                   tsd1,hd,hsd1,hsd2,rd,rsd1,rsd2,v,
     *                   ierr)
c
      integer n,isw,ierr
      real x(n),y(n),d(n),s,eps,ys(n),ysp(n),sigma,td(n),
     *     tsd1(n),hd(n),hsd1(n),hsd2(n),rd(n),rsd1(n),
     *     rsd2(n),v(n)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a smoothing spline under tension. for a given
c increasing sequence of abscissae (x(i)), i = 1,..., n and
c associated ordinates (y(i)), i = 1,..., n, the function
c determined minimizes the summation from i = 1 to n-1 of
c the square of the second derivative of f plus sigma
c squared times the difference of the first derivative of f
c and (f(x(i+1))-f(x(i)))/(x(i+1)-x(i)) squared, over all
c functions f with two continuous derivatives such that the
c summation of the square of (f(x(i))-y(i))/d(i) is less
c than or equal to a given constant s, where (d(i)), i = 1,
c ..., n are a given set of observation weights. the
c function determined is a spline under tension with third
c derivative discontinuities at (x(i)), i = 2,..., n-1. for
c actual computation of points on the curve it is necessary
c to call the function curv2.
c
c on input--
c
c   n is the number of values to be smoothed (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   values to be smoothed.
c
c   y is an array of the n ordinates of the values to be
c   smoothed, (i. e. y(k) is the functional value
c   corresponding to x(k) ).
c
c   d is a parameter containing the observation weights.
c   this may either be an array of length n or a scalar
c   (interpreted as a constant). the value of d
c   corresponding to the observation (x(k),y(k)) should
c   be an approximation to the standard deviation of error.
c
c   isw contains a switch indicating whether the parameter
c   d is to be considered a vector or a scalar,
c          = 0 if d is an array of length n,
c          = 1 if d is a scalar.
c
c   s contains the value controlling the smoothing. this
c   must be non-negative. for s equal to zero, the
c   subroutine does interpolation, larger values lead to
c   smoother funtions. if parameter d contains standard
c   deviation estimates, a reasonable value for s is
c   float(n).
c
c   eps contains a tolerance on the relative precision to
c   which s is to be interpreted. this must be greater than
c   or equal to zero and less than equal or equal to one. a
c   reasonable value for eps is sqrt(2./float(n)).
c
c   ys is an array of length at least n.
c
c   ysp is an array of length at least n.
c
c   sigma contains the tension factor. this value indicates
c   the degree to which the first derivative part of the
c   smoothing functional is emphasized. if sigma is nearly
c   zero (e. g. .001) the resulting curve is approximately a
c   cubic spline. if sigma is large (e. g. 50.) the
c   resulting curve is nearly a polygonal line. if sigma
c   equals zero a cubic spline results. a standard value for
c   sigma is approximately 1.
c
c and
c
c   td, tsd1, hd, hsd1, hsd2, rd, rsd1, rsd2, and v are
c   arrays of length at least n which are used for scratch
c   storage.
c
c on output--
c
c   ys contains the smoothed ordinate values.
c
c   ysp contains the values of the second derivative of the
c   smoothed curve at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if s is negative,
c        = 3 if eps is negative or greater than one,
c        = 4 if x-values are not strictly increasing,
c        = 5 if a d-value is non-positive.
c
c and
c
c   n, x, y, d, isw, s, eps, and sigma are unaltered.
c
c this subroutine references package modules strore, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      if (n .lt. 2) go to 24
      if (s .lt. 0.) go to 25
      if (eps .lt. 0. .or. eps .gt. 1.) go to 26
      ierr = 0
      p = 0.
      v(1) = 0.
      v(n) = 0.
      ysp(1) = 0.
      ysp(n) = 0.
      if (n .eq. 2) go to 14
      rsd1(1) = 0.
      rd(1) = 0.
      rsd2(n) = 0.
      rdim1 = 0.
      yspim2 = 0.
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c form t matrix and second differences of y into ys
c
      nm1 = n-1
      nm3 = n-3
      delxi1 = 1.
      delyi1 = 0.
      dim1 = 0.
      do 1 i = 1,nm1
        delxi = x(i+1)-x(i)
        if (delxi .le. 0.) go to 27
        delyi = (y(i+1)-y(i))/delxi
        ys(i) = delyi-delyi1
        call terms (di,tsd1(i+1),sigmap,delxi)
        td(i) = di+dim1
        hd(i) = -(1./delxi+1./delxi1)
        hsd1(i+1) = 1./delxi
        delxi1 = delxi
        delyi1 = delyi
    1   dim1 = di
c
c calculate lower and upper tolerances
c
      sl = s*(1.-eps)
      su = s*(1.+eps)
      if (isw .eq. 1) go to 3
c
c form h matrix - d array
c
      if (d(1) .le. 0. .or. d(2) .le. 0.) go to 28
      betapp = 0.
      betap = 0.
      alphap = 0.
      do 2 i = 2,nm1
        alpha = hd(i)*d(i)*d(i)
        if (d(i+1) .le. 0.) go to 28
        beta = hsd1(i+1)*d(i+1)*d(i+1)
        hd(i) = (hsd1(i)*d(i-1))**2+alpha*hd(i)
     *                             +beta*hsd1(i+1)
        hsd2(i) = hsd1(i)*betapp
        hsd1(i) = hsd1(i)*(alpha+alphap)
        alphap = alpha
        betapp = betap
    2   betap = beta
      go to 5
c
c form h matrix - d constant
c
    3 if (d(1) .le. 0.) go to 28
      sl = d(1)*d(1)*sl
      su = d(1)*d(1)*su
      hsd1p = 0.
      hdim1 = 0.
      do 4 i = 2,nm1
        hdi = hd(i)
        hd(i) = hsd1(i)*hsd1(i)+hdi*hdi+hsd1(i+1)*hsd1(i+1)
        hsd2(i) = hsd1(i)*hsd1p
        hsd1p = hsd1(i)
        hsd1(i) = hsd1p*(hdi+hdim1)
    4   hdim1 = hdi
c
c top of iteration
c cholesky factorization of p*t+h into r
c
    5 do 6 i = 2,nm1
        rsd2i = hsd2(i)
        rsd1i = p*tsd1(i)+hsd1(i)-rsd2i*rsd1(i-1)
        rsd2(i) = rsd2i*rdim1
        rdim1 = rd(i-1)
        rsd1(i) = rsd1i*rdim1
        rd(i) = 1./(p*td(i)+hd(i)-rsd1i*rsd1(i)
     *                           -rsd2i*rsd2(i))
        ysp(i) = ys(i)-rsd1(i)*ysp(i-1)-rsd2(i)*yspim2
    6   yspim2 = ysp(i-1)
c
c back solve of r(transpose)* r * ysp = ys
c
      ysp(nm1) = rd(nm1)*ysp(nm1)
      if (n .eq. 3) go to 8
      do 7 ibak = 1,nm3
        i = nm1-ibak
    7   ysp(i) = rd(i)*ysp(i)-rsd1(i+1)*ysp(i+1)
     *                       -rsd2(i+2)*ysp(i+2)
    8 sum = 0.
      delyi1 = 0.
      if (isw .eq. 1) go to 10
c
c calculation of residual norm
c  - d array
c
      do 9 i = 1,nm1
        delyi = (ysp(i+1)-ysp(i))/(x(i+1)-x(i))
        v(i) = (delyi-delyi1)*d(i)*d(i)
        sum = sum+v(i)*(delyi-delyi1)
    9   delyi1 = delyi
      v(n) = -delyi1*d(n)*d(n)
      go to 12
c
c calculation of residual norm
c  - d constant
c
   10 do 11 i = 1,nm1
        delyi = (ysp(i+1)-ysp(i))/(x(i+1)-x(i))
        v(i) = delyi-delyi1
        sum = sum+v(i)*(delyi-delyi1)
   11   delyi1 = delyi
      v(n) = -delyi1
   12 sum = sum-v(n)*delyi1
c
c test for convergence
c
      if (sum .le. su) go to 14
c
c calculation of newton correction
c
      f = 0.
      g = 0.
      wim2 = 0.
      wim1 = 0.
      do 13 i = 2,nm1
        tui = tsd1(i)*ysp(i-1)+td(i)*ysp(i)
     *                        +tsd1(i+1)*ysp(i+1)
        wi = tui-rsd1(i)*wim1-rsd2(i)*wim2
        f = f+tui*ysp(i)
        g = g+wi*wi*rd(i)
        wim2 = wim1
   13   wim1 = wi
      h = f-p*g
      if (h .le. 0.) go to 14
c
c update p - newton step
c
      step = (sum-sqrt(sum*sl))/h
      if (sl .ne. 0.) step = step*sqrt(sum/sl)
      if (store(p+step) .eq. p) go to 14
      p = p+step
      go to 5
c
c store smoothed y-values and second derivatives
c
   14 if (p .eq. 0.) go to 16
      do 15 i = 1,n
        ys(i) = y(i)-v(i)
   15   ysp(i) = p*ysp(i)
      return
c
c straight line is acceptable
c
   16 sumx = 0.
      sumy = 0.
      if (isw .eq. 1) go to 19
      sum = 0.
c
c compute straight line coefficients
c   d - vector
c
      do 17 i = 1, n
        dinvsq = 1./(d(i)*d(i))
        sum = sum+dinvsq
        sumx = sumx+x(i)*dinvsq
   17   sumy = sumy+y(i)*dinvsq
      xbar = sumx/sum
      ybar = sumy/sum
      sumx = 0.
      sumy = 0.
      do 18 i = 1, n
        fac = (x(i)-xbar)/(d(i)*d(i))
        sumx = sumx+(x(i)-xbar)*fac
   18   sumy = sumy+(y(i)-ybar)*fac
      go to 22
c
c compute straight line coefficients
c   d - constant
c
   19 sum = float(n)*dinvsq
      do 20 i = 1, n
        sumx = sumx+x(i)
   20   sumy = sumy+y(i)
      xbar = sumx/float(n)
      ybar = sumy/float(n)
      sumx = 0.
      sumy = 0.
      do 21 i = 1, n
        sumx = sumx+(x(i)-xbar)*(x(i)-xbar)
   21   sumy = sumy+(y(i)-ybar)*(x(i)-xbar)
c
c store straight line values
c
   22 slp = sumy/sumx
      do 23 i = 1, n
        ys(i) = ybar+slp*(x(i)-xbar)
   23   ysp(i) = 0.
      return
c
c n less than 2
c
   24 ierr = 1
      return
c
c s negative
c
   25 ierr = 2
      return
c
c eps negative or greater than 1
c
   26 ierr = 3
      return
c
c x-values not strictly increasing
c
   27 ierr = 4
      return
c
c weight non-positive
c
   28 ierr = 5
      return
      end
      function ddyrs(t,n,x,yp,dyp,sigma)
c
      integer n
      real t,x(n),yp(n),dyp(n),sigma
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function differentiates the derivative of a spline
c under tension with respect to the tension factor at a
c given point.
c
c on input--
c
c   t contains a real value at which the derivative is to be
c   determined.
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   x is an array containing the abscissae of the specified
c   points.
c
c   yp is an array of second derivative values of the spline
c   at the nodes.
c
c   dys is an array of first derivative values of yp with
c   respect to sigma.
c
c and
c
c   sigma contains the tension factor.
c
c on output--
c
c   ddyrs contains the derivative value.
c
c none of the input parameters are changed.
c
c this function references package module snhcs2 and fitpack
c modules intrvl and snhcsh.
c
c-----------------------------------------------------------
c
c check for zero
c
      if (sigma.ne.0.0) go to 1
      ddyrs = 0.0
      return
c
c determine interval
c
    1 im1 = intrvl(t,x,n)
      i = im1 + 1
c
c set up and perform differentiation
c
      del1  = t - x(im1)
      del2  = x(i) - t
      dels  = x(i) - x(im1)
      delp1 = dels + del1
      delp2 = dels + del2
      call snhcsh(dummy,coshm1,sigma*del1,1)
      call snhcsh(dummy,coshm2,sigma*del2,1)
      call snhcsh(sinhms,dummy,sigma*dels,-1)
      call snhcs2(snhmm1,cshmm1,sigma*delp1,0)
      call snhcs2(snhmm2,cshmm2,sigma*delp2,0)
      call snhcs2(snhmm3,cshmm3,sigma*del2,0)
      call snhcs2(snhmm4,cshmm4,sigma*del1,0)
      call snhcs2(dummy,cshmms,2.*sigma*dels,2)
      cshmms = cshmms/(sigma*dels)
      denom = sigma*sigma*dels*(1.+sinhms)
      ddyrs = ((yp(i)*(2.*cshmms-snhmm1-snhmm3
     *        -del2*sigma*cshmm1-delp1*sigma*cshmm3)
     *        -yp(im1)*(2.*cshmms-snhmm2-snhmm4
     *        -del1*sigma*cshmm2-delp2*sigma*cshmm4))
     *        /(2*denom)+(dyp(i)*(coshm1-sinhms)
     *        -dyp(im1)*(coshm2-sinhms)))/denom
      return
      end
      subroutine delr(n,m,r,izs,izc,z,ibs,ibc,b)
c
      integer n,m,izs,izc,ibs,ibc
      real    r(m),z(1),b(1)
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c given r(i),i = 1,...,m and n vectors of data zzj(i),
c i = 1,...,m, j = 1,...,n, this subroutine returns the n
c vectors
c
c            zzj(i+2)-zzj(i+1)   zzj(i+1)-zzj(i)
c   bbj(i) = ----------------- - ---------------
c              r(i+2)-r(i+1)       r(i+1)-r(i)
c
c   i = 1,...,m-2,
c
c where the zzj(i) and bbj(i) are rows or columns in
c matrices z and b according to izs, izc and ibs, ibc,
c respectively.
c
c on input--
c
c   n is the number of vectors to be computed.
c
c   m is the number of values in r (m .ge. 3).
c
c   r contains m values.
c
c   izs is the distance between successive components in z
c   (e.g. zz1(1) and zz1(2)).
c
c   izc is the distance between corresponding components in
c   z (e.g. zz1(1) and zz2(1)).
c
c   z contains n * m values
c
c   ibs is the distance between successive components in b.
c
c and
c
c   ibc is the distance between corresponding components
c   in b.
c
c on output--
c
c   b contains n * (m-2) values computed by the above
c   formula.
c
c and
c
c   the input parameters are unaltered.
c
c this module references blas modules saxpy, scopy, and
c sscal.
c
c-----------------------------------------------------------
c
      mm2 = m-2
      ib = 1
      ip1 = 1+izs
      ip2 = ip1+izs
c
c put first quotient into b
c
      do 1 i = 1,mm2
         call scopy(n,z(ip2),izc,b(ib),ibc)
         call saxpy(n,-1.,z(ip1),izc,b(ib),ibc)
         call sscal(n,1./(r(i+2)-r(i+1)+180.+sign(180.,
     *              r(i+1)-r(i+2))),b(ib),ibc)
         ib = ib+ibs
         ip1 = ip1+izs
         ip2 = ip2+izs
    1    continue
c
c previous first quot is current second quot
c
      if (m .eq. 3) go to 3
      ibp = 1+(m-3)*ibs
      do 2 kk = 2,mm2
         ib = ibp
         ibp = ib-ibs
         call saxpy(n,-1.,b(ibp),ibc,b(ib),ibc)
    2    continue
c
c fix first component
c
    3 fact = 1./(r(2)-r(1)+180.+sign(180.,r(1)-r(2)))
      call saxpy(n,-fact,z(izs+1),izc,b(1),ibc)
      call saxpy(n,fact,z(1),izc,b(1),ibc)
c
      return
      end
      subroutine dfmxmn(n,im1,x,y,yp,sigma,isw,dfmax,dfmin,
     *                  xmax,xmin)
c
      integer n,im1,isw
      real x(n),y(n),yp(n),sigma,dfmax,dfmin,xmax,xmin
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine returns the minimum and maximum values of
c the derivative of a spline under tension on a specified
c interval.  the associated x values are also returned.
c
c on input--
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   im1 contains the index to the leftmost point of the
c   interval thus the interval of interest is x(im1) .le. x
c   .le. x(im1+1).
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   yp is an array of secord derivative values of the curve
c   at the nodes.
c
c   sigma is the tension factor.
c
c and
c
c   isw indicates the result desired
c           = -1    only the minimum is desired
c           =  0    both the minimum and maximum are desired
c           =  1    only the maximum is desired.
c
c on output--
c
c   dfmax contains the maximum value and xmax is the
c   associated x value.  (if isw = -1 dfmax and xmax are
c   unaltered.)
c
c   dfmin contains the minimum value and xmin is the
c   associated x value.  (if isw = 1 dfmin and xmin are
c   unaltered.)
c
c none of the input parameters are altered.
c
c this subroutine references fitpack modules curvd and
c snhcsh.
c
c-----------------------------------------------------------
c
      i = im1 + 1
      if (yp(i)*yp(im1).ge.0.) go to 15
      if (sigma.ne.0.) go to 10
      denom = yp(i) - yp(im1)
      xhat = (yp(i)*x(im1)-yp(im1)*x(i))/denom
      go to 20
c
c sigma not equal to zero
c
   10 dels = x(i) - x(im1)
      expsd = exp(sigma*dels)
      denom = yp(i)*(expsd)-yp(im1)
      xhat = (yp(i)-yp(im1)*(expsd))/denom
      xhat = (x(i)+x(im1))/2.+alog(xhat)/(2.*sigma)
      go to 20
c
c set xhat out of range
c
   15 xhat = x(im1) - 1.
c
c initialize dfmin,xmin
c
   20 sigman = sigma*(x(n)-x(1))/float(n-1)
      dyim1 = curvd(x(im1),n,x,y,yp,sigman)
      dyi   = curvd(x(i  ),n,x,y,yp,sigman)
      if (isw.eq.1) go to 30
      dfmin = amin1(dyim1,dyi)
      xmin = x(im1)
      if (dfmin.lt.dyim1) xmin = x(i)
      if (isw.eq.-1) go to 40
c
c initialize dfmax,xmax
c
   30 dfmax = amax1(dyim1,dyi)
      xmax = x(im1)
      if (dfmax.gt.dyim1) xmax = x(i)
   40 if ((xhat.lt.x(im1)).or.(xhat.gt.x(i))) return
      yhat = curvd(xhat,n,x,y,yp,sigman)
c
c finalize dfmin,xmin
c
      if (isw.eq.1) go to 50
      dfmin = amin1(dfmin,yhat)
      if (dfmin.eq.yhat) xmin = xhat
      if (isw.eq.-1) return
c
c finalize dfmax,xmax
c
   50 dfmax = amax1(dfmax,yhat)
      if (dfmax.eq.yhat) xmax = xhat
      return
      end
      function dyrs(t,n,x,yp,dyp,sigma)
c
      integer n
      real t,x(n),yp(n),dyp(n),sigma
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function differentiates a spline under tension with
c respect to the tension factor at a given point.
c
c on input--
c
c   t contains a real value at which the derivative is to be
c   determined.
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   x is an array containing the abscissae of the specified
c   points.
c
c   yp is an array of second derivative values of the spline
c   at the nodes.
c
c   dys is an array of first derivative values of yp with
c   respect to sigma.
c
c and
c
c   sigma contains the tension factor.
c
c on output--
c
c   dyrs contains the derivative value.
c
c none of the parameters are altered.
c
c this function references package module snhcs2 and fitpack
c modules intrvl and snhcsh.
c
c-----------------------------------------------------------
c
c check for zero
c
      if (sigma.ne.0.0) go to 1
      dyrs = 0.0
      return
c
c determine interval
c
    1 im1 = intrvl(t,x,n)
      i = im1 + 1
c
c set up and perform differentiation
c
      del1  = t - x(im1)
      del2  = x(i) -t
      dels  = x(i) - x(im1)
      delp1 = dels + del1
      delp2 = dels + del2
      call snhcsh(sinhm1,dummy,sigma*del1,-1)
      call snhcsh(sinhm2,dummy,sigma*del2,-1)
      call snhcsh(sinhms,dummy,sigma*dels,-1)
      call snhcs2(snhmm1,cshmm1,sigma*delp1,3)
      call snhcs2(snhmm2,cshmm2,sigma*delp2,3)
      call snhcs2(snhmm3,cshmm3,sigma*del2,3)
      call snhcs2(snhmm4,cshmm4,sigma*del1,3)
      call snhcs2(dummy,cshmms,2.*sigma*dels,2)
      denom = sigma*sigma*dels*(1.+sinhms)
      dyrs = ((yp(i)*(delp1*dels*sigma*snhmm3/2.-del2*dels
     *       *sigma*snhmm1/2.+dels*cshmm3-dels*cshmm1+del1*
     *       cshmms)+yp(im1)*(delp2*dels*sigma*snhmm4/2.-
     *       del1*dels*sigma*snhmm2/2.+dels*cshmm4-dels*
     *       cshmm2+del2*cshmms))/(dels*sigma*denom)+
     *       (dyp(i)*del1*(sinhm1-sinhms)+dyp(im1)*del2*
     *       (sinhm2-sinhms)))/denom
      return
      end
      subroutine fmxmn(n,im1,x,y,yp,sigma,isw,fmax,fmin,xmax
     *                 ,xmin)
c
      integer n,im1,isw
      real x(n),y(n),yp(n),sigma,fmax,fmin,xmax,xmin,xhat(2)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine returns the minimum and maximum values of
c a spline under tension on a specified interval.  the
c associated x values are also returned.
c
c on input--
c
c   n contains the number of points which were specified to
c   determmine the spline.
c
c   im1 contains the index to the leftmost point of the
c   interval.  thus the interval of interest is x(im1) .le.
c   x .le. x(im1 + 1).
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c   sigma is the tension factor.
c
c and
c
c   isw indicates the result desired
c            = -1   only the minimum is desired
c            =  0   both the minimum and maximum are desired
c            =  1   only the maximum is desired.
c
c on output--
c
c   fmax contains the maximum value and xmax is the
c   associated value.  (if isw = -1 fmax and xmax are
c   unaltered.)
c
c   fmin contains the minimum value and xmin is the
c   associated value.  (if isw = 1 fmin and xmin are
c   unaltered.)
c
c none of the input parameters are altered.
c
c this subroutine references fitpack modules curv2 and
c snhcsh.
c
c-----------------------------------------------------------
c
      i = im1 + 1
      dels = x(i) - x(im1)
      dely = y(i) - y(im1)
      delyp = yp(i) - yp(im1)
      if (sigma.ne.0.) go to 10
c
c solve quadratic for sigma equal zero
c
      b = (x(i)*yp(im1)-x(im1)*yp(i))
      fact = (x(im1)*x(im1)*yp(i)-x(i)*x(i)*yp(im1))-delyp*
     *       dels*dels/3.+2.*dely
      if (delyp.eq.0.) go to 1
      bsm4ac = dels*dels*(delyp*delyp/3.+yp(i)*yp(im1))-
     *         2.*delyp*dely
      if (bsm4ac.le.0.) go to 3
      nr = 2
      radtrm = sqrt(bsm4ac)
      radtrm = sign(radtrm,b)
      xhat(1) = -(b+radtrm)/delyp
      xhat(2) = -fact/(b+radtrm)
      go to 20
    1 if (b.eq.0.) go to 5
      nr = 1
      xhat(1) = -fact/(2.*b)
      go to 20
    3 if (bsm4ac.lt.0.) go to 5
      nr = 1
      xhat(1) = -b/delyp
      go to 20
    5 nr = 0
      go to 20
c
c solve quadratic for sigma not equal to zero
c
   10 call snhcsh(sinhs,coshs,sigma*dels,0)
      sigma2 = sigma*sigma
      b=(dely*sigma2-delyp)*(1.+sinhs)
      fact1 = yp(i)*(1.+coshs+sigma*dels*(1.+sinhs))-yp(im1)
      fact2 = yp(i)-(1.+coshs+sigma*dels*(1.+sinhs))*yp(im1)
      if (fact1.eq.0.) go to 11
      bsm4ac = sinhs*(sinhs+2.)*
     *         (dely*sigma2-delyp)*(dely*sigma2-delyp)+dely*
     *         sigma2*(dely*sigma2-2.*delyp)+2.*yp(i)*
     *         yp(im1)*coshs
      if (bsm4ac.le.0.) go to 13
      nr = 2
      radtrm = sqrt(bsm4ac)
      radtrm = sign(radtrm,b)
      exp1 = -(b+radtrm)/fact1
      exp2 = -fact2/(b+radtrm)
      xhat(1) = x(im1) - 1.
      xhat(2) = x(im1) - 1.
      if (exp1.gt.0.) xhat(1) = x(i) + alog(exp1)/sigma
      if (exp2.gt.0.) xhat(2) = x(im1) + alog(exp2)/sigma
      go to 20
   11 if (b.eq.0.) go to 15
      nr = 1
      exp1 = -fact2/(2.*b)
      xhat(1) = x(im1) - 1.
      if (exp1.gt.0.) xhat(1) = x(im1) + alog(exp1)/sigma
      go to 20
   13 if (bsm4ac.lt.0.) go to 15
      nr = 1
      xhat(1) = x(im1) - 1.
      exp1 = -b/fact1
      if (exp1.gt.0.) xhat(1) = x(i) + alog(exp1)/sigma
      go to 20
   15 nr = 0
c
c initialize fmin,xmin
c
   20 if (isw.eq.1) go to 30
      fmin = amin1(y(im1),y(i))
      xmin = x(im1)
      if (fmin.lt.y(im1)) xmin = x(i)
      if (isw.eq.-1) go to 40
c
c initialize fmax,xmax
c
   30 fmax = amax1(y(im1),y(i))
      xmax = x(im1)
      if (fmax.gt.y(im1)) xmax = x(i)
   40 if (nr.eq.0) return
      sigman = sigma*(x(n)-x(1))/float(n-1)
      do 60 j = 1,nr
        if((xhat(j).lt.x(im1)).or.(xhat(j).gt.x(i)))go to 60
        yhat = curv2(xhat(j),n,x,y,yp,sigman)
c
c check for new minimum
c
        if (isw.eq.1) go to 50
        fmin = amin1(fmin,yhat)
        if (fmin.eq.yhat) xmin = xhat(j)
        if (isw.eq.-1) go to 60
c
c check for new maximum
c
   50   fmax = amax1(fmax,yhat)
        if (fmax.eq.yhat) xmax = xhat(j)
   60 continue
      return
      end
      subroutine ipredt(t,n,x,yp,sdyp,delta,psigma,isw)
c
      integer n,isw
      real t,x(n),yp(n),sdyp(n),delta,psigma
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine predicts a new tension factor to produce
c a change of delta in a spline under tension, its first
c derivative, or its second derivative at some point t.
c the present tension factor is assumed to be zero.
c
c on input--
c
c   t contains a real value at which the change is desired.
c   if isw .gt. 0 then the contents of t is ignored.
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   x is an array containing the abscissae of the specified
c   points.
c
c   yp is an array of second derivative values of the spline
c   nodes.
c
c   sdyp is an array of second partial derivative values of
c   yp with respect to the tension factor.
c
c   delta is the desired change.
c
c and
c
c   isw indicates the change desired
c         =  0   a change in the spline is desired
c         = -1   a change in the first derivative is desired
c         = m.gt.0  a change in yp(m) is desired
c
c on output--
c
c   psigma is the predicted tension factor.
c
c none of the input parameters are changed.
c
c this subroutine references package modules sddyrs and
c sdyrs and fitpack module intrvl.
c
c-----------------------------------------------------------
c
c find second derivative value
c
      if (isw.ne.0) go to 3
      deriv = sdyrs(t,n,x,yp,sdyp)
      go to 10
    3 if (isw.gt.0) go to 5
      deriv = sddyrs(t,n,x,yp,sdyp)
      go to 10
    5 deriv = sdyp(isw)
c
c predict new tension factor
c
   10 if (deriv.eq.0.0) go to 11
      radtrm = 2.*delta/deriv
      if (radtrm.le.0.0) go to 11
      psigma = sqrt(radtrm)
      return
   11 psigma = 1.0
      return
      end
      function intrvl (t,x,n)
c
      integer n
      real t,x(n)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function determines the index of the interval
c (determined by a given increasing sequence) in which
c a given value lies.
c
c on input--
c
c   t is the given value.
c
c   x is a vector of strictly increasing values.
c
c and
c
c   n is the length of x (n .ge. 2).
c
c on output--
c
c   intrvl returns an integer i such that
c
c          i =  1       if         e   t .lt. x(2)  ,
c          i =  n-1     if x(n-1) .le. t            ,
c          otherwise       x(i)  .le. t .le. x(i+1),
c
c none of the input parameters are altered.
c
c-----------------------------------------------------------
c
      save i
      data i /1/
c
      tt = t
c
c check for illegal i
c
      if (i .ge. n) i = n/2
c
c check old interval and extremes
c
      if (tt .lt. x(i)) then
        if (tt .le. x(2)) then
          i = 1
          intrvl = 1
          return
        else
          il = 2
          ih = i
        end if
      else if (tt .le. x(i+1)) then
        intrvl = i
        return
      else if (tt .ge. x(n-1)) then
        i = n-1
        intrvl = n-1
        return
      else
        il = i+1
        ih = n-1
      end if
c
c binary search loop
c
    1 i = (il+ih)/2
      if (tt .lt. x(i)) then
         ih = i
      else if (tt .gt. x(i+1)) then
         il = i+1
      else
         intrvl = i
         return
      end if
      go to 1
      end
      function intrvp (t,x,n,p,tp)
c
      integer n
      real t,x(n),p,tp
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function determines the index of the interval
c (determined by a given increasing sequence) in which a
c given value lies, after translating the value to within
c the correct period.  it also returns this translated value.
c
c on input--
c
c   t is the given value.
c
c   x is a vector of strictly increasing values.
c
c   n is the length of x (n .ge. 2).
c
c and
c
c   p contains the period.
c
c on output--
c
c   tp contains a translated value of t (i. e. x(1) .le. tp,
c   tp .lt. x(1)+p, and tp = t + k*p for some integer k).
c
c   intrvl returns an integer i such that
c
c          i = 1       if             tp .lt. x(2)  ,
c          i = n       if   x(n) .le. tp            ,
c          otherwise       x(i)  .le. tp .lt. x(i+1),
c
c none of the input parameters are altered.
c
c-----------------------------------------------------------
c
      save i
      data i /1/
c
      nper = (t-x(1))/p
      tp = t-float(nper)*p
      if (tp .lt. x(1)) tp = tp+p
      tt = tp
c
c check for illegal i
c
      if (i .ge. n) i = n/2
c
c check old interval and extremes
c
      if (tt .lt. x(i)) then
        if (tt .le. x(2)) then
          i = 1
          intrvp = 1
          return
        else
          il = 2
          ih = i
        end if
      else if (tt .le. x(i+1)) then
        intrvp = i
        return
      else if (tt .ge. x(n)) then
        i = n
        intrvp = n
        return
      else
        il = i+1
        ih = n
      end if
c
c binary search loop
c
    1 i = (il+ih)/2
      if (tt .lt. x(i)) then
         ih = i
      else if (tt .gt. x(i+1)) then
         il = i+1
      else
         intrvp = i
         return
      end if
      go to 1
      end
      subroutine legcon(n,x,y,slp1,slpn,islpsw,fllmt,fulmt,
     *                 dfllmt,dfulmt,isdcon,ierr)
c
      integer n,isdcon(n),islpsw
      real x(n),y(n),slp1,slpn,fllmt(n),fulmt(n),dfllmt(n)
     *     ,dfulmt(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine checks to see if user specified conditions
c can be achieved by an interpolation spline under tension
c for every tension factor greater than some unknown real
c number.
c
c on input--
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   x and y are arrays containing the abscissae and
c   oredinates, respectively, of the specified points.
c
c   slp1 and slpn contain the values for the first
c   derivatives of the curve at x(1) and x(n), respectively.
c   the user may omit values for either or both of these
c   parameters and signal this with islpsw.
c
c   islpsw contains a switch indicating which slope data
c   should be used and which should be estimated by this
c   subroutine
c      = 0   if slp1 and slpn are to be used,
c      = 1   if slp1 is to be used but not slpn,
c      = 2   if slpn is to be used but not slp1,
c      = 3   if both slp1 and slpn are to be estimated
c            internally.
c
c   fllmt, fulmt, dfllmt, and dfulmt are arrays of length n.
c
c   isdcon is an integer array of length n.
c
c on output-
c
c   fllmt(i) contains a real number such that any real
c   number less than fllmt(i) can be accepted by curvsc as a
c   legal value for the parameter of the same name.
c
c   fulmt(i) contains a real number s.t. any real number
c   greater than fulmt(i) can be accepted by curvsc as a
c   legal value for the parameter of the same name.
c
c   dfllmt(i) contains a real number s.t. any real number
c   less than dfllmt(i) can be accepted by curvsc as a legal
c   value for the parameter of the same name.
c
c   dfulmt(i) contains a real number s.t. any real number
c   greater than fulmt(i) can be accepted by curvsc as a
c   legal value for the parameter of the same name.
c
c   isdcon(i) contains information about what value may be
c   accepted by curvsc as a legal value for the parameter of
c   the same name.
c      if isdcon(i) = -1   legal values are -1 and 0,
c      if isdcon(i) = 0    legal value is 0,
c      if isdcon(i) = 1    legal values are 0 and 1.
c
c   the nth elements of all output arrays are unaltered.
c
c   ierr is an error flag.
c      = 0    for normal return
c      = 1    if n is less than 2
c      = 2    if x-values are not strictly increasing
c
c none of the input parameters are altered.
c
c this subroutine references package module legint.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      if (n.le.1) go to 80
      do 1 i = 2,n
        if (x(i).le.x(i-1)) go to 90
    1 continue
c
c approximate end slopes
c
      if (islpsw.ge.2) go to 10
      slpp1 = slp1
      go to 12
   10 delx1 = x(2) - x(1)
      delx2 = delx1 + delx1
      if (n.gt.2) delx2 = x(3) - x(1)
      call ceez(delx1,delx2,0.,c1,c2,c3,n)
      slpp1 = c1*y(1) + c2*y(2)
      if (n.gt.2) slpp1 = slpp1 + c3*y(3)
   12 if (islpsw.eq.1.or.islpsw.eq.3) go to 13
      slppn = slpn
      go to 14
   13 delxn = x(n) - x(nm1)
      delxmn = delxn + delxn
      if (n.gt.2) delxmn = x(n) - x(n-2)
      call ceez(-delxn,-delxmn,0.,c1,c2,c3,n)
      slppn = c1*y(n) + c2*y(nm1)
      if (n.gt.2) slppn = slppn + c3*y(n-2)
c
c find divided difference
c
   14 dvdif1 = (y(2)-y(1))/(x(2)-x(1))
      if(n.eq.2) go to 30
      dvdif2 = (y(3)-y(2))/(x(3)-x(2))
c
c inspect first interval
c
      call legint(n,1,x,y,slpp1,dvdif1,dvdif2,fllmt,fulmt,
     *            dfllmt,dfulmt,isdcon)
      nm2 = n - 2
      if (nm2.eq.1) go to 20
c
c inspect middle intervals
c
      do 19 i = 2,nm2
        dvdif3 = (y(i+2)-y(i+1))/(x(i+2)-x(i+1))
        call legint(n,i,x,y,dvdif1,dvdif2,dvdif3,fllmt,fulmt
     *              ,dfllmt,dfulmt,isdcon)
        dvdif1 = dvdif2
        dvdif2 = dvdif3
   19 continue
c
c inspect last interval
c
   20 call legint(n,n-1,x,y,dvdif1,dvdif2,slppn,fllmt,fulmt,
     *            dfllmt,dfulmt,isdcon)
      return
c
c case where n = 2
c
   30 call legint(2,1,x,y,slpp1,dvdif1,slppn,fllmt,fulmt,
     *            dfllmt,dfulmt,isdcon)
      return
   80 ierr = 1
      return
   90 ierr = 2
      return
      end
      subroutine legint(n,i,x,y,sp1,sp2,sp3,fllmt,fulmt,
     *                 dfllmt,dfulmt,isdcon)
c
      integer n,i,isdcon(n)
      real x(n),y(n),sp1,sp2,sp3,fllmt(n),fulmt(n),
     *     dfllmt(n),dfulmt(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine checks a certain interval and finds the
c limit of the legal values of fllmt, fulmt, dfllmt, dfulmt,
c and isdcon that the user can give to curvsc.
c
c on input--
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   i contains the index of the interval to be checked.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   sp1, sp2, and sp3 are the limits of the slopes in the
c   i-1,i,i+1 intervals respectively.  if i = 1, sp1 should
c   contain the value of the first derivative of the curve
c   at x(1).  if i = n, sp3 should contain the value of the
c   first derivative of the curve at x(n).
c
c   fllmt, fulmt, dfllmt, dfulmt are arrays of length n.
c
c   isdcon is an integer array of length n.
c
c on output-
c
c   fllmt(i) contains a real number such that any real
c   number less than fllmt(i) can be accepted by curvsc as a
c   legal value for the parameter of the same name.
c
c   fulmt(i) contains a real number s.t. any real number
c   greater than fulmt(i) can be accepted by curvsc as a
c   legal value for the parameter of the same name.
c
c   dfllmt(i) contains a real number s.t. any real number
c   less than dfllmt(i) can be accepted by curvsc as a legal
c   value for the parameter of the same name.
c
c   dfulmt(i) contains a real number s.t. any real number
c   greater than fulmt(i) can be accepted by curvsc as a
c   legal value for the parameter of the same name.
c
c   isdcon(i) contains information about what value may be
c   accepted by curvsc as a legal value for the parameter of
c   the same name.
c      if isdcon(i) = -1   legal values are -1 and 0,
c      if isdcon(i) = 0    legal value is 0,
c      if isdcon(i) = 1    legal values are 0 and 1.
c
c none of the input parameters are altered.
c
c-----------------------------------------------------------
c
c find limit of endpoint slopes
c
      epslp1 = (sp1+sp2)/2
      epslp2 = (sp2+sp3)/2
      if (i.eq.1) epslp1 = sp1
      if (i.eq.n-1) epslp2 = sp3
c
c find fllmt,fulmt,dfllmt, and dfulmt
c
      fllmt(i) = amin1(y(i+1),y(i))
      fulmt(i) = amax1(y(i+1),y(i))
      dfllmt(i) = amin1(epslp1,sp2,epslp2)
      dfulmt(i) = amax1(epslp1,sp2,epslp2)
c
c find isdcon
c
      if(sp1.gt.sp2.and.sp2.gt.sp3) go to 1
      if(sp1.lt.sp2.and.sp2.lt.sp3) go to 2
      return
    1 isdcon(i) = -1
      return
    2 isdcon(i) = 1
      return
      end
      subroutine lstsq(n,theta,ib,b,x1,x2,q1,q2,bb,ierr)
c
      integer n,ib,ierr
      real    theta(n),b(1),x1,x2,q1(1),q2(1),bb(1)
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines x1 and x2, part of a solution
c to the least squares system
c
c     x0+x1*cos(theta(i))+x2*sin(theta(i)) = b(i), i = 1,...,n,
c
c using gram-schmidt orthogonalization.
c
c on input--
c
c   n  is the number of equations in the system.
c
c   theta  is an array of n values of theta in degrees.
c
c   ib is the distance between values in b.
c
c and
c
c   b is an array of n right hand sides.
c
c on output--
c
c   x1, x2 contain the solution.
c
c   ierr is an error flag,
c        = 0 if normal return,
c
c and
c
c   the input parameters are unaltered.
c
c this module references blas modules saxpy, scopy, sdot,
c snrm2, and sscal.
c
c-----------------------------------------------------------
c
      ierr = 0
      fact = atan(1.)/45.
      if (n .eq. 2 .and. abs(theta(n)-theta(1)) .eq. 180.) go to 3
      bsum = 0.
      csum = 0.
      ssum = 0.
      call scopy(n,b,ib,bb,1)
      do 1 i = 1,n
         q1(i) =  cos(theta(i)*fact)
         q2(i) =  sin(theta(i)*fact)
         csum = csum+q1(i)
         ssum = ssum+q2(i)
    1    bsum = bsum+bb(i)
c
      csum = csum/float(n)
      ssum = ssum/float(n)
      bsum = bsum/float(n)
c
      do 2 i = 1,n
         q1(i) = q1(i)-csum
         q2(i) = q2(i)-ssum
    2    bb(i) = bb(i)-bsum
c
      u11 = snrm2(n,q1,1)
      if (u11 .eq. 0.) go to 4
      call sscal(n,1./u11,q1,1)
      u12 = sdot(n,q1,1,q2,1)
      call saxpy(n,-u12,q1,1,q2,1)
      u22 = snrm2(n,q2,1)
      if (u22 .eq. 0.) go to 4
      call sscal(n,1./u22,q2,1)
      x1 = sdot(n,q1,1,bb,1)
      call saxpy(n,-x1,q1,1,bb,1)
      x2 = sdot(n,q2,1,bb,1)/u22
      x1 = (x1-u12*x2)/u11
      return
c
c special case - n = 2, equally spaced data
c
    3 av = (b(1)-b(n))*.5
      x1 = cos(theta(1)*fact)*av
      x2 = sin(theta(1)*fact)*av
      return
c
c singular system
c
    4 ierr = 4
      return
      end
      subroutine matnn(n,sigma,r,d,s)
c
      integer n
      real    sigma,r(n),d(1),s(1)
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine constructs the symmetric tridiagonal mat-
c rix of order n associated with spline under tension inter-
c polation of a non-periodic function.
c
c on input--
c
c   n is the number of r values in the grid.
c
c   sigma contains the tension factor.
c
c and
c
c   r is an array of n grid values.
c
c on output--
c
c   d is an array of n diagonal terms.
c
c   s is an array of n-1 super diagonal terms.
c
c and
c
c   n, sigma, and r are unaltered.
c
c this subroutine references package modules snhcsh and
c terms.
c
c-----------------------------------------------------------
c
      integer nm1,k
      real    term1,term2
c
      nm1 = n-1
      delr = r(2)-r(1)+180.+sign(180.,r(1)-r(2))
      call terms(term2,s(1),sigma,delr)
      d(1) = term2
      if (n .eq. 2) go to 2
c
      do 1 k = 2,nm1
         term1 = term2
         delr = r(k+1)-r(k)+180.+sign(180.,r(k)-r(k+1))
         call terms(term2,s(k),sigma,delr)
    1    d(k) = term1+term2
c
    2 d(n) = term2
      return
      end
      subroutine matnp(n,p,sigma,r,d,s,c)
c
      integer n
      real p,sigma,r(n),d(1),s(1),c
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine constructs the symmetric tridiagonal mat-
c rix of order n associated with spline under tension inter-
c polation of a periodic function.
c
c on input--
c
c   n is the number of r values in the grid.
c
c   p is the period (p .gt. r(n)-r(1)).
c
c   sigma contains the tension factor.
c
c and
c
c   r is an array of n grid values.
c
c on output--
c
c   d is an array of n diagonal terms.
c
c   s is an array of n-1 superdiagonal terms.
c
c   c is the corner element.
c
c and
c
c   n, sigma, and r are unaltered.
c
c this subroutine references package modules snhcsh and
c terms.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      call terms(term2,c,sigma,r(1)-r(n)+p-(180.+sign(180.,
     *                                      r(1)-r(n))))
      d(n) = term2
      do 1 k = 1,nm1
         term1 = term2
         delr = r(k+1)-r(k)+180.+sign(180.,r(k)-r(k+1))
         call terms(term2,s(k),sigma,delr)
    1    d(k) = term1+term2
c
      d(n) = d(n)+term2
      if (n .eq. 2) s(1) = s(1)+c
c
      return
      end
      subroutine mkrhs(n,x,y,slpp1,slppn,rhs)
c
      integer n
      real x(n),y(n),slpp1,slppn,rhs(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine computes the right hand side of the linear
c system used to solve for the second derivative values of a
c spline under tension.
c
c on input--
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   x and y are array contining the abscissae and ordinates,
c   respectively, of the specified points.
c
c and
c
c   slpp1 and slppn are the slopes of the spline under
c   tension at the endpoints.
c
c on output--
c
c   rhs contains the right hand side.
c
c none of the input parameters are changed.
c
c-----------------------------------------------------------
c
      nm1 = n - 1
      dx1 = (y(2) - y(1))/(x(2) -x(1))
      rhs(1) = dx1 - slpp1
      if (n.eq.2) go to 6
      do 5 i = 2,nm1
        dx2 = (y(i+1)-y(i))/(x(i+1)-x(i))
        rhs(i) = dx2 - dx1
    5   dx1 = dx2
    6 rhs(n) = slppn - dx1
      return
      end
      subroutine mkrhs2(n,x,yp,sigma,rhs)
c
      integer n
      real x(n),yp(n),sigma,rhs(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine computes the right hand side of the linear
c system used to solve for the derivative with respect to
c sigma of the second derivative  values of a spline under
c tension.
c
c on input--
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   x is an array containing the abscissae of the specified
c   points.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c and
c
c   sigma is the tension factor.
c
c on output--
c
c   rhs contains the right hand side.
c
c none of the input parameter are changed.
c
c this subroutine references package modules terms2 and
c snhcsh and fitpack module snhcsh.
c
c-----------------------------------------------------------
c
      nm1 = n - 1
      delx1 = x(2) - x(1)
      call terms2(diag1,sdiag1,sigma,delx1)
      rhs(1) = -diag1*yp(1) - sdiag1*yp(2)
      if (n.eq.2) go to 6
      do 5 i = 2,nm1
        delx2 = x(i+1) - x(i)
        call terms2(diag2,sdiag2,sigma,delx2)
        rhs(i) = -sdiag1*yp(i-1) - (diag1 + diag2)*yp(i)
     *           -sdiag2*yp(i+1)
        diag1 = diag2
    5   sdiag1 = sdiag2
    6 rhs(n) = -sdiag1*yp(nm1) - diag1*yp(n)
      return
      end
      subroutine mkrhs3(n,x,yp,rhs)
c
      integer n
      real x(n),yp(n),rhs(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine computes the right hand side of the linear
c system used to solve for the second derivative with
c respect to the tension factor of the second derivative
c values of a spline under tension.  the tension factor is
c assumed to be zero.
c
c on input--
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   x is an array containing the abscissae of the specified
c   points.
c
c and
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c on output--
c
c   rhs contains the right hand side.
c
c none of the input parameters are changed.
c
c-----------------------------------------------------------
c
      nm1 = n - 1
      delx1 = x(2) - x(1)
      fact = -delx1 * delx1 * delx1/180.
      diag1 = 8.*fact
      sdiag1 = diag1 - fact
      rhs(1) = -diag1*yp(1) - sdiag1*yp(2)
      if (n.eq.2) go to 6
      do 5 i = 2,nm1
        delx2 = x(i+1) - x(i)
        fact = -delx2 * delx2 * delx2/180.
        diag2 = 8.*fact
        sdiag2 = diag2 - fact
        rhs(i) = -sdiag1*yp(i-1)-(diag1+diag2)*yp(i)-sdiag2*
     *            yp(i+1)
        diag1 = diag2
    5   sdiag1 = sdiag2
    6 rhs(n) = -sdiag1*yp(nm1) - diag1*yp(n)
      return
      end
      subroutine predt(t,n,x,yp,dyp,sigma,delta,psigma,isw)
c
      integer n,isw
      real t,x(n),yp(n),dyp(n),sigma,delta,psigma
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine predicts a new tension factor to produce a
c change of delta in a spline under tension, its first
c derivative, or its second derivative at some point t.  the
c present tension factor should be non-zero.
c
c on input--
c
c   t contains a real value at which the change is desired.
c   if isw .gt. 0 then the contents of t is ignored.
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   x is an array containing the abscissae of the specified
c   points.
c
c   yp is an array of second derivative values of the spline
c   at the nodes.
c
c   dyp is an array of first derivative values of yp with
c   respect to the tension factor.
c
c   sigma is the present tension factor.
c
c   delta is the desired change.
c
c and
c
c   isw indicates the change desired
c         =  0   a change in the spline is desiired
c         = -1   a change in the first derivative is desired
c         = m.gt.0  a change in yp(m) is desired.
c
c on output--
c
c   psigma is the predicted tension factor.
c
c none of the input parameters are changed.
c
c this subroutine references package modules ddyrs and dyrs
c and fitpack module intrvl.
c
c-----------------------------------------------------------
c
c find first derivative value
c
      if (isw.ne.0) go to 3
      deriv = dyrs(t,n,x,yp,dyp,sigma)
      go to 10
    3 if (isw.gt.0) go to 5
      deriv = ddyrs(t,n,x,yp,dyp,sigma)
      go to 10
    5 deriv = dyp(isw)
c
c predict new sigma
c
   10 if (deriv.eq.0.0) go to 11
      psigma = sigma + delta/deriv
      return
   11 psigma = 0
      return
      end
      subroutine rcrvsc(n,x,y,slp1,slpn,islpsw,sigma,yp,
     *                  temp1,temp2,temp3,temp4,fllmt,fulmt,
     *                  dfllmt,dfulmt,ifcon,idfcon,isdcon,
     *                  ierr,iercon)
c
      integer n,islpsw,ifcon(n),idfcon(n),isdcon(n),ierr
     *        ,iercon(n)
      real x(n),y(n),slp1,slpn,sigma,yp(n),temp1(n),temp2(n)
     *     ,temp3(n),temp4(n),fllmt(n),fulmt(n),dfllmt(n),
     *     dfulmt(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolation spline under tension, that
c satisfies specified conditions, through a sequence of
c functional values.  the slopes at the two ends of the
c curve may be specified or omitted.  the user may also
c specify a lower and/or upper limit for the spline and its
c first derivative on each interval as well as specifing the
c convexity or concavity of the spline on each interval.
c for actual computation of points on the curve it is
c necessary to call the function curv2.
c
c on input--
c
c   n is the number of values to be interpolated.  (n.ge.2)
c
c   x is an array of the n increasing abscissae of the
c   functional values.
c
c   y is an array of the n ordinates of the values, (i.e.
c   y(k) are functional values corresponding to x(k).)
c
c   slp1 and slpn contain the desired values for the first
c   derivatives of the curve at x(1) and x(n), respectively.
c   the user may omit values for either or both of these
c   parameters and signal this with islpsw.
c
c   islpsw contains a switch indicating which slope data
c   should used and which should be estimated by this
c   subroutine
c      = 0   if slp1 and slpn are to be used,
c      = 1   if slp1 is to be used but not slpn,
c      = 2   if slpn is to be used but not slp1,
c      = 3   if both slp1 and slpn are to be estimated
c            internally.
c
c   yp is an array of length at least n.
c
c   temp1,temp2,temp3, and temp4 are arrays on length at
c   least n which are used for scratch storage.
c
c   fllmt and fulmt are arrays of length n which contain the
c   lower limit and the upper limit, respectively, of the
c   desired spline.  fllmt(i) and fulmt(i) describe the
c   limits for the interval x(i) .le. x .le. x(i+1).  the
c   nth element is ignored. the user may omit either or both
c   of these parameters for any interval i and signal this
c   with ifcon(i).
c
c   dfllmt and dfulmt are arrays of length n which contain
c   the lower and upper limits, respectively, of the first
c   derivative of the desired spline.  dfllmt(i) and
c   dfulmt(i) describe the limits for the interval x(i) .le.
c   x .le. x(i+1).  the nth element is ignored.  the user
c   may omit either or both of parameters for any interval i
c   and signal this with idfcon(i).
c
c   ifcon is an array of length n containing information
c   about fllmt and fulmt.
c       ifcon(i) = -1   if fllmt(i) is to be used but not
c                       fulmt(i),
c                =  0   if both fllmt(i) and fulmt(i) are to
c                       be used,
c                =  1   if fulmt(i) is to be used but not
c                       fllmt(i),
c                =  2   if both fllmt(i) and fulmt(i) are
c                       not used.
c   ifcon(n) is ignored.
c
c   idfcon is an array of length n containing information
c   about dfllmt and dfulmt.
c      idfcon(i) = -1   if dfllmt(i) is to be used but not
c                       dfulmt(i),
c                =  0   if both dfllmt(i) and dfulmt(i) are
c                       to be used,
c                =  1   if dfulmt(i) is to be used but not
c                       dfllmt(i),
c                =  2   if both dfllmt(i) and dfulmt(i) are
c                       not used.
c   idfcon(n) is ignored.
c
c and
c
c   isdcon(i) is an array of length n containing information
c   about the second derivative on each interval.
c      isdcon(i) = -1   the spline should be concave on the
c                       ith interval,
c                =  0   no constraints are placed on the
c                       2nd derivative on the ith interval,
c                =  1   the spline should be convex on the
c                       ith interval.
c   isdcon(n) is ignored.
c
c and
c
c   iercon is an array of length at least n.
c
c on output--
c
c   if ierr = 0 sigma contains the tension factor of a
c   spline under tension that satisfies the user specified
c   conditions.  if ierr = 4 sigma contains a large tension
c   factor of a spline under tension that does not satisfy
c   the conditions but graphically appears as piecewise
c   linear interpolation.  otherwise sigma is unaltered.
c
c   if ierr = 0 or 4 yp contains of the second derivative
c   values of the curve at the given nodes.
c   otherwise yp is unaltered.
c
c   ierr contains an error flag.
c      = 0   for normal return
c      = 1   if n is less than 2
c      = 2   if x-values are not strictly increasing
c      = 3   conditions cannot be met
c      = 4   conditions can be met but graphically the curve
c             will not differ from piecewise linear
c             interpolation.
c
c   iercon(i) is unaltered if ierr = 1 or 2.  otherwise
c   iercon(i) contains the decimal equivalent of a five
c   digit binary number a1 a2 a3 a4 a5.
c          a1 = 0   condition fllmt(i) can be met
c          a1 = 1   condition fllmt(i) cannot be met
c          a2 = 0   condition fulmt(i) can be met
c          a2 = 1   condition fulmt(i) cannot be met
c          a3 = 0   condition dfllmt(i) can be met
c          a3 = 1   condition dfllmt(i) cannot be met
c          a4 = 0   condition dfulmt(i) can be met
c          a4 = 1   condition dfulmt(i) cannot be met
c          a5 = 0   condition isdcon(i) can be met
c          a5 = 1   condition isdcon(i) cannot be met
c   iercon(n) is unaltered.
c
c n,x,y,slp1,slpn,islpsw,fllmt,fulmt,dfllmt,dfulmt,ifcon,
c idfcon, and isdcon are unaltered.
c
c this subroutine references package modules bpredt,ckintv,
c condck,ddyrs,dfmxmn,dyrs,fmxmn,ipredt,mkrhs,mkrhs2,mkrhs3,
c predt,sddyrs,sdyrs,store,strhlp,solnck,snhcs2,terms2,
c trifac, and trisol and fitpack modules ceez,curv2,curvd,
c intrvl,snhcsh, and terms.
c
c-----------------------------------------------------------
c
      nm1 = n - 1
      if (n.le.1) go to 18
      do 1 i = 2,n
        if (x(i).le.x(i-1)) go to 19
    1 continue
c
c approximate end slopes
c
      if (islpsw.ge.2) go to 10
      slpp1 = slp1
      go to 12
   10 delx1 = x(2) - x(1)
      delx2 = delx1 + delx1
      if (n.gt.2) delx2 = x(3) - x(1)
      call ceez(delx1,delx2,0.,c1,c2,c3,n)
      slpp1 = c1*y(1) + c2*y(2)
      if (n.gt.2) slpp1 = slpp1 + c3*y(3)
   12 if (islpsw.eq.1.or.islpsw.eq.3) go to 13
      slppn = slpn
      go to 14
   13 delxn = x(n) - x(nm1)
      delxmn = delxn + delxn
      if (n.gt.2) delxmn = x(n) - x(n-2)
      call ceez(-delxn,-delxmn,0.,c1,c2,c3,n)
      slppn = c1*y(n) + c2*y(nm1)
      if (n.gt.2) slppn = slppn + c3*y(n-2)
c
c check if condition can be satisfied.
c
   14 call condck(n,x,y,slpp1,slppn,fllmt,fulmt,dfllmt,
     *            dfulmt,ifcon,idfcon,isdcon,ierr,iercon)
      if (ierr.eq.0) go to 20
      return
   18 ierr = 1
      return
   19 ierr = 2
      return
c
c solve system and test conditions
c
   20 sigma = 0.0
      icount = 0
      lflag = 0
      sigmal = 0.0
      sigmau = 0.0
      delmax = 0.0
      do 21 i = 2,n
   21   delmax = amax1(x(i)-x(i-1),delmax)
      sigmax = 100.0/(2.*delmax)
c
c find eps, the relative machine precision
c
      eps = 1.0
   22 eps = eps/2.0
      if (store(1.0+eps).gt.1.0) go to 22
c
c start iteration
c
   23 call trifac(n,x,sigma,temp1,temp2,temp3)
      call mkrhs(n,x,y,slpp1,slppn,yp)
      call trisol(n,temp1,temp2,temp3,yp,yp)
      call solnck(n,x,y,sigma,temp1,temp2,temp3,temp4,yp,
     *       fllmt,fulmt,dfllmt,dfulmt,ifcon,idfcon,isdcon,
     *       psigma,delta,iflag)
      if (iflag.eq.0) go to 30
      sigmal = sigma
      deltal = delta
      if (lflag.eq.1) go to 27
c
c no working sigma has been found
c
      if (sigma.eq.sigmax) go to 50
      icount = icount + 1
      if (psigma.le.sigma) go to 24
      sigma = amin1(psigma,sigmax)
      go to 23
   24 if (sigma.eq.psigma) go to 25
      sigma = sigma + (sigma/float(icount-1))
      sigma = amin1(sigma,sigmax)
      go to 23
   25 sigma = sigma + 10.0 * sigma * eps
      go to 23
c
c case where working sigma was previously found
c
   27 if (store(sigmau+.1*abs(sigmau-sigma)).eq.sigmau)
     *   go to 35
      if (store(sigmau+.1*abs(sigmau-psigma)).eq.sigmau)
     *   go to 35
      if (psigma.le.sigma.or.psigma.ge.sigmau) go to 28
      sigma = psigma
      go to 23
   28 if (delta.eq.0.0.or.deltau.eq.0.0) go to 29
      dsigma=amax1((sigmau-sigma)*abs(delta/(delta-deltau)),
     *                eps*sigma)
      dsigma = amin1(dsigma,sigmau-sigmal-eps*sigma)
      sigma = sigma + dsigma
      go to 23
   29 sigma = sigma + (sigmau-sigma)/2.
      go to 23
c
c found working sigma
c
   30 if(sigma.eq.0.0) return
      if(store(sigma+.1*abs(sigma-sigmal)).eq.sigma)go to 40
      call bpredt(n,x,y,sigma,temp4,
     *            yp,fllmt,fulmt,dfllmt,dfulmt,ifcon,
     *            idfcon,isdcon,psigma,delta,sigmal)
      if(store(sigma+.1*abs(sigma-psigma)).eq.sigma)go to 40
      sigmau = sigma
      deltau = delta
      lflag = 1
      if (psigma.le.sigmal.or.psigma.ge.sigma) go to 32
      sigma = psigma
      go to 23
   32 if (delta.eq.0.0.or.deltal.eq.0.0) go to 33
      dsigma = amax1((sigma-sigmal)*abs(deltal/(deltal-
     *               delta)),eps*sigma)
      dsigma = amin1(dsigma,sigmau-sigmal-eps*sigma)
      sigma = sigmal + dsigma
      go to 23
   33 sigma = sigmal + (sigma-sigmal)/2.0
      go to 23
c
c   return sigmau
c
   35 sigma = sigmau
      call trifac(n,x,sigma,temp1,temp2,temp3)
      call mkrhs(n,x,y,slpp1,slppn,yp)
      call trisol(n,temp1,temp2,temp3,yp,yp)
c
c normalize tension factor
c
   40 sigma = sigma * (x(n)-x(1))/float(n-1)
      return
c
c sigmax not large enough
c
   50 ierr = 4
      sigma = sigma * (x(n)-x(1))/float(n-1)
      return
      end
      subroutine rhsnn(n,m,izs,izc,z,r,ifr,fr1,frm,ibs,ibc,
     *                 b)
c
      integer n,m,izs,izc,ifr,ibs,ibc
      real    z(1),r(m),fr1(1),frm(1),b(1)
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine builds multiple right hand sides of tri-
c diagonal systems of equations which produce parameters to
c evaluate an interpolatory surface which is non-periodic in
c variable r.  it requires function and derivative values
c which may be stored in rows or columns of a matrix and
c returns the right hand sides as rows or columns of a
c matrix.
c
c on input--
c
c   n is the number of right hand sides to be constructed.
c
c   m is the order of the matrix.
c
c   izs is the distance between successive components of z
c   which are used to compute one right hand side.
c
c   izc is the distance between corresponding components
c   of z.
c
c   z is the array of n * m function values.
c
c   r is the array of m grid values.
c
c   ifr is the distance between components of fr1 and frm.
c
c   fr1 is the array of n derivatives with respect to r at
c   (r(1),theta(j)),j = 1,...,n. (may be first row/column of b.)
c
c   frm is the array of n derivatives with respect to r at
c   (r(m),theta(j)),j = 1,...,n.  (may be last row/column of b.)
c
c   ibs is the distance between successive components of
c   each right hand side in b.
c
c and
c
c   ibc is the distance between corresponding components of
c   any two right hand sides in b.
c
c on output--
c
c   b is the array of n * m components of the right hand
c   sides.
c
c and
c
c   the input parameters are unaltered.
c
c this module references package module delr and blas mod-
c ules saxpy, scopy, and sscal.
c
c-----------------------------------------------------------
c
      ibm = (m-1)*ibs+1
      izmm1 = (m-2)*izs+1
      izm  = izmm1+izs
c
      if (m .gt. 2)
     *   call delr(n,m,r,izs,izc,z,ibs,ibc,b(ibs+1))
c
      fact = 1./(r(2)-r(1)+180.+sign(180.,r(1)-r(2)))
      call scopy(n,fr1,ifr,b(1),ibc)
      call saxpy(n,-fact,z(izs+1),izc,b(1),ibc)
      call saxpy(n,fact,z(1),izc,b(1),ibc)
      call sscal(n,-1.,b(1),ibc)
c
      fact = 1./(r(m)-r(m-1)+180.+sign(180.,r(m-1)-r(m)))
      call scopy(n,frm,ifr,b(ibm),ibc)
      call saxpy(n,-fact,z(izm),izc,b(ibm),ibc)
      call saxpy(n,fact,z(izmm1),izc,b(ibm),ibc)
c
      return
      end
      subroutine rhsnp(n,m,p,izs,izc,z,r,ibs,ibc,b)
c
      integer n,m,izs,izc,ibs,ibc
      real p,z(1),r(m),b(1)
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine builds multiple right hand sides of tri-
c diagonal systems of equations which produce parameters to
c evaluate an interpolatory surface which is non-polar and
c periodic in variable r.  it requires function values which
c may be stored in rows or columns of a matrix and returns
c the right hand sides as rows or columns of a matrix.
c
c on input--
c
c   n is the number of right hand sides to be constructed.
c
c   m is the order of the matrix.
c
c   p is the period  (p .gt. r(m)-r(1)).
c
c   izs is the distance between successive components of z
c   which are used to compute one right hand side.
c
c   izc is the distance between corresponding components
c   of z.
c
c   z is the array of n * m function values.
c
c   r is the array of m grid values.
c
c   ibs is the distance between successive components of
c   each right hand side in b.
c
c and
c
c   ibc is the distance between corresponding components of
c   any two right hand sides in b.
c
c on output--
c
c   b is the array of n * m components of the right hand
c   sides.
c
c and
c
c   the input parameters are unaltered.
c
c this module references package module delr and blas mod-
c saxpy, scopy, and sscal.
c
c-----------------------------------------------------------
      izm = (m-1)*izs+1
      izmm1 = izm-izs
      ibm = (m-1)*ibs+1
c
      if (m .gt. 2)
     *   call delr(n,m,r,izs,izc,z,ibs,ibc,b(ibs+1))
c
      call scopy(n,z(izs+1),izc,b,ibc)
      call saxpy(n,-1.,z,izc,b,ibc)
      call sscal(n,1./(r(2)-r(1)+180.+sign(180.,r(1)-r(2))),
     *           b,ibc)
      fact = 1./(r(1)-r(m)+p-(180.+sign(180.,r(1)-r(m))))
      call saxpy(n,-fact,z,izc,b,ibc)
      call saxpy(n,fact,z(izm),izc,b,ibc)
c
      call scopy(n,z,izc,b(ibm),ibc)
      call saxpy(n,-1.,z(izm),izc,b(ibm),ibc)
      call sscal(n,fact,b(ibm),ibc)
      fact = 1./(r(m)-r(m-1)+180.+sign(180.,r(m-1)-r(m)))
      call saxpy(n,-fact,z(izm),izc,b(ibm),ibc)
      call saxpy(n,fact,z(izmm1),izc,b(ibm),ibc)
c
      return
      end
      function sddyrs(t,n,x,yp,sdyp)
c
      integer n
      real t,x(n),yp(n),sdyp(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function finds the value of the second partial
c derivative with respect to the tension factor of the
c derivative of a spline under tension at a given point.
c the tension factor is assumed to be zero.
c
c on input--
c
c   t contains a real value at which the derivative is to
c   be determened.
c
c   n contains the number of points which were secified to
c   determine to spline.
c
c   x is an array containing the abscissae of the specified
c   points.
c
c   yp is an array of second derivative values of the spline
c   at the nodes.
c
c and
c
c   sdys is an array of second partial derivative values of
c   yp with respect to the tension factor.
c
c on output--
c
c   sddyrs contains the derivative value.
c
c none of the input parammeters are changed.
c
c this function references fitpack module intrvl.
c
c-----------------------------------------------------------
c
c determine interval
c
      im1 = intrvl(t,x,n)
      i = im1 + 1
c
c set up and perform differentiation
c
      del1  = t - x(im1)
      del2  = x(i) - t
      dels  = x(i) - x(im1)
      sdel1 = del1 * del1
      sdel2 = del2 * del2
      cdels = dels * dels * dels
      sddyrs = yp(i)*((sdel1/(12.*dels)-dels/6.)*sdel1+7.
     *         *cdels/180.)-yp(im1)*((sdel2/(12.*dels)-dels
     *         /6.)*sdel2+7.*cdels/180.)+sdyp(i)*(sdel1/(2.
     *         *dels)-dels/6.)-sdyp(im1)*(sdel2/(2.*dels)-
     *         dels/6.)
      return
      end
      function sdyrs(t,n,x,yp,sdyp)
c
      integer n
      real t,x(n),yp(n),sdyp(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function finds the value of the second partial
c derivative of a spline under tension with respect to the
c tension factor at a given point.  the tension factor is
c assumed to be zero.
c
c on input--
c
c   t contains a real value at which the derivative is to be
c   determined.
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   x is an array containing the abscissae of the specified
c   points.
c
c   yp is an array of second derivative values of the spline
c   at the nodes.
c
c and
c
c   sdys is an array of second partial derivative values of
c   yp with respect to the tension factor.
c
c on output--
c
c   sdyrs contains the derivative value.
c
c none of the input parameters are changed.
c
c this function references fitpack module intrvl.
c
c-----------------------------------------------------------
c
c determine interval
c
      im1 = intrvl(t,x,n)
      i = im1 + 1
c
c set up and perform differentiation.
c
      del1  = t - x(im1)
      del2  = x(i) - t
      dels  = x(i) - x(im1)
      sdel1 = del1 * del1
      sdel2 = del2 * del2
      cdels = dels * dels * dels
      sdyrs = yp(i)*((sdel1/(60.*dels)-dels/18.)*sdel1+7.
     *        *cdels/180.)*del1+yp(im1)*((sdel2/(60.*dels)-
     *        dels/18.)*sdel2+7.*cdels/180.)*del2+sdyp(i)*
     *        (sdel1/dels-dels)*del1/6.+sdyp(im1)*(sdel2/
     *        dels-dels)*del2/6.
      return
      end
      subroutine snhcsh (sinhm,coshm,x,isw)
c
      integer isw
      real sinhm,coshm,x
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine returns approximations to
c       sinhm(x) = sinh(x)/x-1
c       coshm(x) = cosh(x)-1
c and
c       coshmm(x) = (cosh(x)-1-x*x/2)/(x*x)
c with relative error less than 1.0e-6
c
c on input--
c
c   x contains the value of the independent variable.
c
c   isw indicates the function desired
c           = -1 if only sinhm is desired,
c           =  0 if both sinhm and coshm are desired,
c           =  1 if only coshm is desired,
c           =  2 if only coshmm is desired,
c           =  3 if both sinhm and coshmm are desired.
c
c on output--
c
c   sinhm contains the value of sinhm(x) if isw .le. 0 or
c   isw .eq. 3 (sinhm is unaltered if isw .eq.1 or isw .eq.
c   2).
c
c   coshm contains the value of coshm(x) if isw .eq. 0 or
c   isw .eq. 1 and contains the value of coshmm(x) if isw
c   .ge. 2 (coshm is unaltered if isw .eq. -1).
c
c and
c
c   x and isw are unaltered.
c
c-----------------------------------------------------------
c
      data sp13/.3029390e-5/,
     *     sp12/.1975135e-3/,
     *     sp11/.8334261e-2/,
     *     sp10/.1666665e0/
      data sp24/.3693467e-7/,
     *     sp23/.2459974e-5/,
     *     sp22/.2018107e-3/,
     *     sp21/.8315072e-2/,
     *     sp20/.1667035e0/
      data sp33/.6666558e-5/,
     *     sp32/.6646307e-3/,
     *     sp31/.4001477e-1/,
     *     sq32/.2037930e-3/,
     *     sq31/-.6372739e-1/,
     *     sq30/.6017497e1/
      data sp43/.2311816e-4/,
     *     sp42/.2729702e-3/,
     *     sp41/.9868757e-1/,
     *     sq42/.1776637e-3/,
     *     sq41/-.7549779e-1/,
     *     sq40/.9110034e1/
      data cp4/.2982628e-6/,
     *     cp3/.2472673e-4/,
     *     cp2/.1388967e-2/,
     *     cp1/.4166665e-1/,
     *     cp0/.5000000e0/
c
      ax = abs(x)
      if (isw .ge. 0) go to 5
c
c sinhm approximation
c
      if (ax .gt. 4.45) go to 2
      xs = ax*ax
      if (ax .gt. 2.3) go to 1
c
c sinhm approximation on (0.,2.3)
c
      sinhm = xs*(((sp13*xs+sp12)*xs+sp11)*xs+sp10)
      return
c
c sinhm approximation on (2.3,4.45)
c
    1 sinhm = xs*((((sp24*xs+sp23)*xs+sp22)*xs+sp21)
     .               *xs+sp20)
      return
    2 if (ax .gt. 7.65) go to 3
c
c sinhm approximation on (4.45,7.65)
c
      xs = ax*ax
      sinhm = xs*(((sp33*xs+sp32)*xs+sp31)*xs+1.)/
     .             ((sq32*xs+sq31)*xs+sq30)
      return
    3 if (ax .gt. 10.1) go to 4
c
c sinhm approximation on (7.65,10.1)
c
      xs = ax*ax
      sinhm = xs*(((sp43*xs+sp42)*xs+sp41)*xs+1.)/
     .             ((sq42*xs+sq41)*xs+sq40)
      return
c
c sinhm approximation above 10.1
c
    4 sinhm = exp(ax)/(ax+ax)-1.
      return
c
c coshm and (possibly) sinhm approximation
c
    5 if (isw .ge. 2) go to 7
      if (ax .gt. 2.3) go to 6
      xs = ax*ax
      coshm = xs*((((cp4*xs+cp3)*xs+cp2)*xs+cp1)*xs+cp0)
      if (isw .eq. 0) sinhm = xs*(((sp13*xs+sp12)*xs+sp11)
     .                              *xs+sp10)
      return
    6 expx = exp(ax)
      coshm = (expx+1./expx)/2.-1.
      if (isw .eq. 0) sinhm = (expx-1./expx)/(ax+ax)-1.
      return
c
c coshmm and (possibly) sinhm approximation
c
    7 xs = ax*ax
      if (ax .gt. 2.3) go to 8
      coshm = xs*(((cp4*xs+cp3)*xs+cp2)*xs+cp1)
      if (isw .eq. 3) sinhm = xs*(((sp13*xs+sp12)*xs+sp11)
     .                              *xs+sp10)
      return
    8 expx = exp(ax)
      coshm = ((expx+1./expx-xs)/2.-1.)/xs
      if (isw .eq. 3) sinhm = (expx-1./expx)/(ax+ax)-1.
      return
      end
      subroutine snhcs2 (sinhmm,coshmm,x,isw)
c
      integer isw
      real sinhmm,coshmm,x
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine returns approximations to
c       sinhmm(x) = sinh(x)-x-x*x*x/6
c       coshmm(x) = cosh(x)-1-x*x/2
c and
c       coshmmm(x) = (cosh(x)-1-x*x/2-x*x*x*x/24
c with relative error less than 1.0e-6
c
c on input--
c
c   x contains the value of the independent variable.
c
c   isw indicates the function desired
c           = -1 if only sinhmmm is desired,
c           =  0 if both sinhmm and coshmm are desired,
c           =  1 if only coshmm is desired,
c           =  2 if only coshmmm is desired,
c           =  3 if both sinhmm and coshmmm are desired.
c
c on output--
c
c   sinhmm contains the value of sinhmm(x) if isw .le. 0 or
c   isw .eq. 3 (sinhmm is unaltered if isw .eq.1 or isw .eq.
c   2).
c
c   coshmm contains the value of coshmm(x) if isw .eq. 0 or
c   isw .eq. 1 and contains the value of coshmmm(x) if isw
c   .ge. 2 (coshmm is unaltered if isw .eq. -1).
c
c and
c
c   x and isw are unaltered.
c
c-----------------------------------------------------------
c
      data sp4/.2077046e-9/,
     *     sp3/.2413238e-7/,
     *     sp2/.2762820e-5/,
     *     sp1/.1983940e-3/,
     *     sp0/.8333341e-2/
      data cp3/.2675694e-5/,
     *     cp2/.3678431e-3/,
     *     cp1/.2653933e-1/,
     *     cq2/-.1631114e0/,
     *     cq1/.2400002e2/
      data zp4/.1437156e-10/,
     *     zp3/.2031314e-8/,
     *     zp2/.2760071e-6/,
     *     zp1/.1388889e-2/,
     *     zp0/.3616504e-6/
c
      xx = x
      ax = abs(xx)
      xs = xx*xx
      x4 = xs*xs
      if (isw .ge. 0) go to 2
c
c sinhmm approximation
c
      if (ax .ge. 4.7) go to 1
      sinhmm = xx*x4*((((sp4*xs+sp3)*xs+sp2)*xs+sp1)*xs+sp0)
      return
    1 expx = exp(ax)
      sinhmm = (expx-1./expx)/2.-xx*(xs/6.+1.)
      return
c
c coshmm and (possibly) sinhmm approximation
c
    2 if (isw .ge. 2) go to 4
      if (ax .ge. 4.7) go to 3
      coshmm = x4*(((cp3*xs+cp2)*xs+cp1)*xs+1.)/(cq2*xs+cq1)
      if (isw .eq. 0) sinhmm = xx*x4*((((sp4*xs+sp3)*xs+sp2)
     *                                      *xs+sp1)*xs+sp0)
      return
    3 expx = exp(ax)
      coshmm = (expx+1./expx-xs)/2.-1.
      if (isw .eq. 0) sinhmm = (expx-1./expx)/2.-xx*(xs/6.+1.)
      return
c
c coshmmm and (possibly) sinhmm approximation
c
    4 if (ax .ge. 5.7) go to 5
      coshmm = xs*x4*((((zp4*xs+zp3)*xs+zp2)*xs+zp1)*xs+zp0)
      if (isw .eq. 3) sinhmm = xx*x4*((((sp4*xs+sp3)*xs+sp2)
     *                                      *xs+sp1)*xs+sp0)
      return
    5 expx = exp(ax)
      coshmm = (expx+1./expx-xs)/2.-1.-x4/24.
      if (isw .eq. 3) sinhmm = (expx-1./expx)/2.-xx*(xs/6.+1.)
      return
      end
      subroutine solnck(n,x,y,sigma,rldiag,rsdiag,usdiag,
     *          sdrdyp,yp,fllmt,fulmt,dfllmt,dfulmt,ifcon,
     *                  idfcon,isdcon,psigma,delta,iflag)
c
      integer n,ifcon(n),idfcon(n),isdcon(n),iflag
      real x(n),y(n),sigma,rldiag(n),rsdiag(n),usdiag(n),
     *     sdrdyp(n),yp(n),fllmt(n),fulmt(n),dfllmt(n),
     *     dfulmt(n),psigma,delta
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine checks to see if an interpolation spline
c under tension using a certain tension factor meets a set
c of user specified conditions.  if not it predicts a new
c sigma.
c
c on input--
c
c   n contains the number of points which were specified to
c   determine the spline.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   sigma is the tension factor.
c
c   rldiag is an array that contains the main diagonal of l,
c   where l is the lower tridiagonal matrix of the lu
c   factorization of the linear system associated with the
c   spline under tension
c
c   rsdiag is an array that contains the subdiagonal of l.
c   rsdiag(1) is ignored.
c
c   usdiag is an array that contains the superdiagonal of u
c   of the lu factorization.  usdiag(n) in ignored.
c
c   sdrdyp is an array of length at least n.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c   fllmt and fulmt are arrays of length n which contain the
c   lower limit and the upper limit, respectively, of the
c   desired spline.  fllmt(i) and fulmt(i) describe the
c   limits for the interval x(i) .le. x .le. x(i+1).  the
c   nth element is ignored. the user may omit either or both
c   of these parameters for any interval i and signal this
c   with ifcon(i).
c
c   dfllmt and dfulmt are arrays of length n which contain
c   the lower and upper limits, respectively, of the first
c   derivative of the desired spline.  dfllmt(i) and
c   dfulmt(i) describe the limits for the interval x(i) .le.
c   x .le. x(i+1).  the nth element is ignored.  the user
c   may omit either or both of parameters for any interval i
c   and signal this with idfcon(i).
c
c   ifcon is an array of length n containing information
c   about fllmt and fulmt.
c       ifcon(i) = -1   if fllmt(i) is to be used but not
c                       fulmt(i),
c                =  0   if both fllmt(i) and fulmt(i) are to
c                       be used,
c                =  1   if fulmt(i) is to be used but not
c                       fllmt(i),
c                =  2   if both fllmt(i) and fulmt(i) are
c                       not used.
c   ifcon(n) is ignored.
c
c   idfcon is an array of length n containing information
c   about dfllmt and dfulmt.
c      idfcon(i) = -1   if dfllmt(i) is to be used but not
c                       dfulmt(i),
c                =  0   if both dfllmt(i) and dfulmt(i) are
c                       to be used,
c                =  1   if dfulmt(i) is to be used but not
c                       dfllmt(i),
c                =  2   if both dfllmt(i) and dfulmt(i) are
c                       not used.
c   idfcon(n) is ignored.
c
c and
c
c   isdcon(i) is an array of length n containing information
c   about the second derivative on each interval.
c      isdcon(i) = -1   the spline should be concave on the
c                       ith interval,
c                =  0   no constraints are placed on the
c                       2nd derivative on the ith interval,
c                =  1   the spline should be convex on the
c                       ith interval.
c   isdcon(n) is ignored.
c
c on output--
c
c   psigma contains a predicted value of sigma if iflag = 1.
c   psigma = zero if iflag = 0.
c
c   delta contains the difference between the actual maximum
c   /mminimum value and the desired maximum/minimum value of
c   the condition used to predict psigma.  if no psigma can
c   be chosen, psigma and delta are return as zero.
c
c   sdrdyp contains the first partials of yp with respect to
c   the tension factor if sigma not equal to zero.  if sigma
c   equal zero sdrdyp contains the second partials of yp
c   with respect to sigma.  sdrdyp(n) is unaltered.
c
c   iflag contains an error flag.
c        iflag = 0   if conditions have been met
c              = 1   if conditions have not been met
c
c none of the input parameters are changed.
c
c this subroutine references package modules ddyrs,dfmxmn,
c dyrs,fmxmn,ipredt,mkrhs2,mkrhs3,predt,sddrys,sdyrs,snhcs2,
c terms2,and trisol and fitpack modules curv2,curvd,intrvl,
c and snhcsh.
c
c-----------------------------------------------------------
c
      psigma = 0.0
      delta = 0.0
      iflag = 0
      nm1 = n - 1
      if(sigma.ne.0.) call mkrhs2(n,x,yp,sigma,sdrdyp)
      if(sigma.eq.0.) call mkrhs3(n,x,yp,sdrdyp)
      call trisol(n,rldiag,rsdiag,usdiag,sdrdyp,sdrdyp)
      do 10 i = 1,nm1
c
c check fllmt and fulmt
c
        if (ifcon(i).eq.2) go to 4
        call fmxmn(n,i,x,y,yp,sigma,ifcon(i),fmax,fmin,xmax,
     *             xmin)
        if (ifcon(i).eq.1) go to 3
        if (fmin.ge.fllmt(i)) go to 2
        delta0 = fllmt(i) - fmin
        if (sigma.ne.0.) call predt(xmin,n,x,yp,sdrdyp,sigma
     *                      ,delta0,pnsig,0)
        if (sigma.eq.0.) call ipredt(xmin,n,x,yp,sdrdyp
     *               ,delta0,pnsig,0)
        iflag = 1
        psigma = amax1(psigma,pnsig)
        if (psigma.eq.pnsig) delta = -delta0
    2   if (ifcon(i).eq.-1) go to 4
    3   if (fmax.le.fulmt(i)) go to 4
        delta0 = fulmt(i) - fmax
        if (sigma.ne.0.) call predt(xmax,n,x,yp,sdrdyp,sigma
     *                        ,delta0,pnsig,0)
        if (sigma.eq.0.) call ipredt(xmax,n,x,yp,sdrdyp,
     *                              delta0,pnsig,0)
        iflag = 1
        psigma = amax1(psigma,pnsig)
        if (psigma.eq.pnsig) delta = -delta0
c
c check dfllmt and dfulmt
c
    4   if (idfcon(i).eq.2) go to 7
        call dfmxmn(n,i,x,y,yp,sigma,idfcon(i),dfmax,dfmin,
     *              xmax,xmin)
        if (idfcon(i).eq.1) go to 6
        if (dfmin.ge.dfllmt(i)) go to 5
        delta0 = dfllmt(i) - dfmin
        if (sigma.ne.0.) call predt(xmin,n,x,yp,sdrdyp,sigma
     *                        ,delta0,pnsig,-1)
        if (sigma.eq.0.) call ipredt(xmin,n,x,yp,sdrdyp,
     *                               delta0,pnsig,1)
        iflag = 1
        psigma = amax1(psigma,pnsig)
        if (psigma.eq.pnsig) delta = -delta0
    5   if (idfcon(i).eq.-1) go to 7
    6   if (dfmax.le.dfulmt(i)) go to 7
        delta0 = dfulmt(i) - dfmax
        if (sigma.ne.0.) call predt(xmax,n,x,yp,sdrdyp,sigma
     *                         ,delta0,pnsig,-1)
        if (sigma.eq.0.) call ipredt(xmax,n,x,yp,sdrdyp,
     *                               delta0,pnsig,-1)
        iflag = 1
        psigma = amax1(psigma,pnsig)
        if (psigma.eq.pnsig) delta = -delta0
c
c check isdcon
c
    7   if (isdcon(i).eq.0) go to 10
        if (isdcon(i).eq.1) go to 8
        imax = i
        sdmax = amax1(yp(i),yp(i+1))
        if (sdmax.ne.yp(i)) imax = i+1
        if (sdmax.le.0.) go to 10
        delta0 = -sdmax
        if (sigma.ne.0.) call predt(dummy,n,x,yp,sdrdyp,
     *                           sigma,delta0,pnsig,imax)
        if (sigma.eq.0.) call ipredt(dummy,n,x,yp,sdrdyp,
     *                            delta0,pnsig,imax)
        iflag = 1
        psigma = amax1(psigma,pnsig)
        if (psigma.eq.pnsig) delta = -delta0
        go to 10
    8   imin = i
        sdmin = amin1(yp(i),yp(i+1))
        if (sdmin.ne.yp(i)) imin = i+1
        if (sdmin.ge.0.) go to 10
        delta0 = -sdmin
        if (sigma.ne.0.) call predt(dummy,n,x,yp,sdrdyp,
     *                            sigma,delta0,pnsig,imin)
        if (sigma.eq.0.) call ipredt(dummy,n,x,yp,sdrdyp,
     *                             delta0,pnsig,imin)
        iflag = 1
        psigma = amax1(psigma,pnsig)
        if (psigma.eq.pnsig) delta = -delta0
   10 continue
      return
      end
      function store(x)
c
      real x
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function forces the placement of the value of its input
c to be placed in a single precision storage cell consistant
c with fortran 66. it is useful for comparing values nearly
c equal with respect to the precision of the computer.
c
c on input--
c
c   x is a real variable.
c
c on output--
c
c   store is a single precision version of x.
c
c and x is unaltered.
c
c this function references module strhlp and requires a
c common block named vcom.
c
c-------------------------------------------------------------
c
c
      common/vcom/v
      call strhlp(x)
      store = v
      return
      end
      subroutine strhlp(x)
c
      real x
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine is used by the function store to force the
c storage of a value into a single precision storage cell
c consistant with fortran 66.
c
c on input--
c
c   x is a real variable.
c
c on output--
c
c   v in the common block vcom contains a single precision
c   version of x.
c
c and x is unaltered.
c
c this subroutine requires a common block named vcom.
c
c-------------------------------------------------------------
c
      common/vcom/v
c
      v = x
      return
      end
      subroutine sum (c1,c2,c3,v,s,sp,isw)    
c 
      integer isw 
      real c1,c2,c3,v(5),s,sp 
c 
c                                 coded by alan kaylor cline
c                         from fitpack -- september 19, 1985
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c       
c this subroutine accumulates b-spline data to obtain 
c function values and second derivatives on grid points.
c 
c on input--
c 
c   c1, c2, and c3 contain the coefficients for the i-1-st, 
c   i-th, and i+1-st basis functions if the values are to be
c   obtained at the i-th grid point.  
c 
c   v contains 5 basis function data at the i-th grid point,
c     v(1) contains the value of basis function i-1,
c     v(2) contains the value of basis function i+1,
c     v(3) contains the derivative of basis function i-1, 
c     v(4) contains the derivative of basis function i, 
c     v(5) contains the derivative of basis function i+1. 
c 
c and 
c 
c   isw contains a switch,
c       = 1 for the left-most grid point, 
c       = 2 for non-extreme grid points,
c       = 3 for the right-most grid point.
c 
c on output-- 
c 
c   s and sp contain the function value and second
c   derivative value at the grid point, respectively. 
c 
c none of the input parameters are altered. 
c       
c--------------------------------------------------------- ----     
c 
      go to (1,2,3),isw 
c 
c isw = 1, left end 
c 
    1 s = c2+c3*v(2)
      sp = c2*v(4)+c3*v(5)  
      return
c 
c isw = 2, neither end
c 
    2 s = c1*v(1)+c2+c3*v(2)
      sp = c1*v(3)+c2*v(4)+c3*v(5)    
      return
c 
c isw = 3, right end
c 
    3 s = c1*v(1)+c2
      sp = c1*v(3)+c2*v(4)  
      return
      end 
      subroutine surfss (m,n,x,y,dx,dy,isw,s,eps,z,iz,zs,td,
     *                 tsd1,hd,hsd1,hsd2,rd,rsd1,rsd2,v,  
     *                 zs1d,zsp1d,se,temp,sigma,ierr)   
c 
      integer m,n,isw,iz,ierr 
      real x(m),y(n),dx(m),dy(n),s,eps,z(iz,n),zs(m,n), 
     *     td(1),tsd1(1),hd(1),hsd1(1),hsd2(1),rd(1), 
     *     rsd1(1),rsd2(1),v(1),zs1d(1),zsp1d(1),se(1), 
     *     temp(1)
c 
c                       coded by a. k. cline and t. h. rowan
c                                 coded by alan kaylor cline
c                         from fitpack -- september 19, 1985
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a smoothing surface under tension approximating
c a rectangular grid of functional values. for given
c increasing sequences of abscissae (x(i)), i = 1,..., m,
c (y(j)), j = 1,..., n and associated ordinates (z(i,j)),
c i = 1,..., m, j = 1,...,n, the function is determined
c so that the double summation of the square of
c (f(x(i),y(j))-z(i,j))/(dx(i)*dy(j)) is less than or equal
c to a given constant s, where (dx(i)), i = 1,..., m and
c (dy(j)), j = 1,..., n are given sets of observation
c weights. the method used is to solve n one-dimensional
c smoothing problems along fixed y lines and to solve m
c one-dimensional smoothing problems along fixed x lines,
c independently from the fixed y solutions. the functional
c values of the smoothed surface are determined by averaging
c the x-direction smoothed values with the y-direction
c smoothed values. for actual mapping of points onto the
c smoothed surface it is necessary to call the function
c surf2 with the surface information returned by surfs in zs
c and zsp.
c
c on input--
c
c   m is the number of grid lines in the x-direction, i. e.
c   lines parallel to the y-axis (m .ge. 2).
c
c   n is the number of grid lines in the y-direction, i. e.
c   lines parallel to the x-axis (n .ge. 2).
c
c   x is an array of the m x-coordinates of the grid lines
c   in the x-direction. these should be strictly increasing.
c
c   y is an array of the n y-coordinates of the grid lines
c   in the y-direction. these should be strictly increasing.
c
c   dx and dy are parameters containing the observation
c   weights. these may either be arrays of lengths m and n
c   respectively or scalars (interpreted as constants). the
c   product of the values of dx and dy corresponding to the
c   observation (x(i),y(j),z(i,j)) should be an
c   approximation to the standard deviation of error.
c
c   isw contains a switch indicating whether the parameters
c   dx and dy are to be considered vectors or scalars,
c          = 0 if dx and dy are arrays of lengths m and n
c              respectively,
c          = 1 if dx and dy are scalars.
c
c   s contains the value controlling the smoothing. this
c   must be non-negative. for s equal to zero, the
c   subroutine does interpolation, larger values lead to
c   smoother functions. if dx(i)*dy(j) is an approximation
c   to the standard deviation of error for observation
c   (x(i),y(j),z(i,j)), a reasonable value for s is
c   float(m*n).
c
c   eps contains a tolerance on the relative precision to
c   which s is to be interpreted. this must be greater than
c   or equal to zero and less than or equal to one. a
c   reasonable value for eps is sqrt(2./float(m*n)).
c
c   z is an array of the m * n functional values at the grid
c   points, i. e. z(i,j) contains the functional value at
c   (x(i),y(j)) for i = 1,...,m and j = 1,...,n.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   zs is an array of at least m*n locations.
c
c   td, tsd1, hd, hsd1, hsd2, rd, rsd1, rsd2, v, zs1d,
c   zsp1d, se, and temp are arrays of at least max(m,n)
c   locations which are used for scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   bi-linear. if sigma equals zero tensor products of
c   cubic splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   zs contains the smoothed ordinate values.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2 or m is less than 2,
c        = 2 if s is negative,
c        = 3 if eps is negative or greater than one,
c        = 4 if the x-values or y-values are not strictly
c            increasing,
c        = 5 if a dx-value or dy-value is non-positive.
c
c and
c
c   m, n, x, y, z, iz, and sigma are unaltered.
c
c this subroutine references package modules crvssa, crvssb,
c terms, and snhcsh.
c
c this subroutine references blas module scopy.
c
c-----------------------------------------------------------
c
      ierr = 0
      if (s .lt. 0.) go to 16
      if (eps .lt. 0. .or. eps .gt. 1.) go to 17
c
c set up matrices for smoothing along fixed y lines
c
      call crvssa (m,x,dx,isw,td,tsd1,hd,hsd1,hsd2,sigma,
     *             ierr)
      if (ierr .ne. 0) return
      p = 0.
      sesum = 0.
      sovern = s/float(n)
      if (isw .ne. 0) go to 3
c
c smooth along fixed y lines with averaged s
c  - dx array
c
      do 2 j = 1,n
        call crvssb (m,x,z(1,j),dx,isw,sovern,eps,zs(1,j),
     *               zsp1d,p,td,tsd1,hd,hsd1,hsd2,rd,rsd1,
     *               rsd2,v,iflag)
        sumerr = 0.
        do 1 i = 1,m
    1     sumerr = sumerr+zs(i,j)*(z(i,j)-zs(i,j))
     *                    /(dx(i)*dx(i))
        se(j) = p*sumerr/(dy(j)*dy(j))
        if (iflag .ne. 0) p = 0.
    2   sesum = sesum+se(j)
      go to 6
c
c smooth along fixed y lines with averaged s
c  - dx constant
c
    3 do 5 j = 1,n
        call crvssb (m,x,z(1,j),dx,isw,sovern,eps,zs(1,j),
     *               zsp1d,p,td,tsd1,hd,hsd1,hsd2,rd,rsd1,
     *               rsd2,v,iflag)
        sumerr = 0.
        do 4 i = 1,m
    4     sumerr = sumerr+zs(i,j)*(z(i,j)-zs(i,j))
        se(j) = p*sumerr
        if (iflag .ne. 0) p = 0.
    5   sesum = sesum+se(j)
    6 if (sesum .eq. 0.) go to 8
      swt = s/sesum
      p = 0.
c
c smooth along fixed y lines with reweighted s
c
      do 7 j = 1,n
        sj = (se(j)*swt+sovern)/2.
        call crvssb (m,x,z(1,j),dx,isw,sj,eps,zs(1,j),zsp1d,
     *               p,td,tsd1,hd,hsd1,hsd2,rd,rsd1,rsd2,v,
     *               iflag)
    7   if (iflag .ne. 0) p = 0.
c
c set up matrices for smoothing along fixed x lines
c
    8 call crvssa (n,y,dy,isw,td,tsd1,hd,hsd1,hsd2,sigma,
     *             ierr)
      if (ierr .ne. 0) return
      p = 0.
      sesum = 0.
      soverm = s/float(m)
      if (isw .ne. 0) go to 11
c
c smooth along fixed x lines with averaged s
c  - dy array
c
      do 10 i = 1,m
        call scopy (n,z(i,1),iz,temp,1)
        call crvssb (n,y,temp,dy,isw,soverm,eps,zs1d,zsp1d,
     *               p,td,tsd1,hd,hsd1,hsd2,rd,rsd1,rsd2,v,
     *               iflag)
        sumerr = 0.
        do 9  j = 1,n
    9     sumerr = sumerr+zs1d(j)*(z(i,j)-zs1d(j))
     *                    /(dy(j)*dy(j))
        se(i) = p*sumerr/(dx(i)*dx(i))
        if (iflag .ne. 0) p = 0.
   10   sesum = sesum+se(i)
      go to 14
c
c smooth along fixed x lines with averaged s
c  - dy constant
c
   11 do 13 i = 1,m
        call scopy (n,z(i,1),iz,temp,1)
        call crvssb (n,y,temp,dy,isw,soverm,eps,zs1d,zsp1d,
     *               p,td,tsd1,hd,hsd1,hsd2,rd,rsd1,rsd2,v,
     *               iflag)
        sumerr = 0.
        do 12 j = 1,n
   12     sumerr = sumerr+zs1d(j)*(z(i,j)-zs1d(j))
        se(i) = p*sumerr
        if (iflag .ne. 0) p = 0.
   13   sesum = sesum+se(i)
   14 if (sesum .ne. 0.) swt = s/sesum
      p = 0.
c
c smooth along fixed x lines with reweighted s
c
      do 15 i = 1,m
        si = soverm
        if (sesum .ne. 0.) si = (se(i)*swt+soverm)/2.
        call scopy (n,z(i,1),iz,temp,1)
        call crvssb (n,y,temp,dy,isw,si,eps,zs1d,zsp1d,p,
     *               td,tsd1,hd,hsd1,hsd2,rd,rsd1,rsd2,v,
     *               iflag)
        if (iflag .ne. 0) p = 0.
c
c average this solution with solution obtained when y fixed
c
        do 15 j = 1,n
   15     zs(i,j) = (zs(i,j)+zs1d(j))/2.
c
      return
c
c s negative
c
   16 ierr = 2
      return
c
c eps negative or greater than 1
c
   17 ierr = 3
      return
      end
      subroutine terms (diag,sdiag,sigma,del)
c
      real diag,sdiag,sigma,del
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine computes the diagonal and superdiagonal
c terms of the tridiagonal linear system associated with
c spline under tension interpolation.
c
c on input--
c
c   sigma contains the tension factor.
c
c and
c
c   del contains the step size.
c
c on output--
c
c                sigma*del*cosh(sigma*del) - sinh(sigma*del)
c   diag = del*--------------------------------------------.
c                     (sigma*del)**2 * sinh(sigma*del)
c
c                   sinh(sigma*del) - sigma*del
c   sdiag = del*----------------------------------.
c                (sigma*del)**2 * sinh(sigma*del)
c
c and
c
c   sigma and del are unaltered.
c
c this subroutine references package module snhcsh.
c
c-----------------------------------------------------------
c
      if (sigma .ne. 0.) go to 1
      diag = del/3.
      sdiag = del/6.
      return
    1 sigdel = sigma*del
      call snhcsh (sinhm,coshm,sigdel,0)
      denom = sigma*sigdel*(1.+sinhm)
      diag = (coshm-sinhm)/denom
      sdiag = sinhm/denom
      return
      end
      subroutine terms2(diag,sdiag,sigma,del)
c
      real diag,sdiag,sigma,del
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine computes the diagonal and superdiagonal
c terms of the derivative with respect to sigma of the
c tridiagonal linear system associated with the spline
c under tension interpolation.
c
c on input--
c
c   sigma contains the tension factor
c
c and
c
c   del contains the step size
c
c on output--
c
c          (-(del*sigma)**2-(del*sigma)/2.*sinh(2*del*sigma)
c          +cosh(2*del*sigma)-1)
c   diag = -------------------------------------------------
c          del*sigma**3*(sinh(del*sigma))**2
c
c           ((del*sigma)**2*cosh(del*sigma)+del*sigma*sinh(
c           del*sigma)-cosh(2*del*sigma)+1
c   sdiag = ------------------------------------------------
c           del*sigma**3*(sinh(del*sigma))**2
c
c and sigma and del are unaltered.
c
c this subroutine references package module snhsc2 and
c fitpack module snhcsh.
c
c-----------------------------------------------------------
c
      if (sigma.ne.0.0) go to 1
      diag = 0.0
      sdiag = 0.0
      return
    1 sigdel = sigma*del
      call snhcsh(sinhm,dummy,sigdel,-1)
      call snhcs2(snhmm1,cshmm,sigdel,0)
      call snhcs2(snhmm2,cshmmm,2.*sigdel,3)
      sinhm = sigdel*(1.+sinhm)
      denom = 1./(sigma*sigma*sigdel*sinhm*sinhm)
      diag = (cshmmm-sigdel*snhmm2/2.)*denom
      sdiag = ((sigdel*cshmm+snhmm1)*sigdel-cshmmm)*
     *         denom
      return
      end
      subroutine threet (a,y,yp,yy,yyp,yypp)
c
      real a(10),y(2),yp(2),yy,yyp,yypp
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine performs hermite interpolation to obtain
c function values, first derivatives, and second
c derivatives.
c
c on input--
c
c
c   a is an array of 10 coefficients. to specify these, let
c   f1 be a spline under tension with value 1 at x1 and
c   second derivative at x1 as well as value and second
c   derivative at x2 all 0. let f2 have value 1 at x2 and
c   second derivative at x2 as well as value and second
c   derivative at x1 all 0. let fp1 have second derivative 1
c   at x1 and value at x1 as well as value and second
c   derivative at x2 all 0. let fp2 have second derivative 1
c   at x2 and value at x2 as well as value and second
c   derivative at x1 all 0. letting xx represent the point
c   at which the interpolations are desired,
c     a(1) contains the value of f1 at xx,
c     a(2) contains the value of f2 at xx,
c     a(3) contains the value of fp1 at xx,
c     a(4) contains the value of fp2 at xx,
c     a(5) contains the first derivative of f1 at xx,
c     a(6) contains the first derivative of f2 at xx,
c     a(7) contains the first derivative of fp1 at xx,
c     a(8) contains the first derivative of fp2 at xx,
c     a(9) contains the second derivative of fp1 at xx,
c     a(10) contains the second derivative of fp2 at xx.
c
c   y(1) and y(2) contain the values of the spline being
c   interpolated at x1 and x2, respectively.
c
c and
c
c   yp(1) and yp(2) contain the second derivatives of the
c   spline being interpolated at x1 and x2, respectively.
c
c on output--
c
c   yy, yyp, and yypp contain the value, first derivative,
c   and second derivative of the spline at xx.
c
c none of the input parameters are altered.
c
c-----------------------------------------------------------
c
      yy = a(1)*y(1)+a(2)*y(2)+a(3)*yp(1)+a(4)*yp(2)
      yyp = a(5)*y(1)+a(6)*y(2)+a(7)*yp(1)+a(8)*yp(2)
      yypp = a(9)*yp(1)+a(10)*yp(2)
      return
      end
      subroutine trdec(n,d,sup,subl)
c
      integer n
      real    d(1),sup(1),subl(1)
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine factors the symmetric tridiagonal matrix
c represented by d and sup into a lower unit triangular mat-
c rix  represented by subl and an upper triangular matrix
c represented by its diagonal overwriting d and super-
c diagonal sup.
c
c on input--
c
c   n is the order of the matrix.
c
c   d is an array of n diagonal elements of the tridiagonal
c   matrix.
c
c and
c
c   sup is an array of n-1 superdiagonal elements of the
c   tridiagonal matrix.
c
c  on output--
c
c   subl is an array of n-1 subdiagonal elements of the
c   unit lower triangular matrix.
c
c   d is an array of n diagonal elements of the upper
c   triangular matrix.
c
c and
c
c    n and sup are unaltered.
c
c note--d is both input and output.
c
c-----------------------------------------------------------
c
c
      nm1 = n-1
      do 1 k = 1,nm1
         kp1 = k+1
         subl(k) = sup(k)/d(k)
         d(kp1) = d(kp1)-subl(k)*sup(k)
    1 continue
      return
      end
      subroutine trsol(n,nrhs,irs,irc,subl,d,sup,rhs)
c
      integer n,nrhs,irs,irc
      real    subl(1),d(1),sup(1),rhs(1)
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine solves a tridiagonal system of equations
c of order n with nrhs right-hand sides, where the factored
c tridiagonal matrix is represented by subl, d, and sup, and
c the right hand sides are rows or columns of rhs.  each
c solution overwrites its respective right hand side.
c
c on input--
c
c   n is the order of the system.
c
c   nrhs is the number of right hand sides.
c
c   irs is the distance between successive components
c   of each right hand side.
c
c   irc is the distance between corresponding components
c   of each right hand side.
c
c   subl is an array of n-1 subdiagonal elements of the
c   unit lower triangular factor.
c
c   d is and array of n diagonal elements of the upper
c   triangular factor.
c
c   sup is an array of n-1 superdiagonal elements of
c   the upper triangular factor.
c
c and
c
c   rhs is an array containing the right hand sides.
c
c on output--
c
c   rhs contains the solutions.
c
c and
c
c    nrhs, irs, irc, subl, d, and sup are unaltered.
c
c this module references blas modules saxpy and sscal.
c
c-----------------------------------------------------------
c
c
      nm1 = n-1
      ist1 = 1
c
      do 1 k = 1,nm1
         ist2 = ist1+irs
         call saxpy(nrhs,-subl(k),rhs(ist1),irc,rhs(ist2),
     *              irc)
    1    ist1 = ist2
c
      call sscal(nrhs,1./d(n),rhs(ist1),irc)
c
      do 2 kk = 1,nm1
         ist2 = ist1-irs
         k = n-kk
         call saxpy(nrhs,-sup(k),rhs(ist1),irc,rhs(ist2),
     *              irc)
         call sscal(nrhs,1./d(k),rhs(ist2),irc)
    2    ist1 = ist2
c
      return
      end
      subroutine trifac(n,x,sigma,rldiag,rsdiag,usdiag)
c
      integer n
      real x(n),sigma,rldiag(n),rsdiag(n),usdiag(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine computes the lu factorization of the
c tridiaconal linear system associated with the spline
c under tension interpolatiion.
c
c on input--
c
c   n contains the number of points which were specified
c   to determine the spline.
c
c   x is an array containing the abscissae of the specified
c   points.
c
c and
c
c   sigma is the tension factor.
c
c on output--
c
c   rldiag is an array that contains the main diagonal of l.
c
c   rsdiag is an array that contains the subdiagonal of l.
c   rsdiag(1) is unchanged.
c
c   usdiag is an array that contains the superdiagonal of u.
c   (u has a unit main diagonal.)  usdiag(n) is unchanged.
c
c none of the input parameters are changed.
c
c this subroutine references fitpack modules terms and
c snhcsh.
c
c-----------------------------------------------------------
c
c perform factorization
c
      nm1 = n - 1
      delx1 = x(2) - x(1)
      call terms(diag1,sdiag1,sigma,delx1)
      rldiag(1) = diag1
      usdiag(1) = sdiag1/diag1
      if (n.eq.2) go to 6
      do 5 i = 2,nm1
        delx2 = x(i+1) - x(i)
        call terms(diag2,sdiag2,sigma,delx2)
        rsdiag(i) = sdiag1
        rldiag(i) = (diag1+diag2)-(sdiag1*usdiag(i-1))
        usdiag(i) = sdiag2/rldiag(i)
      diag1 = diag2
    5 sdiag1 = sdiag2
    6 rsdiag(n) = sdiag1
      rldiag(n) = diag1 - (sdiag1*usdiag(nm1))
      return
      end
      subroutine tridec (n,subdi,diagi,supd,subdo,diago,
     *                   ierr)
c
      integer n,ierr
      real subdi(n),diagi(n),supd(n),subdo(n),diago(n)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine factorizes a tridiagonal matrix in order
c to solve systems of linear equations. the factorization
c employs gaussian elimination without any interchanging of
c columns or rows. the subroutine trisol may be called to
c actually solve the system once the factorization has been
c performed.
c
c on input--
c
c   n contains the order of the matrix (n .ge. 1).
c
c   subdi is an array containing the subdiagonal elements of
c   the matrix in positions 2, ... , n.
c
c   diagi is an array containing the diagonal elements of
c   the matrix.
c
c   supd is an array containing the superdiagonal elements
c   of the matrix in positions 1, ... , n-1.
c
c and
c
c   subdo and diago are arrays of length n. (the storage
c   for these may coincide with that for subdi and diagi,
c   respectively, in which case the original contents of
c   subdi and diagi will be destroyed.)
c
c on output--
c
c   subdo and diago contain the subdiagonal and diagonal of
c   the factorization matrix.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 1,
c        = 2 if the system is singular.
c
c and
c
c   n, subdi, diagi, and supd are unaltered (unless storage
c   for subdi or diagi coincided with that for subdo
c   or diago, respectively).
c
c-----------------------------------------------------------
c
      if (n .le. 0) go to 3
      ierr = 2
      diago(1) = diagi(1)
      if (n .eq. 1) go to 2
c
c forward elimination
c
      do 1 i = 2,n
        im1 = i-1
        if (diago(im1) .eq. 0.) return
        diago(im1) = 1./diago(im1)
        subdo(i) = subdi(i)*diago(im1)
    1   diago(i) = diagi(i)-subdo(i)*supd(im1)
    2 if (diago(n) .eq. 0.) return
      diago(n) = 1./diago(n)
      ierr = 0
      return
c
c n less than 1
c
    3 ierr = 1
      return
      end
      subroutine tridep(n,c,d,s,sub,e,f)
c
      integer n
      real    c,d(1),s(1),sub(1),e(1),f(1)
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c given terms d(i),i = 1,...,n, s(i),i = 1,...,n-1, and c
c representing a symmetric tridiagonal matrix with
c added corner elements, this subroutine determines the
c factored matrix as
c
c   upper triangular factor
c     d(i),i = 1,...,n    (overwrites original d)
c     s(i),i = 1,...,n-1  (unaltered)
c     f(i),i = 1,...,n-1  (nth column)
c
c   and
c
c   unit lower triangular factor
c     sub(i),i = 1,...,n-2
c     e(i),i = 1,...,n-1  (nth row)
c
c       **********          **********     **********
c       *ds     c*          *1       *     *ds     f*
c       *sds     *          *s1      *     * ds    f*
c       * sds    *          * s1     *     *  ds   f*
c       *  sds   *          *  s1    *     *   ds  f*
c       *   sds  *    =     *   s1   *  *  *    ds f*
c       *    sds *          *    s1  *     *     dsf*
c       *     sds*          *     s1 *     *      df*
c       *c     sd*          *eeeeeee1*     *       d*
c       **********          **********     **********
c
c on input--
c
c   n is the order of the matrix.
c
c   c is the corner element.
c
c   d is an array of n diagonal elements.
c
c and
c
c   s is an array of n-1 super diagonal elements.
c
c on output--
c
c   sub is an array of n-1 subdiagonal elements of the
c   lower unit triangular factor.
c
c   d is an array of n diagonal elements of the upper
c   triangular factor.
c
c   e is the last row of the lower triangular factor.
c
c   f is the last column of the upper triangular factor.
c
c and
c
c   n and s are unaltered.
c
c note that d is both input and output.
c
c-----------------------------------------------------------
c
      if (n .le. 3) go to 2
      nm1 = n-1
      nm2 = n-2
      nm3 = n-3
      e(1) = c
      f(1) = c
      do 1 i = 1,nm3
         ip1 = i+1
         sub(i) = s(i)/d(i)
         d(ip1) = d(ip1)-sub(i)*s(i)
         f(ip1) = -f(i)*sub(i)
         e(i) = e(i)/d(i)
         e(ip1) = -s(i)*e(i)
    1    d(n) = d(n)-f(i)*e(i)
      sub(nm2) = s(nm2)/d(nm2)
      d(nm1) = d(nm1)-s(nm2)*sub(nm2)
      f(nm1) = s(nm1)-f(nm2)*sub(nm2)
      e(nm2) = e(nm2)/d(nm2)
      e(nm1) = (s(nm1)-s(nm2)*e(nm2))/d(nm1)
      d(n) = d(n)-f(nm2)*e(nm2)-f(nm1)*e(nm1)
      return
c
c n = 1 or 2 or 3
c
    2 if (n .eq. 1) return
      if (n .eq. 3) go to 3
      sub(1) = s(1)/d(1)
      d(n) = d(n)-sub(1)*s(1)
      return
    3 e(1) = c/d(1)
      f(1) = c
      sub(1) = s(1)/d(1)
      d(2) = d(2)-s(1)*sub(1)
      f(2) = s(2)-f(1)*s(1)
      e(2) = (s(2)-e(1)*s(1))/d(2)
      d(3) = d(3)-f(1)*e(1)-f(2)*e(2)
      return
      end
      subroutine trislm (n,subd,diag,supd,rhs,mrhs,numrhs,
     *                   incrhs)
c
      integer n,mrhs,numrhs,incrhs
      real subd(n),diag(n),supd(n),rhs(1)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine solves tridiagonal systems of linear
c equations with multiple right hand sides. the right hand
c sides may be stored row-wise or column-wise. the
c subroutine tridec should be called earlier to determine a
c factorization of the tridiagonal matrix. the solution
c vectors over-write the right hand sides.
c
c on input--
c
c   n contains the order of the matrix (n .ge. 1).
c
c   subd, diag, and supd are arrays of length n containing
c   the subdiagonal, diagonal, and superdiagonal of the
c   factorization, respectively.
c
c   rhs is an array containing the right hand sides of the
c   tridiagonal system.
c
c   mrhs is the increment between the first components of
c   each of the right hand side vectors in storage (mrhs
c   .ge. 1).
c
c   numrhs is the number of right hand sides to be solved.
c
c and
c
c   incrhs is the increment between components within each
c   of the right hand side vectors in storage (incrhs .ge.
c   1).
c
c the parameters n, subd, diag, and supd may be input as the
c parameters n, subdo, diago, and supd output by subroutine
c tridec, respectively.
c
c on output--
c
c   rhs contains the solution vectors in the same storage
c   structure as for the right hand sides.
c
c and
c
c   n, subd, diag, supd, mrhs, numrhs, and incrhs are
c   unaltered.
c
c-----------------------------------------------------------
c
      np1 = n+1
c
c loop on right hand sides
c
      do 4 k = 1,numrhs
c
c forward elimination
c
        irhs = (k-1)*mrhs+1
        if (n .eq. 1) go to 2
        do 1 i = 2,n
          im1rhs = irhs
          irhs = irhs+incrhs
    1     rhs(irhs) = rhs(irhs)-subd(i)*rhs(im1rhs)
c
c back substitution
c
    2   rhs(irhs) = diag(n)*rhs(irhs)
        if (n .eq. 1) go to 4
        do 3 ibak = 2,n
          i = np1-ibak
          rhs(im1rhs) = diag(i)*(rhs(im1rhs)-supd(i)
     *                                         *rhs(irhs))
          irhs = im1rhs
    3     im1rhs = im1rhs-incrhs
    4   continue
      return
      end
      subroutine trisol(n,rldiag,rsdiag,usdiag,x,b)
c
      integer n
      real rldiag(n),rsdiag(n),usdiag(n),x(n),b(n)
c
c                                     coded by russell lynch
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine solves the tridiagonal linear system lu x
c = b.  the subroutine trifac = b.  is to be called earlier
c compute the lu factorization of the tridiagonal matrix
c associated with the spline under tension.
c
c on input--
c
c   n contains the order of the system.
c
c   rldiag is array that contains the main diagonal of l.
c
c   rsdiag is an array that contains the subdiagonal of l.
c   rsdiag(1) is ignored.
c
c   usdiag is an array that contains the superdiagonal of u.
c   (u has a unit main diagonal.)  the contents of usdiag(n)
c   is ignored.
c
c   b is an array that contains the right hand side.
c
c on output--
c
c   x contains the solution of the system.
c
c if storage is a concern, x and b can be the same variable,
c in which case b is destroyed.
c
c none of the input parameters are changed with the above
c noted exception.
c
c-----------------------------------------------------------
c
c perform forward elimination
c
      np1 = n + 1
      x(1) = b(1)/rldiag(1)
      do 5 i = 2,n
    5   x(i) = (b(i)-rsdiag(i)*x(i-1))/rldiag(i)
c
c perform back substitution
c
      do 7 i = 2,n
        ibak = np1 - i
    7   x(ibak) = x(ibak) - usdiag(ibak)*x(ibak+1)
      return
      end
      subroutine trisop(n,d,s,sub,e,f,nrhs,irs,irc,rhs)
c
      integer n,nrhs,irs,irc
      real    d(1),s(1),sub(1),e(1),f(1),rhs(1)
c
c                                   coded by carol hazlewood
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine solves a symmetric tridiagonal system of
c equations with added corner elements of order n and nrhs
c right hand sides, where the factored matrix is represented
c by d, s, sub, e, f and the right hand sides are rows or
c columns of rhs.  each solution overwrites its respective
c right hand side.
c
c on input--
c
c   n is the order of the system.
c
c   d is the array of n diagonal elements of the upper
c   triangular factor.
c
c   s is the array of n-1 superdiagonal elements of the
c   upper triangular factor.
c
c   sub is the array of n-1 subdiagonal elements of the
c   lower triangular factor.
c
c   e is the last row of the lower triangular factor.
c
c   f is the last column of the upper triangular factor.
c
c   nrhs is the number of right hand sides.
c
c   irs is the distance between successive components of
c   each right hand side.
c
c   irc is the distance between corresponding components of
c   each right hand side.
c
c and
c
c   rhs contains the right hand sides.
c
c on output--
c
c   rhs contains the solutions.
c
c and
c
c   n, d, s, sub, e, f, nrhs, irs, and irc are unaltered.
c
c this module references blas modules saxpy and sscal.
c
c-----------------------------------------------------------
c
      nm1 = n-1
      iri = 1
      irn = 1+nm1*irs
      if (n .le. 2) go to 3
      call saxpy(nrhs,-e(1),rhs(1),irc,rhs(irn),irc)
      do 1 i = 2,nm1
         im1 = i-1
         irim1 = iri
         iri = iri+irs
         call saxpy(nrhs,-sub(im1),rhs(irim1),irc,
     *              rhs(iri),irc)
         call saxpy(nrhs,-e(i),rhs(iri),irc,
     *              rhs(irn),irc)
    1    continue
c
      call sscal(nrhs,1./d(n),rhs(irn),irc)
      iri = irn
      do 2 ii = 1,nm1
         i = n-ii
         irip1 = iri
         iri = iri-irs
         call saxpy(nrhs,-f(i),rhs(irn),irc,rhs(iri),irc)
         if (i .lt. nm1) call saxpy(nrhs,-s(i),rhs(irip1),
     *                  irc,rhs(iri),irc)
         call sscal(nrhs,1./d(i),rhs(iri),irc)
    2    continue
      return
c
c n = 1 or 2
c
    3 if (n .eq. 1) go to 4
      call saxpy(nrhs,-sub(1),rhs(1),irc,rhs(irn),irc)
      call sscal(nrhs,1./d(n),rhs(irn),irc)
      call saxpy(nrhs,-s(1),rhs(irn),irc,rhs(1),irc)
    4 call sscal(nrhs,1./d(1),rhs(1),irc)
      return
      end
      subroutine zurfnc (m,n,x,y,z,ix,iy,iz,xp,yp,zp,s,t,
     *                   temp,xpst,ypst,zpst,xps,yps,zps,
     *                   sigma,ierr)
c
      integer m,n,ix,iy,iz,ierr
      real x(ix,n),y(iy,n),z(iz,n),xp(m,n,3),yp(m,n,3),
     *     zp(m,n,3),s(m),t(n),temp(1),xpst(1),ypst(1),
     *     zpst(1),xps(n),yps(n),zps(n),sigma
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through a grid of
c points in three dimensional space--(x(i,j),y(i,j),z(i,j))
c for i=1,...,m and j=1,...,n. the surface determined can be
c represented as three tensor products of splines under
c tension. for actual mapping of points onto the surface it
c is necessary to call the subroutine zurf2d (which also
c returns derivatives with respect to two parameters for use
c in calculating normal vectors, tangent planes, curvatures,
c etc.).
c
c on input--
c
c   m is the number of rows in the arrays x, y, and z
c   containing the surface values.
c
c   n is the number of columns in the arrays x, y, and z
c   containing the surface values.
c
c   x is an array of the m x n x-coordinates of the surface
c   points.
c
c   y is an array of the m x n y-coordinates of the surface
c   points.
c
c   z is an array of the m x n z-coordinates of the surface
c   points.
c
c   ix is the row dimension of the matrix x used in the
c   calling program (ix .ge. m).
c
c   iy is the row dimension of the matrix y used in the
c   calling program (iy .ge. m).
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   xp is an array of at least 3*m*n locations.
c
c   yp is an array of at least 3*m*n locations.
c
c   zp is an array of at least 3*m*n locations.
c
c   s is an array of length at least m.
c
c   t is an array of length at least n.
c
c   temp, xpst, ypst, and zpst are arrays of at least
c   max(m,n) locations each which are used for scratch
c   storage.
c
c   xps, yps, and zps are arrays of at least n loctions each
c   which are used for scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   bi-linear. if sigma equals zero tensor products of
c   cubic splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   xp, yp, and zp contain information about the curvature
c   of the surface at the given points.
c
c   s and t contain vectors of grids to be used in the
c   parameterized surface.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2 or m is less than 2,
c        = 2 if either x(i,j) = x(i+1,j), y(i,j) = y(i+1,j),
c            and z(i,j) = z(i+1,j) or x(i,j) = x(i,j+1),
c            y(i,j) = y(i,j+1), and z(i,j) = z(i,j+1).
c
c and
c
c   m, n, x, y, z, ix, iy, iz, and sigma are unaltered.
c
c this subroutine references package modules ceez, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      mm1 = m-1
      mp1 = m+1
      nm1 = n-1
      np1 = n+1
      ierr = 0
      if (n .le. 1 .or. m .le. 1) go to 42
c
c initialize t array
c
      do 1 j = 1,n
    1   t(j) = 0.
      temp(1) = 0.
      do 3 i = 1,m
        sum = 0.
        do 2 j = 2,n
          temp(j) = sqrt((x(i,j)-x(i,j-1))**2+
     *           (y(i,j)-y(i,j-1))**2+(z(i,j)-z(i,j-1))**2)
    2     sum = sum+temp(j)
        if (sum .eq. 0.) go to 43
c
c obtain sum of normalized distances
c
        do 3 j = 1,n
    3     t(j) = t(j)+temp(j)/sum
c
c obtain average normalized distances
c
      do 4 j = 2,n
    4   t(j)  = t(j-1)+t(j)/float(m)
      t(n) = 1.
c
c denormalize tension factor in t-direction
c
      sigmat = abs(sigma)*float(n-1)/(t(n)-t(1))
c
c obtain t-partial derivatives along t = t(1)
c
      delt1 = t(2)-t(1)
      delt2 = delt1+delt1
      if (n .gt. 2) delt2 = t(3)-t(1)
      call ceez (delt1,delt2,sigmat,c1,c2,c3,n)
      do 5 i = 1,m
        xp(i,1,1) = c1*x(i,1)+c2*x(i,2)
        yp(i,1,1) = c1*y(i,1)+c2*y(i,2)
    5   zp(i,1,1) = c1*z(i,1)+c2*z(i,2)
      if (n .eq. 2) go to 7
      do 6 i = 1,m
        xp(i,1,1) = xp(i,1,1)+c3*x(i,3)
        yp(i,1,1) = yp(i,1,1)+c3*y(i,3)
    6   zp(i,1,1) = zp(i,1,1)+c3*z(i,3)
c
c obtain t-partial derivatives along t = t(n)
c
    7 deltn = t(n)-t(nm1)
      deltnm = deltn+deltn
      if (n .gt. 2) deltnm = t(n)-t(n-2)
      call ceez (-deltn,-deltnm,sigmat,c1,c2,c3,n)
      do 8 i = 1,m
        xpst(i) = c1*x(i,n)+c2*x(i,nm1)
        ypst(i) = c1*y(i,n)+c2*y(i,nm1)
    8   zpst(i) = c1*z(i,n)+c2*z(i,nm1)
      if (n .eq. 2) go to 10
      do 9 i = 1,m
        xpst(i) = xpst(i)+c3*x(i,n-2)
        ypst(i) = ypst(i)+c3*y(i,n-2)
    9   zpst(i) = zpst(i)+c3*z(i,n-2)
c
c initialize s array
c
   10 do 11 i = 1,m
   11   s(i) = 0.
      temp(1) = 0.
      do 13 j = 1,n
        sum = 0.
        do 12 i = 2,m
          temp(i) = sqrt((x(i,j)-x(i-1,j))**2+
     *           (y(i,j)-y(i-1,j))**2+(z(i,j)-z(i-1,j))**2)
   12     sum = sum+temp(i)
        if (sum .eq. 0.) go to 43
c
c obtain sum of normalized distances
c
        do 13 i = 1,m
   13     s(i) = s(i)+temp(i)/sum
c
c obtain average normalized distances
c
      do 14 i = 2,m
   14   s(i) = s(i-1)+s(i)/float(n)
      s(m) = 1.
c
c denormalize tension factor in s-direction
c
      sigmas = abs(sigma)*float(m-1)/(s(m)-s(1))
c
c obtain s-partial derivatives along s = s(1)
c
      dels1 = s(2)-s(1)
      dels2 = dels1+dels1
      if (m .gt. 2) dels2 = s(3)-s(1)
      call ceez (dels1,dels2,sigmas,c1,c2,c3,m)
      do 15 j = 1,n
        xp(1,j,2) = c1*x(1,j)+c2*x(2,j)
        yp(1,j,2) = c1*y(1,j)+c2*y(2,j)
   15   zp(1,j,2) = c1*z(1,j)+c2*z(2,j)
      if (m .eq. 2) go to 17
      do 16 j = 1,n
        xp(1,j,2) = xp(1,j,2)+c3*x(3,j)
        yp(1,j,2) = yp(1,j,2)+c3*y(3,j)
   16   zp(1,j,2) = zp(1,j,2)+c3*z(3,j)
c
c obtain s-t-partial derivative at (s(1),t(1))
c
   17 xp(1,1,3) = c1*xp(1,1,1)+c2*xp(2,1,1)
      yp(1,1,3) = c1*yp(1,1,1)+c2*yp(2,1,1)
      zp(1,1,3) = c1*zp(1,1,1)+c2*zp(2,1,1)
      if (m .eq. 2) go to 18
      xp(1,1,3) = xp(1,1,3)+c3*xp(3,1,1)
      yp(1,1,3) = yp(1,1,3)+c3*yp(3,1,1)
      zp(1,1,3) = zp(1,1,3)+c3*zp(3,1,1)
c
c obtain s-t-partial derivative at (s(1),t(n))
c
   18 xst1ns = c1*xpst(1)+c2*xpst(2)
      yst1ns = c1*ypst(1)+c2*ypst(2)
      zst1ns = c1*zpst(1)+c2*zpst(2)
      if (m .eq. 2) go to 19
      xst1ns = xst1ns+c3*xpst(3)
      yst1ns = yst1ns+c3*ypst(3)
      zst1ns = zst1ns+c3*zpst(3)
c
c obtain s-partial derivative along s = s(m)
c
   19 delsm = s(m)-s(mm1)
      delsmm = delsm+delsm
      if (m .gt. 2) delsmm = s(m)-s(m-2)
      call ceez (-delsm,-delsmm,sigmas,c1,c2,c3,m)
      do 20 j = 1,n
        xps(j) = c1*x(m,j)+c2*x(mm1,j)
        yps(j) = c1*y(m,j)+c2*y(mm1,j)
   20   zps(j) = c1*z(m,j)+c2*z(mm1,j)
      if (m .eq. 2) go to 22
      do 21 j = 1,n
        xps(j) = xps(j)+c3*x(m-2,j)
        yps(j) = yps(j)+c3*y(m-2,j)
   21   zps(j) = zps(j)+c3*z(m-2,j)
c
c obtain s-t-partial derivative at (s(m),t(1))
c
   22 xp(m,1,3) = c1*xp(m,1,1)+c2*xp(mm1,1,1)
      yp(m,1,3) = c1*yp(m,1,1)+c2*yp(mm1,1,1)
      zp(m,1,3) = c1*zp(m,1,1)+c2*zp(mm1,1,1)
      if (m .eq. 2) go to 23
      xp(m,1,3) = xp(m,1,3)+c3*xp(m-2,1,1)
      yp(m,1,3) = yp(m,1,3)+c3*yp(m-2,1,1)
      zp(m,1,3) = zp(m,1,3)+c3*zp(m-2,1,1)
c
c obtain s-t-partial derivative at (s(m),t(n))
c
   23 xstmns = c1*xpst(m)+c2*xpst(m-1)
      ystmns = c1*ypst(m)+c2*ypst(m-1)
      zstmns = c1*zpst(m)+c2*zpst(m-1)
      if (m .eq. 2) go to 24
      xstmns = xstmns+c3*xpst(m-2)
      ystmns = ystmns+c3*ypst(m-2)
      zstmns = zstmns+c3*zpst(m-2)
c
c set up right hand sides and tridiagonal system for t-grid
c perform forward elimination
c
   24 del1 = t(2)-t(1)
      deli = 1./del1
      do 25 i = 1,m
        xp(i,2,1) = deli*(x(i,2)-x(i,1))
        yp(i,2,1) = deli*(y(i,2)-y(i,1))
   25   zp(i,2,1) = deli*(z(i,2)-z(i,1))
      xp(1,2,3) = deli*(xp(1,2,2)-xp(1,1,2))
      yp(1,2,3) = deli*(yp(1,2,2)-yp(1,1,2))
      zp(1,2,3) = deli*(zp(1,2,2)-zp(1,1,2))
      xp(m,2,3) = deli*(xps(2)-xps(1))
      yp(m,2,3) = deli*(yps(2)-yps(1))
      zp(m,2,3) = deli*(zps(2)-zps(1))
      call terms (diag1,sdiag1,sigmat,del1)
      diagi = 1./diag1
      do 26 i = 1,m
        xp(i,1,1) = diagi*(xp(i,2,1)-xp(i,1,1))
        yp(i,1,1) = diagi*(yp(i,2,1)-yp(i,1,1))
   26   zp(i,1,1) = diagi*(zp(i,2,1)-zp(i,1,1))
      xp(1,1,3) = diagi*(xp(1,2,3)-xp(1,1,3))
      yp(1,1,3) = diagi*(yp(1,2,3)-yp(1,1,3))
      zp(1,1,3) = diagi*(zp(1,2,3)-zp(1,1,3))
      xp(m,1,3) = diagi*(xp(m,2,3)-xp(m,1,3))
      yp(m,1,3) = diagi*(yp(m,2,3)-yp(m,1,3))
      zp(m,1,3) = diagi*(zp(m,2,3)-zp(m,1,3))
      temp(1) = diagi*sdiag1
      if (n .eq. 2) go to 30
      do 29 j = 2,nm1
        jm1 = j-1
        jp1 = j+1
        del2 = t(jp1)-t(j)
        deli = 1./del2
        do 27 i = 1,m
          xp(i,jp1,1) = deli*(x(i,jp1)-x(i,j))
          yp(i,jp1,1) = deli*(y(i,jp1)-y(i,j))
   27     zp(i,jp1,1) = deli*(z(i,jp1)-z(i,j))
        xp(1,jp1,3) = deli*(xp(1,jp1,2)-xp(1,j,2))
        yp(1,jp1,3) = deli*(yp(1,jp1,2)-yp(1,j,2))
        zp(1,jp1,3) = deli*(zp(1,jp1,2)-zp(1,j,2))
        xp(m,jp1,3) = deli*(xps(j+1)-xps(j))
        yp(m,jp1,3) = deli*(yps(j+1)-yps(j))
        zp(m,jp1,3) = deli*(zps(j+1)-zps(j))
        call terms (diag2,sdiag2,sigmat,del2)
        diagin = 1./(diag1+diag2-sdiag1*temp(jm1))
        do 28 i = 1,m
          xp(i,j,1) = diagin*(xp(i,jp1,1)-xp(i,j,1)-
     *                        sdiag1*xp(i,jm1,1))
          yp(i,j,1) = diagin*(yp(i,jp1,1)-yp(i,j,1)-
     *                        sdiag1*yp(i,jm1,1))
   28     zp(i,j,1) = diagin*(zp(i,jp1,1)-zp(i,j,1)-
     *                        sdiag1*zp(i,jm1,1))
        xp(1,j,3) = diagin*(xp(1,jp1,3)-xp(1,j,3)-
     *                      sdiag1*xp(1,jm1,3))
        yp(1,j,3) = diagin*(yp(1,jp1,3)-yp(1,j,3)-
     *                      sdiag1*yp(1,jm1,3))
        zp(1,j,3) = diagin*(zp(1,jp1,3)-zp(1,j,3)-
     *                      sdiag1*zp(1,jm1,3))
        xp(m,j,3) = diagin*(xp(m,jp1,3)-xp(m,j,3)-
     *                      sdiag1*xp(m,jm1,3))
        yp(m,j,3) = diagin*(yp(m,jp1,3)-yp(m,j,3)-
     *                      sdiag1*yp(m,jm1,3))
        zp(m,j,3) = diagin*(zp(m,jp1,3)-zp(m,j,3)-
     *                      sdiag1*zp(m,jm1,3))
        temp(j) = diagin*sdiag2
        diag1 = diag2
   29   sdiag1 = sdiag2
   30 diagin = 1./(diag1-sdiag1*temp(nm1))
      do 31 i = 1,m
        xp(i,n,1) = diagin*(xpst(i)-xp(i,n,1)-
     *                      sdiag1*xp(i,nm1,1))
        yp(i,n,1) = diagin*(ypst(i)-yp(i,n,1)-
     *                      sdiag1*yp(i,nm1,1))
   31   zp(i,n,1) = diagin*(zpst(i)-zp(i,n,1)-
     *                      sdiag1*zp(i,nm1,1))
      xp(1,n,3) = diagin*(xst1ns-xp(1,n,3)-
     *                    sdiag1*xp(1,nm1,3))
      yp(1,n,3) = diagin*(yst1ns-yp(1,n,3)-
     *                    sdiag1*yp(1,nm1,3))
      zp(1,n,3) = diagin*(zst1ns-zp(1,n,3)-
     *                    sdiag1*zp(1,nm1,3))
      xpst(n) = diagin*(xstmns-xp(m,n,3)-
     *                  sdiag1*xp(m,nm1,3))
      ypst(n) = diagin*(ystmns-yp(m,n,3)-
     *                  sdiag1*yp(m,nm1,3))
      zpst(n) = diagin*(zstmns-zp(m,n,3)-
     *                  sdiag1*zp(m,nm1,3))
c
c perform back substitution
c
      do 33 j = 2,n
        jbak = np1-j
        jbakp1 = jbak+1
        p = temp(jbak)
        do 32 i = 1,m
          xp(i,jbak,1) = xp(i,jbak,1)-p*xp(i,jbakp1,1)
          yp(i,jbak,1) = yp(i,jbak,1)-p*yp(i,jbakp1,1)
   32     zp(i,jbak,1) = zp(i,jbak,1)-p*zp(i,jbakp1,1)
        xp(1,jbak,3) = xp(1,jbak,3)-p*xp(1,jbakp1,3)
        yp(1,jbak,3) = yp(1,jbak,3)-p*yp(1,jbakp1,3)
        zp(1,jbak,3) = zp(1,jbak,3)-p*zp(1,jbakp1,3)
        xpst(jbak) = xp(m,jbak,3)-p*xpst(jbakp1)
        ypst(jbak) = yp(m,jbak,3)-p*ypst(jbakp1)
   33   zpst(jbak) = zp(m,jbak,3)-p*zpst(jbakp1)
c
c set up right hand sides and tridiagonal system for s-grid
c perform forward elimination
c
      del1 = s(2)-s(1)
      deli = 1./del1
      do 34 j = 1,n
        xp(2,j,2) = deli*(x(2,j)-x(1,j))
        yp(2,j,2) = deli*(y(2,j)-y(1,j))
        zp(2,j,2) = deli*(z(2,j)-z(1,j))
        xp(2,j,3) = deli*(xp(2,j,1)-xp(1,j,1))
        yp(2,j,3) = deli*(yp(2,j,1)-yp(1,j,1))
   34   zp(2,j,3) = deli*(zp(2,j,1)-zp(1,j,1))
      call terms (diag1,sdiag1,sigmas,del1)
      diagi = 1./diag1
      do 35 j = 1,n
        xp(1,j,2) = diagi*(xp(2,j,2)-xp(1,j,2))
        yp(1,j,2) = diagi*(yp(2,j,2)-yp(1,j,2))
        zp(1,j,2) = diagi*(zp(2,j,2)-zp(1,j,2))
        xp(1,j,3) = diagi*(xp(2,j,3)-xp(1,j,3))
        yp(1,j,3) = diagi*(yp(2,j,3)-yp(1,j,3))
   35   zp(1,j,3) = diagi*(zp(2,j,3)-zp(1,j,3))
      temp(1) = diagi*sdiag1
      if (m .eq. 2) go to 39
      do 38 i = 2,mm1
        im1 = i-1
        ip1 = i+1
        del2 = s(ip1)-s(i)
        deli = 1./del2
        do 36 j = 1,n
          xp(ip1,j,2) = deli*(x(ip1,j)-x(i,j))
          yp(ip1,j,2) = deli*(y(ip1,j)-y(i,j))
          zp(ip1,j,2) = deli*(z(ip1,j)-z(i,j))
          xp(ip1,j,3) = deli*(xp(ip1,j,1)-xp(i,j,1))
          yp(ip1,j,3) = deli*(yp(ip1,j,1)-yp(i,j,1))
   36     zp(ip1,j,3) = deli*(zp(ip1,j,1)-zp(i,j,1))
        call terms (diag2,sdiag2,sigmas,del2)
        diagin = 1./(diag1+diag2-sdiag1*temp(i-1))
        do 37 j = 1,n
          xp(i,j,2) = diagin*(xp(ip1,j,2)-xp(i,j,2)-
     *                        sdiag1*xp(im1,j,2))
          yp(i,j,2) = diagin*(yp(ip1,j,2)-yp(i,j,2)-
     *                        sdiag1*yp(im1,j,2))
          zp(i,j,2) = diagin*(zp(ip1,j,2)-zp(i,j,2)-
     *                        sdiag1*zp(im1,j,2))
          xp(i,j,3) = diagin*(xp(ip1,j,3)-xp(i,j,3)-
     *                        sdiag1*xp(im1,j,3))
          yp(i,j,3) = diagin*(yp(ip1,j,3)-yp(i,j,3)-
     *                        sdiag1*yp(im1,j,3))
   37     zp(i,j,3) = diagin*(zp(ip1,j,3)-zp(i,j,3)-
     *                        sdiag1*zp(im1,j,3))
        temp(i) = diagin*sdiag2
        diag1 = diag2
   38   sdiag1 = sdiag2
   39 diagin = 1./(diag1-sdiag1*temp(m-1))
      do 40 j = 1,n
        xp(m,j,2) = diagin*(xps(j)-xp(m,j,2)-
     *                      sdiag1*xp(mm1,j,2))
        yp(m,j,2) = diagin*(yps(j)-yp(m,j,2)-
     *                      sdiag1*yp(mm1,j,2))
        zp(m,j,2) = diagin*(zps(j)-zp(m,j,2)-
     *                      sdiag1*zp(mm1,j,2))
        xp(m,j,3) = diagin*(xpst(j)-xp(m,j,3)-
     *                      sdiag1*xp(mm1,j,3))
        yp(m,j,3) = diagin*(ypst(j)-yp(m,j,3)-
     *                      sdiag1*yp(mm1,j,3))
   40   zp(m,j,3) = diagin*(zpst(j)-zp(m,j,3)-
     *                      sdiag1*zp(mm1,j,3))
c
c perform back substitution
c
      do 41 i = 2,m
        ibak = mp1-i
        ibakp1 = ibak+1
        p = temp(ibak)
        do 41 j = 1,n
          xp(ibak,j,2) = xp(ibak,j,2)-p*xp(ibakp1,j,2)
          yp(ibak,j,2) = yp(ibak,j,2)-p*yp(ibakp1,j,2)
          zp(ibak,j,2) = zp(ibak,j,2)-p*zp(ibakp1,j,2)
          xp(ibak,j,3) = xp(ibak,j,3)-p*xp(ibakp1,j,3)
          yp(ibak,j,3) = yp(ibak,j,3)-p*yp(ibakp1,j,3)
   41     zp(ibak,j,3) = zp(ibak,j,3)-p*zp(ibakp1,j,3)
      return
c
c too few points
c
   42 ierr = 1
      return
c
c entire adjacent grid rows or columns identical
c
   43 ierr = 2
      return
      end
