#include <stdio.h>
#include <string.h>
#include <math.h>

#include <R.h>

static	int jacsng = -1;
static  int jacupd = -1;
static  double jacond = 0.0;

void F77_SUB(nwstrot0)(const char *s, int *slen)
{   
    /*
     * called by Fortran subroutine to output <slen> chars from fortran char*(*)
     */
	int k, ns;

	ns = *slen;
	for(k=0; k < ns; k++)
		Rprintf("%c", s[k]);
	Rprintf("\n");
}

void F77_SUB(nwsnot)(int *jtype, int *ierr, double *rcond)
{
	/*
	 * save for later printing
	 */

	jacsng = *ierr;
	jacupd = *jtype;
	jacond = *rcond;
}

static char jcbuf[100];

static void  jackar()
{
	char jmethod;

	jcbuf[0] = 0;

	if( jacupd < 0) return;

	jmethod = (jacupd == 0) ? 'N' : 'B';

    /*
     * output inverse condition if jacobian is not singular
     * else output correction mu with an indication
     * of ill conditioning or singularity
     */

	if( jacsng == 0 )
		sprintf(jcbuf, " %c(%7.1e)", jmethod, jacond);
	else if( jacsng == 1 )
		sprintf(jcbuf, "%ci(%7.1e)", jmethod, jacond);
    else
		sprintf(jcbuf, "%cs", jmethod);

	/*
	 * avoid output of redundant information on next time called
	 */

	jacupd = -1;

}

void F77_SUB(nwjerr)(int *iter)
{
    jackar();
    Rprintf( "  %4d %11s\n", *iter, jcbuf);
}

static void enumout(double x)
{
    Rprintf(" %13.*e", fabs(x) >= 1E100? 5 : 6, x);
}

void F77_SUB(nwlsot)(int *iter, int *lstep, double *oarg)
{
	double v;

	if( *lstep <= 0 ) {
		if( *lstep == -1)
			Rprintf("  %4s %11s %8s  %13s %13s %13s\n",
						"Iter","Jac","Lambda","Ftarg","Fnorm","Largest |f|");

		Rprintf("  %4d%36s %13.6e %13.6e\n" , *iter, "", oarg[0],oarg[1]);
	}
	else {
		jackar();
		v = *oarg;
		Rprintf( "  %4d %11s", *iter, jcbuf);
		if( fabs(v) > 0.0001 )
			Rprintf( " %8.4f ",v);
		else
			Rprintf( " %8.1e ",v);

        enumout(oarg[1]);
        enumout(oarg[2]);
        enumout(oarg[3]);
        Rprintf("\n");
	}
}

void F77_SUB(nwdgot)(int *iter, int *lstep, double *oarg)
{
	char step;

	/*
 	 *  C gradient (cauchy) step
 	 *  N newton step
 	 *  P partial newton step
 	 *  W convex combination of P and C
     */

	if( *lstep <= 0 ) {
		if( *lstep == -1)
			Rprintf("  %4s %11s   %8s %8s %8s %8s %8s %13s %13s\n",
 				       "Iter","Jac","Lambda","Gamma", "Eta", "Dlt0", "Dltn", "Fnorm","Largest |f|");

            Rprintf("  %4d%59s" , *iter, "");
            enumout(oarg[0]);
            enumout(oarg[1]); 
            Rprintf("\n");
	}
	else {
		jackar();
		step = "CNPW"[*lstep-1];
		Rprintf( "  %4d %11s %c ", *iter, jcbuf, step);

		if( *lstep == 4 )
			Rprintf( "%8.4f", oarg[0]);
		else
			Rprintf( "%8s", "");

		Rprintf( " %8.4f %8.4f %8.4f %8.4f",
                    oarg[3], oarg[4],oarg[1],oarg[2]);
        enumout(oarg[5]);
        enumout(oarg[6]);
        Rprintf("\n");
 	}
}

void F77_SUB(nwpwot)(int *iter, int *lstep, double *oarg)
{
	char step;

	/*
	 *  C gradient (cauchy) step
	 *  N newton step
	 *  W convex combination of P and C
	 */

	if( *lstep <= 0 ) {
		if( *lstep == -1)
			Rprintf("  %4s %11s   %8s %8s %8s %13s %13s\n",
						"Iter","Jac","Lambda", "Dlt0", "Dltn", "Fnorm","Largest |f|");

            Rprintf("  %4d%41s", *iter, "");
            enumout(oarg[0]);
            enumout(oarg[1]);
            Rprintf("\n");
	}
	else {
		jackar();
		step = "CNW"[*lstep-1];
		Rprintf( "  %4d %11s %c ", *iter, jcbuf, step);

		if( *lstep == 3 )
			Rprintf( "%8.4f",oarg[0]);
		else
			Rprintf( "%8s", "");

        Rprintf( " %8.4f %8.4f", oarg[1],oarg[2]);
        enumout(oarg[3]);
        enumout(oarg[4]);
        Rprintf("\n");
 	}
}