diff options
Diffstat (limited to 'math/gsurfit')
122 files changed, 12754 insertions, 0 deletions
diff --git a/math/gsurfit/README b/math/gsurfit/README new file mode 100644 index 00000000..4ab4a0f3 --- /dev/null +++ b/math/gsurfit/README @@ -0,0 +1,6 @@ +Linear least squares surface fitting package. +Contains routines to fit Legendre and Chebyshev polynomials +in the least squares sense to 2-dimensional data. +The normal equations are accumulated and solved using Cholesky factorization. +The package contains separate entry points for accumulating points, +solving the matrix equations, rejecting points and evaluating the surface. diff --git a/math/gsurfit/dgsurfitdef.h b/math/gsurfit/dgsurfitdef.h new file mode 100644 index 00000000..5888cb81 --- /dev/null +++ b/math/gsurfit/dgsurfitdef.h @@ -0,0 +1,61 @@ +# Header file for the surface fitting package + +# set up the curve descriptor structure + +define LEN_GSSTRUCT 64 + +define GS_XREF Memd[P2D($1)] # x reference value +define GS_YREF Memd[P2D($1+2)] # y reference value +define GS_ZREF Memd[P2D($1+4)] # z reference value +define GS_XMAX Memd[P2D($1+6)] # Maximum x value +define GS_XMIN Memd[P2D($1+8)] # Minimum x value +define GS_YMAX Memd[P2D($1+10)]# Maximum y value +define GS_YMIN Memd[P2D($1+12)]# Minimum y value +define GS_XRANGE Memd[P2D($1+14)]# 2. / (xmax - xmin), polynomials +define GS_XMAXMIN Memd[P2D($1+16)]# - (xmax + xmin) / 2., polynomials +define GS_YRANGE Memd[P2D($1+18)]# 2. / (ymax - ymin), polynomials +define GS_YMAXMIN Memd[P2D($1+20)]# - (ymax + ymin) / 2., polynomials +define GS_TYPE Memi[$1+22] # Type of curve to be fitted +define GS_XORDER Memi[$1+23] # Order of the fit in x +define GS_YORDER Memi[$1+24] # Order of the fit in y +define GS_XTERMS Memi[$1+25] # Cross terms for polynomials +define GS_NXCOEFF Memi[$1+26] # Number of x coefficients +define GS_NYCOEFF Memi[$1+27] # Number of y coefficients +define GS_NCOEFF Memi[$1+28] # Total number of coefficients +define GS_NPTS Memi[$1+29] # Number of data points + +define GS_MATRIX Memi[$1+30] # Pointer to original matrix +define GS_CHOFAC Memi[$1+31] # Pointer to Cholesky factorization +define GS_VECTOR Memi[$1+32] # Pointer to vector +define GS_COEFF Memi[$1+33] # Pointer to coefficient vector +define GS_XBASIS Memi[$1+34] # Pointer to basis functions (all x) +define GS_YBASIS Memi[$1+35] # Pointer to basis functions (all y) +define GS_WZ Memi[$1+36] # Pointer to w * z (gsrefit) + +# matrix and vector element definitions + +define XBASIS Memd[$1] # Non zero basis for all x +define YBASIS Memd[$1] # Non zero basis for all y +define XBS Memd[$1] # Non zero basis for single x +define YBS Memd[$1] # Non zero basis for single y +define MATRIX Memd[$1] # Element of MATRIX +define CHOFAC Memd[$1] # Element of CHOFAC +define VECTOR Memd[$1] # Element of VECTOR +define COEFF Memd[$1] # Element of COEFF + +# structure definitions for restore + +define GS_SAVETYPE $1[1] +define GS_SAVEXORDER $1[2] +define GS_SAVEYORDER $1[3] +define GS_SAVEXTERMS $1[4] +define GS_SAVEXMIN $1[5] +define GS_SAVEXMAX $1[6] +define GS_SAVEYMIN $1[7] +define GS_SAVEYMAX $1[8] + +# data type + +define DELTA EPSILON + +# miscellaneous diff --git a/math/gsurfit/doc/gsaccum.hlp b/math/gsurfit/doc/gsaccum.hlp new file mode 100644 index 00000000..afa63f70 --- /dev/null +++ b/math/gsurfit/doc/gsaccum.hlp @@ -0,0 +1,51 @@ +.help gsaccum Aug85 "Gsurfit Package" +.ih +NAME +gsaccum -- accumulate a single data point into the fit +.ih +SYNOPSIS +include <math/gsurfit.h> + +gsaccum (sf, x, y, weight, wtflag) + +.nf +pointer sf # surface descriptor +real x # x value, xmin <= x <= xmax +real y # y value, ymin <= y <= ymax +real z # z value +real weight # weight +int wtflag # type of weighting +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +The x and y values. +.le +.ls z +Data value. +.le +.ls weight +The weight assigned to the data point. +.le +.ls wtflag +Type of weighting. The options are WTS_USER and WTS_UNIFORM. If wtflag +equals WTS_USER the weight for each data point is supplied by the user. +If wtflag equals WTS_UNIFORM the routine sets the weight to 1. +.le +.ih +DESCRIPTION +GSACCUM calculates the non-zero basis functions for the given x and +y values, computes the contribution of each data point to the normal +equations and sums that contribution into the appropriate arrays and +vectors. +.ih +NOTES +Checking for out of bounds x and y values and INDEF valued data points is +the responsibility of the calling program. +.ih +SEE ALSO +gsacpts, gsfit, gsrefit +.endhelp diff --git a/math/gsurfit/doc/gsacpts.hlp b/math/gsurfit/doc/gsacpts.hlp new file mode 100644 index 00000000..1e253c61 --- /dev/null +++ b/math/gsurfit/doc/gsacpts.hlp @@ -0,0 +1,56 @@ +.help gsacpts Aug85 "Gsurfit Package" +.ih +NAME +gsacpts -- accumulate an array of data points into the fit +.ih +SYNOPSIS +include <math/gsurfit.h> + +gsacpts (sf, x, y, z, weight, npts, wtflag) + +.nf +pointer sf # surface descriptor +real x[npts] # x values, xmin <= x <= xmax +real y[npts] # y values, ymin <= y <= ymax +real z[npts] # z values +real weight[npts] # array of weights +int npts # the number of data points +int wtflag # type of weighting +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +Array of x and y values. +.le +.ls z +Array of data values. +.le +.ls weight +The weights assigned to the data points. +.le +.ls npts +The number of data points. +.le +.ls wtflag +Type of weighting. The options are WTS_USER and WTS_UNIFORM. If wtflag +equals WTS_USER the weight for each data point is supplied by the user. +If wtflag equals WTS_UNIFORM the routine sets the weight to 1. +The weight definitions are contained in the package header file gsurfit.h. +.le +.ih +DESCRIPTION +GSACCUM calculates the non-zero basis functions for the given x and +y values, computes the contribution of each data point to the normal +equations and sums that contribution into the appropriate arrays and +vectors. +.ih +NOTES +Checking for out of bounds x and y values and INDEF valued data points is +the responsibility of the calling program. +.ih +SEE ALSO +gsaccum, gsfit, gsrefit +.endhelp diff --git a/math/gsurfit/doc/gsadd.hlp b/math/gsurfit/doc/gsadd.hlp new file mode 100644 index 00000000..84d388fd --- /dev/null +++ b/math/gsurfit/doc/gsadd.hlp @@ -0,0 +1,35 @@ +.help gsadd Aug85 "Gsurfit Package" +.ih +NAME +gsadd -- add two surface fits together +.ih +SYNOPSIS +gsadd (sf1, sf2, sf3) + +.nf +pointer sf1 # first surface descriptor +pointer sf2 # second surface descriptor +pointer sf3 # resultant surface descriptor +.fi +.ih +ARGUMENTS +.ls sf1 +Pointer to the first surface descriptor. +.le +.ls sf2 +Pointer to the second surface descriptor. +.le +.ls sf3 +Pointer to the resultant surface descriptor. +.le +.ih +DESCRIPTION +The coefficients of the two surfaces are added together. GSADD checks +that the curve_types are the same and that the fits are normalized over +the same range of data. +.ih +NOTES +.ih +SEE ALSO +gscopy, gssub +.endhelp diff --git a/math/gsurfit/doc/gscoeff.hlp b/math/gsurfit/doc/gscoeff.hlp new file mode 100644 index 00000000..e4b792db --- /dev/null +++ b/math/gsurfit/doc/gscoeff.hlp @@ -0,0 +1,39 @@ +.help gscoeff Aug85 "Gsurfit Package" +.ih +NAME +gscoeff - get the number and values of the coefficients +.ih +SYNOPSIS +gscoeff (sf, coeff, ncoeff) + +.nf +pointer sf # surface descriptor +real coeff[ncoeff] # coefficient array +int ncoeff # number of coefficients +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor. +.le +.ls coeff +Array of coefficients. +.le +.ls ncoeff +The number of coefficients. Ncoeff may be obtained by a call +to gsstati. +.le + +.nf + ncoeff = gsstati (sf, GSNCOEFF) +.fi +.ih +DESCRIPTION +GSCOEFF fetches the coefficient array and the number of coefficients from +the surface descriptor structure. +.ih +NOTES +.ih +SEE ALSO +gserrors +.endhelp diff --git a/math/gsurfit/doc/gscopy.hlp b/math/gsurfit/doc/gscopy.hlp new file mode 100644 index 00000000..46a0935f --- /dev/null +++ b/math/gsurfit/doc/gscopy.hlp @@ -0,0 +1,32 @@ +.help gscopy Aug85 "Gsurfit Package" +.ih +NAME +gscopy -- copy a surface fit +.ih +SYNOPSIS +gscopy (sf1, sf2) + +.nf +pointer sf1 # old surface descriptor +pointer sf2 # new surface descriptor +.fi +.ih +ARGUMENTS +.ls sf1 +Pointer to the old surface descriptor structure. +.le +.ls sf2 +Pointer to the new surface descriptor structure. +.le +.ih +DESCRIPTION +The surface fit and parameters are copied for later use by +GSEVAL or GSVECTOR. +.ih +NOTES +The matrices and vectors used by the numerical fitting routines are not +stored. +.ih +SEE ALSO +gsadd, gssub +.endhelp diff --git a/math/gsurfit/doc/gsder.hlp b/math/gsurfit/doc/gsder.hlp new file mode 100644 index 00000000..e1af66e9 --- /dev/null +++ b/math/gsurfit/doc/gsder.hlp @@ -0,0 +1,48 @@ +.help gsder Aug85 "Gsurfit Package" +.ih +NAME +gsder -- evaluate the derivatives of the fitted surface +.ih +SYNOPSIS +gsder (sf, x, y, zfit, npts, nxder, nyder) + +.nf +pointer sf # surface descriptor +real x[npts] # x array, xmin <= x[i] <= xmax +real y[npts] # y array, ymin <= x[i] <= ymax +real zfit[npts] # data values +int npts # number of data points +int nxder # order of x derivative, 0 = function +int nyder # order of y derivative, 0 = function +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +Array of x and y values. +.le +.ls zfit +Array of fitted values. +.le +.ls npts +The number of points to be fit. +.le +.ls nxder, nyder +The order of derivative to be fit. GSDER is the same as GSVECTOR if nxder = 0 +and nyder = 0. If nxder = 1 and nyder = 0 GSDER calculates the first +derivatives of the surface with respect to x. +.le +.ih +DESCRIPTION +Evaluate the derivatives of a surface at a set of data points. +GSDER uses the coefficients stored in the surface descriptor structure. +.ih +NOTES +Checking for out of bounds x and y values is the responsibility of the +calling program. +.ih +SEE ALSO +gseval, gsvector +.endhelp diff --git a/math/gsurfit/doc/gserrors.hlp b/math/gsurfit/doc/gserrors.hlp new file mode 100644 index 00000000..fed9a82e --- /dev/null +++ b/math/gsurfit/doc/gserrors.hlp @@ -0,0 +1,61 @@ +.help gserrors Aug85 "Gsurfit Package" +.ih +NAME +.nf +gserrors -- calculate errors of the coefficients and the chi-square + of the fit +.fi +.ih +SYNOPSIS +gserrors (sf, y, weight, yfit, chi_square, errors) + +.nf +pointer sf # surface descriptor +real y[ARB] # array of data values +real weight[ARB] # array of weights +real yfit[ARB] # array of fitted values +real chi_square # chi_square of fit +real errors[ARB] # array of errors +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls y +Array of data values. +.le +.ls weight +Array of weights. +.le +.ls yfit +Array of fitted values. +.le +.ls chi_square +The reduced chi-square of the fit. +.le +.ls errors +The array of errors of the coefficients. The number of coefficients +can be obtained by a call to gsstati. +.le + +.nf + nerrors = gsstati (sf, GSNCOEFF) +.fi +.ih +DESCRIPTION +GSCOEFF calculates the reduced chi-square of the fit and the standard +deviation of the coefficients. +The chi-square of the fit is the square root of the sum of the +weighted squares of the residuals divided by the number of degrees +of freedom. If the weights are equal, then the reduced chi-square is +the variance of the fit. The error of the j-th coefficient is the +square root of the j-th diagonal element of the inverse of the data +matrix. If the weights are equal to one, then the errors are scaled +by the square root of the variance of the data. +.ih +NOTES +.ih +SEE ALSO +gscoeff +.endhelp diff --git a/math/gsurfit/doc/gseval.hlp b/math/gsurfit/doc/gseval.hlp new file mode 100644 index 00000000..b9cd08bb --- /dev/null +++ b/math/gsurfit/doc/gseval.hlp @@ -0,0 +1,34 @@ +.help gseval Aug85 "Gsurfit Package" +.ih +NAME +gseval -- evaluate the fitted surface at x and y +.ih +SYNOPSIS +y = gseval (sf, x, y) + +.nf +pointer sf # surface descriptor +real x # x value, xmin <= x <= xmax +real y # y value, ymin <= y <= ymax +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +X and y values at which the surface is to be evaluated. +.le +.ih +DESCRIPTION +Evaluate the surface at the specified value of x and y. GSEVAL is a real +valued function which returns the fitted value. +.ih +NOTES +GSEVAL uses the coefficient array stored in the surface descriptor structure. +Checking for out of bounds x and y values is the responsibility of the calling +program. +.ih +SEE ALSO +gsvector, gsder +.endhelp diff --git a/math/gsurfit/doc/gsfit.hlp b/math/gsurfit/doc/gsfit.hlp new file mode 100644 index 00000000..4abdc546 --- /dev/null +++ b/math/gsurfit/doc/gsfit.hlp @@ -0,0 +1,64 @@ +.help gsfit Aug85 "Gsurfit Package" +.ih +NAME +gsfit -- fit a surface to a set of data values +.ih +SYNOPSIS +include <math/gsurfit.h> + +gsfit (sf, x, y, z, weight, npts, wtflag, ier) + +.nf +pointer sf # surface descriptor +real x[npts] # x array, xmin <= x[i] <= xmax +real y[npts] # y array, ymin <= y[i] <= ymax +real z[npts] # data values +real weight[npts] # weight array +int npts # number of data points +int wtflag # type of weighting +int ier # error coded +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +X and y value arrays. +.le +.ls z +Array of data values. +.le +.ls weight +Array of weights. +.le +.ls npts +Number of data points +.le +.ls wtflag +Type of weighting. The options are WTS_USER and WTS_UNIFORM. If wtflag = +WTS_USER individual weights for each data point are supplied by the calling +program and points with zero-valued weights are not included in the fit. +If wtflag = WTS_UNIFORM, all weights are assigned values of 1. +.le +.ls ier +Error code for the fit. The options are OK, SINGULAR and NO_DEG_FREEDOM. +If ier = SINGULAR, the numerical routines will compute a solution but one +or more of the coefficients will be zero. If ier = NO_DEG_FREEDOM there +were too few data points to solve the matrix equations and the routine +returns without fitting the data. +.le +.ih +DESCRIPTION +GSFIT zeroes the matrix and vectors, calculates the non-zero basis functions, +computes the contribution of each data point to the normal equations +and accumulates it into the appropriate array and vector elements. The +Cholesky factorization of the coefficient array is computed and the coefficients +of the fitting function are calculated. +.ih +NOTES +Checking for out of bounds x and y values is the responsibility of the user. +.ih +SEE ALSO +gsrefit, gsaccum, gsacpts, gssolve, gszero +.endhelp diff --git a/math/gsurfit/doc/gsfree.hlp b/math/gsurfit/doc/gsfree.hlp new file mode 100644 index 00000000..a576b2e1 --- /dev/null +++ b/math/gsurfit/doc/gsfree.hlp @@ -0,0 +1,26 @@ +.help gsfree Aug85 "Gsurfit Package" +.ih +NAME +gsfree -- free the surface descriptor structure +.ih +SYNOPSIS +gsfree (sf) + +.nf +pointer sf # surface descriptor +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ih +DESCRIPTION +Frees the surface descriptor structure. +.ih +NOTES +GSFREE should be called after each surface fit. +.ih +SEE ALSO +gsinit +.endhelp diff --git a/math/gsurfit/doc/gsgcoeff.hlp b/math/gsurfit/doc/gsgcoeff.hlp new file mode 100644 index 00000000..78fdc707 --- /dev/null +++ b/math/gsurfit/doc/gsgcoeff.hlp @@ -0,0 +1,31 @@ +.help gsgcoeff Aug85 "Gsurfit Package" +.ih +NAME +gsgcoeff -- Procedure to fetch a coefficient +.ih +SYNOPSIS +rval = gsgcoeff (sf, xorder, yorder) + +.nf + pointer sf # surface descriptor + int xorder # x order of desired coefficient + int yorder # y order of desired coefficient +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor. +.le +.ls xorder, yorder +The x and y order of the desired coefficient. +.le +.ih +DESCRIPTION +GSGCOEFF fetches the coefficient of x ** (xorder - 1) * y ** (yorder - 1). +INDEF is returned if xorder and yorder are out of range. +.ih +NOTES +.ih +SEE ALSO +gsscoeff +.endhelp diff --git a/math/gsurfit/doc/gsinit.hlp b/math/gsurfit/doc/gsinit.hlp new file mode 100644 index 00000000..3a647a8c --- /dev/null +++ b/math/gsurfit/doc/gsinit.hlp @@ -0,0 +1,64 @@ +.help gsinit Aug85 "Gsurfit Package" +.ih +NAME +gsinit -- initialize surface descriptor +.ih +SYNOPSIS +include <math/gsurfit.h> + +.nf +gsinit (sf, surface_type, xorder, yorder, xterms, xmin, xmax, + ymin, ymax) +.fi + +.nf +pointer sf # surface descriptor +int surface_type # surface function +int xorder # order of function in x +int yorder # order of function in y +int xterms # include cross-terms? (YES/NO) +real xmin # minimum x value +real xmax # maximum x value +real ymin # minimum y value +real ymax # maximum y value +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls surface_type +Fitting function. Permitted values are GS_LEGENDRE and GS_CHEBYSHEV for +Legendre and Chebyshev polynomials. +.le +.ls xorder, yorder +Order of the polynomial to be fit. The order must be greater than or +equal to 1. If xorder == 1 and yorder == 1 a constant is fit to the data. +.le +.ls xterms +Set the cross-terms type? The options are GS_XNONE (the old NO option) for +no cross terms, GS_XHALF for diagonal cross terms (new option), and GS_XFULL +for full cross terms (the old YES option). +.le +.ls xmin, xmax +Minimum and maximum x values. All the x values of interest including the +data x values and the x values of any surface to be evaluated must +fall in the range xmin <= x <= xmax. +.le +.ls ymin, ymax +Minimum and maximum y values. All the y values of interest including the +data y values and the y values of any surface to be evaluated must +fall in the range ymin <= y <= ymax. +.le +.ih +DESCRIPTION +GSINIT allocates space for the surface descriptor and the arrays and vectors +used by the numerical routines. It initializes all arrays and vectors to zero +and returns the surface descriptor to the calling routine. +.ih +NOTES +GSINIT must be the first GSURFIT routine called. +.ih +SEE ALSO +gsfree +.endhelp diff --git a/math/gsurfit/doc/gsrefit.hlp b/math/gsurfit/doc/gsrefit.hlp new file mode 100644 index 00000000..629697e8 --- /dev/null +++ b/math/gsurfit/doc/gsrefit.hlp @@ -0,0 +1,55 @@ +.help gsrefit Aug85 "Gsurfit Package" +.ih +NAME +gsrefit -- refit with new z vector using old x, y and weight vector +.ih +SYNOPSIS +include < math/gsurfit.h> + +gsrefit (sf, x, y, z, w, ier) + +.nf +pointer sf # surface descriptor +real x[ARB] # x array, xmin <= x[i] <= xmax +real y[ARB] # y array, ymin <= y[i] <= ymax +real z[ARB] # array of data values +real w[ARB] # array of weights +int ier # error code +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +Array of x and y values. +.le +.ls z +Array of data values. +.le +.ls w +Array of weights. +.le +.ls ier +Error code. The options are OK, SINGULAR and NO_DEG_FREEDOM. If ier = +SINGULAR a solution is computed but one or more coefficients may be zero. +If ier equals NO_DEG_FREEDOM, there are insufficient data points to +compute a solution and GSREFIT returns without solving for the coefficients. +.le +.ih +DESCRIPTION +In some applications the x, y and weight values remain unchanged from fit +to fit and only the z values vary. In this case it is redundant to +reaccumulate the matrix and perform the Cholesky factorization. GSREFIT +zeros and reaccumulates the vector on the right hand side of the matrix +equation and performs the forward and back substitution phase to fit for +a new coefficient vector. +.ih +NOTES +In the first call to GSREFIT space is allocated for the non-zero basis +functions. Subsequent calls to GSREFIT reference this array to avoid +recalculating basis functions at every call. +.ih +SEE ALSO +gsfit, gsaccum, gsacpts, gssolve +.endhelp diff --git a/math/gsurfit/doc/gsreject.hlp b/math/gsurfit/doc/gsreject.hlp new file mode 100644 index 00000000..96344ac2 --- /dev/null +++ b/math/gsurfit/doc/gsreject.hlp @@ -0,0 +1,44 @@ +.help gsreject Aug85 "Gsurfit Package" +.ih +NAME +gsreject -- reject a data point from the fit +.ih +SYNOPSIS +gsreject (sf, x, y, z, weight) + +.nf +pointer sf # surface descriptor +real x # x value, xmin <= x <= xmax +real y # y value, ymin <= y <= ymax +real z # data value +real weight # weight +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +X and y values. +.le +.ls z +Data value. +.le +.ls weight +Weight value. +.le +.ih +DESCRIPTION +GSREJECT removes a data point from the fit. The non-zero basis functions for +each x and y are calculated, and the contribution of the point to the normal +equations is computed and subtracted from the appropriate arrays and vectors. +An array of points can be removed from the fit by repeated calls to GSREJECT +followed by a single call to GSSOLVE to calculate a new set of coefficients. +.ih +NOTES +Out of bounds x and y values and INDEF valued data values are the responsibility +of the calling program. +.ih +SEE ALSO +gsaccum, gsacpts +.endhelp diff --git a/math/gsurfit/doc/gsrestore.hlp b/math/gsurfit/doc/gsrestore.hlp new file mode 100644 index 00000000..f71aab56 --- /dev/null +++ b/math/gsurfit/doc/gsrestore.hlp @@ -0,0 +1,36 @@ +.help gsrestore Aug85 "Gsurfit Package" +.ih +NAME +gsrestore -- restore fit parameters +.ih +SYNOPSIS +gsrestore (sf, fit) + +.nf +pointer sf # surface descriptor +real fit[ARB] # fit array +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. Returned by GSRESTORE. +.le +.ls fit +Array containing the surface parameters. The size of the fit array +can be determined by a call gsstati. + +.nf + len_fit = gsstati (gs, GSNSAVE) +.fi +.le +.ih +DESCRIPTION +GSRESTORE returns the surface descriptor to the calling program and +restores the surface parameters and fit ready for use by GSEVAL or +GSVECTOR. +.ih +NOTES +.ih +SEE ALSO +gssave +.endhelp diff --git a/math/gsurfit/doc/gssave.hlp b/math/gsurfit/doc/gssave.hlp new file mode 100644 index 00000000..a6faf568 --- /dev/null +++ b/math/gsurfit/doc/gssave.hlp @@ -0,0 +1,39 @@ +.help gssave Aug85 "Gsurfit Package" +.ih +NAME +gssave -- save parameters of the fit +.ih +SYNOPSIS +call gssave (sf, fit) + +.nf +pointer sf # surface descriptor +real fit[ARB] # fit array +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls fit +Array containing fit parameters. The size of the fit array can be determined +by a call to gsstati. +.le + +.nf + len_fit = gsstati (sf, GSNSAVE) +.fi +.ih +DESCRIPTION +GSSAVE saves the surface parameters in the real array fit. The first eight +elements of fit contain the surface_type, xorder, yorder, xterms, xmin, +xmax, ymin and ymax. The coefficients are stored in the remaining array +elements. +.ih +NOTES +GSSAVE does not preserve the matrices and vectors used by the fitting +routines. +.ih +SEE ALSO +gsrestore +.endhelp diff --git a/math/gsurfit/doc/gsscoeff.hlp b/math/gsurfit/doc/gsscoeff.hlp new file mode 100644 index 00000000..5f5e4a6a --- /dev/null +++ b/math/gsurfit/doc/gsscoeff.hlp @@ -0,0 +1,35 @@ +.help gsscoeff Aug85 "Gsurfit Package" +.ih +NAME +gsscoeff -- Procedure to set a coefficient +.ih +SYNOPSIS +gsscoeff (sf, xorder, yorder, coeff) + +.nf + pointer sf # surface descriptor + int xorder # x order of desired coefficient + int yorder # y order of desired coefficient + real coeff # coefficient value +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor. +.le +.ls xorder, yorder +The x and y order of the desired coefficient. +.le +.ls coeff +The value of the coefficient to be set. +.le +.ih +DESCRIPTION +GSSCOEFF sets the coefficient of x ** (xorder - 1) * y ** (yorder - 1). +GSSCOEFF returns if xorder and yorder are out of range. +.ih +NOTES +.ih +SEE ALSO +gsgcoeff +.endhelp diff --git a/math/gsurfit/doc/gssolve.hlp b/math/gsurfit/doc/gssolve.hlp new file mode 100644 index 00000000..8ddf42fc --- /dev/null +++ b/math/gsurfit/doc/gssolve.hlp @@ -0,0 +1,40 @@ +.help gssolve Aug85 "Gsurfit Package" +.ih +NAME +gssolve -- solve a linear system of equations by the Cholesky method +.ih +SYNOPSIS +include <math/gsurfit.h> + +gssolve (sf, ier) + +.nf +pointer sf # surface descriptor +int ier # error code +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls ier +Error code returned by the fitting routines. The options are OK, SINGULAR, +and NO_DEG_FREEDOM. If ier = SINGULAR the matrix is singular, GSSOLVE +will compute a solution to the normal equations but one or more of the +coefficients will be zero. If ier = NO_DEG_FREEDOM, too few data points +exist for a reasonable solution to be computed. GSSOLVE returns without +fitting the data. +.le +.ih +DESCRIPTION +GSSOLVE computes the Cholesky factorization of the data matrix and +solves for the coefficients +of the fitting function by forward and back substitution. An error code is +returned by GSSOLVE if it is unable to solve the normal equations as +formulated. +.ih +NOTES +.ih +SEE ALSO +gsfit, gsrefit, gsaccum, gsacpts +.endhelp diff --git a/math/gsurfit/doc/gsstati.hlp b/math/gsurfit/doc/gsstati.hlp new file mode 100644 index 00000000..7b1b7f2e --- /dev/null +++ b/math/gsurfit/doc/gsstati.hlp @@ -0,0 +1,35 @@ +.help gsstati Aug85 "Gsurfit Package" +.ih +NAME +include <math/gsurfit.h> + +gsstati -- get integer parameter +.ih +SYNOPSIS +ival = gsstati (sf, parameter) + +.nf +pointer sf # surface descriptor +int parameter # integer parameter to be returned +.fi +.ih +ARGUMENTS +.ls sf +The pointer to the surface descriptor structure. +.le +.ls parameter +Parameter to be returned. The options are GSTYPE, GSXORDER, GSYORDER, +GSNXCOEFF, GSNYCOEFF, and GSNSAVE. The parameter definitions are +found in the package header file math/gsurfit.h. +.le +.ih +DESCRIPTION +The values of the integer parameters are returned. The parameters include +the surface_type, the x and y orders, the number of x and y coefficients +and the length of the buffer required by GSSAVE. +.ih +NOTES +.ih +SEE ALSO +gsstatr +.endhelp diff --git a/math/gsurfit/doc/gsstatr.hlp b/math/gsurfit/doc/gsstatr.hlp new file mode 100644 index 00000000..5a5578f2 --- /dev/null +++ b/math/gsurfit/doc/gsstatr.hlp @@ -0,0 +1,34 @@ +.help gsstatr Aug85 "Gsurfit Package" +.ih +NAME +gsstatr -- get real parameter +.ih +SYNOPSIS +include <math/gsurfit.h> + +rval = gsstatr (sf, parameter) + +.nf +pointer sf # surface descriptor +real parameter # real parameter to be returned +.fi +.ih +ARGUMENTS +.ls sf +The pointer to the surface descriptor structure. +.le +.ls parameter +Parameter to be returned. The options are GSXMIN, GSXMAX, GSYMIN and +and GSYMAX. The parameter definitions are +found in the package header file math/gsurfit.h. +.le +.ih +DESCRIPTION +The values of the integer parameters are returned. The parameters include +the minimum and maximum x values and the minimum and maximum y values. +.ih +NOTES +.ih +SEE ALSO +gsstati +.endhelp diff --git a/math/gsurfit/doc/gssub.hlp b/math/gsurfit/doc/gssub.hlp new file mode 100644 index 00000000..2c771612 --- /dev/null +++ b/math/gsurfit/doc/gssub.hlp @@ -0,0 +1,35 @@ +.help gssub Aug85 "Gsurfit Package" +.ih +NAME +gssub -- subtract surface 1 from surface 2 +.ih +SYNOPSIS +gssub (sf1, sf2, sf3) + +.nf +pointer sf1 # first surface descriptor +pointer sf2 # second surface descriptor +pointer sf3 # resultant surface descriptor +.fi +.ih +ARGUMENTS +.ls sf1 +Pointer to the first surface descriptor. +.le +.ls sf2 +Pointer to the second surface descriptor. +.le +.ls sf3 +Pointer to the resultant surface descriptor. +.le +.ih +DESCRIPTION +The coefficients of surface 2 are subtracted from surface 1. GSSUB checks +that the surface_types are the same and that the fits are normalized over +the same range of data. +.ih +NOTES +.ih +SEE ALSO +gscopy, gsadd +.endhelp diff --git a/math/gsurfit/doc/gsurfit.hd b/math/gsurfit/doc/gsurfit.hd new file mode 100644 index 00000000..169961f7 --- /dev/null +++ b/math/gsurfit/doc/gsurfit.hd @@ -0,0 +1,25 @@ +# Help directory for the GSURFIT (surface fitting) package. + +$gsurfit = "math$gsurfit/" + +gsaccum hlp = gsaccum.hlp, src = gsurfit$gsaccum.x +gsacpts hlp = gsacpts.hlp, src = gsurfit$gsacpts.x +gsadd hlp = gsadd.hlp, src = gsurfit$gsadd.x +gscoeff hlp = gscoeff.hlp, src = gsurfit$gscoeff.x +gscopy hlp = gscopy.hlp, src = gsurfit$gscopy.x +gsder hlp = gsder.hlp, src = gsurfit$gsder.x +gserrors hlp = gserrors.hlp, src = gsurfit$gserrors.x +gseval hlp = gseval.hlp, src = gsurfit$gseval.x +gsinit hlp = gsinit.hlp, src = gsurfit$gsinit.x +gsfit hlp = gsfit.hlp, src = gsurfit$gsfit.x +gsfree hlp = gsfree.hlp, src = gsurfit$gsfree.x +gsrefit hlp = gsrefit.hlp, src = gsurfit$gsrefit.x +gsreject hlp = gsreject.hlp, src = gsurfit$gsreject.x +gsrestore hlp = gsrestore.hlp, src = gsurfit$gsrestore.x +gssave hlp = gssave.hlp, src = gsurfit$gssave.x +gssolve hlp = gssolve.hlp, src = gsurfit$gssolve.x +gsstati hlp = gsstati.hlp, src = gsurfit$gsstat.x +gsstatr hlp = gsstatr.hlp, src = gsurfit$gsstat.x +gssub hlp = gssub.hlp, src = gsurfit$gssub.x +gsvector hlp = gsvector.hlp, src = gsurfit$gsvector.x +gszero hlp = gszero.hlp, src = gsurfit$gszero.x diff --git a/math/gsurfit/doc/gsurfit.hlp b/math/gsurfit/doc/gsurfit.hlp new file mode 100644 index 00000000..99f42444 --- /dev/null +++ b/math/gsurfit/doc/gsurfit.hlp @@ -0,0 +1,169 @@ +.help gsurfit Aug85 "Math Package" +.ih +NAME +gsurfit -- surface fitting package +.ih +SYNOPSIS + +.nf + gsinit (sf, surf_type, xorder, yorder, xterms, xmin, xmax, ymin, ymax) + gsaccum (sf, x, y, z, w, wtflag) + gsacpts (sf, x, y, z, w, npts, wtflag) + gsreject (sf, x, y, z, w) + gssolve (sf, ier) + gsfit (sf, x, y, z, w, npts, wtflag, ier) + gsrefit (sf, x, y, z, w, ier) + y = gseval (sf, x, y) + gsvector (sf, x, y, zfit, npts) + gsder (sf, x, y, zfit, npts, nxder, nyder) + gscoeff (sf, coeff, ncoeff) + gserrors (sf, z, w, zfit, rms, errors) + gssave (sf, fit) + gsrestore (sf, fit) +ival = gsstati (sf, param) +rval = gsstatr (sf, param) + gsadd (sf1, sf2, sf3) + gssub (sf1, sf2, sf3) + gscopy (sf1, sf2) + gsfree (sf) +.fi +.ih +DESCRIPTION +The gsurfit package provides a set of routines for fitting data to functions +of two variables, linear in their coefficients, using least squares +techniques. The numerical technique employed is the solution of the normal +equations by the Cholesky method. +.ih +NOTES +The fitting function is chosen at run time from the following list. + +.nf + GS_LEGENDRE # Lengendre polynomials in x and y + GS_CHEBYSHEV # Chebyshev polynomials in x and y +.fi + +The gsurfit package performs a weighted fit. The weighting options are +WTS_USER and WTS_UNIFORM. The user must supply a weight array. In the +WTS_UNIFORM mode the gsurfit routines set the weights to 1. In WTS_USER +mode the user must supply an array of weight values. + +In WTS_UNIFORM mode the reduced chi-square returned by GSERRORS is the +variance of the fit and the errors in the coefficients are scaled +by the square root of this variance. Otherwise the weights are +interpreted as one over the variance of the data and the true reduced +chi-square is returned. + +The routines assume that all the x and y values of interest lie in the +region xmin <= x <= xmax and ymin <= y <= ymax. Checking for out of +bounds x and y values is the responsibility of the calling program. +The package routines assume that INDEF valued data points have been removed +from the data set prior to entering the package routines. + +In order to make the package definitions available to the calling program +an include <math/gsurfit.h> statement must be inserted in the calling program. +GSINIT must be called before each fit. GSFREE frees the space used by +the GSURFIT package. +.ih +EXAMPLES +.nf +Example 1: Fit surface to data, uniform weighting + +include <math/gsurfit.h> + +... + +call gsinit (sf, GS_CHEBYSHEV, 4, 4, NO, 1., 512., 1., 512.) + +call gsfit (sf, x, y, z, w, npts, WTS_UNIFORM, ier) +if (ier != OK) + call error (...) + +do i = 1, 512 { + call printf ("x = %g y = %g z = %g zfit = %g\n") + call pargr (x[i]) + call pargr (y[i]) + call pargr (z[i]) + call pargr (gseval (sf, x[i], y[i])) +} + +call gsfree (sf) + +... + +Example 2: Fit a surface using accumulate mode, uniform weighting + +include <math/gsurfit.h> + +... + +do i = 1, 512 { + if (y[i] != INDEF) + call gsaccum (sf, x[i], y[i], z[i], weight[i], WTS_UNIFORM) +} + +call gssolve (sf, ier) +if (ier != OK) + call error (...) + +... + +call gsfree (sf) + +... + +Example 3: Fit and subtract a smooth surface from image lines + +include <math/gsurfit.h> + +... + +call gsinit (gs, GS_CHEBYSHEV, xorder, yorder, YES, 1., 512., 1., 512.) + +call gsfit (sf, xpts, ypts, zpts, w, WTS_UNIFORM, ier) +if (ier != OK) + call error (...) + +do i = 1, 512 + Memr[x+i-1] = i + +do line = 1, 512 { + + inpix = imgl2r (im, line) + outpix = imgl2r (im, line) + + yval = line + call amovkr (yval, Memr[y], 512) + call gsvector (sf, Memr[x], Memr[y], Memr[outpix], 512) + call asubr (Memr[inpix], Memr[outpix], Memr[outpix, 512) +} + +call gsfree (sf) + +... + +Example 4: Fit curve, save fit for later use for GSEVAL + +include <math/gsurfit.h> + +call gsinit (sf, GS_LEGENDRE, xorder, yorder, YES, xmin, xmax, ymin, ymax) + +call gsfit (sf, x, y, z, w, npts, WTS_UNIFORM, ier) +if (ier != OK) + ... + +nsave = gsstati (sf, GSNSAVE) +call salloc (fit, nsave, TY_REAL) +call gssave (sf, Memr[fit]) +call gsfree (sf) + +... + +call gsrestore (sf, Memr[fit]) +do i = 1, npts + zfit[i] = gseval (sf, x[i], y[i]) + +call gsfree (sf) + +... +.fi +.endhelp diff --git a/math/gsurfit/doc/gsurfit.men b/math/gsurfit/doc/gsurfit.men new file mode 100644 index 00000000..0b938ac8 --- /dev/null +++ b/math/gsurfit/doc/gsurfit.men @@ -0,0 +1,21 @@ + gsaccum - Accumulate point into data set + gsacpts - Accumulate points into a data set + gsadd - Add two surfaces + gscoeff - Get coefficients + gscopy - Copy one surface to another + gsder - Evaluate the derivatives of a surface + gserrors - Calculate chi-square and errors in coefficients + gseval - Evaluate surface at x and y + gsfit - Fit surface + gsfree - Free space allocated by gsinit + gsinit - Make ready to fit a surface; set up parameters of fit + gsrefit - Refit surface, same x, y and weight, different z + gsreject - Reject point from data set + gsrestore - Restore surface parameters and coefficients + gssave - Save surface parameters and coefficients + gssolve - Solve matrix for coefficients + gsstati - Get integer parameter + gsstatr - Get real parameter + gssub - Subtract one surface from another + gsvector - Evaluate surface at an array of x and y + gszero - Zero arrays for new fit diff --git a/math/gsurfit/doc/gsvector.hlp b/math/gsurfit/doc/gsvector.hlp new file mode 100644 index 00000000..16003101 --- /dev/null +++ b/math/gsurfit/doc/gsvector.hlp @@ -0,0 +1,41 @@ +.help gsvector Aug85 "Gsurfit Package" +.ih +NAME +gsvector -- evaluate the fitted surface at a set of points +.ih +SYNOPSIS +gsvector (sf, x, y, zfit, npts) + +.nf +pointer sf # surface descriptor +real x[npts] # x array, xmin <= x <= xmax +real y[npts] # y array, ymin <= y <= ymax +real zfit[npts] # data values +int npts # number of data points +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ls x, y +Array of x and y values. +.le +.ls zfit +Array of fitted values. +.le +.ls npts +The number of points to be fit. +.le +.ih +DESCRIPTION +Fit the surface to an array of data points. GSVECTOR uses the coefficients +stored in the surface descriptor structure. +.ih +NOTES +Checking for out of bounds x and y values is the responsibility of the +calling program. +.ih +SEE ALSO +gseval, gsder +.endhelp diff --git a/math/gsurfit/doc/gszero.hlp b/math/gsurfit/doc/gszero.hlp new file mode 100644 index 00000000..c7d411dd --- /dev/null +++ b/math/gsurfit/doc/gszero.hlp @@ -0,0 +1,27 @@ +.help gszero Aug85 "Gsurfit Package" +.ih +NAME +gszero -- set up for a new surface fit +.ih +SYNOPSIS +gszero (sf) + +.nf +pointer sf # surface descriptor +.fi +.ih +ARGUMENTS +.ls sf +Pointer to the surface descriptor structure. +.le +.ih +DESCRIPTION +GSZERO zeros the matrix and right side of the matrix equation. +.ih +NOTES +GSZERO can be used to reinitialize the matrix and right side of the +equation to begin a new fit in accumulate mode. +.ih +SEE ALSO +gsinit, gsfit, gsrefit, gsaccum, gsacpts +.endhelp diff --git a/math/gsurfit/gs_b1eval.gx b/math/gsurfit/gs_b1eval.gx new file mode 100644 index 00000000..6f474aa3 --- /dev/null +++ b/math/gsurfit/gs_b1eval.gx @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_B1POL -- Procedure to evaluate all the non-zero polynomial functions +# for a single point and given order. + +procedure $tgs_b1pol (x, order, k1, k2, basis) + +PIXEL x # data point +int order # order of polynomial, order = 1, constant +PIXEL k1, k2 # nomalizing constants, dummy in this case +PIXEL basis[ARB] # basis functions + +int i + +begin + basis[1] = 1. + if (order == 1) + return + + basis[2] = x + if (order == 2) + return + + do i = 3, order + basis[i] = x * basis[i-1] + +end + +# GS_B1LEG -- Procedure to evaluate all the non-zero Legendre functions for +# a single point and given order. + +procedure $tgs_b1leg (x, order, k1, k2, basis) + +PIXEL x # data point +int order # order of polynomial, order = 1, constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions + +int i +PIXEL ri, xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((2. * ri - 3.) * xnorm * basis[i-1] - + (ri - 2.) * basis[i-2]) / (ri - 1.) + } +end + + +# GS_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure $tgs_b1cheb (x, order, k1, k2, basis) + +PIXEL x # number of data points +int order # order of polynomial, 1 is a constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # array of basis functions + +int i +PIXEL xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = 2. * xnorm * basis[i-1] - basis[i-2] +end diff --git a/math/gsurfit/gs_b1evald.x b/math/gsurfit/gs_b1evald.x new file mode 100644 index 00000000..50fdf0bd --- /dev/null +++ b/math/gsurfit/gs_b1evald.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_B1POL -- Procedure to evaluate all the non-zero polynomial functions +# for a single point and given order. + +procedure dgs_b1pol (x, order, k1, k2, basis) + +double x # data point +int order # order of polynomial, order = 1, constant +double k1, k2 # nomalizing constants, dummy in this case +double basis[ARB] # basis functions + +int i + +begin + basis[1] = 1. + if (order == 1) + return + + basis[2] = x + if (order == 2) + return + + do i = 3, order + basis[i] = x * basis[i-1] + +end + +# GS_B1LEG -- Procedure to evaluate all the non-zero Legendre functions for +# a single point and given order. + +procedure dgs_b1leg (x, order, k1, k2, basis) + +double x # data point +int order # order of polynomial, order = 1, constant +double k1, k2 # normalizing constants +double basis[ARB] # basis functions + +int i +double ri, xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((2. * ri - 3.) * xnorm * basis[i-1] - + (ri - 2.) * basis[i-2]) / (ri - 1.) + } +end + + +# GS_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure dgs_b1cheb (x, order, k1, k2, basis) + +double x # number of data points +int order # order of polynomial, 1 is a constant +double k1, k2 # normalizing constants +double basis[ARB] # array of basis functions + +int i +double xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = 2. * xnorm * basis[i-1] - basis[i-2] +end diff --git a/math/gsurfit/gs_b1evalr.x b/math/gsurfit/gs_b1evalr.x new file mode 100644 index 00000000..a313a043 --- /dev/null +++ b/math/gsurfit/gs_b1evalr.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_B1POL -- Procedure to evaluate all the non-zero polynomial functions +# for a single point and given order. + +procedure rgs_b1pol (x, order, k1, k2, basis) + +real x # data point +int order # order of polynomial, order = 1, constant +real k1, k2 # nomalizing constants, dummy in this case +real basis[ARB] # basis functions + +int i + +begin + basis[1] = 1. + if (order == 1) + return + + basis[2] = x + if (order == 2) + return + + do i = 3, order + basis[i] = x * basis[i-1] + +end + +# GS_B1LEG -- Procedure to evaluate all the non-zero Legendre functions for +# a single point and given order. + +procedure rgs_b1leg (x, order, k1, k2, basis) + +real x # data point +int order # order of polynomial, order = 1, constant +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int i +real ri, xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((2. * ri - 3.) * xnorm * basis[i-1] - + (ri - 2.) * basis[i-2]) / (ri - 1.) + } +end + + +# GS_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure rgs_b1cheb (x, order, k1, k2, basis) + +real x # number of data points +int order # order of polynomial, 1 is a constant +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions + +int i +real xnorm + +begin + basis[1] = 1. + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = 2. * xnorm * basis[i-1] - basis[i-2] +end diff --git a/math/gsurfit/gs_beval.gx b/math/gsurfit/gs_beval.gx new file mode 100644 index 00000000..da45f122 --- /dev/null +++ b/math/gsurfit/gs_beval.gx @@ -0,0 +1,120 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_BPOL -- Procedure to evaluate all the non-zero polynomial functions for +# a set of points and given order. + +procedure $tgs_bpol (x, npts, order, k1, k2, basis) + +PIXEL x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions + +int bptr, k + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + $if (datatype == r) + call amovkr (1.0, basis, npts) + $else + call amovkd (1.0d0, basis, npts) + $endif + else if (k == 2) + call amov$t (x, basis[bptr], npts) + else + call amul$t (basis[bptr-npts], x, basis[bptr], npts) + + bptr = bptr + npts + } +end + +# GS_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure $tgs_bcheb (x, npts, order, k1, k2, basis) + +PIXEL x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions + +int k, bptr + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + $if (datatype == r) + call amovkr (1.0, basis, npts) + $else + call amovkd (1.0d0, basis, npts) + $endif + else if (k == 2) + call alta$t (x, basis[bptr], npts, k1, k2) + else { + call amul$t (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + $if (datatype == r) + call amulkr (basis[bptr], 2.0, basis[bptr], npts) + $else + call amulkd (basis[bptr], 2.0d0, basis[bptr], npts) + $endif + call asub$t (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + + bptr = bptr + npts + } +end + + +# GS_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure $tgs_bleg (x, npts, order, k1, k2, basis) + +PIXEL x[npts] # number of data points +int npts # number of points +int order # order of polynomial, 1 is a constant +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # array of basis functions + +int k, bptr +PIXEL ri, ri1, ri2 + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + $if (datatype == r) + call amovkr (1.0, basis, npts) + $else + call amovkd (1.0d0, basis, npts) + $endif + else if (k == 2) + call alta$t (x, basis[bptr], npts, k1, k2) + else { + $if (datatype == r) + ri = k + ri1 = (2. * ri - 3.) / (ri - 1.) + ri2 = - (ri - 2.) / (ri - 1.) + $else + ri = k + ri1 = (2.0d0 * ri - 3.0d0) / (ri - 1.0d0) + ri2 = - (ri - 2.0d0) / (ri - 1.0d0) + $endif + call amul$t (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call awsu$t (basis[bptr], basis[bptr-2*npts], + basis[bptr], npts, ri1, ri2) + } + + bptr = bptr + npts + } +end diff --git a/math/gsurfit/gs_bevald.x b/math/gsurfit/gs_bevald.x new file mode 100644 index 00000000..7820fa39 --- /dev/null +++ b/math/gsurfit/gs_bevald.x @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_BPOL -- Procedure to evaluate all the non-zero polynomial functions for +# a set of points and given order. + +procedure dgs_bpol (x, npts, order, k1, k2, basis) + +double x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +double k1, k2 # normalizing constants +double basis[ARB] # basis functions + +int bptr, k + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkd (1.0d0, basis, npts) + else if (k == 2) + call amovd (x, basis[bptr], npts) + else + call amuld (basis[bptr-npts], x, basis[bptr], npts) + + bptr = bptr + npts + } +end + +# GS_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure dgs_bcheb (x, npts, order, k1, k2, basis) + +double x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +double k1, k2 # normalizing constants +double basis[ARB] # basis functions + +int k, bptr + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkd (1.0d0, basis, npts) + else if (k == 2) + call altad (x, basis[bptr], npts, k1, k2) + else { + call amuld (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call amulkd (basis[bptr], 2.0d0, basis[bptr], npts) + call asubd (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + + bptr = bptr + npts + } +end + + +# GS_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure dgs_bleg (x, npts, order, k1, k2, basis) + +double x[npts] # number of data points +int npts # number of points +int order # order of polynomial, 1 is a constant +double k1, k2 # normalizing constants +double basis[ARB] # array of basis functions + +int k, bptr +double ri, ri1, ri2 + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkd (1.0d0, basis, npts) + else if (k == 2) + call altad (x, basis[bptr], npts, k1, k2) + else { + ri = k + ri1 = (2.0d0 * ri - 3.0d0) / (ri - 1.0d0) + ri2 = - (ri - 2.0d0) / (ri - 1.0d0) + call amuld (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call awsud (basis[bptr], basis[bptr-2*npts], + basis[bptr], npts, ri1, ri2) + } + + bptr = bptr + npts + } +end diff --git a/math/gsurfit/gs_bevalr.x b/math/gsurfit/gs_bevalr.x new file mode 100644 index 00000000..9d22e3dc --- /dev/null +++ b/math/gsurfit/gs_bevalr.x @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_BPOL -- Procedure to evaluate all the non-zero polynomial functions for +# a set of points and given order. + +procedure rgs_bpol (x, npts, order, k1, k2, basis) + +real x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int bptr, k + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkr (1.0, basis, npts) + else if (k == 2) + call amovr (x, basis[bptr], npts) + else + call amulr (basis[bptr-npts], x, basis[bptr], npts) + + bptr = bptr + npts + } +end + +# GS_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure rgs_bcheb (x, npts, order, k1, k2, basis) + +real x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int k, bptr + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkr (1.0, basis, npts) + else if (k == 2) + call altar (x, basis[bptr], npts, k1, k2) + else { + call amulr (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call amulkr (basis[bptr], 2.0, basis[bptr], npts) + call asubr (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + + bptr = bptr + npts + } +end + + +# GS_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure rgs_bleg (x, npts, order, k1, k2, basis) + +real x[npts] # number of data points +int npts # number of points +int order # order of polynomial, 1 is a constant +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions + +int k, bptr +real ri, ri1, ri2 + +begin + bptr = 1 + do k = 1, order { + + if (k == 1) + call amovkr (1.0, basis, npts) + else if (k == 2) + call altar (x, basis[bptr], npts, k1, k2) + else { + ri = k + ri1 = (2. * ri - 3.) / (ri - 1.) + ri2 = - (ri - 2.) / (ri - 1.) + call amulr (basis[1+npts], basis[bptr-npts], basis[bptr], + npts) + call awsur (basis[bptr], basis[bptr-2*npts], + basis[bptr], npts, ri1, ri2) + } + + bptr = bptr + npts + } +end diff --git a/math/gsurfit/gs_chomat.gx b/math/gsurfit/gs_chomat.gx new file mode 100644 index 00000000..023b3c12 --- /dev/null +++ b/math/gsurfit/gs_chomat.gx @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSCHOFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure $tgschofac (matrix, nbands, nrows, matfac, ier) + +PIXEL matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +PIXEL matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +PIXEL ratio + +begin + if (nrows == 1) { + if (matrix[1,1] > 0.) + matfac[1,1] = 1. / matrix[1,1] + return + } + + # copy matrix into matfac + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + do n = 1, nrows { + + # test to see if matrix is singular + if (((matfac[1,n]+matrix[1,n])-matrix[1,n]) <= 1000/MAX_PIXEL) { + do j = 1, nbands + matfac[j,n] = 0. + ier = SINGULAR + next + } + + matfac[1,n] = 1. / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + + +# GSCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# GSCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure $tgschoslv (matfac, nbands, nrows, vector, coeff) + +PIXEL matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +PIXEL vector[nrows] # right side of matrix equation +PIXEL coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # copy vector to coefficients + do i = 1, nrows + coeff[i] = vector[i] + + # forward substitution + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + # back substitution + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end diff --git a/math/gsurfit/gs_chomatd.x b/math/gsurfit/gs_chomatd.x new file mode 100644 index 00000000..ce15a087 --- /dev/null +++ b/math/gsurfit/gs_chomatd.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSCHOFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure dgschofac (matrix, nbands, nrows, matfac, ier) + +double matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +double matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +double ratio + +begin + if (nrows == 1) { + if (matrix[1,1] > 0.) + matfac[1,1] = 1. / matrix[1,1] + return + } + + # copy matrix into matfac + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + do n = 1, nrows { + + # test to see if matrix is singular + if (((matfac[1,n]+matrix[1,n])-matrix[1,n]) <= 1000/MAX_DOUBLE) { + do j = 1, nbands + matfac[j,n] = 0. + ier = SINGULAR + next + } + + matfac[1,n] = 1. / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + + +# GSCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# GSCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure dgschoslv (matfac, nbands, nrows, vector, coeff) + +double matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +double vector[nrows] # right side of matrix equation +double coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # copy vector to coefficients + do i = 1, nrows + coeff[i] = vector[i] + + # forward substitution + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + # back substitution + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end diff --git a/math/gsurfit/gs_chomatr.x b/math/gsurfit/gs_chomatr.x new file mode 100644 index 00000000..deb4c198 --- /dev/null +++ b/math/gsurfit/gs_chomatr.x @@ -0,0 +1,106 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSCHOFAC -- Routine to calculate the Cholesky factorization of a +# symmetric, positive semi-definite banded matrix. This routines was +# adapted from the bchfac.f routine described in "A Practical Guide +# to Splines", Carl de Boor (1978). + +procedure rgschofac (matrix, nbands, nrows, matfac, ier) + +real matrix[nbands, nrows] # data matrix +int nbands # number of bands +int nrows # number of rows +real matfac[nbands, nrows] # Cholesky factorization +int ier # error code + +int i, n, j, imax, jmax +real ratio + +begin + if (nrows == 1) { + if (matrix[1,1] > 0.) + matfac[1,1] = 1. / matrix[1,1] + return + } + + # copy matrix into matfac + do n = 1, nrows { + do j = 1, nbands + matfac[j,n] = matrix[j,n] + } + + do n = 1, nrows { + + # test to see if matrix is singular + if (((matfac[1,n]+matrix[1,n])-matrix[1,n]) <= 1000/MAX_REAL) { + do j = 1, nbands + matfac[j,n] = 0. + ier = SINGULAR + next + } + + matfac[1,n] = 1. / matfac[1,n] + imax = min (nbands - 1, nrows - n) + if (imax < 1) + next + + jmax = imax + do i = 1, imax { + ratio = matfac[i+1,n] * matfac[1,n] + do j = 1, jmax + matfac[j,n+i] = matfac[j,n+i] - matfac[j+i,n] * ratio + jmax = jmax - 1 + matfac[i+1,n] = ratio + } + } +end + + +# GSCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# GSCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure rgschoslv (matfac, nbands, nrows, vector, coeff) + +real matfac[nbands,nrows] # Cholesky factorization +int nbands # number of bands +int nrows # number of rows +real vector[nrows] # right side of matrix equation +real coeff[nrows] # coefficients + +int i, n, j, jmax, nbndm1 + +begin + if (nrows == 1) { + coeff[1] = vector[1] * matfac[1,1] + return + } + + # copy vector to coefficients + do i = 1, nrows + coeff[i] = vector[i] + + # forward substitution + nbndm1 = nbands - 1 + do n = 1, nrows { + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * coeff[n] + } + } + + # back substitution + for (n = nrows; n >= 1; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - n) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } +end diff --git a/math/gsurfit/gs_deval.gx b/math/gsurfit/gs_deval.gx new file mode 100644 index 00000000..38b90dac --- /dev/null +++ b/math/gsurfit/gs_deval.gx @@ -0,0 +1,241 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_DPOL -- Procedure to evaluate the polynomial derivative basis functions. + +procedure $tgs_dpol (x, npts, order, nder, k1, k2, basis) + +PIXEL x[npts] # array of data points +int npts # number of points +int order # order of new polynomial, order = 1, constant +int nder # order of derivative, order = 0, no derivative +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions + +int bptr, k, kk +PIXEL fac + +begin + # Optimize for oth and first derivatives. + if (nder == 0) { + call $tgs_bpol (x, npts, order, k1, k2, basis) + return + } else if (nder == 1) { + call $tgs_bpol (x, npts, order, k1, k2, basis) + do k = 1, order { + call amulk$t(basis[1+(k-1)*npts], PIXEL (k), + basis[1+(k-1)*npts], npts) + } + return + } + + # Compute the polynomials. + bptr = 1 + do k = 1, order { + if (k == 1) + call amovk$t (PIXEL(1.0), basis, npts) + else if (k == 2) + call amov$t (x, basis[bptr], npts) + else + call amul$t (basis[bptr-npts], x, basis[bptr], npts) + bptr = bptr + npts + } + + # Apply the derivative factor. + bptr = 1 + do k = 1, order { + if (k == 1) { + fac = PIXEL(1.0) + do kk = 2, nder + fac = fac * PIXEL (kk) + } else { + fac = PIXEL(1.0) + do kk = k + nder - 1, k, -1 + fac = fac * PIXEL(kk) + } + call amulk$t (basis[bptr], fac, basis[bptr], npts) + bptr = bptr + npts + } +end + + +# GS_DCHEB -- Procedure to evaluate the chebyshev polynomial derivative +# basis functions using the usual recursion relation. + +procedure $tgs_dcheb (x, npts, order, nder, k1, k2, basis) + +PIXEL x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +int nder # order of derivative, order = 0, no derivative +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions + +int i, k +pointer fn, dfn, xnorm, bptr, fptr +PIXEL fac + +begin + # Optimze the no derivatives case. + if (nder == 0) { + call $tgs_bcheb (x, npts, order, k1, k2, basis) + return + } + + # Allocate working space for the basis functions and derivatives. + call calloc (fn, npts * (order + nder), TY_PIXEL) + call calloc (dfn, npts * (order + nder), TY_PIXEL) + + # Compute the normalized x values. + call malloc (xnorm, npts, TY_PIXEL) + call alta$t (x, Mem$t[xnorm], npts, k1, k2) + + # Compute the current solution. + bptr = fn + do k = 1, order + nder { + if (k == 1) + call amovk$t (PIXEL(1.0), Mem$t[bptr], npts) + else if (k == 2) + call amov$t (Mem$t[xnorm], Mem$t[bptr], npts) + else { + call amul$t (Mem$t[xnorm], Mem$t[bptr-npts], Mem$t[bptr], npts) + call amulk$t (Mem$t[bptr], PIXEL(2.0), Mem$t[bptr], npts) + call asub$t (Mem$t[bptr], Mem$t[bptr-2*npts], Mem$t[bptr], npts) + } + bptr = bptr + npts + } + + # Compute the derivative basis functions. + do i = 1, nder { + + # Compute the derivatives. + bptr = fn + fptr = dfn + do k = 1, order + nder { + if (k == 1) + call amovk$t (PIXEL(0.0), Mem$t[fptr], npts) + else if (k == 2) { + if (i == 1) + call amovk$t (PIXEL(1.0), Mem$t[fptr], npts) + else + call amovk$t (PIXEL(0.0), Mem$t[fptr], npts) + } else { + call amul$t (Mem$t[xnorm], Mem$t[fptr-npts], Mem$t[fptr], + npts) + call amulk$t (Mem$t[fptr], PIXEL(2.0), Mem$t[fptr], npts) + call asub$t (Mem$t[fptr], Mem$t[fptr-2*npts], Mem$t[fptr], + npts) + fac = PIXEL (2.0) * PIXEL (i) + call awsu$t (Mem$t[bptr-npts], Mem$t[fptr], Mem$t[fptr], + npts, fac, PIXEL(1.0)) + + } + bptr = bptr + npts + fptr = fptr + npts + } + + # Make the derivatives the old solution + if (i < nder) + call amov$t (Mem$t[dfn], Mem$t[fn], npts * (order + nder)) + } + + # Copy the solution into the basis functions. + call amov$t (Mem$t[dfn+nder*npts], basis[1], order * npts) + + call mfree (xnorm, TY_PIXEL) + call mfree (fn, TY_PIXEL) + call mfree (dfn, TY_PIXEL) +end + + +# GS_DLEG -- Procedure to evaluate the Legendre polynomial derivative basis +# functions using the usual recursion relation. + +procedure $tgs_dleg (x, npts, order, nder, k1, k2, basis) + +PIXEL x[npts] # number of data points +int npts # number of points +int order # order of new polynomial, 1 is a constant +int nder # order of derivate, 0 is no derivative +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # array of basis functions + +int i, k +pointer fn, dfn, xnorm, bptr, fptr +PIXEL ri, ri1, ri2, fac + +begin + # Optimze the no derivatives case. + if (nder == 0) { + call $tgs_bleg (x, npts, order, k1, k2, basis) + return + } + + # Allocate working space for the basis functions and derivatives. + call calloc (fn, npts * (order + nder), TY_PIXEL) + call calloc (dfn, npts * (order + nder), TY_PIXEL) + + # Compute the normalized x values. + call malloc (xnorm, npts, TY_PIXEL) + call alta$t (x, Mem$t[xnorm], npts, k1, k2) + + # Compute the basis functions. + bptr = fn + do k = 1, order + nder { + if (k == 1) + call amovk$t (PIXEL(1.0), Mem$t[bptr], npts) + else if (k == 2) + call amov$t (Mem$t[xnorm], Mem$t[bptr], npts) + else { + ri = k + ri1 = (PIXEL(2.0) * ri - PIXEL(3.0)) / (ri - PIXEL(1.0)) + ri2 = - (ri - PIXEL(2.0)) / (ri - PIXEL(1.0)) + call amul$t (Mem$t[xnorm], Mem$t[bptr-npts], Mem$t[bptr], npts) + call awsu$t (Mem$t[bptr], Mem$t[bptr-2*npts], Mem$t[bptr], + npts, ri1, ri2) + } + bptr = bptr + npts + } + + # Compute the derivative basis functions. + do i = 1, nder { + + # Compute the derivatives. + bptr = fn + fptr = dfn + do k = 1, order + nder { + if (k == 1) + call amovk$t (PIXEL(0.0), Mem$t[fptr], npts) + else if (k == 2) { + if (i == 1) + call amovk$t (PIXEL(1.0), Mem$t[fptr], npts) + else + call amovk$t (PIXEL(0.0), Mem$t[fptr], npts) + } else { + ri = k + ri1 = (PIXEL(2.0) * ri - PIXEL(3.0)) / (ri - PIXEL(1.0)) + ri2 = - (ri - PIXEL(2.0)) / (ri - PIXEL(1.0)) + call amul$t (Mem$t[xnorm], Mem$t[fptr-npts], Mem$t[fptr], + npts) + call awsu$t (Mem$t[fptr], Mem$t[fptr-2*npts], Mem$t[fptr], + npts, ri1, ri2) + fac = ri1 * PIXEL (i) + call awsu$t (Mem$t[bptr-npts], Mem$t[fptr], Mem$t[fptr], + npts, fac, PIXEL(1.0)) + + } + bptr = bptr + npts + fptr = fptr + npts + } + + # Make the derivatives the old solution + if (i < nder) + call amov$t (Mem$t[dfn], Mem$t[fn], npts * (order + nder)) + } + + # Copy the solution into the basis functions. + call amov$t (Mem$t[dfn+nder*npts], basis[1], order * npts) + + call mfree (xnorm, TY_PIXEL) + call mfree (fn, TY_PIXEL) + call mfree (dfn, TY_PIXEL) +end diff --git a/math/gsurfit/gs_devald.x b/math/gsurfit/gs_devald.x new file mode 100644 index 00000000..131b18dc --- /dev/null +++ b/math/gsurfit/gs_devald.x @@ -0,0 +1,241 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_DPOL -- Procedure to evaluate the polynomial derivative basis functions. + +procedure dgs_dpol (x, npts, order, nder, k1, k2, basis) + +double x[npts] # array of data points +int npts # number of points +int order # order of new polynomial, order = 1, constant +int nder # order of derivative, order = 0, no derivative +double k1, k2 # normalizing constants +double basis[ARB] # basis functions + +int bptr, k, kk +double fac + +begin + # Optimize for oth and first derivatives. + if (nder == 0) { + call dgs_bpol (x, npts, order, k1, k2, basis) + return + } else if (nder == 1) { + call dgs_bpol (x, npts, order, k1, k2, basis) + do k = 1, order { + call amulkd(basis[1+(k-1)*npts], double (k), + basis[1+(k-1)*npts], npts) + } + return + } + + # Compute the polynomials. + bptr = 1 + do k = 1, order { + if (k == 1) + call amovkd (double(1.0), basis, npts) + else if (k == 2) + call amovd (x, basis[bptr], npts) + else + call amuld (basis[bptr-npts], x, basis[bptr], npts) + bptr = bptr + npts + } + + # Apply the derivative factor. + bptr = 1 + do k = 1, order { + if (k == 1) { + fac = double(1.0) + do kk = 2, nder + fac = fac * double (kk) + } else { + fac = double(1.0) + do kk = k + nder - 1, k, -1 + fac = fac * double(kk) + } + call amulkd (basis[bptr], fac, basis[bptr], npts) + bptr = bptr + npts + } +end + + +# GS_DCHEB -- Procedure to evaluate the chebyshev polynomial derivative +# basis functions using the usual recursion relation. + +procedure dgs_dcheb (x, npts, order, nder, k1, k2, basis) + +double x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +int nder # order of derivative, order = 0, no derivative +double k1, k2 # normalizing constants +double basis[ARB] # basis functions + +int i, k +pointer fn, dfn, xnorm, bptr, fptr +double fac + +begin + # Optimze the no derivatives case. + if (nder == 0) { + call dgs_bcheb (x, npts, order, k1, k2, basis) + return + } + + # Allocate working space for the basis functions and derivatives. + call calloc (fn, npts * (order + nder), TY_DOUBLE) + call calloc (dfn, npts * (order + nder), TY_DOUBLE) + + # Compute the normalized x values. + call malloc (xnorm, npts, TY_DOUBLE) + call altad (x, Memd[xnorm], npts, k1, k2) + + # Compute the current solution. + bptr = fn + do k = 1, order + nder { + if (k == 1) + call amovkd (double(1.0), Memd[bptr], npts) + else if (k == 2) + call amovd (Memd[xnorm], Memd[bptr], npts) + else { + call amuld (Memd[xnorm], Memd[bptr-npts], Memd[bptr], npts) + call amulkd (Memd[bptr], double(2.0), Memd[bptr], npts) + call asubd (Memd[bptr], Memd[bptr-2*npts], Memd[bptr], npts) + } + bptr = bptr + npts + } + + # Compute the derivative basis functions. + do i = 1, nder { + + # Compute the derivatives. + bptr = fn + fptr = dfn + do k = 1, order + nder { + if (k == 1) + call amovkd (double(0.0), Memd[fptr], npts) + else if (k == 2) { + if (i == 1) + call amovkd (double(1.0), Memd[fptr], npts) + else + call amovkd (double(0.0), Memd[fptr], npts) + } else { + call amuld (Memd[xnorm], Memd[fptr-npts], Memd[fptr], + npts) + call amulkd (Memd[fptr], double(2.0), Memd[fptr], npts) + call asubd (Memd[fptr], Memd[fptr-2*npts], Memd[fptr], + npts) + fac = double (2.0) * double (i) + call awsud (Memd[bptr-npts], Memd[fptr], Memd[fptr], + npts, fac, double(1.0)) + + } + bptr = bptr + npts + fptr = fptr + npts + } + + # Make the derivatives the old solution + if (i < nder) + call amovd (Memd[dfn], Memd[fn], npts * (order + nder)) + } + + # Copy the solution into the basis functions. + call amovd (Memd[dfn+nder*npts], basis[1], order * npts) + + call mfree (xnorm, TY_DOUBLE) + call mfree (fn, TY_DOUBLE) + call mfree (dfn, TY_DOUBLE) +end + + +# GS_DLEG -- Procedure to evaluate the Legendre polynomial derivative basis +# functions using the usual recursion relation. + +procedure dgs_dleg (x, npts, order, nder, k1, k2, basis) + +double x[npts] # number of data points +int npts # number of points +int order # order of new polynomial, 1 is a constant +int nder # order of derivate, 0 is no derivative +double k1, k2 # normalizing constants +double basis[ARB] # array of basis functions + +int i, k +pointer fn, dfn, xnorm, bptr, fptr +double ri, ri1, ri2, fac + +begin + # Optimze the no derivatives case. + if (nder == 0) { + call dgs_bleg (x, npts, order, k1, k2, basis) + return + } + + # Allocate working space for the basis functions and derivatives. + call calloc (fn, npts * (order + nder), TY_DOUBLE) + call calloc (dfn, npts * (order + nder), TY_DOUBLE) + + # Compute the normalized x values. + call malloc (xnorm, npts, TY_DOUBLE) + call altad (x, Memd[xnorm], npts, k1, k2) + + # Compute the basis functions. + bptr = fn + do k = 1, order + nder { + if (k == 1) + call amovkd (double(1.0), Memd[bptr], npts) + else if (k == 2) + call amovd (Memd[xnorm], Memd[bptr], npts) + else { + ri = k + ri1 = (double(2.0) * ri - double(3.0)) / (ri - double(1.0)) + ri2 = - (ri - double(2.0)) / (ri - double(1.0)) + call amuld (Memd[xnorm], Memd[bptr-npts], Memd[bptr], npts) + call awsud (Memd[bptr], Memd[bptr-2*npts], Memd[bptr], + npts, ri1, ri2) + } + bptr = bptr + npts + } + + # Compute the derivative basis functions. + do i = 1, nder { + + # Compute the derivatives. + bptr = fn + fptr = dfn + do k = 1, order + nder { + if (k == 1) + call amovkd (double(0.0), Memd[fptr], npts) + else if (k == 2) { + if (i == 1) + call amovkd (double(1.0), Memd[fptr], npts) + else + call amovkd (double(0.0), Memd[fptr], npts) + } else { + ri = k + ri1 = (double(2.0) * ri - double(3.0)) / (ri - double(1.0)) + ri2 = - (ri - double(2.0)) / (ri - double(1.0)) + call amuld (Memd[xnorm], Memd[fptr-npts], Memd[fptr], + npts) + call awsud (Memd[fptr], Memd[fptr-2*npts], Memd[fptr], + npts, ri1, ri2) + fac = ri1 * double (i) + call awsud (Memd[bptr-npts], Memd[fptr], Memd[fptr], + npts, fac, double(1.0)) + + } + bptr = bptr + npts + fptr = fptr + npts + } + + # Make the derivatives the old solution + if (i < nder) + call amovd (Memd[dfn], Memd[fn], npts * (order + nder)) + } + + # Copy the solution into the basis functions. + call amovd (Memd[dfn+nder*npts], basis[1], order * npts) + + call mfree (xnorm, TY_DOUBLE) + call mfree (fn, TY_DOUBLE) + call mfree (dfn, TY_DOUBLE) +end diff --git a/math/gsurfit/gs_devalr.x b/math/gsurfit/gs_devalr.x new file mode 100644 index 00000000..06449e38 --- /dev/null +++ b/math/gsurfit/gs_devalr.x @@ -0,0 +1,241 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_DPOL -- Procedure to evaluate the polynomial derivative basis functions. + +procedure rgs_dpol (x, npts, order, nder, k1, k2, basis) + +real x[npts] # array of data points +int npts # number of points +int order # order of new polynomial, order = 1, constant +int nder # order of derivative, order = 0, no derivative +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int bptr, k, kk +real fac + +begin + # Optimize for oth and first derivatives. + if (nder == 0) { + call rgs_bpol (x, npts, order, k1, k2, basis) + return + } else if (nder == 1) { + call rgs_bpol (x, npts, order, k1, k2, basis) + do k = 1, order { + call amulkr(basis[1+(k-1)*npts], real (k), + basis[1+(k-1)*npts], npts) + } + return + } + + # Compute the polynomials. + bptr = 1 + do k = 1, order { + if (k == 1) + call amovkr (real(1.0), basis, npts) + else if (k == 2) + call amovr (x, basis[bptr], npts) + else + call amulr (basis[bptr-npts], x, basis[bptr], npts) + bptr = bptr + npts + } + + # Apply the derivative factor. + bptr = 1 + do k = 1, order { + if (k == 1) { + fac = real(1.0) + do kk = 2, nder + fac = fac * real (kk) + } else { + fac = real(1.0) + do kk = k + nder - 1, k, -1 + fac = fac * real(kk) + } + call amulkr (basis[bptr], fac, basis[bptr], npts) + bptr = bptr + npts + } +end + + +# GS_DCHEB -- Procedure to evaluate the chebyshev polynomial derivative +# basis functions using the usual recursion relation. + +procedure rgs_dcheb (x, npts, order, nder, k1, k2, basis) + +real x[npts] # array of data points +int npts # number of points +int order # order of polynomial, order = 1, constant +int nder # order of derivative, order = 0, no derivative +real k1, k2 # normalizing constants +real basis[ARB] # basis functions + +int i, k +pointer fn, dfn, xnorm, bptr, fptr +real fac + +begin + # Optimze the no derivatives case. + if (nder == 0) { + call rgs_bcheb (x, npts, order, k1, k2, basis) + return + } + + # Allocate working space for the basis functions and derivatives. + call calloc (fn, npts * (order + nder), TY_REAL) + call calloc (dfn, npts * (order + nder), TY_REAL) + + # Compute the normalized x values. + call malloc (xnorm, npts, TY_REAL) + call altar (x, Memr[xnorm], npts, k1, k2) + + # Compute the current solution. + bptr = fn + do k = 1, order + nder { + if (k == 1) + call amovkr (real(1.0), Memr[bptr], npts) + else if (k == 2) + call amovr (Memr[xnorm], Memr[bptr], npts) + else { + call amulr (Memr[xnorm], Memr[bptr-npts], Memr[bptr], npts) + call amulkr (Memr[bptr], real(2.0), Memr[bptr], npts) + call asubr (Memr[bptr], Memr[bptr-2*npts], Memr[bptr], npts) + } + bptr = bptr + npts + } + + # Compute the derivative basis functions. + do i = 1, nder { + + # Compute the derivatives. + bptr = fn + fptr = dfn + do k = 1, order + nder { + if (k == 1) + call amovkr (real(0.0), Memr[fptr], npts) + else if (k == 2) { + if (i == 1) + call amovkr (real(1.0), Memr[fptr], npts) + else + call amovkr (real(0.0), Memr[fptr], npts) + } else { + call amulr (Memr[xnorm], Memr[fptr-npts], Memr[fptr], + npts) + call amulkr (Memr[fptr], real(2.0), Memr[fptr], npts) + call asubr (Memr[fptr], Memr[fptr-2*npts], Memr[fptr], + npts) + fac = real (2.0) * real (i) + call awsur (Memr[bptr-npts], Memr[fptr], Memr[fptr], + npts, fac, real(1.0)) + + } + bptr = bptr + npts + fptr = fptr + npts + } + + # Make the derivatives the old solution + if (i < nder) + call amovr (Memr[dfn], Memr[fn], npts * (order + nder)) + } + + # Copy the solution into the basis functions. + call amovr (Memr[dfn+nder*npts], basis[1], order * npts) + + call mfree (xnorm, TY_REAL) + call mfree (fn, TY_REAL) + call mfree (dfn, TY_REAL) +end + + +# GS_DLEG -- Procedure to evaluate the Legendre polynomial derivative basis +# functions using the usual recursion relation. + +procedure rgs_dleg (x, npts, order, nder, k1, k2, basis) + +real x[npts] # number of data points +int npts # number of points +int order # order of new polynomial, 1 is a constant +int nder # order of derivate, 0 is no derivative +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions + +int i, k +pointer fn, dfn, xnorm, bptr, fptr +real ri, ri1, ri2, fac + +begin + # Optimze the no derivatives case. + if (nder == 0) { + call rgs_bleg (x, npts, order, k1, k2, basis) + return + } + + # Allocate working space for the basis functions and derivatives. + call calloc (fn, npts * (order + nder), TY_REAL) + call calloc (dfn, npts * (order + nder), TY_REAL) + + # Compute the normalized x values. + call malloc (xnorm, npts, TY_REAL) + call altar (x, Memr[xnorm], npts, k1, k2) + + # Compute the basis functions. + bptr = fn + do k = 1, order + nder { + if (k == 1) + call amovkr (real(1.0), Memr[bptr], npts) + else if (k == 2) + call amovr (Memr[xnorm], Memr[bptr], npts) + else { + ri = k + ri1 = (real(2.0) * ri - real(3.0)) / (ri - real(1.0)) + ri2 = - (ri - real(2.0)) / (ri - real(1.0)) + call amulr (Memr[xnorm], Memr[bptr-npts], Memr[bptr], npts) + call awsur (Memr[bptr], Memr[bptr-2*npts], Memr[bptr], + npts, ri1, ri2) + } + bptr = bptr + npts + } + + # Compute the derivative basis functions. + do i = 1, nder { + + # Compute the derivatives. + bptr = fn + fptr = dfn + do k = 1, order + nder { + if (k == 1) + call amovkr (real(0.0), Memr[fptr], npts) + else if (k == 2) { + if (i == 1) + call amovkr (real(1.0), Memr[fptr], npts) + else + call amovkr (real(0.0), Memr[fptr], npts) + } else { + ri = k + ri1 = (real(2.0) * ri - real(3.0)) / (ri - real(1.0)) + ri2 = - (ri - real(2.0)) / (ri - real(1.0)) + call amulr (Memr[xnorm], Memr[fptr-npts], Memr[fptr], + npts) + call awsur (Memr[fptr], Memr[fptr-2*npts], Memr[fptr], + npts, ri1, ri2) + fac = ri1 * real (i) + call awsur (Memr[bptr-npts], Memr[fptr], Memr[fptr], + npts, fac, real(1.0)) + + } + bptr = bptr + npts + fptr = fptr + npts + } + + # Make the derivatives the old solution + if (i < nder) + call amovr (Memr[dfn], Memr[fn], npts * (order + nder)) + } + + # Copy the solution into the basis functions. + call amovr (Memr[dfn+nder*npts], basis[1], order * npts) + + call mfree (xnorm, TY_REAL) + call mfree (fn, TY_REAL) + call mfree (dfn, TY_REAL) +end diff --git a/math/gsurfit/gs_f1deval.gx b/math/gsurfit/gs_f1deval.gx new file mode 100644 index 00000000..17981daf --- /dev/null +++ b/math/gsurfit/gs_f1deval.gx @@ -0,0 +1,189 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_1DEVPOLY -- Procedure to evaulate a 1D polynomial + +procedure $tgs_1devpoly (coeff, x, yfit, npts, order, k1, k2) + +PIXEL coeff[ARB] # EV array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +PIXEL k1, k2 # normalizing constants + +int i +pointer sp, temp + +begin + # fit a constant + call amovk$t (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + call altm$t (x, yfit, npts, coeff[2], coeff[1]) + if (order == 2) + return + + call smark (sp) + $if (datatype == r) + call salloc (temp, npts, TY_REAL) + $else + call salloc (temp, npts, TY_DOUBLE) + $endif + + # accumulate the output vector + call amov$t (x, Mem$t[temp], npts) + do i = 3, order { + call amul$t (Mem$t[temp], x, Mem$t[temp], npts) + $if (datatype == r) + call awsur (yfit, Memr[temp], yfit, npts, 1.0, coeff[i]) + $else + call awsud (yfit, Memd[temp], yfit, npts, 1.0d0, coeff[i]) + $endif + } + + call sfree (sp) + +end + +# GS_1DEVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure $tgs_1devcheb (coeff, x, yfit, npts, order, k1, k2) + +PIXEL coeff[ARB] # EV array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +PIXEL k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +PIXEL c1, c2 + +begin + # fit a constant + call amovk$t (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + c1 = k2 * coeff[2] + c2 = c1 * k1 + coeff[1] + call altm$t (x, yfit, npts, c1, c2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + $if (datatype == r) + call salloc (sx, npts, TY_REAL) + call salloc (pn, npts, TY_REAL) + call salloc (pnm1, npts, TY_REAL) + call salloc (pnm2, npts, TY_REAL) + $else + call salloc (sx, npts, TY_DOUBLE) + call salloc (pn, npts, TY_DOUBLE) + call salloc (pnm1, npts, TY_DOUBLE) + call salloc (pnm2, npts, TY_DOUBLE) + $endif + + # a higher order polynomial + $if (datatype == r) + call amovkr (1., Memr[pnm2], npts) + $else + call amovkd (1.0d0, Memd[pnm2], npts) + $endif + call alta$t (x, Mem$t[sx], npts, k1, k2) + call amov$t (Mem$t[sx], Mem$t[pnm1], npts) + call amulk$t (Mem$t[sx], 2$f, Mem$t[sx], npts) + do i = 3, order { + call amul$t (Mem$t[sx], Mem$t[pnm1], Mem$t[pn], npts) + call asub$t (Mem$t[pn], Mem$t[pnm2], Mem$t[pn], npts) + if (i < order) { + call amov$t (Mem$t[pnm1], Mem$t[pnm2], npts) + call amov$t (Mem$t[pn], Mem$t[pnm1], npts) + } + call amulk$t (Mem$t[pn], coeff[i], Mem$t[pn], npts) + call aadd$t (yfit, Mem$t[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + + +# GS_1DEVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure $tgs_1devleg (coeff, x, yfit, npts, order, k1, k2) + +PIXEL coeff[ARB] # EV array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL yfit[npts] # the fitted points +int npts # number of data points +int order # order of the polynomial, 1 = constant +PIXEL k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +PIXEL ri, ri1, ri2 + +begin + # fit a constant + call amovk$t (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + ri1 = k2 * coeff[2] + ri2 = ri1 * k1 + coeff[1] + call altm$t (x, yfit, npts, ri1, ri2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + $if (datatype == r) + call salloc (sx, npts, TY_REAL) + call salloc (pn, npts, TY_REAL) + call salloc (pnm1, npts, TY_REAL) + call salloc (pnm2, npts, TY_REAL) + $else + call salloc (sx, npts, TY_DOUBLE) + call salloc (pn, npts, TY_DOUBLE) + call salloc (pnm1, npts, TY_DOUBLE) + call salloc (pnm2, npts, TY_DOUBLE) + $endif + + # a higher order polynomial + $if (datatype == r) + call amovkr (1., Memr[pnm2], npts) + $else + call amovkd (1.0d0, Memd[pnm2], npts) + $endif + call alta$t (x, Mem$t[sx], npts, k1, k2) + call amov$t (Mem$t[sx], Mem$t[pnm1], npts) + do i = 3, order { + ri = i + ri1 = (2. * ri - 3.) / (ri - 1.) + ri2 = - (ri - 2.) / (ri - 1.) + call amul$t (Mem$t[sx], Mem$t[pnm1], Mem$t[pn], npts) + call awsu$t (Mem$t[pn], Mem$t[pnm2], Mem$t[pn], npts, ri1, ri2) + if (i < order) { + call amov$t (Mem$t[pnm1], Mem$t[pnm2], npts) + call amov$t (Mem$t[pn], Mem$t[pnm1], npts) + } + call amulk$t (Mem$t[pn], coeff[i], Mem$t[pn], npts) + call aadd$t (yfit, Mem$t[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end diff --git a/math/gsurfit/gs_f1devald.x b/math/gsurfit/gs_f1devald.x new file mode 100644 index 00000000..6f20e7e7 --- /dev/null +++ b/math/gsurfit/gs_f1devald.x @@ -0,0 +1,159 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_1DEVPOLY -- Procedure to evaulate a 1D polynomial + +procedure dgs_1devpoly (coeff, x, yfit, npts, order, k1, k2) + +double coeff[ARB] # EV array of coefficients +double x[npts] # x values of points to be evaluated +double yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +double k1, k2 # normalizing constants + +int i +pointer sp, temp + +begin + # fit a constant + call amovkd (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + call altmd (x, yfit, npts, coeff[2], coeff[1]) + if (order == 2) + return + + call smark (sp) + call salloc (temp, npts, TY_DOUBLE) + + # accumulate the output vector + call amovd (x, Memd[temp], npts) + do i = 3, order { + call amuld (Memd[temp], x, Memd[temp], npts) + call awsud (yfit, Memd[temp], yfit, npts, 1.0d0, coeff[i]) + } + + call sfree (sp) + +end + +# GS_1DEVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure dgs_1devcheb (coeff, x, yfit, npts, order, k1, k2) + +double coeff[ARB] # EV array of coefficients +double x[npts] # x values of points to be evaluated +double yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +double k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +double c1, c2 + +begin + # fit a constant + call amovkd (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + c1 = k2 * coeff[2] + c2 = c1 * k1 + coeff[1] + call altmd (x, yfit, npts, c1, c2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_DOUBLE) + call salloc (pn, npts, TY_DOUBLE) + call salloc (pnm1, npts, TY_DOUBLE) + call salloc (pnm2, npts, TY_DOUBLE) + + # a higher order polynomial + call amovkd (1.0d0, Memd[pnm2], npts) + call altad (x, Memd[sx], npts, k1, k2) + call amovd (Memd[sx], Memd[pnm1], npts) + call amulkd (Memd[sx], 2.0D0, Memd[sx], npts) + do i = 3, order { + call amuld (Memd[sx], Memd[pnm1], Memd[pn], npts) + call asubd (Memd[pn], Memd[pnm2], Memd[pn], npts) + if (i < order) { + call amovd (Memd[pnm1], Memd[pnm2], npts) + call amovd (Memd[pn], Memd[pnm1], npts) + } + call amulkd (Memd[pn], coeff[i], Memd[pn], npts) + call aaddd (yfit, Memd[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + + +# GS_1DEVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure dgs_1devleg (coeff, x, yfit, npts, order, k1, k2) + +double coeff[ARB] # EV array of coefficients +double x[npts] # x values of points to be evaluated +double yfit[npts] # the fitted points +int npts # number of data points +int order # order of the polynomial, 1 = constant +double k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +double ri, ri1, ri2 + +begin + # fit a constant + call amovkd (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + ri1 = k2 * coeff[2] + ri2 = ri1 * k1 + coeff[1] + call altmd (x, yfit, npts, ri1, ri2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_DOUBLE) + call salloc (pn, npts, TY_DOUBLE) + call salloc (pnm1, npts, TY_DOUBLE) + call salloc (pnm2, npts, TY_DOUBLE) + + # a higher order polynomial + call amovkd (1.0d0, Memd[pnm2], npts) + call altad (x, Memd[sx], npts, k1, k2) + call amovd (Memd[sx], Memd[pnm1], npts) + do i = 3, order { + ri = i + ri1 = (2. * ri - 3.) / (ri - 1.) + ri2 = - (ri - 2.) / (ri - 1.) + call amuld (Memd[sx], Memd[pnm1], Memd[pn], npts) + call awsud (Memd[pn], Memd[pnm2], Memd[pn], npts, ri1, ri2) + if (i < order) { + call amovd (Memd[pnm1], Memd[pnm2], npts) + call amovd (Memd[pn], Memd[pnm1], npts) + } + call amulkd (Memd[pn], coeff[i], Memd[pn], npts) + call aaddd (yfit, Memd[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end diff --git a/math/gsurfit/gs_f1devalr.x b/math/gsurfit/gs_f1devalr.x new file mode 100644 index 00000000..5fdab143 --- /dev/null +++ b/math/gsurfit/gs_f1devalr.x @@ -0,0 +1,159 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# GS_1DEVPOLY -- Procedure to evaulate a 1D polynomial + +procedure rgs_1devpoly (coeff, x, yfit, npts, order, k1, k2) + +real coeff[ARB] # EV array of coefficients +real x[npts] # x values of points to be evaluated +real yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +real k1, k2 # normalizing constants + +int i +pointer sp, temp + +begin + # fit a constant + call amovkr (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + call altmr (x, yfit, npts, coeff[2], coeff[1]) + if (order == 2) + return + + call smark (sp) + call salloc (temp, npts, TY_REAL) + + # accumulate the output vector + call amovr (x, Memr[temp], npts) + do i = 3, order { + call amulr (Memr[temp], x, Memr[temp], npts) + call awsur (yfit, Memr[temp], yfit, npts, 1.0, coeff[i]) + } + + call sfree (sp) + +end + +# GS_1DEVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure rgs_1devcheb (coeff, x, yfit, npts, order, k1, k2) + +real coeff[ARB] # EV array of coefficients +real x[npts] # x values of points to be evaluated +real yfit[npts] # the fitted points +int npts # number of points to be evaluated +int order # order of the polynomial, 1 = constant +real k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +real c1, c2 + +begin + # fit a constant + call amovkr (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + c1 = k2 * coeff[2] + c2 = c1 * k1 + coeff[1] + call altmr (x, yfit, npts, c1, c2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (pn, npts, TY_REAL) + call salloc (pnm1, npts, TY_REAL) + call salloc (pnm2, npts, TY_REAL) + + # a higher order polynomial + call amovkr (1., Memr[pnm2], npts) + call altar (x, Memr[sx], npts, k1, k2) + call amovr (Memr[sx], Memr[pnm1], npts) + call amulkr (Memr[sx], 2.0, Memr[sx], npts) + do i = 3, order { + call amulr (Memr[sx], Memr[pnm1], Memr[pn], npts) + call asubr (Memr[pn], Memr[pnm2], Memr[pn], npts) + if (i < order) { + call amovr (Memr[pnm1], Memr[pnm2], npts) + call amovr (Memr[pn], Memr[pnm1], npts) + } + call amulkr (Memr[pn], coeff[i], Memr[pn], npts) + call aaddr (yfit, Memr[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end + + +# GS_1DEVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure rgs_1devleg (coeff, x, yfit, npts, order, k1, k2) + +real coeff[ARB] # EV array of coefficients +real x[npts] # x values of points to be evaluated +real yfit[npts] # the fitted points +int npts # number of data points +int order # order of the polynomial, 1 = constant +real k1, k2 # normalizing constants + +int i +pointer sx, pn, pnm1, pnm2 +pointer sp +real ri, ri1, ri2 + +begin + # fit a constant + call amovkr (coeff[1], yfit, npts) + if (order == 1) + return + + # fit a linear function + ri1 = k2 * coeff[2] + ri2 = ri1 * k1 + coeff[1] + call altmr (x, yfit, npts, ri1, ri2) + if (order == 2) + return + + # allocate temporary space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (pn, npts, TY_REAL) + call salloc (pnm1, npts, TY_REAL) + call salloc (pnm2, npts, TY_REAL) + + # a higher order polynomial + call amovkr (1., Memr[pnm2], npts) + call altar (x, Memr[sx], npts, k1, k2) + call amovr (Memr[sx], Memr[pnm1], npts) + do i = 3, order { + ri = i + ri1 = (2. * ri - 3.) / (ri - 1.) + ri2 = - (ri - 2.) / (ri - 1.) + call amulr (Memr[sx], Memr[pnm1], Memr[pn], npts) + call awsur (Memr[pn], Memr[pnm2], Memr[pn], npts, ri1, ri2) + if (i < order) { + call amovr (Memr[pnm1], Memr[pnm2], npts) + call amovr (Memr[pn], Memr[pnm1], npts) + } + call amulkr (Memr[pn], coeff[i], Memr[pn], npts) + call aaddr (yfit, Memr[pn], yfit, npts) + } + + # free temporary space + call sfree (sp) + +end diff --git a/math/gsurfit/gs_fder.gx b/math/gsurfit/gs_fder.gx new file mode 100644 index 00000000..1620e189 --- /dev/null +++ b/math/gsurfit/gs_fder.gx @@ -0,0 +1,288 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> + +# GS_DERPOLY -- Evaluate the new polynomial derivative surface. + +procedure $tgs_derpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, nxder, + nyder, k1x, k2x, k1y, k2y) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL y[npts] +PIXEL zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +PIXEL k1x, k2x # normalizing constants +PIXEL k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # allocate temporary space for the basis functions + call smark (sp) + $if (datatype == r) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + $else + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + $endif + + # calculate basis functions + call $tgs_dpol (x, npts, xorder, nxder, k1x, k2x, Mem$t[xb]) + call $tgs_dpol (y, npts, yorder, nyder, k1y, k2y, Mem$t[yb]) + + # accumulate the output vector + cptr = 0 + call aclr$t (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclr$t (Mem$t[accum], npts) + xbptr = xb + do k = 1, xincr { + $if (datatype == r) + call awsu$t (Mem$t[accum], Mem$t[xbptr], Mem$t[accum], npts, + 1.0, coeff[cptr+k]) + $else + call awsu$t (Mem$t[accum], Mem$t[xbptr], Mem$t[accum], npts, + 1.0d0, coeff[cptr+k]) + $endif + xbptr = xbptr + npts + } + call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amul$t (Mem$t[xb], Mem$t[yb], zfit, npts) + call amulk$t (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1]) + $else + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1]) + $endif + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + $else + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + $endif + ybptr = ybptr + npts + } + } + + + call sfree (sp) +end + +# GS_DERCHEB -- Evaluate the new Chebyshev polynomial derivative surface. + +procedure $tgs_dercheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, + nxder, nyder, k1x, k2x, k1y, k2y) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL y[npts] +PIXEL zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +PIXEL k1x, k2x # normalizing constants +PIXEL k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # allocate temporary space for the basis functions + call smark (sp) + $if (datatype == r) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + $else + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + $endif + + # calculate basis functions + call $tgs_dcheb (x, npts, xorder, nxder, k1x, k2x, Mem$t[xb]) + call $tgs_dcheb (y, npts, yorder, nyder, k1y, k2y, Mem$t[yb]) + + # accumulate thr output vector + cptr = 0 + call aclr$t (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclr$t (Mem$t[accum], npts) + xbptr = xb + do k = 1, xincr { + $if (datatype == r) + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + $else + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + $endif + xbptr = xbptr + npts + } + call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amul$t (Mem$t[xb], Mem$t[yb], zfit, npts) + call amulk$t (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1]) + $else + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1]) + $endif + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + $else + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + $endif + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + + +# GS_DERLEG -- Evaluate the new Legendre polynomial derivative surface. + +procedure $tgs_derleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, + nxder, nyder, k1x, k2x, k1y, k2y) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL y[npts] +PIXEL zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +PIXEL k1x, k2x # normalizing constants +PIXEL k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, accum, xbptr, ybptr + +begin + # allocate temporary space for the basis functions + call smark (sp) + $if (datatype == r) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + $else + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + $endif + + # calculate basis functions + call $tgs_dleg (x, npts, xorder, nxder, k1x, k2x, Mem$t[xb]) + call $tgs_dleg (y, npts, yorder, nyder, k1y, k2y, Mem$t[yb]) + + cptr = 0 + call aclr$t (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + xbptr = xb + call aclr$t (Mem$t[accum], npts) + do k = 1, xincr { + $if (datatype == r) + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + $else + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + $endif + xbptr = xbptr + npts + } + call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amul$t (Mem$t[xb], Mem$t[yb], zfit, npts) + call amulk$t (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1]) + $else + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1]) + $endif + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + $else + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + $endif + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end diff --git a/math/gsurfit/gs_fderd.x b/math/gsurfit/gs_fderd.x new file mode 100644 index 00000000..8f5cd628 --- /dev/null +++ b/math/gsurfit/gs_fderd.x @@ -0,0 +1,231 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> + +# GS_DERPOLY -- Evaluate the new polynomial derivative surface. + +procedure dgs_derpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, nxder, + nyder, k1x, k2x, k1y, k2y) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double y[npts] +double zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +double k1x, k2x # normalizing constants +double k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + + # calculate basis functions + call dgs_dpol (x, npts, xorder, nxder, k1x, k2x, Memd[xb]) + call dgs_dpol (y, npts, yorder, nyder, k1y, k2y, Memd[yb]) + + # accumulate the output vector + cptr = 0 + call aclrd (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrd (Memd[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpd (Memd[accum], Memd[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amuld (Memd[xb], Memd[yb], zfit, npts) + call amulkd (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + + call sfree (sp) +end + +# GS_DERCHEB -- Evaluate the new Chebyshev polynomial derivative surface. + +procedure dgs_dercheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, + nxder, nyder, k1x, k2x, k1y, k2y) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double y[npts] +double zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +double k1x, k2x # normalizing constants +double k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + + # calculate basis functions + call dgs_dcheb (x, npts, xorder, nxder, k1x, k2x, Memd[xb]) + call dgs_dcheb (y, npts, yorder, nyder, k1y, k2y, Memd[yb]) + + # accumulate thr output vector + cptr = 0 + call aclrd (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrd (Memd[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpd (Memd[accum], Memd[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amuld (Memd[xb], Memd[yb], zfit, npts) + call amulkd (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + + +# GS_DERLEG -- Evaluate the new Legendre polynomial derivative surface. + +procedure dgs_derleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, + nxder, nyder, k1x, k2x, k1y, k2y) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double y[npts] +double zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +double k1x, k2x # normalizing constants +double k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, accum, xbptr, ybptr + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + + # calculate basis functions + call dgs_dleg (x, npts, xorder, nxder, k1x, k2x, Memd[xb]) + call dgs_dleg (y, npts, yorder, nyder, k1y, k2y, Memd[yb]) + + cptr = 0 + call aclrd (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + xbptr = xb + call aclrd (Memd[accum], npts) + do k = 1, xincr { + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpd (Memd[accum], Memd[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amuld (Memd[xb], Memd[yb], zfit, npts) + call amulkd (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k+1]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end diff --git a/math/gsurfit/gs_fderr.x b/math/gsurfit/gs_fderr.x new file mode 100644 index 00000000..9d47dcb4 --- /dev/null +++ b/math/gsurfit/gs_fderr.x @@ -0,0 +1,228 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> + +# GS_DERPOLY -- Evaluate the new polynomial derivative surface. + +procedure rgs_derpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, nxder, + nyder, k1x, k2x, k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call rgs_dpol (x, npts, xorder, nxder, k1x, k2x, Memr[xb]) + call rgs_dpol (y, npts, yorder, nyder, k1y, k2y, Memr[yb]) + + # accumulate the output vector + cptr = 0 + call aclrr (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrr (Memr[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpr (Memr[accum], Memr[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amulr (Memr[xb], Memr[yb], zfit, npts) + call amulkr (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + + call sfree (sp) +end + +# GS_DERCHEB -- Evaluate the new Chebyshev polynomial derivative surface. + +procedure rgs_dercheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, + nxder, nyder, k1x, k2x, k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call rgs_dcheb (x, npts, xorder, nxder, k1x, k2x, Memr[xb]) + call rgs_dcheb (y, npts, yorder, nyder, k1y, k2y, Memr[yb]) + + # accumulate thr output vector + cptr = 0 + call aclrr (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrr (Memr[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpr (Memr[accum], Memr[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amulr (Memr[xb], Memr[yb], zfit, npts) + call amulkr (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + + +# GS_DERLEG -- Evaluate the new Legendre polynomial derivative surface. + +procedure rgs_derleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, + nxder, nyder, k1x, k2x, k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +int nxder,nyder # order of the derivatives in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, accum, xbptr, ybptr + +begin + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call rgs_dleg (x, npts, xorder, nxder, k1x, k2x, Memr[xb]) + call rgs_dleg (y, npts, yorder, nyder, k1y, k2y, Memr[yb]) + + cptr = 0 + call aclrr (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + xbptr = xb + call aclrr (Memr[accum], npts) + do k = 1, xincr { + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpr (Memr[accum], Memr[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + call amulr (Memr[xb], Memr[yb], zfit, npts) + call amulkr (zfit, coeff[1], zfit, npts) + xbptr = xb + npts + do k = 1, xorder - 1 { + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k+1]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end diff --git a/math/gsurfit/gs_feval.gx b/math/gsurfit/gs_feval.gx new file mode 100644 index 00000000..e28ad46d --- /dev/null +++ b/math/gsurfit/gs_feval.gx @@ -0,0 +1,332 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> + +# GS_EVPOLY -- Procedure to evluate the polynomials + +procedure $tgs_evpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, + k2x, k1y, k2y) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL y[npts] +PIXEL zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +PIXEL k1x, k2x # normalizing constants +PIXEL k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovk$t (coeff[1], zfit, npts) + return + } + + # fit first order in x and y + if (xorder == 2 && yorder == 1) { + call altm$t (x, zfit, npts, coeff[2], coeff[1]) + return + } + if (yorder == 2 && xorder == 1) { + call altm$t (x, zfit, npts, coeff[2], coeff[1]) + return + } + if (xorder == 2 && yorder == 2 && xterms == NO) { + do i = 1, npts + zfit[i] = coeff[1] + x[i] * coeff[2] + y[i] * coeff[3] + return + } + + # allocate temporary space for the basis functions + call smark (sp) + $if (datatype == r) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + $else + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + $endif + + # calculate basis functions + call $tgs_bpol (x, npts, xorder, k1x, k2x, Mem$t[xb]) + call $tgs_bpol (y, npts, yorder, k1y, k2y, Mem$t[yb]) + + # accumulate the output vector + cptr = 0 + call aclr$t (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclr$t (Mem$t[accum], npts) + xbptr = xb + do k = 1, xincr { + $if (datatype == r) + call awsu$t (Mem$t[accum], Mem$t[xbptr], Mem$t[accum], npts, + 1.0, coeff[cptr+k]) + $else + call awsu$t (Mem$t[accum], Mem$t[xbptr], Mem$t[accum], npts, + 1.0d0, coeff[cptr+k]) + $endif + xbptr = xbptr + npts + } + call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + $if (datatype == r) + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k]) + $else + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k]) + $endif + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + $else + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + $endif + ybptr = ybptr + npts + } + } + + + call sfree (sp) +end + +# GS_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure $tgs_evcheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, + k2x, k1y, k2y) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL y[npts] +PIXEL zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +PIXEL k1x, k2x # normalizing constants +PIXEL k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovk$t (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + $if (datatype == r) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + $else + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + $endif + + # calculate basis functions + call $tgs_bcheb (x, npts, xorder, k1x, k2x, Mem$t[xb]) + call $tgs_bcheb (y, npts, yorder, k1y, k2y, Mem$t[yb]) + + # accumulate thr output vector + cptr = 0 + call aclr$t (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclr$t (Mem$t[accum], npts) + xbptr = xb + do k = 1, xincr { + $if (datatype == r) + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + $else + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + $endif + xbptr = xbptr + npts + } + call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + $if (datatype == r) + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k]) + $else + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k]) + $endif + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + $else + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + $else + $endif + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + + +# GS_EVLEG -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure $tgs_evleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, k2x, + k1y, k2y) + +PIXEL coeff[ARB] # 1D array of coefficients +PIXEL x[npts] # x values of points to be evaluated +PIXEL y[npts] +PIXEL zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +PIXEL k1x, k2x # normalizing constants +PIXEL k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, accum, xbptr, ybptr + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovk$t (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + $if (datatype == r) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + $else + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + $endif + + # calculate basis functions + call $tgs_bleg (x, npts, xorder, k1x, k2x, Mem$t[xb]) + call $tgs_bleg (y, npts, yorder, k1y, k2y, Mem$t[yb]) + + cptr = 0 + call aclr$t (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + xbptr = xb + call aclr$t (Mem$t[accum], npts) + do k = 1, xincr { + $if (datatype == r) + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + $else + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + $endif + xbptr = xbptr + npts + } + call gs_asumvp$t (Mem$t[accum], Mem$t[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + $if (datatype == r) + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k]) + $else + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k]) + $endif + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + $if (datatype == r) + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + $else + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + $endif + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + +# GS_ASUMVP -- Procedure to add the product of two vectors to another vector + +procedure gs_asumvp$t (a, b, c, d, npts) + +PIXEL a[ARB] # first input vector +PIXEL b[ARB] # second input vector +PIXEL c[ARB] # third vector +PIXEL d[ARB] # output vector +int npts # number of points + +int i + +begin + do i = 1, npts + d[i] = c[i] + a[i] * b[i] +end diff --git a/math/gsurfit/gs_fevald.x b/math/gsurfit/gs_fevald.x new file mode 100644 index 00000000..68265e9c --- /dev/null +++ b/math/gsurfit/gs_fevald.x @@ -0,0 +1,274 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> + +# GS_EVPOLY -- Procedure to evluate the polynomials + +procedure dgs_evpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, + k2x, k1y, k2y) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double y[npts] +double zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +double k1x, k2x # normalizing constants +double k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkd (coeff[1], zfit, npts) + return + } + + # fit first order in x and y + if (xorder == 2 && yorder == 1) { + call altmd (x, zfit, npts, coeff[2], coeff[1]) + return + } + if (yorder == 2 && xorder == 1) { + call altmd (x, zfit, npts, coeff[2], coeff[1]) + return + } + if (xorder == 2 && yorder == 2 && xterms == NO) { + do i = 1, npts + zfit[i] = coeff[1] + x[i] * coeff[2] + y[i] * coeff[3] + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + + # calculate basis functions + call dgs_bpol (x, npts, xorder, k1x, k2x, Memd[xb]) + call dgs_bpol (y, npts, yorder, k1y, k2y, Memd[yb]) + + # accumulate the output vector + cptr = 0 + call aclrd (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrd (Memd[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpd (Memd[accum], Memd[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + + call sfree (sp) +end + +# GS_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure dgs_evcheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, + k2x, k1y, k2y) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double y[npts] +double zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +double k1x, k2x # normalizing constants +double k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkd (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + + # calculate basis functions + call dgs_bcheb (x, npts, xorder, k1x, k2x, Memd[xb]) + call dgs_bcheb (y, npts, yorder, k1y, k2y, Memd[yb]) + + # accumulate thr output vector + cptr = 0 + call aclrd (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrd (Memd[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpd (Memd[accum], Memd[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + + +# GS_EVLEG -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure dgs_evleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, k2x, + k1y, k2y) + +double coeff[ARB] # 1D array of coefficients +double x[npts] # x values of points to be evaluated +double y[npts] +double zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +double k1x, k2x # normalizing constants +double k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, accum, xbptr, ybptr + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkd (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_DOUBLE) + call salloc (yb, yorder * npts, TY_DOUBLE) + call salloc (accum, npts, TY_DOUBLE) + + # calculate basis functions + call dgs_bleg (x, npts, xorder, k1x, k2x, Memd[xb]) + call dgs_bleg (y, npts, yorder, k1y, k2y, Memd[yb]) + + cptr = 0 + call aclrd (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + xbptr = xb + call aclrd (Memd[accum], npts) + do k = 1, xincr { + call awsud (Memd[accum], Memd[xbptr], Memd[accum], npts, + 1.0d0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpd (Memd[accum], Memd[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + call awsud (zfit, Memd[xbptr], zfit, npts, 1.0d0, coeff[k]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsud (zfit, Memd[ybptr], zfit, npts, 1.0d0, + coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + +# GS_ASUMVP -- Procedure to add the product of two vectors to another vector + +procedure gs_asumvpd (a, b, c, d, npts) + +double a[ARB] # first input vector +double b[ARB] # second input vector +double c[ARB] # third vector +double d[ARB] # output vector +int npts # number of points + +int i + +begin + do i = 1, npts + d[i] = c[i] + a[i] * b[i] +end diff --git a/math/gsurfit/gs_fevalr.x b/math/gsurfit/gs_fevalr.x new file mode 100644 index 00000000..7988f66a --- /dev/null +++ b/math/gsurfit/gs_fevalr.x @@ -0,0 +1,271 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> + +# GS_EVPOLY -- Procedure to evluate the polynomials + +procedure rgs_evpoly (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, + k2x, k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkr (coeff[1], zfit, npts) + return + } + + # fit first order in x and y + if (xorder == 2 && yorder == 1) { + call altmr (x, zfit, npts, coeff[2], coeff[1]) + return + } + if (yorder == 2 && xorder == 1) { + call altmr (x, zfit, npts, coeff[2], coeff[1]) + return + } + if (xorder == 2 && yorder == 2 && xterms == NO) { + do i = 1, npts + zfit[i] = coeff[1] + x[i] * coeff[2] + y[i] * coeff[3] + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call rgs_bpol (x, npts, xorder, k1x, k2x, Memr[xb]) + call rgs_bpol (y, npts, yorder, k1y, k2y, Memr[yb]) + + # accumulate the output vector + cptr = 0 + call aclrr (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrr (Memr[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpr (Memr[accum], Memr[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + + call sfree (sp) +end + +# GS_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure rgs_evcheb (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, + k2x, k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, xbptr, ybptr, accum + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkr (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call rgs_bcheb (x, npts, xorder, k1x, k2x, Memr[xb]) + call rgs_bcheb (y, npts, yorder, k1y, k2y, Memr[yb]) + + # accumulate thr output vector + cptr = 0 + call aclrr (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + call aclrr (Memr[accum], npts) + xbptr = xb + do k = 1, xincr { + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpr (Memr[accum], Memr[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + + +# GS_EVLEG -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure rgs_evleg (coeff, x, y, zfit, npts, xterms, xorder, yorder, k1x, k2x, + k1y, k2y) + +real coeff[ARB] # 1D array of coefficients +real x[npts] # x values of points to be evaluated +real y[npts] +real zfit[npts] # the fitted points +int npts # number of points to be evaluated +int xterms # cross terms ? +int xorder,yorder # order of the polynomials in x and y +real k1x, k2x # normalizing constants +real k1y, k2y + +int i, k, cptr, maxorder, xincr +pointer sp, xb, yb, accum, xbptr, ybptr + +begin + # fit a constant + if (xorder == 1 && yorder == 1) { + call amovkr (coeff[1], zfit, npts) + return + } + + # allocate temporary space for the basis functions + call smark (sp) + call salloc (xb, xorder * npts, TY_REAL) + call salloc (yb, yorder * npts, TY_REAL) + call salloc (accum, npts, TY_REAL) + + # calculate basis functions + call rgs_bleg (x, npts, xorder, k1x, k2x, Memr[xb]) + call rgs_bleg (y, npts, yorder, k1y, k2y, Memr[yb]) + + cptr = 0 + call aclrr (zfit, npts) + if (xterms != GS_XNONE) { + maxorder = max (xorder + 1, yorder + 1) + xincr = xorder + ybptr = yb + do i = 1, yorder { + xbptr = xb + call aclrr (Memr[accum], npts) + do k = 1, xincr { + call awsur (Memr[accum], Memr[xbptr], Memr[accum], npts, + 1.0, coeff[cptr+k]) + xbptr = xbptr + npts + } + call gs_asumvpr (Memr[accum], Memr[ybptr], zfit, zfit, npts) + cptr = cptr + xincr + ybptr = ybptr + npts + switch (xterms) { + case GS_XHALF: + if ((i + xorder + 1) > maxorder) + xincr = xincr - 1 + default: + ; + } + } + } else { + xbptr = xb + do k = 1, xorder { + call awsur (zfit, Memr[xbptr], zfit, npts, 1.0, coeff[k]) + xbptr = xbptr + npts + } + ybptr = yb + npts + do k = 1, yorder - 1 { + call awsur (zfit, Memr[ybptr], zfit, npts, 1.0, coeff[xorder+k]) + ybptr = ybptr + npts + } + } + + # free temporary space + call sfree (sp) +end + +# GS_ASUMVP -- Procedure to add the product of two vectors to another vector + +procedure gs_asumvpr (a, b, c, d, npts) + +real a[ARB] # first input vector +real b[ARB] # second input vector +real c[ARB] # third vector +real d[ARB] # output vector +int npts # number of points + +int i + +begin + do i = 1, npts + d[i] = c[i] + a[i] * b[i] +end diff --git a/math/gsurfit/gsaccum.gx b/math/gsurfit/gsaccum.gx new file mode 100644 index 00000000..f9958263 --- /dev/null +++ b/math/gsurfit/gsaccum.gx @@ -0,0 +1,193 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSACCUM -- Procedure to add a point to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +$if (datatype == r) +procedure gsaccum (sf, x, y, z, w, wtflag) +$else +procedure dgsaccum (sf, x, y, z, w, wtflag) +$endif + +pointer sf # surface descriptor +PIXEL x # x value +PIXEL y # y value +PIXEL z # z value +PIXEL w # weight +int wtflag # type of weighting + +bool refsub +int ii, j, k, l +int maxorder, xorder, xxorder, xindex, yindex, ntimes +pointer sp, vzptr, mzptr, xbptr, ybptr +PIXEL x1, y1, z1, byw, bw + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) + 1 + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + $if (datatype == r) + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + $else + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + $endif + + } + + # calculate weight + switch (wtflag) { + case WTS_UNIFORM: + $if (datatype == r) + w = 1. + $else + w = 1.0d0 + $endif + case WTS_USER: + # user supplied weights + default: + $if (datatype == r) + w = 1. + $else + w = 1.0d0 + $endif + } + + # allocate space for the basis functions + call smark (sp) + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_PIXEL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_PIXEL) + + # subtract reference value + refsub = !(IS_INDEF(GS_XREF(sf)) || IS_INDEF(GS_YREF(sf)) || + IS_INDEF(GS_ZREF(sf))) + if (refsub) { + x1 = x - GS_XREF(sf) + y1 = y - GS_YREF(sf) + z1 = z - GS_ZREF(sf) + } else { + x1 = x + y1 = y + z1 = z + } + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call $tgs_b1leg (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_b1leg (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call $tgs_b1cheb (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_b1cheb (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call $tgs_b1pol (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_b1pol (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSACCUM: Unkown surface type.") + } + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) - 1 + xbptr = GS_XBASIS(sf) - 1 + ybptr = GS_YBASIS(sf) - 1 + + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ntimes = 0 + + do l = 1, GS_YORDER(sf) { + byw = w * YBASIS(ybptr+l) + do k = 1, xorder { + bw = byw * XBASIS(xbptr+k) + VECTOR(vzptr+k) = VECTOR(vzptr+k) + bw * z + ii = 1 + xindex = k + yindex = l + xxorder = xorder + do j = k + ntimes, GS_NCOEFF(sf) { + MATRIX(mzptr+ii) = MATRIX(mzptr+ii) + bw * + XBASIS(xbptr+xindex) * YBASIS(ybptr+yindex) + if (mod (xindex, xxorder) == 0) { + xindex = 1 + yindex = yindex + 1 + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((yindex + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else + xindex = xindex + 1 + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + default: + call error (0, "GSACCUM: Unknown surface type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsaccumd.x b/math/gsurfit/gsaccumd.x new file mode 100644 index 00000000..71ed9f90 --- /dev/null +++ b/math/gsurfit/gsaccumd.x @@ -0,0 +1,165 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSACCUM -- Procedure to add a point to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +procedure dgsaccum (sf, x, y, z, w, wtflag) + +pointer sf # surface descriptor +double x # x value +double y # y value +double z # z value +double w # weight +int wtflag # type of weighting + +bool refsub +int ii, j, k, l +int maxorder, xorder, xxorder, xindex, yindex, ntimes +pointer sp, vzptr, mzptr, xbptr, ybptr +double x1, y1, z1, byw, bw + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) + 1 + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + + } + + # calculate weight + switch (wtflag) { + case WTS_UNIFORM: + w = 1.0d0 + case WTS_USER: + # user supplied weights + default: + w = 1.0d0 + } + + # allocate space for the basis functions + call smark (sp) + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + + # subtract reference value + refsub = !(IS_INDEFD(GS_XREF(sf)) || IS_INDEFD(GS_YREF(sf)) || + IS_INDEFD(GS_ZREF(sf))) + if (refsub) { + x1 = x - GS_XREF(sf) + y1 = y - GS_YREF(sf) + z1 = z - GS_ZREF(sf) + } else { + x1 = x + y1 = y + z1 = z + } + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call dgs_b1leg (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_b1leg (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call dgs_b1cheb (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_b1cheb (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call dgs_b1pol (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_b1pol (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSACCUM: Unkown surface type.") + } + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) - 1 + xbptr = GS_XBASIS(sf) - 1 + ybptr = GS_YBASIS(sf) - 1 + + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ntimes = 0 + + do l = 1, GS_YORDER(sf) { + byw = w * YBASIS(ybptr+l) + do k = 1, xorder { + bw = byw * XBASIS(xbptr+k) + VECTOR(vzptr+k) = VECTOR(vzptr+k) + bw * z + ii = 1 + xindex = k + yindex = l + xxorder = xorder + do j = k + ntimes, GS_NCOEFF(sf) { + MATRIX(mzptr+ii) = MATRIX(mzptr+ii) + bw * + XBASIS(xbptr+xindex) * YBASIS(ybptr+yindex) + if (mod (xindex, xxorder) == 0) { + xindex = 1 + yindex = yindex + 1 + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((yindex + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else + xindex = xindex + 1 + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + default: + call error (0, "GSACCUM: Unknown surface type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsaccumr.x b/math/gsurfit/gsaccumr.x new file mode 100644 index 00000000..4e973cfa --- /dev/null +++ b/math/gsurfit/gsaccumr.x @@ -0,0 +1,165 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSACCUM -- Procedure to add a point to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +procedure gsaccum (sf, x, y, z, w, wtflag) + +pointer sf # surface descriptor +real x # x value +real y # y value +real z # z value +real w # weight +int wtflag # type of weighting + +bool refsub +int ii, j, k, l +int maxorder, xorder, xxorder, xindex, yindex, ntimes +pointer sp, vzptr, mzptr, xbptr, ybptr +real x1, y1, z1, byw, bw + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) + 1 + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + + } + + # calculate weight + switch (wtflag) { + case WTS_UNIFORM: + w = 1. + case WTS_USER: + # user supplied weights + default: + w = 1. + } + + # allocate space for the basis functions + call smark (sp) + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + + # subtract reference value + refsub = !(IS_INDEFR(GS_XREF(sf)) || IS_INDEFR(GS_YREF(sf)) || + IS_INDEFR(GS_ZREF(sf))) + if (refsub) { + x1 = x - GS_XREF(sf) + y1 = y - GS_YREF(sf) + z1 = z - GS_ZREF(sf) + } else { + x1 = x + y1 = y + z1 = z + } + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call rgs_b1leg (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_b1leg (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call rgs_b1cheb (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_b1cheb (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call rgs_b1pol (x1, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_b1pol (y1, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSACCUM: Unkown surface type.") + } + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) - 1 + xbptr = GS_XBASIS(sf) - 1 + ybptr = GS_YBASIS(sf) - 1 + + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ntimes = 0 + + do l = 1, GS_YORDER(sf) { + byw = w * YBASIS(ybptr+l) + do k = 1, xorder { + bw = byw * XBASIS(xbptr+k) + VECTOR(vzptr+k) = VECTOR(vzptr+k) + bw * z + ii = 1 + xindex = k + yindex = l + xxorder = xorder + do j = k + ntimes, GS_NCOEFF(sf) { + MATRIX(mzptr+ii) = MATRIX(mzptr+ii) + bw * + XBASIS(xbptr+xindex) * YBASIS(ybptr+yindex) + if (mod (xindex, xxorder) == 0) { + xindex = 1 + yindex = yindex + 1 + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((yindex + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else + xindex = xindex + 1 + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + default: + call error (0, "GSACCUM: Unknown surface type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsacpts.gx b/math/gsurfit/gsacpts.gx new file mode 100644 index 00000000..59a8ae72 --- /dev/null +++ b/math/gsurfit/gsacpts.gx @@ -0,0 +1,257 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSACPTS -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +$if (datatype == r) +procedure gsacpts (sf, x, y, z, w, npts, wtflag) +$else +procedure dgsacpts (sf, x, y, z, w, npts, wtflag) +$endif + +pointer sf # surface descriptor +PIXEL x[npts] # array of x values +PIXEL y[npts] # array of y values +PIXEL z[npts] # data array +PIXEL w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting + +bool refsub +int i, ii, j, jj, k, l, ll +int maxorder, xorder, xxorder, ntimes +pointer sp, vzptr, vindex, mzptr, mindex, bxptr, bbxptr, byptr, bbyptr +pointer x1, y1, z1, byw, bw + +PIXEL adot$t() + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) + npts + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + $if (datatype == r) + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + $else + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + $endif + } + + # calculate weights + switch (wtflag) { + case WTS_UNIFORM: + $if (datatype == r) + call amovkr (1., w, npts) + $else + call amovkd (1.0d0, w, npts) + $endif + case WTS_SPACING: + if (npts == 1) + $if (datatype == r) + w[1] = 1. + $else + w[1] = 1.0d0 + $endif + else + w[1] = abs (x[2] - x[1]) + do i = 2, npts - 1 + w[i] = abs (x[i+1] - x[i-1]) + if (npts == 1) + $if (datatype == r) + w[npts] = 1. + $else + w[npts] = 1.0d0 + $endif + else + w[npts] = abs (x[npts] - x[npts-1]) + case WTS_USER: + # user supplied weights + default: + $if (datatype == r) + call amovkr (1., w, npts) + $else + call amovkd (1.0d0, w, npts) + $endif + } + + + # allocate space for the basis functions + call smark (sp) + call salloc (GS_XBASIS(sf), npts * GS_XORDER(sf), TY_PIXEL) + call salloc (GS_YBASIS(sf), npts * GS_YORDER(sf), TY_PIXEL) + + # subtract reference value + refsub = !(IS_INDEF(GS_XREF(sf)) || IS_INDEF(GS_YREF(sf)) || + IS_INDEF(GS_ZREF(sf))) + if (refsub) { + call salloc (x1, npts, TY_PIXEL) + call salloc (y1, npts, TY_PIXEL) + call salloc (z1, npts, TY_PIXEL) + call asubk$t (x, GS_XREF(sf), Mem$t[x1], npts) + call asubk$t (y, GS_YREF(sf), Mem$t[y1], npts) + call asubk$t (z, GS_ZREF(sf), Mem$t[z1], npts) + } + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + if (refsub) { + call $tgs_bleg (Mem$t[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bleg (Mem$t[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call $tgs_bleg (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bleg (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + case GS_CHEBYSHEV: + if (refsub) { + call $tgs_bcheb (Mem$t[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bcheb (Mem$t[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call $tgs_bcheb (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bcheb (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + case GS_POLYNOMIAL: + if (refsub) { + call $tgs_bpol (Mem$t[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bpol (Mem$t[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call $tgs_bpol (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bpol (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + default: + call error (0, "GSACCUM: Illegal curve type.") + } + + # allocate temporary storage space for matrix accumulation + $if (datatype == r) + call salloc (byw, npts, TY_REAL) + call salloc (bw, npts, TY_REAL) + $else + call salloc (byw, npts, TY_DOUBLE) + call salloc (bw, npts, TY_DOUBLE) + $endif + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) + bxptr = GS_XBASIS(sf) + byptr = GS_YBASIS(sf) + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ntimes = 0 + + do l = 1, GS_YORDER(sf) { + + call amul$t (w, YBASIS(byptr), Mem$t[byw], npts) + bxptr = GS_XBASIS(sf) + do k = 1, xorder { + call amul$t (Mem$t[byw], XBASIS(bxptr), Mem$t[bw], npts) + vindex = vzptr + k + VECTOR(vindex) = VECTOR(vindex) + adot$t (Mem$t[bw], z, + npts) + bbyptr = byptr + bbxptr = bxptr + xxorder = xorder + jj = k + ll = l + ii = 0 + do j = k + ntimes, GS_NCOEFF(sf) { + mindex = mzptr + ii + do i = 1, npts + MATRIX(mindex) = MATRIX(mindex) + Mem$t[bw+i-1] * + XBASIS(bbxptr+i-1) * YBASIS(bbyptr+i-1) + if (mod (jj, xxorder) == 0) { + jj = 1 + ll = ll + 1 + bbxptr = GS_XBASIS(sf) + bbyptr = bbyptr + npts + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((ll + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else { + jj = jj + 1 + bbxptr = bbxptr + npts + } + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + bxptr = bxptr + npts + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + byptr = byptr + npts + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsacptsd.x b/math/gsurfit/gsacptsd.x new file mode 100644 index 00000000..0b0b1695 --- /dev/null +++ b/math/gsurfit/gsacptsd.x @@ -0,0 +1,216 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSACPTS -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +procedure dgsacpts (sf, x, y, z, w, npts, wtflag) + +pointer sf # surface descriptor +double x[npts] # array of x values +double y[npts] # array of y values +double z[npts] # data array +double w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting + +bool refsub +int i, ii, j, jj, k, l, ll +int maxorder, xorder, xxorder, ntimes +pointer sp, vzptr, vindex, mzptr, mindex, bxptr, bbxptr, byptr, bbyptr +pointer x1, y1, z1, byw, bw + +double adotd() + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) + npts + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + } + + # calculate weights + switch (wtflag) { + case WTS_UNIFORM: + call amovkd (1.0d0, w, npts) + case WTS_SPACING: + if (npts == 1) + w[1] = 1.0d0 + else + w[1] = abs (x[2] - x[1]) + do i = 2, npts - 1 + w[i] = abs (x[i+1] - x[i-1]) + if (npts == 1) + w[npts] = 1.0d0 + else + w[npts] = abs (x[npts] - x[npts-1]) + case WTS_USER: + # user supplied weights + default: + call amovkd (1.0d0, w, npts) + } + + + # allocate space for the basis functions + call smark (sp) + call salloc (GS_XBASIS(sf), npts * GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), npts * GS_YORDER(sf), TY_DOUBLE) + + # subtract reference value + refsub = !(IS_INDEFD(GS_XREF(sf)) || IS_INDEFD(GS_YREF(sf)) || + IS_INDEFD(GS_ZREF(sf))) + if (refsub) { + call salloc (x1, npts, TY_DOUBLE) + call salloc (y1, npts, TY_DOUBLE) + call salloc (z1, npts, TY_DOUBLE) + call asubkd (x, GS_XREF(sf), Memd[x1], npts) + call asubkd (y, GS_YREF(sf), Memd[y1], npts) + call asubkd (z, GS_ZREF(sf), Memd[z1], npts) + } + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + if (refsub) { + call dgs_bleg (Memd[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bleg (Memd[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call dgs_bleg (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bleg (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + case GS_CHEBYSHEV: + if (refsub) { + call dgs_bcheb (Memd[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bcheb (Memd[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call dgs_bcheb (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bcheb (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + case GS_POLYNOMIAL: + if (refsub) { + call dgs_bpol (Memd[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bpol (Memd[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call dgs_bpol (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bpol (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + default: + call error (0, "GSACCUM: Illegal curve type.") + } + + # allocate temporary storage space for matrix accumulation + call salloc (byw, npts, TY_DOUBLE) + call salloc (bw, npts, TY_DOUBLE) + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) + bxptr = GS_XBASIS(sf) + byptr = GS_YBASIS(sf) + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ntimes = 0 + + do l = 1, GS_YORDER(sf) { + + call amuld (w, YBASIS(byptr), Memd[byw], npts) + bxptr = GS_XBASIS(sf) + do k = 1, xorder { + call amuld (Memd[byw], XBASIS(bxptr), Memd[bw], npts) + vindex = vzptr + k + VECTOR(vindex) = VECTOR(vindex) + adotd (Memd[bw], z, + npts) + bbyptr = byptr + bbxptr = bxptr + xxorder = xorder + jj = k + ll = l + ii = 0 + do j = k + ntimes, GS_NCOEFF(sf) { + mindex = mzptr + ii + do i = 1, npts + MATRIX(mindex) = MATRIX(mindex) + Memd[bw+i-1] * + XBASIS(bbxptr+i-1) * YBASIS(bbyptr+i-1) + if (mod (jj, xxorder) == 0) { + jj = 1 + ll = ll + 1 + bbxptr = GS_XBASIS(sf) + bbyptr = bbyptr + npts + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((ll + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else { + jj = jj + 1 + bbxptr = bbxptr + npts + } + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + bxptr = bxptr + npts + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + byptr = byptr + npts + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsacptsr.x b/math/gsurfit/gsacptsr.x new file mode 100644 index 00000000..705bb8d7 --- /dev/null +++ b/math/gsurfit/gsacptsr.x @@ -0,0 +1,216 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSACPTS -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +procedure gsacpts (sf, x, y, z, w, npts, wtflag) + +pointer sf # surface descriptor +real x[npts] # array of x values +real y[npts] # array of y values +real z[npts] # data array +real w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting + +bool refsub +int i, ii, j, jj, k, l, ll +int maxorder, xorder, xxorder, ntimes +pointer sp, vzptr, vindex, mzptr, mindex, bxptr, bbxptr, byptr, bbyptr +pointer x1, y1, z1, byw, bw + +real adotr() + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) + npts + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + } + + # calculate weights + switch (wtflag) { + case WTS_UNIFORM: + call amovkr (1., w, npts) + case WTS_SPACING: + if (npts == 1) + w[1] = 1. + else + w[1] = abs (x[2] - x[1]) + do i = 2, npts - 1 + w[i] = abs (x[i+1] - x[i-1]) + if (npts == 1) + w[npts] = 1. + else + w[npts] = abs (x[npts] - x[npts-1]) + case WTS_USER: + # user supplied weights + default: + call amovkr (1., w, npts) + } + + + # allocate space for the basis functions + call smark (sp) + call salloc (GS_XBASIS(sf), npts * GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), npts * GS_YORDER(sf), TY_REAL) + + # subtract reference value + refsub = !(IS_INDEFR(GS_XREF(sf)) || IS_INDEFR(GS_YREF(sf)) || + IS_INDEFR(GS_ZREF(sf))) + if (refsub) { + call salloc (x1, npts, TY_REAL) + call salloc (y1, npts, TY_REAL) + call salloc (z1, npts, TY_REAL) + call asubkr (x, GS_XREF(sf), Memr[x1], npts) + call asubkr (y, GS_YREF(sf), Memr[y1], npts) + call asubkr (z, GS_ZREF(sf), Memr[z1], npts) + } + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + if (refsub) { + call rgs_bleg (Memr[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bleg (Memr[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call rgs_bleg (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bleg (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + case GS_CHEBYSHEV: + if (refsub) { + call rgs_bcheb (Memr[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bcheb (Memr[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call rgs_bcheb (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bcheb (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + case GS_POLYNOMIAL: + if (refsub) { + call rgs_bpol (Memr[x1], npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bpol (Memr[y1], npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } else { + call rgs_bpol (x, npts, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bpol (y, npts, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + } + default: + call error (0, "GSACCUM: Illegal curve type.") + } + + # allocate temporary storage space for matrix accumulation + call salloc (byw, npts, TY_REAL) + call salloc (bw, npts, TY_REAL) + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) + bxptr = GS_XBASIS(sf) + byptr = GS_YBASIS(sf) + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ntimes = 0 + + do l = 1, GS_YORDER(sf) { + + call amulr (w, YBASIS(byptr), Memr[byw], npts) + bxptr = GS_XBASIS(sf) + do k = 1, xorder { + call amulr (Memr[byw], XBASIS(bxptr), Memr[bw], npts) + vindex = vzptr + k + VECTOR(vindex) = VECTOR(vindex) + adotr (Memr[bw], z, + npts) + bbyptr = byptr + bbxptr = bxptr + xxorder = xorder + jj = k + ll = l + ii = 0 + do j = k + ntimes, GS_NCOEFF(sf) { + mindex = mzptr + ii + do i = 1, npts + MATRIX(mindex) = MATRIX(mindex) + Memr[bw+i-1] * + XBASIS(bbxptr+i-1) * YBASIS(bbyptr+i-1) + if (mod (jj, xxorder) == 0) { + jj = 1 + ll = ll + 1 + bbxptr = GS_XBASIS(sf) + bbyptr = bbyptr + npts + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((ll + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else { + jj = jj + 1 + bbxptr = bbxptr + npts + } + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + bxptr = bxptr + npts + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + byptr = byptr + npts + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsadd.gx b/math/gsurfit/gsadd.gx new file mode 100644 index 00000000..516f1b1f --- /dev/null +++ b/math/gsurfit/gsadd.gx @@ -0,0 +1,181 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSADD -- Procedure to add the fits from two surfaces together. The surfaces +# must be the same type and the fit must cover the same range of data in x +# and y. This is a special function. + +$if (datatype == r) +procedure gsadd (sf1, sf2, sf3) +$else +procedure dgsadd (sf1, sf2, sf3) +$endif + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +int i, order, nmove1, nmove2, nmove3, maxorder1, maxorder2, maxorder3 +pointer ptr1, ptr2, ptr3 +bool fpequal$t() + +begin + # test for NULL surface + if (sf1 == NULL && sf2 == NULL) { + sf3 = NULL + return + } else if (sf1 == NULL) { + $if (datatype == r) + call gscopy (sf2, sf3) + $else + call dgscopy (sf2, sf3) + $endif + return + } else if (sf2 == NULL) { + $if (datatype == r) + call gscopy (sf1, sf3) + $else + call dgscopy (sf1, sf3) + $endif + return + } + + # test that function type is the same + if (GS_TYPE(sf1) != GS_TYPE(sf2)) + call error (0, "GSADD: Incompatable surface types.") + + # test that mins and maxs are the same + if (! fpequal$t (GS_XMIN(sf1), GS_XMIN(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequal$t (GS_XMAX(sf1), GS_XMAX(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequal$t (GS_YMIN(sf1), GS_YMIN(sf2))) + call error (0, "GSADD: Y ranges not identical.") + if (! fpequal$t (GS_YMAX(sf1), GS_YMAX(sf2))) + call error (0, "GSADD: Y ranges not identical.") + + # allocate space for the pointer + call calloc (sf3, LEN_GSSTRUCT, TY_STRUCT) + + # copy parameters + GS_TYPE(sf3) = GS_TYPE(sf1) + + switch (GS_TYPE(sf3)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf3) = max (GS_NXCOEFF(sf1), GS_NXCOEFF(sf2)) + GS_XORDER(sf3) = max (GS_XORDER(sf1), GS_XORDER(sf2)) + GS_XMIN(sf3) = GS_XMIN(sf1) + GS_XMAX(sf3) = GS_XMAX(sf1) + GS_XRANGE(sf3) = GS_XRANGE(sf1) + GS_XMAXMIN(sf3) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf3) = max (GS_NYCOEFF(sf1), GS_NYCOEFF(sf2)) + GS_YORDER(sf3) = max (GS_YORDER(sf1), GS_YORDER(sf2)) + GS_YMIN(sf3) = GS_YMIN(sf1) + GS_YMAX(sf3) = GS_YMAX(sf1) + GS_YRANGE(sf3) = GS_YRANGE(sf1) + GS_YMAXMIN(sf3) = GS_YMAXMIN(sf1) + if (GS_XTERMS(sf1) == GS_XTERMS(sf2)) + GS_XTERMS(sf3) = GS_XTERMS(sf1) + else if (GS_XTERMS(sf1) == GS_XFULL || GS_XTERMS(sf2) == GS_XFULL) + GS_XTERMS(sf3) = GS_XFULL + else + GS_XTERMS(sf3) = GS_XHALF + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) + GS_NYCOEFF(sf3) - 1 + case GS_XHALF: + order = min (GS_XORDER(sf3), GS_YORDER(sf3)) + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) - order * + (order - 1) / 2 + default: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) + } + default: + call error (0, "GSADD: Unknown curve type.") + } + + # set pointers to NULL + GS_XBASIS(sf3) = NULL + GS_YBASIS(sf3) = NULL + GS_MATRIX(sf3) = NULL + GS_CHOFAC(sf3) = NULL + GS_VECTOR(sf3) = NULL + GS_COEFF(sf3) = NULL + GS_WZ(sf3) = NULL + + # calculate the coefficients + $if (datatype == r) + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_REAL) + $else + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_DOUBLE) + $endif + + # set up line counters. + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + maxorder3 = max (GS_XORDER(sf3) + 1, GS_YORDER(sf3) + 1) + + # add in the first surface. + ptr1 = GS_COEFF(sf1) + ptr3 = GS_COEFF(sf3) + nmove1 = GS_NXCOEFF(sf1) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf1) { + call amov$t (COEFF(ptr1), COEFF(ptr3), nmove1) + ptr1 = ptr1 + nmove1 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf1)) { + case GS_XNONE: + nmove1 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf1) + 1) > maxorder1) + nmove1 = nmove1 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } + + # add in the second surface. + ptr2 = GS_COEFF(sf2) + ptr3 = GS_COEFF(sf3) + nmove2 = GS_NXCOEFF(sf2) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf2) { + call aadd$t (COEFF(ptr3), COEFF(ptr2), COEFF(ptr3), nmove2) + ptr2 = ptr2 + nmove2 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + nmove2 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf2) + 1) > maxorder2) + nmove2 = nmove2 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } +end diff --git a/math/gsurfit/gsaddd.x b/math/gsurfit/gsaddd.x new file mode 100644 index 00000000..f637d08a --- /dev/null +++ b/math/gsurfit/gsaddd.x @@ -0,0 +1,161 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSADD -- Procedure to add the fits from two surfaces together. The surfaces +# must be the same type and the fit must cover the same range of data in x +# and y. This is a special function. + +procedure dgsadd (sf1, sf2, sf3) + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +int i, order, nmove1, nmove2, nmove3, maxorder1, maxorder2, maxorder3 +pointer ptr1, ptr2, ptr3 +bool fpequald() + +begin + # test for NULL surface + if (sf1 == NULL && sf2 == NULL) { + sf3 = NULL + return + } else if (sf1 == NULL) { + call dgscopy (sf2, sf3) + return + } else if (sf2 == NULL) { + call dgscopy (sf1, sf3) + return + } + + # test that function type is the same + if (GS_TYPE(sf1) != GS_TYPE(sf2)) + call error (0, "GSADD: Incompatable surface types.") + + # test that mins and maxs are the same + if (! fpequald (GS_XMIN(sf1), GS_XMIN(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequald (GS_XMAX(sf1), GS_XMAX(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequald (GS_YMIN(sf1), GS_YMIN(sf2))) + call error (0, "GSADD: Y ranges not identical.") + if (! fpequald (GS_YMAX(sf1), GS_YMAX(sf2))) + call error (0, "GSADD: Y ranges not identical.") + + # allocate space for the pointer + call calloc (sf3, LEN_GSSTRUCT, TY_STRUCT) + + # copy parameters + GS_TYPE(sf3) = GS_TYPE(sf1) + + switch (GS_TYPE(sf3)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf3) = max (GS_NXCOEFF(sf1), GS_NXCOEFF(sf2)) + GS_XORDER(sf3) = max (GS_XORDER(sf1), GS_XORDER(sf2)) + GS_XMIN(sf3) = GS_XMIN(sf1) + GS_XMAX(sf3) = GS_XMAX(sf1) + GS_XRANGE(sf3) = GS_XRANGE(sf1) + GS_XMAXMIN(sf3) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf3) = max (GS_NYCOEFF(sf1), GS_NYCOEFF(sf2)) + GS_YORDER(sf3) = max (GS_YORDER(sf1), GS_YORDER(sf2)) + GS_YMIN(sf3) = GS_YMIN(sf1) + GS_YMAX(sf3) = GS_YMAX(sf1) + GS_YRANGE(sf3) = GS_YRANGE(sf1) + GS_YMAXMIN(sf3) = GS_YMAXMIN(sf1) + if (GS_XTERMS(sf1) == GS_XTERMS(sf2)) + GS_XTERMS(sf3) = GS_XTERMS(sf1) + else if (GS_XTERMS(sf1) == GS_XFULL || GS_XTERMS(sf2) == GS_XFULL) + GS_XTERMS(sf3) = GS_XFULL + else + GS_XTERMS(sf3) = GS_XHALF + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) + GS_NYCOEFF(sf3) - 1 + case GS_XHALF: + order = min (GS_XORDER(sf3), GS_YORDER(sf3)) + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) - order * + (order - 1) / 2 + default: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) + } + default: + call error (0, "GSADD: Unknown curve type.") + } + + # set pointers to NULL + GS_XBASIS(sf3) = NULL + GS_YBASIS(sf3) = NULL + GS_MATRIX(sf3) = NULL + GS_CHOFAC(sf3) = NULL + GS_VECTOR(sf3) = NULL + GS_COEFF(sf3) = NULL + GS_WZ(sf3) = NULL + + # calculate the coefficients + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_DOUBLE) + + # set up line counters. + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + maxorder3 = max (GS_XORDER(sf3) + 1, GS_YORDER(sf3) + 1) + + # add in the first surface. + ptr1 = GS_COEFF(sf1) + ptr3 = GS_COEFF(sf3) + nmove1 = GS_NXCOEFF(sf1) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf1) { + call amovd (COEFF(ptr1), COEFF(ptr3), nmove1) + ptr1 = ptr1 + nmove1 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf1)) { + case GS_XNONE: + nmove1 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf1) + 1) > maxorder1) + nmove1 = nmove1 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } + + # add in the second surface. + ptr2 = GS_COEFF(sf2) + ptr3 = GS_COEFF(sf3) + nmove2 = GS_NXCOEFF(sf2) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf2) { + call aaddd (COEFF(ptr3), COEFF(ptr2), COEFF(ptr3), nmove2) + ptr2 = ptr2 + nmove2 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + nmove2 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf2) + 1) > maxorder2) + nmove2 = nmove2 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } +end diff --git a/math/gsurfit/gsaddr.x b/math/gsurfit/gsaddr.x new file mode 100644 index 00000000..4df5ee48 --- /dev/null +++ b/math/gsurfit/gsaddr.x @@ -0,0 +1,161 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSADD -- Procedure to add the fits from two surfaces together. The surfaces +# must be the same type and the fit must cover the same range of data in x +# and y. This is a special function. + +procedure gsadd (sf1, sf2, sf3) + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +int i, order, nmove1, nmove2, nmove3, maxorder1, maxorder2, maxorder3 +pointer ptr1, ptr2, ptr3 +bool fpequalr() + +begin + # test for NULL surface + if (sf1 == NULL && sf2 == NULL) { + sf3 = NULL + return + } else if (sf1 == NULL) { + call gscopy (sf2, sf3) + return + } else if (sf2 == NULL) { + call gscopy (sf1, sf3) + return + } + + # test that function type is the same + if (GS_TYPE(sf1) != GS_TYPE(sf2)) + call error (0, "GSADD: Incompatable surface types.") + + # test that mins and maxs are the same + if (! fpequalr (GS_XMIN(sf1), GS_XMIN(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequalr (GS_XMAX(sf1), GS_XMAX(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequalr (GS_YMIN(sf1), GS_YMIN(sf2))) + call error (0, "GSADD: Y ranges not identical.") + if (! fpequalr (GS_YMAX(sf1), GS_YMAX(sf2))) + call error (0, "GSADD: Y ranges not identical.") + + # allocate space for the pointer + call calloc (sf3, LEN_GSSTRUCT, TY_STRUCT) + + # copy parameters + GS_TYPE(sf3) = GS_TYPE(sf1) + + switch (GS_TYPE(sf3)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf3) = max (GS_NXCOEFF(sf1), GS_NXCOEFF(sf2)) + GS_XORDER(sf3) = max (GS_XORDER(sf1), GS_XORDER(sf2)) + GS_XMIN(sf3) = GS_XMIN(sf1) + GS_XMAX(sf3) = GS_XMAX(sf1) + GS_XRANGE(sf3) = GS_XRANGE(sf1) + GS_XMAXMIN(sf3) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf3) = max (GS_NYCOEFF(sf1), GS_NYCOEFF(sf2)) + GS_YORDER(sf3) = max (GS_YORDER(sf1), GS_YORDER(sf2)) + GS_YMIN(sf3) = GS_YMIN(sf1) + GS_YMAX(sf3) = GS_YMAX(sf1) + GS_YRANGE(sf3) = GS_YRANGE(sf1) + GS_YMAXMIN(sf3) = GS_YMAXMIN(sf1) + if (GS_XTERMS(sf1) == GS_XTERMS(sf2)) + GS_XTERMS(sf3) = GS_XTERMS(sf1) + else if (GS_XTERMS(sf1) == GS_XFULL || GS_XTERMS(sf2) == GS_XFULL) + GS_XTERMS(sf3) = GS_XFULL + else + GS_XTERMS(sf3) = GS_XHALF + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) + GS_NYCOEFF(sf3) - 1 + case GS_XHALF: + order = min (GS_XORDER(sf3), GS_YORDER(sf3)) + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) - order * + (order - 1) / 2 + default: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) + } + default: + call error (0, "GSADD: Unknown curve type.") + } + + # set pointers to NULL + GS_XBASIS(sf3) = NULL + GS_YBASIS(sf3) = NULL + GS_MATRIX(sf3) = NULL + GS_CHOFAC(sf3) = NULL + GS_VECTOR(sf3) = NULL + GS_COEFF(sf3) = NULL + GS_WZ(sf3) = NULL + + # calculate the coefficients + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_REAL) + + # set up line counters. + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + maxorder3 = max (GS_XORDER(sf3) + 1, GS_YORDER(sf3) + 1) + + # add in the first surface. + ptr1 = GS_COEFF(sf1) + ptr3 = GS_COEFF(sf3) + nmove1 = GS_NXCOEFF(sf1) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf1) { + call amovr (COEFF(ptr1), COEFF(ptr3), nmove1) + ptr1 = ptr1 + nmove1 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf1)) { + case GS_XNONE: + nmove1 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf1) + 1) > maxorder1) + nmove1 = nmove1 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } + + # add in the second surface. + ptr2 = GS_COEFF(sf2) + ptr3 = GS_COEFF(sf3) + nmove2 = GS_NXCOEFF(sf2) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf2) { + call aaddr (COEFF(ptr3), COEFF(ptr2), COEFF(ptr3), nmove2) + ptr2 = ptr2 + nmove2 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + nmove2 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf2) + 1) > maxorder2) + nmove2 = nmove2 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } +end diff --git a/math/gsurfit/gscoeff.gx b/math/gsurfit/gscoeff.gx new file mode 100644 index 00000000..84c495f7 --- /dev/null +++ b/math/gsurfit/gscoeff.gx @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSCOEFF -- Procedure to fetch the number and magnitude of the coefficients. +# If the GS_XTERMS(sf) = GS_XBI (YES) then the number of coefficients will be +# (GS_NXCOEFF(sf) * GS_NYCOEFF(sf)); if GS_XTERMS is GS_XTRI then the number +# of coefficients will be (GS_NXCOEFF(sf) * GS_NYCOEFF(sf) - order * +# (order - 1) / 2) where order is the minimum of the x and yorders; if +# GS_XTERMS(sf) = GS_XNONE then the number of coefficients will be +# (GS_NXCOEFF(sf) + GS_NYCOEFF(sf) - 1). + +$if (datatype == r) +procedure gscoeff (sf, coeff, ncoeff) +$else +procedure dgscoeff (sf, coeff, ncoeff) +$endif + +pointer sf # pointer to the surface fitting descriptor +PIXEL coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + # calculate the number of coefficients + ncoeff = GS_NCOEFF(sf) + call amov$t (COEFF(GS_COEFF(sf)), coeff, ncoeff) +end diff --git a/math/gsurfit/gscoeffd.x b/math/gsurfit/gscoeffd.x new file mode 100644 index 00000000..2090eec1 --- /dev/null +++ b/math/gsurfit/gscoeffd.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "dgsurfitdef.h" + +# GSCOEFF -- Procedure to fetch the number and magnitude of the coefficients. +# If the GS_XTERMS(sf) = GS_XBI (YES) then the number of coefficients will be +# (GS_NXCOEFF(sf) * GS_NYCOEFF(sf)); if GS_XTERMS is GS_XTRI then the number +# of coefficients will be (GS_NXCOEFF(sf) * GS_NYCOEFF(sf) - order * +# (order - 1) / 2) where order is the minimum of the x and yorders; if +# GS_XTERMS(sf) = GS_XNONE then the number of coefficients will be +# (GS_NXCOEFF(sf) + GS_NYCOEFF(sf) - 1). + +procedure dgscoeff (sf, coeff, ncoeff) + +pointer sf # pointer to the surface fitting descriptor +double coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + # calculate the number of coefficients + ncoeff = GS_NCOEFF(sf) + call amovd (COEFF(GS_COEFF(sf)), coeff, ncoeff) +end diff --git a/math/gsurfit/gscoeffr.x b/math/gsurfit/gscoeffr.x new file mode 100644 index 00000000..96cccce5 --- /dev/null +++ b/math/gsurfit/gscoeffr.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gsurfitdef.h" + +# GSCOEFF -- Procedure to fetch the number and magnitude of the coefficients. +# If the GS_XTERMS(sf) = GS_XBI (YES) then the number of coefficients will be +# (GS_NXCOEFF(sf) * GS_NYCOEFF(sf)); if GS_XTERMS is GS_XTRI then the number +# of coefficients will be (GS_NXCOEFF(sf) * GS_NYCOEFF(sf) - order * +# (order - 1) / 2) where order is the minimum of the x and yorders; if +# GS_XTERMS(sf) = GS_XNONE then the number of coefficients will be +# (GS_NXCOEFF(sf) + GS_NYCOEFF(sf) - 1). + +procedure gscoeff (sf, coeff, ncoeff) + +pointer sf # pointer to the surface fitting descriptor +real coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + # calculate the number of coefficients + ncoeff = GS_NCOEFF(sf) + call amovr (COEFF(GS_COEFF(sf)), coeff, ncoeff) +end diff --git a/math/gsurfit/gscopy.gx b/math/gsurfit/gscopy.gx new file mode 100644 index 00000000..9f0a6d09 --- /dev/null +++ b/math/gsurfit/gscopy.gx @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSCOPY -- Procedure to copy the fit from one surface into another. + +$if (datatype == r) +procedure gscopy (sf1, sf2) +$else +procedure dgscopy (sf1, sf2) +$endif + +pointer sf1 # pointer to original surface +pointer sf2 # pointer to the new surface + +begin + if (sf1 == NULL) { + sf2 = NULL + return + } + + # allocate space for new surface descriptor + call calloc (sf2, LEN_GSSTRUCT, TY_STRUCT) + + # copy surface independent parameters + GS_TYPE(sf2) = GS_TYPE(sf1) + + switch (GS_TYPE(sf1)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf2) = GS_NXCOEFF(sf1) + GS_XORDER(sf2) = GS_XORDER(sf1) + GS_XMIN(sf2) = GS_XMIN(sf1) + GS_XMAX(sf2) = GS_XMAX(sf1) + GS_XRANGE(sf2) = GS_XRANGE(sf1) + GS_XMAXMIN(sf2) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf2) = GS_NYCOEFF(sf1) + GS_YORDER(sf2) = GS_YORDER(sf1) + GS_YMIN(sf2) = GS_YMIN(sf1) + GS_YMAX(sf2) = GS_YMAX(sf1) + GS_YRANGE(sf2) = GS_YRANGE(sf1) + GS_YMAXMIN(sf2) = GS_YMAXMIN(sf1) + GS_XTERMS(sf2) = GS_XTERMS(sf1) + GS_NCOEFF(sf2) = GS_NCOEFF(sf1) + default: + call error (0, "GSCOPY: Unknown surface type.") + } + + # set space pointers to NULL + GS_XBASIS(sf2) = NULL + GS_YBASIS(sf2) = NULL + GS_MATRIX(sf2) = NULL + GS_CHOFAC(sf2) = NULL + GS_VECTOR(sf2) = NULL + GS_COEFF(sf2) = NULL + GS_WZ(sf2) = NULL + + # restore coefficient array + $if (datatype == r) + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_REAL) + $else + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_DOUBLE) + $endif + call amov$t (COEFF(GS_COEFF(sf1)), COEFF(GS_COEFF(sf2)), GS_NCOEFF(sf2)) +end diff --git a/math/gsurfit/gscopyd.x b/math/gsurfit/gscopyd.x new file mode 100644 index 00000000..b5b93912 --- /dev/null +++ b/math/gsurfit/gscopyd.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSCOPY -- Procedure to copy the fit from one surface into another. + +procedure dgscopy (sf1, sf2) + +pointer sf1 # pointer to original surface +pointer sf2 # pointer to the new surface + +begin + if (sf1 == NULL) { + sf2 = NULL + return + } + + # allocate space for new surface descriptor + call calloc (sf2, LEN_GSSTRUCT, TY_STRUCT) + + # copy surface independent parameters + GS_TYPE(sf2) = GS_TYPE(sf1) + + switch (GS_TYPE(sf1)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf2) = GS_NXCOEFF(sf1) + GS_XORDER(sf2) = GS_XORDER(sf1) + GS_XMIN(sf2) = GS_XMIN(sf1) + GS_XMAX(sf2) = GS_XMAX(sf1) + GS_XRANGE(sf2) = GS_XRANGE(sf1) + GS_XMAXMIN(sf2) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf2) = GS_NYCOEFF(sf1) + GS_YORDER(sf2) = GS_YORDER(sf1) + GS_YMIN(sf2) = GS_YMIN(sf1) + GS_YMAX(sf2) = GS_YMAX(sf1) + GS_YRANGE(sf2) = GS_YRANGE(sf1) + GS_YMAXMIN(sf2) = GS_YMAXMIN(sf1) + GS_XTERMS(sf2) = GS_XTERMS(sf1) + GS_NCOEFF(sf2) = GS_NCOEFF(sf1) + default: + call error (0, "GSCOPY: Unknown surface type.") + } + + # set space pointers to NULL + GS_XBASIS(sf2) = NULL + GS_YBASIS(sf2) = NULL + GS_MATRIX(sf2) = NULL + GS_CHOFAC(sf2) = NULL + GS_VECTOR(sf2) = NULL + GS_COEFF(sf2) = NULL + GS_WZ(sf2) = NULL + + # restore coefficient array + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_DOUBLE) + call amovd (COEFF(GS_COEFF(sf1)), COEFF(GS_COEFF(sf2)), GS_NCOEFF(sf2)) +end diff --git a/math/gsurfit/gscopyr.x b/math/gsurfit/gscopyr.x new file mode 100644 index 00000000..251b5327 --- /dev/null +++ b/math/gsurfit/gscopyr.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSCOPY -- Procedure to copy the fit from one surface into another. + +procedure gscopy (sf1, sf2) + +pointer sf1 # pointer to original surface +pointer sf2 # pointer to the new surface + +begin + if (sf1 == NULL) { + sf2 = NULL + return + } + + # allocate space for new surface descriptor + call calloc (sf2, LEN_GSSTRUCT, TY_STRUCT) + + # copy surface independent parameters + GS_TYPE(sf2) = GS_TYPE(sf1) + + switch (GS_TYPE(sf1)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf2) = GS_NXCOEFF(sf1) + GS_XORDER(sf2) = GS_XORDER(sf1) + GS_XMIN(sf2) = GS_XMIN(sf1) + GS_XMAX(sf2) = GS_XMAX(sf1) + GS_XRANGE(sf2) = GS_XRANGE(sf1) + GS_XMAXMIN(sf2) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf2) = GS_NYCOEFF(sf1) + GS_YORDER(sf2) = GS_YORDER(sf1) + GS_YMIN(sf2) = GS_YMIN(sf1) + GS_YMAX(sf2) = GS_YMAX(sf1) + GS_YRANGE(sf2) = GS_YRANGE(sf1) + GS_YMAXMIN(sf2) = GS_YMAXMIN(sf1) + GS_XTERMS(sf2) = GS_XTERMS(sf1) + GS_NCOEFF(sf2) = GS_NCOEFF(sf1) + default: + call error (0, "GSCOPY: Unknown surface type.") + } + + # set space pointers to NULL + GS_XBASIS(sf2) = NULL + GS_YBASIS(sf2) = NULL + GS_MATRIX(sf2) = NULL + GS_CHOFAC(sf2) = NULL + GS_VECTOR(sf2) = NULL + GS_COEFF(sf2) = NULL + GS_WZ(sf2) = NULL + + # restore coefficient array + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_REAL) + call amovr (COEFF(GS_COEFF(sf1)), COEFF(GS_COEFF(sf2)), GS_NCOEFF(sf2)) +end diff --git a/math/gsurfit/gsder.gx b/math/gsurfit/gsder.gx new file mode 100644 index 00000000..e0ee95bd --- /dev/null +++ b/math/gsurfit/gsder.gx @@ -0,0 +1,264 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSDER -- Procedure to calculate a new surface which is a derivative of +# the previous surface + +$if (datatype == r) +procedure gsder (sf1, x, y, zfit, npts, nxd, nyd) +$else +procedure dgsder (sf1, x, y, zfit, npts, nxd, nyd) +$endif + +pointer sf1 # pointer to the previous surface +PIXEL x[npts] # x values +PIXEL y[npts] # y values +PIXEL zfit[npts] # fitted values +int npts # number of points +int nxd, nyd # order of the derivatives in x and y + +PIXEL norm +int ncoeff, nxder, nyder, i, j +int order, maxorder1, maxorder2, nmove1, nmove2 +pointer sf2, sp, coeff, ptr1, ptr2 + +begin + if (sf1 == NULL) + return + + if (nxd < 0 || nyd < 0) + call error (0, "GSDER: Order of derivatives cannot be < 0") + + if (nxd == 0 && nyd == 0) { + $if (datatype == r) + call gsvector (sf1, x, y, zfit, npts) + $else + call dgsvector (sf1, x, y, zfit, npts) + $endif + return + } + + # allocate space for new surface + call calloc (sf2, LEN_GSSTRUCT, TY_STRUCT) + + # check the order of the derivatives and return 0 if the order is + # high + nxder = min (nxd, GS_NXCOEFF(sf1)) + nyder = min (nyd, GS_NYCOEFF(sf1)) + if (nxder >= GS_NXCOEFF(sf1) && nyder >= GS_NYCOEFF(sf1)) + call amovk$t (PIXEL(0.0), zfit, npts) + + # set up new surface + GS_TYPE(sf2) = GS_TYPE(sf1) + + # set the derivative surface parameters + switch (GS_TYPE(sf2)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + GS_XTERMS(sf2) = GS_XTERMS(sf1) + + # find the order of the new surface + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + if (nxder > 0 && nyder > 0) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else if (nxder > 0) { + GS_NXCOEFF(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_XORDER(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) + } else if (nyder > 0) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_YORDER(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_NCOEFF(sf2) = GS_NYCOEFF(sf2) + } + + case GS_XHALF: + if ((nxder >= GS_NXCOEFF(sf1)) || (nyder >= GS_NYCOEFF(sf1)) || + (nxder + nyder) >= max (GS_NXCOEFF(sf1), + GS_NYCOEFF(sf1))) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else { + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + order = max (1, min (maxorder1 - 1 - nyder - nxder, + GS_NXCOEFF(sf1) - nxder)) + GS_NXCOEFF(sf2) = order + GS_XORDER(sf2) = order + order = max (1, min (maxorder1 - 1 - nyder - nxder, + GS_NYCOEFF(sf1) - nyder)) + GS_NYCOEFF(sf2) = order + GS_YORDER(sf2) = order + order = min (GS_XORDER(sf2), GS_YORDER(sf2)) + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) * GS_NYCOEFF(sf2) - + order * (order - 1) / 2 + } + + default: + if (nxder >= GS_NXCOEFF(sf1) || nyder >= GS_NYCOEFF(sf1)) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else { + GS_NXCOEFF(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_XORDER(sf2) = max (1, GS_XORDER(sf1) - nxder) + GS_NYCOEFF(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_YORDER(sf2) = max (1, GS_YORDER(sf1) - nyder) + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) * GS_NYCOEFF(sf2) + } + } + + # define the data limits + GS_XMIN(sf2) = GS_XMIN(sf1) + GS_XMAX(sf2) = GS_XMAX(sf1) + GS_XRANGE(sf2) = GS_XRANGE(sf1) + GS_XMAXMIN(sf2) = GS_XMAXMIN(sf1) + GS_YMIN(sf2) = GS_YMIN(sf1) + GS_YMAX(sf2) = GS_YMAX(sf1) + GS_YRANGE(sf2) = GS_YRANGE(sf1) + GS_YMAXMIN(sf2) = GS_YMAXMIN(sf1) + + default: + call error (0, "GSDER: Unknown surface type.") + } + + # set remaining surface pointers to NULL + GS_XBASIS(sf2) = NULL + GS_YBASIS(sf2) = NULL + GS_MATRIX(sf2) = NULL + GS_CHOFAC(sf2) = NULL + GS_VECTOR(sf2) = NULL + GS_COEFF(sf2) = NULL + GS_WZ(sf2) = NULL + + # allocate space for coefficients + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_PIXEL) + + # get coefficients + call smark (sp) + call salloc (coeff, GS_NCOEFF(sf1), TY_PIXEL) + $if (datatype == r) + call gscoeff (sf1, Mem$t[coeff], ncoeff) + $else + call dgscoeff (sf1, Mem$t[coeff], ncoeff) + $endif + + # compute the new coefficients + switch (GS_XTERMS(sf2)) { + case GS_XFULL: + if (nxder >= GS_NXCOEFF(sf1) || nyder >= GS_NYCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr2 = GS_COEFF(sf2) + (GS_NYCOEFF(sf2) - 1) * GS_NXCOEFF(sf2) + ptr1 = coeff + (GS_NYCOEFF(sf1) - 1) * GS_NXCOEFF(sf1) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 { + call amov$t (Mem$t[ptr1+nxder], COEFF(ptr2), + GS_NXCOEFF(sf2)) + ptr2 = ptr2 - GS_NXCOEFF(sf2) + ptr1 = ptr1 - GS_NXCOEFF(sf1) + } + } + + case GS_XHALF: + if ((nxder >= GS_NXCOEFF(sf1)) || (nyder >= GS_NYCOEFF(sf1)) || + (nxder + nyder) >= max (GS_NXCOEFF(sf1), GS_NYCOEFF(sf1))) + COEFF(GS_COEFF(sf2)) = 0. + else { + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + ptr2 = GS_COEFF(sf2) + GS_NCOEFF(sf2) + ptr1 = coeff + GS_NCOEFF(sf1) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 { + nmove1 = max (0, min (maxorder1 - i, GS_NXCOEFF(sf1))) + nmove2 = max (0, min (maxorder2 - i + nyder, + GS_NXCOEFF(sf2))) + ptr1 = ptr1 - nmove1 + ptr2 = ptr2 - nmove2 + call amov$t (Mem$t[ptr1+nxder], COEFF(ptr2), nmove2) + } + } + + default: + if (nxder > 0 && nyder > 0) + COEFF(GS_COEFF(sf2)) = 0. + else if (nxder > 0) { + if (nxder >= GS_NXCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr1 = coeff + ptr2 = GS_COEFF(sf2) + GS_NCOEFF(sf2) - 1 + do j = GS_NXCOEFF(sf1), nxder + 1, -1 { + COEFF(ptr2) = Mem$t[ptr1+j-1] + ptr2 = ptr2 - 1 + } + } + } else if (nyder > 0) { + if (nyder >= GS_NYCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr1 = coeff + GS_NCOEFF(sf1) - 1 + ptr2 = GS_COEFF(sf2) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 + ptr1 = ptr1 - 1 + call amov$t (Mem$t[ptr1+1], COEFF(ptr2), GS_NCOEFF(sf2)) + } + } + } + + # evaluate the derivatives + switch (GS_TYPE(sf2)) { + case GS_POLYNOMIAL: + call $tgs_derpoly (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + case GS_CHEBYSHEV: + call $tgs_dercheb (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + case GS_LEGENDRE: + call $tgs_derleg (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + default: + call error (0, "GSVECTOR: Unknown surface type.") + } + + # Normalize. + if (GS_TYPE(sf2) != GS_POLYNOMIAL) { + norm = (2. / (GS_XMAX(sf2) - GS_XMIN(sf2))) ** nxder * (2. / + (GS_YMAX(sf2) - GS_YMIN(sf2))) ** nyder + call amulk$t (zfit, norm, zfit, npts) + } + + # free the space + $if (datatype == r) + call gsfree (sf2) + $else + call dgsfree (sf2) + $endif + call sfree (sp) +end diff --git a/math/gsurfit/gsderd.x b/math/gsurfit/gsderd.x new file mode 100644 index 00000000..851b7b9b --- /dev/null +++ b/math/gsurfit/gsderd.x @@ -0,0 +1,244 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSDER -- Procedure to calculate a new surface which is a derivative of +# the previous surface + +procedure dgsder (sf1, x, y, zfit, npts, nxd, nyd) + +pointer sf1 # pointer to the previous surface +double x[npts] # x values +double y[npts] # y values +double zfit[npts] # fitted values +int npts # number of points +int nxd, nyd # order of the derivatives in x and y + +double norm +int ncoeff, nxder, nyder, i, j +int order, maxorder1, maxorder2, nmove1, nmove2 +pointer sf2, sp, coeff, ptr1, ptr2 + +begin + if (sf1 == NULL) + return + + if (nxd < 0 || nyd < 0) + call error (0, "GSDER: Order of derivatives cannot be < 0") + + if (nxd == 0 && nyd == 0) { + call dgsvector (sf1, x, y, zfit, npts) + return + } + + # allocate space for new surface + call calloc (sf2, LEN_GSSTRUCT, TY_STRUCT) + + # check the order of the derivatives and return 0 if the order is + # high + nxder = min (nxd, GS_NXCOEFF(sf1)) + nyder = min (nyd, GS_NYCOEFF(sf1)) + if (nxder >= GS_NXCOEFF(sf1) && nyder >= GS_NYCOEFF(sf1)) + call amovkd (double(0.0), zfit, npts) + + # set up new surface + GS_TYPE(sf2) = GS_TYPE(sf1) + + # set the derivative surface parameters + switch (GS_TYPE(sf2)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + GS_XTERMS(sf2) = GS_XTERMS(sf1) + + # find the order of the new surface + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + if (nxder > 0 && nyder > 0) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else if (nxder > 0) { + GS_NXCOEFF(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_XORDER(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) + } else if (nyder > 0) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_YORDER(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_NCOEFF(sf2) = GS_NYCOEFF(sf2) + } + + case GS_XHALF: + if ((nxder >= GS_NXCOEFF(sf1)) || (nyder >= GS_NYCOEFF(sf1)) || + (nxder + nyder) >= max (GS_NXCOEFF(sf1), + GS_NYCOEFF(sf1))) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else { + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + order = max (1, min (maxorder1 - 1 - nyder - nxder, + GS_NXCOEFF(sf1) - nxder)) + GS_NXCOEFF(sf2) = order + GS_XORDER(sf2) = order + order = max (1, min (maxorder1 - 1 - nyder - nxder, + GS_NYCOEFF(sf1) - nyder)) + GS_NYCOEFF(sf2) = order + GS_YORDER(sf2) = order + order = min (GS_XORDER(sf2), GS_YORDER(sf2)) + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) * GS_NYCOEFF(sf2) - + order * (order - 1) / 2 + } + + default: + if (nxder >= GS_NXCOEFF(sf1) || nyder >= GS_NYCOEFF(sf1)) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else { + GS_NXCOEFF(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_XORDER(sf2) = max (1, GS_XORDER(sf1) - nxder) + GS_NYCOEFF(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_YORDER(sf2) = max (1, GS_YORDER(sf1) - nyder) + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) * GS_NYCOEFF(sf2) + } + } + + # define the data limits + GS_XMIN(sf2) = GS_XMIN(sf1) + GS_XMAX(sf2) = GS_XMAX(sf1) + GS_XRANGE(sf2) = GS_XRANGE(sf1) + GS_XMAXMIN(sf2) = GS_XMAXMIN(sf1) + GS_YMIN(sf2) = GS_YMIN(sf1) + GS_YMAX(sf2) = GS_YMAX(sf1) + GS_YRANGE(sf2) = GS_YRANGE(sf1) + GS_YMAXMIN(sf2) = GS_YMAXMIN(sf1) + + default: + call error (0, "GSDER: Unknown surface type.") + } + + # set remaining surface pointers to NULL + GS_XBASIS(sf2) = NULL + GS_YBASIS(sf2) = NULL + GS_MATRIX(sf2) = NULL + GS_CHOFAC(sf2) = NULL + GS_VECTOR(sf2) = NULL + GS_COEFF(sf2) = NULL + GS_WZ(sf2) = NULL + + # allocate space for coefficients + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_DOUBLE) + + # get coefficients + call smark (sp) + call salloc (coeff, GS_NCOEFF(sf1), TY_DOUBLE) + call dgscoeff (sf1, Memd[coeff], ncoeff) + + # compute the new coefficients + switch (GS_XTERMS(sf2)) { + case GS_XFULL: + if (nxder >= GS_NXCOEFF(sf1) || nyder >= GS_NYCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr2 = GS_COEFF(sf2) + (GS_NYCOEFF(sf2) - 1) * GS_NXCOEFF(sf2) + ptr1 = coeff + (GS_NYCOEFF(sf1) - 1) * GS_NXCOEFF(sf1) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 { + call amovd (Memd[ptr1+nxder], COEFF(ptr2), + GS_NXCOEFF(sf2)) + ptr2 = ptr2 - GS_NXCOEFF(sf2) + ptr1 = ptr1 - GS_NXCOEFF(sf1) + } + } + + case GS_XHALF: + if ((nxder >= GS_NXCOEFF(sf1)) || (nyder >= GS_NYCOEFF(sf1)) || + (nxder + nyder) >= max (GS_NXCOEFF(sf1), GS_NYCOEFF(sf1))) + COEFF(GS_COEFF(sf2)) = 0. + else { + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + ptr2 = GS_COEFF(sf2) + GS_NCOEFF(sf2) + ptr1 = coeff + GS_NCOEFF(sf1) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 { + nmove1 = max (0, min (maxorder1 - i, GS_NXCOEFF(sf1))) + nmove2 = max (0, min (maxorder2 - i + nyder, + GS_NXCOEFF(sf2))) + ptr1 = ptr1 - nmove1 + ptr2 = ptr2 - nmove2 + call amovd (Memd[ptr1+nxder], COEFF(ptr2), nmove2) + } + } + + default: + if (nxder > 0 && nyder > 0) + COEFF(GS_COEFF(sf2)) = 0. + else if (nxder > 0) { + if (nxder >= GS_NXCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr1 = coeff + ptr2 = GS_COEFF(sf2) + GS_NCOEFF(sf2) - 1 + do j = GS_NXCOEFF(sf1), nxder + 1, -1 { + COEFF(ptr2) = Memd[ptr1+j-1] + ptr2 = ptr2 - 1 + } + } + } else if (nyder > 0) { + if (nyder >= GS_NYCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr1 = coeff + GS_NCOEFF(sf1) - 1 + ptr2 = GS_COEFF(sf2) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 + ptr1 = ptr1 - 1 + call amovd (Memd[ptr1+1], COEFF(ptr2), GS_NCOEFF(sf2)) + } + } + } + + # evaluate the derivatives + switch (GS_TYPE(sf2)) { + case GS_POLYNOMIAL: + call dgs_derpoly (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + case GS_CHEBYSHEV: + call dgs_dercheb (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + case GS_LEGENDRE: + call dgs_derleg (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + default: + call error (0, "GSVECTOR: Unknown surface type.") + } + + # Normalize. + if (GS_TYPE(sf2) != GS_POLYNOMIAL) { + norm = (2. / (GS_XMAX(sf2) - GS_XMIN(sf2))) ** nxder * (2. / + (GS_YMAX(sf2) - GS_YMIN(sf2))) ** nyder + call amulkd (zfit, norm, zfit, npts) + } + + # free the space + call dgsfree (sf2) + call sfree (sp) +end diff --git a/math/gsurfit/gsderr.x b/math/gsurfit/gsderr.x new file mode 100644 index 00000000..00409c0b --- /dev/null +++ b/math/gsurfit/gsderr.x @@ -0,0 +1,244 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSDER -- Procedure to calculate a new surface which is a derivative of +# the previous surface + +procedure gsder (sf1, x, y, zfit, npts, nxd, nyd) + +pointer sf1 # pointer to the previous surface +real x[npts] # x values +real y[npts] # y values +real zfit[npts] # fitted values +int npts # number of points +int nxd, nyd # order of the derivatives in x and y + +real norm +int ncoeff, nxder, nyder, i, j +int order, maxorder1, maxorder2, nmove1, nmove2 +pointer sf2, sp, coeff, ptr1, ptr2 + +begin + if (sf1 == NULL) + return + + if (nxd < 0 || nyd < 0) + call error (0, "GSDER: Order of derivatives cannot be < 0") + + if (nxd == 0 && nyd == 0) { + call gsvector (sf1, x, y, zfit, npts) + return + } + + # allocate space for new surface + call calloc (sf2, LEN_GSSTRUCT, TY_STRUCT) + + # check the order of the derivatives and return 0 if the order is + # high + nxder = min (nxd, GS_NXCOEFF(sf1)) + nyder = min (nyd, GS_NYCOEFF(sf1)) + if (nxder >= GS_NXCOEFF(sf1) && nyder >= GS_NYCOEFF(sf1)) + call amovkr (real(0.0), zfit, npts) + + # set up new surface + GS_TYPE(sf2) = GS_TYPE(sf1) + + # set the derivative surface parameters + switch (GS_TYPE(sf2)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + GS_XTERMS(sf2) = GS_XTERMS(sf1) + + # find the order of the new surface + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + if (nxder > 0 && nyder > 0) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else if (nxder > 0) { + GS_NXCOEFF(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_XORDER(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) + } else if (nyder > 0) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_YORDER(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_NCOEFF(sf2) = GS_NYCOEFF(sf2) + } + + case GS_XHALF: + if ((nxder >= GS_NXCOEFF(sf1)) || (nyder >= GS_NYCOEFF(sf1)) || + (nxder + nyder) >= max (GS_NXCOEFF(sf1), + GS_NYCOEFF(sf1))) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else { + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + order = max (1, min (maxorder1 - 1 - nyder - nxder, + GS_NXCOEFF(sf1) - nxder)) + GS_NXCOEFF(sf2) = order + GS_XORDER(sf2) = order + order = max (1, min (maxorder1 - 1 - nyder - nxder, + GS_NYCOEFF(sf1) - nyder)) + GS_NYCOEFF(sf2) = order + GS_YORDER(sf2) = order + order = min (GS_XORDER(sf2), GS_YORDER(sf2)) + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) * GS_NYCOEFF(sf2) - + order * (order - 1) / 2 + } + + default: + if (nxder >= GS_NXCOEFF(sf1) || nyder >= GS_NYCOEFF(sf1)) { + GS_NXCOEFF(sf2) = 1 + GS_XORDER(sf2) = 1 + GS_NYCOEFF(sf2) = 1 + GS_YORDER(sf2) = 1 + GS_NCOEFF(sf2) = 1 + } else { + GS_NXCOEFF(sf2) = max (1, GS_NXCOEFF(sf1) - nxder) + GS_XORDER(sf2) = max (1, GS_XORDER(sf1) - nxder) + GS_NYCOEFF(sf2) = max (1, GS_NYCOEFF(sf1) - nyder) + GS_YORDER(sf2) = max (1, GS_YORDER(sf1) - nyder) + GS_NCOEFF(sf2) = GS_NXCOEFF(sf2) * GS_NYCOEFF(sf2) + } + } + + # define the data limits + GS_XMIN(sf2) = GS_XMIN(sf1) + GS_XMAX(sf2) = GS_XMAX(sf1) + GS_XRANGE(sf2) = GS_XRANGE(sf1) + GS_XMAXMIN(sf2) = GS_XMAXMIN(sf1) + GS_YMIN(sf2) = GS_YMIN(sf1) + GS_YMAX(sf2) = GS_YMAX(sf1) + GS_YRANGE(sf2) = GS_YRANGE(sf1) + GS_YMAXMIN(sf2) = GS_YMAXMIN(sf1) + + default: + call error (0, "GSDER: Unknown surface type.") + } + + # set remaining surface pointers to NULL + GS_XBASIS(sf2) = NULL + GS_YBASIS(sf2) = NULL + GS_MATRIX(sf2) = NULL + GS_CHOFAC(sf2) = NULL + GS_VECTOR(sf2) = NULL + GS_COEFF(sf2) = NULL + GS_WZ(sf2) = NULL + + # allocate space for coefficients + call calloc (GS_COEFF(sf2), GS_NCOEFF(sf2), TY_REAL) + + # get coefficients + call smark (sp) + call salloc (coeff, GS_NCOEFF(sf1), TY_REAL) + call gscoeff (sf1, Memr[coeff], ncoeff) + + # compute the new coefficients + switch (GS_XTERMS(sf2)) { + case GS_XFULL: + if (nxder >= GS_NXCOEFF(sf1) || nyder >= GS_NYCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr2 = GS_COEFF(sf2) + (GS_NYCOEFF(sf2) - 1) * GS_NXCOEFF(sf2) + ptr1 = coeff + (GS_NYCOEFF(sf1) - 1) * GS_NXCOEFF(sf1) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 { + call amovr (Memr[ptr1+nxder], COEFF(ptr2), + GS_NXCOEFF(sf2)) + ptr2 = ptr2 - GS_NXCOEFF(sf2) + ptr1 = ptr1 - GS_NXCOEFF(sf1) + } + } + + case GS_XHALF: + if ((nxder >= GS_NXCOEFF(sf1)) || (nyder >= GS_NYCOEFF(sf1)) || + (nxder + nyder) >= max (GS_NXCOEFF(sf1), GS_NYCOEFF(sf1))) + COEFF(GS_COEFF(sf2)) = 0. + else { + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + ptr2 = GS_COEFF(sf2) + GS_NCOEFF(sf2) + ptr1 = coeff + GS_NCOEFF(sf1) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 { + nmove1 = max (0, min (maxorder1 - i, GS_NXCOEFF(sf1))) + nmove2 = max (0, min (maxorder2 - i + nyder, + GS_NXCOEFF(sf2))) + ptr1 = ptr1 - nmove1 + ptr2 = ptr2 - nmove2 + call amovr (Memr[ptr1+nxder], COEFF(ptr2), nmove2) + } + } + + default: + if (nxder > 0 && nyder > 0) + COEFF(GS_COEFF(sf2)) = 0. + else if (nxder > 0) { + if (nxder >= GS_NXCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr1 = coeff + ptr2 = GS_COEFF(sf2) + GS_NCOEFF(sf2) - 1 + do j = GS_NXCOEFF(sf1), nxder + 1, -1 { + COEFF(ptr2) = Memr[ptr1+j-1] + ptr2 = ptr2 - 1 + } + } + } else if (nyder > 0) { + if (nyder >= GS_NYCOEFF(sf1)) + COEFF(GS_COEFF(sf2)) = 0. + else { + ptr1 = coeff + GS_NCOEFF(sf1) - 1 + ptr2 = GS_COEFF(sf2) + do i = GS_NYCOEFF(sf1), nyder + 1, -1 + ptr1 = ptr1 - 1 + call amovr (Memr[ptr1+1], COEFF(ptr2), GS_NCOEFF(sf2)) + } + } + } + + # evaluate the derivatives + switch (GS_TYPE(sf2)) { + case GS_POLYNOMIAL: + call rgs_derpoly (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + case GS_CHEBYSHEV: + call rgs_dercheb (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + case GS_LEGENDRE: + call rgs_derleg (COEFF(GS_COEFF(sf2)), x, y, zfit, npts, + GS_XTERMS(sf2), GS_XORDER(sf2), GS_YORDER(sf2), nxder, + nyder, GS_XMAXMIN(sf2), GS_XRANGE(sf2), GS_YMAXMIN(sf2), + GS_YRANGE(sf2)) + + default: + call error (0, "GSVECTOR: Unknown surface type.") + } + + # Normalize. + if (GS_TYPE(sf2) != GS_POLYNOMIAL) { + norm = (2. / (GS_XMAX(sf2) - GS_XMIN(sf2))) ** nxder * (2. / + (GS_YMAX(sf2) - GS_YMIN(sf2))) ** nyder + call amulkr (zfit, norm, zfit, npts) + } + + # free the space + call gsfree (sf2) + call sfree (sp) +end diff --git a/math/gsurfit/gserrors.gx b/math/gsurfit/gserrors.gx new file mode 100644 index 00000000..5f78cfab --- /dev/null +++ b/math/gsurfit/gserrors.gx @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +define COV Mem$t[P2P($1)] # element of COV + +# GSERRORS -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the coefficients. First the variance +# and the reduced chi-squared of the fit are estimated. If these two +# quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +$if (datatype == r) +procedure gserrors (sf, z, w, zfit, chisqr, errors) +$else +procedure dgserrors (sf, z, w, zfit, chisqr, errors) +$endif + +pointer sf # curve descriptor +PIXEL z[ARB] # data points +PIXEL w[ARB] # array of weights +PIXEL zfit[ARB] # fitted data points +PIXEL chisqr # reduced chi-squared of fit +PIXEL errors[ARB] # errors in coefficients + +int i, nfree +PIXEL variance, chisq, hold +pointer sp, covptr + +begin + # allocate space for covariance vector + call smark (sp) + $if (datatype == r) + call salloc (covptr, GS_NCOEFF(sf), TY_REAL) + $else + call salloc (covptr, GS_NCOEFF(sf), TY_DOUBLE) + $endif + + # estimate the variance and chi-squared of the fit + variance = 0. + chisq = 0. + do i = 1, GS_NPTS(sf) { + hold = (z[i] - zfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + } + + # calculate the reduced chi-squared + nfree = GS_NPTS(sf) - GS_NCOEFF(sf) + if (nfree > 0) + chisqr = chisq / nfree + else + chisqr = 0. + + # if the variance equals the reduced chi_squared as in the + # case of uniform weights then scale the errors in the coefficients + # by the variance not the reduced chi-squared + + if (abs (chisq - variance) <= DELTA) + if (nfree > 0) + variance = chisq / nfree + else + variance = 0. + else + variance = 1. + + # calculate the errors in the coefficients + # the inverse of MATRIX is calculated column by column + # the error of the j-th coefficient is the j-th element of the + # j-th column of the inverse matrix + + do i = 1, GS_NCOEFF(sf) { + call aclr$t (COV(covptr), GS_NCOEFF(sf)) + COV(covptr+i-1) = 1. + call $tgschoslv (CHOFAC(GS_CHOFAC(sf)), GS_NCOEFF(sf), + GS_NCOEFF(sf), COV(covptr), COV(covptr)) + if (COV(covptr+i-1) >= 0.) + errors[i] = sqrt (COV(covptr+i-1) * variance) + else + errors[i] = 0. + } + + call sfree (sp) +end diff --git a/math/gsurfit/gserrorsd.x b/math/gsurfit/gserrorsd.x new file mode 100644 index 00000000..6ebdc87e --- /dev/null +++ b/math/gsurfit/gserrorsd.x @@ -0,0 +1,78 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include "dgsurfitdef.h" + +define COV Memd[P2P($1)] # element of COV + +# GSERRORS -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the coefficients. First the variance +# and the reduced chi-squared of the fit are estimated. If these two +# quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +procedure dgserrors (sf, z, w, zfit, chisqr, errors) + +pointer sf # curve descriptor +double z[ARB] # data points +double w[ARB] # array of weights +double zfit[ARB] # fitted data points +double chisqr # reduced chi-squared of fit +double errors[ARB] # errors in coefficients + +int i, nfree +double variance, chisq, hold +pointer sp, covptr + +begin + # allocate space for covariance vector + call smark (sp) + call salloc (covptr, GS_NCOEFF(sf), TY_DOUBLE) + + # estimate the variance and chi-squared of the fit + variance = 0. + chisq = 0. + do i = 1, GS_NPTS(sf) { + hold = (z[i] - zfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + } + + # calculate the reduced chi-squared + nfree = GS_NPTS(sf) - GS_NCOEFF(sf) + if (nfree > 0) + chisqr = chisq / nfree + else + chisqr = 0. + + # if the variance equals the reduced chi_squared as in the + # case of uniform weights then scale the errors in the coefficients + # by the variance not the reduced chi-squared + + if (abs (chisq - variance) <= DELTA) + if (nfree > 0) + variance = chisq / nfree + else + variance = 0. + else + variance = 1. + + # calculate the errors in the coefficients + # the inverse of MATRIX is calculated column by column + # the error of the j-th coefficient is the j-th element of the + # j-th column of the inverse matrix + + do i = 1, GS_NCOEFF(sf) { + call aclrd (COV(covptr), GS_NCOEFF(sf)) + COV(covptr+i-1) = 1. + call dgschoslv (CHOFAC(GS_CHOFAC(sf)), GS_NCOEFF(sf), + GS_NCOEFF(sf), COV(covptr), COV(covptr)) + if (COV(covptr+i-1) >= 0.) + errors[i] = sqrt (COV(covptr+i-1) * variance) + else + errors[i] = 0. + } + + call sfree (sp) +end diff --git a/math/gsurfit/gserrorsr.x b/math/gsurfit/gserrorsr.x new file mode 100644 index 00000000..594dff29 --- /dev/null +++ b/math/gsurfit/gserrorsr.x @@ -0,0 +1,78 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include "gsurfitdef.h" + +define COV Memr[P2P($1)] # element of COV + +# GSERRORS -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the coefficients. First the variance +# and the reduced chi-squared of the fit are estimated. If these two +# quantities are identical the variance is used to scale the errors +# in the coefficients. The errors in the coefficients are proportional +# to the inverse diagonal elements of MATRIX. + +procedure gserrors (sf, z, w, zfit, chisqr, errors) + +pointer sf # curve descriptor +real z[ARB] # data points +real w[ARB] # array of weights +real zfit[ARB] # fitted data points +real chisqr # reduced chi-squared of fit +real errors[ARB] # errors in coefficients + +int i, nfree +real variance, chisq, hold +pointer sp, covptr + +begin + # allocate space for covariance vector + call smark (sp) + call salloc (covptr, GS_NCOEFF(sf), TY_REAL) + + # estimate the variance and chi-squared of the fit + variance = 0. + chisq = 0. + do i = 1, GS_NPTS(sf) { + hold = (z[i] - zfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + } + + # calculate the reduced chi-squared + nfree = GS_NPTS(sf) - GS_NCOEFF(sf) + if (nfree > 0) + chisqr = chisq / nfree + else + chisqr = 0. + + # if the variance equals the reduced chi_squared as in the + # case of uniform weights then scale the errors in the coefficients + # by the variance not the reduced chi-squared + + if (abs (chisq - variance) <= DELTA) + if (nfree > 0) + variance = chisq / nfree + else + variance = 0. + else + variance = 1. + + # calculate the errors in the coefficients + # the inverse of MATRIX is calculated column by column + # the error of the j-th coefficient is the j-th element of the + # j-th column of the inverse matrix + + do i = 1, GS_NCOEFF(sf) { + call aclrr (COV(covptr), GS_NCOEFF(sf)) + COV(covptr+i-1) = 1. + call rgschoslv (CHOFAC(GS_CHOFAC(sf)), GS_NCOEFF(sf), + GS_NCOEFF(sf), COV(covptr), COV(covptr)) + if (COV(covptr+i-1) >= 0.) + errors[i] = sqrt (COV(covptr+i-1) * variance) + else + errors[i] = 0. + } + + call sfree (sp) +end diff --git a/math/gsurfit/gseval.gx b/math/gsurfit/gseval.gx new file mode 100644 index 00000000..d57d21c7 --- /dev/null +++ b/math/gsurfit/gseval.gx @@ -0,0 +1,104 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSEVAL -- Procedure to evaluate the fitted surface at a single point. +# The GS_NCOEFF(sf) coefficients are stored in the vector COEFF. + +$if (datatype == r) +real procedure gseval (sf, x, y) +$else +double procedure dgseval (sf, x, y) +$endif + +pointer sf # pointer to surface descriptor structure +PIXEL x # x value +PIXEL y # y value + +PIXEL sum, accum +int i, ii, k, maxorder, xorder +pointer sp, xb, xzb, yb, yzb, czptr +errchk smark, salloc, sfree + +begin + call smark (sp) + + # allocate space for the basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + $if (datatype == r) + call salloc (xb, GS_NXCOEFF(sf), TY_REAL) + call salloc (yb, GS_NYCOEFF(sf), TY_REAL) + $else + call salloc (xb, GS_NXCOEFF(sf), TY_DOUBLE) + call salloc (yb, GS_NYCOEFF(sf), TY_DOUBLE) + $endif + xzb = xb - 1 + yzb = yb - 1 + czptr = GS_COEFF(sf) - 1 + default: + call error (0, "GSEVAL: Unknown curve type.") + } + + # calculate the basis functions + switch (GS_TYPE(sf)) { + case GS_CHEBYSHEV: + call $tgs_b1cheb (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call $tgs_b1cheb (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + case GS_LEGENDRE: + call $tgs_b1leg (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call $tgs_b1leg (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + case GS_POLYNOMIAL: + call $tgs_b1pol (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call $tgs_b1pol (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + default: + call error (0, "GSEVAL: Unknown surface type.") + } + + # initialize accumulator + # basis functions + sum = 0. + + # loop over y basis functions + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ii = 1 + do i = 1, GS_YORDER(sf) { + + # loop over the x basis functions + accum = 0. + do k = 1, xorder { + accum = accum + COEFF(czptr+ii) * XBS(xzb+k) + ii = ii + 1 + } + accum = accum * YBS(yzb+i) + sum = sum + accum + + # elements of COEFF where neither k = 1 or i = 1 + # are not calculated if GS_XTERMS(sf) = NO + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + call sfree (sp) + + return (sum) +end diff --git a/math/gsurfit/gsevald.x b/math/gsurfit/gsevald.x new file mode 100644 index 00000000..e7909d91 --- /dev/null +++ b/math/gsurfit/gsevald.x @@ -0,0 +1,91 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSEVAL -- Procedure to evaluate the fitted surface at a single point. +# The GS_NCOEFF(sf) coefficients are stored in the vector COEFF. + +double procedure dgseval (sf, x, y) + +pointer sf # pointer to surface descriptor structure +double x # x value +double y # y value + +double sum, accum +int i, ii, k, maxorder, xorder +pointer sp, xb, xzb, yb, yzb, czptr +errchk smark, salloc, sfree + +begin + call smark (sp) + + # allocate space for the basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + call salloc (xb, GS_NXCOEFF(sf), TY_DOUBLE) + call salloc (yb, GS_NYCOEFF(sf), TY_DOUBLE) + xzb = xb - 1 + yzb = yb - 1 + czptr = GS_COEFF(sf) - 1 + default: + call error (0, "GSEVAL: Unknown curve type.") + } + + # calculate the basis functions + switch (GS_TYPE(sf)) { + case GS_CHEBYSHEV: + call dgs_b1cheb (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call dgs_b1cheb (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + case GS_LEGENDRE: + call dgs_b1leg (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call dgs_b1leg (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + case GS_POLYNOMIAL: + call dgs_b1pol (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call dgs_b1pol (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + default: + call error (0, "GSEVAL: Unknown surface type.") + } + + # initialize accumulator + # basis functions + sum = 0. + + # loop over y basis functions + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ii = 1 + do i = 1, GS_YORDER(sf) { + + # loop over the x basis functions + accum = 0. + do k = 1, xorder { + accum = accum + COEFF(czptr+ii) * XBS(xzb+k) + ii = ii + 1 + } + accum = accum * YBS(yzb+i) + sum = sum + accum + + # elements of COEFF where neither k = 1 or i = 1 + # are not calculated if GS_XTERMS(sf) = NO + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + call sfree (sp) + + return (sum) +end diff --git a/math/gsurfit/gsevalr.x b/math/gsurfit/gsevalr.x new file mode 100644 index 00000000..738e9915 --- /dev/null +++ b/math/gsurfit/gsevalr.x @@ -0,0 +1,91 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSEVAL -- Procedure to evaluate the fitted surface at a single point. +# The GS_NCOEFF(sf) coefficients are stored in the vector COEFF. + +real procedure gseval (sf, x, y) + +pointer sf # pointer to surface descriptor structure +real x # x value +real y # y value + +real sum, accum +int i, ii, k, maxorder, xorder +pointer sp, xb, xzb, yb, yzb, czptr +errchk smark, salloc, sfree + +begin + call smark (sp) + + # allocate space for the basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + call salloc (xb, GS_NXCOEFF(sf), TY_REAL) + call salloc (yb, GS_NYCOEFF(sf), TY_REAL) + xzb = xb - 1 + yzb = yb - 1 + czptr = GS_COEFF(sf) - 1 + default: + call error (0, "GSEVAL: Unknown curve type.") + } + + # calculate the basis functions + switch (GS_TYPE(sf)) { + case GS_CHEBYSHEV: + call rgs_b1cheb (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call rgs_b1cheb (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + case GS_LEGENDRE: + call rgs_b1leg (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call rgs_b1leg (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + case GS_POLYNOMIAL: + call rgs_b1pol (x, GS_NXCOEFF(sf), GS_XMAXMIN(sf), GS_XRANGE(sf), + XBS(xb)) + call rgs_b1pol (y, GS_NYCOEFF(sf), GS_YMAXMIN(sf), GS_YRANGE(sf), + YBS(yb)) + default: + call error (0, "GSEVAL: Unknown surface type.") + } + + # initialize accumulator + # basis functions + sum = 0. + + # loop over y basis functions + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + xorder = GS_XORDER(sf) + ii = 1 + do i = 1, GS_YORDER(sf) { + + # loop over the x basis functions + accum = 0. + do k = 1, xorder { + accum = accum + COEFF(czptr+ii) * XBS(xzb+k) + ii = ii + 1 + } + accum = accum * YBS(yzb+i) + sum = sum + accum + + # elements of COEFF where neither k = 1 or i = 1 + # are not calculated if GS_XTERMS(sf) = NO + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + call sfree (sp) + + return (sum) +end diff --git a/math/gsurfit/gsfit.gx b/math/gsurfit/gsfit.gx new file mode 100644 index 00000000..60251596 --- /dev/null +++ b/math/gsurfit/gsfit.gx @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSFIT -- Procedure to solve the normal equations for a surface. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# GS_NCOEFF(sf)-vector VECTOR. The Cholesky factorization of MATRIX +# is calculated and stored in CHOFAC. Forward and back substitution +# is used to solve for the GS_NCOEFF(sf)-vector COEFF. + +$if (datatype == r) +procedure gsfit (sf, x, y, z, w, npts, wtflag, ier) +$else +procedure dgsfit (sf, x, y, z, w, npts, wtflag, ier) +$endif + +pointer sf # surface descriptor +PIXEL x[npts] # array of x values +PIXEL y[npts] # array of y values +PIXEL z[npts] # data array +PIXEL w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +begin + $if (datatype == r) + call gszero (sf) + call gsacpts (sf, x, y, z, w, npts, wtflag) + call gssolve (sf, ier) + $else + call dgszero (sf) + call dgsacpts (sf, x, y, z, w, npts, wtflag) + call dgssolve (sf, ier) + $endif +end diff --git a/math/gsurfit/gsfit1.gx b/math/gsurfit/gsfit1.gx new file mode 100644 index 00000000..4e7341e4 --- /dev/null +++ b/math/gsurfit/gsfit1.gx @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSFIT1 -- Procedure to solve the normal equations for a surface. +# +# This version modifies the fitting matrix to remove the first +# term from the fitting. For the polynomial functions this means +# constraining the constant term to be zero. Note that the first +# coefficent is still returned but with a value of zero. + +$if (datatype == r) +procedure gsfit1 (sf, x, y, z, w, npts, wtflag, ier) +$else +procedure dgsfit1 (sf, x, y, z, w, npts, wtflag, ier) +$endif + +pointer sf # surface descriptor +PIXEL x[npts] # array of x values +PIXEL y[npts] # array of y values +PIXEL z[npts] # data array +PIXEL w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +begin + $if (datatype == r) + call gszero (sf) + call gsacpts (sf, x, y, z, w, npts, wtflag) + call gssolve1 (sf, ier) + $else + call dgszero (sf) + call dgsacpts (sf, x, y, z, w, npts, wtflag) + call dgssolve1 (sf, ier) + $endif +end + + +# GSSOLVE1 -- Solve the matrix normal equations of the form ca = b for +# a, where c is a symmetric, positive semi-definite, banded matrix with +# GS_NXCOEFF(sf) * GS_NYCOEFF(sf) rows and a and b are GS_NXCOEFF(sf) * +# GS_NYCOEFF(sf)-vectors. Initially c is stored in the matrix MATRIX and b +# is stored in VECTOR. The Cholesky factorization of MATRIX is calculated +# and stored in CHOFAC. Finally the coefficients are calculated by forward +# and back substitution and stored in COEFF. +# +# This version modifies the fitting matrix to remove the first +# term from the fitting. For the polynomial functions this means +# constraining the constant term to be zero. Note that the first +# coefficent is still returned but with a value of zero. + +$if (datatype == r) +procedure gssolve1 (sf, ier) +$else +procedure dgssolve1 (sf, ier) +$endif + +pointer sf # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int i, ncoeff, offset +pointer sp, vector, matrix + +begin + + # test for number of degrees of freedom + offset = 1 + ncoeff = GS_NCOEFF(sf) - offset + ier = OK + i = GS_NPTS(sf) - ncoeff + if (i < 0) { + ier = NO_DEG_FREEDOM + return + } + + # allocate working space for the reduced vector and matrix + call smark (sp) + call salloc (vector, ncoeff, TY_PIXEL) + call salloc (matrix, ncoeff*ncoeff, TY_PIXEL) + + # eliminate the first term from the vector and matrix + call amov$t (VECTOR(GS_VECTOR(sf)+offset), Mem$t[vector], ncoeff) + do i = 0, ncoeff-1 + call amov$t (MATRIX(GS_MATRIX(sf)+(i+offset)*GS_NCOEFF(sf)), + Mem$t[matrix+i*ncoeff], ncoeff) + + # solve for the coefficients. + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # calculate the Cholesky factorization of the data matrix + call $tgschofac (Memd[matrix], ncoeff, ncoeff, + CHOFAC(GS_CHOFAC(sf)), ier) + + # solve for the coefficients by forward and back substitution + COEFF(GS_COEFF(sf)) = 0. + call $tgschoslv (CHOFAC(GS_CHOFAC(sf)), ncoeff, ncoeff, + Memd[vector], COEFF(GS_COEFF(sf)+offset)) + + default: + call error (0, "GSSOLVE1: Illegal surface type.") + } + + call sfree (sp) +end diff --git a/math/gsurfit/gsfit1d.x b/math/gsurfit/gsfit1d.x new file mode 100644 index 00000000..8937103f --- /dev/null +++ b/math/gsurfit/gsfit1d.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSFIT1 -- Procedure to solve the normal equations for a surface. +# +# This version modifies the fitting matrix to remove the first +# term from the fitting. For the polynomial functions this means +# constraining the constant term to be zero. Note that the first +# coefficent is still returned but with a value of zero. + +procedure dgsfit1 (sf, x, y, z, w, npts, wtflag, ier) + +pointer sf # surface descriptor +double x[npts] # array of x values +double y[npts] # array of y values +double z[npts] # data array +double w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +begin + call dgszero (sf) + call dgsacpts (sf, x, y, z, w, npts, wtflag) + call dgssolve1 (sf, ier) +end + + +# GSSOLVE1 -- Solve the matrix normal equations of the form ca = b for +# a, where c is a symmetric, positive semi-definite, banded matrix with +# GS_NXCOEFF(sf) * GS_NYCOEFF(sf) rows and a and b are GS_NXCOEFF(sf) * +# GS_NYCOEFF(sf)-vectors. Initially c is stored in the matrix MATRIX and b +# is stored in VECTOR. The Cholesky factorization of MATRIX is calculated +# and stored in CHOFAC. Finally the coefficients are calculated by forward +# and back substitution and stored in COEFF. +# +# This version modifies the fitting matrix to remove the first +# term from the fitting. For the polynomial functions this means +# constraining the constant term to be zero. Note that the first +# coefficent is still returned but with a value of zero. + +procedure dgssolve1 (sf, ier) + +pointer sf # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int i, ncoeff, offset +pointer sp, vector, matrix + +begin + + # test for number of degrees of freedom + offset = 1 + ncoeff = GS_NCOEFF(sf) - offset + ier = OK + i = GS_NPTS(sf) - ncoeff + if (i < 0) { + ier = NO_DEG_FREEDOM + return + } + + # allocate working space for the reduced vector and matrix + call smark (sp) + call salloc (vector, ncoeff, TY_DOUBLE) + call salloc (matrix, ncoeff*ncoeff, TY_DOUBLE) + + # eliminate the first term from the vector and matrix + call amovd (VECTOR(GS_VECTOR(sf)+offset), Memd[vector], ncoeff) + do i = 0, ncoeff-1 + call amovd (MATRIX(GS_MATRIX(sf)+(i+offset)*GS_NCOEFF(sf)), + Memd[matrix+i*ncoeff], ncoeff) + + # solve for the coefficients. + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # calculate the Cholesky factorization of the data matrix + call dgschofac (Memd[matrix], ncoeff, ncoeff, + CHOFAC(GS_CHOFAC(sf)), ier) + + # solve for the coefficients by forward and back substitution + COEFF(GS_COEFF(sf)) = 0. + call dgschoslv (CHOFAC(GS_CHOFAC(sf)), ncoeff, ncoeff, + Memd[vector], COEFF(GS_COEFF(sf)+offset)) + + default: + call error (0, "GSSOLVE1: Illegal surface type.") + } + + call sfree (sp) +end diff --git a/math/gsurfit/gsfit1r.x b/math/gsurfit/gsfit1r.x new file mode 100644 index 00000000..fe3be3ed --- /dev/null +++ b/math/gsurfit/gsfit1r.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSFIT1 -- Procedure to solve the normal equations for a surface. +# +# This version modifies the fitting matrix to remove the first +# term from the fitting. For the polynomial functions this means +# constraining the constant term to be zero. Note that the first +# coefficent is still returned but with a value of zero. + +procedure gsfit1 (sf, x, y, z, w, npts, wtflag, ier) + +pointer sf # surface descriptor +real x[npts] # array of x values +real y[npts] # array of y values +real z[npts] # data array +real w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +begin + call gszero (sf) + call gsacpts (sf, x, y, z, w, npts, wtflag) + call gssolve1 (sf, ier) +end + + +# GSSOLVE1 -- Solve the matrix normal equations of the form ca = b for +# a, where c is a symmetric, positive semi-definite, banded matrix with +# GS_NXCOEFF(sf) * GS_NYCOEFF(sf) rows and a and b are GS_NXCOEFF(sf) * +# GS_NYCOEFF(sf)-vectors. Initially c is stored in the matrix MATRIX and b +# is stored in VECTOR. The Cholesky factorization of MATRIX is calculated +# and stored in CHOFAC. Finally the coefficients are calculated by forward +# and back substitution and stored in COEFF. +# +# This version modifies the fitting matrix to remove the first +# term from the fitting. For the polynomial functions this means +# constraining the constant term to be zero. Note that the first +# coefficent is still returned but with a value of zero. + +procedure gssolve1 (sf, ier) + +pointer sf # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int i, ncoeff, offset +pointer sp, vector, matrix + +begin + + # test for number of degrees of freedom + offset = 1 + ncoeff = GS_NCOEFF(sf) - offset + ier = OK + i = GS_NPTS(sf) - ncoeff + if (i < 0) { + ier = NO_DEG_FREEDOM + return + } + + # allocate working space for the reduced vector and matrix + call smark (sp) + call salloc (vector, ncoeff, TY_REAL) + call salloc (matrix, ncoeff*ncoeff, TY_REAL) + + # eliminate the first term from the vector and matrix + call amovr (VECTOR(GS_VECTOR(sf)+offset), Memr[vector], ncoeff) + do i = 0, ncoeff-1 + call amovr (MATRIX(GS_MATRIX(sf)+(i+offset)*GS_NCOEFF(sf)), + Memr[matrix+i*ncoeff], ncoeff) + + # solve for the coefficients. + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # calculate the Cholesky factorization of the data matrix + call rgschofac (Memd[matrix], ncoeff, ncoeff, + CHOFAC(GS_CHOFAC(sf)), ier) + + # solve for the coefficients by forward and back substitution + COEFF(GS_COEFF(sf)) = 0. + call rgschoslv (CHOFAC(GS_CHOFAC(sf)), ncoeff, ncoeff, + Memd[vector], COEFF(GS_COEFF(sf)+offset)) + + default: + call error (0, "GSSOLVE1: Illegal surface type.") + } + + call sfree (sp) +end diff --git a/math/gsurfit/gsfitd.x b/math/gsurfit/gsfitd.x new file mode 100644 index 00000000..b432cc3f --- /dev/null +++ b/math/gsurfit/gsfitd.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSFIT -- Procedure to solve the normal equations for a surface. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# GS_NCOEFF(sf)-vector VECTOR. The Cholesky factorization of MATRIX +# is calculated and stored in CHOFAC. Forward and back substitution +# is used to solve for the GS_NCOEFF(sf)-vector COEFF. + +procedure dgsfit (sf, x, y, z, w, npts, wtflag, ier) + +pointer sf # surface descriptor +double x[npts] # array of x values +double y[npts] # array of y values +double z[npts] # data array +double w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +begin + call dgszero (sf) + call dgsacpts (sf, x, y, z, w, npts, wtflag) + call dgssolve (sf, ier) +end diff --git a/math/gsurfit/gsfitr.x b/math/gsurfit/gsfitr.x new file mode 100644 index 00000000..f5321969 --- /dev/null +++ b/math/gsurfit/gsfitr.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSFIT -- Procedure to solve the normal equations for a surface. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# GS_NCOEFF(sf)-vector VECTOR. The Cholesky factorization of MATRIX +# is calculated and stored in CHOFAC. Forward and back substitution +# is used to solve for the GS_NCOEFF(sf)-vector COEFF. + +procedure gsfit (sf, x, y, z, w, npts, wtflag, ier) + +pointer sf # surface descriptor +real x[npts] # array of x values +real y[npts] # array of y values +real z[npts] # data array +real w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +begin + call gszero (sf) + call gsacpts (sf, x, y, z, w, npts, wtflag) + call gssolve (sf, ier) +end diff --git a/math/gsurfit/gsfree.gx b/math/gsurfit/gsfree.gx new file mode 100644 index 00000000..b97e960a --- /dev/null +++ b/math/gsurfit/gsfree.gx @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSFREE -- Procedure to free the surface descriptor + +$if (datatype == r) +procedure gsfree (sf) +$else +procedure dgsfree (sf) +$endif + +pointer sf # the surface descriptor +errchk mfree + +begin + if (sf == NULL) + return + + $if (datatype == r) + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + if (GS_MATRIX(sf) != NULL) + call mfree (GS_MATRIX(sf), TY_REAL) + if (GS_CHOFAC(sf) != NULL) + call mfree (GS_CHOFAC(sf), TY_REAL) + if (GS_VECTOR(sf) != NULL) + call mfree (GS_VECTOR(sf), TY_REAL) + if (GS_COEFF(sf) != NULL) + call mfree (GS_COEFF(sf), TY_REAL) + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + $else + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + if (GS_MATRIX(sf) != NULL) + call mfree (GS_MATRIX(sf), TY_DOUBLE) + if (GS_CHOFAC(sf) != NULL) + call mfree (GS_CHOFAC(sf), TY_DOUBLE) + if (GS_VECTOR(sf) != NULL) + call mfree (GS_VECTOR(sf), TY_DOUBLE) + if (GS_COEFF(sf) != NULL) + call mfree (GS_COEFF(sf), TY_DOUBLE) + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + $endif + + if (sf != NULL) + call mfree (sf, TY_STRUCT) +end diff --git a/math/gsurfit/gsfreed.x b/math/gsurfit/gsfreed.x new file mode 100644 index 00000000..498bf00c --- /dev/null +++ b/math/gsurfit/gsfreed.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "dgsurfitdef.h" + +# GSFREE -- Procedure to free the surface descriptor + +procedure dgsfree (sf) + +pointer sf # the surface descriptor +errchk mfree + +begin + if (sf == NULL) + return + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + if (GS_MATRIX(sf) != NULL) + call mfree (GS_MATRIX(sf), TY_DOUBLE) + if (GS_CHOFAC(sf) != NULL) + call mfree (GS_CHOFAC(sf), TY_DOUBLE) + if (GS_VECTOR(sf) != NULL) + call mfree (GS_VECTOR(sf), TY_DOUBLE) + if (GS_COEFF(sf) != NULL) + call mfree (GS_COEFF(sf), TY_DOUBLE) + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + + if (sf != NULL) + call mfree (sf, TY_STRUCT) +end diff --git a/math/gsurfit/gsfreer.x b/math/gsurfit/gsfreer.x new file mode 100644 index 00000000..95148363 --- /dev/null +++ b/math/gsurfit/gsfreer.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "gsurfitdef.h" + +# GSFREE -- Procedure to free the surface descriptor + +procedure gsfree (sf) + +pointer sf # the surface descriptor +errchk mfree + +begin + if (sf == NULL) + return + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + if (GS_MATRIX(sf) != NULL) + call mfree (GS_MATRIX(sf), TY_REAL) + if (GS_CHOFAC(sf) != NULL) + call mfree (GS_CHOFAC(sf), TY_REAL) + if (GS_VECTOR(sf) != NULL) + call mfree (GS_VECTOR(sf), TY_REAL) + if (GS_COEFF(sf) != NULL) + call mfree (GS_COEFF(sf), TY_REAL) + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + + if (sf != NULL) + call mfree (sf, TY_STRUCT) +end diff --git a/math/gsurfit/gsgcoeff.gx b/math/gsurfit/gsgcoeff.gx new file mode 100644 index 00000000..3d8a294d --- /dev/null +++ b/math/gsurfit/gsgcoeff.gx @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSGCOEFF -- Procedure to fetch a particular coefficient. +# If the requested coefficient is undefined then INDEF is returned. + +$if (datatype == r) +real procedure gsgcoeff (sf, xorder, yorder) +$else +double procedure dgsgcoeff (sf, xorder, yorder) +$endif + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent + +int i, n, maxorder, xincr + +begin + if ((xorder > GS_XORDER(sf)) || (yorder > GS_YORDER(sf))) + return (INDEF) + + switch (GS_XTERMS(sf)) { + case GS_XNONE: + if (yorder == 1) + n = xorder + else if (xorder == 1) + n = GS_NXCOEFF(sf) + yorder - 1 + else + return (INDEF) + case GS_XHALF: + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + if ((xorder + yorder) > maxorder) + return (INDEF) + n = xorder + xincr = GS_XORDER(sf) + do i = 2, yorder { + n = n + xincr + if ((i + GS_XORDER(sf) + 1) > maxorder) + xincr = xincr - 1 + } + case GS_XFULL: + n = xorder + (yorder - 1) * GS_NXCOEFF(sf) + } + + return (COEFF(GS_COEFF(sf) + n - 1)) +end diff --git a/math/gsurfit/gsgcoeffd.x b/math/gsurfit/gsgcoeffd.x new file mode 100644 index 00000000..32dead75 --- /dev/null +++ b/math/gsurfit/gsgcoeffd.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSGCOEFF -- Procedure to fetch a particular coefficient. +# If the requested coefficient is undefined then INDEF is returned. + +double procedure dgsgcoeff (sf, xorder, yorder) + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent + +int i, n, maxorder, xincr + +begin + if ((xorder > GS_XORDER(sf)) || (yorder > GS_YORDER(sf))) + return (INDEFD) + + switch (GS_XTERMS(sf)) { + case GS_XNONE: + if (yorder == 1) + n = xorder + else if (xorder == 1) + n = GS_NXCOEFF(sf) + yorder - 1 + else + return (INDEFD) + case GS_XHALF: + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + if ((xorder + yorder) > maxorder) + return (INDEFD) + n = xorder + xincr = GS_XORDER(sf) + do i = 2, yorder { + n = n + xincr + if ((i + GS_XORDER(sf) + 1) > maxorder) + xincr = xincr - 1 + } + case GS_XFULL: + n = xorder + (yorder - 1) * GS_NXCOEFF(sf) + } + + return (COEFF(GS_COEFF(sf) + n - 1)) +end diff --git a/math/gsurfit/gsgcoeffr.x b/math/gsurfit/gsgcoeffr.x new file mode 100644 index 00000000..45ef51e4 --- /dev/null +++ b/math/gsurfit/gsgcoeffr.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSGCOEFF -- Procedure to fetch a particular coefficient. +# If the requested coefficient is undefined then INDEF is returned. + +real procedure gsgcoeff (sf, xorder, yorder) + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent + +int i, n, maxorder, xincr + +begin + if ((xorder > GS_XORDER(sf)) || (yorder > GS_YORDER(sf))) + return (INDEFR) + + switch (GS_XTERMS(sf)) { + case GS_XNONE: + if (yorder == 1) + n = xorder + else if (xorder == 1) + n = GS_NXCOEFF(sf) + yorder - 1 + else + return (INDEFR) + case GS_XHALF: + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + if ((xorder + yorder) > maxorder) + return (INDEFR) + n = xorder + xincr = GS_XORDER(sf) + do i = 2, yorder { + n = n + xincr + if ((i + GS_XORDER(sf) + 1) > maxorder) + xincr = xincr - 1 + } + case GS_XFULL: + n = xorder + (yorder - 1) * GS_NXCOEFF(sf) + } + + return (COEFF(GS_COEFF(sf) + n - 1)) +end diff --git a/math/gsurfit/gsinit.gx b/math/gsurfit/gsinit.gx new file mode 100644 index 00000000..1d94c027 --- /dev/null +++ b/math/gsurfit/gsinit.gx @@ -0,0 +1,124 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSINIT -- Procedure to initialize the surface descriptor. + +$if (datatype == r) +procedure gsinit (sf, surface_type, xorder, yorder, xterms, xmin, xmax, + ymin, ymax) +$else +procedure dgsinit (sf, surface_type, xorder, yorder, xterms, xmin, xmax, + ymin, ymax) +$endif + +pointer sf # surface descriptor +int surface_type # type of surface to be fitted +int xorder # x order of surface to be fit +int yorder # y order of surface to be fit +int xterms # presence of cross terms +PIXEL xmin # minimum value of x +PIXEL xmax # maximum value of x +PIXEL ymin # minimum value of y +PIXEL ymax # maximum value of y + +int order +errchk malloc, calloc + +begin + if (xorder < 1 || yorder < 1) + call error (0, "GSINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "GSINIT: xmax <= xmin.") + if (ymax <= ymin) + call error (0, "GSINIT: ymax <= ymin.") + + # allocate space for the gsurve descriptor + call calloc (sf, LEN_GSSTRUCT, TY_STRUCT) + + # specify the surface-type dependent parameters + switch (surface_type) { + case GS_CHEBYSHEV, GS_LEGENDRE: + GS_XORDER(sf) = xorder + GS_YORDER(sf) = yorder + GS_NXCOEFF(sf) = xorder + GS_NYCOEFF(sf) = yorder + GS_XTERMS(sf) = xterms + switch (xterms) { + case GS_XNONE: + GS_NCOEFF(sf) = xorder + yorder - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = xorder * yorder - order * (order - 1) / 2 + default: + GS_NCOEFF(sf) = xorder * yorder + } + GS_XRANGE(sf) = 2. / (xmax - xmin) + GS_XMAXMIN(sf) = - (xmax + xmin) / 2. + GS_YRANGE(sf) = 2. / (ymax - ymin) + GS_YMAXMIN(sf) = - (ymax + ymin) / 2. + case GS_POLYNOMIAL: + GS_XORDER(sf) = xorder + GS_YORDER(sf) = yorder + GS_NXCOEFF(sf) = xorder + GS_NYCOEFF(sf) = yorder + GS_XTERMS(sf) = xterms + switch (xterms) { + case GS_XNONE: + GS_NCOEFF(sf) = xorder + yorder - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = xorder * yorder - order * (order - 1) / 2 + default: + GS_NCOEFF(sf) = xorder * yorder + } + GS_XRANGE(sf) = 1.0 + GS_XMAXMIN(sf) = 0.0 + GS_YRANGE(sf) = 1.0 + GS_YMAXMIN(sf) = 0.0 + default: + call error (0, "GSINIT: Unknown surface type.") + } + + # set remaining parameters + GS_TYPE(sf) = surface_type + GS_XREF(sf) = INDEF + GS_YREF(sf) = INDEF + GS_ZREF(sf) = INDEF + GS_XMIN(sf) = xmin + GS_XMAX(sf) = xmax + GS_YMAX(sf) = ymax + GS_YMIN(sf) = ymin + + # allocate space for the matrix and vectors + switch (surface_type ) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + $if (datatype == r) + call calloc (GS_MATRIX(sf), GS_NCOEFF(sf) ** 2, TY_REAL) + call calloc (GS_CHOFAC(sf), GS_NCOEFF(sf) ** 2, TY_REAL) + call calloc (GS_VECTOR(sf), GS_NCOEFF(sf), TY_REAL) + call calloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_REAL) + $else + call calloc (GS_MATRIX(sf), GS_NCOEFF(sf) ** 2, TY_DOUBLE) + call calloc (GS_CHOFAC(sf), GS_NCOEFF(sf) ** 2, TY_DOUBLE) + call calloc (GS_VECTOR(sf), GS_NCOEFF(sf), TY_DOUBLE) + call calloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_DOUBLE) + $endif + default: + call error (0, "GSINIT: Unknown surface type.") + } + + # initialize pointer to basis functions to null + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL + GS_WZ(sf) = NULL + + # set data points counter + GS_NPTS(sf) = 0 +end diff --git a/math/gsurfit/gsinitd.x b/math/gsurfit/gsinitd.x new file mode 100644 index 00000000..ad8e2650 --- /dev/null +++ b/math/gsurfit/gsinitd.x @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSINIT -- Procedure to initialize the surface descriptor. + +procedure dgsinit (sf, surface_type, xorder, yorder, xterms, xmin, xmax, + ymin, ymax) + +pointer sf # surface descriptor +int surface_type # type of surface to be fitted +int xorder # x order of surface to be fit +int yorder # y order of surface to be fit +int xterms # presence of cross terms +double xmin # minimum value of x +double xmax # maximum value of x +double ymin # minimum value of y +double ymax # maximum value of y + +int order +errchk malloc, calloc + +begin + if (xorder < 1 || yorder < 1) + call error (0, "GSINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "GSINIT: xmax <= xmin.") + if (ymax <= ymin) + call error (0, "GSINIT: ymax <= ymin.") + + # allocate space for the gsurve descriptor + call calloc (sf, LEN_GSSTRUCT, TY_STRUCT) + + # specify the surface-type dependent parameters + switch (surface_type) { + case GS_CHEBYSHEV, GS_LEGENDRE: + GS_XORDER(sf) = xorder + GS_YORDER(sf) = yorder + GS_NXCOEFF(sf) = xorder + GS_NYCOEFF(sf) = yorder + GS_XTERMS(sf) = xterms + switch (xterms) { + case GS_XNONE: + GS_NCOEFF(sf) = xorder + yorder - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = xorder * yorder - order * (order - 1) / 2 + default: + GS_NCOEFF(sf) = xorder * yorder + } + GS_XRANGE(sf) = 2. / (xmax - xmin) + GS_XMAXMIN(sf) = - (xmax + xmin) / 2. + GS_YRANGE(sf) = 2. / (ymax - ymin) + GS_YMAXMIN(sf) = - (ymax + ymin) / 2. + case GS_POLYNOMIAL: + GS_XORDER(sf) = xorder + GS_YORDER(sf) = yorder + GS_NXCOEFF(sf) = xorder + GS_NYCOEFF(sf) = yorder + GS_XTERMS(sf) = xterms + switch (xterms) { + case GS_XNONE: + GS_NCOEFF(sf) = xorder + yorder - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = xorder * yorder - order * (order - 1) / 2 + default: + GS_NCOEFF(sf) = xorder * yorder + } + GS_XRANGE(sf) = 1.0 + GS_XMAXMIN(sf) = 0.0 + GS_YRANGE(sf) = 1.0 + GS_YMAXMIN(sf) = 0.0 + default: + call error (0, "GSINIT: Unknown surface type.") + } + + # set remaining parameters + GS_TYPE(sf) = surface_type + GS_XREF(sf) = INDEFD + GS_YREF(sf) = INDEFD + GS_ZREF(sf) = INDEFD + GS_XMIN(sf) = xmin + GS_XMAX(sf) = xmax + GS_YMAX(sf) = ymax + GS_YMIN(sf) = ymin + + # allocate space for the matrix and vectors + switch (surface_type ) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + call calloc (GS_MATRIX(sf), GS_NCOEFF(sf) ** 2, TY_DOUBLE) + call calloc (GS_CHOFAC(sf), GS_NCOEFF(sf) ** 2, TY_DOUBLE) + call calloc (GS_VECTOR(sf), GS_NCOEFF(sf), TY_DOUBLE) + call calloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_DOUBLE) + default: + call error (0, "GSINIT: Unknown surface type.") + } + + # initialize pointer to basis functions to null + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL + GS_WZ(sf) = NULL + + # set data points counter + GS_NPTS(sf) = 0 +end diff --git a/math/gsurfit/gsinitr.x b/math/gsurfit/gsinitr.x new file mode 100644 index 00000000..8c44d6e4 --- /dev/null +++ b/math/gsurfit/gsinitr.x @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSINIT -- Procedure to initialize the surface descriptor. + +procedure gsinit (sf, surface_type, xorder, yorder, xterms, xmin, xmax, + ymin, ymax) + +pointer sf # surface descriptor +int surface_type # type of surface to be fitted +int xorder # x order of surface to be fit +int yorder # y order of surface to be fit +int xterms # presence of cross terms +real xmin # minimum value of x +real xmax # maximum value of x +real ymin # minimum value of y +real ymax # maximum value of y + +int order +errchk malloc, calloc + +begin + if (xorder < 1 || yorder < 1) + call error (0, "GSINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "GSINIT: xmax <= xmin.") + if (ymax <= ymin) + call error (0, "GSINIT: ymax <= ymin.") + + # allocate space for the gsurve descriptor + call calloc (sf, LEN_GSSTRUCT, TY_STRUCT) + + # specify the surface-type dependent parameters + switch (surface_type) { + case GS_CHEBYSHEV, GS_LEGENDRE: + GS_XORDER(sf) = xorder + GS_YORDER(sf) = yorder + GS_NXCOEFF(sf) = xorder + GS_NYCOEFF(sf) = yorder + GS_XTERMS(sf) = xterms + switch (xterms) { + case GS_XNONE: + GS_NCOEFF(sf) = xorder + yorder - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = xorder * yorder - order * (order - 1) / 2 + default: + GS_NCOEFF(sf) = xorder * yorder + } + GS_XRANGE(sf) = 2. / (xmax - xmin) + GS_XMAXMIN(sf) = - (xmax + xmin) / 2. + GS_YRANGE(sf) = 2. / (ymax - ymin) + GS_YMAXMIN(sf) = - (ymax + ymin) / 2. + case GS_POLYNOMIAL: + GS_XORDER(sf) = xorder + GS_YORDER(sf) = yorder + GS_NXCOEFF(sf) = xorder + GS_NYCOEFF(sf) = yorder + GS_XTERMS(sf) = xterms + switch (xterms) { + case GS_XNONE: + GS_NCOEFF(sf) = xorder + yorder - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = xorder * yorder - order * (order - 1) / 2 + default: + GS_NCOEFF(sf) = xorder * yorder + } + GS_XRANGE(sf) = 1.0 + GS_XMAXMIN(sf) = 0.0 + GS_YRANGE(sf) = 1.0 + GS_YMAXMIN(sf) = 0.0 + default: + call error (0, "GSINIT: Unknown surface type.") + } + + # set remaining parameters + GS_TYPE(sf) = surface_type + GS_XREF(sf) = INDEFR + GS_YREF(sf) = INDEFR + GS_ZREF(sf) = INDEFR + GS_XMIN(sf) = xmin + GS_XMAX(sf) = xmax + GS_YMAX(sf) = ymax + GS_YMIN(sf) = ymin + + # allocate space for the matrix and vectors + switch (surface_type ) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + call calloc (GS_MATRIX(sf), GS_NCOEFF(sf) ** 2, TY_REAL) + call calloc (GS_CHOFAC(sf), GS_NCOEFF(sf) ** 2, TY_REAL) + call calloc (GS_VECTOR(sf), GS_NCOEFF(sf), TY_REAL) + call calloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_REAL) + default: + call error (0, "GSINIT: Unknown surface type.") + } + + # initialize pointer to basis functions to null + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL + GS_WZ(sf) = NULL + + # set data points counter + GS_NPTS(sf) = 0 +end diff --git a/math/gsurfit/gsrefit.gx b/math/gsurfit/gsrefit.gx new file mode 100644 index 00000000..00327abb --- /dev/null +++ b/math/gsurfit/gsrefit.gx @@ -0,0 +1,174 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSREFIT -- Procedure to refit the surface assuming that the x, y and w +# values and the matrices MATRIX and CHOFAC have remained unchanged. It +# is necessary only to accumulate a new VECTOR. The new coefficients +# are calculated by forward and back subsitution and stored in COEFF. + +$if (datatype == r) +procedure gsrefit (sf, x, y, z, w, ier) +$else +procedure dgsrefit (sf, x, y, z, w, ier) +$endif + +pointer sf # surface descriptor +PIXEL x[ARB] # array of x values +PIXEL y[ARB] # array of y values +PIXEL z[ARB] # data array +PIXEL w[ARB] # array of weights +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int k, l +int xorder, nfree, maxorder +pointer sp, vzptr, vindex, bxptr, byptr, bwz + +PIXEL adot$t() + +errchk smark, salloc, sfree + +begin + # clear accumulator + call aclr$t (VECTOR(GS_VECTOR(sf)), GS_NCOEFF(sf)) + + # if first call to gsefit calculate basis functions + if (GS_XBASIS(sf) == NULL || GS_YBASIS(sf) == NULL) { + + $if (datatype == r) + call malloc (GS_WZ(sf), GS_NPTS(sf), TY_REAL) + $else + call malloc (GS_WZ(sf), GS_NPTS(sf), TY_DOUBLE) + $endif + + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + $if (datatype == r) + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_REAL) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_REAL) + $else + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_DOUBLE) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_DOUBLE) + $endif + call $tgs_bleg (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bleg (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + $if (datatype == r) + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_REAL) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_REAL) + $else + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_DOUBLE) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_DOUBLE) + $endif + call $tgs_bcheb (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bcheb (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + $if (datatype == r) + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_REAL) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_REAL) + $else + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_DOUBLE) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_DOUBLE) + $endif + call $tgs_bpol (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_bpol (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSREFIT: Unknown curve type.") + } + + } + + call smark (sp) + $if (datatype == r) + call salloc (bwz, GS_NPTS(sf), TY_REAL) + $else + call salloc (bwz, GS_NPTS(sf), TY_DOUBLE) + $endif + + # index the pointers + vzptr = GS_VECTOR(sf) - 1 + byptr = GS_YBASIS(sf) + + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + call amul$t (w, z, Mem$t[GS_WZ(sf)], GS_NPTS(sf)) + xorder = GS_XORDER(sf) + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + + do l = 1, GS_YORDER(sf) { + call amul$t (Mem$t[GS_WZ(sf)], YBASIS(byptr), Mem$t[bwz], + GS_NPTS(sf)) + bxptr = GS_XBASIS(sf) + do k = 1, xorder { + vindex = vzptr + k + VECTOR(vindex) = VECTOR(vindex) + adot$t (Mem$t[bwz], + XBASIS(bxptr), GS_NPTS(sf)) + bxptr = bxptr + GS_NPTS(sf) + } + + vzptr = vzptr + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + byptr = byptr + GS_NPTS(sf) + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # test for number of degrees of freedom + ier = OK + nfree = GS_NPTS(sf) - GS_NCOEFF(sf) + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the values of the coefficients + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # solve for the coefficients by forward and back substitution + call $tgschoslv (CHOFAC(GS_CHOFAC(sf)), GS_NCOEFF(sf), + GS_NCOEFF(sf), VECTOR(GS_VECTOR(sf)), COEFF(GS_COEFF(sf))) + default: + call error (0, "GSSOLVE: Illegal surface type.") + } + + # release the space + call sfree (sp) +end diff --git a/math/gsurfit/gsrefitd.x b/math/gsurfit/gsrefitd.x new file mode 100644 index 00000000..a7f7d706 --- /dev/null +++ b/math/gsurfit/gsrefitd.x @@ -0,0 +1,137 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSREFIT -- Procedure to refit the surface assuming that the x, y and w +# values and the matrices MATRIX and CHOFAC have remained unchanged. It +# is necessary only to accumulate a new VECTOR. The new coefficients +# are calculated by forward and back subsitution and stored in COEFF. + +procedure dgsrefit (sf, x, y, z, w, ier) + +pointer sf # surface descriptor +double x[ARB] # array of x values +double y[ARB] # array of y values +double z[ARB] # data array +double w[ARB] # array of weights +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int k, l +int xorder, nfree, maxorder +pointer sp, vzptr, vindex, bxptr, byptr, bwz + +double adotd() + +errchk smark, salloc, sfree + +begin + # clear accumulator + call aclrd (VECTOR(GS_VECTOR(sf)), GS_NCOEFF(sf)) + + # if first call to gsefit calculate basis functions + if (GS_XBASIS(sf) == NULL || GS_YBASIS(sf) == NULL) { + + call malloc (GS_WZ(sf), GS_NPTS(sf), TY_DOUBLE) + + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_DOUBLE) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_DOUBLE) + call dgs_bleg (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bleg (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_DOUBLE) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_DOUBLE) + call dgs_bcheb (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bcheb (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_DOUBLE) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_DOUBLE) + call dgs_bpol (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_bpol (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSREFIT: Unknown curve type.") + } + + } + + call smark (sp) + call salloc (bwz, GS_NPTS(sf), TY_DOUBLE) + + # index the pointers + vzptr = GS_VECTOR(sf) - 1 + byptr = GS_YBASIS(sf) + + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + call amuld (w, z, Memd[GS_WZ(sf)], GS_NPTS(sf)) + xorder = GS_XORDER(sf) + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + + do l = 1, GS_YORDER(sf) { + call amuld (Memd[GS_WZ(sf)], YBASIS(byptr), Memd[bwz], + GS_NPTS(sf)) + bxptr = GS_XBASIS(sf) + do k = 1, xorder { + vindex = vzptr + k + VECTOR(vindex) = VECTOR(vindex) + adotd (Memd[bwz], + XBASIS(bxptr), GS_NPTS(sf)) + bxptr = bxptr + GS_NPTS(sf) + } + + vzptr = vzptr + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + byptr = byptr + GS_NPTS(sf) + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # test for number of degrees of freedom + ier = OK + nfree = GS_NPTS(sf) - GS_NCOEFF(sf) + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the values of the coefficients + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # solve for the coefficients by forward and back substitution + call dgschoslv (CHOFAC(GS_CHOFAC(sf)), GS_NCOEFF(sf), + GS_NCOEFF(sf), VECTOR(GS_VECTOR(sf)), COEFF(GS_COEFF(sf))) + default: + call error (0, "GSSOLVE: Illegal surface type.") + } + + # release the space + call sfree (sp) +end diff --git a/math/gsurfit/gsrefitr.x b/math/gsurfit/gsrefitr.x new file mode 100644 index 00000000..6b550084 --- /dev/null +++ b/math/gsurfit/gsrefitr.x @@ -0,0 +1,137 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSREFIT -- Procedure to refit the surface assuming that the x, y and w +# values and the matrices MATRIX and CHOFAC have remained unchanged. It +# is necessary only to accumulate a new VECTOR. The new coefficients +# are calculated by forward and back subsitution and stored in COEFF. + +procedure gsrefit (sf, x, y, z, w, ier) + +pointer sf # surface descriptor +real x[ARB] # array of x values +real y[ARB] # array of y values +real z[ARB] # data array +real w[ARB] # array of weights +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int k, l +int xorder, nfree, maxorder +pointer sp, vzptr, vindex, bxptr, byptr, bwz + +real adotr() + +errchk smark, salloc, sfree + +begin + # clear accumulator + call aclrr (VECTOR(GS_VECTOR(sf)), GS_NCOEFF(sf)) + + # if first call to gsefit calculate basis functions + if (GS_XBASIS(sf) == NULL || GS_YBASIS(sf) == NULL) { + + call malloc (GS_WZ(sf), GS_NPTS(sf), TY_REAL) + + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_REAL) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_REAL) + call rgs_bleg (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bleg (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_REAL) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_REAL) + call rgs_bcheb (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bcheb (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call malloc (GS_XBASIS(sf), GS_NPTS(sf) * GS_XORDER(sf), + TY_REAL) + call malloc (GS_YBASIS(sf), GS_NPTS(sf) * GS_YORDER(sf), + TY_REAL) + call rgs_bpol (x, GS_NPTS(sf), GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_bpol (y, GS_NPTS(sf), GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSREFIT: Unknown curve type.") + } + + } + + call smark (sp) + call salloc (bwz, GS_NPTS(sf), TY_REAL) + + # index the pointers + vzptr = GS_VECTOR(sf) - 1 + byptr = GS_YBASIS(sf) + + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + call amulr (w, z, Memr[GS_WZ(sf)], GS_NPTS(sf)) + xorder = GS_XORDER(sf) + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + + do l = 1, GS_YORDER(sf) { + call amulr (Memr[GS_WZ(sf)], YBASIS(byptr), Memr[bwz], + GS_NPTS(sf)) + bxptr = GS_XBASIS(sf) + do k = 1, xorder { + vindex = vzptr + k + VECTOR(vindex) = VECTOR(vindex) + adotr (Memr[bwz], + XBASIS(bxptr), GS_NPTS(sf)) + bxptr = bxptr + GS_NPTS(sf) + } + + vzptr = vzptr + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + byptr = byptr + GS_NPTS(sf) + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # test for number of degrees of freedom + ier = OK + nfree = GS_NPTS(sf) - GS_NCOEFF(sf) + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the values of the coefficients + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # solve for the coefficients by forward and back substitution + call rgschoslv (CHOFAC(GS_CHOFAC(sf)), GS_NCOEFF(sf), + GS_NCOEFF(sf), VECTOR(GS_VECTOR(sf)), COEFF(GS_COEFF(sf))) + default: + call error (0, "GSSOLVE: Illegal surface type.") + } + + # release the space + call sfree (sp) +end diff --git a/math/gsurfit/gsreject.gx b/math/gsurfit/gsreject.gx new file mode 100644 index 00000000..b5d8e01e --- /dev/null +++ b/math/gsurfit/gsreject.gx @@ -0,0 +1,188 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSREJ-- Procedure to reject a point from the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +$if (datatype == r) +procedure gsrej (sf, x, y, z, w, wtflag) +$else +procedure dgsrej (sf, x, y, z, w, wtflag) +$endif + +pointer sf # surface descriptor +PIXEL x # x value +PIXEL y # y value +PIXEL z # z value +PIXEL w # weight +int wtflag # type of weighting + +int ii, j, k, l +int maxorder, xorder, xxorder, xindex, yindex, ntimes +pointer sp, vzptr, mzptr, xbptr, ybptr +PIXEL byw, bw + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) - 1 + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + $if (datatype == r) + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + $else + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + $endif + } + + # calculate weight + switch (wtflag) { + case WTS_UNIFORM: + w = 1. + case WTS_USER: + # user supplied weights + default: + w = 1. + } + + # allocate space for the basis functions + call smark (sp) + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + $if (datatype == r) + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + $else + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + $endif + call $tgs_b1leg (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_b1leg (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + $if (datatype == r) + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + $else + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + $endif + call $tgs_b1cheb (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_b1cheb (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + $if (datatype == r) + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + $else + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + $endif + call $tgs_b1pol (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call $tgs_b1pol (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSACCUM: Illegal curve type.") + } + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) - 1 + xbptr = GS_XBASIS(sf) - 1 + ybptr = GS_YBASIS(sf) - 1 + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + ntimes = 0 + xorder = GS_XORDER(sf) + do l = 1, GS_YORDER(sf) { + + byw = w * YBASIS(ybptr+l) + do k = 1, xorder { + bw = byw * XBASIS(xbptr+k) + VECTOR(vzptr+k) = VECTOR(vzptr+k) - bw * z + ii = 1 + xindex = k + yindex = l + xxorder = xorder + do j = k + ntimes, GS_NCOEFF(sf) { + MATRIX(mzptr+ii) = MATRIX(mzptr+ii) - bw * + XBASIS(xbptr+xindex) * YBASIS(ybptr+yindex) + if (mod (xindex, xxorder) == 0) { + xindex = 1 + yindex = yindex + 1 + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((yindex + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else + xindex = xindex + 1 + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsrejectd.x b/math/gsurfit/gsrejectd.x new file mode 100644 index 00000000..da1d71dd --- /dev/null +++ b/math/gsurfit/gsrejectd.x @@ -0,0 +1,153 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSREJ-- Procedure to reject a point from the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +procedure dgsrej (sf, x, y, z, w, wtflag) + +pointer sf # surface descriptor +double x # x value +double y # y value +double z # z value +double w # weight +int wtflag # type of weighting + +int ii, j, k, l +int maxorder, xorder, xxorder, xindex, yindex, ntimes +pointer sp, vzptr, mzptr, xbptr, ybptr +double byw, bw + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) - 1 + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + } + + # calculate weight + switch (wtflag) { + case WTS_UNIFORM: + w = 1. + case WTS_USER: + # user supplied weights + default: + w = 1. + } + + # allocate space for the basis functions + call smark (sp) + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + call dgs_b1leg (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_b1leg (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + call dgs_b1cheb (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_b1cheb (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_DOUBLE) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_DOUBLE) + call dgs_b1pol (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call dgs_b1pol (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSACCUM: Illegal curve type.") + } + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) - 1 + xbptr = GS_XBASIS(sf) - 1 + ybptr = GS_YBASIS(sf) - 1 + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + ntimes = 0 + xorder = GS_XORDER(sf) + do l = 1, GS_YORDER(sf) { + + byw = w * YBASIS(ybptr+l) + do k = 1, xorder { + bw = byw * XBASIS(xbptr+k) + VECTOR(vzptr+k) = VECTOR(vzptr+k) - bw * z + ii = 1 + xindex = k + yindex = l + xxorder = xorder + do j = k + ntimes, GS_NCOEFF(sf) { + MATRIX(mzptr+ii) = MATRIX(mzptr+ii) - bw * + XBASIS(xbptr+xindex) * YBASIS(ybptr+yindex) + if (mod (xindex, xxorder) == 0) { + xindex = 1 + yindex = yindex + 1 + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((yindex + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else + xindex = xindex + 1 + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsrejectr.x b/math/gsurfit/gsrejectr.x new file mode 100644 index 00000000..fea86cef --- /dev/null +++ b/math/gsurfit/gsrejectr.x @@ -0,0 +1,153 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSREJ-- Procedure to reject a point from the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the GS_NCOEFF(sf) ** 2 matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. +# The inner product +# of the basis functions and the data ordinates are stored in the +# NCOEFF(sf)-vector VECTOR. + +procedure gsrej (sf, x, y, z, w, wtflag) + +pointer sf # surface descriptor +real x # x value +real y # y value +real z # z value +real w # weight +int wtflag # type of weighting + +int ii, j, k, l +int maxorder, xorder, xxorder, xindex, yindex, ntimes +pointer sp, vzptr, mzptr, xbptr, ybptr +real byw, bw + +begin + # increment the number of points + GS_NPTS(sf) = GS_NPTS(sf) - 1 + + # remove basis functions calculated by any previous gsrefit call + if (GS_XBASIS(sf) != NULL || GS_YBASIS(sf) != NULL) { + + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + } + + # calculate weight + switch (wtflag) { + case WTS_UNIFORM: + w = 1. + case WTS_USER: + # user supplied weights + default: + w = 1. + } + + # allocate space for the basis functions + call smark (sp) + + # calculate the non-zero basis functions + switch (GS_TYPE(sf)) { + case GS_LEGENDRE: + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + call rgs_b1leg (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_b1leg (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_CHEBYSHEV: + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + call rgs_b1cheb (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_b1cheb (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + case GS_POLYNOMIAL: + call salloc (GS_XBASIS(sf), GS_XORDER(sf), TY_REAL) + call salloc (GS_YBASIS(sf), GS_YORDER(sf), TY_REAL) + call rgs_b1pol (x, GS_XORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), XBASIS(GS_XBASIS(sf))) + call rgs_b1pol (y, GS_YORDER(sf), GS_YMAXMIN(sf), + GS_YRANGE(sf), YBASIS(GS_YBASIS(sf))) + default: + call error (0, "GSACCUM: Illegal curve type.") + } + + # one index the pointers + vzptr = GS_VECTOR(sf) - 1 + mzptr = GS_MATRIX(sf) - 1 + xbptr = GS_XBASIS(sf) - 1 + ybptr = GS_YBASIS(sf) - 1 + + switch (GS_TYPE(sf)) { + + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + ntimes = 0 + xorder = GS_XORDER(sf) + do l = 1, GS_YORDER(sf) { + + byw = w * YBASIS(ybptr+l) + do k = 1, xorder { + bw = byw * XBASIS(xbptr+k) + VECTOR(vzptr+k) = VECTOR(vzptr+k) - bw * z + ii = 1 + xindex = k + yindex = l + xxorder = xorder + do j = k + ntimes, GS_NCOEFF(sf) { + MATRIX(mzptr+ii) = MATRIX(mzptr+ii) - bw * + XBASIS(xbptr+xindex) * YBASIS(ybptr+yindex) + if (mod (xindex, xxorder) == 0) { + xindex = 1 + yindex = yindex + 1 + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xxorder = 1 + case GS_XHALF: + if ((yindex + GS_XORDER(sf)) > maxorder) + xxorder = xxorder - 1 + default: + ; + } + } else + xindex = xindex + 1 + ii = ii + 1 + } + mzptr = mzptr + GS_NCOEFF(sf) + } + + vzptr = vzptr + xorder + ntimes = ntimes + xorder + switch (GS_XTERMS(sf)) { + case GS_XNONE: + xorder = 1 + case GS_XHALF: + if ((l + GS_XORDER(sf) + 1) > maxorder) + xorder = xorder - 1 + default: + ; + } + } + + default: + call error (0, "GSACCUM: Unknown curve type.") + } + + # release the space + call sfree (sp) + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL +end diff --git a/math/gsurfit/gsrestore.gx b/math/gsurfit/gsrestore.gx new file mode 100644 index 00000000..f8ced0a8 --- /dev/null +++ b/math/gsurfit/gsrestore.gx @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSRESTORE -- Procedure to restore the surface fit stored by GSSAVE +# to the surface descriptor for use by the evaluating routines. The +# surface parameters, surface type, xorder (or number of polynomial +# pieces in x), yorder (or number of polynomial pieces in y), xterms, +# xmin, xmax and ymin and ymax, are stored in the first +# eight elements of the real array fit, followed by the GS_NCOEFF(sf) +# surface coefficients. + +$if (datatype == r) +procedure gsrestore (sf, fit) +$else +procedure dgsrestore (sf, fit) +$endif + +pointer sf # surface descriptor +PIXEL fit[ARB] # array containing the surface parameters and + # coefficients + +int surface_type, xorder, yorder, order +PIXEL xmin, xmax, ymin, ymax + +begin + # allocate space for the surface descriptor + call calloc (sf, LEN_GSSTRUCT, TY_STRUCT) + + xorder = nint (GS_SAVEXORDER(fit)) + if (xorder < 1) + call error (0, "GSRESTORE: Illegal x order.") + yorder = nint (GS_SAVEYORDER(fit)) + if (yorder < 1) + call error (0, "GSRESTORE: Illegal y order.") + + xmin = GS_SAVEXMIN(fit) + xmax = GS_SAVEXMAX(fit) + if (xmax <= xmin) + call error (0, "GSRESTORE: Illegal x range.") + ymin = GS_SAVEYMIN(fit) + ymax = GS_SAVEYMAX(fit) + if (ymax <= ymin) + call error (0, "GSRESTORE: Illegal y range.") + + # set surface type dependent surface descriptor parameters + surface_type = nint (GS_SAVETYPE(fit)) + switch (surface_type) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf) = xorder + GS_XORDER(sf) = xorder + GS_XMIN(sf) = xmin + GS_XMAX(sf) = xmax + GS_XRANGE(sf) = PIXEL(2.0) / (xmax - xmin) + GS_XMAXMIN(sf) = - (xmax + xmin) / PIXEL(2.0) + GS_NYCOEFF(sf) = yorder + GS_YORDER(sf) = yorder + GS_YMIN(sf) = ymin + GS_YMAX(sf) = ymax + GS_YRANGE(sf) = PIXEL(2.0) / (ymax - ymin) + GS_YMAXMIN(sf) = - (ymax + ymin) / PIXEL(2.0) + GS_XTERMS(sf) = GS_SAVEXTERMS(fit) + switch (GS_XTERMS(sf)) { + case GS_XNONE: + GS_NCOEFF(sf) = GS_NXCOEFF(sf) + GS_NYCOEFF(sf) - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = GS_NXCOEFF(sf) * GS_NYCOEFF(sf) - order * + (order - 1) / 2 + case GS_XFULL: + GS_NCOEFF(sf) = GS_NXCOEFF(sf) * GS_NYCOEFF(sf) + } + default: + call error (0, "GSRESTORE: Unknown surface type.") + } + + # set remaining curve parameters + GS_TYPE(sf) = surface_type + + # allocate space for the coefficient array + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL + GS_MATRIX(sf) = NULL + GS_CHOFAC(sf) = NULL + GS_VECTOR(sf) = NULL + GS_COEFF(sf) = NULL + GS_WZ(sf) = NULL + + $if (datatype == r) + call malloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_REAL) + $else + call malloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_DOUBLE) + $endif + + # restore coefficient array + call amov$t (fit[GS_SAVECOEFF+1], COEFF(GS_COEFF(sf)), GS_NCOEFF(sf)) +end diff --git a/math/gsurfit/gsrestored.x b/math/gsurfit/gsrestored.x new file mode 100644 index 00000000..11008ec2 --- /dev/null +++ b/math/gsurfit/gsrestored.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSRESTORE -- Procedure to restore the surface fit stored by GSSAVE +# to the surface descriptor for use by the evaluating routines. The +# surface parameters, surface type, xorder (or number of polynomial +# pieces in x), yorder (or number of polynomial pieces in y), xterms, +# xmin, xmax and ymin and ymax, are stored in the first +# eight elements of the real array fit, followed by the GS_NCOEFF(sf) +# surface coefficients. + +procedure dgsrestore (sf, fit) + +pointer sf # surface descriptor +double fit[ARB] # array containing the surface parameters and + # coefficients + +int surface_type, xorder, yorder, order +double xmin, xmax, ymin, ymax + +begin + # allocate space for the surface descriptor + call calloc (sf, LEN_GSSTRUCT, TY_STRUCT) + + xorder = nint (GS_SAVEXORDER(fit)) + if (xorder < 1) + call error (0, "GSRESTORE: Illegal x order.") + yorder = nint (GS_SAVEYORDER(fit)) + if (yorder < 1) + call error (0, "GSRESTORE: Illegal y order.") + + xmin = GS_SAVEXMIN(fit) + xmax = GS_SAVEXMAX(fit) + if (xmax <= xmin) + call error (0, "GSRESTORE: Illegal x range.") + ymin = GS_SAVEYMIN(fit) + ymax = GS_SAVEYMAX(fit) + if (ymax <= ymin) + call error (0, "GSRESTORE: Illegal y range.") + + # set surface type dependent surface descriptor parameters + surface_type = nint (GS_SAVETYPE(fit)) + switch (surface_type) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf) = xorder + GS_XORDER(sf) = xorder + GS_XMIN(sf) = xmin + GS_XMAX(sf) = xmax + GS_XRANGE(sf) = double(2.0) / (xmax - xmin) + GS_XMAXMIN(sf) = - (xmax + xmin) / double(2.0) + GS_NYCOEFF(sf) = yorder + GS_YORDER(sf) = yorder + GS_YMIN(sf) = ymin + GS_YMAX(sf) = ymax + GS_YRANGE(sf) = double(2.0) / (ymax - ymin) + GS_YMAXMIN(sf) = - (ymax + ymin) / double(2.0) + GS_XTERMS(sf) = GS_SAVEXTERMS(fit) + switch (GS_XTERMS(sf)) { + case GS_XNONE: + GS_NCOEFF(sf) = GS_NXCOEFF(sf) + GS_NYCOEFF(sf) - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = GS_NXCOEFF(sf) * GS_NYCOEFF(sf) - order * + (order - 1) / 2 + case GS_XFULL: + GS_NCOEFF(sf) = GS_NXCOEFF(sf) * GS_NYCOEFF(sf) + } + default: + call error (0, "GSRESTORE: Unknown surface type.") + } + + # set remaining curve parameters + GS_TYPE(sf) = surface_type + + # allocate space for the coefficient array + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL + GS_MATRIX(sf) = NULL + GS_CHOFAC(sf) = NULL + GS_VECTOR(sf) = NULL + GS_COEFF(sf) = NULL + GS_WZ(sf) = NULL + + call malloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_DOUBLE) + + # restore coefficient array + call amovd (fit[GS_SAVECOEFF+1], COEFF(GS_COEFF(sf)), GS_NCOEFF(sf)) +end diff --git a/math/gsurfit/gsrestorer.x b/math/gsurfit/gsrestorer.x new file mode 100644 index 00000000..0b7b0e56 --- /dev/null +++ b/math/gsurfit/gsrestorer.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSRESTORE -- Procedure to restore the surface fit stored by GSSAVE +# to the surface descriptor for use by the evaluating routines. The +# surface parameters, surface type, xorder (or number of polynomial +# pieces in x), yorder (or number of polynomial pieces in y), xterms, +# xmin, xmax and ymin and ymax, are stored in the first +# eight elements of the real array fit, followed by the GS_NCOEFF(sf) +# surface coefficients. + +procedure gsrestore (sf, fit) + +pointer sf # surface descriptor +real fit[ARB] # array containing the surface parameters and + # coefficients + +int surface_type, xorder, yorder, order +real xmin, xmax, ymin, ymax + +begin + # allocate space for the surface descriptor + call calloc (sf, LEN_GSSTRUCT, TY_STRUCT) + + xorder = nint (GS_SAVEXORDER(fit)) + if (xorder < 1) + call error (0, "GSRESTORE: Illegal x order.") + yorder = nint (GS_SAVEYORDER(fit)) + if (yorder < 1) + call error (0, "GSRESTORE: Illegal y order.") + + xmin = GS_SAVEXMIN(fit) + xmax = GS_SAVEXMAX(fit) + if (xmax <= xmin) + call error (0, "GSRESTORE: Illegal x range.") + ymin = GS_SAVEYMIN(fit) + ymax = GS_SAVEYMAX(fit) + if (ymax <= ymin) + call error (0, "GSRESTORE: Illegal y range.") + + # set surface type dependent surface descriptor parameters + surface_type = nint (GS_SAVETYPE(fit)) + switch (surface_type) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf) = xorder + GS_XORDER(sf) = xorder + GS_XMIN(sf) = xmin + GS_XMAX(sf) = xmax + GS_XRANGE(sf) = real(2.0) / (xmax - xmin) + GS_XMAXMIN(sf) = - (xmax + xmin) / real(2.0) + GS_NYCOEFF(sf) = yorder + GS_YORDER(sf) = yorder + GS_YMIN(sf) = ymin + GS_YMAX(sf) = ymax + GS_YRANGE(sf) = real(2.0) / (ymax - ymin) + GS_YMAXMIN(sf) = - (ymax + ymin) / real(2.0) + GS_XTERMS(sf) = GS_SAVEXTERMS(fit) + switch (GS_XTERMS(sf)) { + case GS_XNONE: + GS_NCOEFF(sf) = GS_NXCOEFF(sf) + GS_NYCOEFF(sf) - 1 + case GS_XHALF: + order = min (xorder, yorder) + GS_NCOEFF(sf) = GS_NXCOEFF(sf) * GS_NYCOEFF(sf) - order * + (order - 1) / 2 + case GS_XFULL: + GS_NCOEFF(sf) = GS_NXCOEFF(sf) * GS_NYCOEFF(sf) + } + default: + call error (0, "GSRESTORE: Unknown surface type.") + } + + # set remaining curve parameters + GS_TYPE(sf) = surface_type + + # allocate space for the coefficient array + GS_XBASIS(sf) = NULL + GS_YBASIS(sf) = NULL + GS_MATRIX(sf) = NULL + GS_CHOFAC(sf) = NULL + GS_VECTOR(sf) = NULL + GS_COEFF(sf) = NULL + GS_WZ(sf) = NULL + + call malloc (GS_COEFF(sf), GS_NCOEFF(sf), TY_REAL) + + # restore coefficient array + call amovr (fit[GS_SAVECOEFF+1], COEFF(GS_COEFF(sf)), GS_NCOEFF(sf)) +end diff --git a/math/gsurfit/gssave.gx b/math/gsurfit/gssave.gx new file mode 100644 index 00000000..a4cbaa82 --- /dev/null +++ b/math/gsurfit/gssave.gx @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSSAVE -- Procedure to save the surface fit for later use by the +# evaluate routines. After a call to GSSAVE the first eight elements +# of fit contain the surface type, xorder (or number of polynomial pieces +# in x), yorder (or the number of polynomial pieces in y), xterms, xmin, +# xmax, ymin, and ymax. The remaining spaces are filled by the GS_NCOEFF(sf) +# coefficients. + +$if (datatype == r) +procedure gssave (sf, fit) +$else +procedure dgssave (sf, fit) +$endif + +pointer sf # pointer to the surface descriptor +PIXEL fit[ARB] # array for storing fit + +begin + # get the surface parameters + if (sf == NULL) + return + + # order is surface type dependent + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_SAVEXORDER(fit) = GS_XORDER(sf) + GS_SAVEYORDER(fit) = GS_YORDER(sf) + default: + call error (0, "GSSAVE: Unknown surface type.") + } + + # save remaining parameters + GS_SAVETYPE(fit) = GS_TYPE(sf) + GS_SAVEXMIN(fit) = GS_XMIN(sf) + GS_SAVEXMAX(fit) = GS_XMAX(sf) + GS_SAVEYMIN(fit) = GS_YMIN(sf) + GS_SAVEYMAX(fit) = GS_YMAX(sf) + GS_SAVEXTERMS(fit) = GS_XTERMS(sf) + + # save the coefficients + call amov$t (COEFF(GS_COEFF(sf)), fit[GS_SAVECOEFF+1], GS_NCOEFF(sf)) +end diff --git a/math/gsurfit/gssaved.x b/math/gsurfit/gssaved.x new file mode 100644 index 00000000..b2bddffd --- /dev/null +++ b/math/gsurfit/gssaved.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSSAVE -- Procedure to save the surface fit for later use by the +# evaluate routines. After a call to GSSAVE the first eight elements +# of fit contain the surface type, xorder (or number of polynomial pieces +# in x), yorder (or the number of polynomial pieces in y), xterms, xmin, +# xmax, ymin, and ymax. The remaining spaces are filled by the GS_NCOEFF(sf) +# coefficients. + +procedure dgssave (sf, fit) + +pointer sf # pointer to the surface descriptor +double fit[ARB] # array for storing fit + +begin + # get the surface parameters + if (sf == NULL) + return + + # order is surface type dependent + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_SAVEXORDER(fit) = GS_XORDER(sf) + GS_SAVEYORDER(fit) = GS_YORDER(sf) + default: + call error (0, "GSSAVE: Unknown surface type.") + } + + # save remaining parameters + GS_SAVETYPE(fit) = GS_TYPE(sf) + GS_SAVEXMIN(fit) = GS_XMIN(sf) + GS_SAVEXMAX(fit) = GS_XMAX(sf) + GS_SAVEYMIN(fit) = GS_YMIN(sf) + GS_SAVEYMAX(fit) = GS_YMAX(sf) + GS_SAVEXTERMS(fit) = GS_XTERMS(sf) + + # save the coefficients + call amovd (COEFF(GS_COEFF(sf)), fit[GS_SAVECOEFF+1], GS_NCOEFF(sf)) +end diff --git a/math/gsurfit/gssaver.x b/math/gsurfit/gssaver.x new file mode 100644 index 00000000..b4f5bf32 --- /dev/null +++ b/math/gsurfit/gssaver.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSSAVE -- Procedure to save the surface fit for later use by the +# evaluate routines. After a call to GSSAVE the first eight elements +# of fit contain the surface type, xorder (or number of polynomial pieces +# in x), yorder (or the number of polynomial pieces in y), xterms, xmin, +# xmax, ymin, and ymax. The remaining spaces are filled by the GS_NCOEFF(sf) +# coefficients. + +procedure gssave (sf, fit) + +pointer sf # pointer to the surface descriptor +real fit[ARB] # array for storing fit + +begin + # get the surface parameters + if (sf == NULL) + return + + # order is surface type dependent + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_SAVEXORDER(fit) = GS_XORDER(sf) + GS_SAVEYORDER(fit) = GS_YORDER(sf) + default: + call error (0, "GSSAVE: Unknown surface type.") + } + + # save remaining parameters + GS_SAVETYPE(fit) = GS_TYPE(sf) + GS_SAVEXMIN(fit) = GS_XMIN(sf) + GS_SAVEXMAX(fit) = GS_XMAX(sf) + GS_SAVEYMIN(fit) = GS_YMIN(sf) + GS_SAVEYMAX(fit) = GS_YMAX(sf) + GS_SAVEXTERMS(fit) = GS_XTERMS(sf) + + # save the coefficients + call amovr (COEFF(GS_COEFF(sf)), fit[GS_SAVECOEFF+1], GS_NCOEFF(sf)) +end diff --git a/math/gsurfit/gsscoeff.gx b/math/gsurfit/gsscoeff.gx new file mode 100644 index 00000000..09b894e3 --- /dev/null +++ b/math/gsurfit/gsscoeff.gx @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSSCOEFF -- Procedure to set a particular coefficient. +# If the requested coefficient is undefined then the coefficient is not set. + +$if (datatype == r) +procedure gsscoeff (sf, xorder, yorder, coeff) +$else +procedure dgsscoeff (sf, xorder, yorder, coeff) +$endif + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent +PIXEL coeff # Coefficient value + +int i, n, maxorder, xincr + +begin + if ((xorder > GS_XORDER(sf)) || (yorder > GS_YORDER(sf))) + return + + switch (GS_XTERMS(sf)) { + case GS_XNONE: + if (yorder == 1) + n = xorder + else if (xorder == 1) + n = GS_NXCOEFF(sf) + yorder - 1 + else + return + case GS_XHALF: + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + if ((xorder + yorder) > maxorder) + return + n = xorder + xincr = GS_XORDER(sf) + do i = 2, yorder { + n = n + xincr + if ((i + GS_XORDER(sf) + 1) > maxorder) + xincr = xincr - 1 + } + case GS_XFULL: + n = xorder + (yorder - 1) * GS_NXCOEFF(sf) + } + + COEFF(GS_COEFF(sf) + n - 1) = coeff +end diff --git a/math/gsurfit/gsscoeffd.x b/math/gsurfit/gsscoeffd.x new file mode 100644 index 00000000..452eb70b --- /dev/null +++ b/math/gsurfit/gsscoeffd.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSSCOEFF -- Procedure to set a particular coefficient. +# If the requested coefficient is undefined then the coefficient is not set. + +procedure dgsscoeff (sf, xorder, yorder, coeff) + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent +double coeff # Coefficient value + +int i, n, maxorder, xincr + +begin + if ((xorder > GS_XORDER(sf)) || (yorder > GS_YORDER(sf))) + return + + switch (GS_XTERMS(sf)) { + case GS_XNONE: + if (yorder == 1) + n = xorder + else if (xorder == 1) + n = GS_NXCOEFF(sf) + yorder - 1 + else + return + case GS_XHALF: + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + if ((xorder + yorder) > maxorder) + return + n = xorder + xincr = GS_XORDER(sf) + do i = 2, yorder { + n = n + xincr + if ((i + GS_XORDER(sf) + 1) > maxorder) + xincr = xincr - 1 + } + case GS_XFULL: + n = xorder + (yorder - 1) * GS_NXCOEFF(sf) + } + + COEFF(GS_COEFF(sf) + n - 1) = coeff +end diff --git a/math/gsurfit/gsscoeffr.x b/math/gsurfit/gsscoeffr.x new file mode 100644 index 00000000..dacb4bd0 --- /dev/null +++ b/math/gsurfit/gsscoeffr.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSSCOEFF -- Procedure to set a particular coefficient. +# If the requested coefficient is undefined then the coefficient is not set. + +procedure gsscoeff (sf, xorder, yorder, coeff) + +pointer sf # pointer to the surface fitting descriptor +int xorder # X order of desired coefficent +int yorder # Y order of desired coefficent +real coeff # Coefficient value + +int i, n, maxorder, xincr + +begin + if ((xorder > GS_XORDER(sf)) || (yorder > GS_YORDER(sf))) + return + + switch (GS_XTERMS(sf)) { + case GS_XNONE: + if (yorder == 1) + n = xorder + else if (xorder == 1) + n = GS_NXCOEFF(sf) + yorder - 1 + else + return + case GS_XHALF: + maxorder = max (GS_XORDER(sf) + 1, GS_YORDER(sf) + 1) + if ((xorder + yorder) > maxorder) + return + n = xorder + xincr = GS_XORDER(sf) + do i = 2, yorder { + n = n + xincr + if ((i + GS_XORDER(sf) + 1) > maxorder) + xincr = xincr - 1 + } + case GS_XFULL: + n = xorder + (yorder - 1) * GS_NXCOEFF(sf) + } + + COEFF(GS_COEFF(sf) + n - 1) = coeff +end diff --git a/math/gsurfit/gssolve.gx b/math/gsurfit/gssolve.gx new file mode 100644 index 00000000..9008e140 --- /dev/null +++ b/math/gsurfit/gssolve.gx @@ -0,0 +1,101 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSSOLVE -- Solve the matrix normal equations of the form ca = b for a, +# where c is a symmetric, positive semi-definite, banded matrix with +# GS_NXCOEFF(sf) * GS_NYCOEFF(sf) rows and a and b are GS_NXCOEFF(sf) * +# GS_NYCOEFF(sf)-vectors. +# Initially c is stored in the matrix MATRIX +# and b is stored in VECTOR. +# The Cholesky factorization of MATRIX is calculated and stored in CHOFAC. +# Finally the coefficients are calculated by forward and back substitution +# and stored in COEFF. +# +# This version has two options: fit all the coefficients or fix the +# the zeroth coefficient at a specified reference point. + +$if (datatype == r) +procedure gssolve (sf, ier) +$else +procedure dgssolve (sf, ier) +$endif + +pointer sf # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int i, ncoeff +pointer sp, vector, matrix + +$if (datatype == r) +PIXEL gseval() +$else +PIXEL dgseval() +$endif + +begin + if (IS_INDEF(GS_XREF(sf)) || IS_INDEF(GS_YREF(sf)) || + IS_INDEF(GS_ZREF(sf))) + ncoeff = GS_NCOEFF(sf) + else + ncoeff = GS_NCOEFF(sf) - 1 + + # test for number of degrees of freedom + ier = OK + i = GS_NPTS(sf) - ncoeff + if (i < 0) { + ier = NO_DEG_FREEDOM + return + } + + if (ncoeff == GS_NCOEFF(sf)) { + vector = GS_VECTOR(sf) + matrix = GS_MATRIX(sf) + } else { + # allocate working space for the reduced vector and matrix + call smark (sp) + call salloc (vector, ncoeff, TY_PIXEL) + call salloc (matrix, ncoeff*ncoeff, TY_PIXEL) + + # eliminate the terms from the vector and matrix + call amov$t (VECTOR(GS_VECTOR(sf)+1), Mem$t[vector], ncoeff) + do i = 0, ncoeff-1 + call amov$t (MATRIX(GS_MATRIX(sf)+(i+1)*GS_NCOEFF(sf)), + Mem$t[matrix+i*ncoeff], ncoeff) + } + + # solve for the coefficients. + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # calculate the Cholesky factorization of the data matrix + call $tgschofac (MATRIX(matrix), ncoeff, ncoeff, + CHOFAC(GS_CHOFAC(sf)), ier) + + # solve for the coefficients by forward and back substitution + call $tgschoslv (CHOFAC(GS_CHOFAC(sf)), ncoeff, ncoeff, + VECTOR(vector), COEFF(GS_COEFF(sf)+GS_NCOEFF(sf)-ncoeff)) + + default: + call error (0, "GSSOLVE: Illegal surface type.") + } + + if (ncoeff != GS_NCOEFF(sf)) { + $if (datatype == r) + COEFF(GS_COEFF(sf)) = GS_ZREF(sf) - + gseval (sf, GS_XREF(sf), GS_YREF(sf)) + $else + COEFF(GS_COEFF(sf)) = GS_ZREF(sf) - + dgseval (sf, GS_XREF(sf), GS_YREF(sf)) + $endif + call sfree (sp) + } +end diff --git a/math/gsurfit/gssolved.x b/math/gsurfit/gssolved.x new file mode 100644 index 00000000..e3ed43ce --- /dev/null +++ b/math/gsurfit/gssolved.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSSOLVE -- Solve the matrix normal equations of the form ca = b for a, +# where c is a symmetric, positive semi-definite, banded matrix with +# GS_NXCOEFF(sf) * GS_NYCOEFF(sf) rows and a and b are GS_NXCOEFF(sf) * +# GS_NYCOEFF(sf)-vectors. +# Initially c is stored in the matrix MATRIX +# and b is stored in VECTOR. +# The Cholesky factorization of MATRIX is calculated and stored in CHOFAC. +# Finally the coefficients are calculated by forward and back substitution +# and stored in COEFF. +# +# This version has two options: fit all the coefficients or fix the +# the zeroth coefficient at a specified reference point. + +procedure dgssolve (sf, ier) + +pointer sf # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int i, ncoeff +pointer sp, vector, matrix + +double dgseval() + +begin + if (IS_INDEFD(GS_XREF(sf)) || IS_INDEFD(GS_YREF(sf)) || + IS_INDEFD(GS_ZREF(sf))) + ncoeff = GS_NCOEFF(sf) + else + ncoeff = GS_NCOEFF(sf) - 1 + + # test for number of degrees of freedom + ier = OK + i = GS_NPTS(sf) - ncoeff + if (i < 0) { + ier = NO_DEG_FREEDOM + return + } + + if (ncoeff == GS_NCOEFF(sf)) { + vector = GS_VECTOR(sf) + matrix = GS_MATRIX(sf) + } else { + # allocate working space for the reduced vector and matrix + call smark (sp) + call salloc (vector, ncoeff, TY_DOUBLE) + call salloc (matrix, ncoeff*ncoeff, TY_DOUBLE) + + # eliminate the terms from the vector and matrix + call amovd (VECTOR(GS_VECTOR(sf)+1), Memd[vector], ncoeff) + do i = 0, ncoeff-1 + call amovd (MATRIX(GS_MATRIX(sf)+(i+1)*GS_NCOEFF(sf)), + Memd[matrix+i*ncoeff], ncoeff) + } + + # solve for the coefficients. + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # calculate the Cholesky factorization of the data matrix + call dgschofac (MATRIX(matrix), ncoeff, ncoeff, + CHOFAC(GS_CHOFAC(sf)), ier) + + # solve for the coefficients by forward and back substitution + call dgschoslv (CHOFAC(GS_CHOFAC(sf)), ncoeff, ncoeff, + VECTOR(vector), COEFF(GS_COEFF(sf)+GS_NCOEFF(sf)-ncoeff)) + + default: + call error (0, "GSSOLVE: Illegal surface type.") + } + + if (ncoeff != GS_NCOEFF(sf)) { + COEFF(GS_COEFF(sf)) = GS_ZREF(sf) - + dgseval (sf, GS_XREF(sf), GS_YREF(sf)) + call sfree (sp) + } +end diff --git a/math/gsurfit/gssolver.x b/math/gsurfit/gssolver.x new file mode 100644 index 00000000..5135298a --- /dev/null +++ b/math/gsurfit/gssolver.x @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSSOLVE -- Solve the matrix normal equations of the form ca = b for a, +# where c is a symmetric, positive semi-definite, banded matrix with +# GS_NXCOEFF(sf) * GS_NYCOEFF(sf) rows and a and b are GS_NXCOEFF(sf) * +# GS_NYCOEFF(sf)-vectors. +# Initially c is stored in the matrix MATRIX +# and b is stored in VECTOR. +# The Cholesky factorization of MATRIX is calculated and stored in CHOFAC. +# Finally the coefficients are calculated by forward and back substitution +# and stored in COEFF. +# +# This version has two options: fit all the coefficients or fix the +# the zeroth coefficient at a specified reference point. + +procedure gssolve (sf, ier) + +pointer sf # curve descriptor +int ier # ier = OK, everything OK + # ier = SINGULAR, matrix is singular, 1 or more + # coefficients are 0. + # ier = NO_DEG_FREEDOM, too few points to solve matrix + +int i, ncoeff +pointer sp, vector, matrix + +real gseval() + +begin + if (IS_INDEFR(GS_XREF(sf)) || IS_INDEFR(GS_YREF(sf)) || + IS_INDEFR(GS_ZREF(sf))) + ncoeff = GS_NCOEFF(sf) + else + ncoeff = GS_NCOEFF(sf) - 1 + + # test for number of degrees of freedom + ier = OK + i = GS_NPTS(sf) - ncoeff + if (i < 0) { + ier = NO_DEG_FREEDOM + return + } + + if (ncoeff == GS_NCOEFF(sf)) { + vector = GS_VECTOR(sf) + matrix = GS_MATRIX(sf) + } else { + # allocate working space for the reduced vector and matrix + call smark (sp) + call salloc (vector, ncoeff, TY_REAL) + call salloc (matrix, ncoeff*ncoeff, TY_REAL) + + # eliminate the terms from the vector and matrix + call amovr (VECTOR(GS_VECTOR(sf)+1), Memr[vector], ncoeff) + do i = 0, ncoeff-1 + call amovr (MATRIX(GS_MATRIX(sf)+(i+1)*GS_NCOEFF(sf)), + Memr[matrix+i*ncoeff], ncoeff) + } + + # solve for the coefficients. + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + # calculate the Cholesky factorization of the data matrix + call rgschofac (MATRIX(matrix), ncoeff, ncoeff, + CHOFAC(GS_CHOFAC(sf)), ier) + + # solve for the coefficients by forward and back substitution + call rgschoslv (CHOFAC(GS_CHOFAC(sf)), ncoeff, ncoeff, + VECTOR(vector), COEFF(GS_COEFF(sf)+GS_NCOEFF(sf)-ncoeff)) + + default: + call error (0, "GSSOLVE: Illegal surface type.") + } + + if (ncoeff != GS_NCOEFF(sf)) { + COEFF(GS_COEFF(sf)) = GS_ZREF(sf) - + gseval (sf, GS_XREF(sf), GS_YREF(sf)) + call sfree (sp) + } +end diff --git a/math/gsurfit/gsstat.gx b/math/gsurfit/gsstat.gx new file mode 100644 index 00000000..d701ea9e --- /dev/null +++ b/math/gsurfit/gsstat.gx @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSGET -- Procedure to fetch a gsurfit parameter +$if (datatype == r) +real procedure gsgetr (sf, parameter) +$else +double procedure dgsgetd (sf, parameter) +$endif + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched + +begin + switch (parameter) { + case GSXMAX: + return (GS_XMAX(sf)) + case GSXMIN: + return (GS_XMIN(sf)) + case GSYMAX: + return (GS_YMAX(sf)) + case GSYMIN: + return (GS_YMIN(sf)) + case GSXREF: + return (GS_XREF(sf)) + case GSYREF: + return (GS_YREF(sf)) + case GSZREF: + return (GS_ZREF(sf)) + } +end + + +# GSSET -- Procedure to set a gsurfit parameter +$if (datatype == r) +procedure gsset (sf, parameter, val) +$else +procedure dgsset (sf, parameter, val) +$endif + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched +PIXEL val # value to set + +begin + switch (parameter) { + case GSXREF: + GS_XREF(sf) = val + case GSYREF: + GS_YREF(sf) = val + case GSZREF: + GS_ZREF(sf) = val + } +end + + +# GSGETI -- Procedure to fetch an integer parameter + +$if (datatype == r) +int procedure gsgeti (sf, parameter) +$else +int procedure dgsgeti (sf, parameter) +$endif + +pointer sf # pointer to the surface fit +int parameter # integer parameter + +begin + switch (parameter) { + case GSTYPE: + return (GS_TYPE(sf)) + case GSXORDER: + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + return (GS_XORDER(sf)) + } + case GSYORDER: + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + return (GS_YORDER(sf)) + } + case GSXTERMS: + return (GS_XTERMS(sf)) + case GSNXCOEFF: + return (GS_NXCOEFF(sf)) + case GSNYCOEFF: + return (GS_NYCOEFF(sf)) + case GSNCOEFF: + return (GS_NCOEFF(sf)) + case GSNSAVE: + return (GS_SAVECOEFF+GS_NCOEFF(sf)) + } +end diff --git a/math/gsurfit/gsstatd.x b/math/gsurfit/gsstatd.x new file mode 100644 index 00000000..b8c551f1 --- /dev/null +++ b/math/gsurfit/gsstatd.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSGET -- Procedure to fetch a gsurfit parameter +double procedure dgsgetd (sf, parameter) + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched + +begin + switch (parameter) { + case GSXMAX: + return (GS_XMAX(sf)) + case GSXMIN: + return (GS_XMIN(sf)) + case GSYMAX: + return (GS_YMAX(sf)) + case GSYMIN: + return (GS_YMIN(sf)) + case GSXREF: + return (GS_XREF(sf)) + case GSYREF: + return (GS_YREF(sf)) + case GSZREF: + return (GS_ZREF(sf)) + } +end + + +# GSSET -- Procedure to set a gsurfit parameter +procedure dgsset (sf, parameter, val) + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched +double val # value to set + +begin + switch (parameter) { + case GSXREF: + GS_XREF(sf) = val + case GSYREF: + GS_YREF(sf) = val + case GSZREF: + GS_ZREF(sf) = val + } +end + + +# GSGETI -- Procedure to fetch an integer parameter + +int procedure dgsgeti (sf, parameter) + +pointer sf # pointer to the surface fit +int parameter # integer parameter + +begin + switch (parameter) { + case GSTYPE: + return (GS_TYPE(sf)) + case GSXORDER: + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + return (GS_XORDER(sf)) + } + case GSYORDER: + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + return (GS_YORDER(sf)) + } + case GSXTERMS: + return (GS_XTERMS(sf)) + case GSNXCOEFF: + return (GS_NXCOEFF(sf)) + case GSNYCOEFF: + return (GS_NYCOEFF(sf)) + case GSNCOEFF: + return (GS_NCOEFF(sf)) + case GSNSAVE: + return (GS_SAVECOEFF+GS_NCOEFF(sf)) + } +end diff --git a/math/gsurfit/gsstatr.x b/math/gsurfit/gsstatr.x new file mode 100644 index 00000000..826bcafa --- /dev/null +++ b/math/gsurfit/gsstatr.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSGET -- Procedure to fetch a gsurfit parameter +real procedure gsgetr (sf, parameter) + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched + +begin + switch (parameter) { + case GSXMAX: + return (GS_XMAX(sf)) + case GSXMIN: + return (GS_XMIN(sf)) + case GSYMAX: + return (GS_YMAX(sf)) + case GSYMIN: + return (GS_YMIN(sf)) + case GSXREF: + return (GS_XREF(sf)) + case GSYREF: + return (GS_YREF(sf)) + case GSZREF: + return (GS_ZREF(sf)) + } +end + + +# GSSET -- Procedure to set a gsurfit parameter +procedure gsset (sf, parameter, val) + +pointer sf # pointer to the surface fit +int parameter # parameter to be fetched +real val # value to set + +begin + switch (parameter) { + case GSXREF: + GS_XREF(sf) = val + case GSYREF: + GS_YREF(sf) = val + case GSZREF: + GS_ZREF(sf) = val + } +end + + +# GSGETI -- Procedure to fetch an integer parameter + +int procedure gsgeti (sf, parameter) + +pointer sf # pointer to the surface fit +int parameter # integer parameter + +begin + switch (parameter) { + case GSTYPE: + return (GS_TYPE(sf)) + case GSXORDER: + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + return (GS_XORDER(sf)) + } + case GSYORDER: + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + return (GS_YORDER(sf)) + } + case GSXTERMS: + return (GS_XTERMS(sf)) + case GSNXCOEFF: + return (GS_NXCOEFF(sf)) + case GSNYCOEFF: + return (GS_NYCOEFF(sf)) + case GSNCOEFF: + return (GS_NCOEFF(sf)) + case GSNSAVE: + return (GS_SAVECOEFF+GS_NCOEFF(sf)) + } +end diff --git a/math/gsurfit/gssub.gx b/math/gsurfit/gssub.gx new file mode 100644 index 00000000..533417a7 --- /dev/null +++ b/math/gsurfit/gssub.gx @@ -0,0 +1,198 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSSUB -- Procedure to subtract two surfaces. The surfaces +# must be the same type and the fit must cover the same range of data in x +# and y. This is a special function. + +$if (datatype == r) +procedure gssub (sf1, sf2, sf3) +$else +procedure dgssub (sf1, sf2, sf3) +$endif + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +int i, ncoeff, order, maxorder1, maxorder2, maxorder3 +int nmove1, nmove2, nmove3 +pointer sp, coeff, ptr1, ptr2, ptr3 + +bool fpequal$t() +$if (datatype == r) +int gsgeti() +$else +int dgsgeti() +$endif + +begin + # test for NULL surface + if (sf1 == NULL && sf2 == NULL) { + sf3 = NULL + return + } else if (sf1 == NULL) { +$if (datatype == r) + ncoeff = gsgeti (sf2, GSNSAVE) +$else + ncoeff = dgsgeti (sf2, GSNSAVE) +$endif + call smark (sp) + $if (datatype == r) + call salloc (coeff, ncoeff, TY_REAL) + $else + call salloc (coeff, ncoeff, TY_DOUBLE) + $endif + call gssave (sf2, Mem$t[coeff]) + $if (datatype == r) + call amulk$t (Mem$t[coeff], -1.0, Mem$t[coeff], ncoeff) + $else + call amulk$t (Mem$t[coeff], -1.0d0, Mem$t[coeff], ncoeff) + $endif + call gsrestore (sf3, Mem$t[coeff]) + call sfree (sp) + return + } else if (sf2 == NULL) { + call gscopy (sf1, sf3) + return + } + + # test that function type is the same + if (GS_TYPE(sf1) != GS_TYPE(sf2)) + call error (0, "GSSUB: Incompatable surface types.") + + # test that mins and maxs are the same + if (! fpequal$t (GS_XMIN(sf1), GS_XMIN(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequal$t (GS_XMAX(sf1), GS_XMAX(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequal$t (GS_YMIN(sf1), GS_YMIN(sf2))) + call error (0, "GSADD: Y ranges not identical.") + if (! fpequal$t (GS_YMAX(sf1), GS_YMAX(sf2))) + call error (0, "GSADD: Y ranges not identical.") + + # allocate space for the pointer + call calloc (sf3, LEN_GSSTRUCT, TY_STRUCT) + + # copy parameters + GS_TYPE(sf3) = GS_TYPE(sf1) + + switch (GS_TYPE(sf3)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf3) = max (GS_NXCOEFF(sf1), GS_NXCOEFF(sf2)) + GS_XORDER(sf3) = max (GS_XORDER(sf1), GS_XORDER(sf2)) + GS_XMIN(sf3) = GS_XMIN(sf1) + GS_XMAX(sf3) = GS_XMAX(sf1) + GS_XRANGE(sf3) = GS_XRANGE(sf1) + GS_XMAXMIN(sf3) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf3) = max (GS_NYCOEFF(sf1), GS_NYCOEFF(sf2)) + GS_YORDER(sf3) = max (GS_YORDER(sf1), GS_YORDER(sf2)) + GS_YMIN(sf3) = GS_YMIN(sf1) + GS_YMAX(sf3) = GS_YMAX(sf1) + GS_YRANGE(sf3) = GS_YRANGE(sf1) + GS_YMAXMIN(sf3) = GS_YMAXMIN(sf1) + if (GS_XTERMS(sf1) == GS_XTERMS(sf2)) + GS_XTERMS(sf3) = GS_XTERMS(sf1) + else if (GS_XTERMS(sf1) == GS_XFULL || GS_XTERMS(sf2) == GS_XFULL) + GS_XTERMS(sf3) = GS_XFULL + else + GS_XTERMS(sf3) = GS_XHALF + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) + GS_NYCOEFF(sf3) - 1 + case GS_XHALF: + order = min (GS_XORDER(sf3), GS_YORDER(sf3)) + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) - order * + (order - 1) / 2 + default: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) + } + default: + call error (0, "GSADD: Unknown curve type.") + } + + # set pointers to NULL + GS_XBASIS(sf3) = NULL + GS_YBASIS(sf3) = NULL + GS_MATRIX(sf3) = NULL + GS_CHOFAC(sf3) = NULL + GS_VECTOR(sf3) = NULL + GS_COEFF(sf3) = NULL + GS_WZ(sf3) = NULL + + # calculate the coefficients + $if (datatype == r) + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_REAL) + $else + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_DOUBLE) + $endif + + # set up the line counters. + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + maxorder3 = max (GS_XORDER(sf3) + 1, GS_YORDER(sf3) + 1) + + # add in the first surface. + ptr1 = GS_COEFF(sf1) + ptr3 = GS_COEFF(sf3) + nmove1 = GS_NXCOEFF(sf1) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf1) { + call amov$t (COEFF(ptr1), COEFF(ptr3), nmove1) + ptr1 = ptr1 + nmove1 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf1)) { + case GS_XNONE: + nmove1 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf1) + 1) > maxorder1) + nmove1 = nmove1 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } + + # subtract the second surface. + ptr2 = GS_COEFF(sf2) + ptr3 = GS_COEFF(sf3) + nmove2 = GS_NXCOEFF(sf2) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf2) { + call asub$t (COEFF(ptr3), COEFF(ptr2), COEFF(ptr3), nmove2) + ptr2 = ptr2 + nmove2 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + nmove2 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf2) + 1) > maxorder2) + nmove2 = nmove2 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } +end diff --git a/math/gsurfit/gssubd.x b/math/gsurfit/gssubd.x new file mode 100644 index 00000000..7f4dd1ba --- /dev/null +++ b/math/gsurfit/gssubd.x @@ -0,0 +1,170 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSSUB -- Procedure to subtract two surfaces. The surfaces +# must be the same type and the fit must cover the same range of data in x +# and y. This is a special function. + +procedure dgssub (sf1, sf2, sf3) + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +int i, ncoeff, order, maxorder1, maxorder2, maxorder3 +int nmove1, nmove2, nmove3 +pointer sp, coeff, ptr1, ptr2, ptr3 + +bool fpequald() +int dgsgeti() + +begin + # test for NULL surface + if (sf1 == NULL && sf2 == NULL) { + sf3 = NULL + return + } else if (sf1 == NULL) { + ncoeff = dgsgeti (sf2, GSNSAVE) + call smark (sp) + call salloc (coeff, ncoeff, TY_DOUBLE) + call gssave (sf2, Memd[coeff]) + call amulkd (Memd[coeff], -1.0d0, Memd[coeff], ncoeff) + call gsrestore (sf3, Memd[coeff]) + call sfree (sp) + return + } else if (sf2 == NULL) { + call gscopy (sf1, sf3) + return + } + + # test that function type is the same + if (GS_TYPE(sf1) != GS_TYPE(sf2)) + call error (0, "GSSUB: Incompatable surface types.") + + # test that mins and maxs are the same + if (! fpequald (GS_XMIN(sf1), GS_XMIN(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequald (GS_XMAX(sf1), GS_XMAX(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequald (GS_YMIN(sf1), GS_YMIN(sf2))) + call error (0, "GSADD: Y ranges not identical.") + if (! fpequald (GS_YMAX(sf1), GS_YMAX(sf2))) + call error (0, "GSADD: Y ranges not identical.") + + # allocate space for the pointer + call calloc (sf3, LEN_GSSTRUCT, TY_STRUCT) + + # copy parameters + GS_TYPE(sf3) = GS_TYPE(sf1) + + switch (GS_TYPE(sf3)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf3) = max (GS_NXCOEFF(sf1), GS_NXCOEFF(sf2)) + GS_XORDER(sf3) = max (GS_XORDER(sf1), GS_XORDER(sf2)) + GS_XMIN(sf3) = GS_XMIN(sf1) + GS_XMAX(sf3) = GS_XMAX(sf1) + GS_XRANGE(sf3) = GS_XRANGE(sf1) + GS_XMAXMIN(sf3) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf3) = max (GS_NYCOEFF(sf1), GS_NYCOEFF(sf2)) + GS_YORDER(sf3) = max (GS_YORDER(sf1), GS_YORDER(sf2)) + GS_YMIN(sf3) = GS_YMIN(sf1) + GS_YMAX(sf3) = GS_YMAX(sf1) + GS_YRANGE(sf3) = GS_YRANGE(sf1) + GS_YMAXMIN(sf3) = GS_YMAXMIN(sf1) + if (GS_XTERMS(sf1) == GS_XTERMS(sf2)) + GS_XTERMS(sf3) = GS_XTERMS(sf1) + else if (GS_XTERMS(sf1) == GS_XFULL || GS_XTERMS(sf2) == GS_XFULL) + GS_XTERMS(sf3) = GS_XFULL + else + GS_XTERMS(sf3) = GS_XHALF + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) + GS_NYCOEFF(sf3) - 1 + case GS_XHALF: + order = min (GS_XORDER(sf3), GS_YORDER(sf3)) + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) - order * + (order - 1) / 2 + default: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) + } + default: + call error (0, "GSADD: Unknown curve type.") + } + + # set pointers to NULL + GS_XBASIS(sf3) = NULL + GS_YBASIS(sf3) = NULL + GS_MATRIX(sf3) = NULL + GS_CHOFAC(sf3) = NULL + GS_VECTOR(sf3) = NULL + GS_COEFF(sf3) = NULL + GS_WZ(sf3) = NULL + + # calculate the coefficients + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_DOUBLE) + + # set up the line counters. + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + maxorder3 = max (GS_XORDER(sf3) + 1, GS_YORDER(sf3) + 1) + + # add in the first surface. + ptr1 = GS_COEFF(sf1) + ptr3 = GS_COEFF(sf3) + nmove1 = GS_NXCOEFF(sf1) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf1) { + call amovd (COEFF(ptr1), COEFF(ptr3), nmove1) + ptr1 = ptr1 + nmove1 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf1)) { + case GS_XNONE: + nmove1 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf1) + 1) > maxorder1) + nmove1 = nmove1 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } + + # subtract the second surface. + ptr2 = GS_COEFF(sf2) + ptr3 = GS_COEFF(sf3) + nmove2 = GS_NXCOEFF(sf2) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf2) { + call asubd (COEFF(ptr3), COEFF(ptr2), COEFF(ptr3), nmove2) + ptr2 = ptr2 + nmove2 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + nmove2 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf2) + 1) > maxorder2) + nmove2 = nmove2 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } +end diff --git a/math/gsurfit/gssubr.x b/math/gsurfit/gssubr.x new file mode 100644 index 00000000..748f7bee --- /dev/null +++ b/math/gsurfit/gssubr.x @@ -0,0 +1,170 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSSUB -- Procedure to subtract two surfaces. The surfaces +# must be the same type and the fit must cover the same range of data in x +# and y. This is a special function. + +procedure gssub (sf1, sf2, sf3) + +pointer sf1 # pointer to the first surface +pointer sf2 # pointer to the second surface +pointer sf3 # pointer to the output surface + +int i, ncoeff, order, maxorder1, maxorder2, maxorder3 +int nmove1, nmove2, nmove3 +pointer sp, coeff, ptr1, ptr2, ptr3 + +bool fpequalr() +int gsgeti() + +begin + # test for NULL surface + if (sf1 == NULL && sf2 == NULL) { + sf3 = NULL + return + } else if (sf1 == NULL) { + ncoeff = gsgeti (sf2, GSNSAVE) + call smark (sp) + call salloc (coeff, ncoeff, TY_REAL) + call gssave (sf2, Memr[coeff]) + call amulkr (Memr[coeff], -1.0, Memr[coeff], ncoeff) + call gsrestore (sf3, Memr[coeff]) + call sfree (sp) + return + } else if (sf2 == NULL) { + call gscopy (sf1, sf3) + return + } + + # test that function type is the same + if (GS_TYPE(sf1) != GS_TYPE(sf2)) + call error (0, "GSSUB: Incompatable surface types.") + + # test that mins and maxs are the same + if (! fpequalr (GS_XMIN(sf1), GS_XMIN(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequalr (GS_XMAX(sf1), GS_XMAX(sf2))) + call error (0, "GSADD: X ranges not identical.") + if (! fpequalr (GS_YMIN(sf1), GS_YMIN(sf2))) + call error (0, "GSADD: Y ranges not identical.") + if (! fpequalr (GS_YMAX(sf1), GS_YMAX(sf2))) + call error (0, "GSADD: Y ranges not identical.") + + # allocate space for the pointer + call calloc (sf3, LEN_GSSTRUCT, TY_STRUCT) + + # copy parameters + GS_TYPE(sf3) = GS_TYPE(sf1) + + switch (GS_TYPE(sf3)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + GS_NXCOEFF(sf3) = max (GS_NXCOEFF(sf1), GS_NXCOEFF(sf2)) + GS_XORDER(sf3) = max (GS_XORDER(sf1), GS_XORDER(sf2)) + GS_XMIN(sf3) = GS_XMIN(sf1) + GS_XMAX(sf3) = GS_XMAX(sf1) + GS_XRANGE(sf3) = GS_XRANGE(sf1) + GS_XMAXMIN(sf3) = GS_XMAXMIN(sf1) + GS_NYCOEFF(sf3) = max (GS_NYCOEFF(sf1), GS_NYCOEFF(sf2)) + GS_YORDER(sf3) = max (GS_YORDER(sf1), GS_YORDER(sf2)) + GS_YMIN(sf3) = GS_YMIN(sf1) + GS_YMAX(sf3) = GS_YMAX(sf1) + GS_YRANGE(sf3) = GS_YRANGE(sf1) + GS_YMAXMIN(sf3) = GS_YMAXMIN(sf1) + if (GS_XTERMS(sf1) == GS_XTERMS(sf2)) + GS_XTERMS(sf3) = GS_XTERMS(sf1) + else if (GS_XTERMS(sf1) == GS_XFULL || GS_XTERMS(sf2) == GS_XFULL) + GS_XTERMS(sf3) = GS_XFULL + else + GS_XTERMS(sf3) = GS_XHALF + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) + GS_NYCOEFF(sf3) - 1 + case GS_XHALF: + order = min (GS_XORDER(sf3), GS_YORDER(sf3)) + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) - order * + (order - 1) / 2 + default: + GS_NCOEFF(sf3) = GS_NXCOEFF(sf3) * GS_NYCOEFF(sf3) + } + default: + call error (0, "GSADD: Unknown curve type.") + } + + # set pointers to NULL + GS_XBASIS(sf3) = NULL + GS_YBASIS(sf3) = NULL + GS_MATRIX(sf3) = NULL + GS_CHOFAC(sf3) = NULL + GS_VECTOR(sf3) = NULL + GS_COEFF(sf3) = NULL + GS_WZ(sf3) = NULL + + # calculate the coefficients + call calloc (GS_COEFF(sf3), GS_NCOEFF(sf3), TY_REAL) + + # set up the line counters. + maxorder1 = max (GS_XORDER(sf1) + 1, GS_YORDER(sf1) + 1) + maxorder2 = max (GS_XORDER(sf2) + 1, GS_YORDER(sf2) + 1) + maxorder3 = max (GS_XORDER(sf3) + 1, GS_YORDER(sf3) + 1) + + # add in the first surface. + ptr1 = GS_COEFF(sf1) + ptr3 = GS_COEFF(sf3) + nmove1 = GS_NXCOEFF(sf1) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf1) { + call amovr (COEFF(ptr1), COEFF(ptr3), nmove1) + ptr1 = ptr1 + nmove1 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf1)) { + case GS_XNONE: + nmove1 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf1) + 1) > maxorder1) + nmove1 = nmove1 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } + + # subtract the second surface. + ptr2 = GS_COEFF(sf2) + ptr3 = GS_COEFF(sf3) + nmove2 = GS_NXCOEFF(sf2) + nmove3 = GS_NXCOEFF(sf3) + do i = 1, GS_NYCOEFF(sf2) { + call asubr (COEFF(ptr3), COEFF(ptr2), COEFF(ptr3), nmove2) + ptr2 = ptr2 + nmove2 + ptr3 = ptr3 + nmove3 + switch (GS_XTERMS(sf2)) { + case GS_XNONE: + nmove2 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf2) + 1) > maxorder2) + nmove2 = nmove2 - 1 + case GS_XFULL: + ; + } + switch (GS_XTERMS(sf3)) { + case GS_XNONE: + nmove3 = 1 + case GS_XHALF: + if ((i + GS_XORDER(sf3) + 1) > maxorder3) + nmove3 = nmove3 - 1 + case GS_XFULL: + ; + } + } +end diff --git a/math/gsurfit/gsurfit.h b/math/gsurfit/gsurfit.h new file mode 100644 index 00000000..5d46762b --- /dev/null +++ b/math/gsurfit/gsurfit.h @@ -0,0 +1,48 @@ +# definitions for the gsurfit package + +# define the permitted types of curves + +define GS_FUNCTIONS "|chebyshev|legendre|polynomial|" +define GS_CHEBYSHEV 1 # chebyshev polynomials +define GS_LEGENDRE 2 # legendre polynomials +define GS_POLYNOMIAL 3 # power series polynomials +define NTYPES 3 + +# define the xterms flags + +define GS_XTYPES "|none|full|half|" +define GS_XNONE 0 # no x-terms (old NO) +define GS_XFULL 1 # full x-terms (new YES) +define GS_XHALF 2 # half x-terms (new) + +# define the weighting flags + +define GS_WEIGHTS "|user|uniform|spacing|" +define WTS_USER 1 # user enters weights +define WTS_UNIFORM 2 # equal weights +define WTS_SPACING 3 # weight proportional to spacing of data points + +# error conditions + +define SINGULAR 1 +define NO_DEG_FREEDOM 2 + +# gsstat/gsset definitions + +define GSTYPE 1 +define GSXORDER 2 +define GSYORDER 3 +define GSXTERMS 4 +define GSNXCOEFF 5 +define GSNYCOEFF 6 +define GSNCOEFF 7 +define GSNSAVE 8 +define GSXMIN 9 +define GSXMAX 10 +define GSYMIN 11 +define GSYMAX 12 +define GSXREF 13 +define GSYREF 14 +define GSZREF 15 + +define GS_SAVECOEFF 8 diff --git a/math/gsurfit/gsurfitdef.h b/math/gsurfit/gsurfitdef.h new file mode 100644 index 00000000..7ee6cc1d --- /dev/null +++ b/math/gsurfit/gsurfitdef.h @@ -0,0 +1,61 @@ +# Header file for the surface fitting package + +# set up the curve descriptor structure + +define LEN_GSSTRUCT 64 + +define GS_TYPE Memi[$1] # Type of curve to be fitted +define GS_XORDER Memi[$1+1] # Order of the fit in x +define GS_YORDER Memi[$1+2] # Order of the fit in y +define GS_XTERMS Memi[$1+3] # Cross terms for polynomials +define GS_NXCOEFF Memi[$1+4] # Number of x coefficients +define GS_NYCOEFF Memi[$1+5] # Number of y coefficients +define GS_NCOEFF Memi[$1+6] # Total number of coefficients +define GS_XREF Memr[P2R($1+7)] # x reference value +define GS_YREF Memr[P2R($1+8)] # y reference value +define GS_ZREF Memr[P2R($1+9)] # z reference value +define GS_XMAX Memr[P2R($1+10)]# Maximum x value +define GS_XMIN Memr[P2R($1+11)]# Minimum x value +define GS_YMAX Memr[P2R($1+12)]# Maximum y value +define GS_YMIN Memr[P2R($1+13)]# Minimum y value +define GS_XRANGE Memr[P2R($1+14)]# 2. / (xmax - xmin), polynomials +define GS_XMAXMIN Memr[P2R($1+15)]# - (xmax + xmin) / 2., polynomials +define GS_YRANGE Memr[P2R($1+16)]# 2. / (ymax - ymin), polynomials +define GS_YMAXMIN Memr[P2R($1+17)]# - (ymax + ymin) / 2., polynomials +define GS_NPTS Memi[$1+18] # Number of data points + +define GS_MATRIX Memi[$1+19] # Pointer to original matrix +define GS_CHOFAC Memi[$1+20] # Pointer to Cholesky factorization +define GS_VECTOR Memi[$1+21] # Pointer to vector +define GS_COEFF Memi[$1+22] # Pointer to coefficient vector +define GS_XBASIS Memi[$1+23] # Pointer to basis functions (all x) +define GS_YBASIS Memi[$1+24] # Pointer to basis functions (all y) +define GS_WZ Memi[$1+25] # Pointer to w * z (gsrefit) + +# matrix and vector element definitions + +define XBASIS Memr[P2P($1)] # Non zero basis for all x +define YBASIS Memr[P2P($1)] # Non zero basis for all y +define XBS Memr[P2P($1)] # Non zero basis for single x +define YBS Memr[P2P($1)] # Non zero basis for single y +define MATRIX Memr[P2P($1)] # Element of MATRIX +define CHOFAC Memr[P2P($1)] # Element of CHOFAC +define VECTOR Memr[P2P($1)] # Element of VECTOR +define COEFF Memr[P2P($1)] # Element of COEFF + +# structure definitions for restore + +define GS_SAVETYPE $1[1] +define GS_SAVEXORDER $1[2] +define GS_SAVEYORDER $1[3] +define GS_SAVEXTERMS $1[4] +define GS_SAVEXMIN $1[5] +define GS_SAVEXMAX $1[6] +define GS_SAVEYMIN $1[7] +define GS_SAVEYMAX $1[8] + +# data type + +define DELTA EPSILON + +# miscellaneous diff --git a/math/gsurfit/gsvector.gx b/math/gsurfit/gsvector.gx new file mode 100644 index 00000000..60044dd6 --- /dev/null +++ b/math/gsurfit/gsvector.gx @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSVECTOR -- Procedure to evaluate the fitted surface at an array of points. +# The GS_NCOEFF(sf) coefficients are stored in the +# vector COEFF. + +$if (datatype == r) +procedure gsvector (sf, x, y, zfit, npts) +$else +procedure dgsvector (sf, x, y, zfit, npts) +$endif + +pointer sf # pointer to surface descriptor structure +PIXEL x[ARB] # x value +PIXEL y[ARB] # y value +PIXEL zfit[ARB] # fits surface values +int npts # number of data points + +begin + # evaluate the surface along the vector + switch (GS_TYPE(sf)) { + case GS_POLYNOMIAL: + if (GS_XORDER(sf) == 1) { + call $tgs_1devpoly (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call $tgs_1devpoly (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call $tgs_evpoly (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + case GS_CHEBYSHEV: + if (GS_XORDER(sf) == 1) { + call $tgs_1devcheb (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call $tgs_1devcheb (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call $tgs_evcheb (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + case GS_LEGENDRE: + if (GS_XORDER(sf) == 1) { + call $tgs_1devleg (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call $tgs_1devleg (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call $tgs_evleg (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + default: + call error (0, "GSVECTOR: Unknown surface type.") + } +end diff --git a/math/gsurfit/gsvectord.x b/math/gsurfit/gsvectord.x new file mode 100644 index 00000000..8bb980e6 --- /dev/null +++ b/math/gsurfit/gsvectord.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSVECTOR -- Procedure to evaluate the fitted surface at an array of points. +# The GS_NCOEFF(sf) coefficients are stored in the +# vector COEFF. + +procedure dgsvector (sf, x, y, zfit, npts) + +pointer sf # pointer to surface descriptor structure +double x[ARB] # x value +double y[ARB] # y value +double zfit[ARB] # fits surface values +int npts # number of data points + +begin + # evaluate the surface along the vector + switch (GS_TYPE(sf)) { + case GS_POLYNOMIAL: + if (GS_XORDER(sf) == 1) { + call dgs_1devpoly (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call dgs_1devpoly (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call dgs_evpoly (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + case GS_CHEBYSHEV: + if (GS_XORDER(sf) == 1) { + call dgs_1devcheb (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call dgs_1devcheb (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call dgs_evcheb (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + case GS_LEGENDRE: + if (GS_XORDER(sf) == 1) { + call dgs_1devleg (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call dgs_1devleg (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call dgs_evleg (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + default: + call error (0, "GSVECTOR: Unknown surface type.") + } +end diff --git a/math/gsurfit/gsvectorr.x b/math/gsurfit/gsvectorr.x new file mode 100644 index 00000000..38213ecc --- /dev/null +++ b/math/gsurfit/gsvectorr.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSVECTOR -- Procedure to evaluate the fitted surface at an array of points. +# The GS_NCOEFF(sf) coefficients are stored in the +# vector COEFF. + +procedure gsvector (sf, x, y, zfit, npts) + +pointer sf # pointer to surface descriptor structure +real x[ARB] # x value +real y[ARB] # y value +real zfit[ARB] # fits surface values +int npts # number of data points + +begin + # evaluate the surface along the vector + switch (GS_TYPE(sf)) { + case GS_POLYNOMIAL: + if (GS_XORDER(sf) == 1) { + call rgs_1devpoly (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call rgs_1devpoly (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call rgs_evpoly (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + case GS_CHEBYSHEV: + if (GS_XORDER(sf) == 1) { + call rgs_1devcheb (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call rgs_1devcheb (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call rgs_evcheb (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + case GS_LEGENDRE: + if (GS_XORDER(sf) == 1) { + call rgs_1devleg (COEFF(GS_COEFF(sf)), y, zfit, npts, + GS_YORDER(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + } else if (GS_YORDER(sf) == 1) { + call rgs_1devleg (COEFF(GS_COEFF(sf)), x, zfit, npts, + GS_XORDER(sf), GS_XMAXMIN(sf), GS_XRANGE(sf)) + } else + call rgs_evleg (COEFF(GS_COEFF(sf)), x, y, zfit, npts, + GS_XTERMS(sf), GS_XORDER(sf), GS_YORDER(sf), GS_XMAXMIN(sf), + GS_XRANGE(sf), GS_YMAXMIN(sf), GS_YRANGE(sf)) + default: + call error (0, "GSVECTOR: Unknown surface type.") + } +end diff --git a/math/gsurfit/gszero.gx b/math/gsurfit/gszero.gx new file mode 100644 index 00000000..e99cbe4d --- /dev/null +++ b/math/gsurfit/gszero.gx @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +$if (datatype == r) +include "gsurfitdef.h" +$else +include "dgsurfitdef.h" +$endif + +# GSZERO -- Procedure to zero the accumulators before doing +# a new fit in accumulate mode. The inner products of the basis functions +# are accumulated in the GS_NCOEFF(sf) ** 2 +# array MATRIX, while +# the inner products of the basis functions and the data ordinates are +# accumulated in the NCOEFF(sf)-vector VECTOR. + +$if (datatype == r) +procedure gszero (sf) +$else +procedure dgszero (sf) +$endif + +pointer sf # pointer to surface descriptor +errchk mfree + +begin + # zero the accumulators + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + GS_NPTS(sf) = 0 + call aclr$t (VECTOR(GS_VECTOR(sf)), GS_NCOEFF(sf)) + call aclr$t (MATRIX(GS_MATRIX(sf)), GS_NCOEFF(sf) ** 2) + + # free the basis functions defined from previous calls to sfrefit + $if (datatype == r) + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + $else + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + $endif + default: + call error (0, "GSZERO: Unknown surface type.") + } +end diff --git a/math/gsurfit/gszerod.x b/math/gsurfit/gszerod.x new file mode 100644 index 00000000..80c10883 --- /dev/null +++ b/math/gsurfit/gszerod.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "dgsurfitdef.h" + +# GSZERO -- Procedure to zero the accumulators before doing +# a new fit in accumulate mode. The inner products of the basis functions +# are accumulated in the GS_NCOEFF(sf) ** 2 +# array MATRIX, while +# the inner products of the basis functions and the data ordinates are +# accumulated in the NCOEFF(sf)-vector VECTOR. + +procedure dgszero (sf) + +pointer sf # pointer to surface descriptor +errchk mfree + +begin + # zero the accumulators + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + GS_NPTS(sf) = 0 + call aclrd (VECTOR(GS_VECTOR(sf)), GS_NCOEFF(sf)) + call aclrd (MATRIX(GS_MATRIX(sf)), GS_NCOEFF(sf) ** 2) + + # free the basis functions defined from previous calls to sfrefit + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_DOUBLE) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_DOUBLE) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_DOUBLE) + GS_WZ(sf) = NULL + default: + call error (0, "GSZERO: Unknown surface type.") + } +end diff --git a/math/gsurfit/gszeror.x b/math/gsurfit/gszeror.x new file mode 100644 index 00000000..f7c4e5ed --- /dev/null +++ b/math/gsurfit/gszeror.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/gsurfit.h> +include "gsurfitdef.h" + +# GSZERO -- Procedure to zero the accumulators before doing +# a new fit in accumulate mode. The inner products of the basis functions +# are accumulated in the GS_NCOEFF(sf) ** 2 +# array MATRIX, while +# the inner products of the basis functions and the data ordinates are +# accumulated in the NCOEFF(sf)-vector VECTOR. + +procedure gszero (sf) + +pointer sf # pointer to surface descriptor +errchk mfree + +begin + # zero the accumulators + switch (GS_TYPE(sf)) { + case GS_LEGENDRE, GS_CHEBYSHEV, GS_POLYNOMIAL: + + GS_NPTS(sf) = 0 + call aclrr (VECTOR(GS_VECTOR(sf)), GS_NCOEFF(sf)) + call aclrr (MATRIX(GS_MATRIX(sf)), GS_NCOEFF(sf) ** 2) + + # free the basis functions defined from previous calls to sfrefit + if (GS_XBASIS(sf) != NULL) + call mfree (GS_XBASIS(sf), TY_REAL) + GS_XBASIS(sf) = NULL + if (GS_YBASIS(sf) != NULL) + call mfree (GS_YBASIS(sf), TY_REAL) + GS_YBASIS(sf) = NULL + if (GS_WZ(sf) != NULL) + call mfree (GS_WZ(sf), TY_REAL) + GS_WZ(sf) = NULL + default: + call error (0, "GSZERO: Unknown surface type.") + } +end diff --git a/math/gsurfit/mkpkg b/math/gsurfit/mkpkg new file mode 100644 index 00000000..f7aaa08f --- /dev/null +++ b/math/gsurfit/mkpkg @@ -0,0 +1,111 @@ +# General surface fitting tools library. + +$checkout libgsurfit.a lib$ +$update libgsurfit.a +$checkin libgsurfit.a lib$ +$exit + +zzdebug: + $update libgsurfit.a + $omake zzdebug.x + $link zzdebug.o libgsurfit.a -o zzdebug + ; + +tfiles: + $set GEN = "$$generic -k -t rd" + + $ifolder (gs_b1evalr.x, gs_b1eval.gx) $(GEN) gs_b1eval.gx $endif + $ifolder (gs_bevalr.x, gs_beval.gx) $(GEN) gs_beval.gx $endif + $ifolder (gs_chomatr.x, gs_chomat.gx) $(GEN) gs_chomat.gx $endif + $ifolder (gs_f1devalr.x, gs_f1deval.gx) $(GEN) gs_f1deval.gx $endif + $ifolder (gs_fevalr.x, gs_feval.gx) $(GEN) gs_feval.gx $endif + $ifolder (gs_fderr.x, gs_fder.gx) $(GEN) gs_fder.gx $endif + $ifolder (gs_devalr.x, gs_deval.gx) $(GEN) gs_deval.gx $endif + $ifolder (gsaccumr.x, gsaccum.gx) $(GEN) gsaccum.gx $endif + $ifolder (gsacptsr.x, gsacpts.gx) $(GEN) gsacpts.gx $endif + $ifolder (gsaddr.x, gsadd.gx) $(GEN) gsadd.gx $endif + $ifolder (gscoeffr.x, gscoeff.gx) $(GEN) gscoeff.gx $endif + $ifolder (gscopyr.x, gscopy.gx) $(GEN) gscopy.gx $endif + $ifolder (gsderr.x, gsder.gx) $(GEN) gsder.gx $endif + $ifolder (gserrorsr.x, gserrors.gx) $(GEN) gserrors.gx $endif + $ifolder (gsevalr.x, gseval.gx) $(GEN) gseval.gx $endif + $ifolder (gsfitr.x, gsfit.gx) $(GEN) gsfit.gx $endif + $ifolder (gsfreer.x, gsfree.gx) $(GEN) gsfree.gx $endif + $ifolder (gsgcoeffr.x, gsgcoeff.gx) $(GEN) gsgcoeff.gx $endif + $ifolder (gsinitr.x, gsinit.gx) $(GEN) gsinit.gx $endif + $ifolder (gsrefitr.x, gsrefit.gx) $(GEN) gsrefit.gx $endif + $ifolder (gsrejectr.x, gsreject.gx) $(GEN) gsreject.gx $endif + $ifolder (gsrestorer.x, gsrestore.gx) $(GEN) gsrestore.gx $endif + $ifolder (gssaver.x, gssave.gx) $(GEN) gssave.gx $endif + $ifolder (gsscoeffr.x, gsscoeff.gx) $(GEN) gsscoeff.gx $endif + $ifolder (gssolver.x, gssolve.gx) $(GEN) gssolve.gx $endif + $ifolder (gsstatr.x, gsstat.gx) $(GEN) gsstat.gx $endif + $ifolder (gssubr.x, gssub.gx) $(GEN) gssub.gx $endif + $ifolder (gsvectorr.x, gsvector.gx) $(GEN) gsvector.gx $endif + $ifolder (gszeror.x, gszero.gx) $(GEN) gszero.gx $endif + ; + +libgsurfit.a: + + $ifeq (USE_GENERIC, yes) $call tfiles $endif + + gs_b1evalr.x + gs_bevalr.x + gs_chomatr.x gsurfitdef.h <mach.h> <math/gsurfit.h> + gs_f1devalr.x + gs_fevalr.x <math/gsurfit.h> + gs_fderr.x <math/gsurfit.h> + gs_devalr.x + gsaccumr.x gsurfitdef.h <math/gsurfit.h> + gsacptsr.x gsurfitdef.h <math/gsurfit.h> + gsaddr.x gsurfitdef.h <math/gsurfit.h> + gscoeffr.x gsurfitdef.h + gscopyr.x gsurfitdef.h <math/gsurfit.h> + gsderr.x gsurfitdef.h <math/gsurfit.h> + gserrorsr.x gsurfitdef.h <mach.h> + gsevalr.x gsurfitdef.h <math/gsurfit.h> + gsfitr.x gsurfitdef.h <math/gsurfit.h> + gsfreer.x gsurfitdef.h + gsgcoeffr.x gsurfitdef.h <math/gsurfit.h> + gsinitr.x gsurfitdef.h <math/gsurfit.h> + gsrefitr.x gsurfitdef.h <math/gsurfit.h> + gsrejectr.x gsurfitdef.h <math/gsurfit.h> + gsrestorer.x gsurfitdef.h <math/gsurfit.h> + gssaver.x gsurfitdef.h <math/gsurfit.h> + gsscoeffr.x gsurfitdef.h <math/gsurfit.h> + gssolver.x gsurfitdef.h <math/gsurfit.h> + gsstatr.x gsurfitdef.h <math/gsurfit.h> + gssubr.x gsurfitdef.h <math/gsurfit.h> + gsvectorr.x gsurfitdef.h <math/gsurfit.h> + gszeror.x gsurfitdef.h <math/gsurfit.h> + + gs_b1evald.x + gs_bevald.x + gs_chomatd.x dgsurfitdef.h <mach.h> <math/gsurfit.h> + gs_f1devald.x + gs_fevald.x <math/gsurfit.h> + gs_fderd.x <math/gsurfit.h> + gs_devald.x + gsaccumd.x dgsurfitdef.h <math/gsurfit.h> + gsacptsd.x dgsurfitdef.h <math/gsurfit.h> + gsaddd.x dgsurfitdef.h <math/gsurfit.h> + gscoeffd.x dgsurfitdef.h + gscopyd.x dgsurfitdef.h <math/gsurfit.h> + gsderd.x dgsurfitdef.h <math/gsurfit.h> + gserrorsd.x dgsurfitdef.h <mach.h> + gsevald.x dgsurfitdef.h <math/gsurfit.h> + gsfitd.x dgsurfitdef.h <math/gsurfit.h> + gsfreed.x dgsurfitdef.h + gsgcoeffd.x dgsurfitdef.h <math/gsurfit.h> + gsinitd.x dgsurfitdef.h <math/gsurfit.h> + gsrefitd.x dgsurfitdef.h <math/gsurfit.h> + gsrejectd.x dgsurfitdef.h <math/gsurfit.h> + gsrestored.x dgsurfitdef.h <math/gsurfit.h> + gssaved.x dgsurfitdef.h <math/gsurfit.h> + gsscoeffd.x dgsurfitdef.h <math/gsurfit.h> + gssolved.x dgsurfitdef.h <math/gsurfit.h> + gsstatd.x dgsurfitdef.h <math/gsurfit.h> + gssubd.x dgsurfitdef.h <math/gsurfit.h> + gsvectord.x dgsurfitdef.h <math/gsurfit.h> + gszerod.x dgsurfitdef.h <math/gsurfit.h> + ; diff --git a/math/gsurfit/zzdebug.x b/math/gsurfit/zzdebug.x new file mode 100644 index 00000000..522da747 --- /dev/null +++ b/math/gsurfit/zzdebug.x @@ -0,0 +1,348 @@ +task test = t_test + +include <math/gsurfit.h> + +procedure t_test() + +int i, j, k +int xorder, yorder, xterms, stype +int ncoeff, maxorder, xincr, npts, stype1, ier +pointer gs, ags, sgs +double dx, dy, const, accum, sum, rms1, rms2 +double x[121], y[121], z[121], w[121], zfit[121], coeff[121], save[121] +int clgeti() +double dgseval(), dgsgcoeff() + +begin + # Generate x and y grid. + dy = -1.0d0 + npts = 0 + do i = 1, 9 { + dx = -1.0d0 + do j = 1, 9 { + x[npts+1] = dx + y[npts+1] = dy + npts = npts + 1 + dx = dx + 0.25d0 + } + dy = dy + 0.25d0 + } + + stype = clgeti ("stype") + xorder = clgeti ("xorder") + yorder = clgeti ("yorder") + xterms = clgeti ("xterms") + call printf ("\n\nSURFACE: %d XORDER: %d YORDER: %d XTERMS: %d\n") + call pargi (stype) + call pargi (xorder) + call pargi (yorder) + call pargi (xterms) + + # Generate data + if (stype > 3) { + switch (xterms) { + case GS_XNONE: + + do i = 1, npts { + sum = 0.0d0 + do j = 2, yorder + sum = sum + j * y[i] ** (j - 1) + do j = 2, xorder + sum = sum + j * x[i] ** (j - 1) + z[i] = sum + } + + case GS_XHALF: + + maxorder = max (xorder + 1, yorder + 1) + do i = 1, npts { + sum = 0.0d0 + xincr = xorder + do j = 1, yorder { + const = j * y[i] ** (j - 1) + accum= 0.0d0 + do k = 1, xincr { + if (j > 1 || k > 1) + accum = accum + k * x[i] ** (k - 1) + } + sum = sum + const * accum + if ((j + xorder + 1) > maxorder) + xincr = xincr - 1 + } + z[i] = sum + } + + case GS_XFULL: + + do i = 1, npts { + sum = 0.0d0 + do j = 1, yorder { + const = j * y[i] ** (j - 1) + accum = 0.0d0 + do k = 1, xorder { + if (j > 1 || k > 1) + accum = accum + k * x[i] ** (k - 1) + } + sum = sum + const * accum + } + z[i] = sum + } + } + + stype1 = stype - 3 + } else { + switch (xterms) { + case GS_XNONE: + + do i = 1, npts { + sum = 0.0d0 + do j = 2, yorder + sum = sum + j * y[i] ** (j - 1) + do j = 1, xorder + sum = sum + j * x[i] ** (j - 1) + z[i] = sum + } + + case GS_XHALF: + + maxorder = max (xorder + 1, yorder + 1) + do i = 1, npts { + sum = 0.0d0 + xincr = xorder + do j = 1, yorder { + const = j * y[i] ** (j - 1) + accum= 0.0d0 + do k = 1, xincr { + accum = accum + k * x[i] ** (k - 1) + } + sum = sum + const * accum + if ((j + xorder + 1) > maxorder) + xincr = xincr - 1 + } + z[i] = sum + } + + case GS_XFULL: + + do i = 1, npts { + sum = 0.0d0 + do j = 1, yorder { + const = j * y[i] ** (j - 1) + accum = 0.0d0 + do k = 1, xorder { + accum = accum + k * x[i] ** (k - 1) + } + sum = sum + const * accum + } + z[i] = sum + } + } + + stype1 = stype + } + + # Print out the data. + call printf ("\nXIN:\n") + do i = 1, npts { + call printf ("%6.3f ") + call pargd (x[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + + call printf ("\nYIN:\n") + do i = 1, npts { + call printf ("%6.3f ") + call pargd (y[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + + call printf ("\nZIN:\n") + do i = 1, npts { + call printf ("%6.3f ") + call pargd (z[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + + # Fit surface. + call dgsinit (gs, stype1, xorder, yorder, xterms, -1.0d0, 1.0d0, + -1.0d0, 1.0d0) + if (stype > 3) { + call dgsset (gs, GSXREF, 0d0) + call dgsset (gs, GSYREF, 0d0) + call dgsset (gs, GSZREF, 0d0) + } + call dgsfit (gs, x, y, z, w, npts, WTS_UNIFORM, ier) + call printf ("\nFIT ERROR CODE: %d\n") + call pargi (ier) + + # Evaluate the fit and its rms. + call dgsvector (gs, x, y, zfit, npts) + call printf ("\nZFIT:\n") + do i = 1, npts { + call printf ("%6.3f ") + call pargd (zfit[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + rms1 = 0.0d0 + do i = 1, npts + rms1 = rms1 + (z[i] - zfit[i]) ** 2 + rms1 = sqrt (rms1 / (npts - 1)) + rms2 = 0.0d0 + do i = 1, npts + rms2 = rms2 + (z[i] - dgseval (gs, x[i], y[i])) ** 2 + rms2 = sqrt (rms2 / (npts - 1)) + #call printf ("\nRMS: vector = %0.14g point = %0.14g\n\n") + call printf ("\nRMS: vector = %0.4f point = %0.4f\n\n") + call pargd (rms1) + call pargd (rms2) + + # Print the coefficients. + call dgscoeff (gs, coeff, ncoeff) + call printf ("GSFIT coeff:\n") + call printf ("first %0.14g %0.14g\n") + call pargd (dgsgcoeff (gs, 1, 1)) + call pargd (dgsgcoeff (gs, xorder, 1)) + do i = 1, ncoeff { + call printf ("%d %0.14g\n") + call pargi (i) + call pargd (coeff[i]) + } + call printf ("last %0.14g %0.14g\n") + call pargd (dgsgcoeff (gs, 1, yorder)) + call pargd (dgsgcoeff (gs, xorder, yorder)) + call printf ("\n") + + call dgsfree (gs) + return + + # Evaluate the first derivatives. + call dgsder (gs, x, y, zfit, npts, 1, 0) + call printf ("\nZDER: 1 0\n") + do i = 1, npts { + call printf ("%0.7g ") + call pargd (zfit[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + + call dgsder (gs, x, y, zfit, npts, 0, 1) + call printf ("\nZDER: 0 1\n") + do i = 1, npts { + call printf ("%0.7g ") + call pargd (zfit[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + + call dgsder (gs, x, y, zfit, npts, 1, 1) + call printf ("\nZDER: 1 1\n") + do i = 1, npts { + call printf ("%0.7g ") + call pargd (zfit[i]) + if (mod (i, 9) == 0) + call printf ("\n") + } + call printf ("\n") + + # Refit the surface point by point. + call dgszero (gs) + do i = 1, npts { + call dgsaccum (gs, x[i], y[i], z[i], w[i], WTS_UNIFORM) + } + if (stype > 3) + call dgssolve1 (gs, ier) + else + call dgssolve (gs, ier) + call printf ("\nACCUM FIT ERROR CODE: %d\n") + call pargi (ier) + call dgsrej (gs, x[1], y[1], z[1], w[1], WTS_UNIFORM) + call dgsrej (gs, x[npts], y[npts], z[npts], w[npts], WTS_UNIFORM) + call dgsaccum (gs, x[1], y[1], z[1], w[1], WTS_UNIFORM) + call dgsaccum (gs, x[npts], y[npts], z[npts], w[npts], WTS_UNIFORM) + call dgssolve (gs, ier) + call printf ("\nREJ FIT ERROR CODE: %d\n") + call pargi (ier) + + call dgscoeff (gs, coeff, ncoeff) + call printf ("GSACCUM coeff:\n") + call printf ("first %0.14g %0.14g\n") + call pargd (dgsgcoeff (gs, 1, 1)) + call pargd (dgsgcoeff (gs, xorder, 1)) + do i = 1, ncoeff { + call printf ("%d %0.14g\n") + call pargi (i) + call pargd (coeff[i]) + } + call printf ("last %0.14g %0.14g\n") + call pargd (dgsgcoeff (gs, 1, yorder)) + call pargd (dgsgcoeff (gs, xorder, yorder)) + call printf ("\n") + + # Save and restore. + call dgssave (gs, save) + call dgsfree (gs) + call dgsrestore (gs, save) + + call dgscoeff (gs, coeff, ncoeff) + call printf ("RESTORE coeff:\n") + call printf ("first %0.14g %0.14g\n") + call pargd (dgsgcoeff (gs, 1, 1)) + call pargd (dgsgcoeff (gs, xorder, 1)) + do i = 1, ncoeff { + call printf ("%d %0.14g\n") + call pargi (i) + call pargd (coeff[i]) + } + call printf ("last %0.14g %0.14g\n") + call pargd (dgsgcoeff (gs, 1, yorder)) + call pargd (dgsgcoeff (gs, xorder, yorder)) + call printf ("\n") + + # Add two surfaces. + call dgsadd (gs, gs, ags) + call dgscoeff (ags, coeff, ncoeff) + call printf ("GSADD coeff:\n") + call printf ("first %0.14g %0.14g\n") + call pargd (dgsgcoeff (ags, 1, 1)) + call pargd (dgsgcoeff (ags, xorder, 1)) + do i = 1, ncoeff { + call printf ("%d %0.14g\n") + call pargi (i) + call pargd (coeff[i]) + } + call printf ("last %0.14g %0.14g\n") + call pargd (dgsgcoeff (ags, 1, yorder)) + call pargd (dgsgcoeff (ags, xorder, yorder)) + call printf ("\n") + + # Subtract two surfaces. + call dgssub (gs, gs, sgs) + call dgscoeff (sgs, coeff, ncoeff) + call printf ("GSSUB coeff:\n") + call printf ("first %0.14g %0.14g\n") + call pargd (dgsgcoeff (sgs, 1, 1)) + call pargd (dgsgcoeff (sgs, xorder, 1)) + do i = 1, ncoeff { + call printf ("%d %0.14g\n") + call pargi (i) + call pargd (coeff[i]) + } + call printf ("last %0.14g %0.14g\n") + call pargd (dgsgcoeff (sgs, 1, yorder)) + call pargd (dgsgcoeff (sgs, xorder, yorder)) + call printf ("\n") + + call dgsfree (gs) + call dgsfree (ags) + call dgsfree (sgs) +end |