Initial commit

1 files changed, 164 insertions, 0 deletions

diff --git a/math/nlfit/nldump.gx b/math/nlfit/nldump.gx
new file mode 100644
index 00000000..aa5899bd
--- /dev/null
+++ b/math/nlfit/nldump.gx
@@ -0,0 +1,164 @@
+$if (datatype == r)
+include "nlfitdefr.h"
+$else
+include "nlfitdefd.h"
+$endif
+
+# NL_DUMP -- Dump NLFIT structure to a file
+
+procedure nl_dump$t (fd, nl)
+
+int	fd		# file descriptor
+pointer	nl		# NLFIT descriptor
+
+int	i, npars, nfpars
+
+begin
+	# Test NLFIT pointer
+	if (nl == NULL) {
+	    call fprintf (fd, "\n****** nl_dump: Null NLFIT pointer\n")
+	    call flush (fd)
+	    return
+	}
+
+	# File and NLFIT descriptors
+	call fprintf (fd, "\n****** nl_dump: (fd=%d), (nl=%d)\n")
+	    call pargi (fd)
+	    call pargi (nl)
+	call flush (fd)
+
+	# Dump function and derivative addresses
+	call fprintf (fd, "Fitting function pointer    = %d\n")
+	    call pargi (NL_FUNC (nl))
+	call fprintf (fd, "Derivative function pointer = %d\n")
+	    call pargi (NL_DFUNC (nl))
+	call flush (fd)
+
+	# Number of parameters
+	npars = NL_NPARAMS (nl)
+	nfpars = NL_NFPARAMS (nl)
+	call fprintf (fd, "Number of parameters        = %d\n")
+	    call pargi (npars)
+	call fprintf (fd, "Number of fitted parameters = %d\n")
+	    call pargi (nfpars)
+	call flush (fd)
+
+	# Fit parameters
+	call fprintf (fd, "Max number of iterations    = %d\n")
+	    call pargi (NL_ITMAX (nl))
+	call fprintf (fd, "Tolerance for convergence   = %g\n")
+	    call parg$t (NL_TOL (nl))
+	call flush (fd)
+
+	# Sums
+	call fprintf (fd, "Damping factor = %g\n")
+	    call parg$t (NL_LAMBDA (nl))
+	call fprintf (fd, "Sum of residuals squared last iteration = %g\n")
+	    call parg$t (NL_OLDSQ (nl))
+	call fprintf (fd, "Sum of residuals squared                = %g\n")
+	    call parg$t (NL_SUMSQ (nl))
+	call flush (fd)
+
+	# Counters
+	call fprintf (fd, "Iteration counter       = %d\n")
+	    call pargi (NL_ITER (nl))
+	call fprintf (fd, "Number of points in fit = %d\n")
+	    call pargi (NL_NPTS (nl))
+	call flush (fd)
+
+	# Parameter values
+	call fprintf (fd, "Parameter values (%d):\n")
+	    call pargi (NL_PARAM (nl))
+	if (NL_PARAM (nl) != NULL) {
+	    do i = 1, npars {
+		call fprintf (fd, "%d -> %g\n")
+		    call pargi (i)
+		    call parg$t (Mem$t[NL_PARAM (nl) + i - 1])
+	    }
+	} else
+	    call fprintf (fd, "	Null pointer\n")
+	call flush (fd)
+
+	# Parameter errors
+	call fprintf (fd, "Parameter errors (%d):\n")
+	    call pargi (NL_DPARAM (nl))
+	if (NL_DPARAM (nl) != NULL) {
+	    do i = 1, npars {
+		call fprintf (fd, "%d -> %g\n")
+		    call pargi (i)
+		    call parg$t (Mem$t[NL_DPARAM (nl) + i - 1])
+	    }
+	} else
+	    call fprintf (fd, "	Null pointer\n")
+	call flush (fd)
+
+	# Parameter list
+	call fprintf (fd, "Parameter list (%d):\n")
+	    call pargi (NL_PLIST (nl))
+	if (NL_PLIST (nl) != NULL) {
+	    do i = 1, npars {
+		call fprintf (fd, "%d -> %d\n")
+		    call pargi (i)
+		    call pargi (Memi[NL_PLIST (nl) + i - 1])
+	    }
+	} else
+	    call fprintf (fd, "	Null pointer\n")
+	call flush (fd)
+
+	# Alpha matrix
+	call fprintf (fd, "Alpha matrix (%d):\n")
+	    call pargi (NL_ALPHA (nl))
+	if (NL_ALPHA (nl) != NULL)
+	    call nl_adump$t (fd, Mem$t[NL_ALPHA (nl)], nfpars, nfpars)
+	else
+	    call fprintf (fd, "	Null pointer\n")
+	call flush (fd)
+
+	# Beta matrix
+	call fprintf (fd, "Beta matrix (%d):\n")
+	    call pargi (NL_BETA (nl))
+	if (NL_BETA (nl) != NULL)
+	    call nl_adump$t (fd, Mem$t[NL_BETA (nl)], nfpars, 1)
+	else
+	    call fprintf (fd, "	Null pointer\n")
+	call flush (fd)
+
+	# Covariance matrix
+	call fprintf (fd, "Covariance matrix (%d):\n")
+	    call pargi (NL_COVAR (nl))
+	if (NL_COVAR (nl) != NULL)
+	    call nl_adump$t (fd, Mem$t[NL_COVAR (nl)], nfpars, nfpars)
+	else
+	    call fprintf (fd, "	Null pointer\n")
+	call flush (fd)
+
+	# Cholesky factorization
+	call fprintf (fd, "Cholesky factorization matrix (%d):\n")
+	    call pargi (NL_CHOFAC (nl))
+	if (NL_CHOFAC (nl) != NULL)
+	    call nl_adump$t (fd, Mem$t[NL_CHOFAC (nl)], nfpars, nfpars)
+	else
+	    call fprintf (fd, "	Null pointer\n")
+	call flush (fd)
+end
+
+
+# NL_ADUMP -- Dump array to file
+
+procedure nl_adump$t (fd, a, nrows, ncols)
+
+int	fd			# file descriptor
+PIXEL	a[nrows, ncols]		# array
+int	nrows, ncols		# dimension
+
+int	i, j
+
+begin
+	do i = 1, nrows {
+	    do j = 1, ncols {
+		call fprintf (fd, "%g  ")
+		    call parg$t (a[i, j])
+	    }
+	    call fprintf (fd, "\n")
+	}
+end