/****************************************************************************/
/* ALBERT:   an Adaptive multi Level finite element toolbox using           */
/*           Bisectioning refinement and Error control by Residual          */
/*           Techniques                                                     */
/*                                                                          */
/* file:                                                                    */
/*                                                                          */
/*                                                                          */
/* description:                                                             */
/*                                                                          */
/*                                                                          */
/* history:                                                                 */
/*                                                                          */
/*                                                                          */
/****************************************************************************/
/*                                                                          */
/*        authors: Alfred Schmidt and Kunibert G. Siebert                   */
/*                 Institut f"ur Angewandte Mathematik                      */
/*                 Albert-Ludwigs-Universit"at Freiburg                     */
/*                 Hermann-Herder-Str. 10                                   */
/*                 79104 Freiburg                                           */
/*                 Germany                                                  */
/*                                                                          */
/*        email:   alfred,kunibert@mathematik.uni-freiburg.de               */
/*                                                                          */
/*     (c) by A. Schmidt and K.G. Siebert (1996-1999)                       */
/*                                                                          */
/****************************************************************************/
#include <alberta.h>
#if (defined(ALBERTA_VER) && (ALBERTA_VER==2))
//# include <alberta_inlines.h>
//#include <alberta_util_inlines.h>
//# include "alberta1_wrapper.h"
// call functions in error.c 
REAL L2_err_c(REAL (*u)(const REAL_D), const DOF_REAL_VEC *uh,
	      const QUAD *quad, REAL *(*rw_err_el)(EL *),
	      REAL *max_l2_err2, REAL c)
{
  FUNCNAME("L2_err_c");
  bool mv_offset = false;//Schnotter
  return L2_err(u,uh,quad,1,mv_offset, rw_err_el,max_l2_err2);
}
//REAL L2_err(REAL (*)(const REAL*), const DOF_REAL_VEC*, const QUAD*, _Bool, _Bool, REAL* (*)(EL*), REAL*)
/*
REAL H1_err_c(const REAL *(*grd_u)(const REAL_D), const DOF_REAL_VEC *uh, 
	      const QUAD *quad, REAL *(*rw_err_el)(EL *),
	      REAL *max_h1_err2, REAL c)
{
  FUNCNAME("H1_err_c");
  bool mv_offset = false;//Schnotter
  return H1_err(grd_u,uh,quad,mv_offset, rw_err_el,max_h1_err2);
}
*/
REAL L2_err_c_d(const REAL *(*u)(const REAL_D, REAL_D), 
		const DOF_REAL_D_VEC *uh,
		const QUAD *quad, REAL *(*rw_err_el)(EL *),
		REAL *max_l2_err2, REAL c)
{
  FUNCNAME("L2_err_c_d");
  bool mv_offset = false;//Schnotter
  return L2_err_d(u,uh,quad,1, mv_offset, rw_err_el,max_l2_err2);
}
/*
REAL H1_err_c_d(const REAL_D *(*grd_u)(const REAL_D, REAL_DD),
	       const DOF_REAL_D_VEC *uh, const QUAD *quad,
	       REAL *(*rw_err_el)(EL *), REAL *max_h1_err2, REAL c)
{
  FUNCNAME("H1_err_c_d");
  return H1_err_d(grd_u,uh,quad,rw_err_el,max_h1_err2);
} 
*/ 
#else

static const QUAD_FAST  *quad_fast = nil;

/****************************************************************************/
/*  discrete solution                                                       */
/****************************************************************************/
static const DOF_REAL_VEC    *err_uh;
static const DOF_REAL_D_VEC  *err_uh_d;
static const BAS_FCTS  *bas_fcts;

/****************************************************************************/
/*  data on a single element                                                */
/****************************************************************************/
static const EL_INFO *elinfo;
static const REAL    *(*get_real_vec_el)(const EL *, const DOF_REAL_VEC *,
					   REAL *);
static const REAL_D  *(*get_real_d_vec_el)(const EL *, const DOF_REAL_D_VEC *,
					   REAL_D *);
static REAL          *(*rw_error)(EL *el);

static PARAMETRIC    *el_parametric = nil;

/****************************************************************************/
/*  functions handed over to the error routines evaluated in local          */
/*  coordinates                                                             */
/****************************************************************************/

static REAL   (*p_u)(const REAL_D);

static REAL err_u(const REAL lambda[N_LAMBDA])
{
  REAL_D  x[1];

  if (el_parametric) {
    el_parametric->coord_to_world(elinfo, nil, 1,
				  (const REAL (*)[N_LAMBDA])lambda, x);
  }
  else {
    coord_to_world(elinfo, lambda, *x);
  }
  return((*p_u)(*x));
}

static const REAL   *(*p_u_d)(const REAL_D, REAL_D);

static const REAL *err_u_d(const REAL lambda[N_LAMBDA])
{
  REAL_D  x[1];

  if (el_parametric) {
    el_parametric->coord_to_world(elinfo, nil, 1,
				  (const REAL (*)[N_LAMBDA])lambda, x);
  }
  else {
    coord_to_world(elinfo, lambda, x[0]);
  }
  return((*p_u_d)(x[0], nil));
}

static const REAL  *(*p_grd_u)(const REAL_D);

static const REAL *err_grd_u(const REAL lambda[N_LAMBDA])
{
  REAL_D  x[1];

  if (el_parametric) {
    el_parametric->coord_to_world(elinfo, nil, 1,
				  (const REAL (*)[N_LAMBDA])lambda, x);
  }
  else {
    coord_to_world(elinfo, lambda, *x);
  }
  
  return((*p_grd_u)(*x));
}

static const REAL_D  *(*p_grd_u_d)(const REAL_D, REAL_D [DIM_OF_WORLD]);

static const REAL_D *err_grd_u_d(const REAL lambda[N_LAMBDA])
{
  REAL_D  x[1];

  if (el_parametric) {
    el_parametric->coord_to_world(elinfo, nil, 1,
				  (const REAL (*)[N_LAMBDA])lambda, x);
  }
  else {
    coord_to_world(elinfo, lambda, *x);
  }
  
  return((*p_grd_u_d)(*x, nil));
}

/****************************************************************************/
/*  and now, the error functions :-)))                                      */
/****************************************************************************/
static REAL max_err = 0.0;

/****************************************************************************/
/*  additional scale for errors                                             */
/****************************************************************************/

static REAL c2 = 1.0;

/****************************************************************************/
/*  L2 error on the mesh                                                    */
/****************************************************************************/
static REAL l2_err_2, l2_norm2;

static void l2_err_fct(const EL_INFO *el_info)
{
  int          i;
  REAL         err, det, l2_err_el, norm_el, exact;
  const REAL   *uh_el, *u_vec, *uh_vec;
  PARAMETRIC   *parametric = el_info->mesh->parametric;

  elinfo = el_info;
  if (parametric && parametric->init_element(el_info, parametric)) {
    el_parametric = parametric;

	MSG("el_parametric set to el_info->mesh->parametric\n");
  }
  else {
    el_parametric = nil;
  }

  u_vec = f_at_qp(quad_fast->quad, err_u, nil);

  uh_el = (*get_real_vec_el)(el_info->el, err_uh, nil);
  uh_vec = uh_at_qp(quad_fast, uh_el, nil);

  if (el_parametric) {
    el_parametric->det(el_info, nil, 1, nil, &det);
  }
  else {
    det = el_det(el_info);
  }

  for (l2_err_el = i = 0; i < quad_fast->n_points; i++)
  {
    err = u_vec[i] - uh_vec[i];
    l2_err_el += quad_fast->w[i]*SQR(err);
  }

  exact = det*l2_err_el;
  
  exact *= c2;

  l2_err_2 += exact;
  max_err = MAX(max_err, exact);

  if (rw_error) *(*rw_error)(el_info->el) += exact;

  return;
}


REAL L2_err_c(REAL (*u)(const REAL_D), const DOF_REAL_VEC *uh,
	      const QUAD *quad, REAL *(*rw_err_el)(EL *),
	      REAL *max_l2_err2, REAL c)
{
  FUNCNAME("L2_err_c");
  const FE_SPACE *fe_space;
  
  c2 = c*c;

  if (!(p_u = u))
  {
    ERROR("no function u specified; doing nothing\n");
    return(0.0);
  }
  if (!(err_uh = uh)  ||  !(fe_space = uh->fe_space))
  {
    ERROR("no discrete function or no fe_space for it; doing nothing\n");
    return(0.0);
  }
  if (!uh->vec)
  {
    ERROR("no coefficient vector at discrete solution ; doing nothing\n");
    return(0.0);
  }
  if (!(bas_fcts = fe_space->bas_fcts))
  {
    ERROR("no basis functions at discrete solution ; doing nothing\n");
    return(0.0);
  }
  if (!quad)
    quad = get_quadrature(DIM, 2*fe_space->bas_fcts->degree -2);
  quad_fast = get_quad_fast(bas_fcts, quad, INIT_PHI);

  get_real_vec_el = fe_space->bas_fcts->get_real_vec;

  rw_error = rw_err_el;

  max_err = l2_err_2 = l2_norm2 = 0.0;
  mesh_traverse(fe_space->mesh, -1, FILL_COORDS|CALL_LEAF_EL, l2_err_fct);

  if (max_l2_err2)  *max_l2_err2 = max_err;

  return(sqrt(l2_err_2));
}

/****************************************************************************/
/*  H1 error on the mesh                                                    */
/****************************************************************************/

static REAL h1_err_2, h1_norm2;

static void h1_err_fct(const EL_INFO *el_info)
{
  int          i, j;
  REAL         err, err_2, h1_err_el, norm_el, norm2, det, exact;
  REAL_D       Lambda[1][N_LAMBDA];
  const REAL   *uh_el;
  const REAL_D *grdu_vec, *grduh_vec;
  PARAMETRIC  *parametric = el_info->mesh->parametric;

  elinfo = el_info;
  if (parametric && parametric->init_element(el_info, parametric)) {
    el_parametric = parametric;
  }
  else {
    el_parametric = nil;
  }

  grdu_vec = grd_f_at_qp(quad_fast->quad, err_grd_u, nil);

  uh_el = (*get_real_vec_el)(el_info->el, err_uh, nil);

  if (el_parametric) {
    el_parametric->grd_lambda(el_info, nil, 1, nil, Lambda, &det);
  }
  else {
    det = el_grd_lambda(el_info, *Lambda);
  }

  grduh_vec = grd_uh_at_qp(quad_fast, (const REAL_D *) *Lambda, uh_el, nil);

  for (h1_err_el = i = 0; i < quad_fast->n_points; i++)
  {
    for (err_2 = j = 0; j < DIM_OF_WORLD; j++) 
    {
      err = grdu_vec[i][j] - grduh_vec[i][j];
      err_2 += SQR(err);
    }
    h1_err_el += quad_fast->w[i]*err_2;
  }

  exact = det*h1_err_el;

  exact *= c2;

  h1_err_2 += exact;
  max_err = MAX(max_err, exact);

  if (rw_error) *(*rw_error)(el_info->el) += exact;

  return;
}

REAL H1_err_c(const REAL *(*grd_u)(const REAL_D), const DOF_REAL_VEC *uh, 
	      const QUAD *quad, REAL *(*rw_err_el)(EL *),
	      REAL *max_h1_err2, REAL c)
{
  FUNCNAME("H1_err_c");
  const FE_SPACE *fe_space;
  
  c2 = c*c;
  
  if (!(p_grd_u = grd_u))
  {
    ERROR("no gradient function grd_u specified; doing nothing\n");
    return(0.0);
  }
  if (!(err_uh = uh)  ||  !(fe_space = uh->fe_space))
  {
    ERROR("no discrete function or no fe_space for it; doing nothing\n");
    return(0.0);
  }
  if (!uh->vec)
  {
    ERROR("no coefficient vector at discrete solution ; doing nothing\n");
    return(0.0);
  }
  if (!(bas_fcts = fe_space->bas_fcts))
  {
    ERROR("no basis functions at discrete solution ; doing nothing\n");
    return(0.0);
  }
  if (!quad)
    quad = get_quadrature(DIM, 2*fe_space->bas_fcts->degree-2);
  quad_fast = get_quad_fast(bas_fcts, quad, INIT_GRD_PHI);

  get_real_vec_el = fe_space->bas_fcts->get_real_vec;

  rw_error = rw_err_el;

/*
  if (!rw_error) 
    MSG("rw_err_el nil pointer; can not write errors to elements\n");
*/

  max_err = h1_err_2 = h1_norm2 = 0.0;
  mesh_traverse(fe_space->mesh, -1, FILL_COORDS|CALL_LEAF_EL, h1_err_fct);

  if (max_h1_err2)  *max_h1_err2 = max_err;

  return(sqrt(h1_err_2));
}

/****************************************************************************/
/*  and now, the error functions for _d :-)))                               */
/****************************************************************************/

/****************************************************************************/
/*  L2_d error on the mesh                                                  */
/****************************************************************************/

static void l2_err_fct_d(const EL_INFO *el_info)
{
  int            i, k;
  REAL           err = 0, det, l2_err_el, norm_el, exact;
  const REAL_D   *uh_el, *u_vec, *uh_vec;
  PARAMETRIC  *parametric = el_info->mesh->parametric;

  elinfo = el_info;
  if (parametric && parametric->init_element(el_info, parametric)) {
    el_parametric = parametric;
  }
  else {
    el_parametric = nil;
  }

  u_vec = f_d_at_qp(quad_fast->quad, err_u_d, nil);

  uh_el = (*get_real_d_vec_el)(el_info->el, err_uh_d, nil);
  uh_vec = uh_d_at_qp(quad_fast, uh_el, nil);

  if (el_parametric) {
    el_parametric->det(el_info, nil, 1, nil, &det);
  }
  else {
    det = el_det(el_info);
  }

  for (l2_err_el = i = 0; i < quad_fast->n_points; i++)
  {
    for (err = k = 0; k < DIM_OF_WORLD; k++)
      err += SQR(u_vec[i][k] - uh_vec[i][k]);

    l2_err_el += quad_fast->w[i]*err;
  }

  exact = det*l2_err_el;

  exact *= c2;

  l2_err_2 += exact;
  max_err = MAX(max_err, exact);

  if (rw_error) *(*rw_error)(el_info->el) += exact;

  return;
}

REAL L2_err_c_d(const REAL *(*u)(const REAL_D, REAL_D), 
		const DOF_REAL_D_VEC *uh,
		const QUAD *quad, REAL *(*rw_err_el)(EL *),
		REAL *max_l2_err2, REAL c)
{
  FUNCNAME("L2_err_c_d");
  const FE_SPACE *fe;
  
  c2 = c*c;

  if (!(p_u_d = u))
  {
    ERROR("no function u specified; doing nothing\n");
    return(0.0);
  }
  if (!(err_uh_d = uh) )
  {
    ERROR("no discrete function, doing nothing\n");
    return(0.0);
  }
  if (!(fe = uh->fe_space))
  {
    ERROR(" no fe_space for it; doing nothing\n");
    return(0.0);
  }
  if (!uh->vec)
  {
    ERROR("no coefficient vector at discrete solution ; doing nothing\n");
    return(0.0);
  }
  if (!(bas_fcts = fe->bas_fcts))
  {
    ERROR("no basis functions at discrete solution ; doing nothing\n");
    return(0.0);
  }
  if (!quad)
    quad = get_quadrature(DIM, 2*bas_fcts->degree -2);
  quad_fast = get_quad_fast(bas_fcts, quad, INIT_PHI);

  get_real_d_vec_el = bas_fcts->get_real_d_vec;

  rw_error = rw_err_el;

  max_err = l2_err_2 = l2_norm2 = 0.0;
  mesh_traverse(fe->mesh, -1, FILL_COORDS|CALL_LEAF_EL, l2_err_fct_d);

  if (max_l2_err2) *max_l2_err2 = max_err;

  return(sqrt(l2_err_2));
}

/****************************************************************************/
/*  H1_d error on the mesh                                                  */
/****************************************************************************/

static void h1_err_fct_d(const EL_INFO *el_info)
{
  int            i, j, k;
  REAL           err, err_2, h1_err_el, norm_el, norm2, det, exact;
  REAL_D         Lambda[1][N_LAMBDA];
  const REAL_D   *uh_el;
  const REAL_DD  *grdu_vec, *grduh_vec;
  PARAMETRIC  *parametric = el_info->mesh->parametric;

  elinfo = el_info;
  if (parametric && parametric->init_element(el_info, parametric)) {
    el_parametric = parametric;
  }
  else {
    el_parametric = nil;
  }

  grdu_vec = grd_f_d_at_qp(quad_fast->quad, err_grd_u_d, nil);

  uh_el = (*get_real_d_vec_el)(el_info->el, err_uh_d, nil);

  if (el_parametric) {
    el_parametric->grd_lambda(el_info, nil, 1, nil, Lambda, &det);
  }
  else {
    det = el_grd_lambda(el_info, *Lambda);
  }

  grduh_vec = grd_uh_d_at_qp(quad_fast, /*(void *) unnuetz und schaedlich*/ *Lambda, uh_el, nil);

  for (h1_err_el = i = 0; i < quad_fast->n_points; i++)
  {
    for (err_2 = k = 0; k < DIM_OF_WORLD; k++)
      for (j = 0; j < DIM_OF_WORLD; j++) 
      {
	err = grdu_vec[i][k][j] - grduh_vec[i][k][j];
	err_2 += SQR(err);
      }

    h1_err_el += quad_fast->w[i]*err_2;
  }

  exact = det*h1_err_el;

  exact *= c2;
  
  h1_err_2 += exact;
  max_err = MAX(max_err, exact);

  if (rw_error) *(*rw_error)(el_info->el) += exact;

  return;
}

REAL H1_err_c_d(const REAL_D *(*grd_u)(const REAL_D, REAL_DD),
	       const DOF_REAL_D_VEC *uh, const QUAD *quad,
	       REAL *(*rw_err_el)(EL *), REAL *max_h1_err2, REAL c)
{
  FUNCNAME("H1_err_c_d");
  const FE_SPACE *fe;
  
  c2 = c*c;
  
  if (!(p_grd_u_d = grd_u))
  {
    ERROR("no gradient function grd_u specified; doing nothing\n");
    return(0.0);
  }
  if (!(err_uh_d = uh)  ||  !(fe = uh->fe_space))
  {
    ERROR("no discrete function or no admin for it; doing nothing\n");
    return(0.0);
  }
  if (!uh->vec)
  {
    ERROR("no coefficient vector at discrete solution ; doing nothing\n");
    return(0.0);
  }
  if (!(bas_fcts = fe->bas_fcts))
  {
    ERROR("no basis functions at discrete solution ; doing nothing\n");
    return(0.0);
  }
  if (!quad)
    quad = get_quadrature(DIM, 2*bas_fcts->degree-2);
  quad_fast = get_quad_fast(bas_fcts, quad, INIT_GRD_PHI);

  get_real_d_vec_el = bas_fcts->get_real_d_vec;

  rw_error = rw_err_el;
  
  max_err = h1_err_2 = h1_norm2 = 0.0;
  mesh_traverse(fe->mesh, -1, FILL_COORDS|CALL_LEAF_EL, h1_err_fct_d);

  if (max_h1_err2) *max_h1_err2 = max_err;

  return(sqrt(h1_err_2));
}
#endif
