#! /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:  continuation.c continuation.h gauss_newton.c
#   gauss_newton.h group.c group.h
# Wrapped by karin@borodin on Wed Jul 24 21:34:58 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'continuation.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'continuation.c'\"
else
echo shar: Extracting \"'continuation.c'\" \(10425 characters\)
sed "s/^X//" >'continuation.c' <<'END_OF_FILE'
X/*----------------------------------------------------------------------
X	continuation.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
X#include "macros.h"
X#include "matalloc.h"
X#include "matutil.h"
X#include "mattrans.h"
X
X#include "group.h"
X#include "tree.h"
X#include "gauss_newton.h"
X#include "general.h"
X
X#include "continuation.h"
X
X#define CONT_MAX				10	
X#define BOUND_MAX				10
X#define THETA_MAX				0.25
X
X#define RHO						0.5
X#define TANGENT_MIN				0.3
X#define COND_FACTOR_MAX			1/EPS_MACH
X#define EXTRAPOLATION_FACTOR	1.5
X#define REDUCTION_MAX			2
X#define REDUCTION_FACTOR		0.5
X#define LINEAR_FACTOR			1.5
X
XBOOLEAN steplength_control;
XREAL steplength, tangent_min = TANGENT_MIN;
X
Xstatic REAL *scale = nil, *u_hat, *tu_hat, *y, *ty, *y_temp;
X
Xvoid init_continuation()
X{
X	u_hat 	= dvector(1, n);
X	tu_hat 	= dvector(1, n);
X	y 		= dvector(1, n);
X	ty 		= dvector(1, n);
X	y_temp	= dvector(1, n);
X	if (scaling) 	scale = dvector(1, n);
X}
X
Xvoid quit_continuation()
X{
X	free_dvector(ty, 1, n);
X	free_dvector(y, 1, n);
X	free_dvector(y_temp, 1, n);
X	free_dvector(u_hat, 1, n);
X	free_dvector(tu_hat, 1, n);
X	free_dvector(scale, 1, n);
X}
X
X/*---------------------------------------------------------------------------
X	scaling procedures
X---------------------------------------------------------------------------*/
X
Xstatic void init_scale(x, n)
X	REAL *x;
X	int n;
X{
X	int i;
X	for (i=1; i<=n; i++) 	scale[i] = MAX(fabs(x[i]), scale_min);
X}
X
Xstatic void rescale(x, n)
X	REAL *x;
X	int n;
X{
X	int i;
X	for (i=1; i<=n; i++) {
X	 	scale[i] = MAX((fabs(x[i]) + scale[i])/2, scale_min);
X	}
X}
X
X/*---------------------------------------------------------------------------
X	compute first solution
X---------------------------------------------------------------------------*/
X
Xstatic BOOLEAN look_for_first_solution(u)
X	REAL *u;
X{
X	REAL nc, snc;	
X	int errno, iter;
X	
X	change_group(group);
X	inv_transform(y_guess, u);
X	return gauss_newton(g, g_jac, g_solve, u, scale, &nc, &snc,
X												 mu, nu, &errno, &iter);
X}	
X
XREAL initial_steplength()
X{
X	return steplength;
X}
X
Xstatic void handle_first_solution(u)
X	REAL *u;
X{
X	Branch *branch;
X	Point *point;
X	REAL *tu, *det, *sym_det, *sym_sc;
X	int i, para;
X	
X	tu 		= dvector(1, nu);
X	det  	= dvector(1, nu);
X	sym_det = dvector(2, sigma->s);
X	sym_sc  = dvector(2, sigma->s);
X	
X	tangent(dg, u, tu, mu, nu, YES);
X	para = pivot[nu];
X	for (i=1; i<=nu; i++) det[i] = extended_det(a, d, pivot, mu, i, signum);
X	for (i=2; i<=sigma->s; i++) {
X		sigma->dg[i](u, a);
X		det_sc(&sym_det[i], &sym_sc[i], sigma->m[i]);
X	}
X
X	point = new_point();		
X	point->type 	= REGULAR;
X	point->para 	= para;
X	point->u 		= u;
X	point->tu 		= tu;
X	point->s 		= initial_steplength();
X	point->sc 		= cond;
X	point->det		= det;
X	point->sym_det	= sym_det;
X	point->sym_sc	= sym_sc;
X	point->op		= sigma->op;
X		
X	draw_point(sigma, point);
X		
X	branch = new_branch();
X	branch->group 		= sigma;
X	branch->point 		= point;
X	branch->type		= REGULAR;
X	tappend_branch(branch, &cont_list);
X		
X	point = new_point();		
X	point->type 	= REGULAR;
X	point->para 	= para;
X	point->u 		= u;
X	point->tu 		= dvector(1, nu);
X	for (i=1; i<=nu; i++)	point->tu[i] = - tu[i];
X	point->s 		= initial_steplength();
X	point->sc 		= cond;
X	point->det		= det;
X	point->sym_det	= sym_det;
X	point->sym_sc	= sym_sc;
X	point->op		= sigma->op;
X		
X	branch = new_branch();
X	branch->group 		= sigma;
X	branch->point = point;
X	branch->type		= REGULAR;
X	tappend_branch(branch, &cont_list);
X	draw_picture();	
X}
X
Xvoid compute_first_solution()
X{	
X	REAL *u;
X	
X	u = dvector(1, nu);
X	if (look_for_first_solution(u)) handle_first_solution(u);
X	else {
X        sprintf(str, "initial guess was too bad!");
X        message(str);
X		free_dvector(u, 1, nu);
X	}
X}
X	
X/*---------------------------------------------------------------------------
X	compute next solution
X----------------------------------------------------------------------------*/
X
X#define CORR_MAX		0.7
X#define CORR_MIN		0.1
X	 
XREAL steplength_corrector(nc, snc, s)
X	REAL nc, snc, s;
X{
X	REAL temp;
X	
X	if (steplength_control) {
X		temp = sqrt(RHO * theta_max / sqrt(snc / nc));
X		if (temp > CORR_MAX) temp = CORR_MAX;
X		else if (temp < CORR_MIN) temp = CORR_MIN;
X		temp *= s;
X	}
X	else temp = steplength;
X	return temp;
X}
X
XBOOLEAN look_for_next_solution(p, u, s, nc, snc, curve, dist, iter)
X	Point *p;
X	REAL *u, *s, *nc, *snc, *curve, *dist;
X	int *iter;
X{
X	REAL temp;
X	int i, j, k, errno, return_code;
X	
X	for (k=1; k<=CONT_MAX; k++) {
X/*		temp = p->s * snorm(p->tu, scale, 1, nu); */
X		temp = p->s;
X		for (j=1; j<=REDUCTION_MAX; j++) {
X			for (i=1; i<=nu; i++) 	u_hat[i] = p->u[i] + temp * p->tu[i];
X			tangent(dg, u_hat, tu_hat, mu, nu, YES);
X			if (p->type != BIFURCATION && (cond / p->sc > COND_FACTOR_MAX || 
X					fabs(product(p->tu, tu_hat, 1, nu)) < tangent_min)) {
X				message("steplength reduction in look_for_next_solution");
X				temp *= REDUCTION_FACTOR;
X			}
X			else break;
X		}
X		if (j>REDUCTION_MAX) {
X			message("too many steplength reductions in look_for_next_solution");
X		}
X		copy_dvector(u, u_hat, 1, nu);
X		if (gauss_newton(g, g_jac, g_solve, u, scale, nc, snc, mu,
X						 nu, &errno, iter)) {
X			tangent(dg, u, tu_hat, mu, nu, YES);
X			if (fabs(product(p->tu, tu_hat, 1, nu)) > tangent_min) {
X				break;
X			}
X			else {
X				message("angle between the two tangents is too small");
X			}
X		}
X		p->s = steplength_corrector(*nc, *snc, p->s);
X	}	
X	
X	*curve = fabs(sproduct(tu_hat, p->tu, scale, 1, nu));
X	*curve /= snorm(tu_hat, scale, 1, nu);
X	*curve /= snorm(p->tu, scale, 1, nu);
X	*dist  = sdistance(u_hat, u, scale, 1, nu);
X	
X	return (k<=CONT_MAX);
X}
X
Xstatic void handle_next_solution(p, u, nc, snc, curve, dist, iter, type)
X	Point *p;
X	REAL *u, nc, snc, curve, dist;
X	int iter, type;
X{
X	Branch *branch;
X	Point *q;
X	REAL *tu, *det, *sym_det, *sym_sc;
X	REAL temp, s, theta, sc;
X	int i, para;
X	
X	tu 		= dvector(1, nu);
X	det  	= dvector(1, nu);
X	sym_det = dvector(2, sigma->s);
X	sym_sc  = dvector(2, sigma->s);
X	
X	tangent(dg, u, tu, mu, nu, YES);
X	sc = cond;	
X	para = pivot[nu];
X/*
X * 	choose tangent's orientation
X */
X	if (product(p->tu, tu, 1, nu) < 0)	turn_dvector(tu, 1, nu);
X	for (i=1; i<=nu; i++) det[i] = extended_det(a, d, pivot, mu, i, signum);
X	for (i=2; i<=sigma->s; i++) {
X		sigma->dg[i](u, a);
X		det_sc(&sym_det[i], &sym_sc[i], sigma->m[i]);
X	}
X 	if (type == BOUNDARY) 	s = 0;
X 	else if (!steplength_control) 	s = steplength;
X 	else {
X/*
X * 	steplength predictor
X */
X		if (iter != 0) {
X			theta = sqrt(snc / nc);
X			temp = sqrt(nc) / dist;
X			temp = sqrt(temp * RHO * theta_max / (theta * curve));
X		}
X		else {
X			temp = LINEAR_FACTOR;
X		}
X		s = MIN(temp, 1/sqrt(theta_min)) * p->s;
X/*
X * 	steplength bound by extrapolation in nearly linear case
X */
X		if (p->det != nil) {
X			if (det[para] * p->det[para] > 0 && sc > p->sc) {
X				temp = p->sc / sc;
X				temp = (u[para] - temp * p->u[para]) / (1 - temp);
X				temp = fabs(EXTRAPOLATION_FACTOR * (temp - u[para]) / tu[para]);
X				if (temp > 10 * eps && temp < s) {
X					message("steplength reduction wrt. sc");
X					s = temp;
X				}
X			}
X		}
X/*
X * 	steplength bound by extrapolation w. r. t. sym_sc
X */
X		if (p->sym_det != nil) {
X			for (i=2; i<=sigma->s; i++) {
X				if (sym_det[i] * p->sym_det[i] > 0 &&
X									sym_sc[i] > p->sym_sc[i]) {
X					temp = p->sym_sc[i] / sym_sc[i];
X					temp = (u[para] - temp * p->u[para]) / (1 - temp);
X					temp = (temp - u[para]) / tu[para];
X					temp = fabs(EXTRAPOLATION_FACTOR * temp);
X					if (temp > 10 * eps && temp < s) {
X						sprintf(str, "steplength reduction wrt. sym_sc[%d]", i);
X						message(str);
X						s = temp;
X					}
X				}
X			}
X		}
X	}
X	q = new_point();		
X	q->type 	= type;
X	q->para 	= para;
X	q->u 		= u;
X	q->tu 		= tu;
X	q->s 		= s;
X	q->sc 		= sc;
X	q->det		= det;
X	q->sym_det	= sym_det;
X	q->sym_sc	= sym_sc;
X	q->op		= p->op;	
X	p->next = q;
X}
X
Xvoid handle_symmetric_solution(p, q)
X	Point *p, *q;
X{
X	Point *q_sym, *p_sym;
X	Group *sigma_sym;
X	Op *op;
X	REAL *sym_det, *sym_sc;
X	int i;
X	
X	for (p_sym=p, q_sym=q, sigma_sym=sigma; p_sym->sym_next != p;) {
X		sigma_sym->transform(q_sym->u, y);
X		sigma_sym->transform(q_sym->tu, ty);
X		op = p_sym->op;		
X		sigma_sym = op->group(sigma_sym);
X		
X		sym_det = dvector(2, sigma->s);
X		sym_sc  = dvector(2, sigma->s);
X		for (i=2; i<=sigma->s; i++) {
X			sym_det[op->isotypic(i)] = q_sym->sym_det[i];
X			sym_sc[op->isotypic(i)]  = q_sym->sym_sc[i];
X		}
X		
X		p_sym = p_sym->sym_next;
X		q_sym = q_sym->sym_next = new_point();		
X		q_sym->type 	= q->type;
X		q_sym->para 	= p->para;
X		q_sym->u 		= dvector(1, nu);
X		q_sym->tu 		= dvector(1, nu);
X		q_sym->s 		= q->s;
X		q_sym->sc 		= q->sc;
X		q_sym->det		= q->det;
X		q_sym->sym_det	= sym_det;
X		q_sym->sym_sc	= sym_sc;
X		q_sym->op		= p_sym->op;		
X		op->proc(y, y_temp);	sigma_sym->inv_transform(y_temp, q_sym->u);
X		op->proc(ty, y_temp);	sigma_sym->inv_transform(y_temp, q_sym->tu);
X			
X		p_sym->next = q_sym;
X	}	
X	q_sym->sym_next = q;		
X}
X
Xstatic BOOLEAN detect_boundary(u, h)
X	REAL *u, *h;
X{
X	REAL tau;
X	
X	tau = u[nu];
X	if (tau < tau_min) {
X		*h = tau - tau_min;		/* h < 0, if tau < tau_min	*/
X		return TRUE;
X	}
X	else if (tau > tau_max) {
X		*h = tau - tau_max;		/* h > 0, if tau > tau_max	*/
X		return TRUE;
X	}
X	else return FALSE;
X}
X
Xstatic BOOLEAN look_for_boundary(pu, qu, h, nc, snc, iter)
X	REAL *pu, *qu, h, *nc, *snc;
X	int *iter;
X{		
X	REAL alpha;
X	int i, errno;
X	
X	alpha = 1 - h / (qu[nu] - pu[nu]);
X	for (i=1; i<=nu; i++) qu[i] = alpha * qu[i] + (1 - alpha) * pu[i];
X	return gauss_newton(g, g_jac, g_solve, qu, scale, nc, snc,
X												 mu, nu, &errno, iter);
X}
X
XBOOLEAN compute_next_solution(p)
X	Point *p;
X{	
X	REAL *u, s, nc, snc, curve, dist, h;
X	int k, return_code = FALSE, iter;
X	
X	u = dvector(1, nu);
X	for (k=1; k<=BOUND_MAX; k++) {
X		if (look_for_next_solution(p, u, &s, &nc, &snc, &curve, &dist, &iter)) {
X			if (detect_boundary(u, &h)) {
X				if (look_for_boundary(p->u, u, h, &nc, &snc, &iter)) {
X					handle_next_solution(p, u, nc, snc, 0.0, 0.0, iter, BOUNDARY);
X					return_code = TRUE;
X					break;
X				}
X				else p->s = RHO * p->s;
X			}
X			else {
X				handle_next_solution(p, u, nc, snc, curve, dist, iter, REGULAR);
X				return_code = TRUE;
X				break;
X			}
X		}
X		else break;
X	}
X	if (!return_code) {
X		printf("Continuation method failed!\n");
X		free_dvector(u, 1, nu);
X	}
X	return return_code;
X}
X
END_OF_FILE
if test 10425 -ne `wc -c <'continuation.c'`; then
    echo shar: \"'continuation.c'\" unpacked with wrong size!
fi
# end of 'continuation.c'
fi
if test -f 'continuation.h' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'continuation.h'\"
else
echo shar: Extracting \"'continuation.h'\" \(471 characters\)
sed "s/^X//" >'continuation.h' <<'END_OF_FILE'
X/*----------------------------------------------------------------------
X	continuation.h		continuation method and steplength-control
X-----------------------------------------------------------------------*/
X 
Xextern void init_continuation();
Xextern void quit_continuation();
X
Xextern BOOLEAN steplength_control;
Xextern double steplength, tangent_min;
X
Xextern void compute_first_solution();
Xextern BOOLEAN compute_next_solution();
Xextern void handle_symmetric_solution();
X
END_OF_FILE
if test 471 -ne `wc -c <'continuation.h'`; then
    echo shar: \"'continuation.h'\" unpacked with wrong size!
fi
# end of 'continuation.h'
fi
if test -f 'gauss_newton.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gauss_newton.c'\"
else
echo shar: Extracting \"'gauss_newton.c'\" \(7052 characters\)
sed "s/^X//" >'gauss_newton.c' <<'END_OF_FILE'
X#include <strings.h>
X#include <stdio.h>
X#include <math.h>
X
X#include "macros.h"
X#include "matalloc.h"
X#include "matutil.h"
X#include "mattrans.h"
X#include "gauss_newton.h"
X
X#define THETA_MAX 	.25
X#define GN_MAX 		10
X
X
X/*----------------------------------------------------------------------------
X	universal gauss newton method
X	
X	This version uses an external linear solver to compute the pseudo
X	inverse of the Jacobian. It's devided into two parts to allow a
X	check for an already computed solutions	after the first iteration.
X	
X	input
X		
X		m, n			: dimensions of the problem
X		f(x,b)			: evaluate the function at x --> b 
X		jac(x)  		: evaluate the Jacobian at x
X		solve(b, x)		: solver for x = A^+ b, A = Jacobian
X		x[1..n]			: starting point
X		user_scale		: scaling vector; no scaling, if user_scale == nil
X		
X	output
X	
X		x[1..n]			: solution computed by the Gauss-Newton-method
X		user_scale[1..n]: first scaling vector, if user_scale != nil
X		first_nc		: squared_norm(first Newton-correction)
X		first_snc		: squared_norm(first simplified Newton-correction)
X		iter			: number of iterations needed
X		errno			: error code (see gn_message)
X	
X	exported control-parameter
X	
X		gn_option	: JACOBIAN   --> use full Jacobian for each iterate
X					  BROYDEN    --> use Broyden-Updates of first Jacobian
X					  SIMPLIFIED --> use first Jacobian
X
X	return code = (errno == 0)
X	
X-----------------------------------------------------------------------------
X
X	before using the module call
X	
X		 init_gauss_newton(m, n);
X		 
X	where m, n are the maximal dimensions ever to be used	
X	
X-----------------------------------------------------------------------------
X
X	typical usage with splitting
X	
X	define f(), jac(), solve() and put starting point in x
X		
X	if (!gn_first(f, jac, solve, x, nc, snc, m, n, &errno)) {
X		printf(gn_message[errno]);
X	}
X	else if (detect_old_solution(1/nc)) {
X		printf("old solution found\n");
X	}
X	else if (!gn_second(f, jac, solve, x, m, n, &errno, &iter)) {
X		printf(gn_message[errno]);
X	}
X	else {
X		printf("solution found after %d iterations\n", iter);
X	}		
X	
X-----------------------------------------------------------------------------
X	
X	typical usage without splitting
X	
X	define f, jac, solve and put starting point in x
X		
X	if (!gauss_newton(f, jac, solve, x, nc, snc, m, n, &errno, &iter)) {
X		printf(gn_message[errno]);
X	}
X	else {
X		printf("solution found after %d iterations\n", iter);
X	}		
X	
X-----------------------------------------------------------------------------
X
X	after using the module call
X	
X		 quit_gauss_newton(m, n);
X		 
X	where m, n are the same as in init_gauss_newton(m, n)	
X	
X---------------------------------------------------------------------------*/
X
Xchar *gn_message[] = {
X	"success, solution in x",
X	"jac() failed in gn_first()",
X	"first solve() failed in gn_first()",
X	"second solve() failed in gn_first()",
X	"monotonicity test failed in gn_first()",
X	"jac() failed in gn_second()",
X	"first solve() failed in gn_second()",
X	"second solve() failed in gn_second()",
X	"monotonicity test failed in gn_second()",
X	"maximal number of steps exceeded"
X};
X
Xdouble eps, theta_max = THETA_MAX, scale_min; 
Xint gn_option;
X
Xstatic double *b, *dx, *dxb, nc, snc, temp, **dx_save, *nc_save, *scale;
Xstatic double conv;
Xstatic int gn_max = GN_MAX;
X
Xvoid init_gauss_newton(m, n)
X	int m, n;
X{
X	dxb = dvector(1, n);
X	b   = dvector(1, m);
X	nc_save = dvector(0, gn_max);
X	dx_save = dmatrix(0, gn_max, 1, n);	
X	dx = dx_save[0];
X	scale = dvector(1, n);
X}
X
Xvoid quit_gauss_newton(m, n)
X	int m, n;
X{
X	free_dvector(dxb, 1, n);
X	free_dvector(b, 1, m);
X	free_dvector(nc_save, 0, gn_max);
X	free_dmatrix(dx_save, 0, gn_max, 1, n);
X	free_dvector(scale, 1, n);
X}
X
Xstatic void init_scale(x, n)
X	double *x;
X	int n;
X{
X	int i;
X	for (i=1; i<=n; i++) 	scale[i] = MAX(fabs(x[i]), scale_min);
X}
X
Xstatic void rescale(x, n)
X	double *x;
X	int n;
X{
X	int i;
X	for (i=1; i<=n; i++) {
X	 	scale[i] = MAX((fabs(x[i]) + scale[i])/2, scale_min);
X	}
X}
X
XBOOLEAN gn_first(f, jac, solve, x, user_scale, first_nc, first_snc, m, n, errno)
X	void (*f)();
X	BOOLEAN (*jac)(), (*solve)();
X	double *x, *first_nc, *first_snc, *user_scale;
X	int m, n, *errno;
X{
X	int i;
X	
X/* 	theta_max = (gn_option == JACOBIAN) ? 0.5 : 0.25;	*/
X	*errno = 0;
X	
X	if (user_scale != nil) {
X		init_scale(x, n);
X		copy_dvector(user_scale, scale, 1, n);
X	}
X	else {
X		for (i=1; i<=n; i++) 	scale[i] = 1;
X	}
X	FOREVER {
X		if (!jac(x)) {
X			*errno = 1;
X			break;
X		}
X		f(x, b);
X		for (i=1; i<=m; i++) b[i] = -b[i];
X		if (!solve(b, dx)) {
X			*errno = 2;
X			break;
X		}
X		*first_nc = nc = squared_snorm(dx, scale, 1, n);
X		conv = max_snorm(dx, scale, 1, n);
X		for (i=1; i<=n; i++) x[i] += dx[i];
X		f(x, b);
X		for (i=1; i<=m; i++) b[i] = -b[i];
X		if (!solve(b, dxb)) {
X			*errno = 3;
X			 break;
X		}
X		*first_snc = snc = squared_snorm(dxb, scale, 1, n);
X		if (scale != nil)	rescale(x, n);
X		if (sqrt(snc/nc) >= theta_max && conv >= eps) {
X			*errno = 4;
X			break;
X		}
X		if (gn_option == BROYDEN) 	nc_save[0] = nc;
X		break;
X	}
X	return (*errno == 0);
X}
X
XBOOLEAN gn_second(f, jac, solve, x, user_scale, m, n, errno, iter)
X	void (*f)();
X	BOOLEAN (*jac)(), (*solve)();
X	double *x, *user_scale;
X	int m, n, *errno, *iter;
X{
X	double theta;
X	int i, j, k=0;
X	
X	*errno = 0;
X	
X	if (conv < eps * max_snorm(x, scale, 1, n)) 	*errno = 0;
X	else {
X		for (k=1; k<=gn_max; k++) {
X			if (gn_option == JACOBIAN) {
X				if (!jac(x)) {
X					*errno = 5;
X					break;
X				}
X			}
X			if (gn_option != BROYDEN) {
X				if (!solve(b, dx)) {
X					*errno = 6;
X					break;
X				}
X				nc = squared_snorm(dx, scale, 1, n);
X			}
X			else {
X				temp = product(dxb, dx_save[k-1], 1, n) / nc_save[k-1];
X				dx = dx_save[k];
X				for (i=1; i<=n; i++)	dx[i] = dxb[i] / (ONE - temp);
X				nc_save[k] = nc = squared_snorm(dx, scale, 1, n);
X			}
X			for (i=1; i<=n; i++) x[i] += dx[i];
X			if (max_snorm(dx, scale, 1, n) < eps * max_snorm(x, scale, 1, n)) {
X				*errno = 0;
X				break;
X			}
X			f(x, b);
X			for (i=1; i<=m; i++) b[i] = -b[i];
X			if (!solve(b, dxb)) {
X				*errno = 7;
X				 break;
X			}
X			if (gn_option == BROYDEN) {
X				for (i=0; i<=k-1; i++) {
X					temp = product(dx_save[i], dxb, 1, n) / nc_save[i];
X					for (j=1; j<=n; j++) dxb[j] += temp * dx_save[i+1][j];
X				}
X			}
X			snc = squared_snorm(dxb, scale, 1, n);
X			if (scale != nil)	rescale(x, n);
X			theta = sqrt(snc/nc);
X			if (theta >= theta_max) {
X				*errno = 8;
X				break;
X			}
X		}
X		if (k > gn_max) 	*errno = 9;
X	}
X	*iter = k;
X	dx = dx_save[0];		/* necessary, if changed using BROYDEN */
X	return (*errno == 0);
X}
X
X/*--------------------------------------------------------------------------
X	Gauss-Newton-method without splitting			
X--------------------------------------------------------------------------*/
X
XBOOLEAN gauss_newton(f, jac, solve, x, user_scale, first_nc, first_snc, m, n, errno, iter)
X	void (*f)();
X	BOOLEAN (*jac)(), (*solve)();
X	double *x, *first_nc, *first_snc;
X	int m, n, *errno, *iter;
X{
X	if (gn_first(f, jac, solve, x, user_scale, first_nc, first_snc, m, n, errno))
X		return gn_second(f, jac, solve, x, user_scale, m, n, errno, iter);
X	else return FALSE;
X}
X
X
X		
X
X
END_OF_FILE
if test 7052 -ne `wc -c <'gauss_newton.c'`; then
    echo shar: \"'gauss_newton.c'\" unpacked with wrong size!
fi
# end of 'gauss_newton.c'
fi
if test -f 'gauss_newton.h' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gauss_newton.h'\"
else
echo shar: Extracting \"'gauss_newton.h'\" \(834 characters\)
sed "s/^X//" >'gauss_newton.h' <<'END_OF_FILE'
X/*----------------------------------------------------------------------
X    gauss_newton.h      
X----------------------------------------------------------------------*/
X
X#define JACOBIAN        1
X#define BROYDEN         2
X#define SIMPLIFIED      3
X
X/*----------------------------------------------------------------------
X    import list     
X----------------------------------------------------------------------*/
X
X/*----------------------------------------------------------------------
X    export list     
X----------------------------------------------------------------------*/
X
Xextern double eps, theta_max, scale_min;
Xextern int gn_option;
Xextern char *gn_message[];
X
Xextern void init_gauss_newton();
Xextern void quit_gauss_newton();
X
Xextern BOOLEAN gauss_newton();
Xextern BOOLEAN gn_first();
Xextern BOOLEAN gn_second();
X
X
X
END_OF_FILE
if test 834 -ne `wc -c <'gauss_newton.h'`; then
    echo shar: \"'gauss_newton.h'\" unpacked with wrong size!
fi
# end of 'gauss_newton.h'
fi
if test -f 'group.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'group.c'\"
else
echo shar: Extracting \"'group.c'\" \(8807 characters\)
sed "s/^X//" >'group.c' <<'END_OF_FILE'
X/*------------------------------------------------------------------
X	group.c		group structure for symcon, version 2.0	
X-------------------------------------------------------------------*/
X
X#include <strings.h>
X#include <stdio.h>
X#include <math.h>
X#include <malloc.h>
X
X#include "macros.h"
X#include "matalloc.h"
X#include "matio.h"
X
X#include "general.h"
X#include "break.h"
X#include "no_break.h"
X
X#include "group.h"
X
X/*---------------------------------------------------------------------------
X	global data of current symmetry group `sigma`
X----------------------------------------------------------------------------*/
X
XGroup *group, *sigma, *plot_group;
Xdouble *par, *y_guess, tau_min, tau_max;
Xint mu, nu;
Xvoid (*g)(), (*dg)(), (*cg)(), (*transform)(), (*inv_transform)();
X
X/*---------------------------------------------------------------------------
X	data for numeric mode
X----------------------------------------------------------------------------*/
X
XBOOLEAN numeric_mode = FALSE;
X
Xstatic REAL *y, *e, *b, *bu;
X
X/*---------------------------------------------------------------------------
X	initialization
X----------------------------------------------------------------------------*/
X
Xvoid init_group_data()
X{
X	e = dvector(1,n);	const_dvector(e,0.0,1,n);
X	y = dvector(1,n);
X	b = dvector(1,n);
X	bu = dvector(1,n);
X}
X
Xvoid free_group_data()
X{
X	free_dvector(e,1,n);
X	free_dvector(y,1,n);
X	free_dvector(b,1,n);
X	free_dvector(bu,1,n);
X}
X
X/*---------------------------------------------------------------------------
X	set current symmetry group sigma := new_sigma
X----------------------------------------------------------------------------*/
X
Xvoid change_group(new_sigma)
X	Group *new_sigma;
X{
X	sigma = new_sigma;
X	mu 	= sigma->m[1];
X	nu 	= mu + 1;
X	g  	= sigma->g;
X	dg 	= sigma->dg[1];	
X	cg 	= sigma->cg[1];	
X	transform 		= sigma->transform;
X	inv_transform 	= sigma->inv_transform;
X}
X
X/*---------------------------------------------------------------------------
X	QR-Solver for current symmetry group sigma
X----------------------------------------------------------------------------*/
X
XBOOLEAN g_jac(x)
X	double *x;
X{
X	dg(x,a);
X	return qr_jac(x, mu, nu);
X}
X
XBOOLEAN g_solve(b, x)
X	double *b, *x;
X{
X	return qr_solve(b, x, mu, nu);
X}
X
X/*---------------------------------------------------------------------------
X	allocation routines
X----------------------------------------------------------------------------*/
X
Xvoid (** void_vector(nl, nh))()
X	int nl, nh;
X{
X	void (**f)();
X	f = (void (**)()) malloc((unsigned) (nh - nl + 1) * sizeof(void (*)()));
X	if (!f)
X		error("Allocation failure in void_vector()");
X	return f - nl;
X}
X
Xvoid (*** void_ptr_vector(nl, nh))()
X	int nl, nh;
X{
X	void (***f)();
X	f = (void (***)()) malloc((unsigned) (nh - nl + 1) * sizeof(void (**)()));
X	if (!f)
X		error("Allocation failure in void_vector()");
X	return f - nl;
X}
X
XGroup** group_vector(nl, nh)
X	int nl, nh;
X{
X	Group **group;
X	group = (Group **) malloc((unsigned) (nh - nl + 1) * sizeof(Group *));
X	if (!group)
X		error("Allocation failure in group_vector()");
X	return group - nl;
X}
X
Xstatic Group*** group_ptr_vector(nl, nh)
X	int nl, nh;
X{
X	Group ***group;
X	group = (Group ***) malloc((unsigned) (nh - nl + 1) * sizeof(Group **));
X	if (!group)
X		error("Allocation failure in group_ptr_vector()");
X	return group - nl;
X}
X
Xstatic int **int_ptr_vector(nl, nh)
X	int nl, nh;
X{
X	int  **m;
X	
X	m = (int **) malloc((unsigned) (nh - nl + 1) * sizeof(int *));
X	if (!m)		
X		error("Allocation failure 1 in imatrix()");
X	return m - nl;
X}
X
XOp *new_op()
X{
X	Op *op;
X	op = (Op *) malloc(sizeof(Op));
X	if (!op)	error("Allocation failure in new_op()");
X	op->proc 		= nil;
X	op->inv_proc 	= nil;
X	op->group 		= nil;
X	op->isotypic 	= nil;
X	op->next		= nil;
X	return op;
X}
X
XGroup *new_group(s, nsub, r)
X	int s, *nsub, r;
X{
X	int i;
X	Group *group;
X
X	group = (Group *) malloc(sizeof(Group));
X	if (! group) 	error("Allocation failure in new_group()");
X	
X	group->s		= s;
X	group->m		= ivector(1, s);
X	group->dg		= void_vector(1, s);
X	group->cg		= void_vector(1, s);
X	group->iso_transform		= void_vector(1, s);
X	group->inv_iso_transform	= void_vector(1, s);
X	group->op		= nil;
X	group->plot		= TRUE;
X	if (s>1) {
X		group->nsub			= nsub;
X		group->tangent		= void_ptr_vector(2, s);
X		group->subgroup 	= group_ptr_vector(2, s);	
X		group->symmetric	= int_ptr_vector(2, s);
X		for (i=2; i<=s; i++) {
X			group->subgroup[i] 	= group_vector(1, nsub[i]);
X			group->tangent[i] 	= void_vector(1, nsub[i]);
X			group->symmetric[i]	= ivector(1, nsub[i]);
X		}
X	}
X	else {
X		group->nsub		= nil;
X		group->tangent	= nil;
X		group->subgroup = nil;
X	}
X	group->r = r;
X	if (r>0) {
X		group->ntest		= ivector(1, r);
X		group->implemented	= TRUE;
X		group->supergroup 	= group_vector(1, r);
X		group->test			= void_vector(1, r);
X	}
X	else {
X		group->ntest		= nil;
X		group->supergroup 	= nil;
X		group->test			= nil;
X	}
X	return group;
X}
X
Xvoid append_op(sigma, proc, inv_proc, group, isotypic)
X	Group *sigma;
X	void (*proc)(), (*inv_proc)();
X	Group *(*group)();
X	int (*isotypic)();
X{
X	Op *op, *o;
X    op = new_op();
X    op->proc 		= proc;
X    op->inv_proc 	= inv_proc;
X    op->group		= group;
X    op->isotypic	= isotypic;
X    
X    if (sigma->op==nil) 	sigma->op = op;
X    else {
X    	for (o=sigma->op; o->next!=nil; o=o->next);
X    	o->next = op;
X    }
X}
X    
XBOOLEAN look_for_subgroup(sigma, sigma0)
X	Group *sigma, *sigma0;
X{
X	BOOLEAN found = FALSE;
X	int i, k;
X	
X	for (i=2; i<=sigma->s && !found; i++) {
X		for (k=1; k<=sigma->nsub[i] && !found; k++) {	
X			if (sigma0 == sigma->subgroup[i][k]) found = TRUE;
X		}
X	}	
X	return found;
X}
X					
Xstatic void fprint_group_vector(f, v, nl, nh)
X	FILE *f;
X	Group **v;
X	int nl, nh;
X{
X	int i;
X	
X	for (i=nl; i<=nh; i++) {
X		if (v[i] != nil) {
X			fprintf(f, "%s  ", v[i]->label);
X		}
X		else {
X			fprintf(f, "nil  ");
X		}
X	}
X}
X
Xvoid fprint_group(f, sigma)
X	FILE *f;
X	Group *sigma;
X{
X	int i, k;
X	Op *op;
X	Group *g;
X
X	if (sigma != nil) {	
X		fprintf(f, "group = %s, no = %d (", sigma->label, sigma->no);
X		fprint_color(f, sigma->no % 7 + 1);
X		fprintf(f, "), ");
X		fprintf(f, "m[1..%d] =", sigma->s);
X		fprintf_ivector(f, " %d", sigma->m, 1, sigma->s);
X		fprintf(f, ", ");
X		if (!sigma->implemented) fprintf(f, "not ");
X		fprintf(f, "completely implemented");
X		if (sigma->op->next != nil) {
X			for (op = sigma->op, k=1; op!=nil; op = op->next, k++) {
X				fprintf(f, "\n    op No %d:", k);
X				for (g=group; g!=nil; g=g->next) {
X					if (g!=op->group(g)) {
X						fprintf(f, "  %s --> %s", g->label, op->group(g)->label);
X					}
X				}
X				for (i=2; i<=sigma->s; i++) {
X					if (i!=op->isotypic(i)) {
X						fprintf(f, "  %d --> %d", i, op->isotypic(i));
X					}
X				}
X			}			
X		}
X		if (sigma->s > 1) {
X			for (i=2; i<=sigma->s; i++) {
X				fprintf(f, "\n    subgroup[%d][1..%d] = ", i, sigma->nsub[i]);
X				fprint_group_vector(f, sigma->subgroup[i], 1, sigma->nsub[i]);
X				fprintf(f, ", symmetric[%d][1..%d] = ", i, sigma->nsub[i]);
X				fprintf_ivector(f, "%d ", sigma->symmetric[i], 1, sigma->nsub[i]);
X			}
X			fprintf(f, "\n    nsub[2..%d] = ", sigma->s);
X			fprintf_ivector(f, "%d ", sigma->nsub, 2, sigma->s);
X		}
X		else fprintf(f, "\n    no subgroup");
X		if (sigma->r > 0) {
X			fprintf(f, "\n    supergroup[1..%d] = ", sigma->r);
X			fprint_group_vector(f, sigma->supergroup, 1, sigma->r);
X			fprintf(f, "\n    ntest[1..%d]  = ", sigma->r);
X			fprintf_ivector(f, "%d ", sigma->ntest, 1, sigma->r);
X		}
X		else fprintf(f, "\n    no supergroup");
X		fprintf(f, "\n\n");
X		fprint_group(f, sigma->next);
X	}
X}
X
X/*---------------------------------------------------------------------------
X	procedures for numeric mode
X----------------------------------------------------------------------------*/
X
Xvoid g_num(sigma, u, gu)
X	Group *sigma;
X	double *u, *gu;
X{
X	int i, mu = sigma->m[1];
X	
X	sigma->transform(u,y);
X	f(y,b);
X	sigma->inv_transform(b, bu);
X	for (i=1; i<=mu; i++) gu[i] = bu[i];
X}
X
Xvoid dg_num(sigma, u, a)
X	Group *sigma;
X	double *u, **a;
X{
X	int i, j, mu, nu;
X	
X	mu = sigma->m[1];
X	nu = mu + 1;
X	sigma->transform(u,y);
X	update_jacobian(y);
X	for (j=1; j<=nu; j++) {
X		e[j] = 1;
X		sigma->transform(e,y);
X		mat_vec_mult(dfy, y, b, m, n);
X		sigma->inv_transform(b, bu);
X		for (i=1; i<=mu; i++) a[i][j] = bu[i];
X		e[j] = 0;
X	}
X}
X
Xvoid dgi_num(sigma, i, u, a)
X	Group *sigma;
X	int i;
X	double *u, **a;
X{
X	int k, j, mi;
X	
X	mi = sigma->m[i];
X	sigma->transform(u,y);
X	update_jacobian(y);
X	for (j=1; j<=mi; j++) {
X		e[j] = 1;
X		sigma->iso_transform[i](e,y);
X		mat_vec_mult(dfy, y, b, m, m);
X		sigma->inv_iso_transform[i](b, bu);
X		for (k=1; k<=mi; k++) a[k][j] = bu[k];
X		e[j] = 0;
X	}
X}
X
Xvoid cgi_num(sigma, i, u, t, c)
X	Group *sigma;
X	int i;
X	double *u, *t, **c;
X{
X	num_diff(aiut, u, c, sigma->m[i], sigma->m[1]+1);	/* 	aiut = A_i(u)t	*/
X}
X
Xvoid cg_num(sigma, u, t, c)
X	Group *sigma;
X	double *u, *t, **c;
X{
X	sym_num_diff(autt, u, c, sigma->m[1]+1);	/* 	autt = A(u)^T*t	*/
X}
X
X
X
X
END_OF_FILE
if test 8807 -ne `wc -c <'group.c'`; then
    echo shar: \"'group.c'\" unpacked with wrong size!
fi
# end of 'group.c'
fi
if test -f 'group.h' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'group.h'\"
else
echo shar: Extracting \"'group.h'\" \(4329 characters\)
sed "s/^X//" >'group.h' <<'END_OF_FILE'
X/*-------------------------------------------------------------------------
X	group.h		group structure for symcon, version 2.0	
X-------------------------------------------------------------------------*/
X
X/*------------------------------------------------------------------------
X
Xstructure Group
X	
X	label				:	name of the group
X	s					:	number of isotypic components
X	r					:	number of break up supergroups
X	no					: 	number of the group (1,...,number of groups)
X	op					:	list of group operations
X	m[i] 				:	dimension of symmetry adapted subspace Y_i
X							(i=1,...,s)
X	ntest[k]			:	dimension of testspace for Sigma to Sigma_k break
X							up bifurcations (k=1,...,r)
X	subgroup[i][k]		:	k-th bifurcation subgroup, if A_i is singular
X							(i=1,...,s and k=1,...,nsub[i])
X	symmetric[i][k]		: 	= TRUE in case of symmetric bifurcation
X							(i=1,...,s and k=1,...,nsub[i])
X	supergroup[k]		:	k-th supergroup (k=1,...,r)
X	implemented			:	= TRUE, if group is completely implemented
X							(and not only conjugated to another subgroup)
X	next				:	next group in linear group list
X							
X							
Xvoid g(u, b)
X	double *u, *b;
X{
X	function restricted to fix point space 
X}
X
Xvoid transform(u, y)
X	double *u, *y;
X{
X	transformation from fix point space Y^Sigma to Y 
X}
X
Xvoid inv_transform(y, u)
X	double *y, *u;
X{
X	transformation from Y to fix point space Y^Sigma 
X}
X
Xvoid dg[i](u, a)
X	double *u, **a;
X{
X	Jacobian block A_i at u (i=1,...,s) 
X}
X			
Xvoid cg[i](u, t, c)
X	double *u, *t, **c;
X{
X	second derivatives needed for augmented systems at u (i=1,...,s) 
X}	
X
Xvoid tangent[i][k](ti, t)
X	double *ti, *t;
X{
X	tangent belonging to a solution ti of the augmented system	
X	for Sigma to subgroup[i][k] break down bifurcations			
X	i=2,...,s and k=1,...,nsub[i]								
X}
X
Xvoid test[k](u, t)
X	double *u, *t;
X{
X	test vector for Sigma to supergroup[k] break up bifurcations	
X	k=1,...,r and where t is an ntest[k]-vector				
X} 	
X	
X	
X--------------------------------------------------------------------------*/
X
Xstruct OP;
X
Xtypedef struct GROUP {
X	char *label;
X	int no;
X	int s, *m, *nsub, r, *ntest;
X	BOOLEAN **symmetric, implemented, plot;
X	void (*g)(), (*transform)(), (*inv_transform)();
X	void (**iso_transform)(), (**inv_iso_transform)(); 
X	void (**dg)(), (**cg)(), (***tangent)(), (**test)();
X	struct OP *op;
X	struct GROUP ***subgroup, **supergroup, *next;
X} Group;
X
X/*------------------------------------------------------------------------
X
Xstructure Op
X
Xvoid proc(u, v)
X	double *u, *v;
X{
X	u --> v		action on Y 
X}
X
Xvoid inv_proc(u, v)
X	double *u, *v;
X{
X	u --> v		inverse operation on Y 	 
X}
X
XGroup *group(sigma)
X	Group *sigma;
X{
X	sigma --> group(sigma)  	operation on subgroups
X}
X
Xint isotypic(i)
X	int i;
X{
X	i --> isotypic(i)			operation on isotypic components
X}
X	
X--------------------------------------------------------------------------*/
X
Xtypedef struct OP {
X	void (*proc)(), (*inv_proc)();
X	Group *(*group)();
X	int (*isotypic)();
X	struct OP *next;
X} Op;
X
Xextern void (** void_vector())();
Xextern Group **group_vector();
Xextern Group *new_group();
Xextern Op *new_op();
Xextern void append_op();
Xextern void fprint_group();
Xextern BOOLEAN look_for_subgroup();
X
X/*-------------------------------------------------------------------------
X	data and procedures for the current group `sigma`
X--------------------------------------------------------------------------*/
X
Xextern Group *sigma, *plot_group;
Xextern void (*g)(), (*dg)(), (*cg)(), (*transform)(), (*inv_transform)();
Xextern int mu, nu;
X
Xextern void change_group();
Xextern BOOLEAN g_jac();
Xextern BOOLEAN g_solve();
X
X/*-------------------------------------------------------------------------
X	data and procedures for the main group `group` (imported)
X	
X	These data and procedures must be defined differently for every 
X	particular problem, cf. frame. This will be done symbolically.		
X--------------------------------------------------------------------------*/
X
Xextern int m, n, nog, npar;
Xextern double *par, *y_guess, tau_min, tau_max;
Xextern Group *group;
X
Xextern void init_group(), setpar();
X
X/*-------------------------------------------------------------------------
X	data and procedures for numeric mode
X--------------------------------------------------------------------------*/
X
Xextern BOOLEAN numeric_mode;
X
Xextern void f(), df(), g_num(), dg_num(), dgi_num(), cg_num();
X
END_OF_FILE
if test 4329 -ne `wc -c <'group.h'`; then
    echo shar: \"'group.h'\" unpacked with wrong size!
fi
# end of 'group.h'
fi
echo shar: End of shell archive.
exit 0

