diff options
Diffstat (limited to 'math/curfit')
99 files changed, 9800 insertions, 0 deletions
diff --git a/math/curfit/README b/math/curfit/README new file mode 100644 index 00000000..b622c824 --- /dev/null +++ b/math/curfit/README @@ -0,0 +1,6 @@ +Linear Least squares curve fitting package. +Contains routines to fit Legendre and Chebyshev polynomials and linear +cubic splines in the least squares sense to 1-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 curve. diff --git a/math/curfit/Revisions b/math/curfit/Revisions new file mode 100644 index 00000000..ea59404b --- /dev/null +++ b/math/curfit/Revisions @@ -0,0 +1,118 @@ +.help revisions Jun89 math.curfit +.nf +From Davis, September 20, 1999 + +Added some missing file dependices to the mkpkg file. +pkg/math/curfit/mkpkg + +From Davis, March 20, 1997 + +The weights computed by the WTS_CHISQ option in the routines cvacpts[rd] +were not being forced to be positive as intended. +math/curfit/cvacpts.gx +math/curfit/cvacptsr.x +math/curfit/cvacptsd.x + +There was an inconsistency in the way the ncoeff argument to the cvpower[rd] +routines was being used. Ncoeff was intended to be an output argument. +pkg/math/curfit/doc/cvpower.hlp +pkg/math/curfit/cvpower.gx +pkg/math/curfit/cvpowerr.x +pkg/math/curfit/cvpowerd.x + +From Davis, June 13, 1995 + +Added a new routine cvepower to the curfit math package. Cvepower computes +errors of the equivalent power series coefficients for the fitted Legendre +and Chebyshev polynomials and has the same calling sequence as the +cverrors routine. +math/curfit/cvpower.gx +math/curfit/cvpowerr.x +math/curfit/cvpowerd.x +math/curfit/doc/curfit.hd +math/curfit/doc/curfit.men +math/curfit/doc/cvepower.hlp + +From Davis, May, 6, 1990 + +Finished cleaning up the .gx files in curfit. +math/curfit/cverrors.gx +math/curfit/cvpower.gx +math/curfit/cvrefit.gx +math/curfit/cvpower.gx + +From Davis, May 6, 1990 + +Changed the constant from INDEFR to INDEF in the amov$t call in cvpower.gx. +This was causing a problem for the Mac compiler. + +From Davis, April 23, 1991 + +Did some cleaning up in the following .gx files to make the code easier to read. +math/curfit/cv_b1eval.gx +math/curfit/cv_beval.gx +math/curfit/cv_feval.gx +math/curfit/cvaccum.gx +math/curfit/cvacpts.gx +math/curfit/cvchomat.gx +math/curfit/cvfree.gx +math/curfit/cvinit.gx + +From Davis, September 18, 1990 + +Changed the int calls in cvrestore.gx to nint calls. This is a totally +safe way to do the conversion from double precision to integer +quantities in the curfit package and removes any potential precision +problems for task which must read the curfit structure back from a +text database file. + +From Davis, July 14, 1988: + +The calling sequence for the cverrors routine as been changed to include +an npts argument. This edition removesd the possibility for error when +points have been rejected by setting w[i] = 0. + +----------------------------------------------------------------------------- + +From Davis, April 30, 1986: + +1. Several bugs involving double precision constants in the double precision +version of curfit detected on the SUN have been fixed. + +----------------------------------------------------------------------------- + +From Davis, March 13, 1986: + +1. A double precision version of CURFIT has been installed in IRAF. The entry +points for the double precision version are identical to those of the real +version with the addition of a preceeding d (e.g. cveval and dcveval). All +internal arithmetic is done in double and the data is entered in double. + +2. A user function facility has been added to CURFIT. The user may enter +any linear function in the following manner. + + extern func + + ... + + call cvinit (cv, USERFNC, nterms, xmin, xmax) + call cvuser (cv, func) + call cvfit (cv, x, y, w, npts, WTS_USER, ier) + call cvvector (cv, x, yfit, npts) + call cvfree (cv) + + ... + +The user function must have the following form. + + procedure func (x, nterms, k1, k2, basis) + +where + + real x x value + int nterms number of basis functions + real k1, k2 optional normalization parameters + real basis[ARB] computed basis functions + +------------------------------------------------------------------------------- +.endhelp diff --git a/math/curfit/curfit.sem b/math/curfit/curfit.sem new file mode 100644 index 00000000..28058626 --- /dev/null +++ b/math/curfit/curfit.sem @@ -0,0 +1,708 @@ +# Semi-code for curfit.h + +# define the permitted types of curves + +define CHEBYSHEV 1 +define LEGENDRE 2 +define L2SPLINE4 3 + +# define the weighting flags + +define NORMAL 1 # user enters weights +define UNIFORM 2 # equal weights, weight 1.0 +define SPACING 3 # weigth proportional to spacing of data points + +define SPLINE_ORDER 4 + +# set up the curve fitting structure + +define LEN_CVSTRUCT + +struct curfit { + +define CV_TYPE Memi[] # Type of curve to be fitted +define CV_ORDER Memi[] # Order of the fit +define CV_NPIECES Memi[] # Number of polynomial pieces, spline +define CV_NCOEFF Memi[] # Number of coefficients +define CV_XMAX Memr[] # Maximum x value +define CV_XMIN Memr[] # Minimum x value +define CV_RANGE Memr[] # Xmax minus xmin +define CV_MAXMIN Memr[] # Xmax plus xmin +define CV_SPACING Memr[] # Knot spacing for splines +define CV_YNORM Memr[] # Norm of the Y vector +define CV_NPTS Memi[] # Number of data points + +define CV_MATRIX Memi[] # Pointer to original matrix +define CV_CHOFAC Memi[] # Pointer to Cholesky factorization +define CV_BASIS Memi[] # Pointer to basis functions +define CV_VECTOR Memi[] # Pointer to vector +define CV_COEFF Memi[] # Pointer to coefficient vector +define CV_LEFT Memi[] # + +} + +# matrix and vector element definitions + +define MATRIX Memr[$1+($2-1)*NCOEFF(cv)] # Matrix element +define CHOFAC Memr[$1+($2-1)*NCOEFF(cv)] # Triangular matrix +define VECTOR Memr[$1+$2] # Right side +define COEFF Memr[$1+$2] # Coefficient vector +define LEFT Memi[$1+$2] + +# matrix and vector definitions + +define MAT Memr[$1] +define CHO Memr[$1] +define VECT Memr[$1] +define COF Memr[$1] + +# semi-code for the initialization procedure + +include "curfit.h" + +# CVINIT -- Procedure to set up the curve descriptor. + +procedure cvinit (cv, curve_type, order, xmin, xmax) + +pointer cv # pointer to curve descriptor structure +int curve_type # type of curve to be fitted +int order # order of curve to be fitted, or in the case of the + # spline the number of polynomial pieces to be fit +real xmin # minimum value of x +real xmax # maximum value of x + +begin + # allocate space for the curve descriptor + call smark (sp) + call salloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + if (order < 1) + call error (0, "CVINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "CVINIT: xmax <= xmin.") + + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(CV) = order + CV_RANGE(cv) = xmax - xmin + CV_MAXMIN(cv) = xmax + xmin + case L2SPLINE4: + CV_ORDER(cv) = SPLINE_ORDER + CV_NCOEFF(cv) = order + SPLINE_ORDER - 1 + CV_NPIECES(cv) = order + CV_SPACING(cv) = (xmax - xmin) / order + default: + call error (0, "CVINIT: Unknown curve type.") + } + + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for the matrix and vectors + call calloc (CV_MATRIX(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_REAL) + call calloc (CV_CHOFAC(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_REAL) + call calloc (CV_VECTOR(cv), CV_NCOEFF(cv), TY_REAL) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_REAL) + + # initialize pointer to basis functions to null + CV_BASIS(cv) = NULL + + CV_NPTS(cv) = 0 + CV_YNORM(cv) = 0. +end + +# semi-code for cvaccum + +include "curfit.h" + +# CVACCUM -- Procedure to add a single point to the data set. + +procedure cvaccum (cv, x, y, w, wtflag) + +pointer cv # curve descriptor +real x # x value +real y # y value +real w # weight of the data point +int wtflag # type of weighting desired + +begin + # calculate the weights + switch (wtflag) { + case UNIFORM: + w = 1.0 + case NORMAL, SPACING: # problem spacing + default: + w = 1.0 + } + + # caculate all non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 1 + call chebyshev (cv, x, basis) + case LEGENDRE: + left = 1 + call legendre (cv, x, basis) + case L2SPLINE4: + call l2spline4 (cv, x, left, basis) + } + + # accumulate into the matrix + leftm1 = left - 1 + vptr = CV_VECTOR(cv) - 1 + do i = 1, CV_ORDER(cv) { + bw = basis[i] * w + jj = leftm1 + i + mptr = CV_MATRIX(cv) + jj - 1 + VECTOR(vptr, jj) = VECTOR(vptr, jj) + bw * y + ii = 1 + do j = i, CV_ORDER(cv) { + MATRIX(mptr, ii) = MATRIX(mptr, ii) + basis[j] * bw + ii = ii + 1 + } + } + + CV_NPTS(cv) = CV_NPTS(cv) + 1 + CV_YNORM(cv) = CV_YNORM(cv) + w * y * y +end + +# semi-code for cvreject + +include "curfit.h" + +# CVREJECT -- Procedure to subtract a single datapoint from the data set +# to be fitted. + +procedure cvreject (cv, x, y, w) + +pointer cv # curve fitting image descriptor +real x # x value +real y # y value +real w # weight of the data point + +begin + # caculate all type non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 1 + call chebyshev (cv, x, basis) + case LEGENDRE: + left = 1 + call legendre (cv, x, basis) + case L2SPLINE4: + call l2spline4 (cv, x, left, basis) + } + + # subtract the data point from the matrix + leftm1 = left - 1 + vptr = CV_VECTOR(cv) - 1 + do i = 1, CV_ORDER(cv) { + bw = basis[i] * w + jj = leftm1 + i + mptr = CV_MATRIX(cv) + jj - 1 + VECTOR(vptr, jj) = VECTOR(vptr, jj) - bw * y + ii = 1 + do j = i, CV_ORDER(cv) { + MATRIX(mptr, ii) = MATRIX(mptr, ii) - basis[j] * bw + ii = ii + 1 + } + } + + CV_NPTS(cv) = CV_NPTS(cv) - 1 + CV_NORM(cv) = CV_NORM(cv) - w * y * y +end + +# semi-code for cvsolve + +include "curfit.h" + +# CVSOLVE -- Procedure to solve a matrix equation of the form Ax = B. +# The Cholesky factorization of matrix A is calculated in the first +# step, followed by forward and back substitution to solve for the vector +# x. + +procedure cvsolve (cv, ier) + +pointer cv # pointer to the image descriptor structure +int ier # ier = 0, everything OK + # ier = 1, matrix is singular + +begin + # solve matrix by adapting Deboor's bchfac.f and bchslv.f routines + # so that the original matrix and vector are not destroyed + + call chofac (MAT(CV_MATRIX(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + CHO(CV_CHOFAC(cv)), ier) + call choslv (CHO(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECT(CV_VECTOR(cv)), COF(CV_COEFF(cv))) +end + +# semi-code for cvfit + +include "curfit.h" + +# CVFIT -- Procedure to fit a curve to an array of data points x and y with +# weights w. + +procedure cvfit (x, y, w, npts, wtflag, ier) + +real x[npts] # array of abcissa +real y[npts] # array of ordinates +real w[npts] # array of weights +int wtflag # type of weighting +int ier + +begin + # calculate weights + switch (wtflag) { + case UNIFORM: + call amovkr (1., w, npts) + case SPACING: + w[1] = x[2] - x[1] # check for npts > 1 + do i = 2, npts - 1 + w[i] = x[i+1] - x[i-1] + w[npts] = x[npts] - x[npts-1] + case NORMAL: + default: + call amovkr (1., w, npts) + } + + # accumulate data points + do i = 1, npts { + + CV_NPTS(cv) = CV_NPTS(cv) + 1 + + # calculate the norm of the Y vector + CV_YNORM(cv) = CV_YNORM(cv) + w[i] * y[i] * y[i] + + # calculate non zero basis functions + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 1 + call chebyshev (cv, x, basis) + case LEGENDRE: + left = 1 + call legendre (cv, x, basis) + case L2SPLINE4: + call l2spline4 (cv, x, left, basis) + } + + # accumulate the matrix + leftm1 = left - 1 + vptr = CV_VECTOR(cv) - 1 + do i = 1, CV_ORDER(cv) { + bw = basis[i] * w + jj = leftm1 + i + mptr = CV_MATRIX(cv) + jj - 1 + VECTOR(vptr, jj) = VECTOR(vptr, jj) + bw * y + ii = 1 + do j = i, CV_ORDER(cv) { + MATRIX(mptr, ii) = MATRIX(mptr, ii) + basis[j] * bw + ii = ii + 1 + } + } + } + + # solve the matrix + ier = 0 + call chofac (MAT(CV_MATRIX(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + CHO(CV_CHOFAC(cv)), ier) + call choslv (CHO(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECT(CV_VECTOR(cv)), COF(CV_COEFF(cv))) +end + +# semi-code for cvrefit + +include "curfit.com" + +# CV_REFIT -- Procedure to refit the data assuming that the x and w values do +# not change. + +procedure cvrefit (cv, x, y, w, ier) + +pointer cv +real x[ARB] +real y[ARB] +real w[ARB] +int ier + +begin + # if first call to refit then calculate and store the basis + # functions + + vcptr = CV_VECTOR(cv) - 1 + do i = 1, NCOEFF(cv) + VECTOR(vcptr+i) = 0. + + CV_YNORM(cv) = 0. + lptr = CV_LEFT(cv) - 1 + bcptr = CV_BASIS(cv) - CV_NPTS(cv) + + if (CV_BASIS(cv) == NULL) { + + call calloc (CV_BASIS(cv), CV_NPTS(cv)*CV_ORDER(cv), TY_REAL) + call calloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + + do l = 1, CV_NPTS(cv) { + bptr = bcptr + l * CV_NPTS(cv) + switch (CV_TYPE(cv)) { + case LEGENDRE: + LEFT(lptr+l) = 1 + call legendre (cv, x, BASIS(bptr)) + case CHEBYSHEV: + LEFT(lptr+l) = 1 + call chebyshev (cv, x, BASIS(bptr)) + case L2SPLINE4: + call l2spline4 (cv, x, LEFT(lptr+l), BASIS(bptr)) + } + } + } + + # reset vector to zero + + # accumulate right side of the matrix equation + do l = 1, CV_NPTS(cv) { + + CV_YNORM(cv) = CV_YNORM(cv) + w[l] * y[l] * y[l] + leftm1 = LEFT(lptr+l) - 1 + bptr = bcptr + l * CV_NPTS(cv) + + do i = 1, CV_ORDER(cv) { + vptr = vcptr + leftm1 + i + VECTOR(vptr) = VECTOR(vptr) + BASIS(bptr) * w[l] * y[l] + } + } + + # solve the matrix + call choslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(CV), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end + +# semi-code for cvcoeff + +# CVCOEFF -- Procedure to fetch the number and magnitude of the coefficients. + +procedure cvcoeff (cv, coeff, ncoeff) + +pointer cv # pointer to the curve fitting descriptor +real coeff[ncoeff] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + ncoeff = CV_NCOEFF(cv) + cptr = CV_COEFF(cv) - 1 + do i = 1, ncoeff + coeff[i] = COEFF(cptr, i) +end + +# semi-code for cvvector + +include "curfit.h" + +# CVVECTOR -- Procedure to evaluate the fitted curve + +procedure cvvector (cv, x, npts, yfit) + +pointer cv # pointer to the curve descriptor structure +real x[npts] # data x values +int npts # number of data points +real yfit[npts] # the fitted y values + +begin + do l = 1, npts { + + # calculate the non-zero basis functions + switch (CV_TYPE(cv) { + case LEGENDRE: + left = 1 + call legendre (cv, x[l], XBASIS(CV_XBASIS(cv))) + case CHEBYSHEV: + left = 1 + call chebyshev (cv, x[l], XBASIS(CV_XBASIS(cv))) + case L2SPLINE4: + call l2spline4 (cv, x[l], left, XBASIS(CV_XBASIS(cv))) + } + + sum = 0.0 + leftm1 = left - 1 + cptr = CV_COEFF(cv) - 1 + xptr = CV_XBASIS(cv) - 1 + + do i = 1, CV_NCOEFF(cv) { + jj = leftm1 + i + sum = sum + XBASIS(xptr + i) * COEFF(cptr + jj) + } + } +end + +# semi-code for cveval + +include "curfit.h" + +# CVEVAL -- Procedure to evaluate curve at a given x + +real procedure cveval (cv, x) + +pointer cv # pointer to image descriptor structure +real x # x value + +int left, leftm1, i +pointer cptr, xptr +real sum + +begin + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 1 + call chebyshev (cv, x, XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 1 + call legendre (cv, x, XBASIS(CV_XBASIS(cv))) + case L2SPLINE4: + call l2spline4 (cv, x, left, XBASIS(CV_XBASIS(cv))) + } + + sum = 0. + leftm1 = left - 1 + cptr = CV_COEFF(cv) - 1 + xptr = CV_XBASIS(cv) - 1 + do i = 1, CV_NCOEFF(cv) { + jj = leftm1 + i + sum = sum + XBASIS(xptr + i) * COEFF(cptr + jj) + } + + return (sum) +end + +# semi-code for cverrors + +include "curfit.h" + +# CVERRORS -- Procedure to calculate the standard deviation of the fit and the +# standard deviations of the coefficients + +procedure cverrors (cv, rms, errors) + +pointer cv # curve descriptor +real rms # standard deviation of data with respect to fit +real errors[ARB] # errors in coefficients + +begin + # calculate the variance + rms = CV_YNORM(cv) + cptr = CV_COEFF(cv) - 1 + vptr = CV_VECTOR(cv) - 1 + do i = 1, CV_NCOEFF(cv) + rms = rms - COEFF(cptr, i) * VECTOR(vptr, i) + rms = rms / (CV_NPTS(cv) - CV_NCOEFF(cv)) + + # calculate the standard deviations + do i = 1, CV_NCOEFF(cv) { + do j = 1, CV_NCOEFF(cv) + cov[j] = 0. + cov[i] = 1. + call choslv (CHO(CV_CHOFAC(cv)), CV_ORDER(cv), + CV_NCOEFF(cv), cov, cov) + errors[i] = sqrt (cov[i] * rms) + } + + rms = sqrt (rms) +end + +# semi-code for CVFREE + +# CVFREE -- Procedure to free the curve descriptor + +procedure cvfree (cv) + +pointer cv + +begin + call sfree (cv) +end + +include "curfit.h" + +# LEGENDRE -- Procedure to calculate the Legendre functions. + +procedure legendre (cv, x, basis) + +pointer cv +real x +real basis[ARB] + +begin + # normalize to the range x = -1. to 1. + xnorm = (2. * x - CV_MAXMIN(cv)) / CV_RANGE(cv) + + b[1] = 1.0 + if (CV_ORDER(cv) == 1) + return + + b[2] = xnorm + if (CV_ORDER(cv) == 2) + return + + do i = 3, CV_ORDER(cv) { + ri = i + b[i] = ((2.*ri-3.)*xnorm*b[i-1] - (ri-2.)*b[i-2]) / (ri-1.) + } +end + +# CHEBYSHEV -- Procedure to calculate Chebyshev polynomials. + +procedure chebyshev (cv, x, basis) + +real x +int order +real basis[ARB] + +begin + # normalize to the range -1. to 1. + xnorm = (2. * x - CV_MAXMIN(cv)) / CV_RANGE(cv) + + b[1] = 1. + if (CV_ORDER(cv) == 1) + return + + b[2] = xnorm + if (CV_ORDER(cv) == 2) + return + + do i = 3, CV_ORDER(cv) { + ri = i + b[i] = 2.*xnorm*b[i-1] - b[i-2] + } +end + +define NPTS_SPLINE 401 # Number of points in the spline lookup table +define INTERVALS 100 # Number of intervals per spline knot + +# L2SPLINE4 -- Procedure to calculate the cubic spline functions + +procedure (cv, x, left, basis) + +pointer cv +real x +int left +real basis[ARB] + +real table[NPTS_SPLINE] + +# data table containing the spline +include "table.dat" + +begin + xnorm = (x - CV_XMIN(cv)) / CV_SPACING(cv) + temp = min (int (xnorm), npieces - 1) + left = temp + 1 + xnorm = xnorm - temp + + near = int ((1. - xnorm + 0.5) * INTERVALS) + 1 + basis[1] = table[near] + near = table[near] + INTERVALS + basis[2] = table[near] + near = table[near] + INTERVALS + basis[3] = table[near] + near = table[near] + INTERVALS + basis[4] = table[near] +end + +# CHOFAC -- Routine to calculate the Cholesky factorization of a banded +# matrix. + +procedure chofac (matrix, nbands, nrows, matfac, ier) + +real matrix[nbands, nrows] +int nbands +int nrows +real matfac[nbands, nrows] +int ier + +begin + ier = 0 + + if (nrows == 1) { + if (matrix[1,1] .gt. 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]) { + do j = 1, nbands + w[j,n] = 0. + ier = 1 + 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 + +# CHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# CHOFAC. + +procedure choslv (matfac, nbands, nrows, vector, coeff) + +real matfac[nbands,nrows] +int nbands +int nrows +real vector[nrows] +real coeff[nrows] + +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) + next + do j = 1, jmax + coeff[j+n] = coeff[j+n] - matfac[j+1,n] * b[n] + } + + # back substitution + for (n = nrows; n > 0; n = n - 1) { + coeff[n] = coeff[n] * matfac[1,n] + jmax = min (nbndm1, nrows - 1) + if (jmax >= 1) { + do j = 1, jmax + coeff[n] = coeff[n] - matfac[j+1,n] * coeff[j+n] + } + } + +end diff --git a/math/curfit/curfitdef.h b/math/curfit/curfitdef.h new file mode 100644 index 00000000..b72349ac --- /dev/null +++ b/math/curfit/curfitdef.h @@ -0,0 +1,55 @@ +# Header file for the curve fitting package + +# set up the curve descriptor structure + +define LEN_CVSTRUCT 20 + +define CV_TYPE Memi[$1] # Type of curve to be fitted +define CV_ORDER Memi[$1+1] # Order of the fit +define CV_NPIECES Memi[$1+2] # Number of polynomial pieces - 1 +define CV_NCOEFF Memi[$1+3] # Number of coefficients +define CV_XMAX Memr[P2R($1+4)] # Maximum x value +define CV_XMIN Memr[P2R($1+5)] # Minimum x value +define CV_RANGE Memr[P2R($1+6)] # 2. / (xmax - xmin), polynomials +define CV_MAXMIN Memr[P2R($1+7)] # - (xmax + xmin) / 2., polynomials +define CV_SPACING Memr[P2R($1+8)] # order / (xmax - xmin), splines +define CV_NPTS Memi[$1+9] # Number of data points + +define CV_XBASIS Memi[$1+10] # Pointer to non zero basis for single x +define CV_MATRIX Memi[$1+11] # Pointer to original matrix +define CV_CHOFAC Memi[$1+12] # Pointer to Cholesky factorization +define CV_VECTOR Memi[$1+13] # Pointer to vector +define CV_COEFF Memi[$1+14] # Pointer to coefficient vector +define CV_BASIS Memi[$1+15] # Pointer to basis functions (all x) +define CV_LEFT Memi[$1+16] # Pointer to first non-zero basis +define CV_WY Memi[$1+17] # Pointer to y * w (cvrefit) +define CV_USERFNC Memi[$1+18] # Pointer to external user subroutine +define CV_USERFNCR Memr[P2R($1+18)]# Real version of above for cvrestore. + # one free slot left + +# matrix and vector element definitions + +define XBASIS Memr[P2P($1)] # Non zero basis for single x +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 +define BASIS Memr[P2P($1)] # Element of BASIS +define LEFT Memi[P2P($1)] # Element of LEFT + +# structure definitions for restore + +define CV_SAVETYPE $1[1] +define CV_SAVEORDER $1[2] +define CV_SAVEXMIN $1[3] +define CV_SAVEXMAX $1[4] +define CV_SAVEFNC $1[5] + +define CV_SAVECOEFF 5 + + +# miscellaneous + +define SPLINE3_ORDER 4 +define SPLINE1_ORDER 2 +define DELTA EPSILON diff --git a/math/curfit/cv_b1eval.gx b/math/curfit/cv_b1eval.gx new file mode 100644 index 00000000..bd77f0ed --- /dev/null +++ b/math/curfit/cv_b1eval.gx @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_B1LEG -- Procedure to evaluate all the non-zero Legendrefunctions for +# a single point and given order. + +procedure $tcv_b1leg (x, order, k1, k2, basis) + +PIXEL x # array of data points +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] = PIXEL(1.0) + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((PIXEL(2.0) * ri - PIXEL(3.0)) * xnorm * basis[i-1] - + (ri - PIXEL(2.0)) * basis[i-2]) / (ri - PIXEL(1.0)) + } +end + + +# CV_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure $tcv_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] = PIXEL(1.0) + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = PIXEL(2.0) * xnorm * basis[i-1] - basis[i-2] +end + + +# CV_B1SPLINE1 -- Evaluate all the non-zero spline1 functions for a +# single point. + +procedure $tcv_b1spline1 (x, npieces, k1, k2, basis, left) + +PIXEL x # set of data points +int npieces # number of polynomial pieces minus 1 +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions +int left # index of the appropriate spline functions + +PIXEL xnorm + +begin + xnorm = (x + k1) * k2 + left = min (int (xnorm), npieces) + + basis[2] = max (PIXEL(0.0), min (PIXEL(1.0), xnorm - left)) + basis[1] = max (PIXEL(0.0), min (PIXEL(1.0), PIXEL(1.0) - basis[2])) +end + + +# CV_B1SPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure $tcv_b1spline3 (x, npieces, k1, k2, basis, left) + +PIXEL x # array of data points +int npieces # number of polynomial pieces +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # array of basis functions +int left # array of indices for first non-zero spline + +PIXEL sx, tx + +begin + sx = (x + k1) * k2 + left = min (int (sx), npieces) + + sx = max (PIXEL(0.0), min (PIXEL(1.0), sx - left)) + tx = max (PIXEL(0.0), min (PIXEL(1.0), PIXEL(1.0) - sx)) + + basis[1] = tx * tx * tx + basis[2] = PIXEL(1.0) + tx * (PIXEL(3.0) + tx * (PIXEL(3.0) - + PIXEL(3.0) * tx)) + basis[3] = PIXEL(1.0) + sx * (PIXEL(3.0) + sx * (PIXEL(3.0) - + PIXEL(3.0) * sx)) + basis[4] = sx * sx * sx +end diff --git a/math/curfit/cv_b1evald.x b/math/curfit/cv_b1evald.x new file mode 100644 index 00000000..d5254ed8 --- /dev/null +++ b/math/curfit/cv_b1evald.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_B1LEG -- Procedure to evaluate all the non-zero Legendrefunctions for +# a single point and given order. + +procedure dcv_b1leg (x, order, k1, k2, basis) + +double x # array of data points +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] = double(1.0) + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((double(2.0) * ri - double(3.0)) * xnorm * basis[i-1] - + (ri - double(2.0)) * basis[i-2]) / (ri - double(1.0)) + } +end + + +# CV_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure dcv_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] = double(1.0) + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = double(2.0) * xnorm * basis[i-1] - basis[i-2] +end + + +# CV_B1SPLINE1 -- Evaluate all the non-zero spline1 functions for a +# single point. + +procedure dcv_b1spline1 (x, npieces, k1, k2, basis, left) + +double x # set of data points +int npieces # number of polynomial pieces minus 1 +double k1, k2 # normalizing constants +double basis[ARB] # basis functions +int left # index of the appropriate spline functions + +double xnorm + +begin + xnorm = (x + k1) * k2 + left = min (int (xnorm), npieces) + + basis[2] = max (double(0.0), min (double(1.0), xnorm - left)) + basis[1] = max (double(0.0), min (double(1.0), double(1.0) - basis[2])) +end + + +# CV_B1SPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure dcv_b1spline3 (x, npieces, k1, k2, basis, left) + +double x # array of data points +int npieces # number of polynomial pieces +double k1, k2 # normalizing constants +double basis[ARB] # array of basis functions +int left # array of indices for first non-zero spline + +double sx, tx + +begin + sx = (x + k1) * k2 + left = min (int (sx), npieces) + + sx = max (double(0.0), min (double(1.0), sx - left)) + tx = max (double(0.0), min (double(1.0), double(1.0) - sx)) + + basis[1] = tx * tx * tx + basis[2] = double(1.0) + tx * (double(3.0) + tx * (double(3.0) - + double(3.0) * tx)) + basis[3] = double(1.0) + sx * (double(3.0) + sx * (double(3.0) - + double(3.0) * sx)) + basis[4] = sx * sx * sx +end diff --git a/math/curfit/cv_b1evalr.x b/math/curfit/cv_b1evalr.x new file mode 100644 index 00000000..fd6fb8e7 --- /dev/null +++ b/math/curfit/cv_b1evalr.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_B1LEG -- Procedure to evaluate all the non-zero Legendrefunctions for +# a single point and given order. + +procedure rcv_b1leg (x, order, k1, k2, basis) + +real x # array of data points +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] = real(1.0) + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order { + ri = i + basis[i] = ((real(2.0) * ri - real(3.0)) * xnorm * basis[i-1] - + (ri - real(2.0)) * basis[i-2]) / (ri - real(1.0)) + } +end + + +# CV_B1CHEB -- Procedure to evaluate all the non zero Chebyshev function +# for a given x and order. + +procedure rcv_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] = real(1.0) + if (order == 1) + return + + xnorm = (x + k1) * k2 + basis[2] = xnorm + if (order == 2) + return + + do i = 3, order + basis[i] = real(2.0) * xnorm * basis[i-1] - basis[i-2] +end + + +# CV_B1SPLINE1 -- Evaluate all the non-zero spline1 functions for a +# single point. + +procedure rcv_b1spline1 (x, npieces, k1, k2, basis, left) + +real x # set of data points +int npieces # number of polynomial pieces minus 1 +real k1, k2 # normalizing constants +real basis[ARB] # basis functions +int left # index of the appropriate spline functions + +real xnorm + +begin + xnorm = (x + k1) * k2 + left = min (int (xnorm), npieces) + + basis[2] = max (real(0.0), min (real(1.0), xnorm - left)) + basis[1] = max (real(0.0), min (real(1.0), real(1.0) - basis[2])) +end + + +# CV_B1SPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure rcv_b1spline3 (x, npieces, k1, k2, basis, left) + +real x # array of data points +int npieces # number of polynomial pieces +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions +int left # array of indices for first non-zero spline + +real sx, tx + +begin + sx = (x + k1) * k2 + left = min (int (sx), npieces) + + sx = max (real(0.0), min (real(1.0), sx - left)) + tx = max (real(0.0), min (real(1.0), real(1.0) - sx)) + + basis[1] = tx * tx * tx + basis[2] = real(1.0) + tx * (real(3.0) + tx * (real(3.0) - + real(3.0) * tx)) + basis[3] = real(1.0) + sx * (real(3.0) + sx * (real(3.0) - + real(3.0) * sx)) + basis[4] = sx * sx * sx +end diff --git a/math/curfit/cv_beval.gx b/math/curfit/cv_beval.gx new file mode 100644 index 00000000..3bb2b2e1 --- /dev/null +++ b/math/curfit/cv_beval.gx @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure $tcv_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) + call amovk$t (PIXEL(1.0), basis, npts) + 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) + call amulk$t (basis[bptr], PIXEL(2.0), basis[bptr], npts) + call asub$t (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + bptr = bptr + npts + } +end + + +# CV_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure $tcv_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) + call amovk$t (PIXEL(1.0), basis, npts) + else if (k == 2) + call alta$t (x, basis[bptr], npts, k1, k2) + 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 (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 + + +# CV_BSPLINE1 -- Evaluate all the non-zero spline1 functions for a set +# of points. + +procedure $tcv_bspline1 (x, npts, npieces, k1, k2, basis, left) + +PIXEL x[npts] # set of data points +int npts # number of points +int npieces # number of polynomial pieces minus 1 +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # basis functions +int left[ARB] # indices of the appropriate spline functions + +int k + +begin + call alta$t (x, basis[1+npts], npts, k1, k2) + call acht$ti (basis[1+npts], left, npts) + call aminki (left, npieces, left, npts) + + do k = 1, npts { + basis[npts+k] = max (PIXEL(0.0), min (PIXEL(1.0), + basis[npts+k] - left[k])) + basis[k] = max (PIXEL(0.0), min (PIXEL(1.0), PIXEL(1.0) - + basis[npts+k])) + } +end + + +# CV_BSPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure $tcv_bspline3 (x, npts, npieces, k1, k2, basis, left) + +PIXEL x[npts] # array of data points +int npts # number of data points +int npieces # number of polynomial pieces minus 1 +PIXEL k1, k2 # normalizing constants +PIXEL basis[ARB] # array of basis functions +int left[ARB] # array of indices for first non-zero spline + +int i +pointer sp, sx, tx +PIXEL dsx, dtx + +begin + # allocate space + call smark (sp) + call salloc (sx, npts, TY_PIXEL) + call salloc (tx, npts, TY_PIXEL) + + # calculate the index of the first non-zero coeff + call alta$t (x, Mem$t[sx], npts, k1, k2) + call acht$ti (Mem$t[sx], left, npts) + call aminki (left, npieces, left, npts) + + do i = 1, npts { + Mem$t[sx+i-1] = max (PIXEL(0.0), min (PIXEL(1.0), + Mem$t[sx+i-1] - left[i])) + Mem$t[tx+i-1] = max (PIXEL(0.0), min (PIXEL(1.0), PIXEL(1.0) - + Mem$t[sx+i-1])) + } + + # calculate the basis function + #call apowk$t (Mem$t[tx], 3, basis, npts) + do i = 1, npts { + dsx = Mem$t[sx+i-1] + dtx = Mem$t[tx+i-1] + basis[i] = dtx * dtx * dtx + basis[npts+i] = PIXEL(1.0) + dtx * (PIXEL(3.0) + dtx * + (PIXEL(3.0) - PIXEL(3.0) * dtx)) + basis[2*npts+i] = PIXEL(1.0) + dsx * (PIXEL(3.0) + dsx * + (PIXEL(3.0) - PIXEL(3.0) * dsx)) + basis[3*npts+i] = dsx * dsx * dsx + } + #call apowk$t (Mem$t[sx], 3, basis[1+3*npts], npts) + + # release space + call sfree (sp) +end diff --git a/math/curfit/cv_bevald.x b/math/curfit/cv_bevald.x new file mode 100644 index 00000000..7d7f6e44 --- /dev/null +++ b/math/curfit/cv_bevald.x @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure dcv_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 (double(1.0), 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], double(2.0), basis[bptr], npts) + call asubd (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + bptr = bptr + npts + } +end + + +# CV_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure dcv_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 (double(1.0), basis, npts) + else if (k == 2) + call altad (x, basis[bptr], npts, k1, k2) + 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 (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 + + +# CV_BSPLINE1 -- Evaluate all the non-zero spline1 functions for a set +# of points. + +procedure dcv_bspline1 (x, npts, npieces, k1, k2, basis, left) + +double x[npts] # set of data points +int npts # number of points +int npieces # number of polynomial pieces minus 1 +double k1, k2 # normalizing constants +double basis[ARB] # basis functions +int left[ARB] # indices of the appropriate spline functions + +int k + +begin + call altad (x, basis[1+npts], npts, k1, k2) + call achtdi (basis[1+npts], left, npts) + call aminki (left, npieces, left, npts) + + do k = 1, npts { + basis[npts+k] = max (double(0.0), min (double(1.0), + basis[npts+k] - left[k])) + basis[k] = max (double(0.0), min (double(1.0), double(1.0) - + basis[npts+k])) + } +end + + +# CV_BSPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure dcv_bspline3 (x, npts, npieces, k1, k2, basis, left) + +double x[npts] # array of data points +int npts # number of data points +int npieces # number of polynomial pieces minus 1 +double k1, k2 # normalizing constants +double basis[ARB] # array of basis functions +int left[ARB] # array of indices for first non-zero spline + +int i +pointer sp, sx, tx +double dsx, dtx + +begin + # allocate space + call smark (sp) + call salloc (sx, npts, TY_DOUBLE) + call salloc (tx, npts, TY_DOUBLE) + + # calculate the index of the first non-zero coeff + call altad (x, Memd[sx], npts, k1, k2) + call achtdi (Memd[sx], left, npts) + call aminki (left, npieces, left, npts) + + do i = 1, npts { + Memd[sx+i-1] = max (double(0.0), min (double(1.0), + Memd[sx+i-1] - left[i])) + Memd[tx+i-1] = max (double(0.0), min (double(1.0), double(1.0) - + Memd[sx+i-1])) + } + + # calculate the basis function + #call apowk$t (Mem$t[tx], 3, basis, npts) + do i = 1, npts { + dsx = Memd[sx+i-1] + dtx = Memd[tx+i-1] + basis[i] = dtx * dtx * dtx + basis[npts+i] = double(1.0) + dtx * (double(3.0) + dtx * + (double(3.0) - double(3.0) * dtx)) + basis[2*npts+i] = double(1.0) + dsx * (double(3.0) + dsx * + (double(3.0) - double(3.0) * dsx)) + basis[3*npts+i] = dsx * dsx * dsx + } + #call apowk$t (Mem$t[sx], 3, basis[1+3*npts], npts) + + # release space + call sfree (sp) +end diff --git a/math/curfit/cv_bevalr.x b/math/curfit/cv_bevalr.x new file mode 100644 index 00000000..b36aebad --- /dev/null +++ b/math/curfit/cv_bevalr.x @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_BCHEB -- Procedure to evaluate all the non-zero Chebyshev functions for +# a set of points and given order. + +procedure rcv_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 (real(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], real(2.0), basis[bptr], npts) + call asubr (basis[bptr], basis[bptr-2*npts], basis[bptr], npts) + } + bptr = bptr + npts + } +end + + +# CV_BLEG -- Procedure to evaluate all the non zero Legendre function +# for a given order and set of points. + +procedure rcv_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 (real(1.0), basis, npts) + else if (k == 2) + call altar (x, basis[bptr], npts, k1, k2) + 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 (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 + + +# CV_BSPLINE1 -- Evaluate all the non-zero spline1 functions for a set +# of points. + +procedure rcv_bspline1 (x, npts, npieces, k1, k2, basis, left) + +real x[npts] # set of data points +int npts # number of points +int npieces # number of polynomial pieces minus 1 +real k1, k2 # normalizing constants +real basis[ARB] # basis functions +int left[ARB] # indices of the appropriate spline functions + +int k + +begin + call altar (x, basis[1+npts], npts, k1, k2) + call achtri (basis[1+npts], left, npts) + call aminki (left, npieces, left, npts) + + do k = 1, npts { + basis[npts+k] = max (real(0.0), min (real(1.0), + basis[npts+k] - left[k])) + basis[k] = max (real(0.0), min (real(1.0), real(1.0) - + basis[npts+k])) + } +end + + +# CV_BSPLINE3 -- Procedure to evaluate all the non-zero basis functions +# for a cubic spline. + +procedure rcv_bspline3 (x, npts, npieces, k1, k2, basis, left) + +real x[npts] # array of data points +int npts # number of data points +int npieces # number of polynomial pieces minus 1 +real k1, k2 # normalizing constants +real basis[ARB] # array of basis functions +int left[ARB] # array of indices for first non-zero spline + +int i +pointer sp, sx, tx +real dsx, dtx + +begin + # allocate space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (tx, npts, TY_REAL) + + # calculate the index of the first non-zero coeff + call altar (x, Memr[sx], npts, k1, k2) + call achtri (Memr[sx], left, npts) + call aminki (left, npieces, left, npts) + + do i = 1, npts { + Memr[sx+i-1] = max (real(0.0), min (real(1.0), + Memr[sx+i-1] - left[i])) + Memr[tx+i-1] = max (real(0.0), min (real(1.0), real(1.0) - + Memr[sx+i-1])) + } + + # calculate the basis function + #call apowk$t (Mem$t[tx], 3, basis, npts) + do i = 1, npts { + dsx = Memr[sx+i-1] + dtx = Memr[tx+i-1] + basis[i] = dtx * dtx * dtx + basis[npts+i] = real(1.0) + dtx * (real(3.0) + dtx * + (real(3.0) - real(3.0) * dtx)) + basis[2*npts+i] = real(1.0) + dsx * (real(3.0) + dsx * + (real(3.0) - real(3.0) * dsx)) + basis[3*npts+i] = dsx * dsx * dsx + } + #call apowk$t (Mem$t[sx], 3, basis[1+3*npts], npts) + + # release space + call sfree (sp) +end diff --git a/math/curfit/cv_feval.gx b/math/curfit/cv_feval.gx new file mode 100644 index 00000000..759bb193 --- /dev/null +++ b/math/curfit/cv_feval.gx @@ -0,0 +1,242 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure $tcv_evcheb (coeff, x, yfit, npts, order, k1, k2) + +PIXEL coeff[ARB] # 1D 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 + if (order == 1) { + call amovk$t (coeff[1], yfit, npts) + 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) + call salloc (sx, npts, TY_PIXEL) + call salloc (pn, npts, TY_PIXEL) + call salloc (pnm1, npts, TY_PIXEL) + call salloc (pnm2, npts, TY_PIXEL) + + # a higher order polynomial + call amovk$t (PIXEL(1.0), Mem$t[pnm2], npts) + 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], PIXEL(2.0), 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 + +# CV_EVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure $tcv_evleg (coeff, x, yfit, npts, order, k1, k2) + +PIXEL coeff[ARB] # 1D 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 + if (order == 1) { + call amovk$t (coeff[1], yfit, npts) + 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) + call salloc (sx, npts, TY_PIXEL) + call salloc (pn, npts, TY_PIXEL) + call salloc (pnm1, npts, TY_PIXEL) + call salloc (pnm2, npts, TY_PIXEL) + + # a higher order polynomial + call amovk$t (PIXEL(1.0), Mem$t[pnm2], npts) + 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 = (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[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 + +# CV_EVSPLINE1 -- Procedure to evaluate a piecewise linear spline function +# assuming that the coefficients have been calculated. + +procedure $tcv_evspline1 (coeff, x, yfit, npts, npieces, k1, k2) + +PIXEL coeff[ARB] # array of coefficients +PIXEL x[npts] # array of x values +PIXEL yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of fitted points minus 1 +PIXEL k1, k2 # normalizing constants + +int j +pointer sx, tx, azindex, aindex, index +pointer sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_PIXEL) + call salloc (tx, npts, TY_PIXEL) + call salloc (index, npts, TY_INT) + + # calculate the index of the first non-zero coefficient + # for each point + call alta$t (x, Mem$t[sx], npts, k1, k2) + call acht$ti (Mem$t[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + azindex = sx - 1 + do j = 1, npts { + aindex = azindex + j + Mem$t[aindex] = max (PIXEL(0.0), min (PIXEL(1.0), Mem$t[aindex] - + Memi[index+j-1])) + Mem$t[tx+j-1] = max (PIXEL(0.0), min (PIXEL(1.0), PIXEL(1.0) - + Mem$t[aindex])) + } + + # calculate yfit using the two non-zero basis function + do j = 1, npts + yfit[j] = Mem$t[tx+j-1] * coeff[1+Memi[index+j-1]] + + Mem$t[sx+j-1] * coeff[2+Memi[index+j-1]] + + # free space + call sfree (sp) + +end + +# CV_EVSPLINE3 -- Procedure to evaluate the cubic spline assuming that +# the coefficients of the fit are known. + +procedure $tcv_evspline3 (coeff, x, yfit, npts, npieces, k1, k2) + +PIXEL coeff[ARB] # array of coeffcients +PIXEL x[npts] # array of x values +PIXEL yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of polynomial pieces +PIXEL k1, k2 # normalizing constants + +int i, j +pointer sx, tx, temp, index, sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_PIXEL) + call salloc (tx, npts, TY_PIXEL) + call salloc (temp, npts, TY_PIXEL) + call salloc (index, npts, TY_INT) + + # calculate to which coefficients the x values contribute to + call alta$t (x, Mem$t[sx], npts, k1, k2) + call acht$ti (Mem$t[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + do j = 1, npts { + Mem$t[sx+j-1] = max (PIXEL(0.0), min (PIXEL(1.0), Mem$t[sx+j-1] - + Memi[index+j-1])) + Mem$t[tx+j-1] = max (PIXEL(0.0), min (PIXEL(1.0), PIXEL(1.0) - + Mem$t[sx+j-1])) + } + + # calculate yfit using the four non-zero basis function + call aclr$t (yfit, npts) + do i = 1, 4 { + + switch (i) { + case 1: + call apowk$t (Mem$t[tx], 3, Mem$t[temp], npts) + case 2: + do j = 1, npts { + Mem$t[temp+j-1] = PIXEL(1.0) + Mem$t[tx+j-1] * + (PIXEL(3.0) + Mem$t[tx+j-1] * (PIXEL(3.0) - + PIXEL(3.0) * Mem$t[tx+j-1])) + } + case 3: + do j = 1, npts { + Mem$t[temp+j-1] = PIXEL(1.0) + Mem$t[sx+j-1] * + (PIXEL(3.0) + Mem$t[sx+j-1] * (PIXEL(3.0) - + PIXEL(3.0) * Mem$t[sx+j-1])) + } + case 4: + call apowk$t (Mem$t[sx], 3, Mem$t[temp], npts) + } + + do j = 1, npts + Mem$t[temp+j-1] = Mem$t[temp+j-1] * coeff[i+Memi[index+j-1]] + call aadd$t (yfit, Mem$t[temp], yfit, npts) + } + + # free space + call sfree (sp) + +end diff --git a/math/curfit/cv_fevald.x b/math/curfit/cv_fevald.x new file mode 100644 index 00000000..9293a821 --- /dev/null +++ b/math/curfit/cv_fevald.x @@ -0,0 +1,242 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure dcv_evcheb (coeff, x, yfit, npts, order, k1, k2) + +double coeff[ARB] # 1D 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 + if (order == 1) { + call amovkd (coeff[1], yfit, npts) + 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 (double(1.0), Memd[pnm2], npts) + call altad (x, Memd[sx], npts, k1, k2) + call amovd (Memd[sx], Memd[pnm1], npts) + call amulkd (Memd[sx], double(2.0), 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 + +# CV_EVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure dcv_evleg (coeff, x, yfit, npts, order, k1, k2) + +double coeff[ARB] # 1D 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 + if (order == 1) { + call amovkd (coeff[1], yfit, npts) + 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 (double(1.0), 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 = (double(2.0) * ri - double(3.0)) / (ri - double(1.0)) + ri2 = - (ri - double(2.0)) / (ri - double(1.0)) + 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 + +# CV_EVSPLINE1 -- Procedure to evaluate a piecewise linear spline function +# assuming that the coefficients have been calculated. + +procedure dcv_evspline1 (coeff, x, yfit, npts, npieces, k1, k2) + +double coeff[ARB] # array of coefficients +double x[npts] # array of x values +double yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of fitted points minus 1 +double k1, k2 # normalizing constants + +int j +pointer sx, tx, azindex, aindex, index +pointer sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_DOUBLE) + call salloc (tx, npts, TY_DOUBLE) + call salloc (index, npts, TY_INT) + + # calculate the index of the first non-zero coefficient + # for each point + call altad (x, Memd[sx], npts, k1, k2) + call achtdi (Memd[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + azindex = sx - 1 + do j = 1, npts { + aindex = azindex + j + Memd[aindex] = max (double(0.0), min (double(1.0), Memd[aindex] - + Memi[index+j-1])) + Memd[tx+j-1] = max (double(0.0), min (double(1.0), double(1.0) - + Memd[aindex])) + } + + # calculate yfit using the two non-zero basis function + do j = 1, npts + yfit[j] = Memd[tx+j-1] * coeff[1+Memi[index+j-1]] + + Memd[sx+j-1] * coeff[2+Memi[index+j-1]] + + # free space + call sfree (sp) + +end + +# CV_EVSPLINE3 -- Procedure to evaluate the cubic spline assuming that +# the coefficients of the fit are known. + +procedure dcv_evspline3 (coeff, x, yfit, npts, npieces, k1, k2) + +double coeff[ARB] # array of coeffcients +double x[npts] # array of x values +double yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of polynomial pieces +double k1, k2 # normalizing constants + +int i, j +pointer sx, tx, temp, index, sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_DOUBLE) + call salloc (tx, npts, TY_DOUBLE) + call salloc (temp, npts, TY_DOUBLE) + call salloc (index, npts, TY_INT) + + # calculate to which coefficients the x values contribute to + call altad (x, Memd[sx], npts, k1, k2) + call achtdi (Memd[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + do j = 1, npts { + Memd[sx+j-1] = max (double(0.0), min (double(1.0), Memd[sx+j-1] - + Memi[index+j-1])) + Memd[tx+j-1] = max (double(0.0), min (double(1.0), double(1.0) - + Memd[sx+j-1])) + } + + # calculate yfit using the four non-zero basis function + call aclrd (yfit, npts) + do i = 1, 4 { + + switch (i) { + case 1: + call apowkd (Memd[tx], 3, Memd[temp], npts) + case 2: + do j = 1, npts { + Memd[temp+j-1] = double(1.0) + Memd[tx+j-1] * + (double(3.0) + Memd[tx+j-1] * (double(3.0) - + double(3.0) * Memd[tx+j-1])) + } + case 3: + do j = 1, npts { + Memd[temp+j-1] = double(1.0) + Memd[sx+j-1] * + (double(3.0) + Memd[sx+j-1] * (double(3.0) - + double(3.0) * Memd[sx+j-1])) + } + case 4: + call apowkd (Memd[sx], 3, Memd[temp], npts) + } + + do j = 1, npts + Memd[temp+j-1] = Memd[temp+j-1] * coeff[i+Memi[index+j-1]] + call aaddd (yfit, Memd[temp], yfit, npts) + } + + # free space + call sfree (sp) + +end diff --git a/math/curfit/cv_fevalr.x b/math/curfit/cv_fevalr.x new file mode 100644 index 00000000..ac019042 --- /dev/null +++ b/math/curfit/cv_fevalr.x @@ -0,0 +1,242 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CV_EVCHEB -- Procedure to evaluate a Chebyshev polynomial assuming that +# the coefficients have been calculated. + +procedure rcv_evcheb (coeff, x, yfit, npts, order, k1, k2) + +real coeff[ARB] # 1D 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 + if (order == 1) { + call amovkr (coeff[1], yfit, npts) + 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 (real(1.0), Memr[pnm2], npts) + call altar (x, Memr[sx], npts, k1, k2) + call amovr (Memr[sx], Memr[pnm1], npts) + call amulkr (Memr[sx], real(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 + +# CV_EVLEG -- Procedure to evaluate a Legendre polynomial assuming that +# the coefficients have been calculated. + +procedure rcv_evleg (coeff, x, yfit, npts, order, k1, k2) + +real coeff[ARB] # 1D 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 + if (order == 1) { + call amovkr (coeff[1], yfit, npts) + 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 (real(1.0), 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 = (real(2.0) * ri - real(3.0)) / (ri - real(1.0)) + ri2 = - (ri - real(2.0)) / (ri - real(1.0)) + 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 + +# CV_EVSPLINE1 -- Procedure to evaluate a piecewise linear spline function +# assuming that the coefficients have been calculated. + +procedure rcv_evspline1 (coeff, x, yfit, npts, npieces, k1, k2) + +real coeff[ARB] # array of coefficients +real x[npts] # array of x values +real yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of fitted points minus 1 +real k1, k2 # normalizing constants + +int j +pointer sx, tx, azindex, aindex, index +pointer sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (tx, npts, TY_REAL) + call salloc (index, npts, TY_INT) + + # calculate the index of the first non-zero coefficient + # for each point + call altar (x, Memr[sx], npts, k1, k2) + call achtri (Memr[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + azindex = sx - 1 + do j = 1, npts { + aindex = azindex + j + Memr[aindex] = max (real(0.0), min (real(1.0), Memr[aindex] - + Memi[index+j-1])) + Memr[tx+j-1] = max (real(0.0), min (real(1.0), real(1.0) - + Memr[aindex])) + } + + # calculate yfit using the two non-zero basis function + do j = 1, npts + yfit[j] = Memr[tx+j-1] * coeff[1+Memi[index+j-1]] + + Memr[sx+j-1] * coeff[2+Memi[index+j-1]] + + # free space + call sfree (sp) + +end + +# CV_EVSPLINE3 -- Procedure to evaluate the cubic spline assuming that +# the coefficients of the fit are known. + +procedure rcv_evspline3 (coeff, x, yfit, npts, npieces, k1, k2) + +real coeff[ARB] # array of coeffcients +real x[npts] # array of x values +real yfit[npts] # array of fitted values +int npts # number of data points +int npieces # number of polynomial pieces +real k1, k2 # normalizing constants + +int i, j +pointer sx, tx, temp, index, sp + +begin + + # allocate the required space + call smark (sp) + call salloc (sx, npts, TY_REAL) + call salloc (tx, npts, TY_REAL) + call salloc (temp, npts, TY_REAL) + call salloc (index, npts, TY_INT) + + # calculate to which coefficients the x values contribute to + call altar (x, Memr[sx], npts, k1, k2) + call achtri (Memr[sx], Memi[index], npts) + call aminki (Memi[index], npieces, Memi[index], npts) + + # transform sx to range 0 to 1 + do j = 1, npts { + Memr[sx+j-1] = max (real(0.0), min (real(1.0), Memr[sx+j-1] - + Memi[index+j-1])) + Memr[tx+j-1] = max (real(0.0), min (real(1.0), real(1.0) - + Memr[sx+j-1])) + } + + # calculate yfit using the four non-zero basis function + call aclrr (yfit, npts) + do i = 1, 4 { + + switch (i) { + case 1: + call apowkr (Memr[tx], 3, Memr[temp], npts) + case 2: + do j = 1, npts { + Memr[temp+j-1] = real(1.0) + Memr[tx+j-1] * + (real(3.0) + Memr[tx+j-1] * (real(3.0) - + real(3.0) * Memr[tx+j-1])) + } + case 3: + do j = 1, npts { + Memr[temp+j-1] = real(1.0) + Memr[sx+j-1] * + (real(3.0) + Memr[sx+j-1] * (real(3.0) - + real(3.0) * Memr[sx+j-1])) + } + case 4: + call apowkr (Memr[sx], 3, Memr[temp], npts) + } + + do j = 1, npts + Memr[temp+j-1] = Memr[temp+j-1] * coeff[i+Memi[index+j-1]] + call aaddr (yfit, Memr[temp], yfit, npts) + } + + # free space + call sfree (sp) + +end diff --git a/math/curfit/cv_userfnc.gx b/math/curfit/cv_userfnc.gx new file mode 100644 index 00000000..7a4e80e8 --- /dev/null +++ b/math/curfit/cv_userfnc.gx @@ -0,0 +1,84 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# Interface Routine for external user functions + +# CV_B1USER - Evaluate basis functions at a single point with +# external user routine. + +procedure $tcv_b1user (cv, x) + +pointer cv +PIXEL x + +begin + if (CV_USERFNC(cv) == NULL) + call error (0, "CV_USERFNC: Pointer not set") + + call zcall5 (CV_USERFNC(cv), x, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), XBASIS(CV_XBASIS(cv))) +end + +# CV_BUSER - Evaluate basis functions at a set of points with +# external user routine. + +procedure $tcv_buser (cv, x, npts) + +pointer cv +PIXEL x[ARB] +int npts + +int i, j + +begin + do i = 1, npts { + call $tcv_b1user (cv, x[i]) + do j = 1, CV_ORDER(cv) + BASIS(CV_BASIS(cv)-1+i + npts*(j-1)) = + XBASIS(CV_XBASIS(cv)-1+j) + } +end + +# CV_EVUSER - Evaluate user function at a set of points using present +# coefficient values + +procedure $tcv_evuser (cv, x, yfit, npts) + +pointer cv +PIXEL x[ARB], yfit[ARB] +int npts + +int i +PIXEL adot$t + +begin + do i = 1, npts { + call $tcv_b1user (cv, x[i]) + yfit[i] = adot$t ( XBASIS(CV_XBASIS(cv)), COEFF(CV_COEFF(cv)), + CV_ORDER(cv)) + } +end + +# CVUSERFNC - Set external user function. + +$if (datatype == r) +procedure cvuserfnc (cv, fnc) +$else +procedure dcvuserfnc (cv, fnc) +$endif + +pointer cv +extern fnc() + +int locpr() + +begin + CV_USERFNC(cv) = locpr (fnc) +end diff --git a/math/curfit/cv_userfncd.x b/math/curfit/cv_userfncd.x new file mode 100644 index 00000000..ae05d372 --- /dev/null +++ b/math/curfit/cv_userfncd.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + +# Interface Routine for external user functions + +# CV_B1USER - Evaluate basis functions at a single point with +# external user routine. + +procedure dcv_b1user (cv, x) + +pointer cv +double x + +begin + if (CV_USERFNC(cv) == NULL) + call error (0, "CV_USERFNC: Pointer not set") + + call zcall5 (CV_USERFNC(cv), x, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), XBASIS(CV_XBASIS(cv))) +end + +# CV_BUSER - Evaluate basis functions at a set of points with +# external user routine. + +procedure dcv_buser (cv, x, npts) + +pointer cv +double x[ARB] +int npts + +int i, j + +begin + do i = 1, npts { + call dcv_b1user (cv, x[i]) + do j = 1, CV_ORDER(cv) + BASIS(CV_BASIS(cv)-1+i + npts*(j-1)) = + XBASIS(CV_XBASIS(cv)-1+j) + } +end + +# CV_EVUSER - Evaluate user function at a set of points using present +# coefficient values + +procedure dcv_evuser (cv, x, yfit, npts) + +pointer cv +double x[ARB], yfit[ARB] +int npts + +int i +double adotd + +begin + do i = 1, npts { + call dcv_b1user (cv, x[i]) + yfit[i] = adotd ( XBASIS(CV_XBASIS(cv)), COEFF(CV_COEFF(cv)), + CV_ORDER(cv)) + } +end + +# CVUSERFNC - Set external user function. + +procedure dcvuserfnc (cv, fnc) + +pointer cv +extern fnc() + +int locpr() + +begin + CV_USERFNC(cv) = locpr (fnc) +end diff --git a/math/curfit/cv_userfncr.x b/math/curfit/cv_userfncr.x new file mode 100644 index 00000000..b9f502c3 --- /dev/null +++ b/math/curfit/cv_userfncr.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + +# Interface Routine for external user functions + +# CV_B1USER - Evaluate basis functions at a single point with +# external user routine. + +procedure rcv_b1user (cv, x) + +pointer cv +real x + +begin + if (CV_USERFNC(cv) == NULL) + call error (0, "CV_USERFNC: Pointer not set") + + call zcall5 (CV_USERFNC(cv), x, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), XBASIS(CV_XBASIS(cv))) +end + +# CV_BUSER - Evaluate basis functions at a set of points with +# external user routine. + +procedure rcv_buser (cv, x, npts) + +pointer cv +real x[ARB] +int npts + +int i, j + +begin + do i = 1, npts { + call rcv_b1user (cv, x[i]) + do j = 1, CV_ORDER(cv) + BASIS(CV_BASIS(cv)-1+i + npts*(j-1)) = + XBASIS(CV_XBASIS(cv)-1+j) + } +end + +# CV_EVUSER - Evaluate user function at a set of points using present +# coefficient values + +procedure rcv_evuser (cv, x, yfit, npts) + +pointer cv +real x[ARB], yfit[ARB] +int npts + +int i +real adotr + +begin + do i = 1, npts { + call rcv_b1user (cv, x[i]) + yfit[i] = adotr ( XBASIS(CV_XBASIS(cv)), COEFF(CV_COEFF(cv)), + CV_ORDER(cv)) + } +end + +# CVUSERFNC - Set external user function. + +procedure cvuserfnc (cv, fnc) + +pointer cv +extern fnc() + +int locpr() + +begin + CV_USERFNC(cv) = locpr (fnc) +end diff --git a/math/curfit/cvaccum.gx b/math/curfit/cvaccum.gx new file mode 100644 index 00000000..fb5a957b --- /dev/null +++ b/math/curfit/cvaccum.gx @@ -0,0 +1,108 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVACCUM -- Procedure to add a data point to the set of normal equations. +# The inner products of the basis functions are added into the CV_ORDER(cv) +# by CV_NCOEFF(cv) array MATRIX. The first row of MATRIX +# contains the main diagonal of the matrix followed by +# the CV_ORDER(cv) lower diagonals. This method of storing MATRIX +# minimizes the space required by large symmetric, banded matrices. +# The inner products of the basis functions and the data ordinates are +# stored in VECTOR which has CV_NCOEFF(cv) elements. The integers left +# and leftm1 are used to determine which elements of MATRIX and VECTOR +# are to receive the data. + +$if (datatype == r) +procedure cvaccum (cv, x, y, w, wtflag) +$else +procedure dcvaccum (cv, x, y, w, wtflag) +$endif + +pointer cv # curve descriptor +PIXEL x # x value +PIXEL y # y value +PIXEL w # weight of the data point +int wtflag # type of weighting desired + +int left, i, ii, j +PIXEL bw +pointer xzptr +pointer mzptr, mzzptr +pointer vzptr + +begin + + # increment number of points + CV_NPTS(cv) = CV_NPTS(cv) + 1 + + # calculate the weights + switch (wtflag) { + case WTS_UNIFORM, WTS_SPACING: + w = 1.0 + case WTS_USER: + # user defined weights + case WTS_CHISQ: + # data assumed to be scaled to photons with Poisson statistics + if (y > 0.0) + w = 1.0 / y + else if (y < 0.0) + w = - 1.0 / y + else + w = 0.0 + default: + w = 1.0 + } + + # calculate all non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call $tcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call $tcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call $tcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call $tcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call $tcv_b1user (cv, x) + } + + # index the pointers + xzptr = CV_XBASIS(cv) - 1 + vzptr = CV_VECTOR(cv) + left - 1 + mzptr = CV_MATRIX(cv) + CV_ORDER(CV) * (left - 1) + + # accumulate the data point into the matrix and vector + do i = 1, CV_ORDER(cv) { + + # calculate the non-zero basis functions + bw = XBASIS(xzptr+i) * w + + # add the inner product of the basis functions and the ordinate + # into the appropriate element of VECTOR + VECTOR(vzptr+i) = VECTOR(vzptr+i) + bw * y + + # accumulate the inner products of the basis functions into + # the apprpriate element of MATRIX + mzzptr = mzptr + i * CV_ORDER(cv) + ii = 0 + do j = i, CV_ORDER(cv) { + MATRIX(mzzptr+ii) = MATRIX(mzzptr+ii) + XBASIS(xzptr+j) * bw + ii = ii + 1 + } + } +end diff --git a/math/curfit/cvaccumd.x b/math/curfit/cvaccumd.x new file mode 100644 index 00000000..2a30b584 --- /dev/null +++ b/math/curfit/cvaccumd.x @@ -0,0 +1,100 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVACCUM -- Procedure to add a data point to the set of normal equations. +# The inner products of the basis functions are added into the CV_ORDER(cv) +# by CV_NCOEFF(cv) array MATRIX. The first row of MATRIX +# contains the main diagonal of the matrix followed by +# the CV_ORDER(cv) lower diagonals. This method of storing MATRIX +# minimizes the space required by large symmetric, banded matrices. +# The inner products of the basis functions and the data ordinates are +# stored in VECTOR which has CV_NCOEFF(cv) elements. The integers left +# and leftm1 are used to determine which elements of MATRIX and VECTOR +# are to receive the data. + +procedure dcvaccum (cv, x, y, w, wtflag) + +pointer cv # curve descriptor +double x # x value +double y # y value +double w # weight of the data point +int wtflag # type of weighting desired + +int left, i, ii, j +double bw +pointer xzptr +pointer mzptr, mzzptr +pointer vzptr + +begin + + # increment number of points + CV_NPTS(cv) = CV_NPTS(cv) + 1 + + # calculate the weights + switch (wtflag) { + case WTS_UNIFORM, WTS_SPACING: + w = 1.0 + case WTS_USER: + # user defined weights + case WTS_CHISQ: + # data assumed to be scaled to photons with Poisson statistics + if (y > 0.0) + w = 1.0 / y + else if (y < 0.0) + w = - 1.0 / y + else + w = 0.0 + default: + w = 1.0 + } + + # calculate all non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call dcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call dcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call dcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call dcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call dcv_b1user (cv, x) + } + + # index the pointers + xzptr = CV_XBASIS(cv) - 1 + vzptr = CV_VECTOR(cv) + left - 1 + mzptr = CV_MATRIX(cv) + CV_ORDER(CV) * (left - 1) + + # accumulate the data point into the matrix and vector + do i = 1, CV_ORDER(cv) { + + # calculate the non-zero basis functions + bw = XBASIS(xzptr+i) * w + + # add the inner product of the basis functions and the ordinate + # into the appropriate element of VECTOR + VECTOR(vzptr+i) = VECTOR(vzptr+i) + bw * y + + # accumulate the inner products of the basis functions into + # the apprpriate element of MATRIX + mzzptr = mzptr + i * CV_ORDER(cv) + ii = 0 + do j = i, CV_ORDER(cv) { + MATRIX(mzzptr+ii) = MATRIX(mzzptr+ii) + XBASIS(xzptr+j) * bw + ii = ii + 1 + } + } +end diff --git a/math/curfit/cvaccumr.x b/math/curfit/cvaccumr.x new file mode 100644 index 00000000..a2184840 --- /dev/null +++ b/math/curfit/cvaccumr.x @@ -0,0 +1,100 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + +# CVACCUM -- Procedure to add a data point to the set of normal equations. +# The inner products of the basis functions are added into the CV_ORDER(cv) +# by CV_NCOEFF(cv) array MATRIX. The first row of MATRIX +# contains the main diagonal of the matrix followed by +# the CV_ORDER(cv) lower diagonals. This method of storing MATRIX +# minimizes the space required by large symmetric, banded matrices. +# The inner products of the basis functions and the data ordinates are +# stored in VECTOR which has CV_NCOEFF(cv) elements. The integers left +# and leftm1 are used to determine which elements of MATRIX and VECTOR +# are to receive the data. + +procedure cvaccum (cv, x, y, w, wtflag) + +pointer cv # curve descriptor +real x # x value +real y # y value +real w # weight of the data point +int wtflag # type of weighting desired + +int left, i, ii, j +real bw +pointer xzptr +pointer mzptr, mzzptr +pointer vzptr + +begin + + # increment number of points + CV_NPTS(cv) = CV_NPTS(cv) + 1 + + # calculate the weights + switch (wtflag) { + case WTS_UNIFORM, WTS_SPACING: + w = 1.0 + case WTS_USER: + # user defined weights + case WTS_CHISQ: + # data assumed to be scaled to photons with Poisson statistics + if (y > 0.0) + w = 1.0 / y + else if (y < 0.0) + w = - 1.0 / y + else + w = 0.0 + default: + w = 1.0 + } + + # calculate all non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call rcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call rcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call rcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call rcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call rcv_b1user (cv, x) + } + + # index the pointers + xzptr = CV_XBASIS(cv) - 1 + vzptr = CV_VECTOR(cv) + left - 1 + mzptr = CV_MATRIX(cv) + CV_ORDER(CV) * (left - 1) + + # accumulate the data point into the matrix and vector + do i = 1, CV_ORDER(cv) { + + # calculate the non-zero basis functions + bw = XBASIS(xzptr+i) * w + + # add the inner product of the basis functions and the ordinate + # into the appropriate element of VECTOR + VECTOR(vzptr+i) = VECTOR(vzptr+i) + bw * y + + # accumulate the inner products of the basis functions into + # the apprpriate element of MATRIX + mzzptr = mzptr + i * CV_ORDER(cv) + ii = 0 + do j = i, CV_ORDER(cv) { + MATRIX(mzzptr+ii) = MATRIX(mzzptr+ii) + XBASIS(xzptr+j) * bw + ii = ii + 1 + } + } +end diff --git a/math/curfit/cvacpts.gx b/math/curfit/cvacpts.gx new file mode 100644 index 00000000..56a36cb2 --- /dev/null +++ b/math/curfit/cvacpts.gx @@ -0,0 +1,186 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVACPTS -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner product +# of the basis functions and the data ordinates are stored in the +# CV_NCOEFF(cv)-vector VECTOR. The array LEFT stores the +# indices which show which elements of MATRIX and VECTOR are +# to receive the inner products. + +$if (datatype == r) +procedure cvacpts (cv, x, y, w, npts, wtflag) +$else +procedure dcvacpts (cv, x, y, w, npts, wtflag) +$endif + +pointer cv # curve descriptor +PIXEL x[npts] # array of abcissa +PIXEL y[npts] # array of ordinates +PIXEL w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting + +int i, ii, j, k +pointer sp +pointer vzptr, vindex, mzptr, mindex, bptr, bbptr +pointer bw, rows + +begin + + # increment the number of points + CV_NPTS(cv) = CV_NPTS(cv) + npts + + # remove basis functions calculated by any previous cvrefit call + if (CV_BASIS(cv) != NULL) { + + call mfree (CV_BASIS(cv), TY_PIXEL) + call mfree (CV_WY(cv), TY_PIXEL) + + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + + if (CV_LEFT(cv) != NULL) { + call mfree (CV_LEFT(cv), TY_INT) + CV_LEFT(cv) = NULL + } + } + + # calculate weights + switch (wtflag) { + case WTS_UNIFORM: + call amovk$t (PIXEL(1.0), 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 + case WTS_CHISQ: + # data assumed to be scaled to photons with Poisson statistics + do i = 1, npts { + if (y[i] > PIXEL(0.0)) + w[i] = PIXEL(1.0) / y[i] + else if (y[i] < PIXEL(0.0)) + w[i] = -PIXEL(1.0) / y[i] + else + w[i] = PIXEL(0.0) + } + default: + call amovk$t (PIXEL(1.0), w, npts) + } + + + # allocate space for the basis functions + call smark (sp) + call salloc (CV_BASIS(cv), npts * CV_ORDER(cv), TY_PIXEL) + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case LEGENDRE: + call $tcv_bleg (x, npts, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case CHEBYSHEV: + call $tcv_bcheb (x, npts, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case SPLINE3: + call salloc (CV_LEFT(cv), npts, TY_INT) + call $tcv_bspline3 (x, npts, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + case SPLINE1: + call salloc (CV_LEFT(cv), npts, TY_INT) + call $tcv_bspline1 (x, npts, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + case USERFNC: + call $tcv_buser (cv, x, npts) + } + + + # allocate temporary storage space for matrix accumulation + call salloc (bw, npts, TY_PIXEL) + call salloc (rows, npts, TY_INT) + + # one index the pointers + vzptr = CV_VECTOR(cv) - 1 + mzptr = CV_MATRIX(cv) + bptr = CV_BASIS(cv) + + switch (CV_TYPE(cv)) { + + case LEGENDRE, CHEBYSHEV, USERFNC: + + # accumulate the new right side of the matrix equation + do k = 1, CV_ORDER(cv) { + call amul$t (w, BASIS(bptr), Mem$t[bw], npts) + vindex = vzptr + k + do i = 1, npts + VECTOR(vindex) = VECTOR(vindex) + Mem$t[bw+i-1] * y[i] + bbptr = bptr + ii = 0 + do j = k, CV_ORDER(cv) { + mindex = mzptr + ii + do i = 1, npts + MATRIX(mindex) = MATRIX(mindex) + Mem$t[bw+i-1] * + BASIS(bbptr+i-1) + ii = ii + 1 + bbptr = bbptr + npts + } + bptr = bptr + npts + mzptr = mzptr + CV_ORDER(cv) + } + + case SPLINE1,SPLINE3: + + call amulki (LEFT(CV_LEFT(cv)), CV_ORDER(cv), Memi[rows], npts) + call aaddki (Memi[rows], CV_MATRIX(cv), Memi[rows], npts) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), npts) + + # accumulate the new right side of the matrix equation + do k = 1, CV_ORDER(cv) { + call amul$t (w, BASIS(bptr), Mem$t[bw], npts) + do i = 1, npts { + vindex = LEFT(CV_LEFT(cv)+i-1) + k + VECTOR(vindex) = VECTOR(vindex)+ Mem$t[bw+i-1] * y[i] + } + bbptr = bptr + ii = 0 + do j = k, CV_ORDER(cv) { + do i = 1, npts { + mindex = Memi[rows+i-1] + ii + MATRIX(mindex) = MATRIX(mindex) + Mem$t[bw+i-1] * + BASIS(bbptr+i-1) + } + ii = ii + 1 + bbptr = bbptr + npts + } + bptr = bptr + npts + call aaddki (Memi[rows], CV_ORDER(cv), Memi[rows], npts) + } + } + + # release the space + call sfree (sp) + CV_BASIS(cv) = NULL + CV_LEFT(cv) = NULL +end diff --git a/math/curfit/cvacptsd.x b/math/curfit/cvacptsd.x new file mode 100644 index 00000000..aa4665d8 --- /dev/null +++ b/math/curfit/cvacptsd.x @@ -0,0 +1,178 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVACPTS -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner product +# of the basis functions and the data ordinates are stored in the +# CV_NCOEFF(cv)-vector VECTOR. The array LEFT stores the +# indices which show which elements of MATRIX and VECTOR are +# to receive the inner products. + +procedure dcvacpts (cv, x, y, w, npts, wtflag) + +pointer cv # curve descriptor +double x[npts] # array of abcissa +double y[npts] # array of ordinates +double w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting + +int i, ii, j, k +pointer sp +pointer vzptr, vindex, mzptr, mindex, bptr, bbptr +pointer bw, rows + +begin + + # increment the number of points + CV_NPTS(cv) = CV_NPTS(cv) + npts + + # remove basis functions calculated by any previous cvrefit call + if (CV_BASIS(cv) != NULL) { + + call mfree (CV_BASIS(cv), TY_DOUBLE) + call mfree (CV_WY(cv), TY_DOUBLE) + + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + + if (CV_LEFT(cv) != NULL) { + call mfree (CV_LEFT(cv), TY_INT) + CV_LEFT(cv) = NULL + } + } + + # calculate weights + switch (wtflag) { + case WTS_UNIFORM: + call amovkd (double(1.0), 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 + case WTS_CHISQ: + # data assumed to be scaled to photons with Poisson statistics + do i = 1, npts { + if (y[i] > double(0.0)) + w[i] = double(1.0) / y[i] + else if (y[i] < double(0.0)) + w[i] = -double(1.0) / y[i] + else + w[i] = double(0.0) + } + default: + call amovkd (double(1.0), w, npts) + } + + + # allocate space for the basis functions + call smark (sp) + call salloc (CV_BASIS(cv), npts * CV_ORDER(cv), TY_DOUBLE) + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case LEGENDRE: + call dcv_bleg (x, npts, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case CHEBYSHEV: + call dcv_bcheb (x, npts, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case SPLINE3: + call salloc (CV_LEFT(cv), npts, TY_INT) + call dcv_bspline3 (x, npts, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + case SPLINE1: + call salloc (CV_LEFT(cv), npts, TY_INT) + call dcv_bspline1 (x, npts, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + case USERFNC: + call dcv_buser (cv, x, npts) + } + + + # allocate temporary storage space for matrix accumulation + call salloc (bw, npts, TY_DOUBLE) + call salloc (rows, npts, TY_INT) + + # one index the pointers + vzptr = CV_VECTOR(cv) - 1 + mzptr = CV_MATRIX(cv) + bptr = CV_BASIS(cv) + + switch (CV_TYPE(cv)) { + + case LEGENDRE, CHEBYSHEV, USERFNC: + + # accumulate the new right side of the matrix equation + do k = 1, CV_ORDER(cv) { + call amuld (w, BASIS(bptr), Memd[bw], npts) + vindex = vzptr + k + do i = 1, npts + VECTOR(vindex) = VECTOR(vindex) + Memd[bw+i-1] * y[i] + bbptr = bptr + ii = 0 + do j = k, CV_ORDER(cv) { + mindex = mzptr + ii + do i = 1, npts + MATRIX(mindex) = MATRIX(mindex) + Memd[bw+i-1] * + BASIS(bbptr+i-1) + ii = ii + 1 + bbptr = bbptr + npts + } + bptr = bptr + npts + mzptr = mzptr + CV_ORDER(cv) + } + + case SPLINE1,SPLINE3: + + call amulki (LEFT(CV_LEFT(cv)), CV_ORDER(cv), Memi[rows], npts) + call aaddki (Memi[rows], CV_MATRIX(cv), Memi[rows], npts) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), npts) + + # accumulate the new right side of the matrix equation + do k = 1, CV_ORDER(cv) { + call amuld (w, BASIS(bptr), Memd[bw], npts) + do i = 1, npts { + vindex = LEFT(CV_LEFT(cv)+i-1) + k + VECTOR(vindex) = VECTOR(vindex)+ Memd[bw+i-1] * y[i] + } + bbptr = bptr + ii = 0 + do j = k, CV_ORDER(cv) { + do i = 1, npts { + mindex = Memi[rows+i-1] + ii + MATRIX(mindex) = MATRIX(mindex) + Memd[bw+i-1] * + BASIS(bbptr+i-1) + } + ii = ii + 1 + bbptr = bbptr + npts + } + bptr = bptr + npts + call aaddki (Memi[rows], CV_ORDER(cv), Memi[rows], npts) + } + } + + # release the space + call sfree (sp) + CV_BASIS(cv) = NULL + CV_LEFT(cv) = NULL +end diff --git a/math/curfit/cvacptsr.x b/math/curfit/cvacptsr.x new file mode 100644 index 00000000..fde31363 --- /dev/null +++ b/math/curfit/cvacptsr.x @@ -0,0 +1,178 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + +# CVACPTS -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner product +# of the basis functions and the data ordinates are stored in the +# CV_NCOEFF(cv)-vector VECTOR. The array LEFT stores the +# indices which show which elements of MATRIX and VECTOR are +# to receive the inner products. + +procedure cvacpts (cv, x, y, w, npts, wtflag) + +pointer cv # curve descriptor +real x[npts] # array of abcissa +real y[npts] # array of ordinates +real w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting + +int i, ii, j, k +pointer sp +pointer vzptr, vindex, mzptr, mindex, bptr, bbptr +pointer bw, rows + +begin + + # increment the number of points + CV_NPTS(cv) = CV_NPTS(cv) + npts + + # remove basis functions calculated by any previous cvrefit call + if (CV_BASIS(cv) != NULL) { + + call mfree (CV_BASIS(cv), TY_REAL) + call mfree (CV_WY(cv), TY_REAL) + + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + + if (CV_LEFT(cv) != NULL) { + call mfree (CV_LEFT(cv), TY_INT) + CV_LEFT(cv) = NULL + } + } + + # calculate weights + switch (wtflag) { + case WTS_UNIFORM: + call amovkr (real(1.0), 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 + case WTS_CHISQ: + # data assumed to be scaled to photons with Poisson statistics + do i = 1, npts { + if (y[i] > real(0.0)) + w[i] = real(1.0) / y[i] + else if (y[i] < real(0.0)) + w[i] = -real(1.0) / y[i] + else + w[i] = real(0.0) + } + default: + call amovkr (real(1.0), w, npts) + } + + + # allocate space for the basis functions + call smark (sp) + call salloc (CV_BASIS(cv), npts * CV_ORDER(cv), TY_REAL) + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case LEGENDRE: + call rcv_bleg (x, npts, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case CHEBYSHEV: + call rcv_bcheb (x, npts, CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case SPLINE3: + call salloc (CV_LEFT(cv), npts, TY_INT) + call rcv_bspline3 (x, npts, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + case SPLINE1: + call salloc (CV_LEFT(cv), npts, TY_INT) + call rcv_bspline1 (x, npts, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + case USERFNC: + call rcv_buser (cv, x, npts) + } + + + # allocate temporary storage space for matrix accumulation + call salloc (bw, npts, TY_REAL) + call salloc (rows, npts, TY_INT) + + # one index the pointers + vzptr = CV_VECTOR(cv) - 1 + mzptr = CV_MATRIX(cv) + bptr = CV_BASIS(cv) + + switch (CV_TYPE(cv)) { + + case LEGENDRE, CHEBYSHEV, USERFNC: + + # accumulate the new right side of the matrix equation + do k = 1, CV_ORDER(cv) { + call amulr (w, BASIS(bptr), Memr[bw], npts) + vindex = vzptr + k + do i = 1, npts + VECTOR(vindex) = VECTOR(vindex) + Memr[bw+i-1] * y[i] + bbptr = bptr + ii = 0 + do j = k, CV_ORDER(cv) { + mindex = mzptr + ii + do i = 1, npts + MATRIX(mindex) = MATRIX(mindex) + Memr[bw+i-1] * + BASIS(bbptr+i-1) + ii = ii + 1 + bbptr = bbptr + npts + } + bptr = bptr + npts + mzptr = mzptr + CV_ORDER(cv) + } + + case SPLINE1,SPLINE3: + + call amulki (LEFT(CV_LEFT(cv)), CV_ORDER(cv), Memi[rows], npts) + call aaddki (Memi[rows], CV_MATRIX(cv), Memi[rows], npts) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), npts) + + # accumulate the new right side of the matrix equation + do k = 1, CV_ORDER(cv) { + call amulr (w, BASIS(bptr), Memr[bw], npts) + do i = 1, npts { + vindex = LEFT(CV_LEFT(cv)+i-1) + k + VECTOR(vindex) = VECTOR(vindex)+ Memr[bw+i-1] * y[i] + } + bbptr = bptr + ii = 0 + do j = k, CV_ORDER(cv) { + do i = 1, npts { + mindex = Memi[rows+i-1] + ii + MATRIX(mindex) = MATRIX(mindex) + Memr[bw+i-1] * + BASIS(bbptr+i-1) + } + ii = ii + 1 + bbptr = bbptr + npts + } + bptr = bptr + npts + call aaddki (Memi[rows], CV_ORDER(cv), Memi[rows], npts) + } + } + + # release the space + call sfree (sp) + CV_BASIS(cv) = NULL + CV_LEFT(cv) = NULL +end diff --git a/math/curfit/cvchomat.gx b/math/curfit/cvchomat.gx new file mode 100644 index 00000000..c9324a32 --- /dev/null +++ b/math/curfit/cvchomat.gx @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVCHOFAC -- 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 $tcvchofac (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 (datatype == r) + if(((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= 10. * EPSILONR) { + $else + if(((matfac[1,n] + matrix[1,n]) - matrix[1,n]) <= 10. * EPSILOND) { + $endif + do j = 1, nbands + matfac[j,n] = PIXEL (0.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 + +# CVCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# CVCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure $tcvchoslv (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/curfit/cvchomatd.x b/math/curfit/cvchomatd.x new file mode 100644 index 00000000..1afef515 --- /dev/null +++ b/math/curfit/cvchomatd.x @@ -0,0 +1,109 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVCHOFAC -- 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 dcvchofac (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]) <= 10. * EPSILOND) { + do j = 1, nbands + matfac[j,n] = double (0.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 + +# CVCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# CVCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure dcvchoslv (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/curfit/cvchomatr.x b/math/curfit/cvchomatr.x new file mode 100644 index 00000000..cce25ecf --- /dev/null +++ b/math/curfit/cvchomatr.x @@ -0,0 +1,109 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <math/curfit.h> + +include "curfitdef.h" + +# CVCHOFAC -- 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 rcvchofac (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]) <= 10. * EPSILONR) { + do j = 1, nbands + matfac[j,n] = real (0.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 + +# CVCHOSLV -- Solve the matrix whose Cholesky factorization was calculated in +# CVCHOFAC for the coefficients. This routine was adapted from bchslv.f +# described in "A Practical Guide to Splines", by Carl de Boor (1978). + +procedure rcvchoslv (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/curfit/cvcoeff.gx b/math/curfit/cvcoeff.gx new file mode 100644 index 00000000..46c58c0f --- /dev/null +++ b/math/curfit/cvcoeff.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVCOEFF -- Procedure to fetch the number and magnitude of the coefficients. + +$if (datatype == r) +procedure cvcoeff (cv, coeff, ncoeff) +$else +procedure dcvcoeff (cv, coeff, ncoeff) +$endif + +pointer cv # curve descriptor +PIXEL coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + ncoeff = CV_NCOEFF(cv) + + # fetch coefficients + call amov$t (COEFF(CV_COEFF(cv)), coeff, ncoeff) +end diff --git a/math/curfit/cvcoeffd.x b/math/curfit/cvcoeffd.x new file mode 100644 index 00000000..1d63b9cf --- /dev/null +++ b/math/curfit/cvcoeffd.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "dcurfitdef.h" + +# CVCOEFF -- Procedure to fetch the number and magnitude of the coefficients. + +procedure dcvcoeff (cv, coeff, ncoeff) + +pointer cv # curve descriptor +double coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + ncoeff = CV_NCOEFF(cv) + + # fetch coefficients + call amovd (COEFF(CV_COEFF(cv)), coeff, ncoeff) +end diff --git a/math/curfit/cvcoeffr.x b/math/curfit/cvcoeffr.x new file mode 100644 index 00000000..69e73848 --- /dev/null +++ b/math/curfit/cvcoeffr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "curfitdef.h" + +# CVCOEFF -- Procedure to fetch the number and magnitude of the coefficients. + +procedure cvcoeff (cv, coeff, ncoeff) + +pointer cv # curve descriptor +real coeff[ARB] # the coefficients of the fit +int ncoeff # the number of coefficients + +begin + ncoeff = CV_NCOEFF(cv) + + # fetch coefficients + call amovr (COEFF(CV_COEFF(cv)), coeff, ncoeff) +end diff --git a/math/curfit/cverrors.gx b/math/curfit/cverrors.gx new file mode 100644 index 00000000..07288c7f --- /dev/null +++ b/math/curfit/cverrors.gx @@ -0,0 +1,91 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +define COV Mem$t[P2P($1)] # element of COV + +# CVERRORS -- 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 cverrors (cv, y, w, yfit, npts, chisqr, errors) +$else +procedure dcverrors (cv, y, w, yfit, npts, chisqr, errors) +$endif + +pointer cv # curve descriptor +PIXEL y[ARB] # data points +PIXEL yfit[ARB] # fitted data points +PIXEL w[ARB] # array of weights +int npts # number of points +PIXEL chisqr # reduced chi-squared of fit +PIXEL errors[ARB] # errors in coefficients + +int i, n, nfree +PIXEL variance, chisq, hold +pointer sp, covptr + +begin + # allocate space for covariance vector + call smark (sp) + call salloc (covptr, CV_NCOEFF(cv), TY_PIXEL) + + # estimate the variance and chi-squared of the fit + n = 0 + variance = 0. + chisq = 0. + do i = 1, npts { + if (w[i] <= 0.0) + next + hold = (y[i] - yfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + n = n + 1 + } + + # calculate the reduced chi-squared + nfree = n - CV_NCOEFF(cv) + 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, CV_NCOEFF(cv) { + call aclr$t (COV(covptr), CV_NCOEFF(cv)) + COV(covptr+i-1) = 1. + call $tcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + 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/curfit/cverrorsd.x b/math/curfit/cverrorsd.x new file mode 100644 index 00000000..ed0cf9dc --- /dev/null +++ b/math/curfit/cverrorsd.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +include "dcurfitdef.h" + +define COV Memd[P2P($1)] # element of COV + +# CVERRORS -- 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 dcverrors (cv, y, w, yfit, npts, chisqr, errors) + +pointer cv # curve descriptor +double y[ARB] # data points +double yfit[ARB] # fitted data points +double w[ARB] # array of weights +int npts # number of points +double chisqr # reduced chi-squared of fit +double errors[ARB] # errors in coefficients + +int i, n, nfree +double variance, chisq, hold +pointer sp, covptr + +begin + # allocate space for covariance vector + call smark (sp) + call salloc (covptr, CV_NCOEFF(cv), TY_DOUBLE) + + # estimate the variance and chi-squared of the fit + n = 0 + variance = 0. + chisq = 0. + do i = 1, npts { + if (w[i] <= 0.0) + next + hold = (y[i] - yfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + n = n + 1 + } + + # calculate the reduced chi-squared + nfree = n - CV_NCOEFF(cv) + 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, CV_NCOEFF(cv) { + call aclrd (COV(covptr), CV_NCOEFF(cv)) + COV(covptr+i-1) = 1. + call dcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + 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/curfit/cverrorsr.x b/math/curfit/cverrorsr.x new file mode 100644 index 00000000..89533b7b --- /dev/null +++ b/math/curfit/cverrorsr.x @@ -0,0 +1,83 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +include "curfitdef.h" + +define COV Memr[P2P($1)] # element of COV + +# CVERRORS -- 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 cverrors (cv, y, w, yfit, npts, chisqr, errors) + +pointer cv # curve descriptor +real y[ARB] # data points +real yfit[ARB] # fitted data points +real w[ARB] # array of weights +int npts # number of points +real chisqr # reduced chi-squared of fit +real errors[ARB] # errors in coefficients + +int i, n, nfree +real variance, chisq, hold +pointer sp, covptr + +begin + # allocate space for covariance vector + call smark (sp) + call salloc (covptr, CV_NCOEFF(cv), TY_REAL) + + # estimate the variance and chi-squared of the fit + n = 0 + variance = 0. + chisq = 0. + do i = 1, npts { + if (w[i] <= 0.0) + next + hold = (y[i] - yfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + n = n + 1 + } + + # calculate the reduced chi-squared + nfree = n - CV_NCOEFF(cv) + 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, CV_NCOEFF(cv) { + call aclrr (COV(covptr), CV_NCOEFF(cv)) + COV(covptr+i-1) = 1. + call rcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + 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/curfit/cveval.gx b/math/curfit/cveval.gx new file mode 100644 index 00000000..995b4f74 --- /dev/null +++ b/math/curfit/cveval.gx @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVEVAL -- Procedure to evaluate curve at a given x. The CV_NCOEFF(cv) +# coefficients are assumed to be in COEFF. + +$if (datatype == r) +PIXEL procedure cveval (cv, x) +$else +PIXEL procedure dcveval (cv, x) +$endif + +pointer cv # curve descriptor +PIXEL x # x value + +int left +pointer cptr, xptr +PIXEL yfit + +PIXEL adot$t() + +begin + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call $tcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call $tcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call $tcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call $tcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call $tcv_b1user (cv, x) + } + + + # accumulate the fitted value + cptr = CV_COEFF(cv) + left + xptr = CV_XBASIS(cv) + yfit = adot$t (XBASIS(xptr), COEFF(cptr), CV_ORDER(cv)) + + return (yfit) +end diff --git a/math/curfit/cvevald.x b/math/curfit/cvevald.x new file mode 100644 index 00000000..c1c1f052 --- /dev/null +++ b/math/curfit/cvevald.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVEVAL -- Procedure to evaluate curve at a given x. The CV_NCOEFF(cv) +# coefficients are assumed to be in COEFF. + +double procedure dcveval (cv, x) + +pointer cv # curve descriptor +double x # x value + +int left +pointer cptr, xptr +double yfit + +double adotd() + +begin + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call dcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call dcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call dcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call dcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call dcv_b1user (cv, x) + } + + + # accumulate the fitted value + cptr = CV_COEFF(cv) + left + xptr = CV_XBASIS(cv) + yfit = adotd (XBASIS(xptr), COEFF(cptr), CV_ORDER(cv)) + + return (yfit) +end diff --git a/math/curfit/cvevalr.x b/math/curfit/cvevalr.x new file mode 100644 index 00000000..56c4c772 --- /dev/null +++ b/math/curfit/cvevalr.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + +# CVEVAL -- Procedure to evaluate curve at a given x. The CV_NCOEFF(cv) +# coefficients are assumed to be in COEFF. + +real procedure cveval (cv, x) + +pointer cv # curve descriptor +real x # x value + +int left +pointer cptr, xptr +real yfit + +real adotr() + +begin + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call rcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call rcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call rcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call rcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call rcv_b1user (cv, x) + } + + + # accumulate the fitted value + cptr = CV_COEFF(cv) + left + xptr = CV_XBASIS(cv) + yfit = adotr (XBASIS(xptr), COEFF(cptr), CV_ORDER(cv)) + + return (yfit) +end diff --git a/math/curfit/cvfit.gx b/math/curfit/cvfit.gx new file mode 100644 index 00000000..65c3bfb5 --- /dev/null +++ b/math/curfit/cvfit.gx @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVFIT -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner product +# of the basis functions and the data ordinates are stored in the +# CV_NCOEFF(cv)-vector VECTOR. The array LEFT is +# used for the indices describing which elements of MATRIX and VECTOR are +# to receive the inner products. After accumulation is complete +# the Cholesky factorization of MATRIX is calculated and stored +# in the CV_ORDER(cv) by CV_NCOEFF(cv) matrix CHOFAC. Finally +# the coefficients are calculated by forward and back substitution +# and placed in COEFF. + +$if (datatype == r) +procedure cvfit (cv, x, y, w, npts, wtflag, ier) +$else +procedure dcvfit (cv, x, y, w, npts, wtflag, ier) +$endif + +pointer cv # curve descriptor +PIXEL x[npts] # array of abcissa +PIXEL y[npts] # array of ordinates +PIXEL w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # error code + + +begin + $if (datatype == r) + + # zero the appropriate arrays + call cvzero (cv) + + # enter data points + call cvacpts (cv, x, y, w, npts, wtflag) + + # solve the system + call cvsolve (cv, ier) + + $else + + # zero the appropriate arrays + call dcvzero (cv) + + # enter data points + call dcvacpts (cv, x, y, w, npts, wtflag) + + # solve the system + call dcvsolve (cv, ier) + + $endif +end diff --git a/math/curfit/cvfitd.x b/math/curfit/cvfitd.x new file mode 100644 index 00000000..bd4f9e83 --- /dev/null +++ b/math/curfit/cvfitd.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVFIT -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner product +# of the basis functions and the data ordinates are stored in the +# CV_NCOEFF(cv)-vector VECTOR. The array LEFT is +# used for the indices describing which elements of MATRIX and VECTOR are +# to receive the inner products. After accumulation is complete +# the Cholesky factorization of MATRIX is calculated and stored +# in the CV_ORDER(cv) by CV_NCOEFF(cv) matrix CHOFAC. Finally +# the coefficients are calculated by forward and back substitution +# and placed in COEFF. + +procedure dcvfit (cv, x, y, w, npts, wtflag, ier) + +pointer cv # curve descriptor +double x[npts] # array of abcissa +double y[npts] # array of ordinates +double w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # error code + + +begin + + # zero the appropriate arrays + call dcvzero (cv) + + # enter data points + call dcvacpts (cv, x, y, w, npts, wtflag) + + # solve the system + call dcvsolve (cv, ier) + +end diff --git a/math/curfit/cvfitr.x b/math/curfit/cvfitr.x new file mode 100644 index 00000000..53374278 --- /dev/null +++ b/math/curfit/cvfitr.x @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + +# CVFIT -- Procedure to add a set of points to the normal equations. +# The inner products of the basis functions are calculated and +# accumulated into the CV_ORDER(cv) by CV_NCOEFF(cv) matrix MATRIX. +# The main diagonal of the matrix is stored in the first row of +# MATRIX followed by the remaining non-zero diagonals. This method +# of storage is particularly efficient for the large symmetric +# banded matrices produced during spline fits. The inner product +# of the basis functions and the data ordinates are stored in the +# CV_NCOEFF(cv)-vector VECTOR. The array LEFT is +# used for the indices describing which elements of MATRIX and VECTOR are +# to receive the inner products. After accumulation is complete +# the Cholesky factorization of MATRIX is calculated and stored +# in the CV_ORDER(cv) by CV_NCOEFF(cv) matrix CHOFAC. Finally +# the coefficients are calculated by forward and back substitution +# and placed in COEFF. + +procedure cvfit (cv, x, y, w, npts, wtflag, ier) + +pointer cv # curve descriptor +real x[npts] # array of abcissa +real y[npts] # array of ordinates +real w[npts] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # error code + + +begin + + # zero the appropriate arrays + call cvzero (cv) + + # enter data points + call cvacpts (cv, x, y, w, npts, wtflag) + + # solve the system + call cvsolve (cv, ier) + +end diff --git a/math/curfit/cvfree.gx b/math/curfit/cvfree.gx new file mode 100644 index 00000000..1c18d637 --- /dev/null +++ b/math/curfit/cvfree.gx @@ -0,0 +1,45 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVFREE -- Procedure to free the curve descriptor + +$if (datatype == r) +procedure cvfree (cv) +$else +procedure dcvfree (cv) +$endif + +pointer cv # the curve descriptor + +errchk mfree + +begin + if (cv == NULL) + return + + if (CV_XBASIS(cv) != NULL) + call mfree (CV_XBASIS(cv), TY_PIXEL) + if (CV_VECTOR(cv) != NULL) + call mfree (CV_VECTOR(cv), TY_PIXEL) + if (CV_COEFF(cv) != NULL) + call mfree (CV_COEFF(cv), TY_PIXEL) + + if (CV_BASIS(cv) != NULL) + call mfree (CV_BASIS(cv), TY_PIXEL) + if (CV_LEFT(cv) != NULL) + call mfree (CV_LEFT(cv), TY_INT) + if (CV_WY(cv) != NULL) + call mfree (CV_WY(cv), TY_PIXEL) + + if (CV_MATRIX(cv) != NULL) + call mfree (CV_MATRIX(cv), TY_PIXEL) + if (CV_CHOFAC(cv) != NULL) + call mfree (CV_CHOFAC(cv), TY_PIXEL) + + call mfree (cv, TY_STRUCT) +end diff --git a/math/curfit/cvfreed.x b/math/curfit/cvfreed.x new file mode 100644 index 00000000..42971c86 --- /dev/null +++ b/math/curfit/cvfreed.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "dcurfitdef.h" + +# CVFREE -- Procedure to free the curve descriptor + +procedure dcvfree (cv) + +pointer cv # the curve descriptor + +errchk mfree + +begin + if (cv == NULL) + return + + if (CV_XBASIS(cv) != NULL) + call mfree (CV_XBASIS(cv), TY_DOUBLE) + if (CV_VECTOR(cv) != NULL) + call mfree (CV_VECTOR(cv), TY_DOUBLE) + if (CV_COEFF(cv) != NULL) + call mfree (CV_COEFF(cv), TY_DOUBLE) + + if (CV_BASIS(cv) != NULL) + call mfree (CV_BASIS(cv), TY_DOUBLE) + if (CV_LEFT(cv) != NULL) + call mfree (CV_LEFT(cv), TY_INT) + if (CV_WY(cv) != NULL) + call mfree (CV_WY(cv), TY_DOUBLE) + + if (CV_MATRIX(cv) != NULL) + call mfree (CV_MATRIX(cv), TY_DOUBLE) + if (CV_CHOFAC(cv) != NULL) + call mfree (CV_CHOFAC(cv), TY_DOUBLE) + + call mfree (cv, TY_STRUCT) +end diff --git a/math/curfit/cvfreer.x b/math/curfit/cvfreer.x new file mode 100644 index 00000000..95adffca --- /dev/null +++ b/math/curfit/cvfreer.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "curfitdef.h" + +# CVFREE -- Procedure to free the curve descriptor + +procedure cvfree (cv) + +pointer cv # the curve descriptor + +errchk mfree + +begin + if (cv == NULL) + return + + if (CV_XBASIS(cv) != NULL) + call mfree (CV_XBASIS(cv), TY_REAL) + if (CV_VECTOR(cv) != NULL) + call mfree (CV_VECTOR(cv), TY_REAL) + if (CV_COEFF(cv) != NULL) + call mfree (CV_COEFF(cv), TY_REAL) + + if (CV_BASIS(cv) != NULL) + call mfree (CV_BASIS(cv), TY_REAL) + if (CV_LEFT(cv) != NULL) + call mfree (CV_LEFT(cv), TY_INT) + if (CV_WY(cv) != NULL) + call mfree (CV_WY(cv), TY_REAL) + + if (CV_MATRIX(cv) != NULL) + call mfree (CV_MATRIX(cv), TY_REAL) + if (CV_CHOFAC(cv) != NULL) + call mfree (CV_CHOFAC(cv), TY_REAL) + + call mfree (cv, TY_STRUCT) +end diff --git a/math/curfit/cvinit.gx b/math/curfit/cvinit.gx new file mode 100644 index 00000000..f3518dab --- /dev/null +++ b/math/curfit/cvinit.gx @@ -0,0 +1,95 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include <mach.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVINIT -- Procedure to initialize the curve descriptor. + +$if (datatype == r) +procedure cvinit (cv, curve_type, order, xmin, xmax) +$else +procedure dcvinit (cv, curve_type, order, xmin, xmax) +$endif + +pointer cv # curve descriptor +int curve_type # type of curve to be fitted +int order # order of curve to be fitted, or in the case of the + # spline the number of polynomial pieces to be fit +PIXEL xmin # minimum value of x +PIXEL xmax # maximum value of x + +errchk malloc, calloc + +begin + # check for bad parameters. + cv = NULL + if (order < 1) + call error (0, "CVINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "CVINIT: xmax <= xmin.") + + # allocate space for the curve descriptor + call calloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + # specify the curve-type dependent parameters + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = order + SPLINE3_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (xmax - xmin) + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = order + SPLINE1_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (xmax - xmin) + case USERFNC: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + # Prevent abort for non-linear userfnc, where these values + # may be arbitrary arguments to pass to external. + if ( abs(xmax-xmin) > EPSILON ) { + CV_RANGE(cv) = 2. / (xmax - xmin) + } else { + CV_RANGE(cv) = 0. + } + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + default: + call error (0, "CVINIT: Unknown curve type.") + } + + # set remaining parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for the matrix and vectors + call calloc (CV_XBASIS(cv), CV_ORDER(cv), TY_PIXEL) + call calloc (CV_MATRIX(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_PIXEL) + call calloc (CV_CHOFAC(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_PIXEL) + call calloc (CV_VECTOR(cv), CV_NCOEFF(cv), TY_PIXEL) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_PIXEL) + + # initialize pointer to basis functions to null + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + CV_LEFT(cv) = NULL + + # set null user function + CV_USERFNC(cv) = NULL + + # set data points counter + CV_NPTS(cv) = 0 +end diff --git a/math/curfit/cvinitd.x b/math/curfit/cvinitd.x new file mode 100644 index 00000000..6613d88a --- /dev/null +++ b/math/curfit/cvinitd.x @@ -0,0 +1,87 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include <mach.h> + +include "dcurfitdef.h" + +# CVINIT -- Procedure to initialize the curve descriptor. + +procedure dcvinit (cv, curve_type, order, xmin, xmax) + +pointer cv # curve descriptor +int curve_type # type of curve to be fitted +int order # order of curve to be fitted, or in the case of the + # spline the number of polynomial pieces to be fit +double xmin # minimum value of x +double xmax # maximum value of x + +errchk malloc, calloc + +begin + # check for bad parameters. + cv = NULL + if (order < 1) + call error (0, "CVINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "CVINIT: xmax <= xmin.") + + # allocate space for the curve descriptor + call calloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + # specify the curve-type dependent parameters + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = order + SPLINE3_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (xmax - xmin) + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = order + SPLINE1_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (xmax - xmin) + case USERFNC: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + # Prevent abort for non-linear userfnc, where these values + # may be arbitrary arguments to pass to external. + if ( abs(xmax-xmin) > EPSILON ) { + CV_RANGE(cv) = 2. / (xmax - xmin) + } else { + CV_RANGE(cv) = 0. + } + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + default: + call error (0, "CVINIT: Unknown curve type.") + } + + # set remaining parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for the matrix and vectors + call calloc (CV_XBASIS(cv), CV_ORDER(cv), TY_DOUBLE) + call calloc (CV_MATRIX(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_DOUBLE) + call calloc (CV_CHOFAC(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_DOUBLE) + call calloc (CV_VECTOR(cv), CV_NCOEFF(cv), TY_DOUBLE) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_DOUBLE) + + # initialize pointer to basis functions to null + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + CV_LEFT(cv) = NULL + + # set null user function + CV_USERFNC(cv) = NULL + + # set data points counter + CV_NPTS(cv) = 0 +end diff --git a/math/curfit/cvinitr.x b/math/curfit/cvinitr.x new file mode 100644 index 00000000..0af12853 --- /dev/null +++ b/math/curfit/cvinitr.x @@ -0,0 +1,87 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> +include <mach.h> + +include "curfitdef.h" + +# CVINIT -- Procedure to initialize the curve descriptor. + +procedure cvinit (cv, curve_type, order, xmin, xmax) + +pointer cv # curve descriptor +int curve_type # type of curve to be fitted +int order # order of curve to be fitted, or in the case of the + # spline the number of polynomial pieces to be fit +real xmin # minimum value of x +real xmax # maximum value of x + +errchk malloc, calloc + +begin + # check for bad parameters. + cv = NULL + if (order < 1) + call error (0, "CVINIT: Illegal order.") + + if (xmax <= xmin) + call error (0, "CVINIT: xmax <= xmin.") + + # allocate space for the curve descriptor + call calloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + # specify the curve-type dependent parameters + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = order + SPLINE3_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (xmax - xmin) + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = order + SPLINE1_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (xmax - xmin) + case USERFNC: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + # Prevent abort for non-linear userfnc, where these values + # may be arbitrary arguments to pass to external. + if ( abs(xmax-xmin) > EPSILON ) { + CV_RANGE(cv) = 2. / (xmax - xmin) + } else { + CV_RANGE(cv) = 0. + } + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + default: + call error (0, "CVINIT: Unknown curve type.") + } + + # set remaining parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for the matrix and vectors + call calloc (CV_XBASIS(cv), CV_ORDER(cv), TY_REAL) + call calloc (CV_MATRIX(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_REAL) + call calloc (CV_CHOFAC(cv), CV_ORDER(cv)*CV_NCOEFF(cv), TY_REAL) + call calloc (CV_VECTOR(cv), CV_NCOEFF(cv), TY_REAL) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_REAL) + + # initialize pointer to basis functions to null + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + CV_LEFT(cv) = NULL + + # set null user function + CV_USERFNC(cv) = NULL + + # set data points counter + CV_NPTS(cv) = 0 +end diff --git a/math/curfit/cvpower.gx b/math/curfit/cvpower.gx new file mode 100644 index 00000000..0e3cb62a --- /dev/null +++ b/math/curfit/cvpower.gx @@ -0,0 +1,526 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVPOWER -- Convert legendre or chebyshev coeffecients to power series. + +$if (datatype == r) +procedure cvpower (cv, ps_coeff, ncoeff) +$else +procedure dcvpower (cv, ps_coeff, ncoeff) +$endif + +pointer cv # Pointer to curfit structure +PIXEL ps_coeff[ncoeff] # Power series coefficients (output) +int ncoeff # Number of coefficients in fit + +pointer sp, cf_coeff, elm +int function +$if (datatype == r) +int cvstati() +$else +int dcvstati() +$endif + +begin + $if (datatype == r) + function = cvstati (cv, CVTYPE) + ncoeff = cvstati (cv, CVNCOEFF) + $else + function = dcvstati (cv, CVTYPE) + ncoeff = dcvstati (cv, CVNCOEFF) + $endif + + if (function != LEGENDRE && function != CHEBYSHEV) { + call eprintf ("Cannot convert coefficients - wrong function type\n") + call amovk$t (INDEF, ps_coeff, ncoeff) + return + } + + call smark (sp) + call salloc (elm, ncoeff ** 2, TY_DOUBLE) + call salloc (cf_coeff, ncoeff, TY_PIXEL) + + call amovkd (0.0d0, Memd[elm], ncoeff ** 2) + + # Get existing coefficients + $if (datatype == r) + call cvcoeff (cv, Memr[cf_coeff], ncoeff) + $else + call dcvcoeff (cv, Memd[cf_coeff], ncoeff) + $endif + + switch (function){ + case (LEGENDRE): + call $tcv_mlegen (Memd[elm], ncoeff) + call $tcv_legen (Memd[elm], Mem$t[cf_coeff], ps_coeff, ncoeff) + case (CHEBYSHEV): + call $tcv_mcheby (Memd[elm], ncoeff) + call $tcv_cheby (Memd[elm], Mem$t[cf_coeff], ps_coeff, ncoeff) + } + + # Normalize coefficients + call $tcv_normalize (cv, ps_coeff, ncoeff) + + call sfree (sp) +end + + +# CVEPOWER -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the power series 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 cvepower (cv, y, w, yfit, npts, chisqr, perrors) +$else +procedure dcvepower (cv, y, w, yfit, npts, chisqr, perrors) +$endif + +pointer cv # curve descriptor +PIXEL y[ARB] # data points +PIXEL yfit[ARB] # fitted data points +PIXEL w[ARB] # array of weights +int npts # number of points +PIXEL chisqr # reduced chi-squared of fit +PIXEL perrors[ARB] # errors in coefficients + +int i, j, n, nfree, function, ncoeff +PIXEL variance, chisq, hold +pointer sp, covar, elm +$if (datatype == r) +int cvstati() +$else +int dcvstati() +$endif + +begin + # Determine the function type. + $if (datatype == r) + function = cvstati (cv, CVTYPE) + ncoeff = cvstati (cv, CVNCOEFF) + $else + function = dcvstati (cv, CVTYPE) + ncoeff = dcvstati (cv, CVNCOEFF) + $endif + + # Check the function type. + if (function != LEGENDRE && function != CHEBYSHEV) { + call eprintf ("Cannot convert errors - wrong function type\n") + call amovk$t (INDEF, perrors, ncoeff) + return + } + + # Estimate the variance and chi-squared of the fit. + n = 0 + variance = 0. + chisq = 0. + do i = 1, npts { + if (w[i] <= 0.0) + next + hold = (y[i] - yfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + n = n + 1 + } + + # Calculate the reduced chi-squared. + nfree = n - CV_NCOEFF(cv) + 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. + + + # Allocate space for the covariance and conversion matrices. + call smark (sp) + call salloc (covar, ncoeff * ncoeff, TY_DOUBLE) + call salloc (elm, ncoeff * ncoeff, TY_DOUBLE) + + # Compute the covariance matrix. + do j = 1, ncoeff { + call aclr$t (perrors, ncoeff) + perrors[j] = PIXEL(1.0) + call $tcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), + CV_NCOEFF(cv), perrors, perrors) + call amulk$t (perrors, PIXEL(variance), perrors, ncoeff) + call acht$td (perrors, Memd[covar+(j-1)*ncoeff], ncoeff) + } + + # Compute the conversion matrix. + call amovkd (0.0d0, Memd[elm], ncoeff * ncoeff) + switch (function) { + case LEGENDRE: + call $tcv_mlegen (Memd[elm], ncoeff) + case CHEBYSHEV: + call $tcv_mcheby (Memd[elm], ncoeff) + } + + # Normalize the errors to the appropriate data range. + call $tcv_enormalize (cv, Memd[elm], ncoeff) + + # Compute the new squared errors. + call $tcv_etransform (cv, Memd[covar], Memd[elm], perrors, ncoeff) + + # Compute the errors. + do j = 1, ncoeff { + if (perrors[j] >= 0.0) + perrors[j] = sqrt(perrors[j]) + else + perrors[j] = 0.0 + } + + call sfree (sp) +end + + +# CV_MLEGEN -- Compute the matrix required to convert from legendre +# coefficients to power series coefficients. Summation notation for Legendre +# series taken from Arfken, page 536, equation 12.8. + +procedure $tcv_mlegen (matrix, ncoeff) + +double matrix[ncoeff, ncoeff] +int ncoeff + +int s, n, r +double $tcv_legcoeff() + +begin + # Calculate matrix elements. + do s = 0, ncoeff - 1 { + if (mod (s, 2) == 0) + r = s / 2 + else + r = (s - 1) / 2 + + do n = 0, r + matrix[s+1, (s+1) - (2*n)] = $tcv_legcoeff (n, s) + } +end + + +# CV_ETRANSFORM -- Convert the square of the fitted polynomial errors +# to the values appropriate for the equivalent power series polynomial. + +procedure $tcv_etransform (cv, covar, elm, perrors, ncoeff) + +pointer cv +double covar[ncoeff,ncoeff] +double elm[ncoeff,ncoeff] +PIXEL perrors[ncoeff] +int ncoeff + +int i, j, k +double sum + +begin + do i = 1, ncoeff { + sum = 0.0d0 + do j = 1, ncoeff { + sum = sum + elm[j,i] * covar[j,j] * elm[j,i] + do k = j + 1, ncoeff { + sum = sum + 2.0 * elm[j,i] * covar[j,k] * elm[k,i] + } + } + perrors[i] = sum + } +end + + +# CV_LEGEN -- Convert legendre coeffecients to power series coefficients. +# Scaling the coefficients from -1,+1 to the full data range is done in a +# seperate procedure (cf_normalize). + +procedure $tcv_legen (matrix, cf_coeff, ps_coeff, ncoeff) + +double matrix[ncoeff, ncoeff] +PIXEL cf_coeff[ncoeff] +PIXEL ps_coeff[ncoeff] +int ncoeff + +int n, i +double sum + +begin + # Multiply matrix columns by curfit coefficients and sum. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff + sum = sum + (matrix[i,n] * cf_coeff[i]) + ps_coeff[n] = sum + } +end + + +# CV_LEGCOEFF -- calculate matrix elements for converting legendre coefficients +# to powers of x. + +double procedure $tcv_legcoeff (k, n) + +int k +int n + +double fcn, sum1, divisor +double $tcv_factorial() + +begin + sum1 = ((-1) ** k) * $tcv_factorial (2 * n - 2 * k) + divisor = (2**n) * $tcv_factorial (k) * $tcv_factorial (n-k) * + $tcv_factorial (n - 2*k) + fcn = sum1 / divisor + + return (fcn) +end + + +# CV_MCHEBY -- Compute the matrix required to convert from Chebyshev +# coefficient to power series coefficients. Summation notation for Chebyshev +# series from Arfken, page 628, equation 13.83 + +procedure $tcv_mcheby (matrix, ncoeff) + +double matrix[ncoeff, ncoeff] # Work array for matrix elements +int ncoeff # Number of coefficients + +int s, n, m +double $tcv_chebcoeff() + +begin + # Set first matrix element. + matrix[1,1] = 1.0d0 + + # Calculate remaining matrix elements. + do s = 1, ncoeff - 1 { + if (mod (s, 2) == 0) + n = s / 2 + else + n = (s - 1) / 2 + + do m = 0, n + matrix[(s+1),(s+1)-(2*m)] = (double(s)/2.0) * + $tcv_chebcoeff (m, s) + } +end + + +# CV_CHEBY -- Convert chebyshev coeffecients to power series coefficients. +# Scaling the coefficients from -1,+1 to the full data range is done in a +# seperate procedure (cf_normalize). + +procedure $tcv_cheby (matrix, cf_coeff, ps_coeff, ncoeff) + +double matrix[ncoeff, ncoeff] # Work array for matrix elements +PIXEL cf_coeff[ncoeff] # Input curfit coefficients +PIXEL ps_coeff[ncoeff] # Output power series coefficients +int ncoeff # Number of coefficients + +int n, i +double sum + +begin + # Multiply matrix columns by curfit coefficients and sum. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff + sum = sum + (matrix[i,n] * cf_coeff[i]) + ps_coeff[n] = sum + } +end + + +# CV_CHEBCOEFF -- calculate matrix elements for converting chebyshev +# coefficients to powers of x. + +double procedure $tcv_chebcoeff (m, n) + +int m # Summation notation index +int n # Summation notation index + +double fcn, sum1, divisor +double $tcv_factorial() + +begin + sum1 = ((-1) ** m) * $tcv_factorial (n - m - 1) * (2 ** (n - (2*m))) + divisor = $tcv_factorial (n - (2*m)) * $tcv_factorial (m) + fcn = sum1 / divisor + + return (fcn) +end + + +# CV_NORMALIZE -- Return coefficients scaled to full data range. + +procedure $tcv_normalize (cv, ps_coeff, ncoeff) + +pointer cv # Pointer to curfit structure +int ncoeff # Number of coefficients in fit +PIXEL ps_coeff[ncoeff] # Power series coefficients + +pointer sp, elm, index +int n, i, k +double k1, k2, bc, sum + +double $tcv_bcoeff() + +begin + # Need space for ncoeff**2 matrix elements + call smark (sp) + call salloc (elm, ncoeff ** 2, TY_DOUBLE) + + k1 = CV_RANGE(cv) + k2 = k1 * CV_MAXMIN(cv) + + # Fill matrix, after zeroing it. + call amovkd (0.0d0, Memd[elm], ncoeff ** 2) + do n = 1, ncoeff { + k = n - 1 + do i = 0, k { + bc = $tcv_bcoeff (k, i) + index = elm + k * ncoeff + i + Memd[index] = bc * ps_coeff[n] * (k1 ** i) * (k2 ** (k-i)) + } + } + + # Now sum along matrix columns to get coefficient of individual + # powers of x. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff { + index = elm + (n-1) + (i-1) * ncoeff + sum = sum + Memd[index] + } + ps_coeff[n] = sum + } + + call sfree (sp) +end + + +# CV_ENORMALIZE -- Return the squares of the errors scaled to full data range. + +procedure $tcv_enormalize (cv, elm, ncoeff) + +pointer cv # Pointer to curfit structure +double elm[ncoeff,ncoeff] # Input transformed matrix +int ncoeff # Number of coefficients in fit + +pointer sp, norm, onorm, index +int n, i, k +double k1, k2, bc + +double $tcv_bcoeff() + +begin + # Need space for ncoeff**2 matrix elements + call smark (sp) + call salloc (norm, ncoeff ** 2, TY_DOUBLE) + call salloc (onorm, ncoeff ** 2, TY_DOUBLE) + + k1 = CV_RANGE(cv) + k2 = k1 * CV_MAXMIN(cv) + + # Fill normalization matrix after zeroing it. + call amovkd (0.0d0, Memd[norm], ncoeff ** 2) + do n = 1, ncoeff { + k = n - 1 + do i = 0, k { + bc = $tcv_bcoeff (k, i) + index = norm + i * ncoeff + k + Memd[index] = bc * (k1 ** i) * (k2 ** (k-i)) + } + } + + # Multiply the input transformation matrix by the normalization + # matrix. + call cv_mmuld (Memd[norm], elm, Memd[onorm], ncoeff) + call amovd (Memd[onorm], elm, ncoeff ** 2) + + call sfree (sp) +end + + +# CV_BCOEFF -- calculate and return binomial coefficient as function value. + +double procedure $tcv_bcoeff (n, i) + +int n +int i + +double $tcv_factorial() + +begin + if (i == 0) + return (1.0d0) + else if (n == i) + return (1.0d0) + else + return ($tcv_factorial (n) / ($tcv_factorial (n - i) * + $tcv_factorial (i))) +end + + +# CV_FACTORIAL -- calculate factorial of argument and return as function value. + +double procedure $tcv_factorial (n) + +int n + +int i +double fact + +begin + if (n == 0) + return (1.0d0) + else { + fact = 1.0d0 + do i = n, 1, -1 + fact = fact * double (i) + return (fact) + } +end + + +# CV_MMUL -- Matrix multiply. + +procedure cv_mmul$t (a, b, c, ndim) + +PIXEL a[ndim,ndim] #I left input matrix +PIXEL b[ndim,ndim] #I right input matrix +PIXEL c[ndim,ndim] #O output matrix +int ndim #I dimensionality of system + +int i, j, k +PIXEL v + +begin + do j = 1, ndim + do i = 1, ndim { + v = PIXEL(0.0) + do k = 1, ndim + #v = v + a[k,j] * b[i,k] + v = v + a[k,j] * b[i,k] + c[i,j] = v + } +end + diff --git a/math/curfit/cvpowerd.x b/math/curfit/cvpowerd.x new file mode 100644 index 00000000..626aa723 --- /dev/null +++ b/math/curfit/cvpowerd.x @@ -0,0 +1,492 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVPOWER -- Convert legendre or chebyshev coeffecients to power series. + +procedure dcvpower (cv, ps_coeff, ncoeff) + +pointer cv # Pointer to curfit structure +double ps_coeff[ncoeff] # Power series coefficients (output) +int ncoeff # Number of coefficients in fit + +pointer sp, cf_coeff, elm +int function +int dcvstati() + +begin + function = dcvstati (cv, CVTYPE) + ncoeff = dcvstati (cv, CVNCOEFF) + + if (function != LEGENDRE && function != CHEBYSHEV) { + call eprintf ("Cannot convert coefficients - wrong function type\n") + call amovkd (INDEFD, ps_coeff, ncoeff) + return + } + + call smark (sp) + call salloc (elm, ncoeff ** 2, TY_DOUBLE) + call salloc (cf_coeff, ncoeff, TY_DOUBLE) + + call amovkd (0.0d0, Memd[elm], ncoeff ** 2) + + # Get existing coefficients + call dcvcoeff (cv, Memd[cf_coeff], ncoeff) + + switch (function){ + case (LEGENDRE): + call dcv_mlegen (Memd[elm], ncoeff) + call dcv_legen (Memd[elm], Memd[cf_coeff], ps_coeff, ncoeff) + case (CHEBYSHEV): + call dcv_mcheby (Memd[elm], ncoeff) + call dcv_cheby (Memd[elm], Memd[cf_coeff], ps_coeff, ncoeff) + } + + # Normalize coefficients + call dcv_normalize (cv, ps_coeff, ncoeff) + + call sfree (sp) +end + + +# CVEPOWER -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the power series 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 dcvepower (cv, y, w, yfit, npts, chisqr, perrors) + +pointer cv # curve descriptor +double y[ARB] # data points +double yfit[ARB] # fitted data points +double w[ARB] # array of weights +int npts # number of points +double chisqr # reduced chi-squared of fit +double perrors[ARB] # errors in coefficients + +int i, j, n, nfree, function, ncoeff +double variance, chisq, hold +pointer sp, covar, elm +int dcvstati() + +begin + # Determine the function type. + function = dcvstati (cv, CVTYPE) + ncoeff = dcvstati (cv, CVNCOEFF) + + # Check the function type. + if (function != LEGENDRE && function != CHEBYSHEV) { + call eprintf ("Cannot convert errors - wrong function type\n") + call amovkd (INDEFD, perrors, ncoeff) + return + } + + # Estimate the variance and chi-squared of the fit. + n = 0 + variance = 0. + chisq = 0. + do i = 1, npts { + if (w[i] <= 0.0) + next + hold = (y[i] - yfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + n = n + 1 + } + + # Calculate the reduced chi-squared. + nfree = n - CV_NCOEFF(cv) + 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. + + + # Allocate space for the covariance and conversion matrices. + call smark (sp) + call salloc (covar, ncoeff * ncoeff, TY_DOUBLE) + call salloc (elm, ncoeff * ncoeff, TY_DOUBLE) + + # Compute the covariance matrix. + do j = 1, ncoeff { + call aclrd (perrors, ncoeff) + perrors[j] = double(1.0) + call dcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), + CV_NCOEFF(cv), perrors, perrors) + call amulkd (perrors, double(variance), perrors, ncoeff) + call achtdd (perrors, Memd[covar+(j-1)*ncoeff], ncoeff) + } + + # Compute the conversion matrix. + call amovkd (0.0d0, Memd[elm], ncoeff * ncoeff) + switch (function) { + case LEGENDRE: + call dcv_mlegen (Memd[elm], ncoeff) + case CHEBYSHEV: + call dcv_mcheby (Memd[elm], ncoeff) + } + + # Normalize the errors to the appropriate data range. + call dcv_enormalize (cv, Memd[elm], ncoeff) + + # Compute the new squared errors. + call dcv_etransform (cv, Memd[covar], Memd[elm], perrors, ncoeff) + + # Compute the errors. + do j = 1, ncoeff { + if (perrors[j] >= 0.0) + perrors[j] = sqrt(perrors[j]) + else + perrors[j] = 0.0 + } + + call sfree (sp) +end + + +# CV_MLEGEN -- Compute the matrix required to convert from legendre +# coefficients to power series coefficients. Summation notation for Legendre +# series taken from Arfken, page 536, equation 12.8. + +procedure dcv_mlegen (matrix, ncoeff) + +double matrix[ncoeff, ncoeff] +int ncoeff + +int s, n, r +double dcv_legcoeff() + +begin + # Calculate matrix elements. + do s = 0, ncoeff - 1 { + if (mod (s, 2) == 0) + r = s / 2 + else + r = (s - 1) / 2 + + do n = 0, r + matrix[s+1, (s+1) - (2*n)] = dcv_legcoeff (n, s) + } +end + + +# CV_ETRANSFORM -- Convert the square of the fitted polynomial errors +# to the values appropriate for the equivalent power series polynomial. + +procedure dcv_etransform (cv, covar, elm, perrors, ncoeff) + +pointer cv +double covar[ncoeff,ncoeff] +double elm[ncoeff,ncoeff] +double perrors[ncoeff] +int ncoeff + +int i, j, k +double sum + +begin + do i = 1, ncoeff { + sum = 0.0d0 + do j = 1, ncoeff { + sum = sum + elm[j,i] * covar[j,j] * elm[j,i] + do k = j + 1, ncoeff { + sum = sum + 2.0 * elm[j,i] * covar[j,k] * elm[k,i] + } + } + perrors[i] = sum + } +end + + +# CV_LEGEN -- Convert legendre coeffecients to power series coefficients. +# Scaling the coefficients from -1,+1 to the full data range is done in a +# seperate procedure (cf_normalize). + +procedure dcv_legen (matrix, cf_coeff, ps_coeff, ncoeff) + +double matrix[ncoeff, ncoeff] +double cf_coeff[ncoeff] +double ps_coeff[ncoeff] +int ncoeff + +int n, i +double sum + +begin + # Multiply matrix columns by curfit coefficients and sum. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff + sum = sum + (matrix[i,n] * cf_coeff[i]) + ps_coeff[n] = sum + } +end + + +# CV_LEGCOEFF -- calculate matrix elements for converting legendre coefficients +# to powers of x. + +double procedure dcv_legcoeff (k, n) + +int k +int n + +double fcn, sum1, divisor +double dcv_factorial() + +begin + sum1 = ((-1) ** k) * dcv_factorial (2 * n - 2 * k) + divisor = (2**n) * dcv_factorial (k) * dcv_factorial (n-k) * + dcv_factorial (n - 2*k) + fcn = sum1 / divisor + + return (fcn) +end + + +# CV_MCHEBY -- Compute the matrix required to convert from Chebyshev +# coefficient to power series coefficients. Summation notation for Chebyshev +# series from Arfken, page 628, equation 13.83 + +procedure dcv_mcheby (matrix, ncoeff) + +double matrix[ncoeff, ncoeff] # Work array for matrix elements +int ncoeff # Number of coefficients + +int s, n, m +double dcv_chebcoeff() + +begin + # Set first matrix element. + matrix[1,1] = 1.0d0 + + # Calculate remaining matrix elements. + do s = 1, ncoeff - 1 { + if (mod (s, 2) == 0) + n = s / 2 + else + n = (s - 1) / 2 + + do m = 0, n + matrix[(s+1),(s+1)-(2*m)] = (double(s)/2.0) * + dcv_chebcoeff (m, s) + } +end + + +# CV_CHEBY -- Convert chebyshev coeffecients to power series coefficients. +# Scaling the coefficients from -1,+1 to the full data range is done in a +# seperate procedure (cf_normalize). + +procedure dcv_cheby (matrix, cf_coeff, ps_coeff, ncoeff) + +double matrix[ncoeff, ncoeff] # Work array for matrix elements +double cf_coeff[ncoeff] # Input curfit coefficients +double ps_coeff[ncoeff] # Output power series coefficients +int ncoeff # Number of coefficients + +int n, i +double sum + +begin + # Multiply matrix columns by curfit coefficients and sum. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff + sum = sum + (matrix[i,n] * cf_coeff[i]) + ps_coeff[n] = sum + } +end + + +# CV_CHEBCOEFF -- calculate matrix elements for converting chebyshev +# coefficients to powers of x. + +double procedure dcv_chebcoeff (m, n) + +int m # Summation notation index +int n # Summation notation index + +double fcn, sum1, divisor +double dcv_factorial() + +begin + sum1 = ((-1) ** m) * dcv_factorial (n - m - 1) * (2 ** (n - (2*m))) + divisor = dcv_factorial (n - (2*m)) * dcv_factorial (m) + fcn = sum1 / divisor + + return (fcn) +end + + +# CV_NORMALIZE -- Return coefficients scaled to full data range. + +procedure dcv_normalize (cv, ps_coeff, ncoeff) + +pointer cv # Pointer to curfit structure +int ncoeff # Number of coefficients in fit +double ps_coeff[ncoeff] # Power series coefficients + +pointer sp, elm, index +int n, i, k +double k1, k2, bc, sum + +double dcv_bcoeff() + +begin + # Need space for ncoeff**2 matrix elements + call smark (sp) + call salloc (elm, ncoeff ** 2, TY_DOUBLE) + + k1 = CV_RANGE(cv) + k2 = k1 * CV_MAXMIN(cv) + + # Fill matrix, after zeroing it. + call amovkd (0.0d0, Memd[elm], ncoeff ** 2) + do n = 1, ncoeff { + k = n - 1 + do i = 0, k { + bc = dcv_bcoeff (k, i) + index = elm + k * ncoeff + i + Memd[index] = bc * ps_coeff[n] * (k1 ** i) * (k2 ** (k-i)) + } + } + + # Now sum along matrix columns to get coefficient of individual + # powers of x. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff { + index = elm + (n-1) + (i-1) * ncoeff + sum = sum + Memd[index] + } + ps_coeff[n] = sum + } + + call sfree (sp) +end + + +# CV_ENORMALIZE -- Return the squares of the errors scaled to full data range. + +procedure dcv_enormalize (cv, elm, ncoeff) + +pointer cv # Pointer to curfit structure +double elm[ncoeff,ncoeff] # Input transformed matrix +int ncoeff # Number of coefficients in fit + +pointer sp, norm, onorm, index +int n, i, k +double k1, k2, bc + +double dcv_bcoeff() + +begin + # Need space for ncoeff**2 matrix elements + call smark (sp) + call salloc (norm, ncoeff ** 2, TY_DOUBLE) + call salloc (onorm, ncoeff ** 2, TY_DOUBLE) + + k1 = CV_RANGE(cv) + k2 = k1 * CV_MAXMIN(cv) + + # Fill normalization matrix after zeroing it. + call amovkd (0.0d0, Memd[norm], ncoeff ** 2) + do n = 1, ncoeff { + k = n - 1 + do i = 0, k { + bc = dcv_bcoeff (k, i) + index = norm + i * ncoeff + k + Memd[index] = bc * (k1 ** i) * (k2 ** (k-i)) + } + } + + # Multiply the input transformation matrix by the normalization + # matrix. + call cv_mmuld (Memd[norm], elm, Memd[onorm], ncoeff) + call amovd (Memd[onorm], elm, ncoeff ** 2) + + call sfree (sp) +end + + +# CV_BCOEFF -- calculate and return binomial coefficient as function value. + +double procedure dcv_bcoeff (n, i) + +int n +int i + +double dcv_factorial() + +begin + if (i == 0) + return (1.0d0) + else if (n == i) + return (1.0d0) + else + return (dcv_factorial (n) / (dcv_factorial (n - i) * + dcv_factorial (i))) +end + + +# CV_FACTORIAL -- calculate factorial of argument and return as function value. + +double procedure dcv_factorial (n) + +int n + +int i +double fact + +begin + if (n == 0) + return (1.0d0) + else { + fact = 1.0d0 + do i = n, 1, -1 + fact = fact * double (i) + return (fact) + } +end + + +# CV_MMUL -- Matrix multiply. + +procedure cv_mmuld (a, b, c, ndim) + +double a[ndim,ndim] #I left input matrix +double b[ndim,ndim] #I right input matrix +double c[ndim,ndim] #O output matrix +int ndim #I dimensionality of system + +int i, j, k +double v + +begin + do j = 1, ndim + do i = 1, ndim { + v = double(0.0) + do k = 1, ndim + #v = v + a[k,j] * b[i,k] + v = v + a[k,j] * b[i,k] + c[i,j] = v + } +end + diff --git a/math/curfit/cvpowerr.x b/math/curfit/cvpowerr.x new file mode 100644 index 00000000..a100d057 --- /dev/null +++ b/math/curfit/cvpowerr.x @@ -0,0 +1,492 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <math/curfit.h> + +include "curfitdef.h" + +# CVPOWER -- Convert legendre or chebyshev coeffecients to power series. + +procedure cvpower (cv, ps_coeff, ncoeff) + +pointer cv # Pointer to curfit structure +real ps_coeff[ncoeff] # Power series coefficients (output) +int ncoeff # Number of coefficients in fit + +pointer sp, cf_coeff, elm +int function +int cvstati() + +begin + function = cvstati (cv, CVTYPE) + ncoeff = cvstati (cv, CVNCOEFF) + + if (function != LEGENDRE && function != CHEBYSHEV) { + call eprintf ("Cannot convert coefficients - wrong function type\n") + call amovkr (INDEFR, ps_coeff, ncoeff) + return + } + + call smark (sp) + call salloc (elm, ncoeff ** 2, TY_DOUBLE) + call salloc (cf_coeff, ncoeff, TY_REAL) + + call amovkd (0.0d0, Memd[elm], ncoeff ** 2) + + # Get existing coefficients + call cvcoeff (cv, Memr[cf_coeff], ncoeff) + + switch (function){ + case (LEGENDRE): + call rcv_mlegen (Memd[elm], ncoeff) + call rcv_legen (Memd[elm], Memr[cf_coeff], ps_coeff, ncoeff) + case (CHEBYSHEV): + call rcv_mcheby (Memd[elm], ncoeff) + call rcv_cheby (Memd[elm], Memr[cf_coeff], ps_coeff, ncoeff) + } + + # Normalize coefficients + call rcv_normalize (cv, ps_coeff, ncoeff) + + call sfree (sp) +end + + +# CVEPOWER -- Procedure to calculate the reduced chi-squared of the fit +# and the standard deviations of the power series 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 cvepower (cv, y, w, yfit, npts, chisqr, perrors) + +pointer cv # curve descriptor +real y[ARB] # data points +real yfit[ARB] # fitted data points +real w[ARB] # array of weights +int npts # number of points +real chisqr # reduced chi-squared of fit +real perrors[ARB] # errors in coefficients + +int i, j, n, nfree, function, ncoeff +real variance, chisq, hold +pointer sp, covar, elm +int cvstati() + +begin + # Determine the function type. + function = cvstati (cv, CVTYPE) + ncoeff = cvstati (cv, CVNCOEFF) + + # Check the function type. + if (function != LEGENDRE && function != CHEBYSHEV) { + call eprintf ("Cannot convert errors - wrong function type\n") + call amovkr (INDEFR, perrors, ncoeff) + return + } + + # Estimate the variance and chi-squared of the fit. + n = 0 + variance = 0. + chisq = 0. + do i = 1, npts { + if (w[i] <= 0.0) + next + hold = (y[i] - yfit[i]) ** 2 + variance = variance + hold + chisq = chisq + hold * w[i] + n = n + 1 + } + + # Calculate the reduced chi-squared. + nfree = n - CV_NCOEFF(cv) + 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. + + + # Allocate space for the covariance and conversion matrices. + call smark (sp) + call salloc (covar, ncoeff * ncoeff, TY_DOUBLE) + call salloc (elm, ncoeff * ncoeff, TY_DOUBLE) + + # Compute the covariance matrix. + do j = 1, ncoeff { + call aclrr (perrors, ncoeff) + perrors[j] = real(1.0) + call rcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), + CV_NCOEFF(cv), perrors, perrors) + call amulkr (perrors, real(variance), perrors, ncoeff) + call achtrd (perrors, Memd[covar+(j-1)*ncoeff], ncoeff) + } + + # Compute the conversion matrix. + call amovkd (0.0d0, Memd[elm], ncoeff * ncoeff) + switch (function) { + case LEGENDRE: + call rcv_mlegen (Memd[elm], ncoeff) + case CHEBYSHEV: + call rcv_mcheby (Memd[elm], ncoeff) + } + + # Normalize the errors to the appropriate data range. + call rcv_enormalize (cv, Memd[elm], ncoeff) + + # Compute the new squared errors. + call rcv_etransform (cv, Memd[covar], Memd[elm], perrors, ncoeff) + + # Compute the errors. + do j = 1, ncoeff { + if (perrors[j] >= 0.0) + perrors[j] = sqrt(perrors[j]) + else + perrors[j] = 0.0 + } + + call sfree (sp) +end + + +# CV_MLEGEN -- Compute the matrix required to convert from legendre +# coefficients to power series coefficients. Summation notation for Legendre +# series taken from Arfken, page 536, equation 12.8. + +procedure rcv_mlegen (matrix, ncoeff) + +double matrix[ncoeff, ncoeff] +int ncoeff + +int s, n, r +double rcv_legcoeff() + +begin + # Calculate matrix elements. + do s = 0, ncoeff - 1 { + if (mod (s, 2) == 0) + r = s / 2 + else + r = (s - 1) / 2 + + do n = 0, r + matrix[s+1, (s+1) - (2*n)] = rcv_legcoeff (n, s) + } +end + + +# CV_ETRANSFORM -- Convert the square of the fitted polynomial errors +# to the values appropriate for the equivalent power series polynomial. + +procedure rcv_etransform (cv, covar, elm, perrors, ncoeff) + +pointer cv +double covar[ncoeff,ncoeff] +double elm[ncoeff,ncoeff] +real perrors[ncoeff] +int ncoeff + +int i, j, k +double sum + +begin + do i = 1, ncoeff { + sum = 0.0d0 + do j = 1, ncoeff { + sum = sum + elm[j,i] * covar[j,j] * elm[j,i] + do k = j + 1, ncoeff { + sum = sum + 2.0 * elm[j,i] * covar[j,k] * elm[k,i] + } + } + perrors[i] = sum + } +end + + +# CV_LEGEN -- Convert legendre coeffecients to power series coefficients. +# Scaling the coefficients from -1,+1 to the full data range is done in a +# seperate procedure (cf_normalize). + +procedure rcv_legen (matrix, cf_coeff, ps_coeff, ncoeff) + +double matrix[ncoeff, ncoeff] +real cf_coeff[ncoeff] +real ps_coeff[ncoeff] +int ncoeff + +int n, i +double sum + +begin + # Multiply matrix columns by curfit coefficients and sum. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff + sum = sum + (matrix[i,n] * cf_coeff[i]) + ps_coeff[n] = sum + } +end + + +# CV_LEGCOEFF -- calculate matrix elements for converting legendre coefficients +# to powers of x. + +double procedure rcv_legcoeff (k, n) + +int k +int n + +double fcn, sum1, divisor +double rcv_factorial() + +begin + sum1 = ((-1) ** k) * rcv_factorial (2 * n - 2 * k) + divisor = (2**n) * rcv_factorial (k) * rcv_factorial (n-k) * + rcv_factorial (n - 2*k) + fcn = sum1 / divisor + + return (fcn) +end + + +# CV_MCHEBY -- Compute the matrix required to convert from Chebyshev +# coefficient to power series coefficients. Summation notation for Chebyshev +# series from Arfken, page 628, equation 13.83 + +procedure rcv_mcheby (matrix, ncoeff) + +double matrix[ncoeff, ncoeff] # Work array for matrix elements +int ncoeff # Number of coefficients + +int s, n, m +double rcv_chebcoeff() + +begin + # Set first matrix element. + matrix[1,1] = 1.0d0 + + # Calculate remaining matrix elements. + do s = 1, ncoeff - 1 { + if (mod (s, 2) == 0) + n = s / 2 + else + n = (s - 1) / 2 + + do m = 0, n + matrix[(s+1),(s+1)-(2*m)] = (double(s)/2.0) * + rcv_chebcoeff (m, s) + } +end + + +# CV_CHEBY -- Convert chebyshev coeffecients to power series coefficients. +# Scaling the coefficients from -1,+1 to the full data range is done in a +# seperate procedure (cf_normalize). + +procedure rcv_cheby (matrix, cf_coeff, ps_coeff, ncoeff) + +double matrix[ncoeff, ncoeff] # Work array for matrix elements +real cf_coeff[ncoeff] # Input curfit coefficients +real ps_coeff[ncoeff] # Output power series coefficients +int ncoeff # Number of coefficients + +int n, i +double sum + +begin + # Multiply matrix columns by curfit coefficients and sum. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff + sum = sum + (matrix[i,n] * cf_coeff[i]) + ps_coeff[n] = sum + } +end + + +# CV_CHEBCOEFF -- calculate matrix elements for converting chebyshev +# coefficients to powers of x. + +double procedure rcv_chebcoeff (m, n) + +int m # Summation notation index +int n # Summation notation index + +double fcn, sum1, divisor +double rcv_factorial() + +begin + sum1 = ((-1) ** m) * rcv_factorial (n - m - 1) * (2 ** (n - (2*m))) + divisor = rcv_factorial (n - (2*m)) * rcv_factorial (m) + fcn = sum1 / divisor + + return (fcn) +end + + +# CV_NORMALIZE -- Return coefficients scaled to full data range. + +procedure rcv_normalize (cv, ps_coeff, ncoeff) + +pointer cv # Pointer to curfit structure +int ncoeff # Number of coefficients in fit +real ps_coeff[ncoeff] # Power series coefficients + +pointer sp, elm, index +int n, i, k +double k1, k2, bc, sum + +double rcv_bcoeff() + +begin + # Need space for ncoeff**2 matrix elements + call smark (sp) + call salloc (elm, ncoeff ** 2, TY_DOUBLE) + + k1 = CV_RANGE(cv) + k2 = k1 * CV_MAXMIN(cv) + + # Fill matrix, after zeroing it. + call amovkd (0.0d0, Memd[elm], ncoeff ** 2) + do n = 1, ncoeff { + k = n - 1 + do i = 0, k { + bc = rcv_bcoeff (k, i) + index = elm + k * ncoeff + i + Memd[index] = bc * ps_coeff[n] * (k1 ** i) * (k2 ** (k-i)) + } + } + + # Now sum along matrix columns to get coefficient of individual + # powers of x. + do n = 1, ncoeff { + sum = 0.0d0 + do i = 1, ncoeff { + index = elm + (n-1) + (i-1) * ncoeff + sum = sum + Memd[index] + } + ps_coeff[n] = sum + } + + call sfree (sp) +end + + +# CV_ENORMALIZE -- Return the squares of the errors scaled to full data range. + +procedure rcv_enormalize (cv, elm, ncoeff) + +pointer cv # Pointer to curfit structure +double elm[ncoeff,ncoeff] # Input transformed matrix +int ncoeff # Number of coefficients in fit + +pointer sp, norm, onorm, index +int n, i, k +double k1, k2, bc + +double rcv_bcoeff() + +begin + # Need space for ncoeff**2 matrix elements + call smark (sp) + call salloc (norm, ncoeff ** 2, TY_DOUBLE) + call salloc (onorm, ncoeff ** 2, TY_DOUBLE) + + k1 = CV_RANGE(cv) + k2 = k1 * CV_MAXMIN(cv) + + # Fill normalization matrix after zeroing it. + call amovkd (0.0d0, Memd[norm], ncoeff ** 2) + do n = 1, ncoeff { + k = n - 1 + do i = 0, k { + bc = rcv_bcoeff (k, i) + index = norm + i * ncoeff + k + Memd[index] = bc * (k1 ** i) * (k2 ** (k-i)) + } + } + + # Multiply the input transformation matrix by the normalization + # matrix. + call cv_mmuld (Memd[norm], elm, Memd[onorm], ncoeff) + call amovd (Memd[onorm], elm, ncoeff ** 2) + + call sfree (sp) +end + + +# CV_BCOEFF -- calculate and return binomial coefficient as function value. + +double procedure rcv_bcoeff (n, i) + +int n +int i + +double rcv_factorial() + +begin + if (i == 0) + return (1.0d0) + else if (n == i) + return (1.0d0) + else + return (rcv_factorial (n) / (rcv_factorial (n - i) * + rcv_factorial (i))) +end + + +# CV_FACTORIAL -- calculate factorial of argument and return as function value. + +double procedure rcv_factorial (n) + +int n + +int i +double fact + +begin + if (n == 0) + return (1.0d0) + else { + fact = 1.0d0 + do i = n, 1, -1 + fact = fact * double (i) + return (fact) + } +end + + +# CV_MMUL -- Matrix multiply. + +procedure cv_mmulr (a, b, c, ndim) + +real a[ndim,ndim] #I left input matrix +real b[ndim,ndim] #I right input matrix +real c[ndim,ndim] #O output matrix +int ndim #I dimensionality of system + +int i, j, k +real v + +begin + do j = 1, ndim + do i = 1, ndim { + v = real(0.0) + do k = 1, ndim + #v = v + a[k,j] * b[i,k] + v = v + a[k,j] * b[i,k] + c[i,j] = v + } +end + diff --git a/math/curfit/cvrefit.gx b/math/curfit/cvrefit.gx new file mode 100644 index 00000000..448ac684 --- /dev/null +++ b/math/curfit/cvrefit.gx @@ -0,0 +1,111 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVREFIT -- Procedure to refit the data assuming that the x and w values have +# not changed. MATRIX and CHOFAC are assumed to remain unchanged from the +# previous fit. It is only necessary to accumulate a new VECTOR and +# calculate the coefficients COEFF by forward and back substitution. On +# the first call to cvrefit the basis functions for all data points are +# calculated and stored in BASIS. Subsequent calls to cvrefit reference these +# functions. Intervening calls to cvfit or cvzero zero the basis functions. + +$if (datatype == r) +procedure cvrefit (cv, x, y, w, ier) +$else +procedure dcvrefit (cv, x, y, w, ier) +$endif + +pointer cv # curve descriptor +PIXEL x[ARB] # x array +PIXEL y[ARB] # y array +PIXEL w[ARB] # weight array +int ier # error code + +int i, k +pointer bzptr +pointer vzptr, vindex + + +begin + # zero the right side of the matrix equation + call aclr$t (VECTOR(CV_VECTOR(cv)), CV_NCOEFF(cv)) + vzptr = CV_VECTOR(cv) - 1 + + # if first call to cvrefit then calculate and store the basis + # functions + if (CV_BASIS(cv) == NULL) { + + # allocate space for the basis functions and array containing + # the index of the first non-zero basis function + call malloc (CV_BASIS(cv), CV_NPTS(cv)*CV_ORDER(cv), TY_PIXEL) + call malloc (CV_WY(cv), CV_NPTS(cv), TY_PIXEL) + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case LEGENDRE: + call $tcv_bleg (x, CV_NPTS(cv), CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case CHEBYSHEV: + call $tcv_bcheb (x, CV_NPTS(cv), CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case SPLINE3: + call malloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + call $tcv_bspline3 (x, CV_NPTS(cv), CV_NPIECES(cv), + -CV_XMIN(cv), CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), + CV_NPTS(cv)) + case SPLINE1: + call malloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + call $tcv_bspline1 (x, CV_NPTS(cv), CV_NPIECES(cv), + -CV_XMIN(cv), CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), + CV_NPTS(cv)) + case USERFNC: + call $tcv_buser (cv, x, CV_NPTS(cv)) + } + } + + + # accumulate the new right side of the matrix equation + call amul$t (w, y, Mem$t[CV_WY(cv)], CV_NPTS(cv)) + bzptr = CV_BASIS(cv) + + switch (CV_TYPE(cv)) { + + case SPLINE1, SPLINE3: + + do k = 1, CV_ORDER(cv) { + do i = 1, CV_NPTS(cv) { + vindex = LEFT(CV_LEFT(cv)+i-1) + k + VECTOR(vindex) = VECTOR(vindex) + Mem$t[CV_WY(cv)+i-1] * + BASIS(bzptr+i-1) + } + bzptr = bzptr + CV_NPTS(cv) + } + + case LEGENDRE, CHEBYSHEV, USERFNC: + + do k = 1, CV_ORDER(cv) { + vindex = vzptr + k + do i = 1, CV_NPTS(cv) + VECTOR(vindex) = VECTOR(vindex) + Mem$t[CV_WY(cv)+i-1] * + BASIS(bzptr+i-1) + bzptr = bzptr + CV_NPTS(cv) + } + + } + + # solve for the new coefficients using forward and back + # substitution + call $tcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end diff --git a/math/curfit/cvrefitd.x b/math/curfit/cvrefitd.x new file mode 100644 index 00000000..2714beb6 --- /dev/null +++ b/math/curfit/cvrefitd.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVREFIT -- Procedure to refit the data assuming that the x and w values have +# not changed. MATRIX and CHOFAC are assumed to remain unchanged from the +# previous fit. It is only necessary to accumulate a new VECTOR and +# calculate the coefficients COEFF by forward and back substitution. On +# the first call to cvrefit the basis functions for all data points are +# calculated and stored in BASIS. Subsequent calls to cvrefit reference these +# functions. Intervening calls to cvfit or cvzero zero the basis functions. + +procedure dcvrefit (cv, x, y, w, ier) + +pointer cv # curve descriptor +double x[ARB] # x array +double y[ARB] # y array +double w[ARB] # weight array +int ier # error code + +int i, k +pointer bzptr +pointer vzptr, vindex + + +begin + # zero the right side of the matrix equation + call aclrd (VECTOR(CV_VECTOR(cv)), CV_NCOEFF(cv)) + vzptr = CV_VECTOR(cv) - 1 + + # if first call to cvrefit then calculate and store the basis + # functions + if (CV_BASIS(cv) == NULL) { + + # allocate space for the basis functions and array containing + # the index of the first non-zero basis function + call malloc (CV_BASIS(cv), CV_NPTS(cv)*CV_ORDER(cv), TY_DOUBLE) + call malloc (CV_WY(cv), CV_NPTS(cv), TY_DOUBLE) + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case LEGENDRE: + call dcv_bleg (x, CV_NPTS(cv), CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case CHEBYSHEV: + call dcv_bcheb (x, CV_NPTS(cv), CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case SPLINE3: + call malloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + call dcv_bspline3 (x, CV_NPTS(cv), CV_NPIECES(cv), + -CV_XMIN(cv), CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), + CV_NPTS(cv)) + case SPLINE1: + call malloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + call dcv_bspline1 (x, CV_NPTS(cv), CV_NPIECES(cv), + -CV_XMIN(cv), CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), + CV_NPTS(cv)) + case USERFNC: + call dcv_buser (cv, x, CV_NPTS(cv)) + } + } + + + # accumulate the new right side of the matrix equation + call amuld (w, y, Memd[CV_WY(cv)], CV_NPTS(cv)) + bzptr = CV_BASIS(cv) + + switch (CV_TYPE(cv)) { + + case SPLINE1, SPLINE3: + + do k = 1, CV_ORDER(cv) { + do i = 1, CV_NPTS(cv) { + vindex = LEFT(CV_LEFT(cv)+i-1) + k + VECTOR(vindex) = VECTOR(vindex) + Memd[CV_WY(cv)+i-1] * + BASIS(bzptr+i-1) + } + bzptr = bzptr + CV_NPTS(cv) + } + + case LEGENDRE, CHEBYSHEV, USERFNC: + + do k = 1, CV_ORDER(cv) { + vindex = vzptr + k + do i = 1, CV_NPTS(cv) + VECTOR(vindex) = VECTOR(vindex) + Memd[CV_WY(cv)+i-1] * + BASIS(bzptr+i-1) + bzptr = bzptr + CV_NPTS(cv) + } + + } + + # solve for the new coefficients using forward and back + # substitution + call dcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end diff --git a/math/curfit/cvrefitr.x b/math/curfit/cvrefitr.x new file mode 100644 index 00000000..5de9abe2 --- /dev/null +++ b/math/curfit/cvrefitr.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + +# CVREFIT -- Procedure to refit the data assuming that the x and w values have +# not changed. MATRIX and CHOFAC are assumed to remain unchanged from the +# previous fit. It is only necessary to accumulate a new VECTOR and +# calculate the coefficients COEFF by forward and back substitution. On +# the first call to cvrefit the basis functions for all data points are +# calculated and stored in BASIS. Subsequent calls to cvrefit reference these +# functions. Intervening calls to cvfit or cvzero zero the basis functions. + +procedure cvrefit (cv, x, y, w, ier) + +pointer cv # curve descriptor +real x[ARB] # x array +real y[ARB] # y array +real w[ARB] # weight array +int ier # error code + +int i, k +pointer bzptr +pointer vzptr, vindex + + +begin + # zero the right side of the matrix equation + call aclrr (VECTOR(CV_VECTOR(cv)), CV_NCOEFF(cv)) + vzptr = CV_VECTOR(cv) - 1 + + # if first call to cvrefit then calculate and store the basis + # functions + if (CV_BASIS(cv) == NULL) { + + # allocate space for the basis functions and array containing + # the index of the first non-zero basis function + call malloc (CV_BASIS(cv), CV_NPTS(cv)*CV_ORDER(cv), TY_REAL) + call malloc (CV_WY(cv), CV_NPTS(cv), TY_REAL) + + # calculate the non-zero basis functions + switch (CV_TYPE(cv)) { + case LEGENDRE: + call rcv_bleg (x, CV_NPTS(cv), CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case CHEBYSHEV: + call rcv_bcheb (x, CV_NPTS(cv), CV_ORDER(cv), CV_MAXMIN(cv), + CV_RANGE(cv), BASIS(CV_BASIS(cv))) + case SPLINE3: + call malloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + call rcv_bspline3 (x, CV_NPTS(cv), CV_NPIECES(cv), + -CV_XMIN(cv), CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), + CV_NPTS(cv)) + case SPLINE1: + call malloc (CV_LEFT(cv), CV_NPTS(cv), TY_INT) + call rcv_bspline1 (x, CV_NPTS(cv), CV_NPIECES(cv), + -CV_XMIN(cv), CV_SPACING(cv), BASIS(CV_BASIS(cv)), + LEFT(CV_LEFT(cv))) + call aaddki (LEFT(CV_LEFT(cv)), vzptr, LEFT(CV_LEFT(cv)), + CV_NPTS(cv)) + case USERFNC: + call rcv_buser (cv, x, CV_NPTS(cv)) + } + } + + + # accumulate the new right side of the matrix equation + call amulr (w, y, Memr[CV_WY(cv)], CV_NPTS(cv)) + bzptr = CV_BASIS(cv) + + switch (CV_TYPE(cv)) { + + case SPLINE1, SPLINE3: + + do k = 1, CV_ORDER(cv) { + do i = 1, CV_NPTS(cv) { + vindex = LEFT(CV_LEFT(cv)+i-1) + k + VECTOR(vindex) = VECTOR(vindex) + Memr[CV_WY(cv)+i-1] * + BASIS(bzptr+i-1) + } + bzptr = bzptr + CV_NPTS(cv) + } + + case LEGENDRE, CHEBYSHEV, USERFNC: + + do k = 1, CV_ORDER(cv) { + vindex = vzptr + k + do i = 1, CV_NPTS(cv) + VECTOR(vindex) = VECTOR(vindex) + Memr[CV_WY(cv)+i-1] * + BASIS(bzptr+i-1) + bzptr = bzptr + CV_NPTS(cv) + } + + } + + # solve for the new coefficients using forward and back + # substitution + call rcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end diff --git a/math/curfit/cvreject.gx b/math/curfit/cvreject.gx new file mode 100644 index 00000000..bbaffef4 --- /dev/null +++ b/math/curfit/cvreject.gx @@ -0,0 +1,82 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVREJECT -- Procedure to subtract a single datapoint from the data set. +# The normal equations for the data point are calculated +# and subtracted from MATRIX and VECTOR. After all rejected points +# have been subtracted from the fit CVSOLVE, must be called to generate +# a new set of coefficients. + +$if (datatype == r) +procedure cvrject (cv, x, y, w) +$else +procedure dcvrject (cv, x, y, w) +$endif + +pointer cv # curve fitting image descriptor +PIXEL x # x value +PIXEL y # y value +PIXEL w # weight of the data point + +int left, i, ii, j +pointer xzptr +pointer mzptr, mzzptr +pointer vzptr +PIXEL bw + +begin + + # increment the number of points + CV_NPTS(cv) = CV_NPTS(cv) - 1 + + # calculate all type non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call $tcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call $tcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call $tcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call $tcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call $tcv_b1user (cv, x) + } + + # index the pointers + xzptr = CV_XBASIS(cv) - 1 + mzptr = CV_MATRIX(cv) + CV_ORDER(cv) * (left - 1) + vzptr = CV_VECTOR(cv) + left - 1 + + # calculate the normal equations for the data point and subtract + # them from the fit + do i = 1, CV_ORDER(cv) { + + # subtract inner product of basis functions and data ordinate + # from the fit + bw = XBASIS(xzptr+i) * w + VECTOR(vzptr+i) = VECTOR(vzptr+i) - bw * y + + # subtract inner product of basis functions from the fit + ii = 0 + mzzptr = mzptr + i * CV_ORDER(cv) + do j = i, CV_ORDER(cv) { + MATRIX(mzzptr+ii) = MATRIX(mzzptr+ii) - XBASIS(xzptr+j) * bw + ii = ii + 1 + } + } +end diff --git a/math/curfit/cvrejectd.x b/math/curfit/cvrejectd.x new file mode 100644 index 00000000..903ef594 --- /dev/null +++ b/math/curfit/cvrejectd.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVREJECT -- Procedure to subtract a single datapoint from the data set. +# The normal equations for the data point are calculated +# and subtracted from MATRIX and VECTOR. After all rejected points +# have been subtracted from the fit CVSOLVE, must be called to generate +# a new set of coefficients. + +procedure dcvrject (cv, x, y, w) + +pointer cv # curve fitting image descriptor +double x # x value +double y # y value +double w # weight of the data point + +int left, i, ii, j +pointer xzptr +pointer mzptr, mzzptr +pointer vzptr +double bw + +begin + + # increment the number of points + CV_NPTS(cv) = CV_NPTS(cv) - 1 + + # calculate all type non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call dcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call dcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call dcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call dcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call dcv_b1user (cv, x) + } + + # index the pointers + xzptr = CV_XBASIS(cv) - 1 + mzptr = CV_MATRIX(cv) + CV_ORDER(cv) * (left - 1) + vzptr = CV_VECTOR(cv) + left - 1 + + # calculate the normal equations for the data point and subtract + # them from the fit + do i = 1, CV_ORDER(cv) { + + # subtract inner product of basis functions and data ordinate + # from the fit + bw = XBASIS(xzptr+i) * w + VECTOR(vzptr+i) = VECTOR(vzptr+i) - bw * y + + # subtract inner product of basis functions from the fit + ii = 0 + mzzptr = mzptr + i * CV_ORDER(cv) + do j = i, CV_ORDER(cv) { + MATRIX(mzzptr+ii) = MATRIX(mzzptr+ii) - XBASIS(xzptr+j) * bw + ii = ii + 1 + } + } +end diff --git a/math/curfit/cvrejectr.x b/math/curfit/cvrejectr.x new file mode 100644 index 00000000..3f275cce --- /dev/null +++ b/math/curfit/cvrejectr.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + +# CVREJECT -- Procedure to subtract a single datapoint from the data set. +# The normal equations for the data point are calculated +# and subtracted from MATRIX and VECTOR. After all rejected points +# have been subtracted from the fit CVSOLVE, must be called to generate +# a new set of coefficients. + +procedure cvrject (cv, x, y, w) + +pointer cv # curve fitting image descriptor +real x # x value +real y # y value +real w # weight of the data point + +int left, i, ii, j +pointer xzptr +pointer mzptr, mzzptr +pointer vzptr +real bw + +begin + + # increment the number of points + CV_NPTS(cv) = CV_NPTS(cv) - 1 + + # calculate all type non-zero basis functions for a given data point + switch (CV_TYPE(cv)) { + case CHEBYSHEV: + left = 0 + call rcv_b1cheb (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case LEGENDRE: + left = 0 + call rcv_b1leg (x, CV_ORDER(cv), CV_MAXMIN(cv), CV_RANGE(cv), + XBASIS(CV_XBASIS(cv))) + case SPLINE3: + call rcv_b1spline3 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case SPLINE1: + call rcv_b1spline1 (x, CV_NPIECES(cv), -CV_XMIN(cv), + CV_SPACING(cv), XBASIS(CV_XBASIS(cv)), left) + case USERFNC: + left = 0 + call rcv_b1user (cv, x) + } + + # index the pointers + xzptr = CV_XBASIS(cv) - 1 + mzptr = CV_MATRIX(cv) + CV_ORDER(cv) * (left - 1) + vzptr = CV_VECTOR(cv) + left - 1 + + # calculate the normal equations for the data point and subtract + # them from the fit + do i = 1, CV_ORDER(cv) { + + # subtract inner product of basis functions and data ordinate + # from the fit + bw = XBASIS(xzptr+i) * w + VECTOR(vzptr+i) = VECTOR(vzptr+i) - bw * y + + # subtract inner product of basis functions from the fit + ii = 0 + mzzptr = mzptr + i * CV_ORDER(cv) + do j = i, CV_ORDER(cv) { + MATRIX(mzzptr+ii) = MATRIX(mzzptr+ii) - XBASIS(xzptr+j) * bw + ii = ii + 1 + } + } +end diff --git a/math/curfit/cvrestore.gx b/math/curfit/cvrestore.gx new file mode 100644 index 00000000..cfec56d7 --- /dev/null +++ b/math/curfit/cvrestore.gx @@ -0,0 +1,100 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVRESTORE -- Procedure to restore fit parameters saved by CVSAVE +# for use by CVEVAL and CVVECTOR. The parameters are assumed to +# be stored in fit in the following order, curve_type, order, xmin, +# xmax, followed by the coefficients. + +$if (datatype == r) +procedure cvrestore (cv, fit) +$else +procedure dcvrestore (cv, fit) +$endif + +pointer cv # curve descriptor +PIXEL fit[ARB] # array containing fit parameters + +int curve_type, order + +errchk malloc + +begin + # allocate space for curve descriptor + call malloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + order = nint (CV_SAVEORDER(fit)) + if (order < 1) + call error (0, "CVRESTORE: Illegal order.") + + if (CV_SAVEXMAX(fit) <= CV_SAVEXMIN(fit)) + call error (0, "CVRESTORE: xmax <= xmin.") + + # set curve_type dependent curve descriptor parameters + curve_type = nint (CV_SAVETYPE(fit)) + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_MAXMIN(cv) = - (CV_SAVEXMAX(fit) + CV_SAVEXMIN(fit)) / 2. + CV_USERFNC(cv) = NULL + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = order + SPLINE3_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_USERFNC(cv) = NULL + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = order + SPLINE1_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_USERFNC(cv) = NULL + case USERFNC: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_MAXMIN(cv) = - (CV_SAVEXMAX(fit) + CV_SAVEXMIN(fit)) / 2. + $if (datatype == r) + CV_USERFNCR(cv) = CV_SAVEFNC(fit) # avoids type conversion + $else + CV_USERFNCD(cv) = CV_SAVEFNC(fit) # avoids type conversion + $endif + default: + call error (0, "CVRESTORE: Unknown curve type.") + } + + # set remaining curve parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = CV_SAVEXMIN(fit) + CV_XMAX(cv) = CV_SAVEXMAX(fit) + + # allocate space for xbasis and coefficient arrays, set remaining + # pointers to NULL + + call calloc (CV_XBASIS(cv), CV_ORDER(cv), TY_PIXEL) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_PIXEL) + + CV_MATRIX(cv) = NULL + CV_CHOFAC(cv) = NULL + CV_VECTOR(cv) = NULL + CV_BASIS(cv) = NULL + CV_LEFT(cv) = NULL + CV_WY(cv) = NULL + + # restore coefficients + if (CV_TYPE(cv) == USERFNC) + call amov$t (fit[CV_SAVECOEFF+1], COEFF(CV_COEFF(cv)), + CV_NCOEFF(cv)) + else + call amov$t (fit[CV_SAVECOEFF], COEFF(CV_COEFF(cv)), + CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvrestored.x b/math/curfit/cvrestored.x new file mode 100644 index 00000000..e528c1f0 --- /dev/null +++ b/math/curfit/cvrestored.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVRESTORE -- Procedure to restore fit parameters saved by CVSAVE +# for use by CVEVAL and CVVECTOR. The parameters are assumed to +# be stored in fit in the following order, curve_type, order, xmin, +# xmax, followed by the coefficients. + +procedure dcvrestore (cv, fit) + +pointer cv # curve descriptor +double fit[ARB] # array containing fit parameters + +int curve_type, order + +errchk malloc + +begin + # allocate space for curve descriptor + call malloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + order = nint (CV_SAVEORDER(fit)) + if (order < 1) + call error (0, "CVRESTORE: Illegal order.") + + if (CV_SAVEXMAX(fit) <= CV_SAVEXMIN(fit)) + call error (0, "CVRESTORE: xmax <= xmin.") + + # set curve_type dependent curve descriptor parameters + curve_type = nint (CV_SAVETYPE(fit)) + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_MAXMIN(cv) = - (CV_SAVEXMAX(fit) + CV_SAVEXMIN(fit)) / 2. + CV_USERFNC(cv) = NULL + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = order + SPLINE3_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_USERFNC(cv) = NULL + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = order + SPLINE1_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_USERFNC(cv) = NULL + case USERFNC: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_MAXMIN(cv) = - (CV_SAVEXMAX(fit) + CV_SAVEXMIN(fit)) / 2. + CV_USERFNCD(cv) = CV_SAVEFNC(fit) # avoids type conversion + default: + call error (0, "CVRESTORE: Unknown curve type.") + } + + # set remaining curve parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = CV_SAVEXMIN(fit) + CV_XMAX(cv) = CV_SAVEXMAX(fit) + + # allocate space for xbasis and coefficient arrays, set remaining + # pointers to NULL + + call calloc (CV_XBASIS(cv), CV_ORDER(cv), TY_DOUBLE) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_DOUBLE) + + CV_MATRIX(cv) = NULL + CV_CHOFAC(cv) = NULL + CV_VECTOR(cv) = NULL + CV_BASIS(cv) = NULL + CV_LEFT(cv) = NULL + CV_WY(cv) = NULL + + # restore coefficients + if (CV_TYPE(cv) == USERFNC) + call amovd (fit[CV_SAVECOEFF+1], COEFF(CV_COEFF(cv)), + CV_NCOEFF(cv)) + else + call amovd (fit[CV_SAVECOEFF], COEFF(CV_COEFF(cv)), + CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvrestorer.x b/math/curfit/cvrestorer.x new file mode 100644 index 00000000..859d434f --- /dev/null +++ b/math/curfit/cvrestorer.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + +# CVRESTORE -- Procedure to restore fit parameters saved by CVSAVE +# for use by CVEVAL and CVVECTOR. The parameters are assumed to +# be stored in fit in the following order, curve_type, order, xmin, +# xmax, followed by the coefficients. + +procedure cvrestore (cv, fit) + +pointer cv # curve descriptor +real fit[ARB] # array containing fit parameters + +int curve_type, order + +errchk malloc + +begin + # allocate space for curve descriptor + call malloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + order = nint (CV_SAVEORDER(fit)) + if (order < 1) + call error (0, "CVRESTORE: Illegal order.") + + if (CV_SAVEXMAX(fit) <= CV_SAVEXMIN(fit)) + call error (0, "CVRESTORE: xmax <= xmin.") + + # set curve_type dependent curve descriptor parameters + curve_type = nint (CV_SAVETYPE(fit)) + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_MAXMIN(cv) = - (CV_SAVEXMAX(fit) + CV_SAVEXMIN(fit)) / 2. + CV_USERFNC(cv) = NULL + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = order + SPLINE3_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_USERFNC(cv) = NULL + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = order + SPLINE1_ORDER - 1 + CV_NPIECES(cv) = order - 1 + CV_SPACING(cv) = order / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_USERFNC(cv) = NULL + case USERFNC: + CV_ORDER(cv) = order + CV_NCOEFF(cv) = order + CV_RANGE(cv) = 2. / (CV_SAVEXMAX(fit) - CV_SAVEXMIN(fit)) + CV_MAXMIN(cv) = - (CV_SAVEXMAX(fit) + CV_SAVEXMIN(fit)) / 2. + CV_USERFNCR(cv) = CV_SAVEFNC(fit) # avoids type conversion + default: + call error (0, "CVRESTORE: Unknown curve type.") + } + + # set remaining curve parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = CV_SAVEXMIN(fit) + CV_XMAX(cv) = CV_SAVEXMAX(fit) + + # allocate space for xbasis and coefficient arrays, set remaining + # pointers to NULL + + call calloc (CV_XBASIS(cv), CV_ORDER(cv), TY_REAL) + call calloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_REAL) + + CV_MATRIX(cv) = NULL + CV_CHOFAC(cv) = NULL + CV_VECTOR(cv) = NULL + CV_BASIS(cv) = NULL + CV_LEFT(cv) = NULL + CV_WY(cv) = NULL + + # restore coefficients + if (CV_TYPE(cv) == USERFNC) + call amovr (fit[CV_SAVECOEFF+1], COEFF(CV_COEFF(cv)), + CV_NCOEFF(cv)) + else + call amovr (fit[CV_SAVECOEFF], COEFF(CV_COEFF(cv)), + CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvsave.gx b/math/curfit/cvsave.gx new file mode 100644 index 00000000..95fedd2b --- /dev/null +++ b/math/curfit/cvsave.gx @@ -0,0 +1,56 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVSAVE -- Procedure to save the parameters of the fit for later +# use by cveval and cvvector. Only curve_type, order, xmin, xmax +# and the coefficients are saved. The parameters are saved in fit +# in the order curve_type, order, xmin, xmax, followed by the +# coefficients. + +$if (datatype == r) +procedure cvsave (cv, fit) +$else +procedure dcvsave (cv, fit) +$endif + +pointer cv # curve descriptor +PIXEL fit[ARB] # PIXEL array containing curve parameters + +begin + # set common curve parameters + CV_SAVETYPE(fit) = CV_TYPE(cv) + CV_SAVEXMIN(fit) = CV_XMIN(cv) + CV_SAVEXMAX(fit) = CV_XMAX(cv) + if (CV_TYPE(cv) == USERFNC) + $if (datatype == r) + CV_SAVEFNC(fit) = CV_USERFNCR(cv) # no type conversion + $else + CV_SAVEFNC(fit) = CV_USERFNCD(cv) + $endif + + # set curve-type dependent parmeters + switch (CV_TYPE(cv)) { + case LEGENDRE, CHEBYSHEV, USERFNC: + CV_SAVEORDER(fit) = CV_ORDER(cv) + case SPLINE1, SPLINE3: + CV_SAVEORDER(fit) = CV_NPIECES(cv) + 1 + default: + call error (0, "CVSAVE: Unknown curve type.") + } + + + # set coefficients + if (CV_TYPE(cv) == USERFNC) + call amov$t (COEFF(CV_COEFF(cv)), fit[CV_SAVECOEFF+1], + CV_NCOEFF(cv)) + else + call amov$t (COEFF(CV_COEFF(cv)), fit[CV_SAVECOEFF], + CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvsaved.x b/math/curfit/cvsaved.x new file mode 100644 index 00000000..04cb7c8b --- /dev/null +++ b/math/curfit/cvsaved.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVSAVE -- Procedure to save the parameters of the fit for later +# use by cveval and cvvector. Only curve_type, order, xmin, xmax +# and the coefficients are saved. The parameters are saved in fit +# in the order curve_type, order, xmin, xmax, followed by the +# coefficients. + +procedure dcvsave (cv, fit) + +pointer cv # curve descriptor +double fit[ARB] # PIXEL array containing curve parameters + +begin + # set common curve parameters + CV_SAVETYPE(fit) = CV_TYPE(cv) + CV_SAVEXMIN(fit) = CV_XMIN(cv) + CV_SAVEXMAX(fit) = CV_XMAX(cv) + if (CV_TYPE(cv) == USERFNC) + CV_SAVEFNC(fit) = CV_USERFNCD(cv) + + # set curve-type dependent parmeters + switch (CV_TYPE(cv)) { + case LEGENDRE, CHEBYSHEV, USERFNC: + CV_SAVEORDER(fit) = CV_ORDER(cv) + case SPLINE1, SPLINE3: + CV_SAVEORDER(fit) = CV_NPIECES(cv) + 1 + default: + call error (0, "CVSAVE: Unknown curve type.") + } + + + # set coefficients + if (CV_TYPE(cv) == USERFNC) + call amovd (COEFF(CV_COEFF(cv)), fit[CV_SAVECOEFF+1], + CV_NCOEFF(cv)) + else + call amovd (COEFF(CV_COEFF(cv)), fit[CV_SAVECOEFF], + CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvsaver.x b/math/curfit/cvsaver.x new file mode 100644 index 00000000..513083a5 --- /dev/null +++ b/math/curfit/cvsaver.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + +# CVSAVE -- Procedure to save the parameters of the fit for later +# use by cveval and cvvector. Only curve_type, order, xmin, xmax +# and the coefficients are saved. The parameters are saved in fit +# in the order curve_type, order, xmin, xmax, followed by the +# coefficients. + +procedure cvsave (cv, fit) + +pointer cv # curve descriptor +real fit[ARB] # PIXEL array containing curve parameters + +begin + # set common curve parameters + CV_SAVETYPE(fit) = CV_TYPE(cv) + CV_SAVEXMIN(fit) = CV_XMIN(cv) + CV_SAVEXMAX(fit) = CV_XMAX(cv) + if (CV_TYPE(cv) == USERFNC) + CV_SAVEFNC(fit) = CV_USERFNCR(cv) # no type conversion + + # set curve-type dependent parmeters + switch (CV_TYPE(cv)) { + case LEGENDRE, CHEBYSHEV, USERFNC: + CV_SAVEORDER(fit) = CV_ORDER(cv) + case SPLINE1, SPLINE3: + CV_SAVEORDER(fit) = CV_NPIECES(cv) + 1 + default: + call error (0, "CVSAVE: Unknown curve type.") + } + + + # set coefficients + if (CV_TYPE(cv) == USERFNC) + call amovr (COEFF(CV_COEFF(cv)), fit[CV_SAVECOEFF+1], + CV_NCOEFF(cv)) + else + call amovr (COEFF(CV_COEFF(cv)), fit[CV_SAVECOEFF], + CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvset.gx b/math/curfit/cvset.gx new file mode 100644 index 00000000..fed1cf46 --- /dev/null +++ b/math/curfit/cvset.gx @@ -0,0 +1,98 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVSET -- Procedure to store the fit parameters derived from outside +# the CURFIT package inside the curve descriptor structure for use +# by the CVEVAL and CVVECTOR proocedures. The curve_type is one of +# LEGENDRE, CHEBYSHEV or SPLINE3. For the polynomials the number of +# coefficients is equal to one plus the order of the polynomial. In the +# case of the cubic spline the number of coefficients equals three plus +# the number of polynomial pieces. The polynomials are normalized over +# from xmin to xmax. + +$if (datatype == r) +procedure cvset (cv, curve_type, xmin, xmax, coeff, ncoeff) +$else +procedure dcvset (cv, curve_type, xmin, xmax, coeff, ncoeff) +$endif + +pointer cv # curve descriptor +int curve_type # the functional form of the curve +PIXEL xmin # the minimum x value +PIXEL xmax # the maximum x value +PIXEL coeff[ncoeff] # the coefficient array +int ncoeff # the number of coefficients + +errchk malloc + +begin + # allocate space for curve descriptor + call malloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + if (ncoeff < 1) + call error (0, "CVSET: Illegal number of coefficients.") + + if (xmin >= xmax) + call error (0, "CVSET: xmax <= xmin.") + + # set curve_type dependent curve descriptor parameters + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = ncoeff + CV_NCOEFF(cv) = ncoeff + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = ncoeff + CV_NPIECES(cv) = ncoeff - SPLINE3_ORDER + CV_SPACING(cv) = (CV_NPIECES(cv) + 1) / (xmax - xmin) + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = ncoeff + CV_NPIECES(cv) = ncoeff - SPLINE1_ORDER + CV_SPACING(cv) = (CV_NPIECES(cv) + 1) / (xmax - xmin) + case USERFNC: + CV_ORDER(cv) = ncoeff + CV_NCOEFF(cv) = ncoeff + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + default: + call error (0, "CVSET: Unknown curve type.") + } + + # set remaining curve parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for xbasis and coefficient arrays, set remaining + # pointers to NULL + + $if (datatype == r) + call malloc (CV_XBASIS(cv), CV_ORDER(cv), TY_REAL) + call malloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_REAL) + $else + call malloc (CV_XBASIS(cv), CV_ORDER(cv), TY_DOUBLE) + call malloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_DOUBLE) + $endif + + CV_MATRIX(cv) = NULL + CV_CHOFAC(cv) = NULL + CV_VECTOR(cv) = NULL + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + CV_LEFT(cv) = NULL + + CV_USERFNC(cv) = NULL + + # restore coefficients + call amov$t (coeff, COEFF(CV_COEFF(cv)), CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvsetd.x b/math/curfit/cvsetd.x new file mode 100644 index 00000000..c0f41f09 --- /dev/null +++ b/math/curfit/cvsetd.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVSET -- Procedure to store the fit parameters derived from outside +# the CURFIT package inside the curve descriptor structure for use +# by the CVEVAL and CVVECTOR proocedures. The curve_type is one of +# LEGENDRE, CHEBYSHEV or SPLINE3. For the polynomials the number of +# coefficients is equal to one plus the order of the polynomial. In the +# case of the cubic spline the number of coefficients equals three plus +# the number of polynomial pieces. The polynomials are normalized over +# from xmin to xmax. + +procedure dcvset (cv, curve_type, xmin, xmax, coeff, ncoeff) + +pointer cv # curve descriptor +int curve_type # the functional form of the curve +double xmin # the minimum x value +double xmax # the maximum x value +double coeff[ncoeff] # the coefficient array +int ncoeff # the number of coefficients + +errchk malloc + +begin + # allocate space for curve descriptor + call malloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + if (ncoeff < 1) + call error (0, "CVSET: Illegal number of coefficients.") + + if (xmin >= xmax) + call error (0, "CVSET: xmax <= xmin.") + + # set curve_type dependent curve descriptor parameters + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = ncoeff + CV_NCOEFF(cv) = ncoeff + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = ncoeff + CV_NPIECES(cv) = ncoeff - SPLINE3_ORDER + CV_SPACING(cv) = (CV_NPIECES(cv) + 1) / (xmax - xmin) + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = ncoeff + CV_NPIECES(cv) = ncoeff - SPLINE1_ORDER + CV_SPACING(cv) = (CV_NPIECES(cv) + 1) / (xmax - xmin) + case USERFNC: + CV_ORDER(cv) = ncoeff + CV_NCOEFF(cv) = ncoeff + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + default: + call error (0, "CVSET: Unknown curve type.") + } + + # set remaining curve parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for xbasis and coefficient arrays, set remaining + # pointers to NULL + + call malloc (CV_XBASIS(cv), CV_ORDER(cv), TY_DOUBLE) + call malloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_DOUBLE) + + CV_MATRIX(cv) = NULL + CV_CHOFAC(cv) = NULL + CV_VECTOR(cv) = NULL + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + CV_LEFT(cv) = NULL + + CV_USERFNC(cv) = NULL + + # restore coefficients + call amovd (coeff, COEFF(CV_COEFF(cv)), CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvsetr.x b/math/curfit/cvsetr.x new file mode 100644 index 00000000..9a3ec193 --- /dev/null +++ b/math/curfit/cvsetr.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + +# CVSET -- Procedure to store the fit parameters derived from outside +# the CURFIT package inside the curve descriptor structure for use +# by the CVEVAL and CVVECTOR proocedures. The curve_type is one of +# LEGENDRE, CHEBYSHEV or SPLINE3. For the polynomials the number of +# coefficients is equal to one plus the order of the polynomial. In the +# case of the cubic spline the number of coefficients equals three plus +# the number of polynomial pieces. The polynomials are normalized over +# from xmin to xmax. + +procedure cvset (cv, curve_type, xmin, xmax, coeff, ncoeff) + +pointer cv # curve descriptor +int curve_type # the functional form of the curve +real xmin # the minimum x value +real xmax # the maximum x value +real coeff[ncoeff] # the coefficient array +int ncoeff # the number of coefficients + +errchk malloc + +begin + # allocate space for curve descriptor + call malloc (cv, LEN_CVSTRUCT, TY_STRUCT) + + if (ncoeff < 1) + call error (0, "CVSET: Illegal number of coefficients.") + + if (xmin >= xmax) + call error (0, "CVSET: xmax <= xmin.") + + # set curve_type dependent curve descriptor parameters + switch (curve_type) { + case CHEBYSHEV, LEGENDRE: + CV_ORDER(cv) = ncoeff + CV_NCOEFF(cv) = ncoeff + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + case SPLINE3: + CV_ORDER(cv) = SPLINE3_ORDER + CV_NCOEFF(cv) = ncoeff + CV_NPIECES(cv) = ncoeff - SPLINE3_ORDER + CV_SPACING(cv) = (CV_NPIECES(cv) + 1) / (xmax - xmin) + case SPLINE1: + CV_ORDER(cv) = SPLINE1_ORDER + CV_NCOEFF(cv) = ncoeff + CV_NPIECES(cv) = ncoeff - SPLINE1_ORDER + CV_SPACING(cv) = (CV_NPIECES(cv) + 1) / (xmax - xmin) + case USERFNC: + CV_ORDER(cv) = ncoeff + CV_NCOEFF(cv) = ncoeff + CV_RANGE(cv) = 2. / (xmax - xmin) + CV_MAXMIN(cv) = - (xmax + xmin) / 2. + default: + call error (0, "CVSET: Unknown curve type.") + } + + # set remaining curve parameters + CV_TYPE(cv) = curve_type + CV_XMIN(cv) = xmin + CV_XMAX(cv) = xmax + + # allocate space for xbasis and coefficient arrays, set remaining + # pointers to NULL + + call malloc (CV_XBASIS(cv), CV_ORDER(cv), TY_REAL) + call malloc (CV_COEFF(cv), CV_NCOEFF(cv), TY_REAL) + + CV_MATRIX(cv) = NULL + CV_CHOFAC(cv) = NULL + CV_VECTOR(cv) = NULL + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + CV_LEFT(cv) = NULL + + CV_USERFNC(cv) = NULL + + # restore coefficients + call amovr (coeff, COEFF(CV_COEFF(cv)), CV_NCOEFF(cv)) +end diff --git a/math/curfit/cvsolve.gx b/math/curfit/cvsolve.gx new file mode 100644 index 00000000..08e0bf92 --- /dev/null +++ b/math/curfit/cvsolve.gx @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + + +# CVSOLVE -- Solve the matrix normal equations of the form ca = b for a, +# where c is a symmetric, positive semi-definite, banded matrix with +# CV_NCOEFF(cv) rows and a and b are CV_NCOEFF(cv)-vectors. +# Initially c is stored in the CV_ORDER(cv) by CV_NCOEFF(cv) 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. + +$if (datatype == r) +procedure cvsolve (cv, ier) +$else +procedure dcvsolve (cv, ier) +$endif + + +pointer cv # 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 nfree + +begin + ier = OK + nfree = CV_NPTS(cv) - CV_NCOEFF(cv) + + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the Cholesky factorization of the data matrix + call $tcvchofac (MATRIX(CV_MATRIX(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + CHOFAC(CV_CHOFAC(cv)), ier) + + # solve for the coefficients by forward and back substitution + call $tcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end diff --git a/math/curfit/cvsolved.x b/math/curfit/cvsolved.x new file mode 100644 index 00000000..ba61be19 --- /dev/null +++ b/math/curfit/cvsolved.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + + +# CVSOLVE -- Solve the matrix normal equations of the form ca = b for a, +# where c is a symmetric, positive semi-definite, banded matrix with +# CV_NCOEFF(cv) rows and a and b are CV_NCOEFF(cv)-vectors. +# Initially c is stored in the CV_ORDER(cv) by CV_NCOEFF(cv) 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. + +procedure dcvsolve (cv, ier) + + +pointer cv # 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 nfree + +begin + ier = OK + nfree = CV_NPTS(cv) - CV_NCOEFF(cv) + + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the Cholesky factorization of the data matrix + call dcvchofac (MATRIX(CV_MATRIX(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + CHOFAC(CV_CHOFAC(cv)), ier) + + # solve for the coefficients by forward and back substitution + call dcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end diff --git a/math/curfit/cvsolver.x b/math/curfit/cvsolver.x new file mode 100644 index 00000000..b52f012e --- /dev/null +++ b/math/curfit/cvsolver.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + + +# CVSOLVE -- Solve the matrix normal equations of the form ca = b for a, +# where c is a symmetric, positive semi-definite, banded matrix with +# CV_NCOEFF(cv) rows and a and b are CV_NCOEFF(cv)-vectors. +# Initially c is stored in the CV_ORDER(cv) by CV_NCOEFF(cv) 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. + +procedure cvsolve (cv, ier) + + +pointer cv # 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 nfree + +begin + ier = OK + nfree = CV_NPTS(cv) - CV_NCOEFF(cv) + + if (nfree < 0) { + ier = NO_DEG_FREEDOM + return + } + + # calculate the Cholesky factorization of the data matrix + call rcvchofac (MATRIX(CV_MATRIX(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + CHOFAC(CV_CHOFAC(cv)), ier) + + # solve for the coefficients by forward and back substitution + call rcvchoslv (CHOFAC(CV_CHOFAC(cv)), CV_ORDER(cv), CV_NCOEFF(cv), + VECTOR(CV_VECTOR(cv)), COEFF(CV_COEFF(cv))) +end diff --git a/math/curfit/cvstat.gx b/math/curfit/cvstat.gx new file mode 100644 index 00000000..e98367b9 --- /dev/null +++ b/math/curfit/cvstat.gx @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVSTATI -- Return integer paramters from the curfit package + +$if (datatype == r) +int procedure cvstati (cv, param) +$else +int procedure dcvstati (cv, param) +$endif + +pointer cv # Curfit pointer +int param # Parameter + +begin + switch (param) { + case CVTYPE: + return (CV_TYPE(cv)) + case CVORDER: + switch (CV_TYPE(cv)) { + case LEGENDRE, CHEBYSHEV, USERFNC: + return (CV_ORDER(cv)) + case SPLINE1, SPLINE3: + return (CV_NPIECES(cv) + 1) + } + case CVNSAVE: + if (CV_TYPE(cv) == USERFNC) + return (CV_SAVECOEFF + CV_NCOEFF(cv)) + else + return (CV_SAVECOEFF + CV_NCOEFF(cv) - 1) + case CVNCOEFF: + return (CV_NCOEFF(cv)) + } +end + +# CVSTATR -- Return real paramters from the curfit package + +$if (datatype == r) +PIXEL procedure cvstatr (cv, param) +$else +PIXEL procedure dcvstatd (cv, param) +$endif + +pointer cv # Curfit pointer +int param # Parameter + +begin + switch (param) { + case CVXMIN: + return (CV_XMIN(cv)) + case CVXMAX: + return (CV_XMAX(cv)) + } +end diff --git a/math/curfit/cvstatd.x b/math/curfit/cvstatd.x new file mode 100644 index 00000000..fae7c87e --- /dev/null +++ b/math/curfit/cvstatd.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVSTATI -- Return integer paramters from the curfit package + +int procedure dcvstati (cv, param) + +pointer cv # Curfit pointer +int param # Parameter + +begin + switch (param) { + case CVTYPE: + return (CV_TYPE(cv)) + case CVORDER: + switch (CV_TYPE(cv)) { + case LEGENDRE, CHEBYSHEV, USERFNC: + return (CV_ORDER(cv)) + case SPLINE1, SPLINE3: + return (CV_NPIECES(cv) + 1) + } + case CVNSAVE: + if (CV_TYPE(cv) == USERFNC) + return (CV_SAVECOEFF + CV_NCOEFF(cv)) + else + return (CV_SAVECOEFF + CV_NCOEFF(cv) - 1) + case CVNCOEFF: + return (CV_NCOEFF(cv)) + } +end + +# CVSTATR -- Return real paramters from the curfit package + +double procedure dcvstatd (cv, param) + +pointer cv # Curfit pointer +int param # Parameter + +begin + switch (param) { + case CVXMIN: + return (CV_XMIN(cv)) + case CVXMAX: + return (CV_XMAX(cv)) + } +end diff --git a/math/curfit/cvstatr.x b/math/curfit/cvstatr.x new file mode 100644 index 00000000..ee5ef05b --- /dev/null +++ b/math/curfit/cvstatr.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + +# CVSTATI -- Return integer paramters from the curfit package + +int procedure cvstati (cv, param) + +pointer cv # Curfit pointer +int param # Parameter + +begin + switch (param) { + case CVTYPE: + return (CV_TYPE(cv)) + case CVORDER: + switch (CV_TYPE(cv)) { + case LEGENDRE, CHEBYSHEV, USERFNC: + return (CV_ORDER(cv)) + case SPLINE1, SPLINE3: + return (CV_NPIECES(cv) + 1) + } + case CVNSAVE: + if (CV_TYPE(cv) == USERFNC) + return (CV_SAVECOEFF + CV_NCOEFF(cv)) + else + return (CV_SAVECOEFF + CV_NCOEFF(cv) - 1) + case CVNCOEFF: + return (CV_NCOEFF(cv)) + } +end + +# CVSTATR -- Return real paramters from the curfit package + +real procedure cvstatr (cv, param) + +pointer cv # Curfit pointer +int param # Parameter + +begin + switch (param) { + case CVXMIN: + return (CV_XMIN(cv)) + case CVXMAX: + return (CV_XMAX(cv)) + } +end diff --git a/math/curfit/cvvector.gx b/math/curfit/cvvector.gx new file mode 100644 index 00000000..eb005a1a --- /dev/null +++ b/math/curfit/cvvector.gx @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVVECTOR -- Procedure to evaluate a curve. The CV_NCOEFF(cv) coefficients +# are assumed to be in COEFF. + +$if (datatype == r) +procedure cvvector (cv, x, yfit, npts) +$else +procedure dcvvector (cv, x, yfit, npts) +$endif + +pointer cv # curve descriptor +PIXEL x[npts] # data x values +PIXEL yfit[npts] # the fitted y values +int npts # number of data points + +begin + switch (CV_TYPE(cv)) { + case LEGENDRE: + call $tcv_evleg (COEFF(CV_COEFF(cv)), x, yfit, npts, CV_ORDER(cv), + CV_MAXMIN(cv), CV_RANGE(cv)) + case CHEBYSHEV: + call $tcv_evcheb (COEFF(CV_COEFF(cv)), x, yfit, npts, CV_ORDER(cv), + CV_MAXMIN(cv), CV_RANGE(cv)) + case SPLINE3: + call $tcv_evspline3 (COEFF(CV_COEFF(cv)), x, yfit, npts, + CV_NPIECES(cv), -CV_XMIN(cv), CV_SPACING(cv)) + case SPLINE1: + call $tcv_evspline1 (COEFF(CV_COEFF(cv)), x, yfit, npts, + CV_NPIECES(cv), -CV_XMIN(cv), CV_SPACING(cv)) + case USERFNC: + call $tcv_evuser (cv, x, yfit, npts) + } +end diff --git a/math/curfit/cvvectord.x b/math/curfit/cvvectord.x new file mode 100644 index 00000000..f23e988e --- /dev/null +++ b/math/curfit/cvvectord.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "dcurfitdef.h" + +# CVVECTOR -- Procedure to evaluate a curve. The CV_NCOEFF(cv) coefficients +# are assumed to be in COEFF. + +procedure dcvvector (cv, x, yfit, npts) + +pointer cv # curve descriptor +double x[npts] # data x values +double yfit[npts] # the fitted y values +int npts # number of data points + +begin + switch (CV_TYPE(cv)) { + case LEGENDRE: + call dcv_evleg (COEFF(CV_COEFF(cv)), x, yfit, npts, CV_ORDER(cv), + CV_MAXMIN(cv), CV_RANGE(cv)) + case CHEBYSHEV: + call dcv_evcheb (COEFF(CV_COEFF(cv)), x, yfit, npts, CV_ORDER(cv), + CV_MAXMIN(cv), CV_RANGE(cv)) + case SPLINE3: + call dcv_evspline3 (COEFF(CV_COEFF(cv)), x, yfit, npts, + CV_NPIECES(cv), -CV_XMIN(cv), CV_SPACING(cv)) + case SPLINE1: + call dcv_evspline1 (COEFF(CV_COEFF(cv)), x, yfit, npts, + CV_NPIECES(cv), -CV_XMIN(cv), CV_SPACING(cv)) + case USERFNC: + call dcv_evuser (cv, x, yfit, npts) + } +end diff --git a/math/curfit/cvvectorr.x b/math/curfit/cvvectorr.x new file mode 100644 index 00000000..b344ab84 --- /dev/null +++ b/math/curfit/cvvectorr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math/curfit.h> + +include "curfitdef.h" + +# CVVECTOR -- Procedure to evaluate a curve. The CV_NCOEFF(cv) coefficients +# are assumed to be in COEFF. + +procedure cvvector (cv, x, yfit, npts) + +pointer cv # curve descriptor +real x[npts] # data x values +real yfit[npts] # the fitted y values +int npts # number of data points + +begin + switch (CV_TYPE(cv)) { + case LEGENDRE: + call rcv_evleg (COEFF(CV_COEFF(cv)), x, yfit, npts, CV_ORDER(cv), + CV_MAXMIN(cv), CV_RANGE(cv)) + case CHEBYSHEV: + call rcv_evcheb (COEFF(CV_COEFF(cv)), x, yfit, npts, CV_ORDER(cv), + CV_MAXMIN(cv), CV_RANGE(cv)) + case SPLINE3: + call rcv_evspline3 (COEFF(CV_COEFF(cv)), x, yfit, npts, + CV_NPIECES(cv), -CV_XMIN(cv), CV_SPACING(cv)) + case SPLINE1: + call rcv_evspline1 (COEFF(CV_COEFF(cv)), x, yfit, npts, + CV_NPIECES(cv), -CV_XMIN(cv), CV_SPACING(cv)) + case USERFNC: + call rcv_evuser (cv, x, yfit, npts) + } +end diff --git a/math/curfit/cvzero.gx b/math/curfit/cvzero.gx new file mode 100644 index 00000000..c6774758 --- /dev/null +++ b/math/curfit/cvzero.gx @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +$if (datatype == r) +include "curfitdef.h" +$else +include "dcurfitdef.h" +$endif + +# CVZERO -- Procedure to zero the accumulators before doing +# a new fit in accumulate mode. The inner products of the basis functions +# are accumulated in the CV_ORDER(cv) by CV_NCOEFF(cv) array MATRIX, while +# the inner products of the basis functions and the data ordinates are +# accumulated in the CV_NCOEFF(cv)-vector VECTOR. + +$if (datatype == r) +procedure cvzero (cv) +$else +procedure dcvzero (cv) +$endif + +pointer cv # pointer to curve descriptor + +errchk mfree + +begin + # zero the accumulators + CV_NPTS(cv) = 0 + call aclr$t (MATRIX(CV_MATRIX(cv)), CV_ORDER(cv)*CV_NCOEFF(cv)) + call aclr$t (VECTOR(CV_VECTOR(cv)), CV_NCOEFF(cv)) + + # free the basis functions defined from previous calls to cvrefit + if (CV_BASIS(cv) != NULL) { + $if (datatype == r) + call mfree (CV_BASIS(cv), TY_REAL) + call mfree (CV_WY(cv), TY_REAL) + $else + call mfree (CV_BASIS(cv), TY_DOUBLE) + call mfree (CV_WY(cv), TY_DOUBLE) + $endif + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + if (CV_LEFT(cv) != NULL) { + call mfree (CV_LEFT(cv), TY_INT) + CV_LEFT(cv) = NULL + } + } +end diff --git a/math/curfit/cvzerod.x b/math/curfit/cvzerod.x new file mode 100644 index 00000000..f9395fc1 --- /dev/null +++ b/math/curfit/cvzerod.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "dcurfitdef.h" + +# CVZERO -- Procedure to zero the accumulators before doing +# a new fit in accumulate mode. The inner products of the basis functions +# are accumulated in the CV_ORDER(cv) by CV_NCOEFF(cv) array MATRIX, while +# the inner products of the basis functions and the data ordinates are +# accumulated in the CV_NCOEFF(cv)-vector VECTOR. + +procedure dcvzero (cv) + +pointer cv # pointer to curve descriptor + +errchk mfree + +begin + # zero the accumulators + CV_NPTS(cv) = 0 + call aclrd (MATRIX(CV_MATRIX(cv)), CV_ORDER(cv)*CV_NCOEFF(cv)) + call aclrd (VECTOR(CV_VECTOR(cv)), CV_NCOEFF(cv)) + + # free the basis functions defined from previous calls to cvrefit + if (CV_BASIS(cv) != NULL) { + call mfree (CV_BASIS(cv), TY_DOUBLE) + call mfree (CV_WY(cv), TY_DOUBLE) + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + if (CV_LEFT(cv) != NULL) { + call mfree (CV_LEFT(cv), TY_INT) + CV_LEFT(cv) = NULL + } + } +end diff --git a/math/curfit/cvzeror.x b/math/curfit/cvzeror.x new file mode 100644 index 00000000..bd84029f --- /dev/null +++ b/math/curfit/cvzeror.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "curfitdef.h" + +# CVZERO -- Procedure to zero the accumulators before doing +# a new fit in accumulate mode. The inner products of the basis functions +# are accumulated in the CV_ORDER(cv) by CV_NCOEFF(cv) array MATRIX, while +# the inner products of the basis functions and the data ordinates are +# accumulated in the CV_NCOEFF(cv)-vector VECTOR. + +procedure cvzero (cv) + +pointer cv # pointer to curve descriptor + +errchk mfree + +begin + # zero the accumulators + CV_NPTS(cv) = 0 + call aclrr (MATRIX(CV_MATRIX(cv)), CV_ORDER(cv)*CV_NCOEFF(cv)) + call aclrr (VECTOR(CV_VECTOR(cv)), CV_NCOEFF(cv)) + + # free the basis functions defined from previous calls to cvrefit + if (CV_BASIS(cv) != NULL) { + call mfree (CV_BASIS(cv), TY_REAL) + call mfree (CV_WY(cv), TY_REAL) + CV_BASIS(cv) = NULL + CV_WY(cv) = NULL + if (CV_LEFT(cv) != NULL) { + call mfree (CV_LEFT(cv), TY_INT) + CV_LEFT(cv) = NULL + } + } +end diff --git a/math/curfit/dcurfitdef.h b/math/curfit/dcurfitdef.h new file mode 100644 index 00000000..ab611450 --- /dev/null +++ b/math/curfit/dcurfitdef.h @@ -0,0 +1,54 @@ +# Header file for the curve fitting package + +# set up the curve descriptor structure + +define LEN_CVSTRUCT 30 + +define CV_XMAX Memd[P2D($1)] # Maximum x value +define CV_XMIN Memd[P2D($1+2)] # Minimum x value +define CV_RANGE Memd[P2D($1+4)] # 2. / (xmax - xmin), polynomials +define CV_MAXMIN Memd[P2D($1+6)] # - (xmax + xmin) / 2., polynomials +define CV_SPACING Memd[P2D($1+8)] # order / (xmax - xmin), splines +define CV_USERFNCD Memd[P2D($1+10)]# Real version of above for cvrestore. +define CV_TYPE Memi[$1+12] # Type of curve to be fitted +define CV_ORDER Memi[$1+13] # Order of the fit +define CV_NPIECES Memi[$1+14] # Number of polynomial pieces - 1 +define CV_NCOEFF Memi[$1+15] # Number of coefficients +define CV_NPTS Memi[$1+16] # Number of data points + +define CV_XBASIS Memi[$1+17] # Pointer to non zero basis for single x +define CV_MATRIX Memi[$1+18] # Pointer to original matrix +define CV_CHOFAC Memi[$1+19] # Pointer to Cholesky factorization +define CV_VECTOR Memi[$1+20] # Pointer to vector +define CV_COEFF Memi[$1+21] # Pointer to coefficient vector +define CV_BASIS Memi[$1+22] # Pointer to basis functions (all x) +define CV_LEFT Memi[$1+23] # Pointer to first non-zero basis +define CV_WY Memi[$1+24] # Pointer to y * w (cvrefit) +define CV_USERFNC Memi[$1+25] # Pointer to external user subroutine + # one free slot left + +# matrix and vector element definitions + +define XBASIS Memd[$1] # Non zero basis for single x +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 +define BASIS Memd[$1] # Element of BASIS +define LEFT Memi[$1] # Element of LEFT + +# structure definitions for restore + +define CV_SAVETYPE $1[1] +define CV_SAVEORDER $1[2] +define CV_SAVEXMIN $1[3] +define CV_SAVEXMAX $1[4] +define CV_SAVEFNC $1[5] + +define CV_SAVECOEFF 5 + +# miscellaneous + +define SPLINE3_ORDER 4 +define SPLINE1_ORDER 2 +define DELTA EPSILON diff --git a/math/curfit/doc/curfit.hd b/math/curfit/doc/curfit.hd new file mode 100644 index 00000000..b8a00640 --- /dev/null +++ b/math/curfit/doc/curfit.hd @@ -0,0 +1,24 @@ +# Help directory for the CURFIT (curve fitting) package. + +$curfit = "math$curfit/" + +cvaccum hlp = cvaccum.hlp, src = curfit$cvaccum.gx +cvacpts hlp = cvacpts.hlp, src = curfit$cvacpts.gx +cvcoeff hlp = cvcoeff.hlp, src = curfit$cvcoeff.gx +cvepower hlp = cvepower.hlp, src = curfit$cvepower.gx +cverrors hlp = cverrors.hlp, src = curfit$cverrors.gx +cveval hlp = cveval.hlp, src = curfit$cveval.gx +cvinit hlp = cvinit.hlp, src = curfit$cvinit.gx +cvfit hlp = cvfit.hlp, src = curfit$cvfit.gx +cvfree hlp = cvfree.hlp, src = curfit$cvfree.gx +cvpower hlp = cvpower.hlp, src = curfit$cvpower.gx +cvrefit hlp = cvrefit.hlp, src = curfit$cvrefit.gx +cvreject hlp = cvreject.hlp, src = curfit$cvreject.gx +cvrestore hlp = cvrestore.hlp, src = curfit$cvrestore.gx +cvsave hlp = cvsave.hlp, src = curfit$cvsave.gx +cvsolve hlp = cvsolve.hlp, src = curfit$cvsolve.gx +cvstati hlp = cvstati.hlp, src = curfit$cvstat.gx +cvstatr hlp = cvstatr.hlp, src = curfit$cvstat.gx +cvvector hlp = cvvector.hlp, src = curfit$cvvector.gx +cvzero hlp = cvzero.hlp, src = curfit$cvzero.gx +cvset hlp = cvset.hlp, src = curfit$cvset.gx diff --git a/math/curfit/doc/curfit.hlp b/math/curfit/doc/curfit.hlp new file mode 100644 index 00000000..35950c08 --- /dev/null +++ b/math/curfit/doc/curfit.hlp @@ -0,0 +1,163 @@ +.help curfit Jul84 "Math Package" +.ih +NAME +curfit -- curve fitting package +.ih +SYNOPSIS + +.nf + cvinit (cv, curve_type, order, xmin, xmax) + cvzero (cv) + cvaccum (cv, x, y, weight, wtflag) + cvreject (cv, x, y, weight) + cvsolve (cv, ier) + cvfit (cv, x, y, weight, npts, wtflag, ier) + cvrefit (cv, x, y, weight, ier) + y = cveval (cv, x) + cvvector (cv, x, yfit, npts) + cvcoeff (cv, coeff, ncoeff) + cverrors (cv, y, weight, yfit, rms, errors) + cvsave (cv, fit) + cvstati (cv, parameter, ival) + cvstatr (cv, parameter, ival) + cvrestore (cv, fit) + cvset (cv, curve_type, xmin, xmax, coeff, ncoeff) + cvfree (cv) +.fi +.ih +DESCRIPTION +The curfit package provides a set of routines for fitting data to functions +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 curve_type is chosen at run time from the following +list. + +.nf + LEGENDRE # Legendre polynomials + CHEBYSHEV # Chebyshev polynomials + SPLINE3 # cubic spline with uniformly spaced break points + SPLINE1 # linear spline with uniformly spaced break points +.fi + + +The CURFIT package performs a weighted fit. +The weighting options are WTS_USR, WTS_UNIFORM and WTS_SPACING. +The user must supply a weight array. In WTS_UNIFORM mode the curfit +routines set the weights to 1. In WTS_USER mode the user must supply an +array of weight values. +In WTS_SPACING mode +the weights are set to the difference between adjacent data points. +The data must be sorted in x in order to use the WTS_SPACING mode. +In WTS_UNIFORM mode the reduced chi-squared returned by CVERRORS +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-squared is returned. + +The routines assume that all the x values of interest lie in the region +xmin <= x <= xmax. Checking for out of bounds x values is the responsibility +of the calling program. The package routines assume that INDEF values +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 <curfit.h> statement must be included in the user program. +CVINIT must be called before each fit. CVFREE frees space used by the +CURFIT package. +.ih +EXAMPLES +.nf +Example 1: Fit curve to data, unifrom weighting + + include <math/curfit.h> + + ... + + call cvinit (cv, CHEBYSHEV, 4, 1., 512.) + + call cvfit (cv, x, y, weight, 512, WTS_UNIFORM, ier) + if (ier != OK) + call error (...) + + do i = 1, 512 { + x = i + call printf ("%g %g\n") + call pargr (x) + call pargr (cveval (cv, x)) + } + + call cvfree (cv) + + +Example 2: Fit curve using accumulate mode, weight based on spacing + + include <math/curfit.h> + + ... + + old_x = x + do i = 1, 512 { + x = real (i) + if (y[i] != INDEF) { + call cvaccum (cv, x, y, weight, x - old_x, WTS_USER) + old_x = x + } + } + + call cvsolve (cv, ier) + if (ier != OK) + call error (...) + + ... + + call cvfree (cv) + + +Example 3: Fit and subtract smooth curve from image lines + + include <math/curfit.h> + + ... + + call cvinit (cv, CHEBYSHEV, order, 1., 512.) + + do line = 1, nlines { + inpix = imgl2r (im, line) + outpix = impl2r (im, line) + if (line == 1) + call cvfit (cv, x, Memr[inpix], weight, 512, WTS_UNIFORM, ier) + else + call cvrefit (cv, x, Memr[inpix], weight, ier) + if (ier != OK) + ... + call cvvector (cv, x, y, 512) + call asubr (Memr[inpix], y, Memr[outpix], 512) + } + + call cvfree (cv) + + +Example 4: Fit curve, save fit for later use by CVEVAL. LEN_FIT must be a least + order + 7 elements long. + + include <math/curfit.h> + + real fit[LEN_FIT] + + ... + call cvinit (cv, CHEBYSHEV, order, xmin, xmax) + call cvfit (cv, x, y, w, npts, WTS_UNIFORM, ier) + if (ier != OK) + ... + call cvsave (cv, fit) + call cvfree (cv) + ... + call cvrestore (cv, fit) + do i = 1, npts + yfit[i] = cveval (cv, x[i]) + call cvfree (cv) + ... +.fi diff --git a/math/curfit/doc/curfit.men b/math/curfit/doc/curfit.men new file mode 100644 index 00000000..b061badc --- /dev/null +++ b/math/curfit/doc/curfit.men @@ -0,0 +1,20 @@ + cvaccum - Accumulate point into data set + cvacpts - Accumulate points into a data set + cvcoeff - Get coefficients + cvepower - Convert errors to power series equivalents + cverrors - Calculate chi-squared and errors in coefficients + cveval - Evaluate curve at x + cvfit - Fit curve + cvfree - Free space allocated by cvinit + cvinit - Make ready to fit a curve; set up parameters of fit + cvpower - Convert coefficients to power series coefficients + cvrefit - Refit curve, same x and weight, different y + cvreject - Reject point from data set + cvrestore - Restore curve parameters and coefficients + cvsave - Save curve parameters and coefficients + cvset - Input coefficients derived external to the CURFIT package + cvsolve - Solve matrix for coefficients + cvstati - Get integer parameter + cvstatr - Get real parameter + cvvector - Evaluate curve at an array of x + cvzero - Zero arrays for new fit diff --git a/math/curfit/doc/curfit.spc b/math/curfit/doc/curfit.spc new file mode 100644 index 00000000..f5e555a3 --- /dev/null +++ b/math/curfit/doc/curfit.spc @@ -0,0 +1,479 @@ +.help curfit May84 "Math Package" +.ce +Specifications for the Curfit Package +.ce +Lindsey Davis +.ce +July 1984 + +.sh +1. Introduction + +The CURFIT package provides a set of routines for fitting data to +functions linear in their coefficients using least +squares techniques. The basic numerical technique employed +is the solution of the normal equations by the Cholesky method. +This document presents the formal requirements for the package +and describes the algorithms used. + +.sh +2. Requirements + +.ls 4 +.ls (1) +The package shall take as input a set of x and y values and their +corresponding weights. The package routines asssume that data values +equal to INDEF have been rejected from the data set or replaced with +appropriate interpolated values prior to entering the package +routines. The input data may be arbitrarily spaced in x. No assumptions +are made about the ordering of the x values, but see (3) below. +.le +.ls (2) +The package shall perform the following operations: +.ls o +Determine the coefficients of the fitting function by solving the normal +equations. The fitting function is selected at run time from the following +list: (1) LEGENDRE, Legendre polynomials, (2) CHEBYSHEV, +Chebyshev polynomials, (3) SPLINE3, Cubic spline +with uniformly spaced break points, SPLINE1, Linear spline with evenly +spaced break points. The calling sequence must be +invariant to the form of the fitting function. +.le +.ls o +Set an error code if the numerical routines are unable to fit the +specified function. +.le +.ls o +Output the values of the coefficients. +The coefficients are stored internal to the CURFIT package. +However in some applications it is the coefficients which are of primary +interest. A package routine shall exist to extract the +the coefficients from the curve descriptor structure. +.le +.ls o +Evaluate the fitting function at arbitrary value(s) of x. The evaluating +routines shall use the coefficients calculated and +the user supplied x value(s). +.le +.ls o +Calculate the standard deviation of the coefficients and the standard deviation +of the fit. +.le +.le +.ls (3) +The program shall perform a weighted fit using a user supplied weight +array and weight flag. The weighting options are WTS_USER, WTS_UNIFORM and +WTS_SPACING. In WTS_USER mode the package routines apply user supplied +weights to the individual data points, otherwise the package routines +calculate the weights. In WTS_SPACING mode the program assumes that the data +are sorted in x, and sets the individual weights to the difference between +adjacent x values. In WTS_UNIFORM mode the weights are set to 1. +.le +.ls (4) +The input data set and output coefficent, error, and fitted y arrays are single +precision real quantities. All package arithmetic shall be done in single +precision. The package shall however be designed with +conversion to double precision arithmetic in mind. +.le +.le + +.sh +3. Specifications + +.sh +3.1. List of Routines + +The package prefix will be cv for curve fit. +The following procedures shall be part of the package. +Detailed documentation for each procedure can be found by invoking +the help facility. + +.nf + cvinit (cv, curvetype, order, xmin, xmax) + cvzero (cv) + cvaccum (cv, x, y, w, wtflag) + cvreject (cv, x, y, w) + cvsolve (cv, ier) + cvfit (cv, x, y, w, npts, wtflag, ier) + cvrefit (cv, x, y, w, ier) + y = cveval (cv, x) + cvvector (cv, x, yfit, npts) + cvcoeff (cv, coeff, ncoeff) + cverrors (cv, y, w, yfit, rms, errors) + cvsave (cv, fit) + cvrestore (cv, fit) + cvset (cv, curve_type, xmin, xmax, coeff, ncoeff) + cvfree (cv) +.fi + +.sh +3.2. Algorithms + +.sh +3.2.1. Polynomial Basis Functions + +The approximating function is assumed to be of the form + +.nf + f(x) = a(1)*F(1,x) + a(2)*F(2,x) + ... + a(ncoeff)*F(ncoeff,x) +.fi + +where the F(n,x) are polynomial basis functions containing terms +of order x**(n-1), and the a(n) are the coefficients. +In order to avoid a very ill-conditioned linear system for moderate or large n +the Legendre and Chebyshev polynomials were chosen for the basis functions. +The Chebyshev and Legendre polynomials are +orthogonal over -1. <= x <= 1. The data x values are normalized to +this regime using minimum and maximum x values supplied by the user. +For each data point the ncoeff basis functions are calculated using the +following recursion relations. + +.nf + Legendre series + F(1,x) = 1. + F(2,x) = x + F(n,x) = [(2*n-3)*x*F(n-1,x)-(n-2)*F(n-2,x)]/(n-1) + + Chebyshev series + F(1,x) = 1. + F(2,x) = x + F(n,x) = 2*x*F(n-1,x)-F(n-2,x) +.fi + +.sh +3.2.2. Cubic Cardinal B-Spline + +The approximating function is assumed to be of the form + +.nf + f(x) = a(1)*F(1,x) + a(2)*F(2,x) + ... a(ncoeff)*F(ncoeff,x) +.fi + +where the basis functions, F(n, x), are the cubic cardinal B-splines +(Prenter 1975). +The user supplies minimum and maximum x values and the number of polynomial +pieces, npieces, to be fit to the data set. The number of cubic spline +coefficents, ncoeff, will be + +.nf + ncoeff = npieces + 3 +.fi + +The cardinal B-spline is stored in a lookup table. For each x the appropriate +break point is selected and the four non-zero B-splines are calculated by +nearest neighbour interpolation in the lookup table. + +.sh +3.2.3. The Normal Equations + +The coefficients, a, are determined by the solution of the normal equations + +.nf + c * a = b +.fi + +where + +.nf + c[i,j] = (F(i,x), F(j,x)) + b[j] = (F(j,x), f(x)) +.fi + +F(i,x) is the ith basis function at x, f(x) is the function to be +approximated and the inner product of two functions G and H, (G,H), +is given by + +.nf + (G, H) = sum (G(x[i]) * H(x[i]) * weight[i]) i=1,...npts +.fi + +The resulting matrix is symmetric and positive semi-definite. +Therefore it is necessary to store the ncoeff bands at or below the +diagonal. Storage is particularly efficient for the cubic spline +as only the diagonal and three adjacent lower bands are non-zero +(deBoor 1978). + +.sh +3.2.4. Method of Solution + +Since the matrix is symmetric, positive semi-definite and banded +it may be solved by the Cholesky method. The data matrix c may be +written as + +.nf + c = l * d * l-transpose +.fi + +where l is a unit lower triangular matrix and d is the diagonal of c +(deBoor 1978). Near zero pivots are handled in the following way. +At the nth elimination step the current value of the nth diagonal +element is compared with the original nth diagonal element. If the diagonal +element has been reduced by one computer word length, the entire nth +row is declared linearly dependent on the previous n-1 rows and +a(n) = 0. + +The triangular system + +.nf + l * w = b +.fi + +is solved for w (forward substitution), the vector d ** (-1) * w +is computed and the triangular system + +.nf + l-transpose * a = d ** (-1) * w +.fi + +solved for the coefficients, a (backward substitution). + +.sh +3.2.5. Errors + +The reduced ch-squared of the fit is defined as the weighted sum of +the squares of the residuals divided by the number of degrees of +freedom. + +.nf + rms = sqrt (sum (weight * (y - yfit) ** 2) / nfree) + nfree = npts - ncoeff +.fi + +The error of the j-th coefficient, error[j], is equal to the square root +of the j-th diagonal element of inverse data matrix times a scale factor. + +.nf + error[j] = sqrt (c[j,j]-inverse) * scale +.fi + +The scale factor is the square root of the variance of the data when +all the weights are equal, otherwise scale is one. + +.sh +4. Usage + +.sh +4.1. User Notes + +The following series of steps illustrates the use of the package. + +.ls 4 +.ls (1) +Insert an include <curfit.h> statement in the calling program to +make the CURFIT package definitions available to the user program. +.le +.ls (2) +Call CVINIT to initialize the curve fitting parameters. +.le +.ls (3) +Call CVACCUM to select a weighting function +and accumulate data points into the appropriate arrays and vectors. +.le +.ls (4) +Call CVSOLVE to solve the normal equations and calculate the coefficients +of the fitting function. Test for an error condition. +.le +.ls (5) +Call CVEVAL or CVVECTOR to evaluated the fitted function at the +x value(s) of interest. +.le +.ls (6) +Call CVCOEFF to fetch the number and value of the coefficients of the fitting +function. +.le +.ls (7) +Call CVERRORS to calculate the standard deviations in the +coefficients and the standard deviation of the fit. +.le +.ls (8) +Call CVFREE to release the space allocated for the fit. +.le +.le + +Steps (2) and (3) may be combined in a single step by calling CVFIT +and inputting an array of x, y and weight values. Individual points may +be rejected from the fit by calling CVREJECT and CVSOLVE to determine +a new set of coefficients. If the x and weight values remain the same +and only the y values change from fit to fit, CVREFIT can be called. + + +.sh +4.2. Examples + +.nf +Example 1: Fit curve to data, no weighting + + include <curfit.h> + ... + call cvinit (cv, CHEBYSHEV, 4, 1., 512.) + + call cvfit (cv, x, y, w, 512, WTS_UNIFORM, ier) + if (ier != OK) + call error (...) + + do i = 1, 512 { + x = i + call printf ("%g %g\n") + call pargr (x) + call pargr (cveval (cv, x)) + } + + call cvfree (cv) + +Example 2: Fit curve using accumulate mode, weight based on spacing + + include <curfit.h> + ... + call cvinit (cv, SPLINE3, npolypieces, 1., 512.) + + old_x = 0.0 + do i =1, 512 { + x = real (i) + if (y[i] != INDEF) { + call cvaccum (cv, x, y, x - old_x, WTS_USER) + old_x = x + } + } + + call cvsolve (cv, ier) + if (ier != OK) + call error (...) + ... + call cvfree (cv) + +Example 3: Fit and subtract smooth curve from image lines + + include <curfit.h> + ... + call cvinit (cv, CHEBYSHEV, order, 1., 512.) + + do line = 1, nlines { + inpix = imgl2r (im, line) + outpix = impl2r (im, line) + if (line == 1) + call cvfit (cv, x, Memr[inpix], w, 512, WTS_USER, ier) + else + call cvrefit (cv, x, Memr[inpix], w, WTS_USER, ier) + if (ier != OK) + ... + call cvvector (cv, x, y, 512) + call asubr (Memr[inpix], y, Memr[outpix], 512) + } + + call cvfree (cv) + +Example 4: Fit curve and save parameters for later use by CVEVAL + Fit must be at least order + 7 elements long. + + include <curfit.h> + + real fit[LEN_FIT) + ... + call cvinit (cv, LEGENDRE, order, xmin, xmax) + call cvfit (cv, x, y, w, npts, WTS_UNIFORM, ier) + if (ier != OK) + ... + call cvsave (cv, fit) + call cvfree (cv) + ... + call cvrestore (cv, fit) + do i = 1, npts + yfit[i] = cveval (cv, x[i]) + call cvfree (cv) + ... + +.fi + +.sh +5. Detailed Design + +.sh +5.1. Curve Descriptor Structure + +The CURFIT parameters, and the +size and location of the arrays and vectors used in the fitting procedure +are stored in the curve descriptor structure. The structure is referenced +by the pointer cv returned by the CVINIT routine. The curve +descriptor structure is defined in the package +header file curfit.h. The structure is listed below. + +.nf +define LEN_CVSTRUCT 17 + +# CURFIT parameters + +define CV_TYPE Memi[$1] # Type of curve to be fitted +define CV_ORDER Memi[$1+1] # Order of the fit +define CV_NPIECES Memi[$1+2] # Number of polynomial pieces (spline) +define CV_NCOEFF Memi[$1+3] # Number of coefficients +define CV_XMAX Memr[$1+4] # Maximum x value +define CV_XMIN Memr[$1+5] # Minimum x value +define CV_RANGE Memr[$1+6] # Xmax minus xmin +define CV_MAXMIN Memr[$1+7] # Xmax plus xmin +define CV_SPACING Memr[$1+8] # Break point spacing (spline) +define CV_NPTS Memi[$1+9] # Number of data points + +# Pointers to storage arrays and vectors + +define CV_XBASIS Memi[$1+10] # Basis functions single x +define CV_MATRIX Memi[$1+11] # Pointer to matrix +define CV_CHOFAC Memi[$1+12] # Pointer to Cholesky factorization +define CV_VECTOR Memi[$1+13] # Pointer to vector +define CV_COEFF Memi[$1+14] # Pointer to coefficient vector + +# Used only by CVREFIT + +define CV_BASIS Memi[$1+15] # Pointer to basis functions all x +define CV_LEFT Memi[$1+16] # Pointer to index array (spline) +.fi + +.sh +5.2. Storage Requirements + +The storage requirements are listed below. + +.ls 4 +.ls real MATRIX[order,ncoeff] +The real array, matrix, stores the original accumulated data. Storage of this +array is required by the CURFIT routines CVACCUM and CVREJECT which accumulate +and reject individual points from the data set respectively. If the fitting +function is SPLINE3 then order = 4, otherwise order = ncoeff. +.le +.ls real CHOFAC[order, ncoeff] +The real array chofac stores the Cholesky factorization of matrix. +Storage of CHOFAC is required by the CURFIT routines CVERRORS and +CVREFIT. +.le +.ls real VECTOR[ncoeff] +Ncoeff real storage units must be allocated for the vector containing +the right side of the matrix equation. VECTOR is stored for use by the +CVREJECT and CVACCUM routines. Vector is zeroed before every CVREFIT call. +.le +.ls real COEFF[ncoeff] +The coefficients of the fitted function must be stored for use by +the CVEVAL, CVVECTOR, and CVCOEFF routines. +.le +.ls real BASIS[order,npts] +Space is allocated for the basis functions only if the routine CVREFIT is +called. The first call to CVREFIT generates an array of basis functions and +subsequent calls reference the array. +.le +.ls int LEFT[npts] +Space for the array left is allocated only if +CVREFIT is called. The array indicates to which element of +the matrix a given spline function should be accumulated. +.le +.le + +.sh +6. References + +.ls (1) +Carl de Boor, "A Practical Guide to Splines", 1978, Springer-Verlag New +York Inc. +.le +.ls (2) +P.M. Prenter, "Splines and Variational Methods", 1975, John Wiley and Sons +Inc. +.le +.endhelp diff --git a/math/curfit/doc/cvaccum.hlp b/math/curfit/doc/cvaccum.hlp new file mode 100644 index 00000000..4fc3a37b --- /dev/null +++ b/math/curfit/doc/cvaccum.hlp @@ -0,0 +1,51 @@ +.help cvaccum Jun84 "Curfit Package" +.ih +NAME +cvaccum -- accumulate a single data point into the matrix +.ih +SYNOPSIS +include <math/curfit.h> + +cvaccum (cv, x, y, weight, wtflag) + +.nf +pointer cv # curve descriptor +real x # x value +real y # y value +real weight # weight +int wtflag # type of weighting +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls x +X value. Checking for out of bounds x values is the responsibility of the +user. +.le +.ls y +Y value. +.le +.ls weight +Weight assigned to the data point. +.le +.ls wtflag +Type of weighting. The options are WTS_USER, WTS_UNIFORM or WTS_SPACING. +If wtflag equals WTS_USER the weight for each point is supplied by the user. +If wtflag is either WTS_UNIFORM or WTS_SPACING the routine sets weight +to one. +.le +.ih +DESCRIPTION +Calculate the non-zero basis functions for the given value of x. +Compute the contribution of the data point to the normal equations and +sum into the appropriate arrays and vectors. +.ih +NOTES +The WTS_SPACING option cannot be used with CVACCUM. Weights will be set +to 1. +.ih +SEE ALSO +cvfit, cvrefit +.endhelp diff --git a/math/curfit/doc/cvacpts.hlp b/math/curfit/doc/cvacpts.hlp new file mode 100644 index 00000000..c5a6cffd --- /dev/null +++ b/math/curfit/doc/cvacpts.hlp @@ -0,0 +1,54 @@ +.help cvacpts Jun84 "Curfit Package" +.ih +NAME +include <math/curfit.h> + +cvacpts -- fit a curve to a set of data values +.ih +SYNOPSIS +cvacpts (cv, x, y, weight, npts, wtflag) + +.nf +pointer cv # curve descriptor +real x[] # array of x values +real y[] # array of y values +real weight[] # array of weights +int npts # number of data points +int wtflag # type of weighting +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls x +Array of x values. +.le +.ls y +Array of y values +.le +.ls weight +Array of weights +.le +.ls wtflag +Type of weighting. The options are WTS_USER, WTS_SPACING 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. If wtflag = WTS_SPACING, the weights are set equal to the +difference between adjacent data points. In order to correctly use the +WTS_SPACING option the data must be sorted in x. +.le +.ih +DESCRIPTION +CVACPTS zeroes the matrix and vectors, calculates the non-zero basis functions, +calculates the contribution +of each data point to the normal equations and accumulates it into the +appropriate array and vector elements. +.ih +NOTES +Checking for out of bounds x values is the responsibility of the user. +.ih +SEE ALSO +cvaccum +.endhelp diff --git a/math/curfit/doc/cvcoeff.hlp b/math/curfit/doc/cvcoeff.hlp new file mode 100644 index 00000000..6467cd60 --- /dev/null +++ b/math/curfit/doc/cvcoeff.hlp @@ -0,0 +1,36 @@ +.help cvcoeff Jun84 "Curfit Package" +.ih +NAME +cvcoeff -- get the number and values of the coefficients +.ih +SYNOPSIS +cvcoeff (cv, coeff, ncoeff) + +.nf +pointer cv # curve descriptor +real coeff[] # the coefficient array +int ncoeff # the number of coefficients +.fi +.ih +ARGUMENTS +.ls pointer +Pointer to the curve descriptor. +.le +.ls coeff +Array of coefficients. +.le +.ls ncoeff +The number of coefficients. +.le +.ih +DESCRIPTION +CVCOEFF fetches the coefficient array and the number of coefficients from the +curve descriptor structure. +.ih +NOTES +The variable ncoeff is only equal to the order specified in CVINIT if the +curve_type is LEGENDRE or CHEBYSHEV. If curve_type is SPLINE3 then +ncoeff = order + 3. If curve_type is SPLINE1 then ncoeff = order + 1. +.ih +SEE ALSO +.endhelp diff --git a/math/curfit/doc/cvepower.hlp b/math/curfit/doc/cvepower.hlp new file mode 100644 index 00000000..58e78dae --- /dev/null +++ b/math/curfit/doc/cvepower.hlp @@ -0,0 +1,55 @@ +.help cvepower Jun95 "Curfit Package" +.ih +NAME +cvepower -- compute the errors of the equivalent power series +.ih +SYNOPSIS +cvepower (cv, y, weight, yfit, npts, chisqr, errors) + +.nf +pointer cv # curve descriptor +real y[] # array of y data points +weight weight[] # array of weights +real yfit[] # array of fitted data points +int npts # number of points +real chisqr # the standard deviation of the fit +real errors[] # standard deviations of the power series coefficients +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure +.le +.ls y +Array of y data points +.le +.ls yfit +Array of fitted y values +.le +.ls npts +The number of points +.le +.ls chisqr +Reduced chi-squared of the fit. +.le +.ls errors +Array of standard deviations of the equivalent power series coefficients. +.le +.ih +DESCRIPTION +Calculate the reduced chi-squared of the fit and the standard deviation +of the equivalent power series coefficients for fitted Legendre and +Chebyshev polynomials. The errors are rescaled to the equivalent power +series and to the original data range. +.ih +NOTES +The standard deviation 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-squared 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 +SEE ALSO +.endhelp diff --git a/math/curfit/doc/cverrors.hlp b/math/curfit/doc/cverrors.hlp new file mode 100644 index 00000000..a0a0fbb2 --- /dev/null +++ b/math/curfit/doc/cverrors.hlp @@ -0,0 +1,53 @@ +.help cverrors Jun84 "Curfit Package" +.ih +NAME +cverrors -- calculate the standard deviation of the fit and errors +.ih +SYNOPSIS +cverrors (cv, y, weight, yfit, npts, chisqr, errors) + +.nf +pointer cv # curve descriptor +real y[] # array of y data points +weight weight[] # array of weights +real yfit[] # array of fitted data points +int npts # number of points +real chisqr # the standard deviation of the fit +real errors[] # standard deviations of the coefficients +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure +.le +.ls y +Array of y data points +.le +.ls yfit +Array of fitted y values +.le +.ls npts +The number of points +.le +.ls chisqr +Reduced chi-squared of the fit. +.le +.ls errors +Array of standard deviations of the coefficients. +.le +.ih +DESCRIPTION +Calculate the reduced chi-squared of the fit and the standard deviation +of the coefficients. +.ih +NOTES +The standard deviation 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-squared 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 +SEE ALSO +.endhelp diff --git a/math/curfit/doc/cveval.hlp b/math/curfit/doc/cveval.hlp new file mode 100644 index 00000000..48cd7f10 --- /dev/null +++ b/math/curfit/doc/cveval.hlp @@ -0,0 +1,33 @@ +.help cveval Jun84 "Curfit Package" +.ih +NAME +cveval -- evaluate the fitted function at a single x value +.ih +SYNOPSIS +y = cveval (cv, x) + +.nf +pointer cv # curve descriptor +real x # x value +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls x +X value at which the curve is to be evaluated. +.le +.ih +DESCRIPTION +Evaluate the curve at the specified value of x. CVEVAL is a real +function which returns the fitted y value. +.ih +NOTES +It uses the coefficient array stored in the curve descriptor structure. +The x values are assumed to lie in the region xmin <= x <= xmax. Checking +for out of bounds x values is the responsibility of the user. +.ih +SEE ALSO +cvvector +.endhelp diff --git a/math/curfit/doc/cvfit.hlp b/math/curfit/doc/cvfit.hlp new file mode 100644 index 00000000..cb6beb24 --- /dev/null +++ b/math/curfit/doc/cvfit.hlp @@ -0,0 +1,62 @@ +.help cvfit Jun84 "Curfit Package" +.ih +NAME +cvfit -- fit a curve to a set of data values +.ih +SYNOPSIS +cvfit (cv, x, y, weight, npts, wtflag, ier) + +.nf +pointer cv # curve descriptor +real x[] # array of x values +real y[] # array of y values +real weight[] # array of weights +int npts # number of data points +int wtflag # type of weighting +int ier # error code +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls x +Array of x values. +.le +.ls y +Array of y values +.le +.ls weight +Array of weights +.le +.ls wtflag +Type of weighting. The options are WTS_USER, WTS_SPACING 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. If wtflag = WTS_SPACING, the weights are set equal to the +difference between adjacent data points. In order to correctly use the +WTS_SPACING option the data must be sorted in x. +.le +.ls ier +Error code for the fit. The options are OK, SINGULAR and +NO_DEG_FREEDON. 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 +CVFIT zeroes the matrix and vectors, calculates the non-zero basis functions, +calculates 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 +data array is computed and the coefficients of the fitting function are +calculated. +.ih +NOTES +Checking for out of bounds x values is the responsibility of the user. +.ih +SEE ALSO +cvrefit, cvaccum, cvsolve, cvchofac, cvcholsv +.endhelp diff --git a/math/curfit/doc/cvfree.hlp b/math/curfit/doc/cvfree.hlp new file mode 100644 index 00000000..c486b306 --- /dev/null +++ b/math/curfit/doc/cvfree.hlp @@ -0,0 +1,26 @@ +.help cvfree Jun84 "Curfit Package" +.ih +NAME +cvfree -- free the curve descriptor structure +.ih +SYNOPSIS +cvfree (cv) + +.nf +pointer cv # curve descriptor +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ih +DESCRIPTION +Frees the curve descriptor structure. +.ih +NOTES +CVFREE should be called after each curve fit. +.ih +SEE ALSO +cvinit +.endhelp diff --git a/math/curfit/doc/cvinit.hlp b/math/curfit/doc/cvinit.hlp new file mode 100644 index 00000000..dc891ed2 --- /dev/null +++ b/math/curfit/doc/cvinit.hlp @@ -0,0 +1,55 @@ +.help cvinit Jun84 "Curfit Package" +.ih +NAME +cvinit -- initialise curve descriptor +.ih +SYNOPSIS +include <math/curfit.h> + +cvinit (cv, curve_type, order, xmin, xmax) + +.nf +pointer cv # curve descriptor +int curve_type # the fitting function +int order # order of the fit +real xmin # minimum x value +real xmax # maximum x value +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls curve_type +Fitting function. +Permitted values are LEGENDRE and CHEBYSHEV, for Legendre and +Chebyshev polynomials and SPLINE3 and SPLINE1 for a cubic spline +and linear spline with uniformly spaced +break points. +.le +.ls order +Order of the polynomial to be fit or the number of polynomial pieces +to be fit by a cubic spline. Order must be greater than or equal to one. +If curve_type is set to LEGENDRE or CHEBYSHEV and order equals one, a constant +term is fit to the data. +.le +.ls xmax, xmin +Minimum and maximum x values. All x values of interest +including the data x values and the x values of any curve to be evaluated +must fall in the range xmin <= x <= xmax. Checking for out of bounds x +values is the responsibility of user. +.le +.ih +DESCRIPTION +Allocate space for the curve descriptor structure and the arrays and +vectors used by the numerical routines. Initialize all arrays and vectors +to zero. Return the +curve descriptor to the calling routine. +.ih +NOTES +CVINIT must be the first CURFIT routine called. CVINIT returns if an +illegal curve type is requested. +.ih +SEE ALSO +cvfree +.endhelp diff --git a/math/curfit/doc/cvpower.hlp b/math/curfit/doc/cvpower.hlp new file mode 100644 index 00000000..386558ce --- /dev/null +++ b/math/curfit/doc/cvpower.hlp @@ -0,0 +1,40 @@ +.help cvpower Jan86 "Curfit Package" +.ih +NAME +cvpower -- convert coefficients to power series coefficients. +.ih +SYNOPSIS +.nf +include <math/curfit.h> +include "curfitdef.h" + +cvpower (cv, ps_coeff, ncoeff) + +pointer cv # Curve descriptor +real ps_coeff[ncoeff] # Power series coefficients +int ncoeff # Number of coefficients in fit +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls ps_coeff +The output array of power series coefficients. +.le +.ls ncoeff +The output number of coefficients in the fit. +.le +.ih +DESCRIPTION +This routine routines the equivlalent power series fit coefficients +and the number of coefficients. + +The coefficients of either a legendre or chebyshev solution can be converted +to power series coefficients of the form y = a0 + a1*x + a2*x**2 + a3*x**3... +The output coefficients are scaled to the original data range. +.ih +NOTES +Only legendre and chebyshev coefficients are converted. An error is +reported for other curve types. +.endhelp diff --git a/math/curfit/doc/cvrefit.hlp b/math/curfit/doc/cvrefit.hlp new file mode 100644 index 00000000..4612b4c6 --- /dev/null +++ b/math/curfit/doc/cvrefit.hlp @@ -0,0 +1,52 @@ +.help cvrefit Jun84 "Curfit Package" +.ih +NAME +cvrefit -- refit new y vector using old x vector and weights +.ih +SYNOPSIS +cvrefit (cv, x, y, w, ier) + +.nf +pointer cv # curve descriptor +real x[] # array of x values +real y[] # array of y values +real weight[] # array of weights +int ier # error code +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor +.le +.ls x +Array of x values. +.le +.ls y +Array of y values. +.le +.ls weight +Array of weights. +.le +.ls ier +Error code. The options are OK, SINGULAR and NO_DEG_FREEDOM. If ier equals +singular a solution is computed but one or more of the coefficients may +be zero. If ier equals NO_DEG_FREEDOM, there are insufficient data points +to compute a solution and CVREFIT returns without solving for the coefficients. +.le +.ih +DESCRIPTION +In some application the x and weight values remain unchanged from fit to fit +and only the y values vary. In this case it is redundant to reaccumulate +the matrix and perform the Cholesky factorization. CVREFIT 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 CVREFIT space is allocated for the non-zero basis +functions. Subsequent call to CVREFIT reference this array to avoid +recaculating basis functions at every call. +.ih +SEE ALSO +cvfit, cvaccum, cvsolve, cvchoslv +.endhelp diff --git a/math/curfit/doc/cvreject.hlp b/math/curfit/doc/cvreject.hlp new file mode 100644 index 00000000..52e5ca4f --- /dev/null +++ b/math/curfit/doc/cvreject.hlp @@ -0,0 +1,41 @@ +.help cvreject June84 "Curfit Package" +.ih +NAME +cvreject -- reject a single data point from the data set to be fit +.ih +SYNOPSIS +cvreject (cv, x, y, weight) + +.nf +pointer cv # curve descriptor +real x # x value +real y # y value +real weight # weight value +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls x +X value. +.le +.ls y +Y value. +.le +.ls weight +The weight value. +.le +.ih +DESCRIPTION +CVREJECT removes an individul data point from the data set. +The non-zero basis functions for each x are calculated. The contribution +of each x 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 CVREJECT +followed by a single call to CVSOLVE to calculate a new set of coefficients. +.ih +NOTES +.ih +SEE ALSO +.endhelp diff --git a/math/curfit/doc/cvrestore.hlp b/math/curfit/doc/cvrestore.hlp new file mode 100644 index 00000000..84d352ee --- /dev/null +++ b/math/curfit/doc/cvrestore.hlp @@ -0,0 +1,32 @@ +.help cvrestore Aug84 "Curfit Package" +.ih +NAME +cvrestore -- restore fit parameters +.ih +SYNOPSIS +cvrestore (cv, fit) + +.nf +pointer cv # pointer to curve descriptor +real fit[] # array containing curve parameters +.fi +.ih +ARGUMENTS +.ls cv +Pointer to curve descriptor structure. Returned by CVRESTORE. +.le +.ls fit +Array containing the curve parameters. Must have at least 7 + order +elements, where order is the parameter set in CVINIT. +.le +.ih +DESCRIPTION +CVRESTORE returns oldcv the pointer to the curve descriptor and +stores the curve parameters in fit in the structure ready for +use by cveval or cvvector. +.ih +NOTES +.ih +SEE ALSO +cvsave +.endhelp diff --git a/math/curfit/doc/cvsave.hlp b/math/curfit/doc/cvsave.hlp new file mode 100644 index 00000000..144beaff --- /dev/null +++ b/math/curfit/doc/cvsave.hlp @@ -0,0 +1,35 @@ +.help cvsave Aug84 "Curfit Package" +.ih +NAME +cvsave -- save parameters of fit +.ih +SYNOPSIS +call cvsave (cv, fit) + +.nf +pointer cv # curve descriptor +real fit[] # array containing the fit parameters +.fi +.ih +ARGUMENTS +.ls cv +The pointer to the curve descriptor structure. +.le +.ls fit +Array containing the fit parameters. +Fit must contain at least 7 + order elements, where order is the order of the +fit as set in CVINIT. +.le +.ih +DESCRIPTION +CVSAVE saves the curve parameters in the real array fit. +The first four elements of fit contain the curve_type, order, xmin and xmax. +The coefficients are stored in the remaining array elements. +.ih +NOTES +CVSAVE does not preserve the matrices and vectors used by the fitting +routines. +.ih +SEE ALSO +cvrestore +.endhelp diff --git a/math/curfit/doc/cvset.hlp b/math/curfit/doc/cvset.hlp new file mode 100644 index 00000000..5eb79f30 --- /dev/null +++ b/math/curfit/doc/cvset.hlp @@ -0,0 +1,56 @@ +.help cvset Nov84 "Curfit Package" +.ih +NAME +cvset -- input fit parameters derived external to CURFIT +.ih +SYNOPSIS +include <math/curfit.h> + +cvset (cv, curve_type, xmin, xmax, coeff, ncoeff) + +.nf +pointer cv # pointer to curve descriptor +int curve_type # functional form of the curve to be fitted +real xmin, xmax # minimum and maximum x values +real coeff[ncoeff] # coefficient array +int ncoeff # number of coefficients +.fi +.ih +ARGUMENTS +.ls cv +Pointer to curve descriptor structure. Returned by CVSET. +.le +.ls curve_type +Type of curve to be input. Must be one of LEGENDRE, CHEBYSHEV, SPLINE3 +or SPLINE1. +.le +.ls xmin, xmax +The minimum and maximum data or fitted x values. The Legendre and +Chebyshev polynomials are assumed to be normalized over this range. +For the cubic and linear spline functions, the data range (xmax - xmin) is +divided into (ncoeff - 3) and (ncoeff - 1) evenly spaced polynomial pieces +respectively. +.le +.ls coeff +Array containing the coefficients. Must have at least 7 + order +elements, where order has the same meaning as the order parameter set in CVINIT. +.le +.ls ncoeff +The number of coefficients. For polynomial functions, ncoeff +equals 1 plus the order of the polynomial, e.g. a second order +polynomial curve will have three coefficients. For the cubic +and linear spline the number of polynomial pieces fit are +(ncoeff - 3) and (ncoeff - 1) respectively. +.le +.ih +DESCRIPTION +CVSET returns cv the pointer to the curve descriptor and +stores the curve parameters in the CURFIT structure ready for +use by CVEVAL or CVVECTOR. +.ih +NOTES +The splines are assumed to have been fit in the least squares sense. +.ih +SEE ALSO +cvsave +.endhelp diff --git a/math/curfit/doc/cvsolve.hlp b/math/curfit/doc/cvsolve.hlp new file mode 100644 index 00000000..16badae2 --- /dev/null +++ b/math/curfit/doc/cvsolve.hlp @@ -0,0 +1,39 @@ +.help cvsolve Jun84 "Curfit Package" +.ih +NAME +cvsolve -- solve a linear system of eqns by the Cholesky method +.ih +SYNOPSIS +cvsolve (cv, ier) + +.nf +pointer cv # curve descriptor +int ier # error code +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor +.le +.ls ier +Error code returned by the fitting routines. The options are +OK, SINGULAR and NO_DEG_FREEDOM. If ier is SINGULAR the matrix is singular, +CVSOLVE will compute a solution to the normal equationsbut one or more of the +coefficients will be zero. +If ier equals NO_DEG_FREEDOM, too few data points exist for a reasonable +solution to be computed. CVSOLVE returns +without fitting the data. +.le +.ih +DESCRIPTION +CVSOLVE call two routines CVCHOFAC and CVCHOSLV. CVCHOFAC computes the +Cholesky factorization of the data matrix. CVCHOSLV solves for the +coefficients of the fitting function by forward and back substitution. +An error code is returned by CVSOLVE if it is unable to solve the normal +equations as formulated. +.ih +NOTES +.ih +SEE ALSO +cvchofac, cvchoslv +.endhelp diff --git a/math/curfit/doc/cvstati.hlp b/math/curfit/doc/cvstati.hlp new file mode 100644 index 00000000..ffd05d0a --- /dev/null +++ b/math/curfit/doc/cvstati.hlp @@ -0,0 +1,47 @@ +.help cvstati May85 "Curfit Package" +.ih +NAME +cvstati -- get integer parameter +.ih +SYNOPSIS +include <math/curfit.h> + +ival = cvstati (cv, parameter) + +.nf +pointer cv # curve descriptor +int parameter # parameter to be returned +.fi +.ih +ARGUMENTS +.ls cv +The pointer to the curve descriptor structure. +.le +.ls parameter +Parameter to be return. Definitions in curfit.h are: +.nf + define CVTYPE 1 # curve type + define CVORDER 2 # order + define CVNCOEFF 3 # number of coefficients + define CVNSAVE 4 # length of save buffer +.fi +.le +.ih +DESCRIPTION +The values of integer parameters are returned. The parameters include +the curve type, the order, the number of coefficients, and the length +of the buffer required by CVSAVE (which is of TY_REAL). +.ih +EXAMPLES +.nf + include <curfit.h> + + int cvstati() + + call malloc (buf, cvstati (cv, CVNSAVE), TY_REAL) + call cvsave (cv, Memr[buf]) +.fi +.ih +SEE ALSO +cvstatr +.endhelp diff --git a/math/curfit/doc/cvstatr.hlp b/math/curfit/doc/cvstatr.hlp new file mode 100644 index 00000000..f4d959c2 --- /dev/null +++ b/math/curfit/doc/cvstatr.hlp @@ -0,0 +1,44 @@ +.help cvstatr May85 "Curfit Package" +.ih +NAME +cvstatr -- get real parameter +.ih +SYNOPSIS +include <math/curfit.h> + +rval = cvstatr (cv, parameter) + +.nf +pointer cv # curve descriptor +int parameter # parameter to be returned +.fi +.ih +ARGUMENTS +.ls cv +The pointer to the curve descriptor structure. +.le +.ls parameter +Parameter to be return. Definitions in curfit.h are: +.nf + define CVXMIN 5 # minimum ordinate + define CVORDER 6 # maximum ordinate +.fi +.le +.ih +DESCRIPTION +The values of real parameters are returned. The parameters include +the minimum and maximum ordinate values of the curve. +.ih +EXAMPLES +.nf + include <curfit.h> + + real cvstatr() + + xmin = cvstatr (cv, CVXMIN) + xmax = cvstatr (cv, CVXMAX) +.fi +.ih +SEE ALSO +cvstati +.endhelp diff --git a/math/curfit/doc/cvvector.hlp b/math/curfit/doc/cvvector.hlp new file mode 100644 index 00000000..79c0282f --- /dev/null +++ b/math/curfit/doc/cvvector.hlp @@ -0,0 +1,41 @@ +.help cvvector Jun84 "Curfit Package" +.ih +NAME +cvvector -- evaluate the fitted curve at a set of points +.ih +SYNOPSIS +cvvector (cv, x, yfit, npts) + +.nf +pointer cv # curve descriptor +real x[] # x array +real yfit[] # array of fitted y values +int npts # number of x values +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ls x +Array of x values +.le +.ls yfit +Array of fitted y values +.le +.ls npts +The number of x values at which the curve is to be evaluated. +.le +.ih +DESCRIPTION +Fit the curve to an array of data points. CVVECTOR uses the coefficients +stored in the curve descriptor structure. +.ih +NOTES +The x values are assumed to lie +in the region xmin <= x <= xmax. Checking for out of bounds x values is the +responsibility of the user. +.ih +SEE ALSO +cveval +.endhelp diff --git a/math/curfit/doc/cvzero.hlp b/math/curfit/doc/cvzero.hlp new file mode 100644 index 00000000..7f9e07e2 --- /dev/null +++ b/math/curfit/doc/cvzero.hlp @@ -0,0 +1,26 @@ +.help cvzero Aug84 "Curfit Package" +.ih +NAME +cvzero -- set up for a new curve fit +.ih +SYNOPSIS +cvzero (cv) + +.nf +pointer cv # curve descriptor +.fi +.ih +ARGUMENTS +.ls cv +Pointer to the curve descriptor structure. +.le +.ih +DESCRIPTION +CVZERO zeros the matrix and right side of the matrix equation. +.ih +NOTES +CVZERO can be used to reinitialize the matrix and right side of the matrix +equation to begin a new fit in accumulate mode. +.ih +SEE ALSO +cvfit, cvinit diff --git a/math/curfit/mkpkg b/math/curfit/mkpkg new file mode 100644 index 00000000..345ec582 --- /dev/null +++ b/math/curfit/mkpkg @@ -0,0 +1,87 @@ +# Curve fitting tools library. + +$checkout libcurfit.a lib$ +$update libcurfit.a +$checkin libcurfit.a lib$ +$exit + +tfiles: + $set GEN = "$$generic -k -t rd" + + $ifolder (cv_b1evalr.x, cv_b1eval.gx) $(GEN) cv_b1eval.gx $endif + $ifolder (cv_bevalr.x, cv_beval.gx) $(GEN) cv_beval.gx $endif + $ifolder (cv_fevalr.x, cv_feval.gx) $(GEN) cv_feval.gx $endif + $ifolder (cv_userfncr.x, cv_userfnc.gx) $(GEN) cv_userfnc.gx $endif + $ifolder (cvaccumr.x, cvaccum.gx) $(GEN) cvaccum.gx $endif + $ifolder (cvacptsr.x, cvacpts.gx) $(GEN) cvacpts.gx $endif + $ifolder (cvchomatr.x, cvchomat.gx) $(GEN) cvchomat.gx $endif + $ifolder (cvcoeffr.x, cvcoeff.gx) $(GEN) cvcoeff.gx $endif + $ifolder (cverrorsr.x, cverrors.gx) $(GEN) cverrors.gx $endif + $ifolder (cvevalr.x, cveval.gx) $(GEN) cveval.gx $endif + $ifolder (cvfitr.x, cvfit.gx) $(GEN) cvfit.gx $endif + $ifolder (cvfreer.x, cvfree.gx) $(GEN) cvfree.gx $endif + $ifolder (cvinitr.x, cvinit.gx) $(GEN) cvinit.gx $endif + $ifolder (cvpowerr.x, cvpower.gx) $(GEN) cvpower.gx $endif + $ifolder (cvrefitr.x, cvrefit.gx) $(GEN) cvrefit.gx $endif + $ifolder (cvrejectr.x, cvreject.gx) $(GEN) cvreject.gx $endif + $ifolder (cvrestorer.x, cvrestore.gx) $(GEN) cvrestore.gx $endif + $ifolder (cvsaver.x, cvsave.gx) $(GEN) cvsave.gx $endif + $ifolder (cvsetr.x, cvset.gx) $(GEN) cvset.gx $endif + $ifolder (cvsolver.x, cvsolve.gx) $(GEN) cvsolve.gx $endif + $ifolder (cvstatr.x, cvstat.gx) $(GEN) cvstat.gx $endif + $ifolder (cvvectorr.x, cvvector.gx) $(GEN) cvvector.gx $endif + $ifolder (cvzeror.x, cvzero.gx) $(GEN) cvzero.gx $endif + ; + +libcurfit.a: + + $ifeq (USE_GENERIC, yes) $call tfiles $endif + + cvaccumr.x curfitdef.h <math/curfit.h> + cvacptsr.x curfitdef.h <math/curfit.h> + cv_bevalr.x + cv_b1evalr.x + cvchomatr.x curfitdef.h <mach.h> <math/curfit.h> + cvcoeffr.x curfitdef.h + cverrorsr.x curfitdef.h <mach.h> + cvevalr.x curfitdef.h <math/curfit.h> + cv_fevalr.x + cvfitr.x curfitdef.h <math/curfit.h> + cvfreer.x curfitdef.h + cvinitr.x curfitdef.h <math/curfit.h> <mach.h> + cvpowerr.x curfitdef.h <math/curfit.h> <mach.h> + cvrefitr.x curfitdef.h <math/curfit.h> + cvrejectr.x curfitdef.h <math/curfit.h> + cvrestorer.x curfitdef.h <math/curfit.h> + cvsaver.x curfitdef.h <math/curfit.h> + cvsetr.x curfitdef.h <math/curfit.h> + cvsolver.x curfitdef.h <math/curfit.h> + cvstatr.x curfitdef.h <math/curfit.h> + cv_userfncr.x curfitdef.h <math/curfit.h> + cvvectorr.x curfitdef.h <math/curfit.h> + cvzeror.x curfitdef.h + + cvaccumd.x dcurfitdef.h <math/curfit.h> + cvacptsd.x dcurfitdef.h <math/curfit.h> + cv_bevald.x + cv_b1evald.x + cvchomatd.x dcurfitdef.h <mach.h> <math/curfit.h> + cvcoeffd.x dcurfitdef.h + cverrorsd.x dcurfitdef.h <mach.h> + cvevald.x dcurfitdef.h <math/curfit.h> + cv_fevald.x + cvfitd.x dcurfitdef.h <math/curfit.h> + cvfreed.x dcurfitdef.h + cvinitd.x dcurfitdef.h <math/curfit.h> <mach.h> + cvpowerd.x dcurfitdef.h <math/curfit.h> <mach.h> + cvrefitd.x dcurfitdef.h <math/curfit.h> + cvrejectd.x dcurfitdef.h <math/curfit.h> + cvrestored.x dcurfitdef.h <math/curfit.h> + cvsaved.x dcurfitdef.h <math/curfit.h> + cvsetd.x dcurfitdef.h <math/curfit.h> + cvsolved.x dcurfitdef.h <math/curfit.h> + cvstatd.x dcurfitdef.h <math/curfit.h> + cv_userfncd.x dcurfitdef.h <math/curfit.h> + cvvectord.x dcurfitdef.h <math/curfit.h> + cvzerod.x dcurfitdef.h + ; |