/* SIMPS.C */
/*-
setup data for call of <simpmain()>

J.A. Rupley, Tucson, Arizona
rupley!local@cs.arizona.edu
*/

#include "simpdefs.h"

static char    *Sfunc;

/*-
C function that calls an S function that returns the value of the
function being minimized, for the current parameter values
*/

int 
func(g)
	struct pstruct *g;
{
	double          Sparm[NPARM];
	int             j;
	char           *mode = "double";
	long            length = NPARM;
	char           *args[1];

	for (j = 0; j < nparm; j++) {
		Sparm[j] = g->parm[j];
	}

	args[0] = (char *) (Sparm);
	call_S(Sfunc, 1L, args, &mode, &length, 0, 1, args);
	g->val = *((double *) args[0]);
	return (OK);
}


/*-
C part of the S<->C interface;

function arguments are passed as pointers; there are slots 
for the address of the user-defined function (ff),
for the simplex, 
for control constants,
and for various results to be returned to the calling S function;

set externals for <simpmain()>:
struct pstruct p[nvert] = the starting simplex
double exit_test, quad_test
double ratio_exit_test
int prt_cycle, maxquad_skip
int iter, nparm, nvert, nfree, ndata
int verbose
int ndatval		unused 
*/

int
simpS(x_ff, x_p,
      x_nparm, x_nvert, x_ndata, x_ndatval, x_iter, x_verbose,
      x_prt_cycle, x_maxquad_skip,
      x_q_parmndx,
      x_exit_test, x_quad_test,
      x_qmat, x_pcent, x_std_dev, x_pcentval, x_rms_data, x_hessian)
	char          **x_ff;
	double         *x_p;
	long           *x_nparm, *x_nvert, *x_ndata, *x_ndatval;
	long           *x_iter, *x_verbose, *x_prt_cycle, *x_maxquad_skip;
	long           *x_q_parmndx;
	double         *x_exit_test, *x_quad_test;
	double         *x_qmat, *x_rms_data, *x_pcent, *x_pcentval, *x_std_dev;
	double         *x_hessian;
{
	int             i, j;
	int             ndatval;

	FILE           *fp_out;

	extern          simpmain();
	extern void     fsprint();

	fp_out = stderr;

	maxiter = 0;
	nfree = nvert - 1;

	Sfunc = *x_ff;

	nparm = *x_nparm;
	nvert = *x_nvert;
	ndata = *x_ndata;
	ndatval = *x_ndatval;
	iter = *x_iter;
	verbose = *x_verbose;
	prt_cycle = *x_prt_cycle;
	maxquad_skip = *x_maxquad_skip;
	quad_test = *x_quad_test;
	exit_test = *x_exit_test;

	if (exit_test > 0) {
		ratio_exit_test = TRUE;
	} else {
		/*
		 * negative value for exit_test ==> direct test of rms
		 * deviation of simplex vertices vs abs(exit_test); else test
		 * of rms deviation/mean value at vertices
		 */
		ratio_exit_test = FALSE;
		exit_test = -exit_test;
	}

	for (j = 0; j < nvert; j++) {
		for (i = 0; i < nparm; i++) {
			p[j].parm[i] = x_p[i * nvert + j];
		}
	}

	if (verbose >= VERY) {
		fprintf(fp_out, "ndatval = %d\n", ndatval);
		fprintf(fp_out, "ndata = %d\n", ndata);
		fprintf(fp_out, "nvert = %d\n", nvert);
		fprintf(fp_out, "nparm = %d\n", nparm);
		fprintf(fp_out, "maxquad_skip = %d\n", maxquad_skip);
		fprintf(fp_out, "exit_test = %20.14e\n", exit_test);
		fprintf(fp_out, "ratio_exit_test = %d\n", ratio_exit_test);
		fprintf(fp_out, "prt_cycle = %d\n", prt_cycle);
		fprintf(fp_out, "quad_test = %20.14e\n", quad_test);
		fprintf(fp_out, "iter = %d\n", iter);
		fprintf(fp_out, "verbose = %d\n", verbose);
		fsprint(fp_out, "\n\nsimplex:\n");
	}
	/*
	 * calculate starting function values for simplex
	 */
	for (j = 0; j < nvert; j++) {
		func(&p[j]);
	}
	/*
	 * minimize
	 */
	simpmain(fp_out);
	/*
	 * set up arrays and vectors for return of data
	 */
	*x_pcentval = pcent.val;
	*x_rms_data = rms_data;
	*x_iter = iter;

	for (j = 0; j < nvert; j++) {
		for (i = 0; i < nparm; i++) {
			x_p[i * nvert + j] = p[j].parm[i];
		}
	}

	for (j = 0; j < nfree; j++) {
		for (i = 0; i < nfree; i++) {
			x_qmat[j * nfree + i] = qmat[j][i];
		}
	}

	for (j = 0; j < nfree; j++) {
		for (i = 0; i < nfree; i++) {
			x_hessian[j * nfree + i] = hessian[j][i];
		}
	}

	for (j = 0; j < nfree; j++) {
		x_q_parmndx[j] = (long) q.parmndx[j];
		x_std_dev[j] = q.std_dev[j];
	}

	for (j = 0; j < nparm; j++) {
		x_pcent[j] = pcent.parm[j];
	}


	return (OK);
}				/* END OF SIMPCONTROL */