#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of shell archive."
# Contents:  general.c general.h fileio.c fileio.h
# Wrapped by karin@borodin on Wed Jul 24 21:59:13 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'general.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'general.c'\"
else
echo shar: Extracting \"'general.c'\" \(8225 characters\)
sed "s/^X//" >'general.c' <<'END_OF_FILE'
X/*----------------------------------------------------------------------
X	general.c		procedures used in several modules		
X------------------------------------------------------------------------*/
X 
X#include <strings.h>
X#include <stdio.h>
X#include <math.h>
X#include <malloc.h>
X#include <suntool/sunview.h>
X#include <suntool/canvas.h>
X#include <suntool/panel.h>
X#include <suntool/alert.h>
X#include <suntool/tty.h>
X#include <suntool/textsw.h>
X#include <suntool/scrollbar.h>
X
X#include "macros.h"
X#include "matalloc.h"
X#include "matutil.h"
X#include "mattrans.h"
X
X#include "graphic.h"
X#include "group.h"
X#include "tree.h"
X#include "gauss_newton.h"
X#include "break.h"
X#include "no_break.h"
X#include "continuation.h"
X
X#include "general.h"
X
X#define THETA_MIN		0.1
X
X/*----------------------------------------------------------------------
X	global data for symcon		
X------------------------------------------------------------------------*/
X
XREAL **a, **a_help, **v, **l, *d;
XREAL theta_min = THETA_MIN, quite_small, cond, eps_mach, sqrt_eps_mach;
Xint *pivot, signum;
X
XBOOLEAN scaling 			= FALSE,
X		print_messages 		= TRUE,
X		print_statements 	= TRUE,
X		print_warnings 		= TRUE,
X		print_fatal_errors 	= TRUE;
X
Xchar str[200];
X
Xstatic char message_str[100];
X
X/*----------------------------------------------------------------------
X	data for numerical differentiation		
X------------------------------------------------------------------------*/
X
Xstatic REAL *fy, *fyb, delta_diff, *y_act;
XREAL **dfy;
X
X/*----------------------------------------------------------------------
X	standard procedures and initializations		
X------------------------------------------------------------------------*/
X
Xstatic REAL machine_precision()
X{
X	REAL x=1;
X	
X	while (1.0 != (1.0 + x)) x/=2;
X	return x;
X}
X
Xvoid init_general()
X{
X	a  		= dmatrix(1, n, 1, n);
X	a_help 	= dmatrix(1, m, 1, n);
X	v   	= dmatrix(1, n, 1, 2);
X	l   	= lower_dmatrix(1, 2, 1, 2);
X	d   	= dvector(1, n);	
X	pivot 	= ivector(1, n);
X	y_guess = dvector(1, n);
X	par		= dvector(1, npar);
X	
X	eps_mach = machine_precision();
X	sqrt_eps_mach = sqrt(eps_mach);
X	
X	fy   	= dvector(1, m);
X	fyb   	= dvector(1, m);
X	y_act  	= dvector(1, n);
X	delta_diff = sqrt(1 * eps_mach);
X	
X	dfy 	= dmatrix(1,m,1,n);
X}
X
Xvoid quit_general()
X{
X	free_dvector(d, 1, n);
X	free_dmatrix(a, 1, n, 1, n);
X	free_dmatrix(a_help, 1, m, 1, n);
X	free_dmatrix(v, 1, m, 1, 2);
X	free_lower_dmatrix(l, 1, 2, 1, 2);
X	free_ivector(pivot, 1, n);
X	
X	free_dvector(fy, 1, m);
X	free_dvector(fyb, 1, m);
X	free_dvector(y_act, 1, n);
X	
X	free_dmatrix(dfy,1,m,1,n);
X}
X
XREAL Seconds()
X  {
X     long t = clock();
X     return t*1.0e-6;
X  }
X
X/*--------------------------------------------------------------------
X	output of messages			
X----------------------------------------------------------------------*/
X
Xvoid message(s)
X	char *s;
X{
X	if (print_messages) {
X		sprintf(message_str, "message: %s\n", s);
X		textsw_insert(textsw, message_str, strlen(message_str));
X	}
X}
X
Xvoid statement(s)
X	char *s;
X{
X	if (print_statements) {
X		sprintf(message_str, "%s\n", s);
X		textsw_insert(textsw, message_str, strlen(message_str));
X	}
X}
X
Xvoid warning(s)
X	char *s;
X{
X	if (print_warnings) {
X		sprintf(message_str, "warning: %s\n", s);
X		textsw_insert(textsw, message_str, strlen(message_str));
X	}
X}
X
Xvoid fatal_error(s)
X	char *s;
X{
X	if (print_fatal_errors) {
X		sprintf(message_str, "fatal error: %s\n", s);
X		textsw_insert(textsw, message_str, strlen(message_str));
X	}
X}
X
X/*--------------------------------------------------------------------
X	numerical differentiation
X	
X	approximates the Jacobian a=f'(y) of a function f:R^n --> R^m at
X	y by simple divided differences		
X----------------------------------------------------------------------*/
X
Xvoid num_diff(f, y, a, m, n)
X	void (*f)();
X	REAL *y, **a;
X	int m, n;
X{
X	int i,j;
X	REAL s, t;
X	
X	f(y,fy);
X	for (j=1; j<=n; j++) {
X		t=y[j];
X		s=delta_diff * fabs(t);
X		y[j] += s;
X		f(y, fyb);
X		for (i=1; i<=m; i++) {
X			a[i][j] = (fyb[i]-fy[i])/s;
X		}
X		y[j] = t;
X	}	
X}
X
X/*--------------------------------------------------------------------
X	same as num_diff for symmetric Jacobians a=f'(y) of a function
X	f:R^n --> R^n, stored as a upper triangular matrix		
X----------------------------------------------------------------------*/
X
Xvoid sym_num_diff(f, y, a, n)
X	void (*f)();
X	REAL *y, **a;
X	int n;
X{
X	int i,j;
X	REAL s, t;
X	
X	f(y,fy);
X	for (j=1; j<=n; j++) {
X		t=y[j];
X		s=delta_diff * fabs(t);
X		y[j] += s;
X		f(y, fyb);
X		for (i=1; i<=j; i++) {
X			a[i][j] = (fyb[i]-fy[i])/s;
X		}
X		y[j] = t;
X	}	
X}
X
X/*--------------------------------------------------------------------
X	updating of the Jacobian			
X----------------------------------------------------------------------*/
X
Xvoid update_jacobian(y)
X	double *y;
X{
X	if (squared_distance(y, y_act, 1, n) != 0) {
X		copy_dvector(y_act, y, 1, n);
X		df(y,dfy);
X	}
X}
X
X/*--------------------------------------------------------------------
X	solver (based on QR-decomposition) for gauss_newton()			
X----------------------------------------------------------------------*/
X
XBOOLEAN qr_jac(x, m, n)	
X	REAL *x;
X	int m, n;
X{
X	REAL cond = 1 / sqrt_eps_mach;
X	int p = m;
X
X	householder(a, d, &cond, pivot, m, n, &p, &signum);
X	if(p!=m) {
X		fatal_error("householder failed in qr_jac");
X		return FALSE;
X	}
X	else {
X		prepare_solution(a, v, l, d, m, n, p);
X		return TRUE;
X	}
X}
X
XBOOLEAN qr_solve(b, x, m, n)
X	REAL *b, *x;
X	int m, n;
X{
X	solution(a, v, l, d, b, x, pivot, m, n, m);
X	return TRUE;
X}
X
X/*--------------------------------------------------------------------
X	tangent		computes the normalized tangent vector at y
X	
X	new_jacobian == TRUE 	-->		compute new Jacobian at y
X	new_jacobian == FALSE 	-->		Jacobian at y was already computed
X									and transformed (a, d, v, l)			
X----------------------------------------------------------------------*/
X
XBOOLEAN tangent(df, y, t, m, n, new_jacobian)
X	void (*df)();
X	REAL *y, *t;
X	int m, n;
X	BOOLEAN new_jacobian;
X{
X	int p, i;
X	
X	if (new_jacobian) {
X		df(y, a);
X		cond = 1 / sqrt_eps_mach;
X		p = n-1;
X		householder(a, d, &cond, pivot, m, n, &p, &signum);
X		if (p<n-1) {
X			fatal_error("householder failed in tangent");
X			return FALSE;
X		}	
X		prepare_solution(a, v, l, d, m, n, p);
X	}
X	for (i=1; i<=n-1; i++) t[pivot[i]] = - v[i][1] / l[1][1];
X	t[pivot[n]] = 1 / l[1][1];
X	return TRUE;
X}
X
X/*--------------------------------------------------------------------------
X	compute determinant and subcondition of a
X--------------------------------------------------------------------------*/
X
Xvoid det_sc(det, sc, n)
X	REAL *det, *sc;
X	int n;
X{
X 	int i, p=n, signum;
X
X	*det = 1;
X	*sc = 1 / sqrt_eps_mach;
X	householder(a, d, sc, pivot, n, n, &p, &signum);
X	if (p<n) *det = 0.0;
X	else {
X		for (i=1; i<=n; i++) *det *= d[i];
X		*det *= signum;
X		if (n % 2 == 0) 	*det = -*det;
X	}
X}
X
X/*---------------------------------------------------------------------------
X	extended_det(a, d, pivot, m, k, signum)
X
X		computes the determinant of (m, m+1)-matrix 'a' without the k-th
X		column, where 'a' must be of full rank (p=m) and be QR-decomposed by
X		
X			householder(a, d, &cond, pivot, m, m+1, &p, &signum)
X			
X		and signum is the sign of the pivoting-permutation.
X		
X			det = sgn(PI) * (-1)^(k+l) * det(A_l), 	where pivot[k] = l
X				=  - signum * (-1)^(k+l) * det(A_l).
X		
X		The determinant of the Hessenberg-matrix A_l (= A without the l-th
X		column) is computed by using Givens-rotations.				
X----------------------------------------------------------------------------*/
X
XREAL extended_det(a, d, pivot, m, k, signum)
X	REAL **a, *d;
X	int *pivot, m, k, signum;
X{
X	REAL det = 1, x, y, r, c, s, *temp;
X	int i, j, l, n;
X
X	n = m+1;
X	temp = dvector(1, n);	
X	for (l=1; pivot[l]!=k; l++);		/* find l satisfying pivot[l] = k 	*/
X	
X	for (j=1; j<=l-1; j++) {			/* product of first (l-1) diagonal	*/
X		det = det * d[j];				/* elements of R					*/
X	}
X	if (l<=m) {
X		for (j=l+1; j<=n; j++) temp[j] = a[l][j];
X		for (i=l+1; i<=m; i++) {		/* Givens-rotations			*/
X			x = temp[i];
X			y = d[i];
X			r = sqrt(SQR(x) + SQR(y));
X			c = x / r;
X			s = y / r;
X			det = det * r;
X			for (j=i+1; j<=n; j++) {
X				temp[j] = -s * temp[j] + c * a[i][j];
X			}
X		}
X		det = det * temp[n];
X	}
X	free_dvector(temp, 1, n);
X
X	if ((k+l) % 2 != 0) 	det = - det;	
X	return signum * det;
X}
X
X	
END_OF_FILE
if test 8225 -ne `wc -c <'general.c'`; then
    echo shar: \"'general.c'\" unpacked with wrong size!
fi
# end of 'general.c'
fi
if test -f 'general.h' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'general.h'\"
else
echo shar: Extracting \"'general.h'\" \(841 characters\)
sed "s/^X//" >'general.h' <<'END_OF_FILE'
X/*----------------------------------------------------------------------
X	general.h		procedures used in several modules		
X------------------------------------------------------------------------*/
X 
Xextern void init_general();
Xextern void quit_general();
X
Xextern REAL Seconds();
X
Xextern double **a, **a_help, **v, **l, *d;
Xextern double **dfy;
Xextern double theta_min, quite_small, cond, eps_mach, sqrt_eps_mach;
Xextern int *pivot, signum;
Xextern BOOLEAN scaling, print_messages, print_statements, print_warnings,
X		print_fatal_errors;
Xextern char str[200];
X
Xextern BOOLEAN qr_jac();
Xextern BOOLEAN qr_solve();
X
Xextern BOOLEAN tangent();
Xextern double extended_det();
X
Xextern void fatal_error();
Xextern void message();
Xextern void statement();
Xextern void warning();
X
Xextern void num_diff(), sym_num_diff();
X
Xextern char par_string[10][10];
END_OF_FILE
if test 841 -ne `wc -c <'general.h'`; then
    echo shar: \"'general.h'\" unpacked with wrong size!
fi
# end of 'general.h'
fi
if test -f 'fileio.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'fileio.c'\"
else
echo shar: Extracting \"'fileio.c'\" \(2046 characters\)
sed "s/^X//" >'fileio.c' <<'END_OF_FILE'
X/*--------------------------------------------------------------------------
X	fileio.c
X	
X		data and procedures for file I/O	(cf. 'C as a Second Language')	
X---------------------------------------------------------------------------*/
X
X#include <strings.h>
X#include <stdio.h>
X#include <math.h>
X#include <malloc.h>
X
X#include <suntool/sunview.h>
X#include <suntool/alert.h>
X
X#include "macros.h"
X#include "fileio.h"
X
Xstatic str[50];
X
Xvoid file_error_alert(frame, file_error)
X	Frame frame;
X	FILE_ERROR file_error;
X{
X	switch (file_error) {
X		case PARS	:	sprintf(str, "Incorrect parameters");
X						break;
X		case WOPEN	:	sprintf(str, "Cannot open file for output");
X						break;
X		case WRITE	:	sprintf(str, "File write error");
X						break;
X		case WCLOSE	:	sprintf(str, "Cannot close output file");
X						break;
X		case ROPEN	:	sprintf(str, "Cannot open file for input");
X						break;
X		case READ	:	sprintf(str, "File read error");
X						break;
X		case RCLOSE	:	sprintf(str, "Cannot close input file");
X						break;
X		case TOPEN	:	sprintf(str, "Cannot open text file");
X						break;
X		case TREAD	:	sprintf(str, "Text file write error");
X						break;
X		case TCLOSE	:	sprintf(str, "Cannot close text file");
X						break;
X	}
X	alert_prompt(frame, NULL,
X		ALERT_MESSAGE_STRINGS, str, 0,
X		ALERT_BUTTON_YES, "Continue",
X		0);	
X}
X
XBOOLEAN fwrite_int(f, x)
X	FILE *f;
X	int *x;
X{
X	return (fwrite((char *) x, sizeof(int), 1, f) == 1);
X}
X
XBOOLEAN fread_int(f, x)
X	FILE *f;
X	int *x;
X{
X	return (fread((char *) x, sizeof(int), 1, f) == 1);
X}
X
XBOOLEAN fwrite_real(f, x)
X	FILE *f;
X	REAL *x;
X{
X	return (fwrite((char *) x, sizeof(REAL), 1, f) == 1);
X}
X
XBOOLEAN fread_real(f, x)
X	FILE *f;
X	REAL *x;
X{
X	return (fread((char *) x, sizeof(REAL), 1, f) == 1);
X}
X
XBOOLEAN fwrite_vector(f, v, nl, nh)
X	FILE *f;
X	REAL *v;
X	int nl, nh;
X{
X	int n = nh - nl + 1;
X	
X	return (fwrite((char *) (v + nl), sizeof(REAL), n, f) == n);
X}
X
XBOOLEAN fread_vector(f, v, nl, nh)
X	FILE *f;
X	REAL *v;
X	int nl, nh;
X{
X	int n = nh - nl + 1;
X	
X	return (fread((char *) (v + nl), sizeof(REAL), n, f) == n);
X}
X
END_OF_FILE
if test 2046 -ne `wc -c <'fileio.c'`; then
    echo shar: \"'fileio.c'\" unpacked with wrong size!
fi
# end of 'fileio.c'
fi
if test -f 'fileio.h' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'fileio.h'\"
else
echo shar: Extracting \"'fileio.h'\" \(564 characters\)
sed "s/^X//" >'fileio.h' <<'END_OF_FILE'
X/*--------------------------------------------------------------------------
X	fileio.h
X	
X		data and procedures for file I/O	(cf. 'C as a Second Language')	
X---------------------------------------------------------------------------*/
X
Xtypedef enum {PARS, WOPEN, WRITE, WCLOSE, ROPEN, READ, RCLOSE,
X				TOPEN, TREAD, TCLOSE, FILE_OK} FILE_ERROR;
X				
Xextern void file_error_alert();
X
Xextern BOOLEAN fwrite_int();
Xextern BOOLEAN fwrite_real();
Xextern BOOLEAN fwrite_vector();
X
Xextern BOOLEAN fread_int();
Xextern BOOLEAN fread_real();
Xextern BOOLEAN fread_vector();
X
END_OF_FILE
if test 564 -ne `wc -c <'fileio.h'`; then
    echo shar: \"'fileio.h'\" unpacked with wrong size!
fi
# end of 'fileio.h'
fi
echo shar: End of shell archive.
exit 0

